From 550a80bf33e9af5691354ecfc7ffbe3e9fea1c60 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 20 Sep 2022 10:51:52 +0200 Subject: [PATCH 01/49] Change kcp from explicit files to a submodule --- .gitmodules | 3 + quantum_espresso/kcp | 1 + quantum_espresso/kcp/.gitignore | 16 - quantum_espresso/kcp/AFC90/Examples/0D.in | 18 - quantum_espresso/kcp/AFC90/Examples/1D.in | 18 - quantum_espresso/kcp/AFC90/Examples/1D2.in | 18 - quantum_espresso/kcp/AFC90/Examples/2D.in | 18 - quantum_espresso/kcp/AFC90/Examples/2D2.in | 18 - quantum_espresso/kcp/AFC90/Examples/2D3.in | 18 - quantum_espresso/kcp/AFC90/Examples/bcc.in | 18 - quantum_espresso/kcp/AFC90/Examples/cubic.in | 18 - quantum_espresso/kcp/AFC90/Examples/fcc.in | 18 - quantum_espresso/kcp/AFC90/Examples/linear.in | 18 - .../kcp/AFC90/Examples/squared.in | 18 - quantum_espresso/kcp/AFC90/Examples/test.in | 18 - .../kcp/AFC90/Examples/trigonal.in | 18 - quantum_espresso/kcp/AFC90/GPL/gpl-3.0.txt | 674 - quantum_espresso/kcp/AFC90/Makefile | 28 - quantum_espresso/kcp/AFC90/README.txt | 8 - .../kcp/AFC90/UserGuide/UserGuide.pdf | Bin 63525 -> 0 bytes quantum_espresso/kcp/AFC90/make.rules | 10 - quantum_espresso/kcp/AFC90/src/Makefile | 57 - quantum_espresso/kcp/AFC90/src/afcc.f90 | 250 - quantum_espresso/kcp/AFC90/src/besseli.f90 | 36 - quantum_espresso/kcp/AFC90/src/besselk.f90 | 42 - quantum_espresso/kcp/AFC90/src/cylharm.f90 | 38 - quantum_espresso/kcp/AFC90/src/cylharm0.f90 | 35 - .../kcp/AFC90/src/cylharmasympt.f90 | 49 - .../kcp/AFC90/src/cylharmlogslope.f90 | 38 - quantum_espresso/kcp/AFC90/src/cylharmrk.f90 | 85 - .../kcp/AFC90/src/cylharmseries.f90 | 55 - .../kcp/AFC90/src/cylharmslope.f90 | 58 - quantum_espresso/kcp/AFC90/src/ei.f90 | 39 - quantum_espresso/kcp/AFC90/src/eimlog.f90 | 47 - quantum_espresso/kcp/AFC90/src/fft1d.f90 | 49 - quantum_espresso/kcp/AFC90/src/fft2d.f90 | 50 - quantum_espresso/kcp/AFC90/src/fft3d.f90 | 64 - quantum_espresso/kcp/AFC90/src/fftw3.f | 72 - quantum_espresso/kcp/AFC90/src/gaussian.f90 | 33 - quantum_espresso/kcp/AFC90/src/gaussiank.f90 | 182 - quantum_espresso/kcp/AFC90/src/gaussianl.f90 | 50 - quantum_espresso/kcp/AFC90/src/interp.f90 | 143 - quantum_espresso/kcp/AFC90/src/main.f90 | 222 - quantum_espresso/kcp/AFC90/src/make.depend | 0 quantum_espresso/kcp/AFC90/src/nfft.f90 | 29 - quantum_espresso/kcp/AFC90/src/phi0d.f90 | 60 - quantum_espresso/kcp/AFC90/src/phi1d.f90 | 110 - quantum_espresso/kcp/AFC90/src/phi2d.f90 | 98 - quantum_espresso/kcp/AFC90/src/phi3d.f90 | 80 - quantum_espresso/kcp/AFC90/src/reciprocal.f90 | 43 - quantum_espresso/kcp/AFC90/src/rtoaxis.f90 | 47 - quantum_espresso/kcp/AFC90/src/rungekutta.f90 | 42 - quantum_espresso/kcp/AFC90/src/steprk.f90 | 80 - .../kcp/AFC90/src/vectorproduct.f90 | 29 - quantum_espresso/kcp/AFC90/src/volume.f90 | 36 - quantum_espresso/kcp/AFC90/src/ydot.f90 | 38 - quantum_espresso/kcp/CPV/Makefile | 268 - quantum_espresso/kcp/CPV/adjef.f90 | 198 - quantum_espresso/kcp/CPV/atoms_type.f90 | 184 - quantum_espresso/kcp/CPV/berryion.f90 | 157 - quantum_espresso/kcp/CPV/bessel.f90 | 199 - quantum_espresso/kcp/CPV/bforceion.f90 | 118 - quantum_espresso/kcp/CPV/brillouin.f90 | 233 - .../kcp/CPV/centers_and_spreads.f90 | 175 - quantum_espresso/kcp/CPV/cg.f90 | 135 - quantum_espresso/kcp/CPV/cg_empty_sub.f90 | 1485 - quantum_espresso/kcp/CPV/cg_sub.f90 | 1947 - quantum_espresso/kcp/CPV/cglib.f90 | 3380 - quantum_espresso/kcp/CPV/chargedensity.f90 | 3470 - quantum_espresso/kcp/CPV/chargemix.f90 | 148 - quantum_espresso/kcp/CPV/chi2.f90 | 132 - .../kcp/CPV/compute_fes_grads.f90 | 735 - quantum_espresso/kcp/CPV/compute_scf.f90 | 175 - quantum_espresso/kcp/CPV/cp_autopilot.f90 | 413 - quantum_espresso/kcp/CPV/cp_emass.f90 | 50 - quantum_espresso/kcp/CPV/cp_fpmd.f90 | 2034 - quantum_espresso/kcp/CPV/cp_interfaces.f90 | 2101 - quantum_espresso/kcp/CPV/cp_restart.f90 | 4477 -- .../kcp/CPV/cp_restart_backup.f90 | 4446 -- quantum_espresso/kcp/CPV/cp_version.f90 | 14 - quantum_espresso/kcp/CPV/cplib.f90 | 6449 -- quantum_espresso/kcp/CPV/cplib_meta.f90 | 455 - quantum_espresso/kcp/CPV/cpr.f90 | 1173 - quantum_espresso/kcp/CPV/cpr_mod.f90 | 55 - quantum_espresso/kcp/CPV/cprstart.f90 | 149 - quantum_espresso/kcp/CPV/cprsub.f90 | 993 - quantum_espresso/kcp/CPV/dealloc.f90 | 135 - quantum_espresso/kcp/CPV/dforceb.f90 | 292 - quantum_espresso/kcp/CPV/eelib.f90 | 1207 - quantum_espresso/kcp/CPV/eelib.old | 1082 - quantum_espresso/kcp/CPV/efermi.f90 | 729 - quantum_espresso/kcp/CPV/efield.f90 | 378 - quantum_espresso/kcp/CPV/eigs0.f90 | 846 - quantum_espresso/kcp/CPV/electrons.f90 | 551 - .../kcp/CPV/empty_koopmans_pp.f90 | 397 - .../kcp/CPV/empty_koopmans_pp.f90_bk | 390 - quantum_espresso/kcp/CPV/emptystates.f90 | 1596 - quantum_espresso/kcp/CPV/emptystates_tocg.f90 | 1353 - quantum_espresso/kcp/CPV/ensemble_dft.f90 | 361 - quantum_espresso/kcp/CPV/entropy.f90 | 66 - quantum_espresso/kcp/CPV/environment.f90 | 196 - quantum_espresso/kcp/CPV/exch_corr.f90 | 983 - quantum_espresso/kcp/CPV/exx_divergence.f90 | 154 - quantum_espresso/kcp/CPV/fft.f90 | 669 - quantum_espresso/kcp/CPV/forceconv.f90 | 48 - quantum_espresso/kcp/CPV/forces.f90 | 702 - quantum_espresso/kcp/CPV/fpmdpp.f90 | 955 - quantum_espresso/kcp/CPV/fromscra.f90 | 442 - quantum_espresso/kcp/CPV/geninv.f90 | 666 - quantum_espresso/kcp/CPV/gradrho.f90 | 131 - quantum_espresso/kcp/CPV/gram_swap.f90 | 85 - quantum_espresso/kcp/CPV/gtable.f90 | 652 - quantum_espresso/kcp/CPV/hflib.f90 | 413 - quantum_espresso/kcp/CPV/indices.f90 | 307 - quantum_espresso/kcp/CPV/init.f90 | 382 - quantum_espresso/kcp/CPV/init_run.f90 | 436 - quantum_espresso/kcp/CPV/inner_loop.f90 | 642 - quantum_espresso/kcp/CPV/inner_loop_cold.f90 | 695 - .../kcp/CPV/inner_loop_generalize.f90 | 941 - quantum_espresso/kcp/CPV/inner_loop_smear.f90 | 170 - quantum_espresso/kcp/CPV/input.f90 | 1311 - quantum_espresso/kcp/CPV/io_pot_sic_xml.f90 | 115 - quantum_espresso/kcp/CPV/ions_positions.f90 | 514 - quantum_espresso/kcp/CPV/ksstates.f90 | 224 - quantum_espresso/kcp/CPV/main.f90 | 683 - quantum_espresso/kcp/CPV/main_loops.f90 | 103 - quantum_espresso/kcp/CPV/mainvar.f90 | 753 - quantum_espresso/kcp/CPV/make.depend | 1553 - quantum_espresso/kcp/CPV/makov_payne.f90 | 282 - quantum_espresso/kcp/CPV/metaxc.f90 | 102 - quantum_espresso/kcp/CPV/modules.f90 | 679 - quantum_espresso/kcp/CPV/move_electrons.f90 | 415 - quantum_espresso/kcp/CPV/nksiclib.f90 | 8260 --- quantum_espresso/kcp/CPV/nksiclib.f90_bk | 8335 --- quantum_espresso/kcp/CPV/nl_base.f90 | 2006 - quantum_espresso/kcp/CPV/nlcc.f90 | 578 - quantum_espresso/kcp/CPV/odd_alpha.f90 | 158 - quantum_espresso/kcp/CPV/odd_alpha.f90_bk | 371 - quantum_espresso/kcp/CPV/ortho.f90 | 1161 - quantum_espresso/kcp/CPV/ortho_base.f90 | 2557 - quantum_espresso/kcp/CPV/ortho_check.f90 | 94 - quantum_espresso/kcp/CPV/para.f90 | 238 - quantum_espresso/kcp/CPV/path_routines.f90 | 282 - quantum_espresso/kcp/CPV/pc3nc_fixed.f90 | 173 - quantum_espresso/kcp/CPV/perturbing_pot.f90 | 180 - quantum_espresso/kcp/CPV/phasefactor.f90 | 309 - quantum_espresso/kcp/CPV/polarization.f90 | 338 - quantum_espresso/kcp/CPV/potentials.f90 | 1607 - quantum_espresso/kcp/CPV/pres_ai_mod.f90 | 81 - quantum_espresso/kcp/CPV/print_out.f90 | 1190 - quantum_espresso/kcp/CPV/problem_size.f90 | 94 - quantum_espresso/kcp/CPV/pseudo_base.f90 | 430 - quantum_espresso/kcp/CPV/pseudopot.f90 | 95 - quantum_espresso/kcp/CPV/pseudopot_sub.f90 | 1440 - quantum_espresso/kcp/CPV/qmatrixd.f90 | 465 - quantum_espresso/kcp/CPV/qqberry.f90 | 281 - quantum_espresso/kcp/CPV/read_pseudo.f90 | 554 - quantum_espresso/kcp/CPV/restart.f90 | 764 - quantum_espresso/kcp/CPV/restart_sub.f90 | 262 - quantum_espresso/kcp/CPV/runcp.f90 | 627 - quantum_espresso/kcp/CPV/spharmonic.f90 | 430 - quantum_espresso/kcp/CPV/spline.f90 | 708 - quantum_espresso/kcp/CPV/start_c0_wan.f90 | 51 - quantum_espresso/kcp/CPV/stop_run.f90 | 57 - quantum_espresso/kcp/CPV/stress.f90 | 568 - quantum_espresso/kcp/CPV/symm_wannier.f90 | 192 - quantum_espresso/kcp/CPV/turbo.f90 | 71 - quantum_espresso/kcp/CPV/util.f90 | 122 - quantum_espresso/kcp/CPV/vanderwaals.f90 | 454 - quantum_espresso/kcp/CPV/vol_clu.f90 | 420 - quantum_espresso/kcp/CPV/wannier.f90 | 868 - quantum_espresso/kcp/CPV/wannier_base.f90 | 153 - quantum_espresso/kcp/CPV/wave.f90 | 787 - quantum_espresso/kcp/CPV/wave.f90~ | 795 - .../kcp/CPV/wave_init_wannier.f90 | 583 - quantum_espresso/kcp/CPV/wave_types.f90 | 189 - quantum_espresso/kcp/CPV/waveinit.f90 | 15 - quantum_espresso/kcp/CPV/wf.f90 | 3855 -- quantum_espresso/kcp/CPV/what_to_do.txt | 7 - .../kcp/CPV/write_hamiltonian.f90 | 247 - quantum_espresso/kcp/CPV/writetofile.f90 | 254 - quantum_espresso/kcp/License | 340 - quantum_espresso/kcp/Makefile | 83 - quantum_espresso/kcp/Modules/Makefile | 98 - quantum_espresso/kcp/Modules/atom.f90 | 25 - quantum_espresso/kcp/Modules/autopilot.f90 | 859 - .../kcp/Modules/basic_algebra_routines.f90 | 199 - quantum_espresso/kcp/Modules/berry_phase.f90 | 260 - quantum_espresso/kcp/Modules/bfgs_module.f90 | 851 - quantum_espresso/kcp/Modules/cell_base.f90 | 1098 - quantum_espresso/kcp/Modules/check_stop.f90 | 161 - quantum_espresso/kcp/Modules/clocks.f90 | 546 - .../kcp/Modules/compute_dipole.f90 | 248 - quantum_espresso/kcp/Modules/constants.f90 | 146 - .../kcp/Modules/constraints_module.f90 | 1539 - .../kcp/Modules/control_flags.f90 | 455 - quantum_espresso/kcp/Modules/descriptors.f90 | 201 - quantum_espresso/kcp/Modules/dspev_drv.f90 | 749 - .../kcp/Modules/electrons_base.f90 | 535 - quantum_espresso/kcp/Modules/energies.f90 | 285 - .../kcp/Modules/error_handler.f90 | 246 - quantum_espresso/kcp/Modules/exc_t.f90 | 51 - quantum_espresso/kcp/Modules/fft_base.f90 | 1051 - quantum_espresso/kcp/Modules/fft_parallel.f90 | 458 - quantum_espresso/kcp/Modules/fft_scalar.f90 | 2217 - quantum_espresso/kcp/Modules/fft_types.f90 | 550 - quantum_espresso/kcp/Modules/functionals.f90 | 1627 - quantum_espresso/kcp/Modules/griddim.f90 | 456 - .../kcp/Modules/input_parameters.f90 | 1795 - quantum_espresso/kcp/Modules/io_files.f90 | 256 - quantum_espresso/kcp/Modules/io_global.f90 | 102 - quantum_espresso/kcp/Modules/ions_base.f90 | 876 - quantum_espresso/kcp/Modules/ions_nose.f90 | 473 - quantum_espresso/kcp/Modules/kind.f90 | 64 - quantum_espresso/kcp/Modules/make.depend | 346 - quantum_espresso/kcp/Modules/metadyn_base.f90 | 417 - quantum_espresso/kcp/Modules/metadyn_io.f90 | 325 - quantum_espresso/kcp/Modules/metadyn_vars.f90 | 108 - quantum_espresso/kcp/Modules/metagga.f90 | 670 - .../kcp/Modules/mm_dispersion.f90 | 688 - quantum_espresso/kcp/Modules/mp.f90 | 2283 - quantum_espresso/kcp/Modules/mp_base.f90 | 1014 - quantum_espresso/kcp/Modules/mp_global.f90 | 498 - quantum_espresso/kcp/Modules/mp_wave.f90 | 780 - .../kcp/Modules/parallel_include.f90 | 26 - .../kcp/Modules/parallel_types.f90 | 106 - quantum_espresso/kcp/Modules/parameters.f90 | 22 - quantum_espresso/kcp/Modules/parser.f90 | 411 - quantum_espresso/kcp/Modules/path_base.f90 | 1194 - quantum_espresso/kcp/Modules/path_formats.f90 | 52 - .../kcp/Modules/path_io_routines.f90 | 1009 - .../kcp/Modules/path_opt_routines.f90 | 307 - .../kcp/Modules/path_reparametrisation.f90 | 309 - .../kcp/Modules/path_variables.f90 | 152 - .../kcp/Modules/paw_variables.f90 | 72 - .../kcp/Modules/printout_base.f90 | 353 - quantum_espresso/kcp/Modules/pseudo_types.f90 | 282 - quantum_espresso/kcp/Modules/ptoolkit.f90 | 5010 -- quantum_espresso/kcp/Modules/radial_grids.f90 | 481 - .../kcp/Modules/random_numbers.f90 | 155 - quantum_espresso/kcp/Modules/read_cards.f90 | 2633 - .../kcp/Modules/read_namelists.f90 | 2369 - quantum_espresso/kcp/Modules/read_ncpp.f90 | 267 - .../kcp/Modules/read_oddalpha_file.f90 | 60 - quantum_espresso/kcp/Modules/read_upf_v1.f90 | 832 - quantum_espresso/kcp/Modules/read_upf_v2.f90 | 617 - quantum_espresso/kcp/Modules/read_uspp.f90 | 823 - quantum_espresso/kcp/Modules/recvec.f90 | 325 - .../kcp/Modules/shmem_include.f90 | 53 - quantum_espresso/kcp/Modules/sic.f90 | 138 - quantum_espresso/kcp/Modules/smallbox.f90 | 80 - quantum_espresso/kcp/Modules/splinelib.f90 | 293 - quantum_espresso/kcp/Modules/stick_base.f90 | 828 - quantum_espresso/kcp/Modules/task_groups.f90 | 225 - quantum_espresso/kcp/Modules/timestep.f90 | 68 - quantum_espresso/kcp/Modules/twin_types.f90 | 518 - quantum_espresso/kcp/Modules/upf.f90 | 115 - .../kcp/Modules/upf_to_internal.f90 | 73 - quantum_espresso/kcp/Modules/uspp.f90 | 331 - quantum_espresso/kcp/Modules/version.f90 | 17 - quantum_espresso/kcp/Modules/vxc_t.f90 | 54 - quantum_espresso/kcp/Modules/vxcgc.f90 | 296 - quantum_espresso/kcp/Modules/wannier.f90 | 54 - quantum_espresso/kcp/Modules/wannier_new.f90 | 55 - quantum_espresso/kcp/Modules/wave_base.f90 | 707 - .../kcp/Modules/wavefunctions.f90 | 63 - quantum_espresso/kcp/Modules/wrappers.f90 | 87 - quantum_espresso/kcp/Modules/write_upf_v2.f90 | 608 - quantum_espresso/kcp/Modules/xml_input.f90 | 175 - quantum_espresso/kcp/Modules/xml_io_base.f90 | 2456 - quantum_espresso/kcp/Modules/zhpev_drv.f90 | 1575 - quantum_espresso/kcp/clib/Makefile | 27 - quantum_espresso/kcp/clib/c_mkdir.c | 100 - quantum_espresso/kcp/clib/cptimer.c | 42 - quantum_espresso/kcp/clib/eval_infix.c | 730 - quantum_espresso/kcp/clib/fft_stick.c | 214 - quantum_espresso/kcp/clib/fftw.c | 27463 -------- quantum_espresso/kcp/clib/fftw.h | 460 - quantum_espresso/kcp/clib/indici.c | 182 - quantum_espresso/kcp/clib/konst.h | 1325 - quantum_espresso/kcp/clib/make.depend | 10 - quantum_espresso/kcp/clib/memstat.c | 41 - quantum_espresso/kcp/clib/qsort.c | 63 - quantum_espresso/kcp/clib/stack.c | 36 - quantum_espresso/kcp/config.guess | 1415 - quantum_espresso/kcp/config.sub | 1504 - quantum_espresso/kcp/configure | 80 - quantum_espresso/kcp/configure.msg.in | 22 - quantum_espresso/kcp/flib/Makefile | 70 - quantum_espresso/kcp/flib/atomic_number.f90 | 152 - quantum_espresso/kcp/flib/avrec.f90 | 47 - quantum_espresso/kcp/flib/bachel.f90 | 82 - quantum_espresso/kcp/flib/blas.f | 10849 ---- quantum_espresso/kcp/flib/blas_mac.f | 45 - quantum_espresso/kcp/flib/capital.f90 | 97 - quantum_espresso/kcp/flib/cryst_to_car.f90 | 66 - quantum_espresso/kcp/flib/date_and_tim.f90 | 26 - quantum_espresso/kcp/flib/dlamch.f | 857 - quantum_espresso/kcp/flib/dost.f90 | 72 - quantum_espresso/kcp/flib/dylmr2.f90 | 85 - quantum_espresso/kcp/flib/erf.f90 | 127 - quantum_espresso/kcp/flib/flush_unit.f90 | 28 - quantum_espresso/kcp/flib/functionals.f90 | 1014 - quantum_espresso/kcp/flib/gridsetup.f90 | 93 - quantum_espresso/kcp/flib/iglocal.f90 | 55 - quantum_espresso/kcp/flib/inpfile.f90 | 198 - quantum_espresso/kcp/flib/int_to_char.f90 | 53 - quantum_espresso/kcp/flib/invmat.f90 | 50 - quantum_espresso/kcp/flib/invmat_complex.f90 | 50 - quantum_espresso/kcp/flib/lapack_all.f | 7340 --- quantum_espresso/kcp/flib/lapack_atlas.f | 53436 ---------------- quantum_espresso/kcp/flib/lapack_mkl.f | 299 - quantum_espresso/kcp/flib/latgen.f90 | 306 - quantum_espresso/kcp/flib/linpack.f90 | 251 - quantum_espresso/kcp/flib/localdim.f90 | 231 - quantum_espresso/kcp/flib/localindex.f90 | 273 - .../kcp/flib/lsda_functionals.f90 | 652 - quantum_espresso/kcp/flib/make.depend | 38 - quantum_espresso/kcp/flib/matches.f90 | 40 - .../kcp/flib/more_functionals.f90 | 1794 - quantum_espresso/kcp/flib/recips.f90 | 77 - .../kcp/flib/remove_tot_torque.f90 | 120 - quantum_espresso/kcp/flib/simpsn.f90 | 134 - quantum_espresso/kcp/flib/sort.f90 | 997 - quantum_espresso/kcp/flib/sort_gvec.f90 | 66 - quantum_espresso/kcp/flib/sph_bes.f90 | 260 - quantum_espresso/kcp/flib/sph_dbes.f90 | 147 - quantum_espresso/kcp/flib/transto.f90 | 411 - quantum_espresso/kcp/flib/volume.f90 | 62 - quantum_espresso/kcp/flib/xerbla.f | 46 - quantum_espresso/kcp/flib/ylmr2.f90 | 149 - quantum_espresso/kcp/include/c_defs.h.in | 21 - quantum_espresso/kcp/include/configure.h.in | 47 - quantum_espresso/kcp/include/defs.h.README | 103 - quantum_espresso/kcp/include/f_defs.h | 61 - quantum_espresso/kcp/include/fft_defs.h.in | 2 - quantum_espresso/kcp/include/opt_param.h | 13 - quantum_espresso/kcp/install-sh | 294 - quantum_espresso/kcp/install/.gitignore | 2 - .../kcp/install/Makefile.lib_eigsolve | 65 - quantum_espresso/kcp/install/README.FX10 | 167 - quantum_espresso/kcp/install/aclocal.m4 | 39 - quantum_espresso/kcp/install/addsonpatch.sh | 77 - quantum_espresso/kcp/install/addsontool.sh | 190 - .../kcp/install/build_fox_with_pgi.sh | 171 - quantum_espresso/kcp/install/config.guess | 1438 - quantum_espresso/kcp/install/config.sub | 1813 - quantum_espresso/kcp/install/configure | 10712 ---- quantum_espresso/kcp/install/configure-w90 | 0 quantum_espresso/kcp/install/configure.ac | 139 - quantum_espresso/kcp/install/configure.msg.in | 27 - quantum_espresso/kcp/install/extlibs_makefile | 152 - quantum_espresso/kcp/install/includedep.sh | 52 - quantum_espresso/kcp/install/install-sh | 294 - quantum_espresso/kcp/install/install_utils | 38 - .../kcp/install/m4/ax_check_compile_flag.m4 | 74 - .../kcp/install/m4/x_ac_qe_aix_dflags.m4 | 13 - quantum_espresso/kcp/install/m4/x_ac_qe_ar.m4 | 28 - .../kcp/install/m4/x_ac_qe_arch.m4 | 56 - .../kcp/install/m4/x_ac_qe_blas.m4 | 362 - quantum_espresso/kcp/install/m4/x_ac_qe_cc.m4 | 82 - .../kcp/install/m4/x_ac_qe_cpp.m4 | 29 - .../kcp/install/m4/x_ac_qe_default_env.m4 | 46 - .../kcp/install/m4/x_ac_qe_elpa.m4 | 76 - .../kcp/install/m4/x_ac_qe_environ.m4 | 20 - .../kcp/install/m4/x_ac_qe_f90.m4 | 285 - .../kcp/install/m4/x_ac_qe_f90rule.m4 | 19 - .../kcp/install/m4/x_ac_qe_fft.m4 | 199 - .../kcp/install/m4/x_ac_qe_hdf5.m4 | 261 - .../kcp/install/m4/x_ac_qe_lapack.m4 | 99 - quantum_espresso/kcp/install/m4/x_ac_qe_ld.m4 | 20 - .../kcp/install/m4/x_ac_qe_libxc.m4 | 131 - .../kcp/install/m4/x_ac_qe_mass.m4 | 121 - .../kcp/install/m4/x_ac_qe_mpi.m4 | 65 - .../kcp/install/m4/x_ac_qe_mpif90.m4 | 218 - .../kcp/install/m4/x_ac_qe_openmp.m4 | 15 - .../kcp/install/m4/x_ac_qe_ranlib.m4 | 20 - .../kcp/install/m4/x_ac_qe_scalapack.m4 | 105 - .../kcp/install/m4/x_ac_qe_signal.m4 | 19 - .../kcp/install/m4/x_ac_qe_wget.m4 | 14 - quantum_espresso/kcp/install/make-w90 | 0 quantum_espresso/kcp/install/make.inc.in | 138 - .../kcp/install/make_lapack.inc.in | 82 - .../kcp/install/make_wannier90.inc.in | 11 - quantum_espresso/kcp/install/makedeps.sh | 173 - quantum_espresso/kcp/install/moduledep.sh | 54 - quantum_espresso/kcp/install/namedep.sh | 114 - quantum_espresso/kcp/install/plugins_list | 37 - quantum_espresso/kcp/install/plugins_makefile | 213 - .../kcp/install/refresh-configure.sh | 20 - quantum_espresso/kcp/install/uncompress-w90 | 0 quantum_espresso/kcp/iotk/ABOUT | 38 - quantum_espresso/kcp/iotk/CHANGES | 20 - quantum_espresso/kcp/iotk/DOWNLOAD | 17 - quantum_espresso/kcp/iotk/IDE/IDE.conf | 33 - quantum_espresso/kcp/iotk/IDE/IDE_makemake.sh | 190 - quantum_espresso/kcp/iotk/IDE/README | 34 - quantum_espresso/kcp/iotk/IDE/README.options | 22 - quantum_espresso/kcp/iotk/IDE/add_dir | 37 - quantum_espresso/kcp/iotk/IDE/arch.sh | 56 - quantum_espresso/kcp/iotk/IDE/basename_src | 60 - quantum_espresso/kcp/iotk/IDE/check_main | 57 - quantum_espresso/kcp/iotk/IDE/cvssnap.sh | 156 - quantum_espresso/kcp/iotk/IDE/dir_setup.sh | 71 - quantum_espresso/kcp/iotk/IDE/getoption | 90 - .../kcp/iotk/IDE/include/CVS/Entries | 3 - .../kcp/iotk/IDE/include/CVS/Repository | 1 - .../kcp/iotk/IDE/include/CVS/Root | 1 - .../kcp/iotk/IDE/include/IDE_version.h | 5 - .../kcp/iotk/IDE/include/IDE_version.sh | 5 - quantum_espresso/kcp/iotk/IDE/linked | 17 - quantum_espresso/kcp/iotk/IDE/makeinfo.sh | 28 - quantum_espresso/kcp/iotk/IDE/makemake.sh | 600 - quantum_espresso/kcp/iotk/IDE/makeouter.sh | 23 - quantum_espresso/kcp/iotk/IDE/makeversion.sh | 41 - quantum_espresso/kcp/iotk/IDE/moduledep.sh | 117 - quantum_espresso/kcp/iotk/IDE/packls.sh | 54 - quantum_espresso/kcp/iotk/IDE/reverse | 7 - quantum_espresso/kcp/iotk/IDE/split_line | 67 - quantum_espresso/kcp/iotk/IDE/tarlist.sh | 24 - quantum_espresso/kcp/iotk/IDE/used | 75 - quantum_espresso/kcp/iotk/License | 481 - quantum_espresso/kcp/iotk/Makefile | 99 - quantum_espresso/kcp/iotk/OPTIONS | 34 - quantum_espresso/kcp/iotk/README | 131 - quantum_espresso/kcp/iotk/TODO | 78 - quantum_espresso/kcp/iotk/configure | 15 - .../kcp/iotk/doc/binary_format.tex | 264 - quantum_espresso/kcp/iotk/doc/file_format.txt | 27 - quantum_espresso/kcp/iotk/doc/manpages | 414 - quantum_espresso/kcp/iotk/doc/manual.txt | 418 - .../kcp/iotk/include/iotk_auxmacros.h | 244 - .../kcp/iotk/include/iotk_auxmacros.spp | 121 - .../kcp/iotk/include/iotk_config.h | 103 - .../kcp/iotk/include/iotk_config.h.in | 55 - .../kcp/iotk/include/iotk_config.h.save | 150 - .../kcp/iotk/include/iotk_config.sh | 4 - .../kcp/iotk/include/iotk_include.sh | 67 - .../kcp/iotk/include/iotk_list.sh | 135 - .../kcp/iotk/include/iotk_mangen.sh | 26 - .../kcp/iotk/include/iotk_version.h | 5 - .../kcp/iotk/include/iotk_version.sh | 5 - quantum_espresso/kcp/iotk/src/Makefile | 1502 - quantum_espresso/kcp/iotk/src/example1.f90 | 49 - quantum_espresso/kcp/iotk/src/example2.f90 | 47 - quantum_espresso/kcp/iotk/src/example3.f90 | 26 - quantum_espresso/kcp/iotk/src/example4.f90 | 87 - quantum_espresso/kcp/iotk/src/iotk.f90 | 16 - quantum_espresso/kcp/iotk/src/iotk.spp | 16 - .../kcp/iotk/src/iotk_attr+CHARACTER1_0.f90 | 280 - .../kcp/iotk/src/iotk_attr+COMPLEX1_0.f90 | 915 - .../kcp/iotk/src/iotk_attr+COMPLEX1_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+COMPLEX1_6.f90 | 521 - .../kcp/iotk/src/iotk_attr+COMPLEX2_0.f90 | 915 - .../kcp/iotk/src/iotk_attr+COMPLEX2_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+COMPLEX2_6.f90 | 521 - .../kcp/iotk/src/iotk_attr+COMPLEX3_0.f90 | 915 - .../kcp/iotk/src/iotk_attr+COMPLEX3_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+COMPLEX3_6.f90 | 521 - .../kcp/iotk/src/iotk_attr+COMPLEX4_0.f90 | 915 - .../kcp/iotk/src/iotk_attr+COMPLEX4_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+COMPLEX4_6.f90 | 521 - .../kcp/iotk/src/iotk_attr+INTEGER1_0.f90 | 888 - .../kcp/iotk/src/iotk_attr+INTEGER1_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+INTEGER1_6.f90 | 521 - .../kcp/iotk/src/iotk_attr+INTEGER2_0.f90 | 888 - .../kcp/iotk/src/iotk_attr+INTEGER2_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+INTEGER2_6.f90 | 521 - .../kcp/iotk/src/iotk_attr+INTEGER3_0.f90 | 888 - .../kcp/iotk/src/iotk_attr+INTEGER3_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+INTEGER3_6.f90 | 521 - .../kcp/iotk/src/iotk_attr+INTEGER4_0.f90 | 888 - .../kcp/iotk/src/iotk_attr+INTEGER4_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+INTEGER4_6.f90 | 521 - .../kcp/iotk/src/iotk_attr+LOGICAL1_0.f90 | 888 - .../kcp/iotk/src/iotk_attr+LOGICAL1_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+LOGICAL1_6.f90 | 521 - .../kcp/iotk/src/iotk_attr+LOGICAL2_0.f90 | 888 - .../kcp/iotk/src/iotk_attr+LOGICAL2_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+LOGICAL2_6.f90 | 521 - .../kcp/iotk/src/iotk_attr+LOGICAL3_0.f90 | 888 - .../kcp/iotk/src/iotk_attr+LOGICAL3_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+LOGICAL3_6.f90 | 521 - .../kcp/iotk/src/iotk_attr+LOGICAL4_0.f90 | 888 - .../kcp/iotk/src/iotk_attr+LOGICAL4_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+LOGICAL4_6.f90 | 521 - .../kcp/iotk/src/iotk_attr+REAL1_0.f90 | 906 - .../kcp/iotk/src/iotk_attr+REAL1_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+REAL1_6.f90 | 521 - .../kcp/iotk/src/iotk_attr+REAL2_0.f90 | 906 - .../kcp/iotk/src/iotk_attr+REAL2_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+REAL2_6.f90 | 521 - .../kcp/iotk/src/iotk_attr+REAL3_0.f90 | 906 - .../kcp/iotk/src/iotk_attr+REAL3_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+REAL3_6.f90 | 521 - .../kcp/iotk/src/iotk_attr+REAL4_0.f90 | 906 - .../kcp/iotk/src/iotk_attr+REAL4_3.f90 | 773 - .../kcp/iotk/src/iotk_attr+REAL4_6.f90 | 521 - quantum_espresso/kcp/iotk/src/iotk_attr.f90 | 36 - quantum_espresso/kcp/iotk/src/iotk_attr.spp | 488 - .../kcp/iotk/src/iotk_attr_interf.f90 | 5137 -- .../kcp/iotk/src/iotk_attr_interf.spp | 144 - quantum_espresso/kcp/iotk/src/iotk_base.f90 | 316 - quantum_espresso/kcp/iotk/src/iotk_base.spp | 244 - quantum_espresso/kcp/iotk/src/iotk_copy.f90 | 50 - .../kcp/iotk/src/iotk_dat+CHARACTER1_0.f90 | 1568 - .../kcp/iotk/src/iotk_dat+CHARACTER1_3.f90 | 1349 - .../kcp/iotk/src/iotk_dat+CHARACTER1_6.f90 | 903 - .../kcp/iotk/src/iotk_dat+COMPLEX1_0.f90 | 1713 - .../kcp/iotk/src/iotk_dat+COMPLEX1_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+COMPLEX1_6.f90 | 897 - .../kcp/iotk/src/iotk_dat+COMPLEX2_0.f90 | 1713 - .../kcp/iotk/src/iotk_dat+COMPLEX2_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+COMPLEX2_6.f90 | 897 - .../kcp/iotk/src/iotk_dat+COMPLEX3_0.f90 | 1713 - .../kcp/iotk/src/iotk_dat+COMPLEX3_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+COMPLEX3_6.f90 | 897 - .../kcp/iotk/src/iotk_dat+COMPLEX4_0.f90 | 1713 - .../kcp/iotk/src/iotk_dat+COMPLEX4_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+COMPLEX4_6.f90 | 897 - .../kcp/iotk/src/iotk_dat+INTEGER1_0.f90 | 1713 - .../kcp/iotk/src/iotk_dat+INTEGER1_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+INTEGER1_6.f90 | 897 - .../kcp/iotk/src/iotk_dat+INTEGER2_0.f90 | 1713 - .../kcp/iotk/src/iotk_dat+INTEGER2_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+INTEGER2_6.f90 | 897 - .../kcp/iotk/src/iotk_dat+INTEGER3_0.f90 | 1713 - .../kcp/iotk/src/iotk_dat+INTEGER3_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+INTEGER3_6.f90 | 897 - .../kcp/iotk/src/iotk_dat+INTEGER4_0.f90 | 1713 - .../kcp/iotk/src/iotk_dat+INTEGER4_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+INTEGER4_6.f90 | 897 - .../kcp/iotk/src/iotk_dat+LOGICAL1_0.f90 | 1725 - .../kcp/iotk/src/iotk_dat+LOGICAL1_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+LOGICAL1_6.f90 | 897 - .../kcp/iotk/src/iotk_dat+LOGICAL2_0.f90 | 1725 - .../kcp/iotk/src/iotk_dat+LOGICAL2_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+LOGICAL2_6.f90 | 897 - .../kcp/iotk/src/iotk_dat+LOGICAL3_0.f90 | 1725 - .../kcp/iotk/src/iotk_dat+LOGICAL3_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+LOGICAL3_6.f90 | 897 - .../kcp/iotk/src/iotk_dat+LOGICAL4_0.f90 | 1725 - .../kcp/iotk/src/iotk_dat+LOGICAL4_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+LOGICAL4_6.f90 | 897 - .../kcp/iotk/src/iotk_dat+REAL1_0.f90 | 1713 - .../kcp/iotk/src/iotk_dat+REAL1_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+REAL1_6.f90 | 897 - .../kcp/iotk/src/iotk_dat+REAL2_0.f90 | 1713 - .../kcp/iotk/src/iotk_dat+REAL2_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+REAL2_6.f90 | 897 - .../kcp/iotk/src/iotk_dat+REAL3_0.f90 | 1713 - .../kcp/iotk/src/iotk_dat+REAL3_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+REAL3_6.f90 | 897 - .../kcp/iotk/src/iotk_dat+REAL4_0.f90 | 1713 - .../kcp/iotk/src/iotk_dat+REAL4_3.f90 | 1337 - .../kcp/iotk/src/iotk_dat+REAL4_6.f90 | 897 - quantum_espresso/kcp/iotk/src/iotk_dat.f90 | 36 - quantum_espresso/kcp/iotk/src/iotk_dat.spp | 794 - .../kcp/iotk/src/iotk_dat_interf.f90 | 6067 -- .../kcp/iotk/src/iotk_dat_interf.spp | 132 - quantum_espresso/kcp/iotk/src/iotk_error.f90 | 507 - quantum_espresso/kcp/iotk/src/iotk_error.spp | 512 - .../kcp/iotk/src/iotk_error_interf.f90 | 272 - .../kcp/iotk/src/iotk_error_interf.spp | 276 - quantum_espresso/kcp/iotk/src/iotk_files.f90 | 871 - quantum_espresso/kcp/iotk/src/iotk_files.spp | 648 - .../kcp/iotk/src/iotk_files_interf.f90 | 136 - .../kcp/iotk/src/iotk_files_interf.spp | 140 - quantum_espresso/kcp/iotk/src/iotk_fmt.f90 | 261 - quantum_espresso/kcp/iotk/src/iotk_fmt.spp | 137 - .../kcp/iotk/src/iotk_fmt_interf.f90 | 58 - .../kcp/iotk/src/iotk_fmt_interf.spp | 62 - quantum_espresso/kcp/iotk/src/iotk_misc.f90 | 1460 - quantum_espresso/kcp/iotk/src/iotk_misc.spp | 828 - .../kcp/iotk/src/iotk_misc_interf.f90 | 236 - .../kcp/iotk/src/iotk_misc_interf.spp | 240 - quantum_espresso/kcp/iotk/src/iotk_module.f90 | 95 - quantum_espresso/kcp/iotk/src/iotk_module.spp | 95 - .../kcp/iotk/src/iotk_print_kinds.f90 | 4 - quantum_espresso/kcp/iotk/src/iotk_scan.f90 | 1084 - quantum_espresso/kcp/iotk/src/iotk_scan.spp | 855 - .../kcp/iotk/src/iotk_scan_interf.f90 | 146 - .../kcp/iotk/src/iotk_scan_interf.spp | 150 - quantum_espresso/kcp/iotk/src/iotk_str.f90 | 323 - quantum_espresso/kcp/iotk/src/iotk_str.spp | 324 - .../kcp/iotk/src/iotk_str_interf.f90 | 169 - .../kcp/iotk/src/iotk_str_interf.spp | 173 - quantum_espresso/kcp/iotk/src/iotk_stream.f90 | 2347 - quantum_espresso/kcp/iotk/src/iotk_stream.spp | 167 - .../kcp/iotk/src/iotk_stream_interf.f90 | 339 - .../kcp/iotk/src/iotk_stream_interf.spp | 81 - quantum_espresso/kcp/iotk/src/iotk_tool.f90 | 2517 - quantum_espresso/kcp/iotk/src/iotk_tool.spp | 486 - .../kcp/iotk/src/iotk_tool_interf.f90 | 75 - .../kcp/iotk/src/iotk_tool_interf.spp | 79 - quantum_espresso/kcp/iotk/src/iotk_unit.f90 | 318 - quantum_espresso/kcp/iotk/src/iotk_unit.spp | 279 - .../kcp/iotk/src/iotk_unit_interf.f90 | 112 - .../kcp/iotk/src/iotk_unit_interf.spp | 116 - .../kcp/iotk/src/iotk_unit_list.f90 | 218 - .../kcp/iotk/src/iotk_unit_list.spp | 45 - quantum_espresso/kcp/iotk/src/iotk_write.f90 | 526 - quantum_espresso/kcp/iotk/src/iotk_write.spp | 447 - .../kcp/iotk/src/iotk_write_interf.f90 | 110 - .../kcp/iotk/src/iotk_write_interf.spp | 113 - quantum_espresso/kcp/iotk/src/iotk_xtox.f90 | 471 - quantum_espresso/kcp/iotk/src/iotk_xtox.spp | 168 - .../kcp/iotk/src/iotk_xtox_interf.f90 | 186 - .../kcp/iotk/src/iotk_xtox_interf.spp | 94 - quantum_espresso/kcp/iotk/src/test.f90 | 218 - quantum_espresso/kcp/iotk/src/test2.f90 | 18 - quantum_espresso/kcp/iotk/src/test3.f90 | 14 - quantum_espresso/kcp/iotk/src/test4.f90 | 57 - quantum_espresso/kcp/iotk/src/test5.f90 | 61 - quantum_espresso/kcp/iotk/src/test6.f90 | 103 - quantum_espresso/kcp/iotk/src/test7.f90 | 24 - quantum_espresso/kcp/iotk/src/test8.f90 | 89 - quantum_espresso/kcp/iotk/src/test9.f90 | 37 - quantum_espresso/kcp/iotk/tools/auto_config | 439 - quantum_espresso/kcp/iotk/tools/configure | 3265 - quantum_espresso/kcp/iotk/tools/configure.ac | 359 - quantum_espresso/kcp/iotk/tools/export | 39 - quantum_espresso/kcp/iotk/tools/iotk | 71 - quantum_espresso/kcp/make.sys.in | 138 - quantum_espresso/kcp/make.sys.intel | 138 - 625 files changed, 4 insertions(+), 442536 deletions(-) create mode 160000 quantum_espresso/kcp delete mode 100644 quantum_espresso/kcp/.gitignore delete mode 100644 quantum_espresso/kcp/AFC90/Examples/0D.in delete mode 100644 quantum_espresso/kcp/AFC90/Examples/1D.in delete mode 100644 quantum_espresso/kcp/AFC90/Examples/1D2.in delete mode 100644 quantum_espresso/kcp/AFC90/Examples/2D.in delete mode 100644 quantum_espresso/kcp/AFC90/Examples/2D2.in delete mode 100644 quantum_espresso/kcp/AFC90/Examples/2D3.in delete mode 100644 quantum_espresso/kcp/AFC90/Examples/bcc.in delete mode 100644 quantum_espresso/kcp/AFC90/Examples/cubic.in delete mode 100644 quantum_espresso/kcp/AFC90/Examples/fcc.in delete mode 100644 quantum_espresso/kcp/AFC90/Examples/linear.in delete mode 100644 quantum_espresso/kcp/AFC90/Examples/squared.in delete mode 100644 quantum_espresso/kcp/AFC90/Examples/test.in delete mode 100644 quantum_espresso/kcp/AFC90/Examples/trigonal.in delete mode 100644 quantum_espresso/kcp/AFC90/GPL/gpl-3.0.txt delete mode 100644 quantum_espresso/kcp/AFC90/Makefile delete mode 100644 quantum_espresso/kcp/AFC90/README.txt delete mode 100644 quantum_espresso/kcp/AFC90/UserGuide/UserGuide.pdf delete mode 100755 quantum_espresso/kcp/AFC90/make.rules delete mode 100755 quantum_espresso/kcp/AFC90/src/Makefile delete mode 100644 quantum_espresso/kcp/AFC90/src/afcc.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/besseli.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/besselk.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/cylharm.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/cylharm0.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/cylharmasympt.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/cylharmlogslope.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/cylharmrk.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/cylharmseries.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/cylharmslope.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/ei.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/eimlog.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/fft1d.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/fft2d.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/fft3d.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/fftw3.f delete mode 100644 quantum_espresso/kcp/AFC90/src/gaussian.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/gaussiank.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/gaussianl.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/interp.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/main.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/make.depend delete mode 100644 quantum_espresso/kcp/AFC90/src/nfft.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/phi0d.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/phi1d.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/phi2d.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/phi3d.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/reciprocal.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/rtoaxis.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/rungekutta.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/steprk.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/vectorproduct.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/volume.f90 delete mode 100644 quantum_espresso/kcp/AFC90/src/ydot.f90 delete mode 100644 quantum_espresso/kcp/CPV/Makefile delete mode 100644 quantum_espresso/kcp/CPV/adjef.f90 delete mode 100644 quantum_espresso/kcp/CPV/atoms_type.f90 delete mode 100644 quantum_espresso/kcp/CPV/berryion.f90 delete mode 100644 quantum_espresso/kcp/CPV/bessel.f90 delete mode 100644 quantum_espresso/kcp/CPV/bforceion.f90 delete mode 100644 quantum_espresso/kcp/CPV/brillouin.f90 delete mode 100644 quantum_espresso/kcp/CPV/centers_and_spreads.f90 delete mode 100644 quantum_espresso/kcp/CPV/cg.f90 delete mode 100644 quantum_espresso/kcp/CPV/cg_empty_sub.f90 delete mode 100644 quantum_espresso/kcp/CPV/cg_sub.f90 delete mode 100644 quantum_espresso/kcp/CPV/cglib.f90 delete mode 100644 quantum_espresso/kcp/CPV/chargedensity.f90 delete mode 100644 quantum_espresso/kcp/CPV/chargemix.f90 delete mode 100644 quantum_espresso/kcp/CPV/chi2.f90 delete mode 100644 quantum_espresso/kcp/CPV/compute_fes_grads.f90 delete mode 100644 quantum_espresso/kcp/CPV/compute_scf.f90 delete mode 100644 quantum_espresso/kcp/CPV/cp_autopilot.f90 delete mode 100644 quantum_espresso/kcp/CPV/cp_emass.f90 delete mode 100644 quantum_espresso/kcp/CPV/cp_fpmd.f90 delete mode 100644 quantum_espresso/kcp/CPV/cp_interfaces.f90 delete mode 100644 quantum_espresso/kcp/CPV/cp_restart.f90 delete mode 100644 quantum_espresso/kcp/CPV/cp_restart_backup.f90 delete mode 100644 quantum_espresso/kcp/CPV/cp_version.f90 delete mode 100644 quantum_espresso/kcp/CPV/cplib.f90 delete mode 100644 quantum_espresso/kcp/CPV/cplib_meta.f90 delete mode 100644 quantum_espresso/kcp/CPV/cpr.f90 delete mode 100644 quantum_espresso/kcp/CPV/cpr_mod.f90 delete mode 100644 quantum_espresso/kcp/CPV/cprstart.f90 delete mode 100644 quantum_espresso/kcp/CPV/cprsub.f90 delete mode 100644 quantum_espresso/kcp/CPV/dealloc.f90 delete mode 100644 quantum_espresso/kcp/CPV/dforceb.f90 delete mode 100644 quantum_espresso/kcp/CPV/eelib.f90 delete mode 100644 quantum_espresso/kcp/CPV/eelib.old delete mode 100644 quantum_espresso/kcp/CPV/efermi.f90 delete mode 100644 quantum_espresso/kcp/CPV/efield.f90 delete mode 100644 quantum_espresso/kcp/CPV/eigs0.f90 delete mode 100644 quantum_espresso/kcp/CPV/electrons.f90 delete mode 100644 quantum_espresso/kcp/CPV/empty_koopmans_pp.f90 delete mode 100644 quantum_espresso/kcp/CPV/empty_koopmans_pp.f90_bk delete mode 100644 quantum_espresso/kcp/CPV/emptystates.f90 delete mode 100644 quantum_espresso/kcp/CPV/emptystates_tocg.f90 delete mode 100644 quantum_espresso/kcp/CPV/ensemble_dft.f90 delete mode 100644 quantum_espresso/kcp/CPV/entropy.f90 delete mode 100644 quantum_espresso/kcp/CPV/environment.f90 delete mode 100644 quantum_espresso/kcp/CPV/exch_corr.f90 delete mode 100644 quantum_espresso/kcp/CPV/exx_divergence.f90 delete mode 100644 quantum_espresso/kcp/CPV/fft.f90 delete mode 100644 quantum_espresso/kcp/CPV/forceconv.f90 delete mode 100644 quantum_espresso/kcp/CPV/forces.f90 delete mode 100644 quantum_espresso/kcp/CPV/fpmdpp.f90 delete mode 100644 quantum_espresso/kcp/CPV/fromscra.f90 delete mode 100644 quantum_espresso/kcp/CPV/geninv.f90 delete mode 100644 quantum_espresso/kcp/CPV/gradrho.f90 delete mode 100644 quantum_espresso/kcp/CPV/gram_swap.f90 delete mode 100644 quantum_espresso/kcp/CPV/gtable.f90 delete mode 100644 quantum_espresso/kcp/CPV/hflib.f90 delete mode 100644 quantum_espresso/kcp/CPV/indices.f90 delete mode 100644 quantum_espresso/kcp/CPV/init.f90 delete mode 100644 quantum_espresso/kcp/CPV/init_run.f90 delete mode 100644 quantum_espresso/kcp/CPV/inner_loop.f90 delete mode 100644 quantum_espresso/kcp/CPV/inner_loop_cold.f90 delete mode 100644 quantum_espresso/kcp/CPV/inner_loop_generalize.f90 delete mode 100644 quantum_espresso/kcp/CPV/inner_loop_smear.f90 delete mode 100644 quantum_espresso/kcp/CPV/input.f90 delete mode 100644 quantum_espresso/kcp/CPV/io_pot_sic_xml.f90 delete mode 100644 quantum_espresso/kcp/CPV/ions_positions.f90 delete mode 100644 quantum_espresso/kcp/CPV/ksstates.f90 delete mode 100644 quantum_espresso/kcp/CPV/main.f90 delete mode 100644 quantum_espresso/kcp/CPV/main_loops.f90 delete mode 100644 quantum_espresso/kcp/CPV/mainvar.f90 delete mode 100644 quantum_espresso/kcp/CPV/make.depend delete mode 100644 quantum_espresso/kcp/CPV/makov_payne.f90 delete mode 100644 quantum_espresso/kcp/CPV/metaxc.f90 delete mode 100644 quantum_espresso/kcp/CPV/modules.f90 delete mode 100644 quantum_espresso/kcp/CPV/move_electrons.f90 delete mode 100644 quantum_espresso/kcp/CPV/nksiclib.f90 delete mode 100644 quantum_espresso/kcp/CPV/nksiclib.f90_bk delete mode 100644 quantum_espresso/kcp/CPV/nl_base.f90 delete mode 100644 quantum_espresso/kcp/CPV/nlcc.f90 delete mode 100644 quantum_espresso/kcp/CPV/odd_alpha.f90 delete mode 100644 quantum_espresso/kcp/CPV/odd_alpha.f90_bk delete mode 100644 quantum_espresso/kcp/CPV/ortho.f90 delete mode 100644 quantum_espresso/kcp/CPV/ortho_base.f90 delete mode 100644 quantum_espresso/kcp/CPV/ortho_check.f90 delete mode 100644 quantum_espresso/kcp/CPV/para.f90 delete mode 100644 quantum_espresso/kcp/CPV/path_routines.f90 delete mode 100644 quantum_espresso/kcp/CPV/pc3nc_fixed.f90 delete mode 100644 quantum_espresso/kcp/CPV/perturbing_pot.f90 delete mode 100644 quantum_espresso/kcp/CPV/phasefactor.f90 delete mode 100644 quantum_espresso/kcp/CPV/polarization.f90 delete mode 100644 quantum_espresso/kcp/CPV/potentials.f90 delete mode 100644 quantum_espresso/kcp/CPV/pres_ai_mod.f90 delete mode 100644 quantum_espresso/kcp/CPV/print_out.f90 delete mode 100644 quantum_espresso/kcp/CPV/problem_size.f90 delete mode 100644 quantum_espresso/kcp/CPV/pseudo_base.f90 delete mode 100644 quantum_espresso/kcp/CPV/pseudopot.f90 delete mode 100644 quantum_espresso/kcp/CPV/pseudopot_sub.f90 delete mode 100644 quantum_espresso/kcp/CPV/qmatrixd.f90 delete mode 100644 quantum_espresso/kcp/CPV/qqberry.f90 delete mode 100644 quantum_espresso/kcp/CPV/read_pseudo.f90 delete mode 100644 quantum_espresso/kcp/CPV/restart.f90 delete mode 100644 quantum_espresso/kcp/CPV/restart_sub.f90 delete mode 100644 quantum_espresso/kcp/CPV/runcp.f90 delete mode 100644 quantum_espresso/kcp/CPV/spharmonic.f90 delete mode 100644 quantum_espresso/kcp/CPV/spline.f90 delete mode 100644 quantum_espresso/kcp/CPV/start_c0_wan.f90 delete mode 100644 quantum_espresso/kcp/CPV/stop_run.f90 delete mode 100644 quantum_espresso/kcp/CPV/stress.f90 delete mode 100644 quantum_espresso/kcp/CPV/symm_wannier.f90 delete mode 100644 quantum_espresso/kcp/CPV/turbo.f90 delete mode 100644 quantum_espresso/kcp/CPV/util.f90 delete mode 100644 quantum_espresso/kcp/CPV/vanderwaals.f90 delete mode 100644 quantum_espresso/kcp/CPV/vol_clu.f90 delete mode 100644 quantum_espresso/kcp/CPV/wannier.f90 delete mode 100644 quantum_espresso/kcp/CPV/wannier_base.f90 delete mode 100644 quantum_espresso/kcp/CPV/wave.f90 delete mode 100644 quantum_espresso/kcp/CPV/wave.f90~ delete mode 100644 quantum_espresso/kcp/CPV/wave_init_wannier.f90 delete mode 100644 quantum_espresso/kcp/CPV/wave_types.f90 delete mode 100644 quantum_espresso/kcp/CPV/waveinit.f90 delete mode 100644 quantum_espresso/kcp/CPV/wf.f90 delete mode 100644 quantum_espresso/kcp/CPV/what_to_do.txt delete mode 100644 quantum_espresso/kcp/CPV/write_hamiltonian.f90 delete mode 100644 quantum_espresso/kcp/CPV/writetofile.f90 delete mode 100644 quantum_espresso/kcp/License delete mode 100644 quantum_espresso/kcp/Makefile delete mode 100644 quantum_espresso/kcp/Modules/Makefile delete mode 100644 quantum_espresso/kcp/Modules/atom.f90 delete mode 100644 quantum_espresso/kcp/Modules/autopilot.f90 delete mode 100644 quantum_espresso/kcp/Modules/basic_algebra_routines.f90 delete mode 100644 quantum_espresso/kcp/Modules/berry_phase.f90 delete mode 100644 quantum_espresso/kcp/Modules/bfgs_module.f90 delete mode 100644 quantum_espresso/kcp/Modules/cell_base.f90 delete mode 100644 quantum_espresso/kcp/Modules/check_stop.f90 delete mode 100644 quantum_espresso/kcp/Modules/clocks.f90 delete mode 100644 quantum_espresso/kcp/Modules/compute_dipole.f90 delete mode 100644 quantum_espresso/kcp/Modules/constants.f90 delete mode 100644 quantum_espresso/kcp/Modules/constraints_module.f90 delete mode 100644 quantum_espresso/kcp/Modules/control_flags.f90 delete mode 100644 quantum_espresso/kcp/Modules/descriptors.f90 delete mode 100644 quantum_espresso/kcp/Modules/dspev_drv.f90 delete mode 100644 quantum_espresso/kcp/Modules/electrons_base.f90 delete mode 100644 quantum_espresso/kcp/Modules/energies.f90 delete mode 100644 quantum_espresso/kcp/Modules/error_handler.f90 delete mode 100644 quantum_espresso/kcp/Modules/exc_t.f90 delete mode 100644 quantum_espresso/kcp/Modules/fft_base.f90 delete mode 100644 quantum_espresso/kcp/Modules/fft_parallel.f90 delete mode 100644 quantum_espresso/kcp/Modules/fft_scalar.f90 delete mode 100644 quantum_espresso/kcp/Modules/fft_types.f90 delete mode 100644 quantum_espresso/kcp/Modules/functionals.f90 delete mode 100644 quantum_espresso/kcp/Modules/griddim.f90 delete mode 100644 quantum_espresso/kcp/Modules/input_parameters.f90 delete mode 100644 quantum_espresso/kcp/Modules/io_files.f90 delete mode 100644 quantum_espresso/kcp/Modules/io_global.f90 delete mode 100644 quantum_espresso/kcp/Modules/ions_base.f90 delete mode 100644 quantum_espresso/kcp/Modules/ions_nose.f90 delete mode 100644 quantum_espresso/kcp/Modules/kind.f90 delete mode 100644 quantum_espresso/kcp/Modules/make.depend delete mode 100644 quantum_espresso/kcp/Modules/metadyn_base.f90 delete mode 100644 quantum_espresso/kcp/Modules/metadyn_io.f90 delete mode 100644 quantum_espresso/kcp/Modules/metadyn_vars.f90 delete mode 100644 quantum_espresso/kcp/Modules/metagga.f90 delete mode 100644 quantum_espresso/kcp/Modules/mm_dispersion.f90 delete mode 100644 quantum_espresso/kcp/Modules/mp.f90 delete mode 100644 quantum_espresso/kcp/Modules/mp_base.f90 delete mode 100644 quantum_espresso/kcp/Modules/mp_global.f90 delete mode 100644 quantum_espresso/kcp/Modules/mp_wave.f90 delete mode 100644 quantum_espresso/kcp/Modules/parallel_include.f90 delete mode 100644 quantum_espresso/kcp/Modules/parallel_types.f90 delete mode 100644 quantum_espresso/kcp/Modules/parameters.f90 delete mode 100644 quantum_espresso/kcp/Modules/parser.f90 delete mode 100644 quantum_espresso/kcp/Modules/path_base.f90 delete mode 100644 quantum_espresso/kcp/Modules/path_formats.f90 delete mode 100644 quantum_espresso/kcp/Modules/path_io_routines.f90 delete mode 100644 quantum_espresso/kcp/Modules/path_opt_routines.f90 delete mode 100644 quantum_espresso/kcp/Modules/path_reparametrisation.f90 delete mode 100644 quantum_espresso/kcp/Modules/path_variables.f90 delete mode 100644 quantum_espresso/kcp/Modules/paw_variables.f90 delete mode 100644 quantum_espresso/kcp/Modules/printout_base.f90 delete mode 100644 quantum_espresso/kcp/Modules/pseudo_types.f90 delete mode 100644 quantum_espresso/kcp/Modules/ptoolkit.f90 delete mode 100644 quantum_espresso/kcp/Modules/radial_grids.f90 delete mode 100644 quantum_espresso/kcp/Modules/random_numbers.f90 delete mode 100644 quantum_espresso/kcp/Modules/read_cards.f90 delete mode 100644 quantum_espresso/kcp/Modules/read_namelists.f90 delete mode 100644 quantum_espresso/kcp/Modules/read_ncpp.f90 delete mode 100644 quantum_espresso/kcp/Modules/read_oddalpha_file.f90 delete mode 100644 quantum_espresso/kcp/Modules/read_upf_v1.f90 delete mode 100644 quantum_espresso/kcp/Modules/read_upf_v2.f90 delete mode 100644 quantum_espresso/kcp/Modules/read_uspp.f90 delete mode 100644 quantum_espresso/kcp/Modules/recvec.f90 delete mode 100644 quantum_espresso/kcp/Modules/shmem_include.f90 delete mode 100644 quantum_espresso/kcp/Modules/sic.f90 delete mode 100644 quantum_espresso/kcp/Modules/smallbox.f90 delete mode 100644 quantum_espresso/kcp/Modules/splinelib.f90 delete mode 100644 quantum_espresso/kcp/Modules/stick_base.f90 delete mode 100755 quantum_espresso/kcp/Modules/task_groups.f90 delete mode 100644 quantum_espresso/kcp/Modules/timestep.f90 delete mode 100644 quantum_espresso/kcp/Modules/twin_types.f90 delete mode 100644 quantum_espresso/kcp/Modules/upf.f90 delete mode 100644 quantum_espresso/kcp/Modules/upf_to_internal.f90 delete mode 100644 quantum_espresso/kcp/Modules/uspp.f90 delete mode 100644 quantum_espresso/kcp/Modules/version.f90 delete mode 100644 quantum_espresso/kcp/Modules/vxc_t.f90 delete mode 100644 quantum_espresso/kcp/Modules/vxcgc.f90 delete mode 100644 quantum_espresso/kcp/Modules/wannier.f90 delete mode 100644 quantum_espresso/kcp/Modules/wannier_new.f90 delete mode 100644 quantum_espresso/kcp/Modules/wave_base.f90 delete mode 100644 quantum_espresso/kcp/Modules/wavefunctions.f90 delete mode 100644 quantum_espresso/kcp/Modules/wrappers.f90 delete mode 100644 quantum_espresso/kcp/Modules/write_upf_v2.f90 delete mode 100644 quantum_espresso/kcp/Modules/xml_input.f90 delete mode 100644 quantum_espresso/kcp/Modules/xml_io_base.f90 delete mode 100644 quantum_espresso/kcp/Modules/zhpev_drv.f90 delete mode 100644 quantum_espresso/kcp/clib/Makefile delete mode 100644 quantum_espresso/kcp/clib/c_mkdir.c delete mode 100644 quantum_espresso/kcp/clib/cptimer.c delete mode 100644 quantum_espresso/kcp/clib/eval_infix.c delete mode 100644 quantum_espresso/kcp/clib/fft_stick.c delete mode 100644 quantum_espresso/kcp/clib/fftw.c delete mode 100644 quantum_espresso/kcp/clib/fftw.h delete mode 100644 quantum_espresso/kcp/clib/indici.c delete mode 100644 quantum_espresso/kcp/clib/konst.h delete mode 100644 quantum_espresso/kcp/clib/make.depend delete mode 100644 quantum_espresso/kcp/clib/memstat.c delete mode 100644 quantum_espresso/kcp/clib/qsort.c delete mode 100644 quantum_espresso/kcp/clib/stack.c delete mode 100755 quantum_espresso/kcp/config.guess delete mode 100644 quantum_espresso/kcp/config.sub delete mode 100755 quantum_espresso/kcp/configure delete mode 100644 quantum_espresso/kcp/configure.msg.in delete mode 100644 quantum_espresso/kcp/flib/Makefile delete mode 100644 quantum_espresso/kcp/flib/atomic_number.f90 delete mode 100644 quantum_espresso/kcp/flib/avrec.f90 delete mode 100644 quantum_espresso/kcp/flib/bachel.f90 delete mode 100644 quantum_espresso/kcp/flib/blas.f delete mode 100644 quantum_espresso/kcp/flib/blas_mac.f delete mode 100644 quantum_espresso/kcp/flib/capital.f90 delete mode 100644 quantum_espresso/kcp/flib/cryst_to_car.f90 delete mode 100644 quantum_espresso/kcp/flib/date_and_tim.f90 delete mode 100644 quantum_espresso/kcp/flib/dlamch.f delete mode 100644 quantum_espresso/kcp/flib/dost.f90 delete mode 100644 quantum_espresso/kcp/flib/dylmr2.f90 delete mode 100644 quantum_espresso/kcp/flib/erf.f90 delete mode 100644 quantum_espresso/kcp/flib/flush_unit.f90 delete mode 100644 quantum_espresso/kcp/flib/functionals.f90 delete mode 100644 quantum_espresso/kcp/flib/gridsetup.f90 delete mode 100644 quantum_espresso/kcp/flib/iglocal.f90 delete mode 100644 quantum_espresso/kcp/flib/inpfile.f90 delete mode 100644 quantum_espresso/kcp/flib/int_to_char.f90 delete mode 100644 quantum_espresso/kcp/flib/invmat.f90 delete mode 100644 quantum_espresso/kcp/flib/invmat_complex.f90 delete mode 100644 quantum_espresso/kcp/flib/lapack_all.f delete mode 100644 quantum_espresso/kcp/flib/lapack_atlas.f delete mode 100644 quantum_espresso/kcp/flib/lapack_mkl.f delete mode 100644 quantum_espresso/kcp/flib/latgen.f90 delete mode 100644 quantum_espresso/kcp/flib/linpack.f90 delete mode 100644 quantum_espresso/kcp/flib/localdim.f90 delete mode 100644 quantum_espresso/kcp/flib/localindex.f90 delete mode 100644 quantum_espresso/kcp/flib/lsda_functionals.f90 delete mode 100644 quantum_espresso/kcp/flib/make.depend delete mode 100644 quantum_espresso/kcp/flib/matches.f90 delete mode 100644 quantum_espresso/kcp/flib/more_functionals.f90 delete mode 100644 quantum_espresso/kcp/flib/recips.f90 delete mode 100644 quantum_espresso/kcp/flib/remove_tot_torque.f90 delete mode 100644 quantum_espresso/kcp/flib/simpsn.f90 delete mode 100644 quantum_espresso/kcp/flib/sort.f90 delete mode 100644 quantum_espresso/kcp/flib/sort_gvec.f90 delete mode 100644 quantum_espresso/kcp/flib/sph_bes.f90 delete mode 100644 quantum_espresso/kcp/flib/sph_dbes.f90 delete mode 100644 quantum_espresso/kcp/flib/transto.f90 delete mode 100644 quantum_espresso/kcp/flib/volume.f90 delete mode 100644 quantum_espresso/kcp/flib/xerbla.f delete mode 100644 quantum_espresso/kcp/flib/ylmr2.f90 delete mode 100644 quantum_espresso/kcp/include/c_defs.h.in delete mode 100644 quantum_espresso/kcp/include/configure.h.in delete mode 100644 quantum_espresso/kcp/include/defs.h.README delete mode 100644 quantum_espresso/kcp/include/f_defs.h delete mode 100644 quantum_espresso/kcp/include/fft_defs.h.in delete mode 100644 quantum_espresso/kcp/include/opt_param.h delete mode 100755 quantum_espresso/kcp/install-sh delete mode 100644 quantum_espresso/kcp/install/.gitignore delete mode 100644 quantum_espresso/kcp/install/Makefile.lib_eigsolve delete mode 100644 quantum_espresso/kcp/install/README.FX10 delete mode 100644 quantum_espresso/kcp/install/aclocal.m4 delete mode 100755 quantum_espresso/kcp/install/addsonpatch.sh delete mode 100755 quantum_espresso/kcp/install/addsontool.sh delete mode 100644 quantum_espresso/kcp/install/build_fox_with_pgi.sh delete mode 100755 quantum_espresso/kcp/install/config.guess delete mode 100644 quantum_espresso/kcp/install/config.sub delete mode 100755 quantum_espresso/kcp/install/configure delete mode 100644 quantum_espresso/kcp/install/configure-w90 delete mode 100644 quantum_espresso/kcp/install/configure.ac delete mode 100644 quantum_espresso/kcp/install/configure.msg.in delete mode 100644 quantum_espresso/kcp/install/extlibs_makefile delete mode 100755 quantum_espresso/kcp/install/includedep.sh delete mode 100755 quantum_espresso/kcp/install/install-sh delete mode 100644 quantum_espresso/kcp/install/install_utils delete mode 100644 quantum_espresso/kcp/install/m4/ax_check_compile_flag.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_aix_dflags.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_ar.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_arch.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_blas.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_cc.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_cpp.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_default_env.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_elpa.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_environ.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_f90.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_f90rule.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_fft.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_hdf5.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_lapack.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_ld.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_libxc.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_mass.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_mpi.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_mpif90.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_openmp.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_ranlib.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_scalapack.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_signal.m4 delete mode 100644 quantum_espresso/kcp/install/m4/x_ac_qe_wget.m4 delete mode 100644 quantum_espresso/kcp/install/make-w90 delete mode 100644 quantum_espresso/kcp/install/make.inc.in delete mode 100644 quantum_espresso/kcp/install/make_lapack.inc.in delete mode 100644 quantum_espresso/kcp/install/make_wannier90.inc.in delete mode 100755 quantum_espresso/kcp/install/makedeps.sh delete mode 100755 quantum_espresso/kcp/install/moduledep.sh delete mode 100755 quantum_espresso/kcp/install/namedep.sh delete mode 100644 quantum_espresso/kcp/install/plugins_list delete mode 100644 quantum_espresso/kcp/install/plugins_makefile delete mode 100755 quantum_espresso/kcp/install/refresh-configure.sh delete mode 100644 quantum_espresso/kcp/install/uncompress-w90 delete mode 100644 quantum_espresso/kcp/iotk/ABOUT delete mode 100644 quantum_espresso/kcp/iotk/CHANGES delete mode 100644 quantum_espresso/kcp/iotk/DOWNLOAD delete mode 100644 quantum_espresso/kcp/iotk/IDE/IDE.conf delete mode 100755 quantum_espresso/kcp/iotk/IDE/IDE_makemake.sh delete mode 100644 quantum_espresso/kcp/iotk/IDE/README delete mode 100644 quantum_espresso/kcp/iotk/IDE/README.options delete mode 100755 quantum_espresso/kcp/iotk/IDE/add_dir delete mode 100755 quantum_espresso/kcp/iotk/IDE/arch.sh delete mode 100755 quantum_espresso/kcp/iotk/IDE/basename_src delete mode 100755 quantum_espresso/kcp/iotk/IDE/check_main delete mode 100755 quantum_espresso/kcp/iotk/IDE/cvssnap.sh delete mode 100755 quantum_espresso/kcp/iotk/IDE/dir_setup.sh delete mode 100755 quantum_espresso/kcp/iotk/IDE/getoption delete mode 100644 quantum_espresso/kcp/iotk/IDE/include/CVS/Entries delete mode 100644 quantum_espresso/kcp/iotk/IDE/include/CVS/Repository delete mode 100644 quantum_espresso/kcp/iotk/IDE/include/CVS/Root delete mode 100644 quantum_espresso/kcp/iotk/IDE/include/IDE_version.h delete mode 100644 quantum_espresso/kcp/iotk/IDE/include/IDE_version.sh delete mode 100755 quantum_espresso/kcp/iotk/IDE/linked delete mode 100755 quantum_espresso/kcp/iotk/IDE/makeinfo.sh delete mode 100755 quantum_espresso/kcp/iotk/IDE/makemake.sh delete mode 100755 quantum_espresso/kcp/iotk/IDE/makeouter.sh delete mode 100755 quantum_espresso/kcp/iotk/IDE/makeversion.sh delete mode 100755 quantum_espresso/kcp/iotk/IDE/moduledep.sh delete mode 100755 quantum_espresso/kcp/iotk/IDE/packls.sh delete mode 100755 quantum_espresso/kcp/iotk/IDE/reverse delete mode 100755 quantum_espresso/kcp/iotk/IDE/split_line delete mode 100755 quantum_espresso/kcp/iotk/IDE/tarlist.sh delete mode 100755 quantum_espresso/kcp/iotk/IDE/used delete mode 100644 quantum_espresso/kcp/iotk/License delete mode 100644 quantum_espresso/kcp/iotk/Makefile delete mode 100644 quantum_espresso/kcp/iotk/OPTIONS delete mode 100644 quantum_espresso/kcp/iotk/README delete mode 100644 quantum_espresso/kcp/iotk/TODO delete mode 100755 quantum_espresso/kcp/iotk/configure delete mode 100755 quantum_espresso/kcp/iotk/doc/binary_format.tex delete mode 100644 quantum_espresso/kcp/iotk/doc/file_format.txt delete mode 100644 quantum_espresso/kcp/iotk/doc/manpages delete mode 100644 quantum_espresso/kcp/iotk/doc/manual.txt delete mode 100644 quantum_espresso/kcp/iotk/include/iotk_auxmacros.h delete mode 100644 quantum_espresso/kcp/iotk/include/iotk_auxmacros.spp delete mode 100644 quantum_espresso/kcp/iotk/include/iotk_config.h delete mode 100644 quantum_espresso/kcp/iotk/include/iotk_config.h.in delete mode 100644 quantum_espresso/kcp/iotk/include/iotk_config.h.save delete mode 100644 quantum_espresso/kcp/iotk/include/iotk_config.sh delete mode 100644 quantum_espresso/kcp/iotk/include/iotk_include.sh delete mode 100644 quantum_espresso/kcp/iotk/include/iotk_list.sh delete mode 100644 quantum_espresso/kcp/iotk/include/iotk_mangen.sh delete mode 100644 quantum_espresso/kcp/iotk/include/iotk_version.h delete mode 100644 quantum_espresso/kcp/iotk/include/iotk_version.sh delete mode 100644 quantum_espresso/kcp/iotk/src/Makefile delete mode 100644 quantum_espresso/kcp/iotk/src/example1.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/example2.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/example3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/example4.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+CHARACTER1_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX1_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX1_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX1_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX2_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX2_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX2_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX3_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX3_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX3_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX4_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX4_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX4_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER1_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER1_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER1_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER2_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER2_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER2_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER3_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER3_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER3_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER4_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER4_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER4_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL1_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL1_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL1_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL2_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL2_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL2_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL3_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL3_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL3_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL4_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL4_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL4_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+REAL1_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+REAL1_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+REAL1_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+REAL2_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+REAL2_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+REAL2_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+REAL3_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+REAL3_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+REAL3_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+REAL4_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+REAL4_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr+REAL4_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr_interf.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_attr_interf.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_base.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_base.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_copy.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+CHARACTER1_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+CHARACTER1_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+CHARACTER1_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX1_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX1_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX1_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX2_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX2_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX2_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX3_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX3_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX3_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX4_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX4_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX4_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER1_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER1_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER1_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER2_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER2_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER2_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER3_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER3_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER3_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER4_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER4_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER4_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL1_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL1_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL1_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL2_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL2_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL2_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL3_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL3_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL3_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL4_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL4_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL4_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+REAL1_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+REAL1_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+REAL1_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+REAL2_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+REAL2_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+REAL2_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+REAL3_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+REAL3_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+REAL3_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+REAL4_0.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+REAL4_3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat+REAL4_6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat_interf.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_dat_interf.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_error.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_error.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_error_interf.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_error_interf.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_files.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_files.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_files_interf.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_files_interf.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_fmt.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_fmt.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_fmt_interf.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_fmt_interf.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_misc.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_misc.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_misc_interf.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_misc_interf.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_module.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_module.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_print_kinds.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_scan.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_scan.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_scan_interf.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_scan_interf.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_str.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_str.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_str_interf.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_str_interf.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_stream.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_stream.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_stream_interf.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_stream_interf.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_tool.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_tool.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_tool_interf.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_tool_interf.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_unit.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_unit.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_unit_interf.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_unit_interf.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_unit_list.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_unit_list.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_write.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_write.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_write_interf.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_write_interf.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_xtox.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_xtox.spp delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_xtox_interf.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/iotk_xtox_interf.spp delete mode 100644 quantum_espresso/kcp/iotk/src/test.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/test2.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/test3.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/test4.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/test5.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/test6.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/test7.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/test8.f90 delete mode 100644 quantum_espresso/kcp/iotk/src/test9.f90 delete mode 100755 quantum_espresso/kcp/iotk/tools/auto_config delete mode 100755 quantum_espresso/kcp/iotk/tools/configure delete mode 100644 quantum_espresso/kcp/iotk/tools/configure.ac delete mode 100755 quantum_espresso/kcp/iotk/tools/export delete mode 100755 quantum_espresso/kcp/iotk/tools/iotk delete mode 100644 quantum_espresso/kcp/make.sys.in delete mode 100644 quantum_espresso/kcp/make.sys.intel diff --git a/.gitmodules b/.gitmodules index 891c47057..ea955abb8 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,6 @@ [submodule "quantum_espresso/q-e"] path = quantum_espresso/q-e url = https://gitlab.com/QEF/q-e.git +[submodule "quantum_espresso/kcp"] + path = quantum_espresso/kcp + url = ../koopmans-kcp.git diff --git a/quantum_espresso/kcp b/quantum_espresso/kcp new file mode 160000 index 000000000..e52975af4 --- /dev/null +++ b/quantum_espresso/kcp @@ -0,0 +1 @@ +Subproject commit e52975af42c54b9983e4f43d0ee93b24662fb7f6 diff --git a/quantum_espresso/kcp/.gitignore b/quantum_espresso/kcp/.gitignore deleted file mode 100644 index c3e147736..000000000 --- a/quantum_espresso/kcp/.gitignore +++ /dev/null @@ -1,16 +0,0 @@ -CPV/cpver.h -Modules/cpver.h -include/iotk_config.h -include/configure.h -include/c_defs.h -include/fft_defs.h -include/build_date.h -config.log -config.status -configure.msg -make.sys -*.o -*.x -*.mod -*.a -bin/ diff --git a/quantum_espresso/kcp/AFC90/Examples/0D.in b/quantum_espresso/kcp/AFC90/Examples/0D.in deleted file mode 100644 index 023893823..000000000 --- a/quantum_espresso/kcp/AFC90/Examples/0D.in +++ /dev/null @@ -1,18 +0,0 @@ -&input -a(1,1)=10.d0 -a(2,1)=0.d0 -a(3,1)=0.d0 -a(1,2)=0.d0 -a(2,2)=10.d0 -a(3,2)=0.d0 -a(1,3)=0.d0 -a(2,3)=0.d0 -a(3,3)=10.d0 -tperiodic(1)=.false. -tperiodic(2)=.false. -tperiodic(3)=.false. -npt(1)=51 -npt(2)=51 -npt(3)=51 -spread=0.5d0 -/ diff --git a/quantum_espresso/kcp/AFC90/Examples/1D.in b/quantum_espresso/kcp/AFC90/Examples/1D.in deleted file mode 100644 index b396584c9..000000000 --- a/quantum_espresso/kcp/AFC90/Examples/1D.in +++ /dev/null @@ -1,18 +0,0 @@ -&input -a(1,1)=100.d0 -a(2,1)=0.d0 -a(3,1)=0.d0 -a(1,2)=0.d0 -a(2,2)=100.d0 -a(3,2)=0.d0 -a(1,3)=0.d0 -a(2,3)=0.d0 -a(3,3)=100.d0 -tperiodic(1)=.false. -tperiodic(2)=.false. -tperiodic(3)=.true. -npt(1)=200 -npt(2)=200 -npt(3)=200 -spread=2.5d0 -/ diff --git a/quantum_espresso/kcp/AFC90/Examples/1D2.in b/quantum_espresso/kcp/AFC90/Examples/1D2.in deleted file mode 100644 index 455485ab2..000000000 --- a/quantum_espresso/kcp/AFC90/Examples/1D2.in +++ /dev/null @@ -1,18 +0,0 @@ -&input -a(1,1)=100.d0 -a(2,1)=0.d0 -a(3,1)=50.d0 -a(1,2)=25.d0 -a(2,2)=100.d0 -a(3,2)=0.d0 -a(1,3)=0.d0 -a(2,3)=0.d0 -a(3,3)=100.d0 -tperiodic(1)=.false. -tperiodic(2)=.false. -tperiodic(3)=.true. -npt(1)=200 -npt(2)=200 -npt(3)=200 -spread=2.5d0 -/ diff --git a/quantum_espresso/kcp/AFC90/Examples/2D.in b/quantum_espresso/kcp/AFC90/Examples/2D.in deleted file mode 100644 index 689e966bb..000000000 --- a/quantum_espresso/kcp/AFC90/Examples/2D.in +++ /dev/null @@ -1,18 +0,0 @@ -&input -a(1,1)=100.d0 -a(2,1)=0.d0 -a(3,1)=0.d0 -a(1,2)=0.d0 -a(2,2)=100.d0 -a(3,2)=0.d0 -a(1,3)=0.d0 -a(2,3)=0.d0 -a(3,3)=100.d0 -tperiodic(1)=.true. -tperiodic(2)=.true. -tperiodic(3)=.false. -npt(1)=200 -npt(2)=200 -npt(3)=200 -spread=2.5d0 -/ diff --git a/quantum_espresso/kcp/AFC90/Examples/2D2.in b/quantum_espresso/kcp/AFC90/Examples/2D2.in deleted file mode 100644 index ef4c6b40a..000000000 --- a/quantum_espresso/kcp/AFC90/Examples/2D2.in +++ /dev/null @@ -1,18 +0,0 @@ -&input -a(1,1)=100.d0 -a(2,1)=0.d0 -a(3,1)=0.d0 -a(1,2)=0.d0 -a(2,2)=100.d0 -a(3,2)=0.d0 -a(1,3)=50.d0 -a(2,3)=25.d0 -a(3,3)=100.d0 -tperiodic(1)=.true. -tperiodic(2)=.true. -tperiodic(3)=.false. -npt(1)=200 -npt(2)=200 -npt(3)=200 -spread=2.5d0 -/ diff --git a/quantum_espresso/kcp/AFC90/Examples/2D3.in b/quantum_espresso/kcp/AFC90/Examples/2D3.in deleted file mode 100644 index ef4c6b40a..000000000 --- a/quantum_espresso/kcp/AFC90/Examples/2D3.in +++ /dev/null @@ -1,18 +0,0 @@ -&input -a(1,1)=100.d0 -a(2,1)=0.d0 -a(3,1)=0.d0 -a(1,2)=0.d0 -a(2,2)=100.d0 -a(3,2)=0.d0 -a(1,3)=50.d0 -a(2,3)=25.d0 -a(3,3)=100.d0 -tperiodic(1)=.true. -tperiodic(2)=.true. -tperiodic(3)=.false. -npt(1)=200 -npt(2)=200 -npt(3)=200 -spread=2.5d0 -/ diff --git a/quantum_espresso/kcp/AFC90/Examples/bcc.in b/quantum_espresso/kcp/AFC90/Examples/bcc.in deleted file mode 100644 index 98045174c..000000000 --- a/quantum_espresso/kcp/AFC90/Examples/bcc.in +++ /dev/null @@ -1,18 +0,0 @@ -&input -a(1,1)=-0.5d0 -a(2,1)=0.5d0 -a(3,1)=0.5d0 -a(1,2)=0.5d0 -a(2,2)=-0.5d0 -a(3,2)=0.5d0 -a(1,3)=0.5d0 -a(2,3)=0.5d0 -a(3,3)=-0.5d0 -tperiodic(1)=.false. -tperiodic(2)=.false. -tperiodic(3)=.false. -npt(1)=51 -npt(2)=51 -npt(3)=51 -spread=0.1d0 -/ diff --git a/quantum_espresso/kcp/AFC90/Examples/cubic.in b/quantum_espresso/kcp/AFC90/Examples/cubic.in deleted file mode 100644 index 9e035fe12..000000000 --- a/quantum_espresso/kcp/AFC90/Examples/cubic.in +++ /dev/null @@ -1,18 +0,0 @@ -&input -a(1,1)=1.d0 -a(2,1)=0.d0 -a(3,1)=0.d0 -a(1,2)=0.d0 -a(2,2)=1.d0 -a(3,2)=0.d0 -a(1,3)=0.d0 -a(2,3)=0.d0 -a(3,3)=1.d0 -tperiodic(1)=.false. -tperiodic(2)=.false. -tperiodic(3)=.false. -npt(1)=51 -npt(2)=51 -npt(3)=51 -spread=0.1d0 -/ diff --git a/quantum_espresso/kcp/AFC90/Examples/fcc.in b/quantum_espresso/kcp/AFC90/Examples/fcc.in deleted file mode 100644 index 9f4f58c83..000000000 --- a/quantum_espresso/kcp/AFC90/Examples/fcc.in +++ /dev/null @@ -1,18 +0,0 @@ -&input -a(1,1)=0.d0 -a(2,1)=0.5d0 -a(3,1)=0.5d0 -a(1,2)=0.5d0 -a(2,2)=0.d0 -a(3,2)=0.5d0 -a(1,3)=0.5d0 -a(2,3)=0.5d0 -a(3,3)=0.d0 -tperiodic(1)=.false. -tperiodic(2)=.false. -tperiodic(3)=.false. -npt(1)=51 -npt(2)=51 -npt(3)=51 -spread=0.1d0 -/ diff --git a/quantum_espresso/kcp/AFC90/Examples/linear.in b/quantum_espresso/kcp/AFC90/Examples/linear.in deleted file mode 100644 index 217f30f7c..000000000 --- a/quantum_espresso/kcp/AFC90/Examples/linear.in +++ /dev/null @@ -1,18 +0,0 @@ -&input -a(1,1)=1.d0 -a(2,1)=0.d0 -a(3,1)=0.d0 -a(1,2)=0.d0 -a(2,2)=1.d0 -a(3,2)=0.d0 -a(1,3)=0.d0 -a(2,3)=0.d0 -a(3,3)=1.d0 -tperiodic(1)=.true. -tperiodic(2)=.true. -tperiodic(3)=.false. -npt(1)=1 -npt(2)=1 -npt(3)=51 -spread=0.1d0 -/ diff --git a/quantum_espresso/kcp/AFC90/Examples/squared.in b/quantum_espresso/kcp/AFC90/Examples/squared.in deleted file mode 100644 index ab007ab7c..000000000 --- a/quantum_espresso/kcp/AFC90/Examples/squared.in +++ /dev/null @@ -1,18 +0,0 @@ -&input -a(1,1)=1.d0 -a(2,1)=0.d0 -a(3,1)=0.d0 -a(1,2)=0.d0 -a(2,2)=1.d0 -a(3,2)=0.d0 -a(1,3)=0.d0 -a(2,3)=0.d0 -a(3,3)=1.d0 -tperiodic(1)=.false. -tperiodic(2)=.false. -tperiodic(3)=.true. -npt(1)=51 -npt(2)=51 -npt(3)=1 -spread=0.1d0 -/ diff --git a/quantum_espresso/kcp/AFC90/Examples/test.in b/quantum_espresso/kcp/AFC90/Examples/test.in deleted file mode 100644 index 4b919ddea..000000000 --- a/quantum_espresso/kcp/AFC90/Examples/test.in +++ /dev/null @@ -1,18 +0,0 @@ -&input -a(1,1)=35.d0 -a(2,1)=0.d0 -a(3,1)=0.d0 -a(1,2)=0.d0 -a(2,2)=35.d0 -a(3,2)=0.d0 -a(1,3)=0.d0 -a(2,3)=0.d0 -a(3,3)=35.d0 -tperiodic(1)=.false. -tperiodic(2)=.false. -tperiodic(3)=.false. -npt(1)=125 -npt(2)=125 -npt(3)=125 -spread=2.d0 -/ diff --git a/quantum_espresso/kcp/AFC90/Examples/trigonal.in b/quantum_espresso/kcp/AFC90/Examples/trigonal.in deleted file mode 100644 index 63a1ac987..000000000 --- a/quantum_espresso/kcp/AFC90/Examples/trigonal.in +++ /dev/null @@ -1,18 +0,0 @@ -&input -a(1,1)=1.d0 -a(2,1)=0.d0 -a(3,1)=0.d0 -a(1,2)=0.5d0 -a(2,2)=0.866025d0 -a(3,2)=0.d0 -a(1,3)=0.d0 -a(2,3)=0.d0 -a(3,3)=1.d0 -tperiodic(1)=.false. -tperiodic(2)=.false. -tperiodic(3)=.true. -npt(1)=51 -npt(2)=51 -npt(3)=1 -spread=0.1d0 -/ diff --git a/quantum_espresso/kcp/AFC90/GPL/gpl-3.0.txt b/quantum_espresso/kcp/AFC90/GPL/gpl-3.0.txt deleted file mode 100644 index 94a9ed024..000000000 --- a/quantum_espresso/kcp/AFC90/GPL/gpl-3.0.txt +++ /dev/null @@ -1,674 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The GNU General Public License is a free, copyleft license for -software and other kinds of works. - - The licenses for most software and other practical works are designed -to take away your freedom to share and change the works. By contrast, -the GNU General Public License is intended to guarantee your freedom to -share and change all versions of a program--to make sure it remains free -software for all its users. We, the Free Software Foundation, use the -GNU General Public License for most of our software; it applies also to -any other work released this way by its authors. You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -them if you wish), that you receive source code or can get it if you -want it, that you can change the software or use pieces of it in new -free programs, and that you know you can do these things. - - To protect your rights, we need to prevent others from denying you -these rights or asking you to surrender the rights. Therefore, you have -certain responsibilities if you distribute copies of the software, or if -you modify it: responsibilities to respect the freedom of others. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must pass on to the recipients the same -freedoms that you received. You must make sure that they, too, receive -or can get the source code. And you must show them these terms so they -know their rights. - - Developers that use the GNU GPL protect your rights with two steps: -(1) assert copyright on the software, and (2) offer you this License -giving you legal permission to copy, distribute and/or modify it. - - For the developers' and authors' protection, the GPL clearly explains -that there is no warranty for this free software. For both users' and -authors' sake, the GPL requires that modified versions be marked as -changed, so that their problems will not be attributed erroneously to -authors of previous versions. - - Some devices are designed to deny users access to install or run -modified versions of the software inside them, although the manufacturer -can do so. This is fundamentally incompatible with the aim of -protecting users' freedom to change the software. The systematic -pattern of such abuse occurs in the area of products for individuals to -use, which is precisely where it is most unacceptable. Therefore, we -have designed this version of the GPL to prohibit the practice for those -products. If such problems arise substantially in other domains, we -stand ready to extend this provision to those domains in future versions -of the GPL, as needed to protect the freedom of users. - - Finally, every program is threatened constantly by software patents. -States should not allow patents to restrict development and use of -software on general-purpose computers, but in those that do, we wish to -avoid the special danger that patents applied to a free program could -make it effectively proprietary. To prevent this, the GPL assures that -patents cannot be used to render the program non-free. - - The precise terms and conditions for copying, distribution and -modification follow. - - TERMS AND CONDITIONS - - 0. Definitions. - - "This License" refers to version 3 of the GNU General Public License. - - "Copyright" also means copyright-like laws that apply to other kinds of -works, such as semiconductor masks. - - "The Program" refers to any copyrightable work licensed under this -License. Each licensee is addressed as "you". "Licensees" and -"recipients" may be individuals or organizations. - - To "modify" a work means to copy from or adapt all or part of the work -in a fashion requiring copyright permission, other than the making of an -exact copy. The resulting work is called a "modified version" of the -earlier work or a work "based on" the earlier work. - - A "covered work" means either the unmodified Program or a work based -on the Program. - - To "propagate" a work means to do anything with it that, without -permission, would make you directly or secondarily liable for -infringement under applicable copyright law, except executing it on a -computer or modifying a private copy. Propagation includes copying, -distribution (with or without modification), making available to the -public, and in some countries other activities as well. - - To "convey" a work means any kind of propagation that enables other -parties to make or receive copies. Mere interaction with a user through -a computer network, with no transfer of a copy, is not conveying. - - An interactive user interface displays "Appropriate Legal Notices" -to the extent that it includes a convenient and prominently visible -feature that (1) displays an appropriate copyright notice, and (2) -tells the user that there is no warranty for the work (except to the -extent that warranties are provided), that licensees may convey the -work under this License, and how to view a copy of this License. If -the interface presents a list of user commands or options, such as a -menu, a prominent item in the list meets this criterion. - - 1. Source Code. - - The "source code" for a work means the preferred form of the work -for making modifications to it. "Object code" means any non-source -form of a work. - - A "Standard Interface" means an interface that either is an official -standard defined by a recognized standards body, or, in the case of -interfaces specified for a particular programming language, one that -is widely used among developers working in that language. - - The "System Libraries" of an executable work include anything, other -than the work as a whole, that (a) is included in the normal form of -packaging a Major Component, but which is not part of that Major -Component, and (b) serves only to enable use of the work with that -Major Component, or to implement a Standard Interface for which an -implementation is available to the public in source code form. A -"Major Component", in this context, means a major essential component -(kernel, window system, and so on) of the specific operating system -(if any) on which the executable work runs, or a compiler used to -produce the work, or an object code interpreter used to run it. - - The "Corresponding Source" for a work in object code form means all -the source code needed to generate, install, and (for an executable -work) run the object code and to modify the work, including scripts to -control those activities. However, it does not include the work's -System Libraries, or general-purpose tools or generally available free -programs which are used unmodified in performing those activities but -which are not part of the work. For example, Corresponding Source -includes interface definition files associated with source files for -the work, and the source code for shared libraries and dynamically -linked subprograms that the work is specifically designed to require, -such as by intimate data communication or control flow between those -subprograms and other parts of the work. - - The Corresponding Source need not include anything that users -can regenerate automatically from other parts of the Corresponding -Source. - - The Corresponding Source for a work in source code form is that -same work. - - 2. Basic Permissions. - - All rights granted under this License are granted for the term of -copyright on the Program, and are irrevocable provided the stated -conditions are met. This License explicitly affirms your unlimited -permission to run the unmodified Program. The output from running a -covered work is covered by this License only if the output, given its -content, constitutes a covered work. This License acknowledges your -rights of fair use or other equivalent, as provided by copyright law. - - You may make, run and propagate covered works that you do not -convey, without conditions so long as your license otherwise remains -in force. You may convey covered works to others for the sole purpose -of having them make modifications exclusively for you, or provide you -with facilities for running those works, provided that you comply with -the terms of this License in conveying all material for which you do -not control copyright. Those thus making or running the covered works -for you must do so exclusively on your behalf, under your direction -and control, on terms that prohibit them from making any copies of -your copyrighted material outside their relationship with you. - - Conveying under any other circumstances is permitted solely under -the conditions stated below. Sublicensing is not allowed; section 10 -makes it unnecessary. - - 3. Protecting Users' Legal Rights From Anti-Circumvention Law. - - No covered work shall be deemed part of an effective technological -measure under any applicable law fulfilling obligations under article -11 of the WIPO copyright treaty adopted on 20 December 1996, or -similar laws prohibiting or restricting circumvention of such -measures. - - When you convey a covered work, you waive any legal power to forbid -circumvention of technological measures to the extent such circumvention -is effected by exercising rights under this License with respect to -the covered work, and you disclaim any intention to limit operation or -modification of the work as a means of enforcing, against the work's -users, your or third parties' legal rights to forbid circumvention of -technological measures. - - 4. Conveying Verbatim Copies. - - You may convey verbatim copies of the Program's source code as you -receive it, in any medium, provided that you conspicuously and -appropriately publish on each copy an appropriate copyright notice; -keep intact all notices stating that this License and any -non-permissive terms added in accord with section 7 apply to the code; -keep intact all notices of the absence of any warranty; and give all -recipients a copy of this License along with the Program. - - You may charge any price or no price for each copy that you convey, -and you may offer support or warranty protection for a fee. - - 5. Conveying Modified Source Versions. - - You may convey a work based on the Program, or the modifications to -produce it from the Program, in the form of source code under the -terms of section 4, provided that you also meet all of these conditions: - - a) The work must carry prominent notices stating that you modified - it, and giving a relevant date. - - b) The work must carry prominent notices stating that it is - released under this License and any conditions added under section - 7. This requirement modifies the requirement in section 4 to - "keep intact all notices". - - c) You must license the entire work, as a whole, under this - License to anyone who comes into possession of a copy. This - License will therefore apply, along with any applicable section 7 - additional terms, to the whole of the work, and all its parts, - regardless of how they are packaged. This License gives no - permission to license the work in any other way, but it does not - invalidate such permission if you have separately received it. - - d) If the work has interactive user interfaces, each must display - Appropriate Legal Notices; however, if the Program has interactive - interfaces that do not display Appropriate Legal Notices, your - work need not make them do so. - - A compilation of a covered work with other separate and independent -works, which are not by their nature extensions of the covered work, -and which are not combined with it such as to form a larger program, -in or on a volume of a storage or distribution medium, is called an -"aggregate" if the compilation and its resulting copyright are not -used to limit the access or legal rights of the compilation's users -beyond what the individual works permit. Inclusion of a covered work -in an aggregate does not cause this License to apply to the other -parts of the aggregate. - - 6. Conveying Non-Source Forms. - - You may convey a covered work in object code form under the terms -of sections 4 and 5, provided that you also convey the -machine-readable Corresponding Source under the terms of this License, -in one of these ways: - - a) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by the - Corresponding Source fixed on a durable physical medium - customarily used for software interchange. - - b) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by a - written offer, valid for at least three years and valid for as - long as you offer spare parts or customer support for that product - model, to give anyone who possesses the object code either (1) a - copy of the Corresponding Source for all the software in the - product that is covered by this License, on a durable physical - medium customarily used for software interchange, for a price no - more than your reasonable cost of physically performing this - conveying of source, or (2) access to copy the - Corresponding Source from a network server at no charge. - - c) Convey individual copies of the object code with a copy of the - written offer to provide the Corresponding Source. This - alternative is allowed only occasionally and noncommercially, and - only if you received the object code with such an offer, in accord - with subsection 6b. - - d) Convey the object code by offering access from a designated - place (gratis or for a charge), and offer equivalent access to the - Corresponding Source in the same way through the same place at no - further charge. You need not require recipients to copy the - Corresponding Source along with the object code. If the place to - copy the object code is a network server, the Corresponding Source - may be on a different server (operated by you or a third party) - that supports equivalent copying facilities, provided you maintain - clear directions next to the object code saying where to find the - Corresponding Source. Regardless of what server hosts the - Corresponding Source, you remain obligated to ensure that it is - available for as long as needed to satisfy these requirements. - - e) Convey the object code using peer-to-peer transmission, provided - you inform other peers where the object code and Corresponding - Source of the work are being offered to the general public at no - charge under subsection 6d. - - A separable portion of the object code, whose source code is excluded -from the Corresponding Source as a System Library, need not be -included in conveying the object code work. - - A "User Product" is either (1) a "consumer product", which means any -tangible personal property which is normally used for personal, family, -or household purposes, or (2) anything designed or sold for incorporation -into a dwelling. In determining whether a product is a consumer product, -doubtful cases shall be resolved in favor of coverage. For a particular -product received by a particular user, "normally used" refers to a -typical or common use of that class of product, regardless of the status -of the particular user or of the way in which the particular user -actually uses, or expects or is expected to use, the product. A product -is a consumer product regardless of whether the product has substantial -commercial, industrial or non-consumer uses, unless such uses represent -the only significant mode of use of the product. - - "Installation Information" for a User Product means any methods, -procedures, authorization keys, or other information required to install -and execute modified versions of a covered work in that User Product from -a modified version of its Corresponding Source. The information must -suffice to ensure that the continued functioning of the modified object -code is in no case prevented or interfered with solely because -modification has been made. - - If you convey an object code work under this section in, or with, or -specifically for use in, a User Product, and the conveying occurs as -part of a transaction in which the right of possession and use of the -User Product is transferred to the recipient in perpetuity or for a -fixed term (regardless of how the transaction is characterized), the -Corresponding Source conveyed under this section must be accompanied -by the Installation Information. But this requirement does not apply -if neither you nor any third party retains the ability to install -modified object code on the User Product (for example, the work has -been installed in ROM). - - The requirement to provide Installation Information does not include a -requirement to continue to provide support service, warranty, or updates -for a work that has been modified or installed by the recipient, or for -the User Product in which it has been modified or installed. Access to a -network may be denied when the modification itself materially and -adversely affects the operation of the network or violates the rules and -protocols for communication across the network. - - Corresponding Source conveyed, and Installation Information provided, -in accord with this section must be in a format that is publicly -documented (and with an implementation available to the public in -source code form), and must require no special password or key for -unpacking, reading or copying. - - 7. Additional Terms. - - "Additional permissions" are terms that supplement the terms of this -License by making exceptions from one or more of its conditions. -Additional permissions that are applicable to the entire Program shall -be treated as though they were included in this License, to the extent -that they are valid under applicable law. If additional permissions -apply only to part of the Program, that part may be used separately -under those permissions, but the entire Program remains governed by -this License without regard to the additional permissions. - - When you convey a copy of a covered work, you may at your option -remove any additional permissions from that copy, or from any part of -it. (Additional permissions may be written to require their own -removal in certain cases when you modify the work.) You may place -additional permissions on material, added by you to a covered work, -for which you have or can give appropriate copyright permission. - - Notwithstanding any other provision of this License, for material you -add to a covered work, you may (if authorized by the copyright holders of -that material) supplement the terms of this License with terms: - - a) Disclaiming warranty or limiting liability differently from the - terms of sections 15 and 16 of this License; or - - b) Requiring preservation of specified reasonable legal notices or - author attributions in that material or in the Appropriate Legal - Notices displayed by works containing it; or - - c) Prohibiting misrepresentation of the origin of that material, or - requiring that modified versions of such material be marked in - reasonable ways as different from the original version; or - - d) Limiting the use for publicity purposes of names of licensors or - authors of the material; or - - e) Declining to grant rights under trademark law for use of some - trade names, trademarks, or service marks; or - - f) Requiring indemnification of licensors and authors of that - material by anyone who conveys the material (or modified versions of - it) with contractual assumptions of liability to the recipient, for - any liability that these contractual assumptions directly impose on - those licensors and authors. - - All other non-permissive additional terms are considered "further -restrictions" within the meaning of section 10. If the Program as you -received it, or any part of it, contains a notice stating that it is -governed by this License along with a term that is a further -restriction, you may remove that term. If a license document contains -a further restriction but permits relicensing or conveying under this -License, you may add to a covered work material governed by the terms -of that license document, provided that the further restriction does -not survive such relicensing or conveying. - - If you add terms to a covered work in accord with this section, you -must place, in the relevant source files, a statement of the -additional terms that apply to those files, or a notice indicating -where to find the applicable terms. - - Additional terms, permissive or non-permissive, may be stated in the -form of a separately written license, or stated as exceptions; -the above requirements apply either way. - - 8. Termination. - - You may not propagate or modify a covered work except as expressly -provided under this License. Any attempt otherwise to propagate or -modify it is void, and will automatically terminate your rights under -this License (including any patent licenses granted under the third -paragraph of section 11). - - However, if you cease all violation of this License, then your -license from a particular copyright holder is reinstated (a) -provisionally, unless and until the copyright holder explicitly and -finally terminates your license, and (b) permanently, if the copyright -holder fails to notify you of the violation by some reasonable means -prior to 60 days after the cessation. - - Moreover, your license from a particular copyright holder is -reinstated permanently if the copyright holder notifies you of the -violation by some reasonable means, this is the first time you have -received notice of violation of this License (for any work) from that -copyright holder, and you cure the violation prior to 30 days after -your receipt of the notice. - - Termination of your rights under this section does not terminate the -licenses of parties who have received copies or rights from you under -this License. If your rights have been terminated and not permanently -reinstated, you do not qualify to receive new licenses for the same -material under section 10. - - 9. Acceptance Not Required for Having Copies. - - You are not required to accept this License in order to receive or -run a copy of the Program. Ancillary propagation of a covered work -occurring solely as a consequence of using peer-to-peer transmission -to receive a copy likewise does not require acceptance. However, -nothing other than this License grants you permission to propagate or -modify any covered work. These actions infringe copyright if you do -not accept this License. Therefore, by modifying or propagating a -covered work, you indicate your acceptance of this License to do so. - - 10. Automatic Licensing of Downstream Recipients. - - Each time you convey a covered work, the recipient automatically -receives a license from the original licensors, to run, modify and -propagate that work, subject to this License. You are not responsible -for enforcing compliance by third parties with this License. - - An "entity transaction" is a transaction transferring control of an -organization, or substantially all assets of one, or subdividing an -organization, or merging organizations. If propagation of a covered -work results from an entity transaction, each party to that -transaction who receives a copy of the work also receives whatever -licenses to the work the party's predecessor in interest had or could -give under the previous paragraph, plus a right to possession of the -Corresponding Source of the work from the predecessor in interest, if -the predecessor has it or can get it with reasonable efforts. - - You may not impose any further restrictions on the exercise of the -rights granted or affirmed under this License. For example, you may -not impose a license fee, royalty, or other charge for exercise of -rights granted under this License, and you may not initiate litigation -(including a cross-claim or counterclaim in a lawsuit) alleging that -any patent claim is infringed by making, using, selling, offering for -sale, or importing the Program or any portion of it. - - 11. Patents. - - A "contributor" is a copyright holder who authorizes use under this -License of the Program or a work on which the Program is based. The -work thus licensed is called the contributor's "contributor version". - - A contributor's "essential patent claims" are all patent claims -owned or controlled by the contributor, whether already acquired or -hereafter acquired, that would be infringed by some manner, permitted -by this License, of making, using, or selling its contributor version, -but do not include claims that would be infringed only as a -consequence of further modification of the contributor version. For -purposes of this definition, "control" includes the right to grant -patent sublicenses in a manner consistent with the requirements of -this License. - - Each contributor grants you a non-exclusive, worldwide, royalty-free -patent license under the contributor's essential patent claims, to -make, use, sell, offer for sale, import and otherwise run, modify and -propagate the contents of its contributor version. - - In the following three paragraphs, a "patent license" is any express -agreement or commitment, however denominated, not to enforce a patent -(such as an express permission to practice a patent or covenant not to -sue for patent infringement). To "grant" such a patent license to a -party means to make such an agreement or commitment not to enforce a -patent against the party. - - If you convey a covered work, knowingly relying on a patent license, -and the Corresponding Source of the work is not available for anyone -to copy, free of charge and under the terms of this License, through a -publicly available network server or other readily accessible means, -then you must either (1) cause the Corresponding Source to be so -available, or (2) arrange to deprive yourself of the benefit of the -patent license for this particular work, or (3) arrange, in a manner -consistent with the requirements of this License, to extend the patent -license to downstream recipients. "Knowingly relying" means you have -actual knowledge that, but for the patent license, your conveying the -covered work in a country, or your recipient's use of the covered work -in a country, would infringe one or more identifiable patents in that -country that you have reason to believe are valid. - - If, pursuant to or in connection with a single transaction or -arrangement, you convey, or propagate by procuring conveyance of, a -covered work, and grant a patent license to some of the parties -receiving the covered work authorizing them to use, propagate, modify -or convey a specific copy of the covered work, then the patent license -you grant is automatically extended to all recipients of the covered -work and works based on it. - - A patent license is "discriminatory" if it does not include within -the scope of its coverage, prohibits the exercise of, or is -conditioned on the non-exercise of one or more of the rights that are -specifically granted under this License. You may not convey a covered -work if you are a party to an arrangement with a third party that is -in the business of distributing software, under which you make payment -to the third party based on the extent of your activity of conveying -the work, and under which the third party grants, to any of the -parties who would receive the covered work from you, a discriminatory -patent license (a) in connection with copies of the covered work -conveyed by you (or copies made from those copies), or (b) primarily -for and in connection with specific products or compilations that -contain the covered work, unless you entered into that arrangement, -or that patent license was granted, prior to 28 March 2007. - - Nothing in this License shall be construed as excluding or limiting -any implied license or other defenses to infringement that may -otherwise be available to you under applicable patent law. - - 12. No Surrender of Others' Freedom. - - If conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot convey a -covered work so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you may -not convey it at all. For example, if you agree to terms that obligate you -to collect a royalty for further conveying from those to whom you convey -the Program, the only way you could satisfy both those terms and this -License would be to refrain entirely from conveying the Program. - - 13. Use with the GNU Affero General Public License. - - Notwithstanding any other provision of this License, you have -permission to link or combine any covered work with a work licensed -under version 3 of the GNU Affero General Public License into a single -combined work, and to convey the resulting work. The terms of this -License will continue to apply to the part which is the covered work, -but the special requirements of the GNU Affero General Public License, -section 13, concerning interaction through a network will apply to the -combination as such. - - 14. Revised Versions of this License. - - The Free Software Foundation may publish revised and/or new versions of -the GNU General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - - Each version is given a distinguishing version number. If the -Program specifies that a certain numbered version of the GNU General -Public License "or any later version" applies to it, you have the -option of following the terms and conditions either of that numbered -version or of any later version published by the Free Software -Foundation. If the Program does not specify a version number of the -GNU General Public License, you may choose any version ever published -by the Free Software Foundation. - - If the Program specifies that a proxy can decide which future -versions of the GNU General Public License can be used, that proxy's -public statement of acceptance of a version permanently authorizes you -to choose that version for the Program. - - Later license versions may give you additional or different -permissions. However, no additional obligations are imposed on any -author or copyright holder as a result of your choosing to follow a -later version. - - 15. Disclaimer of Warranty. - - THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY -APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT -HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY -OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, -THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM -IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF -ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. Limitation of Liability. - - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS -THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY -GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE -USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF -DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD -PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), -EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF -SUCH DAMAGES. - - 17. Interpretation of Sections 15 and 16. - - If the disclaimer of warranty and limitation of liability provided -above cannot be given local legal effect according to their terms, -reviewing courts shall apply local law that most closely approximates -an absolute waiver of all civil liability in connection with the -Program, unless a warranty or assumption of liability accompanies a -copy of the Program in return for a fee. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -state the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . - -Also add information on how to contact you by electronic and paper mail. - - If the program does terminal interaction, make it output a short -notice like this when it starts in an interactive mode: - - Copyright (C) - This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, your program's commands -might be different; for a GUI interface, you would use an "about box". - - You should also get your employer (if you work as a programmer) or school, -if any, to sign a "copyright disclaimer" for the program, if necessary. -For more information on this, and how to apply and follow the GNU GPL, see -. - - The GNU General Public License does not permit incorporating your program -into proprietary programs. If your program is a subroutine library, you -may consider it more useful to permit linking proprietary applications with -the library. If this is what you want to do, use the GNU Lesser General -Public License instead of this License. But first, please read -. diff --git a/quantum_espresso/kcp/AFC90/Makefile b/quantum_espresso/kcp/AFC90/Makefile deleted file mode 100644 index 12baeb327..000000000 --- a/quantum_espresso/kcp/AFC90/Makefile +++ /dev/null @@ -1,28 +0,0 @@ -# Makefile for CPV -# Adapted from TDDFPT main Makefile - -default: all - -all: - if test -d src ; then \ - ( cd src ; if test "$(MAKE)" = "" ; then make $(MFLAGS) $@; \ - else $(MAKE) $(MFLAGS) $@ ; fi ) ; fi ; \ - -clean : - if test -d src ; then \ - ( cd src ; if test "$(MAKE)" = "" ; then make clean ; \ - else $(MAKE) clean ; fi ) ; fi ;\ - -#doc: -# if test -d Doc ; then \ - (cd Doc ; if test "$(MAKE)" = "" ; then make $(MFLAGS) all ; \ - else $(MAKE) $(MFLAGS) all ; fi ) ; fi -#doc_clean: -# if test -d Doc ; then \ - (cd Doc ; if test "$(MAKE)" = "" ; then make $(MFLAGS) clean ; \ - else $(MAKE) $(MFLAGS) clean ; fi ) ; fi - -#distclean: clean doc_clean - - - diff --git a/quantum_espresso/kcp/AFC90/README.txt b/quantum_espresso/kcp/AFC90/README.txt deleted file mode 100644 index c34492c2a..000000000 --- a/quantum_espresso/kcp/AFC90/README.txt +++ /dev/null @@ -1,8 +0,0 @@ -LIBAFCC version 0.0 -------------------- - -Installation instructions and documentation to be provided... - -#added:giovanni NB porting LibAfc into quantum espresso version 5.0 -#added the latest Libafc provided by ismaila, library to be tested (today is the 23 Jul 2012) -#the svn update of this subroutine uploads changes from Libafc directory on repository dabo_devel on theossrv2.epfl.ch diff --git a/quantum_espresso/kcp/AFC90/UserGuide/UserGuide.pdf b/quantum_espresso/kcp/AFC90/UserGuide/UserGuide.pdf deleted file mode 100644 index 758995357b5ff41b6328f140c0de87520433489c..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 63525 zcmb@u1yo(Vvp0-Gf#UA&ZU=WL?poa44_+Kfad(&E?ykkHxVu|{LUDPaeR|*jwRP{i zzHc24`y`V+nPl%tW+uOcTtQTvo|%Cami*i9&)ws~%k1yp`eE6Kn278QEn#_ii5O)} zY|Vh?MC`9wN<@s}7S=!$$JeX10nkL$#K_LrgovLX)(PlnVqgR723oEq8@Jq#+`g?o zN(@~k<;xUswnJ9lPEGD;%#-H$wT8dUf=XPNfn2zzPJm7QC9y3tPHbuZCyi9R zD;d{L?g61X7gt~ls?KH_pYxK+>vzG+-S(=vfPW* z%xV4lDK1p?Fh@0=s(sv`s#9#+aCBEc4#x|;RQp;vkfp1wr&B&N))`xAcTznrNgFZl zxvEAoR#oRyq*AUDlSVdsCuMS*KV|sUTLs{wgee8E$!cslji2M(%fE~b#JE1D%#XUrjUUe9e6_O6cAEgu-OMMjK-#oRu}tr0Nckl21)~#;*GmbE zaqu1EEY(ei{F1_6L?)=7TV55hPquMBH`i4Heq3(gH}})D4I-d z1zan-%Ft_Xz9ihqA$|xv3+MA$fcluYBN&@K(x!S?w;Y&tbKBz2wGmU6qj%ckZ%u@- z0nQz#$=+bJfPsVVewxWb%EoMC^+JLW#Fq&i`+Y+tDUfk#@y;a5vu#C-Q==MXA5oZrGUauVHwAJM{mB$gqJch5UK z7%|G@))xCUxtd`tM?yBpxdpZHlT8hhAnkV#?xL#o^+#;B^cBvr-rvp;TCKU));C*? z;#4EVuH~PBJeY}DoAA&Scx5)`%xXkb7k)D4eBv0DU7vlIni71m<{c$C*S6s0k@irJ z^GdART2Jo^BqMQhu-E!b`L{|c@@lKV)_f&f2tS9fve{z$!sKeg@RV*-nM`adT8V_7 z$K?6qxRTgsgvjm$f+6bm^^8rn1DLuha#q!&;n2 z63vsuW~H3&^^Eg{K8hkNSD*~s8d?&oVHhM-@EIAa>P^PL>9c+XR??;i1A0_Rr)*J_r75IHKxhgyQ=(u3hf_-=EH@D!5oUK-33hh~LV423& zUS7IHl17M*>P-OX>5gfWNk3MnDBi$1?CO(-VCFn(qZaWJ_2t-Qc~|M`$g~*gihEsH z%pa5c&5@uM>?h}p-kJa5b^ItsVV14>Mr@?!92(l4b;%gir+w-7p=5#skYS+ffh#mA z4ja%u1)s*rzWjt#*l8zbwo2*lj*MoL{*?%KLB6?e^AyMyj&&U$RqIcX(sRv|vp-gq zp(eQsv$(jBxl71*58-#$P@M z9z@2)QI|GBY#NXI-1I^S0vf7>I6h=Aqa11>F-u*oa>_QuFu}V89MRHHA{Z$q@VENc zZo2O9AXS-If6z^zf`>)R?ydF%H@9D-O10KjO<3TDe>aaQ2^9!4N$g0DwvZsCvE!1D zu#wPIL}#riYS!aN9NNK#KgDaV_7fn06X>9D7kbw-!!v3I6PdiI62GIW&UO+L^W6Rl91ZM>VYu&HWYoJyc{8(ulY)DF96;D*4b0cgz{0 zFTBZpU|`=(Kyfsb0`alS#*$V*t8On7X))>XWkM~4DZym)6oEdE$cpt#%3_Hl69UEB zk4!F?YR7>O`+6{13mAtPUThWBv!_RhTS0;1{4z|16zu21n!p!A#(1$o9@`~w#=xap z4boUVJJAKAGUsnq1Jh7cgGIgj+f;JvdseIrtpsiVNpaoD+@U245$3re5Hv znhG*_PI3*fxJHu$rY@?hG#ivrIIzmPFO%K+40_#qw1*OOTSssuT)?%iz&g251bzVa zr;*H|z0>kBj6C@Ol$S_J;Io1$29uE#(f~Fsn)6*CnXDos|^2>Og zq=l1!&w<2L{l!8`CyeRbdHxXK?}^Pm6Da{Hz>$=H#fvYh1>i#wk+$5Sh>JHMxTeSF zi(s|c1bR{Vs7}!*LGIO5Kv%7%^1Y*h&mr?6fa&E@AnDC@d2gzrLB8tgrhg0XV_Y=i zby)7X{GhaKEuiq#K!J)lYeLFbkY$@Y4*mn4Br}}>rE12@=YCRPjXp^{=HO9IWsswKrrADr1FO94d=g!*-b@t%RrpHa4ijBBCr zG9F!7WA#|CWIHtH#?{NHovk>VY5jm9$dU&L4)y^0f)Grc4|@7m;r!<@)YfO> zPceBgej^eG_C`$H<^5gk!;K^fz!Hd>JMSjqORC#c1C7N*gHT5$|VbgAoUe z8nf|e*bwPu(SC@l2$`Eq`1uCDLGvQKJ!A&Ov0#)jCij8-F+@1-WPzB(7whMcr7;UJOk9ac~835+F2vJKU(+6oGcMG3%2Ty zir4oJr45;Q24v6(j<|STJZ&UsgL&)sdPi3Z&LuK}_)mM%TL~|faw~PLSM5R|#Yb2# zTF0@tnPbYs$RoyHgHzNnsKY&{%O(62D54J^uBDCM2 zpM9fU%rKwK;L$VSvHETnyzD(Tu>_~tNY&yVGVB^(0aW(S=e8y|hDnG2d`Y*e&p4pH z^U1a5J>$27u#pr6S2-{vt#J+XTTtBy>%gUP6vLIipEUu^plK3awAkO7&451CWfTW} z*qYYa+pCG4+o*T`G%YKf4y^K!*|bXIpq$-WXg}DImLE4r29P!2n^tSG^=$xC)(B^9 zo8an9={*3vn6d@Z1ka|qu%4v;djB6zB{@G(W@SKq*_+}6{TXsosd5#%n?Y`O4Zv8n z*s^7+ea<+Z!L#l>OIYY>e6?<{1V}rHY+CegbCUKC`K}?@zlix!FHRAvgy@YEvt`hy zw!nHwn@Y7FNyd7#p|QoGiI81~v8PoykgnF;Hx^UZb?DG1di7C!>c#L3YTm(YZu*wM z{T`#Q_u@{$*&UD@&Y1Nuao);D$C7duT5xuUH>0pUKo)fT1yaGX76z@HZq(9!t?>d# zSf_iu0M-=mMmY;wwQv9J!bO8~;p5>aqEYc_XA|vkCwHmodE7>2ws@q^ zpA0vv)+BB50eVcyJl;Vk5*bA^td9CJ#4(-?7`>6x2}Qyd>xIyA4-5~Cp~$8**y3Ry zle4WQh%}!r)VIK%;;;NA)H$TAJE`8Q4ecuGVspv0Hg$z^yr-o!Y>O zH#qX;XKr;}IMs2Brs46DE-Y~o^QB=clsrpapQo1tHY6Rb{W1k^c>OMxp{d|w)Vv+i zD)}BB0Bsk_=6hJD_SOIrA8=$&Rf4oe2u}pT<(+OoSNoGKZhHr5O0>Xe@i`ErHWE3W zsh(QuRyq>t_?G727K^reAsd?*6z~v5ym{NklhP@L6a9Uv3g;}gAEO1KTo?pIx5IC@ z=u=-EIBy^^Nde8~4WuB2L4K7v55E82#R7aPI3v}2_)o)>k?%dcye@lba$G6xWwm)t zl^HeyjBBXDd`y*HBWNd`R|=pj_o32UE>zvO*3fSI_enTVKP1=8lg^rJNH&rSi;)-gs*iEDxv@lp%4cfO0M`o;zSip!>K&4mt9L})~v~~+1 z6~Ykni*JamrHjZINySP61U|G~oc%!lyuZNFGzrAAsXJ&8LmU4g>Zdv*&Gn?01%-$P z_P(XBZv~S$d$s*8WJhGj=3sUVs&h z=XwL+nhb}WhtO%G0GZ{IYL zzW)#fJcN_GDD0rxPAH7#nURB#utK~Syv$cvzZ9Y}&{q@c;={@zE zGk$M<)()e*lRNPKyj}v*`DrbBMevcjYeI}~8*sm>VUt|6!S6x1c|7{_>q@1F zVg^JA)-XY%sd5ieIlhE}4vJ&*le!zUpto;!4I0wsNLDZ zknhL@`561c3H#`-I79w=hs?D$!H>RzJndTK6)I9OaBLv!=Ys+^($XO%6SIeG_UT4% z$RXedtck7hKThuJuQ%WL%^`lfvT`!9yiwnNv;2$Stm1BOLd2+GVD|gJqlqn$i1m*T ztz_b4=j>=?;zY#pCqu-}7WhhcB6{EvDBD4rUf202hl6ETfRE zt=(%W=0C+=-R^&?ePi?2T~~0lGg3AI5^25GEh9j@mzBmY-TwZ6yTqEGg_nfq(+^#a|d7@$>7+&Xthq03* zsz5t;p7n>PC+~GnQJai{GahOo6(^Ad+OLJSa@_=%MZ{GhxV2xU0uq`BaT zsm)B&lj*>(HS{scd%09Jm4-Z$6%TjK{T*TTApy_YQKoZ|?X^cGlQJ`PH=;Rhh!vvP z6M8Dw*6e77@3+$>L~y8oR?M!`$_yaK&>~4eDX|+jXIaW+IBz&(wd%CQZQouaedQn0 zFAAwYtVzKS@&a+8896~Zhdj8bF+|+=^E7zTQtXZEqBIaN4tAd_C%ne2P~Pwia0q-@o~<>tCT;$d?qt6p>b`T73Z<6-G1fz5CcH5KYu zt*B{ywN~EFs@w9DX$*1}CwIqwd+5iZXGt+6fgrArG(XW)uhbOgzS)@}c;hyBYYTkc z|0VRq`;M{ z`^of8JO2H!^IIq0^aQ}f_E&fQs?MvQ^tb=J2|%=`j@A25&tk?AC^vdd`3GVXmK_n>ux_ex7*rd|t2kv~V&~ z<*^~q^fDtK>{~8yt~Zy_j9EsaYM3-xH=3pWI0#M<6dEFOlN2@)^(0cidL_@p^EvE@ zc!M^4&mW3!5-xQdeD1yPn5~+$JX1=u_Ym`H#|VJKdx9p^68$C$=$+_oVhHMAht$!3#< zbSh&6YP{kehCC=Z8Q(>6ZYmFa&Sp)0J}6VTVl_o(t7>?S58+_ss9}slh+k#kZT!1L z$Y2x=h!{=WIex_xKu-rM>3M2l?j}p^Xxbd8D@Rk1>KhfdT>FlkjD{lPS#*JTOvr8~2;eCvI+yexGd8?YZrSrEp=Tts0U3s>a$3(CCgvBS`fv zXHwwJxG_+3{TLM+-3?761w9fQI<6MszT!qv1+LvYR%$<;QiNdtp0u)OjN)#dpJR9L zM+7XYGCStbN6hUjQ~(^Y;bB;EIXlH<$uVLhC`Z9ac}xs~Ng~<`m?1chZEK@H$2=5I zQE0C}+)Lm@)q3ATxCLWb43o?L*Y}AHvW58uH|Ja2)MUh{q^ zT4?$r+wh8xYX|e4{y;_=6sSeaw>5kDuHYmX{QwMw0AKBb5NI4r6GKYo^U8#GsJn^% zGf0ZMfn1noBS+SUUw(1+LBcB5E8K|T^|w$7!gjy+YDRCLd>l0Yc>s(ia>D&Ud8zZ{ zO4ub-=plEmOXkX#m?iOe#|$A?;PsOwr~3)_TtJHE`96P&29XughV#Cy0E0XM*^D61 z0W8|aH`oEIxeKy+Q7K9;q|Q08)z~V0&6=$Q#}fpdB28^Jf0fb8LAST67{Ch9S6?;v6SrhjTx;QhHq@{_ITnF1qX{4d}B{UoA z2pa@tg$IDEtoeW$)5nfL7QZ~~TOVa%aYm*I5X@2;QWCX3Nyj$;u&Hb-fel3y0$SpF$!r|8lcV3%~S=VC9n!!#{yhBl*ghx|OUItbxez+qL=~gx? z`K&nTeE+<*Z?<@bUjecEo2?&3IS2Q&_tzRh4*nd?AN&@}p=+|1!KM6l{Fp}MT3jrO zar~PW!N*7Oaqh#_Otg`rdl*hwW9$a^Pmp$7gTO$0 z2XfRa8yQYU>P4?yZj2{d_)zB}djB3$k0FM~5|}WCMRgXDOO|;E16gbQY0cHvS>oh#=;sn?(9m4$#KhLZv47LlI)-Y1Qj-2ojw#Dtg?jTMDWT2O94xm{^~@ zX66h|VEj*T;@Lnr1;WKrIva8|>zL$n+e5F(iJe>3@Vd8-eaT}N;x%t1@*;DgT&gAZ z%S;-n)%mH^h7K??pLifF6Vf``(o`fw(%z}u=ohQ(ZHC4tG7bJR31(6$Y8Ow zY%4CxoWWb*u+y^>%LnHkEF_xjj}kFhpyW)x6z)08rA*_*bIXdVV1JlDeDBzBBR6I4 zVc}T6jE8_uV&h>-Mz&PZ;#Z>ALqI@ZMM*~!+ zd2jX8k>ELN?~xAFVFmU6>~Y;ZDCnCXKJ8S=0{?k#{5_w&&2h{eoSc6rN9H#R_V2{^ zzcI>Lew)8<7V|$=`R}RoU(9mYe`l8eiBAZ&Gvq^!~dVnZI=IH0gvT> zxq_FWCL5K;gw+0^9$tspDy3n4xhuk0z9iLN9yrrm01c5Zod5z_v-LGZQoMqJF~*hi~^e1T9byA5frF`l#_P%ly>Eo50y3(sE0%9|O-Hz*e=Jz`^`uzC(bd`-K(FY4APw z=+qNF7#`lkl1i&evMYSObW(y;*W@CV{PxU3|Cb48uX)ja0pIn%* z1emcad7rr3iA7gpL~str7N>!C*M$MDrCXSS_!TEHL(={(_Tqg#0G`Qy%GE~iwxbk_ z3KEU=1SY#jwW1F5gXBVQD2sDsU=1ZOP=O}8M|t>z6k!pngwZNV`f3i6Qy+@Wb|fNF z3fxLGc@V62zIaH->2kRKM9(S%-%!u##~?Po)0FSg-AfHfXMI=}wq@u6AieNtSf6pd zQf+x3QWL(!%x#-LKO~;k6ggGePbsT`T%CDX;dxACGH{%0#;`gnnVfG62fz&U@TxBi zaT}j59s)8K``|f_$qXymqU)=l)2UfS7Jw4_MA&Bp@4iw%mCpMYmc6d4 z@NXi245$2T!9-iVMr!B!9QxVnPqTlW7# z=l}ZQ902COD$nxfn*Pc!Rkg>3}dUe`~SpM+VWMg1vXJ=*sQ2%|qeg`oAR{NjY%laq!!T2BB%km%F`%e%2KeYEZ>%SHMKeU(i z&CUCJ-#?)h)_*3sKS}1-&<@LMMCN~ncX+%5qN#S=w5!g}sN1S z*v=;lBZ?Gnkc<|jgn-8)2Ne=B@@EzY=j~hY9Vvp16$Q zWI_3L8!wa}cIH~T{KYB#ZjWcb^s2m7ZS}?FMQit-d}I$5?vRXEabIWoyVTVPKkV$L z`$#3C>3t7v;P-LJa&^75!>~A*7;)Xz8bhIi${Cc{2an6g&jm7B>Ee79*x)Jr_+j_y zdsda5%+rlJQ7xS&7i}kPPh|H_6*f)Gtpax-PaDqf=f@|?qO8TdY>&6To^WZ$I5`|! z>#zv4W*YiDFCAQ=mtRWeR{io9B_`(Z4OiWd)BGke93se>8%=dbPP{^GL3aN2o_DV7 z)Am@k)2Ye&lIPg1G)j<{7N%cw|=bIM=b8pJL!CU5!QRB zri^uY8j`1cw%j!tH7IpQ0`(4-%Ce|{0!bT78}4bcy79cD zwsCj7l)~}S6xSPG;su52X!8SW33e?1kf(Q%qxh@<<|OrFt>b3>CoC1-l=4x8ak)_p ze|5!26wK*BkH!|g-4W?DSZPLUniGLqpZUwXyX`A(N`Ue*x>~91#K@e(_5O)x-h}AG zNEY>3=T-{sJvobD=Jq&zx_hEgdCz|C#5)%3Y$Y96+0D;8gFUpdPH|yzk2b8iL9F+= zLGmtWm=(uq+6(iF$_vx0DorJM#Z{%AUIwloGz~llJfM7!&We)RDmKLJp5L#v?XGpP z*!}pmmi~23jnPH<>5e|Ey`wF$uS0NTE8VK%5~`xP!btK52_TI(u2Vl}Ij&JZhq6lF zVEob4Ro~mmRqKZrdZ93`!o9*=PMMfygd?RCq7*<1bC@O`A>Ji^>%mky2>0k~51AC< z(y_wavlNZ?TN(Lsm4%3@pc>exw^Hu!l?+Iw9G+B_Hm&2AQj|6;6>v-?g5Je%mD;C; zY~dYO5AY@$Mt$=8fVaJwN8s3DHe>$aj=bDVdMZY0y$|1r2)FD{>?xE(ADv|PYk%h> zpKjLdp`+GmXs==Q5?#%ZHF8935GFiEt_PLbJ8dfTB}$2)PsJ({{nA0~%&CrY#L5No zGR;&+7O2YAgJ{uKmL;4l?l%(*qzb_-7ODqZ<}JPtGD3#MJEXPXdKrD zoj#zw7og;&L!+Y`oPgWeyY6rZi(x6{#`Wp3^B5EU7o$9~YYDfu;*f4zoQh8>Nd=m7AIf`2@OBsante#kH_5sKlTN+Id`lW2%hnNfs)>PBFss?Au z@@L3dTy5vsz>L?m$Gi_;(>YUmOEom(mDDM}!>EHfk2ZOy`yFXJU88jyrHDa{Tw%zD zpi}2{*x4IM*+|69c4y>W-&7o`OBj(DTEGI>M=NA6-V+_k^&nPSW=0aYh)c3TD}!Cn z+JS~cl%@u>AJm$>Tj@=3J2D$!rcx6f|sJKN1NE5jr@qgj^4vK!BmR{Zk$I{M$RwfaH zUGEHvRFha=n3qwUQYF+hAc9b1Y{Zs25#1+VmSOW*SjJ!drZnH-sz{;aa(GEbKmrF` z9+@2nQ~<@=^aYVM6WhArGB_n?0M&qL-(pqzGCw~zCrjs|r6iRyzvw1QW@2KrP#eAe zldn-Q7(GK*Z6Y<8jY8s2vG4qVDY%9<0y*lK_#79X>@tQT&TMk5n}VQ1ZLU%djaeQt z$dnku=+6m!(pNcX&pB7n!tIe&tQt7wxbI&aXX3p{=8fUK1^A{{^(22nf04Ouc4Fc) zP+`)juR<~O9}mi7ve$(vuTktif_Lh5?q1VB+bLMncdlyAdB=3XzGLrgr-K%rt`^oi zx{#uD3??#m=j@Dno*A~_c@C3!Gq?FZtj12T98qjq<0?#1nP^vxz5Y8yMgmgsFgFv< zRvn>ZBO!E7B(V}d1T~SZ-oZpq8Q9*>OC}$OJ$fQ#N?pbI<&m`z0(FQVH`h=eej)rQ z2;JL52v?|H@6kjBRIMx*<8cs}FG^v9dx*Of)k9q6Aw0b~we6R&CBN26O3?@@QA_?aHr_VUe}Q1Af0i0Tl>%aqp^Q=|R)gq_M4)Oa zN;qeSXDIFR?whZwcs4C6D)Tlrt+>s%$krZ=bZ4&bE-30QWZS(SSD8t-3Z!$q$HQEu zW2wz#f>D?2s+F{jfVf)Wj1rJjd{fXrxqiwtD|;`q zjRG4FaWAPZ`NR5Hrfb$pG}11-IbFWQ3V|r}N`RFtN$F zsUC95R?--7#2+aF#buBPfW8#BFJX%B+3NUZAAGIZq;f6v58ox&Gt&#!iwdtpw^n<( z8Lsyha$>s2Mj>pSp3I(z=U4DTgmr+i^b)TlaRWrK{%c-;(F&t@ydd9km`qRKEbw3ICNfLQSRi6DF_a(m1 zR=b=Dd3d7l@{MwLV0fA|Y7G{PXH(8&V@JCDG5uQO*h*B9jH#(2Vgl)>ybq(FoDVy{ zR+2e{+9cYlGKehu~HYdMnA)FheSge3rxUnGg6X2Ue+exHtf@l5*EosatNn~MMO0dsPcNiw1_z7^P-%;1iGH$7@W%D4>VY| zPEC+C_0@T*TE>p=&u&Z_c5#JUE0Q|eqU=wgAQr{qAwrzADc3J;%N6oi1oyuKt?Ill zny{PFfv0s+=*1rI!05f{<$Cz=cEvsgrwf ztV9<^pDuHr+_wdyQC<^WJQQ zjU6)BuJ@%be|NgCJv_|Q*2nTWJe+9KD{uvcsPf^y1r_q|Z~0iRK{2I0A>mq_cHgKR|kEy$?D=<-2 zCRCaz;ByBlo8~35EPV_>M6r;DwG7=qASe(pr6t0z(k{6c;RavxG@qGFJrP?kiW_{!b!%zIVSG!?DSzK7ljm=Be~ip zkwLb85vvZbKF4syG}{bqNuLzTfRh=8#;=xe@FKf}mYh$R*H>$kPC2QC3#X>RPTLGc zUPKz?x@T}zn{ntU_8#WDhbjNG7qH_+$op$)@1#ATBuA4ZpSbx{p)fLcr(d7rc0;#1++Z^WX_JQL>C%P%F zo=BL;(7WfKK>zsZjP{IYeFD9W7k$;sWm$XK5Z6u_f4phTwE7x(ZQ9I%0Tb(M)LE>o z1F=?~k71N-2+xujM?MC(wu2BPtAPXgk3f6jEePU5oui3HcW%1Y%Xrj7mgJx*b1yA2 z6kG^uR+b4E?TIUBh>kUM{~92!^AoZom!VKF$`(Fx5h8hA%I7Eo0SVfvGjsLEvcl7k z1AJ_C$C~9sRn{*?!4>6m{EIH%kt8}L+h>wGn7uZhRqK2wZBg4gZ8sQ@p^Fv5@V(*z zH`p09W2D-aY1Cy^s|;nB*D&A>@x9z|m|Nnn%}0rNiR z0g1z2qBA_Gg;Pn`b5N zNd97-VtlZGf=NnqYP`opt8*cimL5GxH2E?hIdht9ha!F~9fc%4OM7 zfUt~LC_&MVz<(w-`nX)Pzp(LZlF5hvV8DLp7Hm@%*gc?UPFa#TSrciewl?|elk|ug zPuB8Hyuo5vl=mu@$H$RE{D=JlT)(AYSLgDUG^XZ0a%*r~lw$QT@;nE0a$8F@YUVAG zu%=<6ruR@n+2Xo884??~qHE@8qTs2~>fIn_ARSVp$N`ih!z0-YBYq%GP-KEDq#0)u z{tT=>G5y9g*3v#JvCmCm9g^!zbkda)Jk5+vnO8mzCsyDe7=l*QdhG)Altc+s#%M)W z?bFBEms4^)Wi#lOw}Vf7U^>lwXde^S1s`XQ>3=!~Nv4g_qF32lx+x7ylf>IMYe(j* z$Bc39#h5-HRH63jf3YzXawSRH+e_6MjnrIyZW>`PqqXel8BGzggCzbBjSH9$F-5pE-f{y$ zy^ej(uI%gYe+}VxIQIrvEd$&yV<&v(Ki$zs$;gIRe02QKdrw(5a?Oyo?lxU>6*g)5 z(fmX!cdL~CU=q{=55$L#^Ed>wC+kjv{${sN59LMqQG5q-(grrwjrL3y2Mrdmbi&eH zMCJZfp4>Zhn`VGLGmSTj=bBqoJ*f^5+~^z!nr^YG``rV-&yh3jmH`x3h{WOCVUT_c zUnH?Hui9?oP`BipaE7m&92QHVCK zjjUig1x5|yv@?EVp9zNKQ~xkhNhx>fp9ZY#X}kIFpJTKxLd8htPc$|;cibk3y8`$t zxNRDmNTIL4TNikG876IWRoYT+pnPCK64^S!mbTYT_Gj?7%AV#P*XT(IckT~$KWwo2 z@$z&Apzo}Ay~{c4@VUV0cv^aAXSeQ*>lv<=VQiZ(8Aeq=V>$WOoqc|Z76D> zJoXj&PH+m!2Rb!vcvg_&Ze%LZz`jSWUa*^gYTwBg4y~ z-BwhiA$#Y*fK{*7fVi<-@TI{MX>K$(j0e{{$E`B8iKKD|Nfct18k-!mpwsMA{HV?3 z2#*$+cx;Vkz(xV<9VG97>mruv;r*83E>Oz>O^$trCQOl}r8rP4qq{Qm^Y|9TIRs_f zXCyGCm`+;!O#zLU9XmpgLtmHIp>a8?aKLGLz;?8bRkPe1eR zhkq%x2fd$oj7;(5sFSYg7h|fVkG-%P(L_r6WnaBNf4N7zwb-Hxmu36eOlD%qsLj&f zO2iyf8nOz|x8=~@PvH@Pe}z-iX8?T?X_)&(@!Q5fqz&EQy31an`%SIz+1- zQciBv2`+LapNuNVMY{2qd*#95HNT$VW$P(qojy@fy08D|RyBCNcOT#%uh4scGQqa+ zhI@AqnimDbg@=}PA0Y6~+FsvQ9 zdc0}6Xy(S57`b(#1AS-2`Aqj9x|6gkZ=x$NJljiY++4`<4Y#Eg{yar~;j>D7u-J@D zZ*xt`y8@)9LE4!zuZLk;1&29x0=K7#2f|O=@4eHm`(k>Rl4cxkVVpD99)Ikue>z`F z96Mu4buv!ih+T(XNw&3JwjtOL?E6$OzmeR7bJfO?BNX-F!+ln zbJ&-*mK*Y63(9NPN(*aiz53mA9<9Vn+yON!JwmR0{8FhbCb|yF_J*Th0}UOOBjYqg zP9F!1+HlAcvrW?cK727QEE)RT2C0&aJ}1T;vf2;o*^g))b)VuAmZayJo4l;DMuoK0gl693tUQgm%`q0x=e+yR&{~%QY_8K)P>3B z`|lyl2>?+`yt~V8OFCM#<|t2~*BoTiCCX;r5V3uCI$%*c_yTt;wp0^V$0ZBI zXb)d^^PuQFy>e~42!49MEQku{u4GeH^)!ajxM;mON}=rHlLAeZ!ZhkjRq%nWNlcWw zEd?`X06_GuK|`j74(AlZ_@}I?=Ei$*H-War@H0g^_$}~H5C)u#EJeqlE?x+RID41J z8)h-*$IOwDFt&>d(B{U~cNTptpEl_{y1rM*YT?XATKW)_uSRF1n%m?3Qcl<$_R73I zU)CV|78+R#d5>sGsMfC29vGa*h!dV3vpJ3(qsO+@8Q_L5O^{{orjY3fssPuW>eVKQ zJty8%$49(nxM0~Jp|8hyZ{CcOufPrqBOzNeYZF+eSEK~c#72#Xo%K}~7c+GW zU zh}gLPQdpS&)XT>41`>JQvGR(2VSn4I0?Q8gQ}^GJ?418T{mO;q4XE;ZeeI0jR{$3g z%PaRk{FyobaDKhQ0szdv>tttR`NREp%UEB#hxHZX@+Qq2FTihE-nji6JpcEeo4**1 zKlqim{(SB1zknJQM`x2igg1cyAL4)WSl@{M_sxR+-M6n`rr*!-^~L$KedrbI;phYu zF*k60eU)C1`7rn=@d^YXVidD|J=w#;_7(FZYha{gXJcUdHwX4#p6Xxd)xR7Q!uk)A z>MyQ@ll|>I`5#XW;f8ZlR!!YsaXK60x!GG~vx#G?~PeyNFvdJI6p2GVB5~8ImaQ=V$fUQ zTvr%~S1naOnP58~R` zF~!U;>zaL=IPcBc@|Q>S8O}!5K4->Y+!%CkJEmjc)N*P#r9%#OFmAF*zDQ@_@#?kk zmkXuD-VA(#xOAT}A&kH|B@~A{>4fIQw5d8fyjg;Vl0HR5Bp`U~BRUN8IBf^P^fX;S zbTwVnJGHFpgty<@$9Z_*)AdB$;c0EVHdp`LUJe(gb5XI$pfnv+YYQ-2GaX+rZKzM1 zZcHuL8nxLY=7P;Pv0X53Ft%PWuC`e)*6|5jYTQO|uufpncFv2THbg^9ljzd4>N3 zEJ)gVJjb*#4a*^%tp7y*bt)RG%qPDPHyQI5YDT@}y*arQnjN`0xnblQosYrFgEdw* z*eR)ORxSO;4dz!+dE!XUmi6MLYE-I6f*6c(rSC?Hkxgg*4{PrnBBtsxI4Rmu=g&ZR4w6>#V)jj(yHO-;KDDk@4o7Ib+N*-+c40-!q<3zhu`U zOVkjj--J6ByJGIaR#7Q3SGQ*i9OR(px_VFn)=m@YzBXsuZme_((GMSx#WKFi86anw z*5(}IE5zGirDOx4@!h@>HmoZSV&{DQ#j=+5$of^x`Qb(Nxb7DDR|joy5fWW=56g)DT8!{J_HA%$810qgJWqjaS#_@rV&x;hK+5YIN{tcU zneTYRRxIG}XiSZi*y_i)SLb!*o!F118{aT5B0{f9Mmk9))kL!ir^T-<1KX*;L@h>% zgl428z5mQ@ticRW`Dk$K(~ozUdIk%F8s%ceD~d-_)DTtMF9Nw&4v<$WhMVjbr}+_v zFz8>Q+{VO)u1=+OhniKWm`G+uRE$+r)Vh3_vf1CKF%0yhRb$S+UT-KvSN0 zM~-5!3k;~Nx+m9hmxstM!zJJO<)|E=0od!1$%L&^nu5LB{1>y4-pdf^0DDQO8A)5$ z^WIE?6xjGN5?hORs9Vmtgs};n>#-tMmvXsTGZfQTAPW z8s7&Ak2@t~k7(?bHdN6a6#GeQ3Dn|pewL&?7Mv)-WPrcMVhrRXNvqn4cUFSh>L-In zJ|QUXE5Q>AOECmsbnmnYqLSZy2`DrilbU?h&FGO^k_RjS3~Y0ir5}TA3ckis`sUj# z5S2t+pGCM|WXH6?>NA^%;!sJCcI|VS0NUkK46)-IV@b4v0TtiL^>WBX2huzsKqqK! z1}2tIIf3EuET_$E>SQH_P}b1`q?knn(hZ7=1*U}!wg(@WweSup3Ai(!P>V9o3zqgE z<9`o4q(;zt6ht9VjggKlE=eoKh4!n@2dTJ!F93s5i9R5YXA>pJCW}-o6^NEhsYyI> zW)Fl*0F~~chak2T47B=LrwT<$vu9eA6d~|OG>}`g7`5jqe(&_a2VMftm2>s&5Ts;B z&vYTc0U3n^yeF@OmUmz_G7g*vd~iz~&iOkY9Iq#A@OO|PM1=?hp70dafML}Dcs?^g z@`DV1SQvqqC;nQj>-0R-CpF>{;)^Wx!5R89fVNg_N4^i~dQ=*}+VsY$x84vlOtzUR zw`qTu^D-28k_jgW>3Xgl+eBc{kL?H+L^gh~gkWSsNg#MKPsE7Vc2Os(y*j=8?G(2? z<|p%Cl*L&hSYlf)VIalSM7Yz${wR>CF_>zyST#8g#pM8~StN&Yw_N*IRvb!cJmN-@Ly1B|%9S{R99C&CC##`PRz~Vj{21 z1v-b5<4OeNOg^WAje#L_6QN4iQ*3{1x9OjKeqsgZDX0K~xoJ4_NM0d$L5zwNmCI&L z5R96EsK~;S+j$X49_?&&fQCBmvBB!Con2XS{6?ACkkfrq>KBip$np-#K5*By$W%+d znHd<~i)2sIAlu($8^tyz3G>#Jo{Izs&eQcz`=ZepH^ zeT|-~W3eR&xL^|$-LD{t5mc#Dp>EJ$NORW@=Fm|YB0L^bt+m;`*{_=IBsSJG8rEle z?nqcjwIy0(8c{d=N3I-Q7Lt2|bzUj15T!r1B~Agj=y?DJS-PGAvub^U4iWX5oscyF z$X!@wj7D^YGsgqrTd$!O-tXW-S)i+4NwTCM8Q?%$NyqSNbp+8$PG(o;gvzI0p9pROI3DGYv2; zLKpPO)I`_P$T;8Ab>Hr#Il?iD22%sau1Onz`1{b&AR+sk0NVI45!I^HxuwmrE2B)|Nc?RyDZ%%Fo0dhT$U$&kVpY~q>R ziF&d2&ZW&3VY2D3vA&l4mM5KJNKXob9&Ai|mfrX@xM)E_1gaboH z2T&hv^li6ILeY^+F9};snQZYUS|1^4rCUeW5>3U^f}OeX0Q|zQ+8IL|zP=M)vD|Av z!k=c>9D}I2`kXs3(ZpmxH?TqPRt~FCBPevN`ZQl&!Bk5;CQG%#V0>H8`bo4igITBA z&xspX$SBM~ZlssF;EhYGpQ?SQ=$0v|DeiF}(7^C9*PK0`YxxVh>7ELo_xe%fp#uDx z1 zy35kh2ZpDclAEQCqV^$U(D;}!8=NJ}K4tSDbL&#umLHhR`nmLixx@P|2|s04O34>6 zsQoc>4!)c z^u>13AK;9aoRk#Sr`C%Qucd3y^03=@pNs%Is)43tTETzSmaU0RPC2|BU1TD$chpib z-1Ag0Gv;c#*c&IAHyS}wF1y)PoS@8rrv}cL^SxmQu*-E*MzK*0rRu#q#icHlgG}Jh zK?g%65}cj3XXpic`GtX>UYNZ&wf3zcg;B}WCnsLJOwhJ6h##zi|w%cn4zJ{?|%SMoo#2C^q z6Fy1O3lEOa7t?Qi;zqnxg-$Q-+jrc>f)-J5P6*CPK&!FVv|2Mv`&rZ7%n7FWouYe( zAQ#tDza#*vj*{0{nK;#RC*WnP)1MAf`i~B}OlyIX?BhqB-Wj*ij)Qn7?DY-zp;GRd z8?Q&n$Q`&Rz1D;E6@r=#}nCU!LXlll18xBSq53D>HK#ABEG`M=TcVPcT}n>V2g$^M-N*O77ge z*E?D09GS1+BR@##6s#{_z^5%=b*%uF?Z87!g^dFz+DEln-Ay2)BcK9xOp>I;PyG}a zzf%sl=0FJ#O+K#pvR5g8Ls1(|SWECv&{1UzCs7DFcfxaEkS1#`Jp>n)l)DWY)k=mp z!5cSZWIT|JM9adO44tue(hBa`&c771Bc7Z(1Gr`9+79yUKA1v9_a{1`?z7T855ZRK zqH%P1@oIE?b)+>l?UqBLWZFR1?79}ToL0Dil z@eBU(M1223)fCN`y&%QDK#JBn89I!e=J(_X)Tr=ezb+h zCO6OdY_k>3mIaHL(7JQTd8sQI(yflK83oD`1u|z7fd@eZ6b=&57g0WyL=~XQK*V<| zg)htp-kX;fVK5U70tJV6e5qn&0$TGT!^tz}Mx62PN84pG%^B-^wI%IcRP*KThm~Avph~5et(|mh zNnuh&T*?$%ck!s&cMDQyQs^3K)BDij663|M_>#_(TwqWf7Qyx$2WPA z&sxuZJJ;Kj_zJSV9gX`|bAx*VkK_d@v*X=v+q>#GexYjr>cH*7>-eZ8cS7zNa~6&V zqzXiH)Kr?F;fJM(yIPJ?n15B|GLyfmswo5}hM?ju9Zqg-iM9h05w>pc;{F#NBZN7* z4vR_lwz7aZ!}P9vM!_s)MK;`qotnxjTKac88&4UTv*YstvWfm#8kDuJMB8EEosfru9QsklLILT{_sXoKXl3$snL+QxISlkm>0xRLwHN zO$PyVH54Q6q&wC5R5c4sp_R)5VP?8989i4D$EH`T=oKl0!#o9m%!XtRVOc1Ark|0r zCJRI3x=8=Nwf{8^W$3KEc6@sDl9& z&}?)pcEAx?io@VcU=4H{MQEK-KgFSY?yw|Dfw}v{^yB=t5wW6wM#c-+0O^IorKXXZ zFpvW}(}0@NKC*YmKRz5TN76Vu(Mn9z<9y+&V83zEANRdBG5$*TBAAZxg<^@mSD%|e z88`)T5T#nWOMR)BS`GrN%_)Z22M}92S+VUpPK4r19(^B#s%+&QU zfB7V0X~CR+?}n$B%+8T*`w?j1li}D|Ni}JQDiN<9-z`5>y~-Ylbni^^Rb_Bu$R$^@ zzoFO`+q6D~gh3oBCQE+U2xyfQAs#E}(hk$lDNr(t9z=6XCsZn1qA88EM?xbL=aj?wjm$Hx{5c)BfmUaBL(-9fweRcU864M+6#3l;)X;VB z0vJ0`1KllLKaiY0?XaLW6ZE^eE?!DBT6g7lR=!(1Vs)qwi7K3OKB_Gi3ZWg17@rJr zK)j6geZ`704dwP#?n8G`Ki!J{4=n2wIsNx6i-qks%lfQJrDOecAY=G`kPSwks0$Rq52~iMs^kg#!qJWo56j~KrwwXM%K?0{EJQfr-8P<3<@5CaE0vma zceNp2a6NFZ)akGS@XYeHT4m+)V+HX0!iEDEn!Lq~a=+Sw%= zRqAB^p%x3@d1A%1xN-5~_4(G`x$dJPiwVQy16r=Da`A#(;`Jm$B--G0GQMhMB-`MF z=x{i#7@;tU@`jjrlQ^*E-5LD`kukO+v!US5`(_y+PD3U`jpuxy3%}KL@x{VszY#pc zo@_$%J&BPF_wu!P<{)bBeg-p1CPVF2_3UO!r;E$c>1q`6;F0J3J>%wpR?BI>%^PT< za6*SmjuY>~|A`o)#{ljPhJH2ri%?8N$sp`X1_@IuJeaA+C=J(uMh#750BngxA>cLq9QU;uN!Y|WYhGs z?-{+DS0g{WzqOBIaCL{Oc>8*buakB}=M4I7K)muq1=&Ds@VQ?Rc)`CxdE!m%bab6P zQoN1@az1|5ELQC++NqeDZ4sC;b-FSncfTGKBYS7Z68V53dxJMcW)I}hwIK3tY8GD? z{bq+6uZu_O9V+g^JDRw~JQ`>sD?h3Cj&<4rHQ^0y0Q2brJ=T4A{Pi2yp4h~(%oWry z^4H-VP?Y{Qa_Rja;3hvrA8EsOI(`j+x$ycv5H6zkF94`T;Wgk1Ka1~B=6kAra zR=N)^LqOdtH(TlKCzluwOz!J)(sEgS;;!RFQxvKBo7JBppEb)S_0PI0P&_8d%%ND?B<_qFxPGh`4a; z+3v#T&+GcQ@C#+?J*qhhhAW8{Rk_>XzUkZku|k(vJXb z;TFI*aixJUc_mQa=1%Ua(tCbTP1TCb<-ni)3RJJN@#j89H5LU;4TTrAn9<3`)Xkj7 zthw|ZykF zUCTa=gX}rlYBI5O0=~~uKq7~x$vagWZ(T1hNk64Tt&1hTwG<&Xc(!3c_OS6ZSzYWv zm~OKNW=u;ve*U14NIu9rPYyf0F3@lA!zZ!U?A@jTtxq)vM$EsgqQXnei_arspwc`Bb4O-R<5FI}T?F@j-8Ri=C=bNbH)`8)a9@yK4zo1LbOWGa}Z z$!8Y0KN5pHELIgEA3JPQEK{^v9q+KQA zNoi*3DR=ux1Y%nSQ`MRnaE$88HsZzsNR+|hzhuC^M9|AQZ1P5kcY3e*emqZ7gv5yF zFK^8I(S+6)=OCa_bP>r`Am+J+p}obT80=A>P{&CJgfnMZNK>QL+$pt$SGG>HFk%f9u(gz_T*Mh78uHyerze9lIis6RD~|_yJK8HT2}aP(m!T z>VC^W()>R9B&ywhb(IV3#gOHOEJt`AkE|d?!szSCFBl&7GJ(T!|0a5=ce(ZLa?AX%WiI#e`R*8ai?ML6f@;9|Q{W#BW39OV;Fx#_gaK3+Hgx1= zD}fAq@SPGbe0o>9*)?v7^ZU4Ao-W_Q7pDig@5QBY^fMR85lfi!3+@|)PS?|YD}f{^ zU(8#%V9K_4`vee*@)M}HiZirzsUEDXhWV|gIo4K>kD;2^O_xsKP9T_h9a}M58|2UN z`qz-c4ImGb>|H7?k6Lk|Y|}bf$~%>#z%OHrNUMRxhC~8HC2_z3Nzbodvz*evDgDn7 zm|}a3$H!G53+x0Qg!{x4se8YhPFSziQ$b(*=)yt>Bg9u^qQ412tv19Rr|?1MHcQ(y z-=u62){qsu8(DWE`O$i7M;E)!p!!_W8&+mqR<*@F#v9A{K%~&>iwmYKE&GDc*y7(L zh1N&9DNnrhj@3hOi*uD5w)k!J+F*wlstPe*+paA?N=n}>$qA5?2u;z^&(&c(;`MfV zIplH#!s8U-rJYV*of@w48t&%m;}LTxWZ9XwtC{8;xmMCD9y)N4pW^+vHzqNcU9M^3 zAe3@soYK#ru{f9ogGWS6I05XYcc|Kvy}9hfamJ%qMYKrcjs0QdkcGGkjI&yxJ%|{U zvbBW}aO-=*UyCM^YLnkc%1&_esrnUGb{e#V72u3N!N}S_YF-q5_AjOp#eaK6=k@Zi zpY2w?kq;^cIMigntwzsmF}beEMj`F1%FL6`e{~Uq3eX&@u!;cXf0zc%rJ8=|Dy@7S zDzGV}ER^S$Fb%y|P@zOFARPC;Iq0~bzUkmy&-^MS3+sRb3@~_T(_YSqbL`6&py|gd zfFqqvR@&q8a(@g*0(;vcOfO5J&m;o~_EfN+q%kc5CBHQCCG-i5rRrW&1kQrk)YfFcd5@J!fzJ|%m9JeD*4Y<|GTRLs z74Ondfd>=mYfW9j4Ms;Mi7>als5@!m{;A)ed`}h*eH-9TGdDPcNrW_FSrAO=@(5IXuCjaU@szj6CN#Lq{RA*Z$gFpi4| zHqPpPsC#{NPK?zQLM1q{r|757Vwr(bjl2bmVZXh{4g^XY0K>{VFX!_H)v*u8kR}au zL6C8*lMLX?4Ggg1c@M^W8qb{);tL(&iGKuUT3eP>IJZy@7wT2z%Fk=xG0u5Gwi=x5 z4AM^jMF`pSs^&e)y#qw6=>NW(Qdkv}V@H8VMgbg*RGoCDUP5+QqqRrVx-o|0S6wm0 z;G87+C}AbSJ;9w~bxkL!7#{|5i~~EUcJHLyaNN8=0vTIy?8Wu{SAM~wRRLrcBk2{k zV>%&U8<`I!2%P2Rud_`P(JAw}v&Y5iV_T{3YX&&$X19;R;(Y{hy;&Ls+GmqpJr25p z`HAEw7W7DRHVMB^Ut}9-$7}tY@VYidS>iYZ zs{3N*}j*P-mq-p=_+MI z=e?A3{5Tl^`)ZKT+qbpxdhmmkh|dpL5R+$2<8iSVnz{l*kGi+}rw}R?p+e_km^d@U zTo@Mea2P9jk}@oxUt5Jujn0X6w*aO1%~O=2s;wFW7zsF#G%%`@Ho@D2Csbln!GHS|wXQWJM5?=~=4<6F#tXk9RS+(;VMK( zor^P;1s#SPR8~~b$79CR)okRe>L-ZTAJx=zE=>iIs#B5r-kx<048{8)S8e)B=hL9G zpxC%px(J?t|8Yx^l(9w0mmbT$K?8|5US+<`X;W|}@KvSn()C>&g~ZP5se@kDl*rgYQ|IDF_Y}MbF<(Y( z@Br8E8X-+Ni2KJj)tygGJS;rTcTs}i4O4n{*0h%Lz+3yNctDWLQAR6royci0fcf>m z+V-(n?FDIyQm5V`qilJdBS>L%Ro_8`4775MYsS>b&)CB5zqW1yUXUvR)F|IGTb7um=leEFsrkyn+R zm*+!16yWZU^pn5e52c`jR0|TZtHw~Lkb0N_bXj)w5lQi66+G51kp}S#6=Fmno3)SF zq2DV!a~`!@1XHrX`QFENFBeEFfZ^$(TIW@M4*0EaP7g~LLqZ3oYY3o^f>d>MK(q>z zHj8w{?Y<__#nlzoW%n~422*Di?EObOc>P=U0=6TtXrSY z;H_Gp*Y=hwTQ64^+MiDgJAgirFKBQ;KCnf@4}}k@ak$mF>-%m?gCSal`&LK^ zt05dZS4A6oxng;KxhGb|`JN1q9vaYyF804iB>XWXK6CET}z|}kPMcnSrWOo7}5%`e$+5eb}$GO67y|ujX z^d?rC_?KtrA?8wZ;69Tu6U|{B{n2TcW`gmdt);f+}&A2kw*r#KGwbIocI@DG)sC|IY&F@wS1XjLSVJ+gwg7QmWhcLgJ zMeOBT7=y)s%izPF&=R$2oX6kZwGzbuj{`Ou$fB8V+;8A76;8!IGY_!94=#%ZCjs;A zUTOrPmp@VVSr3k>F(B2sKmyfM@2vkUkS`6(_ODe&5uCh^Le`y0%k&Rolye-Ga(wT7 z|0U7Xg}?Ue!$KGoQkqF>Kb>^zaP=HHIAOoAr}#xCB0YReT!bks6cvrtk{p(NCVLqby*{2@sAme)Xv1zot0xs)RF?b2~q_sMJ# z6u2c{g(H7jB#gNuEH)`Gysu6Yx5oQpoZlPx6Us@nINRAS=A?nn!q&M!;Bb6&Tq)rw zgQzsbN6*2DpsXRUhz1$5Net0cNB7{t`+_nMzBE6sSz6&&WoMc3=~6hKoF5F00Kxsp zanAj!3e=1f;%os^asmM(_F1dxidxB$M1}$umW6aVAQ<>l*BN+9UCY8m`9UzIB;V@w z_2LlQeYY=h5L6?Cq$005i@y#@CIBLZ4!Urn4qYq#2y%$A#84gvjI6h~De~cW1p4Sf zU!Rv08k!>`mBKB^D%nov#noBkP+y;g_?q1l+L;($!0lkon8c3tHKBSC5>&P*0lOd( z8A%4ekrC}}V&bNXy$hr%P*g;1%O8xb!GsDfootJ>uLm?zhFv?mNvp@avC8gk?pRvo z_d9DXrS4$;&pm8XH=M;(VmCHF9CUXEt9%cY)u|o!@(k;+mn+IFW4~LvDD)r^vbJk! zT~=U+NRjC+TC!f$zzV~Hqc5+8^jJj+DrC4*UV==5-#!QXD0N7d z>;lA0k)~PiAAvaS=AZKnlH*&wBmIvj`h4FNj;TnZRhJ4~3^ zDBxFiduYLY8~&|~Oc<{1uf5myA2*!nYvS5DzGAIy?$8q(rM#dkCA-eD;L9PjO754N zx{h&W+qKyWrT9FEQ@UAVdwH|7LtJw6ipKip_6kwPq4@J+{P1}vR@^YC?5xxuM7q2Q28UgZ?^NL+Q9qpqK=Cn44JzYW@mcd_j)S652 zktOC7bzUGu7TQHL&QsBzO*=5XQb69xxV-c{)3U7oMkWHQXJRmD3$2)u5~ zG=Kzxr9*;gGTYqtU;W>Xjw}zTQkypPe(Jo5zM^kBTOR7xVKy|Va0>V;r^K0#=Mlz} z3Q=Sx#-!%AQK$6F1t2?W*kH3slwJ1fl-=PY6}3%)ojExO1_DOOKajW#E&Q;uB_-p& zyWbR58W!ST>2STeZt8*7qChZP9(pUpb9)@ebv7n;<@zcvP{#Fs*`%NXu70EUu{lKc zRnyhViF__W!ltdi@<`N1>boM}%^Wo?S}DmcBO?>(lxhZ%7@ib6D|EvzL!@BDs5QH9 zF-#WIW~W8Hvej2%VfU!~7-Tli07@z^O2#v5Ba z(DEswR{`f38qFVF`A_aD2|zBHQ*!IPZZK}RdJ+k30~ae;-=F{m8TI`&G8=97o=)5y ztQ~bv?&%ww{2$o719gZm{7BmX*>5+yj%Dtfs!#yilNMtp`>fFEkrOZmeM3Q-zGu*k=@Pe0f4~k+nqR82{OHzf<1((><27n8fvOfHPHKq5d&he8JO>wIMsuw;*DfnZIt zoVU|y>K=(W2MRj>LPpq=z;lVG?cu{<7WraeSv9{M?8ivU?Cx1Xi^deth(X#c#G`;? zB_(R)P4206kEH6#ju0gdI;co=)!aIkCDRK~1hYPm3?fX@N0lU$ZTe*q_fbH!nK2!K z+v+YzrN31VLc^1aN+nEaOM-mU#I`dlTr;?CQ||Wan3Rh}8Q0mdzC}?HqWDP4!JIa( z09#fGYceS&MC8k***;^d-+H&(FmU`i5?oTrCO?})=^TGynOcjLg$CdHZZZOvInx~m zt7HBY+g|h{uIf_F$cK6^Jcj_wf$CEbC*HaSBlLTSZ7AgnhKg?i;g>M#-d6s#8m3Ak z&$)VWe_Wll{qrAN(qO0w++D?Q2WlIjP80qM z73&fggrd=-7iXV343tSa9_?SG7kw)MXJUv4RtW7p-MHv3tB9NR2$kHkua9hQty7KB z_B+eX@QPwu#%$YB$QaZ=*t8sJMNb_?3mL!)=OCT!ZO*B!JCHBU*Nh!?d5hei^zu{b z_*2`_@NCi)HCm71_yqC0{lgz(Z@J?MKo?=d>Zjw(5PR9D@LaSVM zAa;Gyg)U}mv6qmAA{*M$i%x(n`yXXI}Y&|?AohU(o#}mK|*KK zl786%>=KISq0~h@|5ie_%~4TDUTu(vM!*a)Q`CXj?FE;OKWe3MjfQ5608l*mR3t6S z0yJLGMT=#_uQHW-;Gy@_>0!&bo|4}V06IS89?w?x2Bph$jpnOwntx*#ik<7L2zNel zg)-`j%_jH=U^jDexS{lQhjqQE9rNur9H~7oClOyh6Gw%0tRy(6WU3&+eR$Rches%w zWz7|Qfqa7N&M-_Zn)~`P@W$l+Vuh2VrfG2r5e^fr<)hvGVyVgC1;rtR>j)V;=@O^q z>exKf6O`BH?3~KIfUKd8iHzH}u?}%37)vmB9!@>?9;|#2vz^xAc=XpirW-`tl<5kq z#fo};92jms@EqxE`D&`U;@ajuGx1G@|1Ysc7emf=On6rK-F#H|(0*cT$n@0UclDqb zyNN*0a-Pks>G4Q+#n4&yC}Rx+9C0%5UH}PWrnB`8v?&b$bF9lLN%QS_5J4fT4$u0S z$y7jh&ZK1`W$vU+Dc7%4dCUnB&NUD>+r0Q(^0n$KWdg zi7{<{9JAbs(F+Lsnu(WdepPY3NCjI^ZYa3tImqPom(Zg1_r_bsoFohL8Z>yBZy{}D zn#}IN4_iJxCfIx?Ubq(R;FR@H8Og=t(#|nsb6vhrkl`gmMGNV9GjUA3(@XpkJm2tQ zq3DD9)ieMb^e_*z*6FbvI7I4dx~G)6K=_@Pl8=nnopX~#;>K;_z!+Uk&+Y_RY&m$G zup#UMa;041A%KdYkJ<2Y#-$;hB#a466E?LbqYi%^vszp`8WvqDpC1Qft170`qpCZL z*2|o()R@rYj!;{1&XSp%jLjl~J6qJGt!vSIKYW~5+Y|+=TSk3tIHYqc zcEjee%WG~lA25vm<^*b56RiyI>U*GU2Q>0VW=Be7+)QmXo(X7^@F0`+6oO< zb+IA%TtpE2c}I^vAe#=3iH-ijU?6lW)C5iz#N4d3o4?izr1viL{Ta_P zYCbpr2nLXtJbot1mM%LZD*K2{!>b zI{|&AIpNq^eRyCWz}p`6@AA#z@zXb&=n*FmZxT&NS2SOazI~0fENGLNG{;umT21CW zAQfrw3$aCC{9%&W{E?v<|Vv{@zF70r!srLZw3KO()UnZWE2+DL2fkhGRlr8Dmn zl8uh->oNrfl)!J^TuR!^7gF8@m;u*O<-bvAj<05RNWmTytk0!jmm&@jM005t2&n`A z>uPA3s5}`R|Fs=bbc-K@9jY>l+XF)f*?0QRec2x>e|V-MZ+i^nO+cY+8tKa2127uu zAu>*E(xYq7Z8{P4>v+GA6Hf)E6*{S@Weu@MU&_go+)!D_hubOoTOm-6Tq{v zBP8#m?p-$Sk3~4g-K=H@rE-^9O)^W%e3Fs8L|UDa$yMBj!~hbGW}{zpK+yQIuItVh zYXea@8O@dg3fy2ToUEL{%tb+4XvYsUbHEN~ zvBz2=VtZJm;Zxjjj6+!f< zVgh9~cOmo#?LZ5}o;zmPUr?+9LaFN8cN#p!8+&Oc?WR$%igrhRgLak5Vx`i6*|2}g zbOC&MWR;^+WR0ThhrXHI7?YH4u;#Jf-o_n3n;2iUfA3vGzi9N>)<2lVZOE+c$lJpi+ql-CTMxM6 ziMZ%|P1%c`b z_~AbVYyi>^6R|@_+v9@K5B*mp+~<3E4<2>*NIA2$R`a#iMk{S?){R!Han8)hgN(R^DbSFN?L+ zcWoX2x5W9g4udtEc2K90gG_B!-d|Q;wrj7`%}?=;_Aloc>|_@M$ve595bVLD+vU zmSbXOA)sOWEtX?pV)<0eu`vFd^MksOh@!Y06~CpC-FE{$tKS(o+kO9RrTM1^1k``4 zp8MTN;~(ld_RrDZ9uO>_4i5jNp8M>K^tT5DJM*806n}U?5HSAPi{o$g+@~YLpIs40$Jr#WQAh9$K2*jg0@`d4soe~L|i~VTg^534)dTqtFBO>UD+IMZB z3|i85V`mX#!_srpM*0$K^eG*y6+%hQPnLuqgV~CkvCkws&L5f&+A25P*SMFP3{>E4 zWB7>>3~uTx&U%~E;81uMTis1sHPM}r1n^tTU)ENJ9VsM3EN{=tGh0hFo!bRNZgj0> zRGgcnWyu`dOvx9HBFRnetX7&DG@V}o@~iJM#!%aD4vHpL=j$4-y{@5-uVfr7Pbfx2 zb%dI1Ubr6w;Jt(&cBWcAMP-CD_969tJj`p!V#;$2A!Dma3U%`p4oSrXoL42PdklJ* zEU2tGH)FqxX>;HXPpNx?Y)2Dq)g79N(`lDhM0_W7cJBR$c+sn_zc72&LwprvBc+1Rw zZn{}i#vnA>3dW$4ZAWJ4)f+eR^UNsmCziy)4rS#Nh;ziJK)un-VGMv$aEikcgMj2ufK~eb;JP zy_NgfK*P#dJWn53MsKcAUNBux$SZy{1*9(JWD^lvSKwk3k$uThXFV7_1!008l9Pgu zdW3po^TGkBLGQu94`$?2{P57T}_;4#2Ywj5#M}O@R3Aq3Wnj&Rhgh6_33ZTWiM19-uNze;8?+me^Zv?Jj6C1Hcryy#; zX6RPy@3yPhbZ+46pq9Kr%a*%Vha1AngWN?|Cr+<(aZh5>OC(FpeXPc2=rocWRavCW z-s`LEze-I=Oh~t@F_mU=XNb0B={6r+xtl+`iI|pXRS(6IS7Dh2rCt}vmVXfHAz3s1 z5JN%xi7lF2KkI%xv!PPyrsLVK_+}jUIF?|jz=-eiv-UOdn+NG#YCuQevsHI0<<}v{ z2NHXYQ85K)6EZg@vb)A5J9aI(zG)*xh16In?qfeJh7vOZX4#lE9&rsGaT>q6-GnHH z95(dXByA97$EXd@0^1^Fp&CqO-<_6z{&TihD>VLw8U)`YVL1gW2FrQ(9SzCckuSm9 zxy&XK!2=F8#f*E0(oW8nAa+`v&`(Vq3oQvdNjuIa)~hI2+9!y@5?l+|U$e*iIIbjF zau*y|rYx+7(UDEcQDjGxGk!J!ajSS7^X3Xrpsynx%*hvHu;RBde^^=hji5jUUiziD zP$c$-r=ZX7J|_Sl*|_n;2K#6S7PS0|KAB$VyBodhlL&UB)`Hh)R?BJ9mXuuBh^36T zTN~1JR$=vq6|rWBtW)NnueWF0X6IYbEMigu=|rTFHn9g(weM43*iG#mBWX$5vR?%) zROg_gF&)%0>Tk*@mCT)qu#QSKl;Q~;mw3!Ifuyk1?tVk-nFM7nw_I>bmaof*NPHKQ zTu#RE_BZz^&o7-OQaSPdlC~6UaYP-j9($D_Z&GZ2I=oq6s40^mqM;$NVxR6}uCbnH z`Z1nev}D()dz{|pKv8voH(5ivfg$ChE84W|R42YEZ$sTkHwp;#SYCpX1YN_D8N!;p zd+$LAMR1d*4c)A1C+fFD+l8Z|yMu9OV{k7 zafGs;8)rYRy$51-kk(b2R(ziR{}K0((UpDM8ZR8DV%v7bb}F`6v2EM7?WAJcwr$%+ z1vj;E_J5!E>~r4x>9&PA+Z=t3Ip!F1wbk0Qp8o4%l9O|b(u6vcb;Vv*+{a@N-gq+=DSD0CBS__13?!nVwQ8jAlo&An&$$mCWd z?|B47`+tY0MWGYWHUvpfR&WCnz^gC~oSL*6BQgR{r*D}6mBh-}qi#Q@UT>B4QQS)? zns(8VXwItx%)~nK|E#$sSA77d7tB@M)z2F=(*G_|XabR>N;3k|h?*EguQ!6fKJ;rQ z>4=&rb$c>Ff;0}|Sk7c{c?|GzLAJ-~8aO8I(3yXgtB~C7Fh{En)O73ObwZ+1TzfFrQl7AF9F>>HdG_|C$W0D3s9(@www5+O^RW3RnI zLkgjJ0F*(?Hd%O}u3eptUx6u}X@O_Fbd!-bJ*lsJezkhK6VNUuYdR;^WNKkw#P=q88q^b33eL8+RGQfXen>zxKF z5hqt&hLk(XAKKKS+6KJ~450jKD^|QmT$Q%?S4;*&<|&iG$L@qg)gh;;%Y}qY_RH=2 zY^C?_(c>!8DAAeFVq9LPXCW)B$0NOd4hW$UIOwf#Ey|OWaUCw~5$W`^n`D{}1k&G* z(L+b`^#n@3v0+nt7`KRBOX1w5Mt68~j#Y4^WobiaFhgU)+8m*|%{PMr=oRcJ1ZDEf zTseb6lwnG^yGTavXB|`>M;*JkSNvBYXp8P8yWGqjdL4!y-bP#-c%umfCck{9w=1fu z0OZ;UGVE-lWA1~%_%=BeOAOIz9CEgQVi$yVhb(+^qD;U^bav z*zf9uOqV30ab9%wR^#Iz?rVnB$zA~$qj|h_mXduIZmGJ^U|g?PM` z7k=n+ac!P+?^@({dz8LVvAWdc+YQY)bo5^+F}V3qQ9kV%Xv-;=&T1k0|DRbyjV@ z*Wd>-I5nqAp;kYh#YzAZ1nc(EHaOTHUkSG+4pr}A_;8uw2AK3idLwYD?%l8Z^R<_9&Q-txiSu_2k;y8-!V=E*~R^&+KiHOZM`dkhIN z@zq@h#Hn>;-xi}OPiVDS9!n@2r^3R}JC=g53G=}Nu2{rC3{ zeHrJ?hhQ{s{-gK(ljRJxTyQV(Aqj1dJgzF!{buETU;G9P3Bn!{{zlg4tq4PqFjqs# z>z#rNvanKA=3?!+>VW5P-yB}}Z*FXoxVXUA7d`PxHPk!}Fqmb0Y$%6F%u{qoj);P0 z*Wm3emVtMSs=!`5UzHXVg~Y#^oiVeBn9oCB#IKrO4_`pZ-^L+qx;;^CbKKHfJvCu;;Wh4jyhlAykKOpa+ zoLTnSpP5dOPE@{TeR!y8k;1GDKsAyZdf7An98L0{9Fp2&J15Z6UjWT7JDgP7_sKRG}vp8@^wukkSD^>8OtBl{J^Mnw0}JyGDW2W}+O z)ItSi)Z?ul|DY-a7%q>ZSpYp=amx|vNLb6}tGe7rcsMKF09*_VU$1y;$;q0L6X{sj^;28P_iBa>yWaz{7}U($YDX>G2wK-~<9%Ld zxuyFE1kr`uRA=Zq(Oy5hesxtyIAK+(kGXhLCipI%)Q)nsVli^%-nn_tIQ|e9;5Y)D zVt#`7o|eH*79OCK{4m3^9D|)@>yl$tvNyQ$VtJFN$j!judZoST@siRx$b5~p1ARNs zu)P^Y0WaD%gN|^l1;{C3U;yP#_^taLbSJMHpdQ}f3?oO=mb<|6JR)Rzzp@|aSIrJ) z^}5hD+{F<~H{gdy$P_C{ELE3rG*MUoFs+PKblD^|&}ZBZc&=dYPPyjI+C><*7BeH( zPQ(koz$5!(Ylsbj0D&HwCy-r9Zc80k?&S2to~l!M6Yl^h4OhyTfnq<^fpkH) z5DTt1518|NmJ`^lF4bAlV8x;r2$WIbG3IuiA1FyT5=>mw@Dq*-88~O9nyNlL^Z5-e zUi(XyFo*qK)8~n~NHH8&tCz^#e$^5e{dG=tDWej1-b8{>-`qzV;sRK6*0(oKlb&cqn=CW($FDNcVss{Tw^}0eEBx65td- zIM~DfYNH^4oGQGeiv*#1v21)COkzplqDG~qJL&lqzgGEINr)J@scs6fR{_lj5)+Aq zabj$d5?OCN6ERiR)s)~37Y={GYjT950NyG?n5^!wt>N-I&l#_()$t(C|2%5OpA@^Yia%y?;$ zCY|86i#4cw?|%@p|B38nVr6Il)BH!`WBM!c^?w($*_r=M%>GXlV|JE*rx<^U-v6Q) zv$3=Oo0hGluB0q2_FtLbe^;>op8frAS>TW~U(DIR!;HVQ+J6bzOn>se|0QJq6=wVu z_8(xze^Utm3N!wj{QGA%{;xFf|0u|Q$%}t|eBp}!7m4=oz+&bvD(_!E^WXQsR_Uw# zD~MTmMo8l?5H)`j#EBARA0!v zFMXKj7B(0+9=>wF)fPOCeb0fQGD8|+2BrOt&yDzi2@Tqlm9qyw%cit)Te znO~o+x9#`W8}2lOv#;N??w+_;UpmqGOzu|$>&T|ihh}7U?5}~&>0Vs`c;?U=aozfl zkv2cWe^+K*Vi#-sd^A+VM>|wTe*nFnCdO+RN8XWbKgqqUE`Z}Pysk1{zq~boPdZHw zrB8dK>bh9xb_qh4i3)&>i2g8Ie$slA2^ot7`ZVSAYc6}v#fb%Nk1_Bn`kPVS+Ay!hC)W8`+}Nm^^P2`+Ww$c}KDR&GH#J|@3>C`P%qR~C9iT8kDM4uT zKp#2(VUUd4?iCgT5!ih}NIL@7+itml_Tk{SS5#vQ*)7Q2>W`5vLQaiAVF#5@Y1W`! z8#0IlL5hT+-{X1MqxnFTd5DzxJZv?7rN4q+Rd8z(y4I zm2{P!W3Juj#aU0Z!=mZ&e#a;#^N>W3RHf<_Db0aPX)|gweuf{=mea0~UP%8o#`cer zVMEKPqWG;@duF{3*Y-Jlr?J`5Y5xKE8Sm?{9qmWvw*|wE11n^*-*9}CrwyoS4UFQI z`G#)rJ@-din4uaYLTDH|y&Q6gs4q~2uAeV5`UKZcOHf(&a*jif@Xx-5nx>q)MfB6E zofjzWK>p!7H0jRLi!E$3@F&ouVwT#!r3zL`k- z@!bh*Zo=vPrKKc(Hzr>~Z!?Zl_)7ma%PvAX3NR9lQ78mqs8An4u!(Vx&r*Jfbk`J3 zvt%u~Php+Iyj&ZgCJv~-3mX4xzyQa=`5#!sl z6z#B8MD2B|<$^sCvCR%^-{71Yz%(X&g}KA@(WPZbbhGE{`x>XN?%bcY4*@cQKl|OQ z%FnT&21LvbQbi4R)=hYJ!eK(N7^50YR`>8q_6Lb#iIV4i$ZmJ1Ei8X#;A&%~<`L)Z zTp^u?kwE>JaQDz!>ybUqQB|)%IhE5E`vtp`EuTGsA;kn1<$`=?M%`$pg#%G2@O`T7 zGay3gmV}JwgEY(Z5l*$I!zP1qjTb?DpLK?iBSbpam>DLUry{e)@)Apr>`B?49}&sY z>XcV}O=4U0xHOslx2ksvJJPsE`*7Nsg_jpJ3=5V3FN6O2rA_Gtp1De<4_$Q@@P$WN zIJX1LxZ^Qrchk&?*0#)9w>xncZPeOw_XcCSq1&_4+vH5ULSaZG)bAJ(4qVJ}hxB zdsP{eJWHWuAR!puM#d(Z)0JA=QLaL0NJC4fv(u+`lFT9EjfHl1CQQ9iFdVF8>`oa} zWv7DE!JA4^aN6C93k`pT;Dd-lU*Z^%nN(pavR3$-xXKrF^JaA=6ruTC)hVB$_)xy7 zD@m-meW4}ybdD zbnsdwb65ac#|Sn(EjSy5lyq^sS!qp6+J^kg>ChJ7qeEE1pCv89tNNdZ9}6OnM!Qbo z6|J_9L|bnAI-5py2dhipPo56^e!F2_LcJj`dWU|RQJVfNWY_rxloNGu2Ca>yvBT?a zhU)c!|Mq5I@Y2tka-o8kIefEKg~xU`+l0$5Tdj66<}se#z4u%-l01#snuBuv@xI#X z+Dc13o}?#tPER$$4J_`o5R04~RF^h>+Ii382hLG&cKnQP;x@E-DtSh-3b48rKIN5Z z5?3s@WP13(M%Rrr#KEBijU2u!UBwPi%mgkk#ugZ@bk#%gb7Ln#xPyKA#FhJ5O9;7~ z$jX|q=@)r;OTZGh9;p5~ekh17;(LnB1P%G9!1o>dlc9{a<%j${!)cUA4#GIm!Vn@v zdl+>=Gff7GfjkR!hVXLt3>xpO7kkVi7)6?Va8L|}m%<~WiT3aSJWqeYA8U#X;>mG+xbP%>kM`4y4UQ9M zK%anlps6V2iZcYf)YbhRd<-{@+RsZf;aj0RVZX(EjcZAMU~^7VTqRNc z6#)Tks~dtZ<=3MQ9i?Zbjn3otyUM~TUc&L45mgatm*(T31!?S0Z>mIc5E?~j;gO+y z^+|ICPvvGjzp%AWzQ?|I)$ORmh8Qmq(&9`=9y2>e1H%aZylP-R_aWlT0HEHr^_*pY z{}^Pm){WgH=xDB+UXd-wv%q94FCmT^*Zp;fE$ffnBk!lO?AOFCvL>s~x;@RQj<-(d zckH9Si3@M=K~K!c9GVJ05s`+Pb6IxXC&NTp%^pCrFnMHHIcoYbzO(}h`^DQ~LxSc_ zA%r}%z9|23ow@46puKb1;wWMFT%3bxqX0;0630Ow5&(Uu!(c3&P+#0Wuya4|AcWnZ zj51_iV5hxmpA7{2#f&jkET;vmWDmjt!hS{1q}oDdWo+I}n6Ikv%=9{lF;#T85QN=c|2^)JpRyuYZRXdYTv?N#9 zv7Cav9M0+t9+P8W>grTbbdDIG(UU_^C;AfmdMs-I{ga)n-u3AJ`lZsdldMt?5Tx`!~-N}T19vzOIj-{@4+mM?)eXF)NQXpY zw#O4VyGBe=9MH|a_jw8E{LHpW%8DSImFMkYLo(Q1ZvQVsbKUpZ@RmFX?8~-K*@Qj5 zQQx?REzD4IU928c?`;W}v+cqsi;F7het*Xj@5|?21yV!?3qN3oEAs0KX!d31iXe05 zifrXQE&B#qB)e&G27W^b#6WR8gl2_U9~+jU1W`VIwz(fHxH&)i!(N7#m#2bcFci-M zO9pj&AysI3tk9i4ql$VAoAUrs_t*f_Y1+Ye$ueyAw!GP5-F{7}Qx|!rx{%n>#8sr& zAHH5#t57d1jt7HTe?kU*`#pOxMHatz#+0g;$DCSpw&z-mGzHgho!wmrrt;{}%n*$m z-0Z2#uVJtPjf*$d_N#$-*VMLGrb2F%jz+o$0sL-qf0hDJ0Q`X^IdfAGR^~ z9SkmeZwk{$1&;*+_ zBScz_LK7)0^mv%U4+oC~DUESQ;om9cl28(YMByL(gj|+D!#e z7|U?N{ogE_B^W;1fxWa9nkcx`t$d4)5%A%X9f3C*n15Dfk@R@fdfO3bGmSZU&oic8 zgHeZe^e~Y=_^Mxq0#dN&M51}3RXX5E>UgvPQy+1uYL3+*^!oa)K;PCb; zv1YrxXNt~r+22uk+8wwtt68B|8nXI)zn$-2UG49Oy!M73IOx)Z_jzMC1OM<} z0r@CSMb}521_I@8o`re6?=BruJZAR_{=8kg=2ciCv9!@mE{XBD%+lRmuA%Ckwnxiy zvpTDR^EzFba5m`WVaD{fxY?Wt^bCee{wi|VqG9}<=l4Lg_X`|cgowSI%sh|a>JaJ? z9FDpw$LLEo-_XsIC{k&_Ud)tO9H~ASGZ8tBz{Vgvs^9_6-DZn1IoVeZ{H##I&1yAo ze0SBxhpPwV)@CrRr|}14cIqdrPBNc&bXRa!rk9!C?j90S(8lM=4ZmE3wh9Q;6J7*d*Ti%6@_8RS zf;U{H&Ff<^-Or-u%s}mJ-~hCh57z6lPXV6rq-iiWzOuausf+9B&L8IC?!k)5B+VkV zII6)2Q_!TKWOw6BjHYJ#oeZhip%AzM3sG9vh@dV?WL2QP-a7{^I3TU03PR}}*VcB= zj4hC0$=&xq5i-gU22UIF;<5bjb`Y$`V20kTv~o-ynzya0p_ISH8A465^&ByQhmcHI zWG!*QUPrRq4=NtVUpTg<)uItK{!}h%tj=8V?o+E^>ns-(V2CuRLsj9-QhQRrZI_N! z<+e*;D0?tNmkB`h-oc=M75w2 zixi>&Cc>iQwrxn%cXRmQcPANhQ=P_1a!fKuX1PD$UiX}g=OpJabkA39(^q08B|}b#ZKjC};{Ei*1{9>N6~n|(s`@Z! z;R>O|eC6e%6tV}fAN4Xgu1`P-n=dHn z>|u&D0~?nzsnYHao5k#ktQC=nO`k##=X>WU5fFub6lE-FgKAml!I{rJU+Z2BPm5=k zLnrFr!=p^d{;;LW+ah=!$z#L1Ee)NKF-^Y1XV>9~$uefWE?VMrpY8o|Y*Y0N>l^}C&T3MTj>22;+CDj6mVvW+h9VOK z%o~0*g0teMvmK3A${|pBvmCgFemQqNn#wGIXi5zs>)vksvY+^SiW=`)-MJp=~=W?Rp))Bu{KX_ z7IeHp*f42awL2Y8116<9REf_BS`%#h&B)Yy4-Pj6j9Y!!W`5*O1G8mUtxOrXF$z7Wm(8#DJ<$`ygURm?1vb2?RhUgRwgdV3SI9D?0gO*00k>?5dF?*UYXcX zr^DzA&QPj|c?VsUZHfji`9APfkI%IkH!C5>Y9?D3BnniBi!(z((XA850zLOnoOW+( zW+ANfITT5GAsVzWDet*RuI*&~qAhyzXcSsj^){uiShvx|)8Q(M!}}KVS22=X0jFkQ|{r#T7dW z#r1Pgwt?7c+CO6wkqAg?YNJWh^lHc(S^68|LrA5kB{>ocLMd@9@9Q4T^N$s2FN@hOF`})6 z9a0ol=D$k-{lp!jq0`w`bPlU(PZ=-VKd=Y}q9T6CxbC*&0iDw?g_en!VgayBZ;O_V zy%&*RG12s?sD*StL!TNtq8n&|M))?dinV(SoCV`txD8%KI{h=Lf^Q`In+$E36&5R} zVlPEZ_xNGY)Z`?H6h?fVW=#pR2Hko>I1qs#JY+u?dK24xUW=^rL~GIB2?jhYKmD-n zV92)*g*ooy{s5L0UUZU9c%|Q?dL3Q#;w0b`&@84b3ZQqj!E$I4g>>0`gR@aeC*5U? z8F%SRk{q!0XW+z4GvW6jBI*GraGG}n>4DyvYH^v!LFphkf>wOpt=E>J2kJ4P&gIY_ zbMKdfi>o6mHdgn1`pq-R_9^Fb+T@Oo2TKs)1-lTEoxz^(7vSm(C5CI~yQlLU8HB0x z^0}By8sv=NT)7S=CJ*6Tm8tUTUFt}|G9LPidj?4_78psAF&B6M!cMoKzrxP>ucp6CKaB<45*Vv$jVyRqV9({)G{0_ALtjX>ta;*Vk;-V#4x znJ_`o@X_<|Xs*}Z3mG!7BA^G+-PxHv4NG9{x2f)Ua=L@+q}f!zj7oGEQ6>NmP}Pi3}wE-{zQnx4k8NuT)}RBXHNGp zDCM%I7t0-=1OLwRcweZ`YVFX;x!6Ctsi#X8G#oxv$i`X`huq+G~ z2;+*g;<~6ywKrMAfJJ#NQqw=o`{Hlf;m%8ThTPs&J}gItbErIYwmtA&wuKf7&AF9Er2>JBU>2FVY^Rs3^~(4L3*i-NaRkNE+mLik*VDTqccgMM(Yuw_Nhs#Hn5r6 zbWt~yWD0{V!IRb`5UR)|mCsR)%eD+9iZz?OV{~<6iREkYi!5+UobJ7w87R`t5BT!; zq0S^iL6A4K2tD`NFavcS@ZD&2T#jQJ353*Pn)-wbi_oKK=RQJNaIy+F9n~2aO92#? zH}KPpXqNs!$dEtVIfVrPm29PG^l05iAC@NiC*8h+p?wE=_B ze)nT>l%xe$k@0gqz*VeFUu)>rzF|2IraZ_Tq0Jo=pzB{o5)aWxLes_oQi1yCNAC-B|y`^Ss@5sipy?xvsrQ6tQq>S<&itKRkQdkuI1Zv%uh6Ftww| z6(9LyPUMHYEJpWt!%FLq?bC5}`2{0^lG9D1cwlyATx{y3AS+&FD&*1zkDAdIv(*m@ zS7?hh&tnuz3~NhMm7m~;gLQyZS&C`4r>o9>yE~|;tapl(XcDs5UDf~)Qmrkv(GFfp z_PwfH%)-$%b4MeEa|Wi?AmYf#dq|qgx#Ba9HW_tX_;jZz(}0jzOip%;#a$dgY`%?d zpw)$KoPBG6;qE146-zkjRd~K5WPRk~vU}H}Sy5|ykk$phnoGaje{6Fk<27aDYkQ() zytp&*t~eh974fX}jAMjkhULa|m^gv9JB9ZV58+Qf2p*}-w!cOW_+Tf_*K)_fP}Q^- z#sr$ehosXtz7~XJK$GjuUoe)$WplkZSlrK_9*L-B?g|1O&ZjP!+K2WAFe_nlC1awG zpJ(ekVPUa6NZcdI-+2i)judzl87IKjE31mG64_Y5)(i|~sW%?MS5939rXO3)z5 z^(&71$<4^5PnfRa>c{gV)g7tjbDcC0onM837EL{fs;U5g2gdRE@eK#zdFE%;w?hX6 zblJ-SE1Yvz%HE0*0Q7Jpv~f;Vw-hwQ)}O^X6OM-(svzN1X?6Tf_PrSL_KhC$QDcB| z&_FRKwHnG&b^=ki7JA*;qR+WI`wET7vvoxGqdt-CG zEFRU6-RzqDSp`JkvK$SEhJ!92G zW{1m8K4vQ>zvTvcUR5rT=tCE$XnGA&RqIhnQ!1t=U8AW@`|A8q15ejmR zh}!dQ1=|Zjo|HZdqy>$yKFGor(10_nvYR8QhTd{Lp&>oUWJRHf9B_a)g3!+Z;#r3P zIKcwbpjzN3q-2C^Ywy{r+=juaE6S2azR7fKJb2{8sA#dTOYXh z_6dacr33gbCqw-55hVnk(%d|Ul@OPewo|>G2+FokEU#9&T z^9R`aki^a9RwU=9Q9Y4~Uf1&%#PO6eq8wK_Japn=8>F*xu3TR?jF;Mb6=olv#PHlt z1~k5sTWwuslp(8!XTb9Dbh4kHp;#*?Wk?3TG59jN)rS+1`_Q|>HDjc6kpj@U+CjoN zovpbQW05@z5GePQG}?BwP|QFDF=SK>3v&`t+Dpv;G8gE3MTK zYW9M`1g)P;LxRumWYTFu17^2_+2vg$5?uzK5iOJZv^K49Dvir9g?U=oV7XS(q9821 zjj}Cf$VFB(eI*VFq$41OgGo^<(ivHGZQ#HMx&DkuLX;RVz+cZ!;cii-D^#N<5i3C_ z80pxHpSy7IzT7{rDLrlk){V0zWGdyUf~vAUuQ-tIyPmh9{ATzLBNjdOHOEhWD#Z~gP}ZHNKb?+eI=EY5s2 z=CLvIXx)Wr8+rh>ZZpUd$SMkeWeQO#yRI$gQ0@wb%8CQkFh&aBYS;^_6E5|c_UeOd zkUvcgN|Zz!z1oP$gpwzA0FhF{kXFqiXqmays=V2p&o^Y#fykhhN()AXD|yny!Gvra z60Tj*f$r#d`#)i8Tg;m}O+aynIwD(Mev?1zSODk$>jJ$cEcUCvW zs{G<$!pc$c(P@%VDau6q?8g(pI#i7W)~$D`#hlc7mj=#+msLduerWWOZr$YJl*I~` zb)2hq^ucng4R0KPwt=Zt-JEXL9Dt49V@Rw0gfa6q;vC5@uyy#dWe5STuy~FX|%-lSb zlT0E)q}ZW!I8Ar1>%M*2ZhxhGqdf>BFBeP4tkUFqnLwE42k+1IhI09yTihVm-d=v8 zU$;jBYMc;*qCCuJ>M<*YQ9g}@OHVIC_5I-`C8o44WAO3&y3okCz%th z>p8Mtz=9$X%hN`Tm<+%uo=1|1U>=Bo2{p@te{7H!or@|F!XAQ0|J{MV{FG{moiXx3 zc)bN6}A@M&WP}P#O z+49=Yot8eOIttAg;fqJUnY3GM%yQ!=b?SU5Ml3o}V#`mwx9_(=TxbqjXMGE$%1D9G zfoisL)F?^>(tS?p@S{h_)mJ43eAiF(3doE4j(y}lgXH-RWR&bIoPok{rH_8{2RQ~2 z+o3}_E!1oVA=zvV5wjs$5tpb+-41>7^$30nC8AFH%oq-3(p5`I3U;PT%8fPyJluC) z6|yUokxUH1Tla1_PT9XbSlm})M_s%<5XO-r;P@+UfVdc)zIAAu??u8`+S^(h4TGON z3$_59*8iFo^^YpEl?xNrL(b6?@SY%0RMp9%!TTwkFVzIUdntD^>kIzQm2^_HEx?b}0dH{(&-Bo9*0)tbEZ2_I+vL*Td&lc3mX?Khy4slU;dUhr8RcE< zy0a4&yiE=zR)Sc*$oPT{g4}nxMJ~0Pk+(#srof)k<)apZjzHj)EFfQNBJU?@qb3!r zGXu3dxf+cTTIt-Fy!l{S2of->`c>%{pE-1SITMIx9 zM-;gz*VuL#S85$E5FDyo9_dq!)aJNnzi|zPZ2_ngFopYj9vGJ`e5=)~YXyqJK2KOD zQhes}T9I&3ew2_SW$YbLrDWS}^Ae0K=GSoj@dIUOfC;5>MV^L(yvNxi>y517qgW_% zP^iN2&k)(R_Zo3f-Wc5*CN^9C?wDQKHUnU3NLiv*Fx3uVGeN57nxT4)I@YQzb}tv# z+AN36*5b@iecpxyQz(J^mGJvkg}fG%fLZzxmY>j&q(*JFA31arhj{H*x2vZ>=^|29 z8^ToR+FkwzXhWA|teS%i8d)KmiAhc=ZaCbFWAj673NVbDYJ)&-EAi^LD{{14F~CXY z;A;j`w#z3z#Rc~+8SdY{LxFn~V>R{NAq1=qv`HTu6NAyK)`x2q38XBNJVjjoju^`VhVzM8)=JaCyq zp1>VR(#jUB?`PeT8fl&NC|S4O%w+=0zU=x0deVU<nx0Zi#!_&_0%ULPN?D7Uc-#X&$m*pMLJ+f0@ces!W4#kYr3` zO37diELCs>l{^d!TcUCK?++ajP}Anpy{fi3e-s-RlRe4`(`vayY_N^SDYnvY;U&dM zB%(`LZLktT*MVQMLfl49L@p3Y5qcPi*q3gY0_tn}#%5kOhe`zE%>kEA3i69YbJ(%_ zWgRDuA^r4^XaUMk<6aI01#^<*+Oi$;v0s?JIdY|Z7UC>`&GHg;Y{#WdUdpU%hdOgY)S{-GcK?>1AGb&0wRTypsQumn?8@4CR@Req%xg3 z?71cXdki>a8d4f$1(=k7Bjg20z4>%jz#~_^N=^sl1&qm7;G?IBHD+|P0+~nYS3mU^ zlTbb8##lsbUMjo|W!akxQ z3pL+?+g{0>AHHfKew~K5uFTs><#WCA<3;lws_oUyWXqq{8?pgS=2;u-@^q`Itm@O7 zn0u?M_Uw5<^WD7dHD}!U{lmZQ74G6xduzelMddSA^IhcX@{_Z(t?H8(_V^R9+Z%)T ze=z3%u`>U$H`CL9RqpyPXZ~NyUj56i{Xbx4*y+B^@qfY0uzj&D{)8D?Ieb~~|1)Oh zt3nvfAFnt)8}rv2-G8&@tI0?T%k%#an3;b!=6{{*@4oym63f4Q`7Cs-fA!_FvHrup zFN*(F2=2dp`OIIum4B6IgZ!J#`>($Izd>dG;miLAV20(Zz}epsENp*+$uNBl{m<*~ z#~8j)FpOWF{@F79Bl1tnUtW-Z+5fNOe_Zo_E1~xFnZK7%`$Eh7Ei2&f{r&?&^97vw z=i}@6e{=Z%GxDDif8G8KH}enV%%3axCv@fyisnyGj9)$fLC*XEw`yT|(*SP=I z{uTe_{QqkG8-(W1ReeSM0k-^oCjP$nkF))^G5vK6|1bCdKk4bu-24}Y=AYjRE-rl9 zf8GE8N4moQa@YR%WQD)ujA&I%4IE7Dzn1-LKL2yF!oTrn{@mL7^46BRRzg<#)&{0l z#*qJ_A~F9J5A}~^g|FIl|DLQs&-?`w`ahEu7Tnxj6c<{a)PJ+MPdQF8GhzrBr2zC2 zOOL|`=`gkN0fi)n@F5YiwfF$?e``{Zm86S`#Ro?qI?he{!B5l3@k@trxF;!0zDAvw zd(%WFdi14S(32}9Y<%)b!#yaZ;$rE_wbOfYyu72*z2d2H>p|lxD{)L^f=qdq-zATk z*7T=vM09=%yqovkX=1L0rVGMD6zG`M&$tQ+g>SJU8_g~geij>Qf}+=pi!YHhD;(_6 z9u`!XU-k09T;SfQD{d>jxroOIvSkg5O^lps#xP^5Y`kwghwhN1lkD^*V_*cusPb7+fK%ON3VNq zSQ=X2{`KYuX1LBbtiPwle5;L9ig`DY->U7kt{4cmf6MfiuMx5Zw4(kg0Yy^y)uBEvKxwRw@c zy$GX7TEpS$p?g}OtiGjwZB0J?26<4NNE~)c?tRccO#5PWxi1v+SLyYUpN>{0R(6%} zty#OtZ-7!}PbMNvouzq&)w{Pzy_>#7GTbV%bc@5lFDvW0wLi^WrE4M`u^q6(xRK5( z+=@z_Um54z4QEAQ?SMUjr|ilVUFe)-WkvB4&lDO0*W83rq_0|XjZNXahssrV$}4Jm z$yUc8n=CTbn;SYBtEm>`n>#xSs~H`=bxS*HZ8U$sM*vK0@z{!*i{9^z6vc{ZJ>Bm`mM5Ean_r7vBw%J84U`f!gjpI3w2wVC8VlqVFv}o8BaI!c z95Q5yGmlt8cv2s0A2rk}nI9W!-xoVYk(_A?V{qGl!~nO9YY3;KF0=a{_Ns09*IQeAh4mM!N8mjxf3 zGuq4qZ)I8Hv02`ut0>QkU_68if9MM__)-%t+3?~w7{EH?Ipeh?o$aGCpxwZE9L9m} zo7QGalBrD7n&P~3U+ga0E!lQ$PtJiKk9mg!y>2<&4b<6-c`;x~pdW?Xmn6=|k|wCV zj=|kc*vG_)Hi&-GW+St+uz8@Z2&vy#4mq==PBhrH4VzTx{nWE~NpV>*EUb}`2+PkG z(PXgezs?)3w)tga(i5ZO)t!BG=eGX6__TVh9JP)xomg(0T|CTm6;1&m+TsU(90Hv*1uMt$A)fp40;6 z^n*ZoR8D@QmR!Dr4ku+fPI5O&41qbJ@`XByXaL_Odw`3c!M3xdAmyAz|pQ4e5 zTTHA2613K(7SLsujB@@y1hz|uwR-_`f|Z!Wc2LjtOh-!{`7DX<7rY57WcA%ML#8K) zzHz~bVg9Ta%+39lwI4XR2s9aAeB+TxWMMqczS%rk#yhX`a%!0@(0NeOGJ1TR@2T<~ z*P{1@uIZWVM5>JAhgo-4^fgkN-jq69gzcEYG5h&kzhn=fIH<23gE(>$R5VHO1nQ;B zbUa_k8M=UkxTiN7Z$cBbP(in*y0<5`NAmjkY&s5yEikx5XK0Q<-Q>e;3i6mJ?h zJV*e1ruZ)J_PCaWVX}CD8?4aYUc%&=o%2LHgsGBDQZBFn( zIAL<*i?q_Xq`vboj9h0HOApW`Z+#C>Snnj${Q+Qw=e?|HE9i24^;i02Flsd z?Kfr~W(r#Dn6@a`AS`wMeuX;5kRWFHg?W5G;m|mt;MMKNPv3~iiT$VwI-%;OFn>q! z+KB6ABl;*tKFfx$vObO*fScx;|LL+l! zU*QBF5|GN`Zcf{i#zv1FqGLB9kvBM*~{ELc5p=?OYUYN!v!8guBzc z`vn>^BLc<-mPiz})wrpU8KqUy z1A)gRmsArdUMSFLD;LMV77cCVKzlkMl3W+rG|g(v%FTf<(AYCop^PW|g+AI=OHtYH z+3KLQy+9MUF+F3cA2E|ZuMv)W?3S^gVekY(VKS!)Vp>=hd`(7u!1R^cbn+Vx9`WQ` zb2Ne*9dD&=KF9TS8-KY`B`cEcn;CB5K?@J06kl&Xa_Qo^xf%KKDEbnIo8*D`v}8L6 zeq0B$STtsKK5v$5BnHL8?Uv!K9mafPmntcPH<5Dvwyz(pf3fhkpI4hlPf6is(*~zU z=i3oPwO{XM`Cgs;To(WTU-3Zb%@x+C^y;ed#Q zTMg~>v|0$>1Eu~vLl`MzAzsB+aA#!&%}Wo6MQ*^r5Wk>3)z|*yB*FUD1F%3+Vzkdn2ay9E-jNO|eUm+n5neCoA4*R+|dkv#Hr9-UNqs(C7aCC%%LPlLe#0MWg zy#y~~nxQeBWSZNg0ouVGL6xC9UrE+;x79>|VE1^o#z2VGWl8U#@xbUMob>_! zF3}xTfoDtj2aE@-2dxJtNSZ-EEUeTo1ZxNIymf?d!3Ng2bme3f7L|YF3kP~`F?poQ zT!7H7C`U#RQF*y^k#cxJUCl_%$mxqyD{VDY$J=*`?`vb+H9hlEibr!KQn@GTc%H%A zGN`N`wVL1;R*dA|@8}pQvToKRDGWYwJ1SB|Q*3_P#3dE{gpC#o)1TjXBS_%H$k51? z-%7@l$;h$Dp?R{JDs*bULDqU=g?-vqc8_+{k%NJ7E5xb3A?E!~&D%6jkxgcAA>OT} z$rJ0fyhw6>W9iL&yMz0^-PgNq{M+p;Cg{^UN_27>hz=7h$CbI{4PL3T`y3XUB#@VM znLg;Ln3N0SjkAVm_mi6740A@Y=6dBq?ph4#_Z$>$;^`RTz~WQB`O{Bd#k}VGWQc&M z3zY{8jUx$y;%2p55;`nB%i6b65*n^Y?dIKmy22|QVqJj2clJR z`^L;Y-~xdjqA24sG?(&MY#*&H4EFDCqZJ+>8GW1R>b}kpI|BJ0>V~v#me;WC_uMy& zC0lD1^fwJReuY!0I&4|m&qcJ~Wyf?+(7&kpTPl}Iwq+TUWR6Z%XXUuN91)31#>N*# z%M?+I)RJ$vB=GNRMC|FlDG=z zr{2YdZM}jA3s|3b2I3Aj4*Rj(3BbtH|DSgPzK4O~mM=ev6|y!C6z0e%3VS1@!HUw~23 z$6}s!tgUM_yjk55a_k6!f;gCQ>E2q=y}e}dNi7_4M`53a7-Ll9{rDW~2XwPiN@`zh`dl*( z<&O=_`uQ9ow0SK(e8JB@J@|SVlA&SOctkgaB&);T46ru1H2E1PqW6KMNb!>p!+rsk zvZ$nzAEbn&3WM?)(hQ`sl8mLfa9NrdSq7G;_9~P1Gi*b~G|&-|dI- zH{SB8vD;IVP>zZ_laC=Xfhv#`-@veh3fU*5G37dWpI3{lUmbB8WtE6(aU~a|m86xW zk)UM1V<%UA6S;Ehs{Y$Pn~8O!m-Q5s2MH_7`5kf-)Z7xvvSD@C$9n7%rt)3-wpm5K zohqLi|1iEKX#cf6q*DIn3U7utDS6ir3co98wb^Z#xEV`6!FX+{9=7cAK1E1az3>WW zCg)K|V-Ep3QGvX~-FC0UG+X;(@~Z9`rHb)Jev{`*q&*E@E}R`NpXTH?mEseHw!XPF zH9CCbp2mIh`$5;5L^w0i*>&)`h;rHlyx3xORk~RSQWS9K9j%{CsE;P;X3<%HKrB&PkVO*OG#XOG9+C zMW9g36#jN6E6-agt?zUt6Dy0$U}siZ$##gEj1}eMaSG>2?h~2!faXh!D4eeDrpHAO zr^7EDySJmQ6-n*vr_MyUQu#O2S0MY)dkxq2*y|*^PD9B!& zUXv3hTnM_3``sz2(J?#bE@yPirW>cbkfM6BZB3xD5S3%jF z;DinV_E#{f7gxM_Spi<)+2-r!6I9=a(G(3-47VO-sAS%Wi_|to!*-GjYkz*Mx+pt4&@t{#9fl&9JX7S&UN*qXKyA>8|gIn>ML#F)61gVM@)!pj1 z)VBPASkgPOg5;Bwz6kmV61h7wAsT@`W>P- z?!vvDAn|xd8s8S1bt(5X2;?o&xRop7F|S62PVbJm>19NN|KKxaeU0(LLoW=I0Hbs_ zHzarHhCF+WNZKa6>(N*)6@k0Z(dw6xB)AvIhhnX2CB;DK)YEcpNw4_Zp5xqRxpk#| z{rG9M!)EWc>o)8DS}BKs#+ZBaoJp{r>hg+KiH+lzzU)kKreQ5^Vxc0#PG~~rz4_ir zFIV}M4+#xfBYK{Mk$z7~C33>Qq9>y;H{WIRHPgyybx?f^91{5c946_)w2_yYXTA9~ zR|wGW;CAfT%1uJ3-g;SP@cf2ln!FGtpVzJW2?AH0W*6*=OXbkiaY6<~l2LTLHKm3y z34v7L)8yw77JK!q&33Z1w&bt5TOE@qo6Cf5Wy7PddsR?FCvx5O_AIG!x-3{ENHE5! z+pOrPw!q*UTI+SSLUWz+1zFjsd*c2dM>Din4VqyaR0pkzX>d3^{4I^QT4b_q(A;z> z(#>Z?OM>3j66%Mmd25%=B8XK^M)nqUm|wY!ah&x=TLxVcaorxbwwP2j36;mk=}Yd( z@=c;*F_y19nP^^6in?fLvA^rhO?~L-7g|y{qaxVzQkCS=ow_x=C8to)Z)7;%zjlsN zjHTb5V!-h(4_)~}@~(=*@lk58F<2-=sULUo&`D%#JI|}d;(i@mT!1gaK>_E7WJ4Q0 z9b<^oV=AAB04KUM&W|Qm-UOj|)7AI$M+>S(mE zh{yL1iQ<;qytMw5c~{ILaSh{c@w znqLj3jgFYxCh*GIM={gqRA_l>F+F@uFkor&e%VY18>ew!1&7RTuX>ECm6NAc z95*?0llg?vT8cATG?py(E{^RLV!MV0c3k}|{Pp%>A6!1DYkzQoe_TCz*(gN~Q~9XF zC$b!=)9Gfi!toLPqc}|iPrFvD{2!j%N{ZFFzH%u%Y3c7a-%m~)7w=9C7au-gag4|f z=@r47AXhXWwY@oi4a$Bh)+sSHBlt!~S14?h)Jge$<7DI8k8Qq|J4c2MD`r~t*OL9R ziVsQT8%9I>Ebx65WMo48)q?J9PtjeeOJD9vyYKFY-u@6`2q7o3X6x*fVPjgqr?qp^ z@+~vAzn4aKeEf5X&2ehnfnY416D zaefN3PDQ)6n-hYzfN%?TS|tc}t}rC{_&C~v^!r}CrJ@K%hW5M4y6bfW0m4OCPw;k< zLn&smPB>WiNkTzN!^J*NPbxV|zyWf25<@B=BrTV;HU)dmo2UWWf0<<18i?ue> zPPdiY+yg@FbslL+41Qp+bzmoWldy)3PBi2< zs8$>c*+v$%COLyeBslyyR^vk)Utz!9OlSM{1U=nufkWf7)9K3`*`duC6=YPghWX~|bZu9qM8^#0yHAvssIP#B=uG-*I@?Y^(Qf_W0 zM`5cPggu-qxb^BYoufU0bVFOA!*y=13EH~`^b~=Zgt#pBL43%)Mtk3K&^deot#&Atv5VhWw2be-=L`p zag67>Z%7R%5mfZ4N=kGuj&eBpbexmaNRQ9jh)F6KUTWlN_>@EAoiU|0l_$A*)@=oU zsZKmKWX71N6?UKyLNBr>Dcah)!e>p>;102VpRZ;T(!JH0dDA%0vGUMrGNpUR)o@Pg zy9y0NuQ++8Rs(6ncC~~e>HV^zjOox+w+)s(GKad?FXp9S?*S(}=F{PM?p^o7%Eoq7 z(aZXFGv?vz+>t}nz9Uojliunfd)sm2 zZ#|oN!T2#$cZg<5o?U&VmoZByCHV~FMfifCU~ecfy^bu=^?@0;FgtWYDPhuUP18QX zWx6CJFK-dtq-WY0SB@t{%d`*L2;WlIT-?-Ir1IdaJwCGbS>Mlh-x<83g4blfBhI3+ z5jbdWx^gdryK8>z0H@)0ODYcs!*qZi=PG?DB=S4voM?8qR^EN7rwRld`T_}D zVRhjw$t-T+80!`VSEd5IVq2w+)!=@sn4~9$i=XI3TCaq!(A%|=*E5q5?ZXPX2?`C>2!mW37DDv;w55K0)x3J}J~L((uPs|K=|3*VaTBSmNeHDhi|t zF;?B3UAyu9^P1fZ;J1k2xI_#nZ(FmL%&WYI_5t1lU)Oo2pXu#nUJ_ka**A~V`=H!q zA2-J(-n%$DvSj0JBcLa9Z*&{EHRV#JZXkY|BAoBq=j=gpm_)*?vFBvnE*id4(k_UG z7JZc^Ua?r=>!fJ)3n7|(u$va~oPPltVfEu1b$HE&WjAgxaA8Ck2LzJ$+`$jdk(w!3 zLPRJk6Z8|7kYPD=GE`WvZWpP>=(1~ya|NsJWhp$sJ$@K*eUWbqr}3HXS4C5sxo>_H zqC6+EnAru?;10{Ywm^*cMVF1R2bFR{?SwKqKTA-t5U@NJqL~knpdt{y*WYxNjm?>AOP%M(@I72?%Ghv+O76wSXS zP%7ZLs_{^66iq*-k*8ucw-=lDHnVhxO|QK3UgRE9WK<&e5#3=z)&Mi#NLlZE1qI!`8N3xLPBImUIr>A_g5d|Mg{1|i=Ui$KnZ7pVsOv*~XPfU@v z)ozhWwC9BM8)bjJ~_MTi&<=t@8$aM?JK(nfHv=t7&{>;Rd zKU|hQH0DZz6Cza;06j zPc)TY`Y{H({Y@J*mk=$&N|z4xVitu^Mg0o5AI?wU`D~RQQ%~|Z+D|XTtkNKVB0WF< z;eST1Ab|2szla{be-~i<7orD&1SpyRBzgdv<~Pv;1rFY}HZpUhgF?=0Z34=czqK}z zAlNyrO%)kAb#a*sTATj`<^e+e4fF7U&%r$ZDY6M*J^w{y^Ct#z4(9nKKl*PXn@}hK z?f~yI2;)rL5(^mk{?9ES$O!=|f}PoUkw651_UK=GXTQPW zXMhd}hYu)Zbmo2b{y8c@loJX%s~+{2FC2*GOxpA8tN`uxGoD`~IJf=Rn9h0p_qOMc z{GXrc{Jj4a)7hB*L3e)6?=Qj5|8I8Zzbw!T+|JLt2mp0{aXWvPcDilh;OHb_ZsY*m z6o4wI(ce4&3vTC^5-yv%qp5?mvjxhO{hvGc>^hx|hYbLK=#=i#X#u<(H;fxjr{Zkn z;N(H4EO}eP*2c-y&FOcWv(@;sjfLX_BMWOII+T&I?eD|C@Fq58BQsOS-}YbFADbjU z1Ox_yLBLNWA0HH<0|K!E-~V_5C9MAL;J4`)dvxzVuEpP8KQSr`Cu>tW0GInoBZ)aX zncF(h@tp+8Oj&{dxAiQ-|4a*R4yN~k1qy@Ufc|;W!GQ7d(cP!}%Ledn z05$mYD4osUHV_nfR#NWl_1lIxOHCJSAP`VF?1Bw?mR~Q}ctK}{-OgUW&&LOX0pXsr z@j-YY!1SH7L3qJHtMfJ(m=AujUnnmWe$fvMRJOYq3lxd`qhAm&7^vBIz7G(B_g`#~ zvnz2fJ`gYDEVZ7u@d0PNXoDeu;(34gA^(^c7~;?PU`U|Y;f1zv1oDr5;a~``yw1l0 zN1UbM^EL#q`-cs3R-o^K9~8h{FWPvafAoQX0i_Ku`oZ8A{lG9d7v~hP{jpA=NH|cC@_c-}An+NodoE@^FbsNeY=G@7rCjhsf-l}jd=S{# zqxzg5U;$n918je+As85Nyx0~D|6@*JfKK$EehA>1aiL!@0(SAb!GP!d#qk2U38<`j zu`TjUulv_HoE(7cZ|Z<^mVobCc$fmYj*dsw*47EYl>bVRvNrc^>HbQLJhGB>_vi%g zo50|}9clzT06-wHi75zzg2GHpjrmMLFcjG2zA(=J+l5Z=tSX|T6YzlgnPg!QFa(an L%q*pJ8|QxjXssKW diff --git a/quantum_espresso/kcp/AFC90/make.rules b/quantum_espresso/kcp/AFC90/make.rules deleted file mode 100755 index 8d63c44f4..000000000 --- a/quantum_espresso/kcp/AFC90/make.rules +++ /dev/null @@ -1,10 +0,0 @@ -.SUFFIXES : -.SUFFIXES : .o .f .f90 - -.f90.o: - gfortran -O3 -x f95-cpp-input -c -I/usr/include/ $< - -.f.o: - gfortran -O3 -c $< - - diff --git a/quantum_espresso/kcp/AFC90/src/Makefile b/quantum_espresso/kcp/AFC90/src/Makefile deleted file mode 100755 index fe772c720..000000000 --- a/quantum_espresso/kcp/AFC90/src/Makefile +++ /dev/null @@ -1,57 +0,0 @@ -include ../../make.sys - -#include make.rules - -#LIBS=-llapack -lblas -lfftw3 - -# targets - -OBJS=\ -afcc.o \ -besseli.o \ -besselk.o \ -cylharm.o \ -cylharm0.o \ -cylharmasympt.o \ -cylharmlogslope.o \ -cylharmrk.o \ -cylharmseries.o \ -cylharmslope.o \ -ei.o \ -eimlog.o \ -fft1d.o \ -fft2d.o \ -fft3d.o \ -gaussian.o \ -gaussiank.o \ -gaussianl.o \ -interp.o \ -main.o \ -nfft.o \ -phi0d.o \ -phi1d.o \ -phi2d.o \ -phi3d.o \ -reciprocal.o \ -rtoaxis.o \ -rungekutta.o \ -steprk.o \ -vectorproduct.o \ -volume.o \ -ydot.o - -AFCFILES= $(OBJS) - -all : $(OBJS) libafc90.a - -libafc90.a: $(AFCFILES) - $(AR) $(ARFLAGS) $@ $? - $(RANLIB) $@ - -clean : - - /bin/rm -f cppp.x *.o *.mod *.a - -tldeps: - test -n "$(TLDEPS)" && ( cd ../.. ; $(MAKE) $(MFLAGS) $(TLDEPS) || exit 1) || : - -include make.depend diff --git a/quantum_espresso/kcp/AFC90/src/afcc.f90 b/quantum_espresso/kcp/AFC90/src/afcc.f90 deleted file mode 100644 index 99c9373c0..000000000 --- a/quantum_espresso/kcp/AFC90/src/afcc.f90 +++ /dev/null @@ -1,250 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function afc(a,npt,tperiodic,spreadopt) - ! - implicit none - ! - real(8), intent(in), optional :: spreadopt - real(8), intent(in), dimension(3,3) :: a - integer, intent(in), dimension(3) :: npt - logical, intent(in), dimension(3) :: tperiodic - real(8), dimension(npt(1),npt(2),npt(3)) :: afc - ! - real(8), dimension(3,3) :: e - real(8), dimension(3,3) :: aaux - real(8), allocatable, dimension(:) :: r - real(8), allocatable, dimension(:,:) :: phi - real(8), allocatable, dimension(:,:,:) :: phi0 - real(8), allocatable, dimension(:,:,:) :: phi1 - real(8), allocatable, dimension(:,:,:) :: phi2 - real(8), allocatable, dimension(:,:,:) :: phi3 - integer, dimension(3) :: nptaux - real(8), dimension(3) :: l - real(8) :: spread - integer, dimension(3) :: i,j - integer :: nperiodic,n,m,p - real(8), parameter :: pi=3.141592653589793d0 - ! - integer :: ierr - CHARACTER(len=5) :: subname="afcc" - ! - interface - ! - function fft1d(in,sign) - complex(8), intent(in), dimension(:) :: in - integer, intent(in) :: sign - complex(8), dimension(size(in)) :: fft1d - end function - ! - function fft2d(in,sign) - complex(8), intent(in), dimension(:,:) :: in - integer, intent(in) :: sign - complex(8), dimension(size(in,1),size(in,2)) :: fft2d - end function - ! - function fft3d(in,sign) - complex(8), intent(in), dimension(:,:,:) :: in - integer, intent(in) :: sign - complex(8), dimension(size(in,1),size(in,2),size(in,3)) :: fft3d - end function - ! - function gaussianl(sigma,g,z) - real(8), intent(in) :: sigma - real(8), intent(in) :: z,g - real(8) :: gaussianl - end function - ! - function phi0d(s,a,npt) - real(8), intent(in) :: s - integer, intent(in), dimension(3) :: npt - real(8), intent(in), dimension(3,3) :: a - real(8), dimension(npt(1),npt(2),npt(3)) :: phi0d - end function - ! - function phi1d(s,a,npt) - real(8), intent(in) :: s - integer, intent(in), dimension(3) :: npt - real(8), intent(in), dimension(3,3) :: a - real(8), dimension(npt(1),npt(2),npt(3)) :: phi1d - end function - ! - function phi2d(s,a,npt) - real(8), intent(in) :: s - integer, intent(in), dimension(3) :: npt - real(8), intent(in), dimension(3,3) :: a - real(8), dimension(npt(1),npt(2),npt(3)) :: phi2d - end function - ! - function phi3d(s,a,npt) - real(8), intent(in) :: s - integer, intent(in), dimension(3) :: npt - real(8), intent(in), dimension(3,3) :: a - real(8), dimension(npt(1),npt(2),npt(3)) :: phi3d - end function - ! - function volume1(a) - real(8), intent(in), dimension(3,3) :: a - real(8) :: volume1 - end function - ! - end interface - ! - l(1)=sqrt(sum(a(1:3,1)**2)) - l(2)=sqrt(sum(a(1:3,2)**2)) - l(3)=sqrt(sum(a(1:3,3)**2)) - e(1:3,1)=a(1:3,1)/l(1) - e(1:3,2)=a(1:3,2)/l(2) - e(1:3,3)=a(1:3,3)/l(3) - ! - if (present(spreadopt)) then - spread=spreadopt - else - spread=minval(l(1:3)/npt(1:3))*5.d0 - endif - ! - nperiodic=count(tperiodic) - ! -#ifdef __AFC90_DEBUG - print *, '#lattice vectors' - print *, '#',a(1:3,1) - print *, '#',a(1:3,2) - print *, '#',a(1:3,3) - print *, '#volume1' - write(6,*) volume1(a), "volume1", a, lbound(a), ubound(a) - !print *, '#',volume1(a) - print *, '#periodicity' - print *, '#',tperiodic(1:3) - print *, '#grid' - print *, '#',npt(1:3) - print *, '#periodicity dimension' - print *, '#',nperiodic - print *, '#Gaussian spread' - print *, '#',spread - print *, '#lattice unit vectors' - print *, '#',e(1:3,1) - print *, '#',e(1:3,2) - print *, '#',e(1:3,3) -#endif - ! - if (nperiodic.eq.0) then - ! - allocate(phi0(npt(1),npt(2),npt(3))) - allocate(phi3(npt(1),npt(2),npt(3))) - !write(6,*) "allocated phi0phi3" - phi0=phi0d(spread,a,npt) - !write(6,*) "called phi0" - phi3=phi3d(spread,a,npt) - !write(6,*) "called phi3" - afc=phi0-phi3+pi/volume1(a)*spread*spread -#ifdef __AFC90_DEBUG - print *, '#phi3(0)', phi3(1,1,1) - print *, '#phi0(0)', phi0(1,1,1) - print *, '#afc(0)', afc(1,1,1) - print *, 'npt', npt -#endif - deallocate(phi0,phi3) - ! - elseif (nperiodic.eq.1) then - ! - do n=1,3 - if (tperiodic(n)) i(3)=n - enddo - i(1)=mod(i(3),3)+1 - i(2)=mod(i(1),3)+1 -#ifdef __AFC90_DEBUG - print *, '#re-indexing' - print *, '#',i -#endif - allocate(phi1(npt(1),npt(2),npt(3))) - allocate(phi3(npt(1),npt(2),npt(3))) - do n=1,3 - aaux(1:3,n)=a(1:3,i(n)) - !write(6,*) "done", n - nptaux(n)=npt(i(n)) - enddo - phi3=phi1d(spread,aaux,nptaux) - !write(6,*) "done phi3", n - do m=1,npt(i(1)) - do n=1,npt(i(2)) - do p=1,npt(i(3)) - j(i(1))=m - j(i(2))=n - j(i(3))=p - phi1(j(1),j(2),j(3))=phi3(m,n,p) - enddo - enddo - enddo - phi3=phi3d(spread,a,npt) - afc=phi1-phi3+pi/volume1(a)*spread*spread -#ifdef __AFC90_DEBUG - print *, '#phi1(0)', phi1(1,1,1) - print *, '#phi3(0)', phi3(1,1,1) - print *, '#afc(0)', afc(1,1,1)+2.d0*log(l(i(1)))-2.d0*log(spread) -#endif - deallocate(phi1,phi3, STAT=ierr) - IF(ierr/=0) call errore(subname,"deallocating phi1,phi3", abs(ierr)) - ! - elseif (nperiodic.eq.2) then - ! - do n=1,3 - if (.not.tperiodic(n)) i(3)=n - enddo - i(1)=mod(i(3),3)+1 - i(2)=mod(i(1),3)+1 -#ifdef __AFC90_DEBUG - print *, '#re-indexing' - print *, '#',i -#endif - allocate(phi2(npt(1),npt(2),npt(3))) - allocate(phi3(npt(1),npt(2),npt(3))) - do n=1,3 - aaux(1:3,n)=a(1:3,i(n)) - nptaux(n)=npt(i(n)) - enddo - phi3=phi2d(spread,aaux,nptaux) - do m=1,npt(i(1)) - do n=1,npt(i(2)) - do p=1,npt(i(3)) - j(i(1))=m - j(i(2))=n - j(i(3))=p - phi2(j(1),j(2),j(3))=phi3(m,n,p) - enddo - enddo - enddo - phi3=phi3d(spread,a,npt) - afc=phi2-phi3+pi/volume1(a)*spread*spread -#ifdef __AFC90_DEBUG - print *, '#phi2(0)', phi2(1,1,1) - print *, '#phi3(0)', phi3(1,1,1) - print *, '#afc(0)', afc(1,1,1) -#endif - deallocate(phi2,phi3) - ! - endif - ! -! do m=1,npt(1) -! do n=1,npt(2) -! do p=1,npt(3) -! ! -! print *, afc(m,n,p) -! ! -! enddo -! enddo -! enddo - ! -end function afc diff --git a/quantum_espresso/kcp/AFC90/src/besseli.f90 b/quantum_espresso/kcp/AFC90/src/besseli.f90 deleted file mode 100644 index 0a1f912a3..000000000 --- a/quantum_espresso/kcp/AFC90/src/besseli.f90 +++ /dev/null @@ -1,36 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function besseli(x) - ! - implicit none - ! - real(8), intent(in) :: x - real(8) :: besseli - real(8), parameter :: eulergamma=0.5772156649015328606d0 - ! - interface - ! - function cylharmseries(a0,b0,sigma,x) - real(8), intent(in) :: a0,b0,sigma,x - real(8) :: cylharmseries - end function - ! - end interface - ! - besseli=cylharmseries(1.d0,0.d0,0.d0,x) - ! -end function besseli diff --git a/quantum_espresso/kcp/AFC90/src/besselk.f90 b/quantum_espresso/kcp/AFC90/src/besselk.f90 deleted file mode 100644 index 162bf2528..000000000 --- a/quantum_espresso/kcp/AFC90/src/besselk.f90 +++ /dev/null @@ -1,42 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function besselk(x) - ! - implicit none - ! - real(8), intent(in) :: x - real(8) :: besselk - real(8), parameter :: eulergamma=0.5772156649015328606d0 - real(8), parameter :: pi=3.141592653589793d0 - real(8), parameter :: xthr=20.d0 - ! - interface - ! - function cylharmseries(a0,b0,sigma,x) - real(8), intent(in) :: a0,b0,sigma,x - real(8) :: cylharmseries - end function - ! - end interface - ! - if (x. -! -function cylharm(dt,sigma,x) - ! - implicit none - ! - real(8), intent(in) :: dt,sigma,x - real(8) :: cylharm - real(8), dimension(2) :: y - ! - interface - ! - function cylharmrk(dt,sigma,x) - real(8), intent(in) :: dt,sigma,x - real(8), dimension(2) :: cylharmrk - end function - ! - end interface - ! - y=cylharmrk(dt,sigma,x) - ! - cylharm=y(1) - ! -end function cylharm diff --git a/quantum_espresso/kcp/AFC90/src/cylharm0.f90 b/quantum_espresso/kcp/AFC90/src/cylharm0.f90 deleted file mode 100644 index fdeaddebe..000000000 --- a/quantum_espresso/kcp/AFC90/src/cylharm0.f90 +++ /dev/null @@ -1,35 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function cylharm0(sigma) - ! - implicit none - ! - real(8), intent(in) :: sigma - real(8) :: cylharm0 - ! - interface - ! - function ei(x) - real(8), intent(in) :: x - real(8) :: ei - end function - ! - end interface - ! - cylharm0=-0.5d0*exp(sigma*sigma/4.d0)*ei(-sigma*sigma/4.d0) - ! -end function cylharm0 diff --git a/quantum_espresso/kcp/AFC90/src/cylharmasympt.f90 b/quantum_espresso/kcp/AFC90/src/cylharmasympt.f90 deleted file mode 100644 index c127d608d..000000000 --- a/quantum_espresso/kcp/AFC90/src/cylharmasympt.f90 +++ /dev/null @@ -1,49 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function cylharmasympt(x) - ! - implicit none - ! - real(8), intent(in) :: x - real(8) :: cylharmasympt - real(8), parameter :: pi=3.141592653589793d0 - ! - cylharmasympt=sqrt(0.5d0*pi)*exp(-exp(x))*exp(-0.5d0*x) - ! -end function cylharmasympt -function cylharmasymptdot(x) - ! - implicit none - ! - real(8), intent(in) :: x - real(8) :: cylharmasymptdot - real(8), parameter :: pi=3.141592653589793d0 - ! - cylharmasymptdot=sqrt(0.5d0*pi)*exp(-exp(x))*exp(-0.5d0*x)*(-exp(x)-0.5d0) - ! -end function cylharmasymptdot -function cylharmasymptdotdot(x) - ! - implicit none - ! - real(8), intent(in) :: x - real(8) :: cylharmasymptdotdot - real(8), parameter :: pi=3.141592653589793d0 - ! - cylharmasymptdotdot=sqrt(0.5d0*pi)*exp(-exp(x))*exp(-0.5d0*x)*((-exp(x)-0.5d0)**2-exp(x)) - ! -end function cylharmasymptdotdot diff --git a/quantum_espresso/kcp/AFC90/src/cylharmlogslope.f90 b/quantum_espresso/kcp/AFC90/src/cylharmlogslope.f90 deleted file mode 100644 index 79a243d00..000000000 --- a/quantum_espresso/kcp/AFC90/src/cylharmlogslope.f90 +++ /dev/null @@ -1,38 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function cylharmlogslope(dt,sigma,x) - ! - implicit none - ! - real(8), intent(in) :: dt,sigma,x - real(8) :: cylharmlogslope - real(8), dimension(2) :: y - ! - interface - ! - function cylharmrk(dt,sigma,x) - real(8), intent(in) :: dt,sigma,x - real(8), dimension(2) :: cylharmrk - end function - ! - end interface - ! - y=cylharmrk(dt,sigma,x) - ! - cylharmlogslope=y(2) - ! -end function cylharmlogslope diff --git a/quantum_espresso/kcp/AFC90/src/cylharmrk.f90 b/quantum_espresso/kcp/AFC90/src/cylharmrk.f90 deleted file mode 100644 index 4eb5f11c2..000000000 --- a/quantum_espresso/kcp/AFC90/src/cylharmrk.f90 +++ /dev/null @@ -1,85 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function cylharmrk(dt,sigma,x) - ! - implicit none - ! - real(8), intent(in) :: dt,sigma,x - real(8), dimension(2) :: cylharmrk - real(8), parameter :: tol=1.d-10 - real(8), parameter :: tmax=20.d0 - real(8), dimension(2) :: y,yd - real(8) :: t0,error,t,tx - integer :: n - ! - interface - ! - function cylharmasympt(x) - real(8), intent(in) :: x - real(8) :: cylharmasympt - end function - ! - function cylharmasymptdot(x) - real(8), intent(in) :: x - real(8) :: cylharmasymptdot - end function - ! - function cylharmasymptdotdot(x) - real(8), intent(in) :: x - real(8) :: cylharmasymptdotdot - end function - ! - function ydot(sigma,t,x) - real(8), intent(in) :: sigma,t - real(8), intent(in), dimension(2) :: x - real(8), dimension(2) :: ydot - end function - ! - function rungekutta(sigma,t,dt,x) - real(8), intent(in), dimension(2) :: x - real(8), intent(in) :: sigma,t,dt - real(8), dimension(2) :: rungekutta - end function - ! - end interface - ! - tx=log(abs(x)) - t0=tx - y=(/cylharmasympt(t0),cylharmasymptdot(t0)/) - yd=ydot(sigma,t0,y) - error=abs(yd(2)-cylharmasymptdotdot(t0)) - searcht0: do while (error>tol) - if (t0+dt>tmax) then - print *, 'warning: maximum t0 reached in subroutine cylharmrk' - exit searcht0 - endif - t0=t0+dt - y=(/cylharmasympt(t0),cylharmasymptdot(t0)/) - yd=ydot(sigma,t0,y) - error=abs(yd(2)-cylharmasymptdotdot(t0)) - enddo searcht0 - y=(/cylharmasympt(t0),cylharmasymptdot(t0)/) - ! - t=t0 - rk: do while (t>tx) - y=rungekutta(sigma,t,-dt,y) - t=t-dt - enddo rk - ! - cylharmrk=y - ! -end function cylharmrk diff --git a/quantum_espresso/kcp/AFC90/src/cylharmseries.f90 b/quantum_espresso/kcp/AFC90/src/cylharmseries.f90 deleted file mode 100644 index 19b308f48..000000000 --- a/quantum_espresso/kcp/AFC90/src/cylharmseries.f90 +++ /dev/null @@ -1,55 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function cylharmseries(a0,b0,sigma,x) - ! - implicit none - ! - real(8), intent(in) :: a0,b0,sigma,x - real(8) :: cylharmseries - real(8), parameter :: tol=1d-20 - real(8), parameter :: pi=3.141592653589793d0 - real(8), parameter :: sigmathr=1.d-50 - integer, parameter :: nmax=50 - integer :: n - real(8) :: an,bn,cn,dy - ! - n=0 - an=a0 - bn=b0 - cn=0.d0 - if (sigma>sigmathr) cn=-2.d0/sigma/sigma - dy=a0+b0*log(abs(x)) - cylharmseries=dy - ! - series: do while (nsigmathr) cn=-cn/n/sigma/sigma - dy=an+bn*log(abs(x)) - cylharmseries=cylharmseries/x/x+dy - if ((abs(dy). -! -function cylharmslope(tol,dt,sigma) - ! - implicit none - ! - real(8), intent(in) :: tol,dt,sigma - real(8) :: cylharmslope - integer, parameter :: nmax=100 !afcmodified:giovanni 100 - real(8) :: t,x,dlogslope - integer :: n - ! - interface - ! - function cylharmlogslope(dt,sigma,x) - real(8), intent(in) :: dt,sigma,x - real(8) :: cylharmlogslope - end function - ! - end interface - ! - t=0.d0 - x=exp(t) - cylharmslope=cylharmlogslope(dt,sigma,x) - t=t-1.d0 - x=exp(t) - dlogslope=cylharmslope - cylharmslope=cylharmlogslope(dt,sigma,x) - dlogslope=abs(cylharmslope-dlogslope) - n=0 - logslope: do while (dlogslope>tol*abs(cylharmslope)) - n=n+1 - if (n>nmax) then - print *, 'warning: nmax exceeded in subroutine cylharmslope' - exit logslope - endif - t=t-1.d0 - x=exp(t) - dlogslope=cylharmslope - cylharmslope=cylharmlogslope(dt,sigma,x) - dlogslope=abs(cylharmslope-dlogslope) - enddo logslope - ! -end function cylharmslope diff --git a/quantum_espresso/kcp/AFC90/src/ei.f90 b/quantum_espresso/kcp/AFC90/src/ei.f90 deleted file mode 100644 index 6c7529c9b..000000000 --- a/quantum_espresso/kcp/AFC90/src/ei.f90 +++ /dev/null @@ -1,39 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function ei(x) - ! - implicit none - ! - real(8), intent(in) :: x - real(8) :: ei - real(8), parameter :: tol=1d-20 - real(8), parameter :: eulergamma=0.5772156649015328606d0 - integer, parameter :: nmax=100 - integer :: n - real(8) :: y,dy - ! - n=1 - dy=x - ei=log(abs(x))+eulergamma+dy - ! - do while ((abs(dy)>tol*abs(ei)).and.(n. -! -function eimlog(x) - ! - implicit none - ! - real(8), intent(in) :: x - real(8) :: eimlog - real(8), parameter :: tol=1d-20 - real(8), parameter :: xthr=25.d0 - real(8), parameter :: eulergamma=0.5772156649015328606d0 - integer, parameter :: nmax=100 - integer :: n - real(8) :: dy - ! - if (x>-xthr) then - n=1 - dy=x - eimlog=eulergamma+dy - loop: do while ((abs(dy)>tol*abs(eimlog)).and.(nnmax) then - print *, 'warning: nmax exceeded in eimlog' - exit loop - endif - dy=dy*x/n - eimlog=eimlog+dy/n - enddo loop - else - eimlog=-log(abs(x)) - endif - ! -end function eimlog diff --git a/quantum_espresso/kcp/AFC90/src/fft1d.f90 b/quantum_espresso/kcp/AFC90/src/fft1d.f90 deleted file mode 100644 index 24605b4c0..000000000 --- a/quantum_espresso/kcp/AFC90/src/fft1d.f90 +++ /dev/null @@ -1,49 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function fft1d(in,sign) - ! - implicit none - ! - complex(8), intent(in), dimension(:) :: in - integer, intent(in) :: sign - complex(8), dimension(size(in)) :: fft1d - complex(8), dimension(size(in)) :: aux - integer(8) :: plan - integer :: n - ! - include "fftw3.f" - ! - n=size(in) - ! - if (sign>0) then - ! - call dfftw_plan_dft_1d(plan,n,in,aux,FFTW_FORWARD,FFTW_ESTIMATE) - call dfftw_execute(plan) - call dfftw_destroy_plan(plan) - ! - else - ! - call dfftw_plan_dft_1d(plan,n,in,aux,FFTW_BACKWARD,FFTW_ESTIMATE) - call dfftw_execute(plan) - call dfftw_destroy_plan(plan) - aux=aux/n - ! - endif - ! - fft1d=aux - ! -end function fft1d diff --git a/quantum_espresso/kcp/AFC90/src/fft2d.f90 b/quantum_espresso/kcp/AFC90/src/fft2d.f90 deleted file mode 100644 index 3358b13ea..000000000 --- a/quantum_espresso/kcp/AFC90/src/fft2d.f90 +++ /dev/null @@ -1,50 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function fft2d(in,sign) - ! - implicit none - ! - complex(8), intent(in), dimension(:,:) :: in - integer, intent(in) :: sign - complex(8), dimension(size(in,1),size(in,2)) :: fft2d - complex(8), dimension(size(in,1),size(in,2)) :: aux - integer(8) :: plan - integer :: nx,ny - ! - include "fftw3.f" - ! - nx=size(in,1) - ny=size(in,2) - ! - if (sign>0) then - ! - call dfftw_plan_dft_2d(plan,nx,ny,in,aux,FFTW_FORWARD,FFTW_ESTIMATE) - call dfftw_execute(plan) - call dfftw_destroy_plan(plan) - ! - else - ! - call dfftw_plan_dft_2d(plan,nx,ny,in,aux,FFTW_BACKWARD,FFTW_ESTIMATE) - call dfftw_execute(plan) - call dfftw_destroy_plan(plan) - aux=aux/nx/ny - ! - endif - ! - fft2d=aux - ! -end function fft2d diff --git a/quantum_espresso/kcp/AFC90/src/fft3d.f90 b/quantum_espresso/kcp/AFC90/src/fft3d.f90 deleted file mode 100644 index 8eb749cc6..000000000 --- a/quantum_espresso/kcp/AFC90/src/fft3d.f90 +++ /dev/null @@ -1,64 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function fft3d(in,sign) - ! - implicit none - ! - complex(8), intent(in), dimension(:,:,:) :: in - integer, intent(in) :: sign - complex(8), dimension(size(in,1),size(in,2),size(in,3)) :: fft3d - complex(8), dimension(size(in,3)) :: aux1 - complex(8), dimension(size(in,1),size(in,2)) :: aux2 - integer :: i,j,nx,ny,nz - ! - interface - ! - function fft1d(in,sign) - complex(8), intent(in), dimension(:) :: in - integer, intent(in) :: sign - complex(8), dimension(size(in)) :: fft1d - end function - ! - function fft2d(in,sign) - complex(8), intent(in), dimension(:,:) :: in - integer, intent(in) :: sign - complex(8), dimension(size(in,1),size(in,2)) :: fft2d - end function - ! - end interface - ! - nx=size(in,1) - ny=size(in,2) - nz=size(in,3) - ! - fft3d=in - ! - do i=1,nz - aux2(1:nx,1:ny)=fft3d(1:nx,1:ny,i) - aux2=fft2d(aux2,sign) - fft3d(1:nx,1:ny,i)=aux2(1:nx,1:ny) - enddo - ! - do i=1,nx - do j=1,ny - aux1(1:nz)=fft3d(i,j,1:nz) - aux1=fft1d(aux1,sign) - fft3d(i,j,1:nz)=aux1(1:nz) - enddo - enddo - ! -end function fft3d diff --git a/quantum_espresso/kcp/AFC90/src/fftw3.f b/quantum_espresso/kcp/AFC90/src/fftw3.f deleted file mode 100644 index 72d1aaf2a..000000000 --- a/quantum_espresso/kcp/AFC90/src/fftw3.f +++ /dev/null @@ -1,72 +0,0 @@ - INTEGER FFTW_R2HC - PARAMETER (FFTW_R2HC=0) - INTEGER FFTW_HC2R - PARAMETER (FFTW_HC2R=1) - INTEGER FFTW_DHT - PARAMETER (FFTW_DHT=2) - INTEGER FFTW_REDFT00 - PARAMETER (FFTW_REDFT00=3) - INTEGER FFTW_REDFT01 - PARAMETER (FFTW_REDFT01=4) - INTEGER FFTW_REDFT10 - PARAMETER (FFTW_REDFT10=5) - INTEGER FFTW_REDFT11 - PARAMETER (FFTW_REDFT11=6) - INTEGER FFTW_RODFT00 - PARAMETER (FFTW_RODFT00=7) - INTEGER FFTW_RODFT01 - PARAMETER (FFTW_RODFT01=8) - INTEGER FFTW_RODFT10 - PARAMETER (FFTW_RODFT10=9) - INTEGER FFTW_RODFT11 - PARAMETER (FFTW_RODFT11=10) - INTEGER FFTW_FORWARD - PARAMETER (FFTW_FORWARD=-1) - INTEGER FFTW_BACKWARD - PARAMETER (FFTW_BACKWARD=+1) - INTEGER FFTW_MEASURE - PARAMETER (FFTW_MEASURE=0) - INTEGER FFTW_DESTROY_INPUT - PARAMETER (FFTW_DESTROY_INPUT=1) - INTEGER FFTW_UNALIGNED - PARAMETER (FFTW_UNALIGNED=2) - INTEGER FFTW_CONSERVE_MEMORY - PARAMETER (FFTW_CONSERVE_MEMORY=4) - INTEGER FFTW_EXHAUSTIVE - PARAMETER (FFTW_EXHAUSTIVE=8) - INTEGER FFTW_PRESERVE_INPUT - PARAMETER (FFTW_PRESERVE_INPUT=16) - INTEGER FFTW_PATIENT - PARAMETER (FFTW_PATIENT=32) - INTEGER FFTW_ESTIMATE - PARAMETER (FFTW_ESTIMATE=64) - INTEGER FFTW_WISDOM_ONLY - PARAMETER (FFTW_WISDOM_ONLY=2097152) - INTEGER FFTW_ESTIMATE_PATIENT - PARAMETER (FFTW_ESTIMATE_PATIENT=128) - INTEGER FFTW_BELIEVE_PCOST - PARAMETER (FFTW_BELIEVE_PCOST=256) - INTEGER FFTW_NO_DFT_R2HC - PARAMETER (FFTW_NO_DFT_R2HC=512) - INTEGER FFTW_NO_NONTHREADED - PARAMETER (FFTW_NO_NONTHREADED=1024) - INTEGER FFTW_NO_BUFFERING - PARAMETER (FFTW_NO_BUFFERING=2048) - INTEGER FFTW_NO_INDIRECT_OP - PARAMETER (FFTW_NO_INDIRECT_OP=4096) - INTEGER FFTW_ALLOW_LARGE_GENERIC - PARAMETER (FFTW_ALLOW_LARGE_GENERIC=8192) - INTEGER FFTW_NO_RANK_SPLITS - PARAMETER (FFTW_NO_RANK_SPLITS=16384) - INTEGER FFTW_NO_VRANK_SPLITS - PARAMETER (FFTW_NO_VRANK_SPLITS=32768) - INTEGER FFTW_NO_VRECURSE - PARAMETER (FFTW_NO_VRECURSE=65536) - INTEGER FFTW_NO_SIMD - PARAMETER (FFTW_NO_SIMD=131072) - INTEGER FFTW_NO_SLOW - PARAMETER (FFTW_NO_SLOW=262144) - INTEGER FFTW_NO_FIXED_RADIX_LARGE_N - PARAMETER (FFTW_NO_FIXED_RADIX_LARGE_N=524288) - INTEGER FFTW_ALLOW_PRUNING - PARAMETER (FFTW_ALLOW_PRUNING=1048576) diff --git a/quantum_espresso/kcp/AFC90/src/gaussian.f90 b/quantum_espresso/kcp/AFC90/src/gaussian.f90 deleted file mode 100644 index 67b2ded3f..000000000 --- a/quantum_espresso/kcp/AFC90/src/gaussian.f90 +++ /dev/null @@ -1,33 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function gaussian(sigma,x) - ! - implicit none - ! - real(8), intent(in) :: sigma - real(8), intent(in) :: x - real(8) :: gaussian - real(8), parameter :: pi=3.141592653589793d0 - real(8), parameter :: sigmathr=1.d-50 - ! - if (sigma>sigmathr) then - gaussian=1.d0/pi/sigma/sigma*exp(-x*x/sigma/sigma) - else - gaussian=0.d0 - endif - ! -end function gaussian diff --git a/quantum_espresso/kcp/AFC90/src/gaussiank.f90 b/quantum_espresso/kcp/AFC90/src/gaussiank.f90 deleted file mode 100644 index d3b5d246c..000000000 --- a/quantum_espresso/kcp/AFC90/src/gaussiank.f90 +++ /dev/null @@ -1,182 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function gaussiank(sigma,x) - ! - implicit none - ! - real(8), intent(in) :: sigma - real(8), intent(in), dimension(:) :: x - real(8), dimension(size(x)) :: gaussiank - real(8), parameter :: sigmamax=4.d0 - real(8), parameter :: sigmamin=1.d-6 - real(8), parameter :: tmax=20.d0 - real(8), parameter :: tol=1.d-10 - real(8), parameter :: xthr=1.d-10 - real(8), dimension(2) :: yd,y - real(8) :: logslope - real(8) :: temp1,temp2,x1,t1,t0,tx,t,dt - real(8) :: error - real(8), allocatable, dimension(:,:) :: z - integer :: i,n,nt - ! - interface - ! - function besselk(x) - real(8), intent(in) :: x - real(8) :: besselk - end function - ! - function cylharm(dt,sigma,x) - real(8), intent(in) :: dt,sigma,x - real(8) :: cylharm - end function - ! - function cylharm0(sigma) - real(8), intent(in) :: sigma - real(8) :: cylharm0 - end function - ! - function cylharmasympt(x) - real(8), intent(in) :: x - real(8) :: cylharmasympt - end function - ! - function cylharmasymptdot(x) - real(8), intent(in) :: x - real(8) :: cylharmasymptdot - end function - ! - function cylharmasymptdotdot(x) - real(8), intent(in) :: x - real(8) :: cylharmasymptdotdot - end function - ! - function cylharmseries(a0,b0,sigma,x) - real(8), intent(in) :: a0,b0,sigma,x - real(8) :: cylharmseries - end function - ! - function cylharmslope(tol,dt,sigma) - real(8), intent(in) :: tol,dt,sigma - real(8) :: cylharmslope - end function - ! - function pinterp(x,side,bound) - real(8), intent(in) :: x - integer :: side,bound - real(8) :: pinterp - end function - ! - function qinterp(x,side,bound) - real(8), intent(in) :: x - integer :: side,bound - real(8) :: qinterp - end function - ! - function rungekutta(sigma,t,dt,x) - real(8), intent(in), dimension(2) :: x - real(8), intent(in) :: sigma,t,dt - real(8), dimension(2) :: rungekutta - end function - ! - function steprk(sigma) - real(8), intent(in) :: sigma - real(8) :: steprk - end function - ! - function ydot(sigma,t,x) - real(8), intent(in) :: sigma,t - real(8), intent(in), dimension(2) :: x - real(8), dimension(2) :: ydot - end function - ! - end interface - ! - if (sigma.le.sigmamin) then - do i=1,size(x) - gaussiank(i)=besselk(x(i)) - enddo - elseif (sigma.ge.sigmamax) then - gaussiank(:)=0.d0 - else - ! - dt=steprk(sigma) -#ifdef __AFC90_DEBUG - write(6,*) dt, "time" - write(0,*) "entering logslope" -#endif - logslope=cylharmslope(1.d-10,dt,sigma) -! stop - ! - x1=max(minval(x),xthr) - t1=log(x1) - t0=t1 - nt=1 - y=(/cylharmasympt(t0),cylharmasymptdot(t0)/) - yd=ydot(sigma,t0,y) - error=abs(yd(2)-cylharmasymptdotdot(t0)) - searcht0: do while (error>tol) - if (t0+dt>tmax) then - print *, 'warning: maximum t0 reached in subroutine gaussiank' - exit searcht0 - endif - t0=t0+dt - nt=nt+1 - y=(/cylharmasympt(t0),cylharmasymptdot(t0)/) - yd=ydot(sigma,t0,y) - error=abs(yd(2)-cylharmasymptdotdot(t0)) - enddo searcht0 - ! - allocate(z(2,nt)) - n=nt - t=t0 - z(1:2,n)=(/cylharmasympt(t),cylharmasymptdot(t)/) - rk: do while (t>t1) - z(1:2,n-1)=rungekutta(sigma,t,-dt,z(1:2,n)) - t=t-dt - n=n-1 - enddo rk - ! - do i=1,size(x) - if (x(i)>xthr) then - tx=log(max(x(i),xthr)) - if (tx>t0) then - temp1=cylharmasympt(tx)+logslope*besselk(x(i)) - else - n=int((tx-t1)/dt)+1 - t=t1+(n-1)*dt - temp1=pinterp((tx-t)/dt,0,0)*z(1,n) & - +pinterp((tx-t)/dt,1,0)*z(1,n+1) & - +dt*qinterp((tx-t)/dt,1,0)*z(2,n) & - +dt*qinterp((tx-t)/dt,1,0)*z(2,n+1) & - +logslope*besselk(x(i)) - temp2=cylharmseries(cylharm0(sigma),0.d0,sigma,x(i)) - if (abs(temp1-temp2)>tol*abs(temp1).or.isnan(temp2)) then - gaussiank(i)=temp1 - else - gaussiank(i)=temp2 - endif - endif - else - gaussiank(i)=cylharm0(sigma) - endif - enddo - deallocate(z) - ! - endif - ! -end function gaussiank diff --git a/quantum_espresso/kcp/AFC90/src/gaussianl.f90 b/quantum_espresso/kcp/AFC90/src/gaussianl.f90 deleted file mode 100644 index 84ce146f6..000000000 --- a/quantum_espresso/kcp/AFC90/src/gaussianl.f90 +++ /dev/null @@ -1,50 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function gaussianl(sigma,g,z) - ! - implicit none - ! - real(8), intent(in) :: sigma - real(8), intent(in) :: z,g - real(8) :: gaussianl - real(8), parameter :: pi=3.141592653589793d0 - real(8), parameter :: sigmathr=1.d-50 - real(8), parameter :: gthr=1.d-50 - real(8), parameter :: expthr=500.d0 - ! - if (g>gthr) then - if (g*abs(z)sigmathr) then - gaussianl=pi/g*(exp(g*z)*(1.d0-erf(z/sigma+sigma*g/2.d0)) & - +exp(-g*z)*(1.d0+erf(z/sigma-sigma*g/2.d0))) - else - gaussianl=2.d0*pi/g*exp(-g*abs(z)) - endif - ! - else - print *, 'warning: expthr exceeded in gaussianl' - gaussianl=0.d0 - endif - else - if (sigma>sigmathr) then - gaussianl=-2.d0*pi*(z*erf(z/sigma)+sigma/sqrt(pi)*exp(-z*z/sigma/sigma)) - else - gaussianl=-2.d0*pi*abs(z) - endif - endif - ! -end function gaussianl diff --git a/quantum_espresso/kcp/AFC90/src/interp.f90 b/quantum_espresso/kcp/AFC90/src/interp.f90 deleted file mode 100644 index 0069a3477..000000000 --- a/quantum_espresso/kcp/AFC90/src/interp.f90 +++ /dev/null @@ -1,143 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function pinterp(x,side,bound) - ! - ! interpolation polynomial satifying - ! p'(0)=0,p'(1)=0,p(0)=1,p(1)=0 for side=0,bound=0 - ! p'(0)=0,p'(1)=0,p(0)=0,p(1)=1 for side=1,bound=0 - ! p'(1)=0,p(0)=0,p(1)=1 for side=1,bound=-1 - ! p'(1)=0,p(0)=1,p(1)=0 for side=0,bound=-1 - ! p'(0)=0,p(0)=0,p(1)=1 for side=1,bound=1 - ! p'(0)=0,p(0)=1,p(1)=0 for side=0,bound=1 - ! - implicit none - ! - real(8) :: pinterp - real(8) :: x - integer :: side - integer :: bound - ! - if( bound == 0 .and. side == 1 ) then - pinterp = 3.d0 * x * x - 2.d0 * x * x * x - else if( bound == 0 .and. side == 0 ) then - pinterp = 1.d0 - 3.d0 * x * x + 2.d0 * x * x * x - else if( bound == - 1 .and. side == 0 ) then - pinterp = 1.d0 - 2.d0 * x + x * x - else if( bound == - 1 .and. side == 1 ) then - pinterp = 2.d0 * x - x * x - else if( bound == 1 .and. side == 1 ) then - pinterp = x * x - else if( bound == 1 .and. side == 0 ) then - pinterp = 1 - x * x - end if - ! - return - ! -end function pinterp - -function dpinterp(x,side,bound) - ! - ! derivative of pinterp - ! - implicit none - ! - real(8) :: dpinterp - real(8) :: x - integer :: side - integer :: bound - ! - if( bound == 0 .and. side == 1 ) then - dpinterp = 6.d0 * x - 6.d0 * x * x - else if( bound == 0 .and. side == 0 ) then - dpinterp = - 6.d0 * x + 6.d0 * x * x - else if( bound == - 1 .and. side == 0 ) then - dpinterp = - 2.d0 + 2 * x - else if( bound == - 1 .and. side == 1 ) then - dpinterp = 2.d0 - 2 * x - else if( bound == 1 .and. side == 1 ) then - dpinterp = 2 * x - else if( bound == 1 .and. side == 0 ) then - dpinterp = - 2 * x - end if - ! - return - ! -end function dpinterp - -function qinterp(x,side,bound) - ! - ! interpolation polynomial satifying - ! q'(0)=1,q'(1)=0,q(0)=0,q(1)=0 for side=0,bound=0 - ! q'(0)=0,q'(1)=1,q(0)=0,q(1)=0 for side=1,bound=0 - ! q'(1)=1,q(0)=0,q(1)=0 for side=1,bound=-1 - ! q'(0)=1,q(0)=0,q(1)=0 for side=0,bound=-1 - ! q'(1)=1,q(0)=0,q(1)=0 for side=1,bound=1 - ! q'(0)=1,q(0)=0,q(1)=0 for side=0,bound=1 - ! - implicit none - ! - real(8) :: qinterp - real(8) :: x - integer :: side - integer :: bound - ! - if( bound == 0 .and. side == 1 ) then - qinterp = - x * x + x * x * x - else if( bound == 0 .and. side == 0 ) then - qinterp = x - 2.d0 * x * x + x * x * x - else if( bound == - 1 .and. side == 0 ) then - qinterp = 0.d0 - else if( bound == 1 .and. side == 1 ) then - qinterp = 0.d0 - else if( bound == - 1 .and. side == 1 ) then - qinterp = - x + x * x - else if( bound == 1 .and. side == 0 ) then - qinterp = x - x * x - end if - ! - return - ! -end function qinterp - -function dqinterp(x,side,bound) - ! - ! derivative of qinterp - ! - implicit none - ! - real(8) :: dqinterp - real(8) :: x - integer :: side - integer :: bound - ! - if( bound == 0 .and. side == 1 ) then - dqinterp = - 2 * x + 3 * x * x - else if( bound == 0 .and. side == 0 ) then - dqinterp = 1 - 4.d0 * x + 3 * x * x - else if( bound == - 1 .and. side == 0 ) then - dqinterp = 0.d0 - else if( bound == 1 .and. side == 1 ) then - dqinterp = 0.d0 - else if( bound == - 1 .and. side == 1 ) then - dqinterp = - 1 + 2 * x - else if( bound == 1 .and. side == 0 ) then - dqinterp = 1 - 2 * x - end if - ! - return - ! -end function dqinterp diff --git a/quantum_espresso/kcp/AFC90/src/main.f90 b/quantum_espresso/kcp/AFC90/src/main.f90 deleted file mode 100644 index ed9c5d63e..000000000 --- a/quantum_espresso/kcp/AFC90/src/main.f90 +++ /dev/null @@ -1,222 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -program main - ! - implicit none - ! - real(8) :: spread - real(8), dimension(3,3) :: a,aaux - real(8), dimension(3,3) :: e - real(8), allocatable, dimension(:) :: r - real(8), allocatable, dimension(:,:) :: phi - real(8), allocatable, dimension(:,:,:) :: phi0 - real(8), allocatable, dimension(:,:,:) :: phi1 - real(8), allocatable, dimension(:,:,:) :: phi2 - real(8), allocatable, dimension(:,:,:) :: phi3 - real(8), allocatable, dimension(:,:,:) :: afc - logical, dimension(3) :: tperiodic - integer, dimension(3) :: npt,nptaux - real(8), dimension(3) :: l - integer, dimension(3) :: i,j - integer :: nperiodic,n,m,p - real(8), parameter :: pi=3.141592653589793d0 - ! - namelist / input / spread, a, tperiodic, npt - ! - interface - ! - function fft1d(in,sign) - complex(8), intent(in), dimension(:) :: in - integer, intent(in) :: sign - complex(8), dimension(size(in)) :: fft1d - end function - ! - function fft2d(in,sign) - complex(8), intent(in), dimension(:,:) :: in - integer, intent(in) :: sign - complex(8), dimension(size(in,1),size(in,2)) :: fft2d - end function - ! - function fft3d(in,sign) - complex(8), intent(in), dimension(:,:,:) :: in - integer, intent(in) :: sign - complex(8), dimension(size(in,1),size(in,2),size(in,3)) :: fft3d - end function - ! - function gaussianl(sigma,g,z) - real(8), intent(in) :: sigma - real(8), intent(in) :: z,g - real(8) :: gaussianl - end function - ! - function phi0d(s,a,npt) - real(8), intent(in) :: s - integer, intent(in), dimension(3) :: npt - real(8), intent(in), dimension(3,3) :: a - real(8), dimension(npt(1),npt(2),npt(3)) :: phi0d - end function - ! - function phi1d(s,a,npt) - real(8), intent(in) :: s - integer, intent(in), dimension(3) :: npt - real(8), intent(in), dimension(3,3) :: a - real(8), dimension(npt(1),npt(2),npt(3)) :: phi1d - end function - ! - function phi2d(s,a,npt) - real(8), intent(in) :: s - integer, intent(in), dimension(3) :: npt - real(8), intent(in), dimension(3,3) :: a - real(8), dimension(npt(1),npt(2),npt(3)) :: phi2d - end function - ! - function phi3d(s,a,npt) - real(8), intent(in) :: s - integer, intent(in), dimension(3) :: npt - real(8), intent(in), dimension(3,3) :: a - real(8), dimension(npt(1),npt(2),npt(3)) :: phi3d - end function - ! - function volume1(a) - real(8), intent(in), dimension(3,3) :: a - real(8) :: volume1 - end function - ! - end interface - ! - read(5,input) - ! - nperiodic=count(tperiodic) - ! - print *, '#lattice vectors' - print *, '#',a(1:3,1) - print *, '#',a(1:3,2) - print *, '#',a(1:3,3) - print *, '#volume1' - print *, '#',volume1(a) - print *, '#periodicity' - print *, '#',tperiodic(1:3) - print *, '#grid' - print *, '#',npt(1:3) - print *, '#periodic dimension' - print *, '#',nperiodic - print *, '#Gaussian spread' - print *, '#',spread - ! - l(1)=sqrt(sum(a(1:3,1)**2)) - l(2)=sqrt(sum(a(1:3,2)**2)) - l(3)=sqrt(sum(a(1:3,3)**2)) - e(1:3,1)=a(1:3,1)/l(1) - e(1:3,2)=a(1:3,2)/l(2) - e(1:3,3)=a(1:3,3)/l(3) - print *, '#lattice unit vectors' - print *, '#',e(1:3,1) - print *, '#',e(1:3,2) - print *, '#',e(1:3,3) - ! - allocate(afc(npt(1),npt(2),npt(3))) - ! - if (nperiodic.eq.0) then - ! - allocate(phi0(npt(1),npt(2),npt(3))) - allocate(phi3(npt(1),npt(2),npt(3))) - phi0=phi0d(spread,a,npt) - phi3=phi3d(spread,a,npt) - afc=phi0-phi3+pi/volume1(a)*spread*spread - print *, '#phi0(0)', phi0(1,1,1) - print *, '#phi3(0)', phi3(1,1,1) - print *, '#afc(0)', afc(1,1,1) - !print *,afc - deallocate(phi0,phi3) - ! - elseif (nperiodic.eq.1) then - ! - do n=1,3 - if (tperiodic(n)) i(3)=n - enddo - i(1)=mod(i(3),3)+1 - i(2)=mod(i(1),3)+1 - print *, '#re-indexing' - print *, '#',i - allocate(phi1(npt(1),npt(2),npt(3))) - allocate(phi3(npt(1),npt(2),npt(3))) - do n=1,3 - aaux(1:3,n)=a(1:3,i(n)) - nptaux(n)=npt(i(n)) - enddo - phi3=phi1d(spread,aaux,nptaux) - do m=1,npt(i(1)) - do n=1,npt(i(2)) - do p=1,npt(i(3)) - j(i(1))=m - j(i(2))=n - j(i(3))=p - phi1(j(1),j(2),j(3))=phi3(m,n,p) - enddo - enddo - enddo - phi3=phi3d(spread,a,npt) - afc=phi1-phi3+pi/volume1(a)*spread*spread -#ifdef __AFC90_DEBUG - print *, '#phi1(0)', phi1(1,1,1) - print *, '#phi3(0)', phi3(1,1,1) - print *, '#afc(0)', afc(1,1,1)+2.d0*log(l(i(1)))-2.d0*log(spread) -#endif - deallocate(phi1,phi3) - ! - elseif (nperiodic.eq.2) then - ! - do n=1,3 - if (.not.tperiodic(n)) i(3)=n - enddo - i(1)=mod(i(3),3)+1 - i(2)=mod(i(1),3)+1 -#ifdef __AFC90_DEBUG - print *, '#re-indexing' - print *, '#',i -#endif - allocate(phi2(npt(1),npt(2),npt(3))) - allocate(phi3(npt(1),npt(2),npt(3))) - do n=1,3 - aaux(1:3,n)=a(1:3,i(n)) - nptaux(n)=npt(i(n)) - enddo - phi3=phi2d(spread,aaux,nptaux) - do m=1,npt(i(1)) - do n=1,npt(i(2)) - do p=1,npt(i(3)) - j(i(1))=m - j(i(2))=n - j(i(3))=p - phi2(j(1),j(2),j(3))=phi3(m,n,p) - enddo - enddo - enddo - phi3=phi3d(spread,a,npt) - afc=phi2-phi3+pi/volume1(a)*spread*spread -#ifdef __AFC90_DEBUG - print *, '#phi2(0)', phi2(1,1,1) - print *, '#phi3(0)', phi3(1,1,1) - print *, '#afc(0)', afc(1,1,1) -#endif - deallocate(phi2,phi3) - ! - endif - ! - deallocate(afc) - ! -end program diff --git a/quantum_espresso/kcp/AFC90/src/make.depend b/quantum_espresso/kcp/AFC90/src/make.depend deleted file mode 100644 index e69de29bb..000000000 diff --git a/quantum_espresso/kcp/AFC90/src/nfft.f90 b/quantum_espresso/kcp/AFC90/src/nfft.f90 deleted file mode 100644 index 90007e363..000000000 --- a/quantum_espresso/kcp/AFC90/src/nfft.f90 +++ /dev/null @@ -1,29 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function nfft(k,n) - ! - implicit none - ! - integer, intent(in) :: k,n - integer :: nfft - ! - nfft=mod(k-1,n) - if (nfft.gt.n-nfft) then - nfft=nfft-n - endif - ! -end function nfft diff --git a/quantum_espresso/kcp/AFC90/src/phi0d.f90 b/quantum_espresso/kcp/AFC90/src/phi0d.f90 deleted file mode 100644 index c1a074128..000000000 --- a/quantum_espresso/kcp/AFC90/src/phi0d.f90 +++ /dev/null @@ -1,60 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function phi0d(s,a,npt) - ! - implicit none - ! - real(8), intent(in) :: s - integer, intent(in), dimension(3) :: npt - real(8), intent(in), dimension(3,3) :: a - real(8), dimension(npt(1),npt(2),npt(3)) :: phi0d - real(8), parameter :: pi=3.141592653589793d0 - real(8), parameter :: rthr=1.d-10 - real(8) :: r - integer :: i,j,k,n,m,p - ! - interface - ! - function nfft(k,n) - integer, intent(in) :: k,n - integer :: nfft - end function - ! - function volume1(a) - real(8), intent(in), dimension(3,3) :: a - real(8) :: volume1 - end function - ! - end interface - ! - do i=1,npt(1) - m=nfft(i,npt(1)) - do j=1,npt(2) - n=nfft(j,npt(2)) - do k=1,npt(3) - p=nfft(k,npt(3)) - r=sqrt(sum((m*a(1:3,1)/npt(1)+n*a(1:3,2)/npt(2)+p*a(1:3,3)/npt(3))**2)) - if (r>rthr) then - phi0d(i,j,k)=erf(r/s)/r - else - phi0d(i,j,k)=2.d0/sqrt(pi)/s - endif - enddo - enddo - enddo - ! -end function phi0d diff --git a/quantum_espresso/kcp/AFC90/src/phi1d.f90 b/quantum_espresso/kcp/AFC90/src/phi1d.f90 deleted file mode 100644 index 6036870cb..000000000 --- a/quantum_espresso/kcp/AFC90/src/phi1d.f90 +++ /dev/null @@ -1,110 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function phi1d(s,a,npt) - ! - implicit none - ! - real(8), intent(in) :: s - integer, intent(in), dimension(3) :: npt - real(8), intent(in), dimension(3,3) :: a - real(8), dimension(npt(1),npt(2),npt(3)) :: phi1d - real(8), parameter :: pi=3.141592653589793d0 - real(8), parameter :: sthr=1.d-50 - real(8) :: sigma,g,l,phase,z - real(8), dimension(npt(1)*npt(2)) :: x - real(8), dimension(npt(1)*npt(2)) :: r - real(8), dimension(3) :: epara - complex(8), dimension(npt(1)*npt(2),npt(3)) :: phi - complex(8), dimension(npt(3)) :: aux1 - integer :: i,j,k,n,m,p,nr - ! - interface - ! - function fft1d(in,sign) - complex(8), intent(in), dimension(:) :: in - integer, intent(in) :: sign - complex(8), dimension(size(in)) :: fft1d - end function - ! - function gaussiank(sigma,x) - real(8), intent(in) :: sigma - real(8), intent(in), dimension(:) :: x - real(8), dimension(size(x)) :: gaussiank - end function - ! - function eimlog(x) - real(8), intent(in) :: x - real(8) :: eimlog - end function - ! - function nfft(k,n) - integer, intent(in) :: k,n - integer :: nfft - end function - ! - function rtoaxis(a1,a2,n1,n2,e3) - real(8), intent(in), dimension(3) :: a1,a2,e3 - integer, intent(in) :: n1,n2 - real(8), dimension(n1*n2) :: rtoaxis - end function - ! - end interface - ! - nr=npt(1)*npt(2) - l=sqrt(sum(a(1:3,3)**2)) - epara=a(1:3,3)/l - r=rtoaxis(a(1:3,1),a(1:3,2),npt(1),npt(2),epara) - ! - phi1d=0.d0 - do i=1,npt(3) - g=abs(2.d0*pi/l*nfft(i,npt(3))) - if (g.eq.0.d0) then - if (s>sthr) then - do j=1,nr - phi(j,i)=eimlog(-r(j)*r(j)/s/s) - enddo - else - do j=1,nr - phi(j,i)=-2.d0*log(r(j)) - enddo - endif - else - x=g*r - sigma=g*s - phi(1:nr,i)=2.d0*gaussiank(sigma,x) - endif - phi(1:nr,i)=phi(1:nr,i)*exp(-g*g*s*s/4.d0)/l - enddo - ! - do i=1,npt(1) - m=nfft(i,npt(1)) - do j=1,npt(2) - n=nfft(j,npt(2)) - do k=1,npt(3) - p=nfft(k,npt(3)) - g=2.d0*pi/l*p - z=sum(epara(1:3)*(m*a(1:3,1)/npt(1)+n*a(1:3,2)/npt(2))) - phase=g*z - aux1(k)=phi(i+npt(1)*(j-1),k)*cmplx(cos(phase),sin(phase)) - enddo - aux1=fft1d(aux1,1) - !aux1=0.d0 - phi1d(i,j,1:npt(3))=aux1(1:npt(3)) - enddo - enddo - ! -end function phi1d diff --git a/quantum_espresso/kcp/AFC90/src/phi2d.f90 b/quantum_espresso/kcp/AFC90/src/phi2d.f90 deleted file mode 100644 index 267ebcc15..000000000 --- a/quantum_espresso/kcp/AFC90/src/phi2d.f90 +++ /dev/null @@ -1,98 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function phi2d(s,a,npt) - ! - implicit none - ! - real(8), intent(in) :: s - integer, intent(in), dimension(3) :: npt - real(8), intent(in), dimension(3,3) :: a - real(8), dimension(npt(1),npt(2),npt(3)) :: phi2d - real(8), dimension(3,3) :: b - real(8), dimension(3) :: eperp,apara - real(8) :: z,surface,g,phase - complex(8), dimension(npt(1),npt(2)) :: aux - complex(8), dimension(npt(1),npt(2),npt(3)) :: phi - integer :: i,j,k,m,n,p - ! - interface - ! - function fft2d(in,sign) - complex(8), intent(in), dimension(:,:) :: in - integer, intent(in) :: sign - complex(8), dimension(size(in,1),size(in,2)) :: fft2d - end function - ! - function gaussianl(sigma,g,z) - real(8), intent(in) :: sigma - real(8), intent(in) :: z,g - real(8) :: gaussianl - end function - ! - function nfft(k,n) - integer, intent(in) :: k,n - integer :: nfft - end function - ! - function reciprocal(a) - real(8), intent(in), dimension(3,3) :: a - real(8), dimension(3,3) :: reciprocal - end function - ! - function vectorproduct(u,v) - real(8), intent(in), dimension(3) :: u,v - real(8), dimension(3) :: vectorproduct - end function - ! - end interface - ! - eperp=vectorproduct(a(1:3,1),a(1:3,2)) - surface=sqrt(abs(sum(eperp**2))) - if (sum(a(1:3,3)*eperp(1:3))>0.d0) then - eperp=eperp/surface - else - eperp=-eperp/surface - endif - apara(1:3)=a(1:3,3)-sum(a(1:3,3)*eperp(1:3))*eperp(1:3) - ! - b=a - b(1:3,3)=a(1:3,3)-apara(1:3) - b=reciprocal(b) - ! - do i=1,npt(1) - m=nfft(i,npt(1)) - do j=1,npt(2) - n=nfft(j,npt(2)) - g=sqrt(sum((m*b(1:3,1)+n*b(1:3,2))**2)) - phase=sum((m*b(1:3,1)+n*b(1:3,2))*apara(1:3)) - do k=1,npt(3) - p=nfft(k,npt(3)) - z=p*sum(eperp(1:3)*a(1:3,3))/npt(3) - phi(i,j,k)=gaussianl(s,g,z)*cmplx(cos(p*phase/npt(3)),sin(p*phase/npt(3))) - enddo - enddo - enddo - ! - do k=1,npt(3) - aux=phi(:,:,k) - aux=fft2d(aux,1) - phi2d(:,:,k)=aux - enddo - ! - phi2d=phi2d/surface - ! -end function phi2d diff --git a/quantum_espresso/kcp/AFC90/src/phi3d.f90 b/quantum_espresso/kcp/AFC90/src/phi3d.f90 deleted file mode 100644 index 2e956ce6d..000000000 --- a/quantum_espresso/kcp/AFC90/src/phi3d.f90 +++ /dev/null @@ -1,80 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function phi3d(s,a,npt) - ! - implicit none - ! - real(8), intent(in) :: s - integer, intent(in), dimension(3) :: npt - real(8), intent(in), dimension(3,3) :: a - real(8), dimension(npt(1),npt(2),npt(3)) :: phi3d - complex(8), dimension(npt(1),npt(2),npt(3)) :: aux - real(8), parameter :: pi=3.141592653589793d0 - real(8), parameter :: gthr=1.d-10 - real(8) :: omega, g - real(8), dimension(3,3) :: b - integer :: i,j,k,n,m,p - ! - interface - ! - function fft3d(in,sign) - complex(8), intent(in), dimension(:,:,:) :: in - integer, intent(in) :: sign - complex(8), dimension(size(in,1),size(in,2),size(in,3)) :: fft3d - end function - ! - function nfft(k,n) - integer, intent(in) :: k,n - integer :: nfft - end function - ! - function reciprocal(a) - real(8), intent(in), dimension(3,3) :: a - real(8), dimension(3,3) :: reciprocal - end function - ! - function volume1(a) - real(8), intent(in), dimension(3,3) :: a - real(8) :: volume1 - end function - ! - end interface - ! - b=reciprocal(a) - omega=volume1(a) - ! - do i=1,npt(1) - m=nfft(i,npt(1)) - do j=1,npt(2) - n=nfft(j,npt(2)) - do k=1,npt(3) - p=nfft(k,npt(3)) - g=sqrt(sum((m*b(1:3,1)+n*b(1:3,2)+p*b(1:3,3))**2)) - if (g.ge.gthr) then - phi3d(i,j,k)=4.d0*pi/omega/g/g*exp(-s*s*g*g/4.d0) - else - phi3d(i,j,k)=0.d0 - endif - enddo - enddo - enddo - ! - aux=phi3d - aux=fft3d(aux,1) - phi3d=aux - ! -end function phi3d diff --git a/quantum_espresso/kcp/AFC90/src/reciprocal.f90 b/quantum_espresso/kcp/AFC90/src/reciprocal.f90 deleted file mode 100644 index 04c26c887..000000000 --- a/quantum_espresso/kcp/AFC90/src/reciprocal.f90 +++ /dev/null @@ -1,43 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function reciprocal(a) - ! - implicit none - ! - real(8), intent(in), dimension(3,3) :: a - real(8), dimension(3,3) :: reciprocal - real(8), parameter :: pi=3.141592653589793d0 - ! - interface - ! - function vectorproduct(u,v) - real(8), intent(in), dimension(3) :: u,v - real(8), dimension(3) :: vectorproduct - end function - ! - end interface - ! - reciprocal(1:3,1)=vectorproduct(a(1:3,2),a(1:3,3)) - reciprocal(1:3,1)=reciprocal(1:3,1)/sum(reciprocal(1:3,1)*a(1:3,1)) - reciprocal(1:3,2)=vectorproduct(a(1:3,3),a(1:3,1)) - reciprocal(1:3,2)=reciprocal(1:3,2)/sum(reciprocal(1:3,2)*a(1:3,2)) - reciprocal(1:3,3)=vectorproduct(a(1:3,1),a(1:3,2)) - reciprocal(1:3,3)=reciprocal(1:3,3)/sum(reciprocal(1:3,3)*a(1:3,3)) - ! - reciprocal=reciprocal*2.d0*pi - ! -end function reciprocal diff --git a/quantum_espresso/kcp/AFC90/src/rtoaxis.f90 b/quantum_espresso/kcp/AFC90/src/rtoaxis.f90 deleted file mode 100644 index a7c9e238c..000000000 --- a/quantum_espresso/kcp/AFC90/src/rtoaxis.f90 +++ /dev/null @@ -1,47 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function rtoaxis(a1,a2,n1,n2,e3) - ! - implicit none - ! - real(8), intent(in), dimension(3) :: a1,a2,e3 - integer, intent(in) :: n1,n2 - real(8), dimension(n1*n2) :: rtoaxis - integer :: i1,i2 - real(8), dimension(3) :: u - ! - interface - ! - function nfft(k,n) - integer, intent(in) :: k,n - integer :: nfft - end function - ! - end interface - ! - do i1=1,n1 - do i2=1,n2 - u=nfft(i1,n1)*a1/n1+nfft(i2,n2)*a2/n2 - u=u-sum(e3(1:3)*u(1:3))*u - rtoaxis(i1+n1*(i2-1))=sqrt(sum(u(1:3)**2)) - enddo - enddo - ! -end function rtoaxis - - - diff --git a/quantum_espresso/kcp/AFC90/src/rungekutta.f90 b/quantum_espresso/kcp/AFC90/src/rungekutta.f90 deleted file mode 100644 index 7ab287cfa..000000000 --- a/quantum_espresso/kcp/AFC90/src/rungekutta.f90 +++ /dev/null @@ -1,42 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function rungekutta(sigma,t,dt,x) - ! - implicit none - ! - real(8), intent(in), dimension(2) :: x - real(8), intent(in) :: sigma,t,dt - real(8), dimension(2) :: rungekutta - real(8), dimension(2) :: k1,k2,k3,k4 - ! - interface - ! - function ydot(sigma,t,x) - real(8), intent(in) :: sigma,t - real(8), intent(in), dimension(2) :: x - real(8), dimension(2) :: ydot - end function - ! - end interface - ! - k1=ydot(sigma,t,x) - k2=ydot(sigma,t+0.5d0*dt,x+k1*0.5d0*dt) - k3=ydot(sigma,t+0.5d0*dt,x+k2*0.5d0*dt) - k4=ydot(sigma,t+dt,x+k3*dt) - rungekutta=x+(k1+2.d0*k2+2.d0*k3+k4)*dt/6.d0 - ! -end function rungekutta diff --git a/quantum_espresso/kcp/AFC90/src/steprk.f90 b/quantum_espresso/kcp/AFC90/src/steprk.f90 deleted file mode 100644 index 47860f41f..000000000 --- a/quantum_espresso/kcp/AFC90/src/steprk.f90 +++ /dev/null @@ -1,80 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function steprk(sigma) - ! - implicit none - ! - real(8), intent(in) :: sigma - real(8) :: steprk - real(8), parameter :: x=exp(-20.d0) - real(8), parameter :: tol=1.d-3 !afcmodified:giovanni 1.d-3 - real(8), parameter :: dt0=1.d-2 !afcmodified:giovanni 1.d-2 - integer, parameter :: nmax=5 !afcmodified:giovanni 5 - real(8) :: logslope,dy,dt,y - integer :: n - ! - interface - ! - function cylharm(dt,sigma,x) - real(8), intent(in) :: dt,sigma,x - real(8) :: cylharm - end function - ! - function cylharm0(sigma) - real(8), intent(in) :: sigma - real(8) :: cylharm0 - end function - ! - function besselk(x) - real(8), intent(in) :: x - real(8) :: besselk - end function - ! - function cylharmslope(tol,dt,sigma) - real(8), intent(in) :: tol,dt,sigma - real(8) :: cylharmslope - end function - ! - function cylharmseries(a0,b0,sigma,x) - real(8), intent(in) :: a0,b0,sigma,x - real(8) :: cylharmseries - end function - ! - end interface - ! - dt=dt0 - logslope=cylharmslope(1.d-10,dt,sigma) - y=cylharmseries(cylharm0(sigma),0.d0,sigma,x) - dy=abs(cylharm(dt,sigma,x)+logslope*besselk(x)-y) - n=0 - step: do while (dy>tol*abs(y)) - n=n+1 - if (n>nmax) then - print *, 'warning: nmax exceeded in steprk' - print *, 'rk:', cylharm(dt,sigma,x)+logslope*besselk(x) - print *, 'series:',cylharmseries(cylharm0(sigma),0.d0,sigma,x) - exit step - endif - dt=dt/2.d0 - logslope=cylharmslope(tol,dt,sigma) - y=cylharmseries(cylharm0(sigma),0.d0,sigma,x) - dy=abs(cylharm(dt,sigma,x)+logslope*besselk(x)-y) - enddo step - ! - steprk=dt - ! -end function steprk diff --git a/quantum_espresso/kcp/AFC90/src/vectorproduct.f90 b/quantum_espresso/kcp/AFC90/src/vectorproduct.f90 deleted file mode 100644 index 0908f5c5b..000000000 --- a/quantum_espresso/kcp/AFC90/src/vectorproduct.f90 +++ /dev/null @@ -1,29 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function vectorproduct(u,v) - ! - implicit none - ! - real(8), intent(in), dimension(3) :: u,v - real(8), dimension(3) :: vectorproduct - ! - vectorproduct(1)=u(2)*v(3)-u(3)*v(2) - vectorproduct(2)=u(3)*v(1)-u(1)*v(3) - vectorproduct(3)=u(1)*v(2)-u(2)*v(1) - ! - return -end function vectorproduct diff --git a/quantum_espresso/kcp/AFC90/src/volume.f90 b/quantum_espresso/kcp/AFC90/src/volume.f90 deleted file mode 100644 index a965d7b54..000000000 --- a/quantum_espresso/kcp/AFC90/src/volume.f90 +++ /dev/null @@ -1,36 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -real(8) function volume1(a) - ! - implicit none - ! - real(8), intent(IN) :: a(3,3) - real(8) :: tmp(3)=0.d0 - - interface - function vectorproduct(u,v) - real(8), intent(in), dimension(3) :: u,v - real(8), dimension(3) :: vectorproduct - end function - end interface - - tmp=vectorproduct(a(1:3,1),a(1:3,2)) - !volume1=1.000 - volume1=abs(dot_product(tmp,a(1:3,3))) - return - ! -end function volume1 diff --git a/quantum_espresso/kcp/AFC90/src/ydot.f90 b/quantum_espresso/kcp/AFC90/src/ydot.f90 deleted file mode 100644 index 84fc8a46c..000000000 --- a/quantum_espresso/kcp/AFC90/src/ydot.f90 +++ /dev/null @@ -1,38 +0,0 @@ -! -! LibAFCC - Library for auxiliary-function countercharge correction -! Copyright (c) 2010-2011 I. Dabo -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. See GPL/gpl-3.0.txt. -! If not, see . -! -function ydot(sigma,t,x) - ! - implicit none - ! - real(8), intent(in) :: sigma,t - real(8), intent(in), dimension(2) :: x - real(8), dimension(2) :: ydot - real(8), parameter :: pi=3.141592653589793d0 - ! - interface - ! - function gaussian(sigma,x) - real(8), intent(in) :: sigma, x - real(8) :: gaussian - end function - ! - end interface - ! - ydot(1)=x(2) - ydot(2)=(x(1)-2.d0*pi*gaussian(sigma,exp(t)))*exp(2*t) - ! -end function ydot diff --git a/quantum_espresso/kcp/CPV/Makefile b/quantum_espresso/kcp/CPV/Makefile deleted file mode 100644 index 242022453..000000000 --- a/quantum_espresso/kcp/CPV/Makefile +++ /dev/null @@ -1,268 +0,0 @@ -# Makefile for CP/FPMD - -include ../make.sys - -FOBJS = \ -atoms_type.o \ -bessel.o \ -berryion.o \ -bforceion.o \ -centers_and_spreads.o \ -cg.o \ -cg_sub.o \ -cglib.o \ -chargedensity.o \ -chargemix.o \ -chi2.o \ -compute_fes_grads.o \ -compute_scf.o \ -cp_autopilot.o \ -cp_emass.o \ -cp_fpmd.o \ -cp_interfaces.o \ -cp_restart.o \ -cplib.o \ -cpr_mod.o \ -cpr.o \ -cprsub.o \ -dealloc.o \ -dforceb.o \ -eelib.o \ -efermi.o \ -efield.o \ -eigs0.o \ -electrons.o \ -emptystates.o \ -ensemble_dft.o \ -environment.o \ -exch_corr.o \ -exx_divergence.o \ -fft.o \ -forces.o \ -fromscra.o \ -gradrho.o \ -gtable.o \ -init.o \ -init_run.o \ -inner_loop.o \ -inner_loop_cold.o \ -inner_loop_smear.o \ -input.o \ -io_pot_sic_xml.o \ -ions_positions.o \ -ksstates.o \ -main.o \ -mainvar.o \ -main_loops.o \ -cplib_meta.o \ -metaxc.o \ -modules.o \ -move_electrons.o \ -nksiclib.o \ -hflib.o \ -nl_base.o \ -nlcc.o \ -ortho_base.o \ -ortho.o \ -ortho_check.o \ -para.o \ -path_routines.o \ -phasefactor.o \ -polarization.o \ -potentials.o \ -pres_ai_mod.o \ -print_out.o \ -problem_size.o \ -pseudo_base.o \ -pseudopot.o \ -pseudopot_sub.o \ -qmatrixd.o \ -qqberry.o \ -read_pseudo.o \ -restart.o \ -restart_sub.o \ -runcp.o \ -spharmonic.o \ -spline.o \ -stop_run.o \ -stress.o \ -symm_wannier.o \ -turbo.o \ -util.o \ -vanderwaals.o \ -vol_clu.o \ -cp_version.o \ -wannier_base.o \ -wannier.o \ -waveinit.o \ -wave.o \ -wave_types.o \ -wf.o \ -write_hamiltonian.o \ -writetofile.o \ -gram_swap.o \ -odd_alpha.o \ -cg_empty_sub.o \ -wave_init_wannier.o \ -inner_loop_generalize.o \ -makov_payne.o \ -pc3nc_fixed.o \ -empty_koopmans_pp.o \ -perturbing_pot.o \ - -# dgradcorr.o -# setup_gga.o - -LOBJS = \ -adjef.o \ -entropy.o \ -forceconv.o \ -geninv.o \ -indices.o - -MODULES = \ -../Modules/atom.o \ -../Modules/autopilot.o \ -../Modules/basic_algebra_routines.o \ -../Modules/berry_phase.o \ -../Modules/cell_base.o \ -../Modules/check_stop.o \ -../Modules/clocks.o \ -../Modules/constants.o \ -../Modules/constraints_module.o \ -../Modules/control_flags.o \ -../Modules/descriptors.o \ -../Modules/dspev_drv.o \ -../Modules/electrons_base.o \ -../Modules/energies.o \ -../Modules/error_handler.o \ -../Modules/fft_base.o \ -../Modules/fft_parallel.o \ -../Modules/fft_scalar.o \ -../Modules/fft_types.o \ -../Modules/functionals.o \ -../Modules/griddim.o \ -../Modules/input_parameters.o \ -../Modules/io_files.o \ -../Modules/io_global.o \ -../Modules/ions_base.o \ -../Modules/ions_nose.o \ -../Modules/kind.o \ -../Modules/mp_global.o \ -../Modules/mp_wave.o \ -../Modules/mp.o \ -../Modules/mp_base.o \ -../Modules/metagga.o \ -../Modules/metadyn_base.o \ -../Modules/metadyn_io.o \ -../Modules/metadyn_vars.o \ -../Modules/parallel_types.o \ -../Modules/path_base.o \ -../Modules/path_formats.o \ -../Modules/path_variables.o \ -../Modules/path_opt_routines.o \ -../Modules/path_io_routines.o \ -../Modules/path_reparametrisation.o \ -../Modules/parallel_include.o \ -../Modules/parameters.o \ -../Modules/parser.o \ -../Modules/printout_base.o \ -../Modules/pseudo_types.o \ -../Modules/ptoolkit.o \ -../Modules/radial_grids.o \ -../Modules/random_numbers.o \ -../Modules/read_upf_v1.o \ -../Modules/read_upf_v2.o \ -../Modules/read_cards.o \ -../Modules/read_namelists.o \ -../Modules/read_uspp.o \ -../Modules/recvec.o \ -../Modules/shmem_include.o \ -../Modules/sic.o \ -../Modules/smallbox.o \ -../Modules/splinelib.o \ -../Modules/stick_base.o \ -../Modules/task_groups.o \ -../Modules/timestep.o \ -../Modules/twin_types.o \ -../Modules/upf_to_internal.o \ -../Modules/upf.o \ -../Modules/uspp.o \ -../Modules/version.o \ -../Modules/vxc_t.o \ -../Modules/wavefunctions.o \ -../Modules/wave_base.o \ -../Modules/write_upf_v2.o \ -../Modules/xml_input.o \ -../Modules/xml_io_base.o \ -../Modules/zhpev_drv.o \ -../Modules/wannier_new.o \ -../Modules/wrappers.o \ -../Modules/compute_dipole.o - -AFCLIB=../AFC90/src/libafc90.a - -TLDEPS= bindir mods libs libiotk afclib - -all : kcp -kcp : tldeps libcp.a kcp.x cppp.x - -kcp.x : cprstart.o libcp.a $(LIBOBJS) $(AFCLIB) - $(LD) $(LDFLAGS) -o kcp.x \ - cprstart.o $(MODULES) libcp.a \ - $(LIBOBJS) $(AFCLIB) $(LIBS) - - ( cd ../bin ; ln -fs ../CPV/kcp.x . ) - -cp_test : tldeps libcp.a cp_test.x cppp.x - -cp_test.x : cprstart.o libcp.a $(LIBOBJS) - $(LD) $(LDFLAGS) -o cp_test.x \ - cprstart.o $(MODULES) libcp.a $(LIBOBJS) $(LIBS) - - ( cd ../bin ; ln -fs ../CPV/cp_test.x . ) - -cp_bad_sd : tldeps libcp.a cp_bad_sd.x cppp.x - -cp_bad_sd.x : cprstart.o libcp.a $(LIBOBJS) - $(LD) $(LDFLAGS) -o cp_bad_sd.x \ - cprstart.o $(MODULES) libcp.a $(LIBOBJS) $(LIBS) - - ( cd ../bin ; ln -fs ../CPV/cp_bad_sd.x . ) - -libcp.a : $(FOBJS) $(WAN90) $(LOBJS) - $(AR) $(ARFLAGS) $@ $? - $(RANLIB) $@ - -cp_version.o : cpver.h - -cpver.h : - echo "CHARACTER(LEN=70), PARAMETER :: version_date = '"`date`"'" \ - > cpver.h - -PPOBJS = \ -../Modules/xml_io_base.o \ -../Modules/mp.o \ -../Modules/mp_base.o \ -../Modules/mp_global.o \ -../Modules/io_global.o \ -../Modules/io_files.o \ -../Modules/mp_wave.o \ -../Modules/parser.o \ -../Modules/kind.o \ -../Modules/control_flags.o \ -../Modules/parameters.o \ -../Modules/parallel_include.o \ -../Modules/error_handler.o \ -../Modules/constants.o \ -../Modules/wrappers.o - -cppp.x : fpmdpp.o $(PPOBJS) $(LIBOBJS) - $(LD) $(LDFLAGS) -o cppp.x fpmdpp.o $(PPOBJS) $(LIBOBJS) $(LIBS) - - (cd ../bin ; ln -fs ../CPV/cppp.x . ) - -tldeps: - test -n "$(TLDEPS)" && ( cd .. ; $(MAKE) $(MFLAGS) $(TLDEPS) || exit 1) || : - -clean : - - /bin/rm -f cppp.x *.o *.mod cpver.h *.i core* *.F90 fort* \ - *.cpp *.d *.L *.a *.s kcp.x - -include make.depend diff --git a/quantum_espresso/kcp/CPV/adjef.f90 b/quantum_espresso/kcp/CPV/adjef.f90 deleted file mode 100644 index e264f4d48..000000000 --- a/quantum_espresso/kcp/CPV/adjef.f90 +++ /dev/null @@ -1,198 +0,0 @@ -! -! Copyright (C) 2002-2008 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! AB INITIO COSTANT PRESSURE MOLECULAR DYNAMICS -! ---------------------------------------------- -! Car-Parrinello Parallel Program -! Carlo Cavazzoni - Gerardo Ballabio -! SISSA, Trieste, Italy - 1997-99 -! Last modified: Fri Dec 3 10:42:00 MET 1999 -! ---------------------------------------------- -! routines in this file: -! SUBROUTINE adjef(nk,e,wk,wke,fke,ef,qtot,ne,temp,sume,nspin) -! REAL(DP) FUNCTION stepf(x) -! ---------------------------------------------- -! BEGIN manual - - SUBROUTINE adjef(nk,e,wk,wke,fke,ef,qtot,ne,temp,sume,nspin) - -! this routine computes Fermi energy and weights of occupied states -! using an improved Gaussian-smearing method -! refs: C.L.Fu and K.M.Ho, Phys.Rev. B28, 5480 (1983) -! M.Methfessel and A.T.Paxton Phys.Rev. B40 (15 aug. 89). -! -! taken from APW code by J. Soler and A. Williams (jk+ss) -! added computation of occupation numbers without k-point weight -! ---------------------------------------------- -! END manual - - USE kinds - USE io_global, ONLY: stdout - - IMPLICIT NONE - -! ... declare subroutine arguments - INTEGER ne,nk,nspin - REAL(DP) ef,qtot,temp,sume - REAL(DP) e(ne,nk,nspin),wke(ne,nk,nspin) - REAL(DP) wk(nk),fke(ne,nk,nspin) - REAL(DP), PARAMETER :: tol = 1.d-10 - INTEGER, PARAMETER :: nitmax = 100 - -! ... declare functions - REAL(DP) stepf - -! ... declare other variables - REAL(DP) sumq,emin,emax,fac,t,drange - INTEGER ik,ispin,ie,iter - -! end of declarations -! ---------------------------------------------- - -! qtot=DBLE(nel) - sumq=0.d0 - sume=0.d0 - emin=e(1,1,1) - emax=e(1,1,1) - fac=2.d0 - IF (nspin.EQ.2) fac=1.d0 - - DO ik=1,nk - DO ispin=1,nspin - DO ie=1,ne - wke(ie,ik,ispin)=wk(ik)*fac - fke(ie,ik,ispin)=fac - sumq=sumq+wke(ie,ik,ispin) - sume=sume+wke(ie,ik,ispin)*e(ie,ik,ispin) - emin= MIN (emin,e(ie,ik,ispin)) - emax= MAX (emax,e(ie,ik,ispin)) - END DO - END DO - END DO - ef=emax - IF (dabs(sumq-qtot).LT.tol) RETURN - IF (sumq.LT.qtot) THEN - WRITE( stdout,*) 'FERMIE: NOT ENOUGH STATES' - WRITE( stdout,*) 'FERMIE: QTOT,SUMQ=',qtot,sumq - STOP - END IF - - t=DMAX1(temp,1.d-6) - drange=t*dsqrt(-dlog(tol*.01d0)) - emin=emin-drange - emax=emax+drange - DO iter=1,nitmax - ef=0.5d0*(emin+emax) - sumq=0.d0 - sume=0.d0 - DO ik=1,nk - DO ispin=1,nspin - DO ie=1,ne - wke(ie,ik,ispin)=fac/2.d0* & - wk(ik)*stepf((e(ie,ik,ispin)-ef)/t) - fke(ie,ik,ispin)=fac/2.d0* & - stepf((e(ie,ik,ispin)-ef)/t) - sumq=sumq+wke(ie,ik,ispin) - sume=sume+wke(ie,ik,ispin)*e(ie,ik,ispin) - END DO - END DO - END DO - IF (dabs(sumq-qtot).LT.tol) RETURN - IF (sumq.LE.qtot) emin=ef - IF (sumq.GE.qtot) emax=ef - END DO - - WRITE( stdout,*) 'FERMIE: ITERATION HAS NOT CONVERGED.' - WRITE( stdout,*) 'FERMIE: QTOT,SUMQ=',qtot,sumq - STOP - - END SUBROUTINE adjef - -! ---------------------------------------------- - - DOUBLE PRECISION FUNCTION stepf(x) - USE kinds - IMPLICIT NONE - REAL(DP) :: x - REAL(DP), PARAMETER :: c=0.5641895835D0 -! REAL(DP), EXTERNAL :: qe_erfc -! stepf=qe_erfc(x) - stepf=1.d0/(exp(min(x,100.d0))+1.d0) - END FUNCTION stepf - - - SUBROUTINE adjef_s(e,fke,ef,nel,nx,temp,sume) - -! e(nstati) -! fke(nstati) = f(nstati) (output) -! ef = fermi energy (output) -! nel = n. electrons -! ne = nstati -! temp = broadening (au) -! sume = sum e(nstati) (output) - - -! CALCULATES FERMI ENERGY AND WEIGHTS OF OCCUPIED STATES USING -! AN IMPROVED GAUSSIAN-SMEARING METHOD -! REFS: C.L.FU AND K.M.HO, PHYS.REV. B28, 5480 (1983) -! M.METHFESSEL AND A.T.PAXTON PHYS.REV. B40 (15 AUG. 89). -! -! Taken from APW code by J. Soler and A. Williams (jk+ss) -! Added computation of occupation numbers without k-point weight - - use kinds - USE io_global, ONLY: stdout - IMPLICIT NONE - - integer nx,nel - real(DP) E(nx),FKE(nx),temp,sume,ef,tol - integer nitmax - PARAMETER (TOL=1.D-10,NITMAX=100) - integer iter,ie - real(DP) t,emin,emax,stepf - real(DP) sumq,fac,qtot,drange - QTOT=DBLE(NEL) - SUMQ=0.D0 - SUME=0.D0 - EMIN=E(1) - EMAX=E(1) - fac=2.d0 - do ie=1,nx - FKE(IE)=fac - SUMQ=SUMQ+FKE(IE) - SUME=SUME+E(IE) - EMIN=MIN(EMIN,E(IE)) - EMAX=MAX(EMAX,E(IE)) - end do - EF=EMAX - IF (DABS(SUMQ-QTOT).LT.TOL) RETURN - IF (SUMQ.LT.QTOT) THEN - WRITE( stdout,*) 'FERMIE: NOT ENOUGH STATES' - WRITE( stdout,*) 'FERMIE: QTOT,SUMQ=',QTOT,SUMQ - STOP - ENDIF - T=MAX(TEMP,1.D-6) - DRANGE=T*DSQRT(-DLOG(TOL*.01D0)) - EMIN=EMIN-DRANGE - EMAX=EMAX+DRANGE - DO ITER=1,NITMAX - EF=0.5D0*(EMIN+EMAX) - SUMQ=0.D0 - SUME=0.D0 - do ie=1,nx - FKE(IE)=fac*STEPF((E(IE)-EF)/T) - SUMQ=SUMQ+FKE(IE) - SUME=SUME+FKE(IE)*E(IE) - enddo - IF (DABS(SUMQ-QTOT).LT.TOL) RETURN - IF (SUMQ.LE.QTOT) EMIN=EF - IF (SUMQ.GE.QTOT) EMAX=EF - ENDDO - WRITE( stdout,*) 'FERMIE: ITERATION HAS NOT CONVERGED.' - WRITE( stdout,*) 'FERMIE: QTOT,SUMQ=',QTOT,SUMQ - STOP - END SUBROUTINE adjef_s diff --git a/quantum_espresso/kcp/CPV/atoms_type.f90 b/quantum_espresso/kcp/CPV/atoms_type.f90 deleted file mode 100644 index 45d486872..000000000 --- a/quantum_espresso/kcp/CPV/atoms_type.f90 +++ /dev/null @@ -1,184 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -!=----------------------------------------------------------------------------=! - MODULE atoms_type_module -!=----------------------------------------------------------------------------=! - -! this module contains the definition of TYPE structure -! relative to the ionic degrees of freedom - - USE kinds - USE parameters, ONLY: nsx - - IMPLICIT NONE - SAVE - - PRIVATE - -! ... title ... - TYPE atoms_type - INTEGER :: doft ! total number of degree_of_freedom - INTEGER :: nsp ! number of species - INTEGER :: nat ! total number of atoms - INTEGER :: nax ! maximum number of atoms per specie - INTEGER :: dof(nsx) ! degree_of_freedom for each specie - - CHARACTER(LEN=3) :: label(nsx) ! atomic labels - INTEGER :: na(nsx) ! number of atoms per specie - INTEGER :: isa(nsx) ! index of the first atom (in the whole list) of a given specie - REAL(DP) :: m(nsx) ! atomic masses - REAL(DP), POINTER :: taur(:,:) ! (3,nat) - REAL(DP), POINTER :: taus(:,:) ! (3,nat) - ! ... tau: atomic positions, sorted by specie. Atomic positions of specie "is" are - ! stored in array elements whose index are "isa(is) ... isa(is)+na(is)-1" - REAL(DP), POINTER :: vels(:,:) ! (3,nat) ! scaled velocities, same layout of "tau" - REAL(DP), POINTER :: for (:,:) ! (3,nat) ! total force acting on the atom - INTEGER, POINTER :: mobile(:,:) ! (3,nat) ! atomic freedom, same layout of "tau" ( 1 atom can move ) - INTEGER, POINTER :: ityp(:) ! (nat) ! index of the specie to which the atom belong - LOGICAL :: tscfor ! indicate if the force are scaled or real - REAL(DP) :: ekin(nsx) ! kinetic energy per specie - REAL(DP) :: ekint ! total kinetic energy - END TYPE atoms_type - - - PUBLIC :: atoms_type - PUBLIC :: atoms_type_init - -!=----------------------------------------------------------------------------=! - CONTAINS -!=----------------------------------------------------------------------------=! - -! subroutines - - SUBROUTINE specie_index(isa, na, is, ia) - INTEGER, INTENT(IN) :: isa, na(:) - INTEGER, INTENT(OUT) :: is, ia - INTEGER :: i, nat - nat = 0 - ia = 0 - is = 0 - LOOP: DO i = 1, SIZE( na ) - IF( (nat + na(i) ) >= isa ) THEN - ia = isa - nat - is = i - EXIT LOOP - ELSE - nat = nat + na(i) - END IF - END DO LOOP - RETURN - END SUBROUTINE specie_index - - - SUBROUTINE atoms_type_init(atoms, staur, ismbl, label, pma, na, nsp, h) - USE cell_base, ONLY: s_to_r - TYPE (atoms_type) :: atoms - REAL(DP), INTENT(IN) :: staur(:,:) - LOGICAL, INTENT(IN) :: ismbl(:,:) - REAL(DP), INTENT(IN) :: pma(:), h(3,3) - INTEGER, INTENT(IN) :: na(:), nsp - CHARACTER(LEN=3), INTENT(IN) :: label(:) - INTEGER :: nax, nat - INTEGER :: is, isa, isatop - - - nat = SUM( na( 1 : nsp ) ) - nax = MAXVAL( na( 1 : nsp ) ) - - IF( SIZE( na ) < nsp ) & - CALL errore(' atoms_type_init ', ' wrong na dimensions ', 1) - IF( SIZE( pma ) < nsp ) & - CALL errore(' atoms_type_init ', ' wrong pma dimensions ', 1) - - IF( nsp < 1 ) THEN - CALL errore(' atoms_type_init ', ' nsp less than one ', 3) - END IF - IF( nax < 1 ) THEN - CALL errore(' atoms_type_init ', ' nax less than one ', 4) - END IF - IF( nat < 1 ) THEN - CALL errore(' atoms_type_init ', ' nat less than one ', 5) - END IF - IF( ( nat > SIZE(ismbl, 2) ) ) THEN - CALL errore(' atoms_type_init ', ' invalid nat ', 6) - END IF - IF( ( nat > SIZE(staur, 2) ) ) THEN - CALL errore(' atoms_type_init ', ' invalid nat ', 6) - END IF - - atoms%nsp = nsp - atoms%nat = nat - atoms%nax = nax - atoms%ekint = 0.0d0 - - isa = 1 - atoms%taus = 0.0d0 - atoms%vels = 0.0d0 - atoms%for = 0.0d0 - atoms%mobile = 0 - atoms%ityp = 0 - atoms%tscfor = .FALSE. - - DO is = 1, nsp - atoms%na(is) = na(is) - atoms%m(is) = pma(is) - - atoms%isa(is) = isa - isatop = isa + na(is) - 1 - - atoms%label(is) = TRIM( label(is) ) - atoms%taus(1:3,isa:isatop) = staur(1:3,isa:isatop) - WHERE( ismbl(1:3,isa:isatop) ) atoms%mobile(1:3,isa:isatop) = 1 - atoms%ityp(isa:isatop) = is - atoms%dof(is) = MAX( COUNT( atoms%mobile(1:3,isa:isatop) == 1 ), 1 ) - atoms%ekin(is) = 0.0d0 - - isa = isa + na(is) - END DO - - CALL s_to_r( atoms%taus, atoms%taur, atoms%na, atoms%nsp, h ) - - atoms%doft = MAX( SUM( atoms%dof(1:nsp) )-3, 1 ) - - RETURN - END SUBROUTINE atoms_type_init - - - - SUBROUTINE allocate_atoms_type( atoms, nsp, nat ) - INTEGER, INTENT(IN) :: nsp, nat - TYPE (atoms_type) :: atoms - - ALLOCATE( atoms % taur( 3, nat ) ) - ALLOCATE( atoms % taus( 3, nat ) ) - ALLOCATE( atoms % vels( 3, nat ) ) - ALLOCATE( atoms % for ( 3, nat ) ) - ALLOCATE( atoms % mobile ( 3, nat ) ) - ALLOCATE( atoms % ityp ( nat ) ) - - RETURN - END SUBROUTINE allocate_atoms_type - - SUBROUTINE deallocate_atoms_type( atoms ) - TYPE (atoms_type) :: atoms - IF( ASSOCIATED( atoms % taur ) ) DEALLOCATE( atoms % taur ) - IF( ASSOCIATED( atoms % taus ) ) DEALLOCATE( atoms % taus ) - IF( ASSOCIATED( atoms % vels ) ) DEALLOCATE( atoms % vels ) - IF( ASSOCIATED( atoms % for ) ) DEALLOCATE( atoms % for ) - IF( ASSOCIATED( atoms % mobile ) ) DEALLOCATE( atoms % mobile ) - IF( ASSOCIATED( atoms % ityp ) ) DEALLOCATE( atoms % ityp ) - RETURN - END SUBROUTINE deallocate_atoms_type - - - -!=----------------------------------------------------------------------------=! - END MODULE atoms_type_module -!=----------------------------------------------------------------------------=! - diff --git a/quantum_espresso/kcp/CPV/berryion.f90 b/quantum_espresso/kcp/CPV/berryion.f90 deleted file mode 100644 index f34eca944..000000000 --- a/quantum_espresso/kcp/CPV/berryion.f90 +++ /dev/null @@ -1,157 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -subroutine berryion( tau0,fion, tfor,ipol,evalue,enbi) - -! this subroutine returns the berry phase energy -! = L/2*Pi*Im(log Sum_R exp(i*(2pi/L)*R_i*rho_i)) -! of the ions and the constant force on the ions -! now only for orthorombic primitive cell - -! tau0 : input, positions of ions -! fion : input,output, forces on ions -! tfor : input, flag for force calculation -! ipol : input, electric field polarization -! evalue : input, scale for electric field -! enbi : output, berry phase energy of the ions - - use constants, only : pi, fpi - use ions_base, ONLY : nsp, na, zv - use cell_base, only : a1, a2, a3 - - implicit none - - real(8) tau0(3,*) - real(8) fion(3,*) - real(8) enbi, evalue - integer ipol, isa - logical tfor - -!local variables - real(8) gmes - real(8) pola - integer is, ia - complex(8) temp, ci - - temp = (0.d0,0.d0) - ci = (0.d0,1.d0) - - if(ipol.eq.1) then - gmes=a1(1)**2+a1(2)**2+a1(3)**2 - gmes=2*pi/SQRT(gmes) - endif - if(ipol.eq.2) then - gmes=a2(1)**2+a2(2)**2+a2(3)**2 - gmes=2*pi/SQRT(gmes) - endif - if(ipol.eq.3) then - gmes=a3(1)**2+a3(2)**2+a3(3)**2 - gmes=2*pi/SQRT(gmes) - endif - pola=0.d0 - isa = 0 - do is=1,nsp - do ia=1,na(is) - isa = isa + 1 - -!this force term is along ipol-direction - if( tfor) then - fion(ipol,isa)=fion(ipol,isa)+evalue*zv(is) - endif - - temp = temp - ci*gmes*tau0(ipol,isa)*zv(is) - pola=pola+evalue*zv(is)*tau0(ipol,isa)!this is just the center of ionic charge - enddo - enddo - - enbi=AIMAG(log(exp(temp)))/gmes!this sounds stupid it's just a Riemann plane - return -end subroutine berryion - - -!------------------------------------------------------------------------- - subroutine cofcharge(tau,cdz) -!----------------------------------------------------------------------- -!this subroutine gives the center of the ionic charge - - - use ions_base, only: na, nsp, zv -! - implicit none - real(8) tau(3,*), cdz(3) -! local variables - real(8) zmas - integer is,i,ia,isa -! - zmas=0.0d0 - do is=1,nsp - zmas=zmas+na(is)*zv(is) - end do -! - isa = 0 - do i=1,3 - cdz(i)=0.0d0 - do is=1,nsp - do ia=1,na(is) - isa = isa + 1 - cdz(i)=cdz(i)+tau(i,isa)*zv(is) - end do - end do - cdz(i)=cdz(i)/zmas - end do -! write(6,*) 'Center of charge', cdz(3)!ATTENZIONE -! - return - end subroutine cofcharge -! - - - -!---------------------------------------------------- - subroutine noforce(fion, ipol) -!---------------------------------------------------- - -! this subroutine adds a electric force, in order -! to keep steady the center of mass along the electric -! field direction - - use ions_base, ONLY : na, nsp, zv - - implicit none - - real(8) fion(3,*) - integer ipol!el. field polarization - - - integer ia,is,isa - real(8) fcm!force appplied on center of mass - real(8) tch!total charge - - fcm=0.d0 - tch=0.d0 - isa = 0 - do is=1,nsp - do ia=1,na(is) - isa = isa + 1 - fcm=fcm+fion(ipol,isa) - tch=tch+zv(is) - enddo - enddo - fcm=fcm/tch - isa = 0 - do is=1,nsp - do ia=1,na(is) - isa = isa + 1 - fion(ipol,isa)=fion(ipol,isa)-fcm*zv(is) - enddo - enddo - - return - end subroutine noforce - - diff --git a/quantum_espresso/kcp/CPV/bessel.f90 b/quantum_espresso/kcp/CPV/bessel.f90 deleted file mode 100644 index 9d7bd92d3..000000000 --- a/quantum_espresso/kcp/CPV/bessel.f90 +++ /dev/null @@ -1,199 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -! ---------------------------------------------------------------------------- -! BEGIN manual - - SUBROUTINE bessel2_x(XG, RW, FINT, LNL, INDL, MMAX) - -! This subroutine Compute: -! Fint(x,l) = J_l(x); l = INDL(j); j = 1, LNL -! x = XG * RW(i); i = 1, ..., mmax - -! END manual -! ---------------------------------------------------------------------------- - - USE kinds, ONLY: DP - USE constants, ONLY: eps14 - USE cp_interfaces - - IMPLICIT NONE - -! ... Argument Variables - - REAL(DP), INTENT(IN) :: XG - REAL(DP), INTENT(IN) :: RW(:) - REAL(DP), INTENT(OUT) :: FINT(:,:) - INTEGER, INTENT(IN) :: INDL(:), LNL, MMAX - -! ... Local Variables - - REAL(DP) :: J0(MMAX) - REAL(DP) :: J1(MMAX) - REAL(DP) :: J2(MMAX) - REAL(DP) :: J3(MMAX) - INTEGER :: L, LL, LMAX - -! ... Subroutine Body - - IF( ABS(XG) < eps14 ) THEN - CALL errore( ' bessel2 ',' xg too small ', 2) - END IF - ! - LMAX = MAXVAL( INDL ) + 1 - - IF ( LMAX > 0 ) THEN -! ... Calculate J0(|G||r|) = SIN(|G||r|) / (|G||r|) - CALL sph_bes( mmax, rw(1), xg, 0, j0(1) ) - END IF - - IF ( LMAX > 1 ) THEN -! ... Calculate J1(|G||r|) = SIN(|G||r|) / (|G||r|)^2 - COS(|G||r|) / (|G||r|) - CALL sph_bes( mmax, rw(1), xg, 1, j1(1) ) - END IF - - IF ( LMAX > 2 ) THEN -! ... Calculate J2(|G||r|) = 3 * J1(|G||r|) / (|G||r|) - J0 - CALL sph_bes( mmax, rw(1), xg, 2, j2(1) ) - END IF - - IF ( LMAX > 3 ) THEN -! ... Calculate J3(|G||r|) = 5 * J2(|G||r|) / (|G||r|) - J1 - CALL sph_bes( mmax, rw(1), xg, 3, j3(1) ) - END IF - - DO L = 1,LNL - LL = INDL(L) - IF(LL == 0) THEN -! ... FINT = FUNT * J0 - FINT(1:mmax,L) = J0(1:mmax) - ELSE IF (LL == 1) THEN -! ... FINT = FUNT * J1 - FINT(1:mmax,L) = J1(1:mmax) - ELSE IF (LL == 2) THEN -! ... FINT = FUNT * J2 - FINT(1:mmax,L) = J2(1:mmax) - ELSE IF (LL == 3) THEN -! ... FINT = FUNT * J3 - FINT(1:mmax,L) = J3(1:mmax) - ELSE - CALL errore(" bessel2 "," ll value not programmed ", MAX( 1, ABS(ll) ) ) - END IF - END DO - - RETURN - END SUBROUTINE bessel2_x - -! ---------------------------------------------------------------------------- -! BEGIN manual - - SUBROUTINE BESSEL3_x(XG, RW, FINT, LNL, INDL, MMAX) - -! This subroutine Compute: -! Fint(x,l) = f_l(x); l = INDL(j); j = 1, LNL -! x = XG * RW(i); i = 1, ..., mmax -! f_0(x) = cos(x) -! f_l(x) = x * j_(l-1)(x); l > 0 -! -! END manual -! ---------------------------------------------------------------------------- - - USE kinds, ONLY: DP - USE constants, ONLY: eps14 - USE cp_interfaces - - IMPLICIT NONE - -! ... Argument Variables - - REAL(DP), INTENT(IN) :: XG - REAL(DP), INTENT(IN) :: RW(:) - REAL(DP), INTENT(OUT) :: FINT(:,:) - INTEGER, INTENT(IN) :: INDL(:), LNL, MMAX - -! ... Local Variables - - REAL(DP) :: XRG(MMAX) - REAL(DP) :: F0(MMAX) - REAL(DP) :: F1(MMAX) - REAL(DP) :: F2(MMAX) - REAL(DP) :: F3(MMAX) - INTEGER :: L, LL, LMAX, mmin - -! ... Subroutine Body - - LMAX = MAXVAL( INDL ) + 1 - - IF( ABS( xg * rw( 1 ) ) < eps14 ) THEN - mmin = 2 - ELSE - mmin = 1 - END IF - - xrg(1:mmax) = RW(1:mmax) * XG - - IF( LMAX > 0 ) THEN - - ! ... Calculate F0(|G||r|) = COS(|G||r|) - - CALL sph_bes( (mmax-mmin+1), rw(mmin), xg, -1, F0(mmin) ) - ! - F0(mmin:mmax) = F0(mmin:mmax) * xrg(mmin:mmax) - - IF( mmin == 2 ) F0( 1 ) = F0( 2 ) - - END IF - - IF( LMAX > 1 ) THEN - -! ... Calculate F1(|G||r|) = SIN(|G||r|) = |G||r| * J0(|G||r|) - - CALL sph_bes( mmax, rw(1), xg, 0, F1(1) ) - - F1 = F1 * xrg - - END IF - - IF( LMAX > 2 ) THEN - -! ... Calculate F2(|G||r|) = SIN(|G||r|) / |G||r| - COS(|G||r|) = |G||r| * J1(|G||r|) - - F2(mmin:mmax) = (F1(mmin:mmax) / XRG(mmin:mmax) - F0(mmin:mmax)) - - IF( mmin == 2 ) F2( 1 ) = F2( 2 ) - - END IF - - IF( LMAX > 3 ) THEN - -! ... Calculate F3(|G||r|) = 3 F2(|G||r|)/|G||r| - F1(|G||r|) = |G||r| * J2(|G||r|) - - F3(mmin:mmax) = (3.0d0 * F2(mmin:mmax) / XRG(mmin:mmax) - F1(mmin:mmax)) - - IF( mmin == 2 ) F3( 1 ) = F3( 2 ) - - END IF - - DO L = 1,LNL - LL = INDL(L) - IF(LL.EQ.0) THEN - FINT(1:mmax, L) = F0(1:mmax) - ELSE IF (LL.EQ.1) THEN - FINT(1:mmax, L) = F1(1:mmax) - ELSE IF (LL.EQ.2) THEN - FINT(1:mmax, L) = F2(1:mmax) - ELSE IF (LL.EQ.3) THEN - FINT(1:mmax, L) = F3(1:mmax) - ELSE - CALL errore(" bessel3 "," ll value not programmed ", MAX( 1, ABS(ll) ) ) - END IF - END DO - - RETURN - END SUBROUTINE bessel3_x - diff --git a/quantum_espresso/kcp/CPV/bforceion.f90 b/quantum_espresso/kcp/CPV/bforceion.f90 deleted file mode 100644 index 9e2fd7ba8..000000000 --- a/quantum_espresso/kcp/CPV/bforceion.f90 +++ /dev/null @@ -1,118 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -subroutine bforceion(fion,tfor,ipol,qmatinv,bec0,becdr,gqq,evalue) - -! this subroutine compute the part of force for the ions due to -! electronic berry phase( see internal notes) -! it needs becdr - -! fion : input, forces on ions -! tfor : input, if true it computes force -! a1,a2,a3 : input, direct lattice vectors -! ipol : input, electric field polarization -! qmatinv : input, inverse of Q matrix: Q_i,j= -! bec0 : input, factors -! becdr : input, factors d/dR -! gqq : input, Int_e exp(iG*r)*q_ijR(r) -! evalue : input, scale of electric field - - use ions_base, only : nas => nax, na, nsp - use cvan - use parameters - use constants - use cell_base, only: a1, a2, a3 - use uspp_param, only: nh, nhm - use uspp, only : nhsa=> nkb - use electrons_base, only: n => nbsp, nx => nbspx, nspin - use cp_main_variables, only : nlax, descla, collect_bec - - - implicit none - - real(8) evalue - complex(8) qmatinv(nx,nx),gqq(nhm,nhm,nas,nsp) - real(8) bec0(nhsa,n),becdr(nhsa,nspin*nlax,3) - real(8) fion(3,*) - integer ipol - logical tfor - -!local variables - - complex(8) temp, temp1,temp2,temp3 - real(8) gmes - integer iv,jv,ia,is,k,i,j,isa,ilm,jlm,inl,jnl,ism - real(8), allocatable :: becdr_repl(:,:,:) - - if(.not. tfor) return - - ALLOCATE( becdr_repl( nhsa,n,3 ) ) - CALL collect_bec( becdr_repl(:,:,1), becdr(:,:,1), descla, nspin ) - CALL collect_bec( becdr_repl(:,:,2), becdr(:,:,2), descla, nspin ) - CALL collect_bec( becdr_repl(:,:,3), becdr(:,:,3), descla, nspin ) - - if(ipol.eq.1) then - gmes=a1(1)**2+a1(2)**2+a1(3)**2 - gmes=2*pi/SQRT(gmes) - endif - if(ipol.eq.2) then - gmes=a2(1)**2+a2(2)**2+a2(3)**2 - gmes=2*pi/SQRT(gmes) - endif - if(ipol.eq.3) then - gmes=a3(1)**2+a3(2)**2+a3(3)**2 - gmes=2*pi/SQRT(gmes) - endif - - - - isa = 0 - do is=1,nvb - do ia=1,na(is) - isa = isa + 1 - do iv= 1,nh(is) - do jv=1,nh(is) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - - temp=(0.d0,0.d0) - temp1=(0.d0,0.d0) - temp2=(0.d0,0.d0) - temp3=(0.d0,0.d0) - do i=1,n - do j=1,n - - temp = temp + ci*gmes*gqq(iv,jv,ia,is)* &!TAKECARE: sign + due to exp(+iGr) in gqq - & bec0(inl,i)*bec0(jnl,j)*qmatinv(j,i) - - temp1 = temp1 + gqq(iv,jv,ia,is)*& - & ( becdr_repl(inl,i,1)*bec0(jnl,j)+bec0(inl,i)*becdr_repl(jnl,j,1))*qmatinv(j,i) - - temp2 = temp2 + gqq(iv,jv,ia,is)*& - & ( becdr_repl(inl,i,2)*bec0(jnl,j)+bec0(inl,i)*becdr_repl(jnl,j,2))*qmatinv(j,i) - - temp3 = temp3 + gqq(iv,jv,ia,is)*& - & ( becdr_repl(inl,i,3)*bec0(jnl,j)+bec0(inl,i)*becdr_repl(jnl,j,3))*qmatinv(j,i) - - - enddo - enddo - - fion(ipol,isa) = fion(ipol,isa) - 2.d0*evalue*AIMAG(temp)/gmes - fion(1,isa) = fion(1,isa) - 2.d0*evalue*AIMAG(temp1)/gmes - fion(2,isa) = fion(2,isa) - 2.d0*evalue*AIMAG(temp2)/gmes - fion(3,isa) = fion(3,isa) - 2.d0*evalue*AIMAG(temp3)/gmes - end do - end do - end do - end do - - DEALLOCATE( becdr_repl ) - - return -end subroutine bforceion diff --git a/quantum_espresso/kcp/CPV/brillouin.f90 b/quantum_espresso/kcp/CPV/brillouin.f90 deleted file mode 100644 index e46a00e6c..000000000 --- a/quantum_espresso/kcp/CPV/brillouin.f90 +++ /dev/null @@ -1,233 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -!------------------------------------------------------------------------------! -! - MODULE brillouin -! -!------------------------------------------------------------------------------! - USE kinds, ONLY : DP -! ... -! - IMPLICIT NONE - SAVE -! - PRIVATE -! -! ... CP2K Type ... - TYPE kpoints - CHARACTER (len=20) :: scheme - LOGICAL :: gamma_only - INTEGER :: nk1, nk2, nk3 - INTEGER :: k1, k2, k3 - REAL (DP) :: shift(3) - LOGICAL :: symmetry - INTEGER :: wfn_type - INTEGER :: nkpt - REAL (DP), DIMENSION (:), POINTER :: weight - REAL (DP), DIMENSION (:,:), POINTER :: xk - END TYPE kpoints -!------------------------------------------------------------------------------! - - TYPE (kpoints) :: kp - REAL (DP), ALLOCATABLE , TARGET :: weight(:) - REAL (DP), ALLOCATABLE , TARGET :: xk(:,:) - - - PUBLIC :: kpoints, kpoint_info, kpoint_setup, kp - PUBLIC :: get_kpoints_number -! -! - CONTAINS -! -! CP2K input section -!!>----------------------------------------------------------------------------! -!! SECTION: &kpoint... &end ! -!! ! -!! scheme [Gamma, Monkhorst-Pack, MacDonald, General] ! -!! { nx ny nz } ! -!! { nx ny nz sx sy sz } ! -!! { nkpt x1 y1 z1 w1 ... xn yn zn wn } ! -!! symmetry [on, off] ! -!! wavefunction [real, complex] ! -!! ! -!!<----------------------------------------------------------------------------! - - SUBROUTINE kpoint_setup(k_points, nkpt_in, nk1, nk2, nk3, k1, k2, k3, xk_in, weight_in) - IMPLICIT NONE - CHARACTER (len=80) :: k_points - INTEGER :: nk1, nk2, nk3 - INTEGER :: k1, k2, k3 - INTEGER :: nkpt_in - REAL (DP) :: weight_in(:) - REAL (DP) :: xk_in(:,:) - REAL (DP) :: weight_sum - - kp%scheme = 'gamma' - kp%symmetry = .FALSE. - kp%wfn_type = 0 - - IF( ALLOCATED( xk ) ) DEALLOCATE( xk ) - IF( ALLOCATED( weight ) ) DEALLOCATE( weight ) - - IF( TRIM( k_points ) /= 'gamma' ) & - CALL errore( ' kpoint_setup ', ' only gamma is allowed for CP MD, use PW instead ', 1 ) - -! ... Kpoint type - SELECT CASE ( TRIM(k_points) ) - CASE ( 'gamma', 'default' ) - CASE ( 'automatic' ) - CALL errore(' kpoint_setup ',' k_points = '//TRIM(k_points)//' not yet implemented ', 1 ) - CASE ( 'tpiba' ) - kp%scheme = 'general' - kp%symmetry = .FALSE. - kp%wfn_type = 1 - CASE ( 'crystal' ) - CALL errore(' kpoint_setup ',' k_points = '//TRIM(k_points)//' not yet implemented ', 1 ) - CASE DEFAULT - CALL errore(' kpoint_setup ',' unknown k_points '//TRIM(k_points), 1 ) - END SELECT - - kp%nkpt = nkpt_in - kp%nk1 = nk1 - kp%nk2 = nk2 - kp%nk3 = nk3 - kp%nk1 = k1 - kp%nk2 = k2 - kp%nk3 = k3 - kp%shift = 0.0d0 - kp%gamma_only = .FALSE. - - SELECT CASE (kp%scheme) - CASE DEFAULT - CALL errore(' kpoint_setup ',' unknown Scheme '//TRIM(kp%scheme), 1) - CASE ('gamma') - kp%nkpt = 1 - ALLOCATE( xk(3,1), weight(1) ) - kp%xk => xk - kp%weight => weight - kp%xk = 0.0_DP - kp%weight = 1.0_DP - kp%gamma_only = .TRUE. - CASE ('monkhorst-pack') - kp%nk1 = nk1 - kp%nk2 = nk2 - kp%nk3 = nk3 - CASE ('macdonald') - kp%nk1 = nk1 - kp%nk2 = nk2 - kp%nk3 = nk3 - kp%shift = 0.0d0 - CASE ('general') - kp%nkpt = nkpt_in - ALLOCATE( xk(3,SIZE(xk_in,2)), weight(SIZE(xk_in,2)) ) - kp%xk => xk - kp%weight => weight - kp%xk = xk_in -! ... normalize and set k points weights - kp%weight = weight_in - weight_sum = sum(kp%weight) - kp%weight = kp%weight / weight_sum - END SELECT - RETURN - END SUBROUTINE kpoint_setup - -!------------------------------------------------------------------------------! - - SUBROUTINE kpoint_info(punit) - IMPLICIT NONE - INTEGER, INTENT (IN) :: punit - INTEGER :: i - - WRITE (punit,*) - WRITE (punit,'(3X,A)') 'K points' - WRITE (punit,'(3X,A)') '--------' - IF (kp%scheme=='gamma') THEN - WRITE (punit,'(3X,A)') 'Gamma-point calculation' - WRITE (punit,'(3X,A)') 'Wavefunction type: REAL' - ELSE - WRITE (punit,'(3X,A,1X,A)') 'K-point scheme: ', adjustr(kp%scheme) - IF (kp%scheme=='monkhorst-pack') THEN - WRITE (punit,'(3X,A,3I5)') 'K-Point grid : ', kp%nk1, kp%nk2, kp%nk3 - ELSE IF (kp%scheme=='macdonald') THEN - WRITE (punit,'(3X,A,3I5)') 'K-Point grid : ', kp%nk1, kp%nk2, kp%nk3 - WRITE (punit,'(3X,A,3F10.4)') 'K-Point shift : ', kp%shift - END IF - IF (kp%symmetry) THEN - WRITE (punit,'(3X,A)') 'K-Point symmetry: ON' - ELSE - WRITE (punit,'(3X,A)') 'K-Point symmetry: OFF' - END IF - IF (kp%wfn_type==0) THEN - WRITE (punit,'(3X,A)') 'Wavefunction type: REAL' - ELSE - WRITE (punit,'(3X,A)') 'Wavefunction type: COMPLEX' - END IF - WRITE (punit,'(3X,A,I3)') 'Number of K-points: ', kp%nkpt - WRITE (punit,'(3X,A,T19,A,T37,A,T52,A,T67,A)') & - ' Number ', 'Weight', 'X', 'Y', 'Z' - DO i = 1, kp%nkpt - WRITE (punit,'(3X,A,I5,3X,4F15.5)') & - ' ', i, kp%weight(i), kp%xk(1,i), kp%xk(2,i), kp%xk(3,i) - END DO - END IF - END SUBROUTINE kpoint_info - -!------------------------------------------------------------------------------! - - SUBROUTINE brillouin_info(kp,punit) - IMPLICIT NONE - TYPE (kpoints), INTENT (IN) :: kp - INTEGER, INTENT (IN) :: punit - INTEGER :: i - - IF (kp%scheme=='gamma') THEN - WRITE (punit,*) - WRITE (punit,'(A,T57,A)') ' BRILLOUIN|', ' Gamma-point calculation' - WRITE (punit,'(A,T76,A)') ' BRILLOUIN| Wavefunction type', ' REAL' - ELSE - WRITE (punit,*) - WRITE (punit,'(A,T61,A)') ' BRILLOUIN| K-point scheme ', & - adjustr(kp%scheme) - IF (kp%scheme=='monkhorst-pack') THEN - WRITE (punit,'(A,T66,3I5)') ' BRILLOUIN| K-Point grid', kp%nk1, kp%nk2, kp%nk3 - ELSE IF (kp%scheme=='macdonald') THEN - WRITE (punit,'(A,T66,3I5)') ' BRILLOUIN| K-Point grid', kp%nk1, kp%nk2, kp%nk3 - WRITE (punit,'(A,T51,3F10.4)') ' BRILLOUIN| K-Point shift', & - kp%shift - END IF - IF (kp%symmetry) THEN - WRITE (punit,'(A,T76,A)') ' BRILLOUIN| K-Point symmetry', ' ON' - ELSE - WRITE (punit,'(A,T76,A)') ' BRILLOUIN| K-Point symmetry', ' OFF' - END IF - IF (kp%wfn_type==0) THEN - WRITE (punit,'(A,T76,A)') ' BRILLOUIN| Wavefunction type', ' REAL' - ELSE - WRITE (punit,'(A,T73,A)') ' BRILLOUIN| Wavefunction type', & - ' COMPLEX' - END IF - WRITE (punit,'(A,T71,I10)') ' BRILLOUIN| Number of K-points ', & - kp%nkpt - WRITE (punit,'(A,T30,A,T48,A,T63,A,T78,A)') ' BRILLOUIN| Number ', & - 'Weight', 'X', 'Y', 'Z' - DO i = 1, kp%nkpt - WRITE (punit,'(A,I5,3X,4F15.5)') ' BRILLOUIN| ', i, kp%weight(i), & - kp%xk(1,i), kp%xk(2,i), kp%xk(3,i) - END DO - END IF - END SUBROUTINE brillouin_info - - INTEGER FUNCTION get_kpoints_number() - get_kpoints_number = kp%nkpt - RETURN - END FUNCTION get_kpoints_number - -!------------------------------------------------------------------------------! - END MODULE brillouin -!------------------------------------------------------------------------------! diff --git a/quantum_espresso/kcp/CPV/centers_and_spreads.f90 b/quantum_espresso/kcp/CPV/centers_and_spreads.f90 deleted file mode 100644 index 0cbe9313d..000000000 --- a/quantum_espresso/kcp/CPV/centers_and_spreads.f90 +++ /dev/null @@ -1,175 +0,0 @@ -! -! Copyright (C) 2002-2007 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!----------------------------------------------------------------------- -MODULE centers_and_spreads - !--------------------------------------------------------------------- - ! - ! ... This module contains all the routines and variables important for - ! ... the calculation of centers and spreads of the variational orbitals - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - USE reciprocal_vectors, ONLY : g2_g, g, gx - USE electrons_base, ONLY : nspin - USE constants, ONLY : BOHR_RADIUS_ANGS - ! - ! - IMPLICIT NONE - ! - SAVE - ! - PRIVATE - ! - PUBLIC :: read_wannier_centers, read_wannier_spreads - ! - ! ... end of module-scope declarations - ! - !--------------------------------------------------------------------- - ! -CONTAINS - ! - ! - SUBROUTINE read_wannier_centers( centers, num_wann, emp ) - !--------------------------------------------------------------------- - ! - ! ... This routine reads the centers of Wannier functions from .xyz - ! ... file print out by Wannier90, fold them into the R=0 primitive - ! ... cell and gives them in output (in crystal units) - ! - ! ... emp = .true. when reading empty states - ! - USE kinds, ONLY : DP - USE cell_base, ONLY : bg, alat - USE constants, ONLY : BOHR_RADIUS_ANGS - USE io_files, ONLY : prefix - ! - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: num_wann ! number of Wannier functions - LOGICAL, INTENT(IN) :: emp - ! - REAL(DP), INTENT(OUT) :: centers(3,num_wann) - ! - LOGICAL :: exst - INTEGER :: n - CHARACTER(LEN=268) :: filename - CHARACTER(LEN=256) :: input_line - ! - ! - IF ( emp ) THEN - filename = trim(prefix)//'_emp_centres.xyz' - ELSE - filename = trim(prefix)//'_centres.xyz' - ENDIF - ! - INQUIRE( file=filename, exist=exst ) - ! - IF ( .not. exst ) CALL errore( 'read_wannier_centers', 'File not found', 1 ) - ! - OPEN( 100, file=filename, form='formatted', status='old' ) - ! - READ( 100, *, end=10, err=20 ) ! skip 1st line - READ( 100, *, end=10, err=20 ) ! skip 2nd line - ! - DO n = 1, num_wann - ! - READ( 100, '(a256)', end=10, err=20 ) input_line - ! - IF ( input_line(1:1) .ne. 'X' ) CALL errore( 'read_wannier_centers', & - 'X must precede each Wannier center line', 1 ) - ! - READ( input_line(2:), *, end=10, err=20 ) centers(:,n) - ! - ENDDO - ! - READ( 100, * ) input_line - IF ( input_line(1:1) == 'X' ) CALL errore( 'read_wannier_centers', & - 'Missing some center!', 1 ) - ! - CLOSE( 100 ) - ! - ! - centers = centers / ( alat * BOHR_RADIUS_ANGS ) - ! - DO n = 1, num_wann - ! - CALL cryst_to_cart( 1, centers(:,n), bg, -1 ) - ! - ENDDO - ! - RETURN - ! - 10 CALL errore ( 'read_wannier_centers', 'end of file while reading', 1 ) - 20 CALL errore ( 'read_wannier_centers', 'error while reading', 1 ) - ! - ! - END SUBROUTINE read_wannier_centers - ! - ! - SUBROUTINE read_wannier_spreads( spreads, num_wann, emp ) - !--------------------------------------------------------------------- - ! - ! ... This routine reads the spreads of Wannier functions from .wout - ! ... file print out by Wannier90, gives them in output (in Ang^2) - ! - ! ... emp = .true. when reading empty states - ! - USE io_files, ONLY : prefix - ! - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: num_wann ! number of Wannier functions - LOGICAL, INTENT(IN) :: emp - ! - REAL(DP), INTENT(OUT) :: spreads(num_wann) - ! - LOGICAL :: exst - INTEGER :: n - CHARACTER(LEN=268) :: filename - CHARACTER(LEN=256) :: input_line - ! - ! - IF ( emp ) THEN - filename = trim(prefix)//'_emp.wout' - ELSE - filename = trim(prefix)//'.wout' - ENDIF - ! - INQUIRE( file=filename, exist=exst ) - ! - IF ( .not. exst ) CALL errore( 'read_wannier_spreads', 'File not found', 1 ) - ! - OPEN( 200, file=filename, form='formatted', status='old' ) - ! - READ( 200, '(a256)', end=10, err=20 ) input_line - DO WHILE ( input_line .ne. ' Final State' ) - READ( 200, '(a256)', end=10, err=20 ) input_line - ENDDO - ! - DO n = 1, num_wann - ! - READ( 200, '(a256)', end=10, err=20 ) input_line - READ( input_line(65:), * ) spreads(n) - ! - ENDDO - ! - CLOSE( 200 ) - ! - ! - RETURN - ! - 10 CALL errore ( 'read_wannier_spreads', 'end of file while reading', 1 ) - 20 CALL errore ( 'read_wannier_spreads', 'error while reading', 1 ) - ! - ! - END SUBROUTINE read_wannier_spreads - ! - ! -END MODULE centers_and_spreads diff --git a/quantum_espresso/kcp/CPV/cg.f90 b/quantum_espresso/kcp/CPV/cg.f90 deleted file mode 100644 index 69014dbd6..000000000 --- a/quantum_espresso/kcp/CPV/cg.f90 +++ /dev/null @@ -1,135 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -MODULE cg_module - - USE kinds, ONLY: DP - - IMPLICIT NONE - SAVE - - logical :: tcg = .false. ! if true do conjugate gradient minimization for electrons - integer :: maxiter = 100 ! maximum number of iterations - real(DP) :: conv_thr = 1.d-5 !energy treshold - real(DP) :: passop =0.3d0 !small step for conjugate gradient - integer :: niter_cg_restart = 20!frequency (in iterations) for restarting the cg algorith - -!*** -!*** Conjugate Gradient -!*** - - COMPLEX(DP), ALLOCATABLE :: c0old(:,:)!old wfcs for extrapolation - logical ene_ok!if .true. do not recalculate energy - REAL(DP) :: enever!used to pass data to/from inner_loop - INTEGER :: itercg!number of cg iterations - - ! real(DP) ene0,ene1,dene0,enever,enesti !energy terms for linear minimization along hi - ! real(DP) passof,passov !step to minimum: effective, estimated - ! integer itercg !iteration number - ! logical ltresh!flag for convergence on energy - ! real(DP) passo!step to minimum - ! real(DP) etotnew,etotold!energies - ! real(DP) spasso!sign of small step - ! logical tcutoff! - ! logical restartcg!if .true. restart again the CG algorithm, performing a SD step - ! integer numok!counter on converged iterations - ! real(DP) pcnum,pcden - ! integer iter3 - ! real(DP) ebanda - - integer ninner_ef - - -CONTAINS - - - SUBROUTINE cg_init( tcg_ , maxiter_ , conv_thr_ , passop_ ,niter_cg_restart_) - USE kinds, ONLY: DP - LOGICAL, INTENT(IN) :: tcg_ - INTEGER, INTENT(IN) :: maxiter_ - REAL(DP), INTENT(IN) :: conv_thr_ , passop_ - INTEGER :: niter_cg_restart_ - tcg=tcg_ - maxiter=maxiter_ - conv_thr=conv_thr_ - passop=passop_ - niter_cg_restart=niter_cg_restart_ - IF (tcg) CALL cg_info() - RETURN - END SUBROUTINE cg_init - - SUBROUTINE cg_info() - USE io_global, ONLY: stdout - if(tcg) then - write (stdout,400) maxiter,conv_thr,passop,niter_cg_restart - endif -400 format (/4x,'========================================' & - & /4x,'| CONJUGATE GRADIENT |' & - & /4x,'========================================' & - & /4x,'| iterations =',i14,' |' & - & /4x,'| conv_thr =',f14.11,' a.u. |' & - & /4x,'| passop =',f14.5,' a.u. |' & - & /4x,'| niter_cg_restart =',i4,' |' & - & /4x,'========================================') - RETURN - END SUBROUTINE cg_info - - - SUBROUTINE allocate_cg( ngw, nx, nhsavb ) - IMPLICIT NONE - INTEGER, INTENT(IN) :: ngw, nx, nhsavb - allocate(c0old(ngw,nx)) - RETURN - END SUBROUTINE allocate_cg - - SUBROUTINE deallocate_cg( ) - IMPLICIT NONE - IF( ALLOCATED( c0old ) ) deallocate(c0old ) - RETURN - END SUBROUTINE deallocate_cg - - SUBROUTINE cg_update( tfirst, nfi, c0 ) - use gvecw, only: ngw - use electrons_base, only: n => nbsp - IMPLICIT NONE - COMPLEX(DP) :: c0( :, : ) - INTEGER :: nfi - LOGICAL :: tfirst - INTEGER :: i, ig - if(.not. tfirst.and.(mod(nfi,10).ne.1)) then - call DSWAP(2*ngw*n,c0,1,c0old,1) - do i=1,n - do ig=1,ngw - c0(ig,i)=-c0(ig,i)+2.d0*c0old(ig,i) - enddo - enddo - else - do i=1,n - do ig=1,ngw - c0old(ig,i)=c0(ig,i) - enddo - enddo - endif - RETURN - END SUBROUTINE cg_update - - SUBROUTINE print_clock_tcg() - CALL print_clock( 'runcg_uspp') - CALL print_clock( 'inner_loop') - CALL print_clock( 'rotate' ) - CALL print_clock( 'calcmt' ) - CALL print_clock( 'calcm' ) - CALL print_clock( 'pc2' ) - CALL print_clock( 'pcdaga2' ) - CALL print_clock( 'set_x_minus1' ) - CALL print_clock( 'xminus1' ) - CALL print_clock( 'emass_p_tpa' ) - return - END SUBROUTINE print_clock_tcg - -END MODULE cg_module diff --git a/quantum_espresso/kcp/CPV/cg_empty_sub.f90 b/quantum_espresso/kcp/CPV/cg_empty_sub.f90 deleted file mode 100644 index 648328c48..000000000 --- a/quantum_espresso/kcp/CPV/cg_empty_sub.f90 +++ /dev/null @@ -1,1485 +0,0 @@ - -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -!#define DEBUG -! -!======================================================================= -subroutine runcg_uspp_emp(c0_emp, cm_emp, bec_emp, f_emp, fsic_emp, n_empx, & - n_emps, ispin_emp, iupdwn_emp, nupdwn_emp, phi_emp, lambda_emp, & - maxiter_emp, wxd_emp, vsic_emp, sizvsic_emp, pink_emp, rhovan_emp, & - deeq_sic_emp, nudx_emp, eodd_emp, etot_emp, & - filledstates_potential, nfi, tfirst, eigr, bec, irb, eigrb, & - rhor, rhoc, ema0bg, desc_emp) -!======================================================================= - - use kinds, only: dp - use control_flags, only: iprsta, & - gamma_only, do_wf_cmplx, tstress !added:giovanni gamma_only, do_wf_cmplx - use core, only: nlcc_any - !---ensemble-DFT - use electrons_base, only: nspin, iupdwn, nupdwn - use ensemble_dft, only: id_matrix_init - !--- - use gvecp, only: ngm - use gvecb, only: ngb - use gvecw, only: ngw - use reciprocal_vectors, only: ng0 => gstart - use cvan, only: nvb, ish - use ions_base, only: na, nat, nsp - use grid_dimensions, only: nnr => nnrx - use cell_base, only: tpiba2 - use smooth_grid_dimensions, only: nnrsx - use io_global, ONLY: io_global_start, stdout, ionode - use mp_global, ONLY: intra_image_comm, me_image - ! use dener - use cdvan - use constants, only: pi, au_gpa - use uspp, only: nhsa => nkb, nhsavb => nkbus, betae => vkb, qq - use uspp_param, only: nh - use cg_module, only: ene_ok, maxiter, niter_cg_restart, & - conv_thr, passop, enever, itercg - use wavefunctions_module, only: c0 => cp - use mp, only: mp_sum, mp_bcast - use cp_electronic_mass, ONLY: emass_cutoff - use orthogonalize_base, ONLY: calphi - use cp_interfaces, ONLY: rhoofr, dforce, compute_stress, nlfl, set_x_minus1, xminus1 - USE cp_main_variables, ONLY: collect_lambda, distribute_lambda - USE descriptors, ONLY: la_npc_, la_npr_, la_comm_, la_me_, la_nrl_, ldim_cyclic - USE mp_global, ONLY: me_image - ! - use twin_types !added:giovanni - use printout_base, only: printout_base_open, printout_base_unit, & - printout_base_close - use nksic, only: odd_alpha, valpsi, nkscalfact, do_orbdep, wtot, vsicpsi, sizwtot, & - do_innerloop_empty, do_innerloop_cg, & - innerloop_init_n, innerloop_cg_ratio, & - innerloop_until, do_bare_eigs - use electrons_module, only: wfc_spreads_emp, wfc_centers_emp, icompute_spread - use cp_interfaces, only: gram_empty, nlsm1 - use uspp_param, only: nhm - use descriptors, only: descla_siz_ - use input_parameters, only: odd_nkscalfact_empty, wo_odd_in_empty_run, odd_nkscalfact, & - do_outerloop_empty, reortho - ! - implicit none - ! - integer :: nfi - logical :: tfirst - integer :: sizvsic_emp - complex(dp) :: eigr(ngw, nat) - type(twin_matrix) :: bec - type(twin_matrix) :: bec_emp - type(twin_matrix) :: lambda_emp(nspin) - integer :: irb(3, nat) - complex(dp) :: eigrb(ngb, nat) - real(dp) :: rhor(nnr, nspin) - real(dp) :: rhoc(nnr) - real(dp) :: ema0bg(ngw) - integer :: n_emps, n_empx, iupdwn_emp(nspin), nupdwn_emp(nspin), maxiter_emp, & - nudx_emp, ispin_emp(n_empx) - real(dp) :: f_emp(n_empx), fsic_emp(n_empx), wxd_emp(sizvsic_emp, 2), vsic_emp(sizvsic_emp, n_empx), & - pink_emp(n_empx), rhovan_emp(nhm*(nhm + 1)/2, nat, nspin), & - deeq_sic_emp(nhm, nhm, nat, n_empx), eodd_emp, etot_emp, & - filledstates_potential(nnrsx, nspin) - complex(dp) :: c0_emp(ngw, n_empx), cm_emp(ngw, n_empx), phi_emp(ngw, n_empx) - integer, intent(in) :: desc_emp(descla_siz_, 2) - ! - ! local variables - ! - integer :: i, ig, is, iss, ia, iv, jv - integer :: inl, jnl - complex(dp) :: gamma_c !warning_giovanni, is it real anyway? - complex(dp), allocatable :: c2(:), c3(:), c2_bare(:), c3_bare(:) - complex(dp), allocatable :: hpsi(:, :), hpsi0(:, :), gi(:, :), hi(:, :), gi_bare(:, :) - type(twin_matrix) :: s_minus1!(:,:) !factors for inverting US S matrix - type(twin_matrix) :: k_minus1!(:,:) !factors for inverting US preconditioning matrix - ! - real(dp) :: dumm(1) - logical :: newscheme, firstiter - integer :: maxiter3 - ! - type(twin_matrix) :: bec0, becm !modified:giovanni - ! - complex(DP) :: esse_c, essenew_c !factors in c.g. - logical :: ltresh!flag for convergence on energy - real(DP) :: passo!step to minimum - real(DP) :: etotnew, etotold!energies - real(DP) :: spasso!sign of small step - logical :: restartcg!if .true. restart again the CG algorithm, performing a SD step - integer :: numok!counter on converged iterations - integer :: iter3 - real(DP) :: passof, passov !step to minimum: effective, estimated - real(DP) :: ene0, ene1, dene0, enesti !energy terms for linear minimization along hi - ! - real(DP), allocatable :: faux(:) ! takes into account spin multiplicity - complex(DP), allocatable :: hitmp(:, :) - integer :: ninner, itercgeff - real(dp) :: tmppasso - ! - logical :: lgam, switch = .false., okvan, steepest = .false. - integer :: ierr, northo_flavor - real(DP) :: deltae, sic_coeff1, sic_coeff2 !coefficients which may change according to the flavour of SIC - integer :: me, iunit_manifold_overlap, iunit_spreads - real(DP):: ekin_emp, enl_emp, dekin_emp(6), denl_emp(3, 3), epot_emp - real(DP), allocatable :: rhor_emp(:, :), rhos_emp(:, :), rhoc_emp(:) - complex(DP), allocatable :: rhog_emp(:, :) - real(DP), allocatable :: faux_emp(:) - integer :: in_emp, issw - COMPLEX(DP), PARAMETER :: c_zero = CMPLX(0.d0, 0.d0) - CHARACTER(256) :: fname - ! - ! var for numerical derivatives - REAl(DP):: etot_emp_tmp1, etot_emp_tmp2, etot_emp_tmp - ! - call do_allocation_initialization() - ! - ! Initializing clock for minimization - ! - call start_clock('runcg_uspp') - - if (tfirst .and. ionode) & - write (stdout, "(/,a,/)") 'PERFORMING CONJUGATE GRADIENT MINIMIZATION OF EMPTY STATES' - ! - ! set tpa mass preconditioning - ! - call emass_precond_tpa(ema0bg, tpiba2, emass_cutoff) - ! - call prefor(eigr, betae) - ! - ! orthonormalize c0_empty - ! - !call orthogonalize_wfc_only(c0_emp, bec_emp) - call nlsm1(n_emps, 1, nsp, eigr, c0_emp, bec_emp, 1, lgam) - ! - ! recompute phi (the augmented wave function) from the new c0_empty - ! - CALL calphi(c0_emp, SIZE(c0_emp, 1), bec_emp, nhsa, betae, phi_emp, n_emps, lgam) - ! - ! calculates the factors for S and K inversion in US case -- they are important for preconditioning - ! see paper by Hasnip and Pickard, Computer Physics Communications 174 (2006) 24–29 - ! - if (okvan) then - ! - call init_twin(s_minus1, lgam) - call allocate_twin(s_minus1, nhsavb, nhsavb, lgam) - call init_twin(k_minus1, lgam) - call allocate_twin(k_minus1, nhsavb, nhsavb, lgam) - call set_x_minus1_twin(betae, s_minus1, dumm, .false.) - call set_x_minus1_twin(betae, k_minus1, ema0bg, .true.) - ! - else - ! - call init_twin(s_minus1, lgam) - call allocate_twin(s_minus1, 1, 1, lgam) - call init_twin(k_minus1, lgam) - call allocate_twin(k_minus1, 1, 1, lgam) - ! - end if - ! - ! set index on number of converged iterations - ! - numok = 0 - ! - allocate (hpsi(ngw, n_empx)) - allocate (hpsi0(ngw, n_empx)) - allocate (gi(ngw, n_empx), hi(ngw, n_empx)) - ! - allocate (hitmp(ngw, n_empx)) - hitmp(:, :) = CMPLX(0.d0, 0.d0) - ! - gi(:, :) = CMPLX(0.d0, 0.d0) - hi(:, :) = CMPLX(0.d0, 0.d0) - ene_ok = .false. - ! - !======================================================================= - ! begin of the main loop - !======================================================================= - ! - OUTER_LOOP: & - do while (((itercg < maxiter_emp) .and. (.not. ltresh)) .or. & - ((maxiter_emp == 1) .and. (itercg == 1) .and. (do_orbdep .and. (.not. wo_odd_in_empty_run)))) - ! - call start_clock("outer_loop") - ! - ENERGY_CHECK: & - if (.not. ene_ok) then - ! - call nlsm1(n_emps, 1, nsp, eigr, c0_emp, bec_emp, 1, lgam) - ! - call rhoofr_cp_ortho_new & - (n_empx, n_emps, nudx_emp, f_emp, ispin_emp, iupdwn_emp, & - nupdwn_emp, nspin, nfi, c0_emp, irb, eigrb, bec_emp, & - rhovan_emp, rhor_emp, rhog_emp, rhos_emp, enl_emp, denl_emp, & - ekin_emp, dekin_emp, tstress, 0) - ! - etot_emp = enl_emp + ekin_emp - ! - call v_times_rho(filledstates_potential, nspin, rhos_emp, epot_emp) - ! - etot_emp = etot_emp + epot_emp - ! - if (do_orbdep .and. (.not. wo_odd_in_empty_run)) then - ! - if (odd_nkscalfact_empty) then - ! - valpsi(:, :) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - CALL odd_alpha_routine(n_empx, .true.) - ! - else - ! - ! here, we want to use only one value alpha for all empty - ! states, - ! that value alpha is defined from in input file. - ! This require to deactive the odd_nkscalfact here so that - ! it does not do odd_alpha in nksic_potential. - ! - odd_nkscalfact = .false. - ! - end if - ! - ! - ! when reortho=.true. the empty states are reorthogonalized to the - ! occupied manifold. Of course if do_outerloop_empty=.true., the - ! orthogonalization is already performed and so this is of no use - ! - IF (reortho .AND. .NOT. do_outerloop_empty) THEN - ! - WRITE (stdout, '(A,/)') "Empty states are orthogonalized to the occupied manifold" - ! - DO iss = 1, nspin - ! - in_emp = iupdwn_emp(iss) - ! - issw = iupdwn(iss) - ! - IF (nupdwn(iss) > 0 .and. nupdwn_emp(iss) > 0) THEN - ! - CALL gram_empty(.false., eigr, betae, bec_emp, bec, nhsa, & - c0_emp(:, in_emp:), c0(:, issw:), ngw, & - nupdwn_emp(iss), nupdwn(iss), in_emp, issw) - ! - END IF - ! - END DO - ! - END IF - ! - icompute_spread = .true. - ! - call nksic_potential(n_emps, n_empx, c0_emp, fsic_emp, & - bec_emp, rhovan_emp, deeq_sic_emp, & - ispin_emp, iupdwn_emp, nupdwn_emp, rhor, rhoc, & - wtot, sizwtot, vsic_emp, .false., pink_emp, nudx_emp, & - wfc_centers_emp, wfc_spreads_emp, & - icompute_spread, .true.) - ! - ! Print spreads infor - ! - ! WRITE( stdout, *) "sum spreads:1", sum(wfc_spreads_emp(1:nupdwn_emp(1), 1, 1)), & - ! sum(wfc_spreads_emp(1:nupdwn_emp(2), 2, 1)) - ! WRITE( stdout, *) "sum spreads:2", sum(wfc_spreads_emp(1:nupdwn_emp(1), 1, 2)), & - ! sum(wfc_spreads_emp(1:nupdwn_emp(2), 2, 2)) - ! - IF ((maxiter_emp == 1) .and. (itercg == 1)) THEN - write (stdout, *) "Localization of orbitals from PZS localization" - do i = 1, nupdwn_emp(2) - write (stdout, *) i, wfc_spreads_emp(i, 2, 2), pink_emp(nupdwn_emp(1) + i) - end do - ! - ! This was removed Aug-23 2017. Check if it's OK to exit from the OUTERNLOOP here (See also line 334). NsC - EXIT - ! - END IF - ! - do i = 1, n_emps - ! - ! Here wxd_emp <-> wtot that computed from nksic_potential of occupied states. - ! wtot is scaled with nkscalfact constant, we thus need to rescaled it here with - ! odd_alpha - ! - if (odd_nkscalfact_empty) wxd_emp(:, :) = wxd_emp(:, :)*odd_alpha(i)/nkscalfact - ! - vsic_emp(:, i) = vsic_emp(:, i) + wxd_emp(:, ispin_emp(i)) - ! - end do - ! - eodd_emp = sum(pink_emp(1:n_empx)) - ! - etot_emp = etot_emp + eodd_emp - ! - end if - ! - etotnew = etot_emp - ! - else - ! - etot_emp = enever - ! - etotnew = etot_emp - ene_ok = .false. - ! - end if ENERGY_CHECK - ! - if (do_orbdep) then - ! - if (do_innerloop_empty .and. innerloop_until >= itercgeff) then - ! - call do_innerloop_subroutine() - ! - end if - ! - end if - ! - call print_out_observables() - ! - IF (.not. do_outerloop_empty) THEN - EXIT OUTER_LOOP - END IF - ! - ! here we store the etot in ene0, to keep track of the energy of the initial point - ! - call check_convergence_cg() - ! - !call prefor(eigr, betae)!ATTENZIONE - ! - call compute_hpsi() - ! - ! HPSI IS ORTHOGONALIZED TO c0 - ! - ! comp. - ! - if (switch .or. (.not. do_orbdep) .or. (do_orbdep .and. wo_odd_in_empty_run)) then - ! - call pcdaga2_new(c0_emp, phi_emp, hpsi, n_emps, ispin_emp, lgam) - ! - else - ! - call pc3nc_new(c0_emp, hpsi, n_emps, ispin_emp, lgam) - ! - end if - ! - CALL nlsm1(n_emps, 1, nsp, eigr, hpsi, becm, 1, lgam) - ! - do iss = 1, nspin - ! - in_emp = iupdwn_emp(iss) - issw = iupdwn(iss) - ! - CALL gram_empty(.true., eigr, betae, becm, bec, nhsa, & - hpsi(:, in_emp:), c0(:, issw:), ngw, & - nupdwn_emp(iss), nupdwn(iss), in_emp, issw) - ! - end do - ! - call nlsm1(n_emps, 1, nsp, eigr, hpsi, becm, 1, lgam) - ! - ! TWO VECTORS INITIALIZED TO HPSI - ! - hpsi0(1:ngw, :) = hpsi(1:ngw, :) - ! - gi(1:ngw, :) = hpsi(1:ngw, :) - ! - ! COMPUTES ULTRASOFT-PRECONDITIONED HPSI, - ! non kinetic-preconditioned, - ! is the subsequent reorthogonalization necessary - ! in the norm conserving case???: giovanni - ! - call xminus1_twin_new(hpsi, n_emps, betae, dumm, becm, s_minus1, .false.) - ! - call orthogonalize(c0_emp, hpsi, becm, bec_emp) - ! - call xminus1_twin_new(gi, n_emps, betae, ema0bg, becm, k_minus1, .true.) - ! - call orthogonalize(c0_emp, gi, becm, bec_emp) - ! - ! calculates gamma - ! - gamma_c = CMPLX(0.d0, 0.d0) - ! - DO i = 1, n_emps - ! - IF (lgam) THEN - ! - do ig = 1, ngw - ! - gamma_c = gamma_c + 2.d0*DBLE(CONJG(gi(ig, i))*hpsi(ig, i)) - ! - end do - ! - if (ng0 .eq. 2) then - ! - gamma_c = gamma_c - DBLE(CONJG(gi(1, i))*hpsi(1, i)) - ! - end if - ! - ELSE - ! - do ig = 1, ngw - ! - gamma_c = gamma_c + CONJG(gi(ig, i))*hpsi(ig, i) - ! - end do - ! - END IF - ! - END DO - ! - call mp_sum(gamma_c, intra_image_comm) - ! - if (nvb .gt. 0) then - ! - if (.not. becm%iscmplx) then - ! - do i = 1, n_emps - ! - do is = 1, nvb - ! - do iv = 1, nh(is) - ! - do jv = 1, nh(is) - ! - do ia = 1, na(is) - ! - inl = ish(is) + (iv - 1)*na(is) + ia - ! - jnl = ish(is) + (jv - 1)*na(is) + ia - ! - gamma_c = gamma_c + qq(iv, jv, is)*becm%rvec(inl, i)*bec0%rvec(jnl, i) - ! - end do - ! - end do - ! - end do - ! - end do - ! - end do - ! - else - ! - do i = 1, n_emps - ! - do is = 1, nvb - ! - do iv = 1, nh(is) - ! - do jv = 1, nh(is) - ! - do ia = 1, na(is) - ! - inl = ish(is) + (iv - 1)*na(is) + ia - ! - jnl = ish(is) + (jv - 1)*na(is) + ia - ! - gamma_c = gamma_c + qq(iv, jv, is)*CONJG(becm%cvec(inl, i))*(bec0%cvec(jnl, i)) - ! - end do - ! - end do - ! - end do - ! - end do - ! - end do - ! - end if - ! - end if - ! - ! case of first iteration - ! - gamma_c = CMPLX(DBLE(gamma_c), 0.d0) - ! - if (steepest) then - ! - ! steepest descent - ! - gamma_c = 0.d0 - ! - end if - ! - if (itercg == 1 .or. mod(itercg, niter_cg_restart) == 0 .or. restartcg) then - ! - restartcg = .false. - ! - ! We do not have to reset passof every exception of CG! - ! warning:giovanni if we do not reset we may have fake convergences!!!! - ! - passof = passop - ! - ! hi is the search direction - ! - hi(1:ngw, :) = gi(1:ngw, :) - ! - esse_c = gamma_c - ! - else - ! - ! find direction hi for general case - ! calculates gamma for general case, not using Polak Ribiere - ! - if (.not. steepest) then - ! - essenew_c = gamma_c - ! - gamma_c = gamma_c/esse_c - ! - esse_c = essenew_c - ! - else - ! - esse_c = 0.d0 - ! - essenew_c = 0.d0 - ! - end if - ! - hi(:, :) = gi(:, :) + gamma_c*hi(:, :) - ! - end if - ! - ! note that hi is saved on gi, because we need it before projection on conduction states - ! - ! ... find minimum along direction hi: - ! - ! project hi on conduction sub-space - ! - call orthogonalize(c0_emp, hi, bec0, bec_emp) - ! - ! do quadratic minimization - ! - ! calculate derivative with respect to lambda along direction hi - ! - dene0 = 0.d0 - ! - do i = 1, n_emps - ! - IF (lgam) THEN - ! - do ig = 1, ngw - ! - dene0 = dene0 - 4.d0*DBLE(CONJG(hi(ig, i))*hpsi0(ig, i)) - ! - end do - ! - if (ng0 .eq. 2) then - ! - dene0 = dene0 + 2.d0*DBLE(CONJG(hi(1, i))*hpsi0(1, i)) - ! - end if - ! - ELSE - ! - do ig = 1, ngw - ! - dene0 = dene0 - 2.d0*DBLE(CONJG(hi(ig, i))*hpsi0(ig, i)) - ! - end do - ! - END IF - ! - end do - ! - ! We need the following because n for spin 2 is double that for spin 1! - ! - dene0 = dene0*2.d0/nspin - ! - call mp_sum(dene0, intra_image_comm) - ! - ! if the derivative is positive, search along opposite direction - ! - if (dene0 .gt. 0.d0) then - ! - spasso = -1.D0 - ! - else - ! - spasso = 1.d0 - ! - end if - ! - ! below is the debug part, that computes numerical derivative. - ! Thank Nicola for providing it. - ! - if (.false.) then - ! - etot_emp_tmp1 = 0.0 - etot_emp_tmp2 = 0.0 - etot_emp_tmp = 0.0 - ! - tmppasso = 0.0 - do i = 1, 30 - tmppasso = tmppasso + 0.1 - ! - !if (i==1) tmppasso=1.d-5 - !if (i==2) tmppasso=-1.d-5 - ! - cm_emp(:, :) = c0_emp(:, :) + spasso*tmppasso*hi(:, :) - ! - if (lgam .and. ng0 == 2) cm_emp(1, :) = 0.5d0*(cm_emp(1, :) + CONJG(cm_emp(1, :))) - ! - ! orthonormalize - ! - call orthogonalize_wfc_only(cm_emp, becm) - ! - call rhoofr_cp_ortho_new & - (n_empx, n_emps, nudx_emp, f_emp, ispin_emp, iupdwn_emp, & - nupdwn_emp, nspin, nfi, cm_emp, irb, eigrb, becm, & - rhovan_emp, rhor_emp, rhog_emp, rhos_emp, enl_emp, denl_emp, & - ekin_emp, dekin_emp, tstress, 0) - ! - etot_emp_tmp = enl_emp + ekin_emp - ! - call v_times_rho(filledstates_potential, nspin, rhos_emp, epot_emp) - ! - etot_emp_tmp = etot_emp_tmp + epot_emp - ! - if (do_orbdep .and. (.not. wo_odd_in_empty_run)) then - ! - if (odd_nkscalfact_empty) then - ! - valpsi(:, :) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - CALL odd_alpha_routine(n_empx, .true.) - ! - else - ! - ! here, we want to use only one value alpha for all empty - ! states, - ! that value alpha is defined from in input file. - ! This require to deactive the odd_nkscalfact here so that - ! it does not do odd_alpha in nksic_potential. - ! - odd_nkscalfact = .false. - ! - end if - ! - call nksic_potential(n_emps, n_empx, cm_emp, fsic_emp, & - becm, rhovan_emp, deeq_sic_emp, & - ispin_emp, iupdwn_emp, nupdwn_emp, rhor, rhoc, & - wtot, sizwtot, vsic_emp, .false., pink_emp, nudx_emp, & - wfc_centers_emp, wfc_spreads_emp, & - icompute_spread, .true.) - ! - eodd_emp = sum(pink_emp(:)) - ! - etot_emp_tmp = etot_emp_tmp + eodd_emp - ! - end if - ! - write (stdout, *) "etot_emp: ", i, tmppasso, " = ", etot_emp_tmp - ! - !if (i==1) etot_emp_tmp1 = etot_emp_tmp - !if (i==2) etot_emp_tmp2 = etot_emp_tmp - ! - end do - ! - !write(stdout,*) "here is numerical derivative vs analytic derivative at step", itercg - !write(stdout,*) "(etot_emp_tmp1-etot_emp_tmp2)/tmppasso, dene0, tmppasso, ((etot_emp-ene0)/tmppasso)/dene0" - !write(stdout,'(2e25.15,4e20.10)') (etot_emp_tmp1 - etot_emp_tmp2)/(2.0*tmppasso), dene0, tmppasso, ((etot_emp_tmp1 - etot_emp_tmp2)/(2.0*tmppasso)/dene0) - ! - end if - ! - ! calculates wave-functions on a point on direction hi - ! - cm_emp(:, :) = c0_emp(:, :) + spasso*passof*hi(:, :) - ! - if (lgam .and. ng0 == 2) cm_emp(1, :) = 0.5d0*(cm_emp(1, :) + CONJG(cm_emp(1, :))) - ! - ! orthonormalize - ! - call orthogonalize_wfc_only(cm_emp, becm) - ! - call rhoofr_cp_ortho_new & - (n_empx, n_emps, nudx_emp, f_emp, ispin_emp, iupdwn_emp, & - nupdwn_emp, nspin, nfi, cm_emp, irb, eigrb, becm, & - rhovan_emp, rhor_emp, rhog_emp, rhos_emp, enl_emp, denl_emp, & - ekin_emp, dekin_emp, tstress, 0) - ! - etot_emp = enl_emp + ekin_emp - ! - call v_times_rho(filledstates_potential, nspin, rhos_emp, epot_emp) - ! - etot_emp = etot_emp + epot_emp - ! - if (do_orbdep .and. (.not. wo_odd_in_empty_run)) then - ! - if (odd_nkscalfact_empty) then - ! - valpsi(:, :) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - CALL odd_alpha_routine(n_empx, .true.) - ! - else - ! - ! here, we want to use only one value alpha for all empty - ! states, - ! that value alpha is defined from in input file. - ! This require to deactive the odd_nkscalfact here so that - ! it does not do odd_alpha in nksic_potential. - ! - odd_nkscalfact = .false. - ! - end if - ! - call nksic_potential(n_emps, n_empx, cm_emp, fsic_emp, & - becm, rhovan_emp, deeq_sic_emp, & - ispin_emp, iupdwn_emp, nupdwn_emp, rhor, rhoc, & - wtot, sizwtot, vsic_emp, .false., pink_emp, nudx_emp, & - wfc_centers_emp, wfc_spreads_emp, & - icompute_spread, .true.) - ! - eodd_emp = sum(pink_emp(:)) - ! - etot_emp = etot_emp + eodd_emp - ! - end if - ! - ene1 = etot_emp - ! - ! find the minimum - ! - call minparabola(ene0, spasso*dene0, ene1, passof, passo, enesti) - ! - if (ionode .and. iprsta > 1) write (stdout, "(6f20.12)") ene0, dene0, ene1, passo, DBLE(gamma_c), esse_c - ! - ! set new step - ! - passov = passof - ! - ! doing the following makes the convergence better... - ! - passof = passo - ! - ! calculates wave-functions at minimum - ! - cm_emp(:, :) = c0_emp(:, :) + spasso*passo*hi(:, :) - ! - IF (lgam .and. ng0 == 2) cm_emp(1, :) = 0.5d0*(cm_emp(1, :) + CONJG(cm_emp(1, :))) - ! - call orthogonalize_wfc_only(cm_emp, becm) - ! - call rhoofr_cp_ortho_new & - (n_empx, n_emps, nudx_emp, f_emp, ispin_emp, iupdwn_emp, & - nupdwn_emp, nspin, nfi, cm_emp, irb, eigrb, becm, & - rhovan_emp, rhor_emp, rhog_emp, rhos_emp, enl_emp, denl_emp, & - ekin_emp, dekin_emp, tstress, 0) - ! - etot_emp = enl_emp + ekin_emp - ! - call v_times_rho(filledstates_potential, nspin, rhos_emp, epot_emp) - ! - etot_emp = etot_emp + epot_emp - ! - if (do_orbdep .and. (.not. wo_odd_in_empty_run)) then - ! - if (odd_nkscalfact_empty) then - ! - valpsi(:, :) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - CALL odd_alpha_routine(n_empx, .true.) - ! - else - ! - ! here, we want to use only one value alpha for all empty - ! states, - ! that value alpha is defined from in input file. - ! This require to deactive the odd_nkscalfact here so that - ! it does not do odd_alpha in nksic_potential. - ! - odd_nkscalfact = .false. - ! - end if - ! - icompute_spread = .true. - call nksic_potential(n_emps, n_empx, cm_emp, fsic_emp, & - becm, rhovan_emp, deeq_sic_emp, & - ispin_emp, iupdwn_emp, nupdwn_emp, rhor, rhoc, & - wtot, sizwtot, vsic_emp, .false., pink_emp, nudx_emp, & - wfc_centers_emp, wfc_spreads_emp, & - icompute_spread, .true.) - ! - ! Print spreads infor - ! - ! WRITE( stdout, *) "sum spreads:1", sum(wfc_spreads_emp(1:nupdwn_emp(1), 1, 1)), & - ! sum(wfc_spreads_emp(1:nupdwn_emp(2), 2, 1) - ! WRITE( stdout, *) "sum spreads:2", sum(wfc_spreads_emp(1:nupdwn_emp(1), 1, 2)), & - ! sum(wfc_spreads_emp(1:nupdwn_emp(2), 2, 2)) - ! - do i = 1, n_emps - ! - ! Here wxd_emp <-> wtot that computed from nksic_potential of - ! occupied states. - ! wtot is scaled with nkscalfact constant, we thus need to - ! rescaled it here with - ! odd_alpha - ! - if (odd_nkscalfact_empty) wxd_emp(:, :) = wxd_emp(:, :)*odd_alpha(i)/nkscalfact - ! - vsic_emp(:, i) = vsic_emp(:, i) + wxd_emp(:, ispin_emp(i)) - ! - end do - ! - eodd_emp = sum(pink_emp(:)) - ! - etot_emp = etot_emp + eodd_emp - ! - end if - ! - enever = etot_emp - ! - ! check with what supposed - ! -#ifdef DEBUG - write (stdout, *) 'ene0, dene0, ene1, enesti,enever, passo, passov, passof' - write (stdout, "(7f18.12)") ene0, dene0, ene1, enesti, enever, passo, passov, passof -#endif - ! - ! if the energy has diminished with respect to ene0 and ene1 , everything ok - ! - if (((enever .lt. ene0) .and. (enever .lt. ene1))) then - ! - c0_emp(:, :) = cm_emp(:, :) - ! - call copy_twin(bec_emp, becm) !modified:giovanni - ! - ene_ok = .true. - ! - ! if ene1 << energy < ene0; go to ene1 - ! - elseif ((enever .ge. ene1) .and. (enever .lt. ene0)) then - ! - if (ionode) then - ! - write (stdout, "(5x,a,i5,f20.12)") 'WARNING cg_sub: missed minimum, case 1, iteration', itercg, passof - ! - end if - ! - c0_emp(:, :) = c0_emp(:, :) + spasso*passov*hi(:, :) - ! - passof = 2.d0*passov - ! - restartcg = .true. - ! - call orthogonalize_wfc_only(c0_emp, bec_emp) - ! - ene_ok = .false. - ! - ! if ene1 << ene0 <= energy; go to ene1 - ! - elseif ((enever .ge. ene0) .and. (ene0 .gt. ene1)) then - ! - if (ionode) then - write (stdout, "(5x,a,i5)") 'WARNING cg_sub: missed minimum, case 2, iteration', itercg - end if - ! - c0_emp(:, :) = c0_emp(:, :) + spasso*passov*hi(:, :) - ! - passof = 1.d0*passov - ! - restartcg = .true. - ! - call orthogonalize_wfc_only(c0_emp, bec_emp) - ! - ene_ok = .false. - ! - ! if ene > ene0, en1 do a steepest descent step - ! - elseif ((enever .ge. ene0) .and. (ene0 .le. ene1)) then - ! - if (ionode) then - write (stdout, "(5x,a,i5)") 'WARNING cg_sub: missed minimum, case 3, iteration, doing steepest descent', itercg - end if - ! - iter3 = 0 - ! - do while (enever .ge. ene0 .and. iter3 .lt. maxiter3) - ! - iter3 = iter3 + 1 - ! - passov = passov*0.5d0 - ! - cm_emp(:, :) = c0_emp(:, :) + spasso*passov*hi(:, :) - ! - passof = 1.d0*passov - ! - itercgeff = itercgeff + 1 - ! - ! change the searching direction - ! - spasso = spasso*(-1.d0) - ! - call orthogonalize_wfc_only(cm_emp, becm) - ! - call rhoofr_cp_ortho_new & - (n_empx, n_emps, nudx_emp, f_emp, ispin_emp, iupdwn_emp, & - nupdwn_emp, nspin, nfi, cm_emp, irb, eigrb, becm, & - rhovan_emp, rhor_emp, rhog_emp, rhos_emp, enl_emp, denl_emp, & - ekin_emp, dekin_emp, tstress, 0) - ! - etot_emp = enl_emp + ekin_emp - ! - call v_times_rho(filledstates_potential, nspin, rhos_emp, epot_emp) - ! - etot_emp = etot_emp + epot_emp - ! - if (do_orbdep .and. (.not. wo_odd_in_empty_run)) then - ! - if (odd_nkscalfact_empty) then - ! - valpsi(:, :) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - call odd_alpha_routine(n_empx, .true.) - ! - else - ! - ! here, we want to use only one value alpha for all empty - ! states, - ! that value alpha is defined from in input file. - ! This require to deactive the odd_nkscalfact here so that - ! it does not do odd_alpha in nksic_potential. - ! - odd_nkscalfact = .false. - ! - end if - ! - icompute_spread = .false. - call nksic_potential(n_emps, n_empx, cm_emp, fsic_emp, & - becm, rhovan_emp, deeq_sic_emp, & - ispin_emp, iupdwn_emp, nupdwn_emp, rhor, rhoc, & - wtot, sizwtot, vsic_emp, .false., pink_emp, nudx_emp, & - wfc_centers_emp, wfc_spreads_emp, & - icompute_spread, .true.) - ! - eodd_emp = sum(pink_emp(:)) - ! - etot_emp = etot_emp + eodd_emp - ! - end if - ! - enever = etot_emp - ! - end do - ! - if (ionode) write (stdout, "(7x,a,i5)") 'iter3 = ', iter3 - ! - if (iter3 == maxiter3 .and. enever .gt. ene0) then - ! - write (stdout, "(7x,a)") 'WARNING missed minimum: iter3 = maxiter3' - write (stdout, '(7x, "enever, ene0", 2F20.15)') enever, ene0 - ! - elseif (enever .le. ene0) then - ! - c0_emp(:, :) = cm_emp(:, :) - ! - call copy_twin(bec_emp, becm) - ! - end if - ! - restartcg = .true. - ene_ok = .false. - ! - if (iter3 == maxiter3) then - ! - passof = passop - ! - end if - ! - end if - ! - if (.not. ene_ok) call nlsm1(n_emps, 1, nsp, eigr, c0_emp, bec_emp, 1, lgam) - ! - ! calculates phi for pc_daga - ! - call calphi(c0_emp, SIZE(c0_emp, 1), bec_emp, nhsa, betae, phi_emp, n_emps, lgam) - ! - !======================================================================= - ! end of the outer loop - !======================================================================= - ! - itercg = itercg + 1 - ! - itercgeff = itercgeff + 1 - ! - call stop_clock("outer_loop") - ! - end do OUTER_LOOP - ! - !======================================================================= - ! end of the main loop - !======================================================================= - ! - ! faux takes into account spin multiplicity. - ! - faux(:) = f_emp(:)*DBLE(nspin)/2.0d0 - ! - IF (do_bare_eigs) THEN - ! - allocate (c2_bare(ngw), c3_bare(ngw)) - allocate (gi_bare(ngw, n_empx)) - c2_bare = 0.d0 - c3_bare = 0.d0 - gi_bare = 0.d0 - ! - END IF - ! - do i = 1, n_emps, 2 - ! - call start_clock('dforce2') - ! - call dforce(i, bec_emp, betae, c0_emp, c2, c3, filledstates_potential, nnrsx, ispin_emp, faux, n_emps, nspin) - ! - IF (do_bare_eigs) THEN - ! - c2_bare(:) = c2(:) - c3_bare(:) = c3(:) - ! - END IF - ! - call start_clock('dforce2') - ! - if (do_orbdep .and. (.not. wo_odd_in_empty_run)) then - ! - ! faux takes into account spin multiplicity. - ! - call nksic_eforce(i, n_emps, n_empx, vsic_emp, deeq_sic_emp, bec_emp, ngw, c0_emp(:, i), c0_emp(:, i + 1), vsicpsi, & - lgam) - ! - c2(:) = c2(:) - vsicpsi(:, 1)*faux(i) - ! - if (i + 1 <= n_emps) c3(:) = c3(:) - vsicpsi(:, 2)*faux(i + 1) - ! - end if - ! - do ig = 1, ngw - ! - gi(ig, i) = c2(ig) - ! - if (i + 1 <= n_emps) gi(ig, i + 1) = c3(ig) - ! - end do - ! - if (lgam .and. ng0 .eq. 2) then - ! - gi(1, i) = CMPLX(DBLE(gi(1, i)), 0.d0) - ! - if (i + 1 <= n_emps) gi(1, i + 1) = CMPLX(DBLE(gi(1, i + 1)), 0.d0) - ! - end if - ! - ! - IF (do_bare_eigs) THEN - ! - do ig = 1, ngw - gi_bare(ig, i) = c2_bare(ig) - if (i + 1 <= n_emps) gi_bare(ig, i + 1) = c3_bare(ig) - end do - ! - if (lgam .and. ng0 .eq. 2) then - gi_bare(1, i) = CMPLX(DBLE(gi_bare(1, i)), 0.d0) - if (i + 1 <= n_emps) gi_bare(1, i + 1) = CMPLX(DBLE(gi_bare(1, i + 1)), 0.d0) - end if - ! - END IF - ! - end do - ! - IF (do_bare_eigs) THEN - CALL compute_lambda(c0_emp, gi_bare, lambda_emp, nspin, n_empx, ngw, nudx_emp, desc_emp, nupdwn_emp, iupdwn_emp) - fname = 'hamiltonian0_emp' - WRITE (stdout, '(/,3X,"writing empty state DFT Hamiltonian file: ",A)') TRIM(fname) - CALL write_ham_emp_xml(nspin, nudx_emp, lambda_emp, desc_emp, fname) - END IF - ! - CALL compute_lambda(c0_emp, gi, lambda_emp, nspin, n_empx, ngw, nudx_emp, desc_emp, nupdwn_emp, iupdwn_emp) - fname = 'hamiltonian_emp' - WRITE (stdout, '(/,3X,"writing empty state KC Hamiltonian file: ",A)') TRIM(fname) - CALL write_ham_emp_xml(nspin, nudx_emp, lambda_emp, desc_emp, fname) - ! - call do_deallocation() - ! - return - ! -contains - ! - ! - ! - subroutine do_allocation_initialization() - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! INITIALIZATION PART (variables, allocation of arrays, minimization parameters) - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - !!! Initialize some basic variables - ! - me = me_image + 1 - lgam = gamma_only .and. .not. do_wf_cmplx - okvan = (nvb > 0) - ! - deltae = 2.d0*conv_thr - etotnew = 0.d0 - etotold = 0.d0 - ! - !!! Initialize printing - ! - IF (ionode) THEN - ! - iunit_spreads = printout_base_unit("sha") - CALL printout_base_open("sha") - WRITE (iunit_spreads, *) " " - iunit_manifold_overlap = printout_base_unit("ovp") - CALL printout_base_open("ovp") - WRITE (iunit_manifold_overlap, *) " " - ! - END IF - ! - northo_flavor = 1 - ! - IF (northo_flavor == 2) THEN - ! - sic_coeff1 = 1.d0 - sic_coeff2 = 1.d0 - ! - ELSE - ! - sic_coeff1 = 0.5d0 - sic_coeff2 = 0.5d0 - ! - END IF - ! - allocate (faux(n_empx)) - allocate (faux_emp(n_empx)) - ! - faux_emp = 0.d0 - ! - allocate (c2(ngw), c3(ngw)) - ! - allocate (rhor_emp(nnr, nspin), rhos_emp(nnrsx, nspin), rhog_emp(ngm, nspin)) - ! - if (nlcc_any) allocate (rhoc_emp(nnr)) - ! - ! Allocation of twin-type variables - ! - call init_twin(bec0, lgam) - call allocate_twin(bec0, nhsa, n_emps, lgam) - ! - call init_twin(becm, lgam) - call allocate_twin(becm, nhsa, n_emps, lgam) - ! - ! initializing variables for checking iterations and convergence - ! - newscheme = .false. - firstiter = .true. - maxiter3 = 12 - ! - if (do_orbdep) maxiter3 = 10 - ! - ninner = 0 - ! - ltresh = .false. - itercg = 1 - etotold = 1.d8 - restartcg = .true. - passof = passop - ene_ok = .false. - ! - itercgeff = 1 - ! - end subroutine do_allocation_initialization - - subroutine do_deallocation() - ! - deallocate (hpsi0, hpsi, gi, hi) - deallocate (hitmp, STAT=ierr) - ! - call deallocate_twin(s_minus1) - call deallocate_twin(k_minus1) - ! - call stop_clock('runcg_uspp') - ! - call deallocate_twin(bec0) - call deallocate_twin(becm) - ! - deallocate (c2, c3) - deallocate (faux) - deallocate (faux_emp) - deallocate (rhor_emp, rhos_emp, rhog_emp) - ! - if (nlcc_any) deallocate (rhoc_emp) - ! - IF (ionode) THEN - ! - CALL printout_base_close("sha") - CALL printout_base_close("ovp") - ! - END IF - ! - IF (allocated(c2_bare)) deallocate (c2_bare) - IF (allocated(c3_bare)) deallocate (c3_bare) - IF (allocated(gi_bare)) deallocate (gi_bare) - ! - end subroutine do_deallocation - ! - subroutine do_innerloop_subroutine() - ! - call start_clock("inner_loop") - ! - eodd_emp = sum(pink_emp(:)) - etot_emp = etot_emp - eodd_emp - etotnew = etotnew - eodd_emp - ninner = 0 - ! - if (.not. do_innerloop_cg) then - ! - write (stdout, *) "WARNING, do_innerloop_cg should be .true." - ! - else - ! - call nksic_rot_emin_cg_general(itercg, innerloop_init_n, ninner, etot_emp, deltae*innerloop_cg_ratio, lgam, & - n_emps, n_empx, nudx_emp, iupdwn_emp, nupdwn_emp, ispin_emp, & - c0_emp, rhovan_emp, bec_emp, rhor, rhoc, vsic_emp, pink_emp, & - deeq_sic_emp, wtot, fsic_emp, sizwtot, .false., wfc_centers_emp, wfc_spreads_emp, .true.) - ! - end if - ! - eodd_emp = sum(pink_emp(:)) - etot_emp = etot_emp + eodd_emp - etotnew = etotnew + eodd_emp - ! - call stop_clock("inner_loop") - ! - end subroutine do_innerloop_subroutine - ! - subroutine print_out_observables() - ! - call print_clock('CP') - ! - if (ionode) then - ! - if (itercg > 2) then - write (stdout, '(5x,"iteration =",I4," eff iteration =",I4," Etot (Ha) =",F22.14," delta_E=",E22.14)') & - itercg, itercgeff, etotnew, deltae - else - write (stdout, '(5x,"iteration =",I4," eff iteration =",I4," Etot (Ha) =",F22.14)') & - itercg, itercgeff, etotnew - end if - ! - write (stdout, '(5x, "Ekin (Ha) = ",F22.14 , " Enl (Ha) = ",F22.14, " Eloc (Ha) =" , F22.14)') & - ekin_emp, enl_emp, epot_emp - ! - if (do_orbdep .and. (.not. wo_odd_in_empty_run)) then - write (stdout, '(1x, "Fake EODD (Ha) = ",F22.14) ') eodd_emp - end if - ! - if (etotnew /= etotnew) call errore(' print_out_observables ', 'Energy is NaN', 1) - end if - ! - if (ionode .and. mod(itercg, 10) == 0) write (stdout, "()") - ! - !if ( ionode .and. mod(itercg, iprint_spreads)==0) then - if (.false.) then - ! - if (nspin == 1) then - ! - write (iunit_spreads, '(400f20.14)') wfc_spreads_emp(:, 1, 2) - ! - elseif (nspin == 2) then - ! - write (iunit_spreads, '(2(400f20.14)(3x))') wfc_spreads_emp(:, 1, 2), wfc_spreads_emp(:, 2, 2) - ! - end if - ! - end if - ! - end subroutine print_out_observables - ! - subroutine check_convergence_cg() - ! - deltae = abs(etotnew - etotold) - ! - if (deltae < conv_thr) then - numok = numok + 1 - else - numok = 0 - end if - ! - if (numok >= 4) ltresh = .true. - ! - if (ltresh .or. itercg == maxiter - 1) icompute_spread = .true. - ! - etotold = etotnew - ene0 = etot_emp - ! - end subroutine check_convergence_cg - ! - subroutine compute_hpsi() - ! - ! faux takes into account spin multiplicity. - ! - faux(:) = 0.d0 - faux(1:n_emps) = f_emp(1:n_emps)*DBLE(nspin)/2.0d0 - ! - do i = 1, n_emps, 2 - ! - call dforce(i, bec_emp, betae, c0_emp, c2, c3, filledstates_potential, nnrsx, ispin_emp, faux, n_emps, nspin) - ! - ! ODD terms - ! - if (do_orbdep .and. (.not. wo_odd_in_empty_run)) then - ! - CALL nksic_eforce(i, n_emps, n_empx, vsic_emp, deeq_sic_emp, bec_emp, ngw, & - c0_emp(:, i), c0_emp(:, i + 1), vsicpsi, lgam) - ! - c2(:) = c2(:) - vsicpsi(:, 1)*faux(i) - ! - if (i + 1 <= n_emps) c3(:) = c3(:) - vsicpsi(:, 2)*faux(i + 1) - ! - end if - ! - hpsi(1:ngw, i) = c2(1:ngw) - ! - if (i + 1 <= n_emps) then - hpsi(1:ngw, i + 1) = c3(1:ngw) - end if - ! - if (lgam) then - ! - if (ng0 .eq. 2) then - ! - hpsi(1, i) = CMPLX(DBLE(hpsi(1, i)), 0.d0) - ! - if (i + 1 <= n_emps) then - ! - hpsi(1, i + 1) = CMPLX(DBLE(hpsi(1, i + 1)), 0.d0) - ! - end if - ! - end if - ! - end if - ! - end do - ! - end subroutine compute_hpsi - - subroutine orthogonalize(wfc0, wfc, becwfc, bec0) - ! - type(twin_matrix) :: becwfc, bec0 - complex(DP) :: wfc(:, :), wfc0(:, :) - ! - if (switch .or. (.not. do_orbdep) .or. (do_orbdep .and. wo_odd_in_empty_run)) then - ! - call pc2_new(wfc0, bec0, wfc, becwfc, n_emps, & - nupdwn_emp, iupdwn_emp, ispin_emp, lgam) - ! - else - ! - if (.not. okvan) then - ! - call pc3nc_new(wfc0, wfc, n_empx, ispin_emp, lgam) - ! - else - ! - call pc3nc_new(wfc0, wfc, n_empx, ispin_emp, lgam) - ! - end if - ! - end if - ! - CALL nlsm1(n_emps, 1, nsp, eigr, wfc, becwfc, 1, lgam) - ! - do iss = 1, nspin - ! - in_emp = iupdwn_emp(iss) - issw = iupdwn(iss) - ! - CALL gram_empty(.true., eigr, betae, becwfc, bec, nhsa, & - wfc(:, in_emp:), c0(:, issw:), & - ngw, nupdwn_emp(iss), nupdwn(iss), in_emp, issw) - ! - end do - ! - end subroutine orthogonalize - ! - subroutine orthogonalize_wfc_only(wfc, becwfc) - ! - type(twin_matrix) :: becwfc - complex(DP) :: wfc(:, :) - ! - call nlsm1(n_emps, 1, nsp, eigr, wfc, becwfc, 1, lgam) - ! - do iss = 1, nspin - ! - issw = iupdwn(iss) - in_emp = iupdwn_emp(iss) - ! - CALL gram_empty(.false., eigr, betae, becwfc, bec, nhsa, & - wfc(:, in_emp:), c0(:, issw:), & - ngw, nupdwn_emp(iss), nupdwn(iss), in_emp, issw) - ! - end do - ! - call nlsm1(n_emps, 1, nsp, eigr, wfc, becwfc, 1, lgam) - ! - end subroutine orthogonalize_wfc_only - ! - subroutine v_times_rho(v, nspin, rhos_emp, epot_emp) - ! - use kinds, only: DP - use mp, only: mp_sum - use mp_global, only: intra_image_comm - use cell_base, only: omega - use smooth_grid_dimensions, only: nnrsx, nr1s, nr2s, nr3s - ! - implicit none - ! - integer, intent(in) :: nspin - real(DP), intent(in) :: v(nnrsx, nspin), rhos_emp(nnrsx, nspin) - real(DP), intent(out) :: epot_emp - ! - ! local vars - ! - integer :: i - real(DP) :: etemp, fact, rhosum(2) - ! - etemp = 0.d0 - rhosum = 0.d0 - fact = omega/DBLE(nr1s*nr2s*nr3s) - ! - do i = 1, nspin - ! - etemp = etemp + sum(v(1:nnrsx, i)*rhos_emp(1:nnrsx, i)) - ! - rhosum(i) = sum(rhos_emp(1:nnrsx, i)) - ! - end do - ! - call mp_sum(etemp, intra_image_comm) - ! - call mp_sum(rhosum, intra_image_comm) - ! - epot_emp = etemp*fact - ! - rhosum = rhosum*fact - ! - return - ! - end subroutine v_times_rho - ! -END SUBROUTINE runcg_uspp_emp - diff --git a/quantum_espresso/kcp/CPV/cg_sub.f90 b/quantum_espresso/kcp/CPV/cg_sub.f90 deleted file mode 100644 index a737be9c2..000000000 --- a/quantum_espresso/kcp/CPV/cg_sub.f90 +++ /dev/null @@ -1,1947 +0,0 @@ -! -! Copyright (C) 2002 CP90 group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -!#define DEBUG !! Uncomment this for extra prints out -! -!======================================================================= -subroutine runcg_uspp(nfi, tfirst, tlast, eigr, bec, irb, eigrb, & - rhor, rhog, rhos, rhoc, ei1, ei2, ei3, sfac, & - fion, ema0bg, becdr, lambdap, lambda, lambda_bare, vpot) -!======================================================================= - ! - use kinds, only: dp - use control_flags, only: tpre, iprsta, & - tfor, tprnfor, gamma_only, do_wf_cmplx !added:giovanni gamma_only, do_wf_cmplx - use core, only: nlcc_any - !---ensemble-DFT - use energies, only: etot, enl, ekin, eodd - use electrons_base, only: f, nspin, iupdwn, nupdwn, nudx, & - nbspx, nbsp, ispin - use ensemble_dft, only: id_matrix_init - !--- - use gvecp, only: ngm - use gvecs, only: ngs - use gvecb, only: ngb - use gvecw, only: ngw, ngwx - use reciprocal_vectors, only: ng0 => gstart - use cvan, only: nvb, ish - use ions_base, only: na, nat, nsp, zv - use grid_dimensions, only: nnr => nnrx, nr1, nr2, nr3 - use cell_base, only: omega, alat - use cell_base, only: tpiba2 - use smooth_grid_dimensions, only: nnrsx - !use smallbox_grid_dimensions, only : nnrb => nnrbx - use io_global, ONLY: io_global_start, stdout, ionode - use mp_global, ONLY: intra_image_comm, me_image - use dener - use cdvan - use constants, only: pi, au_gpa, e2 - use uspp, only: nhsa => nkb, nhsavb => nkbus, betae => vkb, rhovan => becsum, deeq, qq - use uspp_param, only: nh - use cg_module, only: ene_ok, maxiter, niter_cg_restart, & - conv_thr, passop, enever, itercg - use ions_positions, only: ityp, tau0 - use wavefunctions_module, only: c0, cm, phi => cp, cstart - use efield_module, only: tefield, evalue, qmat, ipolp, & - berry_energy, ctabin, gqq, gqqm, df, & - tefield2, berry_energy2 - use mp, only: mp_sum, mp_bcast - use cp_electronic_mass, ONLY: emass_cutoff - use orthogonalize_base, ONLY: calphi - use cp_interfaces, ONLY: rhoofr, dforce, compute_stress, nlfl, set_x_minus1, xminus1 - USE cp_main_variables, ONLY: nlax, collect_lambda, distribute_lambda, descla - USE descriptors, ONLY: la_npc_, la_npr_, la_comm_, la_me_, la_nrl_, ldim_cyclic - USE mp_global, ONLY: me_image - ! - use nksic, only: do_orbdep, do_innerloop, do_innerloop_cg, & - innerloop_init_n, innerloop_cg_ratio, & - vsicpsi, vsic, wtot, fsic, deeq_sic, f_cutoff, & - pink, do_wxd, sizwtot, do_bare_eigs, innerloop_until, & - valpsi, odd_alpha - use hfmod, only: do_hf, vxxpsi, exx - use twin_types !added:giovanni - use cp_main_variables, only: becstart - use electrons_module, only: wfc_spreads, wfc_centers, icompute_spread, manifold_overlap - use ldau, only: lda_plus_u, vupsi - use printout_base, only: printout_base_open, printout_base_unit, & - printout_base_close - use control_flags, only: iprint_manifold_overlap, iprint_spreads - use input_parameters, only: fixed_state, fixed_band, odd_nkscalfact, do_outerloop, & - finite_field_introduced, finite_field_for_empty_state - ! - implicit none - ! - CHARACTER(LEN=6), EXTERNAL :: int_to_char - integer, EXTERNAL :: get_clock - integer :: nfi - logical :: tfirst, tlast - complex(dp) :: eigr(ngw, nat) - type(twin_matrix) :: bec !modified:giovanni - type(twin_tensor) :: becdr!(nhsa,nspin*nlax,3) !modified:giovanni - integer :: irb(3, nat) - complex(dp) :: eigrb(ngb, nat) - real(dp) :: rhor(nnr, nspin) - real(dp) :: vpot(nnr, nspin) - complex(dp) :: rhog(ngm, nspin) - real(dp) :: rhos(nnrsx, nspin) - real(dp) :: rhoc(nnr) - complex(dp) :: ei1(-nr1:nr1, nat) - complex(dp) :: ei2(-nr2:nr2, nat) - complex(dp) :: ei3(-nr3:nr3, nat) - complex(dp) :: sfac(ngs, nsp) - real(dp) :: fion(3, nat) - real(dp) :: ema0bg(ngw) - type(twin_matrix) :: lambdap(nspin)!(nlam,nlam,nspin) !modified:giovanni - type(twin_matrix) :: lambda(nspin)!(nlam,nlam,nspin) !modified:giovanni - type(twin_matrix) :: lambda_bare(nspin) !(nlam,nlam,nspin) !modified:giovanni - ! - integer :: i, ig, is, ia, iv, jv, iat - integer :: inl, jnl - real(dp) :: enb, enbi - complex(dp) :: gamma_c !warning_giovanni, is it real anyway? - complex(dp), allocatable :: c2(:), c3(:), c2_bare(:), c3_bare(:) - complex(dp), allocatable :: hpsi(:, :), hpsi0(:, :), gi(:, :), hi(:, :), gi_bare(:, :) - type(twin_matrix) :: s_minus1!(:,:) !factors for inverting US S matrix - type(twin_matrix) :: k_minus1!(:,:) !factors for inverting US preconditioning matrix - ! - real(dp) :: dumm(1) - logical :: newscheme, firstiter - integer :: maxiter3 - ! - type(twin_tensor) :: becdrdiag !modified:giovanni - type(twin_matrix) :: bec0, becm !modified:giovanni - real(kind=DP), allocatable :: ave_ene(:)!average kinetic energy for preconditioning - ! - logical :: pre_state!if .true. does preconditioning state by state - ! - complex(DP) :: esse_c, essenew_c !factors in c.g. - logical :: ltresh!flag for convergence on energy - real(DP) :: passo!step to minimum - real(DP) :: etotnew, etotold!energies - real(DP) :: eoddnew, eoddold!odd energies - real(DP) :: spasso!sign of small step - logical :: restartcg!if .true. restart again the CG algorithm, performing a SD step - integer :: numok!counter on converged iterations - integer :: iter3 - real(DP) :: passof, passov !step to minimum: effective, estimated - real(DP) :: ene0, ene1, dene0, enesti !energy terms for linear minimization along hi - ! - real(DP), allocatable :: faux(:) ! takes into account spin multiplicity - complex(DP), allocatable :: hitmp(:, :) - integer :: ninner, itercgeff - complex(DP) :: Omattot(nbspx, nbspx) - real(DP) :: etot_tmp1, etot_tmp2, tmppasso - ! - logical :: lgam, switch = .false., ortho_switch = .false., okvan, steepest = .false. - integer :: ierr, northo_flavor - real(DP) :: deltae, sic_coeff1, sic_coeff2 !coefficients which may change according to the flavour of SIC - integer :: me, iunit_manifold_overlap, iunit_spreads - real(DP) :: charge - ! - real(dp) :: uPi - real(dp), allocatable :: rho_init(:, :), dvpot(:) - complex(dp), allocatable :: dvpotpsi(:, :) - real(dp) :: exxdiv, mp1 - ! - real(dp), external :: exx_divergence - ! - ! - call do_allocation_initialization() - ! - ! Initializing clock for minimization - ! - call start_clock('runcg_uspp') - - if (tfirst .and. ionode) & - write (stdout, "(/,a,/)") 'PERFORMING CONJUGATE GRADIENT MINIMIZATION OF EL. STATES' - ! - ! set tpa mass preconditioning - ! - call emass_precond_tpa(ema0bg, tpiba2, emass_cutoff) - ! - call prefor(eigr, betae) - ! - ! orthonormalize c0 - ! - call orthogonalize_wfc_only(c0, bec) - ! - ! recompute phi (the augmented wave function) from the new c0 - ! - CALL calphi(c0, SIZE(c0, 1), bec, nhsa, betae, phi, nbsp, lgam) - ! - ! calculates the factors for S and K inversion in US case -- they are important for preconditioning - ! see paper by Hasnip and Pickard, Computer Physics Communications 174 (2006) 24–29 - ! - if (okvan) then - ! - call init_twin(s_minus1, lgam) - call allocate_twin(s_minus1, nhsavb, nhsavb, lgam) - call init_twin(k_minus1, lgam) - call allocate_twin(k_minus1, nhsavb, nhsavb, lgam) - call set_x_minus1_twin(betae, s_minus1, dumm, .false.) - call set_x_minus1_twin(betae, k_minus1, ema0bg, .true.) - ! - else - ! - call init_twin(s_minus1, lgam) - call allocate_twin(s_minus1, 1, 1, lgam) - call init_twin(k_minus1, lgam) - call allocate_twin(k_minus1, 1, 1, lgam) - ! - end if - ! - ! set index on number of converged iterations - ! - numok = 0 - ! - allocate (hpsi(ngw, nbsp)) - allocate (hpsi0(ngw, nbsp)) - allocate (gi(ngw, nbsp), hi(ngw, nbsp)) - ! - allocate (hitmp(ngw, nbsp)) - hitmp(:, :) = CMPLX(0.d0, 0.d0) - ! - gi(:, :) = CMPLX(0.d0, 0.d0) - hi(:, :) = CMPLX(0.d0, 0.d0) - ene_ok = .false. - ! - ! set occupation for the fixed state ... linh - ! - if (fixed_state) then - ! - do i = 1, nbspx - if (i == fixed_band) f(i) = f_cutoff - end do - ! - end if - ! - !======================================================================= - ! begin of the main loop - !======================================================================= - ! - OUTER_LOOP: & - do while (itercg < maxiter .and. (.not. ltresh)) - ! - call start_clock("outer_loop") - ! - ENERGY_CHECK: & - if (.not. ene_ok) then - ! - call calbec(1, nsp, eigr, c0, bec) - ! - call rhoofr(nfi, c0(:, :), irb, eigrb, bec, rhovan, rhor, rhog, rhos, enl, denl, ekin, dekin6) - ! - ! put core charge (if present) in rhoc(r) - ! - if (nlcc_any) call set_cc(irb, eigrb, rhoc) - ! - ! ensemble-DFT - ! - vpot = rhor - ! - CALL start_clock('vofrho1') - ! - call vofrho(nfi, vpot, rhog, rhos, rhoc, tfirst, tlast, & - ei1, ei2, ei3, irb, eigrb, sfac, tau0, fion) - ! - CALL stop_clock('vofrho1') - ! - if (tefield) then - ! - call berry_energy(enb, enbi, bec, c0(:, :), fion) - ! - etot = etot + enb + enbi - ! - end if - ! - if (do_orbdep) then - ! - if (odd_nkscalfact) then - ! - valpsi(:, :) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - call odd_alpha_routine(nbspx, .false.) - ! - end if - ! - fsic = f - ! - call nksic_potential(nbsp, nbspx, c0, fsic, bec, rhovan, deeq_sic, & - ispin, iupdwn, nupdwn, rhor, rhoc, wtot, sizwtot, vsic, do_wxd, pink, nudx, wfc_centers, & - wfc_spreads, icompute_spread, .false.) - ! - eodd = sum(pink(1:nbsp)) - etot = etot + eodd - ! - end if - ! - if (do_hf) then - ! - call hf_potential(nbsp, nbspx, c0, f, ispin, iupdwn, nupdwn, & - nbsp, nbspx, c0, f, ispin, iupdwn, nupdwn, & - rhor, rhog, vxxpsi, exx) - ! - etot = etot + sum(exx(1:nbsp)) - ! - end if - ! - if (finite_field_introduced) then - ! - if (itercg == 1) then - ! - allocate (rho_init(nnr, nspin)) - allocate (dvpotpsi(ngw, 2)) - allocate (dvpot(nnr)) - ! - ! 1) compute dvpot only for the first time - - !call perturbing_pot_nic(fixed_band, ispin(fixed_band), rhor, dvpot) - if (.false.) then ! here for Koopmans - ! - call perturbing_pot(fixed_band, ispin(fixed_band), rhor, dvpot, uPi, lgam, finite_field_for_empty_state) - ! - end if - ! - if (.true.) then ! here for BSE - ! - !call perturbing_pot_bse(fixed_band, fixed_band_1, ispin(fixed_band), ispin(fixed_band_1), rhor, dvpot, uPi,lgam) - ! - end if - ! - ! 2) save rhor to rhor_starting - rho_init(:, :) = rhor(:, :) - ! - end if - ! -#ifdef __TOBE_FIXED - ! compute int dvpot rhor - call compute_effective_energy(dvpot, rhor, eff_finite_field) - ! - etot = etot + eff_finite_field -#endif - ! - end if - ! - etotnew = etot - ! - else - ! - etot = enever - ! - etotnew = etot - ene_ok = .false. - ! - end if ENERGY_CHECK - ! - if (do_orbdep) then - ! - if (do_innerloop .and. innerloop_until >= itercgeff) then - ! - if (nupdwn(1) .le. 1 .and. nupdwn(2) .le. 1) then - ! - ! skip innerloop if there is only zero or one electrons/spin - write (stdout, fmt='(5x,a)') "WARNING: skipping innerloop for 1-electron systems" - ! - else - ! - call do_innerloop_subroutine() - ! - end if - ! - end if - ! - eodd = sum(pink(1:nbsp)) - ! - end if - ! - call print_out_observables() - ! - IF (.not. do_outerloop) THEN - EXIT OUTER_LOOP - END IF - ! - ! here we store the etot in ene0, to keep track of the energy of the initial point - ! - call check_convergence_cg() - ! - call newd(vpot, irb, eigrb, rhovan, fion) - call prefor(eigr, betae)!ATTENZIONE - ! - call compute_hpsi() - ! - if (pre_state) call ave_kin(c0, SIZE(c0, 1), nbsp, ave_ene) - ! - ! HPSI IS ORTHOGONALIZED TO c0 - ! - if (switch .or. (.not. do_orbdep)) then - ! - if (fixed_state) then - ! - hpsi(:, fixed_band) = cmplx(0.d0, 0.d0) - ! - end if - ! - call pcdaga2(c0, phi, hpsi, lgam) - ! - else - ! - if (.not. okvan) then - ! - if (fixed_state) then - ! - call pc3nc_fixed(c0, hpsi, lgam) - ! - end if - ! - call pc3nc(c0, hpsi, lgam) - ! - else - ! - call pc3us(c0, bec, hpsi, becm, lgam) - ! - end if - ! - end if - ! - ! TWO VECTORS INITIALIZED TO HPSI - ! - hpsi0(1:ngw, 1:nbsp) = hpsi(1:ngw, 1:nbsp) - ! - gi(1:ngw, 1:nbsp) = hpsi(1:ngw, 1:nbsp) - ! - ! COMPUTES ULTRASOFT-PRECONDITIONED HPSI, - ! non kinetic-preconditioned, - ! is the subsequent reorthogonalization necessary - ! in the norm conserving case???: giovanni - ! - call calbec(1, nsp, eigr, hpsi, becm) - call xminus1_twin(hpsi, betae, dumm, becm, s_minus1, .false.) - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! look if the following two lines are really needed - ! - call orthogonalize(c0, hpsi, becm, bec) - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! COMPUTES ULTRASOFT+KINETIC-preconditioned GI - ! - IF (do_orbdep) THEN - ! - ! preconditioning with respect to spreads. - ! the gradient along wavefunctions with the largest - ! localization is a bit shortened - ! - !do i=1,nbsp - ! gi(:,i) = gi(:,i)*(1.d0+1.d0/sqrt(wfc_spreads(1+i-iupdwn(ispin(i)),ispin(i),2))) - !enddo - ! - END IF - ! - if (.not. pre_state) then - ! - call xminus1_twin(gi, betae, ema0bg, becm, k_minus1, .true.) - ! - else - ! - ! warning:giovanni not yet implemented - ! - call xminus1_state(gi, betae, ema0bg, becm, k_minus1, .true., ave_ene) - ! - end if - ! - call orthogonalize(c0, gi, becm, bec) - ! - ! calculates gamma - ! - gamma_c = CMPLX(0.d0, 0.d0) - ! - DO i = 1, nbsp - ! - IF (lgam) THEN - ! - do ig = 1, ngw - ! - gamma_c = gamma_c + 2.d0*DBLE(CONJG(gi(ig, i))*hpsi(ig, i)) - ! - end do - ! - if (ng0 .eq. 2) then - ! - gamma_c = gamma_c - DBLE(CONJG(gi(1, i))*hpsi(1, i)) - ! - end if - ! - ELSE - ! - do ig = 1, ngw - ! - gamma_c = gamma_c + CONJG(gi(ig, i))*hpsi(ig, i) - ! - end do - ! - END IF - ! - END DO - ! - call mp_sum(gamma_c, intra_image_comm) - ! - if (nvb .gt. 0) then - ! - if (.not. becm%iscmplx) then - ! - do i = 1, nbsp - ! - do is = 1, nvb - ! - do iv = 1, nh(is) - ! - do jv = 1, nh(is) - ! - do ia = 1, na(is) - ! - inl = ish(is) + (iv - 1)*na(is) + ia - ! - jnl = ish(is) + (jv - 1)*na(is) + ia - ! - gamma_c = gamma_c + qq(iv, jv, is)*becm%rvec(inl, i)*bec0%rvec(jnl, i) - ! - end do - ! - end do - ! - end do - ! - end do - ! - end do - ! - else - ! - do i = 1, nbsp - ! - do is = 1, nvb - ! - do iv = 1, nh(is) - ! - do jv = 1, nh(is) - ! - do ia = 1, na(is) - ! - inl = ish(is) + (iv - 1)*na(is) + ia - ! - jnl = ish(is) + (jv - 1)*na(is) + ia - ! - gamma_c = gamma_c + qq(iv, jv, is)*CONJG(becm%cvec(inl, i))*(bec0%cvec(jnl, i)) - ! - end do - ! - end do - ! - end do - ! - end do - ! - end do - ! - end if - ! - end if - ! - ! case of first iteration - ! - gamma_c = CMPLX(DBLE(gamma_c), 0.d0) - ! - if (steepest) then - ! - ! steepest descent - ! - gamma_c = 0.d0 - ! - end if - ! - if (itercg == 1 .or. mod(itercg, niter_cg_restart) == 0 .or. restartcg) then - ! - restartcg = .false. - ! - ! We do not have to reset passof every exception of CG! - ! warning:giovanni if we do not reset we may have fake convergences!!!! - ! - passof = passop - ! - ! hi is the search direction - ! - hi(1:ngw, 1:nbsp) = gi(1:ngw, 1:nbsp) - ! - esse_c = gamma_c - ! - else - ! - ! find direction hi for general case - ! calculates gamma for general case, not using Polak Ribiere - ! - if (.not. steepest) then - ! - essenew_c = gamma_c - ! - gamma_c = gamma_c/esse_c - ! - esse_c = essenew_c - ! - else - ! - esse_c = 0.d0 - ! - essenew_c = 0.d0 - ! - end if - ! - hi(1:ngw, 1:nbsp) = gi(1:ngw, 1:nbsp) + (gamma_c)*hi(1:ngw, 1:nbsp) - ! - end if - ! - ! note that hi is saved on gi, because we need it before projection on conduction states - ! - ! ... find minimum along direction hi: - ! - ! project hi on conduction sub-space - ! - call orthogonalize(c0, hi, bec0, bec) - ! - ! do quadratic minimization - ! - ! calculate derivative with respect to lambda along direction hi - ! - dene0 = 0.d0 - ! - do i = 1, nbsp - ! - IF (lgam) THEN - ! - do ig = 1, ngw - ! - dene0 = dene0 - 4.d0*DBLE(CONJG(hi(ig, i))*hpsi0(ig, i)) - ! - end do - ! - if (ng0 .eq. 2) then - ! - dene0 = dene0 + 2.d0*DBLE(CONJG(hi(1, i))*hpsi0(1, i)) - ! - end if - ! - ELSE - ! - do ig = 1, ngw - ! - dene0 = dene0 - 2.d0*DBLE(CONJG(hi(ig, i))*hpsi0(ig, i)) - ! - end do - ! - END IF - ! - end do - ! - ! We need the following because n for spin 2 is double that for spin 1! - ! - dene0 = dene0*2.d0/nspin - ! - call mp_sum(dene0, intra_image_comm) - ! - ! if the derivative is positive, search along opposite direction - ! - if (dene0 .gt. 0.d0) then - ! - spasso = -1.D0 - ! - else - ! - spasso = 1.d0 - ! - end if - ! - ! Thank Nicola for providing it. - ! - if (.false.) then - ! - etot_tmp1 = 0.0 - etot_tmp2 = 0.0 - ! - tmppasso = 0.0 - do i = 1, 2 - ! - if (i == 1) tmppasso = 1.d-5 - if (i == 2) tmppasso = -1.d-5 - !tmppasso =tmppasso+0.00001 - ! - cm(:, :) = c0(:, :) + spasso*tmppasso*hi(:, :) - ! - if (lgam .and. ng0 == 2) cm(1, :) = 0.5d0*(cm(1, :) + CONJG(cm(1, :))) - ! - ! orthonormalize - ! - call orthogonalize_wfc_only(cm, becm) - ! - ! **** calculate energy ene1 - ! - call rhoofr(nfi, cm(:, :), irb, eigrb, becm, rhovan, rhor, rhog, rhos, enl, denl, ekin, dekin6) - ! - ! calculate potential - ! - ! put core charge (if present) in rhoc(r) - ! - if (nlcc_any) call set_cc(irb, eigrb, rhoc) - ! - vpot = rhor - ! - CALL vofrho(nfi, vpot, rhog, rhos, rhoc, tfirst, tlast, & - ei1, ei2, ei3, irb, eigrb, sfac, tau0, fion) - ! - if (tefield) then - ! - call berry_energy(enb, enbi, becm, cm(:, :), fion) - ! - etot = etot + enb + enbi - ! - end if - ! - if (do_orbdep) then - ! - if (odd_nkscalfact) then - ! - valpsi(:, :) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - call odd_alpha_routine(nbspx, .false.) - ! - end if - ! - ! warning:giovanni don't we need becm down here??? otherwise - ! problems - ! with ultrasoft!! - ! - call nksic_potential(nbsp, nbspx, cm, fsic, becm, rhovan, deeq_sic, & - ispin, iupdwn, nupdwn, rhor, rhoc, wtot, sizwtot, vsic, do_wxd, pink, nudx, & - wfc_centers, wfc_spreads, & - icompute_spread, .false.) - ! - eodd = sum(pink(1:nbsp)) - ! - etot = etot + eodd - ! - end if - ! - if (do_hf) then - ! - call hf_potential(nbsp, nbspx, cm, f, ispin, iupdwn, nupdwn, & - nbsp, nbspx, cm, f, ispin, iupdwn, nupdwn, & - rhor, rhog, vxxpsi, exx) - ! - etot = etot + sum(exx(1:nbsp)) - ! - end if - ! -#ifdef __TOBE_FIXED - if (finite_field_introduced) then - ! - ! compute int dvpot rhor - call compute_effective_energy(dvpot, rhor, eff_finite_field) - ! - etot = etot + eff_finite_field - ! - end if -#endif - ! - write (stdout, *) "etot: ", i, "=", etot - ! - if (i == 1) etot_tmp1 = etot - if (i == 2) etot_tmp2 = etot - ! - end do - ! - write (stdout, *) "here is numerical derivative vs analytic derivative at step", itercg - write (stdout, *) "(etot_emp_tmp1-etot_emp_tmp2)/tmppasso, dene0, tmppasso, & -& ((etot_emp-etot_emp_tmp2)/(2*tmppasso)/dene0)" - write (stdout, '(2e25.15,4e20.10)') (etot_tmp1 - etot_tmp2)/(2.0*tmppasso), dene0, & - tmppasso, ((etot_tmp1 - etot_tmp2)/(2.0*tmppasso)/dene0) - ! - end if - ! - ! calculates wave-functions on a point on direction hi - ! - cm(1:ngw, 1:nbsp) = c0(1:ngw, 1:nbsp) + spasso*passof*hi(1:ngw, 1:nbsp) - ! - ! - ! I do not know why the following 3 lines - ! were not in the original code (CHP) - ! - if (lgam .and. ng0 == 2) cm(1, :) = 0.5d0*(cm(1, :) + CONJG(cm(1, :))) - ! - ! orthonormalize - ! - call orthogonalize_wfc_only(cm, becm) - ! - ! **** calculate energy ene1 - ! - call rhoofr(nfi, cm(:, :), irb, eigrb, becm, rhovan, rhor, rhog, rhos, enl, denl, ekin, dekin6) - ! - ! calculate potential - ! - ! put core charge (if present) in rhoc(r) - ! - if (nlcc_any) call set_cc(irb, eigrb, rhoc) - ! - vpot = rhor - ! - CALL start_clock('vofrho2') - ! - CALL vofrho(nfi, vpot, rhog, rhos, rhoc, tfirst, tlast, & - ei1, ei2, ei3, irb, eigrb, sfac, tau0, fion) - ! - CALL stop_clock('vofrho2') - ! - if (tefield) then - ! - call berry_energy(enb, enbi, becm, cm(:, :), fion) - ! - etot = etot + enb + enbi - ! - end if - ! - if (do_orbdep) then - ! - if (odd_nkscalfact) then - ! - valpsi(:, :) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - call odd_alpha_routine(nbspx, .false.) - ! - end if - ! - ! warning:giovanni don't we need becm down here??? otherwise problems with ultrasoft!! - ! - call nksic_potential(nbsp, nbspx, cm, fsic, becm, rhovan, deeq_sic, & - ispin, iupdwn, nupdwn, rhor, rhoc, wtot, sizwtot, vsic, do_wxd, pink, nudx, & - wfc_centers, wfc_spreads, & - icompute_spread, .false.) - ! - eodd = sum(pink(1:nbsp)) - ! - etot = etot + eodd - ! - end if - ! - if (do_hf) then - ! - call hf_potential(nbsp, nbspx, cm, f, ispin, iupdwn, nupdwn, & - nbsp, nbspx, cm, f, ispin, iupdwn, nupdwn, & - rhor, rhog, vxxpsi, exx) - ! - etot = etot + sum(exx(1:nbsp)) - ! - end if - ! -#ifdef __TOBE_FIXED - if (finite_field_introduced) then - ! - ! compute int dvpot rhor - call compute_effective_energy(dvpot, rhor, eff_finite_field) - ! - etot = etot + eff_finite_field - ! - end if -#endif - ! - ene1 = etot - ! - ! find the minimum - ! - call minparabola(ene0, spasso*dene0, ene1, passof, passo, enesti) - ! - if (ionode .and. iprsta > 1) write (stdout, "(6f20.12)") ene0, dene0, ene1, passo, DBLE(gamma_c), esse_c - ! - ! set new step - ! - passov = passof - ! - ! doing the following makes the convergence better... - ! - passof = passo - ! - ! calculates wave-functions at minimum - ! - cm(1:ngw, 1:nbsp) = c0(1:ngw, 1:nbsp) + spasso*passo*hi(1:ngw, 1:nbsp) - ! - IF (lgam .and. ng0 == 2) cm(1, :) = 0.5d0*(cm(1, :) + CONJG(cm(1, :))) - ! - call orthogonalize_wfc_only(cm, becm) - ! - call rhoofr(nfi, cm(:, :), irb, eigrb, becm, rhovan, rhor, rhog, rhos, enl, denl, ekin, dekin6) - ! - ! calculates the potential - ! - ! put core charge (if present) in rhoc(r) - ! - if (nlcc_any) call set_cc(irb, eigrb, rhoc) - ! - vpot = rhor - ! - CALL start_clock('vofrho3') - ! - call vofrho(nfi, vpot, rhog, rhos, rhoc, tfirst, tlast, & - ei1, ei2, ei3, irb, eigrb, sfac, tau0, fion) - ! - CALL stop_clock('vofrho3') - ! - if (tefield) then - ! - call berry_energy(enb, enbi, becm, cm(:, :), fion) - ! - etot = etot + enb + enbi - ! - end if - ! - if (do_orbdep) then - ! - if (odd_nkscalfact) then - ! - valpsi(:, :) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - call odd_alpha_routine(nbspx, .false.) - ! - end if - ! - ! warning:giovanni... don't we need becm down here?? otherwise problem with ultrasoft!! - ! - call nksic_potential(nbsp, nbspx, cm, fsic, becm, rhovan, deeq_sic, & - ispin, iupdwn, nupdwn, rhor, rhoc, wtot, sizwtot, vsic, do_wxd, pink, nudx, & - wfc_centers, wfc_spreads, & - icompute_spread, .false.) - eodd = sum(pink(1:nbsp)) - etot = etot + eodd - ! - end if - ! - if (do_hf) then - ! - call hf_potential(nbsp, nbspx, cm, f, ispin, iupdwn, nupdwn, & - nbsp, nbspx, cm, f, ispin, iupdwn, nupdwn, & - rhor, rhog, vxxpsi, exx) - ! - etot = etot + sum(exx(1:nbsp)) - ! - end if - ! -#ifdef __TOBE_FIXED - if (finite_field_introduced) then - ! - ! compute int dvpot rhor - call compute_effective_energy(dvpot, rhor, eff_finite_field) - ! - write (stdout, *) "eff_finite_field", eff_finite_field - etot = etot + eff_finite_field - ! - end if -#endif - ! - enever = etot - ! - ! check with what supposed - ! -#ifdef DEBUG - write (stdout, *) 'ene0, dene0, ene1, enesti,enever, passo, passov, passof' - write (stdout, "(8f18.12)") ene0, dene0, ene1, enesti, enever, passo, passov, passof -#endif - - if (ionode .and. iprsta > 1) then - write (stdout, "(2x,a,f20.12)") 'cg_sub: estimate :', (enesti - enever)/(ene0 - enever) - write (stdout, "(2x,a,3f20.12)") 'cg_sub: minmum :', enever, passo, passov - end if - ! - ! if the energy has diminished with respect to ene0 and ene1 , everything ok - ! - if (((enever .lt. ene0) .and. (enever .lt. ene1)) .or. (tefield .or. tefield2)) then - ! - c0(:, :) = cm(:, :) - call copy_twin(bec, becm) !modified:giovanni - ene_ok = .true. - ! - ! if ene1 << energy < ene0; go to ene1 - ! - elseif ((enever .ge. ene1) .and. (enever .lt. ene0)) then - ! - if (ionode) then - ! - write (stdout, "(5x,a,i5,f20.12)") 'WARNING cg_sub: missed minimum, case 1, iteration', itercg, passof - ! - end if - ! - c0(1:ngw, 1:nbsp) = c0(1:ngw, 1:nbsp) + spasso*passov*hi(1:ngw, 1:nbsp) - ! - passof = 2.d0*passov - ! - restartcg = .true. - ! - call orthogonalize_wfc_only(c0, bec) - ! - ene_ok = .false. - ! - ! if ene1 << ene0 <= energy; go to ene1 - ! - elseif ((enever .ge. ene0) .and. (ene0 .gt. ene1)) then - ! - if (ionode) then - write (stdout, "(5x,a,i5)") 'WARNING cg_sub: missed minimum, case 2, iteration', itercg - end if - ! - c0(1:ngw, 1:nbsp) = c0(1:ngw, 1:nbsp) + spasso*passov*hi(1:ngw, 1:nbsp) - ! - passof = 1.d0*passov - ! - restartcg = .true.!ATTENZIONE - ! - call orthogonalize_wfc_only(c0, bec) - ! - ! if ene > ene0, en1 do a steepest descent step - ! - ene_ok = .false. - ! - elseif ((enever .ge. ene0) .and. (ene0 .le. ene1)) then - ! - if (ionode) then - write (stdout, "(5x,a,i5)") 'WARNING cg_sub: missed minimum, case 3, iteration', itercg - end if - ! - iter3 = 0 - ! - do while (enever .ge. ene0 .and. iter3 .lt. maxiter3) - ! - iter3 = iter3 + 1 - ! - passov = passov*0.5d0 - ! - cm(1:ngw, 1:nbsp) = c0(1:ngw, 1:nbsp) + spasso*passov*hi(1:ngw, 1:nbsp) - ! - passof = 1.d0*passov - ! - itercgeff = itercgeff + 1 - ! - ! change the searching direction - ! - spasso = spasso*(-1.d0) - ! - call orthogonalize_wfc_only(cm, becm) - ! - call rhoofr(nfi, cm(:, :), irb, eigrb, becm, rhovan, rhor, rhog, rhos, enl, denl, ekin, dekin6) - ! - ! calculates the potential - ! - ! put core charge (if present) in rhoc(r) - ! - if (nlcc_any) call set_cc(irb, eigrb, rhoc) - ! - vpot = rhor - ! - CALL start_clock('vofrho4') - ! - call vofrho(nfi, vpot, rhog, rhos, rhoc, tfirst, tlast, & - ei1, ei2, ei3, irb, eigrb, sfac, tau0, fion) - ! - CALL stop_clock('vofrho4') - ! - if (tefield) then!to be bettered - ! - call berry_energy(enb, enbi, becm, cm(:, :), fion) - ! - etot = etot + enb + enbi - ! - end if - ! - if (do_orbdep) then - ! - if (odd_nkscalfact) then - ! - valpsi(:, :) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - call odd_alpha_routine(nbspx, .false.) - ! - end if - ! - ! warning:giovanni don't we need becm down here??? otherwise problems with ultrasoft - ! - call nksic_potential(nbsp, nbspx, cm, fsic, becm, rhovan, deeq_sic, & - ispin, iupdwn, nupdwn, rhor, rhoc, wtot, sizwtot, vsic, do_wxd, pink, nudx, & - wfc_centers, wfc_spreads, & - icompute_spread, .false.) - ! - eodd = sum(pink(1:nbsp)) - ! - etot = etot + eodd - ! - end if - ! - if (do_hf) then - ! - call hf_potential(nbsp, nbspx, cm, f, ispin, iupdwn, nupdwn, & - nbsp, nbspx, cm, f, ispin, iupdwn, nupdwn, & - rhor, rhog, vxxpsi, exx) - ! - etot = etot + sum(exx(1:nbsp)) - ! - end if - ! -#ifdef __TOBE_FIXED - if (finite_field_introduced) then - ! - ! compute int dvpot rhor - call compute_effective_energy(dvpot, rhor, eff_finite_field) - ! - etot = etot + eff_finite_field - ! - end if -#endif - ! - enever = etot - ! - write (stdout, *) iter3, spasso*passov, enever - ! - end do - ! - if (ionode) write (stdout, "(7x,a,i5)") 'iter3 = ', iter3 - ! - if (iter3 == maxiter3 .and. enever .gt. ene0) then - ! - write (stdout, "(7x,a)") 'WARNING missed minimum: iter3 = maxiter3' - write (stdout, '(7x, "enever, ene0", 2F20.15)') enever, ene0 - ! - elseif (enever .le. ene0) then - ! - c0(:, :) = cm(:, :) - ! - call copy_twin(bec, becm) - ! - end if - ! - restartcg = .true. - ene_ok = .false. - ! - if (iter3 == maxiter3) then - passof = passop - end if - ! - end if - ! - if (.not. ene_ok) call calbec(1, nsp, eigr, c0, bec) - ! - ! calculates phi for pc_daga - ! - CALL calphi(c0, SIZE(c0, 1), bec, nhsa, betae, phi, nbsp, lgam) - ! - !======================================================================= - ! end of the outer loop - !======================================================================= - ! - itercg = itercg + 1 - ! - itercgeff = itercgeff + 1 - ! - call stop_clock("outer_loop") - ! - end do OUTER_LOOP - ! -#ifdef __DEBUG - ! for debug and tuning purposes - if (ionode) write (37, *) itercg, itercgeff, etotnew - if (ionode) write (1037, '("iteration =",I4," eff iteration =",I4," Etot (Ha) =",F22.14)') & - itercg, itercgeff, etotnew -#endif - ! - ! Computes the leading term of the Makov-Payne corrective energy - ! E = q^2 * madelung_const / ( 2 * L ) - ! - IF (fixed_state) THEN - ! - WRITE (stdout, '(//,A)') " -----------------------" - WRITE (stdout, '(A)') " MAKOV-PAYNE CORRECTIONS" - WRITE (stdout, '(A)') " -----------------------" - exxdiv = exx_divergence() - ! - ! Determining the system charge - charge = 0 - DO iat = 1, nat - charge = charge + zv(ityp(iat)) - END DO - charge = charge - nbsp + 1 - f_cutoff - ! - mp1 = -exxdiv/omega*charge**2/2 - mp1 = mp1/e2 ! Ry to Ha conversion - WRITE (stdout, '(/,2X,A,ES20.8)') " Makov-Payne 1-order energy : ", mp1 - ! - END IF - ! - ! OBSOLETE: old version for calculating correction for charged systems - ! using Makov-Payne corrections (simple cubic systems only!) - !IF (fixed_state .and. do_orbdep) THEN - ! ! - ! write(stdout, *) "NLN: This is 2nd term in MP formular, computed with localized orbital" - ! write(stdout, *) "NLN: Use for extended system only where tcc does not have the correction" - ! ! - ! charge = 1.0_dp - ! ! - ! call makov_payne_correction_2nd_term ( charge, wfc_spreads(fixed_band, 1, 1)) - ! ! - !ENDIF - ! - !======================================================================= - ! end of the main loop - !======================================================================= - ! - ! calculates atomic forces and lambda matrix elements - ! - ! if pressure is need the following is written because of caldbec - ! - if (tpre) then - ! - call calbec(1, nsp, eigr, c0, bec) - ! - call caldbec(ngw, nhsa, nbsp, 1, nsp, eigr, c0, dbec) - call rhoofr(nfi, c0(:, :), irb, eigrb, bec, rhovan, rhor, rhog, rhos, enl, denl, ekin, dekin6) - ! - !calculates the potential - ! - ! put core charge (if present) in rhoc(r) - ! - if (nlcc_any) call set_cc(irb, eigrb, rhoc) - ! - !---ensemble-DFT - ! - vpot = rhor - ! - CALL start_clock('vofrho5') - ! - call vofrho(nfi, vpot, rhog, rhos, rhoc, tfirst, tlast, & - ei1, ei2, ei3, irb, eigrb, sfac, tau0, fion) - ! - CALL stop_clock('vofrho5') - ! - if (do_orbdep) then - ! - if (odd_nkscalfact) then - ! - valpsi(:, :) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - call odd_alpha_routine(nbspx, .false.) - ! - end if - ! - call nksic_potential(nbsp, nbspx, c0, fsic, bec, rhovan, deeq_sic, & - ispin, iupdwn, nupdwn, rhor, rhoc, wtot, sizwtot, vsic, do_wxd, pink, nudx, & - wfc_centers, wfc_spreads, & - icompute_spread, .false.) - ! - eodd = sum(pink(1:nbsp)) - etot = etot + eodd - ! - end if - ! - if (do_hf) then - ! - call hf_potential(nbsp, nbspx, c0, f, ispin, iupdwn, nupdwn, & - nbsp, nbspx, c0, f, ispin, iupdwn, nupdwn, & - rhor, rhog, vxxpsi, exx) - ! - etot = etot + sum(exx(1:nbsp)) - ! - end if - ! -#ifdef __TOBE_FIXED - if (finite_field_introduced) then - ! - ! compute int dvpot rhor - call compute_effective_energy(dvpot, rhor, eff_finite_field) - ! - etot = etot + eff_finite_field - ! - end if -#endif - ! - end if - ! -#ifdef __TOBE_FIXED - if (finite_field_introduced) then - ! - ! 1) compute drho = rho_final - rho_init - ! 2) compute rPi = int{ dvpot * drho()} - ! 3) compute alpha_i = 1 + rPi/uPi - ! - rho_init(:, :) = rhor(:, :) - rho_init(:, :) - ! - call compute_effective_energy(dvpot, rho_init, rPi) - ! - WRITE (stdout, *) "Here is uPi", uPi - WRITE (stdout, *) "Here is rPi", rPi - WRITE (stdout, *) "Here is 1+rPi/uPi", 1 + rPi/uPi - ! - deallocate (rho_init) - ! - end if -#endif - ! - call newd(vpot, irb, eigrb, rhovan, fion) - ! - if (tfor .or. tprnfor) call nlfq(c0, eigr, bec, becdr, fion, lgam) - ! - call prefor(eigr, betae) - ! - ! faux takes into account spin multiplicity. - ! - faux(1:nbsp) = max(f_cutoff, f(1:nbsp))*DBLE(nspin)/2.0d0 - ! - ! This condition to ensure that the orbital(fixed_band) is frozen - ! - IF (fixed_state) THEN - faux(fixed_band) = f_cutoff - END IF - ! - IF (do_bare_eigs) THEN - ! - allocate (c2_bare(ngw), c3_bare(ngw)) - allocate (gi_bare(ngw, nbsp)) - c2_bare = 0.d0 - c3_bare = 0.d0 - gi_bare = 0.d0 - ! - END IF - ! - do i = 1, nbsp, 2 -!$$ - CALL start_clock('dforce2') - ! - call dforce(i, bec, betae, c0, c2, c3, rhos, nnrsx, ispin, faux, nbsp, nspin) - ! - CALL start_clock('dforce2') -!$$ - IF (do_bare_eigs) THEN - ! - c2_bare(:) = c2(:) - c3_bare(:) = c3(:) - ! - END IF -!$$ - if (tefield .and. (evalue .ne. 0.d0)) then - ! - call dforceb & - (c0, i, betae, ipolp, bec, ctabin(1, 1, ipolp), gqq, gqqm, qmat, deeq, df) - ! - c2(:) = c2(:) + evalue*df(:) - ! - call dforceb & - (c0, i + 1, betae, ipolp, bec, ctabin(1, 1, ipolp), gqq, gqqm, qmat, deeq, df) - ! - c3(:) = c3(:) + evalue*df(:) - ! - end if - - if (do_orbdep) then - ! - IF (odd_nkscalfact) THEN - ! - c2(:) = c2(:) - valpsi(i, :)*faux(i) - ! - if (i + 1 <= nbsp) c3(:) = c3(:) - valpsi(i + 1, :)*faux(i + 1) - ! - END IF - ! - ! faux takes into account spin multiplicity. - ! - CALL nksic_eforce(i, nbsp, nbspx, vsic, deeq_sic, bec, ngw, c0(:, i), c0(:, i + 1), vsicpsi, lgam) - ! - ! - c2(:) = c2(:) - vsicpsi(:, 1)*faux(i) - ! - if (i + 1 <= nbsp) c3(:) = c3(:) - vsicpsi(:, 2)*faux(i + 1) - ! - end if -!$$ - IF (lda_plus_u) THEN - ! - c2(:) = c2(:) - vupsi(:, i)*faux(i) - if (i + 1 <= nbsp) c3(:) = c3(:) - vupsi(:, i + 1)*faux(i + 1) - ! - END IF - - if (do_hf) then - ! - c2(:) = c2(:) - vxxpsi(:, i)*faux(i) - ! - if (i + 1 <= nbsp) c3(:) = c3(:) - vxxpsi(:, i + 1)*faux(i + 1) - ! - end if -!$$ -#ifdef __TOBE_FIXED - if (finite_field_introduced) then - ! - ! faux takes into account spin multiplicity. - ! - CALL finite_field_force(i, nbsp, nbspx, dvpot, ngw, c0(:, i), c0(:, i + 1), dvpotpsi, lgam) - ! - c2(:) = c2(:) + dvpotpsi(:, 1)*faux(i) - ! - if (i + 1 <= nbsp) c3(:) = c3(:) + dvpotpsi(:, 2)*faux(i + 1) - ! - end if -#endif - ! - do ig = 1, ngw - gi(ig, i) = c2(ig) - if (i + 1 <= nbsp) gi(ig, i + 1) = c3(ig) - end do - ! - if (lgam .and. ng0 .eq. 2) then - gi(1, i) = CMPLX(DBLE(gi(1, i)), 0.d0) - if (i + 1 <= nbsp) gi(1, i + 1) = CMPLX(DBLE(gi(1, i + 1)), 0.d0) - end if - - IF (do_bare_eigs) THEN - ! - do ig = 1, ngw - gi_bare(ig, i) = c2_bare(ig) - if (i + 1 <= nbsp) gi_bare(ig, i + 1) = c3_bare(ig) - end do - ! - if (lgam .and. ng0 .eq. 2) then - gi_bare(1, i) = CMPLX(DBLE(gi_bare(1, i)), 0.d0) - if (i + 1 <= nbsp) gi_bare(1, i + 1) = CMPLX(DBLE(gi_bare(1, i + 1)), 0.d0) - end if - ! - END IF - ! - end do - ! - CALL compute_lambda(c0, gi, lambda, nspin, nbsp, ngw, nudx, descla, nupdwn, iupdwn) - IF (do_bare_eigs) CALL compute_lambda(c0, gi_bare, lambda_bare, nspin, nbsp, ngw, nudx, descla, nupdwn, iupdwn) - ! - call nlfl_twin(bec, becdr, lambda, fion, lgam) - ! - ! bforceion adds the force term due to electronic berry phase - ! only in US-case - ! - if (tefield .and. (evalue .ne. 0.d0)) then - call bforceion(fion, tfor .or. tprnfor, ipolp, qmat, bec, becdr, gqq, evalue) - end if - ! - call do_deallocation() - ! - return - ! -contains - - subroutine do_allocation_initialization() - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! INITIALIZATION PART (variables, allocation of arrays, minimization parameters) - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - !!! Initialize some basic variables - ! - me = me_image + 1 - lgam = gamma_only .and. .not. do_wf_cmplx - okvan = (nvb > 0) - ! - deltae = 2.d0*conv_thr - etotnew = 0.d0 - etotold = 0.d0 - eoddnew = 0.d0 - eoddold = 0.d0 - ! - !!! Initialize printing - ! - IF (ionode) THEN - ! - iunit_spreads = printout_base_unit("sha") - CALL printout_base_open("sha") - WRITE (iunit_spreads, *) " " - iunit_manifold_overlap = printout_base_unit("ovp") - CALL printout_base_open("ovp") - WRITE (iunit_manifold_overlap, *) " " - ! - END IF - ! - northo_flavor = 1 - ! - IF (northo_flavor == 2) THEN - ! - sic_coeff1 = 1.d0 - sic_coeff2 = 1.d0 - ! - ELSE - ! - sic_coeff1 = 0.5d0 - sic_coeff2 = 0.5d0 - ! - END IF - ! - if (innerloop_until < 0) then - ! - innerloop_until = 2*maxiter - ! - end if - ! - allocate (faux(nbspx)) - ! - allocate (ave_ene(nbsp)) - allocate (c2(ngw), c3(ngw)) - ! - ! Allocation of twin-type variables - ! - call init_twin(bec0, lgam) - call allocate_twin(bec0, nhsa, nbsp, lgam) - - call init_twin(becm, lgam) - call allocate_twin(becm, nhsa, nbsp, lgam) - - call init_twin(becdrdiag, lgam) - call allocate_twin(becdrdiag, nhsa, nspin*nlax, 3, lgam) - - ! - ! initializing variables for checking iterations and convergence - ! - - newscheme = .false. - firstiter = .true. - - pre_state = .false.!normally is disabled - - maxiter3 = 12 - !$$ - if (do_orbdep) maxiter3 = 5 - !$$ - ninner = 0 - - ltresh = .false. - itercg = 1 - etotold = 1.d8 - eoddold = 1.d8 - restartcg = .true. - passof = passop - ene_ok = .false. - !$$ - itercgeff = 1 - !$$ - - end subroutine do_allocation_initialization - - subroutine do_deallocation() - - deallocate (hpsi0, hpsi, gi, hi) - deallocate (hitmp, STAT=ierr) - ! - call deallocate_twin(s_minus1) - call deallocate_twin(k_minus1) -#ifdef __DEBUG - ! - !for debug and tuning purposes - ! - if (ionode) close (37) - if (ionode) close (1037) -#endif - call stop_clock('runcg_uspp') - - ! deallocate(bec0,becm,becdrdiag) - - !begin_modified:giovanni - call deallocate_twin(bec0) - call deallocate_twin(becm) - call deallocate_twin(becdrdiag) - ! - ! do i=1,nspin - ! call deallocate_twin(lambda(i)) - ! call deallocate_twin(lambdap(i)) - ! enddo - ! - !end_modified:giovanni - - deallocate (ave_ene) - deallocate (c2, c3) - IF (allocated(c2_bare)) deallocate (c2_bare) - IF (allocated(c3_bare)) deallocate (c3_bare) - IF (allocated(gi_bare)) deallocate (gi_bare) - ! - IF (ionode) THEN - ! - CALL printout_base_close("sha") - CALL printout_base_close("ovp") - ! - END IF - ! - if (finite_field_introduced) deallocate (dvpot, dvpotpsi) - ! - end subroutine do_deallocation - - subroutine do_innerloop_subroutine() - ! - call start_clock("inner_loop") - ! - eodd = sum(pink(1:nbsp)) - etot = etot - eodd - etotnew = etotnew - eodd - ninner = 0 - ! - if (.not. do_innerloop_cg) then - ! - call nksic_rot_emin(itercg, ninner, etot, Omattot, lgam) - ! - else - ! - !call nksic_rot_emin_cg(itercg,innerloop_init_n,ninner,etot,Omattot,deltae*innerloop_cg_ratio,lgam) - call nksic_rot_emin_cg_general(itercg, innerloop_init_n, ninner, etot, deltae*innerloop_cg_ratio, lgam, & - nbsp, nbspx, nudx, iupdwn, nupdwn, ispin, c0, rhovan, bec, rhor, rhoc, & - vsic, pink, deeq_sic, wtot, fsic, sizwtot, do_wxd, wfc_centers, wfc_spreads, .false.) - ! - end if - ! - eodd = sum(pink(1:nbsp)) - etot = etot + eodd - etotnew = etotnew + eodd - eoddnew = eodd - ! - call stop_clock("inner_loop") - ! - end subroutine do_innerloop_subroutine - - subroutine print_out_observables() - -#ifdef __DEBUG - ! for debug and tuning purposes - if (ionode) write (37, *) itercg, itercgeff, etotnew - if (ionode) write (1037, '("iteration =",I4," eff iteration =",I4," Etot (Ha) =",F22.14)') & - itercg, itercgeff, etotnew -#endif -! tcpu_cg_here=get_clock('nk_corr') - call print_clock('CP') -! # - if (ionode) then - if (itercg > 2) then - write (stdout, '(5x,"iteration =",I4," eff iteration =",I4," Etot (Ha) =",F22.14," delta_E=",E22.14)') & - itercg, itercgeff, etotnew, deltae - else - write (stdout, '(5x,"iteration =",I4," eff iteration =",I4," Etot (Ha) =",F22.14)') & - itercg, itercgeff, etotnew - end if - ! - end if - ! - - if (ionode .and. mod(itercg, 10) == 0) write (stdout, "()") - - IF (iprint_spreads > 0) THEN - ! - IF (ionode .and. mod(itercg, iprint_spreads) == 0) THEN - ! - IF (nspin == 1) THEN - ! - WRITE (iunit_spreads, '(400f20.14)') wfc_spreads(:, 1, 2) - ! - ELSE IF (nspin == 2) THEN - ! - WRITE (iunit_spreads, '(2(400f20.14)(3x))') wfc_spreads(:, 1, 2), wfc_spreads(:, 2, 2) - ! - END IF - ! - END IF - ! - END IF - - IF (iprint_manifold_overlap > 0) THEN - ! - IF (mod(itercg, iprint_manifold_overlap) == 0) THEN - ! - CALL compute_manifold_overlap(cstart, c0, becstart, bec, ngwx, nbspx, manifold_overlap) !added:giovanni - ! - IF (ionode) THEN - ! - IF (nspin == 1) THEN - ! - WRITE (iunit_manifold_overlap, '(2f20.14)') manifold_overlap(1) - ! - ELSE IF (nspin == 2) THEN - ! - WRITE (iunit_manifold_overlap, '(2(2f20.14)(3x))') manifold_overlap(1), manifold_overlap(2) - ! - END IF - ! - END IF - ! - END IF - ! - END IF -!$$ - - end subroutine print_out_observables - - subroutine check_convergence_cg() - ! - deltae = abs(etotnew - etotold) - ! - if (do_orbdep) then - deltae = deltae + abs(eoddnew - eoddold) - end if - ! - if (deltae < conv_thr) then - numok = numok + 1 - else - numok = 0 - end if - ! - if (numok >= 4) ltresh = .true. - ! - if (ltresh .or. itercg == maxiter - 1) icompute_spread = .true. - ! - etotold = etotnew - eoddold = eoddnew - ene0 = etot - ! - end subroutine check_convergence_cg - - subroutine compute_hpsi() - ! - ! faux takes into account spin multiplicity. - ! - faux(1:nbspx) = 0.d0 - faux(1:nbsp) = max(f_cutoff, f(1:nbsp))*DBLE(nspin)/2.0d0 - ! - ! - ! This condition to ensure that the orbital(fixed_band) is frozen - ! - IF (fixed_state) THEN - faux(fixed_band) = f_cutoff - END IF - ! - do i = 1, nbsp, 2 - ! - ! FIRST CALL TO DFORCE - ! - CALL start_clock('dforce1') - ! - CALL dforce(i, bec, betae, c0, c2, c3, rhos, nnrsx, ispin, faux, nbsp, nspin) - ! - CALL stop_clock('dforce1') - ! - ! COMPUTE DFORCE FROM BERRY PHASE - ! - if (tefield .and. (evalue .ne. 0.d0)) then - ! - call dforceb(c0, i, betae, ipolp, bec, ctabin(1, 1, ipolp), gqq, gqqm, qmat, deeq, df) - ! - c2(:) = c2(:) + evalue*df(:) - ! - call dforceb(c0, i + 1, betae, ipolp, bec, ctabin(1, 1, ipolp), gqq, gqqm, qmat, deeq, df) - ! - c3(:) = c3(:) + evalue*df(:) - ! - end if - - IF (lda_plus_u) THEN - ! - ! - c2(:) = c2(:) - vupsi(:, i)*faux(i) - if (i + 1 <= nbsp) c3(:) = c3(:) - vupsi(:, i + 1)*faux(i + 1) - ! - ! - END IF - -!$$ - if (do_orbdep) then - ! - IF (odd_nkscalfact) THEN - ! - c2(:) = c2(:) - valpsi(i, :)*faux(i) - ! - if (i + 1 <= nbsp) c3(:) = c3(:) - valpsi(i + 1, :)*faux(i + 1) - ! - END IF - ! - ! faux takes into account spin multiplicity. - ! - CALL nksic_eforce(i, nbsp, nbspx, vsic, deeq_sic, bec, ngw, c0(:, i), c0(:, i + 1), vsicpsi, lgam) - ! - ! - c2(:) = c2(:) - vsicpsi(:, 1)*faux(i) - ! - if (i + 1 <= nbsp) c3(:) = c3(:) - vsicpsi(:, 2)*faux(i + 1) - ! - - ! - end if -!$$ - if (do_hf) then - ! - c2(:) = c2(:) - vxxpsi(:, i)*faux(i) - ! - if (i + 1 <= nbsp) c3(:) = c3(:) - vxxpsi(:, i + 1)*faux(i + 1) - ! - end if -!$$ - -#ifdef __TOBE_FIXED - if (finite_field_introduced) then - ! - ! faux takes into account spin multiplicity. - ! - CALL finite_field_force(i, nbsp, nbspx, dvpot, ngw, c0(:, i), c0(:, i + 1), dvpotpsi, lgam) - ! - c2(:) = c2(:) - dvpotpsi(:, 1)*faux(i) - ! - if (i + 1 <= nbsp) c3(:) = c3(:) - dvpotpsi(:, 2)*faux(i + 1) - ! - end if -#endif - - hpsi(1:ngw, i) = c2(1:ngw) - if (i + 1 <= nbsp) then - hpsi(1:ngw, i + 1) = c3(1:ngw) - end if - ! - IF (lgam) THEN - if (ng0 .eq. 2) then - hpsi(1, i) = CMPLX(DBLE(hpsi(1, i)), 0.d0) - if (i + 1 <= nbsp) then - hpsi(1, i + 1) = CMPLX(DBLE(hpsi(1, i + 1)), 0.d0) - end if - end if - END IF - ! - end do - - end subroutine compute_hpsi - - subroutine orthogonalize(wfc0, wfc, becwfc, bec0) - ! - type(twin_matrix) :: becwfc, bec0 - complex(DP) :: wfc(:, :), wfc0(:, :) - ! - if (switch .or. (.not. do_orbdep)) then - ! - if (fixed_state) then - ! - wfc(:, fixed_band) = cmplx(0.d0, 0.d0) - ! - end if - ! - call calbec(1, nsp, eigr, wfc, becwfc) - ! - call pc2(wfc0, bec0, wfc, becwfc, lgam) - ! - else - ! - if (fixed_state) then - ! - call pc3nc_fixed(wfc0, wfc, lgam) - ! - end if - ! - call calbec(1, nsp, eigr, wfc, becwfc) - ! - if (.not. okvan) then - ! - call pc3nc(wfc0, wfc, lgam) - ! - else - ! - call pc3us(wfc0, bec0, wfc, becwfc, lgam) - ! - end if - ! - end if - ! - end subroutine orthogonalize - ! - subroutine orthogonalize_wfc_only(wfc, becwfc) - ! - type(twin_matrix) :: becwfc - complex(DP) :: wfc(:, :) - complex(DP) :: s(nbspx, nbspx) - integer :: nbnd1, nbnd2, ndim, i, j, isp - ! - call calbec(1, nsp, eigr, wfc, becwfc) - ! - IF (do_orbdep .and. ortho_switch) THEN - ! - if (.not. okvan) then - ! - call lowdin(wfc, lgam) - ! - else - ! - call lowdin_uspp(wfc, becwfc, lgam) - ! - end if - ! - ELSE - ! - if (fixed_state) then - ! - call gram_swap(betae, becwfc, nhsa, wfc, ngw, nbsp, fixed_band) - ! - else - ! - call gram(betae, becwfc, nhsa, wfc, ngw, nbsp) - ! - end if - ! - END IF - ! - call calbec(1, nsp, eigr, wfc, becwfc) - ! - s(:, :) = CMPLX(0.d0, 0.d0) - ! - DO isp = 1, nspin - ndim = nupdwn(isp) - DO i = 1, ndim - ! - nbnd1 = iupdwn(isp) - 1 + i - ! - DO j = 1, i - ! - nbnd2 = iupdwn(isp) - 1 + j - ! - call dotcsv(s(j, i), nbspx, nbsp, wfc, becwfc, wfc, becwfc, ngw, iupdwn(isp) + j - 1, iupdwn(isp) + i - 1, lgam) - s(i, j) = CONJG(s(j, i)) - ! - END DO - ! - END DO - END DO - ! - end subroutine orthogonalize_wfc_only - ! - subroutine makov_payne_correction_2nd_term(charge, quadrupole) - ! - real(DP) :: charge, quadrupole - real(DP) :: corr2, corr1 - ! - ! 1 / 2 Ry -> a.u. - corr1 = -2.8373D0/alat*charge**2/2.0D0 - ! - corr2 = (2.D0/3.D0*pi)*(charge*quadrupole)/omega - ! - write (stdout, *) "Test MP:", charge, omega, quadrupole - write (stdout, *) "Makov-Payne 1st energy ", corr1 - write (stdout, *) "Makov-Payne 2nd energy ", corr2 - ! - return - ! - end subroutine makov_payne_correction_2nd_term - ! -END SUBROUTINE runcg_uspp diff --git a/quantum_espresso/kcp/CPV/cglib.f90 b/quantum_espresso/kcp/CPV/cglib.f90 deleted file mode 100644 index b3cf2008c..000000000 --- a/quantum_espresso/kcp/CPV/cglib.f90 +++ /dev/null @@ -1,3380 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - -!----------------------------------------------------------------------- - subroutine calcmt( fdiag, zmat, fmat, firstiter) -!----------------------------------------------------------------------- -! -! constructs fmat=z0^t.fdiag.z0 zmat = z0^t -! - USE kinds, ONLY: DP - use electrons_base, ONLY: nudx, nspin, nupdwn, iupdwn, nx => nbspx - USE cp_main_variables, ONLY: descla, nrlx - USE descriptors, ONLY: la_npc_ , la_npr_ , la_comm_ , la_me_ , la_nrl_ , & - lambda_node_ , ldim_cyclic - USE mp, ONLY: mp_sum, mp_bcast - - implicit none - logical firstiter - - real(DP) :: zmat( nrlx, nudx, nspin ), fmat( nrlx, nudx, nspin ), fdiag( nx ) - ! NOTE: zmat and fmat are distributed by row across processors - ! fdiag is replicated - - integer :: iss, nss, istart, i, j, k, ii - integer :: np_rot, me_rot, nrl, comm_rot, ip, nrl_ip - - real(DP), ALLOCATABLE :: mtmp(:,:) - real(DP) :: f_z0t - - - call start_clock('calcmt') - - fmat = 0.0d0 - - DO iss = 1, nspin - - nss = nupdwn( iss ) - istart = iupdwn( iss ) - np_rot = descla( la_npr_ , iss ) * descla( la_npc_ , iss ) - me_rot = descla( la_me_ , iss ) - nrl = descla( la_nrl_ , iss ) - comm_rot = descla( la_comm_ , iss ) - - IF( descla( lambda_node_ , iss ) > 0 ) THEN - - ALLOCATE( mtmp( nrlx, nudx ) ) - - DO ip = 1, np_rot - - IF( me_rot == ( ip - 1 ) ) THEN - mtmp = zmat(:,:,iss) - END IF - nrl_ip = ldim_cyclic( nss, np_rot, ip - 1 ) - CALL mp_bcast( mtmp , ip - 1 , comm_rot ) - - DO j = 1, nss - ii = ip - DO i = 1, nrl_ip - f_z0t = fdiag( j + istart - 1 ) * mtmp( i, j ) - DO k = 1, nrl - fmat( k, ii, iss ) = fmat( k, ii, iss )+ zmat( k, j, iss ) * f_z0t - END DO - ii = ii + np_rot - END DO - END DO - - END DO - - DEALLOCATE( mtmp ) - - END IF - - END DO - - call stop_clock('calcmt') - - RETURN - END SUBROUTINE calcmt - -!----------------------------------------------------------------------- - subroutine calcmt_twin( fdiag, zmat, fmat, firstiter) -!----------------------------------------------------------------------- -! -! constructs fmat=z0^t.fdiag.z0 zmat = z0^t -! - USE kinds, ONLY: DP - use electrons_base, ONLY: nudx, nspin, nupdwn, iupdwn, nx => nbspx - USE cp_main_variables, ONLY: descla, nrlx - USE descriptors, ONLY: la_npc_ , la_npr_ , la_comm_ , la_me_ , la_nrl_ , & - lambda_node_ , ldim_cyclic - USE mp, ONLY: mp_sum, mp_bcast - USE twin_types - - implicit none - logical firstiter - - real(DP) :: fdiag( nx ) - ! NOTE: zmat and fmat are distributed by row across processors - ! fdiag is replicated - type(twin_matrix) :: zmat(:), fmat(:) - - integer :: iss, nss, istart, i, j, k, ii - integer :: np_rot, me_rot, nrl, comm_rot, ip, nrl_ip - - real(DP), ALLOCATABLE :: mtmp(:,:) - complex(DP), ALLOCATABLE :: mtmp_c(:,:) - real(DP) :: f_z0t - complex(DP) :: f_z0t_c - - - call start_clock('calcmt') - - do iss=1,nspin - call set_twin(fmat(iss), CMPLX(0.d0,0.d0)) - enddo - - DO iss = 1, nspin - - nss = nupdwn( iss ) - istart = iupdwn( iss ) - np_rot = descla( la_npr_ , iss ) * descla( la_npc_ , iss ) - me_rot = descla( la_me_ , iss ) - nrl = descla( la_nrl_ , iss ) - comm_rot = descla( la_comm_ , iss ) - - IF( descla( lambda_node_ , iss ) > 0 ) THEN - - IF(.not.fmat(iss)%iscmplx) THEN - ALLOCATE( mtmp( nrlx, nudx ) ) - - DO ip = 1, np_rot - - IF( me_rot == ( ip - 1 ) ) THEN - mtmp = zmat(iss)%rvec(:,:) - END IF - nrl_ip = ldim_cyclic( nss, np_rot, ip - 1 ) - CALL mp_bcast( mtmp , ip - 1 , comm_rot ) - - DO j = 1, nss - ii = ip - DO i = 1, nrl_ip - f_z0t = fdiag( j + istart - 1 ) * mtmp( i, j ) - DO k = 1, nrl - fmat(iss)%rvec( k, ii) = fmat(iss)%rvec( k, ii)+ zmat(iss)%rvec(k, j) * f_z0t - END DO - ii = ii + np_rot - END DO - END DO - - END DO - - DEALLOCATE( mtmp ) - ELSE - ALLOCATE( mtmp_c( nrlx, nudx ) ) - - DO ip = 1, np_rot - - IF( me_rot == ( ip - 1 ) ) THEN - mtmp_c(:,:) = zmat(iss)%cvec(:,:) - END IF - nrl_ip = ldim_cyclic( nss, np_rot, ip - 1 ) - CALL mp_bcast( mtmp_c , ip - 1 , comm_rot ) - - DO j = 1, nss - ii = ip - DO i = 1, nrl_ip - f_z0t_c = fdiag( j + istart - 1 ) * mtmp_c( i, j ) - DO k = 1, nrl - fmat(iss)%cvec( k, ii) = fmat(iss)%cvec(k, ii)+ zmat(iss)%cvec( k, j) * f_z0t_c - END DO - ii = ii + np_rot - END DO - END DO - - END DO - - DEALLOCATE( mtmp_c ) - ENDIF - - END IF - - END DO - - call stop_clock('calcmt') - - RETURN - END SUBROUTINE calcmt_twin - -!----------------------------------------------------------------------- - subroutine rotate( z0, c0, bec, c0diag, becdiag, firstiter ) -!----------------------------------------------------------------------- - use kinds, only: dp - use cvan - use electrons_base, only: nudx, nspin, nupdwn, iupdwn, nx => nbspx, n => nbsp - use uspp_param, only: nh - use uspp, only :nhsa=>nkb - use gvecw, only: ngw - use ions_base, only: nsp, na - USE cp_main_variables, ONLY: descla, nrlx - USE descriptors, ONLY: la_npc_ , la_npr_ , la_comm_ , la_me_ , la_nrl_ - USE cp_interfaces, ONLY: protate - - implicit none - integer iss, nss, istart - integer :: np_rot, me_rot, nrl, comm_rot - real(kind=DP) z0( nrlx, nudx, nspin ) - real(kind=DP) bec( nhsa, n ), becdiag( nhsa, n ) - complex(kind=DP) c0( ngw, nx ), c0diag( ngw, nx ) - logical firstiter - - CALL start_clock( 'rotate' ) - - DO iss = 1, nspin - istart = iupdwn( iss ) - nss = nupdwn( iss ) - np_rot = descla( la_npr_ , iss ) * descla( la_npc_ , iss ) - me_rot = descla( la_me_ , iss ) - nrl = descla( la_nrl_ , iss ) - comm_rot = descla( la_comm_ , iss ) - CALL protate ( c0, bec, c0diag, becdiag, ngw, nss, istart, z0(:,:,iss), & - na, nsp, ish, nh, np_rot, me_rot) - END DO - - CALL stop_clock( 'rotate' ) - return - end subroutine rotate - -!----------------------------------------------------------------------- - subroutine rotate_twin( z0, c0, bec, c0diag, becdiag, firstiter ) -!----------------------------------------------------------------------- - use kinds, only: dp - use cvan - use electrons_base, only: nspin, nupdwn, iupdwn, nx => nbspx - use uspp_param, only: nh - use gvecw, only: ngw - use ions_base, only: nsp, na - USE cp_main_variables, ONLY: descla - USE descriptors, ONLY: la_npc_ , la_npr_ , la_comm_ , la_me_ , la_nrl_ - USE cp_interfaces, ONLY: protate - USE twin_types - - implicit none - integer iss, nss, istart - integer :: np_rot, me_rot, nrl, comm_rot -! real(kind=DP) z0( nrlx, nudx, nspin ) -! real(kind=DP) bec( nhsa, n ), becdiag( nhsa, n ) - type(twin_matrix) :: z0(:) - type(twin_matrix) :: bec, becdiag - complex(kind=DP) c0( ngw, nx ), c0diag( ngw, nx ) - logical firstiter - - CALL start_clock( 'rotate' ) - - DO iss = 1, nspin - istart = iupdwn( iss ) - nss = nupdwn( iss ) - np_rot = descla( la_npr_ , iss ) * descla( la_npc_ , iss ) - me_rot = descla( la_me_ , iss ) - nrl = descla( la_nrl_ , iss ) - comm_rot = descla( la_comm_ , iss ) - IF(.not.z0(iss)%iscmplx) THEN - CALL protate ( c0, bec%rvec, c0diag, becdiag%rvec, ngw, nss, istart, z0(iss)%rvec, & - na, nsp, ish, nh, np_rot, me_rot) - ELSE - CALL protate ( c0, bec%cvec, c0diag, becdiag%cvec, ngw, nss, istart, z0(iss)%cvec, & - na, nsp, ish, nh, np_rot, me_rot ) - ENDIF - END DO - - CALL stop_clock( 'rotate' ) - return - end subroutine rotate_twin - -!----------------------------------------------------------------------- - subroutine ddiag(nx,n,amat,dval,dvec,iflag) -!----------------------------------------------------------------------- -! - use dspev_module, only: dspev_drv - use kinds , only : dp - - implicit none - - integer nx,n,ndim,iflag,k,i,j - real(dp) dval(n) - real(dp) amat(nx,n), dvec(nx,n) - real(dp), allocatable:: ap(:) - - ndim=(n*(n+1))/2 - allocate(ap(ndim)) - ap(:)=0.d0 - - k=0 - do j=1,n - do i=1,j - k=k+1 - ap(k)=amat(i,j) - end do - end do - - CALL dspev_drv( 'V', 'U', n, ap, dval, dvec, nx ) - - deallocate(ap) - - return - end subroutine ddiag - - -!$$ -!----------------------------------------------------------------------- - subroutine zdiag(nx,n,amat,dval,cvec,iflag) -!----------------------------------------------------------------------- -! - use zhpev_module, only: zhpev_drv - use kinds , only : dp - - implicit none - - integer nx,n,ndim,iflag,k,i,j - real(dp) dval(n) - complex(dp) amat(nx,n), cvec(nx,n) - complex(dp), allocatable:: ap(:) - - ndim=(n*(n+1))/2 - allocate(ap(ndim)) - ap(:)=CMPLX(0.d0,0.d0) - - k=0 - do j=1,n - do i=1,j - k=k+1 - ap(k)=amat(i,j) - end do - end do - - CALL zhpev_drv( 'V', 'U', n, ap, dval, cvec, nx ) - - deallocate(ap) - - return - end subroutine zdiag -!$$ - - -!----------------------------------------------------------------------- - subroutine calcm(fdiag,zmat,fmat,firstiter) -!----------------------------------------------------------------------- -! -! constructs fmat=zmat.fdiag.zmat^t -! - use electrons_base, only: nudx, nspin, nupdwn, iupdwn, nx => nbspx - use kinds, only : dp - - implicit none - - logical firstiter - - - integer iss, nss, istart, i, j, k - real(dp) zmat(nudx,nudx,nspin), fmat(nudx,nudx,nspin), & - & fdiag(nx) - - call errore(" calcm ", " subroutine not updated ", 1) - - call start_clock('calcm') - - - do iss=1,nspin - nss=nupdwn(iss) - istart=iupdwn(iss) - do i=1,nss - do k=1,nss - fmat(k,i,iss)=0.0d0 - do j=1,nss - fmat(k,i,iss)=fmat(k,i,iss)+ & - & zmat(k,j,iss)*fdiag(j+istart-1)*zmat(i,j,iss) - end do - end do - end do - end do - - call stop_clock('calcm') - return - end subroutine calcm - - subroutine minparabola(ene0,dene0,ene1,passop,passo,stima) -!this subroutines finds the minimum of a quadratic real function - - use kinds, only : dp - - implicit none - real(dp) ene0,dene0,ene1,passop,passo,stima - real(dp) a,b,c!a*x^2+b*x+c - - c=ene0 - b=dene0 - a=(ene1-b*passop-c)/(passop**2.d0) - - passo = -b/(2.d0*a) - if( a.lt.0.d0) then - if(ene1.lt.ene0) then - passo=passop -!$$ passo=passop*2.d0 - else -!$$ This case never happens. -!$$ (1) b is always negative and hence -b*passop is positive. -!$$ (2) in order for a to be negative, therefore, ene1-c(=ene0). -!$$ should be very negative. - passo=0.5d0*passop - endif - endif - - - stima=a*passo**2.d0+b*passo+c - - - return - end subroutine minparabola - -subroutine pc2_non_ortho(a, adual, beca, becadual, b,becb, lgam) - -! this function applies the operator Pc - -! this subroutine applies the Pc operator -! a input :unperturbed wavefunctions -! b input :first order wavefunctions -! b output:b_i =b_i-a_j> - - use kinds, only: dp - use ions_base, only: na - use mp_global, only: intra_image_comm - use cvan - use gvecw, only: ngw - use constants, only: pi, fpi - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - use electrons_base, only: n => nbsp, nupdwn, iupdwn, nspin - use uspp_param, only: nh - use uspp, only :nhsa=>nkb - use uspp, only :qq - use parallel_toolkit, only : rep_matmul_drv - use twin_types ! added:giovanni - - - implicit none - - complex(kind=DP) a(ngw,n), adual(ngw,n), b(ngw,n) - - type(twin_matrix) :: beca,becb,becadual!(nhsa,n) !modified:giovanni - logical :: lgam -! local variables - integer is, iv, jv, ia, inl, jnl, i, j - real(DP), allocatable :: bectmp(:,:) - complex(DP), allocatable :: bectmp_c(:,:) - real(DP), allocatable :: qq_tmp(:,:), qqb_tmp(:,:) - complex(DP), allocatable :: qqb_tmp_c(:,:), qq_tmp_c(:,:) - complex(DP), allocatable :: zbectmp(:,:) - integer :: nl_max - integer :: nss,iss, istart - - logical :: mat_par=.true.!if true uses parallel routines - - CALL start_clock( 'pc2' ) - - do iss= 1, nspin - nss= nupdwn( iss ) -! write(6,*) "nupdwn", iss, nupdwn(iss), iupdwn(iss) - if(nss>0) THEN - - istart= iupdwn( iss ) - - if(lgam) then - allocate(bectmp(nss,nss)) - bectmp(:,:)=0.d0 - else - allocate(bectmp_c(nss,nss)) - bectmp_c(:,:)=CMPLX(0.d0,0.d0) - endif - ! - allocate(zbectmp(nss,nss)) - call zgemm('C','N',nss,nss,ngw,(1.d0,0.d0),a(:,istart),ngw,b(:,istart),ngw,(0.d0,0.d0),zbectmp,nss) - - if(lgam) then - do j=1,nss - do i=1,nss - bectmp(i,j)=2.d0*DBLE(zbectmp(i,j)) - if(ng0.eq.2) bectmp(i,j)=bectmp(i,j)-DBLE(a(1,j))*DBLE(b(1,i)) - enddo - enddo - call mp_sum( bectmp(:,:), intra_image_comm) - else - do j=1,nss - do i=1,nss - bectmp_c(i,j)=zbectmp(i,j) - enddo - enddo - call mp_sum( bectmp_c(:,:), intra_image_comm) - endif - deallocate(zbectmp) - if(nvb >= 0) then - - nl_max=0 - do is=1,nvb - nl_max=nl_max+nh(is)*na(is) - enddo - if(lgam) then - allocate (qqb_tmp(nl_max,nss)) - allocate (qq_tmp(nl_max,nl_max)) - qq_tmp(:,:)=0.d0 - do is=1,nvb - do iv=1,nh(is) - do jv=1,nh(is) - do ia=1,na(is) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - qq_tmp(inl,jnl)=qq(iv,jv,is) - enddo - enddo - enddo - enddo - else - allocate (qqb_tmp_c(nl_max,nss)) - allocate (qq_tmp_c(nl_max,nl_max)) - qq_tmp_c(:,:)=CMPLX(0.d0,0.d0) - do is=1,nvb - do iv=1,nh(is) - do jv=1,nh(is) - do ia=1,na(is) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - qq_tmp_c(inl,jnl)=CMPLX(qq(iv,jv,is),0.d0) - enddo - enddo - enddo - enddo - endif - ! - if(lgam) then - if( nhsa > 0 .and. .not. mat_par) then - call dgemm('N','N',nl_max,nss,nl_max,1.d0,qq_tmp,nl_max,becb%rvec(:,istart),nhsa,0.d0,qqb_tmp,nl_max) - call dgemm('T','N',nss,nss,nl_max,1.d0,beca%rvec(:,istart),nhsa,qqb_tmp,nl_max,1.d0,bectmp,nss) - else if ( nhsa > 0 ) then - call para_dgemm ('N','N',nl_max,nss,nl_max,1.d0,qq_tmp,nl_max,& - becb%rvec(:,istart),nhsa,0.d0,qqb_tmp,nl_max, intra_image_comm) - call para_dgemm ('T','N',nss,nss,nl_max,1.d0,beca%rvec(:,istart),nhsa, & - qqb_tmp,nl_max,1.d0,bectmp,nss, intra_image_comm) - endif - deallocate(qq_tmp,qqb_tmp) - else - if( nhsa > 0 .and. .not. mat_par) then - call zgemm('N','N',nl_max,nss,nl_max,(1.d0,0.d0),qq_tmp_c, & - nl_max,becb%cvec(:,istart),nhsa,(0.d0,0.d0), qqb_tmp_c,nl_max) - call zgemm('C','N',nss,nss,nl_max,(1.d0,0.d0), & - beca%cvec(:,istart),nhsa,qqb_tmp_c,nl_max,(1.d0,0.d0),bectmp_c,nss) - else if ( nhsa > 0 ) then - call para_zgemm ('N','N',nl_max,nss,nl_max,(1.d0,0.d0),qq_tmp_c,nl_max,& - becb%cvec(:,istart),nhsa,(0.d0,0.d0),qqb_tmp_c,nl_max, intra_image_comm) - call para_zgemm ('C','N',nss,nss,nl_max,(1.d0,0.d0),beca%cvec(:,istart),nhsa, & - qqb_tmp_c,nl_max,(1.d0,0.d0),bectmp_c,nss, intra_image_comm) - endif - deallocate(qq_tmp_c,qqb_tmp_c) - endif - ! - endif - allocate(zbectmp(nss,nss)) - if(lgam) then - do i=1,nss - do j=1,nss - zbectmp(i,j)=CMPLX(bectmp(i,j),0.d0) - enddo - enddo - else - do i=1,nss - do j=1,nss - zbectmp(i,j)=bectmp_c(i,j) - enddo - enddo - endif - call zgemm('N','N',ngw,nss,nss,(-1.d0,0.d0),adual(:,istart),ngw,zbectmp,nss,(1.d0,0.d0),b(:,istart),ngw) - deallocate(zbectmp) - - ! this computes the new bec - if(lgam) then - if ( nhsa > 0 ) then - call dgemm('N','N',nhsa,nss,nss,1.0d0,becadual%rvec(:,istart), & - nhsa,bectmp,nss,1.0d0,becb%rvec(:,istart),nhsa) - endif - deallocate(bectmp) - else - if ( nhsa > 0 ) then - call zgemm('N','N',nhsa,nss,nss,(1.0d0,0.d0),becadual%cvec(:,istart), & - nhsa,bectmp_c,nss,(1.0d0,0.d0),becb%cvec(:,istart),nhsa) - endif - deallocate(bectmp_c) - endif - ! - ENDIF - enddo!on spin - CALL stop_clock( 'pc2' ) - return - end subroutine pc2_non_ortho - -subroutine pc2(a,beca,b,becb, lgam) - -! this function applies the operator Pc - -! this subroutine applies the Pc operator -! a input :unperturbed wavefunctions -! b input :first order wavefunctions -! b output:b_i =b_i-a_j> - - use kinds, only: dp - use ions_base, only: na - use mp_global, only: intra_image_comm - use cvan - use gvecw, only: ngw - use constants, only: pi, fpi - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - use electrons_base, only: n => nbsp, nupdwn, iupdwn, nspin - use uspp_param, only: nh - use uspp, only :nhsa=>nkb - use uspp, only :qq - use parallel_toolkit, only : rep_matmul_drv - use twin_types ! added:giovanni - - - implicit none - - complex(kind=DP) a(ngw,n), b(ngw,n) - - type(twin_matrix) :: beca,becb!(nhsa,n) !modified:giovanni - logical :: lgam -! local variables - integer is, iv, jv, ia, inl, jnl, i, j - real(DP), allocatable :: bectmp(:,:) - complex(DP), allocatable :: bectmp_c(:,:) - real(DP), allocatable :: qq_tmp(:,:), qqb_tmp(:,:) - complex(DP), allocatable :: qqb_tmp_c(:,:), qq_tmp_c(:,:) - complex(DP), allocatable :: zbectmp(:,:) - integer :: nl_max - integer :: nss,iss, istart - - logical :: mat_par=.true.!if true uses parallel routines - - CALL start_clock( 'pc2' ) - - do iss= 1, nspin - nss= nupdwn( iss ) -! write(6,*) "nupdwn", iss, nupdwn(iss), iupdwn(iss) - if(nss>0) THEN - - istart= iupdwn( iss ) - - if(lgam) then - allocate(bectmp(nss,nss)) - bectmp(:,:)=0.d0 - else - allocate(bectmp_c(nss,nss)) - bectmp_c(:,:)=CMPLX(0.d0,0.d0) - endif - ! - allocate(zbectmp(nss,nss)) - call zgemm('C','N',nss,nss,ngw,(1.d0,0.d0),a(:,istart),ngw,b(:,istart),ngw,(0.d0,0.d0),zbectmp,nss) - - if(lgam) then - do j=1,nss - do i=1,nss - bectmp(i,j)=2.d0*DBLE(zbectmp(i,j)) - if(ng0.eq.2) bectmp(i,j)=bectmp(i,j)-DBLE(a(1,j))*DBLE(b(1,i)) - enddo - enddo - call mp_sum( bectmp(:,:), intra_image_comm) - else - do j=1,nss - do i=1,nss - bectmp_c(i,j)=zbectmp(i,j) - enddo - enddo - call mp_sum( bectmp_c(:,:), intra_image_comm) - endif - deallocate(zbectmp) - if(nvb >= 0) then - - nl_max=0 - do is=1,nvb - nl_max=nl_max+nh(is)*na(is) - enddo - if(lgam) then - allocate (qqb_tmp(nl_max,nss)) - allocate (qq_tmp(nl_max,nl_max)) - qq_tmp(:,:)=0.d0 - do is=1,nvb - do iv=1,nh(is) - do jv=1,nh(is) - do ia=1,na(is) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - qq_tmp(inl,jnl)=qq(iv,jv,is) - enddo - enddo - enddo - enddo - else - allocate (qqb_tmp_c(nl_max,nss)) - allocate (qq_tmp_c(nl_max,nl_max)) - qq_tmp_c(:,:)=CMPLX(0.d0,0.d0) - do is=1,nvb - do iv=1,nh(is) - do jv=1,nh(is) - do ia=1,na(is) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - qq_tmp_c(inl,jnl)=CMPLX(qq(iv,jv,is),0.d0) - enddo - enddo - enddo - enddo - endif - ! - if(lgam) then - if( nhsa > 0 .and. .not. mat_par) then - call dgemm('N','N',nl_max,nss,nl_max,1.d0,qq_tmp,nl_max,becb%rvec(:,istart),nhsa,0.d0,qqb_tmp,nl_max) - call dgemm('T','N',nss,nss,nl_max,1.d0,beca%rvec(:,istart),nhsa,qqb_tmp,nl_max,1.d0,bectmp,nss) - else if ( nhsa > 0 ) then - call para_dgemm ('N','N',nl_max,nss,nl_max,1.d0,qq_tmp,nl_max,& - becb%rvec(:,istart),nhsa,0.d0,qqb_tmp,nl_max, intra_image_comm) - call para_dgemm ('T','N',nss,nss,nl_max,1.d0,beca%rvec(:,istart),nhsa, & - qqb_tmp,nl_max,1.d0,bectmp,nss, intra_image_comm) - endif - deallocate(qq_tmp,qqb_tmp) - else - if( nhsa > 0 .and. .not. mat_par) then - call zgemm('N','N',nl_max,nss,nl_max,(1.d0,0.d0),qq_tmp_c, & - nl_max,becb%cvec(:,istart),nhsa,(0.d0,0.d0), qqb_tmp_c,nl_max) - call zgemm('C','N',nss,nss,nl_max,(1.d0,0.d0),beca%cvec(:,istart),& - nhsa,qqb_tmp_c,nl_max,(1.d0,0.d0),bectmp_c,nss) - else if ( nhsa > 0 ) then - call para_zgemm ('N','N',nl_max,nss,nl_max,(1.d0,0.d0),qq_tmp_c,nl_max,& - becb%cvec(:,istart),nhsa,(0.d0,0.d0),qqb_tmp_c,nl_max, intra_image_comm) - call para_zgemm ('C','N',nss,nss,nl_max,(1.d0,0.d0),beca%cvec(:,istart),nhsa, & - qqb_tmp_c,nl_max,(1.d0,0.d0),bectmp_c,nss, intra_image_comm) - endif - deallocate(qq_tmp_c,qqb_tmp_c) - endif - ! - endif - allocate(zbectmp(nss,nss)) - if(lgam) then - do i=1,nss - do j=1,nss - zbectmp(i,j)=CMPLX(bectmp(i,j),0.d0) - enddo - enddo - else - do i=1,nss - do j=1,nss - zbectmp(i,j)=bectmp_c(i,j) - enddo - enddo - endif - call zgemm('N','N',ngw,nss,nss,(-1.d0,0.d0),a(:,istart),ngw,& - zbectmp,nss,(1.d0,0.d0),b(:,istart),ngw) - deallocate(zbectmp) - - ! this computes the new bec - if(lgam) then - if ( nhsa > 0 ) then - call dgemm('N','N',nhsa,nss,nss,1.0d0,beca%rvec(:,istart),nhsa,bectmp,nss,1.0d0,becb%rvec(:,istart),nhsa) - endif - deallocate(bectmp) - else - if ( nhsa > 0 ) then - call zgemm('N','N',nhsa,nss,nss,(1.0d0,0.d0),beca%cvec(:,istart),& - nhsa,bectmp_c,nss,(1.0d0,0.d0),becb%cvec(:,istart),nhsa) - endif - deallocate(bectmp_c) - endif - ! - ENDIF - enddo!on spin - CALL stop_clock( 'pc2' ) - return - end subroutine pc2 - - subroutine pc2_new(a,beca,b,becb,n,nupdwn,iupdwn,ispin, lgam) - -! this function applies the operator Pc - -! this subroutine applies the Pc operator -! a input :unperturbed wavefunctions -! b input :first order wavefunctions -! b output:b_i =b_i-a_j> - - use kinds, only: dp - use ions_base, only: na - use mp_global, only: intra_image_comm - use cvan - use gvecw, only: ngw - use constants, only: pi, fpi - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - use electrons_base, only: nspin - use uspp_param, only: nh - use uspp, only :nhsa=>nkb - use uspp, only :qq - use parallel_toolkit, only : rep_matmul_drv - use twin_types ! added:giovanni - - - implicit none - - integer, intent(in) :: n, nupdwn(nspin), iupdwn(nspin), ispin(n) - complex(kind=DP) a(ngw,n), b(ngw,n) - - type(twin_matrix) :: beca,becb!(nhsa,n) !modified:giovanni - logical :: lgam -! local variables - integer is, iv, jv, ia, inl, jnl, i, j - real(DP), allocatable :: bectmp(:,:) - complex(DP), allocatable :: bectmp_c(:,:) - real(DP), allocatable :: qq_tmp(:,:), qqb_tmp(:,:) - complex(DP), allocatable :: qqb_tmp_c(:,:), qq_tmp_c(:,:) - complex(DP), allocatable :: zbectmp(:,:) - integer :: nl_max - integer :: nss,iss, istart - - logical :: mat_par=.true.!if true uses parallel routines - - CALL start_clock( 'pc2' ) - - do iss= 1, nspin - nss= nupdwn( iss ) -! write(6,*) "nupdwn", iss, nupdwn(iss), iupdwn(iss) - if(nss>0) THEN - - istart= iupdwn( iss ) - - if(lgam) then - allocate(bectmp(nss,nss)) - bectmp(:,:)=0.d0 - else - allocate(bectmp_c(nss,nss)) - bectmp_c(:,:)=CMPLX(0.d0,0.d0) - endif - ! - allocate(zbectmp(nss,nss)) - call zgemm('C','N',nss,nss,ngw,(1.d0,0.d0),a(:,istart), & - ngw,b(:,istart),ngw,(0.d0,0.d0),zbectmp,nss) - - if(lgam) then - do j=1,nss - do i=1,nss - bectmp(i,j)=2.d0*DBLE(zbectmp(i,j)) - if(ng0.eq.2) bectmp(i,j)=bectmp(i,j)-DBLE(a(1,j))*DBLE(b(1,i)) - enddo - enddo - call mp_sum( bectmp(:,:), intra_image_comm) - else - do j=1,nss - do i=1,nss - bectmp_c(i,j)=zbectmp(i,j) - enddo - enddo - call mp_sum( bectmp_c(:,:), intra_image_comm) - endif - deallocate(zbectmp) - if(nvb >= 0) then - - nl_max=0 - do is=1,nvb - nl_max=nl_max+nh(is)*na(is) - enddo - if(lgam) then - allocate (qqb_tmp(nl_max,nss)) - allocate (qq_tmp(nl_max,nl_max)) - qq_tmp(:,:)=0.d0 - do is=1,nvb - do iv=1,nh(is) - do jv=1,nh(is) - do ia=1,na(is) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - qq_tmp(inl,jnl)=qq(iv,jv,is) - enddo - enddo - enddo - enddo - else - allocate (qqb_tmp_c(nl_max,nss)) - allocate (qq_tmp_c(nl_max,nl_max)) - qq_tmp_c(:,:)=CMPLX(0.d0,0.d0) - do is=1,nvb - do iv=1,nh(is) - do jv=1,nh(is) - do ia=1,na(is) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - qq_tmp_c(inl,jnl)=CMPLX(qq(iv,jv,is),0.d0) - enddo - enddo - enddo - enddo - endif - ! - if(lgam) then - if( nhsa > 0 .and. .not. mat_par) then - call dgemm('N','N',nl_max,nss,nl_max,1.d0,qq_tmp,nl_max,becb%rvec(:,istart),nhsa,0.d0,qqb_tmp,nl_max) - call dgemm('T','N',nss,nss,nl_max,1.d0,beca%rvec(:,istart),nhsa,qqb_tmp,nl_max,1.d0,bectmp,nss) - else if ( nhsa > 0 ) then - call para_dgemm ('N','N',nl_max,nss,nl_max,1.d0,qq_tmp,nl_max,& - becb%rvec(:,istart),nhsa,0.d0,qqb_tmp,nl_max, intra_image_comm) - call para_dgemm ('T','N',nss,nss,nl_max,1.d0,beca%rvec(:,istart),nhsa, & - qqb_tmp,nl_max,1.d0,bectmp,nss, intra_image_comm) - endif - deallocate(qq_tmp,qqb_tmp) - else - if( nhsa > 0 .and. .not. mat_par) then - call zgemm('N','N',nl_max,nss,nl_max,(1.d0,0.d0),qq_tmp_c,& - nl_max,becb%cvec(:,istart),nhsa,(0.d0,0.d0), qqb_tmp_c,nl_max) - call zgemm('C','N',nss,nss,nl_max,(1.d0,0.d0),beca%cvec(:,istart),& - nhsa,qqb_tmp_c,nl_max,(1.d0,0.d0),bectmp_c,nss) - else if ( nhsa > 0 ) then - call para_zgemm ('N','N',nl_max,nss,nl_max,(1.d0,0.d0),qq_tmp_c,nl_max,& - becb%cvec(:,istart),nhsa,(0.d0,0.d0),qqb_tmp_c,nl_max, intra_image_comm) - call para_zgemm ('C','N',nss,nss,nl_max,(1.d0,0.d0),beca%cvec(:,istart),nhsa, & - qqb_tmp_c,nl_max,(1.d0,0.d0),bectmp_c,nss, intra_image_comm) - endif - deallocate(qq_tmp_c,qqb_tmp_c) - endif - ! - endif - allocate(zbectmp(nss,nss)) - if(lgam) then - do i=1,nss - do j=1,nss - zbectmp(i,j)=CMPLX(bectmp(i,j),0.d0) - enddo - enddo - else - do i=1,nss - do j=1,nss - zbectmp(i,j)=bectmp_c(i,j) - enddo - enddo - endif - call zgemm('N','N',ngw,nss,nss,(-1.d0,0.d0),a(:,istart), & - ngw,zbectmp,nss,(1.d0,0.d0),b(:,istart),ngw) - deallocate(zbectmp) - - ! this computes the new bec - if(lgam) then - if ( nhsa > 0 ) then - call dgemm('N','N',nhsa,nss,nss,1.0d0,beca%rvec(:,istart), & - nhsa,bectmp,nss,1.0d0,becb%rvec(:,istart),nhsa) - endif - deallocate(bectmp) - else - if ( nhsa > 0 ) then - call zgemm('N','N',nhsa,nss,nss,(1.0d0,0.d0),beca%cvec(:,istart), & - nhsa,bectmp_c,nss,(1.0d0,0.d0),becb%cvec(:,istart),nhsa) - endif - deallocate(bectmp_c) - endif - ! - ENDIF - enddo!on spin - CALL stop_clock( 'pc2' ) - return - end subroutine pc2_new - - subroutine pcdaga2_non_ortho(a,adual, as ,b, lgam ) - -! this function applies the operator Pc - -! this subroutine applies the Pc^dagerr operator -! a input :unperturbed wavefunctions -! b input :first order wavefunctions -! b output:b_i =b_i - S|a_j> - - use kinds - use mp_global, only: intra_image_comm - use cvan - use gvecw, only: ngw - use constants, only: pi, fpi - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - use electrons_base, only: n => nbsp, ispin - - implicit none - - complex(dp) a(ngw,n), adual(ngw,n), b(ngw,n), as(ngw,n) - logical :: lgam - ! local variables - integer i, j,ig - complex(dp) sca - complex(DP), allocatable:: scar(:) - ! - call start_clock('pcdaga2') - allocate(scar(n)) - do j=1,n - do i=1,n - sca=0.0d0 - if(ispin(i) == ispin(j)) then - IF(lgam) THEN - if (ng0.eq.2) b(1,i) = CMPLX(DBLE(b(1,i)),0.0d0) - do ig=1,ngw !loop on g vectors - sca=sca+DBLE(CONJG(a(ig,j))*b(ig,i)) - enddo - sca = sca*2.0d0 !2. for real weavefunctions - if (ng0.eq.2) sca = sca - DBLE(a(1,j))*DBLE(b(1,i)) - ELSE - do ig=1,ngw !loop on g vectors - sca=sca+CONJG(a(ig,j))*b(ig,i) - enddo - ENDIF - endif - scar(i) = sca - enddo - - call mp_sum( scar, intra_image_comm ) - - do i=1,n - if(ispin(i) == ispin(j)) then - sca = scar(i) - do ig=1,ngw - b(ig,i)=b(ig,i)-sca*as(ig,j) - enddo - ! this to prevent numerical errors - IF(lgam) THEN - if (ng0.eq.2) b(1,i) = CMPLX(DBLE(b(1,i)),0.0d0) - ENDIF - endif - enddo - enddo - deallocate(scar) - call stop_clock('pcdaga2') - return - end subroutine pcdaga2_non_ortho - - - subroutine pcdaga2(a,as ,b, lgam ) - -! this function applies the operator Pc - -! this subroutine applies the Pc^dagerr operator -! a input :unperturbed wavefunctions -! b input :first order wavefunctions -! b output:b_i =b_i - S|a_j> - - use kinds - use mp_global, only: intra_image_comm - use cvan - use gvecw, only: ngw - use constants, only: pi, fpi - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - use electrons_base, only: n => nbsp, ispin - - implicit none - - complex(dp) a(ngw,n), b(ngw,n), as(ngw,n) - logical :: lgam - ! local variables - integer i, j,ig - complex(dp) sca - complex(DP), allocatable:: scar(:) - ! - call start_clock('pcdaga2') - allocate(scar(n)) - do j=1,n - do i=1,n - sca=0.0d0 - if(ispin(i) == ispin(j)) then - IF(lgam) THEN - if (ng0.eq.2) b(1,i) = CMPLX(DBLE(b(1,i)),0.0d0) - do ig=1,ngw !loop on g vectors - sca=sca+DBLE(CONJG(a(ig,j))*b(ig,i)) - enddo - sca = sca*2.0d0 !2. for real weavefunctions - if (ng0.eq.2) sca = sca - DBLE(a(1,j))*DBLE(b(1,i)) - ELSE - do ig=1,ngw !loop on g vectors - sca=sca+CONJG(a(ig,j))*b(ig,i) - enddo - ENDIF - endif - scar(i) = sca - enddo - - call mp_sum( scar, intra_image_comm ) - - do i=1,n - if(ispin(i) == ispin(j)) then - sca = scar(i) - do ig=1,ngw - b(ig,i)=b(ig,i)-sca*as(ig,j) - enddo - ! this to prevent numerical errors - IF(lgam) THEN - if (ng0.eq.2) b(1,i) = CMPLX(DBLE(b(1,i)),0.0d0) - ENDIF - endif - enddo - enddo - deallocate(scar) - call stop_clock('pcdaga2') - return - end subroutine pcdaga2 - - subroutine pcdaga2_new(a,as ,b, n, ispin, lgam ) - -! this function applies the operator Pc - -! this subroutine applies the Pc^dagerr operator -! a input :unperturbed wavefunctions -! b input :first order wavefunctions -! b output:b_i =b_i - S|a_j> - - use kinds - use mp_global, only: intra_image_comm - use cvan - use gvecw, only: ngw - use constants, only: pi, fpi - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - - implicit none - - integer, intent(in) :: n, ispin(n) - complex(dp) a(ngw,n), b(ngw,n), as(ngw,n) - logical :: lgam - ! local variables - integer i, j,ig - complex(dp) sca - complex(DP), allocatable:: scar(:) - ! - call start_clock('pcdaga2') - allocate(scar(n)) - do j=1,n - do i=1,n - sca=0.0d0 - if(ispin(i) == ispin(j)) then - IF(lgam) THEN - if (ng0.eq.2) b(1,i) = CMPLX(DBLE(b(1,i)),0.0d0) - do ig=1,ngw !loop on g vectors - sca=sca+DBLE(CONJG(a(ig,j))*b(ig,i)) - enddo - sca = sca*2.0d0 !2. for real weavefunctions - if (ng0.eq.2) sca = sca - DBLE(a(1,j))*DBLE(b(1,i)) - ELSE - do ig=1,ngw !loop on g vectors - sca=sca+CONJG(a(ig,j))*b(ig,i) - enddo - ENDIF - endif - scar(i) = sca - enddo - - call mp_sum( scar, intra_image_comm ) - - do i=1,n - if(ispin(i) == ispin(j)) then - sca = scar(i) - do ig=1,ngw - b(ig,i)=b(ig,i)-sca*as(ig,j) - enddo - ! this to prevent numerical errors - IF(lgam) THEN - if (ng0.eq.2) b(1,i) = CMPLX(DBLE(b(1,i)),0.0d0) - ENDIF - endif - enddo - enddo - deallocate(scar) - call stop_clock('pcdaga2') - return - end subroutine pcdaga2_new - - subroutine pcdaga3(a,as ,b, lgam ) - - !For LOWDIN orthogonalization - -! this subroutine applies the Pc^dagerr operator -! a input :unperturbed wavefunctions -! b input :first order wavefunctions -! b output:b_i =b_i - S|a_j>(+)/2 - - use kinds - use mp_global, only: intra_image_comm - use cvan - use gvecw, only: ngw - use constants, only: pi, fpi - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - use electrons_base, only: n => nbsp, ispin - - implicit none - - complex(dp) a(ngw,n), b(ngw,n), as(ngw,n) - logical :: lgam - ! local variables - integer i, j,ig - complex(dp) sca - complex(DP) :: bold(ngw,n) - complex(DP), allocatable:: scar(:) - ! - call start_clock('pcdaga2') - allocate(scar(n)) - bold(:,:) = b(:,:) - ! - do j=1,n - do i=1,n - sca=0.0d0 - if(ispin(i) == ispin(j)) then - IF(lgam) THEN - if (ng0.eq.2) b(1,i) = CMPLX(DBLE(b(1,i)),0.0d0) - do ig=1,ngw !loop on g vectors - sca=sca+DBLE( CONJG(a(ig,j))*bold(ig,i)+a(ig,i)*CONJG(bold(ig,j))) - enddo - sca = sca*2.0d0 !2. for real weavefunctions - if (ng0.eq.2) sca = sca - DBLE(CONJG(a(1,j))*bold(1,i)+a(1,i)*CONJG(bold(1,j))) - ELSE - do ig=1,ngw !loop on g vectors - sca=sca+CONJG(a(ig,j))*bold(ig,i)+a(ig,i)*CONJG(bold(ig,j)) - enddo - ENDIF - endif - scar(i) = sca*0.5d0 - enddo - - call mp_sum( scar, intra_image_comm ) - - do i=1,n - if(ispin(i) == ispin(j)) then - sca = scar(i) - do ig=1,ngw - b(ig,i)=b(ig,i)-sca*as(ig,j) - enddo - ! this to prevent numerical errors - IF(lgam) THEN - if (ng0.eq.2) b(1,i) = CMPLX(DBLE(b(1,i)),0.0d0) - ENDIF - endif - enddo - enddo - deallocate(scar) - call stop_clock('pcdaga2') - return - end subroutine pcdaga3 - -!$$ -!---------------------------------------------------------------------- - SUBROUTINE lowdin(a, lgam) -!---------------------------------------------------------------------- - - use kinds - use io_global, only: ionode - use mp_global, only: intra_image_comm - use gvecw, only: ngw - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - use cvan, only: nvb - use electrons_base, only: n => nbsp, nspin, nupdwn, iupdwn - - implicit none - - complex(dp) a(ngw,n), aold(ngw,n) - integer i, j,k,ig, isp,ndim,nbnd1,nbnd2 - real(dp) sqrt_seig(n) - complex(DP) :: sca - real(DP), allocatable :: seig(:) - complex(DP), allocatable :: s(:,:), omat(:,:), sqrt_s(:,:) - logical :: lgam, okvan - ! - okvan=nvb>0 - aold(:,:)=a(:,:) - - do isp=1,nspin - - ndim=nupdwn(isp) - - allocate(s(ndim,ndim)) - allocate(omat(ndim,ndim)) - allocate(seig(ndim)) - allocate(sqrt_s(ndim,ndim)) - - s(:,:)=CMPLX(0.d0,0.d0) - - do i=1,ndim - ! - nbnd1=iupdwn(isp)-1+i - ! - do j=1,i - ! - nbnd2=iupdwn(isp)-1+j - ! - sca=CMPLX(0.0d0,0.d0) - ! - IF(lgam) THEN - ! - if (ng0.eq.2) aold(1,nbnd1) = CMPLX(DBLE(a(1,nbnd1)),0.0d0) - ! - do ig=1,ngw !loop on g vectors - ! - sca=sca+DBLE(CONJG(a(ig,nbnd2))*a(ig,nbnd1)) - ! - enddo - ! - sca = sca*2.0d0 !2. for real weavefunctions - if (ng0.eq.2) sca = sca - DBLE(CONJG(a(1,nbnd2))*a(1,nbnd1)) - s(i,j) = CMPLX(DBLE(sca),0.d0) - s(j,i) = s(i,j) - ! - ELSE - ! - do ig=1,ngw !loop on g vectors - ! - sca=sca+CONJG(a(ig,nbnd2))*a(ig,nbnd1) - s(i,j) = sca - s(j,i) = CONJG(sca) - ! - enddo - ! - ENDIF - ! - enddo - ! - enddo - - call mp_sum( s, intra_image_comm ) - call zdiag(ndim,ndim,s,seig,omat,1) - - do i=1,ndim - ! - if(seig(i).lt.0.d0.and.ionode) write(*,*) 'seig is negative ',seig(:) - ! - enddo - - sqrt_seig(:)=1.d0/DSQRT(seig(:)) - - sqrt_s(:,:)=CMPLX(0.d0,0.d0) - - do i=1,ndim - ! - do j=1,i -! if(j.lt.i) then -! sqrt_s(i,j)=sqrt_s(j,i) -! else - sca=0.d0 - do k=1,ndim - ! - sca=sca+sqrt_seig(k) * omat(i,k)*CONJG(omat(j,k)) - ! - enddo - sqrt_s(i,j) = sca - sqrt_s(j,i) = CONJG(sca) - ! - enddo - ! - enddo - - do i=1,ndim - ! - nbnd1=iupdwn(isp)-1+i - a(:,nbnd1) = CMPLX(0.d0,0.d0) - ! - do j=1,ndim - ! - nbnd2=iupdwn(isp)-1+j - a(:,nbnd1) = a(:,nbnd1) + sqrt_s(i,j) * aold(:,nbnd2) - ! - enddo - ! - enddo - - deallocate(s) - deallocate(omat) - deallocate(seig) - deallocate(sqrt_s) - - enddo - - END SUBROUTINE lowdin -!$$ - -!---------------------------------------------------------------------- - SUBROUTINE lowdin_uspp(a, beca, lgam) -!---------------------------------------------------------------------- - - use kinds - use io_global, only: ionode - use gvecw, only: ngw - use mp, only: mp_sum - use cvan, only: nvb - use twin_types - use electrons_base, only: n => nbsp, nbspx, nspin, nupdwn, iupdwn - - implicit none - - complex(dp) a(ngw,n), aold(ngw,n) - integer i, j,k,isp,ndim,nbnd1,nbnd2 - real(dp) sqrt_seig(n) - complex(DP) :: sca - type(twin_matrix) :: beca - real(DP), allocatable :: seig(:) - complex(DP), allocatable :: s(:,:), omat(:,:), sqrt_s(:,:) - logical :: lgam, okvan - ! - okvan=nvb>0 - aold(:,:)=a(:,:) - - do isp=1,nspin - - ndim=nupdwn(isp) - - if (ndim>0) then - allocate(s(ndim,ndim)) - allocate(omat(ndim,ndim)) - allocate(seig(ndim)) - allocate(sqrt_s(ndim,ndim)) - - s(:,:)=CMPLX(0.d0,0.d0) - - do i=1,ndim - ! - nbnd1=iupdwn(isp)-1+i - ! - do j=1,i - ! - nbnd2=iupdwn(isp)-1+j - ! - call dotcsv( s(j,i), nbspx, n, a, beca, a, beca, ngw, iupdwn(isp)+j-1, iupdwn(isp)+i-1, lgam) - s(i,j)=CONJG(s(j,i)) - ! - enddo - ! - enddo - do i=1,ndim - write(111,*) s(i,:) - write(111,*) i - enddo - write(111,*) "END" - ! call mp_sum( s, intra_image_comm ) - call zdiag(ndim,ndim,s,seig,omat,1) - - do i=1,ndim - ! - if(seig(i).lt.0.d0.and.ionode) write(*,*) 'seig is negative ',seig(:) - ! - enddo - - sqrt_seig(:)=1.d0/DSQRT(seig(:)) - - sqrt_s(:,:)=CMPLX(0.d0,0.d0) - - do i=1,ndim - ! - do j=1,i - ! - sca=0.d0 - do k=1,ndim - ! - sca=sca+sqrt_seig(k) * omat(i,k)*CONJG(omat(j,k)) - ! - enddo - sqrt_s(i,j) = sca - sqrt_s(j,i) = CONJG(sca) - ! - enddo - ! - enddo - - do i=1,ndim - ! - nbnd1=iupdwn(isp)-1+i - a(:,nbnd1) = CMPLX(0.d0,0.d0) - ! - do j=1,ndim - ! - nbnd2=iupdwn(isp)-1+j - a(:,nbnd1) = a(:,nbnd1) + sqrt_s(j,i) * aold(:,nbnd2) - ! - enddo - ! - enddo - - deallocate(s) - deallocate(omat) - deallocate(seig) - deallocate(sqrt_s) - ! - endif - - enddo - - END SUBROUTINE lowdin_uspp -!$$ - -!$$ - subroutine pc3us(a, beca, b, becb, lgam) - -! this function applies the modified Pc operator which is -! equivalent to Lowdin orthonormalization of the revised wavefunctions. -! this subroutine works for pseudopotentials. - -! this function applies the operator Pc - -! this subroutine applies the Pc operator -! a input :unperturbed wavefunctions -! b input :first order wavefunctions -! b output:b_i =b_i-a_j>(+)/2 - - use kinds, only: dp - use ions_base, only: na - use mp_global, only: intra_image_comm - use cvan - use gvecw, only: ngw - use constants, only: pi, fpi - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - use electrons_base, only: n => nbsp, nupdwn, iupdwn, nspin - use uspp_param, only: nh - use uspp, only :nhsa=>nkb - use uspp, only :qq - use parallel_toolkit, only : rep_matmul_drv - use twin_types - - implicit none - - complex(kind=DP) a(ngw,n), b(ngw,n) - - type(twin_matrix) :: beca,becb!(nhsa,n) !modified:giovanni - logical :: lgam -! local variables - integer is, iv, jv, ia, inl, jnl, i, j - real(DP), allocatable :: bectmp(:,:) - complex(DP), allocatable :: bectmp_c(:,:) - real(DP), allocatable :: qq_tmp(:,:), qqb_tmp(:,:) - complex(DP), allocatable :: qqb_tmp_c(:,:), qq_tmp_c(:,:) - complex(DP), allocatable :: zbectmp(:,:) - integer :: nl_max - integer :: nss,iss, istart - - logical :: mat_par=.true.!if true uses parallel routines - - CALL start_clock( 'pc3us' ) - - do iss= 1, nspin - ! - nss= nupdwn( iss ) - istart= iupdwn( iss ) - - if(lgam) then - ! - allocate(bectmp(nss,nss)) - bectmp(:,:)=0.d0 - ! - else - ! - allocate(bectmp_c(nss,nss)) - bectmp_c(:,:)=CMPLX(0.d0,0.d0) - ! - endif - ! - allocate(zbectmp(nss,nss)) - ! - call zgemm('C','N',nss,nss,ngw,(1.d0,0.d0),a(:,istart),ngw,b(:,istart),ngw,(0.d0,0.d0),zbectmp,nss) - - if(lgam) then - ! - do j=1,nss - ! - do i=1,nss - ! - bectmp(i,j)=2.d0*DBLE(zbectmp(i,j)) - if(ng0.eq.2) bectmp(i,j)=bectmp(i,j)-DBLE(CONJG(a(1,j))*(b(1,i))) - ! - enddo - ! - enddo - ! - call mp_sum( bectmp(:,:), intra_image_comm) - ! - else - ! - do j=1,nss - ! - do i=1,nss - ! - bectmp_c(i,j)=zbectmp(i,j) - ! - enddo - ! - enddo - ! - call mp_sum( bectmp_c(:,:), intra_image_comm) - ! - endif - ! - deallocate(zbectmp) - ! - if(nvb >= 0) then - ! - nl_max=0 - ! - do is=1,nvb - ! - nl_max=nl_max+nh(is)*na(is) - ! - enddo - ! - if(lgam) then - ! - allocate (qqb_tmp(nl_max,nss)) - allocate (qq_tmp(nl_max,nl_max)) - qq_tmp(:,:)=0.d0 - ! - do is=1,nvb - ! - do iv=1,nh(is) - ! - do jv=1,nh(is) - ! - do ia=1,na(is) - ! - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - qq_tmp(inl,jnl)=qq(iv,jv,is) - ! - enddo - ! - enddo - ! - enddo - ! - enddo - ! - else - ! - allocate (qqb_tmp_c(nl_max,nss)) - allocate (qq_tmp_c(nl_max,nl_max)) - qq_tmp_c(:,:)=CMPLX(0.d0,0.d0) - ! - do is=1,nvb - ! - do iv=1,nh(is) - ! - do jv=1,nh(is) - ! - do ia=1,na(is) - ! - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - qq_tmp_c(inl,jnl)=CMPLX(qq(iv,jv,is),0.d0) - ! - enddo - ! - enddo - ! - enddo - ! - enddo - ! - endif - ! - if(lgam) then - ! - if( nhsa > 0 .and. .not. mat_par) then - ! - call dgemm('N','N',nl_max,nss,nl_max,1.d0,qq_tmp,nl_max,becb%rvec(:,istart),nhsa,0.d0,qqb_tmp,nl_max) - call dgemm('T','N',nss,nss,nl_max,1.d0,beca%rvec(:,istart),nhsa,qqb_tmp,nl_max,1.d0,bectmp,nss) - ! - else if ( nhsa > 0 ) then - ! - call para_dgemm ('N','N',nl_max,nss,nl_max,1.d0,qq_tmp,nl_max,& - becb%rvec(:,istart),nhsa,0.d0,qqb_tmp,nl_max, intra_image_comm) - call para_dgemm ('T','N',nss,nss,nl_max,1.d0,beca%rvec(:,istart),nhsa, & - qqb_tmp,nl_max,1.d0,bectmp,nss, intra_image_comm) - ! - endif - ! - deallocate(qq_tmp,qqb_tmp) - ! - else - ! - if( nhsa > 0 .and. .not. mat_par) then - ! - call zgemm('N','N',nl_max,nss,nl_max,(1.d0,0.d0),qq_tmp_c, & - nl_max,becb%cvec(:,istart),nhsa,(0.d0,0.d0), qqb_tmp_c,nl_max) - call zgemm('C','N',nss,nss,nl_max,(1.d0,0.d0),beca%cvec(:,istart), & - nhsa,qqb_tmp_c,nl_max,(1.d0,0.d0),bectmp_c,nss) - ! - else if ( nhsa > 0 ) then - ! - call para_zgemm ('N','N',nl_max,nss,nl_max,(1.d0,0.d0),qq_tmp_c,nl_max,& - becb%cvec(:,istart),nhsa,(0.d0,0.d0),qqb_tmp_c,nl_max, intra_image_comm) - call para_zgemm ('C','N',nss,nss,nl_max,(1.d0,0.d0),beca%cvec(:,istart),nhsa, & - qqb_tmp_c,nl_max,(1.d0,0.d0),bectmp_c,nss, intra_image_comm) - ! - endif - ! - deallocate(qq_tmp_c,qqb_tmp_c) - ! - endif - ! - endif - - allocate(zbectmp(nss,nss)) - - if(lgam) then - ! - do i=1,nss - ! - do j=1,nss - ! - zbectmp(i,j)=0.5d0*(CMPLX(bectmp(i,j),0.d0) + CMPLX(bectmp(j,i),0.d0)) - ! - enddo - ! - enddo - ! - bectmp(:,:) = DBLE(zbectmp(:,:)) - ! - else - ! - do i=1,nss - ! - do j=1,nss - ! - zbectmp(i,j)=0.5d0*(bectmp_c(i,j)+CONJG(bectmp_c(j,i))) - ! - enddo - ! - enddo - ! - bectmp_c(:,:) = CONJG(zbectmp(:,:)) - ! - endif - - call zgemm('N','N',ngw,nss,nss,(-1.d0,0.d0),a(:,istart),ngw,zbectmp,nss,(1.d0,0.d0),b(:,istart),ngw) - deallocate(zbectmp) - - ! this computes the new bec - if(lgam) then - ! - if ( nhsa > 0 ) then - ! - call dgemm('N','N',nhsa,nss,nss,1.0d0,beca%rvec(:,istart),nhsa,bectmp,nss,1.0d0,becb%rvec(:,istart),nhsa) - ! - endif - ! - deallocate(bectmp) - ! - else - ! - if ( nhsa > 0 ) then - ! - call zgemm('N','N',nhsa,nss,nss,(1.0d0,0.d0),beca%cvec(:,istart), & - nhsa,bectmp_c,nss,(1.0d0,0.d0),becb%cvec(:,istart),nhsa) - ! - endif - ! - deallocate(bectmp_c) - ! - endif - ! - enddo!on spin - ! - CALL stop_clock( 'pc3us' ) - ! - return - ! - end subroutine pc3us - - subroutine pc3nc(a,b, lgam) - -! this function applies the modified Pc operator which is -! equivalent to Lowdin orthonormalization of the revised wavefunctions. -! currently implemented only for norm-conserving pseudopotentials. - -! this subroutine applies the modified Pc operator -! a input :unperturbed wavefunctions -! b input :first order wavefunctions -! b output:b_i =b_i - |a_j>(+)/2 - - use kinds - use mp_global, only: intra_image_comm - use gvecw, only: ngw - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - use electrons_base, only: n => nbsp, ispin - - implicit none - - complex(dp) a(ngw,n), b(ngw,n) - logical :: lgam - ! local variables - complex(DP) :: bold(ngw,n) - integer i, j,ig -! real(dp) sca - complex(DP) :: sca_c - complex(DP), allocatable:: scar_c(:) - ! - call start_clock('pc3') - - allocate(scar_c(n)) - - bold(:,:)=b(:,:) - - do j=1,n - ! - do i=1,n - ! - sca_c=CMPLX(0.0d0,0.d0) - ! - if(ispin(i) == ispin(j)) then - ! - if(lgam) then - ! - if (ng0.eq.2) bold(1,i) = CMPLX(DBLE(bold(1,i)),0.0d0) - ! - endif - ! - do ig=1,ngw !loop on g vectors - ! - sca_c=sca_c+CONJG(a(ig,j))*bold(ig,i) !uncomment this for lowdin ortho - sca_c=sca_c+(a(ig,i))*CONJG(bold(ig,j)) !remove the 2.d0 for lowdin ortho - ! - enddo - !sca = sca*2.0d0 !2. for real weavefunctions - !$$ not necessary: sca = sca*2.0d0 !2. for real weavefunctions - if(lgam) then - ! - if (ng0.eq.2) then - ! - sca_c = CMPLX(DBLE(sca_c),0.d0) - & - CMPLX(0.5d0*DBLE(CONJG(a(1,j))*(bold(1,i))+(a(1,i))*CONJG(bold(1,j))),0.d0) !use this one for lowdin ortho - !sca_c = CMPLX(DBLE(sca_c),0.d0) - CMPLX(DBLE((a(1,i))*CONJG(bold(1,j))),0.d0) !comment this one for lowdin ortho - else - ! - sca_c = CMPLX(DBLE(sca_c), 0.d0) - ! - endif - ! - else - ! - sca_c=0.5d0*sca_c - ! - endif - ! - scar_c(i) = sca_c - ! - endif - ! - enddo - - call mp_sum( scar_c, intra_image_comm ) - - do i=1,n - ! - if(ispin(i) == ispin(j)) then - ! - sca_c = scar_c(i) - ! - do ig=1,ngw - ! - b(ig,i)=b(ig,i)-sca_c*a(ig,j) - ! - enddo - ! this to prevent numerical errors - if(lgam) then - ! - if (ng0.eq.2) b(1,i) = CMPLX(DBLE(b(1,i)),0.0d0) - ! - endif - ! - endif - ! - enddo - ! - enddo - ! - deallocate(scar_c) - call stop_clock('pc3') - return - end subroutine pc3nc - - subroutine pc3nc_new(a,b,n,ispin, lgam) - -! this function applies the modified Pc operator which is -! equivalent to Lowdin orthonormalization of the revised wavefunctions. -! currently implemented only for norm-conserving pseudopotentials. - -! this subroutine applies the modified Pc operator -! a input :unperturbed wavefunctions -! b input :first order wavefunctions -! b output:b_i =b_i - |a_j>(+)/2 - - use kinds - use mp_global, only: intra_image_comm - use gvecw, only: ngw - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - - implicit none - - integer, intent(in) :: n, ispin(n) - complex(dp) :: a(ngw,n), b(ngw,n) - logical :: lgam - ! local variables - complex(DP) :: bold(ngw,n) - integer i, j,ig -! real(dp) sca - complex(DP) :: sca_c - complex(DP), allocatable:: scar_c(:) - ! - call start_clock('pc3') - - allocate(scar_c(n)) - - bold(:,:)=b(:,:) - - do j=1,n - ! - do i=1,n - ! - sca_c=CMPLX(0.0d0,0.d0) - ! - if(ispin(i) == ispin(j)) then - ! - if(lgam) then - ! - if (ng0.eq.2) bold(1,i) = CMPLX(DBLE(bold(1,i)),0.0d0) - ! - endif - ! - do ig=1,ngw - ! - sca_c=sca_c+CONJG(a(ig,j))*bold(ig,i) !uncomment this for lowdin ortho - sca_c=sca_c+(a(ig,i))*CONJG(bold(ig,j)) !remove the 2.d0 for lowdin ortho - ! - enddo - !sca = sca*2.0d0 !2. for real weavefunctions - !$$ not necessary: sca = sca*2.0d0 !2. for real weavefunctions - if(lgam) then - ! - if (ng0.eq.2) then - ! - sca_c = CMPLX(DBLE(sca_c),0.d0) - & - CMPLX(0.5d0*DBLE(CONJG(a(1,j))*(bold(1,i))+(a(1,i))*CONJG(bold(1,j))),0.d0) !use this one for lowdin ortho - !sca_c = CMPLX(DBLE(sca_c),0.d0) - CMPLX(DBLE((a(1,i))*CONJG(bold(1,j))),0.d0) !comment this one for lowdin ortho - else - ! - sca_c = CMPLX(DBLE(sca_c), 0.d0) - ! - endif - ! - else - ! - sca_c=0.5d0*sca_c - ! - endif - ! - scar_c(i) = sca_c - ! - endif - ! - enddo - ! - call mp_sum( scar_c, intra_image_comm ) - ! - do i=1,n - ! - if(ispin(i) == ispin(j)) then - ! - sca_c = scar_c(i) - ! - do ig=1,ngw - ! - b(ig,i)=b(ig,i)-sca_c*a(ig,j) - ! - enddo - ! this to prevent numerical errors - if(lgam) then - ! - if (ng0.eq.2) b(1,i) = CMPLX(DBLE(b(1,i)),0.0d0) - ! - endif - ! - endif - ! - enddo - ! - enddo - ! - deallocate(scar_c) - call stop_clock('pc3') - return - end subroutine pc3nc_new - - subroutine pc3nc_both(a, b, n_emp, c0, n, ispin_emp, ispin, lgam) - -! this function applies the modified Pc operator which is -! equivalent to Lowdin orthonormalization of the revised wavefunctions. -! currently implemented only for norm-conserving pseudopotentials. - -! this subroutine applies the modified Pc operator -! a input :unperturbed wavefunctions -! b input :first order wavefunctions -! b output:b_i =b_i - |a_j>(+)/2 - - use kinds - use mp_global, only: intra_image_comm - use gvecw, only: ngw - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - - implicit none - - integer, intent(in) :: n_emp, ispin_emp(n_emp), n, ispin(n) - complex(dp) :: a(ngw,n_emp), b(ngw,n_emp), c0(ngw,n) - logical :: lgam - ! local variables - complex(DP) :: bold(ngw,n_emp) - integer i, j, ig, ispin_tot(n+n_emp) - complex(DP) :: sca_c - complex(DP), allocatable:: scar_c(:) - ! - call start_clock('pc3') - - allocate(scar_c(n_emp)) - ! - ispin_tot(1:n_emp) = ispin_emp(1:n_emp) - ispin_tot(n_emp+1:n_emp+n) = ispin(n) - ! - bold(:,:)=b(:,:) - ! - do j=1,n_emp+n - ! - do i=1,n_emp - ! - sca_c=CMPLX(0.0d0,0.d0) - ! - if(ispin_tot(i) == ispin_tot(j)) then - ! - if(lgam) then - ! - if (ng0.eq.2) bold(1,i) = CMPLX(DBLE(bold(1,i)),0.0d0) - ! - endif - ! - IF(j<=n_emp) THEN - ! - do ig=1,ngw - ! - sca_c=sca_c+CONJG(a(ig,j))*bold(ig,i) !uncomment this for lowdin ortho - sca_c=sca_c+(a(ig,i))*CONJG(bold(ig,j)) !remove the 2.d0 for lowdin ortho - ! - enddo - ! - ELSE - ! - do ig=1,ngw - ! - sca_c=sca_c+CONJG(c0(ig,j-n_emp))*bold(ig,i) !uncomment this for lowdin ortho -! sca_c=sca_c+(a(ig,i))*CONJG(bold(ig,j)) !remove the 2.d0 for lowdin ortho - ! - enddo - ! - ENDIF - !sca = sca*2.0d0 !2. for real weavefunctions - !$$ not necessary: sca = sca*2.0d0 !2. for real weavefunctions - IF(lgam) then - ! - IF (ng0.eq.2) then - ! - IF(j<=n_emp) THEN - ! - sca_c = CMPLX(DBLE(sca_c),0.d0) - & - CMPLX(0.5d0*DBLE(CONJG(a(1,j))*(bold(1,i))+(a(1,i))*CONJG(bold(1,j))),0.d0) !use this one for lowdin ortho - ! - ELSE - ! - sca_c = CMPLX(DBLE(sca_c),0.d0) - & - CMPLX(0.5d0*DBLE(CONJG(c0(1,j-n_emp))*(bold(1,i))),0.d0) !use this one for lowdin ortho - ! - ENDIF - ! - !sca_c = CMPLX(DBLE(sca_c),0.d0) - CMPLX(DBLE((a(1,i))*CONJG(bold(1,j))),0.d0) !comment this one for lowdin ortho - ELSE - ! - sca_c = CMPLX(DBLE(sca_c), 0.d0) - ! - ENDIF - ! - ELSE - ! - sca_c=0.5d0*sca_c - ! - ENDIF - ! - scar_c(i) = sca_c - ! - ENDIF - ! - ENDDO - - call mp_sum( scar_c, intra_image_comm ) - - do i=1,n_emp - ! - if(ispin_tot(i) == ispin_tot(j)) then - - sca_c = scar_c(i) - ! - IF(j<=n_emp) THEN - ! - do ig=1,ngw - ! - b(ig,i)=b(ig,i)-sca_c*a(ig,j) - ! - enddo - ! - ELSE - ! - do ig=1,ngw - ! - b(ig,i)=b(ig,i)-sca_c*c0(ig,j-n_emp) - ! - enddo - ! - ENDIF - ! this to prevent numerical errors - IF(lgam) THEN - ! - if (ng0.eq.2) b(1,i) = CMPLX(DBLE(b(1,i)),0.0d0) - ! - ENDIF - ! - ENDIF - ! - ENDDO - ! - ENDDO - ! - deallocate(scar_c) - ! - call stop_clock('pc3') - ! - return - ! - end subroutine pc3nc_both - - subroutine pc4nc(a,b, lgam) - -! this function applies the modified Pc operator which is -! equivalent to Lowdin orthonormalization of the revised wavefunctions. -! currently implemented only for norm-conserving pseudopotentials. - -! this subroutine applies the modified Pc operator -! a input :unperturbed wavefunctions -! b input :first order wavefunctions -! b output:b_i =b_i - |a_j>() - - use kinds - use mp_global, only: intra_image_comm - use gvecw, only: ngw - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - use electrons_base, only: n => nbsp, ispin - - implicit none - - complex(dp) a(ngw,n), b(ngw,n) - logical :: lgam - ! local variables - complex(DP) :: bold(ngw,n) - integer i, j,ig -! real(dp) sca - complex(DP) :: sca_c - complex(DP), allocatable:: scar_c(:) - ! - call start_clock('pc3') - - allocate(scar_c(n)) - - bold(:,:)=b(:,:) - - do j=1,n - do i=1,n - sca_c=CMPLX(0.0d0,0.d0) - if(ispin(i) == ispin(j)) then - if(lgam) then - if (ng0.eq.2) bold(1,i) = CMPLX(DBLE(bold(1,i)),0.0d0) - endif - do ig=1,ngw !loop on g vectors - !sca_c=sca_c+CONJG(a(ig,j))*bold(ig,i) !uncomment this for lowdin ortho - sca_c=sca_c+2.d0*(a(ig,i))*CONJG(bold(ig,j)) !remove the 2.d0 for lowdin ortho - enddo - !sca = sca*2.0d0 !2. for real weavefunctions - !$$ not necessary: sca = sca*2.0d0 !2. for real weavefunctions - if(lgam) then - if (ng0.eq.2) then - !sca_c = CMPLX(DBLE(sca_c),0.d0) - CMPLX(0.5d0*DBLE(CONJG(a(1,j))*(bold(1,i))+(a(1,i))*CONJG(bold(1,j))),0.d0) !use this one for lowdin ortho - sca_c = CMPLX(DBLE(sca_c),0.d0) - CMPLX(DBLE((a(1,i))*CONJG(bold(1,j))),0.d0) !comment this one for lowdin ortho - else - sca_c = CMPLX(DBLE(sca_c), 0.d0) - endif - else - sca_c=0.5d0*sca_c - endif - scar_c(i) = sca_c - endif - enddo - - call mp_sum( scar_c, intra_image_comm ) - - do i=1,n - if(ispin(i) == ispin(j)) then - sca_c = scar_c(i) - do ig=1,ngw - b(ig,i)=b(ig,i)-sca_c*a(ig,j) - enddo - ! this to prevent numerical errors - if(lgam) then - if (ng0.eq.2) b(1,i) = CMPLX(DBLE(b(1,i)),0.0d0) - endif - endif - enddo - enddo - deallocate(scar_c) - call stop_clock('pc3') - return - end subroutine pc4nc - - - subroutine pc3nc_non_ortho(a,adual, b, lgam) - -! this function applies the modified Pc operator which is -! equivalent to Lowdin orthonormalization of the revised wavefunctions. -! currently implemented only for norm-conserving pseudopotentials. - -! this subroutine applies the modified Pc operator -! a input :unperturbed wavefunctions -! b input :first order wavefunctions -! b output:b_i =b_i - |adual_j>(+)/2 - - use kinds - use mp_global, only: intra_image_comm - use gvecw, only: ngw - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - use electrons_base, only: n => nbsp, ispin - - implicit none - - complex(dp) a(ngw,n), adual(ngw,n), b(ngw,n) - logical :: lgam - ! local variables - complex(DP) :: bold(ngw,n) - integer i, j,ig -! real(dp) sca - complex(DP) :: sca_c - complex(DP), allocatable:: scar_c(:) - ! - call start_clock('pc3') - - allocate(scar_c(n)) - - bold(:,:)=b(:,:) - - do j=1,n - do i=1,n - sca_c=CMPLX(0.0d0,0.d0) - if(ispin(i) == ispin(j)) then - if(lgam) then - if (ng0.eq.2) bold(1,i) = CMPLX(DBLE(bold(1,i)),0.0d0) - endif - do ig=1,ngw !loop on g vectors - sca_c=sca_c+CONJG(a(ig,j))*bold(ig,i) - sca_c=sca_c+(a(ig,i))*CONJG(bold(ig,j)) - enddo - !sca = sca*2.0d0 !2. for real weavefunctions - !$$ not necessary: sca = sca*2.0d0 !2. for real weavefunctions - if(lgam) then - if (ng0.eq.2) then - sca_c = CMPLX(DBLE(sca_c),0.d0) - & - CMPLX(0.5d0*DBLE(CONJG(a(1,j))*(bold(1,i))+(a(1,i))*CONJG(bold(1,j))),0.d0) - else - sca_c = CMPLX(DBLE(sca_c), 0.d0) - endif - else - sca_c=0.5d0*sca_c - endif - scar_c(i) = sca_c - endif - enddo - - call mp_sum( scar_c, intra_image_comm ) - - do i=1,n - if(ispin(i) == ispin(j)) then - sca_c = scar_c(i) - do ig=1,ngw - b(ig,i)=b(ig,i)-sca_c*adual(ig,j) - enddo - ! this to prevent numerical errors - if(lgam) then - if (ng0.eq.2) b(1,i) = CMPLX(DBLE(b(1,i)),0.0d0) - endif - endif - enddo - enddo - deallocate(scar_c) - call stop_clock('pc3') - return - end subroutine pc3nc_non_ortho - - subroutine pc4nc_non_ortho(c, a, adual, b, lgam) - -! this function applies the modified Pc operator which is -! equivalent to Lowdin orthonormalization of the revised wavefunctions. -! currently implemented only for norm-conserving pseudopotentials. - -! this subroutine applies the modified Pc operator -! a input :unperturbed wavefunctions -! b input :first order wavefunctions -! b output:c_i = - |adual_i>() - - use kinds - use mp_global, only: intra_image_comm - use gvecw, only: ngw - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - use electrons_base, only: n => nbsp, ispin - - implicit none - - complex(dp) a(ngw,n), adual(ngw,n), b(ngw,n), c(ngw,n) - logical :: lgam - ! local variables - complex(DP) :: bold(ngw,n) - integer i, j,ig -! real(dp) sca - complex(DP) :: sca_c - complex(DP), allocatable:: scar_c(:) - ! - call start_clock('pc4') - - allocate(scar_c(n)) - - bold(:,:)=b(:,:) - -! do j=1,n - do i=1,n - j=i - sca_c=CMPLX(0.0d0,0.d0) - if(ispin(i) == ispin(j)) then - if(lgam) then - if (ng0.eq.2) bold(1,i) = CMPLX(DBLE(bold(1,i)),0.0d0) - endif - do ig=1,ngw !loop on g vectors - sca_c=sca_c+CONJG(a(ig,j))*bold(ig,i) - sca_c=sca_c+(a(ig,i))*CONJG(bold(ig,j)) - enddo - !sca = sca*2.0d0 !2. for real weavefunctions - !$$ not necessary: sca = sca*2.0d0 !2. for real weavefunctions - if(lgam) then - if (ng0.eq.2) then - sca_c = CMPLX(DBLE(sca_c),0.d0) - & - CMPLX(0.5d0*DBLE(CONJG(a(1,j))*(bold(1,i))+(a(1,i))*CONJG(bold(1,j))),0.d0) - else - sca_c = CMPLX(DBLE(sca_c), 0.d0) - endif - else - sca_c=0.5d0*sca_c - endif - scar_c(i) = sca_c - endif - enddo - - call mp_sum( scar_c, intra_image_comm ) - - do i=1,n - j=i - if(ispin(i) == ispin(j)) then - sca_c = scar_c(i) - do ig=1,ngw - c(ig,i)=-sca_c*adual(ig,j) - enddo - ! this to prevent numerical errors - if(lgam) then - if (ng0.eq.2) c(1,i) = CMPLX(DBLE(c(1,i)),0.0d0) - endif - endif - enddo -! enddo - deallocate(scar_c) - call stop_clock('pc4') - return - end subroutine pc4nc_non_ortho - - subroutine set_x_minus1_real(betae,m_minus1,ema0bg,use_ema) - ! - ! this function calculates the factors for the inverse of the US K matrix - ! it takes care of the preconditioning - ! see paper by Hasnip and Pickard, Computer Physics Communications 174 (2006) 24–29 - ! - - use kinds, only: dp - use ions_base, only: na - use io_global, only: stdout - use mp_global, only: intra_image_comm - use cvan - use gvecw, only: ngw - use constants, only: pi, fpi - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum, mp_bcast - use uspp_param, only: nh - use uspp, only :nhsa=>nkb,qq,nhsavb=>nkbus - use io_global, ONLY: ionode, ionode_id - - implicit none - - complex(DP) :: betae(ngw,nhsa) - real(DP) :: m_minus1(nhsavb,nhsavb) - real(DP) :: ema0bg(ngw) - logical :: use_ema - - -! local variables - real(DP),allocatable :: q_matrix(:,:), c_matrix(:,:) - integer is, iv, jv, ia, inl, jnl, i, ig, js, ja - real(DP) sca - integer info, lwork - integer, allocatable :: ipiv(:) - real(dp),allocatable :: work(:) - - call start_clock('set_x_minus1') - allocate(ipiv(nhsavb)) - allocate(work(nhsavb)) - - lwork=nhsavb - - allocate(q_matrix(nhsavb,nhsavb),c_matrix(nhsavb,nhsavb)) -!construct q matrix - q_matrix(:,:) = 0.d0 - - do is=1,nvb - do iv=1,nh(is) - do jv=1,nh(is) - do ia=1,na(is) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - q_matrix(inl,jnl)= qq(iv,jv,is) - enddo - enddo - enddo - enddo - -!construct C matrix -! m_minus1 used to be C matrix - m_minus1(:,:) = 0.d0 - do is=1,nvb - do ia=1,na(is) - do iv=1,nh(is) - do js=1,nvb - do ja=1,na(js) - do jv=1,nh(js) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(js)+(jv-1)*na(js)+ja - sca=0.d0 - if (use_ema) then - ! k_minus case - do ig=1,ngw !loop on g vectors - sca=sca+ema0bg(ig)*DBLE(CONJG(betae(ig,inl))*betae(ig,jnl)) - enddo - sca = sca*2.0d0 !2. for real weavefunctions - if (ng0.eq.2) sca = sca - ema0bg(1)*DBLE(CONJG(betae(1,inl))*betae(1,jnl)) - else - ! s_minus case - do ig=1,ngw !loop on g vectors - sca=sca+DBLE(CONJG(betae(ig,inl))*betae(ig,jnl)) - enddo - sca = sca*2.0d0 !2. for real weavefunctions - if (ng0.eq.2) sca = sca - DBLE(CONJG(betae(1,inl))*betae(1,jnl)) - endif - m_minus1(inl,jnl)=sca - enddo - enddo - enddo - enddo - enddo - enddo - call mp_sum( m_minus1, intra_image_comm ) - -!calculate -(1+QC)**(-1) * Q - CALL DGEMM('N','N',nhsavb,nhsavb,nhsavb,1.0d0,q_matrix,nhsavb,m_minus1,nhsavb,0.0d0,c_matrix,nhsavb) - - do i=1,nhsavb - c_matrix(i,i)=c_matrix(i,i)+1.d0 - enddo - - if(ionode) then - call dgetrf(nhsavb,nhsavb,c_matrix,nhsavb,ipiv,info) - if(info .ne. 0) write(stdout,*) 'set_k_minus1 Problem with dgetrf :', info - call dgetri(nhsavb,c_matrix,nhsavb,ipiv,work,lwork,info) - if(info .ne. 0) write(stdout,*) 'set_k_minus1 Problem with dgetri :', info - endif - call mp_bcast( c_matrix, ionode_id, intra_image_comm ) - - - CALL DGEMM('N','N',nhsavb,nhsavb,nhsavb,-1.0d0,c_matrix,nhsavb,q_matrix,nhsavb,0.0d0,m_minus1,nhsavb) - - deallocate(q_matrix,c_matrix) - deallocate(ipiv,work) - call stop_clock('set_x_minus1') - return - - end subroutine set_x_minus1_real - - subroutine set_x_minus1_twin(betae,m_minus1,ema0bg,use_ema) - - ! - ! this function calculates the factors for the inverse of the US K matrix - ! it takes care of the preconditioning - ! see paper by Hasnip and Pickard, Computer Physics Communications 174 (2006) 24–29 - ! - ! this subroutine stores in m_mins1 the matrix R of the above paper - ! - - use kinds, only: dp - use ions_base, only: na - use io_global, only: stdout - use mp_global, only: intra_image_comm - use cvan - use gvecw, only: ngw - use constants, only: pi, fpi - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum, mp_bcast - use uspp_param, only: nh - use uspp, only :nhsa=>nkb,qq,nhsavb=>nkbus - use io_global, ONLY: ionode, ionode_id - use twin_types - - implicit none - - complex(DP) :: betae(ngw,nhsa) -! real(DP) :: m_minus1(nhsavb,nhsavb) - type(twin_matrix) :: m_minus1 - real(DP) :: ema0bg(ngw) - logical :: use_ema - - -! local variables - real(DP),allocatable :: q_matrix(:,:) ,c_matrix(:,:) - complex(DP), allocatable :: q_matrix_c(:,:), c_matrix_c(:,:) - integer is, iv, jv, ia, inl, jnl, i, ig, js, ja - complex(DP) :: sca - integer info, lwork - integer, allocatable :: ipiv(:) - real(dp),allocatable :: work(:) - complex(dp),allocatable :: work_c(:) - complex(dp), parameter :: c_zero=CMPLX(0.d0,0.d0), c_one=CMPLX(1.d0,0.d0) - complex(dp), parameter :: c_mone=CMPLX(-1.d0,0.d0) - - call start_clock('set_x_minus1') - allocate(ipiv(nhsavb)) - - - lwork=nhsavb - - IF(.not.m_minus1%iscmplx) THEN - allocate(q_matrix(nhsavb,nhsavb),c_matrix(nhsavb,nhsavb)) - allocate(work(nhsavb)) - ELSE - allocate(q_matrix_c(nhsavb,nhsavb),c_matrix_c(nhsavb,nhsavb)) - allocate(work_c(nhsavb)) - ENDIF -!construct q matrix - IF(.not.m_minus1%iscmplx) THEN - q_matrix(:,:) = 0.d0 - - do is=1,nvb - do iv=1,nh(is) - do jv=1,nh(is) - do ia=1,na(is) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - q_matrix(inl,jnl)= qq(iv,jv,is) - enddo - enddo - enddo - enddo - ELSE - q_matrix_c(:,:) = CMPLX(0.d0,0.d0) - - do is=1,nvb - do iv=1,nh(is) - do jv=1,nh(is) - do ia=1,na(is) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - q_matrix_c(inl,jnl)= CMPLX(qq(iv,jv,is),0.d0) - enddo - enddo - enddo - enddo - ENDIF -!construct b matrix -! m_minus1 used to be b matrix - call set_twin(m_minus1, CMPLX(0.d0,0.d0)) -! m_minus1(:,:) = 0.d0 - do is=1,nvb - do ia=1,na(is) - do iv=1,nh(is) - do js=1,nvb - do ja=1,na(js) - do jv=1,nh(js) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(js)+(jv-1)*na(js)+ja - sca=CMPLX(0.d0,0.d0) - if (use_ema) then - !k_minus case - IF(.not.m_minus1%iscmplx) THEN - ! - do ig=1,ngw !loop on g vectors - sca=sca+ema0bg(ig)*DBLE(CONJG(betae(ig,inl))*betae(ig,jnl)) - enddo - ! - sca = sca*2.0d0 !2. for real weavefunctions - ! - if (ng0.eq.2) sca = sca - ema0bg(1)*DBLE(CONJG(betae(1,inl))*betae(1,jnl)) - ! - ELSE - ! - do ig=1,ngw !loop on g vectors - ! - sca=sca+ema0bg(ig)*CONJG(betae(ig,inl))*(betae(ig,jnl)) - ! - enddo - ! - ENDIF - else - ! s_minus case - IF(.not.m_minus1%iscmplx) THEN - do ig=1,ngw !loop on g vectors - sca=sca+DBLE(CONJG(betae(ig,inl))*betae(ig,jnl)) - enddo - sca = sca*2.0d0 !2. for real weavefunctions - if (ng0.eq.2) sca = sca - DBLE(CONJG(betae(1,inl))*betae(1,jnl)) - ELSE - do ig=1,ngw !loop on g vectors - sca=sca+CONJG(betae(ig,inl))*(betae(ig,jnl)) - enddo - ENDIF - endif - ! - call set_twin(m_minus1,inl,jnl,sca) -! write(6,*) "sca", sca, ema0bg(1), use_ema, betae(3,1) - enddo - enddo - enddo - enddo - enddo - enddo - - call twin_mp_sum( m_minus1) -!calculate -(1+QB)**(-1) * Q - IF(.not.m_minus1%iscmplx) THEN - CALL DGEMM('N','N',nhsavb,nhsavb,nhsavb,1.0d0,q_matrix,nhsavb,m_minus1%rvec,nhsavb,0.0d0,c_matrix,nhsavb) - do i=1,nhsavb - c_matrix(i,i)=c_matrix(i,i)+1.d0 - enddo - ELSE - CALL ZGEMM('N','N',nhsavb,nhsavb,nhsavb,c_one,q_matrix_c,nhsavb,m_minus1%cvec,nhsavb,c_zero,c_matrix_c,nhsavb) !warning:giovanni conjugate? - do i=1,nhsavb - c_matrix_c(i,i)=c_matrix_c(i,i)+CMPLX(1.d0,0.d0) - enddo - ENDIF - if(ionode) then - IF(.not.m_minus1%iscmplx) THEN - call dgetrf(nhsavb,nhsavb,c_matrix,nhsavb,ipiv,info) - if(info .ne. 0) write(stdout,*) 'set_k_minus1 Problem with dgetrf :', info - call dgetri(nhsavb,c_matrix,nhsavb,ipiv,work,lwork,info) - if(info .ne. 0) write(stdout,*) 'set_k_minus1 Problem with dgetri :', info - ELSE - call zgetrf(nhsavb,nhsavb,c_matrix_c,nhsavb,ipiv,info) - if(info .ne. 0) write(stdout,*) 'set_k_minus1 Problem with dgetrf :', info - call zgetri(nhsavb,c_matrix_c,nhsavb,ipiv,work_c,lwork,info) - if(info .ne. 0) write(stdout,*) 'set_k_minus1 Problem with dgetri :', info - ENDIF - endif - IF(.not.m_minus1%iscmplx) THEN - call mp_bcast( c_matrix, ionode_id, intra_image_comm ) - CALL DGEMM('N','N',nhsavb,nhsavb,nhsavb,-1.0d0,c_matrix,nhsavb,q_matrix,nhsavb,0.0d0,m_minus1%rvec,nhsavb) - ELSE - call mp_bcast( c_matrix_c, ionode_id, intra_image_comm ) - CALL ZGEMM('N','N',nhsavb,nhsavb,nhsavb,c_mone,c_matrix_c,nhsavb,q_matrix_c,nhsavb,c_zero,m_minus1%cvec,nhsavb) !warning:giovanni put a conjugate? - ENDIF - IF(.not.m_minus1%iscmplx) THEN - deallocate(q_matrix,c_matrix, work) - ELSE - deallocate(q_matrix_c,c_matrix_c, work_c) - ENDIF - ! - deallocate(ipiv) - ! -! call set_twin(m_minus1,CMPLX(0.d0,0.d0)) - call stop_clock('set_x_minus1') - return - end subroutine set_x_minus1_twin -! - subroutine xminus1_real(c0,betae,ema0bg,beck,m_minus1,do_k) -! if (do_k) then -!----------------------------------------------------------------------- -! input: c0 , bec=, betae=|beta> -! computes the matrix phi (with the old positions) -! where |phi> = K^{-1}|c0> -! else -!----------------------------------------------------------------------- -! input: c0 , bec=, betae=|beta> -! computes the matrix phi (with the old positions) -! where |phi> = s^{-1}|c0> -! endif - use kinds, only: dp - use ions_base, only: na - use mp_global, only: intra_image_comm - use cvan - use uspp_param, only: nh - use uspp, only :nhsa=>nkb, nhsavb=>nkbus - use electrons_base, only: n => nbsp - use gvecw, only: ngw - use constants, only: pi, fpi - use mp, only: mp_sum - use reciprocal_vectors, only: ng0 => gstart -! - implicit none - complex(dp) c0(ngw,n), betae(ngw,nhsa) - real(dp) beck(nhsa,n), ema0bg(ngw) - real(DP) :: m_minus1(nhsavb,nhsavb) - logical :: do_k -! local variables - complex(dp), allocatable :: phi(:,:) - real(dp) , allocatable :: qtemp(:,:) - integer is, iv, ia, inl, i, j ,ig - real(dp) becktmp - - - logical :: mat_par=.true.!if true uses parallel routines - - call start_clock('xminus1') -!$$ -! if(ionode) write(700,*) 'nvb is',nvb -!$$ - if (nvb.gt.0) then -!calculates beck - if (do_k) then - beck(:,:) = 0.d0 - - do is=1,nvb - do iv=1,nh(is) - do ia=1,na(is) - inl=ish(is)+(iv-1)*na(is)+ia - do i=1,n - becktmp = 0.0d0 - do ig=1,ngw - becktmp=becktmp+ema0bg(ig)*DBLE(CONJG(betae(ig,inl))*c0(ig,i)) - enddo - becktmp = becktmp*2.0d0 - if (ng0.eq.2) becktmp = becktmp-ema0bg(1)*DBLE(CONJG(betae(1,inl))*c0(1,i)) - beck(inl,i) = beck(inl,i) + becktmp - enddo - enddo - enddo - enddo - call mp_sum( beck, intra_image_comm ) - endif -! -! - allocate(phi(ngw,n)) - allocate(qtemp(nhsavb,n)) - phi(1:ngw,1:n) = 0.0d0 - qtemp(:,:) = 0.0d0 - if(.not.mat_par) then - call dgemm( 'N', 'N', nhsavb, n, nhsavb, 1.0d0, m_minus1,nhsavb , & - beck, nhsa, 0.0d0, qtemp,nhsavb ) - else - call para_dgemm( 'N', 'N', nhsavb, n, nhsavb, 1.0d0, m_minus1,nhsavb , & - beck, nhsa, 0.0d0, qtemp,nhsavb,intra_image_comm ) - endif - -!NB nhsavb is the total number of US projectors -! it works because the first pseudos are the vanderbilt's ones - - CALL DGEMM( 'N', 'N', 2*ngw, n, nhsavb, 1.0d0, betae, 2*ngw, & - qtemp, nhsavb, 0.0d0, phi, 2*ngw ) - if (do_k) then - do j=1,n - do ig=1,ngw - c0(ig,j)=(phi(ig,j)+c0(ig,j))*ema0bg(ig) - end do - end do - else - do j=1,n - do i=1,ngw - c0(i,j)=(phi(i,j)+c0(i,j)) - end do - end do - endif - deallocate(qtemp,phi) - - else - if (do_k) then - do j=1,n - do ig=1,ngw - c0(ig,j)=c0(ig,j)*ema0bg(ig) - end do - end do - endif - endif - call stop_clock('xminus1') - return - end subroutine xminus1_real - -! - subroutine xminus1_twin(c0,betae,ema0bg,beck,m_minus1,do_k) -! if (do_k) then -!----------------------------------------------------------------------- -! input: c0 , bec=, betae=|beta> -! computes the matrix phi (with the old positions) -! where |phi> = K^{-1}|c0> -! else -!----------------------------------------------------------------------- -! input: c0 , bec=, betae=|beta> -! computes the matrix phi (with the old positions) -! where |phi> = s^{-1}|c0> -! endif - use kinds, only: dp - use ions_base, only: na - use mp_global, only: intra_image_comm - use cvan - use uspp_param, only: nh - use uspp, only :nhsa=>nkb, nhsavb=>nkbus - use electrons_base, only: n => nbsp - use gvecw, only: ngw - use constants, only: pi, fpi - use mp, only: mp_sum - use reciprocal_vectors, only: ng0 => gstart - use twin_types -! - implicit none - complex(dp) c0(ngw,n), betae(ngw,nhsa) - real(dp) :: ema0bg(ngw) - type(twin_matrix) :: beck -! complex(DP) :: m_minus1(nhsavb,nhsavb) - type(twin_matrix) :: m_minus1 !(nhsavb,nhsavb) - logical :: do_k -! local variables - complex(dp), allocatable :: phi(:,:) - real(dp) , allocatable :: qtemp(:,:) - complex(dp) , allocatable :: qtemp_c(:,:) - integer is, iv, ia, inl, i, j,ig - real(dp) becktmp - complex(dp) becktmp_c - logical :: mat_par=.true.!if true uses parallel routines - complex(DP), parameter :: c_one=CMPLX(1.d0,0.d0) - complex(DP), parameter :: c_zero=CMPLX(0.d0,0.d0) - - call start_clock('xminus1') -!$$ -! if(ionode) write(700,*) 'nvb is',nvb -!$$ - if (nvb.gt.0) then -!calculates beck - if (do_k) then - call set_twin(beck,CMPLX(0.d0,0.d0)) - do is=1,nvb - do iv=1,nh(is) - do ia=1,na(is) - inl=ish(is)+(iv-1)*na(is)+ia - do i=1,n - IF(.not.beck%iscmplx) THEN - becktmp = 0.0d0 - do ig=1,ngw - becktmp=becktmp+ema0bg(ig)*DBLE(CONJG(betae(ig,inl))*c0(ig,i)) - enddo - becktmp = becktmp*2.0d0 - if (ng0.eq.2) becktmp = becktmp-ema0bg(1)*DBLE(CONJG(betae(1,inl))*c0(1,i)) - beck%rvec(inl,i) = beck%rvec(inl,i) + becktmp - ELSE - becktmp_c = CMPLX(0.0d0, 0.d0) - do ig=1,ngw - becktmp_c=becktmp_c+ema0bg(ig)*(CONJG(betae(ig,inl))*c0(ig,i)) - enddo - beck%cvec(inl,i) = beck%cvec(inl,i) + becktmp_c - ENDIF - enddo - enddo - enddo - enddo - call twin_mp_sum( beck ) - endif -! -! - allocate(phi(ngw,n)) - phi(1:ngw,1:n) = 0.0d0 - IF(.not.m_minus1%iscmplx) THEN - allocate(qtemp(nhsavb,n)) - qtemp(:,:) = 0.0d0 - ELSE - allocate(qtemp_c(nhsavb,n)) - qtemp_c(:,:) = CMPLX(0.0d0, 0.d0) - ENDIF - if(.not.mat_par) then - IF(.not.m_minus1%iscmplx) THEN - call dgemm( 'N', 'N', nhsavb, n, nhsavb, 1.0d0, m_minus1%rvec,nhsavb , & - beck%rvec, nhsa, 0.0d0, qtemp,nhsavb ) - ELSE - call zgemm( 'N', 'N', nhsavb, n, nhsavb, c_one, m_minus1%cvec,nhsavb , & - beck%cvec, nhsa, c_zero, qtemp_c, nhsavb ) - ENDIF - else - IF(.not.m_minus1%iscmplx) THEN - call para_dgemm( 'N', 'N', nhsavb, n, nhsavb, 1.0d0, m_minus1%rvec,nhsavb , & - beck%rvec, nhsa, 0.0d0, qtemp,nhsavb,intra_image_comm ) - ELSE - call para_zgemm( 'N', 'N', nhsavb, n, nhsavb, (1.0d0,0.d0), m_minus1%cvec,nhsavb , & - beck%cvec, nhsa, (0.0d0,0.d0), qtemp_c,nhsavb,intra_image_comm ) - ENDIF - endif -!NB nhsavb is the total number of US projectors -! it works because the first pseudos are the vanderbilt's ones - IF(.not.m_minus1%iscmplx) THEN - CALL DGEMM( 'N', 'N', 2*ngw, n, nhsavb, 1.0d0, betae, 2*ngw, & - qtemp, nhsavb, 0.0d0, phi, 2*ngw ) - ELSE - CALL ZGEMM( 'N', 'N', ngw, n, nhsavb, (1.0d0,0.d0), betae, ngw, & - qtemp_c, nhsavb, (0.0d0,0.d0), phi, ngw ) !warning:giovanni is it like this?? - ENDIF - if (do_k) then - do j=1,n - do ig=1,ngw - c0(ig,j)=(phi(ig,j)+c0(ig,j))*ema0bg(ig) - end do - end do - else - do j=1,n - do i=1,ngw - c0(i,j)=(phi(i,j)+c0(i,j)) - end do - end do - endif - deallocate(phi) - IF(.not.m_minus1%iscmplx) THEN - deallocate(qtemp) - ELSE - deallocate(qtemp_c) - ENDIF - else - if (do_k) then - do j=1,n - do ig=1,ngw - c0(ig,j)=c0(ig,j)*ema0bg(ig) - end do - end do - endif - endif - call stop_clock('xminus1') - return - end subroutine xminus1_twin - - subroutine xminus1_twin_new(c0,n,betae,ema0bg,beck,m_minus1,do_k) - ! - ! if (do_k) then - !----------------------------------------------------------------------- - ! input: c0 , bec=, betae=|beta> - ! computes the matrix phi (with the old positions) - ! where |phi> = K^{-1}|c0> - ! else - !----------------------------------------------------------------------- - ! input: c0 , bec=, betae=|beta> - ! computes the matrix phi (with the old positions) - ! where |phi> = s^{-1}|c0> - ! endif - ! - use kinds, only: dp - use ions_base, only: na - use mp_global, only: intra_image_comm - use cvan - use uspp_param, only: nh - use uspp, only :nhsa=>nkb, nhsavb=>nkbus - use gvecw, only: ngw - use constants, only: pi, fpi - use mp, only: mp_sum - use reciprocal_vectors, only: ng0 => gstart - use twin_types - ! - implicit none - ! - integer, intent(in) :: n - real(dp) :: ema0bg(ngw) - complex(dp) :: c0(ngw,n), betae(ngw,nhsa) - type(twin_matrix) :: beck - type(twin_matrix) :: m_minus1 - logical :: do_k - ! - ! local variables - ! - complex(dp), allocatable :: phi(:,:) - real(dp) , allocatable :: qtemp(:,:) - complex(dp), allocatable :: qtemp_c(:,:) - integer is, iv, ia, inl, i, j, ig - real(dp) becktmp - complex(dp) becktmp_c - logical :: mat_par=.true.!if true uses parallel routines - complex(DP), parameter :: c_one=CMPLX(1.d0,0.d0) - complex(DP), parameter :: c_zero=CMPLX(0.d0,0.d0) - ! - call start_clock('xminus1') - ! - if (nvb.gt.0) then - if (do_k) then - call set_twin(beck,CMPLX(0.d0,0.d0)) - do is=1,nvb - do iv=1,nh(is) - do ia=1,na(is) - inl=ish(is)+(iv-1)*na(is)+ia - do i=1,n - IF(.not.beck%iscmplx) THEN - becktmp = 0.0d0 - do ig=1,ngw - becktmp=becktmp+ema0bg(ig)*DBLE(CONJG(betae(ig,inl))*c0(ig,i)) - enddo - becktmp = becktmp*2.0d0 - if (ng0.eq.2) becktmp = becktmp-ema0bg(1)*DBLE(CONJG(betae(1,inl))*c0(1,i)) - beck%rvec(inl,i) = beck%rvec(inl,i) + becktmp - ELSE - becktmp_c = CMPLX(0.0d0, 0.d0) - do ig=1,ngw - becktmp_c=becktmp_c+ema0bg(ig)*(CONJG(betae(ig,inl))*c0(ig,i)) - enddo - beck%cvec(inl,i) = beck%cvec(inl,i) + becktmp_c - ENDIF - enddo - enddo - enddo - enddo - call twin_mp_sum( beck ) - endif - ! - ! - allocate(phi(ngw,n)) - phi(1:ngw,1:n) = 0.0d0 - IF(.not.m_minus1%iscmplx) THEN - allocate(qtemp(nhsavb,n)) - qtemp(:,:) = 0.0d0 - ELSE - allocate(qtemp_c(nhsavb,n)) - qtemp_c(:,:) = CMPLX(0.0d0, 0.d0) - ENDIF - if(.not.mat_par) then - IF(.not.m_minus1%iscmplx) THEN - call dgemm( 'N', 'N', nhsavb, n, nhsavb, 1.0d0, m_minus1%rvec,nhsavb , & - beck%rvec, nhsa, 0.0d0, qtemp,nhsavb ) - ELSE - call zgemm( 'N', 'N', nhsavb, n, nhsavb, c_one, m_minus1%cvec,nhsavb , & - beck%cvec, nhsa, c_zero, qtemp_c, nhsavb ) - ENDIF - else - IF(.not.m_minus1%iscmplx) THEN - call para_dgemm( 'N', 'N', nhsavb, n, nhsavb, 1.0d0, m_minus1%rvec,nhsavb , & - beck%rvec, nhsa, 0.0d0, qtemp,nhsavb,intra_image_comm ) - ELSE - call para_zgemm( 'N', 'N', nhsavb, n, nhsavb, (1.0d0,0.d0), m_minus1%cvec,nhsavb , & - beck%cvec, nhsa, (0.0d0,0.d0), qtemp_c,nhsavb,intra_image_comm ) - ENDIF - endif -!NB nhsavb is the total number of US projectors -! it works because the first pseudos are the vanderbilt's ones - IF(.not.m_minus1%iscmplx) THEN - CALL DGEMM( 'N', 'N', 2*ngw, n, nhsavb, 1.0d0, betae, 2*ngw, & - qtemp, nhsavb, 0.0d0, phi, 2*ngw ) - ELSE - CALL ZGEMM( 'N', 'N', ngw, n, nhsavb, (1.0d0,0.d0), betae, ngw, & - qtemp_c, nhsavb, (0.0d0,0.d0), phi, ngw ) !warning:giovanni is it like this?? - ENDIF - if (do_k) then - do j=1,n - do ig=1,ngw - c0(ig,j)=(phi(ig,j)+c0(ig,j))*ema0bg(ig) - end do - end do - else - do j=1,n - do i=1,ngw - c0(i,j)=(phi(i,j)+c0(i,j)) - end do - end do - endif - deallocate(phi) - IF(.not.m_minus1%iscmplx) THEN - deallocate(qtemp) - ELSE - deallocate(qtemp_c) - ENDIF - else - if (do_k) then - do j=1,n - do ig=1,ngw - c0(ig,j)=c0(ig,j)*ema0bg(ig) - end do - end do - endif - endif - call stop_clock('xminus1') - return - end subroutine xminus1_twin_new - - SUBROUTINE emass_precond_tpa( ema0bg, tpiba2, emaec ) - ! - ! kinetic energy preconditioning is computed here: - ! (1+T')^{-1} - ! - use kinds, ONLY : dp - use gvecw, ONLY : ggp, ngw - - IMPLICIT NONE - - REAL(DP), INTENT(OUT) :: ema0bg(ngw) - REAL(DP), INTENT(IN) :: tpiba2, emaec - INTEGER :: i - - real(DP) :: x - - call start_clock('emass_p_tpa') - do i = 1, ngw - ! - x=0.5d0*tpiba2*ggp(i)/emaec - ema0bg(i) = 1.d0/(1.d0+(16.d0*x**4)/(27.d0+18.d0*x+12.d0*x**2+8.d0*x**3)) - ! - end do - call stop_clock('emass_p_tpa') - - RETURN - - END SUBROUTINE emass_precond_tpa - - subroutine ave_kin( c, ngwx, n, ene_ave ) -!this subroutine calculates the average kinetic energy of -!each state , to be used for preconditioning - - - USE kinds, ONLY: DP - USE constants, ONLY: pi, fpi - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gstart - USE gvecw, ONLY: ggp - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE cell_base, ONLY: tpiba2 - - IMPLICIT NONE - - - ! input - - INTEGER, INTENT(IN) :: ngwx, n - COMPLEX(kind=DP), INTENT(IN) :: c( ngwx, n ) - REAL(kind=DP), INTENT(out) :: ene_ave(n)!average kinetic energy to be calculated - ! - ! local - - INTEGER :: ig, i - - ! - DO i=1,n - ene_ave(i)=0.d0 - DO ig=gstart,ngw - ene_ave(i)=ene_ave(i)+DBLE(CONJG(c(ig,i))*c(ig,i))*ggp(ig) - END DO - END DO - - - CALL mp_sum( ene_ave(1:n), intra_image_comm ) - ene_ave(:)=ene_ave(:)*tpiba2 - - RETURN - END subroutine ave_kin - - - - subroutine xminus1_state(c0,betae,ema0bg,beck,m_minus1,do_k,ave_kin) -! if (do_k) then -!----------------------------------------------------------------------- -! input: c0 , bec=, betae=|beta> -! computes the matrix phi (with the old positions) -! where |phi> = K^{-1}|c0> -! else -!----------------------------------------------------------------------- -! input: c0 , bec=, betae=|beta> -! computes the matrix phi (with the old positions) -! where |phi> = s^{-1}|c0> -! endif -!adapted for state by state - use kinds, only: dp - use ions_base, only: na - use mp_global, only: intra_image_comm - use cvan - use uspp_param, only: nh - use uspp, only :nhsa=>nkb, nhsavb=>nkbus - use electrons_base, only: n => nbsp - use gvecw, only: ngw - use constants, only: pi, fpi - use mp, only: mp_sum - use reciprocal_vectors, only: ng0 => gstart - USE gvecw, ONLY: ggp - USE cell_base, ONLY: tpiba2 - - -! - implicit none - complex(dp) c0(ngw,n), betae(ngw,nhsa) - real(dp) beck(nhsa,n), ema0bg(ngw) - real(DP) :: m_minus1(nhsavb,nhsavb) - logical :: do_k - real(kind=DP) :: ave_kin(n)!average kinetic energy per state -! local variables - complex(dp), allocatable :: phi(:,:) - real(dp) , allocatable :: qtemp(:,:) - integer is, iv, ia, inl, i, j, ig - real(dp) becktmp - real(kind=DP) :: prec_fact, x - - - call start_clock('xminus1') - if (nvb.gt.0) then -!calculates beck - if (do_k) then - beck(:,:) = 0.d0 - - do is=1,nvb - do iv=1,nh(is) - do ia=1,na(is) - inl=ish(is)+(iv-1)*na(is)+ia - do i=1,n - becktmp = 0.0d0 - do ig=1,ngw - becktmp=becktmp+ema0bg(ig)*DBLE(CONJG(betae(ig,inl))*c0(ig,i)) - enddo - becktmp = becktmp*2.0d0 - if (ng0.eq.2) becktmp = becktmp-ema0bg(1)*DBLE(CONJG(betae(1,inl))*c0(1,i)) - beck(inl,i) = beck(inl,i) + becktmp - enddo - enddo - enddo - enddo - call mp_sum( beck, intra_image_comm ) - endif -! -! - allocate(phi(ngw,n)) - allocate(qtemp(nhsavb,n)) - phi(1:ngw,1:n) = 0.0d0 - qtemp(:,:) = 0.0d0 - call dgemm( 'N', 'N', nhsavb, n, nhsavb, 1.0d0, m_minus1,nhsavb , & - beck, nhsa, 0.0d0, qtemp,nhsavb ) - - - -!NB nhsavb is the total number of US projectors, it works because the first pseudos are the vanderbilt's ones - - CALL DGEMM( 'N', 'N', 2*ngw, n, nhsavb, 1.0d0, betae, 2*ngw, & - qtemp, nhsavb, 0.0d0, phi, 2*ngw ) - if (do_k) then - do j=1,n - do ig=1,ngw - x=tpiba2*ggp(i)/ave_kin(j) - prec_fact = 1.d0/(1.d0+(16.d0*x**4)/(27.d0+18.d0*x+12.d0*x**2+8.d0*x**3)) - c0(ig,j)=c0(ig,j)*prec_fact - !c0(ig,j)=(phi(ig,j)+c0(ig,j))*ema0bg(ig) - end do - end do - else - do j=1,n - do i=1,ngw - c0(i,j)=(phi(i,j)+c0(i,j)) - end do - end do - endif - deallocate(qtemp,phi) - - else - if (do_k) then - do j=1,n - do ig=1,ngw - x=tpiba2*ggp(ig)/ave_kin(j) - prec_fact = 1.d0/(1.d0+(16.d0*x**4)/(27.d0+18.d0*x+12.d0*x**2+8.d0*x**3)) - c0(ig,j)=c0(ig,j)*prec_fact - end do - end do - endif - endif - call stop_clock('xminus1') - return - end subroutine xminus1_state -! -! ... some simple routines for parallel linear algebra (the matrices are -! ... always replicated on all the cpus) -! -! ... written by carlo sbraccia ( 2006 ) -! -!---------------------------------------------------------------------------- -SUBROUTINE para_dgemm( transa, transb, m, n, k, & - alpha, a, lda, b, ldb, beta, c, ldc, comm ) - !---------------------------------------------------------------------------- - ! - ! ... trivial parallelization (splitting matrix B by columns) of DGEMM - ! - USE kinds, ONLY : DP - USE parallel_toolkit - ! - IMPLICIT NONE - ! - CHARACTER(LEN=1), INTENT(IN) :: transa, transb - INTEGER, INTENT(IN) :: m, n, k - REAL(DP), INTENT(IN) :: alpha, beta - INTEGER, INTENT(IN) :: lda, ldb, ldc - REAL(DP), INTENT(INOUT) :: a(lda,*), b(ldb,*), c(ldc,*) - INTEGER, INTENT(IN) :: comm - ! - ! ... quick return if possible - ! - IF ( m == 0 .OR. n == 0 .OR. & - ( ( alpha == 0.0_DP .OR. k == 0 ) .AND. beta == 1.0_DP ) ) RETURN - ! -!write(*,*) 'DEBUG: para_dgemm' - ! - CALL rep_matmul_drv( transa, transb, m, n, k, & - alpha, a, lda, b, ldb, beta, c, ldc, comm ) - RETURN - ! -END SUBROUTINE para_dgemm - -SUBROUTINE para_zgemm( transa, transb, m, n, k, & - alpha, a, lda, b, ldb, beta, c, ldc, comm ) - !---------------------------------------------------------------------------- - ! - ! ... trivial parallelization (splitting matrix B by columns) of DGEMM - ! - USE kinds, ONLY : DP - USE parallel_toolkit - ! - IMPLICIT NONE - ! - CHARACTER(LEN=1), INTENT(IN) :: transa, transb - INTEGER, INTENT(IN) :: m, n, k - COMPLEX(DP), INTENT(IN) :: alpha, beta - INTEGER, INTENT(IN) :: lda, ldb, ldc - COMPLEX(DP), INTENT(INOUT) :: a(lda,*), b(ldb,*), c(ldc,*) - INTEGER, INTENT(IN) :: comm - ! - ! ... quick return if possible - ! - IF ( m == 0 .OR. n == 0 .OR. & - ( ( alpha == 0.0_DP .OR. k == 0 ) .AND. beta == 1.0_DP ) ) RETURN - ! -!write(*,*) 'DEBUG: para_dgemm' - ! - CALL zrep_matmul_drv( transa, transb, m, n, k, & - alpha, a, lda, b, ldb, beta, c, ldc, comm ) - RETURN - ! -END SUBROUTINE para_zgemm diff --git a/quantum_espresso/kcp/CPV/chargedensity.f90 b/quantum_espresso/kcp/CPV/chargedensity.f90 deleted file mode 100644 index 26a4a58ec..000000000 --- a/quantum_espresso/kcp/CPV/chargedensity.f90 +++ /dev/null @@ -1,3470 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -! ---------------------------------------------- -! AB INITIO COSTANT PRESSURE MOLECULAR DYNAMICS -! ---------------------------------------------- - -#include "f_defs.h" - -!=----------------------------------------------------------------------=! - FUNCTION dft_total_charge_x( c, ngw, fi, n ) -!=----------------------------------------------------------------------=! - ! - ! This subroutine compute the Total Charge in reciprocal space - ! - - USE kinds, ONLY: DP - USE reciprocal_vectors, ONLY: gzero - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: ngw, n - COMPLEX(DP), INTENT(IN) :: c(:,:) - REAL (DP), INTENT(IN) :: fi(:) - ! - REAL(DP) :: dft_total_charge_x - ! - INTEGER :: ib - REAL(DP) :: rsum - COMPLEX(DP) :: wdot - COMPLEX(DP) :: ZDOTC - EXTERNAL ZDOTC - - rsum = 0.0d0 - - IF( gzero ) THEN - - DO ib = 1, n - wdot = ZDOTC( ( ngw - 1 ), c(2,ib), 1, c(2,ib), 1 ) - wdot = wdot + DBLE( c(1,ib) )**2 / 2.0d0 - rsum = rsum + fi(ib) * DBLE( wdot ) - END DO - - ELSE - - DO ib = 1, n - wdot = ZDOTC( ngw, c(1,ib), 1, c(1,ib), 1 ) - rsum = rsum + fi(ib) * DBLE( wdot ) - END DO - - END IF - - dft_total_charge_x = rsum - - RETURN - END FUNCTION dft_total_charge_x - - !----------------------------------------------------------------------- - SUBROUTINE rhoofr_cp_non_ortho & - ( nfi, c, cdual, irb, eigrb, bec, becdual, rhovan, rhor, rhog, rhos, enl, denl, ekin, dekin, tstress, ndwwf ) -!----------------------------------------------------------------------- -! -! this routine computes: -! rhor = normalized electron density in real space -! ekin = kinetic energy -! dekin = kinetic energy term of QM stress -! -! rhor(r) = (sum over ib) fi(ib) |psi(r,ib)|^2 -! -! Using quantities in scaled space -! rhor(r) = rhor(s) / Omega -! rhor(s) = (sum over ib) fi(ib) |psi(s,ib)|^2 -! -! fi(ib) = occupation numbers -! psi(r,ib) = psi(s,ib) / SQRT( Omega ) -! psi(s,ib) = INV_FFT ( c0(ig,ib) ) -! -! ib = index of band -! ig = index of G vector -! ---------------------------------------------- -! the normalized electron density rhor in real space -! the kinetic energy ekin -! subroutine uses complex fft so it computes two ft's -! simultaneously -! -! rho_i,ij = sum_n < beta_i,i | psi_n >< psi_n | beta_i,j > -! < psi_n | beta_i,i > = c_n(0) beta_i,i(0) + -! 2 sum_g> re(c_n*(g) (-i)**l beta_i,i(g) e^-ig.r_i) -! -! e_v = sum_i,ij rho_i,ij d^ion_is,ji -! - USE kinds, ONLY: DP - USE control_flags, ONLY: iprsta, thdyn, tpre, trhor, use_task_groups, program_name, & - & gamma_only, do_wf_cmplx !added:giovanni gamma_only, do_wf_cmplx - USE gvecp, ONLY: ngm - USE gvecs, ONLY: ngs, nps, nms - USE gvecw, ONLY: ngw - USE recvecs_indexes, ONLY: np, nm - USE reciprocal_vectors, ONLY: gstart - USE grid_dimensions, ONLY: nr1, nr2, nr3, nnrx - USE cell_base, ONLY: omega - USE smooth_grid_dimensions, ONLY: nr1sx, nr2sx, nnrsx - USE electrons_base, ONLY: n => nbsp, f, ispin, nspin - USE constants, ONLY: pi, fpi - USE mp, ONLY: mp_sum - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm, nogrp, me_image, ogrp_comm, nolist - USE funct, ONLY: dft_is_meta - USE cg_module, ONLY: tcg - USE cp_interfaces, ONLY: fwfft, invfft, stress_kin - USE fft_base, ONLY: dffts, dfftp - USE cp_interfaces, ONLY: checkrho, calrhovan - USE cdvan, ONLY: dbec, drhovan - USE cp_main_variables, ONLY: iprint_stdout, drhor, drhog - USE wannier_base, ONLY: iwf - USE cell_base, ONLY: a1, a2, a3 - USE twin_types !added:giovanni -! - IMPLICIT NONE - INTEGER nfi - type(twin_matrix) :: bec, becdual!(:,:) - REAL(DP) rhovan(:, :, : ) - REAL(DP) rhor(:,:) - REAL(DP) rhos(:,:) - REAL(DP) enl, ekin - REAL(DP) denl(3,3), dekin(6) - COMPLEX(DP) eigrb( :, : ) - COMPLEX(DP) rhog( :, : ) - COMPLEX(DP) c( :, : ), cdual( :, : ) - INTEGER irb( :, : ) - LOGICAL, OPTIONAL, INTENT(IN) :: tstress - INTEGER, OPTIONAL, INTENT(IN) :: ndwwf - - ! local variables - - INTEGER :: iss, isup, isdw, iss1, iss2, i, ir, ig - REAL(DP) :: rsumr(2), rsumg(2), sa1, sa2 - REAL(DP) :: rnegsum, rmin, rmax, rsum - REAL(DP), EXTERNAL :: enkin_non_ortho, ennl_non_ortho, enkin - REAL(DP), EXTERNAL :: dnrm2, ddot -! COMPLEX, EXTERNAL :: cdotu - COMPLEX(DP) :: ci,fp,fm - COMPLEX(DP), ALLOCATABLE :: psi(:), psis(:), psis2(:) - - LOGICAL :: ttstress - LOGICAL :: lgam - ! - - CALL start_clock( 'rhoofr' ) - - lgam=gamma_only.and..not.do_wf_cmplx - ttstress = tpre - IF( PRESENT( tstress ) ) ttstress = tstress - - ci = ( 0.0d0, 1.0d0 ) - - rhor = 0.d0 - rhos = 0.d0 - rhog = CMPLX(0.d0, 0.d0) - ! - ! calculation of kinetic energy ekin - ! - ekin = enkin_non_ortho( c, cdual, ngw, f, n) - ! - IF( ttstress ) THEN - ! - ! ... compute kinetic energy contribution - ! - CALL stress_kin( dekin, c, f ) - ! - END IF - - IF( PRESENT( ndwwf ) ) THEN - ! - ! called from WF, compute only of rhovan - ! - CALL calrhovan( rhovan, bec, iwf ) - ! - ELSE - ! - ! calculation of non-local energy - ! - enl = ennl_non_ortho( rhovan, bec, becdual ) -! write(6,*) "enl", enl !added:giovanni:debug -! write(6,*) "bec%cvec" , bec%cvec !added:giovanni:debug - ! - END IF - ! - IF( ttstress ) THEN - ! - CALL dennl( bec%rvec, dbec, drhovan, denl ) - ! - END IF - ! - ! warning! trhor and thdyn are not compatible yet! - ! - COMPUTE_CHARGE: IF( trhor .AND. ( .NOT. thdyn ) ) THEN - ! - ! non self-consistent calculation - ! charge density is read from unit 47 - ! - CALL read_rho( nspin, rhor ) - - ALLOCATE( psi( nnrx ) ) -! - IF(nspin.EQ.1)THEN - iss=1 - DO ir=1,nnrx - psi(ir)=CMPLX(rhor(ir,iss),0.d0) - END DO - CALL fwfft('Dense', psi, dfftp ) - DO ig=1,ngm - rhog(ig,iss)=psi(np(ig)) - END DO - ELSE !IF(lgam) THEN !!!### uncomment for k points - isup=1 - isdw=2 - DO ir=1,nnrx - psi(ir)=CMPLX(rhor(ir,isup),rhor(ir,isdw)) - END DO - CALL fwfft('Dense', psi, dfftp ) - DO ig=1,ngm - fp=psi(np(ig))+psi(nm(ig)) - fm=psi(np(ig))-psi(nm(ig)) - rhog(ig,isup)=0.5d0*CMPLX( DBLE(fp),AIMAG(fm)) - rhog(ig,isdw)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - END DO -! ELSE IF(.not.lgam) THEN !!!### uncomment for k points -! DO iss=1,2 !!!### uncomment for k points -! DO ir=1,nnrx !!!### uncomment for k points -! psi(ir)=CMPLX(rhor(ir,iss),0.d0) !!!### uncomment for k points -! END DO !!!### uncomment for k points -! CALL fwfft('Dense', psi, dfftp ) !!!### uncomment for k points -! DO ig=1,ngm !!!### uncomment for k points -! rhog(ig,iss) = psi(np(ig)) !!!### uncomment for k points -! END DO !!!### uncomment for k points -! ENDDO !!!### uncomment for k points - ENDIF - - DEALLOCATE( psi ) -! - ELSE - ! ================================================================== - ! self-consistent charge - ! ================================================================== - ! - ! important: if n is odd then nx must be .ge.n+1 and c(*,n+1)=0. - ! - - IF ( MOD( n, 2 ) /= 0 ) THEN - ! - IF( SIZE( c, 2 ) < n+1 ) & - CALL errore( ' rhoofr ', ' c second dimension too small ', SIZE( c, 2 ) ) - ! - c( :, n+1 ) = ( 0.d0, 0.d0 ) - ! - ENDIF - ! - IF( PRESENT( ndwwf ) ) THEN - ! - ! Wannier function, charge density from state iwf - ! - i = iwf - ! - psis = 0.D0 - DO ig=1,ngw - psis(nms(ig))=CONJG(c(ig,i)) - psis(nps(ig))=c(ig,i) - END DO - ! - CALL invfft('Wave',psis, dffts ) - ! - iss1=1 - sa1=f(i)/omega - DO ir=1,nnrsx - rhos(ir,iss1)=rhos(ir,iss1) + sa1*( DBLE(psis(ir)))**2 - END DO - ! - ELSE IF( use_task_groups ) THEN - ! - CALL loop_over_states_tg() - ! - ELSE - ! - ALLOCATE( psis( nnrsx ) ) - ALLOCATE( psis2(nnrsx) ) - ! - DO i = 1, n, 2 - ! - IF(lgam) THEN !added:giovanni - ! - CALL c2psi( psis, nnrsx, c( 1, i ), c( 1, i+1 ), ngw, 2 ) - CALL invfft('Wave',psis, dffts ) - ! - ! - CALL c2psi( psis2, nnrsx, cdual( 1, i ), cdual( 1, i+1 ), ngw, 2 ) - CALL invfft('Wave',psis2, dffts ) - ! - iss1 = ispin(i) - sa1 = f(i) / omega - IF ( i .NE. n ) THEN - iss2 = ispin(i+1) - sa2 = f(i+1) / omega - ELSE - iss2 = iss1 - sa2 = 0.0d0 - END IF - ! - DO ir = 1, nnrsx - rhos(ir,iss1) = rhos(ir,iss1) + sa1 * DBLE(psis2(ir))*DBLE(psis(ir)) - rhos(ir,iss2) = rhos(ir,iss2) + sa2 * AIMAG(psis2(ir))*AIMAG(psis(ir)) - END DO - - ! -!!!!!begin_added:giovanni - ELSE - CALL c2psi( psis, nnrsx, c( 1, i ), c( 1, i ), ngw, 0 ) - CALL invfft('Wave',psis, dffts ) - ! - ! - CALL c2psi( psis2, nnrsx, cdual( 1, i ), cdual( 1, i ), ngw, 0 ) - CALL invfft('Wave',psis2, dffts ) - ! - ! - iss1 = ispin(i) - sa1 = f(i) / omega -! IF ( i .NE. n ) THEN -! iss2 = ispin(i+1) -! sa2 = f(i+1) / omega -! ELSE -! iss2 = iss1 -! sa2 = 0.0d0 -! END IF - ! - DO ir = 1, nnrsx - rhos(ir,iss1) = rhos(ir,iss1) + sa1 * DBLE(CONJG(psis2(ir))*psis(ir)) - END DO - ! - IF(i.ne.n) then - - CALL c2psi( psis, nnrsx, c( 1, i+1 ), c( 1, i+1 ), ngw, 0 ) - CALL invfft('Wave',psis, dffts ) - ! - CALL c2psi( psis2, nnrsx, cdual( 1, i+1 ), cdual( 1, i+1 ), ngw, 0 ) - CALL invfft('Wave',psis2, dffts ) - ! - iss1 = ispin(i+1) - sa1 = f(i+1) / omega -! IF ( i .NE. n ) THEN -! iss2 = ispin(i+1) -! sa2 = f(i+1) / omega -! ELSE -! iss2 = iss1 -! sa2 = 0.0d0 -! END IF - DO ir = 1, nnrsx - rhos(ir,iss1) = rhos(ir,iss1) + sa1 * DBLE(CONJG(psis2(ir))*psis(ir)) - END DO - ENDIF - ENDIF -!!!!end_added:giovanni - END DO - ! - DEALLOCATE( psis ) - DEALLOCATE(psis2) - ! - END IF - ! - ! smooth charge in g-space is put into rhog(ig) - ! - ALLOCATE( psis( nnrsx ) ) - ! - IF(nspin.EQ.1)THEN - iss=1 - DO ir=1,nnrsx - psis(ir)=CMPLX(rhos(ir,iss),0.d0) - END DO - CALL fwfft('Smooth', psis, dffts ) - DO ig=1,ngs - rhog(ig,iss)=psis(nps(ig)) - END DO - ELSE !IF(lgam) THEN !!!### uncomment for k points - isup=1 - isdw=2 - DO ir=1,nnrsx - psis(ir)=CMPLX(rhos(ir,isup),rhos(ir,isdw)) - END DO - CALL fwfft('Smooth',psis, dffts ) - DO ig=1,ngs - fp= psis(nps(ig)) + psis(nms(ig)) - fm= psis(nps(ig)) - psis(nms(ig)) - rhog(ig,isup)=0.5d0*CMPLX( DBLE(fp),AIMAG(fm)) - rhog(ig,isdw)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - END DO -! ELSE IF(.not.lgam) THEN !!!### uncomment for k points -! DO iss=1,2 !!!### uncomment for k points -! DO ir=1,nnrsx !!!### uncomment for k points -! psis(ir)=CMPLX(rhos(ir,iss),0.d0) !!!### uncomment for k points -! END DO !!!### uncomment for k points -! CALL fwfft('Smooth', psis, dffts ) !!!### uncomment for k points -! DO ig=1,ngs !!!### uncomment for k points -! rhog(ig,iss)=psis(nps(ig)) !!!### uncomment for k points -! END DO !!!### uncomment for k points -! ENDDO !!!### uncomment for k points - ENDIF - ! - ALLOCATE( psi( nnrx ) ) - ! - IF( nspin .EQ. 1 ) THEN - ! - ! case nspin=1 - ! - iss=1 - psi (:) = CMPLX(0.d0, 0.d0) -! IF(lgam) then !added:giovanni !!!### uncomment for k points - DO ig=1,ngs - psi(nm(ig))=CONJG(rhog(ig,iss)) - psi(np(ig))= rhog(ig,iss) - END DO -!!!!!begin_added:giovanni -! ELSE !!!### uncomment for k points -! DO ig=1,ngs !!!### uncomment for k points -! ! psi(nm(ig))=CONJG(rhog(ig,iss)) !!!### uncomment for k points -! psi(np(ig))= rhog(ig,iss) !!!### uncomment for k points -! END DO !!!### uncomment for k points -! ENDIF !!!### uncomment for k points -!!!!!end_added:giovanni - CALL invfft('Dense',psi, dfftp ) - DO ir=1,nnrx - rhor(ir,iss)=DBLE(psi(ir)) - END DO - ! - ELSE - ! - ! case nspin=2 - ! -! IF(lgam) then !added:giovanni !!!### uncomment for k points - isup=1 - isdw=2 - psi (:) = CMPLX(0.d0, 0.d0) - DO ig=1,ngs - psi(nm(ig))=CONJG(rhog(ig,isup))+ci*CONJG(rhog(ig,isdw)) - psi(np(ig))=rhog(ig,isup)+ci*rhog(ig,isdw) - END DO - CALL invfft('Dense',psi, dfftp ) - DO ir=1,nnrx - rhor(ir,isup)= DBLE(psi(ir)) - rhor(ir,isdw)=AIMAG(psi(ir)) - END DO -!!!!!begin_added:giovanni -! ELSE !!!### uncomment for k points -! DO iss=1, 2 !!!### uncomment for k points -! psi (:) = (0.d0, 0.d0) !!!### uncomment for k points -! DO ig=1,ngs !!!### uncomment for k points -! psi(np(ig))=rhog(ig,iss) !!!### uncomment for k points -! END DO !!!### uncomment for k points -! CALL invfft('Dense',psi, dfftp ) !!!### uncomment for k points -! DO ir=1,nnrx !!!### uncomment for k points -! rhor(ir,iss)= DBLE(psi(ir)) !!!### uncomment for k points -! ! rhor(ir,isdw)=AIMAG(psi(ir)) !!!### uncomment for k points -! END DO !!!### uncomment for k points -! ENDDO !!!### uncomment for k points -! ENDIF !!!### uncomment for k points -!!!!!end_added:giovanni - ENDIF - ! - IF ( dft_is_meta() ) CALL kedtauofr_meta( c, psi, SIZE( psi ), psis, SIZE( psis ) ) ! METAGGA - ! - DEALLOCATE( psi ) - DEALLOCATE( psis ) - ! - ! add vanderbilt contribution to the charge density - ! drhov called before rhov because input rho must be the smooth part - ! - ! - IF ( ttstress .AND. program_name == 'CP90' ) & - CALL drhov( irb, eigrb, rhovan, rhog, rhor, drhog, drhor ) - ! - CALL rhov( irb, eigrb, rhovan, rhog, rhor, lgam ) - - ENDIF COMPUTE_CHARGE -! - IF( PRESENT( ndwwf ) ) THEN - ! - CALL old_write_rho( ndwwf, nspin, rhor, a1, a2, a3 ) - ! - END IF -! -! here to check the integral of the charge density -! - IF( ( iprsta >= 2 ) .OR. ( nfi == 0 ) .OR. & - ( MOD(nfi, iprint_stdout) == 0 ) .AND. ( .NOT. tcg ) ) THEN - - IF( iprsta >= 2 ) THEN - CALL checkrho( nnrx, nspin, rhor, rmin, rmax, rsum, rnegsum ) - rnegsum = rnegsum * omega / DBLE(nr1*nr2*nr3) - rsum = rsum * omega / DBLE(nr1*nr2*nr3) - WRITE( stdout,'(a,4(1x,f12.6))') & - & ' rhoofr: rmin rmax rnegsum rsum ',rmin,rmax,rnegsum,rsum - END IF - - CALL sum_charge( rsumg, rsumr ) - - IF ( nspin == 1 ) THEN - WRITE( stdout, 10) rsumg(1), rsumr(1) - ELSE - WRITE( stdout, 20) rsumg(1), rsumr(1), rsumg(2), rsumr(2) - ENDIF - - ENDIF - -10 FORMAT( /, 3X, 'from rhoofr: total integrated electronic density', & - & /, 3X, 'in g-space = ', f11.6, 3x, 'in r-space =', f11.6 ) -20 FORMAT( /, 3X, 'from rhoofr: total integrated electronic density', & - & /, 3X, 'spin up', & - & /, 3X, 'in g-space = ', f11.6, 3x, 'in r-space =', f11.6 , & - & /, 3X, 'spin down', & - & /, 3X, 'in g-space = ', f11.6, 3x, 'in r-space =', f11.6 ) -! - CALL stop_clock( 'rhoofr' ) - -! - RETURN - - - CONTAINS - ! - ! - SUBROUTINE sum_charge( rsumg, rsumr ) - ! - REAL(DP), INTENT(OUT) :: rsumg( : ) - REAL(DP), INTENT(OUT) :: rsumr( : ) - INTEGER :: iss - ! - DO iss=1,nspin - rsumg(iss)=omega*DBLE(rhog(1,iss)) - rsumr(iss)=SUM(rhor(:,iss),1)*omega/DBLE(nr1*nr2*nr3) - END DO - - IF (gstart.NE.2) THEN - ! in the parallel case, only one processor has G=0 ! - DO iss=1,nspin - rsumg(iss)=0.0d0 - END DO - END IF - - CALL mp_sum( rsumg( 1:nspin ), intra_image_comm ) - CALL mp_sum( rsumr( 1:nspin ), intra_image_comm ) - - RETURN - END SUBROUTINE - - ! - ! - - SUBROUTINE loop_over_states_tg - ! - USE parallel_include - ! - ! MAIN LOOP OVER THE EIGENSTATES - ! - This loop is also parallelized within the task-groups framework - ! - Each group works on a number of eigenstates in parallel - ! - IMPLICIT NONE - ! - INTEGER :: from, ii, eig_index, eig_offset - REAL(DP), ALLOCATABLE :: tmp_rhos(:,:) - - ALLOCATE( psis( dffts%nnrx * nogrp ) ) - ! - ALLOCATE( tmp_rhos ( nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ), nspin ) ) - ! - tmp_rhos = 0_DP - - do i = 1, n, 2*nogrp - ! - ! Initialize wave-functions in Fourier space (to be FFTed) - ! The size of psis is nnr: which is equal to the total number - ! of local fourier coefficients. - ! -!$omp parallel default(shared), private(eig_offset, ig, eig_index ) - ! -!$omp do - do ig = 1, SIZE(psis) - psis (ig) = CMPLX(0.d0, 0.d0) - end do - ! - ! Loop for all local g-vectors (ngw) - ! c: stores the Fourier expansion coefficients - ! the i-th column of c corresponds to the i-th state - ! nms and nps matrices: hold conversion indices form 3D to - ! 1-D vectors. Columns along the z-direction are stored contigiously - ! - ! The outer loop goes through i : i + 2*NOGRP to cover - ! 2*NOGRP eigenstates at each iteration - ! - eig_offset = 0 - - do eig_index = 1, 2*nogrp, 2 - ! - ! here we pack 2*nogrp electronic states in the psis array - ! - IF ( ( i + eig_index - 1 ) <= n ) THEN - ! - ! Outer loop for eigenvalues - ! The eig_index loop is executed only ONCE when NOGRP=1. - ! Equivalent to the case with no task-groups - ! dfft%nsw(me) holds the number of z-sticks for the current processor per wave-function - ! We can either send these in the group with an mpi_allgather...or put the - ! in the PSIS vector (in special positions) and send them with them. - ! Otherwise we can do this once at the beginning, before the loop. - ! we choose to do the latter one. - -!$omp do - do ig=1,ngw - psis(nms(ig)+eig_offset*dffts%nnrx)=conjg(c(ig,i+eig_index-1))+ci*conjg(c(ig,i+eig_index)) - psis(nps(ig)+eig_offset*dffts%nnrx)=c(ig,i+eig_index-1)+ci*c(ig,i+eig_index) - end do - ! - eig_offset = eig_offset + 1 - ! - ENDIF - ! - end do -!$omp end parallel - - ! 2*NOGRP are trasformed at the same time - ! psis: holds the fourier coefficients of the current proccesor - ! for eigenstates i and i+2*NOGRP-1 - ! - CALL invfft( 'Wave', psis, dffts ) - ! - ! Now the first proc of the group holds the first two bands - ! of the 2*nogrp bands that we are processing at the same time, - ! the second proc. holds the third and fourth band - ! and so on - ! - ! Compute the proper factor for each band - ! - DO ii = 1, nogrp - IF( nolist( ii ) == me_image ) EXIT - END DO - ! - ! Remember two bands are packed in a single array : - ! proc 0 has bands ibnd and ibnd+1 - ! proc 1 has bands ibnd+2 and ibnd+3 - ! .... - ! - ii = 2 * ii - 1 - - IF( ii + i - 1 < n ) THEN - iss1=ispin( ii + i - 1 ) - sa1 =f( ii + i - 1 )/omega - iss2=ispin( ii + i ) - sa2 =f( ii + i )/omega - ELSE IF( ii + i - 1 == n ) THEN - iss1=ispin( ii + i - 1 ) - sa1 =f( ii + i - 1 )/omega - iss2=iss1 - sa2=0.0d0 - ELSE - iss1=ispin( n ) - sa1 = 0.0d0 - iss2=iss1 - sa2 =0.0d0 - END IF - ! - !Compute local charge density - ! - !This is the density within each orbital group...so it - !coresponds to 1 eignestate for each group and there are - !NOGRP such groups. Thus, during the loop across all - !occupied eigenstates, the total charge density must me - !accumulated across all different orbital groups. - ! - - !This loop goes through all components of charge density that is local - !to each processor. In the original code this is nnrsx. In the task-groups - !code this should be equal to the total number of planes - ! - - IF( nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ) > SIZE( psis ) ) & - CALL errore( ' rhoofr ', ' psis size too low ', nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ) ) - -!$omp parallel do default(shared) - do ir = 1, nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ) - tmp_rhos(ir,iss1) = tmp_rhos(ir,iss1) + sa1*( real(psis(ir)))**2 - tmp_rhos(ir,iss2) = tmp_rhos(ir,iss2) + sa2*(aimag(psis(ir)))**2 - end do - ! - END DO - - IF ( nogrp > 1 ) THEN - CALL mp_sum( tmp_rhos, gid = ogrp_comm ) - ENDIF - ! - !BRING CHARGE DENSITY BACK TO ITS ORIGINAL POSITION - ! - !If the current processor is not the "first" processor in its - !orbital group then does a local copy (reshuffling) of its data - ! - from = 1 - DO ii = 1, nogrp - IF ( nolist( ii ) == me_image ) EXIT !Exit the loop - from = from + nr1sx*nr2sx*dffts%npp( nolist( ii ) + 1 )! From where to copy initially - ENDDO - ! - DO ir = 1, nspin - CALL dcopy( nr1sx*nr2sx*dffts%npp(me_image+1), tmp_rhos(from,ir), 1, rhos(1,ir), 1) - ENDDO - - DEALLOCATE( tmp_rhos ) - DEALLOCATE( psis ) - - RETURN - END SUBROUTINE loop_over_states_tg - -!----------------------------------------------------------------------- - END SUBROUTINE rhoofr_cp_non_ortho -!----------------------------------------------------------------------- - - -!----------------------------------------------------------------------- - SUBROUTINE rhoofr_cp_ortho & - ( nfi, c, irb, eigrb, bec, rhovan, rhor, rhog, rhos, enl, denl, ekin, dekin, tstress, ndwwf ) -!----------------------------------------------------------------------- -! -! this routine computes: -! rhor = normalized electron density in real space -! ekin = kinetic energy -! dekin = kinetic energy term of QM stress -! -! rhor(r) = (sum over ib) fi(ib) |psi(r,ib)|^2 -! -! Using quantities in scaled space -! rhor(r) = rhor(s) / Omega -! rhor(s) = (sum over ib) fi(ib) |psi(s,ib)|^2 -! -! fi(ib) = occupation numbers -! psi(r,ib) = psi(s,ib) / SQRT( Omega ) -! psi(s,ib) = INV_FFT ( c0(ig,ib) ) -! -! ib = index of band -! ig = index of G vector -! ---------------------------------------------- -! the normalized electron density rhor in real space -! the kinetic energy ekin -! subroutine uses complex fft so it computes two ft's -! simultaneously -! -! rho_i,ij = sum_n < beta_i,i | psi_n >< psi_n | beta_i,j > -! < psi_n | beta_i,i > = c_n(0) beta_i,i(0) + -! 2 sum_g> re(c_n*(g) (-i)**l beta_i,i(g) e^-ig.r_i) -! -! e_v = sum_i,ij rho_i,ij d^ion_is,ji -! - USE kinds, ONLY: DP - USE control_flags, ONLY: iprsta, thdyn, tpre, trhor, use_task_groups, program_name, & - & gamma_only, do_wf_cmplx !added:giovanni gamma_only, do_wf_cmplx - USE gvecp, ONLY: ngm - USE gvecs, ONLY: ngs, nps, nms - USE gvecw, ONLY: ngw - USE recvecs_indexes, ONLY: np, nm - USE reciprocal_vectors, ONLY: gstart - USE grid_dimensions, ONLY: nr1, nr2, nr3, nnrx - USE cell_base, ONLY: omega - USE smooth_grid_dimensions, ONLY: nr1sx, nr2sx, nnrsx - USE electrons_base, ONLY: n => nbsp, f, ispin, nspin - USE constants, ONLY: pi, fpi - USE mp, ONLY: mp_sum - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm, nogrp, me_image, ogrp_comm, nolist - USE funct, ONLY: dft_is_meta - USE cg_module, ONLY: tcg - USE cp_interfaces, ONLY: fwfft, invfft, stress_kin - USE fft_base, ONLY: dffts, dfftp - USE cp_interfaces, ONLY: checkrho, calrhovan - USE cdvan, ONLY: dbec, drhovan - USE cp_main_variables, ONLY: iprint_stdout, drhor, drhog - USE wannier_base, ONLY: iwf - USE cell_base, ONLY: a1, a2, a3 - USE twin_types !added:giovanni -! - IMPLICIT NONE - INTEGER nfi - type(twin_matrix) :: bec!(:,:) - REAL(DP) rhovan(:, :, : ) - REAL(DP) rhor(:,:) - REAL(DP) rhos(:,:) - REAL(DP) enl, ekin - REAL(DP) denl(3,3), dekin(6) - COMPLEX(DP) eigrb( :, : ) - COMPLEX(DP) rhog( :, : ) - COMPLEX(DP) c( :, : ) - INTEGER irb( :, : ) - LOGICAL, OPTIONAL, INTENT(IN) :: tstress - INTEGER, OPTIONAL, INTENT(IN) :: ndwwf - - ! local variables - - INTEGER :: iss, isup, isdw, iss1, iss2, i, ir, ig !added:giovanni j - REAL(DP) :: rsumr(2), rsumg(2), sa1, sa2 - REAL(DP) :: rnegsum, rmin, rmax, rsum - REAL(DP), EXTERNAL :: enkin, ennl - REAL(DP), EXTERNAL :: dnrm2, ddot -! COMPLEX, EXTERNAL :: cdotu - COMPLEX(DP) :: ci,fp,fm - COMPLEX(DP), ALLOCATABLE :: psi(:), psis(:) - - LOGICAL :: ttstress - LOGICAL :: lgam - ! - - CALL start_clock( 'rhoofr' ) - - lgam=gamma_only.and..not.do_wf_cmplx - ttstress = tpre - IF( PRESENT( tstress ) ) ttstress = tstress - - ci = CMPLX( 0.0d0, 1.0d0 ) - - rhor = 0.d0 - rhos = 0.d0 - rhog = CMPLX(0.d0, 0.d0) - ! - ! calculation of kinetic energy ekin - ! - ekin = enkin( c, ngw, f, n) - ! - IF( ttstress ) THEN - ! - ! ... compute kinetic energy contribution - ! - CALL stress_kin( dekin, c, f ) - ! - END IF - - IF( PRESENT( ndwwf ) ) THEN - ! - ! called from WF, compute only of rhovan - ! - CALL calrhovan( rhovan, bec, iwf ) - ! - ELSE - ! - ! calculation of non-local energy - ! - enl = ennl( rhovan, bec ) - ! - END IF - ! - IF( ttstress ) THEN - ! - CALL dennl( bec%rvec, dbec, drhovan, denl ) - ! - END IF - ! - ! warning! trhor and thdyn are not compatible yet! - ! - COMPUTE_CHARGE: IF( trhor .AND. ( .NOT. thdyn ) ) THEN - ! - ! non self-consistent calculation - ! charge density is read from unit 47 - ! - CALL read_rho( nspin, rhor ) - - ALLOCATE( psi( nnrx ) ) - ! - IF(nspin.EQ.1)THEN - iss=1 - DO ir=1,nnrx - psi(ir)=CMPLX(rhor(ir,iss),0.d0) - END DO - CALL fwfft('Dense', psi, dfftp ) - DO ig=1,ngm - rhog(ig,iss)=psi(np(ig)) - END DO - ELSE !IF(lgam) THEN !!!### uncomment for k points - isup=1 - isdw=2 - DO ir=1,nnrx - psi(ir)=CMPLX(rhor(ir,isup),rhor(ir,isdw)) - END DO - CALL fwfft('Dense', psi, dfftp ) - DO ig=1,ngm - fp=psi(np(ig))+psi(nm(ig)) - fm=psi(np(ig))-psi(nm(ig)) - rhog(ig,isup)=0.5d0*CMPLX( DBLE(fp),AIMAG(fm)) - rhog(ig,isdw)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - END DO - ENDIF - ! - DEALLOCATE( psi ) - ! - ELSE - ! ================================================================== - ! self-consistent charge - ! ================================================================== - ! - ! important: if n is odd then nx must be .ge.n+1 and c(*,n+1)=0. - ! - - IF ( MOD( n, 2 ) /= 0 ) THEN - ! - IF( SIZE( c, 2 ) < n+1 ) & - CALL errore( ' rhoofr ', ' c second dimension too small ', SIZE( c, 2 ) ) - ! - c( :, n+1 ) = CMPLX( 0.d0, 0.d0 ) - ! - ENDIF - ! - IF( PRESENT( ndwwf ) ) THEN - ! - ! Wannier function, charge density from state iwf - ! - i = iwf - ! - psis = 0.D0 - DO ig=1,ngw - psis(nms(ig))=CONJG(c(ig,i)) - psis(nps(ig))=c(ig,i) - END DO - ! - CALL invfft('Wave',psis, dffts ) - ! - iss1=1 - sa1=f(i)/omega - DO ir=1,nnrsx - rhos(ir,iss1)=rhos(ir,iss1) + sa1*( DBLE(psis(ir)))**2 - END DO - ! - ELSE IF( use_task_groups ) THEN - ! - CALL loop_over_states_tg() - ! - ELSE - ! - ALLOCATE( psis( nnrsx ) ) - ! - DO i = 1, n, 2 - ! - IF(lgam) THEN !added:giovanni - ! - CALL c2psi( psis, nnrsx, c( 1, i ), c( 1, i+1 ), ngw, 2 ) - CALL invfft('Wave',psis, dffts ) - ! - ! - iss1 = ispin(i) - sa1 = f(i) / omega - IF ( i .NE. n ) THEN - iss2 = ispin(i+1) - sa2 = f(i+1) / omega - ELSE - iss2 = iss1 - sa2 = 0.0d0 - END IF - ! - DO ir = 1, nnrsx - rhos(ir,iss1) = rhos(ir,iss1) + sa1 * ( DBLE(psis(ir)))**2 - rhos(ir,iss2) = rhos(ir,iss2) + sa2 * (AIMAG(psis(ir)))**2 - END DO - ! - ELSE - ! - CALL c2psi( psis, nnrsx, c( 1, i ), c( 1, i ), ngw, 0 ) - ! - CALL invfft('Wave',psis, dffts ) - ! - ! - iss1 = ispin(i) - sa1 = f(i) / omega - ! -! DO ir = 1, nnrsx -! rhos(ir,iss1) = rhos(ir,iss1) + sa1 *(ABS(psis(ir))**2) -! END DO - ! - DO ir = 1, nnrsx - rhos(ir,iss1) = rhos(ir,iss1) + sa1 *(DBLE(psis(ir))**2+AIMAG(psis(ir))**2) - END DO - ! - IF(i.ne.n) then - ! - CALL c2psi( psis, nnrsx, c( 1, i+1 ), c( 1, i+1 ), ngw, 0 ) - CALL invfft('Wave',psis, dffts ) - ! - ! - iss1 = ispin(i+1) - sa1 = f(i+1) / omega - ! - DO ir = 1, nnrsx - ! - rhos(ir,iss1) = rhos(ir,iss1) + sa1 *( (DBLE(psis(ir))**2+AIMAG(psis(ir))**2)) - ! - END DO - - ENDIF - - ENDIF -!!!!end_added:giovanni - END DO - ! - DEALLOCATE( psis ) - ! - END IF - ! - ! smooth charge in g-space is put into rhog(ig) - ! - ALLOCATE( psis( nnrsx ) ) - ! - IF(nspin.EQ.1)THEN - iss=1 - DO ir=1,nnrsx - psis(ir)=CMPLX(rhos(ir,iss),0.d0) - END DO - CALL fwfft('Smooth', psis, dffts ) - DO ig=1,ngs - rhog(ig,iss)=psis(nps(ig)) - END DO - ELSE !IF(lgam) THEN !!!### uncomment for k points - isup=1 - isdw=2 - DO ir=1,nnrsx - psis(ir)=CMPLX(rhos(ir,isup),rhos(ir,isdw)) - END DO - CALL fwfft('Smooth',psis, dffts ) - DO ig=1,ngs - fp= psis(nps(ig)) + psis(nms(ig)) - fm= psis(nps(ig)) - psis(nms(ig)) - rhog(ig,isup)=0.5d0*CMPLX( DBLE(fp),AIMAG(fm)) - rhog(ig,isdw)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - END DO -! ELSE IF(.not.lgam) THEN !!!### uncomment for k points -! DO iss=1,2 !!!### uncomment for k points -! DO ir=1,nnrsx !!!### uncomment for k points -! psis(ir)=CMPLX(rhos(ir,iss),0.d0) !!!### uncomment for k points -! END DO !!!### uncomment for k points -! CALL fwfft('Smooth', psis, dffts ) !!!### uncomment for k points -! DO ig=1,ngs !!!### uncomment for k points -! rhog(ig,iss)=psis(nps(ig)) !!!### uncomment for k points -! END DO !!!### uncomment for k points -! ENDDO !!!### uncomment for k points - ENDIF - ! - ALLOCATE( psi( nnrx ) ) - ! - IF( nspin .EQ. 1 ) THEN - ! - ! case nspin=1 - ! - iss=1 - psi (:) = CMPLX(0.d0, 0.d0) -! IF(lgam) then !added:giovanni !!!### uncomment for k points - DO ig=1,ngs - psi(nm(ig))=CONJG(rhog(ig,iss)) - psi(np(ig))= rhog(ig,iss) - END DO -!!!!!begin_added:giovanni -! ELSE !!!### uncomment for k points -! DO ig=1,ngs !!!### uncomment for k points -! ! psi(nm(ig))=CONJG(rhog(ig,iss)) !!!### uncomment for k points -! psi(np(ig))= rhog(ig,iss) !!!### uncomment for k points -! END DO !!!### uncomment for k points -! ENDIF !!!### uncomment for k points -!!!!!end_added:giovanni - CALL invfft('Dense',psi, dfftp ) - DO ir=1,nnrx - rhor(ir,iss)=DBLE(psi(ir)) - END DO - ! - ELSE - ! - ! case nspin=2 - ! -! IF(lgam) then !added:giovanni !!!### uncomment for k points - isup=1 - isdw=2 - psi (:) = CMPLX(0.d0, 0.d0) - ! - DO ig=1,ngs - ! - psi(nm(ig))=CONJG(rhog(ig,isup))+ci*CONJG(rhog(ig,isdw)) - psi(np(ig))=rhog(ig,isup)+ci*rhog(ig,isdw) - ! - END DO - ! - CALL invfft('Dense',psi, dfftp ) - ! - DO ir=1,nnrx - ! - rhor(ir,isup)= DBLE(psi(ir)) - rhor(ir,isdw)=AIMAG(psi(ir)) - ! - END DO -!!!!!begin_added:giovanni -! ELSE !!!### uncomment for k points -! DO iss=1, 2 !!!### uncomment for k points -! psi (:) = (0.d0, 0.d0) !!!### uncomment for k points -! DO ig=1,ngs !!!### uncomment for k points -! psi(np(ig))=rhog(ig,iss) !!!### uncomment for k points -! END DO !!!### uncomment for k points -! CALL invfft('Dense',psi, dfftp ) !!!### uncomment for k points -! DO ir=1,nnrx !!!### uncomment for k points -! rhor(ir,iss)= DBLE(psi(ir)) !!!### uncomment for k points -! ! rhor(ir,isdw)=AIMAG(psi(ir)) !!!### uncomment for k points -! END DO !!!### uncomment for k points -! ENDDO !!!### uncomment for k points -! ENDIF !!!### uncomment for k points -!!!!!end_added:giovanni - ENDIF - ! - IF ( dft_is_meta() ) CALL kedtauofr_meta( c, psi, SIZE( psi ), psis, SIZE( psis ) ) ! METAGGA - ! - DEALLOCATE( psi ) - DEALLOCATE( psis ) - ! - ! add vanderbilt contribution to the charge density - ! drhov called before rhov because input rho must be the smooth part - ! - ! - IF ( ttstress .AND. program_name == 'CP90' ) & - CALL drhov( irb, eigrb, rhovan, rhog, rhor, drhog, drhor ) - ! - CALL rhov( irb, eigrb, rhovan, rhog, rhor, lgam ) - ENDIF COMPUTE_CHARGE -! - IF( PRESENT( ndwwf ) ) THEN - ! - CALL old_write_rho( ndwwf, nspin, rhor, a1, a2, a3 ) - ! - END IF -! -! here to check the integral of the charge density -! - IF( ( iprsta >= 2 ) .OR. ( nfi == 0 ) .OR. & - ( MOD(nfi, iprint_stdout) == 0 ) .AND. ( .NOT. tcg ) ) THEN - - IF( iprsta >= 2 ) THEN - CALL checkrho( nnrx, nspin, rhor, rmin, rmax, rsum, rnegsum ) - rnegsum = rnegsum * omega / DBLE(nr1*nr2*nr3) - rsum = rsum * omega / DBLE(nr1*nr2*nr3) - WRITE( stdout,'(a,4(1x,f12.6))') & - & ' rhoofr: rmin rmax rnegsum rsum ',rmin,rmax,rnegsum,rsum - END IF - - CALL sum_charge( rsumg, rsumr ) - - IF ( nspin == 1 ) THEN - WRITE( stdout, 10) rsumg(1), rsumr(1) - ELSE - WRITE( stdout, 20) rsumg(1), rsumr(1), rsumg(2), rsumr(2) - ENDIF - - ENDIF - -10 FORMAT( /, 3X, 'from rhoofr: total integrated electronic density', & - & /, 3X, 'in g-space = ', f11.6, 3x, 'in r-space =', f11.6 ) -20 FORMAT( /, 3X, 'from rhoofr: total integrated electronic density', & - & /, 3X, 'spin up', & - & /, 3X, 'in g-space = ', f11.6, 3x, 'in r-space =', f11.6 , & - & /, 3X, 'spin down', & - & /, 3X, 'in g-space = ', f11.6, 3x, 'in r-space =', f11.6 ) -! - CALL stop_clock( 'rhoofr' ) - -! - RETURN - - - CONTAINS - ! - ! - SUBROUTINE sum_charge( rsumg, rsumr ) - ! - REAL(DP), INTENT(OUT) :: rsumg( : ) - REAL(DP), INTENT(OUT) :: rsumr( : ) - INTEGER :: iss - ! - DO iss=1,nspin - rsumg(iss)=omega*DBLE(rhog(1,iss)) - rsumr(iss)=SUM(rhor(:,iss),1)*omega/DBLE(nr1*nr2*nr3) - END DO - - IF (gstart.NE.2) THEN - ! in the parallel case, only one processor has G=0 ! - DO iss=1,nspin - rsumg(iss)=0.0d0 - END DO - END IF - - CALL mp_sum( rsumg( 1:nspin ), intra_image_comm ) - CALL mp_sum( rsumr( 1:nspin ), intra_image_comm ) - - RETURN - END SUBROUTINE - - ! - ! - - SUBROUTINE loop_over_states_tg - ! - USE parallel_include - ! - ! MAIN LOOP OVER THE EIGENSTATES - ! - This loop is also parallelized within the task-groups framework - ! - Each group works on a number of eigenstates in parallel - ! - IMPLICIT NONE - ! - INTEGER :: from, ii, eig_index, eig_offset - REAL(DP), ALLOCATABLE :: tmp_rhos(:,:) - - ALLOCATE( psis( dffts%nnrx * nogrp ) ) - ! - ALLOCATE( tmp_rhos ( nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ), nspin ) ) - ! - tmp_rhos = 0_DP - - do i = 1, n, 2*nogrp - ! - ! Initialize wave-functions in Fourier space (to be FFTed) - ! The size of psis is nnr: which is equal to the total number - ! of local fourier coefficients. - ! -!$omp parallel default(shared), private(eig_offset, ig, eig_index ) - ! -!$omp do - do ig = 1, SIZE(psis) - psis (ig) = CMPLX(0.d0, 0.d0) - end do - ! - ! Loop for all local g-vectors (ngw) - ! c: stores the Fourier expansion coefficients - ! the i-th column of c corresponds to the i-th state - ! nms and nps matrices: hold conversion indices form 3D to - ! 1-D vectors. Columns along the z-direction are stored contigiously - ! - ! The outer loop goes through i : i + 2*NOGRP to cover - ! 2*NOGRP eigenstates at each iteration - ! - eig_offset = 0 - - do eig_index = 1, 2*nogrp, 2 - ! - ! here we pack 2*nogrp electronic states in the psis array - ! - IF ( ( i + eig_index - 1 ) <= n ) THEN - ! - ! Outer loop for eigenvalues - ! The eig_index loop is executed only ONCE when NOGRP=1. - ! Equivalent to the case with no task-groups - ! dfft%nsw(me) holds the number of z-sticks for the current processor per wave-function - ! We can either send these in the group with an mpi_allgather...or put the - ! in the PSIS vector (in special positions) and send them with them. - ! Otherwise we can do this once at the beginning, before the loop. - ! we choose to do the latter one. - -!$omp do - do ig=1,ngw - psis(nms(ig)+eig_offset*dffts%nnrx)=conjg(c(ig,i+eig_index-1))+ci*conjg(c(ig,i+eig_index)) - psis(nps(ig)+eig_offset*dffts%nnrx)=c(ig,i+eig_index-1)+ci*c(ig,i+eig_index) - end do - ! - eig_offset = eig_offset + 1 - ! - ENDIF - ! - end do -!$omp end parallel - - ! 2*NOGRP are trasformed at the same time - ! psis: holds the fourier coefficients of the current proccesor - ! for eigenstates i and i+2*NOGRP-1 - ! - CALL invfft( 'Wave', psis, dffts ) - ! - ! Now the first proc of the group holds the first two bands - ! of the 2*nogrp bands that we are processing at the same time, - ! the second proc. holds the third and fourth band - ! and so on - ! - ! Compute the proper factor for each band - ! - DO ii = 1, nogrp - IF( nolist( ii ) == me_image ) EXIT - END DO - ! - ! Remember two bands are packed in a single array : - ! proc 0 has bands ibnd and ibnd+1 - ! proc 1 has bands ibnd+2 and ibnd+3 - ! .... - ! - ii = 2 * ii - 1 - - IF( ii + i - 1 < n ) THEN - iss1=ispin( ii + i - 1 ) - sa1 =f( ii + i - 1 )/omega - iss2=ispin( ii + i ) - sa2 =f( ii + i )/omega - ELSE IF( ii + i - 1 == n ) THEN - iss1=ispin( ii + i - 1 ) - sa1 =f( ii + i - 1 )/omega - iss2=iss1 - sa2=0.0d0 - ELSE - iss1=ispin( n ) - sa1 = 0.0d0 - iss2=iss1 - sa2 =0.0d0 - END IF - ! - !Compute local charge density - ! - !This is the density within each orbital group...so it - !coresponds to 1 eignestate for each group and there are - !NOGRP such groups. Thus, during the loop across all - !occupied eigenstates, the total charge density must me - !accumulated across all different orbital groups. - ! - - !This loop goes through all components of charge density that is local - !to each processor. In the original code this is nnrsx. In the task-groups - !code this should be equal to the total number of planes - ! - - IF( nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ) > SIZE( psis ) ) & - CALL errore( ' rhoofr ', ' psis size too low ', nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ) ) - -!$omp parallel do default(shared) - do ir = 1, nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ) - tmp_rhos(ir,iss1) = tmp_rhos(ir,iss1) + sa1*( real(psis(ir)))**2 - tmp_rhos(ir,iss2) = tmp_rhos(ir,iss2) + sa2*(aimag(psis(ir)))**2 - end do - ! - END DO - - IF ( nogrp > 1 ) THEN - CALL mp_sum( tmp_rhos, gid = ogrp_comm ) - ENDIF - ! - !BRING CHARGE DENSITY BACK TO ITS ORIGINAL POSITION - ! - !If the current processor is not the "first" processor in its - !orbital group then does a local copy (reshuffling) of its data - ! - from = 1 - DO ii = 1, nogrp - IF ( nolist( ii ) == me_image ) EXIT !Exit the loop - from = from + nr1sx*nr2sx*dffts%npp( nolist( ii ) + 1 )! From where to copy initially - ENDDO - ! - DO ir = 1, nspin - CALL dcopy( nr1sx*nr2sx*dffts%npp(me_image+1), tmp_rhos(from,ir), 1, rhos(1,ir), 1) - ENDDO - - DEALLOCATE( tmp_rhos ) - DEALLOCATE( psis ) - - RETURN - END SUBROUTINE loop_over_states_tg - -!----------------------------------------------------------------------- - END SUBROUTINE rhoofr_cp_ortho -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- - SUBROUTINE rhoofr_cp_ortho_new & !this subroutine works with empty states - ( nx, n, nudx, f, ispin, iupdwn, nupdwn, nspin, nfi, c, irb, & - eigrb, bec, rhovan, rhor, rhog, rhos, enl, denl, ekin, dekin, & - tstress, ndwwf ) -!----------------------------------------------------------------------- -! -! this routine computes: -! rhor = normalized electron density in real space -! ekin = kinetic energy -! dekin = kinetic energy term of QM stress -! -! rhor(r) = (sum over ib) fi(ib) |psi(r,ib)|^2 -! -! Using quantities in scaled space -! rhor(r) = rhor(s) / Omega -! rhor(s) = (sum over ib) fi(ib) |psi(s,ib)|^2 -! -! fi(ib) = occupation numbers -! psi(r,ib) = psi(s,ib) / SQRT( Omega ) -! psi(s,ib) = INV_FFT ( c0(ig,ib) ) -! -! ib = index of band -! ig = index of G vector -! ---------------------------------------------- -! the normalized electron density rhor in real space -! the kinetic energy ekin -! subroutine uses complex fft so it computes two ft's -! simultaneously -! -! rho_i,ij = sum_n < beta_i,i | psi_n >< psi_n | beta_i,j > -! < psi_n | beta_i,i > = c_n(0) beta_i,i(0) + -! 2 sum_g> re(c_n*(g) (-i)**l beta_i,i(g) e^-ig.r_i) -! -! e_v = sum_i,ij rho_i,ij d^ion_is,ji -! - USE kinds, ONLY: DP - USE control_flags, ONLY: iprsta, thdyn, tpre, trhor, use_task_groups, program_name, & - & gamma_only, do_wf_cmplx !added:giovanni gamma_only, do_wf_cmplx - USE ions_base, ONLY: nat - USE gvecp, ONLY: ngm - USE gvecs, ONLY: ngs, nps, nms - USE gvecb, ONLY: ngb - USE gvecw, ONLY: ngw - USE recvecs_indexes, ONLY: np, nm - USE reciprocal_vectors, ONLY: gstart - USE uspp_param, ONLY: nhm - USE grid_dimensions, ONLY: nr1, nr2, nr3, nnrx - USE cell_base, ONLY: omega - USE smooth_grid_dimensions, ONLY: nr1sx, nr2sx, nnrsx - USE constants, ONLY: pi, fpi - USE mp, ONLY: mp_sum - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm, nogrp, me_image, ogrp_comm, nolist - USE funct, ONLY: dft_is_meta - USE cg_module, ONLY: tcg - USE cp_interfaces, ONLY: fwfft, invfft, stress_kin - USE fft_base, ONLY: dffts, dfftp - USE cp_interfaces, ONLY: checkrho, calrhovan - USE cdvan, ONLY: dbec, drhovan - USE cp_main_variables, ONLY: iprint_stdout, drhor, drhog - USE wannier_base, ONLY: iwf - USE cell_base, ONLY: a1, a2, a3 - USE twin_types !added:giovanni -! - IMPLICIT NONE - INTEGER nfi, n, nx, nspin, ispin(n), & - iupdwn(nspin), nupdwn(nspin), nudx - type(twin_matrix) :: bec!(:,:) - REAL(DP) rhovan(nhm*(nhm+1)/2, nat, nspin ) - REAL(DP) rhor(nnrx,nspin), f(nx) - REAL(DP) rhos(nnrsx,nspin) - REAL(DP) enl, ekin - REAL(DP) denl(3,3), dekin(6) - COMPLEX(DP) eigrb( ngb, nat ) - COMPLEX(DP) rhog( ngm, nspin ) - COMPLEX(DP) c( ngw, nx ) - INTEGER irb( 3, nat ) - LOGICAL, INTENT(IN) :: tstress - INTEGER, INTENT(IN) :: ndwwf - - ! local variables - INTEGER :: iss, isup, isdw, iss1, iss2, i, ir, ig !added:giovanni j - REAL(DP) :: rsumr(2), rsumg(2), sa1, sa2 - REAL(DP) :: rnegsum, rmin, rmax, rsum - REAL(DP), EXTERNAL :: enkin_new, ennl_new - REAL(DP), EXTERNAL :: dnrm2, ddot -! COMPLEX, EXTERNAL :: cdotu - COMPLEX(DP) :: ci,fp,fm - COMPLEX(DP), ALLOCATABLE :: psi(:), psis(:) - - LOGICAL :: ttstress - LOGICAL :: lgam - ! - CALL start_clock( 'rhoofr' ) - ! - lgam=gamma_only.and..not.do_wf_cmplx - ttstress = tpre - ttstress = tstress - ! - ci = ( 0.0d0, 1.0d0 ) - ! - rhor = 0.d0 - rhos = 0.d0 - rhog = CMPLX(0.d0, 0.d0) - ! - ! calculation of kinetic energy ekin - ! - ekin = enkin_new( c, ngw, f, n, nspin, nudx, iupdwn, nupdwn) - ! - IF( ttstress ) THEN - ! - ! ... compute kinetic energy contribution - ! - CALL stress_kin( dekin, c, f ) - ! - END IF - - IF( ndwwf>0 ) THEN - ! - ! called from WF, compute only of rhovan - ! - CALL calrhovan( rhovan, bec, iwf ) - ! - ELSE - ! - ! calculation of non-local energy - ! - enl = ennl_new( n, nspin, ispin, f, rhovan, bec ) - ! - END IF - ! - IF( ttstress ) THEN - ! - CALL dennl( bec%rvec, dbec, drhovan, denl ) - ! - END IF - ! - ! warning! trhor and thdyn are not compatible yet! - ! - COMPUTE_CHARGE: IF( trhor .AND. ( .NOT. thdyn ) ) THEN - ! - ! non self-consistent calculation - ! charge density is read from unit 47 - ! - CALL read_rho( nspin, rhor ) - ! - ALLOCATE( psi( nnrx ) ) - ! - IF(nspin.EQ.1)THEN - iss=1 - DO ir=1,nnrx - psi(ir)=CMPLX(rhor(ir,iss),0.d0) - END DO - CALL fwfft('Dense', psi, dfftp ) - DO ig=1,ngm - rhog(ig,iss)=psi(np(ig)) - END DO - ELSE !IF(lgam) THEN !!!### uncomment for k points - isup=1 - isdw=2 - DO ir=1,nnrx - psi(ir)=CMPLX(rhor(ir,isup),rhor(ir,isdw)) - END DO - CALL fwfft('Dense', psi, dfftp ) - DO ig=1,ngm - fp=psi(np(ig))+psi(nm(ig)) - fm=psi(np(ig))-psi(nm(ig)) - rhog(ig,isup)=0.5d0*CMPLX( DBLE(fp),AIMAG(fm)) - rhog(ig,isdw)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - END DO - ENDIF - ! - DEALLOCATE( psi ) - ! - ELSE - ! ================================================================== - ! self-consistent charge - ! ================================================================== - ! - ! important: if n is odd then nx must be .ge.n+1 and c(*,n+1)=0. - ! - IF ( MOD( n, 2 ) /= 0 ) THEN - ! - IF( SIZE( c, 2 ) < n+1 ) & - CALL errore( ' rhoofr ', ' c second dimension too small ', SIZE( c, 2 ) ) - ! - c( :, n+1 ) = ( 0.d0, 0.d0 ) - ! - ENDIF - ! - IF( ndwwf>0 ) THEN - ! - ! Wannier function, charge density from state iwf - ! - i = iwf - ! - psis = 0.D0 - DO ig=1,ngw - psis(nms(ig))=CONJG(c(ig,i)) - psis(nps(ig))=c(ig,i) - END DO - ! - CALL invfft('Wave',psis, dffts ) - ! - iss1=1 - sa1=f(i)/omega - DO ir=1,nnrsx - rhos(ir,iss1)=rhos(ir,iss1) + sa1*( DBLE(psis(ir)))**2 - END DO - ! - ELSE IF( use_task_groups ) THEN - ! - CALL loop_over_states_tg() - ! - ELSE - ! - ALLOCATE( psis( nnrsx ) ) - ! - DO i = 1, n, 2 - ! - IF(lgam) THEN !added:giovanni - ! - CALL c2psi( psis, nnrsx, c( 1, i ), c( 1, i+1 ), ngw, 2 ) - CALL invfft('Wave',psis, dffts ) - ! - iss1 = ispin(i) - sa1 = f(i) / omega - IF ( i .NE. n ) THEN - iss2 = ispin(i+1) - sa2 = f(i+1) / omega - ELSE - iss2 = iss1 - sa2 = 0.0d0 - END IF - ! - - DO ir = 1, nnrsx - rhos(ir,iss1) = rhos(ir,iss1) + sa1 * ( DBLE(psis(ir)))**2 - rhos(ir,iss2) = rhos(ir,iss2) + sa2 * (AIMAG(psis(ir)))**2 - END DO - ! - ELSE - CALL c2psi( psis, nnrsx, c( 1, i ), c( 1, i ), ngw, 0 ) - - CALL invfft('Wave',psis, dffts ) - ! - ! - iss1 = ispin(i) - sa1 = f(i) / omega - ! - DO ir = 1, nnrsx - rhos(ir,iss1) = rhos(ir,iss1) + sa1 *(ABS(psis(ir))**2) - END DO - ! - IF(i.ne.n) then - ! - CALL c2psi( psis, nnrsx, c( 1, i+1 ), c( 1, i+1 ), ngw, 0 ) - ! - CALL invfft('Wave',psis, dffts ) - ! - iss1 = ispin(i+1) - sa1 = f(i+1) / omega - ! - DO ir = 1, nnrsx - rhos(ir,iss1) = rhos(ir,iss1) + sa1 *( abs(psis(ir))**2) - END DO - ENDIF - ENDIF - END DO - ! - DEALLOCATE( psis ) - ! - END IF - ! - ! smooth charge in g-space is put into rhog(ig) - ! - ALLOCATE( psis( nnrsx ) ) - ! - IF(nspin.EQ.1)THEN - iss=1 - DO ir=1,nnrsx - psis(ir)=CMPLX(rhos(ir,iss),0.d0) - END DO - CALL fwfft('Smooth', psis, dffts ) - DO ig=1,ngs - rhog(ig,iss)=psis(nps(ig)) - END DO - ELSE - isup=1 - isdw=2 - DO ir=1,nnrsx - psis(ir)=CMPLX(rhos(ir,isup),rhos(ir,isdw)) - END DO - CALL fwfft('Smooth',psis, dffts ) - DO ig=1,ngs - fp= psis(nps(ig)) + psis(nms(ig)) - fm= psis(nps(ig)) - psis(nms(ig)) - rhog(ig,isup)=0.5d0*CMPLX( DBLE(fp),AIMAG(fm)) - rhog(ig,isdw)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - END DO - ENDIF - ! - ALLOCATE( psi( nnrx ) ) - ! - IF( nspin .EQ. 1 ) THEN - ! - ! case nspin=1 - ! - iss=1 - psi (:) = CMPLX(0.d0, 0.d0) - DO ig=1,ngs - psi(nm(ig))=CONJG(rhog(ig,iss)) - psi(np(ig))= rhog(ig,iss) - END DO - CALL invfft('Dense',psi, dfftp ) - DO ir=1,nnrx - rhor(ir,iss)=DBLE(psi(ir)) - END DO - ! - ELSE - ! - isup=1 - isdw=2 - psi (:) = CMPLX(0.d0, 0.d0) - DO ig=1,ngs - psi(nm(ig))=CONJG(rhog(ig,isup))+ci*CONJG(rhog(ig,isdw)) - psi(np(ig))=rhog(ig,isup)+ci*rhog(ig,isdw) - END DO - CALL invfft('Dense',psi, dfftp ) - DO ir=1,nnrx - rhor(ir,isup)= DBLE(psi(ir)) - rhor(ir,isdw)=AIMAG(psi(ir)) - END DO - ! - ENDIF - ! - IF ( dft_is_meta() ) CALL kedtauofr_meta( c, psi, SIZE( psi ), psis, SIZE( psis ) ) ! METAGGA - ! - DEALLOCATE( psi ) - DEALLOCATE( psis ) - ! - ! add vanderbilt contribution to the charge density - ! drhov called before rhov because input rho must be the smooth part - ! - IF ( ttstress .AND. program_name == 'CP90' ) & - CALL drhov( irb, eigrb, rhovan, rhog, rhor, drhog, drhor ) - ! - CALL rhov( irb, eigrb, rhovan, rhog, rhor, lgam ) - - ENDIF COMPUTE_CHARGE - ! - IF( ndwwf>0 ) THEN - ! - CALL old_write_rho( ndwwf, nspin, rhor, a1, a2, a3 ) - ! - END IF - ! - ! here to check the integral of the charge density - ! - IF( ( iprsta >= 2 ) .OR. ( nfi == 0 ) .OR. & - ( MOD(nfi, iprint_stdout) == 0 ) .AND. ( .NOT. tcg ) ) THEN ! - - IF( iprsta >= 2 ) THEN - CALL checkrho( nnrx, nspin, rhor, rmin, rmax, rsum, rnegsum ) - rnegsum = rnegsum * omega / DBLE(nr1*nr2*nr3) - rsum = rsum * omega / DBLE(nr1*nr2*nr3) - WRITE( stdout,'(a,4(1x,f12.6))') & - & ' rhoofr: rmin rmax rnegsum rsum ',rmin,rmax,rnegsum,rsum - END IF - - CALL sum_charge( rsumg, rsumr ) - - IF ( nspin == 1 ) THEN - WRITE( stdout, 10) rsumg(1), rsumr(1) - ELSE - WRITE( stdout, 20) rsumg(1), rsumr(1), rsumg(2), rsumr(2) - ENDIF - - ENDIF - -10 FORMAT( /, 3X, 'from rhoofr: total integrated electronic density', & - & /, 3X, 'in g-space = ', f11.6, 3x, 'in r-space =', f11.6 ) -20 FORMAT( /, 3X, 'from rhoofr: total integrated electronic density', & - & /, 3X, 'spin up', & - & /, 3X, 'in g-space = ', f11.6, 3x, 'in r-space =', f11.6 , & - & /, 3X, 'spin down', & - & /, 3X, 'in g-space = ', f11.6, 3x, 'in r-space =', f11.6 ) -! - - CALL stop_clock( 'rhoofr' ) - -! - RETURN - - - CONTAINS - ! - ! - SUBROUTINE sum_charge( rsumg, rsumr ) - ! - REAL(DP), INTENT(OUT) :: rsumg( : ) - REAL(DP), INTENT(OUT) :: rsumr( : ) - INTEGER :: iss - ! - DO iss=1,nspin - rsumg(iss)=omega*DBLE(rhog(1,iss)) - rsumr(iss)=SUM(rhor(:,iss),1)*omega/DBLE(nr1*nr2*nr3) - END DO - - IF (gstart.NE.2) THEN - ! in the parallel case, only one processor has G=0 ! - DO iss=1,nspin - rsumg(iss)=0.0d0 - END DO - END IF - - CALL mp_sum( rsumg( 1:nspin ), intra_image_comm ) - CALL mp_sum( rsumr( 1:nspin ), intra_image_comm ) - - RETURN - END SUBROUTINE - - ! - ! - - SUBROUTINE loop_over_states_tg - ! - USE parallel_include - ! - ! MAIN LOOP OVER THE EIGENSTATES - ! - This loop is also parallelized within the task-groups framework - ! - Each group works on a number of eigenstates in parallel - ! - IMPLICIT NONE - ! - INTEGER :: from, ii, eig_index, eig_offset - REAL(DP), ALLOCATABLE :: tmp_rhos(:,:) - - ALLOCATE( psis( dffts%nnrx * nogrp ) ) - ! - ALLOCATE( tmp_rhos ( nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ), nspin ) ) - ! - tmp_rhos = 0_DP - - do i = 1, n, 2*nogrp - ! - ! Initialize wave-functions in Fourier space (to be FFTed) - ! The size of psis is nnr: which is equal to the total number - ! of local fourier coefficients. - ! -!$omp parallel default(shared), private(eig_offset, ig, eig_index ) - ! -!$omp do - do ig = 1, SIZE(psis) - psis (ig) = CMPLX(0.d0, 0.d0) - end do - ! - ! Loop for all local g-vectors (ngw) - ! c: stores the Fourier expansion coefficients - ! the i-th column of c corresponds to the i-th state - ! nms and nps matrices: hold conversion indices form 3D to - ! 1-D vectors. Columns along the z-direction are stored contigiously - ! - ! The outer loop goes through i : i + 2*NOGRP to cover - ! 2*NOGRP eigenstates at each iteration - ! - eig_offset = 0 - - do eig_index = 1, 2*nogrp, 2 - ! - ! here we pack 2*nogrp electronic states in the psis array - ! - IF ( ( i + eig_index - 1 ) <= n ) THEN - ! - ! Outer loop for eigenvalues - ! The eig_index loop is executed only ONCE when NOGRP=1. - ! Equivalent to the case with no task-groups - ! dfft%nsw(me) holds the number of z-sticks for the current processor per wave-function - ! We can either send these in the group with an mpi_allgather...or put the - ! in the PSIS vector (in special positions) and send them with them. - ! Otherwise we can do this once at the beginning, before the loop. - ! we choose to do the latter one. - -!$omp do - do ig=1,ngw - psis(nms(ig)+eig_offset*dffts%nnrx)=conjg(c(ig,i+eig_index-1))+ci*conjg(c(ig,i+eig_index)) - psis(nps(ig)+eig_offset*dffts%nnrx)=c(ig,i+eig_index-1)+ci*c(ig,i+eig_index) - end do - ! - eig_offset = eig_offset + 1 - ! - ENDIF - ! - end do -!$omp end parallel - - ! 2*NOGRP are trasformed at the same time - ! psis: holds the fourier coefficients of the current proccesor - ! for eigenstates i and i+2*NOGRP-1 - ! - CALL invfft( 'Wave', psis, dffts ) - ! - ! Now the first proc of the group holds the first two bands - ! of the 2*nogrp bands that we are processing at the same time, - ! the second proc. holds the third and fourth band - ! and so on - ! - ! Compute the proper factor for each band - ! - DO ii = 1, nogrp - IF( nolist( ii ) == me_image ) EXIT - END DO - ! - ! Remember two bands are packed in a single array : - ! proc 0 has bands ibnd and ibnd+1 - ! proc 1 has bands ibnd+2 and ibnd+3 - ! .... - ! - ii = 2 * ii - 1 - - IF( ii + i - 1 < n ) THEN - iss1=ispin( ii + i - 1 ) - sa1 =f( ii + i - 1 )/omega - iss2=ispin( ii + i ) - sa2 =f( ii + i )/omega - ELSE IF( ii + i - 1 == n ) THEN - iss1=ispin( ii + i - 1 ) - sa1 =f( ii + i - 1 )/omega - iss2=iss1 - sa2=0.0d0 - ELSE - iss1=ispin( n ) - sa1 = 0.0d0 - iss2=iss1 - sa2 =0.0d0 - END IF - ! - !Compute local charge density - ! - !This is the density within each orbital group...so it - !coresponds to 1 eignestate for each group and there are - !NOGRP such groups. Thus, during the loop across all - !occupied eigenstates, the total charge density must me - !accumulated across all different orbital groups. - ! - - !This loop goes through all components of charge density that is local - !to each processor. In the original code this is nnrsx. In the task-groups - !code this should be equal to the total number of planes - ! - - IF( nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ) > SIZE( psis ) ) & - CALL errore( ' rhoofr ', ' psis size too low ', nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ) ) - -!$omp parallel do default(shared) - do ir = 1, nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ) - tmp_rhos(ir,iss1) = tmp_rhos(ir,iss1) + sa1*( real(psis(ir)))**2 - tmp_rhos(ir,iss2) = tmp_rhos(ir,iss2) + sa2*(aimag(psis(ir)))**2 - end do - ! - END DO - - IF ( nogrp > 1 ) THEN - CALL mp_sum( tmp_rhos, gid = ogrp_comm ) - ENDIF - ! - !BRING CHARGE DENSITY BACK TO ITS ORIGINAL POSITION - ! - !If the current processor is not the "first" processor in its - !orbital group then does a local copy (reshuffling) of its data - ! - from = 1 - DO ii = 1, nogrp - IF ( nolist( ii ) == me_image ) EXIT !Exit the loop - from = from + nr1sx*nr2sx*dffts%npp( nolist( ii ) + 1 )! From where to copy initially - ENDDO - ! - DO ir = 1, nspin - CALL dcopy( nr1sx*nr2sx*dffts%npp(me_image+1), tmp_rhos(from,ir), 1, rhos(1,ir), 1) - ENDDO - - DEALLOCATE( tmp_rhos ) - DEALLOCATE( psis ) - - RETURN - END SUBROUTINE loop_over_states_tg - -!----------------------------------------------------------------------- - END SUBROUTINE rhoofr_cp_ortho_new -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- - SUBROUTINE rhoofr_cp_old & - ( nfi, c, irb, eigrb, bec, rhovan, rhor, rhog, rhos, enl, denl, ekin, dekin, tstress, ndwwf ) -!----------------------------------------------------------------------- -! -! this routine computes: -! rhor = normalized electron density in real space -! ekin = kinetic energy -! dekin = kinetic energy term of QM stress -! -! rhor(r) = (sum over ib) fi(ib) |psi(r,ib)|^2 -! -! Using quantities in scaled space -! rhor(r) = rhor(s) / Omega -! rhor(s) = (sum over ib) fi(ib) |psi(s,ib)|^2 -! -! fi(ib) = occupation numbers -! psi(r,ib) = psi(s,ib) / SQRT( Omega ) -! psi(s,ib) = INV_FFT ( c0(ig,ib) ) -! -! ib = index of band -! ig = index of G vector -! ---------------------------------------------- -! the normalized electron density rhor in real space -! the kinetic energy ekin -! subroutine uses complex fft so it computes two ft's -! simultaneously -! -! rho_i,ij = sum_n < beta_i,i | psi_n >< psi_n | beta_i,j > -! < psi_n | beta_i,i > = c_n(0) beta_i,i(0) + -! 2 sum_g> re(c_n*(g) (-i)**l beta_i,i(g) e^-ig.r_i) -! -! e_v = sum_i,ij rho_i,ij d^ion_is,ji -! - USE kinds, ONLY: DP - USE io_global, ONLY: stdout - USE control_flags, ONLY: iprsta, thdyn, tpre, trhor, use_task_groups, program_name, & - gamma_only, do_wf_cmplx !added:giovanni gamma_only, do_wf_cmplx - USE gvecp, ONLY: ngm - USE gvecs, ONLY: ngs, nps, nms - USE gvecw, ONLY: ngw - USE recvecs_indexes, ONLY: np, nm - USE reciprocal_vectors, ONLY: gstart - USE grid_dimensions, ONLY: nr1, nr2, nr3, nnrx - USE cell_base, ONLY: omega - USE smooth_grid_dimensions, ONLY: nr1sx, nr2sx, nnrsx - USE electrons_base, ONLY: n => nbsp, f, ispin, nspin - USE constants, ONLY: pi, fpi - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm, nogrp, me_image, ogrp_comm, nolist - USE funct, ONLY: dft_is_meta - USE cg_module, ONLY: tcg - USE cp_interfaces, ONLY: fwfft, invfft, stress_kin - USE fft_base, ONLY: dffts, dfftp - USE cp_interfaces, ONLY: checkrho, calrhovan - USE cdvan, ONLY: dbec, drhovan - USE cp_main_variables, ONLY: iprint_stdout, drhor, drhog - USE wannier_base, ONLY: iwf - USE cell_base, ONLY: a1, a2, a3 -! - IMPLICIT NONE - INTEGER nfi - REAL(DP) bec(:,:) - REAL(DP) rhovan(:, :, : ) - REAL(DP) rhor(:,:) - REAL(DP) rhos(:,:) - REAL(DP) enl, ekin - REAL(DP) denl(3,3), dekin(6) - COMPLEX(DP) eigrb( :, : ) - COMPLEX(DP) rhog( :, : ) - COMPLEX(DP) c( :, : ) - INTEGER irb( :, : ) - LOGICAL, OPTIONAL, INTENT(IN) :: tstress - INTEGER, OPTIONAL, INTENT(IN) :: ndwwf - - ! local variables - - INTEGER :: iss, isup, isdw, iss1, iss2, i, ir, ig - REAL(DP) :: rsumr(2), rsumg(2), sa1, sa2 - REAL(DP) :: rnegsum, rmin, rmax, rsum - REAL(DP), EXTERNAL :: enkin, ennl - COMPLEX(DP) :: ci,fp,fm - COMPLEX(DP), ALLOCATABLE :: psi(:), psis(:) - - LOGICAL :: ttstress - LOGICAL :: lgam - - ! - - CALL start_clock( 'rhoofr' ) - - lgam=gamma_only.and..not.do_wf_cmplx - ttstress = tpre - IF( PRESENT( tstress ) ) ttstress = tstress - - ci = ( 0.0d0, 1.0d0 ) - - rhor = 0.d0 - rhos = 0.d0 - rhog = CMPLX(0.d0, 0.d0) - ! - ! calculation of kinetic energy ekin - ! - ekin = enkin( c, ngw, f, n) - ! - IF( ttstress ) THEN - ! - ! ... compute kinetic energy contribution - ! - CALL stress_kin( dekin, c, f ) - ! - END IF - - IF( PRESENT( ndwwf ) ) THEN - ! - ! called from WF, compute only of rhovan - ! - CALL calrhovan( rhovan, bec, iwf ) - ! - ELSE - ! - ! calculation of nocentro gulliver modenan-local energy - ! - enl = ennl( rhovan, bec ) - call mp_sum(enl) - ! - END IF - ! - IF( ttstress ) THEN - ! - CALL dennl( bec, dbec, drhovan, denl ) - ! - END IF - ! - ! warning! trhor and thdyn are not compatible yet! - ! - COMPUTE_CHARGE: IF( trhor .AND. ( .NOT. thdyn ) ) THEN - ! - ! non self-consistent calculation - ! charge density is read from unit 47 - ! - CALL read_rho( nspin, rhor ) - - ALLOCATE( psi( nnrx ) ) -! - IF(nspin.EQ.1)THEN - iss=1 - DO ir=1,nnrx - psi(ir)=CMPLX(rhor(ir,iss),0.d0) - END DO - CALL fwfft('Dense', psi, dfftp ) - DO ig=1,ngm - rhog(ig,iss)=psi(np(ig)) - END DO - ELSE - isup=1 - isdw=2 - DO ir=1,nnrx - psi(ir)=CMPLX(rhor(ir,isup),rhor(ir,isdw)) - END DO - CALL fwfft('Dense', psi, dfftp ) - DO ig=1,ngm - fp=psi(np(ig))+psi(nm(ig)) - fm=psi(np(ig))-psi(nm(ig)) - rhog(ig,isup)=0.5d0*CMPLX( DBLE(fp),AIMAG(fm)) - rhog(ig,isdw)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - END DO - ENDIF - - DEALLOCATE( psi ) -! - ELSE - ! ================================================================== - ! self-consistent charge - ! ================================================================== - ! - ! important: if n is odd then nx must be .ge.n+1 and c(*,n+1)=0. - ! - - IF ( MOD( n, 2 ) /= 0 ) THEN - ! - IF( SIZE( c, 2 ) < n+1 ) & - CALL errore( ' rhoofr ', ' c second dimension too small ', SIZE( c, 2 ) ) - ! - c( :, n+1 ) = ( 0.d0, 0.d0 ) - ! - ENDIF - ! - IF( PRESENT( ndwwf ) ) THEN !warning:giovanni complex wavefunctions not implemented here - ! - ! Wannier function, charge density from state iwf - ! - i = iwf - ! - psis = 0.D0 - DO ig=1,ngw - psis(nms(ig))=CONJG(c(ig,i)) - psis(nps(ig))=c(ig,i) - END DO - ! - CALL invfft('Wave',psis, dffts ) - ! - iss1=1 - sa1=f(i)/omega - DO ir=1,nnrsx - rhos(ir,iss1)=rhos(ir,iss1) + sa1*( DBLE(psis(ir)))**2 - END DO - ! - ELSE IF( use_task_groups ) THEN !warning:giovanni cmplx wavefunctions not implemented here - ! - CALL loop_over_states_tg() - ! - ELSE - ! - ALLOCATE( psis( nnrsx ) ) - ! - DO i = 1, n, 2 - ! - CALL c2psi( psis, nnrsx, c( 1, i ), c( 1, i+1 ), ngw, 2 ) - - CALL invfft('Wave',psis, dffts ) - ! - iss1 = ispin(i) - sa1 = f(i) / omega - IF ( i .NE. n ) THEN - iss2 = ispin(i+1) - sa2 = f(i+1) / omega - ELSE - iss2 = iss1 - sa2 = 0.0d0 - END IF - ! - DO ir = 1, nnrsx - rhos(ir,iss1) = rhos(ir,iss1) + sa1 * ( DBLE(psis(ir)))**2 - rhos(ir,iss2) = rhos(ir,iss2) + sa2 * (AIMAG(psis(ir)))**2 - END DO - ! - END DO - ! - DEALLOCATE( psis ) - ! - END IF - ! - ! smooth charge in g-space is put into rhog(ig) - ! - ALLOCATE( psis( nnrsx ) ) - ! - IF(nspin.EQ.1)THEN - iss=1 - DO ir=1,nnrsx - psis(ir)=CMPLX(rhos(ir,iss),0.d0) - END DO - CALL fwfft('Smooth', psis, dffts ) - DO ig=1,ngs - rhog(ig,iss)=psis(nps(ig)) - END DO - ELSE - isup=1 - isdw=2 - DO ir=1,nnrsx - psis(ir)=CMPLX(rhos(ir,isup),rhos(ir,isdw)) - END DO - CALL fwfft('Smooth',psis, dffts ) - DO ig=1,ngs - fp= psis(nps(ig)) + psis(nms(ig)) - fm= psis(nps(ig)) - psis(nms(ig)) - rhog(ig,isup)=0.5d0*CMPLX( DBLE(fp),AIMAG(fm)) - rhog(ig,isdw)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - END DO - ENDIF - ! - ALLOCATE( psi( nnrx ) ) - ! - IF( nspin .EQ. 1 ) THEN - ! - ! case nspin=1 - ! - iss=1 - psi (:) = CMPLX(0.d0, 0.d0) - DO ig=1,ngs - psi(nm(ig))=CONJG(rhog(ig,iss)) - psi(np(ig))= rhog(ig,iss) - END DO - CALL invfft('Dense',psi, dfftp ) - DO ir=1,nnrx - rhor(ir,iss)=DBLE(psi(ir)) - END DO - ! - ELSE - ! - ! case nspin=2 - ! - isup=1 - isdw=2 - psi (:) = CMPLX(0.d0, 0.d0) - DO ig=1,ngs - psi(nm(ig))=CONJG(rhog(ig,isup))+ci*CONJG(rhog(ig,isdw)) - psi(np(ig))=rhog(ig,isup)+ci*rhog(ig,isdw) - END DO - CALL invfft('Dense',psi, dfftp ) - DO ir=1,nnrx - rhor(ir,isup)= DBLE(psi(ir)) - rhor(ir,isdw)=AIMAG(psi(ir)) - END DO - ENDIF - ! - IF ( dft_is_meta() ) CALL kedtauofr_meta( c, psi, SIZE( psi ), psis, SIZE( psis ) ) ! METAGGA - ! - DEALLOCATE( psi ) - DEALLOCATE( psis ) - ! - ! add vanderbilt contribution to the charge density - ! drhov called before rhov because input rho must be the smooth part - ! - ! - IF ( ttstress .AND. program_name == 'CP90' ) & - CALL drhov( irb, eigrb, rhovan, rhog, rhor, drhog, drhor ) - ! - CALL rhov( irb, eigrb, rhovan, rhog, rhor, lgam ) - - ENDIF COMPUTE_CHARGE -! - IF( PRESENT( ndwwf ) ) THEN - ! - CALL old_write_rho( ndwwf, nspin, rhor, a1, a2, a3 ) - ! - END IF -! -! here to check the integral of the charge density -! - IF( ( iprsta >= 2 ) .OR. ( nfi == 0 ) .OR. & - ( MOD(nfi, iprint_stdout) == 0 ) .AND. ( .NOT. tcg ) ) THEN - - IF( iprsta >= 2 ) THEN - CALL checkrho( nnrx, nspin, rhor, rmin, rmax, rsum, rnegsum ) - rnegsum = rnegsum * omega / DBLE(nr1*nr2*nr3) - rsum = rsum * omega / DBLE(nr1*nr2*nr3) - WRITE( stdout,'(a,4(1x,f12.6))') & - & ' rhoofr: rmin rmax rnegsum rsum ',rmin,rmax,rnegsum,rsum - END IF - - CALL sum_charge( rsumg, rsumr ) - - IF ( nspin == 1 ) THEN - WRITE( stdout, 10) rsumg(1), rsumr(1) - ELSE - WRITE( stdout, 20) rsumg(1), rsumr(1), rsumg(2), rsumr(2) - ENDIF - - ENDIF - -10 FORMAT( /, 3X, 'from rhoofr: total integrated electronic density', & - & /, 3X, 'in g-space = ', f11.6, 3x, 'in r-space =', f11.6 ) -20 FORMAT( /, 3X, 'from rhoofr: total integrated electronic density', & - & /, 3X, 'spin up', & - & /, 3X, 'in g-space = ', f11.6, 3x, 'in r-space =', f11.6 , & - & /, 3X, 'spin down', & - & /, 3X, 'in g-space = ', f11.6, 3x, 'in r-space =', f11.6 ) -! - CALL stop_clock( 'rhoofr' ) - -! - RETURN - - - CONTAINS - ! - ! - SUBROUTINE sum_charge( rsumg, rsumr ) - ! - REAL(DP), INTENT(OUT) :: rsumg( : ) - REAL(DP), INTENT(OUT) :: rsumr( : ) - INTEGER :: iss - ! - DO iss=1,nspin - rsumg(iss)=omega*DBLE(rhog(1,iss)) - rsumr(iss)=SUM(rhor(:,iss),1)*omega/DBLE(nr1*nr2*nr3) - END DO - - IF (gstart.NE.2) THEN - ! in the parallel case, only one processor has G=0 ! - DO iss=1,nspin - rsumg(iss)=0.0d0 - END DO - END IF - - CALL mp_sum( rsumg( 1:nspin ), intra_image_comm ) - CALL mp_sum( rsumr( 1:nspin ), intra_image_comm ) - - RETURN - END SUBROUTINE - - ! - ! - - SUBROUTINE loop_over_states_tg - ! - USE parallel_include - ! - ! MAIN LOOP OVER THE EIGENSTATES - ! - This loop is also parallelized within the task-groups framework - ! - Each group works on a number of eigenstates in parallel - ! - IMPLICIT NONE - ! - INTEGER :: from, ii, eig_index, eig_offset - REAL(DP), ALLOCATABLE :: tmp_rhos(:,:) - - ALLOCATE( psis( dffts%nnrx * nogrp ) ) - ! - ALLOCATE( tmp_rhos ( nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ), nspin ) ) - ! - tmp_rhos = 0_DP - - do i = 1, n, 2*nogrp - ! - ! Initialize wave-functions in Fourier space (to be FFTed) - ! The size of psis is nnr: which is equal to the total number - ! of local fourier coefficients. - ! -!$omp parallel default(shared), private(eig_offset, ig, eig_index ) - ! -!$omp do - do ig = 1, SIZE(psis) - psis (ig) = CMPLX(0.d0, 0.d0) - end do - ! - ! Loop for all local g-vectors (ngw) - ! c: stores the Fourier expansion coefficients - ! the i-th column of c corresponds to the i-th state - ! nms and nps matrices: hold conversion indices form 3D to - ! 1-D vectors. Columns along the z-direction are stored contigiously - ! - ! The outer loop goes through i : i + 2*NOGRP to cover - ! 2*NOGRP eigenstates at each iteration - ! - eig_offset = 0 - - do eig_index = 1, 2*nogrp, 2 - ! - ! here we pack 2*nogrp electronic states in the psis array - ! - IF ( ( i + eig_index - 1 ) <= n ) THEN - ! - ! Outer loop for eigenvalues - ! The eig_index loop is executed only ONCE when NOGRP=1. - ! Equivalent to the case with no task-groups - ! dfft%nsw(me) holds the number of z-sticks for the current processor per wave-function - ! We can either send these in the group with an mpi_allgather...or put the - ! in the PSIS vector (in special positions) and send them with them. - ! Otherwise we can do this once at the beginning, before the loop. - ! we choose to do the latter one. - -!$omp do - do ig=1,ngw - psis(nms(ig)+eig_offset*dffts%nnrx)=conjg(c(ig,i+eig_index-1))+ci*conjg(c(ig,i+eig_index)) - psis(nps(ig)+eig_offset*dffts%nnrx)=c(ig,i+eig_index-1)+ci*c(ig,i+eig_index) - end do - ! - eig_offset = eig_offset + 1 - ! - ENDIF - ! - end do -!$omp end parallel - - ! 2*NOGRP are trasformed at the same time - ! psis: holds the fourier coefficients of the current proccesor - ! for eigenstates i and i+2*NOGRP-1 - ! - CALL invfft( 'Wave', psis, dffts ) - ! - ! Now the first proc of the group holds the first two bands - ! of the 2*nogrp bands that we are processing at the same time, - ! the second proc. holds the third and fourth band - ! and so on - ! - ! Compute the proper factor for each band - ! - DO ii = 1, nogrp - IF( nolist( ii ) == me_image ) EXIT - END DO - ! - ! Remember two bands are packed in a single array : - ! proc 0 has bands ibnd and ibnd+1 - ! proc 1 has bands ibnd+2 and ibnd+3 - ! .... - ! - ii = 2 * ii - 1 - - IF( ii + i - 1 < n ) THEN - iss1=ispin( ii + i - 1 ) - sa1 =f( ii + i - 1 )/omega - iss2=ispin( ii + i ) - sa2 =f( ii + i )/omega - ELSE IF( ii + i - 1 == n ) THEN - iss1=ispin( ii + i - 1 ) - sa1 =f( ii + i - 1 )/omega - iss2=iss1 - sa2=0.0d0 - ELSE - iss1=ispin( n ) - sa1 = 0.0d0 - iss2=iss1 - sa2 =0.0d0 - END IF - ! - !Compute local charge density - ! - !This is the density within each orbital group...so it - !coresponds to 1 eignestate for each group and there are - !NOGRP such groups. Thus, during the loop across all - !occupied eigenstates, the total charge density must me - !accumulated across all different orbital groups. - ! - - !This loop goes through all components of charge density that is local - !to each processor. In the original code this is nnrsx. In the task-groups - !code this should be equal to the total number of planes - ! - - IF( nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ) > SIZE( psis ) ) & - CALL errore( ' rhoofr ', ' psis size too low ', nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ) ) - -!$omp parallel do default(shared) - do ir = 1, nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ) - tmp_rhos(ir,iss1) = tmp_rhos(ir,iss1) + sa1*( real(psis(ir)))**2 - tmp_rhos(ir,iss2) = tmp_rhos(ir,iss2) + sa2*(aimag(psis(ir)))**2 - end do - ! - END DO - - IF ( nogrp > 1 ) THEN - CALL mp_sum( tmp_rhos, gid = ogrp_comm ) - ENDIF - ! - !BRING CHARGE DENSITY BACK TO ITS ORIGINAL POSITION - ! - !If the current processor is not the "first" processor in its - !orbital group then does a local copy (reshuffling) of its data - ! - from = 1 - DO ii = 1, nogrp - IF ( nolist( ii ) == me_image ) EXIT !Exit the loop - from = from + nr1sx*nr2sx*dffts%npp( nolist( ii ) + 1 )! From where to copy initially - ENDDO - ! - DO ir = 1, nspin - CALL dcopy( nr1sx*nr2sx*dffts%npp(me_image+1), tmp_rhos(from,ir), 1, rhos(1,ir), 1) - ENDDO - - DEALLOCATE( tmp_rhos ) - DEALLOCATE( psis ) - - RETURN - END SUBROUTINE loop_over_states_tg - -!----------------------------------------------------------------------- - END SUBROUTINE rhoofr_cp_old -!----------------------------------------------------------------------- - -!=----------------------------------------------------------------------=! - SUBROUTINE fillgrad_x( nspin, rhog, gradr, lgam ) -!=----------------------------------------------------------------------=! - ! - ! calculates gradient of charge density for gradient corrections - ! in: charge density on G-space out: gradient in R-space - ! - USE kinds, ONLY: DP - use reciprocal_vectors, only: gx - use recvecs_indexes, only: np, nm - use gvecp, only: ngm - use grid_dimensions, only: nnrx - use cell_base, only: tpiba - USE cp_interfaces, ONLY: invfft - USE fft_base, ONLY: dfftp -! - implicit none -! input - integer, intent(in) :: nspin - complex(DP) :: rhog( ngm, nspin ) - logical :: lgam -! output - real(DP) :: gradr( nnrx, 3, nspin ) -! local - complex(DP), allocatable :: v(:) - complex(DP) :: ci - integer :: iss, ig, ir -! - allocate( v( nnrx ) ) - ! - ci = CMPLX( 0.0d0, 1.0d0 ) - do iss = 1, nspin -!$omp parallel default(shared), private(ig) -!$omp do - do ig = 1, nnrx - v( ig ) = CMPLX( 0.0d0, 0.0d0 ) - end do -!$omp do -! if(lgam) then !!! uncomment for k-points - do ig=1,ngm - v(np(ig))= ci*tpiba*gx(1,ig)*rhog(ig,iss) - v(nm(ig))=CONJG(ci*tpiba*gx(1,ig)*rhog(ig,iss)) - end do -! else !!! uncomment for k-points -! do ig=1,ngm !!! uncomment for k-pointvs -! v(np(ig))= ci*tpiba*gx(1,ig)*rhog(ig,iss) !!! uncomment for k-pointvs -! v(nm(ig))=CONJG(ci*tpiba*gx(1,ig)*rhog(ig,iss)) !!! uncomment for k-pointvs -! end do !!! uncomment for k-pointvs - ! endif !!! uncomment for k-pointvs -!$omp end parallel - ! - call invfft( 'Dense', v, dfftp ) - ! -!$omp parallel default(shared), private(ig,ir) -!$omp do - do ir=1,nnrx - gradr(ir,1,iss)=DBLE(v(ir)) - end do -!$omp do - do ig=1,nnrx - v(ig)=CMPLX(0.0d0,0.0d0) - end do -!$omp do -! if(lgam) then !!! uncomment for k-points - do ig=1,ngm - v(np(ig))= tpiba*( ci*gx(2,ig)*rhog(ig,iss)- & - & gx(3,ig)*rhog(ig,iss) ) - v(nm(ig))= tpiba*(CONJG(ci*gx(2,ig)*rhog(ig,iss)+ & - & gx(3,ig)*rhog(ig,iss))) - end do -! else !!! uncomment for k-points -! do ig=1,ngm !!! uncomment for k-points -! v(np(ig))= tpiba*( ci*gx(2,ig)*rhog(ig,iss)- & !!! uncomment for k-points -! & gx(3,ig)*rhog(ig,iss) ) !!! uncomment for k-points -!! v(nm(ig))= tpiba*(CONJG(ci*gx(2,ig)*rhog(ig,iss)+ & !!! uncomment for k-points -!! & gx(3,ig)*rhog(ig,iss))) !!! uncomment for k-points -! end do !!! uncomment for k-points -! endif !!! uncomment for k-points -!$omp end parallel - ! - call invfft( 'Dense', v, dfftp ) - ! -!$omp parallel do default(shared) - do ir=1,nnrx - gradr(ir,2,iss)= DBLE(v(ir)) - gradr(ir,3,iss)=AIMAG(v(ir)) - end do - end do - ! - deallocate( v ) -! - RETURN - END SUBROUTINE fillgrad_x - - -! -!---------------------------------------------------------------------- - SUBROUTINE checkrho_x(nnr,nspin,rhor,rmin,rmax,rsum,rnegsum) -!---------------------------------------------------------------------- -! -! check \int rho(r)dr and the negative part of rho -! - USE kinds, ONLY: DP - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nnr, nspin - REAL(DP) rhor(nnr,nspin), rmin, rmax, rsum, rnegsum - ! - REAL(DP) roe - INTEGER ir, iss -! - rsum =0.0d0 - rnegsum=0.0d0 - rmin =100.d0 - rmax =0.0d0 - DO iss = 1, nspin - DO ir = 1, nnr - roe = rhor(ir,iss) - rsum = rsum + roe - IF ( roe < 0.0d0 ) rnegsum = rnegsum + roe - rmax = MAX( rmax, roe ) - rmin = MIN( rmin, roe ) - END DO - END DO - CALL mp_sum( rsum, intra_image_comm ) - CALL mp_sum( rnegsum, intra_image_comm ) - RETURN - END SUBROUTINE checkrho_x - - - -!---------------------------------------------------------------------- - SUBROUTINE newrho_x(rhor, drho, nfi) -!---------------------------------------------------------------------- - -! ... declare modules - USE kinds, ONLY: DP - USE fft_base, ONLY: dfftp - USE cp_interfaces, ONLY: fwfft, invfft - USE cell_base, ONLY: tpiba2 - USE reciprocal_vectors, ONLY: gstart, gzero, g - USE gvecp, ONLY: ngm - USE wave_base, ONLY: scalw - USE mp_global, ONLY: intra_image_comm - USE io_global, ONLY: stdout - USE mp, ONLY: mp_sum - USE charge_mix, ONLY: chmix, metric, rho, rr, aa_save, & - achmix, g1met2, g0chmix2, daamax, & - allocate_charge_mix - - IMPLICIT NONE - -! ... declare subroutine arguments - REAL(DP), INTENT(INOUT) :: rhor(:) - REAL(DP), INTENT(OUT) :: drho - INTEGER, INTENT(IN) :: nfi - -! ... declare other variables - COMPLEX(DP) :: dr - COMPLEX(DP) :: rhoout(ngm) - REAL(DP) :: g02, g12, den, rsc - REAL(DP) :: alpha(daamax) - REAL(DP), ALLOCATABLE :: aa(:,:) - REAL(DP), ALLOCATABLE :: rho_old(:) - INTEGER :: is, ism, i, ig - LOGICAL, SAVE :: tfirst = .TRUE. - INTEGER, SAVE :: dimaa, dimaaold, nrho_t, ierr - COMPLEX(DP), ALLOCATABLE :: psi(:) - -! ... end of declarations -! ---------------------------------------------- - - IF( nfi /= 0 .AND. tfirst ) THEN - - CALL errore(' newrho ', ' not initialized ', nfi ) - - ELSE IF( nfi == 0 )THEN - - IF( tfirst ) THEN - CALL allocate_charge_mix( ngm ) - END IF - -! ... define array chmix = A * G^2 / (G^2 + G_0^2) and metric = (G^2 + G_1^2) / G^2 - g02 = g0chmix2 / tpiba2 - g12 = g1met2 / tpiba2 - IF(gzero) THEN - chmix(1) = 0.0d0 - metric(1) = 0.0d0 - END IF - DO ig = gstart, ngm - chmix(ig) = achmix * g(ig) / (g(ig)+g02) - metric(ig) = (g(ig)+g12) / g(ig) - END DO - tfirst = .FALSE. - - END IF - -! ... Reset matrix dimension for the first iteration / initialization - IF( nfi <= 1 )THEN - dimaa = 0 - nrho_t = 0 - END IF - -! ... Now update matrix dimension and counter - nrho_t = nrho_t + 1 - - dimaaold = dimaa ! save the previous matrix dimension - dimaa = MIN( daamax, nrho_t-1 ) ! number of densities and rr saved up to now - - ism = MOD( nrho_t-1, daamax ) - if( ism == 0 ) ism = daamax - is = MOD( nrho_t , daamax ) - if( is == 0 ) is = daamax - -! ... Fourier tranform of rhor - - ALLOCATE( psi( SIZE( rhor ) ) ) - - psi = rhor - - CALL fwfft( 'Dense', psi, dfftp ) - CALL psi2rho( 'Dense', psi, dfftp%nnr, rhoout, ngm ) - - DEALLOCATE( psi ) - - - IF( nrho_t == 1 )THEN - - rho(:,1) = rhoout - RETURN - - ELSE IF( nrho_t.EQ.2 .OR. (daamax.EQ.1 .AND. nrho_t.GT.1) )THEN - - WRITE( stdout, fmt='( 3X,"charge mixing of order 1")' ) - - DO ig = gstart, ngm - dr = rhoout(ig) - rho(ig,1) - rr(ig,1) = dr - rhoout(ig) = rho(ig,1) + chmix(ig) * dr - rho(ig,is) = rhoout(ig) - END DO - IF( gzero ) THEN - rhoout(1) = rho(1,1) - rr(1,1) = CMPLX(0.d0,0.d0) - END IF - IF( daamax /= 1 )THEN - rsc = scalw(gzero, rr(:,1), rr(:,1), metric) - aa_save(1, 1) = rsc - END IF - - ELSE - - IF( dimaa < 1 .OR. dimaa > daamax ) THEN - CALL errore(' newrho ', ' dimaa out of range ', dimaa ) - END IF - IF( dimaaold < 1 .OR. dimaaold > daamax ) THEN - CALL errore(' newrho ', ' dimaaold out of range ', dimaaold ) - END IF - - WRITE( stdout, fmt='( 3X,"charge mixing of order ",I2)' ) dimaa - - DO ig = gstart, ngm - rr(ig,ism) = rhoout(ig) - rho(ig,ism) - END DO - IF(gzero) THEN - rr(1,ism) = CMPLX(0.d0, 0.d0) - END IF - -! ... Allocate the new A matrix - ALLOCATE( aa ( dimaa, dimaa ), STAT=ierr ) - IF( ierr /= 0 ) CALL errore(' newrho ', ' allocating aa ', ierr) - -! ... Fill in new A with the content of the old a - aa( 1:dimaaold, 1:dimaaold ) = aa_save( 1:dimaaold, 1:dimaaold ) - -! ... Compute new matrix A - DO i = 1, dimaa - rsc = scalw(gzero,rr(:,i),rr(:,ism),metric) - aa(i,ism)= rsc - aa(ism,i)= rsc - END DO - -! ... Save the content of A for the next iteration - aa_save( 1:dimaa, 1:dimaa ) = aa( 1:dimaa, 1:dimaa ) - -! ... Compute alphas - CALL invgen( aa ) - den = SUM( aa ) - DO i = 1, dimaa - alpha(i) = SUM( aa(:,i) ) / den - END DO - - DEALLOCATE( aa, STAT=ierr ) - IF( ierr /= 0 ) CALL errore(' newrho ', ' deallocating aa ', ierr) - - DO ig = gstart, ngm - rhoout(ig) = CMPLX(0.d0,0.d0) - DO i = 1, dimaa - rhoout(ig) = rhoout(ig) + alpha(i) * ( rho(ig,i) + chmix(ig) * rr(ig,i) ) - END DO - rho(ig,is) = rhoout(ig) - END DO - IF(gzero) THEN - rhoout(1) = rho(1,1) - END IF - - END IF - - ALLOCATE( rho_old( SIZE(rhor) ), STAT=ierr ) - IF( ierr /= 0 ) CALL errore(' newrho ', ' allocating rho_old ', ierr) - rho_old = rhor - - ! ... rhor back to real space rhor = FFT( rhoout ) - ! CALL pinvfft(rhor, rhoout) - - ALLOCATE( psi( SIZE( rhor ) ) ) - - CALL rho2psi( 'Dense', psi, dfftp%nnr, rhoout, ngm ) - CALL invfft( 'Dense', psi, dfftp ) - - rhor = DBLE( psi ) - - drho = SUM( (rho_old - rhor)**2 ) - - DEALLOCATE(psi) - DEALLOCATE(rho_old, STAT=ierr) - IF( ierr /= 0 ) CALL errore(' newrho ', ' deallocating rho_old ', ierr) - - CALL mp_sum(drho, intra_image_comm) - - RETURN - - CONTAINS - - SUBROUTINE invgen( aa ) - - IMPLICIT NONE - REAL(DP) :: aa(:,:) - - REAL(DP) :: scr1(SIZE(aa,1),SIZE(aa,2)) - REAL(DP) :: scr2(SIZE(aa,1),SIZE(aa,2)) - REAL(DP) :: scr3(4*SIZE(aa,1)) - REAL(DP) :: cond, toleig - INTEGER :: info, iopt, mrank - toleig = 1.d-10 - iopt = 10 - CALL geninv(aa, SIZE(aa,1), SIZE(aa,2), mrank, cond, scr1, scr2, scr3, toleig, info, iopt) - RETURN - END SUBROUTINE invgen - - END SUBROUTINE newrho_x - - -!----------------------------------------------------------------------- -SUBROUTINE drhov(irb,eigrb,rhovan,rhog,rhor,drhog,drhor) -!----------------------------------------------------------------------- -! this routine calculates arrays drhog drhor, derivatives wrt h of: -! -! n_v(g) = sum_i,ij rho_i,ij q_i,ji(g) e^-ig.r_i -! -! Same logic as in routine rhov. -! On input rhor and rhog must contain the smooth part only !!! -! Output in (drhor, drhog) -! - USE kinds, ONLY: DP - USE ions_base, ONLY: na, nat - USE cvan, ONLY: nvb - USE uspp_param, ONLY: nhm, nh - USE grid_dimensions, ONLY: nnr => nnrx - USE electrons_base, ONLY: nspin - USE gvecb, ONLY: ngb, npb, nmb - USE gvecp, ONLY: ng => ngm - USE smallbox_grid_dimensions, ONLY: nnrb => nnrbx - USE cell_base, ONLY: ainv - USE qgb_mod, ONLY: qgb - USE cdvan, ONLY: drhovan - USE dqgb_mod, ONLY: dqgb - USE recvecs_indexes, ONLY: nm, np - USE cp_interfaces, ONLY: fwfft, invfft - USE fft_base, ONLY: dfftb, dfftp - - IMPLICIT NONE -! input - INTEGER, INTENT(IN) :: irb(3,nat) - REAL(DP), INTENT(IN) :: rhor(nnr,nspin) - REAL(DP), INTENT(IN) :: rhovan(nhm*(nhm+1)/2,nat,nspin) - COMPLEX(DP), INTENT(IN) :: eigrb(ngb,nat), rhog(ng,nspin) -! output - REAL(DP), INTENT(OUT) :: drhor(nnr,nspin,3,3) - COMPLEX(DP), INTENT(OUT) :: drhog(ng,nspin,3,3) -! local - INTEGER i, j, isup, isdw, nfft, ifft, iv, jv, ig, ijv, is, iss, & - & isa, ia, ir - REAL(DP) sum, dsum - COMPLEX(DP) fp, fm, ci - COMPLEX(DP), ALLOCATABLE :: v(:) - COMPLEX(DP), ALLOCATABLE:: dqgbt(:,:) - COMPLEX(DP), ALLOCATABLE :: qv(:) -! -! - DO j=1,3 - DO i=1,3 - DO iss=1,nspin - DO ir=1,nnr - drhor(ir,iss,i,j)=-rhor(ir,iss)*ainv(j,i) - END DO - DO ig=1,ng - drhog(ig,iss,i,j)=-rhog(ig,iss)*ainv(j,i) - END DO - END DO - END DO - END DO - - IF ( nvb == 0 ) RETURN - - ALLOCATE( v( nnr ) ) - ALLOCATE( qv( nnrb ) ) - ALLOCATE( dqgbt( ngb, 2 ) ) - - ci =( 0.0d0, 1.0d0 ) - - IF( nspin == 1 ) THEN - ! - ! nspin=1 : two fft at a time, one per atom, if possible - ! - DO i=1,3 - DO j=1,3 - - v(:) = CMPLX(0.d0, 0.d0) - - iss=1 - isa=1 - - DO is=1,nvb -#ifdef __PARA - DO ia=1,na(is) - nfft=1 - IF ( dfftb%np3( isa ) <= 0 ) go to 15 -#else - DO ia=1,na(is),2 - nfft=2 -#endif - dqgbt(:,:) = CMPLX(0.d0, 0.d0) - IF (ia.EQ.na(is)) nfft=1 - ! - ! nfft=2 if two ffts at the same time are performed - ! - DO ifft=1,nfft - DO iv=1,nh(is) - DO jv=iv,nh(is) - ijv = (jv-1)*jv/2 + iv - sum = rhovan(ijv,isa+ifft-1,iss) - dsum=drhovan(ijv,isa+ifft-1,iss,i,j) - IF(iv.NE.jv) THEN - sum =2.d0*sum - dsum=2.d0*dsum - ENDIF - DO ig=1,ngb - dqgbt(ig,ifft)=dqgbt(ig,ifft) + & - & (sum*dqgb(ig,ijv,is,i,j) + & - & dsum*qgb(ig,ijv,is) ) - END DO - END DO - END DO - END DO - ! - ! add structure factor - ! - qv(:) = CMPLX(0.d0, 0.d0) - IF(nfft.EQ.2) THEN - DO ig=1,ngb - qv(npb(ig)) = eigrb(ig,isa )*dqgbt(ig,1) & - & + ci* eigrb(ig,isa+1 )*dqgbt(ig,2) - qv(nmb(ig))= & - & CONJG(eigrb(ig,isa )*dqgbt(ig,1)) & - & + ci*CONJG(eigrb(ig,isa+1)*dqgbt(ig,2)) - END DO - ELSE - DO ig=1,ngb - qv(npb(ig)) = eigrb(ig,isa)*dqgbt(ig,1) - qv(nmb(ig)) = & - & CONJG(eigrb(ig,isa)*dqgbt(ig,1)) - END DO - ENDIF -! - CALL invfft('Box',qv, dfftb, isa) - ! - ! qv = US contribution in real space on box grid - ! for atomic species is, real(qv)=atom ia, imag(qv)=atom ia+1 - ! - ! add qv(r) to v(r), in real space on the dense grid - ! - CALL box2grid( irb(1,isa), 1, qv, v ) - IF (nfft.EQ.2) CALL box2grid(irb(1,isa+1),2,qv,v) - - 15 isa = isa + nfft -! - END DO - END DO -! - DO ir=1,nnr - drhor(ir,iss,i,j) = drhor(ir,iss,i,j) + DBLE(v(ir)) - END DO -! - CALL fwfft( 'Dense', v, dfftp ) -! - DO ig=1,ng - drhog(ig,iss,i,j) = drhog(ig,iss,i,j) + v(np(ig)) - END DO -! - ENDDO - ENDDO -! - ELSE - ! - ! nspin=2: two fft at a time, one for spin up and one for spin down - ! - isup=1 - isdw=2 - DO i=1,3 - DO j=1,3 - v(:) = CMPLX(0.d0, 0.d0) - isa=1 - DO is=1,nvb - DO ia=1,na(is) -#ifdef __PARA - IF ( dfftb%np3( isa ) <= 0 ) go to 25 -#endif - DO iss=1,2 - dqgbt(:,iss) = CMPLX(0.d0, 0.d0) - DO iv= 1,nh(is) - DO jv=iv,nh(is) - ijv = (jv-1)*jv/2 + iv - sum=rhovan(ijv,isa,iss) - dsum =drhovan(ijv,isa,iss,i,j) - IF(iv.NE.jv) THEN - sum =2.d0*sum - dsum=2.d0*dsum - ENDIF - DO ig=1,ngb - dqgbt(ig,iss)=dqgbt(ig,iss) + & - & (sum*dqgb(ig,ijv,is,i,j) + & - & dsum*qgb(ig,ijv,is)) - END DO - END DO - END DO - END DO - ! - ! add structure factor - ! - qv(:) = CMPLX(0.d0, 0.d0) - DO ig=1,ngb - qv(npb(ig))= eigrb(ig,isa)*dqgbt(ig,1) & - & + ci* eigrb(ig,isa)*dqgbt(ig,2) - qv(nmb(ig))= CONJG(eigrb(ig,isa)*dqgbt(ig,1)) & - & + ci*CONJG(eigrb(ig,isa)*dqgbt(ig,2)) - END DO -! - CALL invfft('Box',qv, dfftb, isa ) - ! - ! qv is the now the US augmentation charge for atomic species is - ! and atom ia: real(qv)=spin up, imag(qv)=spin down - ! - ! add qv(r) to v(r), in real space on the dense grid - ! - CALL box2grid2(irb(1,isa),qv,v) - ! - 25 isa = isa + 1 - ! - END DO - END DO -! - DO ir=1,nnr - drhor(ir,isup,i,j) = drhor(ir,isup,i,j) + DBLE(v(ir)) - drhor(ir,isdw,i,j) = drhor(ir,isdw,i,j) +AIMAG(v(ir)) - ENDDO -! - CALL fwfft('Dense', v, dfftp ) - DO ig=1,ng - fp=v(np(ig))+v(nm(ig)) - fm=v(np(ig))-v(nm(ig)) - drhog(ig,isup,i,j) = drhog(ig,isup,i,j) + & - & 0.5d0*CMPLX( DBLE(fp),AIMAG(fm)) - drhog(ig,isdw,i,j) = drhog(ig,isdw,i,j) + & - & 0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - END DO -! - END DO - END DO - ENDIF - DEALLOCATE(dqgbt) - DEALLOCATE( v ) - DEALLOCATE( qv ) -! - RETURN -END SUBROUTINE drhov - -! -!----------------------------------------------------------------------- -SUBROUTINE rhov(irb,eigrb,rhovan,rhog,rhor, lgam) !added:giovanni lgam -!----------------------------------------------------------------------- -! Add Vanderbilt contribution to rho(r) and rho(g) -! -! n_v(g) = sum_i,ij rho_i,ij q_i,ji(g) e^-ig.r_i -! -! routine makes use of c(-g)=c*(g) and beta(-g)=beta*(g) -! - USE kinds, ONLY: dp - USE ions_base, ONLY: nat, na - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - USE cvan, ONLY: nvb - USE uspp_param, ONLY: nh, nhm - USE grid_dimensions, ONLY: nr1, nr2, nr3, nnr => nnrx - USE electrons_base, ONLY: nspin - USE gvecb, ONLY: npb, nmb, ngb - USE gvecp, ONLY: ng => ngm - USE cell_base, ONLY: omega - USE small_box, ONLY: omegab - USE smallbox_grid_dimensions, ONLY: nr1b, nr2b, nr3b, nnrb => nnrbx - USE qgb_mod, ONLY: qgb - USE recvecs_indexes, ONLY: np, nm - USE cp_interfaces, ONLY: fwfft, invfft - USE fft_base, ONLY: dfftb, dfftp - USE control_flags, ONLY: iprsta -! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: rhovan(nhm*(nhm+1)/2,nat,nspin) - INTEGER, INTENT(in) :: irb(3,nat) - COMPLEX(DP), INTENT(in):: eigrb(ngb,nat) - ! - REAL(DP), INTENT(inout):: rhor(nnr,nspin) - COMPLEX(DP), INTENT(inout):: rhog(ng,nspin) - LOGICAl, INTENT(IN) :: lgam !added:giovanni -! - INTEGER :: isup, isdw, nfft, ifft, iv, jv, ig, ijv, is, iss, isa, ia, ir, istep - REAL(DP) :: sumrho - COMPLEX(DP) :: ci, fp, fm, ca - COMPLEX(DP), ALLOCATABLE :: qgbt(:,:) - COMPLEX(DP), ALLOCATABLE :: v(:) !, v_c(:) - COMPLEX(DP), ALLOCATABLE :: qv(:) - - ! Quick return if this sub is not needed - ! - IF ( nvb == 0 ) RETURN - - CALL start_clock( 'rhov' ) - ci=CMPLX(0.d0,1.d0) -! -! - ALLOCATE( v( nnr ) ) - ALLOCATE( qv( nnrb ) ) - v (:) = CMPLX(0.d0, 0.d0) - ALLOCATE( qgbt( ngb, 2 ) ) - - IF(lgam) THEN - istep=2 - ELSE - istep=2 - ENDIF - -! - IF(nspin.EQ.1) THEN - ! - ! nspin=1 : two fft at a time, one per atom, if possible - ! - iss=1 - isa=1 - - DO is = 1, nvb - -#ifdef __PARA - - DO ia = 1, na(is) - nfft = 1 - IF ( dfftb%np3( isa ) <= 0 ) go to 15 -#else - - DO ia = 1, na(is), istep - nfft = istep -#endif - - IF( ia .EQ. na(is) ) nfft = 1 - - ! - ! nfft=2 if two ffts at the same time are performed - ! - DO ifft=1,nfft - qgbt(:,ifft) = CMPLX(0.d0, 0.d0) - DO iv= 1,nh(is) - DO jv=iv,nh(is) - ijv = (jv-1)*jv/2 + iv - sumrho=rhovan(ijv,isa+ifft-1,iss) - IF(iv.NE.jv) sumrho=2.d0*sumrho - DO ig=1,ngb - qgbt(ig,ifft)=qgbt(ig,ifft) + sumrho*qgb(ig,ijv,is) - END DO - END DO - END DO - END DO - ! - ! add structure factor - ! - qv(:) = CMPLX(0.d0, 0.d0) - IF(nfft.EQ.2)THEN -! IF(lgam) THEN - DO ig=1,ngb - qv(npb(ig))= & - eigrb(ig,isa )*qgbt(ig,1) & - + ci* eigrb(ig,isa+1)*qgbt(ig,2) - qv(nmb(ig))= & - CONJG(eigrb(ig,isa )*qgbt(ig,1)) & - + ci*CONJG(eigrb(ig,isa+1)*qgbt(ig,2)) - END DO -! ELSE -! DO ig=1,ngb -! qv(npb(ig))= & -! eigrb(ig,isa )*qgbt(ig,1) & -! + ci* eigrb(ig,isa+1)*qgbt(ig,2) -! qv(nmb(ig))= & -! CONJG(eigrb(ig,isa )*qgbt(ig,1)) & -! + ci*CONJG(eigrb(ig,isa+1)*qgbt(ig,2)) -! END DO -! ENDIF - ELSE -! IF(lgam) THEN - DO ig=1,ngb - qv(npb(ig)) = eigrb(ig,isa)*qgbt(ig,1) - qv(nmb(ig)) = CONJG(eigrb(ig,isa)*qgbt(ig,1)) - END DO -! ELSE -! DO ig=1,ngb -! qv(npb(ig)) = eigrb(ig,isa)*qgbt(ig,1) -! qv(nmb(ig)) = CONJG(eigrb(ig,isa)*qgbt(ig,1)) -! END DO -! ENDIF - ENDIF - - CALL invfft('Box',qv,dfftb,isa) - - ! - ! qv = US augmentation charge in real space on box grid - ! for atomic species is, real(qv)=atom ia, imag(qv)=atom ia+1 - - IF(iprsta.GT.2) THEN - ca = SUM(qv) - WRITE( stdout,'(a,f12.8)') ' rhov: 1-atom g-sp = ', & - & omegab*DBLE(qgbt(1,1)) - WRITE( stdout,'(a,f12.8)') ' rhov: 1-atom r-sp = ', & - & omegab*DBLE(ca)/(nr1b*nr2b*nr3b) - WRITE( stdout,'(a,f12.8)') ' rhov: 1-atom g-sp = ', & - & omegab*DBLE(qgbt(1,2)) - WRITE( stdout,'(a,f12.8)') ' rhov: 1-atom r-sp = ', & - & omegab*AIMAG(ca)/(nr1b*nr2b*nr3b) - ENDIF - ! - ! add qv(r) to v(r), in real space on the dense grid - ! - CALL box2grid(irb(1,isa),1,qv,v) - IF (nfft.EQ.2) CALL box2grid(irb(1,isa+1),2,qv,v) - 15 isa=isa+nfft -! - END DO - END DO - ! - ! rhor(r) = total (smooth + US) charge density in real space - ! - DO ir=1,nnr - rhor(ir,iss)=rhor(ir,iss)+DBLE(v(ir)) - END DO -! - IF(iprsta.GT.2) THEN - ca = SUM(v) - - CALL mp_sum( ca, intra_image_comm ) - - WRITE( stdout,'(a,2f12.8)') & - & ' rhov: int n_v(r) dr = ',omega*ca/(nr1*nr2*nr3) - ENDIF -! - CALL fwfft('Dense',v, dfftp ) -! - IF(iprsta.GT.2) THEN - WRITE( stdout,*) ' rhov: smooth ',omega*rhog(1,iss) - WRITE( stdout,*) ' rhov: vander ',omega*v(1) - WRITE( stdout,*) ' rhov: all ',omega*(rhog(1,iss)+v(1)) - ENDIF - ! - ! rhog(g) = total (smooth + US) charge density in G-space - ! - DO ig = 1, ng - rhog(ig,iss)=rhog(ig,iss)+v(np(ig)) - END DO - -! - IF(iprsta.GT.1) WRITE( stdout,'(a,2f12.8)') & - & ' rhov: n_v(g=0) = ',omega*DBLE(rhog(1,iss)) -! - ELSE - ! - ! nspin=2: two fft at a time, one for spin up and one for spin down - ! -! IF(.not.lgam) THEN -! ALLOCATE(v_c(nnr)) -! v_c=CMPLX(0.d0,0.d0) -! ENDIF - - isup=1 - isdw=2 - isa=1 - DO is=1,nvb - DO ia=1,na(is) -#ifdef __PARA - IF ( dfftb%np3( isa ) <= 0 ) go to 25 -#endif - DO iss=1,2 - qgbt(:,iss) = CMPLX(0.d0, 0.d0) - DO iv=1,nh(is) - DO jv=iv,nh(is) - ijv = (jv-1)*jv/2 + iv - sumrho=rhovan(ijv,isa,iss) - IF(iv.NE.jv) sumrho=2.d0*sumrho - DO ig=1,ngb - qgbt(ig,iss)=qgbt(ig,iss)+sumrho*qgb(ig,ijv,is) - END DO - END DO - END DO - END DO -! -! add structure factor -! - qv(:) = CMPLX(0.d0, 0.d0) -! IF(lgam) THEN - DO ig=1,ngb - qv(npb(ig)) = eigrb(ig,isa)*qgbt(ig,1) & - & + ci* eigrb(ig,isa)*qgbt(ig,2) - qv(nmb(ig)) = CONJG(eigrb(ig,isa)*qgbt(ig,1)) & - & + ci* CONJG(eigrb(ig,isa)*qgbt(ig,2)) - END DO -! ELSE -! DO ig=1,ngb -! qv(npb(ig)) = eigrb(ig,isa)*qgbt(ig,1) & -! & + ci* eigrb(ig,isa)*qgbt(ig,2) -! qv(nmb(ig)) = CONJG(eigrb(ig,isa)*qgbt(ig,1)) & -! & + ci* CONJG(eigrb(ig,isa)*qgbt(ig,2)) -! END DO -! ENDIF -! - CALL invfft('Box',qv,dfftb,isa) -! -! qv is the now the US augmentation charge for atomic species is -! and atom ia: real(qv)=spin up, imag(qv)=spin down -! - IF(iprsta.GT.2) THEN - ca = SUM(qv) - WRITE( stdout,'(a,f12.8)') ' rhov: up g-space = ', & - & omegab*DBLE(qgbt(1,1)) - WRITE( stdout,'(a,f12.8)') ' rhov: up r-sp = ', & - & omegab*DBLE(ca)/(nr1b*nr2b*nr3b) - WRITE( stdout,'(a,f12.8)') ' rhov: dw g-space = ', & - & omegab*DBLE(qgbt(1,2)) - WRITE( stdout,'(a,f12.8)') ' rhov: dw r-sp = ', & - & omegab*AIMAG(ca)/(nr1b*nr2b*nr3b) - ENDIF -! -! add qv(r) to v(r), in real space on the dense grid -! - CALL box2grid2(irb(1,isa),qv,v) - 25 isa=isa+1 -! - END DO - END DO -! - DO ir=1,nnr - rhor(ir,isup)=rhor(ir,isup)+DBLE(v(ir)) - rhor(ir,isdw)=rhor(ir,isdw)+AIMAG(v(ir)) - END DO -! - IF(iprsta.GT.2) THEN - ca = SUM(v) - CALL mp_sum( ca, intra_image_comm ) - WRITE( stdout,'(a,2f12.8)') 'rhov:in n_v ',omega*ca/(nr1*nr2*nr3) - ENDIF -! -! IF(lgam) THEN - CALL fwfft('Dense',v, dfftp ) -! ELSE -! DO ir=1,nnr -! v(ir) = CMPLX(rhor(ir,isup),0.d0) -! v_c(ir) = CMPLX(rhor(ir,isdw),0.d0) -! END DO - -! CALL fwfft('Dense',v, dfftp ) -! CALL fwfft('Dense',v_c, dfftp ) -! ENDIF -! - IF(iprsta.GT.2) THEN - WRITE( stdout,*) 'rhov: smooth up',omega*rhog(1,isup) - WRITE( stdout,*) 'rhov: smooth dw',omega*rhog(1,isdw) - WRITE( stdout,*) 'rhov: vander up',omega*DBLE(v(1)) - WRITE( stdout,*) 'rhov: vander dw',omega*AIMAG(v(1)) - WRITE( stdout,*) 'rhov: all up', & - & omega*(rhog(1,isup)+DBLE(v(1))) - WRITE( stdout,*) 'rhov: all dw', & - & omega*(rhog(1,isdw)+AIMAG(v(1))) - ENDIF -! -! IF(lgam) THEN - DO ig=1,ng - fp= v(np(ig)) + v(nm(ig)) - fm= v(np(ig)) - v(nm(ig)) - rhog(ig,isup)=rhog(ig,isup) + 0.5d0*CMPLX(DBLE(fp),AIMAG(fm)) - rhog(ig,isdw)=rhog(ig,isdw) + 0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - END DO -! ELSE -! DO ig=1,ng -! fp= v(np(ig)) !+ v(nm(ig)) -! fm= v_c(np(ig)) !- v(nm(ig)) -! rhog(ig,isup)=rhog(ig,isup) + fp !CMPLX(DBLE(fp),AIMAG(fm)) -! rhog(ig,isdw)=rhog(ig,isdw) + fm !CMPLX(AIMAG(fp),-DBLE(fm)) -! END DO -! ENDIF - -! - IF(iprsta.GT.2) WRITE( stdout,'(a,2f12.8)') & - & ' rhov: n_v(g=0) up = ',omega*DBLE (rhog(1,isup)) - IF(iprsta.GT.2) WRITE( stdout,'(a,2f12.8)') & - & ' rhov: n_v(g=0) down = ',omega*DBLE(rhog(1,isdw)) -! -! IF(.not.lgam) THEN -! DEALLOCATE(v_c) -! ENDIF - ENDIF - - DEALLOCATE(qgbt) - DEALLOCATE( v ) - - DEALLOCATE( qv ) - - CALL stop_clock( 'rhov' ) -! - RETURN -END SUBROUTINE rhov diff --git a/quantum_espresso/kcp/CPV/chargemix.f90 b/quantum_espresso/kcp/CPV/chargemix.f90 deleted file mode 100644 index 8c8d5740d..000000000 --- a/quantum_espresso/kcp/CPV/chargemix.f90 +++ /dev/null @@ -1,148 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -#include "f_defs.h" - -! AB INITIO COSTANT PRESSURE MOLECULAR DYNAMICS -! ---------------------------------------------- -! Car-Parrinello Parallel Program -! Carlo Cavazzoni - Gerardo Ballabio -! SISSA, Trieste, Italy - 1997-99 -! Last modified: Sun Nov 21 13:29:38 MET 1999 -! ---------------------------------------------- -! BEGIN manual - -!=----------------------------------------------------------------------------=! - MODULE charge_mix -!=----------------------------------------------------------------------------=! - -! (describe briefly what this module does...) -! ---------------------------------------------- -! routines in this module: -! SUBROUTINE allocate_charge_mix(ng_l) -! SUBROUTINE deallocate_charge_mix -! SUBROUTINE charge_mix_print_info(unit) -! SUBROUTINE newrho(rhor,nfi,tcel,drho) -! SUBROUTINE invgen(aa,dimaa) -! ---------------------------------------------- -! END manual - - USE kinds - IMPLICIT NONE - SAVE - - PRIVATE - -! ... declare module-scope variables - REAL(DP) :: achmix - REAL(DP) :: g1met2 - REAL(DP) :: g0chmix2 - INTEGER :: daamax - - REAL(DP), ALLOCATABLE :: aa_save(:,:) - COMPLEX(DP), ALLOCATABLE :: rho(:,:) - COMPLEX(DP), ALLOCATABLE :: rr(:,:) - COMPLEX(DP), ALLOCATABLE :: chmix(:) - COMPLEX(DP), ALLOCATABLE :: metric(:) - -! ... end of module-scope declarations -! ---------------------------------------------- - - PUBLIC :: charge_mix_setup - PUBLIC :: allocate_charge_mix, deallocate_charge_mix - PUBLIC :: charge_mix_print_info - PUBLIC :: chmix, metric, rho, rr, aa_save - PUBLIC :: achmix, g1met2, g0chmix2, daamax - -!=----------------------------------------------------------------------------=! - CONTAINS -!=----------------------------------------------------------------------------=! - -! subroutines -! ---------------------------------------------- -! ---------------------------------------------- - - SUBROUTINE charge_mix_setup(achmix_inp, g0chmix2_inp, daamax_inp, g1met2_inp) - REAL(DP), INTENT(IN) :: achmix_inp, g0chmix2_inp - REAL(DP), INTENT(IN) :: g1met2_inp - INTEGER, INTENT(IN) :: daamax_inp - achmix = achmix_inp - g0chmix2 = g0chmix2_inp - daamax = daamax_inp - g1met2 = g1met2_inp - RETURN - END SUBROUTINE charge_mix_setup - -! ---------------------------------------------- -! ---------------------------------------------- - - SUBROUTINE allocate_charge_mix(ng) - INTEGER, INTENT(IN) :: ng - INTEGER :: ierr - ALLOCATE( rho(ng, daamax), STAT=ierr ) - IF( ierr /= 0 ) CALL errore(' allocate_charge_mix ', ' allocating rho ', ierr) - ALLOCATE( rr(ng, daamax), STAT=ierr ) - IF( ierr /= 0 ) CALL errore(' allocate_charge_mix ', ' allocating rr ', ierr) - ALLOCATE( aa_save(daamax, daamax), STAT=ierr ) - IF( ierr /= 0 ) CALL errore(' allocate_charge_mix ', ' allocating aa_save ', ierr) - ALLOCATE( chmix(ng), STAT=ierr ) - IF( ierr /= 0 ) CALL errore(' allocate_charge_mix ', ' allocating chmix ', ierr) - ALLOCATE( metric(ng), STAT=ierr ) - IF( ierr /= 0 ) CALL errore(' allocate_charge_mix ', ' allocating metric ', ierr) - RETURN - END SUBROUTINE allocate_charge_mix - -! ---------------------------------------------- -! ---------------------------------------------- - - SUBROUTINE deallocate_charge_mix - INTEGER :: ierr - IF( ALLOCATED(rho) ) THEN - DEALLOCATE(rho, STAT=ierr) - IF( ierr /= 0 ) CALL errore(' deallocate_charge_mix ', ' deallocating rho ', ierr) - END IF - IF( ALLOCATED(rr) ) THEN - DEALLOCATE(rr, STAT=ierr) - IF( ierr /= 0 ) CALL errore(' deallocate_charge_mix ', ' deallocating rr ', ierr) - END IF - IF( ALLOCATED(aa_save) ) THEN - DEALLOCATE(aa_save, STAT=ierr) - IF( ierr /= 0 ) CALL errore(' deallocate_charge_mix ', ' deallocating aa_save ', ierr) - END IF - IF( ALLOCATED(chmix) ) THEN - DEALLOCATE(chmix, STAT=ierr) - IF( ierr /= 0 ) CALL errore(' deallocate_charge_mix ', ' deallocating chmix ', ierr) - END IF - IF( ALLOCATED(metric) ) THEN - DEALLOCATE(metric, STAT=ierr) - IF( ierr /= 0 ) CALL errore(' deallocate_charge_mix ', ' deallocating metric ', ierr) - END IF - RETURN - END SUBROUTINE deallocate_charge_mix - -! ---------------------------------------------- -! ---------------------------------------------- - - SUBROUTINE charge_mix_print_info(unit) - INTEGER, INTENT(IN) :: unit - WRITE(unit,300) - WRITE(unit,310) achmix, g0chmix2, g1met2 - WRITE(unit,320) daamax -300 FORMAT(/,3X,'Charge mixing parameters:') -310 FORMAT( 3X,'A = ', D14.6, ' G0^2 = ', D14.6,' G1^2 = ',D14.6) -320 FORMAT( 3X,'charge mixing matrix maximum size = ', I5) - RETURN - END SUBROUTINE charge_mix_print_info - -! ---------------------------------------------- -! ---------------------------------------------- - -!=----------------------------------------------------------------------------=! - END MODULE charge_mix -!=----------------------------------------------------------------------------=! - diff --git a/quantum_espresso/kcp/CPV/chi2.f90 b/quantum_espresso/kcp/CPV/chi2.f90 deleted file mode 100644 index 7df4de3af..000000000 --- a/quantum_espresso/kcp/CPV/chi2.f90 +++ /dev/null @@ -1,132 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - module chi2 - - USE kinds - IMPLICIT NONE - SAVE - - PRIVATE - - COMPLEX(DP), allocatable :: VLOCAL(:) - COMPLEX(DP), allocatable :: RHOCHI(:) - logical :: tchi2 - - PUBLIC :: allocate_chi2, deallocate_chi2 - PUBLIC :: rhochi - - contains - - subroutine allocate_chi2(ng) - integer, intent(in) :: ng - allocate(VLOCAL(ng)) - allocate(RHOCHI(ng)) - end subroutine allocate_chi2 - - subroutine deallocate_chi2 - IF( ALLOCATED( vlocal ) ) DEALLOCATE(vlocal) - IF( ALLOCATED( rhochi ) ) DEALLOCATE(rhochi) - end subroutine deallocate_chi2 - - SUBROUTINE PRINTCHI2(box) - - USE cell_base, ONLY: tpiba, boxdimensions - use mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE io_global, ONLY: ionode - USE io_files, ONLY: chiunit, chifile - USE reciprocal_vectors, ONLY: gstart, gx - USE gvecp, ONLY: ngm - - IMPLICIT NONE - -!---------------------------------------------------ARGUMENT - type (boxdimensions), intent(in) :: box - REAL(DP) GXR,GYR,GZR -!---------------------------------------------------COMMON - - - COMPLEX(DP) :: CHI(3,3,3) - COMPLEX(DP) :: ctmp - REAL(DP) :: omega - INTEGER :: idum, ig, i, j, k - INTEGER :: ierr - - IF( .NOT. tchi2 ) RETURN - - omega = box%deth - - idum = 0 - -!======================================================================= -!== FFT: RHO(R) --> RHO(G) (IN ARRAY V) == -!======================================================================= - - CHI = 0.0d0 - DO IG = gstart, ngm - ctmp = CONJG(RHOCHI(IG))*VLOCAL(IG) - do i=1,3 - GXR = gx(i,IG)*TPIBA - do j=1,3 - GYR = gx(j,IG)*TPIBA - do k=1,3 - GZR = gx(k,IG)*TPIBA - CHI(i,j,k) = CHI(i,j,k) - GXR*GYR*GZR*ctmp - end do - end do - end do - END DO - DO IG = gstart, ngm - ctmp = RHOCHI(IG)*CONJG(VLOCAL(IG)) - do i=1,3 - GXR = -gx(i,IG)*TPIBA - do j=1,3 - GYR = -gx(j,IG)*TPIBA - do k=1,3 - GZR = -gx(k,IG)*TPIBA - CHI(i,j,k) = CHI(i,j,k) - GXR*GYR*GZR*ctmp - end do - end do - end do - END DO - - CALL mp_sum(CHI,intra_image_comm) -! - CHI = CHI * OMEGA * CMPLX(0.0d0,1.0d0) - - ierr = 0 - IF( ionode ) THEN - - OPEN(UNIT=chiunit, FILE=chifile, STATUS='unknown', POSITION='append', ERR=300) - - WRITE(chiunit,*) ' == CHI2 ==' - do i=1,3 - do j=1,3 - do k=1,3 - WRITE(chiunit,'(2X,3I3,2F12.4)') i, j, k, chi( i, j, k ) - end do - end do - end do - - CLOSE(UNIT=chiunit, ERR=300) - - GO TO 310 - 300 ierr = 1 - 310 CONTINUE - - END IF - - CALL mp_sum( ierr, intra_image_comm ) - IF( ierr > 0 ) & - CALL errore( ' printchi2 ', ' writing to file '//TRIM( chifile ), 1 ) - - RETURN - END SUBROUTINE PRINTCHI2 - - end module chi2 diff --git a/quantum_espresso/kcp/CPV/compute_fes_grads.f90 b/quantum_espresso/kcp/CPV/compute_fes_grads.f90 deleted file mode 100644 index d96179878..000000000 --- a/quantum_espresso/kcp/CPV/compute_fes_grads.f90 +++ /dev/null @@ -1,735 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!---------------------------------------------------------------------------- -SUBROUTINE compute_fes_grads( fii, lii, stat ) - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE input_parameters, ONLY : electron_damping, ekin_conv_thr, etot_conv_thr - USE wave_base, ONLY : frice - USE control_flags, ONLY : nomore, ldamped, tconvthrs, trane, ampre, & - nbeg, tfor, taurdr, tnosep, ndr, isave - USE metadyn_vars, ONLY : ncolvar, new_target, to_target, dfe_acc, & - sw_nstep, fe_nstep, eq_nstep, to_new_target - USE path_variables, ONLY : pos, grad_fes => grad_pes, & - num_of_images, istep_path, pending_image - USE constraints_module, ONLY : lagrange, constr_target, & - init_constraint, deallocate_constraint - USE cell_base, ONLY : alat, at - USE cp_main_variables, ONLY : nfi - USE ions_base, ONLY : tau, nat, nsp, ityp, sort_tau, & - tau_srt, ind_srt - USE path_formats, ONLY : scf_fmt, scf_fmt_para - USE io_files, ONLY : prefix, outdir, iunpath, iunaxsf - USE constants, ONLY : bohr_radius_angs - USE io_global, ONLY : stdout, ionode, ionode_id, meta_ionode - USE mp_global, ONLY : inter_image_comm, intra_image_comm, & - my_image_id, nimage, root_image - USE mp, ONLY : mp_bcast, mp_barrier, mp_sum, mp_min - USE check_stop, ONLY : check_stop_now - USE input, ONLY : modules_setup - USE xml_io_base, ONLY : check_restartfile - USE path_io_routines, ONLY : new_image_init, get_new_image, & - stop_other_images - USE metadyn_base, ONLY : add_domain_potential - USE metadyn_io, ONLY : write_axsf_file - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: fii, lii - LOGICAL, INTENT(OUT) :: stat - INTEGER :: image - CHARACTER(LEN=256) :: outdir_saved, filename - LOGICAL :: file_exists, opnd - LOGICAL :: tnosep_saved - REAL(DP) :: tcpu - REAL(DP), ALLOCATABLE :: tauout(:,:), fion(:,:) - REAL(DP) :: etot - CHARACTER(LEN=10) :: stage - INTEGER :: fe_step0, sw_step0 - ! - CHARACTER(LEN=6), EXTERNAL :: int_to_char - REAL(DP), EXTERNAL :: get_clock - ! - ! - stat = .TRUE. - ! - ALLOCATE( tauout( 3, nat ), fion( 3, nat ) ) - ! - ! ... out positions are initialised to the input ones - ! - tauout(:,:) = tau(:,:) - ! - CALL flush_unit( iunpath ) - ! - outdir_saved = outdir - tnosep_saved = tnosep - ! - ! ... vectors pes and grad_pes are initalized to zero for all images on - ! ... all nodes: this is needed for the final mp_sum() - ! - IF ( my_image_id == root_image ) THEN - ! - grad_fes(:,:) = 0.D0 - ! - ELSE - ! - grad_fes(:,fii:lii) = 0.D0 - ! - END IF - ! - ! ... only the first cpu initializes the file needed by parallelization - ! ... among images - ! - IF ( meta_ionode ) CALL new_image_init( fii, outdir_saved ) - ! - image = fii + my_image_id - ! - ! ... all processes are syncronized (needed to have an ordered output) - ! - CALL mp_barrier() - ! - fes_loop: DO - ! - ! ... exit if available images are finished - ! - IF ( image > lii ) EXIT fes_loop - ! - pending_image = image - ! - IF ( check_stop_now( iunpath ) ) THEN - ! - stat = .FALSE. - ! - ! ... in case of parallelization on images a stop signal - ! ... is sent via the "EXIT" file - ! - IF ( nimage > 1 ) CALL stop_other_images() - ! - EXIT fes_loop - ! - END IF - ! - ! ... calculation of the mean-force - ! - tcpu = get_clock( 'CP' ) - ! - IF ( nimage > 1 ) THEN - ! - WRITE( UNIT = iunpath, FMT = scf_fmt_para ) my_image_id, tcpu, image - ! - ELSE - ! - WRITE( UNIT = iunpath, FMT = scf_fmt ) tcpu, image - ! - END IF - ! - outdir = TRIM( outdir_saved ) // "/" // TRIM( prefix ) // & - & "_" // TRIM( int_to_char( image ) ) // "/" - ! - ! ... unit stdout is connected to the appropriate file - ! - IF ( ionode ) THEN - ! - INQUIRE( UNIT = stdout, OPENED = opnd ) - IF ( opnd ) CLOSE( UNIT = stdout ) - OPEN( UNIT = stdout, FILE = TRIM( outdir ) // 'CP.out', & - STATUS = 'UNKNOWN', POSITION = 'APPEND' ) - ! - END IF - ! - ! ... initialization - ! - CALL deallocate_modules_var() - CALL deallocate_constraint() - ! - CALL modules_setup() - ! - filename = TRIM( outdir ) // "therm_average.restart" - ! - INQUIRE( FILE = filename, EXIST = file_exists ) - ! - IF ( file_exists ) THEN - ! - ! ... we read the previous positions, the value of the accumulators, - ! ... and the number of steps already performed for this image from - ! ... a restart file - ! - IF ( ionode ) THEN - ! - OPEN( UNIT = 1000, FILE = filename ) - ! - READ( 1000, * ) stage - READ( 1000, * ) tau(:,:) - READ( 1000, * ) nomore - READ( 1000, * ) to_target - READ( 1000, * ) dfe_acc - ! - CLOSE( UNIT = 1000 ) - ! - END IF - ! - CALL mp_bcast( stage, ionode_id ) - CALL mp_bcast( tau, ionode_id ) - CALL mp_bcast( nomore, ionode_id ) - CALL mp_bcast( to_target, ionode_id ) - CALL mp_bcast( dfe_acc, ionode_id ) - ! - ELSE - ! - ! ... otherwise we use the output positions from the previous image - ! - tau(:,:) = tauout(:,:) - ! - stage = 'tobedone' - ! - END IF - ! - CALL sort_tau( tau_srt, ind_srt, tau, ityp, nat, nsp ) - ! - CALL init_constraint( nat, tau, ityp, 1.D0 ) - ! - fe_step0 = 0 - sw_step0 = 0 - ! - SELECT CASE( stage ) - CASE( 'done' ) - ! - ! ... do nothing and recompute the average quantities - ! - CASE( 'tobedone' ) - ! - new_target(:) = pos(:,image) - ! - to_target(:) = ( new_target(:) - & - constr_target(1:ncolvar) ) / DBLE( sw_nstep ) - ! - stage = 'switch' - ! - dfe_acc = 0.D0 - ! - CASE( 'switch' ) - ! - dfe_acc = 0.D0 - ! - sw_step0 = nomore - ! - CASE( 'mean-force' ) - ! - fe_step0 = nomore - ! - CASE DEFAULT - ! - CALL errore( 'compute_fes_grads', & - 'stage ' // TRIM( stage ) // ' unknown', 1 ) - ! - END SELECT - ! - IF ( stage /= 'done' ) THEN - ! - ! ... first we do a wavefunctions optimisation to bring the system - ! ... on the BO surface - ! - tconvthrs%ekin = ekin_conv_thr - tconvthrs%derho = etot_conv_thr - ! - taurdr = .TRUE. - nfi = 0 - tnosep = .FALSE. - tfor = .FALSE. - ! - frice = electron_damping - ! - tconvthrs%active = .TRUE. - ! - IF ( check_restartfile( outdir, ndr ) ) THEN - ! - WRITE( stdout, '(/,3X,"restarting from file",/)' ) - ! - nbeg = 0 - nomore = 50 - ! - ELSE - ! - WRITE( stdout, '(/,3X,"restarting from scratch",/)' ) - ! - nbeg = -1 - nomore = 100 - trane = .TRUE. - ampre = 0.02D0 - ! - END IF - ! - isave = nomore - ! - CALL init_run() - ! - CALL cprmain( tauout, fion, etot ) - ! - tfor = .TRUE. - tnosep = tnosep_saved - ! - END IF - ! - IF ( stage == 'switch' ) THEN - ! - ! ... first the collective variables are "adiabatically" changed to - ! ... the new vales by using MD without damping - ! - WRITE( stdout, '(/,5X,"adiabatic switch of the system ", & - & "to the new coarse-grained positions",/)' ) - ! - nfi = sw_step0 - nomore = sw_nstep - isave = sw_nstep - ! - frice = electron_damping - ! - tconvthrs%active = .FALSE. - to_new_target = .TRUE. - ! - IF ( ldamped ) CALL reset_vel() - ! - CALL cprmain( tauout, fion, etot ) - ! - stage = 'mean-force' - ! - CALL write_restart( 'mean-force', 0 ) - ! - END IF - ! - IF ( stage == 'mean-force' ) THEN - ! - ! ... then the free energy gradients are computed - ! - WRITE( stdout, '(/,5X,"calculation of the mean force",/)' ) - ! - nfi = fe_step0 - nomore = fe_nstep - isave = fe_nstep - ! - IF ( ldamped ) THEN - ! - frice = electron_damping - ! - tconvthrs%active = .TRUE. - ! - CALL reset_vel() - ! - ELSE - ! - frice = 0.D0 - ! - tconvthrs%active = .FALSE. - ! - END IF - ! - to_new_target = .FALSE. - ! - CALL cprmain( tauout, fion, etot ) - ! - END IF - ! - ! ... the averages are computed here - ! - IF ( ldamped ) THEN - ! - ! ... zero temperature case - ! - grad_fes(:,image) = - lagrange(1:ncolvar) - ! - ELSE - ! - ! ... finite temperature case - ! - grad_fes(:,image) = dfe_acc(:) / DBLE( fe_nstep - eq_nstep ) - ! - END IF - ! - ! ... notice that grad_fes(:,image) have been computed, so far, by - ! ... ionode only: here we broadcast to all the other cpus - ! - CALL mp_bcast( grad_fes(:,image), ionode_id, intra_image_comm ) - ! - IF ( ionode ) THEN - ! - ! ... the restart file is written here - ! - CALL write_restart( 'done', 0 ) - ! - CALL write_axsf_file( image, tauout, 1.D0 ) - ! - END IF - ! - ! ... the new image is obtained - ! - CALL get_new_image( image, outdir_saved ) - ! - CALL mp_bcast( image, ionode_id, intra_image_comm ) - ! - END DO fes_loop - ! - CALL mp_barrier() - ! - IF ( meta_ionode ) THEN - ! - ! ... when all the images are done the stage is changed from - ! ... 'done' to 'tobedone' - ! - DO image = fii, lii - ! - outdir = TRIM(outdir_saved ) // TRIM( prefix ) // & - & "_" // TRIM( int_to_char( image ) ) // "/" - ! - filename = TRIM( outdir ) // "therm_average.restart" - ! - OPEN( UNIT = 1000, FILE = filename ) - ! - READ( 1000, * ) stage - READ( 1000, * ) tauout(:,:) - READ( 1000, * ) nomore - READ( 1000, * ) to_target - READ( 1000, * ) dfe_acc - ! - CLOSE( UNIT = 1000 ) - ! - CALL write_restart( 'tobedone', 0 ) - ! - END DO - ! - ! ... here the meta_ionode writes the axsf file for this iteration - ! ... by reading the postions from the restart-file - ! - filename = TRIM( prefix ) // "_" // & - & TRIM( int_to_char( istep_path + 1 ) ) // ".axsf" - ! - OPEN( UNIT = iunaxsf, FILE = filename, ACTION = "WRITE" ) - ! - WRITE( UNIT = iunaxsf, FMT = '(" ANIMSTEPS ",I5)' ) num_of_images - WRITE( UNIT = iunaxsf, FMT = '(" CRYSTAL ")' ) - WRITE( UNIT = iunaxsf, FMT = '(" PRIMVEC ")' ) - WRITE( UNIT = iunaxsf, FMT = '(3F14.10)' ) & - at(1,1)*alat*bohr_radius_angs, & - at(2,1)*alat*bohr_radius_angs, & - at(3,1)*alat*bohr_radius_angs - WRITE( UNIT = iunaxsf, FMT = '(3F14.10)' ) & - at(1,2)*alat*bohr_radius_angs, & - at(2,2)*alat*bohr_radius_angs, & - at(3,2)*alat*bohr_radius_angs - WRITE( UNIT = iunaxsf, FMT = '(3F14.10)' ) & - at(1,3)*alat*bohr_radius_angs, & - at(2,3)*alat*bohr_radius_angs, & - at(3,3)*alat*bohr_radius_angs - ! - DO image = 1, num_of_images - ! - outdir = TRIM( outdir_saved ) // TRIM( prefix ) // & - & "_" // TRIM( int_to_char( image ) ) // "/" - ! - filename = TRIM( outdir ) // "therm_average.restart" - ! - OPEN( UNIT = 1000, FILE = filename ) - ! - READ( 1000, * ) stage - READ( 1000, * ) tauout(:,:) - ! - CLOSE( UNIT = 1000 ) - ! - CALL write_axsf_file( image, tauout, 1.D0 ) - ! - END DO - ! - CLOSE( UNIT = iunaxsf ) - ! - END IF - ! - CALL add_domain_potential() - ! - DEALLOCATE( tauout, fion ) - ! - outdir = outdir_saved - tnosep = tnosep_saved - ! - IF ( nimage > 1 ) THEN - ! - ! ... grad_fes is communicated among "image" pools - ! - CALL mp_sum( grad_fes(:,fii:lii), inter_image_comm ) - ! - END IF - ! - pending_image = 0 - ! - RETURN - ! - CONTAINS - ! - !------------------------------------------------------------------------ - SUBROUTINE write_restart( stage, nstep ) - !------------------------------------------------------------------------ - ! - CHARACTER(LEN=*), INTENT(IN) :: stage - INTEGER, INTENT(IN) :: nstep - ! - OPEN( UNIT = 1000, FILE = filename ) - ! - WRITE( 1000, * ) TRIM( stage ) - WRITE( 1000, * ) tauout(:,:) - WRITE( 1000, * ) nstep - WRITE( 1000, * ) to_target - WRITE( 1000, * ) dfe_acc - ! - CLOSE( UNIT = 1000 ) - ! - END SUBROUTINE write_restart - ! -END SUBROUTINE compute_fes_grads -! -!---------------------------------------------------------------------------- -SUBROUTINE metadyn() - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE input_parameters, ONLY : electron_damping, ekin_conv_thr, etot_conv_thr - USE constraints_module, ONLY : constr_target, lagrange - USE cp_main_variables, ONLY : nfi - USE wave_base, ONLY : frice - USE control_flags, ONLY : nomore, ldamped, tconvthrs, tnosep, trane, & - ampre, nbeg, tfor, taurdr, ndr, ndw, isave - USE ions_base, ONLY : nat - USE io_global, ONLY : stdout, ionode, ionode_id - USE io_files, ONLY : iunmeta, iunaxsf, outdir - USE metadyn_vars, ONLY : ncolvar, fe_grad, & - metadyn_fmt, to_new_target, & - metadyn_history, max_metadyn_iter, & - first_metadyn_iter, fe_nstep, sw_nstep, & - eq_nstep, dfe_acc, etot_av, gaussian_pos - USE metadyn_base, ONLY : add_gaussians, add_domain_potential, & - evolve_collective_vars - USE metadyn_io, ONLY : write_axsf_file, write_metadyn_restart - USE mp_global, ONLY : intra_image_comm - USE xml_io_base, ONLY : restart_dir, check_restartfile - USE time_step, ONLY : delt, set_time_step - USE mp, ONLY : mp_bcast - USE basic_algebra_routines - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: dirname - INTEGER :: iter - REAL(DP), ALLOCATABLE :: tau(:,:) - REAL(DP), ALLOCATABLE :: fion(:,:) - REAL(DP) :: etot, norm_fe_grad, delt_saved - LOGICAL :: do_first_scf - LOGICAL :: tnosep_saved - ! - ! - dirname = restart_dir( outdir, ndw ) - ! - ALLOCATE( tau( 3, nat ), fion( 3, nat ) ) - ! - tnosep_saved = tnosep - ! - taurdr = .TRUE. - nfi = 0 - tfor = .FALSE. - ! - tconvthrs%ekin = ekin_conv_thr - tconvthrs%derho = etot_conv_thr - ! - delt_saved = delt - ! - IF ( nbeg == - 1 ) THEN - ! - WRITE( stdout, '(/,3X,"restarting from scratch",/)' ) - ! - do_first_scf = .TRUE. - ! - nomore = 200 - trane = .TRUE. - ampre = 0.02D0 - ! - tnosep = .FALSE. - ! - tconvthrs%active = .TRUE. - ! - ! ... set a smaller value of time-step and a larger one for friction just - ! ... for the wavefunction optimisation - ! - frice = MIN( 0.2D0, 2.D0*electron_damping ) - ! - delt = MAX( 4.D0, 0.5D0*delt ) - ! - CALL set_time_step( delt ) - ! - ELSE IF ( check_restartfile( outdir, ndr ) ) THEN - ! - WRITE( stdout, '(/,3X,"restarting from file",/)' ) - ! - do_first_scf = .FALSE. - ! - nbeg = 0 - ! - END IF - ! - isave = nomore - ! - CALL init_run() - ! - IF ( do_first_scf ) THEN - ! - ! ... first we bring the system on the BO surface - ! - CALL cprmain( tau, fion, etot ) - ! - CALL set_time_step( delt_saved ) - ! - END IF - ! - tfor = .TRUE. - tnosep = tnosep_saved - iter = first_metadyn_iter - ! - metadyn_loop: DO - ! - IF ( iter > 0 ) THEN - ! - CALL add_gaussians( iter ) - ! - CALL add_domain_potential() - ! - norm_fe_grad = norm( fe_grad ) - ! - CALL evolve_collective_vars( norm_fe_grad ) - ! - ! ... the system is "adiabatically" moved to the new constr_target - ! - WRITE( stdout, '(/,5X,"adiabatic switch of the system ", & - & "to the new coarse-grained positions",/)' ) - ! - nfi = 0 - nomore = sw_nstep - isave = nomore - ! - tconvthrs%active = .FALSE. - to_new_target = .TRUE. - ! - frice = electron_damping - ! - IF ( ldamped ) CALL reset_vel() - ! - CALL cprmain( tau, fion, etot ) - ! - END IF - ! - iter = iter + 1 - ! - metadyn_history(:,iter) = gaussian_pos(:) - ! - IF ( ionode ) CALL write_axsf_file( iter, tau, 1.D0 ) - ! - WRITE( stdout, '(/,5X,"calculation of the mean force",/)' ) - ! - nfi = 0 - nomore = fe_nstep - isave = fe_nstep - ! - IF ( ldamped ) THEN - ! - tconvthrs%active = .TRUE. - ! - frice = electron_damping - ! - CALL reset_vel() - ! - ELSE - ! - frice = 0.D0 - ! - END IF - ! - to_new_target = .FALSE. - ! - dfe_acc(:) = 0.D0 - ! - CALL cprmain( tau, fion, etot ) - ! - ! ... the averages are computed here - ! - IF ( ldamped ) THEN - ! - ! ... zero temperature case - ! - etot_av = etot - ! - fe_grad(:) = - lagrange(1:ncolvar) - ! - ELSE - ! - ! ... finite temperature case - ! - etot_av = etot_av / DBLE( nomore ) - ! - fe_grad(:) = dfe_acc(:) / DBLE( fe_nstep - eq_nstep ) - ! - END IF - ! - ! ... notice that etot_av and fe_grad have been computed, so far, by - ! ... ionode only: here we broadcast to all the other cpus - ! - CALL mp_bcast( etot_av, ionode_id, intra_image_comm ) - CALL mp_bcast( fe_grad, ionode_id, intra_image_comm ) - ! - IF ( ionode ) THEN - ! - WRITE( UNIT = iunmeta, FMT = metadyn_fmt ) & - iter, constr_target(1:ncolvar), etot_av, gaussian_pos(:), fe_grad(:) - ! - CALL flush_unit( iunmeta ) - CALL flush_unit( iunaxsf ) - ! - END IF - ! - CALL write_metadyn_restart( dirname, iter, tau, etot_av, 1.D0 ) - ! - IF ( iter >= max_metadyn_iter ) EXIT metadyn_loop - ! - END DO metadyn_loop - ! - IF ( ionode ) THEN - ! - CLOSE( UNIT = iunaxsf ) - CLOSE( UNIT = iunmeta ) - ! - END IF - ! - tnosep = tnosep_saved - ! - DEALLOCATE( tau, fion ) - ! - RETURN - ! -END SUBROUTINE metadyn -! -!------------------------------------------------------------------------ -SUBROUTINE reset_vel() - !------------------------------------------------------------------------ - ! - USE ions_positions, ONLY : tau0, taum, taus, tausm - ! - IMPLICIT NONE - ! - ! - taum(:,:) = tau0(:,:) - tausm(:,:) = taus(:,:) - ! - RETURN - ! -END SUBROUTINE reset_vel diff --git a/quantum_espresso/kcp/CPV/compute_scf.f90 b/quantum_espresso/kcp/CPV/compute_scf.f90 deleted file mode 100644 index e318dcf9c..000000000 --- a/quantum_espresso/kcp/CPV/compute_scf.f90 +++ /dev/null @@ -1,175 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!---------------------------------------------------------------------------- -SUBROUTINE compute_scf( N_in, N_fin, stat ) - !---------------------------------------------------------------------------- - ! - ! ... this subroutine is the main scf-driver for all "path" calculations - ! ... ( called by Modules/path_base.f90/born_oppenheimer() subroutine ) - ! - USE kinds, ONLY : DP - USE ions_base, ONLY : nat, sort_tau, tau_srt, ind_srt, ityp, nsp - USE control_flags, ONLY : conv_elec, ndr, program_name, nbeg, taurdr, & - trane, ampre, nomore, tfor, isave - USE cp_main_variables, ONLY : nfi - USE io_files, ONLY : iunpath, outdir, prefix - USE io_global, ONLY : stdout, ionode - USE path_formats, ONLY : scf_fmt - USE path_variables, ONLY : pos, pes, grad_pes, & - dim1, pending_image, frozen - USE check_stop, ONLY : check_stop_now - USE xml_io_base, ONLY : check_restartfile - USE cp_interfaces, ONLY : main_fpmd - USE input, ONLY : modules_setup - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: N_in, N_fin - LOGICAL, INTENT(OUT) :: stat - ! - INTEGER :: image - REAL(DP) :: tcpu - CHARACTER(LEN=256) :: outdir_saved - LOGICAL :: opnd - REAL(DP), ALLOCATABLE :: tau(:,:) - REAL(DP), ALLOCATABLE :: fion(:,:) - REAL(DP) :: etot - ! - CHARACTER(LEN=6), EXTERNAL :: int_to_char - REAL(DP), EXTERNAL :: get_clock - ! - ! - stat = .TRUE. - tcpu = 0.D0 - ! - ALLOCATE( tau( 3, nat ), fion( 3, nat ) ) - ! - outdir_saved = outdir - ! - DO image = N_in, N_fin - ! - IF ( frozen(image) ) CYCLE - ! - pending_image = image - ! - IF ( check_stop_now() ) THEN - ! - stat = .FALSE. - ! - RETURN - ! - END IF - ! - outdir = TRIM( outdir_saved ) // "/" // TRIM( prefix ) // "_" // & - TRIM( int_to_char( image ) ) // "/" - ! - tcpu = get_clock( 'CP' ) - ! - WRITE( UNIT = iunpath, FMT = scf_fmt ) tcpu, image - ! - ! ... unit stdout is connected to the appropriate file - ! - IF ( ionode ) THEN - ! - INQUIRE( UNIT = stdout, OPENED = opnd ) - IF ( opnd ) CLOSE( UNIT = stdout ) - OPEN( UNIT = stdout, FILE = TRIM( outdir ) // 'CP.out', & - STATUS = 'UNKNOWN', POSITION = 'APPEND' ) - ! - END IF - ! - CALL deallocate_modules_var() - ! - CALL modules_setup() - ! - tau = RESHAPE( pos(:,image), SHAPE( tau ) ) - ! - CALL sort_tau( tau_srt, ind_srt, tau, ityp, nat, nsp ) - ! - taurdr = .TRUE. - nfi = 0 - tfor = .FALSE. - ! - IF ( check_restartfile( outdir, ndr ) ) THEN - ! - WRITE( stdout, '(/,2X,"restarting from file",/)' ) - ! - nbeg = 0 - nomore = 2000 - trane = .FALSE. - ampre = 0.0D0 - ! - ELSE - ! - WRITE( stdout, '(/,2X,"restarting from scratch",/)' ) - ! - nbeg = -1 - nomore = 5000 - trane = .TRUE. - ampre = 0.02D0 - ! - END IF - ! - isave = nomore - ! - ! ... perform an electronic minimisation using main_fpmd - ! - CALL init_run() - ! - IF ( program_name == 'CP90' ) THEN - ! - CALL cprmain( tau, fion, etot ) - ! - ELSE IF ( program_name == 'FPMD' ) THEN - ! - CALL main_fpmd( tau, fion, etot ) - ! - ELSE - ! - CALL errore( 'compute_scf ', 'unknown program', 1 ) - ! - END IF - ! - IF ( ionode ) THEN - ! - INQUIRE( UNIT = stdout, OPENED = opnd ) - IF ( opnd ) CLOSE( UNIT = stdout ) - ! - END IF - ! - IF ( .NOT. conv_elec ) THEN - ! - WRITE( iunpath, '(/,5X,"WARNING : scf convergence NOT achieved",/)' ) - ! - stat = .FALSE. - ! - RETURN - ! - END IF - ! - ! ... gradients already in ( hartree / bohr ) - ! - grad_pes(:,image) = - RESHAPE( fion, (/ dim1 /) ) - ! - ! ... energy already in hartree - ! - pes(image) = etot - ! - END DO - ! - outdir = outdir_saved - ! - pending_image = 0 - ! - DEALLOCATE( tau, fion ) - ! - RETURN - ! -END SUBROUTINE compute_scf diff --git a/quantum_espresso/kcp/CPV/cp_autopilot.f90 b/quantum_espresso/kcp/CPV/cp_autopilot.f90 deleted file mode 100644 index 664bd516d..000000000 --- a/quantum_espresso/kcp/CPV/cp_autopilot.f90 +++ /dev/null @@ -1,413 +0,0 @@ -! cp_autopilot.f90 -!******************************************************************************** -! cp_autopilot.f90 Copyright (c) 2005 Targacept, Inc. -!******************************************************************************** -! The Autopilot Feature suite is a user level enhancement that enables the -! following features: -! automatic restart of a job; -! preconfiguration of job parameters; -! on-the-fly changes to job parameters; -! and pausing of a running job. -! -! For more information, see AUTOPILOT in document directory. -! -! This program is free software; you can redistribute it and/or modify it under -! the terms of the GNU General Public License as published by the Free Software -! Foundation; either version 2 of the License, or (at your option) any later version. -! This program is distributed in the hope that it will be useful, but WITHOUT ANY -! WARRANTY; without even the implied warranty of MERCHANTABILITY FOR A PARTICULAR -! PURPOSE. See the GNU General Public License at www.gnu.or/copyleft/gpl.txt for -! more details. -! -! THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. -! EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -! PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND THE -! PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, -! YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. -! -! IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING, -! WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE -! THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY -! GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR -! INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA -! BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A -! FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER -! OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. -! -! You should have received a copy of the GNU General Public License along with -! this program; if not, write to the -! Free Software Foundation, Inc., -! 51 Franklin Street, -! Fifth Floor, -! Boston, MA 02110-1301, USA. -! -! Targacept's address is -! 200 East First Street, Suite 300 -! Winston-Salem, North Carolina USA 27101-4165 -! Attn: Molecular Design. -! Email: atp@targacept.com -! -! This work was supported by the Advanced Technology Program of the -! National Institute of Standards and Technology (NIST), Award No. 70NANB3H3065 -! -!******************************************************************************** - - -MODULE cp_autopilot - !--------------------------------------------------------------------------- - ! - ! This module handles the Autopilot Feature Suite - ! Written by Lee Atkinson, with help from the ATP team at Targacept, Inc - ! Created June 2005 - ! Modified by Yonas Abrahm Sept 2006 - ! - ! The address for Targacept, Inc. is: - ! 200 East First Street, Suite - ! 300, Winston-Salem, North Carolina 27101; - ! Attn: Molecular Design. - ! - ! See README.AUTOPILOT in the Doc directory for more information. - !--------------------------------------------------------------------------- - - USE kinds - USE parser, ONLY : read_line - USE autopilot, ONLY : current_nfi, pilot_p, pilot_unit, pause_p,auto_error, & - & parse_mailbox, rule_isave, rule_iprint, rule_dt, rule_emass, & - & rule_electron_dynamics, rule_electron_damping, rule_ion_dynamics, & - & rule_ion_damping, rule_ion_temperature, rule_tempw - USE autopilot, ONLY : event_index, event_step, event_isave, event_iprint, & - & event_dt, event_emass, event_electron_dynamics, event_electron_damping, & - & event_ion_dynamics, event_ion_damping, event_ion_temperature, event_tempw - - IMPLICIT NONE - SAVE - - - PRIVATE - PUBLIC :: pilot, employ_rules - -CONTAINS - - - !----------------------------------------------------------------------- - ! EMPLOY_RULES - !----------------------------------------------------------------------- - SUBROUTINE employ_rules() - USE input_parameters, ONLY : dt, & - & electron_dynamics, electron_damping, & - & ion_dynamics, ion_damping, & - & ion_temperature, fnosep, nhpcl, nhptyp, nhgrp, fnhscl, ndega - use ions_nose, ONLY: tempw - USE control_flags, only: tsde, tsdp, tfor, tcp, tnosep, isave,iprint,& - tconvthrs, tolp,ldamped, & - ekin_conv_thr, forc_conv_thr, etot_conv_thr - USE control_flags, only: tsteepdesc_ => tsteepdesc, & - tdamp_ => tdamp, & - tdampions_ => tdampions - use wave_base, only: frice - use ions_base, only: fricp - USE ions_nose, ONLY: ions_nose_init - USE time_step, ONLY : set_time_step - USE cp_electronic_mass, ONLY: emass - IMPLICIT NONE - - - ! This is notification to stdout - ! It helps the user to identify - ! when rules are employed - write(*,*) - write(*,*) '========================================' - write(*,*) 'EMPLOY RULES:' - write(*,*) ' CURRENT_NFI=', current_nfi - write(*,*) ' event_index=', event_index - write(*,*) ' event_step==', event_step(event_index) - write(*,*) '========================================' - write(*,*) - call flush_unit(6) - - - !---------------------------------------- - ! &CONTROL - !---------------------------------------- - - ! ISAVE - if (event_isave(event_index)) then - isave = rule_isave(event_index) - write(*,*) 'RULE EVENT: isave', isave - endif - - ! IPRINT - if (event_iprint(event_index)) then - iprint = rule_iprint(event_index) - write(*,*) 'RULE EVENT: iprint', iprint - endif - - if (event_dt(event_index)) then - dt = rule_dt(event_index) - CALL set_time_step( dt ) - write(*,*) 'RULE EVENT: dt', dt - endif - - !---------------------------------------- - ! &SYSTEM - !---------------------------------------- - - !---------------------------------------- - ! &ELECTRONS - !---------------------------------------- - - ! EMASS - if (event_emass(event_index)) then - emass = rule_emass(event_index) - write(*,*) 'RULE EVENT: emass', emass - endif - - ! ELECTRON_DYNAMICS - - if (event_electron_dynamics(event_index)) then - electron_dynamics= rule_electron_dynamics(event_index) - tdamp_ = .FALSE. - tsteepdesc_ = .FALSE. - frice = 0.d0 - select case ( electron_dynamics ) - case ('SD') - tsde = .true. - case ('VERLET') - tsde = .false. - case ('DAMP') - tsde = .false. - tdamp_ = .TRUE. - frice = electron_damping - case ('NONE') - tsde = .false. - case default - call auto_error(' autopilot ',' unknown electron_dynamics '//trim(electron_dynamics) ) - end select - - write(*,*) 'RULE EVENT: electron_dynamics', electron_dynamics - - endif - - - ! ELECTRON_DAMPING - if (event_electron_damping(event_index)) then - ! meaningful only if " electron_dynamics = 'damp' " - electron_damping = rule_electron_damping(event_index) - frice = electron_damping - write(*,*) 'RULE EVENT: electron_damping', electron_damping - endif - - !---------------------------------------- - ! &IONS - !---------------------------------------- - - - ! ION_DYNAMICS - ! ion_dynamics = 'default' | 'sd' | 'cg' | 'damp' | 'md' | 'none' | 'diis' - if (event_ion_dynamics(event_index)) then - ion_dynamics= rule_ion_dynamics(event_index) - tdampions_ = .FALSE. - tconvthrs%active = .FALSE. - tconvthrs%nstep = 1 - tconvthrs%ekin = 0.0d0 - tconvthrs%derho = 0.0d0 - tconvthrs%force = 0.0d0 - - select case ( ion_dynamics ) - case ('SD') - tsdp = .true. - tfor = .true. - fricp= 0.d0 - tconvthrs%ekin = ekin_conv_thr - tconvthrs%derho = etot_conv_thr - tconvthrs%force = forc_conv_thr - tconvthrs%active = .TRUE. - tconvthrs%nstep = 1 - case ('VERLET') - tsdp = .false. - tfor = .true. - fricp= 0.d0 - case ('DAMP') - ldamped = .TRUE. - tsdp = .false. - tfor = .true. - tdampions_ = .TRUE. - fricp= ion_damping - tconvthrs%ekin = ekin_conv_thr - tconvthrs%derho = etot_conv_thr - tconvthrs%force = forc_conv_thr - tconvthrs%active = .TRUE. - tconvthrs%nstep = 1 - case ('NONE') - tsdp = .false. - tfor = .false. - fricp= 0.d0 - case default - call auto_error(' iosys ',' unknown ion_dynamics '//trim(ion_dynamics) ) - end select - - write(*,*) 'RULE EVENT: ion_dynamics', ion_dynamics - endif - - - ! ION_DAMPING - if (event_ion_damping(event_index)) then - ! meaningful only if " ion_dynamics = 'damp' " - ion_damping = rule_ion_damping(event_index) - write(*,*) 'RULE EVENT: ion_damping', ion_damping - endif - - - ! ION_TEMPERATURE - if (event_ion_temperature(event_index)) then - ion_temperature = rule_ion_temperature(event_index) - tcp = .FALSE. - tnosep = .FALSE. - tolp = tolp - select case ( ion_temperature ) - ! temperature control of ions via nose' thermostat - ! tempw (real(DP)) frequency (in which units?) - ! fnosep (real(DP)) temperature (in which units?) - case ('NOSE') - tnosep = .true. - tcp = .false. - case ('NOT_CONTROLLED') - tnosep = .false. - tcp = .false. - case ('RESCALING' ) - tnosep = .false. - tcp = .true. - case default - call auto_error(' iosys ',' unknown ion_temperature '//trim(ion_temperature) ) - end select - - write(*,*) 'RULE EVENT: ion_temperature', ion_temperature - - endif - - ! TEMPW - if (event_tempw(event_index)) then - tempw = rule_tempw(event_index) - ! The follwiong is a required side effect - ! when resetting tempw - CALL ions_nose_init( tempw, fnosep, nhpcl, nhptyp, ndega, nhgrp, fnhscl) - write(*,*) 'RULE EVENT: tempw', tempw - endif - - !---------------------------------------- - ! &CELL - !---------------------------------------- - - !---------------------------------------- - ! &PHONON - !---------------------------------------- - - - END SUBROUTINE employ_rules - - - - !----------------------------------------------------------------------- - ! PILOT - ! - ! Here is the main pilot routine called in CPR, at the top - ! of the basic dynamics loop just after nose hoover update - !----------------------------------------------------------------------- - subroutine pilot (nfi) - USE parser, ONLY: parse_unit - USE io_global, ONLY: ionode, ionode_id - USE mp, ONLY : mp_bcast, mp_barrier - IMPLICIT NONE - INTEGER :: nfi - LOGICAL :: file_p - CHARACTER (LEN=256) :: mbfile = "pilot.mb" - - ! Dynamics Loop Started - pilot_p = .TRUE. - - ! This is so we can usurp the exiting parser - ! that defaults to stdin (unit=5) - ! We have to do it this way if we are to - ! call (reuse) the card_autopilot that is called - ! by read_cards - parse_unit = pilot_unit - - ! Our own local for nfi - current_nfi = nfi - - ! Great for Debugging - !IF( ionode ) THEN - !write(*,*) - !write(*,*) '========================================' - !write(*,*) 'Autopilot (Dynamic Rules) Implementation' - !write(*,*) ' CURRENT_NFI=', current_nfi - !write(*,*) ' event_index=', event_index - !write(*,*) ' event_step==', event_step(event_index) - !write(*,*) '========================================' - !write(*,*) - !call flush_unit(6) - !END IF - - - ! This allows one pass. Calling parse_mailbox will either: - ! 1) call init_auto_pilot, which will always set this modules global PAUSE_P variable to FALSE - ! 2) detect a pause indicator, setting PAUSE_P to TRUE until a new mailbox overrides. - pause_loop: do - - file_p = .FALSE. - IF ( ionode ) INQUIRE( FILE = TRIM( mbfile ), EXIST = file_p ) - call mp_bcast(file_p, ionode_id) - - IF ( file_p ) THEN - - WRITE(*,*) - WRITE(*,*) 'Pilot: Mailbox Found!' - WRITE(*,*) ' CURRENT_NFI=', current_nfi - call flush_unit(6) - - ! Open the mailbox - IF ( ionode ) OPEN( UNIT = pilot_unit, FILE = TRIM( mbfile ) ) - - ! Will reset PAUSE_P to false unless there is a PAUSE cmd - ! The following call is MPI safe! It only generates side effects - CALL parse_mailbox() - !call mp_barrier() - WRITE(*,*) 'return from parse_mailbox' - - ! Perhaps instead of deleting move the file as an input log - IF( ionode ) CLOSE( UNIT = pilot_unit, STATUS = 'DELETE' ) - - END IF - - IF( .NOT. pause_p ) THEN - EXIT pause_loop - ELSE - write(*,*) 'SLEEPING .... send another pilot.mb' - call sleep (5) - END if - - end do pause_loop - - ! Autopilot (Dynamic Rules) Implementation - ! When nfi has passed (is greater than - ! the next event, then employ rules - ! Mailbox may have issued several rules - ! Attempt to catch up! - do while (current_nfi >= event_step(event_index) ) - - write(*,*) 'in while: event_index ', event_index - call employ_rules() - call mp_barrier() - - ! update event_index to current - event_index = event_index + 1 - write(*,*) 'in while after: event_index ', event_index - - enddo - - end subroutine pilot - -END MODULE cp_autopilot - diff --git a/quantum_espresso/kcp/CPV/cp_emass.f90 b/quantum_espresso/kcp/CPV/cp_emass.f90 deleted file mode 100644 index 9b21edea9..000000000 --- a/quantum_espresso/kcp/CPV/cp_emass.f90 +++ /dev/null @@ -1,50 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -!------------------------------------------------------------------------------! - MODULE cp_electronic_mass -!------------------------------------------------------------------------------! - - ! This module contains variable and functions relative to the - ! Car-Parrinello fictitious electronic masse - - USE kinds, ONLY: DP -! - IMPLICIT NONE - SAVE - - REAL(DP) :: emass = 1.0d0 ! fictitious electronic mass ( mu ) - REAL(DP) :: emass_cutoff = 1.0d0 ! kinetic energy cutoff for plane - ! waves to be used for Fourier acceleration - ! preconditioning - -!------------------------------------------------------------------------------! - CONTAINS -!------------------------------------------------------------------------------! - - SUBROUTINE emass_precond( ema0bg, ggp, ngw, tpiba2, emaec ) - USE control_flags, ONLY: iprsta - IMPLICIT NONE - REAL(DP), INTENT(OUT) :: ema0bg(:) - REAL(DP), INTENT(IN) :: ggp(:), tpiba2, emaec - INTEGER, INTENT(IN) :: ngw - INTEGER :: i - ! mass preconditioning: ema0bg(i) = ratio of emass(g=0) to emass(g) - ! for g**2>emaec the electron mass ema0bg(g) rises quadratically - do i = 1, ngw - ema0bg(i) = 1.0d0 / MAX( 1.d0, tpiba2 * ggp(i) / emaec ) - IF( iprsta >= 10 ) print *,i,' ema0bg(i) ',ema0bg(i) - end do - - RETURN - END SUBROUTINE emass_precond - - -!------------------------------------------------------------------------------! - END MODULE cp_electronic_mass -!------------------------------------------------------------------------------! diff --git a/quantum_espresso/kcp/CPV/cp_fpmd.f90 b/quantum_espresso/kcp/CPV/cp_fpmd.f90 deleted file mode 100644 index 4c9bd066c..000000000 --- a/quantum_espresso/kcp/CPV/cp_fpmd.f90 +++ /dev/null @@ -1,2034 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!----------------------------------------------------------------------- -subroutine ggenb (b1b, b2b, b3b, nr1b ,nr2b, nr3b, nr1bx ,nr2bx, nr3bx, gcutb ) -!----------------------------------------------------------------------- - ! - ! As ggen, for the box grid. A "b" is appended to box variables. - ! The documentation for ggen applies - ! - USE kinds, ONLY: DP - use gvecb, only: ngb, ngbl, gb, gxb, glb, npb, nmb - use gvecb, only: iglb, mill_b - use io_global, only: stdout - use control_flags, only: iprsta -! - implicit none -! - integer nr1b, nr2b, nr3b, nr1bx, nr2bx, nr3bx - REAL(DP) b1b(3), b2b(3), b3b(3), gcutb -! - integer, allocatable:: idx(:) - integer n1pb, n2pb, n3pb, n1mb, n2mb, n3mb - integer it, icurr, nr1m1, nr2m1, nr3m1, ir, ig, i,j,k, itv(3), idum - REAL(DP) t(3), g2 -! - nr1m1=nr1b-1 - nr2m1=nr2b-1 - nr3m1=nr3b-1 - ngb=0 -! -! first step : count the number of vectors with g2 < gcutb -! -! exclude space with x<0 -! - do i= 0,nr1m1 - do j=-nr2m1,nr2m1 -! -! exclude plane with x=0, y<0 -! - if(i.eq.0.and.j.lt.0) go to 10 -! - do k=-nr3m1,nr3m1 -! -! exclude line with x=0, y=0, z<0 -! - if(i.eq.0.and.j.eq.0.and.k.lt.0) go to 20 - g2=0.d0 - do ir=1,3 - t(ir) = DBLE(i)*b1b(ir) + DBLE(j)*b2b(ir) + DBLE(k)*b3b(ir) - g2=g2+t(ir)*t(ir) - end do - if(g2.gt.gcutb) go to 20 - ngb=ngb+1 - 20 continue - end do - 10 continue - end do - end do -! -! second step: allocate space -! - allocate(gxb(3,ngb)) - allocate(gb(ngb)) - allocate(npb(ngb)) - allocate(nmb(ngb)) - allocate(iglb(ngb)) - allocate(mill_b(3,ngb)) - allocate(idx(ngb)) -! -! third step : find the vectors with g2 < gcutb -! - ngb=0 -! -! exclude space with x<0 -! - do i= 0,nr1m1 - do j=-nr2m1,nr2m1 -! -! exclude plane with x=0, y<0 -! - if(i.eq.0.and.j.lt.0) go to 15 -! - do k=-nr3m1,nr3m1 -! -! exclude line with x=0, y=0, z<0 -! - if(i.eq.0.and.j.eq.0.and.k.lt.0) go to 25 - g2=0.d0 - do ir=1,3 - t(ir) = DBLE(i)*b1b(ir) + DBLE(j)*b2b(ir) + DBLE(k)*b3b(ir) - g2=g2+t(ir)*t(ir) - end do - if(g2.gt.gcutb) go to 25 - ngb=ngb+1 - gb(ngb)=g2 - mill_b(1,ngb)=i - mill_b(2,ngb)=j - mill_b(3,ngb)=k - 25 continue - end do - 15 continue - end do - end do - - IF( iprsta > 3 ) THEN - WRITE( stdout,*) - WRITE( stdout,170) ngb - 170 format(' ggenb: # of gb vectors < gcutb ngb = ',i6) - END IF - - call kb07ad_cp90 (gb,ngb,idx) - - do ig=1,ngb-1 - icurr=ig - 30 if(idx(icurr).ne.ig) then - itv=mill_b(:,icurr) - mill_b(:,icurr)=mill_b(:,idx(icurr)) - mill_b(:,idx(icurr))=itv - - it=icurr - icurr=idx(icurr) - idx(it)=it - if(idx(icurr).eq.ig) then - idx(icurr)=icurr - goto 35 - endif - goto 30 - endif - 35 continue - end do -! - deallocate(idx) -! -! costruct fft indexes (n1b,n2b,n3b) for the box grid -! - do ig=1,ngb - i=mill_b(1,ig) - j=mill_b(2,ig) - k=mill_b(3,ig) - n1pb=i+1 - n2pb=j+1 - n3pb=k+1 -! -! n1pb,n2pb,n3pb: indexes of G -! negative indexes are refolded (note that by construction i.ge.0) -! - if(i.lt.0) n1pb=n1pb+nr1b - if(j.lt.0) n2pb=n2pb+nr2b - if(k.lt.0) n3pb=n3pb+nr3b -! -! n1mb,n2mb,n3mb: indexes of -G -! - if(i.eq.0) then - n1mb=1 - else - n1mb=nr1b-n1pb+2 - end if - if(j.eq.0) then - n2mb=1 - else - n2mb=nr2b-n2pb+2 - end if - if(k.eq.0) then - n3mb=1 - else - n3mb=nr3b-n3pb+2 - end if -! -! conversion from (i,j,k) index to combined 1-d ijk index: -! ijk = 1 + (i-1)+(j-1)*ix+(k-1)*ix*jx -! where the (i,j,k) array is assumed to be dimensioned (ix,jx,kx) -! - npb(ig) = n1pb+(n2pb-1)*nr1bx+(n3pb-1)*nr1bx*nr2bx - nmb(ig) = n1mb+(n2mb-1)*nr1bx+(n3mb-1)*nr1bx*nr2bx - end do -! -! shells of G - first calculate their number and position -! - - CALL gshcount( ngbl, idum, idum, iglb, ngb, gb, -1.0d0, -1.0d0 ) - - IF( iprsta > 3 ) THEN - WRITE( stdout,180) ngbl - 180 format(' ggenb: # of gb shells < gcutb ngbl= ',i6) - END IF -! -! then allocate the array glb -! - allocate(glb(ngbl)) -! -! and finally fill glb with the values of the shells -! - glb(iglb(1))=gb(1) - do ig=2,ngb - if(iglb(ig).ne.iglb(ig-1)) glb(iglb(ig))=gb(ig) - end do -! -! calculation of G-vectors -! - do ig=1,ngb - i=mill_b(1,ig) - j=mill_b(2,ig) - k=mill_b(3,ig) - gxb(1,ig)=i*b1b(1)+j*b2b(1)+k*b3b(1) - gxb(2,ig)=i*b1b(2)+j*b2b(2)+k*b3b(2) - gxb(3,ig)=i*b1b(3)+j*b2b(3)+k*b3b(3) - end do -! - return -end subroutine ggenb - - - -!----------------------------------------------------------------------- - subroutine gcalb( alatb, b1b_ , b2b_ , b3b_ ) -!----------------------------------------------------------------------- -! - USE kinds, ONLY: DP - use gvecb -! - implicit none - REAL(DP), intent(in) :: alatb, b1b_ (3), b2b_ (3), b3b_ (3) - REAL(DP) :: b1b(3), b2b(3), b3b(3) -! - integer i1,i2,i3,ig - - b1b = b1b_ * alatb - b2b = b2b_ * alatb - b3b = b3b_ * alatb -! -! calculation of gxb(3,ngbx) -! - do ig=1,ngb - i1=mill_b(1,ig) - i2=mill_b(2,ig) - i3=mill_b(3,ig) - gxb(1,ig)=i1*b1b(1)+i2*b2b(1)+i3*b3b(1) - gxb(2,ig)=i1*b1b(2)+i2*b2b(2)+i3*b3b(2) - gxb(3,ig)=i1*b1b(3)+i2*b2b(3)+i3*b3b(3) - gb(ig)=gxb(1,ig)**2 + gxb(2,ig)**2 + gxb(3,ig)**2 - enddo -! - return - end subroutine gcalb - - -!------------------------------------------------------------------------- - subroutine ggencp ( b1, b2, b3, nr1, nr2, nr3, nr1s, nr2s, nr3s, & - & gcut, gcuts, gcutw, lgam) !added:giovanni do_wf_cmplx -!----------------------------------------------------------------------- -! generates the reciprocal lattice vectors (g>) with length squared -! less than gcut and returns them in order of increasing length. -! g=i*b1+j*b2+k*b3, -! where b1,b2,b3 are the vectors defining the reciprocal lattice -! -! Only half of the g vectors (g>) are stored: -! if g is present, -g is not (with the exception of g=0) -! The set g> is defined by -! g> = line(i=j=0,k>0)+plane(i=0,j>0)+space(i>0) -! -! n1p,n2p, and n3p are the fast-fourier transform indexes of g> : -! n1p=i+1 if i.ge.0 -! n1p=i+1+nr1 if i.lt.0 -! and the similar definitions for n2p and n3p. -! -! n1m,n2m, and n3m are the fft indexes for g<, that is, the set -! of vectors g=-i*b1-j*b2-k*b3 . These can be shown to be: -! n1m=1 if i.eq.0 (or n1p.eq.1) -! n1m=nr1-n1p+2 if i.ne.0 -! and the similar definitions for n2m and n3m. -! -! the indexes (n1p,n2p,n3p) are collapsed into a one-dimensional -! index np, and the same applies to negative vectors indexes -! -! The fft indices are displaced by one unit so that g=0 corresponds -! to element (1,1,1) (and not (0,0,0)) for purely historical reasons. -! Negative coefficients are refolded to positive coefficients, -! introducing a factor exp(m*2pi*i)=1 in the fourier transform. -! -! For a transform length n and for a single axis, if n odd: -! -n-1 n-1 n+1 -! ----, ..., -1, 0, 1, ...., ---,---,....,n-1 is the "true" index i, -! 2 | | | 2 2 -! | | | | | -! | | V V V -! | | n+1 n+3 -! | | 1, 2, ...., ---,---,....,n is the fft index n1 of G -! | | 2 2 -! | folding \_________________ | ______| -! |_____________________________| -! -! so: if (n1.le.(n+1)/2) i=n1-1 , otherwise, i=n1-n-1 -! -! If n is even: -! n n n -! -- , ..., -1, 0, 1, ...., - ,-+1,....,n-1 is the "real" index i, -! 2 | | | 2 2 -! | | | | | -! | | V V V -! | | n n -! | | 1, 2, ...., -+1,-+2,....,n is the fft index n1 of G -! | | 2 2 -! | folding \_____________ | __________| -! |_________________________| -! -! so: if (n1.le.n/2+1) i=n1-1 ; if(n1.gt.n/2+1) i=n1-n-1 ; -! if (n1.eq.n/2+1) i=n1-1 or i=n1-n-1, depending on how -! the G vectors are refolded -! -! The indices mill_l and mill_g are the i,j,k values. -! They are used to quickly calculate the structure factors -! eigt=exp(-i*g*tau) (i=imaginary unit!) -! by decomposing eigt into products of exponentials: -! eigt=ei1(i)*ei2(j)*ei3(k) (i=index, see above!). -! -! ng is the total number of vectors with length squared less than gcut. -! -! The smooth grid of g with length squared less than gcuts -! (gcuts.le.gcut) is calculated in this routine. -! Smooth grid variables have an "s" appended. -! -! ngw is the total number of vectors with length squared less than gcutw -! (gcutw.le.gcut). -! -! the g's are in units of 2pi/a. -! - USE kinds, ONLY: DP - use reciprocal_vectors, only: g, gx, igl, mill_g, g2_g, gl - use reciprocal_vectors, only: mill_l, ig_l2g - use reciprocal_vectors, only: gzero, gstart, sortedig_l2g - use recvecs_indexes, only: nm, np - use gvecs, only: ngs, nms, ngsl, nps - use gvecw, only: ngw, ngwl, ngwt, ggp - use gvecp, only: ng => ngm, ngl => ngml, ng_g => ngmt - use io_global, only: stdout - USE fft_base, ONLY: dfftp, dffts, fft_dlay_descriptor - use mp, ONLY: mp_sum, mp_max - use mp_global, only: intra_image_comm - use constants, only: eps8 - use control_flags, only: iprsta - ! - implicit none - ! - REAL(DP) :: b1(3), b2(3), b3(3), gcut, gcuts, gcutw - logical :: lgam !added:giovanni do_wf_cmplx - integer :: nr1,nr2,nr3, nr1s,nr2s,nr3s - integer :: ig - integer :: ichk - - ! - ! First of all count the number of G vectors according with the FFT mesh - ! - - CALL gcount( ng, ngs, ngw, b1, b2, b3, nr1, nr2, nr3, gcut, gcuts, gcutw,& - dfftp%isind, SIZE( dfftp%isind), dfftp%nr1x, lgam ) - ! - ! Second step. Compute and sort all G vectors, and build non - ! distributed reciprocal space vectors arrays (ng_g = global - ! number og Gs ) - ! - - ng_g = ng - ngwt = ngw - - CALL mp_sum( ng_g, intra_image_comm ) - CALL mp_sum( ngwt, intra_image_comm ) - - ! - ! Temporary global and replicated arrays, used for sorting - ! - allocate( g2_g( ng_g ) ) - allocate( mill_g( 3, ng_g ) ) - - CALL gglobal( ng_g, g2_g, mill_g, b1, b2, b3, nr1, nr2, nr3, gcut, lgam ) - - ! - ! third step: allocate space - ! ng is the number of Gs local to this processor - ! - allocate( gx ( 3, ng ) ) - allocate( g ( ng ) ) - allocate( ggp( ngw ) ) - allocate( np ( ng ) ) - allocate( nm ( ng ) ) - allocate( igl( ng ) ) - - allocate( ig_l2g( ng ) ) - allocate( mill_l( 3, ng ) ) - allocate( sortedig_l2g( ng ) ) - - ! - ! fourth step : find the vectors with g2 < gcut - ! local to each processor - ! - CALL glocal( ng, g, ig_l2g, mill_l, ng_g, g2_g, mill_g, nr1, nr2, nr3, dfftp%isind, dfftp%nr1x ) - - IF( iprsta > 3 ) THEN - WRITE( stdout,*) - WRITE( stdout,150) ng - 150 format(' ggen: # of g vectors < gcut ng= ',i6) - WRITE( stdout,160) ngs - 160 format(' ggen: # of g vectors < gcuts ngs= ',i6) - WRITE( stdout,170) ngw - 170 format(' ggen: # of g vectors < gcutw ngw= ',i6) - END IF - - ! - ! check for the presence of refolded G-vectors (dense grid) - ! - - CALL gchkrefold( ng, mill_l, nr1, nr2, nr3 ) - - ! - ! costruct fft indexes (n1,n2,n3) for the dense grid - ! - CALL gfftindex( np, nm, ng, mill_l, nr1, nr2, nr3, & - dfftp%isind, dfftp%nr1x, dfftp%nr2x, dfftp%nr3x, lgam) - -! ... Uncomment to make tests and comparisons with other codes -! IF ( ionode ) THEN -! DO ig=1,ng -! WRITE( 201, fmt="( 3I6 )" ) ig, & -! ( np( ig ) - 1 ) / dfftp%nr3x + 1, & -! MOD( ( np( ig ) - 1 ), dfftp%nr3x ) + 1 -! END DO -! CLOSE( 201 ) -! END IF - - - ! - ! check for the presence of refolded G-vectors (smooth grid) - ! - CALL gchkrefold( ngs, mill_l, nr1s, nr2s, nr3s ) - - ! - ! costruct fft indexes (n1s,n2s,n3s) for the smooth grid - ! - allocate(nps(ngs)) - allocate(nms(ngs)) -! - CALL gfftindex( nps, nms, ngs, mill_l, nr1s, nr2s, nr3s, & - dffts%isind, dffts%nr1x, dffts%nr2x, dffts%nr3x, lgam ) - - -! ... Uncomment to make tests and comparisons with other codes -! IF ( ionode ) THEN -! DO ig=1,ngs -! WRITE( 202, fmt="( I6, 2I6, 3I4 )" ) ig, nps(ig), nms(ig), mill_l(1,ig), mill_l(2,ig), mill_l(3,ig) -! END DO -! CLOSE( 202 ) -! END IF - - ! ... here igl is used as temporary storage area - ! ... sortedig_l2g is used to find out local G index given the global G index - ! - DO ig = 1, ng - sortedig_l2g( ig ) = ig - END DO - DO ig = 1, ng - igl( ig ) = ig_l2g( ig ) - END DO - CALL ihpsort( ng, igl, sortedig_l2g ) - igl = 0 - -! -! shells of G - first calculate their number and position -! - - CALL gshcount( ngl, ngsl, ngwl, igl, ng, g, gcuts, gcutw ) - -! -! then allocate the array gl -! - allocate(gl(ngl)) -! -! and finally fill gl with the values of the shells -! - gl(igl(1))=g(1) - do ig=2,ng - if(igl(ig).ne.igl(ig-1)) gl(igl(ig))=g(ig) - end do -! -! gstart is the index of the first nonzero G-vector -! needed in the parallel case (G=0 is found on one node only!) -! - if ( g(1) < 1.d-6 ) then - gstart = 2 - gzero = .TRUE. - else - gstart = 1 - gzero = .FALSE. - end if - - ichk = gstart - CALL mp_max( ichk, intra_image_comm ) - IF( ichk /= 2 ) & - CALL errore( ' ggencp ', ' inconsistent value for gstart ', ichk ) -! - IF( iprsta > 3 ) THEN - WRITE( stdout,180) ngl - 180 format(' ggen: # of g shells < gcut ngl= ',i6) - WRITE( stdout,*) - END IF -! -! calculation of G-vectors -! -!------begin_added:giovanni:debug--------G-VECTORS -! do ig=1,ng -! i=mill_l(1,ig) -! j=mill_l(2,ig) -! k=mill_l(3,ig) -! gx(1,ig)=i*b1(1)+j*b2(1)+k*b3(1) -! gx(2,ig)=i*b1(2)+j*b2(2)+k*b3(2) -! gx(3,ig)=i*b1(3)+j*b2(3)+k*b3(3) -! end do -!------end_added:giovanni:debug-----------G-VECTORS - - return - end subroutine ggencp - - - -!------------------------------------------------------------------------- -SUBROUTINE gcount & - ( ng, ngs, ngw, b1, b2, b3, nr1, nr2, nr3, gcut, gcuts, gcutw, & - isind, nind, ldis, lgam )!added:giovanni do_wf_cmplx -!------------------------------------------------------------------------- - - USE kinds, ONLY: DP - - IMPLICIT NONE - - INTEGER ng, ngs, ngw - INTEGER nr1, nr2, nr3, nind - REAL(DP) b1(3), b2(3), b3(3), gcut, gcuts, gcutw - INTEGER :: isind( nind ), ldis - LOGICAL :: lgam - - INTEGER :: nr1m1, nr2m1, nr3m1 - INTEGER :: i, j, k, n1p, n2p, ir, iind - - REAL(DP) :: g2, t(3) - - if( gcut < gcuts ) call errore(' gcount ', ' gcut .lt. gcuts ', 1 ) - - ng = 0 - ngs = 0 - ngw = 0 -! -! NOTA BENE: these limits are larger than those actually needed -! (-nr/2,..,+nr/2 for nr even; -(nr-1)/2,..,+(nr-1)/2 for nr odd). -! This allows to use a slightly undersized fft grid, with some degree -! of G-vector refolding, at your own risk -! - nr1m1=nr1-1 - nr2m1=nr2-1 - nr3m1=nr3-1 - -! -! first step : count the number of vectors with g2 < gcut -! -! exclude space with x<0 -! - loop_x: do i= -nr1m1, nr1m1 - ! - if( lgam .AND. ( i < 0 ) ) cycle loop_x - ! - loop_y: do j=-nr2m1,nr2m1 - ! - ! exclude plane with x=0, y<0 - ! - if( lgam .AND. ( i.eq.0.and.j.lt.0 ) ) cycle loop_y - ! - ! - ! consider only columns that belong to this node - ! - -#if defined __PARA -! n1p = i + 1 - n1p = mod(i,nr1) + 1 - if ( n1p .lt. 1 ) n1p = n1p + nr1 -! n2p = j + 1 - n2p = mod(j,nr2) + 1 - if ( n2p .lt. 1 ) n2p = n2p + nr2 - iind = n1p + (n2p-1)*ldis - if ( iind > nind ) & - CALL errore( " gcount ", " wrong grid size ", iind ) - if ( isind( iind ) .eq. 0 ) then - cycle loop_y - endif -#endif - - loop_z: do k=-nr3m1,nr3m1 - ! - ! exclude line with x=0, y=0, z<0 - ! - if( lgam .AND. ( i.eq.0.and.j.eq.0.and.k.lt.0 ) ) cycle loop_z - - g2=0.d0 - do ir=1,3 - t(ir) = DBLE(i)*b1(ir) + DBLE(j)*b2(ir) + DBLE(k)*b3(ir) - g2=g2+t(ir)*t(ir) - end do - if(g2.gt.gcut) cycle loop_z - ng=ng+1 - if(g2.lt.gcutw) ngw=ngw+1 - if(g2.lt.gcuts) ngs=ngs+1 - ! - end do loop_z - ! - end do loop_y - ! - end do loop_x - RETURN -END SUBROUTINE gcount - -!------------------------------------------------------------------------- -SUBROUTINE gglobal( ng_g, g2_g, mill_g, b1, b2, b3, nr1, nr2, nr3, gcut, lgam ) -!------------------------------------------------------------------------- - - USE kinds, ONLY: DP - - IMPLICIT NONE - - INTEGER :: ng_g - INTEGER :: mill_g(3,*) - REAL(DP) :: g2_g(*) - integer :: nr1, nr2, nr3 - REAL(DP) :: b1(3), b2(3), b3(3), gcut - LOGICAL :: lgam - - INTEGER :: nr1m1, nr2m1, nr3m1 - INTEGER :: i, j, k, ir, ng - - REAL(DP) :: g2, t(3) - - - nr1m1=nr1-1 - nr2m1=nr2-1 - nr3m1=nr3-1 - - ng = 0 -! -! exclude space with x<0 -! - loopx: do i= -nr1m1,nr1m1 - if( lgam .AND. ( i < 0 ) ) cycle loopx - loopy: do j=-nr2m1,nr2m1 -! ... exclude plane with x=0, y<0 - if( lgam .AND. ( i.eq.0.and.j.lt.0) ) cycle loopy - loopz: do k=-nr3m1,nr3m1 -! ... exclude line with x=0, y=0, z<0 - if( lgam .AND. (i.eq.0.and.j.eq.0.and.k.lt.0)) cycle loopz - g2=0.d0 - do ir=1,3 - t(ir) = DBLE(i)*b1(ir)+DBLE(j)*b2(ir)+DBLE(k)*b3(ir) - g2=g2+t(ir)*t(ir) - end do - if(g2 <= gcut) then - ng=ng+1 - if( ng > ng_g ) call errore( ' gglobal ', ' too many G vectors ', ng ) - g2_g(ng)=g2 - mill_g(1,ng)=i - mill_g(2,ng)=j - mill_g(3,ng)=k - end if - end do loopz - end do loopy - end do loopx - - if( ng /= ng_g ) call errore( ' gglobal ', ' inconsistent number of G vectors ', ng ) - - CALL sort_gvec( ng, g2_g, mill_g ) - -! ... Uncomment to make tests and comparisons with other codes -! IF ( ionode ) THEN -! DO ig=1,ng_g -! WRITE( 201, fmt="( I6, 3I4, 1D25.16 )" ) & -! ig, mill_g(1,ig), mill_g(2,ig), mill_g(3,ig), g2_g( ig ) -! END DO -! CLOSE( 201 ) -! END IF - - RETURN -END SUBROUTINE gglobal - - - -!------------------------------------------------------------------------- -SUBROUTINE glocal( ng, g, ig_l2g, mill_l, ng_g, g2_g, mill_g, nr1, nr2, nr3, isind, ldis ) -!------------------------------------------------------------------------- - - USE kinds, ONLY: DP - - IMPLICIT NONE - - INTEGER :: ng_g, ng - INTEGER :: mill_g(3,*), ig_l2g(*), mill_l(3,*) - REAL(DP) :: g2_g(*), g(*) - integer :: nr1, nr2, nr3, isind(*), ldis - - INTEGER :: i, j, k, ig, n1p, n2p, ng_l - INTEGER :: icurr, it - INTEGER :: mill(3) - integer, allocatable:: idx(:) - - ng_l=0 - loop_allg: do ig = 1, ng_g - i = mill_g(1,ig) - j = mill_g(2,ig) - k = mill_g(3,ig) - -#if defined __PARA - n1p = i + 1 - if (n1p.lt.1) n1p = n1p + nr1 - n2p = j + 1 - if (n2p.lt.1) n2p = n2p + nr2 - if (isind(n1p+(n2p-1)*ldis).eq.0) cycle loop_allg -#endif - - ng_l=ng_l+1 - g(ng_l)=g2_g(ig) - ig_l2g(ng_l) = ig - mill_l(1:3,ng_l) = mill_g(1:3,ig) - end do loop_allg - - if( ng /= ng_l ) call errore( ' glocal ', ' inconsistent number of G vectors ', ng_l ) - - allocate(idx(ng)) -! -! reorder the local g's in order of increasing magnitude. -! - call kb07ad_cp90(g,ng,idx) -! - do ig=1,ng-1 - icurr=ig - 30 if(idx(icurr).ne.ig) then - - it=ig_l2g(icurr) - ig_l2g(icurr)=ig_l2g(idx(icurr)) - ig_l2g(idx(icurr))=it - - mill=mill_l(:,icurr) - mill_l(:,icurr)=mill_l(:,idx(icurr)) - mill_l(:,idx(icurr))=mill -! - it=icurr - icurr=idx(icurr) - idx(it)=it - if(idx(icurr).eq.ig) then - idx(icurr)=icurr - goto 35 - endif - goto 30 - endif - 35 continue - end do - -! ... Uncomment to make tests and comparisons with other codes -! IF ( ionode ) THEN -! DO ig=1,ng -! WRITE( 201, fmt="( I6, 3I4 )" ) & -! ig, mill_l(1,ig), mill_l(2,ig), mill_l(3,ig) -! END DO -! CLOSE( 201 ) -! END IF - - - deallocate( idx ) - - RETURN -END SUBROUTINE glocal - - - -!------------------------------------------------------------------------- -SUBROUTINE gchkrefold( ng, mill_l, nr1, nr2, nr3 ) -!------------------------------------------------------------------------- - - use io_global, only: stdout - - IMPLICIT NONE - - INTEGER :: ng - INTEGER :: mill_l(3,*) - integer :: nr1, nr2, nr3 - - INTEGER :: nr1m1, nr2m1, nr3m1 - INTEGER :: nrefold, ig - - nrefold=0 - if (mod(nr1,2).eq.0) then - nr1m1=nr1/2-1 - else - nr1m1=(nr1-1)/2 - end if - if (mod(nr2,2).eq.0) then - nr2m1=nr2/2-1 - else - nr2m1=(nr2-1)/2 - end if - if (mod(nr3,2).eq.0) then - nr3m1=nr3/2-1 - else - nr3m1=(nr3-1)/2 - end if - do ig=1,ng - if ( mill_l(1,ig).lt.-nr1m1.or.mill_l(1,ig).gt.nr1m1 .or. & - & mill_l(2,ig).lt.-nr2m1.or.mill_l(2,ig).gt.nr2m1 .or. & - & mill_l(3,ig).lt.-nr3m1.or.mill_l(3,ig).gt.nr3m1 ) & - & nrefold=nrefold+1 - end do - if (nrefold.ne.0) WRITE( stdout, '('' WARNING: '',i6, & - & '' G-vectors refolded into FFT grid (ng,nrefold)'')') ng, nrefold - - RETURN -END SUBROUTINE gchkrefold - - -!------------------------------------------------------------------------- - -SUBROUTINE gfftindex( np, nm, ng, mill_l, nr1, nr2, nr3, isind, nr1x, nr2x, nr3x, lgam ) - ! - IMPLICIT NONE - - INTEGER :: ng - INTEGER :: isind(*), nr1x, nr2x, nr3x - INTEGER :: mill_l(3,*), np(*), nm(*) - integer :: nr1, nr2, nr3 - logical :: lgam - - INTEGER :: n1p, n2p, n3p - INTEGER :: n1m, n2m, n3m - INTEGER :: i, j, k, ig, isp, ism - -ngloop: do ig = 1, ng - - i = mill_l(1,ig) - j = mill_l(2,ig) - k = mill_l(3,ig) - ! - ! n1p,n2p,n3p: indexes of G - ! negative indexes are refolded (note that by construction i.ge.0) - ! - n1p=i+1 - n2p=j+1 - n3p=k+1 - if(i.lt.0) n1p=n1p+nr1 - if(j.lt.0) n2p=n2p+nr2 - if(k.lt.0) n3p=n3p+nr3 - - ! - ! n1m,n2m,n3m: indexes of -G - ! -! n1m=-i+1 -! n2m=-j+1 -! n3m=-k+1 -! -! if(-i.lt.0) n1m=n1m+nr1 -! if(-j.lt.0) n2m=n2m+nr2 -! if(-k.lt.0) n3m=n3m+nr3 - - if(i.eq.0) then - n1m=1 - else - n1m=nr1-n1p+2 - end if - if(j.eq.0) then - n2m=1 - else - n2m=nr2-n2p+2 - end if - if(k.eq.0) then - n3m=1 - else - n3m=nr3-n3p+2 - end if - - ! - ! conversion from (i,j,k) index to combined 1-d ijk index: - ! ijk = 1 + (i-1)+(j-1)*ix+(k-1)*ix*jx - ! where the (i,j,k) array is assumed to be dimensioned (ix,jx,kx) - ! - ! for the parallel case: columns along z are stored contiguously - ! - -#if defined __PARA && !defined __USE_3D_FFT - - isp = isind( n1p + ( n2p - 1 ) * nr1x ) - IF( isp <= 0 ) & - CALL errore( ' gfftindex ', ' wrong index: isp', 1 ) - IF( n3p > nr3x ) & - CALL errore( ' gfftindex ', ' wrong index: n3p ', 1 ) - np(ig) = n3p + ( isp - 1 ) * nr3x - -! IF(lgam) THEN !!!### uncomment for k points - ism = isind( n1m + ( n2m - 1 ) * nr1x ) - IF( ism <= 0 ) THEN !modified:giovanni - CALL errore( ' gfftindex ', ' wrong index: ism ', 1 ) - ENDIF - IF( n3m > nr3x ) & - CALL errore( ' gfftindex ', ' wrong index: n3m ', 1 ) - nm(ig) = n3m + ( ism - 1 ) * nr3x -! ELSE !!!### uncomment for k points -! nm(ig) = 0 !n3m + ( ism - 1 ) * nr3x !!!### uncomment for k points -! ENDIFv!!!### uncomment for k points -#else - np(ig) = n1p + (n2p-1)*nr1x + (n3p-1)*nr1x*nr2x - -! IF(lgam) THEN !!!### uncomment for k points - nm(ig) = n1m + (n2m-1)*nr1x + (n3m-1)*nr1x*nr2x -! ELSE !!!### uncomment for k points -! nm(ig) = 0 !n1m + (n2m-1)*nr1x + (n3m-1)*nr1x*nr2x !!!### uncomment for k points -! ENDIF !!!### uncomment for k points -#endif - - end do ngloop - - RETURN -END SUBROUTINE gfftindex - - -!------------------------------------------------------------------------- -SUBROUTINE gshcount( ngl, ngsl, ngwl, igl, ng, g, gcuts, gcutw ) -!------------------------------------------------------------------------- - - USE kinds, ONLY: DP - - IMPLICIT NONE - - INTEGER :: ngl, ngsl, ngwl - INTEGER :: igl(*) - INTEGER :: ng - REAL(DP) :: g(*), gcuts, gcutw - - INTEGER :: ig - - ngl=1 - igl(1)=ngl - do ig=2,ng - if(abs(g(ig)-g(ig-1)).gt.1.e-6)then - ngl=ngl+1 - if (g(ig).lt.gcuts) ngsl=ngl - if (g(ig).lt.gcutw) ngwl=ngl - endif - igl(ig)=ngl - end do - - RETURN -END SUBROUTINE gshcount - - -!------------------------------------------------------------------------- - subroutine gcal( alat, b1_ , b2_ , b3_ , gmax ) -!----------------------------------------------------------------------- -! calculates the values of g-vectors to be assigned to the lattice -! points generated in subroutine ggen. these values are derived -! from the actual values of lattice parameters, with fixed number -! of plane waves and a cut-off function to keep energy cut-off fixed. -! -! g=i*b1+j*b2+k*b3, -! -! where b1,b2,b3 are the vectors defining the reciprocal lattice, -! i go from 1 to +(nr-1) and j,k go from -(nr-1) to +(nr-1). -! -! the g's are in units of 2pi/a. -! - USE kinds, ONLY: DP - use constants, only: tpi - use reciprocal_vectors, only: g, gx, mill_l - use gvecp, only: ngm - use gvecw, only: ngw - use gvecw, only: ggp, ecutz, ecsig, ecfix - implicit none -! - REAL(DP) :: alat, b1_(3),b2_(3),b3_(3), gmax - REAL(DP), external :: qe_erf - REAL(DP) :: b1(3),b2(3),b3(3), tpiba2, gcutz -! - integer i1,i2,i3,ig - - b1 = b1_ * alat - b2 = b2_ * alat - b3 = b3_ * alat -! -! calculation of gx(3,ng) -! - gmax=0.d0 - do ig=1,ngm - i1=mill_l(1,ig) - i2=mill_l(2,ig) - i3=mill_l(3,ig) - gx(1,ig)=i1*b1(1)+i2*b2(1)+i3*b3(1) - gx(2,ig)=i1*b1(2)+i2*b2(2)+i3*b3(2) - gx(3,ig)=i1*b1(3)+i2*b2(3)+i3*b3(3) - g(ig)=gx(1,ig)**2 + gx(2,ig)**2 + gx(3,ig)**2 - if(g(ig).gt.gmax) gmax=g(ig) - enddo - - tpiba2 = ( tpi / alat ) ** 2 - gcutz = ecutz / tpiba2 -! - IF( gcutz > 0.0d0 ) THEN - do ig=1,ngw - ggp(ig) = g(ig) + gcutz * & - ( 1.0d0 + qe_erf( ( tpiba2 * g(ig) - ecfix ) / ecsig ) ) - enddo - ELSE - ggp( 1 : ngw ) = g( 1 : ngw ) - END IF -! - return - end subroutine gcal - - -!=----------------------------------------------------------------------------=! - - SUBROUTINE newgb( a1, a2, a3, omega, alat ) -! -! re-generation of little box g-vectors -! - USE kinds, ONLY: DP - USE grid_dimensions, only: nr1, nr2, nr3 - USE smallbox_grid_dimensions, only: nr1b, nr2b, nr3b - USE small_box, only: a1b, a2b, a3b, ainvb, omegab, tpibab - USE constants, ONLY: pi - - IMPLICIT NONE - REAL(DP) :: a1( 3 ), a2( 3 ), a3( 3 ), omega, alat - - INTEGER :: i - REAL(DP) :: alatb, b1b(3),b2b(3),b3b(3) - - alatb = alat / nr1*nr1b - tpibab = 2.d0*pi / alatb - do i=1,3 - a1b(i)=a1(i)/nr1*nr1b - a2b(i)=a2(i)/nr2*nr2b - a3b(i)=a3(i)/nr3*nr3b - enddo - - omegab=omega/nr1*nr1b/nr2*nr2b/nr3*nr3b -! - call recips( a1b, a2b, a3b, b1b, b2b, b3b ) - ! - call gcalb( alatb, b1b, b2b, b3b ) -! - do i=1,3 - ainvb(1,i)=b1b(i) - ainvb(2,i)=b2b(i) - ainvb(3,i)=b3b(i) - end do - - RETURN - END SUBROUTINE newgb - -!------------------------------------------------------------------------------! -! -! -!------------------------------------------------------------------------------! - - SUBROUTINE ecutoffs_setup( ecutwfc, ecutrho, ecfixed, qcutz, q2sigma, & - refg_ ) - - USE kinds, ONLY: DP - USE constants, ONLY: eps8 - USE gvecw, ONLY: ecutw - USE gvecw, ONLY: ecfix, ecutz, ecsig - USE gvecp, ONLY: ecutp - USE gvecs, ONLY: ecuts, dual, doublegrid - use betax, only: mmx, refg - USE pseudopotential, only: tpstab - USE control_flags, only: program_name , thdyn - USE io_global, only: stdout, ionode - - IMPLICIT NONE - REAL(DP), INTENT(IN) :: ecutwfc, ecutrho, ecfixed, qcutz, q2sigma - REAL(DP), INTENT(IN) :: refg_ - - ecutw = ecutwfc - - IF ( ecutrho <= 0.D0 ) THEN - ! - dual = 4.D0 - ! - ELSE - ! - dual = ecutrho / ecutwfc - ! - IF ( dual <= 1.D0 ) & - CALL errore( ' ecutoffs_setup ', ' invalid dual? ', 1 ) - ! - IF( ( program_name == 'FPMD' ) .AND. ( dual /= 4.0d0 ) ) THEN - IF( ionode ) THEN - WRITE( stdout, * ) 'WARNING from ecutoffs_setup: dual /= 4 not allowed in fpmd' - WRITE( stdout, * ) 'WARNING continuing with dual = 4' - END IF - dual = 4.0d0 - END IF - ! - END IF - - ecutp = dual * ecutwfc - - doublegrid = ( dual > 4.D0 ) - ! - IF ( doublegrid ) THEN - ! - ecuts = 4.D0 * ecutwfc - ! - ELSE - ! - ecuts = ecutp - ! - END IF - - ! - ecfix = ecfixed - ecutz = qcutz - ecsig = q2sigma - - IF( refg_ < 0.0001d0 ) THEN - tpstab = .FALSE. - refg = 0.05d0 - ELSE - refg = refg_ - END IF - - IF( thdyn ) THEN - ! ... a larger table is used when cell is moving to allow - ! ... large volume fluctuation - mmx = NINT( 2.0d0 * ecutp / refg ) - ELSE - mmx = NINT( 1.2d0 * ecutp / refg ) - END IF - - mmx = NINT( 2.0d0 * ecutp / refg ) ! debug - - RETURN - END SUBROUTINE ecutoffs_setup - - - SUBROUTINE gcutoffs_setup( alat, tk_inp, nk_inp, kpoints_inp ) - -! (describe briefly what this routine does...) -! ---------------------------------------------- - - USE kinds, ONLY: DP - USE gvecw, ONLY: ecutwfc => ecutw, gcutw - USE gvecp, ONLY: ecutrho => ecutp, gcutp - USE gvecs, ONLY: ecuts, gcuts - USE gvecw, ONLY: ekcut, gkcut - USE constants, ONLY: eps8, pi - - IMPLICIT NONE - -! ... declare subroutine arguments - REAL(DP), INTENT(IN) :: alat - LOGICAL, INTENT(IN) :: tk_inp - INTEGER, INTENT(IN) :: nk_inp - REAL(DP), INTENT(IN) :: kpoints_inp(3,*) - -! ... declare other variables - INTEGER :: i - REAL(DP) :: kcut, ksq - REAL(DP) :: tpiba - -! end of declarations -! ---------------------------------------------- - -! ... Set Values for the cutoff - - - IF( alat < eps8 ) THEN - CALL errore(' cut-off setup ', ' alat too small ', 0) - END IF - - tpiba = 2.0d0 * pi / alat - - ! ... Constant cutoff simulation parameters - - gcutw = ecutwfc / tpiba**2 ! wave function cut-off - gcutp = ecutrho / tpiba**2 ! potential cut-off - gcuts = ecuts / tpiba**2 ! smooth mesh cut-off - - kcut = 0.0_DP - IF ( tk_inp ) THEN -! ... augment plane wave cutoff to include all k+G's - DO i = 1, nk_inp -! ... calculate modulus - ksq = kpoints_inp( 1, i ) ** 2 + kpoints_inp( 2, i ) ** 2 + kpoints_inp( 3, i ) ** 2 - IF ( ksq > kcut ) kcut = ksq - END DO - END IF - - gkcut = ( sqrt( kcut ) + sqrt( gcutw ) ) ** 2 - - ekcut = gkcut * tpiba ** 2 - - RETURN - END SUBROUTINE gcutoffs_setup - -! ---------------------------------------------- - - SUBROUTINE cutoffs_print_info() - - ! Print out informations about different cut-offs - - USE gvecw, ONLY: ecutwfc => ecutw, gcutw - USE gvecp, ONLY: ecutrho => ecutp, gcutp - USE gvecw, ONLY: ecfix, ecutz, ecsig - USE gvecs, ONLY: ecuts, gcuts - use betax, only: mmx, refg - USE io_global, ONLY: stdout - - WRITE( stdout, 100 ) ecutwfc, ecutrho, ecuts, sqrt(gcutw), sqrt(gcutp), sqrt(gcuts) - IF( ecutz > 0.0d0 ) THEN - WRITE( stdout, 150 ) ecutz, ecsig, ecfix - END IF - - WRITE( stdout,200) refg, mmx - -100 FORMAT(/,3X,'Energy Cut-offs',/ & - ,3X,'---------------',/ & - ,3X,'Ecutwfc = ',F6.1,' Ry, ', 3X,'Ecutrho = ',F6.1,' Ry, ', 3X,'Ecuts = ',F6.1,' Ry',/ & - ,3X,'Gcutwfc = ',F6.1,' , ', 3X,'Gcutrho = ',F6.1,' ', 3X,'Gcuts = ',F6.1) -150 FORMAT( 3X,'modified kinetic energy functional, with parameters:',/, & - 3X,'ecutz = ',f8.4,' ecsig = ', f7.4,' ecfix = ',f6.2) -200 FORMAT( 3X,'NOTA BENE: refg, mmx = ', f10.6,I6 ) - - RETURN - END SUBROUTINE cutoffs_print_info - -! ---------------------------------------------- - - SUBROUTINE orthogonalize_info( ) - USE control_flags, ONLY: ortho_eps, ortho_max - USE io_global, ONLY: stdout - IMPLICIT NONE - WRITE(stdout, 585) - WRITE(stdout, 511) ortho_eps, ortho_max - 511 FORMAT( 3X,'Orthog. with lagrange multipliers : eps = ',E10.2, ', max = ',I3) - 585 FORMAT( 3X,'Eigenvalues calculated without the kinetic term contribution') - RETURN - END SUBROUTINE orthogonalize_info - - -! ---------------------------------------------- - - - SUBROUTINE electrons_print_info( ) - - USE kinds, ONLY: DP - USE electrons_base, ONLY: nbnd, nspin, nel, nelt, nupdwn, iupdwn, & - f, qbac - USE io_global, ONLY: stdout - USE ions_base, ONLY: zv, nsp, na - - IMPLICIT NONE - INTEGER :: i,is - - IF( nspin == 1) THEN - WRITE(stdout,6) nelt, nbnd - WRITE(stdout,7) ( f( i ), i = 1, nbnd ) - ELSE - WRITE(stdout,8) nelt - WRITE(stdout,9) nel(1) - WRITE(stdout,7) ( f( i ), i = 1, nupdwn(1)) - WRITE(stdout,10) nel(2) - WRITE(stdout,7) ( f( i ), i = iupdwn(2), ( iupdwn(2) + nupdwn(2) - 1 ) ) - END IF - - qbac=0. - do is=1,nsp - qbac=qbac+na(is)*zv(is) - end do - qbac=qbac-nelt - if(qbac.ne.0) write(stdout,11) qbac - - -6 FORMAT(/,3X,'Electronic states',/ & - ,3X,'-----------------',/ & - ,3X,'Number of Electron = ',I5,', of States = ',I5,/ & - ,3X,'Occupation numbers :') -7 FORMAT(2X,10F5.2) -8 FORMAT(/,3X,'Electronic states',/ & - ,3X,'-----------------',/ & - ,3X,'Local Spin Density calculation',/ & - ,3X,'Number of Electron = ',I5) -9 FORMAT( 3X,'Spins up = ', I5, ', occupations: ') -10 FORMAT( 3X,'Spins down = ', I5, ', occupations: ') -11 FORMAT(/,3X,'WARNING: system charge = ',F12.6) - RETURN - END SUBROUTINE electrons_print_info - - -! ---------------------------------------------- - - - SUBROUTINE exch_corr_print_info() - - USE funct, ONLY: get_iexch, get_icorr, get_igcx, get_igcc, write_dft_name - USE io_global, ONLY: stdout - - IMPLICIT NONE - - CHARACTER(LEN = 60) :: exch_info - CHARACTER(LEN = 60) :: corr_info - CHARACTER(LEN = 60) :: exgc_info - CHARACTER(LEN = 60) :: cogc_info - - WRITE(stdout,800) - - ! ... iexch => Exchange functional form - ! ... icorr => Correlation functional form - ! ... igcx => Gradient Correction to the Exchange potential - ! ... igcc => Gradient Correction to the Correlation potential - - SELECT CASE ( get_iexch() ) - CASE (0) - exch_info = 'NONE' - CASE (1) - exch_info = 'SLATER' - CASE (2) - exch_info = 'SLATER (alpha=1)' - CASE DEFAULT - exch_info = 'UNKNOWN' - END SELECT - SELECT CASE ( get_icorr() ) - CASE (0) - corr_info = 'NONE' - CASE (1) - corr_info = 'PERDEW AND ZUNGER' - CASE (2) - corr_info = 'VOSKO, WILK AND NUSAIR' - CASE (3) - corr_info = 'LEE, YANG, AND PARR' - CASE (4) - corr_info = 'PERDEW AND WANG' - CASE (9) - corr_info = 'PADE APPROXIMATION' - CASE DEFAULT - corr_info = 'UNKNOWN' - END SELECT - SELECT CASE ( get_igcx() ) - CASE (0) - exgc_info = 'NONE' - CASE (1) - exgc_info = 'BECKE' - CASE (2) - exgc_info = 'PERDEW' - CASE (3) - exgc_info = 'PERDEW BURKE ERNZERHOF' - CASE (7) - exgc_info = 'META-TPSS' - CASE DEFAULT - exgc_info = 'UNKNOWN' - END SELECT - SELECT CASE ( get_igcc() ) - CASE (0) - cogc_info = 'NONE' - CASE (1) - cogc_info = 'PERDEW' - CASE (2) - cogc_info = 'LEE, YANG AND PARR' - CASE (3) - cogc_info = 'PERDEW AND WANG' - CASE (4) - cogc_info = 'PERDEW BURKE ERNZERHOF' - CASE (6) - cogc_info = 'META-TPSS' - CASE DEFAULT - cogc_info = 'UNKNOWN' - END SELECT - - WRITE(stdout,910) - WRITE(stdout,fmt='(5X,"Exchange functional: ",A)') exch_info - WRITE(stdout,fmt='(5X,"Correlation functional: ",A)') corr_info - IF( ( get_igcx() > 0 ) .OR. ( get_igcc() > 0 ) ) THEN - WRITE(stdout,810) - WRITE(stdout,fmt='(5X,"Exchange functional: ",A)') exgc_info - WRITE(stdout,fmt='(5X,"Correlation functional: ",A)') cogc_info - END IF - - call write_dft_name - -800 FORMAT(//,3X,'Exchange and correlations functionals',/ & - ,3X,'-------------------------------------') -810 FORMAT( 3X,'Using Generalized Gradient Corrections with') -910 FORMAT( 3X,'Using Local Density Approximation with') - - RETURN - END SUBROUTINE exch_corr_print_info - - - -! ---------------------------------------------- - - - - SUBROUTINE ions_print_info( ) - - ! Print info about input parameter for ion dynamic - - USE io_global, ONLY: stdout - USE control_flags, ONLY: tranp, amprp, tnosep, tolp, tfor, tsdp, tzerop, & - tv0rd, taurdr, nv0rd, nbeg, tcp, tcap - USE ions_base, ONLY: tau_srt, if_pos, ind_srt, nsp, na, & - pmass, nat, fricp, greasp, rcmax - USE ions_nose, ONLY: tempw, ndega - USE constants, ONLY: amu_au - - IMPLICIT NONE - - integer is, ia, k, isa - LOGICAL :: ismb( 3 ) - - WRITE( stdout, 50 ) - - IF( .NOT. tfor ) THEN - WRITE( stdout, 518 ) - ELSE - WRITE( stdout, 520 ) - IF( tsdp ) THEN - WRITE( stdout, 521 ) - ELSE - WRITE( stdout, 522 ) - END IF - WRITE( stdout, 523 ) ndega - WRITE( stdout, 524 ) fricp, greasp - IF( tzerop ) then - IF( tv0rd ) THEN - WRITE( stdout, 850 ) nv0rd - ELSE - WRITE( stdout, 635 ) - ENDIF - ENDIF - END IF - - DO is = 1, nsp - IF( tranp(is) ) THEN - WRITE( stdout,510) - WRITE( stdout,512) is, amprp(is) - END IF - END DO - - WRITE(stdout,660) - isa = 0 - DO IS = 1, nsp - WRITE(stdout,1000) is, na(is), pmass(is), pmass(is) / amu_au, rcmax(is) - DO IA = 1, na(is) - isa = isa + 1 - WRITE(stdout,1010) ( tau_srt(k,isa), K = 1,3 ) - END DO - END DO - - IF ( ( nbeg > -1 ) .AND. ( .NOT. taurdr ) ) THEN - WRITE(stdout,661) - ELSE - WRITE(stdout,662) - ENDIF - - IF( tfor ) THEN - - IF( ANY( ( if_pos( 1:3, 1:nat ) == 0 ) ) ) THEN - - WRITE(stdout,1020) - WRITE(stdout,1022) - - DO isa = 1, nat - ia = ind_srt( isa ) - ismb( 1 ) = ( if_pos(1,ia) /= 0 ) - ismb( 2 ) = ( if_pos(2,ia) /= 0 ) - ismb( 3 ) = ( if_pos(3,ia) /= 0 ) - IF( .NOT. ALL( ismb ) ) THEN - WRITE( stdout, 1023 ) isa, ( ismb(k), K = 1, 3 ) - END IF - END DO - - ELSE - - WRITE(stdout,1021) - - END IF - END IF - - IF( tfor ) THEN - if( ( tcp .or. tcap .or. tnosep ) .and. tsdp ) then - call errore(' ions_print_info',' t contr. for ions when tsdp=.t.',1) - endif - IF(.not. tcp .and. .not. tcap .and. .not. tnosep ) THEN - WRITE( stdout,550) - ELSE IF( tcp .and. tcap ) then - call errore(' ions_print_info',' tcp and tcap both true',1) - ELSE IF( tcp .and. tnosep ) then - call errore(' ions_print_info',' tcp and tnosep both true',1) - ELSE IF(tcap .and. tnosep ) then - call errore(' ions_print_info',' tcap and tnosep both true',1) - ELSE IF(tcp) THEN - WRITE( stdout,555) tempw,tolp - ELSE IF(tcap) THEN - WRITE( stdout,560) tempw,tolp - ELSE IF(tnosep) THEN - WRITE( stdout,595) - ELSE - WRITE( stdout,550) - END IF - END IF - - 50 FORMAT(//,3X,'Ions Simulation Parameters',/ & - ,3X,'--------------------------') - - 510 FORMAT( 3X,'Initial random displacement of ionic coordinates',/, & - 3X,' specie amplitude') - 512 FORMAT( 3X,I7,2X,F9.6) - - 518 FORMAT( 3X,'Ions are not allowed to move') - 520 FORMAT( 3X,'Ions are allowed to move') - 521 FORMAT( 3X,'Ions dynamics with steepest descent') - 522 FORMAT( 3X,'Ions dynamics with newton equations') - 523 format( 3X,'the temperature is computed for ',i5,' degrees of freedom') - 524 format( 3X,'ion dynamics with fricp = ',f7.4,' and greasp = ',f7.4) - 550 FORMAT( 3X,'Ionic temperature is not controlled') - 555 FORMAT( 3X,'Ionic temperature control via ', & - 'rescaling of velocities :',/ & - ,3X,'temperature required = ',F10.5,'K, ', & - 'tolerance = ',F10.5,'K') - 560 FORMAT( 3X,'Ionic temperature control via ', & - 'canonical velocities rescaling :',/ & - ,3X,'temperature required = ',F10.5,'K, ', & - 'tolerance = ',F10.5,'K') - 595 FORMAT( 3X,'Ionic temperature control via nose thermostat') - 635 FORMAT( 3X,'Zero initial momentum for ions') - - 660 FORMAT( 3X,'Ionic position (from input)', /, & - 3X,'sorted by specie, and converted to real a.u. coordinates') - 661 FORMAT( 3X,'Ionic position will be re-read from restart file') - 662 FORMAT( 3X,'Ionic position read from input file') - - 850 FORMAT( 3X,'Initial ion velocities read from unit : ',I4) - - 1000 FORMAT(3X,'Species ',I3,' atoms = ',I4,' mass = ',F12.2, ' (a.u.), ', & - & F12.2, ' (amu)', ' rcmax = ', F6.2, ' (a.u.)' ) - 1010 FORMAT(3X,3(1X,F12.6)) - 1020 FORMAT(/,3X,'NOT all atoms are allowed to move ') - 1021 FORMAT(/,3X,'All atoms are allowed to move') - 1022 FORMAT( 3X,' indx ..x.. ..y.. ..z..') - 1023 FORMAT( 3X,I4,3(1X,L5)) - - - - RETURN - END SUBROUTINE ions_print_info - - -! ---------------------------------------------- - - subroutine cell_print_info( ) - - USE constants, ONLY: au_gpa - USE control_flags, ONLY: thdyn, tsdc, tzeroc, tbeg, nbeg, tpre - USE control_flags, ONLY: tnoseh - USE io_global, ONLY: stdout - USE cell_base, ONLY: press, frich, greash, wmass - - IMPLICIT NONE - - WRITE(stdout,545 ) - IF ( tpre ) WRITE( stdout, 600 ) - IF ( tbeg ) THEN - WRITE(stdout,546) - ELSE - WRITE(stdout,547) - IF( nbeg > -1 ) WRITE( stdout, 548 ) - END IF - - IF( .NOT. thdyn ) THEN - WRITE( stdout,525) - WRITE( stdout,606) - ELSE - IF( tsdc ) THEN - WRITE( stdout,526) - ELSE - IF( frich /= 0.0d0 ) THEN - WRITE( stdout,602) frich, greash - ELSE - WRITE( stdout,527) - END IF - IF( tnoseh ) then - WRITE( stdout,604) - ELSE - WRITE( stdout,565) - END IF - ! if( thdiag ) WRITE( stdout,608) - IF( tzeroc ) THEN - WRITE( stdout,563) - ENDIF - END IF - WRITE( stdout,530) press * au_gpa, wmass - END IF - - - 545 FORMAT(//,3X,'Cell Dynamics Parameters (from STDIN)',/ & - ,3X,'-------------------------------------') - 546 FORMAT( 3X,'Simulation cell read from STDIN') - 547 FORMAT( 3X,'Starting cell generated from CELLDM') - 548 FORMAT( 3X,'Cell parameters will be re-read from restart file') - 525 FORMAT( 3X,'Constant VOLUME Molecular dynamics') - 606 format( 3X,'cell parameters are not allowed to move') - 526 FORMAT( 3X,'Volume dynamics with steepest descent') - 527 FORMAT( 3X,'Volume dynamics with newton equations') - 530 FORMAT( 3X,'Constant PRESSURE Molecular dynamics:',/ & - ,3X,'External pressure (GPa) = ',F11.2,/ & - ,3X,'Volume mass = ',F11.2) - 563 FORMAT( 3X,'Zero initial momentum for cell variables') - 565 FORMAT( 3X,'Volume dynamics: the temperature is not controlled') - 604 format( 3X,'cell parameters dynamics with nose` temp. control' ) - - 600 format( 3X, 'internal stress tensor calculated') - 602 format( 3X, 'cell parameters dynamics with frich = ',f7.4, & - & 3X, 'and greash = ',f7.4 ) - 608 format( 3X, 'frozen off-diagonal cell parameters'//) - - return - end subroutine cell_print_info - - -!---------------------------------------------- -SUBROUTINE gmeshinfo( ) -!---------------------------------------------- - ! - ! Print out the number of g vectors for the different mesh - ! - USE mp_global, ONLY: nproc_image, intra_image_comm - USE io_global, ONLY: ionode, ionode_id, stdout - USE mp, ONLY: mp_max, mp_gather - use gvecb, only: ngb - USE reciprocal_vectors, only: ngst, ngs, ngsx, & - ngw_g => ngwt, & - ngw_l => ngw , & - ngw_lx => ngwx, & - ng_g => ngmt, & - ng_l => ngm , & - ng_lx => ngmx - - IMPLICIT NONE - - INTEGER :: ip, ng_snd(3), ng_rcv( 3, nproc_image ) - INTEGER :: ierr - - IF(ionode) THEN - WRITE( stdout,*) - WRITE( stdout,*) ' Reciprocal Space Mesh' - WRITE( stdout,*) ' ---------------------' - END IF - - ng_snd(1) = ng_g - ng_snd(2) = ng_l - ng_snd(3) = ng_lx - CALL mp_gather(ng_snd, ng_rcv, ionode_id, intra_image_comm) - ! - IF(ionode) THEN - WRITE( stdout,1000) - DO ip = 1, nproc_image - WRITE( stdout,1010) ip, ng_rcv(1,ip), ng_rcv(2,ip), ng_rcv(3,ip) - END DO - END IF - ! - ng_snd(1) = ngst - ng_snd(2) = ngs - ng_snd(3) = ngsx - CALL mp_gather(ng_snd, ng_rcv, ionode_id, intra_image_comm) - ! - ierr = 0 - ! - IF(ionode) THEN - WRITE( stdout,1001) - DO ip = 1, nproc_image - WRITE( stdout,1010) ip, ng_rcv(1,ip), ng_rcv(2,ip), ng_rcv(3,ip) - IF( ng_rcv(2,ip) < 1 ) ierr = ip - END DO - END IF - ! - CALL mp_max( ierr, intra_image_comm ) - ! - IF( ierr > 0 ) & - CALL errore( " gmeshinfo ", " Wow! some processors have no G-vectors ", ierr ) - ! - ng_snd(1) = ngw_g - ng_snd(2) = ngw_l - ng_snd(3) = ngw_lx - CALL mp_gather(ng_snd, ng_rcv, ionode_id, intra_image_comm) - ! - IF(ionode) THEN - WRITE( stdout,1002) - DO ip = 1, nproc_image - WRITE( stdout,1010) ip, ng_rcv(1,ip), ng_rcv(2,ip), ng_rcv(3,ip) - IF( ng_rcv(2,ip) < 1 ) ierr = ip - END DO - END IF - ! - CALL mp_max( ierr, intra_image_comm ) - ! - IF( ierr > 0 ) & - CALL errore( " gmeshinfo ", " Wow! some processors have no G-vectors ", ierr ) - ! - IF(ionode .AND. ngb > 0 ) THEN - WRITE( stdout,1050) - WRITE( stdout,1060) ngb - END IF - - 1000 FORMAT(16X,'Large Mesh',/, & - 3X,'PE Global(ngmt) Local(ngm) MaxLocal(ngmx)') - 1001 FORMAT(16X,'Smooth Mesh',/, & - 3X,'PE Global(ngst) Local(ngs) MaxLocal(ngsx)') - 1002 FORMAT(16X,'Wave function Mesh',/, & - 3X,'PE Global(ngwt) Local(ngw) MaxLocal(ngwx)') - 1010 FORMAT( I5,3I15 ) - 1050 FORMAT(/,16X,'Small box Mesh') - 1060 FORMAT( 3X, 'ngb = ', I12, ' not distributed to processors' ) - - RETURN - -END SUBROUTINE gmeshinfo - -!---------------------------------------------- -SUBROUTINE constraint_info() -!---------------------------------------------- - USE kinds, ONLY: DP - USE constraints_module, ONLY: nconstr, constr_tol, & - constr_type, constr, constr_target - USE io_global, ONLY: ionode, stdout - USE control_flags, ONLY: lconstrain - ! - IMPLICIT NONE - ! - INTEGER :: ic - ! - IF( lconstrain .AND. ionode ) THEN - ! - WRITE( stdout, 10 ) - WRITE( stdout, 20 ) nconstr, constr_tol - ! - DO ic = 1, nconstr - ! - IF( constr_type( ic ) == 3 ) THEN - ! - ! distance - ! - WRITE( stdout, 30 ) ic - WRITE( stdout, 40 ) NINT( constr(1,ic) ), & - NINT( constr(2,ic) ), constr_target(ic) - ! - END IF - ! - END DO - ! - END IF - ! -10 FORMAT( 3X, "Using constrained dynamics") -20 FORMAT( 3X, "number of constrain and tolerance: ", I5, D10.2) -30 FORMAT( 3X, "constrain ", I5, " type distance ") -40 FORMAT( 3X, " atoms ", I5, I5, " target dist ", F10.5) - ! -END SUBROUTINE constraint_info - - -SUBROUTINE new_atomind_constraints() - ! - USE kinds, ONLY: DP - USE constraints_module, ONLY: constr - USE ions_base, ONLY: ind_bck - ! - IMPLICIT NONE - ! - INTEGER :: ic, ia - INTEGER :: iaa - REAL(DP) :: aa - ! - ! Substitute the atom index given in the input file - ! with the new atom index, after the sort in the - ! atomic coordinates. - ! - DO ic = 1, SIZE( constr, 2 ) - DO ia = 1, SIZE( constr, 1 ) - IF( constr( ia, ic ) > 0.0d0 ) THEN - iaa = NINT( constr( ia, ic ) ) - aa = DBLE( ind_bck( iaa ) ) - constr( ia, ic ) = aa - END IF - END DO - END DO - ! - RETURN - ! -END SUBROUTINE new_atomind_constraints - - -SUBROUTINE compute_stress_x( stress, detot, h, omega ) - USE kinds, ONLY : DP - IMPLICIT NONE - REAL(DP), INTENT(OUT) :: stress(3,3) - REAL(DP), INTENT(IN) :: detot(3,3), h(3,3), omega - integer :: i, j - do i=1,3 - do j=1,3 - stress(i,j)=-1.d0/omega*(detot(i,1)*h(j,1)+ & - & detot(i,2)*h(j,2)+detot(i,3)*h(j,3)) - enddo - enddo - return -END SUBROUTINE compute_stress_x - - -! -! SUBROUTINE ggen_borghi ( gamma_only, at, bg ) -! !in declaration -! ! ( b1, b2, b3, nr1, nr2, nr3, nr1s, nr2s, nr3s, & -! ! & gcut, gcuts, gcutw, do_wf_cmplx, lgam) -! -! !* USE kinds, ONLY: DP -! ! use reciprocal_vectors, only: g, gx, igl, mill_g, g2_g, gl -! ! use reciprocal_vectors, only: mill_l, ig_l2g -! ! use reciprocal_vectors, only: gzero, gstart, sortedig_l2g -! ! use recvecs_indexes, only: nm, np -! ! use gvecs, only: ngs, nms, ngsl, nps -! ! use gvecw, only: ngw, ngwl, ngwt, ggp -! ! use gvecp, only: ng => ngm, ngl => ngml, ng_g => ngmt -! ! use io_global, only: stdout -! ! USE fft_base, ONLY: dfftp, dffts, fft_dlay_descriptor> -! ! use mp, ONLY: mp_sum, mp_max -! ! use io_global, only: ionode -! ! use mp_global, only: intra_image_comm -! !* use constants, only: eps8 -! ! use control_flags, only: iprsta -! -! !in modulo -! ! USE gvect, ONLY : ig_l2g, g, gg, ngm, ngm_g, gcutm, & -! ! mill, nl, gstart -! ! USE gvecs, ONLY : ngms, gcutms, ngms_g, nls -! ! USE fft_base, ONLY : dfftp, dffts -! ! -! !* USE kinds, ONLY : DP ---checked -! !* USE constants, ONLY : eps8 -! -! -! -! !---------------------------------------------------------------------- -! ! -! ! This routine generates all the reciprocal lattice vectors -! ! contained in the sphere of radius gcutm. Furthermore it -! ! computes the indices nl which give the correspondence -! ! between the fft mesh points and the array of g vectors. -! ! -! IMPLICIT NONE -! ! -! LOGICAL, INTENT(in) :: gamma_only -! real(DP), INTENT(IN) :: b1,b2,b3 -! REAL(DP) :: at(3,3), bg(3,3) -! ! here a few local variables -! ! -! REAL(DP) :: t (3), tt -! INTEGER :: ngm_, n1, n2, n3, n1s, n2s, n3s -! ! -! REAL(DP), ALLOCATABLE :: g2sort_g(:) -! ! array containing all g vectors, on all processors: replicated data -! INTEGER, ALLOCATABLE :: mill_g(:,:), mill_unsorted(:,:) -! ! array containing all g vectors generators, on all processors: -! ! replicated data -! INTEGER, ALLOCATABLE :: igsrt(:) -! ! -! #ifdef __PARA -! INTEGER :: m1, m2, mc -! #endif -! INTEGER :: ni, nj, nk, i, j, k, ipol, ng, igl, indsw -! ! -! ! counters -! ! -! ! set the total number of fft mesh points and and initial value of gg -! ! The choice of gcutm is due to the fact that we have to order the -! ! vectors after computing them. -! ! -! gg(:) = gcutm + 1.d0 -! ! -! ! set d vector for unique ordering -! ! -! ! and computes all the g vectors inside a sphere -! ! -! ALLOCATE( mill_g( 3, ngm_g ),mill_unsorted( 3, ngm_g ) ) -! ALLOCATE( igsrt( ngm_g ) ) -! ALLOCATE( g2sort_g( ngm_g ) ) -! g2sort_g(:) = 1.0d20 -! ! -! ! save present value of ngm -! ! -! ngm_ = ngm -! ! -! ngm = 0 -! ngms = 0 -! ! -! ! max miller indices (same convention as in module stick_set) -! ! -! ni = (dfftp%nr1-1)/2 -! nj = (dfftp%nr2-1)/2 -! nk = (dfftp%nr3-1)/2 -! ! -! iloop: DO i = -ni, ni -! ! -! ! gamma-only: exclude space with x < 0 -! ! -! IF ( gamma_only .and. i < 0) CYCLE iloop -! jloop: DO j = -nj, nj -! ! -! ! gamma-only: exclude plane with x = 0, y < 0 -! ! -! IF ( gamma_only .and. i == 0 .and. j < 0) CYCLE jloop -! kloop: DO k = -nk, nk -! ! -! ! gamma-only: exclude line with x = 0, y = 0, z < 0 -! ! -! IF ( gamma_only .and. i == 0 .and. j == 0 .and. k < 0) CYCLE kloop -! t(:) = i * bg (:,1) + j * bg (:,2) + k * bg (:,3) -! tt = sum(t(:)**2) -! IF (tt <= gcutm) THEN -! ngm = ngm + 1 -! IF (tt <= gcutms) ngms = ngms + 1 -! IF (ngm > ngm_g) CALL errore ('ggen', 'too many g-vectors', ngm) -! mill_unsorted( :, ngm ) = (/ i,j,k /) -! IF ( tt > eps8 ) THEN -! g2sort_g(ngm) = tt -! ELSE -! g2sort_g(ngm) = 0.d0 -! ENDIF -! ENDIF -! ENDDO kloop -! ENDDO jloop -! ENDDO iloop -! -! IF (ngm /= ngm_g ) & -! CALL errore ('ggen', 'g-vectors missing !', abs(ngm - ngm_g)) -! IF (ngms /= ngms_g) & -! CALL errore ('ggen', 'smooth g-vectors missing !', abs(ngms - ngms_g)) -! -! igsrt(1) = 0 -! CALL hpsort_eps( ngm_g, g2sort_g, igsrt, eps8 ) -! mill_g(1,:) = mill_unsorted(1,igsrt(:)) -! mill_g(2,:) = mill_unsorted(2,igsrt(:)) -! mill_g(3,:) = mill_unsorted(3,igsrt(:)) -! DEALLOCATE( g2sort_g, igsrt, mill_unsorted ) -! -! ngm = 0 -! ngms = 0 -! ngloop: DO ng = 1, ngm_g -! i = mill_g(1, ng) -! j = mill_g(2, ng) -! k = mill_g(3, ng) -! -! #ifdef __PARA -! m1 = mod (i, dfftp%nr1) + 1 -! IF (m1 < 1) m1 = m1 + dfftp%nr1 -! m2 = mod (j, dfftp%nr2) + 1 -! IF (m2 < 1) m2 = m2 + dfftp%nr2 -! mc = m1 + (m2 - 1) * dfftp%nr1x -! IF ( dfftp%isind ( mc ) == 0) CYCLE ngloop -! #endif -! -! ngm = ngm + 1 -! -! ! Here map local and global g index !!! -! ig_l2g( ngm ) = ng -! -! g (1:3, ngm) = i * bg (:, 1) + j * bg (:, 2) + k * bg (:, 3) -! gg (ngm) = sum(g (1:3, ngm)**2) -! -! IF (gg (ngm) <= gcutms) ngms = ngms + 1 -! IF (ngm > ngm_) CALL errore ('ggen', 'too many g-vectors', ngm) -! ENDDO ngloop -! -! IF (ngm /= ngm_) & -! CALL errore ('ggen', 'g-vectors missing !', abs(ngm - ngm_)) -! ! -! ! determine first nonzero g vector -! ! -! IF (gg(1).le.eps8) THEN -! gstart=2 -! ELSE -! gstart=1 -! ENDIF -! ! -! ! Now set nl and nls with the correct fft correspondence -! ! -! DO ng = 1, ngm -! n1 = nint (sum(g (:, ng) * at (:, 1))) + 1 -! mill (1,ng) = n1 - 1 -! n1s = n1 -! IF (n1<1) n1 = n1 + dfftp%nr1 -! IF (n1s<1) n1s = n1s + dffts%nr1 -! -! n2 = nint (sum(g (:, ng) * at (:, 2))) + 1 -! mill (2,ng) = n2 - 1 -! n2s = n2 -! IF (n2<1) n2 = n2 + dfftp%nr2 -! IF (n2s<1) n2s = n2s + dffts%nr2 -! -! n3 = nint (sum(g (:, ng) * at (:, 3))) + 1 -! mill (3,ng) = n3 - 1 -! n3s = n3 -! IF (n3<1) n3 = n3 + dfftp%nr3 -! IF (n3s<1) n3s = n3s + dffts%nr3 -! -! IF (n1>dfftp%nr1 .or. n2>dfftp%nr2 .or. n3>dfftp%nr3) & -! CALL errore('ggen','Mesh too small?',ng) -! -! #if defined (__PARA) && !defined (__USE_3D_FFT) -! nl (ng) = n3 + ( dfftp%isind (n1 + (n2 - 1) * dfftp%nr1x) - 1) * dfftp%nr3x -! IF (ng <= ngms) & -! nls (ng) = n3s + ( dffts%isind (n1s+(n2s-1)*dffts%nr1x) - 1 ) * dffts%nr3x -! #else -! nl (ng) = n1 + (n2 - 1) * dfftp%nr1x + (n3 - 1) * dfftp%nr1x * dfftp%nr2x -! IF (ng <= ngms) & -! nls (ng) = n1s + (n2s - 1) * dffts%nr1x + (n3s - 1) * dffts%nr1x * dffts%nr2x -! #endif -! ENDDO -! ! -! DEALLOCATE( mill_g ) -! -! IF ( gamma_only) CALL index_minusg() -! -! END SUBROUTINE ggen_borghi diff --git a/quantum_espresso/kcp/CPV/cp_interfaces.f90 b/quantum_espresso/kcp/CPV/cp_interfaces.f90 deleted file mode 100644 index 84eddabfa..000000000 --- a/quantum_espresso/kcp/CPV/cp_interfaces.f90 +++ /dev/null @@ -1,2101 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! written by Carlo Cavazzoni - -!=----------------------------------------------------------------------------=! - MODULE cp_interfaces -!=----------------------------------------------------------------------------=! - - IMPLICIT NONE - PRIVATE - - PUBLIC :: bessel2 - PUBLIC :: bessel3 - PUBLIC :: dforce - - PUBLIC :: pseudopotential_indexes - PUBLIC :: compute_dvan - PUBLIC :: compute_betagx - PUBLIC :: compute_qradx - PUBLIC :: interpolate_beta - PUBLIC :: interpolate_qradb - PUBLIC :: exact_beta - PUBLIC :: build_cctab - PUBLIC :: chkpstab - PUBLIC :: build_pstab - PUBLIC :: check_tables - PUBLIC :: fill_qrl - PUBLIC :: exact_qradb - PUBLIC :: compute_xgtab - - PUBLIC :: rhoofr - PUBLIC :: fillgrad - PUBLIC :: checkrho - PUBLIC :: dft_total_charge - - PUBLIC :: writefile - PUBLIC :: readfile - - PUBLIC :: main_fpmd - - PUBLIC :: runcp_uspp - PUBLIC :: runcp_uspp_force_pairing - - PUBLIC :: newrho - - PUBLIC :: readempty_twin - PUBLIC :: readempty - PUBLIC :: writeempty_twin - PUBLIC :: writeempty - PUBLIC :: gram_empty - PUBLIC :: empty_cp - - PUBLIC :: invfft - PUBLIC :: fwfft - - PUBLIC :: eigs - PUBLIC :: eigs_non_ortho - PUBLIC :: fermi_energy - PUBLIC :: packgam - - PUBLIC :: ortho - PUBLIC :: ortho_gamma - - PUBLIC :: v2gc - PUBLIC :: exch_corr_energy - PUBLIC :: stress_xc - PUBLIC :: stress_gc - - PUBLIC :: nlfh - - PUBLIC :: pstress - PUBLIC :: pseudo_stress - PUBLIC :: compute_gagb - PUBLIC :: stress_har - PUBLIC :: stress_hartree - PUBLIC :: add_drhoph - PUBLIC :: stress_local - PUBLIC :: stress_kin - - PUBLIC :: interpolate_lambda - PUBLIC :: update_lambda - PUBLIC :: elec_fakekine - PUBLIC :: wave_rand_init - PUBLIC :: wave_atom_init - PUBLIC :: crot - PUBLIC :: proj - - PUBLIC :: phfacs - PUBLIC :: strucf - - PUBLIC :: add_core_charge - PUBLIC :: core_charge_forces - - PUBLIC :: printout_new - PUBLIC :: printout - PUBLIC :: print_sfac - PUBLIC :: open_and_append - PUBLIC :: cp_print_rho - - PUBLIC :: vofmean - PUBLIC :: vofrhos - PUBLIC :: vofps - PUBLIC :: vofloc - PUBLIC :: force_loc - PUBLIC :: self_vofhar - PUBLIC :: localisation - ! - PUBLIC :: n_atom_wfc - ! - PUBLIC :: set_eitot - PUBLIC :: set_evtot - ! - PUBLIC :: print_projwfc - PUBLIC :: print_lambda - ! - PUBLIC :: move_electrons - ! - PUBLIC :: compute_stress - - PUBLIC :: protate - - !--- FOR COMPLEX IMPLEMENTATION --! added:giovanni - - PUBLIC :: nlsm1 - PUBLIC :: nlsm1_dist - PUBLIC :: wave_sine_init !added:giovanni debug - PUBLIC :: nksic_get_orbitalrho - PUBLIC :: calrhovan - PUBLIC :: nlfl - PUBLIC :: grabec - PUBLIC :: smooth_csv - PUBLIC :: bec_csv - PUBLIC :: set_x_minus1 - PUBLIC :: xminus1 - PUBLIC :: projwfc_hub - PUBLIC :: s_wfc - PUBLIC :: new_ns - - !--- For writing the Hamiltonian --! added: RdG - - PUBLIC :: write_hamiltonian - PUBLIC :: ortho_check - - PUBLIC :: symm_wannier - - INTERFACE s_wfc - ! - SUBROUTINE s_wfc_real(n_atomic_wfc1,becwfc,betae,wfc,swfc) - ! - USE kinds, ONLY: DP - USE ions_base, ONLY: na - USE cvan, ONLY: nvb, ish - USE uspp, ONLY: nkb - USE uspp_param, ONLY: nh - USE gvecw, ONLY: ngw - IMPLICIT NONE - ! input - INTEGER, INTENT(in) :: n_atomic_wfc1 - COMPLEX(DP), INTENT(in) :: betae(ngw,nkb), wfc(ngw,n_atomic_wfc1) - REAL(DP), INTENT(in) :: becwfc(nkb,n_atomic_wfc1) - ! output - COMPLEX(DP), INTENT(out):: swfc(ngw,n_atomic_wfc1) - END SUBROUTINE s_wfc_real - ! - SUBROUTINE s_wfc_twin(n_atomic_wfc1,becwfc,betae,wfc,swfc, lgam) - ! - USE kinds, ONLY: DP - USE ions_base, ONLY: na - USE cvan, ONLY: nvb, ish - USE uspp, ONLY: nkb, nhsavb=>nkbus, qq - USE uspp_param, ONLY: nh - USE gvecw, ONLY: ngw - USE twin_types - ! - IMPLICIT NONE - ! input - INTEGER, INTENT(in) :: n_atomic_wfc1 - COMPLEX(DP), INTENT(in) :: betae(ngw,nkb), wfc(ngw,n_atomic_wfc1) - TYPE(twin_matrix) :: becwfc - LOGICAL :: lgam - ! output - COMPLEX(DP), INTENT(out):: swfc(ngw,n_atomic_wfc1) - END SUBROUTINE s_wfc_twin - END INTERFACE - ! - INTERFACE new_ns - ! - subroutine new_ns_real(c,eigr,betae,hpsi,hpsi_con,forceh) - - use kinds, ONLY: DP - use ions_base, only: na, nat, nsp - use electrons_base, only: nspin, nbsp, nbspx, ispin, f - use gvecw, only: ngw - USE uspp, ONLY: nkb - implicit none -#ifdef __PARA - include 'mpif.h' -#endif - integer, parameter :: ldmx = 7 - complex(DP), intent(in) :: c(ngw,nbspx), eigr(ngw,nat), & - & betae(ngw,nkb) - complex(DP), intent(out) :: hpsi(ngw,nbspx), hpsi_con(1,1) - real(DP) forceh(3,nat) - ! - end subroutine new_ns_real - ! - subroutine new_ns_twin(c,eigr,betae,hpsi,hpsi_con,forceh,lgam) - - use kinds, ONLY: DP - use ions_base, only: na, nat, nsp - use electrons_base, only: nspin, nbsp, nbspx, ispin, f - use gvecw, only: ngw - USE uspp, ONLY: nkb - implicit none -#ifdef __PARA - include 'mpif.h' -#endif - integer, parameter :: ldmx = 7 - complex(DP), intent(in) :: c(ngw,nbspx), eigr(ngw,nat), & - & betae(ngw,nkb) - complex(DP), intent(out) :: hpsi(ngw,nbspx), hpsi_con(1,1) - real(DP) forceh(3,nat) - logical :: lgam - ! - end subroutine new_ns_twin - ! - END INTERFACE - ! - INTERFACE projwfc_hub - ! - SUBROUTINE projwfc_hub_real( c, nx, eigr, betae, n, n_atomic_wfc, & - & wfc, becwfc, swfc, proj) - - USE kinds, ONLY: DP - USE gvecw, ONLY: ngw - USE ions_base, ONLY: nsp, na, nat - USE uspp, ONLY: nkb - ! - IMPLICIT NONE - INTEGER, INTENT(IN) :: nx, n, n_atomic_wfc - COMPLEX(DP), INTENT(IN) :: c( ngw, nx ), eigr(ngw,nat), betae(ngw,nkb) - COMPLEX(DP), INTENT(OUT):: wfc(ngw,n_atomic_wfc), & - & swfc( ngw, n_atomic_wfc ) - real(DP), intent(out):: becwfc(nkb,n_atomic_wfc) !DEBUG - REAL(DP) :: proj(n,n_atomic_wfc) - ! - end subroutine projwfc_hub_real - ! - SUBROUTINE projwfc_hub_twin( c, nx, eigr, betae, n, n_atomic_wfc, & - & wfc, becwfc, swfc, proj, lgam) - - USE kinds, ONLY: DP - USE gvecw, ONLY: ngw - USE ions_base, ONLY: nsp, na, nat - USE uspp, ONLY: nkb - USE twin_types !added:giovanni - ! - IMPLICIT NONE - INTEGER, INTENT(IN) :: nx, n, n_atomic_wfc - COMPLEX(DP), INTENT(IN) :: c( ngw, nx ), eigr(ngw,nat), betae(ngw,nkb) - LOGICAL :: lgam - ! - COMPLEX(DP), INTENT(OUT):: wfc(ngw,n_atomic_wfc), & - & swfc( ngw, n_atomic_wfc ) - ! real(DP), intent(out):: becwfc(nhsa,n_atomic_wfc) !DEBUG - type(twin_matrix) :: becwfc, proj!(nhsa,n_atomic_wfc) !DEBUG - ! - end SUBROUTINE projwfc_hub_twin - ! - END INTERFACE - - INTERFACE set_x_minus1 - - subroutine set_x_minus1_real(betae,m_minus1,ema0bg,use_ema) - - use kinds, only: dp -! use ions_base, only: na, nsp -! use io_global, only: stdout -! use mp_global, only: intra_image_comm -! use cvan -! use gvecw, only: ngw -! use constants, only: pi, fpi -! use control_flags, only: iprint, iprsta -! use reciprocal_vectors, only: ng0 => gstart -! use mp, only: mp_sum, mp_bcast -! use electrons_base, only: n => nbsp, ispin -! use uspp_param, only: nh -! use uspp, only :nhsa=>nkb,qq,nhsavb=>nkbus -! use io_global, ONLY: ionode, ionode_id - - implicit none - - complex(DP) :: betae(:,:) - real(DP) :: m_minus1(:,:) - real(DP) :: ema0bg(:) - logical :: use_ema - - end subroutine set_x_minus1_real - - subroutine set_x_minus1_twin(betae,m_minus1,ema0bg,use_ema) - - use kinds, only: dp -! use ions_base, only: na, nsp -! use io_global, only: stdout -! use mp_global, only: intra_image_comm -! use cvan - use gvecw, only: ngw -! use constants, only: pi, fpi -! use control_flags, only: iprint, iprsta -! use reciprocal_vectors, only: ng0 => gstart -! use mp, only: mp_sum, mp_bcast -! use electrons_base, only: n => nbsp, ispin -! use uspp_param, only: nh - use uspp, only :nkb -! use io_global, ONLY: ionode, ionode_id - use twin_types - - implicit none - - complex(DP) :: betae(ngw, nkb) - type(twin_matrix) :: m_minus1 - real(DP) :: ema0bg(:) - logical :: use_ema - - end subroutine set_x_minus1_twin - - END INTERFACE - - INTERFACE xminus1 - - subroutine xminus1_real(c0,betae,ema0bg,beck,m_minus1,do_k) - - use kinds, only: dp -! use ions_base, only: na, nsp -! use io_global, only: stdout -! !$$ -! use io_global, only: ionode -! !$$ -! use mp_global, only: intra_image_comm -! use cvan -! use uspp_param, only: nh -! use uspp, only :nhsa=>nkb, nhsavb=>nkbus, qq -! use electrons_base, only: n => nbsp -! use gvecw, only: ngw -! use constants, only: pi, fpi -! use control_flags, only: iprint, iprsta -! use mp, only: mp_sum -! use reciprocal_vectors, only: ng0 => gstart - ! - implicit none - complex(dp) c0(:,:), betae(:,:) - real(dp) beck(:,:), ema0bg(:) - real(DP) :: m_minus1(:,:) - logical :: do_k - - end subroutine xminus1_real - - subroutine xminus1_twin(c0,betae,ema0bg,beck,m_minus1,do_k) -! use ions_base, only: na, nsp -! use io_global, only: stdout -! !$$ -! use io_global, only: ionode -! !$$ -! use mp_global, only: intra_image_comm -! use cvan -! use uspp_param, only: nh -! use uspp, only :nhsa=>nkb, nhsavb=>nkbus, qq -! use electrons_base, only: n => nbsp -! use gvecw, only: ngw -! use constants, only: pi, fpi -! use control_flags, only: iprint, iprsta -! use mp, only: mp_sum -! use reciprocal_vectors, only: ng0 => gstart - use twin_types - use kinds, only: DP - - implicit none - complex(DP) :: c0(:,:), betae(:,:) - real(DP) :: ema0bg(:) - type(twin_matrix) :: beck - ! complex(DP) :: m_minus1(nhsavb,nhsavb) - type(twin_matrix) :: m_minus1 !(nhsavb,nhsavb) - logical :: do_k - end subroutine xminus1_twin - - END INTERFACE - - INTERFACE smooth_csv - SUBROUTINE smooth_csv_real( c, v, ngwx, csv, n ) - USE kinds, ONLY: DP - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ngwx, n - COMPLEX(DP) :: c( ngwx ) - COMPLEX(DP) :: v( ngwx, n ) - REAL(DP) :: csv( n ) - END SUBROUTINE - SUBROUTINE smooth_csv_twin( c, v, ngwx, csv, n ) - USE kinds, ONLY: DP - USE twin_types - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: ngwx, n - COMPLEX(DP) :: c( ngwx ) - COMPLEX(DP) :: v( ngwx, n ) - type(twin_matrix) :: csv - END SUBROUTINE - END INTERFACE - - INTERFACE bec_csv - SUBROUTINE bec_csv_real( becc, becv, nkbx, csv, n ) - USE ions_base, ONLY: na - USE cvan, ONLY :nvb, ish - USE uspp, ONLY : nkb, nhsavb=>nkbus, qq - USE uspp_param, ONLY: nh - USE kinds, ONLY: DP -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: nkbx, n - REAL(DP) :: becc( nkbx ) - REAL(DP) :: becv( nkbx, n ) - REAL(DP) :: csv( n ) - INTEGER :: k, is, iv, jv, ia, inl, jnl - REAL(DP) :: rsum - END SUBROUTINE - - SUBROUTINE bec_csv_twin( becc, becv, nkbx, csv, n, lcc ) - USE ions_base, ONLY: na - USE cvan, ONLY :nvb, ish - USE uspp, ONLY : nkb, nhsavb=>nkbus, qq - USE uspp_param, ONLY: nh - USE kinds, ONLY: DP - USE twin_types -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: nkbx, n, lcc - type(twin_matrix) :: becc !( nkbx ) - type(twin_matrix) :: becv !( nkbx, n ) - type(twin_matrix) :: csv!( n ) - INTEGER :: k, is, iv, jv, ia, inl, jnl - REAL(DP) :: rsum - END SUBROUTINE - END INTERFACE - - INTERFACE nlfl - SUBROUTINE nlfl_real(bec,becdr,lambda,fion) - USE kinds, ONLY: DP -! USE ions_base, ONLY: na, nsp, nat -! USE uspp, ONLY: nhsa=>nkb, qq -! USE electrons_base, ONLY: nbspx, nbsp, nudx, nspin, iupdwn, nupdwn -! USE cp_main_variables, ONLY: nlam, nlax, descla, la_proc -! - IMPLICIT NONE - REAL(DP) :: bec(:,:), becdr(:,:,:), lambda(:,:,:) - REAL(DP) :: fion(:,:) - END SUBROUTINE - SUBROUTINE nlfl_cmplx(bec,becdr,lambda,fion) - USE kinds, ONLY: DP -! USE ions_base, ONLY: na, nsp, nat -! USE uspp, ONLY: nhsa=>nkb, qq -! USE electrons_base, ONLY: nbspx, nbsp, nudx, nspin, iupdwn, nupdwn -! USE cp_main_variables, ONLY: nlam, nlax, descla, la_proc -! - IMPLICIT NONE - COMPLEX(DP) :: bec(:,:), becdr(:,:,:), lambda(:,:,:) - REAL(DP) :: fion(:,:) - END SUBROUTINE - SUBROUTINE nlfl_twin(bec,becdr,lambda,fion, lgam) !warning, why is this interface not working - USE kinds, ONLY: DP -! USE ions_base, ONLY: na, nsp, nat -! USE uspp, ONLY: nhsa=>nkb, qq - USE electrons_base, ONLY: nspin -! USE cp_main_variables, ONLY: nlam, nlax, descla, la_proc - USE twin_types -! - IMPLICIT NONE - - TYPE(twin_matrix) :: lambda(nspin)!(nlam,nlam,nspin) - REAL(DP) :: fion(:,:) - TYPE(twin_matrix) :: bec - TYPE(twin_tensor) :: becdr - LOGICAL :: lgam - END SUBROUTINE - END INTERFACE - - INTERFACE calrhovan - subroutine calrhovan_real( rhovan, bec, iwf ) - use kinds, only : DP - use cvan, only : ish - use uspp_param, only : nhm, nh - use uspp, only : nkb, dvan - use electrons_base, only : nbsp, nspin, ispin, f - use ions_base, only : nsp, nat, na - implicit none - real(DP) :: bec( nkb, nbsp ) - real(DP) :: rhovan( nhm*(nhm+1)/2, nat, nspin ) - integer, intent(in) :: iwf - end subroutine - subroutine calrhovan_twin( rhovan, bec, iwf ) - use kinds, only : DP - use uspp_param, only : nhm, nh - use uspp, only : nkb, dvan - use electrons_base, only : nspin, ispin, f - use ions_base, only : nsp, nat, na - use twin_types - implicit none - type(twin_matrix) :: bec !( nkb, n ) - real(DP) :: rhovan( nhm*(nhm+1)/2, nat, nspin ) - integer, intent(in) :: iwf - end subroutine - END INTERFACE - - INTERFACE nksic_get_orbitalrho - subroutine nksic_get_orbitalrho_real( ngw, nnrx, bec, ispin, nbsp, & - c1, c2, orb_rhor, i1, i2 ) - use kinds, only: dp - use twin_types - ! - implicit none - - integer, intent(in) :: ngw,nnrx,i1,i2 - integer, intent(in) :: nbsp, ispin(nbsp) - type(twin_matrix), intent(in) :: bec!(nkb, nbsp) - complex(dp), intent(in) :: c1(ngw),c2(ngw) - real(dp), intent(out) :: orb_rhor(nnrx,2) - END SUBROUTINE nksic_get_orbitalrho_real - - SUBROUTINE nksic_get_orbitalrho_twin_non_ortho( ngw, nnrx, bec, & - becdual, ispin, nbsp, & - c1, c2, c1dual, c2dual, orb_rhor, & - i1, i2, lgam ) - use kinds, only: dp - use twin_types - ! - implicit none - integer, intent(in) :: ngw,nnrx,i1,i2 - integer, intent(in) :: nbsp, ispin(nbsp) - type(twin_matrix) :: bec,becdual !(nkb, nbsp) - complex(dp), intent(in) :: c1(ngw),c2(ngw),c1dual(ngw),c2dual(ngw) - real(dp), intent(out) :: orb_rhor(nnrx,2) - logical :: lgam - END SUBROUTINE nksic_get_orbitalrho_twin_non_ortho - - SUBROUTINE nksic_get_orbitalrho_twin( ngw, nnrx, bec, ispin, nbsp, & - c1, c2, orb_rhor, i1, i2, lgam ) - - use kinds, only: dp - use twin_types - ! - implicit none - integer, intent(in) :: ngw,nnrx,i1,i2 - integer, intent(in) :: nbsp, ispin(nbsp) - type(twin_matrix) :: bec !(nkb, nbsp) - complex(dp), intent(in) :: c1(ngw),c2(ngw) - real(dp), intent(out) :: orb_rhor(nnrx,2) - logical :: lgam - END SUBROUTINE nksic_get_orbitalrho_twin - - END INTERFACE - - INTERFACE bessel2 - SUBROUTINE bessel2_x(XG, RW, FINT, LNL, INDL, MMAX) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(IN) :: XG - REAL(DP), INTENT(IN) :: RW(:) - REAL(DP), INTENT(OUT) :: FINT(:,:) - INTEGER, INTENT(IN) :: INDL(:), LNL, MMAX - END SUBROUTINE bessel2_x - END INTERFACE - - INTERFACE bessel3 - SUBROUTINE BESSEL3_x(XG, RW, FINT, LNL, INDL, MMAX) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(IN) :: XG - REAL(DP), INTENT(IN) :: RW(:) - REAL(DP), INTENT(OUT) :: FINT(:,:) - INTEGER, INTENT(IN) :: INDL(:), LNL, MMAX - END SUBROUTINE BESSEL3_x - END INTERFACE - - INTERFACE dforce - SUBROUTINE dforce_x_new( i, bec, vkb, c, df, da, v, ldv, ispin, f, n, nspin, v1 ) - USE kinds, ONLY: DP - USE twin_types - IMPLICIT NONE - INTEGER, INTENT(IN) :: i - type(twin_matrix) :: bec!(:,:)!modified:giovanni - COMPLEX(DP) :: vkb(:,:) - COMPLEX(DP) :: c(:,:) - COMPLEX(DP) :: df(:), da(:) - INTEGER, INTENT(IN) :: ldv - REAL(DP) :: v( ldv, * ) - INTEGER :: ispin( : ) - REAL(DP) :: f( : ) - INTEGER, INTENT(IN) :: n, nspin - REAL(DP), OPTIONAL :: v1( ldv, * ) - END SUBROUTINE dforce_x_new - - SUBROUTINE dforce_x( i, bec, vkb, c, df, da, v, ldv, ispin, f, n, nspin, v1 ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: i - REAL(DP) :: bec(:,:) - COMPLEX(DP) :: vkb(:,:) - COMPLEX(DP) :: c(:,:) - COMPLEX(DP) :: df(:), da(:) - INTEGER, INTENT(IN) :: ldv - REAL(DP) :: v( ldv, * ) - INTEGER :: ispin( : ) - REAL(DP) :: f( : ) - INTEGER, INTENT(IN) :: n, nspin - REAL(DP), OPTIONAL :: v1( ldv, * ) - END SUBROUTINE dforce_x - END INTERFACE - - INTERFACE pseudopotential_indexes - SUBROUTINE pseudopotential_indexes_x( ) - IMPLICIT NONE - END SUBROUTINE pseudopotential_indexes_x - END INTERFACE - - INTERFACE compute_dvan - SUBROUTINE compute_dvan_x() - IMPLICIT NONE - END SUBROUTINE - END INTERFACE - - INTERFACE compute_betagx - SUBROUTINE compute_betagx_x( tpre ) - IMPLICIT NONE - LOGICAL, INTENT(IN) :: tpre - END SUBROUTINE - END INTERFACE - - INTERFACE compute_qradx - SUBROUTINE compute_qradx_x( tpre ) - IMPLICIT NONE - LOGICAL, INTENT(IN) :: tpre - END SUBROUTINE - END INTERFACE - - INTERFACE interpolate_beta - SUBROUTINE interpolate_beta_x( tpre ) - IMPLICIT NONE - LOGICAL, INTENT(IN) :: tpre - END SUBROUTINE - END INTERFACE - - INTERFACE interpolate_qradb - SUBROUTINE interpolate_qradb_x( tpre ) - IMPLICIT NONE - LOGICAL, INTENT(IN) :: tpre - END SUBROUTINE - END INTERFACE - - INTERFACE exact_beta - SUBROUTINE exact_beta_x( tpre ) - IMPLICIT NONE - LOGICAL, INTENT(IN) :: tpre - END SUBROUTINE - END INTERFACE - - INTERFACE build_cctab - SUBROUTINE build_cctab_x( ) - IMPLICIT NONE - END SUBROUTINE - END INTERFACE - - INTERFACE chkpstab - LOGICAL FUNCTION chkpstab_x(hg, xgtabmax) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(IN) :: hg(:) - REAL(DP), INTENT(IN) :: xgtabmax - END FUNCTION - END INTERFACE - - INTERFACE build_pstab - SUBROUTINE build_pstab_x( ) - IMPLICIT NONE - END SUBROUTINE - END INTERFACE - - INTERFACE check_tables - LOGICAL FUNCTION check_tables_x( ) - IMPLICIT NONE - END FUNCTION check_tables_x - END INTERFACE - - INTERFACE fill_qrl - SUBROUTINE fill_qrl_x( is, qrl ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: is - REAL(DP), INTENT(OUT) :: qrl( :, :, : ) - END SUBROUTINE - END INTERFACE - - INTERFACE exact_qradb - SUBROUTINE exact_qradb_x( tpre ) - IMPLICIT NONE - LOGICAL, INTENT(IN) :: tpre - END SUBROUTINE - END INTERFACE - - INTERFACE compute_xgtab - SUBROUTINE compute_xgtab_x( xgmin, xgmax, xgtabmax ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(OUT) :: xgmax, xgmin, xgtabmax - END SUBROUTINE - END INTERFACE - - - INTERFACE dft_total_charge - FUNCTION dft_total_charge_x( c, ngw, fi, n ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: ngw, n - COMPLEX(DP), INTENT(IN) :: c(:,:) - REAL (DP), INTENT(IN) :: fi(:) - REAL(DP) dft_total_charge_x - END FUNCTION - END INTERFACE - - INTERFACE rhoofr - ! - SUBROUTINE rhoofr_cp_non_ortho & - ( nfi, c, cdual, irb, eigrb, bec, becdual, rhovan, rhor, rhog, rhos, enl, denl, ekin, dekin, tstress, ndwwf ) - USE kinds, ONLY: DP - USE twin_types - - IMPLICIT NONE - INTEGER nfi - COMPLEX(DP) c( :, : ), cdual( :, : ) - INTEGER irb( :, : ) - COMPLEX(DP) eigrb( :, : ) - type(twin_matrix) :: bec, becdual!(:,:)!modified:giovanni - REAL(DP) rhovan(:, :, : ) - REAL(DP) rhor(:,:) - COMPLEX(DP) rhog( :, : ) - REAL(DP) rhos(:,:) - REAL(DP) enl, ekin - REAL(DP) denl(3,3), dekin(6) - LOGICAL, OPTIONAL, INTENT(IN) :: tstress - INTEGER, OPTIONAL, INTENT(IN) :: ndwwf - END SUBROUTINE rhoofr_cp_non_ortho - ! - SUBROUTINE rhoofr_cp_ortho & - ( nfi, c, irb, eigrb, bec, rhovan, rhor, rhog, rhos, enl, denl, ekin, dekin, tstress, ndwwf ) - USE kinds, ONLY: DP - USE twin_types - - IMPLICIT NONE - INTEGER nfi - COMPLEX(DP) c( :, : ) - INTEGER irb( :, : ) - COMPLEX(DP) eigrb( :, : ) - type(twin_matrix) :: bec!(:,:)!modified:giovanni - REAL(DP) rhovan(:, :, : ) - REAL(DP) rhor(:,:) - COMPLEX(DP) rhog( :, : ) - REAL(DP) rhos(:,:) - REAL(DP) enl, ekin - REAL(DP) denl(3,3), dekin(6) - LOGICAL, OPTIONAL, INTENT(IN) :: tstress - INTEGER, OPTIONAL, INTENT(IN) :: ndwwf - END SUBROUTINE rhoofr_cp_ortho - ! - SUBROUTINE rhoofr_cp_old & - ( nfi, c, irb, eigrb, bec, rhovan, rhor, rhog, rhos, enl, denl, ekin, dekin, tstress, ndwwf ) - USE kinds, ONLY: DP - USE twin_types - - IMPLICIT NONE - INTEGER nfi - COMPLEX(DP) c( :, : ) - INTEGER irb( :, : ) - COMPLEX(DP) eigrb( :, : ) - REAL(DP) :: bec(:,:) - REAL(DP) rhovan(:, :, : ) - REAL(DP) rhor(:,:) - COMPLEX(DP) rhog( :, : ) - REAL(DP) rhos(:,:) - REAL(DP) enl, ekin - REAL(DP) denl(3,3), dekin(6) - LOGICAL, OPTIONAL, INTENT(IN) :: tstress - INTEGER, OPTIONAL, INTENT(IN) :: ndwwf - END SUBROUTINE rhoofr_cp_old - END INTERFACE - - - INTERFACE fillgrad - SUBROUTINE fillgrad_x( nspin, rhog, gradr, lgam ) - USE kinds, ONLY: DP - USE gvecp, ONLY: ngm - USE grid_dimensions, ONLY: nnrx - IMPLICIT NONE - INTEGER, INTENT(IN) :: nspin - complex(DP) :: rhog( ngm, nspin ) - real(DP) :: gradr( nnrx, 3, nspin ) - logical :: lgam - END SUBROUTINE fillgrad_x - END INTERFACE - - - INTERFACE checkrho - SUBROUTINE checkrho_x(nnr,nspin,rhor,rmin,rmax,rsum,rnegsum) - USE kinds, ONLY: DP - USE grid_dimensions, ONLY: nnrx - IMPLICIT NONE - INTEGER, INTENT(IN) :: nnr, nspin - REAL(DP) :: rhor(nnr,nspin), rmin, rmax, rsum, rnegsum - END SUBROUTINE checkrho_x - END INTERFACE - - INTERFACE readfile - SUBROUTINE readfile_cp_real & - & ( flag, h,hold,nfi,c0,cm,taus,tausm,vels,velsm,acc, & - & lambda,lambdam,xnhe0,xnhem,vnhe,xnhp0,xnhpm,vnhp,nhpcl,nhpdim,ekincm,& - & xnhh0,xnhhm,vnhh,velh,fion, tps, mat_z, occ_f ) - USE kinds, ONLY : DP - IMPLICIT NONE - INTEGER, INTENT(in) :: flag - integer :: nfi - REAL(DP) :: h(3,3), hold(3,3) - complex(DP) :: c0(:,:), cm(:,:) - REAL(DP) :: tausm(:,:),taus(:,:), fion(:,:) - REAL(DP) :: vels(:,:), velsm(:,:) - REAL(DP) :: acc(:),lambda(:,:,:), lambdam(:,:,:) - REAL(DP) :: xnhe0,xnhem,vnhe - REAL(DP) :: xnhp0(:), xnhpm(:), vnhp(:) - integer, INTENT(inout) :: nhpcl,nhpdim - REAL(DP) :: ekincm - REAL(DP) :: xnhh0(3,3),xnhhm(3,3),vnhh(3,3),velh(3,3) - REAL(DP), INTENT(OUT) :: tps - REAL(DP), INTENT(INOUT) :: mat_z(:,:,:), occ_f(:) - END SUBROUTINE readfile_cp_real - SUBROUTINE readfile_cp_twin & - & ( flag, h,hold,nfi,c0,cm,taus,tausm,vels,velsm,acc, & - & lambda,lambdam,xnhe0,xnhem,vnhe,xnhp0,xnhpm,vnhp,nhpcl,nhpdim,ekincm,& - & xnhh0,xnhhm,vnhh,velh,fion, tps, mat_z, occ_f ) - USE kinds, ONLY : DP - USE twin_types - - IMPLICIT NONE - INTEGER, INTENT(in) :: flag - integer :: nfi - REAL(DP) :: h(3,3), hold(3,3) - complex(DP) :: c0(:,:), cm(:,:) - REAL(DP) :: tausm(:,:),taus(:,:), fion(:,:) - REAL(DP) :: vels(:,:), velsm(:,:) - REAL(DP) :: acc(:) - TYPE(twin_matrix), dimension(:) :: lambda, lambdam - REAL(DP) :: xnhe0,xnhem,vnhe - REAL(DP) :: xnhp0(:), xnhpm(:), vnhp(:) - integer, INTENT(inout) :: nhpcl,nhpdim - REAL(DP) :: ekincm - REAL(DP) :: xnhh0(3,3),xnhhm(3,3),vnhh(3,3),velh(3,3) - REAL(DP), INTENT(OUT) :: tps - REAL(DP), INTENT(INOUT) :: occ_f(:) - TYPE(twin_matrix), dimension(:) :: mat_z - END SUBROUTINE readfile_cp_twin - END INTERFACE - - INTERFACE writefile - SUBROUTINE writefile_cp_real & - ( h,hold,nfi,c0,cm,taus,tausm,vels,velsm,acc, & - lambda,lambdam,xnhe0,xnhem,vnhe,xnhp0,xnhpm,vnhp,nhpcl,nhpdim,ekincm,& - xnhh0,xnhhm,vnhh,velh, fion, tps, mat_z, occ_f, rho ) - USE kinds, ONLY: DP - implicit none - integer, INTENT(IN) :: nfi - REAL(DP), INTENT(IN) :: h(3,3), hold(3,3) - complex(DP), INTENT(IN) :: c0(:,:), cm(:,:) - REAL(DP), INTENT(IN) :: tausm(:,:), taus(:,:), fion(:,:) - REAL(DP), INTENT(IN) :: vels(:,:), velsm(:,:) - REAL(DP), INTENT(IN) :: acc(:), lambda(:,:,:), lambdam(:,:,:) - REAL(DP), INTENT(IN) :: xnhe0, xnhem, vnhe, ekincm - REAL(DP), INTENT(IN) :: xnhp0(:), xnhpm(:), vnhp(:) - integer, INTENT(in) :: nhpcl, nhpdim - REAL(DP), INTENT(IN) :: xnhh0(3,3),xnhhm(3,3),vnhh(3,3),velh(3,3) - REAL(DP), INTENT(in) :: tps - REAL(DP), INTENT(in) :: rho(:,:) - REAL(DP), INTENT(in) :: occ_f(:) - REAL(DP), INTENT(in) :: mat_z(:,:,:) - END SUBROUTINE writefile_cp_real - SUBROUTINE writefile_cp_twin & - & ( h,hold,nfi,c0,cm,taus,tausm,vels,velsm,acc, & - & lambda,lambdam,lambda_bare, xnhe0,xnhem,vnhe,xnhp0,xnhpm,vnhp,nhpcl,nhpdim,ekincm,& - & xnhh0,xnhhm,vnhh,velh, fion, tps, mat_z, occ_f, rho ) - USE kinds, ONLY: DP - USE twin_types - implicit none - integer, INTENT(IN) :: nfi - REAL(DP), INTENT(IN) :: h(3,3), hold(3,3) - complex(DP), INTENT(IN) :: c0(:,:), cm(:,:) - REAL(DP), INTENT(IN) :: tausm(:,:), taus(:,:), fion(:,:) - REAL(DP), INTENT(IN) :: vels(:,:), velsm(:,:) - REAL(DP), INTENT(IN) :: acc(:) - TYPE(twin_matrix), DIMENSION(:), INTENT(IN) :: lambda, lambdam, lambda_bare - REAL(DP), INTENT(IN) :: xnhe0, xnhem, vnhe, ekincm - REAL(DP), INTENT(IN) :: xnhp0(:), xnhpm(:), vnhp(:) - integer, INTENT(in) :: nhpcl, nhpdim - REAL(DP), INTENT(IN) :: xnhh0(3,3),xnhhm(3,3),vnhh(3,3),velh(3,3) - REAL(DP), INTENT(in) :: tps - REAL(DP), INTENT(in) :: rho(:,:) - REAL(DP), INTENT(in) :: occ_f(:) -! REAL(DP), INTENT(in) :: mat_z(:,:,:) - TYPE(twin_matrix), DIMENSION(:), INTENT(IN) :: mat_z - END SUBROUTINE writefile_cp_twin - SUBROUTINE writefile_fpmd & - ( nfi, trutime, c0, cm, occ, atoms_0, atoms_m, acc, taui, cdmi, ht_m, & - ht_0, rho, lambda, tlast ) - USE kinds, ONLY: DP - USE cell_base, ONLY: boxdimensions - USE atoms_type_module, ONLY: atoms_type - IMPLICIT NONE - INTEGER, INTENT(IN) :: nfi - COMPLEX(DP), INTENT(IN) :: c0(:,:), cm(:,:) - REAL(DP), INTENT(IN) :: occ(:) - TYPE (boxdimensions), INTENT(IN) :: ht_m, ht_0 - TYPE (atoms_type), INTENT(IN) :: atoms_0, atoms_m - REAL(DP), INTENT(IN) :: rho(:,:) - REAL(DP), INTENT(IN) :: taui(:,:) - REAL(DP), INTENT(IN) :: acc(:), cdmi(:) - REAL(DP), INTENT(IN) :: trutime - REAL(DP), INTENT(IN) :: lambda(:,:,:) - LOGICAL, INTENT(IN) :: tlast - END SUBROUTINE writefile_fpmd - END INTERFACE - - INTERFACE main_fpmd - SUBROUTINE cpmain_x( tau, fion, etot ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP) :: tau( :, : ) - REAL(DP) :: fion( :, : ) - REAL(DP) :: etot - END SUBROUTINE cpmain_x - END INTERFACE - - - INTERFACE runcp_uspp - SUBROUTINE runcp_uspp_x & - ( nfi, fccc, ccc, ema0bg, dt2bye, rhos, bec, c0, cm, fromscra, restart, tprint_ham ) - USE kinds, ONLY: DP - USE twin_types !added:giovanni - - IMPLICIT NONE - integer, intent(in) :: nfi - real(DP) :: fccc, ccc - real(DP) :: ema0bg(:), dt2bye - real(DP) :: rhos(:,:) - type(twin_matrix) :: bec!(:,:) !modified:giovanni - complex(DP) :: c0(:,:), cm(:,:) - logical, optional, intent(in) :: fromscra - logical, optional, intent(in) :: restart - logical, optional, intent(in) :: tprint_ham - END SUBROUTINE - END INTERFACE - - - INTERFACE runcp_uspp_force_pairing - SUBROUTINE runcp_uspp_force_pairing_x & - ( fccc, ccc, ema0bg, dt2bye, rhos, bec, c0, cm, intermed, fromscra, & - restart ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP) :: fccc, ccc - REAL(DP) :: ema0bg(:), dt2bye - REAL(DP) :: rhos(:,:) - REAL(DP) :: bec(:,:) - COMPLEX(DP) :: c0(:,:), cm(:,:) - REAL(DP) :: intermed - LOGICAL, OPTIONAL, INTENT(in) :: fromscra - LOGICAL, OPTIONAL, INTENT(in) :: restart - END SUBROUTINE - END INTERFACE - - - - INTERFACE newrho - SUBROUTINE newrho_x( rhor, drho, nfi ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(INOUT) :: rhor(:) - REAL(DP), INTENT(OUT) :: drho - INTEGER, INTENT(IN) :: nfi - END SUBROUTINE - END INTERFACE - - INTERFACE readempty_twin - LOGICAL FUNCTION reademptytwin_x( c_emp, ne, ndi ) - USE kinds, ONLY: DP - IMPLICIT NONE - COMPLEX(DP), INTENT(OUT) :: c_emp(:,:) - INTEGER, INTENT(IN) :: ne - INTEGER, INTENT(IN) :: ndi - END FUNCTION - END INTERFACE - - - INTERFACE writeempty_twin - SUBROUTINE writeemptytwin_x( c_emp, ne, ndi, l_fixed_state, spin_to_save) - USE kinds, ONLY: DP - IMPLICIT NONE - COMPLEX(DP), INTENT(IN) :: c_emp(:,:) - INTEGER, INTENT(IN) :: ne - INTEGER, INTENT(IN) :: ndi - LOGICAL, INTENT(IN) :: l_fixed_state - INTEGER, OPTIONAL, INTENT(IN) :: spin_to_save - END SUBROUTINE - END INTERFACE - - INTERFACE readempty - LOGICAL FUNCTION readempty_x( c_emp, ne, ndi ) - USE kinds, ONLY: DP - IMPLICIT NONE - COMPLEX(DP), INTENT(OUT) :: c_emp(:,:) - INTEGER, INTENT(IN) :: ne - INTEGER, INTENT(IN) :: ndi - END FUNCTION - END INTERFACE - - - INTERFACE writeempty - SUBROUTINE writeempty_x( c_emp, ne, ndi ) - USE kinds, ONLY: DP - IMPLICIT NONE - COMPLEX(DP), INTENT(IN) :: c_emp(:,:) - INTEGER, INTENT(IN) :: ne - INTEGER, INTENT(IN) :: ndi - END SUBROUTINE - END INTERFACE - - - INTERFACE gram_empty - SUBROUTINE gram_empty_real_x & - ( tortho, eigr, betae, bec_emp, bec_occ, nkbx, c_emp, c_occ, ngwx, n_emp, n_occ ) - USE kinds, ONLY: DP - USE ions_base, ONLY : nat - USE uspp, ONLY : nkb - IMPLICIT NONE - INTEGER, INTENT(IN) :: nkbx, ngwx, n_emp, n_occ - COMPLEX(DP) :: eigr(ngwx,nat) - REAL(DP) :: bec_emp( nkbx, n_emp ) - REAL(DP) :: bec_occ( nkbx, n_occ ) - COMPLEX(DP) :: betae( ngwx, nkb ) - COMPLEX(DP) :: c_emp( ngwx, n_emp ) - COMPLEX(DP) :: c_occ( ngwx, n_occ ) - LOGICAL, INTENT(IN) :: tortho - END SUBROUTINE - SUBROUTINE gram_empty_twin_x & - ( tortho, eigr, betae, bec_emp, bec_occ, nkbx, c_emp, c_occ, ngwx, n_emp, n_occ, l_emp, l_occ ) - USE kinds, ONLY: DP - USE ions_base, ONLY : nat - USE uspp, ONLY : nkb - USE twin_types - IMPLICIT NONE - INTEGER, INTENT(IN) :: nkbx, ngwx, n_emp, n_occ, l_emp, l_occ - COMPLEX(DP) :: eigr(ngwx,nat) - type(twin_matrix) :: bec_emp !( nkbx, n_emp ) - type(twin_matrix) :: bec_occ !( nkbx, n_occ ) - COMPLEX(DP) :: betae( ngwx, nkb ) - COMPLEX(DP) :: c_emp( ngwx, n_emp ) - COMPLEX(DP) :: c_occ( ngwx, n_occ ) - LOGICAL, INTENT(IN) :: tortho - END SUBROUTINE - END INTERFACE - - - INTERFACE empty_cp - SUBROUTINE empty_cp_twin_x ( nfi, c0, v, tcg) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: nfi - COMPLEX(DP) :: c0(:,:) - REAL(DP) :: v(:,:) - LOGICAL, OPTIONAL, INTENT(IN) :: tcg - END SUBROUTINE - END INTERFACE - - - INTERFACE invfft - SUBROUTINE invfft_x( grid_type, f, dfft, ia ) - USE fft_types, only: fft_dlay_descriptor - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, OPTIONAL, INTENT(IN) :: ia - CHARACTER(LEN=*), INTENT(IN) :: grid_type - TYPE(fft_dlay_descriptor), INTENT(IN) :: dfft - COMPLEX(DP) :: f(:) - END SUBROUTINE - END INTERFACE - - INTERFACE fwfft - SUBROUTINE fwfft_x( grid_type, f, dfft ) - USE fft_types, only: fft_dlay_descriptor - USE kinds, ONLY: DP - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: grid_type - TYPE(fft_dlay_descriptor), INTENT(IN) :: dfft - COMPLEX(DP) :: f(:) - END SUBROUTINE - END INTERFACE - - INTERFACE eigs - SUBROUTINE cp_eigs_real_x( nfi, lambdap, lambda ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER :: nfi - REAL(DP) :: lambda( :, :, : ), lambdap( :, :, : ) - END SUBROUTINE - SUBROUTINE cp_eigs_twin_x( nfi, lambdap, lambda ) - USE kinds, ONLY: DP - use electrons_base, only: nspin - USE twin_types - IMPLICIT NONE - INTEGER :: nfi - type(twin_matrix), dimension(nspin) :: lambda, lambdap - END SUBROUTINE - END INTERFACE - - INTERFACE eigs_non_ortho - SUBROUTINE cp_eigs_twin_non_ortho_x( nfi, lambdap, lambda ) - USE kinds, ONLY: DP - use electrons_base, only: nspin - USE twin_types - IMPLICIT NONE - INTEGER :: nfi - type(twin_matrix), dimension(nspin) :: lambda, lambdap - END SUBROUTINE - END INTERFACE - - INTERFACE fermi_energy - SUBROUTINE fermi_energy_x(eig, occ, wke, ef, qtot, temp, sume) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP) :: occ(:) - REAL(DP) ef, qtot, temp, sume - REAL(DP) eig(:,:), wke(:,:) - END SUBROUTINE - END INTERFACE - - INTERFACE packgam - SUBROUTINE rpackgam_x( gam, f, aux ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(INOUT) :: gam(:,:) - REAL(DP), INTENT(OUT), OPTIONAL :: aux(:) - REAL(DP), INTENT(IN) :: f(:) - END SUBROUTINE - END INTERFACE - - - INTERFACE ortho - SUBROUTINE ortho_m & - ( c0, cp, lambda, descla, ccc, nupdwn, iupdwn, nspin ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: descla(:,:) - INTEGER, INTENT(IN) :: nupdwn(:), iupdwn(:), nspin - COMPLEX(DP), INTENT(INOUT) :: c0(:,:), cp(:,:) - REAL(DP), INTENT(INOUT) :: lambda(:,:,:) - REAL(DP), INTENT(IN) :: ccc - END SUBROUTINE - SUBROUTINE ortho_m_twin & - ( c0, cp, lambda, descla, ccc, nupdwn, iupdwn, nspin ) - USE kinds, ONLY: DP - USE twin_types - IMPLICIT NONE - INTEGER, INTENT(IN) :: descla(:,:) - INTEGER, INTENT(IN) :: nupdwn(:), iupdwn(:), nspin - COMPLEX(DP), INTENT(INOUT) :: c0(:,:), cp(:,:) - TYPE(twin_matrix), DIMENSION(:), INTENT(INOUT) :: lambda - REAL(DP), INTENT(IN) :: ccc - END SUBROUTINE - SUBROUTINE ortho_cp_real & - ( eigr, cp, phi, ngwx, x0, descla, diff, iter, ccc, bephi, becp, nbsp, nspin, nupdwn, iupdwn) - USE kinds, ONLY: DP - USE ions_base, ONLY: nat - USE uspp, ONLY: nkb - USE descriptors, ONLY: descla_siz_ - IMPLICIT NONE - INTEGER, INTENT(IN) :: ngwx, nbsp, nspin - INTEGER, INTENT(IN) :: nupdwn( nspin ), iupdwn( nspin ) - INTEGER, INTENT(IN) :: descla( descla_siz_ , nspin ) - COMPLEX(DP) :: cp(ngwx,nbsp), phi(ngwx,nbsp), eigr(ngwx,nat) - REAL(DP) :: x0( :, :, : ), diff, ccc - INTEGER :: iter - REAL(DP) :: bephi(:,:), becp(:,:) - END SUBROUTINE - SUBROUTINE ortho_cp_twin & - ( eigr, cp, phi, ngwx, x0, descla, diff, iter, ccc, bephi, becp, nbsp, nspin, nupdwn, iupdwn) - USE kinds, ONLY: DP - USE ions_base, ONLY: nat - USE uspp, ONLY: nkb - USE descriptors, ONLY: descla_siz_ - USE twin_types - IMPLICIT NONE - INTEGER, INTENT(IN) :: ngwx, nbsp, nspin - INTEGER, INTENT(IN) :: nupdwn( nspin ), iupdwn( nspin ) - INTEGER, INTENT(IN) :: descla( descla_siz_ , nspin ) ! this is not varied - COMPLEX(DP) :: cp(ngwx,nbsp), phi(ngwx,nbsp), eigr(ngwx,nat) !these are not - type(twin_matrix), dimension(:) :: x0 !this becomes a twin - REAL(DP) :: diff, ccc - INTEGER :: iter - type(twin_matrix) :: bephi, becp -! REAL(DP) :: bephi(:,:), becp(:,:) - END SUBROUTINE - END INTERFACE - INTERFACE ortho_gamma - SUBROUTINE ortho_gamma_real_x & - ( iopt, cp, ngwx, phi, becp, qbecp, nkbx, bephi, qbephi, & - x0, nx0, descla, diff, iter, n, nss, istart ) - USE kinds, ONLY: DP - USE descriptors, ONLY: descla_siz_ - IMPLICIT NONE - INTEGER, INTENT(IN) :: iopt - INTEGER, INTENT(IN) :: ngwx, nkbx, nx0 - INTEGER, INTENT(IN) :: n, nss, istart - COMPLEX(DP) :: phi( ngwx, n ), cp( ngwx, n ) - REAL(DP) :: bephi( :, : ), becp( :, : ) - REAL(DP) :: qbephi( :, : ), qbecp( :, : ) - REAL(DP) :: x0( nx0, nx0 ) - INTEGER, INTENT(IN) :: descla( descla_siz_ ) - INTEGER, INTENT(OUT) :: iter - REAL(DP), INTENT(OUT) :: diff - END SUBROUTINE - SUBROUTINE ortho_gamma_cmplx_x & - ( iopt, cp, ngwx, phi, becp, qbecp, nkbx, bephi, qbephi, & - x0, nx0, descla, diff, iter, n, nss, istart ) - USE kinds, ONLY: DP - USE descriptors, ONLY: descla_siz_ - IMPLICIT NONE - INTEGER, INTENT(IN) :: iopt - INTEGER, INTENT(IN) :: ngwx, nkbx, nx0 - INTEGER, INTENT(IN) :: n, nss, istart - COMPLEX(DP) :: phi( ngwx, n ), cp( ngwx, n ) - COMPLEX(DP) :: bephi( :, : ), becp( :, : ) - COMPLEX(DP) :: qbephi( :, : ), qbecp( :, : ) - COMPLEX(DP) :: x0( nx0, nx0 ) - INTEGER, INTENT(IN) :: descla( descla_siz_ ) - INTEGER, INTENT(OUT) :: iter - REAL(DP), INTENT(OUT) :: diff - END SUBROUTINE - END INTERFACE - - INTERFACE v2gc - SUBROUTINE v2gc_x( v2xc, grho, rhor, vpot ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP) :: vpot(:,:) - REAL(DP), intent(in) :: v2xc(:,:,:) - REAL(DP), intent(in) :: grho(:,:,:) - REAL(DP), intent(in) :: rhor(:,:) - END SUBROUTINE - END INTERFACE - INTERFACE exch_corr_energy - SUBROUTINE exch_corr_energy_x(rhoetr, grho, vpot, exc, vxc, v2xc) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL (DP) :: rhoetr(:,:) - REAL (DP) :: grho(:,:,:) - REAL (DP) :: vpot(:,:) - REAL (DP) :: exc - REAL (DP) :: vxc - REAL (DP) :: v2xc(:,:,:) - END SUBROUTINE - END INTERFACE - INTERFACE stress_xc - SUBROUTINE stress_xc_x & - ( dexc, strvxc, sfac, vxc, grho, v2xc, gagb, tnlcc, rhocp, box) - USE kinds, ONLY: DP - USE cell_base, ONLY: boxdimensions - IMPLICIT NONE - type (boxdimensions), intent(in) :: box - LOGICAL :: tnlcc(:) - COMPLEX(DP) :: vxc(:,:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - REAL(DP) :: dexc(:), strvxc - REAL(DP) :: grho(:,:,:) - REAL(DP) :: v2xc(:,:,:) - REAL(DP) :: gagb(:,:) - REAL(DP) :: rhocp(:,:) - END SUBROUTINE - END INTERFACE - INTERFACE stress_gc - SUBROUTINE stress_gc_x(grho, v2xc, gcpail, omega) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP) :: v2xc(:,:,:) - REAL(DP) :: grho(:,:,:) - REAL(DP) :: gcpail(6) - REAL(DP) :: omega - END SUBROUTINE - END INTERFACE - - - INTERFACE pstress - SUBROUTINE pstress_x( paiu, desr, dekin, denl, deps, deht, dexc, ht ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP) :: paiu(3,3) - REAL(DP) :: ht(3,3) - REAL(DP) :: denl(3,3) - REAL(DP) :: desr(6), dekin(6), deps(6), deht(6), dexc(6) - END SUBROUTINE - END INTERFACE - - INTERFACE pseudo_stress - SUBROUTINE pseudo_stress_x( deps, gagb, sfac, rhoeg, omega ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(IN) :: omega - REAL(DP), INTENT(OUT) :: deps(:) - REAL(DP), INTENT(IN) :: gagb(:,:) - COMPLEX(DP), INTENT(IN) :: rhoeg(:,:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - END SUBROUTINE - END INTERFACE - - INTERFACE compute_gagb - SUBROUTINE compute_gagb_x( gagb, gx, ngm, tpiba2 ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: ngm - REAL(DP), INTENT(IN) :: gx(:,:) - REAL(DP), INTENT(OUT) :: gagb(:,:) - REAL(DP), INTENT(IN) :: tpiba2 - END SUBROUTINE - END INTERFACE - - INTERFACE stress_har - SUBROUTINE stress_har_x(deht, ehr, sfac, rhoeg, gagb, omega ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(OUT) :: DEHT(:) - REAL(DP), INTENT(IN) :: omega, EHR, gagb(:,:) - COMPLEX(DP), INTENT(IN) :: RHOEG(:,:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - END SUBROUTINE - END INTERFACE - - INTERFACE stress_hartree - SUBROUTINE stress_hartree_x(deht, ehr, rhot, drhot, gagb, omega ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(OUT) :: DEHT(:) - REAL(DP), INTENT(IN) :: omega, EHR, gagb(:,:) - COMPLEX(DP) :: rhot(:) ! total charge: Sum_spin ( rho_e + rho_I ) - COMPLEX(DP) :: drhot(:,:) - END SUBROUTINE - END INTERFACE - - INTERFACE add_drhoph - SUBROUTINE add_drhoph_x( drhot, sfac, gagb ) - USE kinds, ONLY: DP - IMPLICIT NONE - COMPLEX(DP), INTENT(INOUT) :: drhot( :, : ) - COMPLEX(DP), INTENT(IN) :: sfac( :, : ) - REAL(DP), INTENT(IN) :: gagb( :, : ) - END SUBROUTINE - END INTERFACE - - INTERFACE stress_local - SUBROUTINE stress_local_x( deps, gagb, sfac, rhoe, drhoe, omega ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(IN) :: omega - REAL(DP), INTENT(OUT) :: deps(:) - REAL(DP), INTENT(IN) :: gagb(:,:) - COMPLEX(DP), INTENT(IN) :: rhoe(:) - COMPLEX(DP), INTENT(IN) :: drhoe(:,:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - END SUBROUTINE - END INTERFACE - - INTERFACE stress_kin - SUBROUTINE stress_kin_x(dekin, c0, occ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(OUT) :: dekin(:) - COMPLEX(DP), INTENT(IN) :: c0(:,:) - REAL(DP), INTENT(IN) :: occ(:) - END SUBROUTINE - END INTERFACE - - - INTERFACE interpolate_lambda - SUBROUTINE interpolate_lambda_x( lambdap, lambda, lambdam ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP) :: lambdap(:,:,:), lambda(:,:,:), lambdam(:,:,:) - END SUBROUTINE - SUBROUTINE interpolate_lambda_twin_x( lambdap, lambda, lambdam ) - USE kinds, ONLY: DP - USE twin_types - IMPLICIT NONE - TYPE(twin_matrix), dimension(:) :: lambdap, lambda, lambdam - END SUBROUTINE - END INTERFACE - - INTERFACE update_lambda - SUBROUTINE update_lambda_x( i, lambda, c0, c2, n, noff, tdist ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: n, noff - REAL(DP) :: lambda(:,:) - COMPLEX(DP) :: c0(:,:), c2(:) - INTEGER, INTENT(IN) :: i - LOGICAL, INTENT(IN) :: tdist ! if .true. lambda is distributed - END SUBROUTINE - END INTERFACE - - INTERFACE elec_fakekine - SUBROUTINE elec_fakekine_x( ekincm, ema0bg, emass, c0, cm, ngw, n, noff, delt ) - USE kinds, ONLY: DP - IMPLICIT NONE - integer, intent(in) :: ngw ! number of plane wave coeff. - integer, intent(in) :: n ! number of bands - integer, intent(in) :: noff ! offset for band index - real(DP), intent(out) :: ekincm - real(DP), intent(in) :: ema0bg( ngw ), delt, emass - complex(DP), intent(in) :: c0( ngw, n ), cm( ngw, n ) - END SUBROUTINE - END INTERFACE - - INTERFACE wave_rand_init - SUBROUTINE wave_rand_init_x( cm, n, noff ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: n, noff - COMPLEX(DP), INTENT(OUT) :: cm(:,:) - END SUBROUTINE - END INTERFACE - - INTERFACE wave_atom_init - SUBROUTINE wave_atom_init_x( cm, n, noff ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: n, noff - COMPLEX(DP), INTENT(OUT) :: cm(:,:) - END SUBROUTINE - END INTERFACE - - INTERFACE crot - SUBROUTINE crot_gamma2_real ( c0rot, c0, ngw, n, noffr, noff, lambda, nx, eig ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: ngw, n, nx, noffr, noff - COMPLEX(DP), INTENT(INOUT) :: c0rot(:,:) - COMPLEX(DP), INTENT(IN) :: c0(:,:) - REAL(DP), INTENT(IN) :: lambda(:,:) - REAL(DP), INTENT(OUT) :: eig(:) - END SUBROUTINE - SUBROUTINE crot_gamma2_cmplx ( c0rot, c0, ngw, n, noffr, noff, lambda, nx, eig ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: ngw, n, nx, noffr, noff - COMPLEX(DP), INTENT(INOUT) :: c0rot(:,:) - COMPLEX(DP), INTENT(IN) :: c0(:,:) - COMPLEX(DP), INTENT(IN) :: lambda(:,:) - REAL(DP), INTENT(OUT) :: eig(:) - END SUBROUTINE - END INTERFACE - - INTERFACE proj - SUBROUTINE proj_gamma( a, b, ngw, n, noff, lambda) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT( IN ) :: ngw, n, noff - COMPLEX(DP), INTENT(INOUT) :: a(:,:), b(:,:) - REAL(DP), OPTIONAL :: lambda(:,:) - END SUBROUTINE - END INTERFACE - - INTERFACE phfacs - SUBROUTINE phfacs_x( ei1, ei2, ei3, eigr, mill, taus, nr1, nr2, nr3, nat ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: nat - INTEGER, INTENT(IN) :: nr1, nr2, nr3 - COMPLEX(DP) :: ei1( -nr1 : nr1, nat ) - COMPLEX(DP) :: ei2( -nr2 : nr2, nat ) - COMPLEX(DP) :: ei3( -nr3 : nr3, nat ) - COMPLEX(DP) :: eigr( :, : ) - REAL(DP) :: taus( 3, nat ) - INTEGER :: mill( :, : ) - END SUBROUTINE - END INTERFACE - - INTERFACE strucf - SUBROUTINE strucf_x( sfac, ei1, ei2, ei3, mill, ngm ) - USE kinds, ONLY: DP - USE ions_base, ONLY: nat - USE grid_dimensions, ONLY: nr1, nr2, nr3 - IMPLICIT NONE - COMPLEX(DP) :: ei1( -nr1 : nr1, nat ) - COMPLEX(DP) :: ei2( -nr2 : nr2, nat ) - COMPLEX(DP) :: ei3( -nr3 : nr3, nat ) - INTEGER :: mill( :, : ) - INTEGER :: ngm - COMPLEX(DP), INTENT(OUT) :: sfac(:,:) - END SUBROUTINE - END INTERFACE - - - INTERFACE add_core_charge - SUBROUTINE add_core_charge_x( rhoetg, rhoetr, sfac, rhoc, nsp) - USE kinds, ONLY: DP - IMPLICIT NONE - integer :: nsp - COMPLEX(DP) :: rhoetg(:) - REAL(DP) :: rhoetr(:) - REAL(DP) :: rhoc(:,:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - END SUBROUTINE - END INTERFACE - - INTERFACE core_charge_forces - SUBROUTINE core_charge_forces_x & - ( fion, vxc, rhoc1, tnlcc, atoms, ht, ei1, ei2, ei3 ) - USE kinds, ONLY: DP - USE cell_base, ONLY: boxdimensions - USE atoms_type_module, ONLY: atoms_type - USE grid_dimensions, ONLY: nr1, nr2, nr3 - USE ions_base, ONLY: nat - IMPLICIT NONE - TYPE (atoms_type), INTENT(IN) :: atoms ! atomic positions - TYPE (boxdimensions), INTENT(IN) :: ht ! cell parameters - COMPLEX(DP) :: ei1( -nr1:nr1, nat) ! - COMPLEX(DP) :: ei2( -nr2:nr2, nat) ! - COMPLEX(DP) :: ei3( -nr3:nr3, nat) ! - LOGICAL :: tnlcc(:) ! NLCC flags - REAL(DP) :: fion(:,:) ! ionic forces - REAL(DP) :: rhoc1(:,:) ! derivative of the core charge - COMPLEX(DP) :: vxc(:,:) ! XC potential - END SUBROUTINE - END INTERFACE - - - INTERFACE printout_new - SUBROUTINE printout_new_real_x & - ( nfi, tfirst, tfilei, tstdouti, tprint, tps, h, stress, tau0, vels, & - fion, ekinc, temphc, tempp, temps, etot, enthal, econs, econt, & - vnhh, xnhh0, vnhp, xnhp0, atot, ekin, epot, print_forces, print_stress, & - hamilt, print_hamilt_norm ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: nfi - LOGICAL, INTENT(IN) :: tfirst, tfilei, tstdouti, tprint - REAL(DP), INTENT(IN) :: tps - REAL(DP), INTENT(IN) :: h( 3, 3 ) - REAL(DP), INTENT(IN) :: stress( 3, 3 ) - REAL(DP), INTENT(IN) :: tau0( :, : ) ! real positions - REAL(DP), INTENT(IN) :: vels( :, : ) ! scaled velocities - REAL(DP), INTENT(IN) :: fion( :, : ) ! real forces - REAL(DP), INTENT(IN) :: ekinc, temphc, tempp, etot, enthal, econs, econt - REAL(DP), INTENT(IN) :: temps( : ) ! partial temperature for different ionic species - REAL(DP), INTENT(IN) :: vnhh( 3, 3 ), xnhh0( 3, 3 ), vnhp( 1 ), xnhp0( 1 ) - REAL(DP), INTENT(IN) :: atot! enthalpy of system for c.g. case - REAL(DP), INTENT(IN) :: ekin - REAL(DP), INTENT(IN) :: epot ! ( epseu + eht + exc ) - LOGICAL, INTENT(IN) :: print_forces, print_stress - REAL(DP), OPTIONAL, INTENT(IN) :: hamilt(:, :, :) - LOGICAL, OPTIONAL, INTENT(IN) :: print_hamilt_norm - END SUBROUTINE - SUBROUTINE printout_new_twin_x & - ( nfi, tfirst, tfilei, tstdouti, tprint, tps, h, stress, tau0, vels, & - fion, ekinc, temphc, tempp, temps, etot, enthal, econs, econt, & - vnhh, xnhh0, vnhp, xnhp0, atot, ekin, epot, print_forces, print_stress, & - hamilt, print_hamilt_norm, lgam ) - USE kinds, ONLY: DP - USE twin_types - IMPLICIT NONE - INTEGER, INTENT(IN) :: nfi - LOGICAL, INTENT(IN) :: tfirst, tfilei, tstdouti, tprint - REAL(DP), INTENT(IN) :: tps - REAL(DP), INTENT(IN) :: h( 3, 3 ) - REAL(DP), INTENT(IN) :: stress( 3, 3 ) - REAL(DP), INTENT(IN) :: tau0( :, : ) ! real positions - REAL(DP), INTENT(IN) :: vels( :, : ) ! scaled velocities - REAL(DP), INTENT(IN) :: fion( :, : ) ! real forces - REAL(DP), INTENT(IN) :: ekinc, temphc, tempp, etot, enthal, econs, econt - REAL(DP), INTENT(IN) :: temps( : ) ! partial temperature for different ionic species - REAL(DP), INTENT(IN) :: vnhh( 3, 3 ), xnhh0( 3, 3 ), vnhp( 1 ), xnhp0( 1 ) - REAL(DP), INTENT(IN) :: atot! enthalpy of system for c.g. case - REAL(DP), INTENT(IN) :: ekin - REAL(DP), INTENT(IN) :: epot ! ( epseu + eht + exc ) - LOGICAL, INTENT(IN) :: print_forces, print_stress - type(twin_matrix), dimension(:), OPTIONAL, INTENT(IN) :: hamilt - LOGICAL, OPTIONAL, INTENT(IN) :: print_hamilt_norm - LOGICAL, intent(IN) :: lgam - END SUBROUTINE - END INTERFACE - - INTERFACE printout - SUBROUTINE printout_x(nfi, atoms, ekinc, ekcell, tprint, ht, edft) - USE kinds, ONLY: DP - USE atoms_type_module, ONLY: atoms_type - USE cell_base, ONLY: boxdimensions - USE energies, ONLY: dft_energy_type - IMPLICIT NONE - INTEGER, INTENT(IN) :: nfi - TYPE (atoms_type) :: atoms - LOGICAL :: tprint - type (boxdimensions), intent(in) :: ht - TYPE (dft_energy_type) :: edft - REAL(DP) :: ekinc, ekcell - END SUBROUTINE - END INTERFACE - - INTERFACE print_sfac - SUBROUTINE print_sfac_x( rhoe, sfac ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(IN) :: rhoe(:,:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - END SUBROUTINE - END INTERFACE - - INTERFACE open_and_append - SUBROUTINE open_and_append_x( iunit, file_name ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: iunit - CHARACTER(LEN = *), INTENT(IN) :: file_name - END SUBROUTINE - END INTERFACE - - INTERFACE cp_print_rho - SUBROUTINE cp_print_rho_x & - (nfi, bec, c0, eigr, irb, eigrb, rhor, rhog, rhos, lambdap, lambda, tau0, h ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER :: nfi - INTEGER :: irb(:,:) - COMPLEX(DP) :: c0( :, : ) - REAL(DP) :: bec( :, : ), rhor( :, : ), rhos( :, : ) - REAL(DP) :: lambda( :, :, : ), lambdap( :, :, : ) - REAL(DP) :: tau0( :, : ), h( 3, 3 ) - COMPLEX(DP) :: eigrb( :, : ), rhog( :, : ) - COMPLEX(DP) :: eigr( :, : ) - END SUBROUTINE - END INTERFACE - - - INTERFACE vofmean - SUBROUTINE vofmean_x( sfac, rhops, rhoeg ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(IN) :: RHOPS(:,:) - COMPLEX(DP), INTENT(IN) :: RHOEG(:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - END SUBROUTINE - END INTERFACE - - - INTERFACE vofrhos - SUBROUTINE vofrhos_x & - ( tprint, tforce, tstress, rhoe, rhoeg, atoms, vpot, bec, c0, fi, & - eigr, ei1, ei2, ei3, sfac, box, edft ) - USE kinds, ONLY: DP - USE energies, ONLY: dft_energy_type - USE cell_base, ONLY: boxdimensions - USE atoms_type_module, ONLY: atoms_type - USE wave_types, ONLY: wave_descriptor - IMPLICIT NONE - LOGICAL, INTENT(IN) :: tprint, tforce, tstress - REAL(DP) :: rhoe(:,:) - COMPLEX(DP) :: rhoeg(:,:) - TYPE (atoms_type), INTENT(INOUT) :: atoms - REAL(DP) :: vpot(:,:) - REAL(DP) :: bec(:,:) - COMPLEX(DP), INTENT(IN) :: c0(:,:) - REAL(DP), INTENT(IN) :: fi(:) - COMPLEX(DP) :: eigr(:,:) - COMPLEX(DP) :: ei1(:,:) - COMPLEX(DP) :: ei2(:,:) - COMPLEX(DP) :: ei3(:,:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - TYPE (boxdimensions), INTENT(INOUT) :: box - TYPE (dft_energy_type) :: edft - END SUBROUTINE - END INTERFACE - - - INTERFACE vofps - SUBROUTINE vofps_x_new( eps, vloc, rhoeg, vps, sfac, omega, lgam ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(IN) :: vps(:,:) - REAL(DP), INTENT(IN) :: omega - COMPLEX(DP), INTENT(OUT) :: vloc(:) - COMPLEX(DP), INTENT(IN) :: rhoeg(:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - COMPLEX(DP), INTENT(OUT) :: eps - LOGICAL, INTENT(IN) :: lgam - END SUBROUTINE - SUBROUTINE vofps_x( eps, vloc, rhoeg, vps, sfac, omega) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(IN) :: vps(:,:) - REAL(DP), INTENT(IN) :: omega - COMPLEX(DP), INTENT(OUT) :: vloc(:) - COMPLEX(DP), INTENT(IN) :: rhoeg(:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - COMPLEX(DP), INTENT(OUT) :: eps - END SUBROUTINE - END INTERFACE - - - INTERFACE vofloc - SUBROUTINE vofloc_x( tscreen, ehte, ehti, eh, vloc, rhoeg, & - rhops, vps, sfac, omega, screen_coul ) - USE kinds, ONLY: DP - IMPLICIT NONE - LOGICAL, INTENT(IN) :: tscreen - REAL(DP), INTENT(IN) :: rhops(:,:), vps(:,:) - COMPLEX(DP), INTENT(INOUT) :: vloc(:) - COMPLEX(DP), INTENT(IN) :: rhoeg(:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - REAL(DP), INTENT(OUT) :: ehte, ehti - REAL(DP), INTENT(IN) :: omega - COMPLEX(DP), INTENT(OUT) :: eh - COMPLEX(DP), INTENT(IN) :: screen_coul(:) - END SUBROUTINE - END INTERFACE - - INTERFACE force_loc - SUBROUTINE force_loc_x( tscreen, rhoeg, fion, rhops, vps, ei1, ei2, ei3, & - sfac, omega, screen_coul, lgam ) - USE kinds, ONLY: DP - USE grid_dimensions, ONLY: nr1, nr2, nr3 - USE ions_base, ONLY: nat - IMPLICIT NONE - LOGICAL :: tscreen - REAL(DP) :: fion(:,:) - REAL(DP) :: rhops(:,:), vps(:,:) - COMPLEX(DP) :: rhoeg(:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - COMPLEX(DP) :: ei1(-nr1:nr1,nat) - COMPLEX(DP) :: ei2(-nr2:nr2,nat) - COMPLEX(DP) :: ei3(-nr3:nr3,nat) - REAL(DP) :: omega - COMPLEX(DP) :: screen_coul(:) - LOGICAL :: lgam - END SUBROUTINE - END INTERFACE - - INTERFACE self_vofhar - SUBROUTINE self_vofhar_x( tscreen, self_ehte, vloc, rhoeg, omega, hmat ) - USE kinds, ONLY: DP - IMPLICIT NONE - LOGICAL :: tscreen - COMPLEX(DP) :: vloc(:) - COMPLEX(DP) :: rhoeg(:,:) - REAL(DP) :: self_ehte - REAL(DP), INTENT(IN) :: omega - REAL(DP), INTENT(IN) :: hmat( 3, 3 ) - END SUBROUTINE - END INTERFACE - - INTERFACE localisation - SUBROUTINE localisation_x( wfc, atoms_m, ht) - USE kinds, ONLY: DP - USE cell_base, ONLY: boxdimensions - USE atoms_type_module, ONLY: atoms_type - IMPLICIT NONE - COMPLEX(DP), INTENT(IN) :: wfc(:) - TYPE (atoms_type), INTENT(in) :: atoms_m - TYPE (boxdimensions), INTENT(in) :: ht - END SUBROUTINE - END INTERFACE - - - INTERFACE n_atom_wfc - FUNCTION n_atom_wfc_x() - INTEGER n_atom_wfc_x - END FUNCTION - END INTERFACE - - INTERFACE set_eitot - SUBROUTINE set_eitot_x( eitot ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP), INTENT(OUT) :: eitot(:,:) - END SUBROUTINE - END INTERFACE - - INTERFACE set_evtot - SUBROUTINE set_evtot_real_x( c0, ctot, lambda, iupdwn_tot, nupdwn_tot ) - USE kinds, ONLY: DP - IMPLICIT NONE - COMPLEX(DP), INTENT(IN) :: c0(:,:) - COMPLEX(DP), INTENT(OUT) :: ctot(:,:) - REAL(DP), INTENT(IN) :: lambda(:,:,:) - INTEGER, INTENT(IN) :: iupdwn_tot(2), nupdwn_tot(2) - END SUBROUTINE - SUBROUTINE set_evtot_twin_x( c0, ctot, lambda, iupdwn_tot, nupdwn_tot ) - USE kinds, ONLY: DP - USE twin_types - IMPLICIT NONE - COMPLEX(DP), INTENT(IN) :: c0(:,:) - COMPLEX(DP), INTENT(OUT) :: ctot(:,:) - TYPE(twin_matrix), dimension(:), INTENT(IN) :: lambda - INTEGER, INTENT(IN) :: iupdwn_tot(2), nupdwn_tot(2) - END SUBROUTINE - END INTERFACE - - INTERFACE print_projwfc - SUBROUTINE print_projwfc_x ( c0, lambda, eigr, vkb ) - USE kinds, ONLY: DP - IMPLICIT NONE - COMPLEX(DP), INTENT(IN) :: c0(:,:), eigr(:,:), vkb(:,:) - REAL(DP), INTENT(IN) :: lambda(:,:,:) - END SUBROUTINE - SUBROUTINE print_projwfc_twin_x ( c0, lambda, eigr, vkb ) - USE kinds, ONLY: DP - USE twin_types - IMPLICIT NONE - COMPLEX(DP), INTENT(IN) :: c0(:,:), eigr(:,:), vkb(:,:) - TYPE(twin_matrix), DIMENSION(:), INTENT(IN) :: lambda(:) - END SUBROUTINE - END INTERFACE - - INTERFACE move_electrons - SUBROUTINE move_electrons_x( & - nfi, tfirst, tlast, b1, b2, b3, fion, enthal, enb, enbi, fccc, ccc, dt2bye, & - stress, tprint_ham ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: nfi - LOGICAL, INTENT(IN) :: tfirst, tlast - REAL(DP), INTENT(IN) :: b1(3), b2(3), b3(3) - REAL(DP) :: fion(:,:) - REAL(DP), INTENT(IN) :: dt2bye - REAL(DP) :: fccc, ccc - REAL(DP) :: enb, enbi - REAL(DP) :: enthal - REAL(DP) :: ei_unp - REAL(DP) :: stress(3,3) - LOGICAL, OPTIONAL, INTENT(IN) :: tprint_ham - END SUBROUTINE - END INTERFACE - - INTERFACE compute_stress - SUBROUTINE compute_stress_x( stress, detot, h, omega ) - USE kinds, ONLY : DP - IMPLICIT NONE - REAL(DP), INTENT(OUT) :: stress(3,3) - REAL(DP), INTENT(IN) :: detot(3,3), h(3,3), omega - END SUBROUTINE - END INTERFACE - - INTERFACE nlfh - SUBROUTINE nlfh_real_x( stress, bec, dbec, lambda ) - USE kinds, ONLY : DP - IMPLICIT NONE - REAL(DP), INTENT(INOUT) :: stress(3,3) - REAL(DP), INTENT(IN) :: bec( :, : ), dbec( :, :, :, : ) - REAL(DP), INTENT(IN) :: lambda( :, :, : ) - END SUBROUTINE - SUBROUTINE nlfh_twin_x( stress, bec, dbec, lambda ) - USE kinds, ONLY : DP - USE twin_types - IMPLICIT NONE - REAL(DP), INTENT(INOUT) :: stress(3,3) - type(twin_matrix) :: bec - REAL(DP), INTENT(IN) :: dbec( :, :, :, : ) - type(twin_matrix), INTENT(IN) :: lambda(:) ! ( :, :, : ) - END SUBROUTINE - END INTERFACE - - INTERFACE print_lambda - SUBROUTINE print_lambda_x_real( lambda, n, nshow, ccc, iunit ) - USE kinds, ONLY : DP - IMPLICIT NONE - REAL(DP), INTENT(IN) :: lambda(:,:,:), ccc - INTEGER, INTENT(IN) :: n, nshow - INTEGER, INTENT(IN), OPTIONAL :: iunit - END SUBROUTINE - SUBROUTINE print_lambda_x_twin( lambda, n, nshow, ccc, iunit ) - USE kinds, ONLY : DP - USE twin_types - IMPLICIT NONE - real(DP), intent(in) :: ccc - type(twin_matrix), intent(in) :: lambda(:) - integer, intent(in) :: n, nshow - integer, intent(in), optional :: iunit - END SUBROUTINE - END INTERFACE - - INTERFACE protate - SUBROUTINE protate_real_x ( c0, bec, c0rot, becrot, ngwl, nss, noff, lambda, & - na, nsp, ish, nh, np_rot, me_rot ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: ngwl, nss, noff - INTEGER, INTENT(IN) :: na(:), nsp, ish(:), nh(:) - INTEGER, INTENT(IN) :: np_rot, me_rot - COMPLEX(DP), INTENT(IN) :: c0(:,:) - COMPLEX(DP), INTENT(OUT) :: c0rot(:,:) - REAL(DP), INTENT(IN) :: lambda(:,:) - REAL(DP), INTENT(IN) :: bec(:,:) - REAL(DP), INTENT(OUT) :: becrot(:,:) - END SUBROUTINE - SUBROUTINE protate_cmplx_x ( c0, bec, c0rot, becrot, ngwl, nss, noff, lambda, & - na, nsp, ish, nh, np_rot, me_rot ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: ngwl, nss, noff - INTEGER, INTENT(IN) :: na(:), nsp, ish(:), nh(:) - INTEGER, INTENT(IN) :: np_rot, me_rot - COMPLEX(DP), INTENT(IN) :: c0(:,:) - COMPLEX(DP), INTENT(OUT) :: c0rot(:,:) - COMPLEX(DP), INTENT(IN) :: lambda(:,:) - COMPLEX(DP), INTENT(IN) :: bec(:,:) - COMPLEX(DP), INTENT(OUT) :: becrot(:,:) - END SUBROUTINE - - END INTERFACE - -!---------- INTERFACES FOR COMPLEX IMPLEMENTATION - INTERFACE wave_sine_init ! added:giovanni - SUBROUTINE wave_sine_init_x( cm, n, noff ) - USE kinds, ONLY: DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: n, noff - COMPLEX(DP), INTENT(OUT) :: cm(:,:) - END SUBROUTINE - END INTERFACE - - INTERFACE nlsm1 - SUBROUTINE nlsm1_real ( n, nspmn, nspmx, eigr, c, becp ) - !----------------------------------------------------------------------- - USE kinds, ONLY : DP - ! - USE reciprocal_vectors, ONLY : gstart - ! - implicit none - - integer, intent(in) :: n, nspmn, nspmx - complex(DP), intent(in) :: eigr( :, : ), c( :, : ) - real(DP), intent(out) :: becp( :, : ) - END SUBROUTINE - !----------------------------------------------------------------------- - SUBROUTINE nlsm1_twin(n, nspmn, nspmx, eigr, c, becp, lbound_bec, lgam2)!added:giovanni lgam - - USE kinds, ONLY : DP - USE twin_types !added:giovanni - USE ions_base, only : na, nat - USE gvecw, only : ngw - ! - USE reciprocal_vectors, ONLY : gstart, gx !added:giovanni:debug gx - ! - implicit none - - integer, intent(in) :: n, nspmn, nspmx, lbound_bec - complex(DP), intent(in) :: eigr(ngw,nat), c(ngw, n )!modified:giovanni - ! real(DP), intent(out) :: becp - type(twin_matrix) :: becp!( nkb, n ) !modified:giovanni - logical :: lgam2!added:giovanni - END SUBROUTINE - END INTERFACE - - INTERFACE nlsm1_dist - SUBROUTINE nlsm1_dist_real ( n, nspmn, nspmx, eigr, c, becp, nlax, nspin, desc ) - - USE kinds, ONLY : DP -! USE mp, ONLY : mp_sum -! USE mp_global, ONLY : nproc_image, intra_image_comm - USE ions_base, only : na, nat - USE gvecw, only : ngw - USE uspp, only : nkb, nhtol, beta -! USE cvan, only : ish -! USE uspp_param, only : nh - ! -! USE reciprocal_vectors, ONLY : gstart - USE descriptors, ONLY : descla_siz_ , lambda_node_ , nlar_ , ilar_ , la_n_ - ! - implicit none - - integer, intent(in) :: n, nspmn, nspmx, nlax, nspin - integer, intent(in) :: desc( descla_siz_ , nspin ) - complex(DP), intent(in) :: eigr( :, :), c( :, : ) - real(DP), intent(out) :: becp( nkb, nlax*nspin ) - END SUBROUTINE - subroutine nlsm1_dist_twin ( n, nspmn, nspmx, eigr, c, becp, nlax, nspin, desc, lgam2 ) - - USE kinds, ONLY : DP -! USE mp, ONLY : mp_sum -! USE mp_global, ONLY : nproc_image, intra_image_comm - USE ions_base, only : na, nat - USE gvecw, only : ngw - USE uspp, only : nkb, nhtol, beta - USE ions_base, only : na, nat - USE gvecw, only : ngw -! USE cvan, only : ish -! USE uspp_param, only : nh -! ! -! USE reciprocal_vectors, ONLY : gstart - USE descriptors, ONLY : descla_siz_ , lambda_node_ , nlar_ , ilar_ , la_n_ - USE twin_types - ! - implicit none - - integer, intent(in) :: n, nspmn, nspmx, nlax, nspin - integer, intent(in) :: desc( descla_siz_ , nspin ) - complex(DP), intent(in) :: eigr( ngw, nat ), c( ngw, n ) -! complex(DP), intent(in) :: eigr( :, : ), c( :, : ) - type(twin_matrix), intent(out) :: becp !( nkb, nlax*nspin ) - logical, intent(IN) :: lgam2 - END SUBROUTINE - END INTERFACE - - - INTERFACE grabec - SUBROUTINE grabec_real( becc, nkbx, betae, c, ngwx ) -! USE uspp, ONLY : nkb, nhsavb=>nkbus -! USE gvecw, ONLY: ngw - USE kinds, ONLY: DP -! USE reciprocal_vectors, ONLY: gstart - ! - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nkbx, ngwx - COMPLEX(DP) :: betae( :,: ) - REAL(DP) :: becc(: ) - COMPLEX(DP) :: c( :, : ) - END SUBROUTINE - SUBROUTINE grabec_twin( becc, nkbx, betae, c, ngwx, l2_bec) - USE kinds, ONLY: DP - USE twin_types - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nkbx, ngwx, l2_bec - COMPLEX(DP) :: betae( :, : ) - LOGICAL :: lgam - COMPLEX(DP) :: c( :, : ) - type(twin_matrix) :: becc !( nkbx ), - END SUBROUTINE - END INTERFACE -!---------- END INTERFACES FOR COMPLEX IMPLEMENTATION - - INTERFACE write_hamiltonian - SUBROUTINE write_hamiltonian_real( ham, nbnd, ispin, empty ) - USE kinds, ONLY : DP - IMPLICIT NONE - - REAL(DP), INTENT(IN) :: ham(:,:) - INTEGER, INTENT(IN) :: nbnd - INTEGER, INTENT(IN) :: ispin - LOGICAL, INTENT(IN) :: empty - END SUBROUTINE - SUBROUTINE write_hamiltonian_cmplx( ham, nbnd, ispin, empty ) - USE kinds, ONLY : DP - IMPLICIT NONE - - COMPLEX(DP), INTENT(IN) :: ham(:,:) - INTEGER, INTENT(IN) :: nbnd - INTEGER, INTENT(IN) :: ispin - LOGICAL, INTENT(IN) :: empty - END SUBROUTINE - END INTERFACE - - INTERFACE ortho_check - SUBROUTINE ortho_check_cmplx( c0_emp, lgam ) - USE kinds, ONLY : DP - IMPLICIT NONE - - COMPLEX(DP), INTENT(IN) :: c0_emp(:,:) - LOGICAL, INTENT(IN) :: lgam - END SUBROUTINE - END INTERFACE - - INTERFACE symm_wannier - SUBROUTINE symm_wannier_x( wfc, num_states, emp ) - USE kinds, ONLY : DP - IMPLICIT NONE - - COMPLEX(DP), INTENT(INOUT) :: wfc(:,:) - INTEGER, INTENT(IN) :: num_states - LOGICAL, INTENT(IN) :: emp - END SUBROUTINE - END INTERFACE - -!=----------------------------------------------------------------------------=! - END MODULE -!=----------------------------------------------------------------------------=! diff --git a/quantum_espresso/kcp/CPV/cp_restart.f90 b/quantum_espresso/kcp/CPV/cp_restart.f90 deleted file mode 100644 index 56a9ec66a..000000000 --- a/quantum_espresso/kcp/CPV/cp_restart.f90 +++ /dev/null @@ -1,4477 +0,0 @@ -! Copyright (C) 2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!----------------------------------------------------------------------------- -MODULE cp_restart - !----------------------------------------------------------------------------- - ! - ! ... This module contains subroutines to write and read data required to - ! ... restart a calculation from the disk - ! - USE iotk_module - USE xml_io_base, ONLY : default_fmt_version => fmt_version - USE xml_io_base - ! - USE kinds, ONLY : DP - USE io_global, ONLY : ionode, ionode_id, stdout - USE io_files, ONLY : prefix, iunpun, xmlpun, qexml_version, qexml_version_init - USE mp, ONLY : mp_bcast - USE parser, ONLY : version_compare - ! - IMPLICIT NONE - ! - SAVE - ! - PRIVATE :: read_cell - ! - INTEGER, PRIVATE :: iunout - ! - ! - ! variables to describe qexml current version - ! and back compatibility - ! - LOGICAL, PRIVATE :: qexml_version_before_1_4_0 = .FALSE. - ! - INTERFACE cp_writefile - module procedure cp_writefile_twin, cp_writefile_real - END INTERFACE cp_writefile - - INTERFACE cp_readfile - module procedure cp_readfile_twin, cp_readfile_real - END INTERFACE cp_readfile - ! - CONTAINS - ! - !------------------------------------------------------------------------ - SUBROUTINE cp_writefile_twin( ndw, outdir, ascii, nfi, simtime, acc, nk, xk, & - wk, ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, & - taui, cdmi, stau0, svel0, staum, svelm, force, & - vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ0, occm, & - lambda0,lambdam,lambda_bare, xnhe0, xnhem, vnhe,& - ekincm, et, rho, c02, cm2, ctot, iupdwn, nupdwn,& - iupdwn_tot, nupdwn_tot, mat_z ) - !------------------------------------------------------------------------ - ! - USE control_flags, ONLY : do_wf_cmplx, gamma_only, force_pairing, trhow, tksw !added:giovanni do_wf_cmplx! - USE control_flags, ONLY : evc_restart !added:giovanni evc_restart - USE io_files, ONLY : psfile, pseudo_dir - USE mp_global, ONLY : intra_image_comm - USE printout_base, ONLY : title - USE grid_dimensions, ONLY : nr1, nr2, nr3, nr1x, nr2x - USE smooth_grid_dimensions, ONLY : nr1s, nr2s, nr3s - USE smallbox_grid_dimensions, ONLY : nr1b, nr2b, nr3b - USE gvecp, ONLY : ngm, ngmt - USE gvecs, ONLY : ngst, dual - USE gvecw, ONLY : ngw, ngwt, ecutw - USE reciprocal_vectors, ONLY : ig_l2g, mill_l - USE electrons_base, ONLY : nspin, nelt, nel, nudx - USE cell_base, ONLY : ibrav, alat, celldm, & - symm_type, s_to_r - USE ions_base, ONLY : nsp, nat, na, atm, & - amass, iforce, ind_bck - USE funct, ONLY : get_dft_name - USE energies, ONLY : enthal, ekin, eht, esr, eself, & - epseu, enl, exc, vave - USE mp, ONLY : mp_sum - USE fft_base, ONLY : dfftp - USE constants, ONLY : pi - USE cp_interfaces, ONLY : n_atom_wfc, write_hamiltonian - USE global_version, ONLY : version_number - USE cp_main_variables, ONLY : collect_lambda, descla, collect_zmat - USE twin_types !added:giovanni - USE nksic, ONLY : do_bare_eigs !added:giovanni - USE input_parameters, ONLY : print_evc0_occ_empty, write_hr - USE wavefunctions_module, ONLY : c0_fixed, c0_occ_emp_aux - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ndw ! - CHARACTER(LEN=*), INTENT(IN) :: outdir ! directory used to store output and restart files - LOGICAL, INTENT(IN) :: ascii ! - INTEGER, INTENT(IN) :: nfi ! index of the current step - REAL(DP), INTENT(IN) :: simtime ! simulated time - REAL(DP), INTENT(IN) :: acc(:) ! - INTEGER, INTENT(IN) :: nk ! number of kpoints - REAL(DP), INTENT(IN) :: xk(:,:) ! k-points coordinates - REAL(DP), INTENT(IN) :: wk(:) ! k-points weights - REAL(DP), INTENT(IN) :: ht(3,3) ! - REAL(DP), INTENT(IN) :: htm(3,3) ! - REAL(DP), INTENT(IN) :: htvel(3,3) ! - REAL(DP), INTENT(IN) :: gvel(3,3) ! - REAL(DP), INTENT(IN) :: xnhh0(3,3) ! - REAL(DP), INTENT(IN) :: xnhhm(3,3) ! - REAL(DP), INTENT(IN) :: vnhh(3,3) ! - REAL(DP), INTENT(IN) :: taui(:,:) ! - REAL(DP), INTENT(IN) :: cdmi(:) ! - REAL(DP), INTENT(IN) :: stau0(:,:) ! - REAL(DP), INTENT(IN) :: svel0(:,:) ! - REAL(DP), INTENT(IN) :: staum(:,:) ! - REAL(DP), INTENT(IN) :: svelm(:,:) ! - REAL(DP), INTENT(IN) :: force(:,:) ! - REAL(DP), INTENT(IN) :: xnhp0(:) ! - REAL(DP), INTENT(IN) :: xnhpm(:) ! - REAL(DP), INTENT(IN) :: vnhp(:) ! - INTEGER, INTENT(IN) :: nhpcl ! - INTEGER, INTENT(IN) :: nhpdim ! - REAL(DP), INTENT(IN) :: occ0(:) ! occupations of electronic states - REAL(DP), INTENT(IN) :: occm(:) ! - TYPE(twin_matrix), DIMENSION(:), INTENT(IN) :: lambda0 - TYPE(twin_matrix), DIMENSION(:), INTENT(IN) :: lambdam - TYPE(twin_matrix), DIMENSION(:), INTENT(IN) :: lambda_bare -! REAL(DP), INTENT(IN) :: lambda0(:,:,:) ! !removed:giovanni -! REAL(DP), INTENT(IN) :: lambdam(:,:,:) ! !removed:giovanni - REAL(DP), INTENT(IN) :: xnhe0 ! - REAL(DP), INTENT(IN) :: xnhem ! - REAL(DP), INTENT(IN) :: vnhe ! - REAL(DP), INTENT(IN) :: ekincm ! - REAL(DP), INTENT(IN) :: et(:,:) ! eigenvalues - REAL(DP), INTENT(IN) :: rho(:,:) ! - COMPLEX(DP), INTENT(IN) :: c02(:,:) ! - COMPLEX(DP), INTENT(IN) :: cm2(:,:) ! - COMPLEX(DP), INTENT(IN) :: ctot(:,:) ! - INTEGER, INTENT(IN) :: iupdwn(:) ! - INTEGER, INTENT(IN) :: nupdwn(:) ! - INTEGER, INTENT(IN) :: iupdwn_tot(:)! - INTEGER, INTENT(IN) :: nupdwn_tot(:)! -! REAL(DP), OPTIONAL, INTENT(IN) :: mat_z(:,:,:) ! - TYPE(twin_matrix), DIMENSION(:), OPTIONAL, INTENT(IN) :: mat_z - ! - LOGICAL :: write_charge_density - CHARACTER(LEN=20) :: dft_name - CHARACTER(LEN=256) :: dirname, filename, rho_file_base - CHARACTER(LEN=4) :: cspin - INTEGER :: kunit, ib, ik_eff - INTEGER :: k1, k2, k3 - INTEGER :: nk1, nk2, nk3 - INTEGER :: i, iss, iss_wfc - INTEGER :: is, ia, isa, ik, ierr - INTEGER, ALLOCATABLE :: mill(:,:) - INTEGER, ALLOCATABLE :: ftmp(:,:) - INTEGER, ALLOCATABLE :: ityp(:) - REAL(DP), ALLOCATABLE :: tau(:,:) - REAL(DP), ALLOCATABLE :: dtmp(:) - REAL(DP), ALLOCATABLE :: rhoaux(:) - REAL(DP) :: omega, htm1(3,3), h(3,3) - REAL(DP) :: a1(3), a2(3), a3(3) - REAL(DP) :: b1(3), b2(3), b3(3) - REAL(DP) :: nelec - REAL(DP) :: scalef - LOGICAL :: lsda - REAL(DP) :: s0, s1, cclock - INTEGER :: nbnd_tot - INTEGER :: nbnd_emp - INTEGER :: nbnd_ - REAL(DP), ALLOCATABLE :: mrepl(:,:) - COMPLEX(DP), ALLOCATABLE :: mrepl_c(:,:) !added:giovanni - ! - write_charge_density = trhow - ! - IF( nspin > 1 .AND. .NOT. force_pairing ) THEN - ! - ! check if the array storing wave functions is large enought - ! - IF( SIZE( c02, 2 ) < ( iupdwn( 2 ) + nupdwn(1) - 1 ) ) & - CALL errore('cp_writefile',' wrong wave functions dimension ', 1 ) - ! - END IF - ! - IF( nupdwn_tot(1) < nupdwn(1) ) & - CALL errore( " writefile ", " wrong number of states ", 1 ) - ! - nbnd_ = nupdwn(1) - nbnd_tot = MAX( nupdwn(1), nupdwn_tot(1) ) - nbnd_emp = MAX( 0, nupdwn_tot(1) - nupdwn(1) ) - ! - IF ( ionode ) THEN - ! - ! ... look for an empty unit (only ionode needs it) - ! - CALL iotk_free_unit( iunout, ierr ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_writefile', & - 'no free units to write wavefunctions', ierr ) - ! - dirname = restart_dir( outdir, ndw ) - ! - ! ... Create main restart directory - ! - CALL create_directory( dirname ) - ! - ! ... Create k-points subdirectories - ! ... note: in FPMD and CP k-points are not distributed to processors - ! - DO i = 1, nk - ! - CALL create_directory( kpoint_dir( dirname, i ) ) - ! - END DO - ! - ! ... Some ( CP/FPMD ) default values - ! - IF ( nspin == 2 ) THEN - ! - kunit = 2 - ! - ELSE - ! - kunit = 1 - ! - END IF - ! - k1 = 0 - k2 = 0 - k3 = 0 - nk1 = 0 - nk2 = 0 - nk3 = 0 - ! - ! ... Compute Cell related variables - ! - h = TRANSPOSE( ht ) - ! - CALL invmat( 3, ht, htm1, omega ) - ! - a1 = ht(1,:) - a2 = ht(2,:) - a3 = ht(3,:) - ! - ! ... Beware: omega may be negative if axis are left-handed! - ! - scalef = 1.D0 / SQRT( ABS (omega) ) - ! - ! ... Compute array ityp, and tau - ! - ALLOCATE( ityp( nat ) ) - ALLOCATE( tau( 3, nat ) ) - ! - isa = 0 - ! - DO is = 1, nsp - ! - DO ia = 1, na(is) - ! - isa = isa + 1 - ityp(isa) = is - ! - END DO - ! - END DO - ! - CALL s_to_r( stau0, tau, na, nsp, h ) - ! - ! ... Collect G vectors - ! - ALLOCATE( mill( 3, ngmt ) ) - ! - mill = 0 - ! - mill(:,ig_l2g(1:ngm)) = mill_l(:,1:ngm) - ! - CALL mp_sum( mill, intra_image_comm ) - ! - lsda = ( nspin == 2 ) - ! - ALLOCATE( ftmp( nbnd_tot , nspin ) ) - ! - ftmp = 0.0d0 - ! - DO iss = 1, nspin - ! - ftmp( 1:nupdwn(iss), iss ) = occ0( iupdwn(iss) : iupdwn(iss) + nupdwn(iss) - 1 ) - ! - END DO - ! - IF ( ionode ) THEN - ! - ! ... Open XML descriptor - ! - WRITE( stdout, '(/,3X,"writing restart file: ",A)' ) TRIM( dirname ) - ! - CALL iotk_open_write( iunpun, FILE = TRIM( dirname ) // '/' // & - & TRIM( xmlpun ), BINARY = .FALSE., IERR = ierr ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_writefile ', 'cannot open restart file for writing', ierr ) - ! - s0 = cclock() - ! - IF ( ionode ) THEN - -!------------------------------------------------------------------------------- -! ... HEADER -!------------------------------------------------------------------------------- - ! - CALL write_header( "CP", TRIM(version_number) ) - ! -!------------------------------------------------------------------------------- -! ... this flag is used to check if the file can be used for post-processing -!------------------------------------------------------------------------------- - ! - CALL write_control( PP_CHECK_FLAG=.TRUE. ) - ! -!------------------------------------------------------------------------------- -! ... STATUS -!------------------------------------------------------------------------------- - ! - CALL iotk_write_begin( iunpun, "STATUS" ) - ! - CALL iotk_write_attr( attr, "ITERATION", nfi, FIRST = .TRUE. ) - CALL iotk_write_empty(iunpun, "STEP", attr ) - ! - CALL iotk_write_attr( attr, "UNITS", "pico-seconds", FIRST = .TRUE. ) - CALL iotk_write_dat( iunpun, "TIME", simtime, ATTR = attr ) - ! - CALL iotk_write_dat( iunpun, "TITLE", TRIM( title ) ) - ! - CALL iotk_write_attr( attr, "UNITS", "Hartree", FIRST = .TRUE. ) - CALL iotk_write_dat( iunpun, "KINETIC_ENERGY", ekin, ATTR = attr ) - CALL iotk_write_dat( iunpun, "HARTREE_ENERGY", eht, ATTR = attr ) - CALL iotk_write_dat( iunpun, "EWALD_TERM", esr, ATTR = attr ) - CALL iotk_write_dat( iunpun, "GAUSS_SELFINT", eself, ATTR = attr ) - CALL iotk_write_dat( iunpun, "LPSP_ENERGY", epseu, ATTR = attr ) - CALL iotk_write_dat( iunpun, "NLPSP_ENERGY", enl, ATTR = attr ) - CALL iotk_write_dat( iunpun, "EXC_ENERGY", exc, ATTR = attr ) - CALL iotk_write_dat( iunpun, "AVERAGE_POT", vave, ATTR = attr ) - CALL iotk_write_dat( iunpun, "ENTHALPY", enthal, ATTR = attr ) - ! - CALL iotk_write_end( iunpun, "STATUS" ) - ! -!------------------------------------------------------------------------------- -! ... CELL -!------------------------------------------------------------------------------- - ! - a1 = a1 / alat - a2 = a2 / alat - a3 = a3 / alat - ! - CALL recips( a1, a2, a3, b1, b2, b3 ) - ! - CALL write_cell( ibrav, symm_type, & - celldm, alat, a1, a2, a3, b1, b2, b3 ) - ! -!------------------------------------------------------------------------------- -! ... IONS -!------------------------------------------------------------------------------- - ! - CALL write_ions( nsp, nat, atm, ityp(ind_bck(:)), & - psfile, pseudo_dir, amass, tau(:,ind_bck(:)), & - iforce(:,ind_bck(:)), dirname, 1.D0 ) - ! -!------------------------------------------------------------------------------- -! ... PLANE_WAVES -!------------------------------------------------------------------------------- - ! - ! change to .TRUE. to write gvectors.dat for rho - ! - CALL write_planewaves( ecutw, dual, ngwt, do_wf_cmplx, gamma_only, & !added:giovanni do_wf_cmplx - nr1, nr2, nr3, ngmt, nr1s, nr2s, nr3s, & - ngst, nr1b, nr2b, nr3b, mill, .TRUE. ) - ! -!------------------------------------------------------------------------------- -! ... SPIN -!------------------------------------------------------------------------------- - ! - CALL write_spin( lsda, .FALSE., 1, .FALSE., .TRUE. ) - ! -!------------------------------------------------------------------------------- -! ... EXCHANGE_CORRELATION -!------------------------------------------------------------------------------- - ! - dft_name = get_dft_name() - CALL write_xc( DFT = dft_name, NSP = nsp, LDA_PLUS_U = .FALSE. ) - ! -!------------------------------------------------------------------------------- -! ... OCCUPATIONS -!------------------------------------------------------------------------------- - ! - CALL write_occ( LGAUSS = .FALSE., LTETRA = .FALSE., & - TFIXED_OCC = .TRUE., LSDA = lsda, NSTATES_UP = nupdwn_tot(1), & - NSTATES_DOWN = nupdwn_tot(2), F_INP = DBLE( ftmp ) ) - ! -!------------------------------------------------------------------------------- -! ... BRILLOUIN_ZONE -!------------------------------------------------------------------------------- - ! - CALL write_bz( nk, xk, wk, k1, k2, k3, nk1, nk2, nk3, 0.0_DP ) - ! -!------------------------------------------------------------------------------- -! ... PARALLELISM -!------------------------------------------------------------------------------- - ! - CALL iotk_write_begin( iunpun, "PARALLELISM" ) - ! - CALL iotk_write_dat( iunpun, & - "GRANULARITY_OF_K-POINTS_DISTRIBUTION", kunit ) - ! - CALL iotk_write_end( iunpun, "PARALLELISM" ) - ! - END IF - ! -!------------------------------------------------------------------------------- -! ... CHARGE-DENSITY -!------------------------------------------------------------------------------- - ! - IF (write_charge_density) then - ! - rho_file_base = 'charge-density' - ! - IF ( ionode )& - CALL iotk_link( iunpun, "CHARGE-DENSITY", rho_file_base, & - CREATE = .FALSE., BINARY = .TRUE. ) - ! - rho_file_base = TRIM( dirname ) // '/' // TRIM( rho_file_base ) - ! - IF ( nspin == 1 ) THEN - ! - CALL write_rho_xml( rho_file_base, rho(:,1), & - nr1, nr2, nr3, nr1x, nr2x, dfftp%ipp, dfftp%npp ) - ! - ELSE IF ( nspin == 2 ) THEN - ! - ALLOCATE( rhoaux( SIZE( rho, 1 ) ) ) - ! - rhoaux = rho(:,1) + rho(:,2) - ! - CALL write_rho_xml( rho_file_base, rhoaux, & - nr1, nr2, nr3, nr1x, nr2x, dfftp%ipp, dfftp%npp ) - ! - rho_file_base = 'spin-polarization' - ! - IF ( ionode ) & - CALL iotk_link( iunpun, "SPIN-POLARIZATION", rho_file_base, & - CREATE = .FALSE., BINARY = .TRUE. ) - ! - rho_file_base = TRIM( dirname ) // '/' // TRIM( rho_file_base ) - ! - rhoaux = rho(:,1) - rho(:,2) - ! - CALL write_rho_xml( rho_file_base, rhoaux, & - nr1, nr2, nr3, nr1x, nr2x, dfftp%ipp, dfftp%npp ) - ! - DEALLOCATE( rhoaux ) - ! - END IF - ! - END IF ! write_charge_density - ! -!------------------------------------------------------------------------------- -! ... TIMESTEPS -!------------------------------------------------------------------------------- - ! - IF ( ionode ) THEN - ! - CALL iotk_write_attr( attr, "nt", 2, FIRST = .TRUE. ) - ! - CALL iotk_write_begin( iunpun, "TIMESTEPS", attr ) - ! - ! ... STEP0 - ! - CALL iotk_write_begin( iunpun, "STEP0" ) - ! - CALL iotk_write_dat( iunpun, "ACCUMULATORS", acc ) - ! - CALL iotk_write_begin( iunpun, "IONS_POSITIONS" ) - CALL iotk_write_dat( iunpun, "stau", stau0(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "svel", svel0(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "taui", taui(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "cdmi", cdmi(1:3), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "force", force(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_write_begin( iunpun, "IONS_NOSE" ) - CALL iotk_write_dat( iunpun, "nhpcl", nhpcl ) - CALL iotk_write_dat( iunpun, "nhpdim", nhpdim ) - CALL iotk_write_dat( iunpun, "xnhp", xnhp0(1:nhpcl*nhpdim) ) - CALL iotk_write_dat( iunpun, "vnhp", vnhp(1:nhpcl*nhpdim) ) - CALL iotk_write_end( iunpun, "IONS_NOSE" ) - ! - CALL iotk_write_dat( iunpun, "ekincm", ekincm ) - ! - CALL iotk_write_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhe", xnhe0 ) - CALL iotk_write_dat( iunpun, "vnhe", vnhe ) - CALL iotk_write_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_write_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_write_dat( iunpun, "ht", ht ) - CALL iotk_write_dat( iunpun, "htvel", htvel ) - CALL iotk_write_dat( iunpun, "gvel", gvel ) - CALL iotk_write_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_write_begin( iunpun, "CELL_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhh", xnhh0 ) - CALL iotk_write_dat( iunpun, "vnhh", vnhh ) - CALL iotk_write_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_write_end( iunpun, "STEP0" ) - ! - ! ... STEPM - ! - CALL iotk_write_begin( iunpun, "STEPM" ) - ! - CALL iotk_write_begin( iunpun, "IONS_POSITIONS" ) - CALL iotk_write_dat( iunpun, "stau", staum(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "svel", svelm(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_write_begin( iunpun, "IONS_NOSE" ) - CALL iotk_write_dat( iunpun, "nhpcl", nhpcl ) - CALL iotk_write_dat( iunpun, "nhpdim", nhpdim ) - CALL iotk_write_dat( iunpun, "xnhp", xnhpm(1:nhpcl*nhpdim) ) - CALL iotk_write_end( iunpun, "IONS_NOSE" ) - ! - CALL iotk_write_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhe", xnhem ) - CALL iotk_write_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_write_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_write_dat( iunpun, "ht", htm ) - CALL iotk_write_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_write_begin( iunpun, "CELL_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhh", xnhhm ) - CALL iotk_write_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_write_end( iunpun, "STEPM" ) - ! - CALL iotk_write_end( iunpun, "TIMESTEPS" ) - ! - END IF - -!------------------------------------------------------------------------------- -! ... BAND_STRUCTURE_INFO -!------------------------------------------------------------------------------- - - IF ( ionode ) THEN - - ! - CALL iotk_write_begin( iunpun, "BAND_STRUCTURE_INFO" ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_ATOMIC_WFC", n_atom_wfc() ) - ! - nelec = nelt - ! - IF ( nspin == 2 ) THEN - ! - CALL iotk_write_attr( attr, "UP", nel(1), FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "DW", nel(2) ) - CALL iotk_write_dat( iunpun, & - "NUMBER_OF_ELECTRONS", nelec, ATTR = attr ) - ! - CALL iotk_write_attr( attr, "UP", nupdwn_tot(1), FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "DW", nupdwn_tot(2) ) - CALL iotk_write_dat( iunpun, & - "NUMBER_OF_BANDS", nbnd_tot , ATTR = attr ) - ! - ELSE - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_ELECTRONS", nelec ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_BANDS", nbnd_tot ) - ! - END IF - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_EMPTY_STATES", nbnd_emp ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_SPIN_COMPONENTS", nspin ) - ! - CALL iotk_write_end( iunpun, "BAND_STRUCTURE_INFO" ) - ! - CALL iotk_write_begin( iunpun, "EIGENVALUES" ) - ! - ! - END IF - ! -!------------------------------------------------------------------------------- -! ... EIGENVALUES -!------------------------------------------------------------------------------- - ! - k_points_loop1: DO ik = 1, nk - ! - IF ( ionode ) THEN - ! - CALL iotk_write_begin( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - CALL iotk_write_attr( attr, "UNITS", "2 pi / a", FIRST = .TRUE. ) - CALL iotk_write_dat( iunpun, & - "K-POINT_COORDS", xk(:,ik), ATTR = attr ) - ! - CALL iotk_write_dat( iunpun, "WEIGHT", wk(ik) ) - ! - ALLOCATE( dtmp ( nbnd_tot ) ) - ! - DO iss = 1, nspin - ! - cspin = iotk_index( iss ) - ! - dtmp = 0.0d0 - ! - IF( tksw ) THEN - ! - ! writes data required by postproc and PW - ! - IF( nspin == 2 ) THEN - IF( iss == 1 ) filename = wfc_filename( ".", 'eigenval1', ik, EXTENSION='xml' ) - IF( iss == 2 ) filename = wfc_filename( ".", 'eigenval2', ik, EXTENSION='xml' ) - ! - IF( iss == 1 ) CALL iotk_link( iunpun, "DATAFILE.1", & - filename, CREATE = .FALSE., BINARY = .FALSE. ) - IF( iss == 2 ) CALL iotk_link( iunpun, "DATAFILE.2", & - filename, CREATE = .FALSE., BINARY = .FALSE. ) - - IF( iss == 1 ) filename = wfc_filename( dirname, 'eigenval1', ik, EXTENSION='xml' ) - IF( iss == 2 ) filename = wfc_filename( dirname, 'eigenval2', ik, EXTENSION='xml' ) - ELSE - filename = wfc_filename( ".", 'eigenval', ik, EXTENSION='xml' ) - CALL iotk_link( iunpun, "DATAFILE", filename, CREATE = .FALSE., BINARY = .FALSE. ) - filename = wfc_filename( dirname, 'eigenval', ik, EXTENSION='xml' ) - END IF - - dtmp ( 1:nupdwn( iss ) ) = occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) / wk(ik) - ! - CALL write_eig( iunout, filename, nbnd_tot, et( 1:nbnd_tot, iss) , "Hartree", & - OCC = dtmp(:), IK=ik, ISPIN=iss ) - ! - END IF - ! - CALL iotk_write_dat( iunpun, "OCC0" // TRIM( cspin ), & - occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) ) - ! - CALL iotk_write_dat( iunpun, "OCCM" // TRIM( cspin ), & - occm( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) ) - ! - END DO - ! - DEALLOCATE( dtmp ) - ! - CALL iotk_write_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - - END IF - ! - END DO k_points_loop1 - ! - IF ( ionode ) THEN - ! - CALL iotk_write_end( iunpun, "EIGENVALUES" ) - ! - CALL iotk_write_begin( iunpun, "EIGENVECTORS" ) - ! - CALL iotk_write_dat ( iunpun, "MAX_NUMBER_OF_GK-VECTORS", ngwt ) - ! - END IF - ! -!------------------------------------------------------------------------------- -! ... EIGENVECTORS -!------------------------------------------------------------------------------- - ! - k_points_loop2: DO ik = 1, nk - - IF( ionode ) THEN - - CALL iotk_write_begin( iunpun, "K-POINT" // TRIM( iotk_index( ik ) ) ) - ! - ! ... G+K vectors - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_GK-VECTORS", ngwt ) - ! - ! - filename = TRIM( wfc_filename( ".", 'gkvectors', ik ) ) - ! - CALL iotk_link( iunpun, "GK-VECTORS", filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - filename = TRIM( wfc_filename( dirname, 'gkvectors', ik ) ) - ! - END IF - ! - CALL write_gk( iunout, mill, filename ) - ! - DO iss = 1, nspin - ! - ik_eff = ik + ( iss - 1 ) * nk - ! - iss_wfc = iss - if( force_pairing ) iss_wfc = 1 ! only the WF for the first spin is allocated - ! - IF( tksw ) THEN - ! - ! Save additional WF, - ! orthogonal KS states to be used for post processing and PW - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc', ik, iss ) ) - ! - END IF - ! - IF( nspin == 2 ) THEN - CALL iotk_link( iunpun, "WFC" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ELSE - CALL iotk_link( iunpun, "WFC", filename, CREATE = .FALSE., BINARY = .TRUE. ) - END IF - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn_tot( iss_wfc ) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & !added_giovanni do_wf_cmplx - ctot( :, ib : ib + nbnd_tot - 1 ), ngwt, do_wf_cmplx, & - gamma_only, nbnd_tot, ig_l2g, ngw, filename, scalef) - ! - ! - ! - END IF - ! - ! Save wave function at time t - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc0', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc0', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFC0" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc0', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc0', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - IF(.not. evc_restart) then - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - c02( :, ib : ib + nbnd_ - 1 ), ngwt, do_wf_cmplx, & !added:giovanni do_wf_cmplx - gamma_only, nbnd_, ig_l2g, ngw, filename, scalef) - ELSE - WRITE(*,*) "Careful: I am writing Kohn-Sham eigenstates as restart wavefunctions" - WRITE(*,*) "Errors may happen" - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - ctot( :, ib : ib + nbnd_ - 1 ), ngwt, do_wf_cmplx, & !added:giovanni do_wf_cmplx - gamma_only, nbnd_, ig_l2g, ngw, filename, scalef) - ENDIF - ! - ! Save wave function at time t - dt - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evcm', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evcm', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFCM" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evcm', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evcm', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - cm2( :, ib : ib + nbnd_ - 1 ), ngwt, do_wf_cmplx, & !added:giovanni do_wf_cmplx - gamma_only, nbnd_, ig_l2g, ngw, filename, scalef) - ! - ! Save fixed wave function - ! - IF (.false.) THEN - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc0fixed', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc0fixed', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFC0FIXED" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc0fixed', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc0fixed', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - c0_fixed( :, ib : ib + nbnd_ - 1 ), ngwt, do_wf_cmplx, & !added:giovanni do_wf_cmplx - gamma_only, nbnd_, ig_l2g, ngw, filename, scalef) - ! - ENDIF - ! - IF (print_evc0_occ_empty .and. (nbnd_emp>0) ) THEN - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc0_occ_empty', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc0_occ_empty', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFC0_OCC_EMPTY" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc0_occ_empty', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc0_occ_empty', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn_tot( iss_wfc ) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & !added_giovanni do_wf_cmplx - c0_occ_emp_aux( :, ib : ib + nbnd_tot - 1 ), ngwt, do_wf_cmplx, & - gamma_only, nbnd_tot, ig_l2g, ngw, filename, scalef) - ! - ENDIF - ! - cspin = iotk_index( iss ) - ! - ! ... write matrix lambda to file - ! - IF(.not. lambda0(1)%iscmplx) THEN - ALLOCATE( mrepl( nudx, nudx ) ) - CALL collect_lambda( mrepl, lambda0(iss)%rvec(:,:), descla(:,iss) ) - ELSE - ALLOCATE( mrepl_c( nudx, nudx) ) - CALL collect_lambda( mrepl_c, lambda0(iss)%cvec(:,:), descla(:,iss)) - ENDIF - ! - ! - IF ( ionode ) THEN - ! - filename = TRIM( wfc_filename( ".", 'lambda0', ik, iss ) ) - ! - CALL iotk_link( iunpun, "LAMBDA0" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .TRUE. ) - ! - IF(.not. lambda0(1)%iscmplx) THEN - CALL iotk_write_dat( iunpun, & - "LAMBDA0" // TRIM( cspin ), mrepl ) - ELSE - CALL iotk_write_dat( iunpun, & - "LAMBDA0" // TRIM( cspin ), mrepl_c ) - ENDIF - ! - ! Changes by Nicolas Poilvert, Sep. 2010 for printing the lambda - ! matrix at current time step into a formatted file. - ! This matrix corresponds to the Hamiltonian matrix in the case - ! of Self-Interaction. Only in the basis of minimizing orbitals - ! do this matrix has an interpretation. - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'hamiltonian', ik, EXTENSION='xml' ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'hamiltonian', ik, iss, EXTENSION='xml' ) ) - ! - ENDIF - ! - CALL iotk_link( iunpun, "HAMILTONIAN" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .FALSE. ) - ! - ! - IF(allocated(mrepl)) THEN - CALL iotk_write_dat( iunpun, & - "HAMILTONIAN" // TRIM( cspin ), mrepl ) - IF ( write_hr ) CALL write_hamiltonian( mrepl, nupdwn(iss), iss, .false. ) - ! - ! - ELSE IF(allocated(mrepl_c)) THEN - CALL iotk_write_dat( iunpun, & - "HAMILTONIAN" // TRIM( cspin ), mrepl_c ) - IF ( write_hr ) CALL write_hamiltonian( mrepl_c, nupdwn(iss), iss, .false. ) - ENDIF - ! - ENDIF - - IF(do_bare_eigs) THEN - ! - IF(.not. lambda_bare(1)%iscmplx) THEN - mrepl=0.d0 - CALL collect_lambda( mrepl, lambda_bare(iss)%rvec(:,:), descla(:,iss) ) - ELSE - mrepl_c=0.d0 - CALL collect_lambda( mrepl_c, lambda_bare(iss)%cvec(:,:), descla(:,iss)) - ENDIF - ! - IF(ionode) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'hamiltonian0', ik, EXTENSION='xml' ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'hamiltonian0', ik, iss, EXTENSION='xml' ) ) - ! - ENDIF - ! - CALL iotk_link( iunpun, "HAMILTONIAN0" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .FALSE. ) - ! - IF(allocated(mrepl)) THEN - CALL iotk_write_dat( iunpun, & - "HAMILTONIAN0" // TRIM( cspin ), mrepl ) - ELSE IF(allocated(mrepl_c)) THEN - CALL iotk_write_dat( iunpun, & - "HAMILTONIAN0" // TRIM( cspin ), mrepl_c ) - ENDIF - ! - ENDIF - ! - END IF - ! - IF(.not. lambdam(1)%iscmplx) THEN - CALL collect_lambda( mrepl, lambdam(iss)%rvec(:,:), descla(:,iss) ) - ELSE - CALL collect_lambda( mrepl_c, lambdam(iss)%cvec(:,:), descla(:,iss)) - ENDIF - ! - IF ( ionode ) THEN - ! - filename = TRIM( wfc_filename( ".", 'lambdam', ik, iss ) ) - ! - CALL iotk_link( iunpun, "LAMBDAM" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .TRUE. ) - ! - IF(allocated(mrepl)) THEN - CALL iotk_write_dat( iunpun, & - "LAMBDAM" // TRIM( cspin ), mrepl ) - ELSE IF(allocated(mrepl_c)) THEN - CALL iotk_write_dat( iunpun, & - "LAMBDAM" // TRIM( cspin ), mrepl_c ) - ENDIF - - ! - END IF - ! - ! - IF( PRESENT( mat_z ) ) THEN - ! - IF(.not.mat_z(iss)%iscmplx) THEN - IF(.not.allocated(mrepl)) THEN - ALLOCATE( mrepl( nudx, nudx ) ) - ENDIF - CALL collect_zmat( mrepl, mat_z(iss)%rvec(:,:), descla(:,iss) ) - ELSE - IF(.not.allocated(mrepl_c)) THEN - ALLOCATE( mrepl_c( nudx, nudx ) ) - ENDIF - CALL collect_zmat( mrepl_c, mat_z(iss)%cvec(:,:), descla(:,iss) ) - ENDIF - ! - IF ( ionode ) THEN - ! - filename = TRIM( wfc_filename( ".", 'mat_z', ik, iss ) ) - ! - CALL iotk_link( iunpun, "MAT_Z" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .TRUE. ) - ! - IF(.not.mat_z(iss)%iscmplx) THEN - CALL iotk_write_dat( iunpun, "MAT_Z" // TRIM( cspin ), mrepl ) - ELSE - CALL iotk_write_dat( iunpun, "MAT_Z" // TRIM( cspin ), mrepl_c ) - ENDIF - ! - END IF - ! - - END IF - ! - IF(allocated(mrepl)) THEN - DEALLOCATE( mrepl ) - ENDIF - IF(allocated(mrepl_c)) THEN - DEALLOCATE( mrepl_c ) - ENDIF - ! - END DO - ! - IF ( ionode ) & - CALL iotk_write_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - END DO k_points_loop2 - ! - IF ( ionode ) CALL iotk_write_end( iunpun, "EIGENVECTORS" ) - ! - IF ( ionode ) CALL iotk_close_write( iunpun ) - ! -!------------------------------------------------------------------------------- -! ... END RESTART SECTIONS -!------------------------------------------------------------------------------- - ! - DEALLOCATE( ftmp ) - DEALLOCATE( tau ) - DEALLOCATE( ityp ) - DEALLOCATE( mill ) - ! - CALL save_history( dirname, nfi ) - ! - s1 = cclock() - ! - IF ( ionode ) THEN - ! - WRITE( stdout, & - '(3X,"restart file written in ",F8.3," sec.",/)' ) ( s1 - s0 ) - ! - END IF - ! - RETURN - ! - END SUBROUTINE cp_writefile_twin - ! - SUBROUTINE cp_writefile_real( ndw, outdir, ascii, nfi, simtime, acc, nk, xk, & - wk, ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, & - taui, cdmi, stau0, svel0, staum, svelm, force, & - vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ0, occm, & - lambda0,lambdam, xnhe0, xnhem, vnhe, ekincm, & - et, rho, c02, cm2, ctot, iupdwn, nupdwn, & - iupdwn_tot, nupdwn_tot, mat_z ) - !------------------------------------------------------------------------ - ! - USE control_flags, ONLY : gamma_only, do_wf_cmplx, force_pairing, trhow, tksw !added:giovanni do_wf_cmplx - USE io_files, ONLY : psfile, pseudo_dir - USE mp_global, ONLY : intra_image_comm - USE printout_base, ONLY : title - USE grid_dimensions, ONLY : nr1, nr2, nr3, nr1x, nr2x - USE smooth_grid_dimensions, ONLY : nr1s, nr2s, nr3s - USE smallbox_grid_dimensions, ONLY : nr1b, nr2b, nr3b - USE gvecp, ONLY : ngm, ngmt - USE gvecs, ONLY : ngst, dual - USE gvecw, ONLY : ngw, ngwt, ecutw - USE reciprocal_vectors, ONLY : ig_l2g, mill_l - USE electrons_base, ONLY : nspin, nelt, nel, nudx - USE cell_base, ONLY : ibrav, alat, celldm, & - symm_type, s_to_r - USE ions_base, ONLY : nsp, nat, na, atm, & - amass, iforce, ind_bck - USE funct, ONLY : get_dft_name - USE energies, ONLY : enthal, ekin, eht, esr, eself, & - epseu, enl, exc, vave - USE mp, ONLY : mp_sum - USE fft_base, ONLY : dfftp - USE constants, ONLY : pi - USE cp_interfaces, ONLY : n_atom_wfc, write_hamiltonian - USE global_version, ONLY : version_number - USE cp_main_variables, ONLY : collect_lambda, descla, collect_zmat - USE input_parameters, ONLY : print_evc0_occ_empty, write_hr - USE wavefunctions_module, ONLY : c0_fixed, c0_occ_emp_aux - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ndw ! - CHARACTER(LEN=*), INTENT(IN) :: outdir ! directory used to store output and restart files - LOGICAL, INTENT(IN) :: ascii ! - INTEGER, INTENT(IN) :: nfi ! index of the current step - REAL(DP), INTENT(IN) :: simtime ! simulated time - REAL(DP), INTENT(IN) :: acc(:) ! - INTEGER, INTENT(IN) :: nk ! number of kpoints - REAL(DP), INTENT(IN) :: xk(:,:) ! k-points coordinates - REAL(DP), INTENT(IN) :: wk(:) ! k-points weights - REAL(DP), INTENT(IN) :: ht(3,3) ! - REAL(DP), INTENT(IN) :: htm(3,3) ! - REAL(DP), INTENT(IN) :: htvel(3,3) ! - REAL(DP), INTENT(IN) :: gvel(3,3) ! - REAL(DP), INTENT(IN) :: xnhh0(3,3) ! - REAL(DP), INTENT(IN) :: xnhhm(3,3) ! - REAL(DP), INTENT(IN) :: vnhh(3,3) ! - REAL(DP), INTENT(IN) :: taui(:,:) ! - REAL(DP), INTENT(IN) :: cdmi(:) ! - REAL(DP), INTENT(IN) :: stau0(:,:) ! - REAL(DP), INTENT(IN) :: svel0(:,:) ! - REAL(DP), INTENT(IN) :: staum(:,:) ! - REAL(DP), INTENT(IN) :: svelm(:,:) ! - REAL(DP), INTENT(IN) :: force(:,:) ! - REAL(DP), INTENT(IN) :: xnhp0(:) ! - REAL(DP), INTENT(IN) :: xnhpm(:) ! - REAL(DP), INTENT(IN) :: vnhp(:) ! - INTEGER, INTENT(IN) :: nhpcl ! - INTEGER, INTENT(IN) :: nhpdim ! - REAL(DP), INTENT(IN) :: occ0(:) ! occupations of electronic states - REAL(DP), INTENT(IN) :: occm(:) ! - REAL(DP), INTENT(IN) :: lambda0(:,:,:) ! - REAL(DP), INTENT(IN) :: lambdam(:,:,:) ! - REAL(DP), INTENT(IN) :: xnhe0 ! - REAL(DP), INTENT(IN) :: xnhem ! - REAL(DP), INTENT(IN) :: vnhe ! - REAL(DP), INTENT(IN) :: ekincm ! - REAL(DP), INTENT(IN) :: et(:,:) ! eigenvalues - REAL(DP), INTENT(IN) :: rho(:,:) ! - COMPLEX(DP), INTENT(IN) :: c02(:,:) ! - COMPLEX(DP), INTENT(IN) :: cm2(:,:) ! - COMPLEX(DP), INTENT(IN) :: ctot(:,:) ! - INTEGER, INTENT(IN) :: iupdwn(:) ! - INTEGER, INTENT(IN) :: nupdwn(:) ! - INTEGER, INTENT(IN) :: iupdwn_tot(:)! - INTEGER, INTENT(IN) :: nupdwn_tot(:)! - REAL(DP), OPTIONAL, INTENT(IN) :: mat_z(:,:,:) ! - ! - LOGICAL :: write_charge_density - CHARACTER(LEN=20) :: dft_name - CHARACTER(LEN=256) :: dirname, filename, rho_file_base - CHARACTER(LEN=4) :: cspin - INTEGER :: kunit, ib, ik_eff - INTEGER :: k1, k2, k3 - INTEGER :: nk1, nk2, nk3 - INTEGER :: i, iss, iss_wfc - INTEGER :: is, ia, isa, ik, ierr - INTEGER, ALLOCATABLE :: mill(:,:) - INTEGER, ALLOCATABLE :: ftmp(:,:) - INTEGER, ALLOCATABLE :: ityp(:) - REAL(DP), ALLOCATABLE :: tau(:,:) - REAL(DP), ALLOCATABLE :: dtmp(:) - REAL(DP), ALLOCATABLE :: rhoaux(:) - REAL(DP) :: omega, htm1(3,3), h(3,3) - REAL(DP) :: a1(3), a2(3), a3(3) - REAL(DP) :: b1(3), b2(3), b3(3) - REAL(DP) :: nelec - REAL(DP) :: scalef - LOGICAL :: lsda - REAL(DP) :: s0, s1, cclock - INTEGER :: nbnd_tot - INTEGER :: nbnd_emp - INTEGER :: nbnd_ - REAL(DP), ALLOCATABLE :: mrepl(:,:) - ! - write_charge_density = trhow - ! - IF( nspin > 1 .AND. .NOT. force_pairing ) THEN - ! - ! check if the array storing wave functions is large enought - ! - IF( SIZE( c02, 2 ) < ( iupdwn( 2 ) + nupdwn(1) - 1 ) ) & - CALL errore('cp_writefile',' wrong wave functions dimension ', 1 ) - ! - END IF - ! - IF( nupdwn_tot(1) < nupdwn(1) ) & - CALL errore( " writefile ", " wrong number of states ", 1 ) - ! - nbnd_ = nupdwn(1) - nbnd_tot = MAX( nupdwn(1), nupdwn_tot(1) ) - nbnd_emp = MAX( 0, nupdwn_tot(1) - nupdwn(1) ) - ! - ! - IF ( ionode ) THEN - ! - ! ... look for an empty unit (only ionode needs it) - ! - CALL iotk_free_unit( iunout, ierr ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_writefile', & - 'no free units to write wavefunctions', ierr ) - ! - dirname = restart_dir( outdir, ndw ) - ! - ! ... Create main restart directory - ! - CALL create_directory( dirname ) - ! - ! ... Create k-points subdirectories - ! ... note: in FPMD and CP k-points are not distributed to processors - ! - DO i = 1, nk - ! - CALL create_directory( kpoint_dir( dirname, i ) ) - ! - END DO - ! - ! ... Some ( CP/FPMD ) default values - ! - IF ( nspin == 2 ) THEN - ! - kunit = 2 - ! - ELSE - ! - kunit = 1 - ! - END IF - ! - k1 = 0 - k2 = 0 - k3 = 0 - nk1 = 0 - nk2 = 0 - nk3 = 0 - ! - ! ... Compute Cell related variables - ! - h = TRANSPOSE( ht ) - ! - CALL invmat( 3, ht, htm1, omega ) - ! - a1 = ht(1,:) - a2 = ht(2,:) - a3 = ht(3,:) - ! - ! ... Beware: omega may be negative if axis are left-handed! - ! - scalef = 1.D0 / SQRT( ABS (omega) ) - ! - ! ... Compute array ityp, and tau - ! - ALLOCATE( ityp( nat ) ) - ALLOCATE( tau( 3, nat ) ) - ! - isa = 0 - ! - DO is = 1, nsp - ! - DO ia = 1, na(is) - ! - isa = isa + 1 - ityp(isa) = is - ! - END DO - ! - END DO - ! - CALL s_to_r( stau0, tau, na, nsp, h ) - ! - ! ... Collect G vectors - ! - ALLOCATE( mill( 3, ngmt ) ) - ! - mill = 0 - ! - mill(:,ig_l2g(1:ngm)) = mill_l(:,1:ngm) - ! - CALL mp_sum( mill, intra_image_comm ) - ! - lsda = ( nspin == 2 ) - ! - ALLOCATE( ftmp( nbnd_tot , nspin ) ) - ! - ftmp = 0.0d0 - ! - DO iss = 1, nspin - ! - ftmp( 1:nupdwn(iss), iss ) = occ0( iupdwn(iss) : iupdwn(iss) + nupdwn(iss) - 1 ) - ! - END DO - ! - IF ( ionode ) THEN - ! - ! ... Open XML descriptor - ! - WRITE( stdout, '(/,3X,"writing restart file: ",A)' ) TRIM( dirname ) - ! - CALL iotk_open_write( iunpun, FILE = TRIM( dirname ) // '/' // & - & TRIM( xmlpun ), BINARY = .FALSE., IERR = ierr ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_writefile ', 'cannot open restart file for writing', ierr ) - ! - s0 = cclock() - ! - IF ( ionode ) THEN - -!------------------------------------------------------------------------------- -! ... HEADER -!------------------------------------------------------------------------------- - ! - CALL write_header( "CP", TRIM(version_number) ) - ! -!------------------------------------------------------------------------------- -! ... this flag is used to check if the file can be used for post-processing -!------------------------------------------------------------------------------- - ! - CALL write_control( PP_CHECK_FLAG=.TRUE. ) - ! -!------------------------------------------------------------------------------- -! ... STATUS -!------------------------------------------------------------------------------- - ! - CALL iotk_write_begin( iunpun, "STATUS" ) - ! - CALL iotk_write_attr( attr, "ITERATION", nfi, FIRST = .TRUE. ) - CALL iotk_write_empty(iunpun, "STEP", attr ) - ! - CALL iotk_write_attr( attr, "UNITS", "pico-seconds", FIRST = .TRUE. ) - CALL iotk_write_dat( iunpun, "TIME", simtime, ATTR = attr ) - ! - CALL iotk_write_dat( iunpun, "TITLE", TRIM( title ) ) - ! - CALL iotk_write_attr( attr, "UNITS", "Hartree", FIRST = .TRUE. ) - CALL iotk_write_dat( iunpun, "KINETIC_ENERGY", ekin, ATTR = attr ) - CALL iotk_write_dat( iunpun, "HARTREE_ENERGY", eht, ATTR = attr ) - CALL iotk_write_dat( iunpun, "EWALD_TERM", esr, ATTR = attr ) - CALL iotk_write_dat( iunpun, "GAUSS_SELFINT", eself, ATTR = attr ) - CALL iotk_write_dat( iunpun, "LPSP_ENERGY", epseu, ATTR = attr ) - CALL iotk_write_dat( iunpun, "NLPSP_ENERGY", enl, ATTR = attr ) - CALL iotk_write_dat( iunpun, "EXC_ENERGY", exc, ATTR = attr ) - CALL iotk_write_dat( iunpun, "AVERAGE_POT", vave, ATTR = attr ) - CALL iotk_write_dat( iunpun, "ENTHALPY", enthal, ATTR = attr ) - ! - CALL iotk_write_end( iunpun, "STATUS" ) - ! -!------------------------------------------------------------------------------- -! ... CELL -!------------------------------------------------------------------------------- - ! - a1 = a1 / alat - a2 = a2 / alat - a3 = a3 / alat - ! - CALL recips( a1, a2, a3, b1, b2, b3 ) - ! - CALL write_cell( ibrav, symm_type, & - celldm, alat, a1, a2, a3, b1, b2, b3 ) - ! -!------------------------------------------------------------------------------- -! ... IONS -!------------------------------------------------------------------------------- - ! - CALL write_ions( nsp, nat, atm, ityp(ind_bck(:)), & - psfile, pseudo_dir, amass, tau(:,ind_bck(:)), & - iforce(:,ind_bck(:)), dirname, 1.D0 ) - ! -!------------------------------------------------------------------------------- -! ... PLANE_WAVES -!------------------------------------------------------------------------------- - ! - ! change to .TRUE. to write gvectors.dat for rho - ! - CALL write_planewaves( ecutw, dual, ngwt, do_wf_cmplx, gamma_only, & - !added:giovanni do_wf_cmplx - nr1, nr2, nr3, ngmt, nr1s, nr2s, nr3s, ngst, nr1b, & - nr2b, nr3b, mill, .FALSE. ) - ! -!------------------------------------------------------------------------------- -! ... SPIN -!------------------------------------------------------------------------------- - ! - CALL write_spin( lsda, .FALSE., 1, .FALSE., .TRUE. ) - ! -!------------------------------------------------------------------------------- -! ... EXCHANGE_CORRELATION -!------------------------------------------------------------------------------- - ! - dft_name = get_dft_name() - CALL write_xc( DFT = dft_name, NSP = nsp, LDA_PLUS_U = .FALSE. ) - ! -!------------------------------------------------------------------------------- -! ... OCCUPATIONS -!------------------------------------------------------------------------------- - ! - CALL write_occ( LGAUSS = .FALSE., LTETRA = .FALSE., & - TFIXED_OCC = .TRUE., LSDA = lsda, NSTATES_UP = nupdwn_tot(1), & - NSTATES_DOWN = nupdwn_tot(2), F_INP = DBLE( ftmp ) ) - ! -!------------------------------------------------------------------------------- -! ... BRILLOUIN_ZONE -!------------------------------------------------------------------------------- - ! - CALL write_bz( nk, xk, wk, k1, k2, k3, nk1, nk2, nk3, 0.0_DP ) - ! -!------------------------------------------------------------------------------- -! ... PARALLELISM -!------------------------------------------------------------------------------- - ! - CALL iotk_write_begin( iunpun, "PARALLELISM" ) - ! - CALL iotk_write_dat( iunpun, & - "GRANULARITY_OF_K-POINTS_DISTRIBUTION", kunit ) - ! - CALL iotk_write_end( iunpun, "PARALLELISM" ) - ! - END IF - ! -!------------------------------------------------------------------------------- -! ... CHARGE-DENSITY -!------------------------------------------------------------------------------- - ! - IF (write_charge_density) then - ! - rho_file_base = 'charge-density' - ! - IF ( ionode )& - CALL iotk_link( iunpun, "CHARGE-DENSITY", rho_file_base, & - CREATE = .FALSE., BINARY = .TRUE. ) - ! - rho_file_base = TRIM( dirname ) // '/' // TRIM( rho_file_base ) - ! - IF ( nspin == 1 ) THEN - ! - CALL write_rho_xml( rho_file_base, rho(:,1), & - nr1, nr2, nr3, nr1x, nr2x, dfftp%ipp, dfftp%npp ) - ! - ELSE IF ( nspin == 2 ) THEN - ! - ALLOCATE( rhoaux( SIZE( rho, 1 ) ) ) - ! - rhoaux = rho(:,1) + rho(:,2) - ! - CALL write_rho_xml( rho_file_base, rhoaux, & - nr1, nr2, nr3, nr1x, nr2x, dfftp%ipp, dfftp%npp ) - ! - rho_file_base = 'spin-polarization' - ! - IF ( ionode ) & - CALL iotk_link( iunpun, "SPIN-POLARIZATION", rho_file_base, & - CREATE = .FALSE., BINARY = .TRUE. ) - ! - rho_file_base = TRIM( dirname ) // '/' // TRIM( rho_file_base ) - ! - rhoaux = rho(:,1) - rho(:,2) - ! - CALL write_rho_xml( rho_file_base, rhoaux, & - nr1, nr2, nr3, nr1x, nr2x, dfftp%ipp, dfftp%npp ) - ! - DEALLOCATE( rhoaux ) - ! - END IF - ! - END IF ! write_charge_density - ! -!------------------------------------------------------------------------------- -! ... TIMESTEPS -!------------------------------------------------------------------------------- - ! - IF ( ionode ) THEN - ! - CALL iotk_write_attr( attr, "nt", 2, FIRST = .TRUE. ) - ! - CALL iotk_write_begin( iunpun, "TIMESTEPS", attr ) - ! - ! ... STEP0 - ! - CALL iotk_write_begin( iunpun, "STEP0" ) - ! - CALL iotk_write_dat( iunpun, "ACCUMULATORS", acc ) - ! - CALL iotk_write_begin( iunpun, "IONS_POSITIONS" ) - CALL iotk_write_dat( iunpun, "stau", stau0(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "svel", svel0(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "taui", taui(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "cdmi", cdmi(1:3), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "force", force(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_write_begin( iunpun, "IONS_NOSE" ) - CALL iotk_write_dat( iunpun, "nhpcl", nhpcl ) - CALL iotk_write_dat( iunpun, "nhpdim", nhpdim ) - CALL iotk_write_dat( iunpun, "xnhp", xnhp0(1:nhpcl*nhpdim) ) - CALL iotk_write_dat( iunpun, "vnhp", vnhp(1:nhpcl*nhpdim) ) - CALL iotk_write_end( iunpun, "IONS_NOSE" ) - ! - CALL iotk_write_dat( iunpun, "ekincm", ekincm ) - ! - CALL iotk_write_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhe", xnhe0 ) - CALL iotk_write_dat( iunpun, "vnhe", vnhe ) - CALL iotk_write_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_write_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_write_dat( iunpun, "ht", ht ) - CALL iotk_write_dat( iunpun, "htvel", htvel ) - CALL iotk_write_dat( iunpun, "gvel", gvel ) - CALL iotk_write_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_write_begin( iunpun, "CELL_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhh", xnhh0 ) - CALL iotk_write_dat( iunpun, "vnhh", vnhh ) - CALL iotk_write_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_write_end( iunpun, "STEP0" ) - ! - ! ... STEPM - ! - CALL iotk_write_begin( iunpun, "STEPM" ) - ! - CALL iotk_write_begin( iunpun, "IONS_POSITIONS" ) - CALL iotk_write_dat( iunpun, "stau", staum(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "svel", svelm(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_write_begin( iunpun, "IONS_NOSE" ) - CALL iotk_write_dat( iunpun, "nhpcl", nhpcl ) - CALL iotk_write_dat( iunpun, "nhpdim", nhpdim ) - CALL iotk_write_dat( iunpun, "xnhp", xnhpm(1:nhpcl*nhpdim) ) - CALL iotk_write_end( iunpun, "IONS_NOSE" ) - ! - CALL iotk_write_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhe", xnhem ) - CALL iotk_write_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_write_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_write_dat( iunpun, "ht", htm ) - CALL iotk_write_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_write_begin( iunpun, "CELL_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhh", xnhhm ) - CALL iotk_write_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_write_end( iunpun, "STEPM" ) - ! - CALL iotk_write_end( iunpun, "TIMESTEPS" ) - ! - END IF - -!------------------------------------------------------------------------------- -! ... BAND_STRUCTURE_INFO -!------------------------------------------------------------------------------- - - IF ( ionode ) THEN - - ! - CALL iotk_write_begin( iunpun, "BAND_STRUCTURE_INFO" ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_ATOMIC_WFC", n_atom_wfc() ) - ! - nelec = nelt - ! - IF ( nspin == 2 ) THEN - ! - CALL iotk_write_attr( attr, "UP", nel(1), FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "DW", nel(2) ) - CALL iotk_write_dat( iunpun, & - "NUMBER_OF_ELECTRONS", nelec, ATTR = attr ) - ! - CALL iotk_write_attr( attr, "UP", nupdwn_tot(1), FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "DW", nupdwn_tot(2) ) - CALL iotk_write_dat( iunpun, & - "NUMBER_OF_BANDS", nbnd_tot , ATTR = attr ) - ! - ELSE - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_ELECTRONS", nelec ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_BANDS", nbnd_tot ) - ! - END IF - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_EMPTY_STATES", nbnd_emp ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_SPIN_COMPONENTS", nspin ) - ! - CALL iotk_write_end( iunpun, "BAND_STRUCTURE_INFO" ) - ! - CALL iotk_write_begin( iunpun, "EIGENVALUES" ) - ! - ! - END IF - ! -!------------------------------------------------------------------------------- -! ... EIGENVALUES -!------------------------------------------------------------------------------- - ! - k_points_loop1: DO ik = 1, nk - ! - IF ( ionode ) THEN - ! - CALL iotk_write_begin( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - CALL iotk_write_attr( attr, "UNITS", "2 pi / a", FIRST = .TRUE. ) - CALL iotk_write_dat( iunpun, & - "K-POINT_COORDS", xk(:,ik), ATTR = attr ) - ! - CALL iotk_write_dat( iunpun, "WEIGHT", wk(ik) ) - ! - ALLOCATE( dtmp ( nbnd_tot ) ) - ! - DO iss = 1, nspin - ! - cspin = iotk_index( iss ) - ! - dtmp = 0.0d0 - ! - IF( tksw ) THEN - ! - ! writes data required by postproc and PW - ! - IF( nspin == 2 ) THEN - IF( iss == 1 ) filename = wfc_filename( ".", 'eigenval1', ik, EXTENSION='xml' ) - IF( iss == 2 ) filename = wfc_filename( ".", 'eigenval2', ik, EXTENSION='xml' ) - ! - IF( iss == 1 ) CALL iotk_link( iunpun, "DATAFILE.1", & - filename, CREATE = .FALSE., BINARY = .FALSE. ) - IF( iss == 2 ) CALL iotk_link( iunpun, "DATAFILE.2", & - filename, CREATE = .FALSE., BINARY = .FALSE. ) - - IF( iss == 1 ) filename = wfc_filename( dirname, 'eigenval1', ik, EXTENSION='xml' ) - IF( iss == 2 ) filename = wfc_filename( dirname, 'eigenval2', ik, EXTENSION='xml' ) - ELSE - filename = wfc_filename( ".", 'eigenval', ik, EXTENSION='xml' ) - CALL iotk_link( iunpun, "DATAFILE", filename, CREATE = .FALSE., BINARY = .FALSE. ) - filename = wfc_filename( dirname, 'eigenval', ik, EXTENSION='xml' ) - END IF - - dtmp ( 1:nupdwn( iss ) ) = occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) / wk(ik) - ! - CALL write_eig( iunout, filename, nbnd_tot, et( 1:nbnd_tot, iss) , "Hartree", & - OCC = dtmp(:), IK=ik, ISPIN=iss ) - ! - END IF - ! - CALL iotk_write_dat( iunpun, "OCC0" // TRIM( cspin ), & - occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) ) - ! - CALL iotk_write_dat( iunpun, "OCCM" // TRIM( cspin ), & - occm( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) ) - ! - END DO - ! - DEALLOCATE( dtmp ) - ! - CALL iotk_write_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - - END IF - ! - END DO k_points_loop1 - ! - IF ( ionode ) THEN - ! - CALL iotk_write_end( iunpun, "EIGENVALUES" ) - ! - CALL iotk_write_begin( iunpun, "EIGENVECTORS" ) - ! - CALL iotk_write_dat ( iunpun, "MAX_NUMBER_OF_GK-VECTORS", ngwt ) - ! - END IF - ! -!------------------------------------------------------------------------------- -! ... EIGENVECTORS -!------------------------------------------------------------------------------- - ! - k_points_loop2: DO ik = 1, nk - - IF( ionode ) THEN - - CALL iotk_write_begin( iunpun, "K-POINT" // TRIM( iotk_index( ik ) ) ) - ! - ! ... G+K vectors - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_GK-VECTORS", ngwt ) - ! - ! - filename = TRIM( wfc_filename( ".", 'gkvectors', ik ) ) - ! - CALL iotk_link( iunpun, "GK-VECTORS", filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - filename = TRIM( wfc_filename( dirname, 'gkvectors', ik ) ) - ! - END IF - ! - CALL write_gk( iunout, mill, filename ) - ! - DO iss = 1, nspin - ! - ik_eff = ik + ( iss - 1 ) * nk - ! - iss_wfc = iss - if( force_pairing ) iss_wfc = 1 ! only the WF for the first spin is allocated - ! - IF( tksw ) THEN - ! - ! Save additional WF, - ! orthogonal KS states to be used for post processing and PW - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc', ik, iss ) ) - ! - END IF - ! - IF( nspin == 2 ) THEN - CALL iotk_link( iunpun, "WFC" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ELSE - CALL iotk_link( iunpun, "WFC", filename, CREATE = .FALSE., BINARY = .TRUE. ) - END IF - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn_tot( iss_wfc ) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - ctot( :, ib : ib + nbnd_tot - 1 ), ngwt, do_wf_cmplx, gamma_only,& !added:giovanni do_wf_cmplx - nbnd_tot, ig_l2g, ngw, filename, scalef ) - ! - ! - ! - END IF - ! - ! Save wave function at time t - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc0', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc0', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFC0" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc0', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc0', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - c02( :, ib : ib + nbnd_ - 1 ), ngwt, do_wf_cmplx, gamma_only, & !added:giovanni do_wf_cmplx - nbnd_, ig_l2g, ngw, filename, scalef ) - ! - ! Save wave function at time t - dt - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evcm', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evcm', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFCM" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evcm', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evcm', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - cm2( :, ib : ib + nbnd_ - 1 ), ngwt, do_wf_cmplx, gamma_only, & - nbnd_, ig_l2g, ngw, filename, scalef ) - ! - ! Save fixed wave function - ! - IF (.false.) THEN - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc0fixed', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc0fixed', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFC0FIXED" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc0fixed', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc0fixed', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - c0_fixed( :, ib : ib + nbnd_ - 1 ), ngwt, do_wf_cmplx, & !added:giovanni do_wf_cmplx - gamma_only, nbnd_, ig_l2g, ngw, filename, scalef) - ! - ENDIF - ! - IF (print_evc0_occ_empty .and. (nbnd_emp>0) ) THEN - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc0_occ_empty', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc0_occ_empty', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFC0_OCC_EMPTY" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc0_occ_empty', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc0_occ_empty', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn_tot( iss_wfc ) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - c0_occ_emp_aux( :, ib : ib + nbnd_tot - 1 ), ngwt, do_wf_cmplx, & !added:giovanni do_wf_cmplx - gamma_only, nbnd_emp, ig_l2g, ngw, filename, scalef) - ! - ENDIF - ! - cspin = iotk_index( iss ) - ! - ! ... write matrix lambda to file - ! - ALLOCATE( mrepl( nudx, nudx ) ) - ! - CALL collect_lambda( mrepl, lambda0(:,:,iss), descla(:,iss) ) - ! - IF ( ionode ) THEN - ! - filename = TRIM( wfc_filename( ".", 'lambda0', ik, iss ) ) - ! - CALL iotk_link( iunpun, "LAMBDA0" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .TRUE. ) - ! - CALL iotk_write_dat( iunpun, & - "LAMBDA0" // TRIM( cspin ), mrepl ) - ! - ! Changes by Nicolas Poilvert, Sep. 2010 for printing the lambda - ! matrix at current time step into a formatted file. - ! This matrix corresponds to the Hamiltonian matrix in the case - ! of Self-Interaction. Only in the basis of minimizing orbitals - ! do this matrix has an interpretation. - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'hamiltonian', ik, EXTENSION='xml' ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'hamiltonian', ik, iss, EXTENSION='xml' ) ) - ! - ENDIF - ! - CALL iotk_link( iunpun, "HAMILTONIAN" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .FALSE. ) - ! - CALL iotk_write_dat( iunpun, & - "HAMILTONIAN" // TRIM( cspin ), mrepl ) - IF ( write_hr ) CALL write_hamiltonian( mrepl, nupdwn(iss), iss, .false. ) - ! - END IF - ! - CALL collect_lambda( mrepl, lambdam(:,:,iss), descla(:,iss) ) - ! - IF ( ionode ) THEN - ! - filename = TRIM( wfc_filename( ".", 'lambdam', ik, iss ) ) - ! - CALL iotk_link( iunpun, "LAMBDAM" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .TRUE. ) - ! - CALL iotk_write_dat( iunpun, & - "LAMBDAM" // TRIM( cspin ), mrepl ) - ! - END IF - ! - IF( PRESENT( mat_z ) ) THEN - ! - CALL collect_zmat( mrepl, mat_z(:,:,iss), descla(:,iss) ) - ! - IF ( ionode ) THEN - ! - filename = TRIM( wfc_filename( ".", 'mat_z', ik, iss ) ) - ! - CALL iotk_link( iunpun, "MAT_Z" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .TRUE. ) - ! - CALL iotk_write_dat( iunpun, "MAT_Z" // TRIM( cspin ), mrepl ) - ! - END IF - ! - END IF - ! - DEALLOCATE( mrepl ) - ! - END DO - ! - IF ( ionode ) & - CALL iotk_write_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - END DO k_points_loop2 - ! - IF ( ionode ) CALL iotk_write_end( iunpun, "EIGENVECTORS" ) - ! - IF ( ionode ) CALL iotk_close_write( iunpun ) - ! -!------------------------------------------------------------------------------- -! ... END RESTART SECTIONS -!------------------------------------------------------------------------------- - ! - DEALLOCATE( ftmp ) - DEALLOCATE( tau ) - DEALLOCATE( ityp ) - DEALLOCATE( mill ) - ! - CALL save_history( dirname, nfi ) - ! - s1 = cclock() - ! - IF ( ionode ) THEN - ! - WRITE( stdout, & - '(3X,"restart file written in ",F8.3," sec.",/)' ) ( s1 - s0 ) - ! - END IF - ! - RETURN - ! - END SUBROUTINE cp_writefile_real - - !------------------------------------------------------------------------ - SUBROUTINE cp_readfile_real( ndr, outdir, ascii, nfi, simtime, acc, nk, xk, & - wk, ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, & - taui, cdmi, stau0, svel0, staum, svelm, force, & - vnhp, xnhp0, xnhpm, nhpcl,nhpdim,occ0, occm, & - lambda0, lambdam, b1, b2, b3, xnhe0, xnhem, vnhe, & - ekincm, c02, cm2, mat_z ) - !------------------------------------------------------------------------ - ! - USE control_flags, ONLY : force_pairing - USE io_files, ONLY : iunpun, xmlpun - USE printout_base, ONLY : title - USE gvecw, ONLY : ngw - USE electrons_base, ONLY : nspin, nelt, nel, & - nupdwn, iupdwn, nudx - USE cell_base, ONLY : s_to_r, r_to_s - USE ions_base, ONLY : nsp, nat, na, & - sort_tau, ityp, ions_cofmass - USE reciprocal_vectors, ONLY : ig_l2g - USE cp_main_variables, ONLY : nprint_nfi, distribute_lambda, descla, distribute_zmat - USE mp, ONLY : mp_sum - USE mp_global, ONLY : intra_image_comm - USE parameters, ONLY : ntypx - USE constants, ONLY : eps8, angstrom_au, pi - USE input_parameters, ONLY : restart_from_wannier_cp, restart_from_wannier_pwscf, wannier_empty_only - USE wavefunctions_module, ONLY : c0_fixed, ctot_aux - USE electrons_module, ONLY : nupdwn_emp - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ndr ! I/O unit number - CHARACTER(LEN=*), INTENT(IN) :: outdir ! - LOGICAL, INTENT(IN) :: ascii ! - INTEGER, INTENT(INOUT) :: nfi ! index of the current step - REAL(DP), INTENT(INOUT) :: simtime ! simulated time - REAL(DP), INTENT(INOUT) :: acc(:) ! - INTEGER, INTENT(IN) :: nk ! number of kpoints - REAL(DP), INTENT(INOUT) :: xk(:,:) ! k-points coordinates - REAL(DP), INTENT(INOUT) :: wk(:) ! k-points weights - REAL(DP), INTENT(INOUT) :: ht(3,3) ! - REAL(DP), INTENT(INOUT) :: htm(3,3) ! - REAL(DP), INTENT(INOUT) :: htvel(3,3) ! - REAL(DP), INTENT(INOUT) :: gvel(3,3) ! - REAL(DP), INTENT(INOUT) :: xnhh0(3,3) ! - REAL(DP), INTENT(INOUT) :: xnhhm(3,3) ! - REAL(DP), INTENT(INOUT) :: vnhh(3,3) ! - REAL(DP), INTENT(INOUT) :: taui(:,:) ! - REAL(DP), INTENT(INOUT) :: cdmi(:) ! - REAL(DP), INTENT(INOUT) :: stau0(:,:) ! - REAL(DP), INTENT(INOUT) :: svel0(:,:) ! - REAL(DP), INTENT(INOUT) :: staum(:,:) ! - REAL(DP), INTENT(INOUT) :: svelm(:,:) ! - REAL(DP), INTENT(INOUT) :: force(:,:) ! - REAL(DP), INTENT(INOUT) :: xnhp0(:) ! - REAL(DP), INTENT(INOUT) :: xnhpm(:) ! - REAL(DP), INTENT(INOUT) :: vnhp(:) ! - INTEGER, INTENT(INOUT) :: nhpcl ! - INTEGER, INTENT(INOUT) :: nhpdim ! - REAL(DP), INTENT(INOUT) :: occ0(:) ! occupations - REAL(DP), INTENT(INOUT) :: occm(:) ! - REAL(DP), INTENT(INOUT) :: lambda0(:,:,:) ! - REAL(DP), INTENT(INOUT) :: lambdam(:,:,:) ! - REAL(DP), INTENT(INOUT) :: b1(3) ! - REAL(DP), INTENT(INOUT) :: b2(3) ! - REAL(DP), INTENT(INOUT) :: b3(3) ! - REAL(DP), INTENT(INOUT) :: xnhe0 ! - REAL(DP), INTENT(INOUT) :: xnhem ! - REAL(DP), INTENT(INOUT) :: vnhe ! - REAL(DP), INTENT(INOUT) :: ekincm ! - COMPLEX(DP), INTENT(INOUT) :: c02(:,:) ! - COMPLEX(DP), INTENT(INOUT) :: cm2(:,:) ! - REAL(DP), OPTIONAL, INTENT(INOUT) :: mat_z(:,:,:) ! - ! - CHARACTER(LEN=256) :: dirname, filename - CHARACTER(LEN=4) :: cspin - INTEGER :: kunit - INTEGER :: i, iss, ierr, ik - REAL(DP) :: omega, htm1(3,3), hinv(3,3), scalef - LOGICAL :: found - ! - ! ... variables read for testing pourposes - ! - INTEGER :: ibrav_ - CHARACTER(LEN=9) :: symm_type_ - CHARACTER(LEN=3) :: atm_(ntypx) - INTEGER :: nat_, nsp_ - INTEGER :: nt_ - LOGICAL :: lsda_ !added:giovanni do_wf_cmplx - REAL(DP) :: alat_, a1_(3), a2_(3), a3_(3) - REAL(DP) :: celldm_(6) - INTEGER :: iss_, nspin_, ngwt_, nbnd_ , n_emp_ , nbnd_tot - INTEGER :: nstates_up_ , nstates_dw_ , nel_(2) - REAL(DP) :: nelec_ - REAL(DP) :: scalef_ - REAL(DP) :: wk_ - INTEGER :: nhpcl_, nhpdim_ - INTEGER :: ib, nb - INTEGER :: ik_eff - REAL(DP) :: amass_(ntypx) - INTEGER, ALLOCATABLE :: ityp_(:) - INTEGER, ALLOCATABLE :: isrt_(:) - REAL(DP), ALLOCATABLE :: tau_(:,:) - REAL(DP), ALLOCATABLE :: occ_(:) - INTEGER, ALLOCATABLE :: if_pos_(:,:) - CHARACTER(LEN=256) :: psfile_(ntypx) - CHARACTER(LEN=80) :: pos_unit - REAL(DP) :: s1, s0, cclock - REAL(DP), ALLOCATABLE :: mrepl(:,:) - INTEGER :: nupdwn_tot( 2 ), iupdwn_tot( 2 ), nbnd_tot_tmp - - ! - ! ... look for an empty unit - ! - CALL iotk_free_unit( iunout, ierr ) - ! - CALL errore( 'cp_readfile', & - 'no free units to read wavefunctions', ierr ) - ! - kunit = 1 - found = .FALSE. - ! - dirname = restart_dir( outdir, ndr ) - ! - ! ... Open XML descriptor - ! - IF ( ionode ) THEN - ! - filename = TRIM( dirname ) // '/' // TRIM( xmlpun ) - ! - WRITE( stdout, '(/,3X,"reading restart file: ",A)' ) TRIM( dirname ) - ! - CALL iotk_open_read( iunpun, FILE = TRIM( filename ), IERR = ierr ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_readfile', & - 'cannot open restart file for reading', ierr ) - ! - s0 = cclock() - ! - IF ( ionode ) THEN - ! - qexml_version = " " - ! - CALL iotk_scan_begin( iunpun, "HEADER", FOUND=found ) - ! - IF ( found ) THEN - ! - CALL iotk_scan_empty( iunpun, "FORMAT", ATTR=attr ) - CALL iotk_scan_attr( attr, "VERSION", qexml_version ) - CALL iotk_scan_end( iunpun, "HEADER" ) - ! - ELSE - ! - qexml_version = TRIM( default_fmt_version ) - ! - ENDIF - ! - qexml_version_init = .TRUE. - - ! - ! init logical variables for versioning - ! - qexml_version_before_1_4_0 = .FALSE. - ! - IF ( TRIM( version_compare( qexml_version, "1.4.0" )) == "older" ) & - qexml_version_before_1_4_0 = .TRUE. - ! - ENDIF - ! - CALL mp_bcast( qexml_version, ionode_id, intra_image_comm ) - CALL mp_bcast( qexml_version_init, ionode_id, intra_image_comm ) - CALL mp_bcast( qexml_version_before_1_4_0 , ionode_id, intra_image_comm ) - ! - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "STATUS", FOUND = found ) - ! - IF ( found ) THEN - ! - CALL iotk_scan_empty( iunpun, "STEP", attr ) - CALL iotk_scan_attr( attr, "ITERATION", nfi ) - CALL iotk_scan_dat( iunpun, "TIME", simtime ) - CALL iotk_scan_dat( iunpun, "TITLE", title ) - CALL iotk_scan_end( iunpun, "STATUS" ) - ! - END IF - ! - END IF - ! - ! ... Read cell and positions - ! - ALLOCATE( tau_( 3, nat ) ) - ALLOCATE( if_pos_( 3, nat ) ) - ALLOCATE( ityp_( nat ) ) - ! - IF ( ionode ) THEN - ! - CALL read_cell( ibrav_, symm_type_, celldm_, & - alat_, a1_, a2_, a3_, b1, b2, b3 ) - ! - CALL recips( a1_, a2_, a3_, b1, b2, b3 ) - ! - END IF - ! - IF ( ionode ) THEN - ! - CALL read_ions( nsp_, nat_, atm_, ityp_, & - psfile_, amass_, tau_, if_pos_, pos_unit, ierr ) - ! - IF ( ierr == 0 ) THEN - ! - IF( nsp_ /= nsp .OR. nat_ /= nat ) ierr = 2 - ! - DO i = 1, nat - ! - IF ( ityp_(i) /= ityp(i) ) ierr = 3 - ! - END DO - ! - END IF - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_readfile', & - 'cannot read positions from restart file', ierr ) - ! - ! Read SPIN infos - ! - lsda_ = ( nspin == 2 ) - ! - IF( ionode ) THEN - CALL iotk_scan_begin( iunpun, "SPIN", FOUND = found ) - IF( found ) THEN - CALL iotk_scan_dat( iunpun, "LSDA", lsda_ ) - CALL iotk_scan_end( iunpun, "SPIN" ) - END IF - END IF - ! - CALL mp_bcast( lsda_ , ionode_id, intra_image_comm ) - ! - IF( lsda_ .AND. nspin == 1 ) & - CALL errore( 'cp_readfile', 'LSDA restart file with a spinless run', ierr ) - - ! - ! Read Occupations infos - ! - nstates_up_ = nupdwn( 1 ) - nstates_dw_ = nupdwn( 2 ) - - IF( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "OCCUPATIONS", FOUND = found ) - IF( found ) THEN - ! - CALL iotk_scan_empty( iunpun, "INFO", attr, FOUND = found ) - ! - IF( lsda_ .AND. found ) THEN - ! - IF ( qexml_version_before_1_4_0 ) THEN - ! - CALL iotk_scan_attr( attr, "nelup", nstates_up_ ) - CALL iotk_scan_attr( attr, "neldw", nstates_dw_ ) - ! - ELSE - ! - ! current version - ! - CALL iotk_scan_attr( attr, "nstates_up", nstates_up_ ) - CALL iotk_scan_attr( attr, "nstates_down", nstates_dw_ ) - ! - ENDIF - ! - ENDIF - ! - CALL iotk_scan_end( iunpun, "OCCUPATIONS" ) - ! - ENDIF - ENDIF - ! - CALL mp_bcast( nstates_up_ , ionode_id, intra_image_comm ) - CALL mp_bcast( nstates_dw_ , ionode_id, intra_image_comm ) - ! - IF( lsda_ ) THEN - IF( ( nstates_up_ /= nupdwn( 1 ) ) .OR. ( nstates_dw_ /= nupdwn( 2 ) ) ) & - CALL errore( 'cp_readfile', 'inconsistent number of spin states', ierr ) - END IF - - ! ... read MD timesteps variables - ! - IF ( ionode ) & - CALL iotk_scan_begin( iunpun, "TIMESTEPS", attr, FOUND = found ) - ! - ierr = 0 - ! - IF ( ionode .AND. found ) THEN - ! - CALL iotk_scan_attr( attr, "nt", nt_ ) - ! - IF ( nt_ > 0 ) THEN - ! - CALL iotk_scan_begin( iunpun, "STEP0" ) - ! - CALL iotk_scan_dat( iunpun, "ACCUMULATORS", acc ) - ! - CALL iotk_scan_begin( iunpun,"IONS_POSITIONS" ) - CALL iotk_scan_dat( iunpun, "stau", stau0(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "svel", svel0(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "taui", taui(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "cdmi", cdmi(1:3) ) - CALL iotk_scan_dat( iunpun, "force", force(1:3,1:nat) ) - CALL iotk_scan_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_scan_begin( iunpun, "IONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "nhpcl", nhpcl_ ) - CALL iotk_scan_dat( iunpun, "nhpdim", nhpdim_ ) - ! - IF ( nhpcl_ == nhpcl .AND. nhpdim_ == nhpdim ) THEN - ! - CALL iotk_scan_dat( iunpun, "xnhp", xnhp0(1:nhpcl*nhpdim) ) - CALL iotk_scan_dat( iunpun, "vnhp", vnhp(1:nhpcl*nhpdim) ) - ! - ELSE - ! - xnhp0(1:nhpcl*nhpdim) = 0.D0 - vnhp(1:nhpcl*nhpdim) = 0.D0 - ! - END IF - ! - CALL iotk_scan_end( iunpun, "IONS_NOSE" ) - ! - CALL iotk_scan_dat( iunpun, "ekincm", ekincm ) - ! - CALL iotk_scan_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhe", xnhe0 ) - CALL iotk_scan_dat( iunpun, "vnhe", vnhe ) - CALL iotk_scan_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_scan_dat( iunpun, "ht", ht ) - CALL iotk_scan_dat( iunpun, "htvel", htvel ) - CALL iotk_scan_dat( iunpun, "gvel", gvel ) - CALL iotk_scan_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhh", xnhh0 ) - CALL iotk_scan_dat( iunpun, "vnhh", vnhh ) - CALL iotk_scan_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_scan_end( iunpun, "STEP0" ) - ! - ELSE - ! - ierr = 40 - ! - GOTO 100 - ! - END IF - ! - IF ( nt_ > 1 ) THEN - ! - CALL iotk_scan_begin( iunpun, "STEPM" ) - ! - CALL iotk_scan_begin( iunpun, "IONS_POSITIONS" ) - CALL iotk_scan_dat( iunpun, "stau", staum(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "svel", svelm(1:3,1:nat) ) - CALL iotk_scan_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_scan_begin( iunpun, "IONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "nhpcl", nhpcl_ ) - CALL iotk_scan_dat( iunpun, "nhpdim", nhpdim_ ) - ! - IF ( nhpcl_ == nhpcl .AND. nhpdim_ == nhpdim ) THEN - ! - CALL iotk_scan_dat( iunpun, "xnhp", xnhpm(1:nhpcl*nhpdim) ) - ! - ELSE - ! - xnhpm(1:nhpcl*nhpdim) = 0.D0 - ! - END IF - ! - CALL iotk_scan_end( iunpun,"IONS_NOSE" ) - ! - CALL iotk_scan_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhe", xnhem ) - CALL iotk_scan_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_scan_dat( iunpun, "ht", htm ) - CALL iotk_scan_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhh", xnhhm ) - CALL iotk_scan_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_scan_end( iunpun, "STEPM" ) - ! - END IF - ! - CALL iotk_scan_end( iunpun, "TIMESTEPS" ) - ! - ELSE IF ( ionode ) THEN - ! - ! ... MD time steps not found, try to recover from CELL and POSITIONS - ! - acc = 0.D0 - ! - ALLOCATE( isrt_( nat ) ) - ! - SELECT CASE( TRIM( pos_unit ) ) - CASE( "alat" ) - ! - tau_ = tau_ * alat_ - ! - CASE( "Angstrom" ) - ! - tau_ = tau_ * angstrom_au - ! - CASE DEFAULT - ! - END SELECT - ! - CALL sort_tau( taui, isrt_ , tau_ , ityp_ , nat_ , nsp_ ) - ! - ht(1,:) = a1_ - ht(2,:) = a2_ - ht(3,:) = a3_ - ! - CALL invmat( 3, ht, htm1, omega ) - ! - hinv = TRANSPOSE( htm1 ) - ! - CALL r_to_s( taui, stau0, na, nsp, hinv ) - ! - CALL ions_cofmass( taui, amass_ , na, nsp, cdmi ) - ! - staum = stau0 - svel0 = 0.D0 - svelm = 0.D0 - force = 0.D0 - ! - htm = ht - htvel = 0.D0 - gvel = 0.D0 - xnhh0 = 0.D0 - vnhh = 0.D0 - xnhhm = 0.D0 - ! - xnhe0 = 0.D0 - xnhem = 0.D0 - vnhe = 0.D0 - ! - ekincm = 0.D0 - ! - xnhp0 = 0.D0 - xnhpm = 0.D0 - vnhp = 0.D0 - ! - DEALLOCATE( isrt_ ) - ! - END IF - ! - 100 CONTINUE - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - IF( ierr /= 0 ) THEN - CALL mp_bcast( attr, ionode_id, intra_image_comm ) - CALL errore( 'cp_readfile ', TRIM( attr ), ierr ) - END IF - ! - DEALLOCATE( tau_ ) - DEALLOCATE( if_pos_ ) - DEALLOCATE( ityp_ ) - ! - ! ... compute the scale factor - ! - IF ( ionode ) CALL invmat( 3, ht, htm1, omega ) - ! - CALL mp_bcast( omega, ionode_id, intra_image_comm ) - ! - ! ... Beware: omega may be negative if axis are left-handed! - ! - scalef = 1.D0 / SQRT( ABS( omega ) ) - ! - ! ... band Structure - ! - IF ( ionode ) THEN - ! - ierr = 0 - ! - CALL iotk_scan_begin( iunpun, "BAND_STRUCTURE_INFO" ) - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_SPIN_COMPONENTS", nspin_ ) - ! - IF ( nspin_ /= nspin ) THEN - attr = "spin do not match" - ierr = 31 - GOTO 90 - END IF - ! - IF ( nspin == 2 ) THEN - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_ELECTRONS", nelec_, ATTR = attr ) - CALL iotk_scan_attr( attr, "UP", nel_(1) ) - CALL iotk_scan_attr( attr, "DW", nel_(2) ) - ! - IF ( ( nel(1) /= nel_(1) ) .OR. ( nel(2) /= nel_(2) ) .OR. ( NINT( nelec_ ) /= nelt ) ) THEN - attr = "electrons do not match" - write(0,*) "from cp_readfile warning: electrons do not match" - write(6,*) "from cp_readfile warning: electrons do not match" - !ierr = 33 - GOTO 90 - END IF - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_BANDS", nbnd_tot , ATTR = attr ) - ! - ELSE - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_ELECTRONS", nelec_ ) - ! - IF ( NINT( nelec_ ) /= nelt ) THEN - attr = "electrons do not match" - ierr = 33 - GOTO 90 - END IF - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_BANDS", nbnd_tot ) - ! - END IF - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_EMPTY_STATES", n_emp_, FOUND = found ) - ! - IF( .NOT. found ) n_emp_ = 0 - ! - nbnd_ = nbnd_tot - n_emp_ - ! - IF ( nbnd_ < nupdwn(1) ) THEN - attr = "nbnd do not match" - ierr = 32 - GOTO 90 - END IF - ! - CALL iotk_scan_end( iunpun, "BAND_STRUCTURE_INFO" ) - ! - END IF - ! - 90 CONTINUE - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - IF( ierr /= 0 ) THEN - CALL mp_bcast( attr, ionode_id, intra_image_comm ) - CALL errore( 'cp_readfile ', TRIM( attr ), ierr ) - END IF - ! - IF( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "EIGENVALUES" ) - ! - END IF - ! - k_points_loop1: DO ik = 1, nk - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - CALL iotk_scan_dat( iunpun, "WEIGHT", wk_ ) - ! - END IF - ! - DO iss = 1, nspin - ! - cspin = iotk_index( iss ) - ! - ik_eff = ik + ( iss - 1 ) * nk - ! - IF ( ionode ) THEN - ! - ALLOCATE( occ_ ( MAX( nudx , nbnd_tot ) ) ) - ! - occ_ = 0.0d0 - ! - CALL iotk_scan_dat( iunpun, "OCC0" // TRIM( cspin ), occ_ ( 1 : nupdwn( iss ) ), FOUND = found ) - ! - IF( .NOT. found ) THEN - ! - IF( nspin == 1 ) THEN - CALL iotk_scan_begin( iunpun, "DATAFILE", FOUND = found ) - ELSE - CALL iotk_scan_begin( iunpun, "DATAFILE//TRIM(cspin)", FOUND = found ) - END IF - ! - CALL iotk_scan_dat ( iunpun, "OCCUPATIONS", occ_( 1:nbnd_tot ) ) - ! - IF( nspin == 1 ) THEN - CALL iotk_scan_end( iunpun, "DATAFILE" ) - ELSE - CALL iotk_scan_end( iunpun, "DATAFILE//TRIM(cspin)" ) - END IF - ! - IF( found ) THEN - occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) * wk_ - occm( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) * wk_ - END IF - ! - ELSE - ! - occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) - ! - CALL iotk_scan_dat( iunpun, "OCCM" // TRIM( cspin ), occ_ ( 1 : nupdwn( iss ) ), FOUND = found ) - ! - IF( found ) THEN - occm( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) - END IF - ! - END IF - ! - DEALLOCATE ( occ_ ) - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( .NOT. found ) & - CALL errore( " readfile ", " occupation numbers not found! ", 1 ) - ! - END DO - - IF ( ionode ) CALL iotk_scan_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - END DO k_points_loop1 - - IF ( ionode ) THEN - CALL iotk_scan_end ( iunpun, "EIGENVALUES" ) - CALL iotk_scan_begin( iunpun, "EIGENVECTORS" ) - END IF - ! - k_points_loop2: DO ik = 1, nk - ! - IF ( ionode ) THEN - CALL iotk_scan_begin( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - END IF - ! - DO iss = 1, nspin - ! - ! by linh, here is read evc from file for restarting with wannier orbitals. - ! - IF (restart_from_wannier_cp .and. .not. wannier_empty_only .and. .not. restart_from_wannier_pwscf) THEN - ! - nupdwn_tot(:) = nupdwn(:) + nupdwn_emp(:) - iupdwn_tot(1) = iupdwn(1) - iupdwn_tot(2) = nupdwn_tot(1) + 1 - nbnd_tot_tmp = MAX( nupdwn(1), nupdwn_tot(1) ) - ! - IF (.NOT. allocated(ctot_aux) ) ALLOCATE( ctot_aux( SIZE( c02, 1 ), nupdwn_tot(1) * nspin ) ) ! - ! - IF ( ionode ) THEN - ! - IF( nspin == 2 ) THEN - ! - CALL iotk_scan_begin( iunpun, "WFC" // TRIM( iotk_index (iss) ), FOUND = found ) - filename = "WFC" // TRIM( iotk_index (iss) ) - ! - ELSE - ! - CALL iotk_scan_begin( iunpun, "WFC", FOUND = found ) - filename = "WFC" - ! - ENDIF - ! - ENDIF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF ( .NOT. found ) & - CALL errore( " readfile ", " wave functions not found! ", 1 ) - ! - IF ( .NOT. ( iss > 1 .AND. force_pairing ) ) THEN - ! - ! Only WF with spin 1 are needed when force_pairing is active - ! - ib = iupdwn_tot(iss) - nb = nupdwn_tot(iss) - ! - ! filename is not needed we are following the link! - ! - CALL read_wfc( iunpun, ik_eff , nk, kunit, iss_, nspin_, & - ctot_aux( :, ib:ib+nb-1 ), ngwt_, nbnd_tot_tmp, ig_l2g, ngw, & - filename, scalef_, .TRUE. ) - ! - ENDIF - ! - IF ( ionode ) & - CALL iotk_scan_end( iunpun, TRIM(filename) ) - ! - ENDIF - ! - ! by linh, done - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "WFC0" // TRIM( iotk_index (iss) ), FOUND = found ) - ! - filename = "WFC0" // TRIM( iotk_index (iss) ) - ! - IF( .NOT. found ) THEN - ! - IF( nspin == 2 ) THEN - CALL iotk_scan_begin( iunpun, "WFC" // TRIM( iotk_index (iss) ), FOUND = found ) - filename = "WFC" // TRIM( iotk_index (iss) ) - ELSE - CALL iotk_scan_begin( iunpun, "WFC", FOUND = found ) - filename = "WFC" - END IF - ! - END IF - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( .NOT. found ) & - CALL errore( " readfile ", " wave functions not found! ", 1 ) - ! - IF( .NOT. ( iss > 1 .AND. force_pairing ) ) THEN - ! - ! Only WF with spin 1 are needed when force_pairing is active - ! - ib = iupdwn(iss) - nb = nupdwn(iss) - ! - ! filename is not needed we are following the link! - ! - CALL read_wfc( iunpun, ik_eff , nk, kunit, iss_, nspin_, & - c02( :, ib:ib+nb-1 ), ngwt_, nbnd_, ig_l2g, ngw, & - filename, scalef_, .TRUE. ) - ! - END IF - ! - IF ( ionode ) & - CALL iotk_scan_end( iunpun, TRIM(filename) ) - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "WFCM" // TRIM( iotk_index (iss) ), FOUND = found ) - ! - filename = "WFCM" // TRIM( iotk_index (iss) ) - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( found ) THEN - ! - IF( .NOT. ( iss > 1 .AND. force_pairing ) ) THEN - ! - ! Only WF with spin 1 are needed when force_pairing is active - ! - ib = iupdwn(iss) - nb = nupdwn(iss) - ! - CALL read_wfc( iunpun, ik_eff, nk, kunit, iss_, nspin_, & - cm2( :, ib:ib+nb-1 ), ngwt_, nbnd_, ig_l2g, ngw, & - filename, scalef_ , .TRUE. ) - ! - END IF - ! - IF ( ionode ) & - CALL iotk_scan_end( iunpun, TRIM( filename ) ) - ! - ELSE - ! - cm2 = c02 - ! - END IF - ! - IF (.false.) THEN - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "WFC0FIXED" // TRIM( iotk_index (iss) ), FOUND = found ) - ! - filename = "WFC0FIXED" // TRIM( iotk_index (iss) ) - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( .NOT. found ) & - CALL errore( " readfile ", " wave functions evc0fixed not found! ", 1 ) - ! - IF( .NOT. ( iss > 1 .AND. force_pairing ) ) THEN - ! - ! Only WF with spin 1 are needed when force_pairing is active - ! - ib = iupdwn(iss) - nb = nupdwn(iss) - ! - ! filename is not needed we are following the link! - ! - CALL read_wfc( iunpun, ik_eff , nk, kunit, iss_, nspin_, & - c0_fixed( :, ib:ib+nb-1 ), ngwt_, nbnd_, ig_l2g, ngw, & - filename, scalef_, .TRUE. ) - ! - END IF - ! - ! - IF ( ionode ) & - CALL iotk_scan_end( iunpun, TRIM(filename) ) - ! - ENDIF - ! - END DO - ! - DO iss = 1, nspin - ! - ! ... read matrix lambda to file - ! - ALLOCATE( mrepl( nudx, nudx ) ) - ! - IF( ionode ) THEN - CALL iotk_scan_dat( iunpun, "LAMBDA0" // TRIM( cspin ), mrepl, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING lambda0 not read from restart file' - mrepl = 0.0d0 - END IF - END IF - - CALL mp_bcast( mrepl, ionode_id, intra_image_comm ) - - CALL distribute_lambda( mrepl, lambda0(:,:,iss), descla(:,iss) ) - - IF( ionode ) THEN - CALL iotk_scan_dat( iunpun, "LAMBDAM" // TRIM( cspin ), mrepl, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING lambdam not read from restart file' - mrepl = 0.0d0 - END IF - END IF - ! - CALL mp_bcast( mrepl, ionode_id, intra_image_comm ) - - CALL distribute_lambda( mrepl, lambdam(:,:,iss), descla(:,iss) ) - ! - IF ( PRESENT( mat_z ) ) THEN - ! - IF( ionode ) THEN - CALL iotk_scan_dat( iunpun, "MAT_Z" // TRIM( iotk_index( iss ) ), mrepl, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING mat_z not read from restart file' - mrepl = 0.0d0 - END IF - END IF - - CALL mp_bcast( mrepl, ionode_id, intra_image_comm ) - - CALL distribute_zmat( mrepl, mat_z(:,:,iss), descla(:,iss) ) - ! - END IF - ! - DEALLOCATE( mrepl ) - ! - END DO - ! - IF ( ionode ) CALL iotk_scan_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - END DO k_points_loop2 - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_end( iunpun, "EIGENVECTORS" ) - ! - END IF - ! - CALL mp_bcast( qexml_version, ionode_id, intra_image_comm ) - CALL mp_bcast( qexml_version_init, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( nfi, ionode_id, intra_image_comm ) - CALL mp_bcast( simtime, ionode_id, intra_image_comm ) - CALL mp_bcast( title, ionode_id, intra_image_comm ) - CALL mp_bcast( acc, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( ht, ionode_id, intra_image_comm ) - CALL mp_bcast( htm, ionode_id, intra_image_comm ) - CALL mp_bcast( htvel, ionode_id, intra_image_comm ) - CALL mp_bcast( gvel, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhh0, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhhm, ionode_id, intra_image_comm ) - CALL mp_bcast( vnhh, ionode_id, intra_image_comm ) - CALL mp_bcast( b1, ionode_id, intra_image_comm ) - CALL mp_bcast( b2, ionode_id, intra_image_comm ) - CALL mp_bcast( b3, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( stau0, ionode_id, intra_image_comm ) - CALL mp_bcast( svel0, ionode_id, intra_image_comm ) - CALL mp_bcast( staum, ionode_id, intra_image_comm ) - CALL mp_bcast( svelm, ionode_id, intra_image_comm ) - CALL mp_bcast( taui, ionode_id, intra_image_comm ) - CALL mp_bcast( force, ionode_id, intra_image_comm ) - CALL mp_bcast( cdmi, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhp0, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhpm, ionode_id, intra_image_comm ) - CALL mp_bcast( vnhp, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( xnhe0, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhem, ionode_id, intra_image_comm ) - CALL mp_bcast( vnhe, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( kunit, ionode_id, intra_image_comm ) - - CALL mp_bcast( occ0, ionode_id, intra_image_comm ) - CALL mp_bcast( occm, ionode_id, intra_image_comm ) - ! - IF ( PRESENT( mat_z ) ) & - CALL mp_bcast( mat_z(:,:,:), ionode_id, intra_image_comm ) - ! - IF ( ionode ) & - CALL iotk_close_read( iunpun ) - - ! - s1 = cclock() - ! - IF ( ionode ) THEN - ! - WRITE( stdout, & - '(3X,"restart file read in ",F8.3," sec.",/)' ) ( s1 - s0 ) - ! - END IF - ! - if (nprint_nfi.eq.-2) then - write( stdout,*) 'nprint_nfi= ',nprint_nfi - CALL read_print_counter( nprint_nfi, outdir, ndr ) - write( stdout,*) 'nprint_nfi= ',nprint_nfi - endif - ! - RETURN - ! - END SUBROUTINE cp_readfile_real - !------------------------------------------------------------------------ - SUBROUTINE cp_readfile_twin( ndr, outdir, ascii, nfi, simtime, acc, nk, xk, & - wk, ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, & - taui, cdmi, stau0, svel0, staum, svelm, force, & - vnhp, xnhp0, xnhpm, nhpcl,nhpdim,occ0, occm, & - lambda0, lambdam, b1, b2, b3, xnhe0, xnhem, vnhe, & - ekincm, c02, cm2, mat_z ) - !------------------------------------------------------------------------ - ! - USE control_flags, ONLY : do_wf_cmplx, gamma_only, force_pairing !added:giovanni do_wf_cmplx - USE io_files, ONLY : iunpun, xmlpun - USE printout_base, ONLY : title - USE gvecw, ONLY : ngw - USE electrons_base, ONLY : nspin, nelt, nel, & - nupdwn, iupdwn, nudx - USE cell_base, ONLY : s_to_r, r_to_s - USE ions_base, ONLY : nsp, nat, na, & - sort_tau, ityp, ions_cofmass - USE reciprocal_vectors, ONLY : ig_l2g - USE cp_main_variables, ONLY : nprint_nfi, distribute_lambda, descla, distribute_zmat - USE mp, ONLY : mp_sum - USE mp_global, ONLY : intra_image_comm - USE parameters, ONLY : ntypx - USE constants, ONLY : eps8, angstrom_au, pi - USE twin_types - USE input_parameters, ONLY : restart_from_wannier_cp, wannier_empty_only, & - restart_from_wannier_pwscf - USE wavefunctions_module, ONLY : c0_fixed, ctot_aux - USE electrons_module, ONLY : nupdwn_emp - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ndr ! I/O unit number - CHARACTER(LEN=*), INTENT(IN) :: outdir ! - LOGICAL, INTENT(IN) :: ascii ! - INTEGER, INTENT(INOUT) :: nfi ! index of the current step - REAL(DP), INTENT(INOUT) :: simtime ! simulated time - REAL(DP), INTENT(INOUT) :: acc(:) ! - INTEGER, INTENT(IN) :: nk ! number of kpoints - REAL(DP), INTENT(INOUT) :: xk(:,:) ! k-points coordinates - REAL(DP), INTENT(INOUT) :: wk(:) ! k-points weights - REAL(DP), INTENT(INOUT) :: ht(3,3) ! - REAL(DP), INTENT(INOUT) :: htm(3,3) ! - REAL(DP), INTENT(INOUT) :: htvel(3,3) ! - REAL(DP), INTENT(INOUT) :: gvel(3,3) ! - REAL(DP), INTENT(INOUT) :: xnhh0(3,3) ! - REAL(DP), INTENT(INOUT) :: xnhhm(3,3) ! - REAL(DP), INTENT(INOUT) :: vnhh(3,3) ! - REAL(DP), INTENT(INOUT) :: taui(:,:) ! - REAL(DP), INTENT(INOUT) :: cdmi(:) ! - REAL(DP), INTENT(INOUT) :: stau0(:,:) ! - REAL(DP), INTENT(INOUT) :: svel0(:,:) ! - REAL(DP), INTENT(INOUT) :: staum(:,:) ! - REAL(DP), INTENT(INOUT) :: svelm(:,:) ! - REAL(DP), INTENT(INOUT) :: force(:,:) ! - REAL(DP), INTENT(INOUT) :: xnhp0(:) ! - REAL(DP), INTENT(INOUT) :: xnhpm(:) ! - REAL(DP), INTENT(INOUT) :: vnhp(:) ! - INTEGER, INTENT(INOUT) :: nhpcl ! - INTEGER, INTENT(INOUT) :: nhpdim ! - REAL(DP), INTENT(INOUT) :: occ0(:) ! occupations - REAL(DP), INTENT(INOUT) :: occm(:) ! -! REAL(DP), INTENT(INOUT) :: lambda0(:,:,:) ! -! REAL(DP), INTENT(INOUT) :: lambdam(:,:,:) ! - TYPE(twin_matrix), dimension(:), INTENT(INOUT) :: lambda0 - TYPE(twin_matrix), dimension(:), INTENT(INOUT) :: lambdam - REAL(DP), INTENT(INOUT) :: b1(3) ! - REAL(DP), INTENT(INOUT) :: b2(3) ! - REAL(DP), INTENT(INOUT) :: b3(3) ! - REAL(DP), INTENT(INOUT) :: xnhe0 ! - REAL(DP), INTENT(INOUT) :: xnhem ! - REAL(DP), INTENT(INOUT) :: vnhe ! - REAL(DP), INTENT(INOUT) :: ekincm ! - COMPLEX(DP), INTENT(INOUT) :: c02(:,:) ! - COMPLEX(DP), INTENT(INOUT) :: cm2(:,:) ! - TYPE(twin_matrix), dimension(:), INTENT(INOUT), optional :: mat_z - ! - CHARACTER(LEN=256) :: dirname, filename - CHARACTER(LEN=4) :: cspin - INTEGER :: kunit - INTEGER :: i, iss, ierr, ik - REAL(DP) :: omega, htm1(3,3), hinv(3,3), scalef - LOGICAL :: found - ! - ! ... variables read for testing pourposes - ! - INTEGER :: ibrav_ - CHARACTER(LEN=9) :: symm_type_ - CHARACTER(LEN=3) :: atm_(ntypx) - INTEGER :: nat_, nsp_ - INTEGER :: nt_ - LOGICAL :: lsda_ !added:giovanni do_wf_cmplx - REAL(DP) :: alat_, a1_(3), a2_(3), a3_(3) - REAL(DP) :: celldm_(6) - INTEGER :: iss_, nspin_, ngwt_, nbnd_ , n_emp_ , nbnd_tot - INTEGER :: nstates_up_ , nstates_dw_ , nel_(2) - REAL(DP) :: nelec_ - REAL(DP) :: scalef_ - REAL(DP) :: wk_ - INTEGER :: nhpcl_, nhpdim_ - INTEGER :: ib, nb - INTEGER :: ik_eff - REAL(DP) :: amass_(ntypx) - INTEGER, ALLOCATABLE :: ityp_(:) - INTEGER, ALLOCATABLE :: isrt_(:) - REAL(DP), ALLOCATABLE :: tau_(:,:) - REAL(DP), ALLOCATABLE :: occ_(:) - INTEGER, ALLOCATABLE :: if_pos_(:,:) - CHARACTER(LEN=256) :: psfile_(ntypx) - CHARACTER(LEN=80) :: pos_unit - REAL(DP) :: s1, s0, cclock - REAL(DP), ALLOCATABLE :: mrepl(:,:) - COMPLEX(DP), ALLOCATABLE :: mrepl_c(:,:) - INTEGER :: nupdwn_tot( 2 ), iupdwn_tot( 2 ), nbnd_tot_tmp - ! - ! ... look for an empty unit - ! - CALL iotk_free_unit( iunout, ierr ) - ! - CALL errore( 'cp_readfile', & - 'no free units to read wavefunctions', ierr ) - ! - kunit = 1 - found = .FALSE. - ! - dirname = restart_dir( outdir, ndr ) - ! - ! ... Open XML descriptor - ! - IF ( ionode ) THEN - ! - filename = TRIM( dirname ) // '/' // TRIM( xmlpun ) - ! - WRITE( stdout, '(/,3X,"reading restart file: ",A)' ) TRIM( dirname ) - ! - CALL iotk_open_read( iunpun, FILE = TRIM( filename ), IERR = ierr ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_readfile', & - 'cannot open restart file for reading', ierr ) - ! - s0 = cclock() - ! - IF ( ionode ) THEN - ! - qexml_version = " " - ! - CALL iotk_scan_begin( iunpun, "HEADER", FOUND=found ) - ! - IF ( found ) THEN - ! - CALL iotk_scan_empty( iunpun, "FORMAT", ATTR=attr ) - CALL iotk_scan_attr( attr, "VERSION", qexml_version ) - CALL iotk_scan_end( iunpun, "HEADER" ) - ! - ELSE - ! - qexml_version = TRIM( default_fmt_version ) - ! - ENDIF - ! - qexml_version_init = .TRUE. - - ! - ! init logical variables for versioning - ! - qexml_version_before_1_4_0 = .FALSE. - ! - IF ( TRIM( version_compare( qexml_version, "1.4.0" )) == "older" ) & - qexml_version_before_1_4_0 = .TRUE. - ! - ENDIF - ! - CALL mp_bcast( qexml_version, ionode_id, intra_image_comm ) - CALL mp_bcast( qexml_version_init, ionode_id, intra_image_comm ) - CALL mp_bcast( qexml_version_before_1_4_0 , ionode_id, intra_image_comm ) - ! - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "STATUS", FOUND = found ) - ! - IF ( found ) THEN - ! - CALL iotk_scan_empty( iunpun, "STEP", attr ) - CALL iotk_scan_attr( attr, "ITERATION", nfi ) - CALL iotk_scan_dat( iunpun, "TIME", simtime ) - CALL iotk_scan_dat( iunpun, "TITLE", title ) - CALL iotk_scan_end( iunpun, "STATUS" ) - ! - END IF - ! - END IF - ! - ! ... Read cell and positions - ! - ALLOCATE( tau_( 3, nat ) ) - ALLOCATE( if_pos_( 3, nat ) ) - ALLOCATE( ityp_( nat ) ) - ! - IF ( ionode ) THEN - ! - CALL read_cell( ibrav_, symm_type_, celldm_, & - alat_, a1_, a2_, a3_, b1, b2, b3 ) - ! - CALL recips( a1_, a2_, a3_, b1, b2, b3 ) - ! - END IF - ! - IF ( ionode ) THEN - ! - CALL read_ions( nsp_, nat_, atm_, ityp_, & - psfile_, amass_, tau_, if_pos_, pos_unit, ierr ) - ! - IF ( ierr == 0 ) THEN - ! - IF( nsp_ /= nsp .OR. nat_ /= nat ) ierr = 2 - ! - DO i = 1, nat - ! - IF ( ityp_(i) /= ityp(i) ) ierr = 3 - ! - END DO - ! - END IF - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_readfile', & - 'cannot read positions from restart file', ierr ) - ! - ! Read SPIN infos - ! - lsda_ = ( nspin == 2 ) - ! - IF( ionode ) THEN - CALL iotk_scan_begin( iunpun, "SPIN", FOUND = found ) - IF( found ) THEN - CALL iotk_scan_dat( iunpun, "LSDA", lsda_ ) - CALL iotk_scan_end( iunpun, "SPIN" ) - END IF - END IF - ! - CALL mp_bcast( lsda_ , ionode_id, intra_image_comm ) - ! - IF( lsda_ .AND. nspin == 1 ) & - CALL errore( 'cp_readfile', 'LSDA restart file with a spinless run', ierr ) - - ! - ! Read Occupations infos - ! - nstates_up_ = nupdwn( 1 ) - nstates_dw_ = nupdwn( 2 ) - - IF( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "OCCUPATIONS", FOUND = found ) - IF( found ) THEN - ! - CALL iotk_scan_empty( iunpun, "INFO", attr, FOUND = found ) - ! - IF( lsda_ .AND. found ) THEN - ! - IF ( qexml_version_before_1_4_0 ) THEN - ! - CALL iotk_scan_attr( attr, "nelup", nstates_up_ ) - CALL iotk_scan_attr( attr, "neldw", nstates_dw_ ) - ! - ELSE - ! - ! current version - ! - CALL iotk_scan_attr( attr, "nstates_up", nstates_up_ ) - CALL iotk_scan_attr( attr, "nstates_down", nstates_dw_ ) - ! - ENDIF - ! - ENDIF - ! - CALL iotk_scan_end( iunpun, "OCCUPATIONS" ) - ! - ENDIF - ENDIF - ! - CALL mp_bcast( nstates_up_ , ionode_id, intra_image_comm ) - CALL mp_bcast( nstates_dw_ , ionode_id, intra_image_comm ) - ! - IF( lsda_ ) THEN - IF( ( nstates_up_ /= nupdwn( 1 ) ) .OR. ( nstates_dw_ /= nupdwn( 2 ) ) ) & - CALL errore( 'cp_readfile', 'inconsistent number of spin states', ierr ) - END IF - - ! ... read MD timesteps variables - ! - IF ( ionode ) & - CALL iotk_scan_begin( iunpun, "TIMESTEPS", attr, FOUND = found ) - ! - ierr = 0 - ! - IF ( ionode .AND. found ) THEN - ! - CALL iotk_scan_attr( attr, "nt", nt_ ) - ! - IF ( nt_ > 0 ) THEN - ! - CALL iotk_scan_begin( iunpun, "STEP0" ) - ! - CALL iotk_scan_dat( iunpun, "ACCUMULATORS", acc ) - ! - CALL iotk_scan_begin( iunpun,"IONS_POSITIONS" ) - CALL iotk_scan_dat( iunpun, "stau", stau0(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "svel", svel0(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "taui", taui(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "cdmi", cdmi(1:3) ) - CALL iotk_scan_dat( iunpun, "force", force(1:3,1:nat) ) - CALL iotk_scan_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_scan_begin( iunpun, "IONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "nhpcl", nhpcl_ ) - CALL iotk_scan_dat( iunpun, "nhpdim", nhpdim_ ) - ! - IF ( nhpcl_ == nhpcl .AND. nhpdim_ == nhpdim ) THEN - ! - CALL iotk_scan_dat( iunpun, "xnhp", xnhp0(1:nhpcl*nhpdim) ) - CALL iotk_scan_dat( iunpun, "vnhp", vnhp(1:nhpcl*nhpdim) ) - ! - ELSE - ! - xnhp0(1:nhpcl*nhpdim) = 0.D0 - vnhp(1:nhpcl*nhpdim) = 0.D0 - ! - END IF - ! - CALL iotk_scan_end( iunpun, "IONS_NOSE" ) - ! - CALL iotk_scan_dat( iunpun, "ekincm", ekincm ) - ! - CALL iotk_scan_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhe", xnhe0 ) - CALL iotk_scan_dat( iunpun, "vnhe", vnhe ) - CALL iotk_scan_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_scan_dat( iunpun, "ht", ht ) - CALL iotk_scan_dat( iunpun, "htvel", htvel ) - CALL iotk_scan_dat( iunpun, "gvel", gvel ) - CALL iotk_scan_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhh", xnhh0 ) - CALL iotk_scan_dat( iunpun, "vnhh", vnhh ) - CALL iotk_scan_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_scan_end( iunpun, "STEP0" ) - ! - ELSE - ! - ierr = 40 - ! - GOTO 100 - ! - END IF - ! - IF ( nt_ > 1 ) THEN - ! - CALL iotk_scan_begin( iunpun, "STEPM" ) - ! - CALL iotk_scan_begin( iunpun, "IONS_POSITIONS" ) - CALL iotk_scan_dat( iunpun, "stau", staum(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "svel", svelm(1:3,1:nat) ) - CALL iotk_scan_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_scan_begin( iunpun, "IONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "nhpcl", nhpcl_ ) - CALL iotk_scan_dat( iunpun, "nhpdim", nhpdim_ ) - ! - IF ( nhpcl_ == nhpcl .AND. nhpdim_ == nhpdim ) THEN - ! - CALL iotk_scan_dat( iunpun, "xnhp", xnhpm(1:nhpcl*nhpdim) ) - ! - ELSE - ! - xnhpm(1:nhpcl*nhpdim) = 0.D0 - ! - END IF - ! - CALL iotk_scan_end( iunpun,"IONS_NOSE" ) - ! - CALL iotk_scan_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhe", xnhem ) - CALL iotk_scan_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_scan_dat( iunpun, "ht", htm ) - CALL iotk_scan_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhh", xnhhm ) - CALL iotk_scan_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_scan_end( iunpun, "STEPM" ) - ! - END IF - ! - CALL iotk_scan_end( iunpun, "TIMESTEPS" ) - ! - ELSE IF ( ionode ) THEN - ! - ! ... MD time steps not found, try to recover from CELL and POSITIONS - ! - acc = 0.D0 - ! - ALLOCATE( isrt_( nat ) ) - ! - SELECT CASE( TRIM( pos_unit ) ) - CASE( "alat" ) - ! - tau_ = tau_ * alat_ - ! - CASE( "Angstrom" ) - ! - tau_ = tau_ * angstrom_au - ! - CASE DEFAULT - ! - END SELECT - ! - CALL sort_tau( taui, isrt_ , tau_ , ityp_ , nat_ , nsp_ ) - ! - ht(1,:) = a1_ - ht(2,:) = a2_ - ht(3,:) = a3_ - ! - CALL invmat( 3, ht, htm1, omega ) - ! - hinv = TRANSPOSE( htm1 ) - ! - CALL r_to_s( taui, stau0, na, nsp, hinv ) - ! - CALL ions_cofmass( taui, amass_ , na, nsp, cdmi ) - ! - staum = stau0 - svel0 = 0.D0 - svelm = 0.D0 - force = 0.D0 - ! - htm = ht - htvel = 0.D0 - gvel = 0.D0 - xnhh0 = 0.D0 - vnhh = 0.D0 - xnhhm = 0.D0 - ! - xnhe0 = 0.D0 - xnhem = 0.D0 - vnhe = 0.D0 - ! - ekincm = 0.D0 - ! - xnhp0 = 0.D0 - xnhpm = 0.D0 - vnhp = 0.D0 - ! - DEALLOCATE( isrt_ ) - ! - END IF - ! - 100 CONTINUE - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - IF( ierr /= 0 ) THEN - CALL mp_bcast( attr, ionode_id, intra_image_comm ) - CALL errore( 'cp_readfile ', TRIM( attr ), ierr ) - END IF - ! - DEALLOCATE( tau_ ) - DEALLOCATE( if_pos_ ) - DEALLOCATE( ityp_ ) - ! - ! ... compute the scale factor - ! - IF ( ionode ) CALL invmat( 3, ht, htm1, omega ) - ! - CALL mp_bcast( omega, ionode_id, intra_image_comm ) - ! - ! ... Beware: omega may be negative if axis are left-handed! - ! - scalef = 1.D0 / SQRT( ABS( omega ) ) - ! - ! ... band Structure - ! - IF ( ionode ) THEN - ! - ierr = 0 - ! - CALL iotk_scan_begin( iunpun, "BAND_STRUCTURE_INFO" ) - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_SPIN_COMPONENTS", nspin_ ) - ! - IF ( nspin_ /= nspin ) THEN - attr = "spin do not match" - ierr = 31 - GOTO 90 - END IF - ! - IF ( nspin == 2 ) THEN - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_ELECTRONS", nelec_, ATTR = attr ) - CALL iotk_scan_attr( attr, "UP", nel_(1) ) - CALL iotk_scan_attr( attr, "DW", nel_(2) ) - ! - IF ( ( nel(1) /= nel_(1) ) .OR. ( nel(2) /= nel_(2) ) .OR. ( NINT( nelec_ ) /= nelt ) ) THEN - attr = "electrons do not match" - write(0,*) "from cp_readfile warning: electrons do not match" - write(6,*) "from cp_readfile warning: electrons do not match" - !ierr = 33 - GOTO 90 - END IF - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_BANDS", nbnd_tot , ATTR = attr ) - ! - ELSE - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_ELECTRONS", nelec_ ) - ! - IF ( NINT( nelec_ ) /= nelt ) THEN - attr = "electrons do not match" - ierr = 33 - GOTO 90 - END IF - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_BANDS", nbnd_tot ) - ! - END IF - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_EMPTY_STATES", n_emp_, FOUND = found ) - ! - IF( .NOT. found ) n_emp_ = 0 - ! - nbnd_ = nbnd_tot - n_emp_ - ! - IF ( nbnd_ < nupdwn(1) ) THEN - attr = "nbnd do not match" - ierr = 32 - GOTO 90 - END IF - ! - CALL iotk_scan_end( iunpun, "BAND_STRUCTURE_INFO" ) - ! - END IF - ! - 90 CONTINUE - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - IF( ierr /= 0 ) THEN - CALL mp_bcast( attr, ionode_id, intra_image_comm ) - CALL errore( 'cp_readfile ', TRIM( attr ), ierr ) - END IF - ! - IF( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "EIGENVALUES" ) - ! - END IF - ! - k_points_loop1: DO ik = 1, nk - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - CALL iotk_scan_dat( iunpun, "WEIGHT", wk_ ) - ! - END IF - ! - DO iss = 1, nspin - ! - cspin = iotk_index( iss ) - ! - ik_eff = ik + ( iss - 1 ) * nk - ! - IF ( ionode ) THEN - ! - ALLOCATE( occ_ ( MAX( nudx , nbnd_tot ) ) ) - ! - occ_ = 0.0d0 - ! - CALL iotk_scan_dat( iunpun, "OCC0" // TRIM( cspin ), occ_ ( 1 : nupdwn( iss ) ), FOUND = found ) - ! - IF( .NOT. found ) THEN - ! - IF( nspin == 1 ) THEN - CALL iotk_scan_begin( iunpun, "DATAFILE", FOUND = found ) - ELSE - CALL iotk_scan_begin( iunpun, "DATAFILE//TRIM(cspin)", FOUND = found ) - END IF - ! - CALL iotk_scan_dat ( iunpun, "OCCUPATIONS", occ_( 1:nbnd_tot ) ) - ! - IF( nspin == 1 ) THEN - CALL iotk_scan_end( iunpun, "DATAFILE" ) - ELSE - CALL iotk_scan_end( iunpun, "DATAFILE//TRIM(cspin)" ) - END IF - ! - IF( found ) THEN - occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) * wk_ - occm( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) * wk_ - END IF - ! - ELSE - ! - occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) - ! - CALL iotk_scan_dat( iunpun, "OCCM" // TRIM( cspin ), occ_ ( 1 : nupdwn( iss ) ), FOUND = found ) - ! - IF( found ) THEN - occm( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) - END IF - ! - END IF - ! - DEALLOCATE ( occ_ ) - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( .NOT. found ) & - CALL errore( " readfile ", " occupation numbers not found! ", 1 ) - ! - END DO - - IF ( ionode ) CALL iotk_scan_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - END DO k_points_loop1 - - IF ( ionode ) THEN - CALL iotk_scan_end ( iunpun, "EIGENVALUES" ) - CALL iotk_scan_begin( iunpun, "EIGENVECTORS" ) - END IF - ! - k_points_loop2: DO ik = 1, nk - ! - IF ( ionode ) THEN - CALL iotk_scan_begin( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - END IF - ! - DO iss = 1, nspin - ! - ! by linh, here is read evc from file for restarting with wannier orbitals. - ! - IF (restart_from_wannier_cp .and. .not. wannier_empty_only .and. .not. restart_from_wannier_pwscf) THEN - ! - nupdwn_tot(:) = nupdwn(:) + nupdwn_emp(:) - iupdwn_tot(1) = iupdwn(1) - iupdwn_tot(2) = nupdwn_tot(1) + 1 - nbnd_tot_tmp = MAX( nupdwn(1), nupdwn_tot(1) ) - ! - IF (.NOT. allocated(ctot_aux) ) ALLOCATE( ctot_aux( SIZE( c02, 1 ), nupdwn_tot(1) * nspin ) ) ! - ! - IF ( ionode ) THEN - ! - IF( nspin == 2 ) THEN - ! - CALL iotk_scan_begin( iunpun, "WFC" // TRIM( iotk_index (iss) ), FOUND = found ) - filename = "WFC" // TRIM( iotk_index (iss) ) - ! - ELSE - ! - CALL iotk_scan_begin( iunpun, "WFC", FOUND = found ) - filename = "WFC" - ! - ENDIF - ! - ENDIF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF ( .NOT. found ) & - CALL errore( " readfile ", " wave functions not found! ", 1 ) - ! - IF ( .NOT. ( iss > 1 .AND. force_pairing ) ) THEN - ! - ! Only WF with spin 1 are needed when force_pairing is active - ! - ib = iupdwn_tot(iss) - nb = nupdwn_tot(iss) - ! - ! filename is not needed we are following the link! - ! - CALL read_wfc( iunpun, ik_eff , nk, kunit, iss_, nspin_, & - ctot_aux( :, ib:ib+nb-1 ), ngwt_, nbnd_tot_tmp, ig_l2g, ngw, & - filename, scalef_, .TRUE. ) - ! - ENDIF - ! - IF ( ionode ) & - CALL iotk_scan_end( iunpun, TRIM(filename) ) - ! - ENDIF - ! - ! by linh, done - ! - - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "WFC0" // TRIM( iotk_index (iss) ), FOUND = found ) - ! - filename = "WFC0" // TRIM( iotk_index (iss) ) - ! - IF( .NOT. found ) THEN - ! - IF( nspin == 2 ) THEN - CALL iotk_scan_begin( iunpun, "WFC" // TRIM( iotk_index (iss) ), FOUND = found ) - filename = "WFC" // TRIM( iotk_index (iss) ) - ELSE - CALL iotk_scan_begin( iunpun, "WFC", FOUND = found ) - filename = "WFC" - END IF - ! - END IF - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( .NOT. found ) & - CALL errore( " readfile ", " wave functions not found! ", 1 ) - ! - IF( .NOT. ( iss > 1 .AND. force_pairing ) ) THEN - ! - ! Only WF with spin 1 are needed when force_pairing is active - ! - ib = iupdwn(iss) - nb = nupdwn(iss) - ! - ! filename is not needed we are following the link! - ! - CALL read_wfc( iunpun, ik_eff , nk, kunit, iss_, nspin_, & - c02( :, ib:ib+nb-1 ), ngwt_, nbnd_, ig_l2g, ngw, & - filename, scalef_, .TRUE. ) - ! - END IF - ! - IF ( ionode ) & - CALL iotk_scan_end( iunpun, TRIM(filename) ) - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "WFCM" // TRIM( iotk_index (iss) ), FOUND = found ) - ! - filename = "WFCM" // TRIM( iotk_index (iss) ) - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( found ) THEN - ! - IF( .NOT. ( iss > 1 .AND. force_pairing ) ) THEN - ! - ! Only WF with spin 1 are needed when force_pairing is active - ! - ib = iupdwn(iss) - nb = nupdwn(iss) - ! - CALL read_wfc( iunpun, ik_eff, nk, kunit, iss_, nspin_, & - cm2( :, ib:ib+nb-1 ), ngwt_, nbnd_, ig_l2g, ngw, & - filename, scalef_ , .TRUE. ) - ! - END IF - ! - IF ( ionode ) & - CALL iotk_scan_end( iunpun, TRIM( filename ) ) - ! - ELSE - ! - cm2 = c02 - ! - END IF - ! - IF (.false.) THEN - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "WFC0FIXED" // TRIM( iotk_index (iss) ), FOUND = found ) - ! - filename = "WFC0FIXED" // TRIM( iotk_index (iss) ) - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( .NOT. found ) & - CALL errore( " readfile ", " wave functions evc0fixed not found! ", 1 ) - ! - IF( .NOT. ( iss > 1 .AND. force_pairing ) ) THEN - ! - ! Only WF with spin 1 are needed when force_pairing is active - ! - ib = iupdwn(iss) - nb = nupdwn(iss) - ! - ! filename is not needed we are following the link! - ! - CALL read_wfc( iunpun, ik_eff , nk, kunit, iss_, nspin_, & - c0_fixed( :, ib:ib+nb-1 ), ngwt_, nbnd_, ig_l2g, ngw, & - filename, scalef_, .TRUE. ) - ! - END IF - ! - IF ( ionode ) & - CALL iotk_scan_end( iunpun, TRIM(filename) ) - ! - ENDIF - ! - END DO - ! - DO iss = 1, nspin - ! - ! ... read matrix lambda to file - ! - IF(.not. lambda0(1)%iscmplx) THEN - ALLOCATE(mrepl(nudx, nudx )) - ! - IF( ionode ) THEN - CALL iotk_scan_dat( iunpun, "LAMBDA0" // TRIM( cspin ), mrepl, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING lambda0 not read from restart file' - mrepl = 0.0d0 - END IF - END IF - - CALL mp_bcast( mrepl, ionode_id, intra_image_comm ) - CALL distribute_lambda( mrepl, lambda0(iss)%rvec(:,:), descla(:,iss) ) - - IF( ionode ) THEN - CALL iotk_scan_dat( iunpun, "LAMBDAM" // TRIM( cspin ), mrepl, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING lambdam not read from restart file' - mrepl = 0.0d0 - END IF - END IF - ! - CALL mp_bcast( mrepl, ionode_id, intra_image_comm ) - - CALL distribute_lambda( mrepl, lambdam(iss)%rvec(:,:), descla(:,iss) ) - DEALLOCATE(mrepl) - ! - ELSE - WRITE( stdout, * ) 'here should be iotk first error' - ALLOCATE(mrepl_c(nudx, nudx)) - IF( ionode ) THEN - CALL iotk_scan_dat( iunpun, "LAMBDA0" // TRIM( cspin ), mrepl_c, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING lambda0 not read from restart file' - mrepl_c = CMPLX(0.0d0, 0.d0) - END IF - END IF - - CALL mp_bcast( mrepl_c, ionode_id, intra_image_comm ) - - CALL distribute_lambda(mrepl_c, lambda0(iss)%cvec(:,:), descla(:,iss) ) - - IF( ionode ) THEN - CALL iotk_scan_dat( iunpun, "LAMBDAM" // TRIM( cspin ), mrepl_c, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING lambdam not read from restart file' - mrepl_c = CMPLX(0.0d0,0.d0) - END IF - END IF - ! - CALL mp_bcast( mrepl_c, ionode_id, intra_image_comm ) - CALL distribute_lambda( mrepl_c, lambdam(iss)%cvec(:,:), descla(:,iss) ) - DEALLOCATE(mrepl_c) - - ENDIF - - IF ( PRESENT( mat_z ) ) THEN - ! - - IF( ionode ) THEN - IF(.not.mat_z(iss)%iscmplx) THEN - IF(.not.allocated(mrepl)) THEN - ALLOCATE(mrepl(nudx,nudx)) - ENDIF - CALL iotk_scan_dat( iunpun, "MAT_Z" // TRIM( iotk_index( iss ) ), mrepl, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING mat_z not read from restart file' - mrepl = 0.0d0 - END IF - CALL mp_bcast( mrepl, ionode_id, intra_image_comm ) - CALL distribute_zmat( mrepl, mat_z(iss)%rvec(:,:), descla(:,iss) ) - DEALLOCATE(mrepl) - ELSE - IF(.not.allocated(mrepl_c)) THEN - ALLOCATE(mrepl_c(nudx,nudx)) - ENDIF - CALL iotk_scan_dat( iunpun, "MAT_Z" // TRIM( iotk_index( iss ) ), mrepl_c, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING mat_z not read from restart file' - mrepl_c = CMPLX(0.0d0,0.d0) - END IF - CALL mp_bcast( mrepl_c, ionode_id, intra_image_comm ) - CALL distribute_zmat( mrepl_c, mat_z(iss)%cvec(:,:), descla(:,iss) ) - DEALLOCATE(mrepl_c) - ENDIF - END IF - ! - END IF - ! - ! - END DO - ! - IF ( ionode ) CALL iotk_scan_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - END DO k_points_loop2 - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_end( iunpun, "EIGENVECTORS" ) - ! - END IF - ! - CALL mp_bcast( qexml_version, ionode_id, intra_image_comm ) - CALL mp_bcast( qexml_version_init, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( nfi, ionode_id, intra_image_comm ) - CALL mp_bcast( simtime, ionode_id, intra_image_comm ) - CALL mp_bcast( title, ionode_id, intra_image_comm ) - CALL mp_bcast( acc, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( ht, ionode_id, intra_image_comm ) - CALL mp_bcast( htm, ionode_id, intra_image_comm ) - CALL mp_bcast( htvel, ionode_id, intra_image_comm ) - CALL mp_bcast( gvel, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhh0, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhhm, ionode_id, intra_image_comm ) - CALL mp_bcast( vnhh, ionode_id, intra_image_comm ) - CALL mp_bcast( b1, ionode_id, intra_image_comm ) - CALL mp_bcast( b2, ionode_id, intra_image_comm ) - CALL mp_bcast( b3, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( stau0, ionode_id, intra_image_comm ) - CALL mp_bcast( svel0, ionode_id, intra_image_comm ) - CALL mp_bcast( staum, ionode_id, intra_image_comm ) - CALL mp_bcast( svelm, ionode_id, intra_image_comm ) - CALL mp_bcast( taui, ionode_id, intra_image_comm ) - CALL mp_bcast( force, ionode_id, intra_image_comm ) - CALL mp_bcast( cdmi, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhp0, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhpm, ionode_id, intra_image_comm ) - CALL mp_bcast( vnhp, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( xnhe0, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhem, ionode_id, intra_image_comm ) - CALL mp_bcast( vnhe, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( kunit, ionode_id, intra_image_comm ) - - CALL mp_bcast( occ0, ionode_id, intra_image_comm ) - CALL mp_bcast( occm, ionode_id, intra_image_comm ) - ! -! IF ( PRESENT( mat_z ) ) THEN !warning:giovanni this part is a bug??? -! DO iss=1,nspin -! IF(.not.mat_z(iss)%iscmplx) THEN -! CALL mp_bcast( mat_z(iss)%rvec(:,:), ionode_id, intra_image_comm ) -! ELSE -! CALL mp_bcast( mat_z(iss)%cvec(:,:), ionode_id, intra_image_comm ) -! ENDIF -! ENDDO -! ENDIF - ! - IF ( ionode ) & - CALL iotk_close_read( iunpun ) - - ! - s1 = cclock() - ! - IF ( ionode ) THEN - ! - WRITE( stdout, & - '(3X,"restart file read in ",F8.3," sec.",/)' ) ( s1 - s0 ) - ! - END IF - ! - if (nprint_nfi.eq.-2) then - write( stdout,*) 'nprint_nfi= ',nprint_nfi - CALL read_print_counter( nprint_nfi, outdir, ndr ) - write( stdout,*) 'nprint_nfi= ',nprint_nfi - endif - ! - RETURN - ! - END SUBROUTINE cp_readfile_twin - ! - !------------------------------------------------------------------------ - SUBROUTINE cp_read_wfc( ndr, outdir, ik, nk, iss, nspin, c2, tag ) - !------------------------------------------------------------------------ - ! - USE electrons_base, ONLY : iupdwn, nupdwn - USE reciprocal_vectors, ONLY : ngw, ig_l2g - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ndr - CHARACTER(LEN=*), INTENT(IN) :: outdir - INTEGER, INTENT(IN) :: ik, iss, nk, nspin - CHARACTER, INTENT(IN) :: tag - COMPLEX(DP), OPTIONAL, INTENT(OUT) :: c2(:,:) - ! - CHARACTER(LEN=256) :: dirname, filename - INTEGER :: ik_eff, ib, nb, kunit, iss_, nspin_, ngwt_, nbnd_ - REAL(DP) :: scalef - ! - kunit = 1 - ! - ik_eff = ik + ( iss - 1 ) * nk - ! - dirname = restart_dir( outdir, ndr ) - ! - IF ( tag /= 'm' ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc0', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc0', ik, iss ) ) - ! - END IF - ! - ELSE - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evcm', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evcm', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss) - nb = nupdwn(iss) - ! - CALL read_wfc( iunout, ik_eff, nk, kunit, iss_, nspin_, & - c2(:,ib:ib+nb-1), ngwt_, nbnd_, ig_l2g, ngw, & - filename, scalef ) - ! - RETURN - ! - END SUBROUTINE cp_read_wfc - ! - !------------------------------------------------------------------------ - SUBROUTINE cp_read_cell( ndr, outdir, ascii, ht, & - htm, htvel, gvel, xnhh0, xnhhm, vnhh ) - !------------------------------------------------------------------------ - ! - USE io_files, ONLY : iunpun, xmlpun - USE mp_global, ONLY : intra_image_comm - USE mp, ONLY : mp_sum - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ndr - CHARACTER(LEN=*), INTENT(IN) :: outdir - LOGICAL, INTENT(IN) :: ascii - REAL(DP), INTENT(INOUT) :: ht(3,3) - REAL(DP), INTENT(INOUT) :: htm(3,3) - REAL(DP), INTENT(INOUT) :: htvel(3,3) - REAL(DP), INTENT(INOUT) :: gvel(3,3) - REAL(DP), INTENT(INOUT) :: xnhh0(3,3) - REAL(DP), INTENT(INOUT) :: xnhhm(3,3) - REAL(DP), INTENT(INOUT) :: vnhh(3,3) - ! - CHARACTER(LEN=256) :: dirname, filename - INTEGER :: ierr, nt_ - LOGICAL :: found - ! - ! ... variables read for testing pourposes - ! - INTEGER :: ibrav_ - REAL(DP) :: alat_ - REAL(DP) :: celldm_(6) - REAL(DP) :: a1_(3), a2_(3), a3_(3) - REAL(DP) :: b1_(3), b2_(3), b3_(3) - CHARACTER(LEN=9) :: symm_type_ - ! - ! - dirname = restart_dir( outdir, ndr ) - ! - filename = TRIM( dirname ) // '/' // TRIM( xmlpun ) - ! - IF ( ionode ) & - CALL iotk_open_read( iunpun, FILE = TRIM( filename ), & - BINARY = .FALSE., ROOT = attr, IERR = ierr ) - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_read_cell', & - 'cannot open restart file for reading: ' // TRIM(filename), & - ierr ) - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "TIMESTEPS", attr, FOUND = found ) - ! - IF ( found ) THEN - ! - CALL iotk_scan_attr( attr, "nt", nt_ ) - ! - IF ( nt_ > 0 ) THEN - ! - CALL iotk_scan_begin( iunpun, "STEP0" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_scan_dat( iunpun, "ht", ht ) - CALL iotk_scan_dat( iunpun, "htvel", htvel ) - CALL iotk_scan_dat( iunpun, "gvel", gvel, & - FOUND = found, IERR = ierr ) - ! - IF ( .NOT. found ) gvel = 0.D0 - ! - CALL iotk_scan_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhh", xnhh0 ) - CALL iotk_scan_dat( iunpun, "vnhh", vnhh ) - CALL iotk_scan_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_scan_end( iunpun, "STEP0" ) - ! - ELSE - ! - ierr = 40 - ! - GOTO 100 - ! - END IF - ! - IF( nt_ > 1 ) THEN - ! - CALL iotk_scan_begin(iunpun,"STEPM") - ! - CALL iotk_scan_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_scan_dat( iunpun, "ht", htm) - CALL iotk_scan_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhh", xnhhm ) - CALL iotk_scan_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_scan_end( iunpun, "STEPM" ) - ! - END IF - ! - CALL iotk_scan_end( iunpun, "TIMESTEPS" ) - ! - ELSE - ! - ! ... MD steps have not been found, try to restart from cell data - ! - CALL read_cell( ibrav_, symm_type_, celldm_, & - alat_, a1_, a2_, a3_, b1_, b2_, b3_ ) - ! - ht(1,:) = a1_ - ht(2,:) = a2_ - ht(3,:) = a3_ - ! - htm = ht - htvel = 0.D0 - gvel = 0.D0 - xnhh0 = 0.D0 - vnhh = 0.D0 - xnhhm = 0.D0 - ! - END IF - ! - END IF - ! - 100 CONTINUE - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - CALL mp_bcast( attr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_read_cell ', attr, ierr ) - ! - CALL mp_bcast( ht, ionode_id, intra_image_comm ) - CALL mp_bcast( htm, ionode_id, intra_image_comm ) - CALL mp_bcast( htvel, ionode_id, intra_image_comm ) - CALL mp_bcast( gvel, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhh0, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhhm, ionode_id, intra_image_comm ) - CALL mp_bcast( vnhh, ionode_id, intra_image_comm ) - ! - IF ( ionode ) CALL iotk_close_read( iunpun ) - ! - RETURN - ! - END SUBROUTINE cp_read_cell - ! - !------------------------------------------------------------------------ - SUBROUTINE read_cell( ibrav, symm_type, & - celldm, alat, a1, a2, a3, b1, b2, b3 ) - !------------------------------------------------------------------------ - ! - INTEGER, INTENT(OUT) :: ibrav - CHARACTER(LEN=*), INTENT(OUT) :: symm_type - REAL(DP), INTENT(OUT) :: celldm(6), alat - REAL(DP), INTENT(OUT) :: a1(3), a2(3), a3(3) - REAL(DP), INTENT(OUT) :: b1(3), b2(3), b3(3) - ! - CHARACTER(LEN=256) :: bravais_lattice - ! - ! - CALL iotk_scan_begin( iunpun, "CELL" ) - ! - CALL iotk_scan_dat( iunpun, "BRAVAIS_LATTICE", bravais_lattice ) - ! - SELECT CASE ( TRIM( bravais_lattice ) ) - CASE( "free" ) - ibrav = 0 - CASE( "cubic P (sc)" ) - ibrav = 1 - CASE( "cubic F (fcc)" ) - ibrav = 2 - CASE( "cubic I (bcc)" ) - ibrav = 3 - CASE( "Hexagonal and Trigonal P" ) - ibrav = 4 - CASE( "Trigonal R" ) - ibrav = 5 - CASE( "Tetragonal P (st)" ) - ibrav = 6 - CASE( "Tetragonal I (bct)" ) - ibrav = 7 - CASE( "Orthorhombic P" ) - ibrav = 8 - CASE( "Orthorhombic base-centered(bco)" ) - ibrav = 9 - CASE( "Orthorhombic face-centered" ) - ibrav = 10 - CASE( "Orthorhombic body-centered" ) - ibrav = 11 - CASE( "Monoclinic P" ) - ibrav = 12 - CASE( "Monoclinic base-centered" ) - ibrav = 13 - CASE( "Triclinic P" ) - ibrav = 14 - END SELECT - ! - IF ( ibrav == 0 ) & - CALL iotk_scan_dat( iunpun, "CELL_SYMMETRY", symm_type ) - ! - CALL iotk_scan_dat( iunpun, "LATTICE_PARAMETER", alat ) - CALL iotk_scan_dat( iunpun, "CELL_DIMENSIONS", celldm(1:6) ) - ! - CALL iotk_scan_begin( iunpun, "DIRECT_LATTICE_VECTORS" ) - CALL iotk_scan_dat( iunpun, "a1", a1 ) - CALL iotk_scan_dat( iunpun, "a2", a2 ) - CALL iotk_scan_dat( iunpun, "a3", a3 ) - CALL iotk_scan_end( iunpun, "DIRECT_LATTICE_VECTORS" ) - ! - CALL iotk_scan_begin( iunpun, "RECIPROCAL_LATTICE_VECTORS" ) - CALL iotk_scan_dat( iunpun, "b1", b1 ) - CALL iotk_scan_dat( iunpun, "b2", b2 ) - CALL iotk_scan_dat( iunpun, "b3", b3 ) - CALL iotk_scan_end( iunpun, "RECIPROCAL_LATTICE_VECTORS" ) - ! - CALL iotk_scan_end( iunpun, "CELL" ) - ! - RETURN - ! - END SUBROUTINE - ! - !------------------------------------------------------------------------ - SUBROUTINE read_ions( nsp, nat, atm, ityp, psfile, & - amass, tau, if_pos, pos_unit, ierr ) - !------------------------------------------------------------------------ - ! - INTEGER, INTENT(OUT) :: nsp, nat - CHARACTER(LEN=3), INTENT(OUT) :: atm(:) - INTEGER, INTENT(OUT) :: ityp(:) - CHARACTER(LEN=256), INTENT(OUT) :: psfile(:) - REAL(DP), INTENT(OUT) :: amass(:) - REAL(DP), INTENT(OUT) :: tau(:,:) - INTEGER, INTENT(OUT) :: if_pos(:,:) - INTEGER, INTENT(OUT) :: ierr - CHARACTER(LEN=*), INTENT(OUT) :: pos_unit - ! - LOGICAL :: found - INTEGER :: i - CHARACTER(LEN=3) :: lab - ! - ierr = 0 - ! - CALL iotk_scan_begin( iunpun, "IONS", FOUND = found ) - ! - IF ( .NOT. found ) THEN - ! - ierr = 1 - ! - RETURN - ! - END IF - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_ATOMS", nat ) - CALL iotk_scan_dat( iunpun, "NUMBER_OF_SPECIES", nsp ) - ! - IF ( nsp > SIZE( atm ) .OR. nat > SIZE( ityp ) ) THEN - ! - ierr = 10 - ! - CALL iotk_scan_end( iunpun, "IONS" ) - ! - RETURN - ! - END IF - ! - ! - DO i = 1, nsp - ! - IF ( qexml_version_before_1_4_0 ) THEN - ! - CALL iotk_scan_dat( iunpun, "ATOM_TYPE", atm(i) ) - CALL iotk_scan_dat( iunpun, TRIM( atm(i) )//"_MASS", amass(i) ) - CALL iotk_scan_dat( iunpun, "PSEUDO_FOR_" // TRIM( atm(i) ), psfile(i) ) - ! - ELSE - ! - ! current format - ! - CALL iotk_scan_begin( iunpun, "SPECIE"//TRIM(iotk_index(i)) ) - ! - CALL iotk_scan_dat( iunpun, "ATOM_TYPE", atm(i) ) - CALL iotk_scan_dat( iunpun, "MASS", amass(i) ) - CALL iotk_scan_dat( iunpun, "PSEUDO", psfile(i) ) - ! - CALL iotk_scan_end( iunpun, "SPECIE"//TRIM(iotk_index(i)) ) - ! - ENDIF - ! - ENDDO - ! - CALL iotk_scan_empty( iunpun, "UNITS_FOR_ATOMIC_POSITIONS", attr ) - CALL iotk_scan_attr( attr, "UNITS", pos_unit ) - ! - DO i = 1, nat - ! - CALL iotk_scan_empty( iunpun, "ATOM" // TRIM( iotk_index( i ) ), attr ) - CALL iotk_scan_attr( attr, "SPECIES", lab ) - CALL iotk_scan_attr( attr, "INDEX", ityp(i) ) - CALL iotk_scan_attr( attr, "tau", tau(:,i) ) - CALL iotk_scan_attr( attr, "if_pos", if_pos(:,i) ) - ! - END DO - ! - CALL iotk_scan_end( iunpun, "IONS" ) - ! - RETURN - ! - END SUBROUTINE read_ions - ! - ! - ! - SUBROUTINE write_gk( iun, mill, filename ) - ! - USE gvecw, ONLY : ngw, ngwt - USE control_flags, ONLY : do_wf_cmplx, gamma_only !added:giovanni do_wf_cmplx - USE reciprocal_vectors, ONLY : ig_l2g - USE mp, ONLY : mp_sum - USE mp_global, ONLY : intra_image_comm - USE io_global, ONLY : ionode - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: iun - INTEGER, INTENT(IN) :: mill(:,:) - CHARACTER(LEN=256), INTENT(IN) :: filename - ! - INTEGER, ALLOCATABLE :: igwk(:) - INTEGER, ALLOCATABLE :: itmp1(:) - INTEGER :: npwx_g, npw_g, ig, ngg - REAL(DP) :: xk(3) - - xk = 0.0d0 - npwx_g = ngwt - npw_g = ngwt - - ALLOCATE( igwk( npwx_g ) ) - ! - igwk = 0 - ! - ALLOCATE( itmp1( npw_g ) ) - ! - itmp1 = 0 - ! - ! - DO ig = 1, ngw - ! - itmp1( ig_l2g( ig ) ) = ig_l2g( ig ) - ! - END DO - ! - CALL mp_sum( itmp1, intra_image_comm ) - ! - ngg = 0 - ! - DO ig = 1, npw_g - ! - IF ( itmp1(ig) == ig ) THEN - ! - ngg = ngg + 1 - ! - igwk( ngg ) = ig - ! - END IF - ! - END DO - - DEALLOCATE( itmp1 ) - ! - IF ( ionode ) THEN - ! - CALL iotk_open_write( iun, FILE = TRIM( filename ), & - ROOT="GK-VECTORS", BINARY = .TRUE. ) - ! - CALL iotk_write_dat( iun, "NUMBER_OF_GK-VECTORS", npw_g ) - CALL iotk_write_dat( iun, "MAX_NUMBER_OF_GK-VECTORS", npwx_g ) - CALL iotk_write_dat( iun, "DO_WF_CMPLX", do_wf_cmplx ) !added:giovanni do_wf_cmplx - CALL iotk_write_dat( iun, "GAMMA_ONLY", gamma_only.and..not.do_wf_cmplx )!modified:giovanni for post-processing - ! - CALL iotk_write_attr ( attr, "UNITS", "2 pi / a", FIRST = .TRUE. ) - CALL iotk_write_dat( iun, "K-POINT_COORDS", xk(:), ATTR = attr ) - ! - CALL iotk_write_dat( iun, "INDEX", igwk( 1:npw_g ) ) - CALL iotk_write_dat( iun, "GRID", mill( 1:3, igwk( 1:npw_g ) ), COLUMNS = 3 ) - ! - CALL iotk_close_write( iun ) - ! - END IF - ! - DEALLOCATE( igwk ) - - RETURN - - END SUBROUTINE write_gk - ! - ! - ! -! SUBROUTINE write_translation(trans_matrix, trans_vec, )!added:giovanni -! -! -! CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & -! ctot( :, ib : ib + nbnd_tot - 1 ), ngwt, do_wf_cmplx, gamma_only,& !added:giovanni do_wf_cmplx -! nbnd_tot, ig_l2g, ngw, filename, scalef ) -! ib = iupdwn(iss) -! nb = nupdwn(iss) -! ! -! CALL read_wfc( iunout, ik_eff, nk, kunit, iss_, nspin_, & -! c2(:,ib:ib+nb-1), ngwt_, nbnd_, ig_l2g, ngw, & -! filename, scalef ) -! ! -! END SUBROUTINE write_translation - -END MODULE cp_restart diff --git a/quantum_espresso/kcp/CPV/cp_restart_backup.f90 b/quantum_espresso/kcp/CPV/cp_restart_backup.f90 deleted file mode 100644 index b0906cc51..000000000 --- a/quantum_espresso/kcp/CPV/cp_restart_backup.f90 +++ /dev/null @@ -1,4446 +0,0 @@ -! Copyright (C) 2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!----------------------------------------------------------------------------- -MODULE cp_restart - !----------------------------------------------------------------------------- - ! - ! ... This module contains subroutines to write and read data required to - ! ... restart a calculation from the disk - ! - USE iotk_module - USE xml_io_base, ONLY : default_fmt_version => fmt_version - USE xml_io_base - ! - USE kinds, ONLY : DP - USE io_global, ONLY : ionode, ionode_id, stdout - USE io_files, ONLY : prefix, iunpun, xmlpun, qexml_version, qexml_version_init - USE mp, ONLY : mp_bcast - USE parser, ONLY : version_compare - ! - IMPLICIT NONE - ! - SAVE - ! - PRIVATE :: read_cell - ! - INTEGER, PRIVATE :: iunout - ! - ! - ! variables to describe qexml current version - ! and back compatibility - ! - LOGICAL, PRIVATE :: qexml_version_before_1_4_0 = .FALSE. - ! - INTERFACE cp_writefile - module procedure cp_writefile_twin, cp_writefile_real - END INTERFACE cp_writefile - - INTERFACE cp_readfile - module procedure cp_readfile_twin, cp_readfile_real - END INTERFACE cp_readfile - ! - CONTAINS - ! - !------------------------------------------------------------------------ - SUBROUTINE cp_writefile_twin( ndw, outdir, ascii, nfi, simtime, acc, nk, xk, & - wk, ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, & - taui, cdmi, stau0, svel0, staum, svelm, force, & - vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ0, occm, & - lambda0,lambdam,lambda_bare, xnhe0, xnhem, vnhe,& - ekincm, et, rho, c02, cm2, ctot, iupdwn, nupdwn,& - iupdwn_tot, nupdwn_tot, mat_z ) - !------------------------------------------------------------------------ - ! - USE control_flags, ONLY : do_wf_cmplx, gamma_only, force_pairing, trhow, tksw !added:giovanni do_wf_cmplx! - USE control_flags, ONLY : evc_restart !added:giovanni evc_restart - USE io_files, ONLY : psfile, pseudo_dir - USE mp_global, ONLY : intra_image_comm, me_image, nproc_image - USE printout_base, ONLY : title - USE grid_dimensions, ONLY : nr1, nr2, nr3, nr1x, nr2x, nr3l - USE smooth_grid_dimensions, ONLY : nr1s, nr2s, nr3s - USE smallbox_grid_dimensions, ONLY : nr1b, nr2b, nr3b - USE gvecp, ONLY : ngm, ngmt, ecutp, gcutp - USE gvecs, ONLY : ngs, ngst, ecuts, gcuts, dual - USE gvecw, ONLY : ngw, ngwt, ecutw, gcutw - USE reciprocal_vectors, ONLY : ig_l2g, mill_l - USE electrons_base, ONLY : nspin, nelt, nel, nudx - USE cell_base, ONLY : ibrav, alat, celldm, & - symm_type, s_to_r - USE ions_base, ONLY : nsp, nat, na, atm, zv, & - pmass, amass, iforce, ind_bck - USE funct, ONLY : get_dft_name - USE energies, ONLY : enthal, ekin, eht, esr, eself, & - epseu, enl, exc, vave - USE mp_global, ONLY : nproc, mpime - USE mp, ONLY : mp_sum - USE fft_base, ONLY : dfftp - USE constants, ONLY : pi - USE cp_interfaces, ONLY : n_atom_wfc - USE global_version, ONLY : version_number - USE cp_main_variables, ONLY : collect_lambda, descla, collect_zmat - USE twin_types !added:giovanni - USE electrons_base, ONLY : nbsp !added:giovanni - USE nksic, ONLY : do_bare_eigs !added:giovanni - USE input_parameters, ONLY : odd_nkscalfact, restart_odd_nkscalfact, print_wfc_empty - USE wavefunctions_module, ONLY : c0_fixed, c0_emp_aux, cm_emp_aux - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ndw ! - CHARACTER(LEN=*), INTENT(IN) :: outdir ! directory used to store output and restart files - LOGICAL, INTENT(IN) :: ascii ! - INTEGER, INTENT(IN) :: nfi ! index of the current step - REAL(DP), INTENT(IN) :: simtime ! simulated time - REAL(DP), INTENT(IN) :: acc(:) ! - INTEGER, INTENT(IN) :: nk ! number of kpoints - REAL(DP), INTENT(IN) :: xk(:,:) ! k-points coordinates - REAL(DP), INTENT(IN) :: wk(:) ! k-points weights - REAL(DP), INTENT(IN) :: ht(3,3) ! - REAL(DP), INTENT(IN) :: htm(3,3) ! - REAL(DP), INTENT(IN) :: htvel(3,3) ! - REAL(DP), INTENT(IN) :: gvel(3,3) ! - REAL(DP), INTENT(IN) :: xnhh0(3,3) ! - REAL(DP), INTENT(IN) :: xnhhm(3,3) ! - REAL(DP), INTENT(IN) :: vnhh(3,3) ! - REAL(DP), INTENT(IN) :: taui(:,:) ! - REAL(DP), INTENT(IN) :: cdmi(:) ! - REAL(DP), INTENT(IN) :: stau0(:,:) ! - REAL(DP), INTENT(IN) :: svel0(:,:) ! - REAL(DP), INTENT(IN) :: staum(:,:) ! - REAL(DP), INTENT(IN) :: svelm(:,:) ! - REAL(DP), INTENT(IN) :: force(:,:) ! - REAL(DP), INTENT(IN) :: xnhp0(:) ! - REAL(DP), INTENT(IN) :: xnhpm(:) ! - REAL(DP), INTENT(IN) :: vnhp(:) ! - INTEGER, INTENT(IN) :: nhpcl ! - INTEGER, INTENT(IN) :: nhpdim ! - REAL(DP), INTENT(IN) :: occ0(:) ! occupations of electronic states - REAL(DP), INTENT(IN) :: occm(:) ! - TYPE(twin_matrix), DIMENSION(:), INTENT(IN) :: lambda0 - TYPE(twin_matrix), DIMENSION(:), INTENT(IN) :: lambdam - TYPE(twin_matrix), DIMENSION(:), INTENT(IN) :: lambda_bare -! REAL(DP), INTENT(IN) :: lambda0(:,:,:) ! !removed:giovanni -! REAL(DP), INTENT(IN) :: lambdam(:,:,:) ! !removed:giovanni - REAL(DP), INTENT(IN) :: xnhe0 ! - REAL(DP), INTENT(IN) :: xnhem ! - REAL(DP), INTENT(IN) :: vnhe ! - REAL(DP), INTENT(IN) :: ekincm ! - REAL(DP), INTENT(IN) :: et(:,:) ! eigenvalues - REAL(DP), INTENT(IN) :: rho(:,:) ! - COMPLEX(DP), INTENT(IN) :: c02(:,:) ! - COMPLEX(DP), INTENT(IN) :: cm2(:,:) ! - COMPLEX(DP), INTENT(IN) :: ctot(:,:) ! - INTEGER, INTENT(IN) :: iupdwn(:) ! - INTEGER, INTENT(IN) :: nupdwn(:) ! - INTEGER, INTENT(IN) :: iupdwn_tot(:)! - INTEGER, INTENT(IN) :: nupdwn_tot(:)! -! REAL(DP), OPTIONAL, INTENT(IN) :: mat_z(:,:,:) ! - TYPE(twin_matrix), DIMENSION(:), OPTIONAL, INTENT(IN) :: mat_z - ! - LOGICAL :: write_charge_density - CHARACTER(LEN=20) :: dft_name - CHARACTER(LEN=256) :: dirname, filename, rho_file_base - CHARACTER(LEN=4) :: cspin - INTEGER :: kunit, ib, ik_eff - INTEGER :: k1, k2, k3 - INTEGER :: nk1, nk2, nk3 - INTEGER :: j, i, iss, ig, nspin_wfc, iss_wfc - INTEGER :: is, ia, isa, ik, ierr - INTEGER, ALLOCATABLE :: mill(:,:) - INTEGER, ALLOCATABLE :: ftmp(:,:) - INTEGER, ALLOCATABLE :: ityp(:) - REAL(DP), ALLOCATABLE :: tau(:,:) - REAL(DP), ALLOCATABLE :: dtmp(:) - REAL(DP), ALLOCATABLE :: rhoaux(:) - REAL(DP) :: omega, htm1(3,3), h(3,3) - REAL(DP) :: a1(3), a2(3), a3(3) - REAL(DP) :: b1(3), b2(3), b3(3) - REAL(DP) :: nelec - REAL(DP) :: scalef - LOGICAL :: lsda - REAL(DP) :: s0, s1, cclock - INTEGER :: nbnd_tot - INTEGER :: nbnd_emp - INTEGER :: nbnd_ - REAL(DP), ALLOCATABLE :: mrepl(:,:) - COMPLEX(DP), ALLOCATABLE :: mrepl_c(:,:) !added:giovanni - COMPLEX(DP) :: csc(nbsp, nbsp) - INTEGER:: icsc, icsc2 - ! - write_charge_density = trhow - ! - IF( nspin > 1 .AND. .NOT. force_pairing ) THEN - ! - ! check if the array storing wave functions is large enought - ! - IF( SIZE( c02, 2 ) < ( iupdwn( 2 ) + nupdwn(1) - 1 ) ) & - CALL errore('cp_writefile',' wrong wave functions dimension ', 1 ) - ! - END IF - ! - IF( nupdwn_tot(1) < nupdwn(1) ) & - CALL errore( " writefile ", " wrong number of states ", 1 ) - ! - nbnd_ = nupdwn(1) - nbnd_tot = MAX( nupdwn(1), nupdwn_tot(1) ) - nbnd_emp = MAX( 0, nupdwn_tot(1) - nupdwn(1) ) - ! - IF ( ionode ) THEN - ! - ! ... look for an empty unit (only ionode needs it) - ! - CALL iotk_free_unit( iunout, ierr ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_writefile', & - 'no free units to write wavefunctions', ierr ) - ! - dirname = restart_dir( outdir, ndw ) - ! - ! ... Create main restart directory - ! - CALL create_directory( dirname ) - ! - ! ... Create k-points subdirectories - ! ... note: in FPMD and CP k-points are not distributed to processors - ! - DO i = 1, nk - ! - CALL create_directory( kpoint_dir( dirname, i ) ) - ! - END DO - ! - ! ... Some ( CP/FPMD ) default values - ! - IF ( nspin == 2 ) THEN - ! - kunit = 2 - ! - ELSE - ! - kunit = 1 - ! - END IF - ! - k1 = 0 - k2 = 0 - k3 = 0 - nk1 = 0 - nk2 = 0 - nk3 = 0 - ! - ! ... Compute Cell related variables - ! - h = TRANSPOSE( ht ) - ! - CALL invmat( 3, ht, htm1, omega ) - ! - a1 = ht(1,:) - a2 = ht(2,:) - a3 = ht(3,:) - ! - ! ... Beware: omega may be negative if axis are left-handed! - ! - scalef = 1.D0 / SQRT( ABS (omega) ) - ! - ! ... Compute array ityp, and tau - ! - ALLOCATE( ityp( nat ) ) - ALLOCATE( tau( 3, nat ) ) - ! - isa = 0 - ! - DO is = 1, nsp - ! - DO ia = 1, na(is) - ! - isa = isa + 1 - ityp(isa) = is - ! - END DO - ! - END DO - ! - CALL s_to_r( stau0, tau, na, nsp, h ) - ! - ! ... Collect G vectors - ! - ALLOCATE( mill( 3, ngmt ) ) - ! - mill = 0 - ! - mill(:,ig_l2g(1:ngm)) = mill_l(:,1:ngm) - ! - CALL mp_sum( mill, intra_image_comm ) - ! - lsda = ( nspin == 2 ) - ! - ALLOCATE( ftmp( nbnd_tot , nspin ) ) - ! - ftmp = 0.0d0 - ! - DO iss = 1, nspin - ! - ftmp( 1:nupdwn(iss), iss ) = occ0( iupdwn(iss) : iupdwn(iss) + nupdwn(iss) - 1 ) - ! - END DO - ! - IF ( ionode ) THEN - ! - ! ... Open XML descriptor - ! - WRITE( stdout, '(/,3X,"writing restart file: ",A)' ) TRIM( dirname ) - ! - CALL iotk_open_write( iunpun, FILE = TRIM( dirname ) // '/' // & - & TRIM( xmlpun ), BINARY = .FALSE., IERR = ierr ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_writefile ', 'cannot open restart file for writing', ierr ) - ! - s0 = cclock() - ! - IF ( ionode ) THEN - -!------------------------------------------------------------------------------- -! ... HEADER -!------------------------------------------------------------------------------- - ! - CALL write_header( "CP", TRIM(version_number) ) - ! -!------------------------------------------------------------------------------- -! ... this flag is used to check if the file can be used for post-processing -!------------------------------------------------------------------------------- - ! - CALL write_control( PP_CHECK_FLAG=.TRUE. ) - ! -!------------------------------------------------------------------------------- -! ... STATUS -!------------------------------------------------------------------------------- - ! - CALL iotk_write_begin( iunpun, "STATUS" ) - ! - CALL iotk_write_attr( attr, "ITERATION", nfi, FIRST = .TRUE. ) - CALL iotk_write_empty(iunpun, "STEP", attr ) - ! - CALL iotk_write_attr( attr, "UNITS", "pico-seconds", FIRST = .TRUE. ) - CALL iotk_write_dat( iunpun, "TIME", simtime, ATTR = attr ) - ! - CALL iotk_write_dat( iunpun, "TITLE", TRIM( title ) ) - ! - CALL iotk_write_attr( attr, "UNITS", "Hartree", FIRST = .TRUE. ) - CALL iotk_write_dat( iunpun, "KINETIC_ENERGY", ekin, ATTR = attr ) - CALL iotk_write_dat( iunpun, "HARTREE_ENERGY", eht, ATTR = attr ) - CALL iotk_write_dat( iunpun, "EWALD_TERM", esr, ATTR = attr ) - CALL iotk_write_dat( iunpun, "GAUSS_SELFINT", eself, ATTR = attr ) - CALL iotk_write_dat( iunpun, "LPSP_ENERGY", epseu, ATTR = attr ) - CALL iotk_write_dat( iunpun, "NLPSP_ENERGY", enl, ATTR = attr ) - CALL iotk_write_dat( iunpun, "EXC_ENERGY", exc, ATTR = attr ) - CALL iotk_write_dat( iunpun, "AVERAGE_POT", vave, ATTR = attr ) - CALL iotk_write_dat( iunpun, "ENTHALPY", enthal, ATTR = attr ) - ! - CALL iotk_write_end( iunpun, "STATUS" ) - ! -!------------------------------------------------------------------------------- -! ... CELL -!------------------------------------------------------------------------------- - ! - a1 = a1 / alat - a2 = a2 / alat - a3 = a3 / alat - ! - CALL recips( a1, a2, a3, b1, b2, b3 ) - ! - CALL write_cell( ibrav, symm_type, & - celldm, alat, a1, a2, a3, b1, b2, b3 ) - ! -!------------------------------------------------------------------------------- -! ... IONS -!------------------------------------------------------------------------------- - ! - CALL write_ions( nsp, nat, atm, ityp(ind_bck(:)), & - psfile, pseudo_dir, amass, tau(:,ind_bck(:)), & - iforce(:,ind_bck(:)), dirname, 1.D0 ) - ! -!------------------------------------------------------------------------------- -! ... PLANE_WAVES -!------------------------------------------------------------------------------- - ! - ! change to .TRUE. to write gvectors.dat for rho - ! - CALL write_planewaves( ecutw, dual, ngwt, do_wf_cmplx, gamma_only, & !added:giovanni do_wf_cmplx - nr1, nr2, nr3, ngmt, nr1s, nr2s, nr3s, & - ngst, nr1b, nr2b, nr3b, mill, .TRUE. ) - ! -!------------------------------------------------------------------------------- -! ... SPIN -!------------------------------------------------------------------------------- - ! - CALL write_spin( lsda, .FALSE., 1, .FALSE., .TRUE. ) - ! -!------------------------------------------------------------------------------- -! ... EXCHANGE_CORRELATION -!------------------------------------------------------------------------------- - ! - dft_name = get_dft_name() - CALL write_xc( DFT = dft_name, NSP = nsp, LDA_PLUS_U = .FALSE. ) - ! -!------------------------------------------------------------------------------- -! ... OCCUPATIONS -!------------------------------------------------------------------------------- - ! - CALL write_occ( LGAUSS = .FALSE., LTETRA = .FALSE., & - TFIXED_OCC = .TRUE., LSDA = lsda, NSTATES_UP = nupdwn_tot(1), & - NSTATES_DOWN = nupdwn_tot(2), F_INP = DBLE( ftmp ) ) - ! -!------------------------------------------------------------------------------- -! ... BRILLOUIN_ZONE -!------------------------------------------------------------------------------- - ! - CALL write_bz( nk, xk, wk, k1, k2, k3, nk1, nk2, nk3, 0.0_DP ) - ! -!------------------------------------------------------------------------------- -! ... PARALLELISM -!------------------------------------------------------------------------------- - ! - CALL iotk_write_begin( iunpun, "PARALLELISM" ) - ! - CALL iotk_write_dat( iunpun, & - "GRANULARITY_OF_K-POINTS_DISTRIBUTION", kunit ) - ! - CALL iotk_write_end( iunpun, "PARALLELISM" ) - ! - END IF - ! -!------------------------------------------------------------------------------- -! ... CHARGE-DENSITY -!------------------------------------------------------------------------------- - ! - IF (write_charge_density) then - ! - rho_file_base = 'charge-density' - ! - IF ( ionode )& - CALL iotk_link( iunpun, "CHARGE-DENSITY", rho_file_base, & - CREATE = .FALSE., BINARY = .TRUE. ) - ! - rho_file_base = TRIM( dirname ) // '/' // TRIM( rho_file_base ) - ! - IF ( nspin == 1 ) THEN - ! - CALL write_rho_xml( rho_file_base, rho(:,1), & - nr1, nr2, nr3, nr1x, nr2x, dfftp%ipp, dfftp%npp ) - ! - ELSE IF ( nspin == 2 ) THEN - ! - ALLOCATE( rhoaux( SIZE( rho, 1 ) ) ) - ! - rhoaux = rho(:,1) + rho(:,2) - ! - CALL write_rho_xml( rho_file_base, rhoaux, & - nr1, nr2, nr3, nr1x, nr2x, dfftp%ipp, dfftp%npp ) - ! - rho_file_base = 'spin-polarization' - ! - IF ( ionode ) & - CALL iotk_link( iunpun, "SPIN-POLARIZATION", rho_file_base, & - CREATE = .FALSE., BINARY = .TRUE. ) - ! - rho_file_base = TRIM( dirname ) // '/' // TRIM( rho_file_base ) - ! - rhoaux = rho(:,1) - rho(:,2) - ! - CALL write_rho_xml( rho_file_base, rhoaux, & - nr1, nr2, nr3, nr1x, nr2x, dfftp%ipp, dfftp%npp ) - ! - DEALLOCATE( rhoaux ) - ! - END IF - ! - END IF ! write_charge_density - ! -!------------------------------------------------------------------------------- -! ... TIMESTEPS -!------------------------------------------------------------------------------- - ! - IF ( ionode ) THEN - ! - CALL iotk_write_attr( attr, "nt", 2, FIRST = .TRUE. ) - ! - CALL iotk_write_begin( iunpun, "TIMESTEPS", attr ) - ! - ! ... STEP0 - ! - CALL iotk_write_begin( iunpun, "STEP0" ) - ! - CALL iotk_write_dat( iunpun, "ACCUMULATORS", acc ) - ! - CALL iotk_write_begin( iunpun, "IONS_POSITIONS" ) - CALL iotk_write_dat( iunpun, "stau", stau0(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "svel", svel0(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "taui", taui(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "cdmi", cdmi(1:3), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "force", force(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_write_begin( iunpun, "IONS_NOSE" ) - CALL iotk_write_dat( iunpun, "nhpcl", nhpcl ) - CALL iotk_write_dat( iunpun, "nhpdim", nhpdim ) - CALL iotk_write_dat( iunpun, "xnhp", xnhp0(1:nhpcl*nhpdim) ) - CALL iotk_write_dat( iunpun, "vnhp", vnhp(1:nhpcl*nhpdim) ) - CALL iotk_write_end( iunpun, "IONS_NOSE" ) - ! - CALL iotk_write_dat( iunpun, "ekincm", ekincm ) - ! - CALL iotk_write_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhe", xnhe0 ) - CALL iotk_write_dat( iunpun, "vnhe", vnhe ) - CALL iotk_write_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_write_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_write_dat( iunpun, "ht", ht ) - CALL iotk_write_dat( iunpun, "htvel", htvel ) - CALL iotk_write_dat( iunpun, "gvel", gvel ) - CALL iotk_write_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_write_begin( iunpun, "CELL_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhh", xnhh0 ) - CALL iotk_write_dat( iunpun, "vnhh", vnhh ) - CALL iotk_write_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_write_end( iunpun, "STEP0" ) - ! - ! ... STEPM - ! - CALL iotk_write_begin( iunpun, "STEPM" ) - ! - CALL iotk_write_begin( iunpun, "IONS_POSITIONS" ) - CALL iotk_write_dat( iunpun, "stau", staum(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "svel", svelm(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_write_begin( iunpun, "IONS_NOSE" ) - CALL iotk_write_dat( iunpun, "nhpcl", nhpcl ) - CALL iotk_write_dat( iunpun, "nhpdim", nhpdim ) - CALL iotk_write_dat( iunpun, "xnhp", xnhpm(1:nhpcl*nhpdim) ) - CALL iotk_write_end( iunpun, "IONS_NOSE" ) - ! - CALL iotk_write_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhe", xnhem ) - CALL iotk_write_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_write_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_write_dat( iunpun, "ht", htm ) - CALL iotk_write_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_write_begin( iunpun, "CELL_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhh", xnhhm ) - CALL iotk_write_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_write_end( iunpun, "STEPM" ) - ! - CALL iotk_write_end( iunpun, "TIMESTEPS" ) - ! - END IF - -!------------------------------------------------------------------------------- -! ... BAND_STRUCTURE_INFO -!------------------------------------------------------------------------------- - - IF ( ionode ) THEN - - ! - CALL iotk_write_begin( iunpun, "BAND_STRUCTURE_INFO" ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_ATOMIC_WFC", n_atom_wfc() ) - ! - nelec = nelt - ! - IF ( nspin == 2 ) THEN - ! - CALL iotk_write_attr( attr, "UP", nel(1), FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "DW", nel(2) ) - CALL iotk_write_dat( iunpun, & - "NUMBER_OF_ELECTRONS", nelec, ATTR = attr ) - ! - CALL iotk_write_attr( attr, "UP", nupdwn_tot(1), FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "DW", nupdwn_tot(2) ) - CALL iotk_write_dat( iunpun, & - "NUMBER_OF_BANDS", nbnd_tot , ATTR = attr ) - ! - ELSE - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_ELECTRONS", nelec ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_BANDS", nbnd_tot ) - ! - END IF - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_EMPTY_STATES", nbnd_emp ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_SPIN_COMPONENTS", nspin ) - ! - CALL iotk_write_end( iunpun, "BAND_STRUCTURE_INFO" ) - ! - CALL iotk_write_begin( iunpun, "EIGENVALUES" ) - ! - ! - END IF - ! -!------------------------------------------------------------------------------- -! ... EIGENVALUES -!------------------------------------------------------------------------------- - ! - k_points_loop1: DO ik = 1, nk - ! - IF ( ionode ) THEN - ! - CALL iotk_write_begin( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - CALL iotk_write_attr( attr, "UNITS", "2 pi / a", FIRST = .TRUE. ) - CALL iotk_write_dat( iunpun, & - "K-POINT_COORDS", xk(:,ik), ATTR = attr ) - ! - CALL iotk_write_dat( iunpun, "WEIGHT", wk(ik) ) - ! - ALLOCATE( dtmp ( nbnd_tot ) ) - ! - DO iss = 1, nspin - ! - cspin = iotk_index( iss ) - ! - dtmp = 0.0d0 - ! - IF( tksw ) THEN - ! - ! writes data required by postproc and PW - ! - IF( nspin == 2 ) THEN - IF( iss == 1 ) filename = wfc_filename( ".", 'eigenval1', ik, EXTENSION='xml' ) - IF( iss == 2 ) filename = wfc_filename( ".", 'eigenval2', ik, EXTENSION='xml' ) - ! - IF( iss == 1 ) CALL iotk_link( iunpun, "DATAFILE.1", & - filename, CREATE = .FALSE., BINARY = .FALSE. ) - IF( iss == 2 ) CALL iotk_link( iunpun, "DATAFILE.2", & - filename, CREATE = .FALSE., BINARY = .FALSE. ) - - IF( iss == 1 ) filename = wfc_filename( dirname, 'eigenval1', ik, EXTENSION='xml' ) - IF( iss == 2 ) filename = wfc_filename( dirname, 'eigenval2', ik, EXTENSION='xml' ) - ELSE - filename = wfc_filename( ".", 'eigenval', ik, EXTENSION='xml' ) - CALL iotk_link( iunpun, "DATAFILE", filename, CREATE = .FALSE., BINARY = .FALSE. ) - filename = wfc_filename( dirname, 'eigenval', ik, EXTENSION='xml' ) - END IF - - dtmp ( 1:nupdwn( iss ) ) = occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) / wk(ik) - ! - CALL write_eig( iunout, filename, nbnd_tot, et( 1:nbnd_tot, iss) , "Hartree", & - OCC = dtmp(:), IK=ik, ISPIN=iss ) - ! - END IF - ! - CALL iotk_write_dat( iunpun, "OCC0" // TRIM( cspin ), & - occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) ) - ! - CALL iotk_write_dat( iunpun, "OCCM" // TRIM( cspin ), & - occm( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) ) - ! - END DO - ! - DEALLOCATE( dtmp ) - ! - CALL iotk_write_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - - END IF - ! - END DO k_points_loop1 - ! - IF ( ionode ) THEN - ! - CALL iotk_write_end( iunpun, "EIGENVALUES" ) - ! - CALL iotk_write_begin( iunpun, "EIGENVECTORS" ) - ! - CALL iotk_write_dat ( iunpun, "MAX_NUMBER_OF_GK-VECTORS", ngwt ) - ! - END IF - ! -!------------------------------------------------------------------------------- -! ... EIGENVECTORS -!------------------------------------------------------------------------------- - ! - k_points_loop2: DO ik = 1, nk - - IF( ionode ) THEN - - CALL iotk_write_begin( iunpun, "K-POINT" // TRIM( iotk_index( ik ) ) ) - ! - ! ... G+K vectors - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_GK-VECTORS", ngwt ) - ! - ! - filename = TRIM( wfc_filename( ".", 'gkvectors', ik ) ) - ! - CALL iotk_link( iunpun, "GK-VECTORS", filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - filename = TRIM( wfc_filename( dirname, 'gkvectors', ik ) ) - ! - END IF - ! - CALL write_gk( iunout, ik, mill, filename ) - ! - DO iss = 1, nspin - ! - ik_eff = ik + ( iss - 1 ) * nk - ! - iss_wfc = iss - if( force_pairing ) iss_wfc = 1 ! only the WF for the first spin is allocated - ! - IF( tksw ) THEN - ! - ! Save additional WF, - ! orthogonal KS states to be used for post processing and PW - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc', ik, iss ) ) - ! - END IF - ! - IF( nspin == 2 ) THEN - CALL iotk_link( iunpun, "WFC" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ELSE - CALL iotk_link( iunpun, "WFC", filename, CREATE = .FALSE., BINARY = .TRUE. ) - END IF - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn_tot( iss_wfc ) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & !added_giovanni do_wf_cmplx - ctot( :, ib : ib + nbnd_tot - 1 ), ngwt, do_wf_cmplx, & - gamma_only, nbnd_tot, ig_l2g, ngw, filename, scalef) - ! - END IF - ! - ! Save wave function at time t - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc0', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc0', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFC0" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc0', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc0', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - IF(.not. evc_restart) then - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - c02( :, ib : ib + nbnd_ - 1 ), ngwt, do_wf_cmplx, & !added:giovanni do_wf_cmplx - gamma_only, nbnd_, ig_l2g, ngw, filename, scalef) - ELSE - WRITE(*,*) "Careful: I am writing Kohn-Sham eigenstates as restart wavefunctions" - WRITE(*,*) "Errors may happen" - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - ctot( :, ib : ib + nbnd_ - 1 ), ngwt, do_wf_cmplx, & !added:giovanni do_wf_cmplx - gamma_only, nbnd_, ig_l2g, ngw, filename, scalef) - ENDIF - ! - ! Save wave function at time t - dt - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evcm', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evcm', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFCM" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evcm', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evcm', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - cm2( :, ib : ib + nbnd_ - 1 ), ngwt, do_wf_cmplx, & !added:giovanni do_wf_cmplx - gamma_only, nbnd_, ig_l2g, ngw, filename, scalef) - ! - ! Save fixed wave function - ! - IF (odd_nkscalfact) THEN - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc0fixed', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc0fixed', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFC0FIXED" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc0fixed', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc0fixed', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - c0_fixed( :, ib : ib + nbnd_ - 1 ), ngwt, do_wf_cmplx, & !added:giovanni do_wf_cmplx - gamma_only, nbnd_, ig_l2g, ngw, filename, scalef) - ! - ENDIF - ! - ! - IF (print_wfc_empty .and. (nbnd_emp>0) ) THEN - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc0empty', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc0empty', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFC0EMPTY" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc0empty', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc0empty', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - c0_emp_aux( :, ib : ib + nbnd_emp - 1 ), ngwt, do_wf_cmplx, & !added:giovanni do_wf_cmplx - gamma_only, nbnd_emp, ig_l2g, ngw, filename, scalef) - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evcmempty', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evcmempty', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFCMEMPTY" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evcmempty', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evcmempty', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - cm_emp_aux( :, ib : ib + nbnd_emp - 1 ), ngwt, do_wf_cmplx, & !added:giovanni do_wf_cmplx - gamma_only, nbnd_emp, ig_l2g, ngw, filename, scalef) - ! - ENDIF - ! - cspin = iotk_index( iss ) - ! - ! ... write matrix lambda to file - ! - IF(.not. lambda0(1)%iscmplx) THEN - ALLOCATE( mrepl( nudx, nudx ) ) - CALL collect_lambda( mrepl, lambda0(iss)%rvec(:,:), descla(:,iss) ) - ELSE - ALLOCATE( mrepl_c( nudx, nudx) ) - CALL collect_lambda( mrepl_c, lambda0(iss)%cvec(:,:), descla(:,iss)) - ENDIF - ! - ! - IF ( ionode ) THEN - ! - filename = TRIM( wfc_filename( ".", 'lambda0', ik, iss ) ) - ! - CALL iotk_link( iunpun, "LAMBDA0" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .TRUE. ) - ! - IF(.not. lambda0(1)%iscmplx) THEN - CALL iotk_write_dat( iunpun, & - "LAMBDA0" // TRIM( cspin ), mrepl ) - ELSE - CALL iotk_write_dat( iunpun, & - "LAMBDA0" // TRIM( cspin ), mrepl_c ) - ENDIF - ! - ! Changes by Nicolas Poilvert, Sep. 2010 for printing the lambda - ! matrix at current time step into a formatted file. - ! This matrix corresponds to the Hamiltonian matrix in the case - ! of Self-Interaction. Only in the basis of minimizing orbitals - ! do this matrix has an interpretation. - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'hamiltonian', ik, EXTENSION='xml' ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'hamiltonian', ik, iss, EXTENSION='xml' ) ) - ! - ENDIF - ! - CALL iotk_link( iunpun, "HAMILTONIAN" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .FALSE. ) - ! - IF(allocated(mrepl)) THEN - CALL iotk_write_dat( iunpun, & - "HAMILTONIAN" // TRIM( cspin ), mrepl ) - ELSE IF(allocated(mrepl_c)) THEN - CALL iotk_write_dat( iunpun, & - "HAMILTONIAN" // TRIM( cspin ), mrepl_c ) - ENDIF - ! - ENDIF - - IF(do_bare_eigs) THEN - ! - IF(.not. lambda_bare(1)%iscmplx) THEN - mrepl=0.d0 - CALL collect_lambda( mrepl, lambda_bare(iss)%rvec(:,:), descla(:,iss) ) - ELSE - mrepl_c=0.d0 - CALL collect_lambda( mrepl_c, lambda_bare(iss)%cvec(:,:), descla(:,iss)) - ENDIF - ! - IF(ionode) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'hamiltonian0', ik, EXTENSION='xml' ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'hamiltonian0', ik, iss, EXTENSION='xml' ) ) - ! - ENDIF - ! - CALL iotk_link( iunpun, "HAMILTONIAN0" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .FALSE. ) - ! - IF(allocated(mrepl)) THEN - CALL iotk_write_dat( iunpun, & - "HAMILTONIAN0" // TRIM( cspin ), mrepl ) - ELSE IF(allocated(mrepl_c)) THEN - CALL iotk_write_dat( iunpun, & - "HAMILTONIAN0" // TRIM( cspin ), mrepl_c ) - ENDIF - ! - ENDIF - ! - END IF - ! - IF(.not. lambdam(1)%iscmplx) THEN - CALL collect_lambda( mrepl, lambdam(iss)%rvec(:,:), descla(:,iss) ) - ELSE - CALL collect_lambda( mrepl_c, lambdam(iss)%cvec(:,:), descla(:,iss)) - ENDIF - ! - IF ( ionode ) THEN - ! - filename = TRIM( wfc_filename( ".", 'lambdam', ik, iss ) ) - ! - CALL iotk_link( iunpun, "LAMBDAM" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .TRUE. ) - ! - IF(allocated(mrepl)) THEN - CALL iotk_write_dat( iunpun, & - "LAMBDAM" // TRIM( cspin ), mrepl ) - ELSE IF(allocated(mrepl_c)) THEN - CALL iotk_write_dat( iunpun, & - "LAMBDAM" // TRIM( cspin ), mrepl_c ) - ENDIF - - ! - END IF - ! - ! - IF( PRESENT( mat_z ) ) THEN - ! - IF(.not.mat_z(iss)%iscmplx) THEN - IF(.not.allocated(mrepl)) THEN - ALLOCATE( mrepl( nudx, nudx ) ) - ENDIF - CALL collect_zmat( mrepl, mat_z(iss)%rvec(:,:), descla(:,iss) ) - ELSE - IF(.not.allocated(mrepl_c)) THEN - ALLOCATE( mrepl_c( nudx, nudx ) ) - ENDIF - CALL collect_zmat( mrepl_c, mat_z(iss)%cvec(:,:), descla(:,iss) ) - ENDIF - ! - IF ( ionode ) THEN - ! - filename = TRIM( wfc_filename( ".", 'mat_z', ik, iss ) ) - ! - CALL iotk_link( iunpun, "MAT_Z" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .TRUE. ) - ! - IF(.not.mat_z(iss)%iscmplx) THEN - CALL iotk_write_dat( iunpun, "MAT_Z" // TRIM( cspin ), mrepl ) - ELSE - CALL iotk_write_dat( iunpun, "MAT_Z" // TRIM( cspin ), mrepl_c ) - ENDIF - ! - END IF - ! - - END IF - ! - IF(allocated(mrepl)) THEN - DEALLOCATE( mrepl ) - ENDIF - IF(allocated(mrepl_c)) THEN - DEALLOCATE( mrepl_c ) - ENDIF - ! - END DO - ! - IF ( ionode ) & - CALL iotk_write_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - END DO k_points_loop2 - ! - IF ( ionode ) CALL iotk_write_end( iunpun, "EIGENVECTORS" ) - ! - IF ( ionode ) CALL iotk_close_write( iunpun ) - ! -!------------------------------------------------------------------------------- -! ... END RESTART SECTIONS -!------------------------------------------------------------------------------- - ! - DEALLOCATE( ftmp ) - DEALLOCATE( tau ) - DEALLOCATE( ityp ) - DEALLOCATE( mill ) - ! - CALL save_history( dirname, nfi ) - ! - s1 = cclock() - ! - IF ( ionode ) THEN - ! - WRITE( stdout, & - '(3X,"restart file written in ",F8.3," sec.",/)' ) ( s1 - s0 ) - ! - END IF - ! - RETURN - ! - END SUBROUTINE cp_writefile_twin - ! - SUBROUTINE cp_writefile_real( ndw, outdir, ascii, nfi, simtime, acc, nk, xk, & - wk, ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, & - taui, cdmi, stau0, svel0, staum, svelm, force, & - vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ0, occm, & - lambda0,lambdam, xnhe0, xnhem, vnhe, ekincm, & - et, rho, c02, cm2, ctot, iupdwn, nupdwn, & - iupdwn_tot, nupdwn_tot, mat_z ) - !------------------------------------------------------------------------ - ! - USE control_flags, ONLY : gamma_only, do_wf_cmplx, force_pairing, trhow, tksw !added:giovanni do_wf_cmplx - USE io_files, ONLY : psfile, pseudo_dir - USE mp_global, ONLY : intra_image_comm, me_image, nproc_image - USE printout_base, ONLY : title - USE grid_dimensions, ONLY : nr1, nr2, nr3, nr1x, nr2x, nr3l - USE smooth_grid_dimensions, ONLY : nr1s, nr2s, nr3s - USE smallbox_grid_dimensions, ONLY : nr1b, nr2b, nr3b - USE gvecp, ONLY : ngm, ngmt, ecutp, gcutp - USE gvecs, ONLY : ngs, ngst, ecuts, gcuts, dual - USE gvecw, ONLY : ngw, ngwt, ecutw, gcutw - USE reciprocal_vectors, ONLY : ig_l2g, mill_l - USE electrons_base, ONLY : nspin, nelt, nel, nudx - USE cell_base, ONLY : ibrav, alat, celldm, & - symm_type, s_to_r - USE ions_base, ONLY : nsp, nat, na, atm, zv, & - pmass, amass, iforce, ind_bck - USE funct, ONLY : get_dft_name - USE energies, ONLY : enthal, ekin, eht, esr, eself, & - epseu, enl, exc, vave - USE mp_global, ONLY : nproc, mpime - USE mp, ONLY : mp_sum - USE fft_base, ONLY : dfftp - USE constants, ONLY : pi - USE cp_interfaces, ONLY : n_atom_wfc - USE global_version, ONLY : version_number - USE cp_main_variables, ONLY : collect_lambda, descla, collect_zmat - USE input_parameters, ONLY : odd_nkscalfact, restart_odd_nkscalfact, print_wfc_empty - USE wavefunctions_module, ONLY : c0_fixed, c0_emp_aux, cm_emp_aux - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ndw ! - CHARACTER(LEN=*), INTENT(IN) :: outdir ! directory used to store output and restart files - LOGICAL, INTENT(IN) :: ascii ! - INTEGER, INTENT(IN) :: nfi ! index of the current step - REAL(DP), INTENT(IN) :: simtime ! simulated time - REAL(DP), INTENT(IN) :: acc(:) ! - INTEGER, INTENT(IN) :: nk ! number of kpoints - REAL(DP), INTENT(IN) :: xk(:,:) ! k-points coordinates - REAL(DP), INTENT(IN) :: wk(:) ! k-points weights - REAL(DP), INTENT(IN) :: ht(3,3) ! - REAL(DP), INTENT(IN) :: htm(3,3) ! - REAL(DP), INTENT(IN) :: htvel(3,3) ! - REAL(DP), INTENT(IN) :: gvel(3,3) ! - REAL(DP), INTENT(IN) :: xnhh0(3,3) ! - REAL(DP), INTENT(IN) :: xnhhm(3,3) ! - REAL(DP), INTENT(IN) :: vnhh(3,3) ! - REAL(DP), INTENT(IN) :: taui(:,:) ! - REAL(DP), INTENT(IN) :: cdmi(:) ! - REAL(DP), INTENT(IN) :: stau0(:,:) ! - REAL(DP), INTENT(IN) :: svel0(:,:) ! - REAL(DP), INTENT(IN) :: staum(:,:) ! - REAL(DP), INTENT(IN) :: svelm(:,:) ! - REAL(DP), INTENT(IN) :: force(:,:) ! - REAL(DP), INTENT(IN) :: xnhp0(:) ! - REAL(DP), INTENT(IN) :: xnhpm(:) ! - REAL(DP), INTENT(IN) :: vnhp(:) ! - INTEGER, INTENT(IN) :: nhpcl ! - INTEGER, INTENT(IN) :: nhpdim ! - REAL(DP), INTENT(IN) :: occ0(:) ! occupations of electronic states - REAL(DP), INTENT(IN) :: occm(:) ! - REAL(DP), INTENT(IN) :: lambda0(:,:,:) ! - REAL(DP), INTENT(IN) :: lambdam(:,:,:) ! - REAL(DP), INTENT(IN) :: xnhe0 ! - REAL(DP), INTENT(IN) :: xnhem ! - REAL(DP), INTENT(IN) :: vnhe ! - REAL(DP), INTENT(IN) :: ekincm ! - REAL(DP), INTENT(IN) :: et(:,:) ! eigenvalues - REAL(DP), INTENT(IN) :: rho(:,:) ! - COMPLEX(DP), INTENT(IN) :: c02(:,:) ! - COMPLEX(DP), INTENT(IN) :: cm2(:,:) ! - COMPLEX(DP), INTENT(IN) :: ctot(:,:) ! - INTEGER, INTENT(IN) :: iupdwn(:) ! - INTEGER, INTENT(IN) :: nupdwn(:) ! - INTEGER, INTENT(IN) :: iupdwn_tot(:)! - INTEGER, INTENT(IN) :: nupdwn_tot(:)! - REAL(DP), OPTIONAL, INTENT(IN) :: mat_z(:,:,:) ! - ! - LOGICAL :: write_charge_density - CHARACTER(LEN=20) :: dft_name - CHARACTER(LEN=256) :: dirname, filename, rho_file_base - CHARACTER(LEN=4) :: cspin - INTEGER :: kunit, ib, ik_eff - INTEGER :: k1, k2, k3 - INTEGER :: nk1, nk2, nk3 - INTEGER :: j, i, iss, ig, nspin_wfc, iss_wfc - INTEGER :: is, ia, isa, ik, ierr - INTEGER, ALLOCATABLE :: mill(:,:) - INTEGER, ALLOCATABLE :: ftmp(:,:) - INTEGER, ALLOCATABLE :: ityp(:) - REAL(DP), ALLOCATABLE :: tau(:,:) - REAL(DP), ALLOCATABLE :: dtmp(:) - REAL(DP), ALLOCATABLE :: rhoaux(:) - REAL(DP) :: omega, htm1(3,3), h(3,3) - REAL(DP) :: a1(3), a2(3), a3(3) - REAL(DP) :: b1(3), b2(3), b3(3) - REAL(DP) :: nelec - REAL(DP) :: scalef - LOGICAL :: lsda - REAL(DP) :: s0, s1, cclock - INTEGER :: nbnd_tot - INTEGER :: nbnd_emp - INTEGER :: nbnd_ - REAL(DP), ALLOCATABLE :: mrepl(:,:) - ! - write_charge_density = trhow - ! - IF( nspin > 1 .AND. .NOT. force_pairing ) THEN - ! - ! check if the array storing wave functions is large enought - ! - IF( SIZE( c02, 2 ) < ( iupdwn( 2 ) + nupdwn(1) - 1 ) ) & - CALL errore('cp_writefile',' wrong wave functions dimension ', 1 ) - ! - END IF - ! - IF( nupdwn_tot(1) < nupdwn(1) ) & - CALL errore( " writefile ", " wrong number of states ", 1 ) - ! - nbnd_ = nupdwn(1) - nbnd_tot = MAX( nupdwn(1), nupdwn_tot(1) ) - nbnd_emp = MAX( 0, nupdwn_tot(1) - nupdwn(1) ) - ! - IF ( ionode ) THEN - ! - ! ... look for an empty unit (only ionode needs it) - ! - CALL iotk_free_unit( iunout, ierr ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_writefile', & - 'no free units to write wavefunctions', ierr ) - ! - dirname = restart_dir( outdir, ndw ) - ! - ! ... Create main restart directory - ! - CALL create_directory( dirname ) - ! - ! ... Create k-points subdirectories - ! ... note: in FPMD and CP k-points are not distributed to processors - ! - DO i = 1, nk - ! - CALL create_directory( kpoint_dir( dirname, i ) ) - ! - END DO - ! - ! ... Some ( CP/FPMD ) default values - ! - IF ( nspin == 2 ) THEN - ! - kunit = 2 - ! - ELSE - ! - kunit = 1 - ! - END IF - ! - k1 = 0 - k2 = 0 - k3 = 0 - nk1 = 0 - nk2 = 0 - nk3 = 0 - ! - ! ... Compute Cell related variables - ! - h = TRANSPOSE( ht ) - ! - CALL invmat( 3, ht, htm1, omega ) - ! - a1 = ht(1,:) - a2 = ht(2,:) - a3 = ht(3,:) - ! - ! ... Beware: omega may be negative if axis are left-handed! - ! - scalef = 1.D0 / SQRT( ABS (omega) ) - ! - ! ... Compute array ityp, and tau - ! - ALLOCATE( ityp( nat ) ) - ALLOCATE( tau( 3, nat ) ) - ! - isa = 0 - ! - DO is = 1, nsp - ! - DO ia = 1, na(is) - ! - isa = isa + 1 - ityp(isa) = is - ! - END DO - ! - END DO - ! - CALL s_to_r( stau0, tau, na, nsp, h ) - ! - ! ... Collect G vectors - ! - ALLOCATE( mill( 3, ngmt ) ) - ! - mill = 0 - ! - mill(:,ig_l2g(1:ngm)) = mill_l(:,1:ngm) - ! - CALL mp_sum( mill, intra_image_comm ) - ! - lsda = ( nspin == 2 ) - ! - ALLOCATE( ftmp( nbnd_tot , nspin ) ) - ! - ftmp = 0.0d0 - ! - DO iss = 1, nspin - ! - ftmp( 1:nupdwn(iss), iss ) = occ0( iupdwn(iss) : iupdwn(iss) + nupdwn(iss) - 1 ) - ! - END DO - ! - IF ( ionode ) THEN - ! - ! ... Open XML descriptor - ! - WRITE( stdout, '(/,3X,"writing restart file: ",A)' ) TRIM( dirname ) - ! - CALL iotk_open_write( iunpun, FILE = TRIM( dirname ) // '/' // & - & TRIM( xmlpun ), BINARY = .FALSE., IERR = ierr ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_writefile ', 'cannot open restart file for writing', ierr ) - ! - s0 = cclock() - ! - IF ( ionode ) THEN - -!------------------------------------------------------------------------------- -! ... HEADER -!------------------------------------------------------------------------------- - ! - CALL write_header( "CP", TRIM(version_number) ) - ! -!------------------------------------------------------------------------------- -! ... this flag is used to check if the file can be used for post-processing -!------------------------------------------------------------------------------- - ! - CALL write_control( PP_CHECK_FLAG=.TRUE. ) - ! -!------------------------------------------------------------------------------- -! ... STATUS -!------------------------------------------------------------------------------- - ! - CALL iotk_write_begin( iunpun, "STATUS" ) - ! - CALL iotk_write_attr( attr, "ITERATION", nfi, FIRST = .TRUE. ) - CALL iotk_write_empty(iunpun, "STEP", attr ) - ! - CALL iotk_write_attr( attr, "UNITS", "pico-seconds", FIRST = .TRUE. ) - CALL iotk_write_dat( iunpun, "TIME", simtime, ATTR = attr ) - ! - CALL iotk_write_dat( iunpun, "TITLE", TRIM( title ) ) - ! - CALL iotk_write_attr( attr, "UNITS", "Hartree", FIRST = .TRUE. ) - CALL iotk_write_dat( iunpun, "KINETIC_ENERGY", ekin, ATTR = attr ) - CALL iotk_write_dat( iunpun, "HARTREE_ENERGY", eht, ATTR = attr ) - CALL iotk_write_dat( iunpun, "EWALD_TERM", esr, ATTR = attr ) - CALL iotk_write_dat( iunpun, "GAUSS_SELFINT", eself, ATTR = attr ) - CALL iotk_write_dat( iunpun, "LPSP_ENERGY", epseu, ATTR = attr ) - CALL iotk_write_dat( iunpun, "NLPSP_ENERGY", enl, ATTR = attr ) - CALL iotk_write_dat( iunpun, "EXC_ENERGY", exc, ATTR = attr ) - CALL iotk_write_dat( iunpun, "AVERAGE_POT", vave, ATTR = attr ) - CALL iotk_write_dat( iunpun, "ENTHALPY", enthal, ATTR = attr ) - ! - CALL iotk_write_end( iunpun, "STATUS" ) - ! -!------------------------------------------------------------------------------- -! ... CELL -!------------------------------------------------------------------------------- - ! - a1 = a1 / alat - a2 = a2 / alat - a3 = a3 / alat - ! - CALL recips( a1, a2, a3, b1, b2, b3 ) - ! - CALL write_cell( ibrav, symm_type, & - celldm, alat, a1, a2, a3, b1, b2, b3 ) - ! -!------------------------------------------------------------------------------- -! ... IONS -!------------------------------------------------------------------------------- - ! - CALL write_ions( nsp, nat, atm, ityp(ind_bck(:)), & - psfile, pseudo_dir, amass, tau(:,ind_bck(:)), & - iforce(:,ind_bck(:)), dirname, 1.D0 ) - ! -!------------------------------------------------------------------------------- -! ... PLANE_WAVES -!------------------------------------------------------------------------------- - ! - ! change to .TRUE. to write gvectors.dat for rho - ! - CALL write_planewaves( ecutw, dual, ngwt, do_wf_cmplx, gamma_only, & - !added:giovanni do_wf_cmplx - nr1, nr2, nr3, ngmt, nr1s, nr2s, nr3s, ngst, nr1b, & - nr2b, nr3b, mill, .FALSE. ) - ! -!------------------------------------------------------------------------------- -! ... SPIN -!------------------------------------------------------------------------------- - ! - CALL write_spin( lsda, .FALSE., 1, .FALSE., .TRUE. ) - ! -!------------------------------------------------------------------------------- -! ... EXCHANGE_CORRELATION -!------------------------------------------------------------------------------- - ! - dft_name = get_dft_name() - CALL write_xc( DFT = dft_name, NSP = nsp, LDA_PLUS_U = .FALSE. ) - ! -!------------------------------------------------------------------------------- -! ... OCCUPATIONS -!------------------------------------------------------------------------------- - ! - CALL write_occ( LGAUSS = .FALSE., LTETRA = .FALSE., & - TFIXED_OCC = .TRUE., LSDA = lsda, NSTATES_UP = nupdwn_tot(1), & - NSTATES_DOWN = nupdwn_tot(2), F_INP = DBLE( ftmp ) ) - ! -!------------------------------------------------------------------------------- -! ... BRILLOUIN_ZONE -!------------------------------------------------------------------------------- - ! - CALL write_bz( nk, xk, wk, k1, k2, k3, nk1, nk2, nk3, 0.0_DP ) - ! -!------------------------------------------------------------------------------- -! ... PARALLELISM -!------------------------------------------------------------------------------- - ! - CALL iotk_write_begin( iunpun, "PARALLELISM" ) - ! - CALL iotk_write_dat( iunpun, & - "GRANULARITY_OF_K-POINTS_DISTRIBUTION", kunit ) - ! - CALL iotk_write_end( iunpun, "PARALLELISM" ) - ! - END IF - ! -!------------------------------------------------------------------------------- -! ... CHARGE-DENSITY -!------------------------------------------------------------------------------- - ! - IF (write_charge_density) then - ! - rho_file_base = 'charge-density' - ! - IF ( ionode )& - CALL iotk_link( iunpun, "CHARGE-DENSITY", rho_file_base, & - CREATE = .FALSE., BINARY = .TRUE. ) - ! - rho_file_base = TRIM( dirname ) // '/' // TRIM( rho_file_base ) - ! - IF ( nspin == 1 ) THEN - ! - CALL write_rho_xml( rho_file_base, rho(:,1), & - nr1, nr2, nr3, nr1x, nr2x, dfftp%ipp, dfftp%npp ) - ! - ELSE IF ( nspin == 2 ) THEN - ! - ALLOCATE( rhoaux( SIZE( rho, 1 ) ) ) - ! - rhoaux = rho(:,1) + rho(:,2) - ! - CALL write_rho_xml( rho_file_base, rhoaux, & - nr1, nr2, nr3, nr1x, nr2x, dfftp%ipp, dfftp%npp ) - ! - rho_file_base = 'spin-polarization' - ! - IF ( ionode ) & - CALL iotk_link( iunpun, "SPIN-POLARIZATION", rho_file_base, & - CREATE = .FALSE., BINARY = .TRUE. ) - ! - rho_file_base = TRIM( dirname ) // '/' // TRIM( rho_file_base ) - ! - rhoaux = rho(:,1) - rho(:,2) - ! - CALL write_rho_xml( rho_file_base, rhoaux, & - nr1, nr2, nr3, nr1x, nr2x, dfftp%ipp, dfftp%npp ) - ! - DEALLOCATE( rhoaux ) - ! - END IF - ! - END IF ! write_charge_density - ! -!------------------------------------------------------------------------------- -! ... TIMESTEPS -!------------------------------------------------------------------------------- - ! - IF ( ionode ) THEN - ! - CALL iotk_write_attr( attr, "nt", 2, FIRST = .TRUE. ) - ! - CALL iotk_write_begin( iunpun, "TIMESTEPS", attr ) - ! - ! ... STEP0 - ! - CALL iotk_write_begin( iunpun, "STEP0" ) - ! - CALL iotk_write_dat( iunpun, "ACCUMULATORS", acc ) - ! - CALL iotk_write_begin( iunpun, "IONS_POSITIONS" ) - CALL iotk_write_dat( iunpun, "stau", stau0(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "svel", svel0(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "taui", taui(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "cdmi", cdmi(1:3), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "force", force(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_write_begin( iunpun, "IONS_NOSE" ) - CALL iotk_write_dat( iunpun, "nhpcl", nhpcl ) - CALL iotk_write_dat( iunpun, "nhpdim", nhpdim ) - CALL iotk_write_dat( iunpun, "xnhp", xnhp0(1:nhpcl*nhpdim) ) - CALL iotk_write_dat( iunpun, "vnhp", vnhp(1:nhpcl*nhpdim) ) - CALL iotk_write_end( iunpun, "IONS_NOSE" ) - ! - CALL iotk_write_dat( iunpun, "ekincm", ekincm ) - ! - CALL iotk_write_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhe", xnhe0 ) - CALL iotk_write_dat( iunpun, "vnhe", vnhe ) - CALL iotk_write_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_write_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_write_dat( iunpun, "ht", ht ) - CALL iotk_write_dat( iunpun, "htvel", htvel ) - CALL iotk_write_dat( iunpun, "gvel", gvel ) - CALL iotk_write_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_write_begin( iunpun, "CELL_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhh", xnhh0 ) - CALL iotk_write_dat( iunpun, "vnhh", vnhh ) - CALL iotk_write_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_write_end( iunpun, "STEP0" ) - ! - ! ... STEPM - ! - CALL iotk_write_begin( iunpun, "STEPM" ) - ! - CALL iotk_write_begin( iunpun, "IONS_POSITIONS" ) - CALL iotk_write_dat( iunpun, "stau", staum(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "svel", svelm(1:3,1:nat), COLUMNS=3 ) - CALL iotk_write_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_write_begin( iunpun, "IONS_NOSE" ) - CALL iotk_write_dat( iunpun, "nhpcl", nhpcl ) - CALL iotk_write_dat( iunpun, "nhpdim", nhpdim ) - CALL iotk_write_dat( iunpun, "xnhp", xnhpm(1:nhpcl*nhpdim) ) - CALL iotk_write_end( iunpun, "IONS_NOSE" ) - ! - CALL iotk_write_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhe", xnhem ) - CALL iotk_write_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_write_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_write_dat( iunpun, "ht", htm ) - CALL iotk_write_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_write_begin( iunpun, "CELL_NOSE" ) - CALL iotk_write_dat( iunpun, "xnhh", xnhhm ) - CALL iotk_write_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_write_end( iunpun, "STEPM" ) - ! - CALL iotk_write_end( iunpun, "TIMESTEPS" ) - ! - END IF - -!------------------------------------------------------------------------------- -! ... BAND_STRUCTURE_INFO -!------------------------------------------------------------------------------- - - IF ( ionode ) THEN - - ! - CALL iotk_write_begin( iunpun, "BAND_STRUCTURE_INFO" ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_ATOMIC_WFC", n_atom_wfc() ) - ! - nelec = nelt - ! - IF ( nspin == 2 ) THEN - ! - CALL iotk_write_attr( attr, "UP", nel(1), FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "DW", nel(2) ) - CALL iotk_write_dat( iunpun, & - "NUMBER_OF_ELECTRONS", nelec, ATTR = attr ) - ! - CALL iotk_write_attr( attr, "UP", nupdwn_tot(1), FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "DW", nupdwn_tot(2) ) - CALL iotk_write_dat( iunpun, & - "NUMBER_OF_BANDS", nbnd_tot , ATTR = attr ) - ! - ELSE - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_ELECTRONS", nelec ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_BANDS", nbnd_tot ) - ! - END IF - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_EMPTY_STATES", nbnd_emp ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_SPIN_COMPONENTS", nspin ) - ! - CALL iotk_write_end( iunpun, "BAND_STRUCTURE_INFO" ) - ! - CALL iotk_write_begin( iunpun, "EIGENVALUES" ) - ! - ! - END IF - ! -!------------------------------------------------------------------------------- -! ... EIGENVALUES -!------------------------------------------------------------------------------- - ! - k_points_loop1: DO ik = 1, nk - ! - IF ( ionode ) THEN - ! - CALL iotk_write_begin( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - CALL iotk_write_attr( attr, "UNITS", "2 pi / a", FIRST = .TRUE. ) - CALL iotk_write_dat( iunpun, & - "K-POINT_COORDS", xk(:,ik), ATTR = attr ) - ! - CALL iotk_write_dat( iunpun, "WEIGHT", wk(ik) ) - ! - ALLOCATE( dtmp ( nbnd_tot ) ) - ! - DO iss = 1, nspin - ! - cspin = iotk_index( iss ) - ! - dtmp = 0.0d0 - ! - IF( tksw ) THEN - ! - ! writes data required by postproc and PW - ! - IF( nspin == 2 ) THEN - IF( iss == 1 ) filename = wfc_filename( ".", 'eigenval1', ik, EXTENSION='xml' ) - IF( iss == 2 ) filename = wfc_filename( ".", 'eigenval2', ik, EXTENSION='xml' ) - ! - IF( iss == 1 ) CALL iotk_link( iunpun, "DATAFILE.1", & - filename, CREATE = .FALSE., BINARY = .FALSE. ) - IF( iss == 2 ) CALL iotk_link( iunpun, "DATAFILE.2", & - filename, CREATE = .FALSE., BINARY = .FALSE. ) - - IF( iss == 1 ) filename = wfc_filename( dirname, 'eigenval1', ik, EXTENSION='xml' ) - IF( iss == 2 ) filename = wfc_filename( dirname, 'eigenval2', ik, EXTENSION='xml' ) - ELSE - filename = wfc_filename( ".", 'eigenval', ik, EXTENSION='xml' ) - CALL iotk_link( iunpun, "DATAFILE", filename, CREATE = .FALSE., BINARY = .FALSE. ) - filename = wfc_filename( dirname, 'eigenval', ik, EXTENSION='xml' ) - END IF - - dtmp ( 1:nupdwn( iss ) ) = occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) / wk(ik) - ! - CALL write_eig( iunout, filename, nbnd_tot, et( 1:nbnd_tot, iss) , "Hartree", & - OCC = dtmp(:), IK=ik, ISPIN=iss ) - ! - END IF - ! - CALL iotk_write_dat( iunpun, "OCC0" // TRIM( cspin ), & - occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) ) - ! - CALL iotk_write_dat( iunpun, "OCCM" // TRIM( cspin ), & - occm( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) ) - ! - END DO - ! - DEALLOCATE( dtmp ) - ! - CALL iotk_write_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - - END IF - ! - END DO k_points_loop1 - ! - IF ( ionode ) THEN - ! - CALL iotk_write_end( iunpun, "EIGENVALUES" ) - ! - CALL iotk_write_begin( iunpun, "EIGENVECTORS" ) - ! - CALL iotk_write_dat ( iunpun, "MAX_NUMBER_OF_GK-VECTORS", ngwt ) - ! - END IF - ! -!------------------------------------------------------------------------------- -! ... EIGENVECTORS -!------------------------------------------------------------------------------- - ! - k_points_loop2: DO ik = 1, nk - - IF( ionode ) THEN - - CALL iotk_write_begin( iunpun, "K-POINT" // TRIM( iotk_index( ik ) ) ) - ! - ! ... G+K vectors - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_GK-VECTORS", ngwt ) - ! - ! - filename = TRIM( wfc_filename( ".", 'gkvectors', ik ) ) - ! - CALL iotk_link( iunpun, "GK-VECTORS", filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - filename = TRIM( wfc_filename( dirname, 'gkvectors', ik ) ) - ! - END IF - ! - CALL write_gk( iunout, ik, mill, filename ) - ! - DO iss = 1, nspin - ! - ik_eff = ik + ( iss - 1 ) * nk - ! - iss_wfc = iss - if( force_pairing ) iss_wfc = 1 ! only the WF for the first spin is allocated - ! - IF( tksw ) THEN - ! - ! Save additional WF, - ! orthogonal KS states to be used for post processing and PW - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc', ik, iss ) ) - ! - END IF - ! - IF( nspin == 2 ) THEN - CALL iotk_link( iunpun, "WFC" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ELSE - CALL iotk_link( iunpun, "WFC", filename, CREATE = .FALSE., BINARY = .TRUE. ) - END IF - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn_tot( iss_wfc ) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - ctot( :, ib : ib + nbnd_tot - 1 ), ngwt, do_wf_cmplx, gamma_only,& !added:giovanni do_wf_cmplx - nbnd_tot, ig_l2g, ngw, filename, scalef ) - ! - END IF - ! - ! Save wave function at time t - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc0', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc0', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFC0" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc0', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc0', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - c02( :, ib : ib + nbnd_ - 1 ), ngwt, do_wf_cmplx, gamma_only, & !added:giovanni do_wf_cmplx - nbnd_, ig_l2g, ngw, filename, scalef ) - ! - ! Save wave function at time t - dt - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evcm', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evcm', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFCM" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evcm', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evcm', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - cm2( :, ib : ib + nbnd_ - 1 ), ngwt, do_wf_cmplx, gamma_only, & - nbnd_, ig_l2g, ngw, filename, scalef ) - ! - ! Save fixed wave function - ! - IF (odd_nkscalfact) THEN - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc0fixed', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc0fixed', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFC0FIXED" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc0fixed', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc0fixed', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - c0_fixed( :, ib : ib + nbnd_ - 1 ), ngwt, do_wf_cmplx, & !added:giovanni do_wf_cmplx - gamma_only, nbnd_, ig_l2g, ngw, filename, scalef) - ! - ENDIF - ! - IF (print_wfc_empty .and. (nbnd_emp>0) ) THEN - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evc0empty', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evc0empty', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFC0EMPTY" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc0empty', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc0empty', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - c0_emp_aux( :, ib : ib + nbnd_emp - 1 ), ngwt, do_wf_cmplx, & !added:giovanni do_wf_cmplx - gamma_only, nbnd_emp, ig_l2g, ngw, filename, scalef) - ! - IF ( ionode ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'evcmempty', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'evcmempty', ik, iss ) ) - ! - END IF - ! - CALL iotk_link( iunpun, "WFCMEMPTY" // TRIM( iotk_index (iss) ), & - filename, CREATE = .FALSE., BINARY = .TRUE. ) - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evcmempty', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evcmempty', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss_wfc) - ! - CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & - cm_emp_aux( :, ib : ib + nbnd_emp - 1 ), ngwt, do_wf_cmplx, & !added:giovanni do_wf_cmplx - gamma_only, nbnd_emp, ig_l2g, ngw, filename, scalef) - ! - ENDIF - ! - cspin = iotk_index( iss ) - ! - ! ... write matrix lambda to file - ! - ALLOCATE( mrepl( nudx, nudx ) ) - ! - CALL collect_lambda( mrepl, lambda0(:,:,iss), descla(:,iss) ) - ! - IF ( ionode ) THEN - ! - filename = TRIM( wfc_filename( ".", 'lambda0', ik, iss ) ) - ! - CALL iotk_link( iunpun, "LAMBDA0" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .TRUE. ) - ! - CALL iotk_write_dat( iunpun, & - "LAMBDA0" // TRIM( cspin ), mrepl ) - ! - ! Changes by Nicolas Poilvert, Sep. 2010 for printing the lambda - ! matrix at current time step into a formatted file. - ! This matrix corresponds to the Hamiltonian matrix in the case - ! of Self-Interaction. Only in the basis of minimizing orbitals - ! do this matrix has an interpretation. - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( ".", 'hamiltonian', ik, EXTENSION='xml' ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( ".", 'hamiltonian', ik, iss, EXTENSION='xml' ) ) - ! - ENDIF - ! - CALL iotk_link( iunpun, "HAMILTONIAN" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .FALSE. ) - ! - CALL iotk_write_dat( iunpun, & - "HAMILTONIAN" // TRIM( cspin ), mrepl ) - ! - END IF - ! - CALL collect_lambda( mrepl, lambdam(:,:,iss), descla(:,iss) ) - ! - IF ( ionode ) THEN - ! - filename = TRIM( wfc_filename( ".", 'lambdam', ik, iss ) ) - ! - CALL iotk_link( iunpun, "LAMBDAM" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .TRUE. ) - ! - CALL iotk_write_dat( iunpun, & - "LAMBDAM" // TRIM( cspin ), mrepl ) - ! - END IF - ! - IF( PRESENT( mat_z ) ) THEN - ! - CALL collect_zmat( mrepl, mat_z(:,:,iss), descla(:,iss) ) - ! - IF ( ionode ) THEN - ! - filename = TRIM( wfc_filename( ".", 'mat_z', ik, iss ) ) - ! - CALL iotk_link( iunpun, "MAT_Z" // TRIM( cspin ), & - filename, CREATE = .TRUE., BINARY = .TRUE. ) - ! - CALL iotk_write_dat( iunpun, "MAT_Z" // TRIM( cspin ), mrepl ) - ! - END IF - ! - END IF - ! - DEALLOCATE( mrepl ) - ! - END DO - ! - IF ( ionode ) & - CALL iotk_write_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - END DO k_points_loop2 - ! - IF ( ionode ) CALL iotk_write_end( iunpun, "EIGENVECTORS" ) - ! - IF ( ionode ) CALL iotk_close_write( iunpun ) - ! -!------------------------------------------------------------------------------- -! ... END RESTART SECTIONS -!------------------------------------------------------------------------------- - ! - DEALLOCATE( ftmp ) - DEALLOCATE( tau ) - DEALLOCATE( ityp ) - DEALLOCATE( mill ) - ! - CALL save_history( dirname, nfi ) - ! - s1 = cclock() - ! - IF ( ionode ) THEN - ! - WRITE( stdout, & - '(3X,"restart file written in ",F8.3," sec.",/)' ) ( s1 - s0 ) - ! - END IF - ! - RETURN - ! - END SUBROUTINE cp_writefile_real - - !------------------------------------------------------------------------ - SUBROUTINE cp_readfile_real( ndr, outdir, ascii, nfi, simtime, acc, nk, xk, & - wk, ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, & - taui, cdmi, stau0, svel0, staum, svelm, force, & - vnhp, xnhp0, xnhpm, nhpcl,nhpdim,occ0, occm, & - lambda0, lambdam, b1, b2, b3, xnhe0, xnhem, vnhe, & - ekincm, c02, cm2, mat_z ) - !------------------------------------------------------------------------ - ! - USE control_flags, ONLY : do_wf_cmplx, gamma_only, force_pairing !added:giovanni do_wf_cmplx - USE io_files, ONLY : iunpun, xmlpun - USE printout_base, ONLY : title - USE grid_dimensions, ONLY : nr1, nr2, nr3 - USE smooth_grid_dimensions, ONLY : nr1s, nr2s, nr3s - USE smallbox_grid_dimensions, ONLY : nr1b, nr2b, nr3b - USE gvecp, ONLY : ngm, ngmt, ecutp - USE gvecs, ONLY : ngs, ngst - USE gvecw, ONLY : ngw, ngwt, ecutw - USE electrons_base, ONLY : nspin, nbnd, nelt, nel, & - nupdwn, iupdwn, nudx - USE cell_base, ONLY : ibrav, alat, celldm, symm_type, & - s_to_r, r_to_s - USE ions_base, ONLY : nsp, nat, na, atm, zv, pmass, & - sort_tau, ityp, ions_cofmass - USE reciprocal_vectors, ONLY : ig_l2g, mill_l - USE cp_main_variables, ONLY : nprint_nfi, distribute_lambda, descla, distribute_zmat - USE mp, ONLY : mp_sum - USE mp_global, ONLY : intra_image_comm - USE parameters, ONLY : ntypx - USE constants, ONLY : eps8, angstrom_au, pi - USE input_parameters, ONLY : odd_nkscalfact, restart_odd_nkscalfact - USE wavefunctions_module, ONLY : c0_fixed - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ndr ! I/O unit number - CHARACTER(LEN=*), INTENT(IN) :: outdir ! - LOGICAL, INTENT(IN) :: ascii ! - INTEGER, INTENT(INOUT) :: nfi ! index of the current step - REAL(DP), INTENT(INOUT) :: simtime ! simulated time - REAL(DP), INTENT(INOUT) :: acc(:) ! - INTEGER, INTENT(IN) :: nk ! number of kpoints - REAL(DP), INTENT(INOUT) :: xk(:,:) ! k-points coordinates - REAL(DP), INTENT(INOUT) :: wk(:) ! k-points weights - REAL(DP), INTENT(INOUT) :: ht(3,3) ! - REAL(DP), INTENT(INOUT) :: htm(3,3) ! - REAL(DP), INTENT(INOUT) :: htvel(3,3) ! - REAL(DP), INTENT(INOUT) :: gvel(3,3) ! - REAL(DP), INTENT(INOUT) :: xnhh0(3,3) ! - REAL(DP), INTENT(INOUT) :: xnhhm(3,3) ! - REAL(DP), INTENT(INOUT) :: vnhh(3,3) ! - REAL(DP), INTENT(INOUT) :: taui(:,:) ! - REAL(DP), INTENT(INOUT) :: cdmi(:) ! - REAL(DP), INTENT(INOUT) :: stau0(:,:) ! - REAL(DP), INTENT(INOUT) :: svel0(:,:) ! - REAL(DP), INTENT(INOUT) :: staum(:,:) ! - REAL(DP), INTENT(INOUT) :: svelm(:,:) ! - REAL(DP), INTENT(INOUT) :: force(:,:) ! - REAL(DP), INTENT(INOUT) :: xnhp0(:) ! - REAL(DP), INTENT(INOUT) :: xnhpm(:) ! - REAL(DP), INTENT(INOUT) :: vnhp(:) ! - INTEGER, INTENT(INOUT) :: nhpcl ! - INTEGER, INTENT(INOUT) :: nhpdim ! - REAL(DP), INTENT(INOUT) :: occ0(:) ! occupations - REAL(DP), INTENT(INOUT) :: occm(:) ! - REAL(DP), INTENT(INOUT) :: lambda0(:,:,:) ! - REAL(DP), INTENT(INOUT) :: lambdam(:,:,:) ! - REAL(DP), INTENT(INOUT) :: b1(3) ! - REAL(DP), INTENT(INOUT) :: b2(3) ! - REAL(DP), INTENT(INOUT) :: b3(3) ! - REAL(DP), INTENT(INOUT) :: xnhe0 ! - REAL(DP), INTENT(INOUT) :: xnhem ! - REAL(DP), INTENT(INOUT) :: vnhe ! - REAL(DP), INTENT(INOUT) :: ekincm ! - COMPLEX(DP), INTENT(INOUT) :: c02(:,:) ! - COMPLEX(DP), INTENT(INOUT) :: cm2(:,:) ! - REAL(DP), OPTIONAL, INTENT(INOUT) :: mat_z(:,:,:) ! - ! - CHARACTER(LEN=256) :: dirname, kdirname, filename - CHARACTER(LEN=5) :: kindex - CHARACTER(LEN=4) :: cspin - INTEGER :: strlen - INTEGER :: kunit - INTEGER :: k1, k2, k3 - INTEGER :: nk1, nk2, nk3 - INTEGER :: i, j, iss, ig, nspin_wfc, ierr, ik - REAL(DP) :: omega, htm1(3,3), hinv(3,3), scalef - LOGICAL :: found - INTEGER, ALLOCATABLE :: mill(:,:) - ! - ! ... variables read for testing pourposes - ! - INTEGER :: ibrav_ - CHARACTER(LEN=9) :: symm_type_ - CHARACTER(LEN=3) :: atm_(ntypx) - INTEGER :: nat_, nsp_, na_ - INTEGER :: nk_, ik_, nt_ - LOGICAL :: do_wf_cmplx_, gamma_only_ , lsda_ !added:giovanni do_wf_cmplx - REAL(DP) :: alat_, a1_(3), a2_(3), a3_(3) - REAL(DP) :: pmass_, zv_ - REAL(DP) :: celldm_(6) - INTEGER :: iss_, nspin_, ngwt_, nbnd_ , n_emp_ , nbnd_tot - INTEGER :: nstates_up_ , nstates_dw_ , ntmp, nel_(2) - REAL(DP) :: nelec_ - REAL(DP) :: scalef_ - REAL(DP) :: wk_ - INTEGER :: nhpcl_, nhpdim_ - INTEGER :: ib, nb - INTEGER :: ik_eff - REAL(DP) :: amass_(ntypx) - INTEGER, ALLOCATABLE :: ityp_(:) - INTEGER, ALLOCATABLE :: isrt_(:) - REAL(DP), ALLOCATABLE :: tau_(:,:) - REAL(DP), ALLOCATABLE :: occ_(:) - INTEGER, ALLOCATABLE :: if_pos_(:,:) - CHARACTER(LEN=256) :: psfile_(ntypx) - CHARACTER(LEN=80) :: pos_unit - REAL(DP) :: s1, s0, cclock - REAL(DP), ALLOCATABLE :: mrepl(:,:) - ! - ! ... look for an empty unit - ! - CALL iotk_free_unit( iunout, ierr ) - ! - CALL errore( 'cp_readfile', & - 'no free units to read wavefunctions', ierr ) - ! - kunit = 1 - found = .FALSE. - ! - dirname = restart_dir( outdir, ndr ) - ! - ! ... Open XML descriptor - ! - IF ( ionode ) THEN - ! - filename = TRIM( dirname ) // '/' // TRIM( xmlpun ) - ! - WRITE( stdout, '(/,3X,"reading restart file: ",A)' ) TRIM( dirname ) - ! - CALL iotk_open_read( iunpun, FILE = TRIM( filename ), IERR = ierr ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_readfile', & - 'cannot open restart file for reading', ierr ) - ! - s0 = cclock() - ! - IF ( ionode ) THEN - ! - qexml_version = " " - ! - CALL iotk_scan_begin( iunpun, "HEADER", FOUND=found ) - ! - IF ( found ) THEN - ! - CALL iotk_scan_empty( iunpun, "FORMAT", ATTR=attr ) - CALL iotk_scan_attr( attr, "VERSION", qexml_version ) - CALL iotk_scan_end( iunpun, "HEADER" ) - ! - ELSE - ! - qexml_version = TRIM( default_fmt_version ) - ! - ENDIF - ! - qexml_version_init = .TRUE. - - ! - ! init logical variables for versioning - ! - qexml_version_before_1_4_0 = .FALSE. - ! - IF ( TRIM( version_compare( qexml_version, "1.4.0" )) == "older" ) & - qexml_version_before_1_4_0 = .TRUE. - ! - ENDIF - ! - CALL mp_bcast( qexml_version, ionode_id, intra_image_comm ) - CALL mp_bcast( qexml_version_init, ionode_id, intra_image_comm ) - CALL mp_bcast( qexml_version_before_1_4_0 , ionode_id, intra_image_comm ) - ! - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "STATUS", FOUND = found ) - ! - IF ( found ) THEN - ! - CALL iotk_scan_empty( iunpun, "STEP", attr ) - CALL iotk_scan_attr( attr, "ITERATION", nfi ) - CALL iotk_scan_dat( iunpun, "TIME", simtime ) - CALL iotk_scan_dat( iunpun, "TITLE", title ) - CALL iotk_scan_end( iunpun, "STATUS" ) - ! - END IF - ! - END IF - ! - ! ... Read cell and positions - ! - ALLOCATE( tau_( 3, nat ) ) - ALLOCATE( if_pos_( 3, nat ) ) - ALLOCATE( ityp_( nat ) ) - ! - IF ( ionode ) THEN - ! - CALL read_cell( ibrav_, symm_type_, celldm_, & - alat_, a1_, a2_, a3_, b1, b2, b3 ) - ! - CALL recips( a1_, a2_, a3_, b1, b2, b3 ) - ! - END IF - ! - IF ( ionode ) THEN - ! - CALL read_ions( nsp_, nat_, atm_, ityp_, & - psfile_, amass_, tau_, if_pos_, pos_unit, ierr ) - ! - IF ( ierr == 0 ) THEN - ! - IF( nsp_ /= nsp .OR. nat_ /= nat ) ierr = 2 - ! - DO i = 1, nat - ! - IF ( ityp_(i) /= ityp(i) ) ierr = 3 - ! - END DO - ! - END IF - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_readfile', & - 'cannot read positions from restart file', ierr ) - ! - ! Read SPIN infos - ! - lsda_ = ( nspin == 2 ) - ! - IF( ionode ) THEN - CALL iotk_scan_begin( iunpun, "SPIN", FOUND = found ) - IF( found ) THEN - CALL iotk_scan_dat( iunpun, "LSDA", lsda_ ) - CALL iotk_scan_end( iunpun, "SPIN" ) - END IF - END IF - ! - CALL mp_bcast( lsda_ , ionode_id, intra_image_comm ) - ! - IF( lsda_ .AND. nspin == 1 ) & - CALL errore( 'cp_readfile', 'LSDA restart file with a spinless run', ierr ) - - ! - ! Read Occupations infos - ! - nstates_up_ = nupdwn( 1 ) - nstates_dw_ = nupdwn( 2 ) - - IF( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "OCCUPATIONS", FOUND = found ) - IF( found ) THEN - ! - CALL iotk_scan_empty( iunpun, "INFO", attr, FOUND = found ) - ! - IF( lsda_ .AND. found ) THEN - ! - IF ( qexml_version_before_1_4_0 ) THEN - ! - CALL iotk_scan_attr( attr, "nelup", nstates_up_ ) - CALL iotk_scan_attr( attr, "neldw", nstates_dw_ ) - ! - ELSE - ! - ! current version - ! - CALL iotk_scan_attr( attr, "nstates_up", nstates_up_ ) - CALL iotk_scan_attr( attr, "nstates_down", nstates_dw_ ) - ! - ENDIF - ! - ENDIF - ! - CALL iotk_scan_end( iunpun, "OCCUPATIONS" ) - ! - ENDIF - ENDIF - ! - CALL mp_bcast( nstates_up_ , ionode_id, intra_image_comm ) - CALL mp_bcast( nstates_dw_ , ionode_id, intra_image_comm ) - ! - IF( lsda_ ) THEN - IF( ( nstates_up_ /= nupdwn( 1 ) ) .OR. ( nstates_dw_ /= nupdwn( 2 ) ) ) & - CALL errore( 'cp_readfile', 'inconsistent number of spin states', ierr ) - END IF - - ! ... read MD timesteps variables - ! - IF ( ionode ) & - CALL iotk_scan_begin( iunpun, "TIMESTEPS", attr, FOUND = found ) - ! - ierr = 0 - ! - IF ( ionode .AND. found ) THEN - ! - CALL iotk_scan_attr( attr, "nt", nt_ ) - ! - IF ( nt_ > 0 ) THEN - ! - CALL iotk_scan_begin( iunpun, "STEP0" ) - ! - CALL iotk_scan_dat( iunpun, "ACCUMULATORS", acc ) - ! - CALL iotk_scan_begin( iunpun,"IONS_POSITIONS" ) - CALL iotk_scan_dat( iunpun, "stau", stau0(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "svel", svel0(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "taui", taui(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "cdmi", cdmi(1:3) ) - CALL iotk_scan_dat( iunpun, "force", force(1:3,1:nat) ) - CALL iotk_scan_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_scan_begin( iunpun, "IONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "nhpcl", nhpcl_ ) - CALL iotk_scan_dat( iunpun, "nhpdim", nhpdim_ ) - ! - IF ( nhpcl_ == nhpcl .AND. nhpdim_ == nhpdim ) THEN - ! - CALL iotk_scan_dat( iunpun, "xnhp", xnhp0(1:nhpcl*nhpdim) ) - CALL iotk_scan_dat( iunpun, "vnhp", vnhp(1:nhpcl*nhpdim) ) - ! - ELSE - ! - xnhp0(1:nhpcl*nhpdim) = 0.D0 - vnhp(1:nhpcl*nhpdim) = 0.D0 - ! - END IF - ! - CALL iotk_scan_end( iunpun, "IONS_NOSE" ) - ! - CALL iotk_scan_dat( iunpun, "ekincm", ekincm ) - ! - CALL iotk_scan_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhe", xnhe0 ) - CALL iotk_scan_dat( iunpun, "vnhe", vnhe ) - CALL iotk_scan_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_scan_dat( iunpun, "ht", ht ) - CALL iotk_scan_dat( iunpun, "htvel", htvel ) - CALL iotk_scan_dat( iunpun, "gvel", gvel ) - CALL iotk_scan_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhh", xnhh0 ) - CALL iotk_scan_dat( iunpun, "vnhh", vnhh ) - CALL iotk_scan_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_scan_end( iunpun, "STEP0" ) - ! - ELSE - ! - ierr = 40 - ! - GOTO 100 - ! - END IF - ! - IF ( nt_ > 1 ) THEN - ! - CALL iotk_scan_begin( iunpun, "STEPM" ) - ! - CALL iotk_scan_begin( iunpun, "IONS_POSITIONS" ) - CALL iotk_scan_dat( iunpun, "stau", staum(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "svel", svelm(1:3,1:nat) ) - CALL iotk_scan_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_scan_begin( iunpun, "IONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "nhpcl", nhpcl_ ) - CALL iotk_scan_dat( iunpun, "nhpdim", nhpdim_ ) - ! - IF ( nhpcl_ == nhpcl .AND. nhpdim_ == nhpdim ) THEN - ! - CALL iotk_scan_dat( iunpun, "xnhp", xnhpm(1:nhpcl*nhpdim) ) - ! - ELSE - ! - xnhpm(1:nhpcl*nhpdim) = 0.D0 - ! - END IF - ! - CALL iotk_scan_end( iunpun,"IONS_NOSE" ) - ! - CALL iotk_scan_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhe", xnhem ) - CALL iotk_scan_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_scan_dat( iunpun, "ht", htm ) - CALL iotk_scan_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhh", xnhhm ) - CALL iotk_scan_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_scan_end( iunpun, "STEPM" ) - ! - END IF - ! - CALL iotk_scan_end( iunpun, "TIMESTEPS" ) - ! - ELSE IF ( ionode ) THEN - ! - ! ... MD time steps not found, try to recover from CELL and POSITIONS - ! - acc = 0.D0 - ! - ALLOCATE( isrt_( nat ) ) - ! - SELECT CASE( TRIM( pos_unit ) ) - CASE( "alat" ) - ! - tau_ = tau_ * alat_ - ! - CASE( "Angstrom" ) - ! - tau_ = tau_ * angstrom_au - ! - CASE DEFAULT - ! - END SELECT - ! - CALL sort_tau( taui, isrt_ , tau_ , ityp_ , nat_ , nsp_ ) - ! - ht(1,:) = a1_ - ht(2,:) = a2_ - ht(3,:) = a3_ - ! - CALL invmat( 3, ht, htm1, omega ) - ! - hinv = TRANSPOSE( htm1 ) - ! - CALL r_to_s( taui, stau0, na, nsp, hinv ) - ! - CALL ions_cofmass( taui, amass_ , na, nsp, cdmi ) - ! - staum = stau0 - svel0 = 0.D0 - svelm = 0.D0 - force = 0.D0 - ! - htm = ht - htvel = 0.D0 - gvel = 0.D0 - xnhh0 = 0.D0 - vnhh = 0.D0 - xnhhm = 0.D0 - ! - xnhe0 = 0.D0 - xnhem = 0.D0 - vnhe = 0.D0 - ! - ekincm = 0.D0 - ! - xnhp0 = 0.D0 - xnhpm = 0.D0 - vnhp = 0.D0 - ! - DEALLOCATE( isrt_ ) - ! - END IF - ! - 100 CONTINUE - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - IF( ierr /= 0 ) THEN - CALL mp_bcast( attr, ionode_id, intra_image_comm ) - CALL errore( 'cp_readfile ', TRIM( attr ), ierr ) - END IF - ! - DEALLOCATE( tau_ ) - DEALLOCATE( if_pos_ ) - DEALLOCATE( ityp_ ) - ! - ! ... compute the scale factor - ! - IF ( ionode ) CALL invmat( 3, ht, htm1, omega ) - ! - CALL mp_bcast( omega, ionode_id, intra_image_comm ) - ! - ! ... Beware: omega may be negative if axis are left-handed! - ! - scalef = 1.D0 / SQRT( ABS( omega ) ) - ! - ! ... band Structure - ! - IF ( ionode ) THEN - ! - ierr = 0 - ! - CALL iotk_scan_begin( iunpun, "BAND_STRUCTURE_INFO" ) - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_SPIN_COMPONENTS", nspin_ ) - ! - IF ( nspin_ /= nspin ) THEN - attr = "spin do not match" - ierr = 31 - GOTO 90 - END IF - ! - IF ( nspin == 2 ) THEN - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_ELECTRONS", nelec_, ATTR = attr ) - CALL iotk_scan_attr( attr, "UP", nel_(1) ) - CALL iotk_scan_attr( attr, "DW", nel_(2) ) - ! - IF ( ( nel(1) /= nel_(1) ) .OR. ( nel(2) /= nel_(2) ) .OR. ( NINT( nelec_ ) /= nelt ) ) THEN - attr = "electrons do not match" - write(0,*) "from cp_readfile warning: electrons do not match" - write(6,*) "from cp_readfile warning: electrons do not match" - !ierr = 33 - GOTO 90 - END IF - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_BANDS", nbnd_tot , ATTR = attr ) - ! - ELSE - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_ELECTRONS", nelec_ ) - ! - IF ( NINT( nelec_ ) /= nelt ) THEN - attr = "electrons do not match" - ierr = 33 - GOTO 90 - END IF - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_BANDS", nbnd_tot ) - ! - END IF - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_EMPTY_STATES", n_emp_, FOUND = found ) - ! - IF( .NOT. found ) n_emp_ = 0 - ! - nbnd_ = nbnd_tot - n_emp_ - ! - IF ( nbnd_ < nupdwn(1) ) THEN - attr = "nbnd do not match" - ierr = 32 - GOTO 90 - END IF - ! - CALL iotk_scan_end( iunpun, "BAND_STRUCTURE_INFO" ) - ! - END IF - ! - 90 CONTINUE - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - IF( ierr /= 0 ) THEN - CALL mp_bcast( attr, ionode_id, intra_image_comm ) - CALL errore( 'cp_readfile ', TRIM( attr ), ierr ) - END IF - ! - IF( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "EIGENVALUES" ) - ! - END IF - ! - k_points_loop1: DO ik = 1, nk - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - CALL iotk_scan_dat( iunpun, "WEIGHT", wk_ ) - ! - END IF - ! - DO iss = 1, nspin - ! - cspin = iotk_index( iss ) - ! - ik_eff = ik + ( iss - 1 ) * nk - ! - IF ( ionode ) THEN - ! - ALLOCATE( occ_ ( MAX( nudx , nbnd_tot ) ) ) - ! - occ_ = 0.0d0 - ! - CALL iotk_scan_dat( iunpun, "OCC0" // TRIM( cspin ), occ_ ( 1 : nupdwn( iss ) ), FOUND = found ) - ! - IF( .NOT. found ) THEN - ! - IF( nspin == 1 ) THEN - CALL iotk_scan_begin( iunpun, "DATAFILE", FOUND = found ) - ELSE - CALL iotk_scan_begin( iunpun, "DATAFILE//TRIM(cspin)", FOUND = found ) - END IF - ! - CALL iotk_scan_dat ( iunpun, "OCCUPATIONS", occ_( 1:nbnd_tot ) ) - ! - IF( nspin == 1 ) THEN - CALL iotk_scan_end( iunpun, "DATAFILE" ) - ELSE - CALL iotk_scan_end( iunpun, "DATAFILE//TRIM(cspin)" ) - END IF - ! - IF( found ) THEN - occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) * wk_ - occm( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) * wk_ - END IF - ! - ELSE - ! - occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) - ! - CALL iotk_scan_dat( iunpun, "OCCM" // TRIM( cspin ), occ_ ( 1 : nupdwn( iss ) ), FOUND = found ) - ! - IF( found ) THEN - occm( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) - END IF - ! - END IF - ! - DEALLOCATE ( occ_ ) - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( .NOT. found ) & - CALL errore( " readfile ", " occupation numbers not found! ", 1 ) - ! - END DO - - IF ( ionode ) CALL iotk_scan_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - END DO k_points_loop1 - - IF ( ionode ) THEN - CALL iotk_scan_end ( iunpun, "EIGENVALUES" ) - CALL iotk_scan_begin( iunpun, "EIGENVECTORS" ) - END IF - ! - k_points_loop2: DO ik = 1, nk - ! - IF ( ionode ) THEN - CALL iotk_scan_begin( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - END IF - ! - DO iss = 1, nspin - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "WFC0" // TRIM( iotk_index (iss) ), FOUND = found ) - ! - filename = "WFC0" // TRIM( iotk_index (iss) ) - ! - IF( .NOT. found ) THEN - ! - IF( nspin == 2 ) THEN - CALL iotk_scan_begin( iunpun, "WFC" // TRIM( iotk_index (iss) ), FOUND = found ) - filename = "WFC" // TRIM( iotk_index (iss) ) - ELSE - CALL iotk_scan_begin( iunpun, "WFC", FOUND = found ) - filename = "WFC" - END IF - ! - END IF - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( .NOT. found ) & - CALL errore( " readfile ", " wave functions not found! ", 1 ) - ! - IF( .NOT. ( iss > 1 .AND. force_pairing ) ) THEN - ! - ! Only WF with spin 1 are needed when force_pairing is active - ! - ib = iupdwn(iss) - nb = nupdwn(iss) - ! - ! filename is not needed we are following the link! - ! - CALL read_wfc( iunpun, ik_eff , nk, kunit, iss_, nspin_, & - c02( :, ib:ib+nb-1 ), ngwt_, nbnd_, ig_l2g, ngw, & - filename, scalef_, .TRUE. ) - ! - END IF - ! - IF ( ionode ) & - CALL iotk_scan_end( iunpun, TRIM(filename) ) - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "WFCM" // TRIM( iotk_index (iss) ), FOUND = found ) - ! - filename = "WFCM" // TRIM( iotk_index (iss) ) - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( found ) THEN - ! - IF( .NOT. ( iss > 1 .AND. force_pairing ) ) THEN - ! - ! Only WF with spin 1 are needed when force_pairing is active - ! - ib = iupdwn(iss) - nb = nupdwn(iss) - ! - CALL read_wfc( iunpun, ik_eff, nk, kunit, iss_, nspin_, & - cm2( :, ib:ib+nb-1 ), ngwt_, nbnd_, ig_l2g, ngw, & - filename, scalef_ , .TRUE. ) - ! - END IF - ! - IF ( ionode ) & - CALL iotk_scan_end( iunpun, TRIM( filename ) ) - ! - ELSE - ! - cm2 = c02 - ! - END IF - ! - IF (odd_nkscalfact .and. restart_odd_nkscalfact) THEN - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "WFC0FIXED" // TRIM( iotk_index (iss) ), FOUND = found ) - ! - filename = "WFC0FIXED" // TRIM( iotk_index (iss) ) - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( .NOT. found ) & - CALL errore( " readfile ", " wave functions evc0fixed not found! ", 1 ) - ! - IF( .NOT. ( iss > 1 .AND. force_pairing ) ) THEN - ! - ! Only WF with spin 1 are needed when force_pairing is active - ! - ib = iupdwn(iss) - nb = nupdwn(iss) - ! - ! filename is not needed we are following the link! - ! - CALL read_wfc( iunpun, ik_eff , nk, kunit, iss_, nspin_, & - c0_fixed( :, ib:ib+nb-1 ), ngwt_, nbnd_, ig_l2g, ngw, & - filename, scalef_, .TRUE. ) - ! - END IF - ! - ! - IF ( ionode ) & - CALL iotk_scan_end( iunpun, TRIM(filename) ) - ! - ENDIF - ! - END DO - ! - DO iss = 1, nspin - ! - ! ... read matrix lambda to file - ! - ALLOCATE( mrepl( nudx, nudx ) ) - ! - IF( ionode ) THEN - CALL iotk_scan_dat( iunpun, "LAMBDA0" // TRIM( cspin ), mrepl, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING lambda0 not read from restart file' - mrepl = 0.0d0 - END IF - END IF - - CALL mp_bcast( mrepl, ionode_id, intra_image_comm ) - - CALL distribute_lambda( mrepl, lambda0(:,:,iss), descla(:,iss) ) - - IF( ionode ) THEN - CALL iotk_scan_dat( iunpun, "LAMBDAM" // TRIM( cspin ), mrepl, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING lambdam not read from restart file' - mrepl = 0.0d0 - END IF - END IF - ! - CALL mp_bcast( mrepl, ionode_id, intra_image_comm ) - - CALL distribute_lambda( mrepl, lambdam(:,:,iss), descla(:,iss) ) - ! - IF ( PRESENT( mat_z ) ) THEN - ! - IF( ionode ) THEN - CALL iotk_scan_dat( iunpun, "MAT_Z" // TRIM( iotk_index( iss ) ), mrepl, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING mat_z not read from restart file' - mrepl = 0.0d0 - END IF - END IF - - CALL mp_bcast( mrepl, ionode_id, intra_image_comm ) - - CALL distribute_zmat( mrepl, mat_z(:,:,iss), descla(:,iss) ) - ! - END IF - ! - DEALLOCATE( mrepl ) - ! - END DO - ! - IF ( ionode ) CALL iotk_scan_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - END DO k_points_loop2 - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_end( iunpun, "EIGENVECTORS" ) - ! - END IF - ! - CALL mp_bcast( qexml_version, ionode_id, intra_image_comm ) - CALL mp_bcast( qexml_version_init, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( nfi, ionode_id, intra_image_comm ) - CALL mp_bcast( simtime, ionode_id, intra_image_comm ) - CALL mp_bcast( title, ionode_id, intra_image_comm ) - CALL mp_bcast( acc, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( ht, ionode_id, intra_image_comm ) - CALL mp_bcast( htm, ionode_id, intra_image_comm ) - CALL mp_bcast( htvel, ionode_id, intra_image_comm ) - CALL mp_bcast( gvel, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhh0, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhhm, ionode_id, intra_image_comm ) - CALL mp_bcast( vnhh, ionode_id, intra_image_comm ) - CALL mp_bcast( b1, ionode_id, intra_image_comm ) - CALL mp_bcast( b2, ionode_id, intra_image_comm ) - CALL mp_bcast( b3, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( stau0, ionode_id, intra_image_comm ) - CALL mp_bcast( svel0, ionode_id, intra_image_comm ) - CALL mp_bcast( staum, ionode_id, intra_image_comm ) - CALL mp_bcast( svelm, ionode_id, intra_image_comm ) - CALL mp_bcast( taui, ionode_id, intra_image_comm ) - CALL mp_bcast( force, ionode_id, intra_image_comm ) - CALL mp_bcast( cdmi, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhp0, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhpm, ionode_id, intra_image_comm ) - CALL mp_bcast( vnhp, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( xnhe0, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhem, ionode_id, intra_image_comm ) - CALL mp_bcast( vnhe, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( kunit, ionode_id, intra_image_comm ) - - CALL mp_bcast( occ0, ionode_id, intra_image_comm ) - CALL mp_bcast( occm, ionode_id, intra_image_comm ) - ! - IF ( PRESENT( mat_z ) ) & - CALL mp_bcast( mat_z(:,:,:), ionode_id, intra_image_comm ) - ! - IF ( ionode ) & - CALL iotk_close_read( iunpun ) - - ! - s1 = cclock() - ! - IF ( ionode ) THEN - ! - WRITE( stdout, & - '(3X,"restart file read in ",F8.3," sec.",/)' ) ( s1 - s0 ) - ! - END IF - ! - if (nprint_nfi.eq.-2) then - write( stdout,*) 'nprint_nfi= ',nprint_nfi - CALL read_print_counter( nprint_nfi, outdir, ndr ) - write( stdout,*) 'nprint_nfi= ',nprint_nfi - endif - ! - RETURN - ! - END SUBROUTINE cp_readfile_real - !------------------------------------------------------------------------ - SUBROUTINE cp_readfile_twin( ndr, outdir, ascii, nfi, simtime, acc, nk, xk, & - wk, ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, & - taui, cdmi, stau0, svel0, staum, svelm, force, & - vnhp, xnhp0, xnhpm, nhpcl,nhpdim,occ0, occm, & - lambda0, lambdam, b1, b2, b3, xnhe0, xnhem, vnhe, & - ekincm, c02, cm2, mat_z ) - !------------------------------------------------------------------------ - ! - USE control_flags, ONLY : do_wf_cmplx, gamma_only, force_pairing !added:giovanni do_wf_cmplx - USE io_files, ONLY : iunpun, xmlpun - USE printout_base, ONLY : title - USE grid_dimensions, ONLY : nr1, nr2, nr3 - USE smooth_grid_dimensions, ONLY : nr1s, nr2s, nr3s - USE smallbox_grid_dimensions, ONLY : nr1b, nr2b, nr3b - USE gvecp, ONLY : ngm, ngmt, ecutp - USE gvecs, ONLY : ngs, ngst - USE gvecw, ONLY : ngw, ngwt, ecutw - USE electrons_base, ONLY : nspin, nbnd, nelt, nel, & - nupdwn, iupdwn, nudx - USE cell_base, ONLY : ibrav, alat, celldm, symm_type, & - s_to_r, r_to_s - USE ions_base, ONLY : nsp, nat, na, atm, zv, pmass, & - sort_tau, ityp, ions_cofmass - USE reciprocal_vectors, ONLY : ig_l2g, mill_l - USE cp_main_variables, ONLY : nprint_nfi, distribute_lambda, descla, distribute_zmat - USE mp, ONLY : mp_sum - USE mp_global, ONLY : intra_image_comm - USE parameters, ONLY : ntypx - USE constants, ONLY : eps8, angstrom_au, pi - USE twin_types - USE input_parameters, ONLY : odd_nkscalfact, restart_odd_nkscalfact - USE wavefunctions_module, ONLY : c0_fixed - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ndr ! I/O unit number - CHARACTER(LEN=*), INTENT(IN) :: outdir ! - LOGICAL, INTENT(IN) :: ascii ! - INTEGER, INTENT(INOUT) :: nfi ! index of the current step - REAL(DP), INTENT(INOUT) :: simtime ! simulated time - REAL(DP), INTENT(INOUT) :: acc(:) ! - INTEGER, INTENT(IN) :: nk ! number of kpoints - REAL(DP), INTENT(INOUT) :: xk(:,:) ! k-points coordinates - REAL(DP), INTENT(INOUT) :: wk(:) ! k-points weights - REAL(DP), INTENT(INOUT) :: ht(3,3) ! - REAL(DP), INTENT(INOUT) :: htm(3,3) ! - REAL(DP), INTENT(INOUT) :: htvel(3,3) ! - REAL(DP), INTENT(INOUT) :: gvel(3,3) ! - REAL(DP), INTENT(INOUT) :: xnhh0(3,3) ! - REAL(DP), INTENT(INOUT) :: xnhhm(3,3) ! - REAL(DP), INTENT(INOUT) :: vnhh(3,3) ! - REAL(DP), INTENT(INOUT) :: taui(:,:) ! - REAL(DP), INTENT(INOUT) :: cdmi(:) ! - REAL(DP), INTENT(INOUT) :: stau0(:,:) ! - REAL(DP), INTENT(INOUT) :: svel0(:,:) ! - REAL(DP), INTENT(INOUT) :: staum(:,:) ! - REAL(DP), INTENT(INOUT) :: svelm(:,:) ! - REAL(DP), INTENT(INOUT) :: force(:,:) ! - REAL(DP), INTENT(INOUT) :: xnhp0(:) ! - REAL(DP), INTENT(INOUT) :: xnhpm(:) ! - REAL(DP), INTENT(INOUT) :: vnhp(:) ! - INTEGER, INTENT(INOUT) :: nhpcl ! - INTEGER, INTENT(INOUT) :: nhpdim ! - REAL(DP), INTENT(INOUT) :: occ0(:) ! occupations - REAL(DP), INTENT(INOUT) :: occm(:) ! -! REAL(DP), INTENT(INOUT) :: lambda0(:,:,:) ! -! REAL(DP), INTENT(INOUT) :: lambdam(:,:,:) ! - TYPE(twin_matrix), dimension(:), INTENT(INOUT) :: lambda0 - TYPE(twin_matrix), dimension(:), INTENT(INOUT) :: lambdam - REAL(DP), INTENT(INOUT) :: b1(3) ! - REAL(DP), INTENT(INOUT) :: b2(3) ! - REAL(DP), INTENT(INOUT) :: b3(3) ! - REAL(DP), INTENT(INOUT) :: xnhe0 ! - REAL(DP), INTENT(INOUT) :: xnhem ! - REAL(DP), INTENT(INOUT) :: vnhe ! - REAL(DP), INTENT(INOUT) :: ekincm ! - COMPLEX(DP), INTENT(INOUT) :: c02(:,:) ! - COMPLEX(DP), INTENT(INOUT) :: cm2(:,:) ! - TYPE(twin_matrix), dimension(:), INTENT(INOUT), optional :: mat_z - ! - CHARACTER(LEN=256) :: dirname, kdirname, filename - CHARACTER(LEN=5) :: kindex - CHARACTER(LEN=4) :: cspin - INTEGER :: strlen - INTEGER :: kunit - INTEGER :: k1, k2, k3 - INTEGER :: nk1, nk2, nk3 - INTEGER :: i, j, iss, ig, nspin_wfc, ierr, ik - REAL(DP) :: omega, htm1(3,3), hinv(3,3), scalef - LOGICAL :: found - INTEGER, ALLOCATABLE :: mill(:,:) - ! - ! ... variables read for testing pourposes - ! - INTEGER :: ibrav_ - CHARACTER(LEN=9) :: symm_type_ - CHARACTER(LEN=3) :: atm_(ntypx) - INTEGER :: nat_, nsp_, na_ - INTEGER :: nk_, ik_, nt_ - LOGICAL :: do_wf_cmplx_, gamma_only_ , lsda_ !added:giovanni do_wf_cmplx - REAL(DP) :: alat_, a1_(3), a2_(3), a3_(3) - REAL(DP) :: pmass_, zv_ - REAL(DP) :: celldm_(6) - INTEGER :: iss_, nspin_, ngwt_, nbnd_ , n_emp_ , nbnd_tot - INTEGER :: nstates_up_ , nstates_dw_ , ntmp, nel_(2) - REAL(DP) :: nelec_ - REAL(DP) :: scalef_ - REAL(DP) :: wk_ - INTEGER :: nhpcl_, nhpdim_ - INTEGER :: ib, nb - INTEGER :: ik_eff - REAL(DP) :: amass_(ntypx) - INTEGER, ALLOCATABLE :: ityp_(:) - INTEGER, ALLOCATABLE :: isrt_(:) - REAL(DP), ALLOCATABLE :: tau_(:,:) - REAL(DP), ALLOCATABLE :: occ_(:) - INTEGER, ALLOCATABLE :: if_pos_(:,:) - CHARACTER(LEN=256) :: psfile_(ntypx) - CHARACTER(LEN=80) :: pos_unit - REAL(DP) :: s1, s0, cclock - REAL(DP), ALLOCATABLE :: mrepl(:,:) - COMPLEX(DP), ALLOCATABLE :: mrepl_c(:,:) - ! - ! ... look for an empty unit - ! - CALL iotk_free_unit( iunout, ierr ) - ! - CALL errore( 'cp_readfile', & - 'no free units to read wavefunctions', ierr ) - ! - kunit = 1 - found = .FALSE. - ! - dirname = restart_dir( outdir, ndr ) - ! - ! ... Open XML descriptor - ! - IF ( ionode ) THEN - ! - filename = TRIM( dirname ) // '/' // TRIM( xmlpun ) - ! - WRITE( stdout, '(/,3X,"reading restart file: ",A)' ) TRIM( dirname ) - ! - CALL iotk_open_read( iunpun, FILE = TRIM( filename ), IERR = ierr ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_readfile', & - 'cannot open restart file for reading', ierr ) - ! - s0 = cclock() - ! - IF ( ionode ) THEN - ! - qexml_version = " " - ! - CALL iotk_scan_begin( iunpun, "HEADER", FOUND=found ) - ! - IF ( found ) THEN - ! - CALL iotk_scan_empty( iunpun, "FORMAT", ATTR=attr ) - CALL iotk_scan_attr( attr, "VERSION", qexml_version ) - CALL iotk_scan_end( iunpun, "HEADER" ) - ! - ELSE - ! - qexml_version = TRIM( default_fmt_version ) - ! - ENDIF - ! - qexml_version_init = .TRUE. - - ! - ! init logical variables for versioning - ! - qexml_version_before_1_4_0 = .FALSE. - ! - IF ( TRIM( version_compare( qexml_version, "1.4.0" )) == "older" ) & - qexml_version_before_1_4_0 = .TRUE. - ! - ENDIF - ! - CALL mp_bcast( qexml_version, ionode_id, intra_image_comm ) - CALL mp_bcast( qexml_version_init, ionode_id, intra_image_comm ) - CALL mp_bcast( qexml_version_before_1_4_0 , ionode_id, intra_image_comm ) - ! - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "STATUS", FOUND = found ) - ! - IF ( found ) THEN - ! - CALL iotk_scan_empty( iunpun, "STEP", attr ) - CALL iotk_scan_attr( attr, "ITERATION", nfi ) - CALL iotk_scan_dat( iunpun, "TIME", simtime ) - CALL iotk_scan_dat( iunpun, "TITLE", title ) - CALL iotk_scan_end( iunpun, "STATUS" ) - ! - END IF - ! - END IF - ! - ! ... Read cell and positions - ! - ALLOCATE( tau_( 3, nat ) ) - ALLOCATE( if_pos_( 3, nat ) ) - ALLOCATE( ityp_( nat ) ) - ! - IF ( ionode ) THEN - ! - CALL read_cell( ibrav_, symm_type_, celldm_, & - alat_, a1_, a2_, a3_, b1, b2, b3 ) - ! - CALL recips( a1_, a2_, a3_, b1, b2, b3 ) - ! - END IF - ! - IF ( ionode ) THEN - ! - CALL read_ions( nsp_, nat_, atm_, ityp_, & - psfile_, amass_, tau_, if_pos_, pos_unit, ierr ) - ! - IF ( ierr == 0 ) THEN - ! - IF( nsp_ /= nsp .OR. nat_ /= nat ) ierr = 2 - ! - DO i = 1, nat - ! - IF ( ityp_(i) /= ityp(i) ) ierr = 3 - ! - END DO - ! - END IF - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_readfile', & - 'cannot read positions from restart file', ierr ) - ! - ! Read SPIN infos - ! - lsda_ = ( nspin == 2 ) - ! - IF( ionode ) THEN - CALL iotk_scan_begin( iunpun, "SPIN", FOUND = found ) - IF( found ) THEN - CALL iotk_scan_dat( iunpun, "LSDA", lsda_ ) - CALL iotk_scan_end( iunpun, "SPIN" ) - END IF - END IF - ! - CALL mp_bcast( lsda_ , ionode_id, intra_image_comm ) - ! - IF( lsda_ .AND. nspin == 1 ) & - CALL errore( 'cp_readfile', 'LSDA restart file with a spinless run', ierr ) - - ! - ! Read Occupations infos - ! - nstates_up_ = nupdwn( 1 ) - nstates_dw_ = nupdwn( 2 ) - - IF( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "OCCUPATIONS", FOUND = found ) - IF( found ) THEN - ! - CALL iotk_scan_empty( iunpun, "INFO", attr, FOUND = found ) - ! - IF( lsda_ .AND. found ) THEN - ! - IF ( qexml_version_before_1_4_0 ) THEN - ! - CALL iotk_scan_attr( attr, "nelup", nstates_up_ ) - CALL iotk_scan_attr( attr, "neldw", nstates_dw_ ) - ! - ELSE - ! - ! current version - ! - CALL iotk_scan_attr( attr, "nstates_up", nstates_up_ ) - CALL iotk_scan_attr( attr, "nstates_down", nstates_dw_ ) - ! - ENDIF - ! - ENDIF - ! - CALL iotk_scan_end( iunpun, "OCCUPATIONS" ) - ! - ENDIF - ENDIF - ! - CALL mp_bcast( nstates_up_ , ionode_id, intra_image_comm ) - CALL mp_bcast( nstates_dw_ , ionode_id, intra_image_comm ) - ! - IF( lsda_ ) THEN - IF( ( nstates_up_ /= nupdwn( 1 ) ) .OR. ( nstates_dw_ /= nupdwn( 2 ) ) ) & - CALL errore( 'cp_readfile', 'inconsistent number of spin states', ierr ) - END IF - - ! ... read MD timesteps variables - ! - IF ( ionode ) & - CALL iotk_scan_begin( iunpun, "TIMESTEPS", attr, FOUND = found ) - ! - ierr = 0 - ! - IF ( ionode .AND. found ) THEN - ! - CALL iotk_scan_attr( attr, "nt", nt_ ) - ! - IF ( nt_ > 0 ) THEN - ! - CALL iotk_scan_begin( iunpun, "STEP0" ) - ! - CALL iotk_scan_dat( iunpun, "ACCUMULATORS", acc ) - ! - CALL iotk_scan_begin( iunpun,"IONS_POSITIONS" ) - CALL iotk_scan_dat( iunpun, "stau", stau0(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "svel", svel0(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "taui", taui(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "cdmi", cdmi(1:3) ) - CALL iotk_scan_dat( iunpun, "force", force(1:3,1:nat) ) - CALL iotk_scan_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_scan_begin( iunpun, "IONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "nhpcl", nhpcl_ ) - CALL iotk_scan_dat( iunpun, "nhpdim", nhpdim_ ) - ! - IF ( nhpcl_ == nhpcl .AND. nhpdim_ == nhpdim ) THEN - ! - CALL iotk_scan_dat( iunpun, "xnhp", xnhp0(1:nhpcl*nhpdim) ) - CALL iotk_scan_dat( iunpun, "vnhp", vnhp(1:nhpcl*nhpdim) ) - ! - ELSE - ! - xnhp0(1:nhpcl*nhpdim) = 0.D0 - vnhp(1:nhpcl*nhpdim) = 0.D0 - ! - END IF - ! - CALL iotk_scan_end( iunpun, "IONS_NOSE" ) - ! - CALL iotk_scan_dat( iunpun, "ekincm", ekincm ) - ! - CALL iotk_scan_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhe", xnhe0 ) - CALL iotk_scan_dat( iunpun, "vnhe", vnhe ) - CALL iotk_scan_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_scan_dat( iunpun, "ht", ht ) - CALL iotk_scan_dat( iunpun, "htvel", htvel ) - CALL iotk_scan_dat( iunpun, "gvel", gvel ) - CALL iotk_scan_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhh", xnhh0 ) - CALL iotk_scan_dat( iunpun, "vnhh", vnhh ) - CALL iotk_scan_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_scan_end( iunpun, "STEP0" ) - ! - ELSE - ! - ierr = 40 - ! - GOTO 100 - ! - END IF - ! - IF ( nt_ > 1 ) THEN - ! - CALL iotk_scan_begin( iunpun, "STEPM" ) - ! - CALL iotk_scan_begin( iunpun, "IONS_POSITIONS" ) - CALL iotk_scan_dat( iunpun, "stau", staum(1:3,1:nat) ) - CALL iotk_scan_dat( iunpun, "svel", svelm(1:3,1:nat) ) - CALL iotk_scan_end( iunpun, "IONS_POSITIONS" ) - ! - CALL iotk_scan_begin( iunpun, "IONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "nhpcl", nhpcl_ ) - CALL iotk_scan_dat( iunpun, "nhpdim", nhpdim_ ) - ! - IF ( nhpcl_ == nhpcl .AND. nhpdim_ == nhpdim ) THEN - ! - CALL iotk_scan_dat( iunpun, "xnhp", xnhpm(1:nhpcl*nhpdim) ) - ! - ELSE - ! - xnhpm(1:nhpcl*nhpdim) = 0.D0 - ! - END IF - ! - CALL iotk_scan_end( iunpun,"IONS_NOSE" ) - ! - CALL iotk_scan_begin( iunpun, "ELECTRONS_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhe", xnhem ) - CALL iotk_scan_end( iunpun, "ELECTRONS_NOSE" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_scan_dat( iunpun, "ht", htm ) - CALL iotk_scan_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhh", xnhhm ) - CALL iotk_scan_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_scan_end( iunpun, "STEPM" ) - ! - END IF - ! - CALL iotk_scan_end( iunpun, "TIMESTEPS" ) - ! - ELSE IF ( ionode ) THEN - ! - ! ... MD time steps not found, try to recover from CELL and POSITIONS - ! - acc = 0.D0 - ! - ALLOCATE( isrt_( nat ) ) - ! - SELECT CASE( TRIM( pos_unit ) ) - CASE( "alat" ) - ! - tau_ = tau_ * alat_ - ! - CASE( "Angstrom" ) - ! - tau_ = tau_ * angstrom_au - ! - CASE DEFAULT - ! - END SELECT - ! - CALL sort_tau( taui, isrt_ , tau_ , ityp_ , nat_ , nsp_ ) - ! - ht(1,:) = a1_ - ht(2,:) = a2_ - ht(3,:) = a3_ - ! - CALL invmat( 3, ht, htm1, omega ) - ! - hinv = TRANSPOSE( htm1 ) - ! - CALL r_to_s( taui, stau0, na, nsp, hinv ) - ! - CALL ions_cofmass( taui, amass_ , na, nsp, cdmi ) - ! - staum = stau0 - svel0 = 0.D0 - svelm = 0.D0 - force = 0.D0 - ! - htm = ht - htvel = 0.D0 - gvel = 0.D0 - xnhh0 = 0.D0 - vnhh = 0.D0 - xnhhm = 0.D0 - ! - xnhe0 = 0.D0 - xnhem = 0.D0 - vnhe = 0.D0 - ! - ekincm = 0.D0 - ! - xnhp0 = 0.D0 - xnhpm = 0.D0 - vnhp = 0.D0 - ! - DEALLOCATE( isrt_ ) - ! - END IF - ! - 100 CONTINUE - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - IF( ierr /= 0 ) THEN - CALL mp_bcast( attr, ionode_id, intra_image_comm ) - CALL errore( 'cp_readfile ', TRIM( attr ), ierr ) - END IF - ! - DEALLOCATE( tau_ ) - DEALLOCATE( if_pos_ ) - DEALLOCATE( ityp_ ) - ! - ! ... compute the scale factor - ! - IF ( ionode ) CALL invmat( 3, ht, htm1, omega ) - ! - CALL mp_bcast( omega, ionode_id, intra_image_comm ) - ! - ! ... Beware: omega may be negative if axis are left-handed! - ! - scalef = 1.D0 / SQRT( ABS( omega ) ) - ! - ! ... band Structure - ! - IF ( ionode ) THEN - ! - ierr = 0 - ! - CALL iotk_scan_begin( iunpun, "BAND_STRUCTURE_INFO" ) - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_SPIN_COMPONENTS", nspin_ ) - ! - IF ( nspin_ /= nspin ) THEN - attr = "spin do not match" - ierr = 31 - GOTO 90 - END IF - ! - IF ( nspin == 2 ) THEN - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_ELECTRONS", nelec_, ATTR = attr ) - CALL iotk_scan_attr( attr, "UP", nel_(1) ) - CALL iotk_scan_attr( attr, "DW", nel_(2) ) - ! - IF ( ( nel(1) /= nel_(1) ) .OR. ( nel(2) /= nel_(2) ) .OR. ( NINT( nelec_ ) /= nelt ) ) THEN - attr = "electrons do not match" - write(0,*) "from cp_readfile warning: electrons do not match" - write(6,*) "from cp_readfile warning: electrons do not match" - !ierr = 33 - GOTO 90 - END IF - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_BANDS", nbnd_tot , ATTR = attr ) - ! - ELSE - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_ELECTRONS", nelec_ ) - ! - IF ( NINT( nelec_ ) /= nelt ) THEN - attr = "electrons do not match" - ierr = 33 - GOTO 90 - END IF - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_BANDS", nbnd_tot ) - ! - END IF - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_EMPTY_STATES", n_emp_, FOUND = found ) - ! - IF( .NOT. found ) n_emp_ = 0 - ! - nbnd_ = nbnd_tot - n_emp_ - ! - IF ( nbnd_ < nupdwn(1) ) THEN - attr = "nbnd do not match" - ierr = 32 - GOTO 90 - END IF - ! - CALL iotk_scan_end( iunpun, "BAND_STRUCTURE_INFO" ) - ! - END IF - ! - 90 CONTINUE - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - IF( ierr /= 0 ) THEN - CALL mp_bcast( attr, ionode_id, intra_image_comm ) - CALL errore( 'cp_readfile ', TRIM( attr ), ierr ) - END IF - ! - IF( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "EIGENVALUES" ) - ! - END IF - ! - k_points_loop1: DO ik = 1, nk - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - CALL iotk_scan_dat( iunpun, "WEIGHT", wk_ ) - ! - END IF - ! - DO iss = 1, nspin - ! - cspin = iotk_index( iss ) - ! - ik_eff = ik + ( iss - 1 ) * nk - ! - IF ( ionode ) THEN - ! - ALLOCATE( occ_ ( MAX( nudx , nbnd_tot ) ) ) - ! - occ_ = 0.0d0 - ! - CALL iotk_scan_dat( iunpun, "OCC0" // TRIM( cspin ), occ_ ( 1 : nupdwn( iss ) ), FOUND = found ) - ! - IF( .NOT. found ) THEN - ! - IF( nspin == 1 ) THEN - CALL iotk_scan_begin( iunpun, "DATAFILE", FOUND = found ) - ELSE - CALL iotk_scan_begin( iunpun, "DATAFILE//TRIM(cspin)", FOUND = found ) - END IF - ! - CALL iotk_scan_dat ( iunpun, "OCCUPATIONS", occ_( 1:nbnd_tot ) ) - ! - IF( nspin == 1 ) THEN - CALL iotk_scan_end( iunpun, "DATAFILE" ) - ELSE - CALL iotk_scan_end( iunpun, "DATAFILE//TRIM(cspin)" ) - END IF - ! - IF( found ) THEN - occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) * wk_ - occm( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) * wk_ - END IF - ! - ELSE - ! - occ0( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) - ! - CALL iotk_scan_dat( iunpun, "OCCM" // TRIM( cspin ), occ_ ( 1 : nupdwn( iss ) ), FOUND = found ) - ! - IF( found ) THEN - occm( iupdwn( iss ) : iupdwn( iss ) + nupdwn( iss ) - 1 ) = occ_ ( 1:nupdwn( iss ) ) - END IF - ! - END IF - ! - DEALLOCATE ( occ_ ) - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( .NOT. found ) & - CALL errore( " readfile ", " occupation numbers not found! ", 1 ) - ! - END DO - - IF ( ionode ) CALL iotk_scan_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - END DO k_points_loop1 - - IF ( ionode ) THEN - CALL iotk_scan_end ( iunpun, "EIGENVALUES" ) - CALL iotk_scan_begin( iunpun, "EIGENVECTORS" ) - END IF - ! - k_points_loop2: DO ik = 1, nk - ! - IF ( ionode ) THEN - CALL iotk_scan_begin( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - END IF - ! - DO iss = 1, nspin - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "WFC0" // TRIM( iotk_index (iss) ), FOUND = found ) - ! - filename = "WFC0" // TRIM( iotk_index (iss) ) - ! - IF( .NOT. found ) THEN - ! - IF( nspin == 2 ) THEN - CALL iotk_scan_begin( iunpun, "WFC" // TRIM( iotk_index (iss) ), FOUND = found ) - filename = "WFC" // TRIM( iotk_index (iss) ) - ELSE - CALL iotk_scan_begin( iunpun, "WFC", FOUND = found ) - filename = "WFC" - END IF - ! - END IF - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( .NOT. found ) & - CALL errore( " readfile ", " wave functions not found! ", 1 ) - ! - IF( .NOT. ( iss > 1 .AND. force_pairing ) ) THEN - ! - ! Only WF with spin 1 are needed when force_pairing is active - ! - ib = iupdwn(iss) - nb = nupdwn(iss) - ! - ! filename is not needed we are following the link! - ! - CALL read_wfc( iunpun, ik_eff , nk, kunit, iss_, nspin_, & - c02( :, ib:ib+nb-1 ), ngwt_, nbnd_, ig_l2g, ngw, & - filename, scalef_, .TRUE. ) - ! - END IF - ! - IF ( ionode ) & - CALL iotk_scan_end( iunpun, TRIM(filename) ) - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "WFCM" // TRIM( iotk_index (iss) ), FOUND = found ) - ! - filename = "WFCM" // TRIM( iotk_index (iss) ) - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( found ) THEN - ! - IF( .NOT. ( iss > 1 .AND. force_pairing ) ) THEN - ! - ! Only WF with spin 1 are needed when force_pairing is active - ! - ib = iupdwn(iss) - nb = nupdwn(iss) - ! - CALL read_wfc( iunpun, ik_eff, nk, kunit, iss_, nspin_, & - cm2( :, ib:ib+nb-1 ), ngwt_, nbnd_, ig_l2g, ngw, & - filename, scalef_ , .TRUE. ) - ! - END IF - ! - IF ( ionode ) & - CALL iotk_scan_end( iunpun, TRIM( filename ) ) - ! - ELSE - ! - cm2 = c02 - ! - END IF - ! - IF (odd_nkscalfact .and. restart_odd_nkscalfact) THEN - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "WFC0FIXED" // TRIM( iotk_index (iss) ), FOUND = found ) - ! - filename = "WFC0FIXED" // TRIM( iotk_index (iss) ) - ! - END IF - ! - CALL mp_bcast( found, ionode_id, intra_image_comm ) - ! - IF( .NOT. found ) & - CALL errore( " readfile ", " wave functions evc0fixed not found! ", 1 ) - ! - IF( .NOT. ( iss > 1 .AND. force_pairing ) ) THEN - ! - ! Only WF with spin 1 are needed when force_pairing is active - ! - ib = iupdwn(iss) - nb = nupdwn(iss) - ! - ! filename is not needed we are following the link! - ! - CALL read_wfc( iunpun, ik_eff , nk, kunit, iss_, nspin_, & - c0_fixed( :, ib:ib+nb-1 ), ngwt_, nbnd_, ig_l2g, ngw, & - filename, scalef_, .TRUE. ) - ! - END IF - ! - IF ( ionode ) & - CALL iotk_scan_end( iunpun, TRIM(filename) ) - ! - ENDIF - ! - END DO - ! - DO iss = 1, nspin - ! - ! ... read matrix lambda to file - ! - IF(.not. lambda0(1)%iscmplx) THEN - ALLOCATE(mrepl(nudx, nudx )) - ! - IF( ionode ) THEN - CALL iotk_scan_dat( iunpun, "LAMBDA0" // TRIM( cspin ), mrepl, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING lambda0 not read from restart file' - mrepl = 0.0d0 - END IF - END IF - - CALL mp_bcast( mrepl, ionode_id, intra_image_comm ) - CALL distribute_lambda( mrepl, lambda0(iss)%rvec(:,:), descla(:,iss) ) - - IF( ionode ) THEN - CALL iotk_scan_dat( iunpun, "LAMBDAM" // TRIM( cspin ), mrepl, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING lambdam not read from restart file' - mrepl = 0.0d0 - END IF - END IF - ! - CALL mp_bcast( mrepl, ionode_id, intra_image_comm ) - - CALL distribute_lambda( mrepl, lambdam(iss)%rvec(:,:), descla(:,iss) ) - DEALLOCATE(mrepl) - ! - ELSE - WRITE( stdout, * ) 'here should be iotk first error' - ALLOCATE(mrepl_c(nudx, nudx)) - IF( ionode ) THEN - CALL iotk_scan_dat( iunpun, "LAMBDA0" // TRIM( cspin ), mrepl_c, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING lambda0 not read from restart file' - mrepl_c = CMPLX(0.0d0, 0.d0) - END IF - END IF - - CALL mp_bcast( mrepl_c, ionode_id, intra_image_comm ) - - CALL distribute_lambda(mrepl_c, lambda0(iss)%cvec(:,:), descla(:,iss) ) - - IF( ionode ) THEN - CALL iotk_scan_dat( iunpun, "LAMBDAM" // TRIM( cspin ), mrepl_c, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING lambdam not read from restart file' - mrepl_c = CMPLX(0.0d0,0.d0) - END IF - END IF - ! - CALL mp_bcast( mrepl_c, ionode_id, intra_image_comm ) - CALL distribute_lambda( mrepl_c, lambdam(iss)%cvec(:,:), descla(:,iss) ) - DEALLOCATE(mrepl_c) - - ENDIF - - IF ( PRESENT( mat_z ) ) THEN - ! - - IF( ionode ) THEN - IF(.not.mat_z(iss)%iscmplx) THEN - IF(.not.allocated(mrepl)) THEN - ALLOCATE(mrepl(nudx,nudx)) - ENDIF - CALL iotk_scan_dat( iunpun, "MAT_Z" // TRIM( iotk_index( iss ) ), mrepl, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING mat_z not read from restart file' - mrepl = 0.0d0 - END IF - CALL mp_bcast( mrepl, ionode_id, intra_image_comm ) - CALL distribute_zmat( mrepl, mat_z(iss)%rvec(:,:), descla(:,iss) ) - DEALLOCATE(mrepl) - ELSE - IF(.not.allocated(mrepl_c)) THEN - ALLOCATE(mrepl_c(nudx,nudx)) - ENDIF - CALL iotk_scan_dat( iunpun, "MAT_Z" // TRIM( iotk_index( iss ) ), mrepl_c, FOUND = found ) - IF( .NOT. found ) THEN - WRITE( stdout, * ) 'WARNING mat_z not read from restart file' - mrepl_c = CMPLX(0.0d0,0.d0) - END IF - CALL mp_bcast( mrepl_c, ionode_id, intra_image_comm ) - CALL distribute_zmat( mrepl_c, mat_z(iss)%cvec(:,:), descla(:,iss) ) - DEALLOCATE(mrepl_c) - ENDIF - END IF - ! - END IF - ! - ! - END DO - ! - IF ( ionode ) CALL iotk_scan_end( iunpun, "K-POINT" // TRIM( iotk_index(ik) ) ) - ! - END DO k_points_loop2 - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_end( iunpun, "EIGENVECTORS" ) - ! - END IF - ! - CALL mp_bcast( qexml_version, ionode_id, intra_image_comm ) - CALL mp_bcast( qexml_version_init, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( nfi, ionode_id, intra_image_comm ) - CALL mp_bcast( simtime, ionode_id, intra_image_comm ) - CALL mp_bcast( title, ionode_id, intra_image_comm ) - CALL mp_bcast( acc, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( ht, ionode_id, intra_image_comm ) - CALL mp_bcast( htm, ionode_id, intra_image_comm ) - CALL mp_bcast( htvel, ionode_id, intra_image_comm ) - CALL mp_bcast( gvel, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhh0, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhhm, ionode_id, intra_image_comm ) - CALL mp_bcast( vnhh, ionode_id, intra_image_comm ) - CALL mp_bcast( b1, ionode_id, intra_image_comm ) - CALL mp_bcast( b2, ionode_id, intra_image_comm ) - CALL mp_bcast( b3, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( stau0, ionode_id, intra_image_comm ) - CALL mp_bcast( svel0, ionode_id, intra_image_comm ) - CALL mp_bcast( staum, ionode_id, intra_image_comm ) - CALL mp_bcast( svelm, ionode_id, intra_image_comm ) - CALL mp_bcast( taui, ionode_id, intra_image_comm ) - CALL mp_bcast( force, ionode_id, intra_image_comm ) - CALL mp_bcast( cdmi, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhp0, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhpm, ionode_id, intra_image_comm ) - CALL mp_bcast( vnhp, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( xnhe0, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhem, ionode_id, intra_image_comm ) - CALL mp_bcast( vnhe, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( kunit, ionode_id, intra_image_comm ) - - CALL mp_bcast( occ0, ionode_id, intra_image_comm ) - CALL mp_bcast( occm, ionode_id, intra_image_comm ) - ! -! IF ( PRESENT( mat_z ) ) THEN !warning:giovanni this part is a bug??? -! DO iss=1,nspin -! IF(.not.mat_z(iss)%iscmplx) THEN -! CALL mp_bcast( mat_z(iss)%rvec(:,:), ionode_id, intra_image_comm ) -! ELSE -! CALL mp_bcast( mat_z(iss)%cvec(:,:), ionode_id, intra_image_comm ) -! ENDIF -! ENDDO -! ENDIF - ! - IF ( ionode ) & - CALL iotk_close_read( iunpun ) - - ! - s1 = cclock() - ! - IF ( ionode ) THEN - ! - WRITE( stdout, & - '(3X,"restart file read in ",F8.3," sec.",/)' ) ( s1 - s0 ) - ! - END IF - ! - if (nprint_nfi.eq.-2) then - write( stdout,*) 'nprint_nfi= ',nprint_nfi - CALL read_print_counter( nprint_nfi, outdir, ndr ) - write( stdout,*) 'nprint_nfi= ',nprint_nfi - endif - ! - RETURN - ! - END SUBROUTINE cp_readfile_twin - ! - !------------------------------------------------------------------------ - SUBROUTINE cp_read_wfc( ndr, outdir, ik, nk, iss, nspin, c2, tag ) - !------------------------------------------------------------------------ - ! - USE electrons_base, ONLY : iupdwn, nupdwn - USE reciprocal_vectors, ONLY : ngwt, ngw, ig_l2g - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ndr - CHARACTER(LEN=*), INTENT(IN) :: outdir - INTEGER, INTENT(IN) :: ik, iss, nk, nspin - CHARACTER, INTENT(IN) :: tag - COMPLEX(DP), OPTIONAL, INTENT(OUT) :: c2(:,:) - ! - CHARACTER(LEN=256) :: dirname, filename - INTEGER :: ik_eff, ib, nb, kunit, iss_, nspin_, ngwt_, nbnd_ - REAL(DP) :: scalef - ! - kunit = 1 - ! - ik_eff = ik + ( iss - 1 ) * nk - ! - dirname = restart_dir( outdir, ndr ) - ! - IF ( tag /= 'm' ) THEN - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evc0', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evc0', ik, iss ) ) - ! - END IF - ! - ELSE - ! - IF ( nspin == 1 ) THEN - ! - filename = TRIM( wfc_filename( dirname, 'evcm', ik ) ) - ! - ELSE - ! - filename = TRIM( wfc_filename( dirname, 'evcm', ik, iss ) ) - ! - END IF - ! - END IF - ! - ib = iupdwn(iss) - nb = nupdwn(iss) - ! - CALL read_wfc( iunout, ik_eff, nk, kunit, iss_, nspin_, & - c2(:,ib:ib+nb-1), ngwt_, nbnd_, ig_l2g, ngw, & - filename, scalef ) - ! - RETURN - ! - END SUBROUTINE cp_read_wfc - ! - !------------------------------------------------------------------------ - SUBROUTINE cp_read_cell( ndr, outdir, ascii, ht, & - htm, htvel, gvel, xnhh0, xnhhm, vnhh ) - !------------------------------------------------------------------------ - ! - USE io_files, ONLY : iunpun, xmlpun - USE mp_global, ONLY : intra_image_comm - USE mp, ONLY : mp_sum - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ndr - CHARACTER(LEN=*), INTENT(IN) :: outdir - LOGICAL, INTENT(IN) :: ascii - REAL(DP), INTENT(INOUT) :: ht(3,3) - REAL(DP), INTENT(INOUT) :: htm(3,3) - REAL(DP), INTENT(INOUT) :: htvel(3,3) - REAL(DP), INTENT(INOUT) :: gvel(3,3) - REAL(DP), INTENT(INOUT) :: xnhh0(3,3) - REAL(DP), INTENT(INOUT) :: xnhhm(3,3) - REAL(DP), INTENT(INOUT) :: vnhh(3,3) - ! - CHARACTER(LEN=256) :: dirname, filename - INTEGER :: strlen - INTEGER :: i, ierr, nt_ - LOGICAL :: found - ! - ! ... variables read for testing pourposes - ! - INTEGER :: ibrav_ - REAL(DP) :: alat_ - REAL(DP) :: celldm_(6) - REAL(DP) :: a1_(3), a2_(3), a3_(3) - REAL(DP) :: b1_(3), b2_(3), b3_(3) - CHARACTER(LEN=9) :: symm_type_ - ! - ! - dirname = restart_dir( outdir, ndr ) - ! - filename = TRIM( dirname ) // '/' // TRIM( xmlpun ) - ! - IF ( ionode ) & - CALL iotk_open_read( iunpun, FILE = TRIM( filename ), & - BINARY = .FALSE., ROOT = attr, IERR = ierr ) - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_read_cell', & - 'cannot open restart file for reading: ' // TRIM(filename), & - ierr ) - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( iunpun, "TIMESTEPS", attr, FOUND = found ) - ! - IF ( found ) THEN - ! - CALL iotk_scan_attr( attr, "nt", nt_ ) - ! - IF ( nt_ > 0 ) THEN - ! - CALL iotk_scan_begin( iunpun, "STEP0" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_scan_dat( iunpun, "ht", ht ) - CALL iotk_scan_dat( iunpun, "htvel", htvel ) - CALL iotk_scan_dat( iunpun, "gvel", gvel, & - FOUND = found, IERR = ierr ) - ! - IF ( .NOT. found ) gvel = 0.D0 - ! - CALL iotk_scan_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhh", xnhh0 ) - CALL iotk_scan_dat( iunpun, "vnhh", vnhh ) - CALL iotk_scan_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_scan_end( iunpun, "STEP0" ) - ! - ELSE - ! - ierr = 40 - ! - GOTO 100 - ! - END IF - ! - IF( nt_ > 1 ) THEN - ! - CALL iotk_scan_begin(iunpun,"STEPM") - ! - CALL iotk_scan_begin( iunpun, "CELL_PARAMETERS" ) - CALL iotk_scan_dat( iunpun, "ht", htm) - CALL iotk_scan_end( iunpun, "CELL_PARAMETERS" ) - ! - CALL iotk_scan_begin( iunpun, "CELL_NOSE" ) - CALL iotk_scan_dat( iunpun, "xnhh", xnhhm ) - CALL iotk_scan_end( iunpun, "CELL_NOSE" ) - ! - CALL iotk_scan_end( iunpun, "STEPM" ) - ! - END IF - ! - CALL iotk_scan_end( iunpun, "TIMESTEPS" ) - ! - ELSE - ! - ! ... MD steps have not been found, try to restart from cell data - ! - CALL read_cell( ibrav_, symm_type_, celldm_, & - alat_, a1_, a2_, a3_, b1_, b2_, b3_ ) - ! - ht(1,:) = a1_ - ht(2,:) = a2_ - ht(3,:) = a3_ - ! - htm = ht - htvel = 0.D0 - gvel = 0.D0 - xnhh0 = 0.D0 - vnhh = 0.D0 - xnhhm = 0.D0 - ! - END IF - ! - END IF - ! - 100 CONTINUE - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - CALL mp_bcast( attr, ionode_id, intra_image_comm ) - ! - CALL errore( 'cp_read_cell ', attr, ierr ) - ! - CALL mp_bcast( ht, ionode_id, intra_image_comm ) - CALL mp_bcast( htm, ionode_id, intra_image_comm ) - CALL mp_bcast( htvel, ionode_id, intra_image_comm ) - CALL mp_bcast( gvel, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhh0, ionode_id, intra_image_comm ) - CALL mp_bcast( xnhhm, ionode_id, intra_image_comm ) - CALL mp_bcast( vnhh, ionode_id, intra_image_comm ) - ! - IF ( ionode ) CALL iotk_close_read( iunpun ) - ! - RETURN - ! - END SUBROUTINE cp_read_cell - ! - !------------------------------------------------------------------------ - SUBROUTINE read_cell( ibrav, symm_type, & - celldm, alat, a1, a2, a3, b1, b2, b3 ) - !------------------------------------------------------------------------ - ! - INTEGER, INTENT(OUT) :: ibrav - CHARACTER(LEN=*), INTENT(OUT) :: symm_type - REAL(DP), INTENT(OUT) :: celldm(6), alat - REAL(DP), INTENT(OUT) :: a1(3), a2(3), a3(3) - REAL(DP), INTENT(OUT) :: b1(3), b2(3), b3(3) - ! - CHARACTER(LEN=256) :: bravais_lattice - ! - ! - CALL iotk_scan_begin( iunpun, "CELL" ) - ! - CALL iotk_scan_dat( iunpun, "BRAVAIS_LATTICE", bravais_lattice ) - ! - SELECT CASE ( TRIM( bravais_lattice ) ) - CASE( "free" ) - ibrav = 0 - CASE( "cubic P (sc)" ) - ibrav = 1 - CASE( "cubic F (fcc)" ) - ibrav = 2 - CASE( "cubic I (bcc)" ) - ibrav = 3 - CASE( "Hexagonal and Trigonal P" ) - ibrav = 4 - CASE( "Trigonal R" ) - ibrav = 5 - CASE( "Tetragonal P (st)" ) - ibrav = 6 - CASE( "Tetragonal I (bct)" ) - ibrav = 7 - CASE( "Orthorhombic P" ) - ibrav = 8 - CASE( "Orthorhombic base-centered(bco)" ) - ibrav = 9 - CASE( "Orthorhombic face-centered" ) - ibrav = 10 - CASE( "Orthorhombic body-centered" ) - ibrav = 11 - CASE( "Monoclinic P" ) - ibrav = 12 - CASE( "Monoclinic base-centered" ) - ibrav = 13 - CASE( "Triclinic P" ) - ibrav = 14 - END SELECT - ! - IF ( ibrav == 0 ) & - CALL iotk_scan_dat( iunpun, "CELL_SYMMETRY", symm_type ) - ! - CALL iotk_scan_dat( iunpun, "LATTICE_PARAMETER", alat ) - CALL iotk_scan_dat( iunpun, "CELL_DIMENSIONS", celldm(1:6) ) - ! - CALL iotk_scan_begin( iunpun, "DIRECT_LATTICE_VECTORS" ) - CALL iotk_scan_dat( iunpun, "a1", a1 ) - CALL iotk_scan_dat( iunpun, "a2", a2 ) - CALL iotk_scan_dat( iunpun, "a3", a3 ) - CALL iotk_scan_end( iunpun, "DIRECT_LATTICE_VECTORS" ) - ! - CALL iotk_scan_begin( iunpun, "RECIPROCAL_LATTICE_VECTORS" ) - CALL iotk_scan_dat( iunpun, "b1", b1 ) - CALL iotk_scan_dat( iunpun, "b2", b2 ) - CALL iotk_scan_dat( iunpun, "b3", b3 ) - CALL iotk_scan_end( iunpun, "RECIPROCAL_LATTICE_VECTORS" ) - ! - CALL iotk_scan_end( iunpun, "CELL" ) - ! - RETURN - ! - END SUBROUTINE - ! - !------------------------------------------------------------------------ - SUBROUTINE read_ions( nsp, nat, atm, ityp, psfile, & - amass, tau, if_pos, pos_unit, ierr ) - !------------------------------------------------------------------------ - ! - INTEGER, INTENT(OUT) :: nsp, nat - CHARACTER(LEN=3), INTENT(OUT) :: atm(:) - INTEGER, INTENT(OUT) :: ityp(:) - CHARACTER(LEN=256), INTENT(OUT) :: psfile(:) - REAL(DP), INTENT(OUT) :: amass(:) - REAL(DP), INTENT(OUT) :: tau(:,:) - INTEGER, INTENT(OUT) :: if_pos(:,:) - INTEGER, INTENT(OUT) :: ierr - CHARACTER(LEN=*), INTENT(OUT) :: pos_unit - ! - LOGICAL :: found, back_compat - INTEGER :: i - CHARACTER(LEN=3) :: lab - ! - ierr = 0 - ! - CALL iotk_scan_begin( iunpun, "IONS", FOUND = found ) - ! - IF ( .NOT. found ) THEN - ! - ierr = 1 - ! - RETURN - ! - END IF - ! - CALL iotk_scan_dat( iunpun, "NUMBER_OF_ATOMS", nat ) - CALL iotk_scan_dat( iunpun, "NUMBER_OF_SPECIES", nsp ) - ! - IF ( nsp > SIZE( atm ) .OR. nat > SIZE( ityp ) ) THEN - ! - ierr = 10 - ! - CALL iotk_scan_end( iunpun, "IONS" ) - ! - RETURN - ! - END IF - ! - ! - DO i = 1, nsp - ! - IF ( qexml_version_before_1_4_0 ) THEN - ! - CALL iotk_scan_dat( iunpun, "ATOM_TYPE", atm(i) ) - CALL iotk_scan_dat( iunpun, TRIM( atm(i) )//"_MASS", amass(i) ) - CALL iotk_scan_dat( iunpun, "PSEUDO_FOR_" // TRIM( atm(i) ), psfile(i) ) - ! - ELSE - ! - ! current format - ! - CALL iotk_scan_begin( iunpun, "SPECIE"//TRIM(iotk_index(i)) ) - ! - CALL iotk_scan_dat( iunpun, "ATOM_TYPE", atm(i) ) - CALL iotk_scan_dat( iunpun, "MASS", amass(i) ) - CALL iotk_scan_dat( iunpun, "PSEUDO", psfile(i) ) - ! - CALL iotk_scan_end( iunpun, "SPECIE"//TRIM(iotk_index(i)) ) - ! - ENDIF - ! - ENDDO - ! - CALL iotk_scan_empty( iunpun, "UNITS_FOR_ATOMIC_POSITIONS", attr ) - CALL iotk_scan_attr( attr, "UNITS", pos_unit ) - ! - DO i = 1, nat - ! - CALL iotk_scan_empty( iunpun, "ATOM" // TRIM( iotk_index( i ) ), attr ) - CALL iotk_scan_attr( attr, "SPECIES", lab ) - CALL iotk_scan_attr( attr, "INDEX", ityp(i) ) - CALL iotk_scan_attr( attr, "tau", tau(:,i) ) - CALL iotk_scan_attr( attr, "if_pos", if_pos(:,i) ) - ! - END DO - ! - CALL iotk_scan_end( iunpun, "IONS" ) - ! - RETURN - ! - END SUBROUTINE read_ions - ! - ! - ! - SUBROUTINE write_gk( iun, ik, mill, filename ) - ! - USE gvecw, ONLY : ngw, ngwt - USE control_flags, ONLY : do_wf_cmplx, gamma_only !added:giovanni do_wf_cmplx - USE reciprocal_vectors, ONLY : ig_l2g, mill_l - USE mp, ONLY : mp_sum - USE mp_global, ONLY : intra_image_comm - USE io_global, ONLY : ionode - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: iun, ik - INTEGER, INTENT(IN) :: mill(:,:) - CHARACTER(LEN=256), INTENT(IN) :: filename - ! - INTEGER, ALLOCATABLE :: igwk(:) - INTEGER, ALLOCATABLE :: itmp1(:) - INTEGER :: npwx_g, npw_g, ig, ngg - REAL(DP) :: xk(3) - - xk = 0.0d0 - npwx_g = ngwt - npw_g = ngwt - - ALLOCATE( igwk( npwx_g ) ) - ! - igwk = 0 - ! - ALLOCATE( itmp1( npw_g ) ) - ! - itmp1 = 0 - ! - ! - DO ig = 1, ngw - ! - itmp1( ig_l2g( ig ) ) = ig_l2g( ig ) - ! - END DO - ! - CALL mp_sum( itmp1, intra_image_comm ) - ! - ngg = 0 - ! - DO ig = 1, npw_g - ! - IF ( itmp1(ig) == ig ) THEN - ! - ngg = ngg + 1 - ! - igwk( ngg ) = ig - ! - END IF - ! - END DO - - DEALLOCATE( itmp1 ) - ! - IF ( ionode ) THEN - ! - CALL iotk_open_write( iun, FILE = TRIM( filename ), & - ROOT="GK-VECTORS", BINARY = .TRUE. ) - ! - CALL iotk_write_dat( iun, "NUMBER_OF_GK-VECTORS", npw_g ) - CALL iotk_write_dat( iun, "MAX_NUMBER_OF_GK-VECTORS", npwx_g ) - CALL iotk_write_dat( iun, "DO_WF_CMPLX", do_wf_cmplx ) !added:giovanni do_wf_cmplx - CALL iotk_write_dat( iun, "GAMMA_ONLY", gamma_only.and..not.do_wf_cmplx )!modified:giovanni for post-processing - ! - CALL iotk_write_attr ( attr, "UNITS", "2 pi / a", FIRST = .TRUE. ) - CALL iotk_write_dat( iun, "K-POINT_COORDS", xk(:), ATTR = attr ) - ! - CALL iotk_write_dat( iun, "INDEX", igwk( 1:npw_g ) ) - CALL iotk_write_dat( iun, "GRID", mill( 1:3, igwk( 1:npw_g ) ), COLUMNS = 3 ) - ! - CALL iotk_close_write( iun ) - ! - END IF - ! - DEALLOCATE( igwk ) - - RETURN - - END SUBROUTINE write_gk - ! - ! - ! -! SUBROUTINE write_translation(trans_matrix, trans_vec, )!added:giovanni -! -! -! CALL write_wfc( iunout, ik_eff, nk*nspin, kunit, iss, nspin, & -! ctot( :, ib : ib + nbnd_tot - 1 ), ngwt, do_wf_cmplx, gamma_only,& !added:giovanni do_wf_cmplx -! nbnd_tot, ig_l2g, ngw, filename, scalef ) -! ib = iupdwn(iss) -! nb = nupdwn(iss) -! ! -! CALL read_wfc( iunout, ik_eff, nk, kunit, iss_, nspin_, & -! c2(:,ib:ib+nb-1), ngwt_, nbnd_, ig_l2g, ngw, & -! filename, scalef ) -! ! -! END SUBROUTINE write_translation - -END MODULE cp_restart diff --git a/quantum_espresso/kcp/CPV/cp_version.f90 b/quantum_espresso/kcp/CPV/cp_version.f90 deleted file mode 100644 index 80e3f2002..000000000 --- a/quantum_espresso/kcp/CPV/cp_version.f90 +++ /dev/null @@ -1,14 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - - MODULE cp_version - USE global_version, only : version_number - IMPLICIT NONE - SAVE - INCLUDE 'cpver.h' - END MODULE cp_version diff --git a/quantum_espresso/kcp/CPV/cplib.f90 b/quantum_espresso/kcp/CPV/cplib.f90 deleted file mode 100644 index dcbac3112..000000000 --- a/quantum_espresso/kcp/CPV/cplib.f90 +++ /dev/null @@ -1,6449 +0,0 @@ -! -! Copyright (C) 2002-2007 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -#include "f_defs.h" -! -!----------------------------------------------------------------------- -SUBROUTINE atomic_wfc(eigr, n_atomic_wfc, wfc) -!----------------------------------------------------------------------- -! -! Compute atomic wavefunctions in G-space -! - USE kinds, ONLY: DP - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: g, gx - USE ions_base, ONLY: nsp, na, nat - USE cell_base, ONLY: tpiba - USE atom, ONLY: rgrid - USE uspp_param, ONLY: upf -! - IMPLICIT NONE - INTEGER, INTENT(in) :: n_atomic_wfc - COMPLEX(DP), INTENT(in) :: eigr(ngw, nat) - COMPLEX(DP), INTENT(inout):: wfc(ngw, n_atomic_wfc) -! - INTEGER :: natwfc, ndm, is, ia, ir, nb, l, m, lm, i, lmax_wfc, isa, ig - REAL(DP), ALLOCATABLE :: ylm(:, :), q(:), jl(:), vchi(:), chiq(:) -! -! calculate max angular momentum required in wavefunctions -! - IF (.NOT. ALLOCATED(rgrid)) & - CALL errore(' atomic_wfc ', ' rgrid not allocated ', 1) - - lmax_wfc = -1 - DO is = 1, nsp - lmax_wfc = MAX(lmax_wfc, MAXVAL(upf(is)%lchi(1:upf(is)%nwfc))) - END DO - ! - ALLOCATE (ylm(ngw, (lmax_wfc + 1)**2)) - ! - CALL ylmr2((lmax_wfc + 1)**2, ngw, gx, g, ylm) - ndm = MAXVAL(rgrid(1:nsp)%mesh) - ! - ALLOCATE (jl(ndm), vchi(ndm)) - ALLOCATE (q(ngw), chiq(ngw)) -! - DO i = 1, ngw - q(i) = SQRT(g(i))*tpiba - END DO -! - !DEALLOCATE(ylm) - !DEALLOCATE(vchi, jl) - !write(6,*) ngw,ndm,"deallocating", ubound(q), ubound(chiq), ubound(jl), ubound(ylm), ubound(vchi) - !DEALLOCATE(chiq) - !write(6,*) ngw,ndm,"deallocating", ubound(q), ubound(chiq), ubound(jl), ubound(ylm), ubound(vchi) - !DEALLOCATE(q) - !stop - - natwfc = 0 - isa = 0 - DO is = 1, nsp - ! - ! radial fourier transform of the chi functions - ! NOTA BENE: chi is r times the radial part of the atomic wavefunction - ! - DO nb = 1, upf(is)%nwfc - l = upf(is)%lchi(nb) - DO i = 1, ngw - CALL sph_bes(rgrid(is)%mesh, rgrid(is)%r, q(i), l, jl) - DO ir = 1, rgrid(is)%mesh - vchi(ir) = upf(is)%chi(ir, nb)*rgrid(is)%r(ir)*jl(ir) - END DO - CALL simpson_cp90(rgrid(is)%mesh, vchi, rgrid(is)%rab, chiq(i)) - END DO - ! - ! multiply by angular part and structure factor - ! NOTA BENE: the factor i^l MUST be present!!! - ! - DO m = 1, 2*l + 1 - lm = l**2 + m - DO ia = 1 + isa, na(is) + isa - natwfc = natwfc + 1 - do ig = 1, ngw - wfc(ig, natwfc) = CMPLX(0.d0, 1.d0)**l*eigr(ig, ia)*ylm(ig, lm)*chiq(ig) - end do - END DO - END DO - END DO - isa = isa + na(is) - END DO -! - IF (natwfc .NE. n_atomic_wfc) & - & CALL errore('atomic_wfc', 'unexpected error', natwfc) -! - DEALLOCATE (ylm) - DEALLOCATE (q, chiq) - DEALLOCATE (vchi, jl) -! - RETURN -END SUBROUTINE atomic_wfc -! - -!----------------------------------------------------------------------- -FUNCTION n_atom_wfc_x() -!---------------------------------------------------------------------------- - ! - ! ... Find max number of bands needed - ! - USE ions_base, ONLY: na, nsp - USE kinds, ONLY: DP - USE uspp_param, ONLY: upf - ! - IMPLICIT NONE - ! - INTEGER :: n_atom_wfc_x - INTEGER :: is, n - ! - n_atom_wfc_x = 0 - ! - DO is = 1, nsp - ! - DO n = 1, upf(is)%nwfc - ! - IF (upf(is)%oc(n) >= 0.D0) THEN - ! - n_atom_wfc_x = n_atom_wfc_x + na(is)*(2*upf(is)%lchi(n) + 1) - ! - END IF - ! - END DO - ! - END DO - ! - RETURN -END FUNCTION - -! - -!----------------------------------------------------------------------- -FUNCTION cscnorm(bec, nkbx, cp, ngwx, i, n, lgam) -!----------------------------------------------------------------------- -! requires in input the updated bec(i) -! - USE ions_base, ONLY: na - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gstart - USE cvan, ONLY: ish, nvb - USE uspp_param, ONLY: nh - USE uspp, ONLY: qq - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE kinds, ONLY: DP - USE twin_types !added:giovanni -! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: i, n - INTEGER, INTENT(IN) :: ngwx, nkbx - type(twin_matrix) :: bec!modified:giovanni - COMPLEX(DP) :: cp(ngwx, n) - LOGICAL :: lgam!added:giovanni - ! - REAL(DP) :: cscnorm - ! - INTEGER ig, is, iv, jv, ia, inl, jnl - REAL(DP) rsum - COMPLEX(DP) csum - REAL(DP), ALLOCATABLE:: temp(:) - REAL(DP) :: icoeff !added:giovanni - -!!!begin_added:giovanni - IF (lgam) THEN - icoeff = 2.d0 - ELSE - icoeff = 1.d0 - END IF -!!!end_added:giovanni -! - ALLOCATE (temp(ngw)) - - DO ig = 1, ngw - temp(ig) = DBLE(CONJG(cp(ig, i))*cp(ig, i)) - END DO - - IF (lgam) THEN!added:giovanni - rsum = 2.d0*SUM(temp) - IF (gstart == 2) rsum = rsum - temp(1) - ELSE!added:giovanni - rsum = SUM(temp) !added:giovanni - END IF - - CALL mp_sum(rsum, intra_image_comm) - - DEALLOCATE (temp) -! - IF (.not. bec%iscmplx) THEN - DO is = 1, nvb - DO iv = 1, nh(is) - DO jv = 1, nh(is) - IF (ABS(qq(iv, jv, is)) .GT. 1.e-5) THEN - DO ia = 1, na(is) - inl = ish(is) + (iv - 1)*na(is) + ia - jnl = ish(is) + (jv - 1)*na(is) + ia - rsum = rsum + & - & qq(iv, jv, is)*bec%rvec(inl, i)*bec%rvec(jnl, i) - END DO - END IF - END DO - END DO - END DO - ELSE -!begin_added:giovanni - csum = CMPLX(rsum, 0.d0) - DO is = 1, nvb - DO iv = 1, nh(is) - DO jv = 1, nh(is) - IF (ABS(qq(iv, jv, is)) .GT. 1.e-5) THEN - DO ia = 1, na(is) - inl = ish(is) + (iv - 1)*na(is) + ia - jnl = ish(is) + (jv - 1)*na(is) + ia - csum = csum + & - & CMPLX(qq(iv, jv, is), 0.d0)*CONJG(bec%cvec(inl, i))*bec%cvec(jnl, i) - END DO - END IF - END DO - END DO - END DO - rsum = DBLE(csum) -!end_added:giovanni - END IF -! - cscnorm = SQRT(rsum) -! - RETURN -END FUNCTION cscnorm -! -! -!----------------------------------------------------------------------- -SUBROUTINE denlcc(nnr, nspin, vxcr, sfac, drhocg, dcc) -!----------------------------------------------------------------------- -! -! derivative of non linear core correction exchange energy wrt cell -! parameters h -! Output in dcc -! - USE kinds, ONLY: DP - USE ions_base, ONLY: nsp - USE reciprocal_vectors, ONLY: gstart, gx, ngs, g, ngm - USE recvecs_indexes, ONLY: np - USE cell_base, ONLY: omega, ainv, tpiba2 - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE uspp_param, ONLY: upf - USE cp_interfaces, ONLY: fwfft - USE fft_base, ONLY: dfftp - - IMPLICIT NONE - - ! input - - INTEGER, INTENT(IN) :: nnr, nspin - REAL(DP) :: vxcr(nnr, nspin) - COMPLEX(DP) :: sfac(ngs, nsp) - REAL(DP) :: drhocg(ngm, nsp) - - ! output - - REAL(DP), INTENT(OUT) :: dcc(3, 3) - - ! local - - INTEGER :: i, j, ig, is - COMPLEX(DP) :: srhoc - REAL(DP) :: vxcc - ! - COMPLEX(DP), ALLOCATABLE :: vxc(:) -! - dcc = 0.0d0 - ! - ALLOCATE (vxc(nnr)) - ! - vxc(:) = vxcr(:, 1) - ! - IF (nspin > 1) vxc(:) = vxc(:) + vxcr(:, 2) - ! - CALL fwfft('Dense', vxc, dfftp) - ! - DO i = 1, 3 - DO j = 1, 3 - DO ig = gstart, ngs - srhoc = 0.0d0 - DO is = 1, nsp - IF (upf(is)%nlcc) srhoc = srhoc + sfac(ig, is)*drhocg(ig, is) - END DO - vxcc = DBLE(CONJG(vxc(np(ig)))*srhoc)/SQRT(g(ig)*tpiba2) - dcc(i, j) = dcc(i, j) + vxcc* & - & 2.d0*tpiba2*gx(i, ig)* & - & (gx(1, ig)*ainv(j, 1) + & - & gx(2, ig)*ainv(j, 2) + & - & gx(3, ig)*ainv(j, 3)) - END DO - END DO - END DO - - DEALLOCATE (vxc) - - dcc = dcc*omega - - CALL mp_sum(dcc(1:3, 1:3), intra_image_comm) - - RETURN -END SUBROUTINE denlcc - -!----------------------------------------------------------------------- -SUBROUTINE dotcsc(eigr, cp, ngw, n, lgam)!added:giovanni lgam -!----------------------------------------------------------------------- -! - USE kinds, ONLY: DP - USE ions_base, ONLY: na, nat - USE io_global, ONLY: stdout - USE reciprocal_vectors, ONLY: gstart - USE cvan, ONLY: ish, nvb - USE uspp, ONLY: nkb, qq - USE uspp_param, ONLY: nh - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE twin_types !added:giovanni - USE cp_interfaces, ONLY: nlsm1 !added:giovanni -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: ngw, n - COMPLEX(DP) :: eigr(ngw, nat), cp(ngw, n) - LOGICAL, INTENT(IN) :: lgam -! local variables - REAL(DP) rsum - COMPLEX(DP) :: csum - COMPLEX(DP) :: csc(n) ! automatic array - COMPLEX(DP) :: temp(ngw) ! automatic array - - type(twin_matrix) :: becp !modified:giovanni - INTEGER i, kmax, nnn, k, ig, is, ia, iv, jv, inl, jnl - COMPLEX(DP) :: icoeff - -!!!begin_added:giovanni - IF (lgam) THEN - icoeff = CMPLX(2.d0, 0.d0) -! becp%iscmplx=.false.!optional:giovanni - ELSE - icoeff = CMPLX(1.d0, 0.d0) -! becp%iscmplx=.true.!optional:giovanni - END IF -!!!end_added:giovanni -! - CALL allocate_twin(becp, nkb, n, lgam) -! -! < beta | phi > is real. only the i lowest: -! - nnn = MIN(12, n) - - DO i = nnn, 1, -1 - kmax = i - CALL nlsm1(i, 1, nvb, eigr, cp, becp, 1, lgam) -! - DO k = 1, kmax - DO ig = 1, ngw - temp(ig) = CONJG(cp(ig, k))*cp(ig, i) - END DO - csc(k) = icoeff*SUM(temp)!modified:giovanni - IF (gstart == 2) csc(k) = csc(k) - (icoeff - CMPLX(1.d0, 0.d0))*(temp(1)) !modified:giovanni - END DO - - CALL mp_sum(csc(1:kmax), intra_image_comm) - - IF (lgam) THEN - DO k = 1, kmax - rsum = 0.d0 - DO is = 1, nvb - DO iv = 1, nh(is) - DO jv = 1, nh(is) - DO ia = 1, na(is) - inl = ish(is) + (iv - 1)*na(is) + ia - jnl = ish(is) + (jv - 1)*na(is) + ia - rsum = rsum + & - & qq(iv, jv, is)*becp%rvec(inl, i)*becp%rvec(jnl, k) - END DO - END DO - END DO - END DO - csc(k) = csc(k) + CMPLX(rsum, 0.d0) - END DO -! - WRITE (stdout, '("dotcsc =",12f18.15)') (DBLE(csc(k)), k=1, i) -! - ELSE - DO k = 1, kmax - csum = 0.d0 - DO is = 1, nvb - DO iv = 1, nh(is) - DO jv = 1, nh(is) - DO ia = 1, na(is) - inl = ish(is) + (iv - 1)*na(is) + ia - jnl = ish(is) + (jv - 1)*na(is) + ia - csum = csum + & - & qq(iv, jv, is)*CONJG(becp%cvec(inl, i))*becp%cvec(jnl, k) - END DO - END DO - END DO - END DO - csc(k) = csc(k) + csum - END DO -! - WRITE (stdout, '("dotcsc =",12((f18.15)2x(f18.15)))') (csc(k), k=1, i) -! - END IF - - END DO - WRITE (stdout, *) -! - call deallocate_twin(becp) -! - RETURN -END SUBROUTINE dotcsc - -!----------------------------------------------------------------------- -SUBROUTINE dotcsv(csv, nbspx, nbsp, c, bec, v, bev, ngw, ibnd1, ibnd2, lgam) -!----------------------------------------------------------------------- -! - USE kinds, ONLY: DP - USE ions_base, ONLY: na - USE reciprocal_vectors, ONLY: gstart - USE cvan, ONLY: ish, nvb - USE uspp, ONLY: qq - USE uspp_param, ONLY: nh - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE twin_types -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: ngw, nbsp, nbspx, ibnd1, ibnd2 - COMPLEX(DP) :: c(ngw, nbspx), v(ngw, nbspx) - COMPLEX(DP), INTENT(OUT) :: csv - type(twin_matrix) :: bec, bev - LOGICAL :: lgam - - ! local variables - COMPLEX(DP) temp(ngw) ! automatic array - - INTEGER ig, is, ia, iv, jv, inl, jnl - REAL(DP) :: icoeff - - IF (lgam) THEN - icoeff = 2.d0 - ELSE - icoeff = 1.d0 - END IF - -! write(6,*) ubound(c), lbound(c), ubound(v), lbound(v) -! -! < beta | c > is real. only the i lowest: -! - DO ig = 1, ngw - ! - temp(ig) = CONJG(c(ig, ibnd1))*v(ig, ibnd2) - ! - END DO - ! - csv = icoeff*(SUM(temp)) - IF (gstart == 2 .and. lgam) csv = csv - DBLE(temp(1)) - IF (lgam) csv = DBLE(csv) - - CALL mp_sum(csv, intra_image_comm) - - IF (lgam) THEN - DO is = 1, nvb - DO iv = 1, nh(is) - DO jv = 1, nh(is) - DO ia = 1, na(is) - inl = ish(is) + (iv - 1)*na(is) + ia - jnl = ish(is) + (jv - 1)*na(is) + ia - csv = csv + qq(iv, jv, is)*bec%rvec(inl, ibnd1)*bev%rvec(jnl, ibnd2) - END DO - END DO - END DO - END DO - ELSE - DO is = 1, nvb - DO iv = 1, nh(is) - DO jv = 1, nh(is) - DO ia = 1, na(is) - inl = ish(is) + (iv - 1)*na(is) + ia - jnl = ish(is) + (jv - 1)*na(is) + ia - csv = csv + qq(iv, jv, is)*(bec%cvec(inl, ibnd1))*CONJG(bev%cvec(jnl, ibnd2)) - END DO - END DO - END DO - END DO - END IF - ! - RETURN -END SUBROUTINE dotcsv -! - -!----------------------------------------------------------------------- -SUBROUTINE compute_manifold_overlap(cstart, c, becstart, bec, ngwx, n, sss) !added:giovanni -!----------------------------------------------------------------------- -! -! computes overlap between the manifold represented by cstart and that of c0 -! useful to check how far we are from the starting guess, during functional oprimization -! Might even provide a convergence criterion. -! - USE kinds, ONLY: DP - USE constants, ONLY: pi, fpi - USE gvecw, ONLY: ngw - USE mp, ONLY: mp_sum - USE control_flags, ONLY: gamma_only, do_wf_cmplx - USE electrons_base, ONLY: iupdwn, nupdwn, nspin, nudx, nbspx, nbsp - USE twin_types - - INTEGER, INTENT(IN) :: ngwx, n - COMPLEX(DP), INTENT(INOUT) :: cstart(ngwx, nbspx), c(ngwx, nbspx) - COMPLEX(DP), INTENT(OUT) :: sss(nspin) - TYPE(twin_matrix) :: becstart, bec - - COMPLEX(DP) :: ss(nudx, nudx, nspin) - LOGICAL :: lgam - INTEGER :: i, j, isp - - lgam = gamma_only .and. .not. do_wf_cmplx - !write(6,*) ubound(c), lbound(c), ubound(cstart), lbound(cstart) - ss = CMPLX(0.d0, 0.d0) - ! - DO isp = 1, nspin - ! - DO i = 1, nupdwn(isp) - ! - DO j = 1, nupdwn(isp) - ! - call dotcsv(ss(j, i, isp), nbspx, nbsp, cstart, becstart, c, bec, ngw, iupdwn(isp) + j - 1, iupdwn(isp) + i - 1, lgam) - ! - END DO - ! - END DO - ! - END DO - ! - DO isp = 1, nspin - ! - sss(isp) = 0. - ! - DO j = 1, nupdwn(isp) - ! - DO i = 1, nupdwn(isp) - ! - sss(isp) = sss(isp) + abs(ss(i, j, isp))**2 -! write(*,*) ss(i,j,isp)-CONJG(ss(j,i,isp)) - ! - END DO - ! - END DO - ! - ! renormalize by number of electrons of that spin - sss(isp) = sss(isp)/nupdwn(isp) - ! - END DO - ! -END SUBROUTINE compute_manifold_overlap - -!----------------------------------------------------------------------- -SUBROUTINE compute_overlap(c, ngwx, n, ss) !added:giovanni -!----------------------------------------------------------------------- -! -! computes overlap matrix for the non-orthogonal case -! -! - USE kinds, ONLY: DP - USE constants, ONLY: pi, fpi - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gstart - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE control_flags, ONLY: gamma_only, do_wf_cmplx - USE electrons_base, ONLY: iupdwn, nupdwn, nspin, nudx - - INTEGER, INTENT(IN) :: ngwx, n - COMPLEX(DP), INTENT(INOUT) :: c(ngwx, n) - COMPLEX(DP), INTENT(OUT) :: ss(nudx, nudx, nspin) - - LOGICAL :: lgam - INTEGER :: ig, i, j, isp - REAL(DP) :: icoeff - - lgam = gamma_only .and. .not. do_wf_cmplx - - IF (lgam) THEN - icoeff = 2.d0 - ELSE - icoeff = 1.d0 - END IF - - ss = CMPLX(0.d0, 0.d0) - ! - DO isp = 1, nspin - ! - DO i = 1, nupdwn(isp) - ! -! DO ig=1,ngw -! ! -! ss(i,i,isp)=ss(i,i,isp)+icoeff*DBLE(CONJG(c(ig,iupdwn(isp)+i-1))* & -! c(ig,iupdwn(isp)+i-1)) -! ! -! END DO -! ! -! IF(gstart==2) THEN -! ! -! ss(i,i,isp)=ss(i,i,isp)-(icoeff-1.d0)*DBLE(CONJG(c(1,iupdwn(isp)+i-1))* & -! c(1,iupdwn(isp)+i-1)) -! ! -! ENDIF - ! - DO j = 1, nupdwn(isp) - ! - DO ig = 1, ngw - ! - ss(j, i, isp) = ss(j, i, isp) + icoeff*CONJG(c(ig, iupdwn(isp) + j - 1))* & - c(ig, iupdwn(isp) + i - 1) - ! - END DO - ! - IF (gstart == 2) THEN - ss(j, i, isp) = ss(j, i, isp) - (icoeff - 1.d0)*CONJG(c(1, iupdwn(isp) + j - 1))* & - c(1, iupdwn(isp) + i - 1) - END IF - ! - !ss(i,j,isp) = CONJG(ss(j,i,isp)) - ! - END DO - ! - END DO - ! - ! - !DO i=1,nupdwn(isp) - ! c(:,iupdwn(isp)+i-1) = c(:,iupdwn(isp)+i-1)/sqrt(abs(ss(i,i,isp))) - ! DO j=1,i-1 - ! ss(j,i,isp) = ss(j,i,isp)/sqrt(abs(ss(i,i,isp))) - ! ss(i,j,isp) = CONJG(ss(j,i,isp)) - ! ENDDO - ! ss(i,i,isp)=CMPLX(1.d0,0.d0) - !ENDDO - END DO - ! - CALL mp_sum(ss(1:nudx, 1:nudx, 1:nspin), intra_image_comm) - if (lgam) THEN - ss(1:nudx, 1:nudx, 1:nspin) = DBLE(ss(1:nudx, 1:nudx, 1:nspin)) - END IF - ! -END SUBROUTINE compute_overlap - -!----------------------------------------------------------------------- -SUBROUTINE invert_overlap(ss, iss, iflag) !added:giovanni -!----------------------------------------------------------------------- -! -! contracs part of hamiltonian matrix with inverse overlap matrix -! -! - USE kinds, ONLY: DP - USE electrons_base, ONLY: nupdwn, nspin, nudx - USE io_global, ONLY: ionode - - COMPLEX(DP), INTENT(IN) :: ss(nudx, nudx, nspin) - COMPLEX(DP), INTENT(OUT) :: iss(nudx, nudx, nspin) - INTEGER, INTENT(IN) :: iflag - INTEGER, dimension(:), allocatable :: ipiv - COMPLEX, DIMENSION(:), allocatable :: work - - INTEGER :: isp, info, lwork - ! - lwork = nudx*nudx + 10 - allocate (ipiv(nudx)) - allocate (work(lwork)) - iss = CMPLX(0.d0, 0.d0) - iss(1:nudx, 1:nudx, 1:nspin) = ss(1:nudx, 1:nudx, 1:nspin) - do isp = 1, nspin - call zgetrf(nupdwn(isp), nupdwn(isp), iss(1, 1, isp), nudx, ipiv, info) - call zgetri(nupdwn(isp), iss(1, 1, isp), nudx, ipiv, work, lwork, info) - if (ionode) THEN - write (6, *) "inverted?", matmul(ss(1:nupdwn(isp), 1:nupdwn(isp), isp), & - iss(1:nupdwn(isp), 1:nupdwn(isp), isp)) - write (6, *) "overlap", ss(1:nupdwn(isp), 1:nupdwn(isp), isp) - write (6, *) "inverse_overlap", iss(1:nupdwn(isp), 1:nupdwn(isp), isp) - END IF - end do - ! - deallocate (ipiv) - deallocate (work) - ! -END SUBROUTINE invert_overlap - -!----------------------------------------------------------------------- -SUBROUTINE compute_duals(c, cd, n, iflag) !added:giovanni -!----------------------------------------------------------------------- -! -! contracs part of hamiltonian matrix with inverse overlap matrix -! -! - USE kinds, ONLY: DP - USE constants, ONLY: pi, fpi - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gstart - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE control_flags, ONLY: gamma_only, do_wf_cmplx - USE electrons_base, ONLY: iupdwn, nupdwn, nspin, nudx - - INTEGER, INTENT(IN) :: iflag, n - COMPLEX(DP) :: c(ngw, n) - COMPLEX(DP), INTENT(OUT) :: cd(ngw, n) - COMPLEX(DP) :: temp1, temp2 - COMPLEX(DP), allocatable :: ss(:, :, :), iss(:, :, :) - LOGICAL :: lgam - - INTEGER :: i, j, isp, cdindex - - lgam = gamma_only .and. .not. do_wf_cmplx - ! - allocate (ss(nudx, nudx, nspin), iss(nudx, nudx, nspin)) - ss = 0.d0 - iss = 0.d0 - ! - call compute_overlap(c, ngw, n, ss) - call invert_overlap(ss, iss, iflag) - ! - cd(1:ngw, 1:n) = CMPLX(0.d0, 0.d0) - ! - do isp = 1, nspin - do i = 1, nupdwn(isp) - cdindex = iupdwn(isp) + i - 1 - do j = 1, nupdwn(isp) - cd(1:ngw, cdindex) = cd(1:ngw, cdindex) + CONJG(iss(i, j, isp))*c(1:ngw, iupdwn(isp) + j - 1) - end do - end do - end do - ! - temp1 = 0.d0 - temp2 = 0.d0 - ! - do i = 1, ngw - temp1 = temp1 + 2.d0*CONJG(cd(i, 1))*c(i, 1) - temp2 = temp2 + 2.d0*CONJG(cd(i, 2))*c(i, 1) - end do - if (gstart == 2) THEN - temp1 = temp1 - CONJG(cd(1, 1))*c(1, 1) - temp2 = temp2 - CONJG(cd(1, 2))*c(1, 1) - END IF - call mp_sum(temp1, intra_image_comm) - call mp_sum(temp2, intra_image_comm) -! write(6,*) "checkdiag", temp1, temp2 - deallocate (ss, iss) -END SUBROUTINE compute_duals - -!----------------------------------------------------------------------- -SUBROUTINE times_overlap(c, cin, cd, n, iflag) !added:giovanni -!----------------------------------------------------------------------- -! -! contracs part of hamiltonian matrix with inverse overlap matrix -! -! - USE kinds, ONLY: DP - USE constants, ONLY: pi, fpi - USE gvecw, ONLY: ngw - USE mp, ONLY: mp_sum - USE control_flags, ONLY: gamma_only, do_wf_cmplx - USE electrons_base, ONLY: iupdwn, nupdwn, nspin, nudx - - INTEGER, INTENT(IN) :: iflag, n - COMPLEX(DP) :: c(ngw, n) - COMPLEX(DP), INTENT(IN) :: cin(ngw, n) - COMPLEX(DP), intent(OUT) :: cd(ngw, n) -! COMPLEX(DP) :: ss(nudx,nudx,nspin) - COMPLEX(DP), allocatable :: ss(:, :, :), iss(:, :, :) - LOGICAL :: lgam - - INTEGER :: i, j, isp, cdindex - - lgam = gamma_only .and. .not. do_wf_cmplx - ! - allocate (ss(nudx, nudx, nspin), iss(nudx, nudx, nspin)) - ss = 0.d0 - iss = 0.d0 - ! - call compute_overlap(c, ngw, n, ss) - IF (iflag .lt. 0) THEN - call invert_overlap(ss, iss, iflag) - ss = CONJG(iss) - END IF - ! - cd(1:ngw, 1:n) = CMPLX(0.d0, 0.d0) - ! - do isp = 1, nspin - do i = 1, nupdwn(isp) - cdindex = iupdwn(isp) + i - 1 - do j = 1, nupdwn(isp) - cd(1:ngw, cdindex) = cd(1:ngw, cdindex) + (ss(i, j, isp))*cin(1:ngw, iupdwn(isp) + j - 1) - end do - end do - end do - ! -! write(6,*) "checkdiag", temp1, temp2 - deallocate (ss, iss) -END SUBROUTINE times_overlap - -!----------------------------------------------------------------------- -FUNCTION enkin_non_ortho(c, cdual, ngwx, f, n) -!----------------------------------------------------------------------- - ! - ! calculation of kinetic energy term - ! - USE kinds, ONLY: DP - USE constants, ONLY: pi, fpi - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gstart - USE gvecw, ONLY: ggp - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE cell_base, ONLY: tpiba2 - USE control_flags, ONLY: gamma_only, do_wf_cmplx - - IMPLICIT NONE - - REAL(DP) :: enkin_non_ortho - - ! input - - INTEGER, INTENT(IN) :: ngwx, n - COMPLEX(DP), INTENT(IN) :: c(ngwx, n), cdual(ngwx, n) - REAL(DP), INTENT(IN) :: f(n) - ! - ! local - - INTEGER :: ig, i - REAL(DP) :: sk(n) ! automatic array - LOGICAL :: lgam !added:giovanni - REAL(DP) :: icoeff - - lgam = gamma_only .and. .not. do_wf_cmplx - - IF (lgam) THEN - icoeff = 1.d0 - ELSE - icoeff = 0.5d0 - END IF - ! - ! matrix kk should be a global object, to allocate at the beginning - ! - ! -#ifdef __DEBUG_NONORTHO - ! - ! compute the kinetic matrix kk, to contract with the - ! inverse overlap matrix - ! - kk = CMPLX(0.d0, 0.d0) - ! - DO isp = 1, nspin - ! - DO i = 1, nupdwn(isp) - DO j = 1, i - 1 - DO ig = gstart, ngw - kk(j, i, isp) = kk(j, i, isp) + CONJG(c(ig, iupdwn(isp) + j - 1))* & - c(ig, iupdwn(isp) + i - 1)*ggp(ig) - END DO - kk(i, j, isp) = CONJG(kk(j, i, isp)) - END DO - ! - DO ig = gstart, ngw - kk(i, i, isp) = kk(i, i, isp) + DBLE(CONJG(c(ig, iupdwn(isp) + i - 1))* & - c(ig, iupdwn(isp) + i - 1))*ggp(ig) - END DO - ! - END DO - ! - END DO - ! - CALL mp_sum(kk(1:nudx, 1:nudx, 1:nspin), intra_image_comm) - ! - kk = kk*icoeff - ! -#endif - ! - DO i = 1, n - sk(i) = 0.0d0 - DO ig = gstart, ngw - sk(i) = sk(i) + DBLE(CONJG(cdual(ig, i))*c(ig, i))*ggp(ig) - END DO - END DO - ! - CALL mp_sum(sk(1:n), intra_image_comm) - ! - enkin_non_ortho = 0.0d0 - DO i = 1, n - enkin_non_ortho = enkin_non_ortho + f(i)*sk(i) - END DO - ! - - ! ... reciprocal-space vectors are in units of alat/(2 pi) so a - ! ... multiplicative factor (2 pi/alat)**2 is required - - enkin_non_ortho = enkin_non_ortho*tpiba2*icoeff -! - RETURN -END FUNCTION enkin_non_ortho - -!----------------------------------------------------------------------- -FUNCTION enkin(c, ngwx, f, n) -!----------------------------------------------------------------------- - ! - ! calculation of kinetic energy term - ! - USE kinds, ONLY: DP - USE constants, ONLY: pi, fpi - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gstart - USE gvecw, ONLY: ggp - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE cell_base, ONLY: tpiba2 - USE control_flags, ONLY: gamma_only, do_wf_cmplx - - IMPLICIT NONE - - REAL(DP) :: enkin - - ! input - - INTEGER, INTENT(IN) :: ngwx, n - COMPLEX(DP), INTENT(IN) :: c(ngwx, n) - REAL(DP), INTENT(IN) :: f(n) - ! - ! local - - INTEGER :: ig, i - REAL(DP) :: sk(n) ! automatic array - LOGICAL :: lgam !added:giovanni - REAL(DP) :: icoeff - - lgam = gamma_only .and. .not. do_wf_cmplx - - IF (lgam) THEN - icoeff = 1.d0 - ELSE - icoeff = 0.5d0 - END IF - ! - ! matrix kk should be a global object, to allocate at the beginning - ! - ! - ! - DO i = 1, n - sk(i) = 0.0d0 - DO ig = gstart, ngw - sk(i) = sk(i) + DBLE(CONJG(c(ig, i))*c(ig, i))*ggp(ig) - END DO - END DO - ! - CALL mp_sum(sk(1:n), intra_image_comm) - ! - enkin = 0.0d0 - DO i = 1, n - enkin = enkin + f(i)*sk(i) - END DO - ! - ! ... reciprocal-space vectors are in units of alat/(2 pi) so a - ! ... multiplicative factor (2 pi/alat)**2 is required - - enkin = enkin*tpiba2*icoeff -! - RETURN -END FUNCTION enkin -! -!----------------------------------------------------------------------- -FUNCTION enkin_new(c, ngwx, f, n, nspin, nudx, iupdwn, nupdwn) -!----------------------------------------------------------------------- - ! - ! calculation of kinetic energy term - ! - USE kinds, ONLY: DP - USE constants, ONLY: pi, fpi - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gstart - USE gvecw, ONLY: ggp - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE cell_base, ONLY: tpiba2 - USE control_flags, ONLY: gamma_only, do_wf_cmplx -! USE electrons_base, ONLY: iupdwn, nupdwn, nspin, nudx - - IMPLICIT NONE - - REAL(DP) :: enkin_new - - ! input - - INTEGER, INTENT(IN) :: ngwx, n, nudx, nspin - INTEGER, INTENT(IN) :: iupdwn(nspin), nupdwn(nspin) - COMPLEX(DP), INTENT(IN) :: c(ngwx, n) - REAL(DP), INTENT(IN) :: f(n) - ! - ! local - - INTEGER :: ig, i - REAL(DP) :: sk(n) ! automatic array - LOGICAL :: lgam !added:giovanni - REAL(DP) :: icoeff - - lgam = gamma_only .and. .not. do_wf_cmplx - - IF (lgam) THEN - icoeff = 1.d0 - ELSE - icoeff = 0.5d0 - END IF - ! - ! matrix kk should be a global object, to allocate at the beginning - ! - ! - ! - DO i = 1, n - sk(i) = 0.0d0 - DO ig = gstart, ngw - sk(i) = sk(i) + DBLE(CONJG(c(ig, i))*c(ig, i))*ggp(ig) - END DO - END DO - ! - CALL mp_sum(sk(1:n), intra_image_comm) - ! - enkin_new = 0.0d0 - DO i = 1, n - enkin_new = enkin_new + f(i)*sk(i) - END DO - ! - ! ... reciprocal-space vectors are in units of alat/(2 pi) so a - ! ... multiplicative factor (2 pi/alat)**2 is required - - enkin_new = enkin_new*tpiba2*icoeff -! - RETURN -END FUNCTION enkin_new -! -!----------------------------------------------------------------------- -SUBROUTINE enkin_dens(c, ngwx, f) -!----------------------------------------------------------------------- - ! - ! calculation of kinetic energy term - ! - USE kinds, ONLY: DP - USE constants, ONLY: pi, fpi -! USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gx -! USE gvecw, ONLY: ggp - USE gvecp, only: ng => ngm - USE mp, ONLY: mp_sum - USE control_flags, ONLY: gamma_only, do_wf_cmplx -! USE electrons_base, ONLY: iupdwn, nupdwn, nspin, nudx - - IMPLICIT NONE - - ! input - - INTEGER, INTENT(IN) :: ngwx - COMPLEX(DP), INTENT(INOUT) :: c(ngwx) - REAL(DP), INTENT(IN) :: f - ! - ! local - - INTEGER :: ig -! COMPLEX(DP), allocatable :: sk(:) ! automatic array - LOGICAL :: lgam !added:giovanni - REAL(DP) :: icoeff - - lgam = gamma_only .and. .not. do_wf_cmplx - - IF (lgam) THEN - icoeff = 1.d0 - ELSE - icoeff = 0.5d0 - END IF - ! - ! matrix kk should be a global object, to allocate at the beginning - ! - ! -! allocate(sk(ngwx)) - ! - DO ig = 1, ng - ! - c(ig) = DBLE(CONJG(c(ig))*c(ig))*(gx(1, ig)**2 + gx(2, ig)**2 + gx(3, ig)**2) - ! - END DO - ! - RETURN -END SUBROUTINE enkin_dens -! -!----------------------------------------------------------------------- -SUBROUTINE gausin(eigr, cm) -!----------------------------------------------------------------------- -! -! initialize wavefunctions with gaussians - edit to fit your system -! - USE kinds, ONLY: DP - USE ions_base, ONLY: na, nat - USE electrons_base, ONLY: n => nbsp - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gx, g -! - IMPLICIT NONE -! - COMPLEX(DP) eigr(ngw, nat), cm(ngw, n) - REAL(DP) sigma, auxf - INTEGER nband, is, ia, ig, isa -! - sigma = 12.0d0 - nband = 0 -!!! do is=1,nsp - isa = 0 - is = 1 - DO ia = 1, na(is) -! s-like gaussians - nband = nband + 1 - DO ig = 1, ngw - auxf = EXP(-g(ig)/sigma**2) - cm(ig, nband) = auxf*eigr(ig, ia + isa) - END DO -! px-like gaussians - nband = nband + 1 - DO ig = 1, ngw - auxf = EXP(-g(ig)/sigma**2) - cm(ig, nband) = auxf*eigr(ig, ia + isa)*gx(1, ig) - END DO -! py-like gaussians - nband = nband + 1 - DO ig = 1, ngw - auxf = EXP(-g(ig)/sigma**2) - cm(ig, nband) = auxf*eigr(ig, ia + isa)*gx(2, ig) - END DO -! pz-like gaussians - nband = nband + 1 - DO ig = 1, ngw - auxf = EXP(-g(ig)/sigma**2) - cm(ig, nband) = auxf*eigr(ig, ia + isa)*gx(3, ig) - END DO - END DO - isa = isa + na(is) - is = 2 - DO ia = 1, na(is) -! s-like gaussians -! nband=nband+1 -! do ig=1,ngw -! auxf=exp(-g(ig)/sigma**2) -! cm(ig,nband)=auxf*eigr(ig,ia+isa) -! end do -! px-like gaussians -! nband=nband+1 -! do ig=1,ngw -! auxf=exp(-g(ig)/sigma**2) -! cm(ig,nband)=auxf*eigr(ig,ia+isa)*gx(1,ig) -! end do -! py-like gaussians -! nband=nband+1 -! do ig=1,ngw -! auxf=exp(-g(ig)/sigma**2) -! cm(ig,nband)=auxf*eigr(ig,ia+isa)*gx(2,ig) -! end do -! pz-like gaussians -! nband=nband+1 -! do ig=1,ngw -! auxf=exp(-g(ig)/sigma**2) -! cm(ig,nband)=auxf*eigr(ig,ia+isa)*gx(3,ig) -! end do -! dxy-like gaussians -! nband=nband+1 -! do ig=1,ngw -! auxf=exp(-g(ig)/sigma**2) -! cm(ig,nband)=auxf*eigr(ig,ia+isa)*gx(1,ig)*gx(2,ig) -! end do -! dxz-like gaussians -! nband=nband+1 -! do ig=1,ngw -! auxf=exp(-g(ig)/sigma**2) -! cm(ig,nband)=auxf*eigr(ig,ia+isa)*gx(1,ig)*gx(3,ig) -! end do -! dxy-like gaussians -! nband=nband+1 -! do ig=1,ngw -! auxf=exp(-g(ig)/sigma**2) -! cm(ig,nband)=auxf*eigr(ig,ia+isa)*gx(2,ig)*gx(3,ig) -! end do -! dx2-y2-like gaussians -! nband=nband+1 -! do ig=1,ngw -! auxf=exp(-g(ig)/sigma**2) -! cm(ig,nband)=auxf*eigr(ig,ia+isa)* & -! & (gx(1,ig)**2-gx(2,ig)**2) -! end do - END DO -!!! end do - RETURN -END SUBROUTINE gausin -! -!------------------------------------------------------------------------- -SUBROUTINE scalar_us(bec, nkbx, betae, cp, ngwx, i, csc, n, lgam) !added:giovanni SUBROUTINE scalar_us -!----------------------------------------------------------------------- -! requires in input the updated bec(k) for k, k - ! - kmax = i - 1 - ! -!$omp parallel default(shared), private( temp, k, ig ) - -!$omp do - IF (lgam) THEN - DO k = 1, kmax - csc(k) = CMPLX(0.0d0, 0.d0) - IF (ispin(i) .EQ. ispin(k)) THEN - DO ig = 1, ngw - temp(ig) = DBLE(CONJG(cp(ig, i))*cp(ig, k)) - END DO - csc(k) = CMPLX(2.d0*SUM(temp, ngw), 0.d0) - IF (gstart == 2) csc(k) = csc(k) - CMPLX(temp(1), 0.d0) - END IF - END DO - ELSE - !begin_added:giovanni - DO k = 1, kmax - csc(k) = CMPLX(0.0d0, 0.d0) - IF (ispin(i) .EQ. ispin(k)) THEN - DO ig = 1, ngw - temp_c(ig) = CONJG(cp(ig, k))*cp(ig, i) - END DO - csc(k) = SUM(temp_c, ngw) - END IF - END DO - !end_added:giovanni - END IF -!$omp end do - IF (lgam) THEN - DEALLOCATE (temp) - ELSE - DEALLOCATE (temp_c) - END IF -!$omp end parallel - - CALL mp_sum(csc(1:kmax), intra_image_comm) - IF (lgam) THEN - ALLOCATE (temp(ngw)) - ELSE - ALLOCATE (temp_c(ngw)) - END IF -! -! calculate csc(k)=, k csc(k) = -! - IF (.not. bec%iscmplx) THEN - DO k = 1, kmax - IF (ispin(i) .EQ. ispin(k)) THEN - rsum = 0.d0 - DO is = 1, nvb - DO iv = 1, nh(is) - DO jv = 1, nh(is) - IF (ABS(qq(iv, jv, is)) .GT. 1.e-5) THEN - DO ia = 1, na(is) - inl = ish(is) + (iv - 1)*na(is) + ia - jnl = ish(is) + (jv - 1)*na(is) + ia - rsum = rsum + qq(iv, jv, is)*bec%rvec(inl, i)*bec%rvec(jnl, k) - END DO - END IF - END DO - END DO - END DO - csc(k) = csc(k) + CMPLX(rsum, 0.d0) - END IF - END DO - ELSE - DO k = 1, kmax - IF (ispin(i) .EQ. ispin(k)) THEN - csum = CMPLX(0.d0, 0.d0) - DO is = 1, nvb - DO iv = 1, nh(is) - DO jv = 1, nh(is) - IF (ABS(qq(iv, jv, is)) .GT. 1.e-5) THEN -! write(6,*) "updating via qq" ! added - DO ia = 1, na(is) - inl = ish(is) + (iv - 1)*na(is) + ia - jnl = ish(is) + (jv - 1)*na(is) + ia - csum = csum + CMPLX(qq(iv, jv, is), 0.d0)*(bec%cvec(inl, i))*CONJG(bec%cvec(jnl, k)) - END DO - END IF - END DO - END DO - END DO - csc(k) = csc(k) + csum - END IF - END DO - END IF - - IF (lgam) THEN - DEALLOCATE (temp) - ELSE - DEALLOCATE (temp_c) !added:giovanni - END IF -! -! write(6,*) "bec", bec%rvec - RETURN -END SUBROUTINE scalar_us - -! -!------------------------------------------------------------------------- -SUBROUTINE scalar_character(cp, n, ngwx, csc, nunit, lgam) !added:giovanni SUBROUTINE scalar_character -!----------------------------------------------------------------------- -! requires in input the updated bec(k) for k) - kmax = n - rvector(:) = 2.d0*pi*a3(:)/20.d0*nunit - ! -!$omp parallel default(shared), private( temp, k, ig ) - -!$omp do - IF (lgam) THEN - DO i = 1, kmax - DO k = 1, kmax - csc(k, i) = CMPLX(0.0d0, 0.d0) - IF (ispin(i) .EQ. ispin(k)) THEN - DO ig = 1, ngw - phase = exp(CMPLX(0.d0, gx(1, ig)*rvector(1) + gx(2, ig)*rvector(2) + gx(3, ig)*rvector(3))) - temp(ig) = DBLE(CONJG(cp(ig, k))*phase*cp(ig, i)) - END DO - csc(k, i) = CMPLX(2.d0*SUM(temp, ngw), 0.d0) - IF (gstart == 2) csc(k, i) = csc(k, i) - CMPLX(temp(1), 0.d0) - END IF - END DO - END DO - ELSE - !begin_added:giovanni - DO i = 1, kmax - DO k = 1, kmax - csc(k, i) = CMPLX(0.0d0, 0.d0) - IF (ispin(i) .EQ. ispin(k)) THEN - DO ig = 1, ngw - phase = exp(CMPLX(0.d0, gx(1, ig)*rvector(1) + gx(2, ig)*rvector(2) + gx(3, ig)*rvector(3))) - temp_c(ig) = CONJG(cp(ig, k))*phase*cp(ig, i) - END DO - csc(k, i) = SUM(temp_c, ngw) - END IF - END DO - END DO - !end_added:giovanni - END IF -!$omp end do - IF (lgam) THEN - DEALLOCATE (temp) - ELSE - DEALLOCATE (temp_c) - END IF -!$omp end parallel - - CALL mp_sum(csc(1:kmax, 1:kmax), intra_image_comm) -! write(6,*) "bec", bec%rvec - RETURN -END SUBROUTINE scalar_character - -!------------------------------------------------------------------------- -SUBROUTINE gracsc(bec, nkbx, betae, cp, ngwx, i, csc, n, lgam) !added:giovanni lgam -!----------------------------------------------------------------------- -! requires in input the updated bec(k) for k nkbus, qq - USE uspp_param, ONLY: nh - USE electrons_base, ONLY: ispin - USE gvecw, ONLY: ngw - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE kinds, ONLY: DP - USE reciprocal_vectors, ONLY: gstart - USE twin_types !added:giovanni -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: i, nkbx, ngwx, n - COMPLEX(DP) :: betae(ngwx, nkb) - COMPLEX(DP) :: cp(ngwx, n) - type(twin_matrix) :: bec!( nkbx, n )!modified:giovanni - COMPLEX(DP) :: csc(n) !modified:giovanni - LOGICAL :: lgam !added:giovanni - INTEGER :: k, kmax, ig, is, iv, jv, ia, inl, jnl - REAL(DP) :: rsum - COMPLEX(DP) :: csum - REAL(DP), ALLOCATABLE :: temp(:) - COMPLEX(DP), ALLOCATABLE :: temp_c(:) !added:giovanni - -!!!begin_added:giovanni - IF (lgam) THEN - ALLOCATE (temp(ngw)) - temp = 0.d0 - ELSE - ALLOCATE (temp_c(ngw)) - temp_c = CMPLX(0.d0, 0.d0) - END IF -!!!end_added:giovanni - ! - ! calculate csc(k)=, k - ! - kmax = i - 1 - ! -!$omp parallel default(shared), private( temp, k, ig ) - -!$omp do - IF (lgam) THEN - DO k = 1, kmax - csc(k) = CMPLX(0.0d0, 0.d0) - IF (ispin(i) .EQ. ispin(k)) THEN - DO ig = 1, ngw - temp(ig) = DBLE(CONJG(cp(ig, i))*cp(ig, k)) - END DO - csc(k) = CMPLX(2.d0*SUM(temp, ngw), 0.d0) - IF (gstart == 2) csc(k) = csc(k) - CMPLX(temp(1), 0.d0) - END IF - END DO - ELSE - !begin_added:giovanni - DO k = 1, kmax - csc(k) = CMPLX(0.0d0, 0.d0) - IF (ispin(i) .EQ. ispin(k)) THEN - DO ig = 1, ngw - temp_c(ig) = CONJG(cp(ig, k))*cp(ig, i) - END DO - csc(k) = SUM(temp_c, ngw) - END IF - END DO - !end_added:giovanni - END IF -!$omp end do - IF (lgam) THEN - DEALLOCATE (temp) - ELSE - DEALLOCATE (temp_c) - END IF -!$omp end parallel - - CALL mp_sum(csc(1:kmax), intra_image_comm) - IF (lgam) THEN - ALLOCATE (temp(ngw)) - ELSE - ALLOCATE (temp_c(ngw)) - END IF - ! - ! calculate bec(i)= NO:giovanni--> - ! - IF (lgam) THEN - DO inl = 1, nhsavb - DO ig = 1, ngw - temp(ig) = DBLE(cp(ig, i)*CONJG(betae(ig, inl))) - END DO - bec%rvec(inl, i) = 2.d0*SUM(temp)!modified:giovanni - IF (gstart == 2) bec%rvec(inl, i) = bec%rvec(inl, i) - temp(1)!modified:giovanni - END DO - CALL mp_sum(bec%rvec(1:nhsavb, i), intra_image_comm) - ELSE -!begin_added:giovanni - DO inl = 1, nhsavb - DO ig = 1, ngw - temp_c(ig) = cp(ig, i)*CONJG(betae(ig, inl)) - END DO - IF (bec%iscmplx) then - bec%cvec(inl, i) = SUM(temp_c) - ELSE !added:giovanni:debug - bec%rvec(inl, i) = DBLE(SUM(temp_c)) - END IF - END DO - IF (bec%iscmplx) then - CALL mp_sum(bec%cvec(1:nhsavb, i), intra_image_comm) - ELSE - CALL mp_sum(bec%rvec(1:nhsavb, i), intra_image_comm) - END IF -!end_added:giovanni - END IF - -! -! calculate csc(k)=, k csc(k) = -! - IF (.not. bec%iscmplx) THEN - DO k = 1, kmax - IF (ispin(i) .EQ. ispin(k)) THEN - rsum = 0.d0 - DO is = 1, nvb - DO iv = 1, nh(is) - DO jv = 1, nh(is) - IF (ABS(qq(iv, jv, is)) .GT. 1.e-5) THEN - DO ia = 1, na(is) - inl = ish(is) + (iv - 1)*na(is) + ia - jnl = ish(is) + (jv - 1)*na(is) + ia - rsum = rsum + qq(iv, jv, is)*bec%rvec(inl, i)*bec%rvec(jnl, k) - END DO - END IF - END DO - END DO - END DO - csc(k) = csc(k) + CMPLX(rsum, 0.d0) - END IF - END DO - ELSE - DO k = 1, kmax - IF (ispin(i) .EQ. ispin(k)) THEN - csum = CMPLX(0.d0, 0.d0) - DO is = 1, nvb - DO iv = 1, nh(is) - DO jv = 1, nh(is) - IF (ABS(qq(iv, jv, is)) .GT. 1.e-5) THEN -! write(6,*) "updating via qq" ! added - DO ia = 1, na(is) - inl = ish(is) + (iv - 1)*na(is) + ia - jnl = ish(is) + (jv - 1)*na(is) + ia - csum = csum + CMPLX(qq(iv, jv, is), 0.d0)*(bec%cvec(inl, i))*CONJG(bec%cvec(jnl, k)) - END DO - END IF - END DO - END DO - END DO - csc(k) = csc(k) + csum - END IF - END DO - END IF -! -! orthogonalized cp(i) : |cp(i)>=|cp(i)>-\sum_k -! -! corresponing bec: bec(i)=-(csc(k))* -! - IF (.not. bec%iscmplx) THEN - DO k = 1, kmax - DO inl = 1, nkbx - bec%rvec(inl, i) = bec%rvec(inl, i) - DBLE(csc(k))*bec%rvec(inl, k) - END DO - END DO - ELSE -!begin_added:giovanni - DO k = 1, kmax - DO inl = 1, nkbx - bec%cvec(inl, i) = bec%cvec(inl, i) - (csc(k))*bec%cvec(inl, k) - END DO - END DO -! write(6,*) "output complex bec", bec%cvec -!end_added:giovanni - END IF - - IF (lgam) THEN - DEALLOCATE (temp) - ELSE - DEALLOCATE (temp_c) !added:giovanni - END IF -! -! write(6,*) "bec", bec%rvec - RETURN -END SUBROUTINE gracsc - -!------------------------------------------------------------------------- -SUBROUTINE gracsc2(bec, nkbx, betae, cp, ngwx, i, k, csc, n, lgam) !added:giovanni lgam -!----------------------------------------------------------------------- -! requires in input the updated bec(k) for k nkbus, qq - USE uspp_param, ONLY: nh - USE electrons_base, ONLY: ispin - USE gvecw, ONLY: ngw - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE kinds, ONLY: DP - USE reciprocal_vectors, ONLY: gstart - USE twin_types !added:giovanni -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: i, nkbx, ngwx, n, k - COMPLEX(DP) :: betae(ngwx, nkb) - COMPLEX(DP) :: cp(ngwx, n) - type(twin_matrix) :: bec!( nkbx, n )!modified:giovanni - COMPLEX(DP) :: csc(n) !modified:giovanni - LOGICAL :: lgam !added:giovanni - INTEGER :: ig, is, iv, jv, ia, inl, jnl - REAL(DP) :: rsum - COMPLEX(DP) :: csum - REAL(DP), ALLOCATABLE :: temp(:) - COMPLEX(DP), ALLOCATABLE :: temp_c(:) !added:giovanni - -!!!begin_added:giovanni - IF (lgam) THEN - ALLOCATE (temp(ngw)) - temp = 0.d0 - ELSE - ALLOCATE (temp_c(ngw)) - temp_c = CMPLX(0.d0, 0.d0) - END IF -!!!end_added:giovanni - ! - ! calculate csc(k)=, k - ! - IF (lgam) THEN - DO inl = 1, nhsavb - DO ig = 1, ngw - temp(ig) = DBLE(CONJG(cp(ig, i))*betae(ig, inl)) - END DO - bec%rvec(inl, i) = SUM(temp)!modified:giovanni - IF (gstart == 2) bec%rvec(inl, i) = bec%rvec(inl, i) - temp(1)!modified:giovanni - END DO - CALL mp_sum(bec%rvec(1:nhsavb, i), intra_image_comm) - ELSE -!begin_added:giovanni - DO inl = 1, nhsavb - DO ig = 1, ngw - temp_c(ig) = CONJG(cp(ig, i))*betae(ig, inl) -! cmplx(cp(1,ig,i)* DBLE(betae(ig,inl)) + & -! & cp(2,ig,i)*AIMAG(betae(ig,inl)), & -! & cp(1,ig,i)*AIMAG(betae(ig,inl))- & -! & cp(2,ig,i)*DBLE(betae(ig,inl)), DP) - END DO - IF (bec%iscmplx) then - bec%cvec(inl, i) = SUM(temp_c) - ELSE !added:giovanni:debug - bec%rvec(inl, i) = DBLE(SUM(temp_c)) - END IF - END DO - IF (bec%iscmplx) then - CALL mp_sum(bec%cvec(1:nhsavb, i), intra_image_comm) - ELSE - CALL mp_sum(bec%rvec(1:nhsavb, i), intra_image_comm) - END IF -!end_added:giovanni - END IF - -! -! calculate csc(k)=, k=|cp(i)>-\sum_k -! -! corresponing bec: bec(i)=-csc(k) -! - IF (.not. bec%iscmplx) THEN - DO inl = 1, nkbx - bec%rvec(inl, i) = bec%rvec(inl, i) - DBLE(csc(k))*bec%rvec(inl, k) - END DO - ELSE -!begin_added:giovanni - DO inl = 1, nkbx - bec%cvec(inl, i) = bec%cvec(inl, i) - CONJG(csc(k))*bec%cvec(inl, k) - END DO -!end_added:giovanni - END IF - - IF (lgam) THEN - DEALLOCATE (temp) - ELSE - DEALLOCATE (temp_c) !added:giovanni - END IF -! - RETURN -END SUBROUTINE gracsc2 - -!------------------------------------------------------------------------- -SUBROUTINE smooth_csv_real(c, v, ngwx, csv, n) -!----------------------------------------------------------------------- - - USE gvecw, ONLY: ngw - USE kinds, ONLY: DP - USE reciprocal_vectors, ONLY: gstart -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: ngwx, n - REAL(DP) :: c(2, ngwx) - REAL(DP) :: v(2, ngwx, n) - REAL(DP) :: csv(n) - INTEGER :: k, ig - REAL(DP), ALLOCATABLE :: temp(:) - - ! - ! calculate csv(k)= - ! - ALLOCATE (temp(ngw)) - - DO k = 1, n - DO ig = 1, ngw - temp(ig) = v(1, ig, k)*c(1, ig) + v(2, ig, k)*c(2, ig) - END DO - csv(k) = 2.0d0*SUM(temp) - IF (gstart == 2) csv(k) = csv(k) - temp(1) - END DO - - DEALLOCATE (temp) -! - RETURN -END SUBROUTINE smooth_csv_real - -!------------------------------------------------------------------------- -SUBROUTINE smooth_csv_twin(c, v, ngwx, csv, n) -!----------------------------------------------------------------------- - - USE gvecw, ONLY: ngw - USE kinds, ONLY: DP - USE reciprocal_vectors, ONLY: gstart - USE twin_types -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: ngwx, n - COMPLEX(DP) :: c(ngwx) - COMPLEX(DP) :: v(ngwx, n) - type(twin_matrix) :: csv !( n ) -! LOGICAL :: lgam - INTEGER :: k, ig - REAL(DP), ALLOCATABLE :: temp(:) - COMPLEX(DP), ALLOCATABLE :: temp_c(:) - ! - ! calculate csv(k)= - ! - IF (.not. csv%iscmplx) THEN - ALLOCATE (temp(ngw)) - ELSE - ALLOCATE (temp_c(ngw)) - END IF - - IF (.not. csv%iscmplx) THEN - DO k = 1, n - DO ig = 1, ngw - temp(ig) = DBLE(CONJG(v(ig, k))*c(ig)) - END DO - csv%rvec(k, 1) = 2.0d0*SUM(temp) - IF (gstart == 2) csv%rvec(k, 1) = csv%rvec(k, 1) - temp(1) - END DO - ELSE - DO k = 1, n - DO ig = 1, ngw - temp_c(ig) = CONJG(v(ig, k))*c(ig) - END DO - csv%cvec(k, 1) = SUM(temp_c) - END DO - END IF - - IF (.not. csv%iscmplx) THEN - DEALLOCATE (temp) - ELSE - DEALLOCATE (temp_c) - END IF -! - RETURN -END SUBROUTINE smooth_csv_twin - -!------------------------------------------------------------------------- -SUBROUTINE grabec_real(becc, nkbx, betae, c, ngwx) -!----------------------------------------------------------------------- - ! - ! on output: bec(i) is recalculated - ! - USE uspp, ONLY: nkb, nhsavb => nkbus - USE gvecw, ONLY: ngw - USE kinds, ONLY: DP - USE reciprocal_vectors, ONLY: gstart -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: nkbx, ngwx - COMPLEX(DP) :: betae(ngwx, nkb) - REAL(DP) :: becc(nkbx), c(2, ngwx) - INTEGER :: ig, inl - REAL(DP), ALLOCATABLE :: temp(:) - ! - ALLOCATE (temp(ngw)) - ! - ! calculate becc= - ! - DO inl = 1, nhsavb - DO ig = 1, ngw - temp(ig) = c(1, ig)*DBLE(betae(ig, inl)) + & - & c(2, ig)*AIMAG(betae(ig, inl)) - END DO - becc(inl) = 2.d0*SUM(temp) - IF (gstart == 2) becc(inl) = becc(inl) - temp(1) - END DO - - DEALLOCATE (temp) - - RETURN -END SUBROUTINE grabec_real - -!------------------------------------------------------------------------- -SUBROUTINE grabec_twin(becc, nkbx, betae, c, ngwx, l2_bec) -!----------------------------------------------------------------------- - ! - ! on output: bec(i) is recalculated - ! - USE uspp, ONLY: nkb, nhsavb => nkbus - USE gvecw, ONLY: ngw - USE kinds, ONLY: DP - USE reciprocal_vectors, ONLY: gstart - USE twin_types -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: nkbx, ngwx, l2_bec - COMPLEX(DP) :: betae(ngwx, nkb) - ! - COMPLEX(DP) :: c(1, ngwx) - type(twin_matrix) :: becc !( nkbx ), - INTEGER :: ig, inl - REAL(DP), ALLOCATABLE :: temp(:) - COMPLEX(DP), ALLOCATABLE :: temp_c(:) - ! - ! - ! calculate becc= - ! - IF (.not. becc%iscmplx) THEN - ALLOCATE (temp(ngw)) - DO inl = 1, nhsavb - DO ig = 1, ngw - temp(ig) = DBLE(CONJG(c(1, ig))*betae(ig, inl)) - END DO - becc%rvec(inl, l2_bec) = 2.d0*SUM(temp) - IF (gstart == 2) becc%rvec(inl, l2_bec) = becc%rvec(inl, l2_bec) - temp(1) - END DO - DEALLOCATE (temp) - ELSE - ALLOCATE (temp_c(ngw)) - DO inl = 1, nhsavb - DO ig = 1, ngw - temp_c(ig) = CONJG(c(1, ig))*betae(ig, inl) - END DO - becc%cvec(inl, l2_bec) = SUM(temp_c) - END DO - DEALLOCATE (temp_c) - END IF - - RETURN -END SUBROUTINE grabec_twin - -!------------------------------------------------------------------------- -SUBROUTINE bec_csv_real(becc, becv, nkbx, csv, n) -!----------------------------------------------------------------------- -! requires in input the updated becc and becv(k) -! on output: csv is updated -! - USE ions_base, ONLY: na - USE cvan, ONLY: nvb, ish - USE uspp, ONLY: qq - USE uspp_param, ONLY: nh - USE kinds, ONLY: DP -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: nkbx, n - REAL(DP) :: becc(nkbx) - REAL(DP) :: becv(nkbx, n) - REAL(DP) :: csv(n) - INTEGER :: k, is, iv, jv, ia, inl, jnl - REAL(DP) :: rsum - -! calculate csv(k) = csv(k) + , k, k gstart - use mp, only: mp_sum - use electrons_base, only: n => nbsp, nspin, nupdwn, iupdwn - - implicit none - - complex(dp) a(ngw, n), b(ngw, n) - integer i, j, ig, isp, ndim, nbnd1, nbnd2 - real(dp) sca - real(DP), allocatable :: s(:, :) - ! - - s(:, :) = 0.d0 - - do isp = 1, nspin - - ndim = nupdwn(isp) - - allocate (s(ndim, ndim)) - - s(:, :) = 0.d0 - - do i = 1, ndim - nbnd1 = iupdwn(isp) - 1 + i - if (ng0 .eq. 2) a(1, nbnd1) = CMPLX(DBLE(a(1, nbnd1)), 0.0d0) - if (ng0 .eq. 2) b(1, nbnd1) = CMPLX(DBLE(b(1, nbnd1)), 0.0d0) - end do - - do i = 1, ndim - nbnd1 = iupdwn(isp) - 1 + i - do j = 1, ndim - nbnd2 = iupdwn(isp) - 1 + j - sca = 0.0d0 - do ig = 1, ngw !loop on g vectors - sca = sca + DBLE(CONJG(a(ig, nbnd1))*b(ig, nbnd2)) - end do - sca = sca*2.0d0 !2. for real weavefunctions - if (ng0 .eq. 2) sca = sca - DBLE(a(1, nbnd1))*DBLE(b(1, nbnd2)) - s(i, j) = sca - end do - end do - call mp_sum(s, intra_image_comm) - - do i = 1, ndim - do j = 1, ndim - s(i, j) = s(i, j)*s(i, j) - end do - end do - - if (ionode) then - write (1235, *) 'spin ', isp, ', sum ', sum(s(:, :))/ndim - do i = 1, ndim - write (1235, '(40f5.2)') (s(i, j), j=1, ndim) - end do - write (1235, *) - end if - - deallocate (s) - - end do - -END SUBROUTINE calc_wfnoverlap -!$$ - -!------------------------------------------------------------------------- -SUBROUTINE gram(betae, bec, nkbx, cp, ngwx, n) -!----------------------------------------------------------------------- -! gram-schmidt orthogonalization of the set of wavefunctions cp -! - USE uspp, ONLY: nkb - USE gvecw, ONLY: ngw - USE kinds, ONLY: DP - USE control_flags, ONLY: gamma_only, do_wf_cmplx !added:giovanni - USE twin_types !added:giovanni -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: nkbx, ngwx, n - type(twin_matrix) :: bec!( nkbx, n )!modified:giovanni - COMPLEX(DP) :: cp(ngwx, n), betae(ngwx, nkb) -! - REAL(DP) :: anorm, cscnorm - COMPLEX(DP), ALLOCATABLE :: csc(:) !modified:giovanni - INTEGER :: i, k - LOGICAL :: lgam !added:giovanni - EXTERNAL cscnorm - ! - lgam = gamma_only .and. .not. do_wf_cmplx !added:giovanni - ! - CALL start_clock('gram') -! write(6,*) bec%rvec !added:giovanni:debug -! stop - ALLOCATE (csc(n)) - ! - csc = CMPLX(0.d0, 0.d0) - ! - DO i = 1, n - ! - CALL gracsc(bec, nkbx, betae, cp, ngwx, i, csc, n, lgam)!added:giovanni lgam - ! - ! calculate orthogonalized cp(i) : |cp(i)>=|cp(i)>-\sum_k - ! - DO k = 1, i - 1 - CALL ZAXPY(ngw, -csc(k), cp(1, k), 1, cp(1, i), 1)!modified:giovanni - END DO - anorm = cscnorm(bec, nkbx, cp, ngwx, i, n, lgam) - CALL ZSCAL(ngw, CMPLX(1.0d0/anorm, 0.d0), cp(1, i), 1) - ! - ! these are the final bec's - ! - IF (nkbx > 0) THEN - IF (.not. bec%iscmplx) THEN - CALL DSCAL(nkbx, 1.0d0/anorm, bec%rvec(1:nkbx, i), 1)!modified:giovanni - ELSE - CALL ZSCAL(nkbx, CMPLX(1.0d0/anorm, 0.d0), bec%cvec(1:nkbx, i), 1)!added:giovanni - END IF - END IF - ! - END DO - ! -! write(6,*) "csc_giovanni_debug", csc !added:giovanni:debug - DEALLOCATE (csc) - - CALL stop_clock('gram') -! - RETURN -END SUBROUTINE gram -! -!------------------------------------------------------------------------- -SUBROUTINE gram2(betae, bec, nkbx, cp, ngwx, n) -!----------------------------------------------------------------------- -! gram-schmidt orthogonalization of the set of wavefunctions cp -! - USE uspp, ONLY: nkb - USE gvecw, ONLY: ngw - USE kinds, ONLY: DP - USE control_flags, ONLY: gamma_only, do_wf_cmplx !added:giovanni - USE twin_types !added:giovanni -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: nkbx, ngwx, n - type(twin_matrix) :: bec!( nkbx, n )!modified:giovanni - COMPLEX(DP) :: cp(ngwx, n), betae(ngwx, nkb) -! - REAL(DP) :: anorm, cscnorm - COMPLEX(DP), ALLOCATABLE :: csc(:) !modified:giovanni - INTEGER :: i, k - LOGICAL :: lgam !added:giovanni - EXTERNAL cscnorm - - lgam = gamma_only .and. .not. do_wf_cmplx !added:giovanni - -! - CALL start_clock('gram') - - ALLOCATE (csc(n)) - csc = CMPLX(0.d0, 0.d0) -! - DO i = 1, n - DO k = 1, i - 1 - ! - CALL gracsc2(bec, nkbx, betae, cp, ngwx, i, k, csc, n, lgam)!added:giovanni lgam - anorm = cscnorm(bec, nkbx, cp, ngwx, k, n, lgam) - ! - ! calculate orthogonalized cp(i) : |cp(i)>=|cp(i)>-\sum_k - ! - CALL ZAXPY(ngw, -csc(k)*CMPLX(1/anorm, 0.d0), cp(1, k), 1, cp(1, i), 1)!modified:giovanni - END DO - anorm = cscnorm(bec, nkbx, cp, ngwx, i, n, lgam) - CALL ZSCAL(ngw, CMPLX(1.0d0/anorm, 0.d0), cp(1, i), 1) - ! - - ! - ! these are the final bec's - ! - IF (nkbx > 0) THEN - IF (.not. bec%iscmplx) THEN - CALL DSCAL(nkbx, 1.0d0/anorm, bec%rvec(1:nkbx, i), 1)!modified:giovanni - ELSE - CALL ZSCAL(nkbx, CMPLX(1.0d0/anorm, 0.d0), bec%cvec(1:nkbx, i), 1)!added:giovanni - END IF - END IF - - END DO -! - Do i = 1, n - DO k = 1, i - write (6, *) dot_product(conjg(cp(:, i)), cp(:, k)) - END DO - END DO - DEALLOCATE (csc) - - CALL stop_clock('gram') -! - RETURN -END SUBROUTINE gram2 - -!----------------------------------------------------------------------- -SUBROUTINE initbox(tau0, taub, irb, ainv, a1, a2, a3) -!----------------------------------------------------------------------- -! -! sets the indexes irb and positions taub for the small boxes -! around atoms -! - USE kinds, ONLY: DP - USE ions_base, ONLY: nsp, na, nat - USE grid_dimensions, ONLY: nr1, nr2, nr3 - USE smallbox_grid_dimensions, ONLY: nr1b, nr2b, nr3b, nr1bx, nr2bx, nr3bx - USE control_flags, ONLY: iprsta - USE io_global, ONLY: stdout - USE mp_global, ONLY: nproc_image, me_image - USE fft_base, ONLY: dfftb, dfftp, fft_dlay_descriptor - USE fft_types, ONLY: fft_box_set - - IMPLICIT NONE -! input - REAL(DP), INTENT(in) :: tau0(3, nat) -! output - INTEGER, INTENT(out) :: irb(3, nat) - REAL(DP), INTENT(out) :: taub(3, nat) -! input - REAL(DP), INTENT(in) :: ainv(3, 3) - REAL(DP), INTENT(in) :: a1(3) - REAL(DP), INTENT(in) :: a2(3) - REAL(DP), INTENT(in) :: a3(3) -! local - REAL(DP) :: x(3), xmod - INTEGER :: nr(3), nrb(3), xint, is, ia, i, isa -! - IF (nr1b < 1) CALL errore & - ('initbox', 'incorrect value for box grid dimensions', 1) - IF (nr2b < 1) CALL errore & - ('initbox', 'incorrect value for box grid dimensions', 2) - IF (nr3b < 1) CALL errore & - ('initbox', 'incorrect value for box grid dimensions', 3) - - nr(1) = nr1 - nr(2) = nr2 - nr(3) = nr3 - nrb(1) = nr1b - nrb(2) = nr2b - nrb(3) = nr3b -! - isa = 0 - DO is = 1, nsp - DO ia = 1, na(is) - isa = isa + 1 -! - DO i = 1, 3 -! -! bring atomic positions to crystal axis -! - x(i) = ainv(i, 1)*tau0(1, isa) + & - & ainv(i, 2)*tau0(2, isa) + & - & ainv(i, 3)*tau0(3, isa) -! -! bring x in the range between 0 and 1 -! - x(i) = MOD(x(i), 1.d0) - IF (x(i) .LT. 0.d0) x(i) = x(i) + 1.d0 -! -! case of nrb(i) even -! - IF (MOD(nrb(i), 2) .EQ. 0) THEN -! -! find irb = index of the grid point at the corner of the small box -! (the indices of the small box run from irb to irb+nrb-1) -! - xint = INT(x(i)*nr(i)) - irb(i, isa) = xint + 1 - nrb(i)/2 + 1 - IF (irb(i, isa) .LT. 1) irb(i, isa) = irb(i, isa) + nr(i) -! -! x(i) are the atomic positions in crystal coordinates, where the -! "crystal lattice" is the small box lattice and the origin is at -! the corner of the small box. Used to calculate phases exp(iG*taub) -! - xmod = x(i)*nr(i) - xint - x(i) = (xmod + nrb(i)/2 - 1)/nr(i) - ELSE -! -! case of nrb(i) odd - see above for comments -! - xint = NINT(x(i)*nr(i)) - irb(i, isa) = xint + 1 - (nrb(i) - 1)/2 - IF (irb(i, isa) .LT. 1) irb(i, isa) = irb(i, isa) + nr(i) - xmod = x(i)*nr(i) - xint - x(i) = (xmod + (nrb(i) - 1)/2)/nr(i) - END IF - END DO -! -! bring back taub in cartesian coordinates -! - DO i = 1, 3 - taub(i, isa) = x(1)*a1(i) + x(2)*a2(i) + x(3)*a3(i) - END DO - END DO - END DO - - CALL fft_box_set(dfftb, nr1b, nr2b, nr3b, nr1bx, nr2bx, nr3bx, & - nat, irb, me_image + 1, nproc_image, dfftp%npp, dfftp%ipp) - - IF (iprsta > 2) THEN - isa = 1 - DO is = 1, nsp - WRITE (stdout, '( /, 2x, "species= ", i2 )') is - DO ia = 1, na(is) - WRITE (stdout, 2000) ia, (irb(i, isa), i=1, 3) -2000 FORMAT(2x, 'atom= ', i3, ' irb1= ', i3, ' irb2= ', i3, ' irb3= ', i3) - isa = isa + 1 - END DO - END DO - END IF - -#ifdef __PARA - ! - ! for processor that do not call fft on the box - ! artificially start the clock - ! - CALL start_clock('fftb') - CALL stop_clock('fftb') - ! -#endif -! - RETURN -END SUBROUTINE initbox -! -!------------------------------------------------------------------------- -SUBROUTINE newd(vr, irb, eigrb, rhovan, fion) -!----------------------------------------------------------------------- -! -! this routine calculates array deeq: -! deeq_i,lm = \int V_eff(r) q_i,lm(r) dr -! and the corresponding term in forces -! fion_i = \int V_eff(r) \sum_lm rho_lm (dq_i,lm(r)/dR_i) dr -! where -! rho_lm = \sum_j f_j -! - USE kinds, ONLY: dp - USE uspp_param, ONLY: nh, nhm - USE uspp, ONLY: deeq - USE cvan, ONLY: nvb - USE ions_base, ONLY: nat, na - USE constants, ONLY: pi, fpi - USE grid_dimensions, ONLY: nnr => nnrx - USE gvecb, ONLY: ngb, npb, nmb, gxb - USE small_box, ONLY: omegab, tpibab - USE smallbox_grid_dimensions, ONLY: nr1b, nr2b, nr3b, & - nnrb => nnrbx - USE qgb_mod, ONLY: qgb - USE electrons_base, ONLY: nspin - USE control_flags, ONLY: thdyn, tfor, tprnfor - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE cp_interfaces, ONLY: invfft - USE fft_base, ONLY: dfftb - USE control_flags, ONLY: gamma_only, do_wf_cmplx !added:giovanni -! - IMPLICIT NONE -! input - INTEGER irb(3, nat) - REAL(DP) rhovan(nhm*(nhm + 1)/2, nat, nspin) - COMPLEX(DP) eigrb(ngb, nat) - REAL(DP) vr(nnr, nspin) -! output - REAL(DP) fion(3, nat) -! local - INTEGER isup, isdw, iss, iv, ijv, jv, ik, nfft, isa, ia, is, ig - REAL(DP) fvan(3, nat, nvb), fac, fac1, fac2, boxdotgrid - COMPLEX(DP) ci, facg1, facg2 - COMPLEX(DP), ALLOCATABLE :: qv(:) - LOGICAL :: lgam !added:giovanni - INTEGER :: istep !added:giovanni - EXTERNAL boxdotgrid -! - CALL start_clock('newd') - lgam = gamma_only .and. .not. do_wf_cmplx - ci = (0.d0, 1.d0) - fac = omegab/DBLE(nr1b*nr2b*nr3b) - deeq(:, :, :, :) = 0.d0 - fvan(:, :, :) = 0.d0 - - ALLOCATE (qv(nnrb)) - IF (lgam) THEN - istep = 2 - ELSE - istep = 2 - END IF -! -! calculation of deeq_i,lm = \int V_eff(r) q_i,lm(r) dr -! - isa = 1 - DO is = 1, nvb -#ifdef __PARA - nfft = 1 -#else - nfft = istep -#endif - DO ia = 1, na(is), nfft - nfft = 1 -#ifdef __PARA - IF (dfftb%np3(isa) <= 0) go to 15 -#endif - IF (ia .EQ. na(is)) nfft = 1 -! -! two ffts at the same time, on two atoms (if possible: nfft=2) -! - DO iv = 1, nh(is) - DO jv = iv, nh(is) - ijv = (jv - 1)*jv/2 + iv - qv(:) = (0.d0, 0.d0) - IF (nfft .EQ. 2) THEN - DO ig = 1, ngb - qv(npb(ig)) = eigrb(ig, isa)*qgb(ig, ijv, is) & - & + ci*eigrb(ig, isa + 1)*qgb(ig, ijv, is) - qv(nmb(ig)) = CONJG( & - & eigrb(ig, isa)*qgb(ig, ijv, is)) & - & + ci*CONJG( & - & eigrb(ig, isa + 1)*qgb(ig, ijv, is)) - END DO - ELSE -! IF(lgam) THEN - DO ig = 1, ngb - qv(npb(ig)) = eigrb(ig, isa)*qgb(ig, ijv, is) - qv(nmb(ig)) = CONJG( & - & eigrb(ig, isa)*qgb(ig, ijv, is)) - END DO -! ELSE -! DO ig=1,ngb -! qv(npb(ig)) = eigrb(ig,isa)*qgb(ig,ijv,is) -! qv(nmb(ig)) = CONJG( & -! & eigrb(ig,isa)*qgb(ig,ijv,is)) -! END DO -! ENDIF - END IF -! - CALL invfft('Box', qv, dfftb, isa) -! - DO iss = 1, nspin - deeq(iv, jv, isa, iss) = fac* & - & boxdotgrid(irb(1, isa), 1, qv, vr(1, iss)) - IF (iv .NE. jv) & - & deeq(jv, iv, isa, iss) = deeq(iv, jv, isa, iss) -! - IF (nfft .EQ. 2) THEN - deeq(iv, jv, isa + 1, iss) = fac* & - & boxdotgrid(irb(1, isa + 1), 2, qv, vr(1, iss)) - IF (iv .NE. jv) & - & deeq(jv, iv, isa + 1, iss) = deeq(iv, jv, isa + 1, iss) - END IF - END DO - END DO - END DO -15 isa = isa + nfft - END DO - END DO - - CALL mp_sum(deeq, intra_image_comm) - - IF (.NOT. (tfor .OR. thdyn .OR. tprnfor)) go to 10 -! -! calculation of fion_i = \int V_eff(r) \sum_lm rho_lm (dq_i,lm(r)/dR_i) dr -! - isa = 1 - IF (nspin .EQ. 1) THEN -! ================================================================= -! case nspin=1: two ffts at the same time, on two atoms (if possible) -! ----------------------------------------------------------------- - iss = 1 - isa = 1 - DO is = 1, nvb -#ifdef __PARA - nfft = 1 -#else - nfft = istep -#endif - DO ia = 1, na(is), istep - nfft = 1 -#ifdef __PARA - IF (dfftb%np3(isa) <= 0) go to 20 -#endif - IF (ia .EQ. na(is)) nfft = 1 - DO ik = 1, 3 - qv(:) = (0.d0, 0.d0) - DO iv = 1, nh(is) - DO jv = iv, nh(is) - ijv = (jv - 1)*jv/2 + iv - IF (iv .NE. jv) THEN - fac1 = 2.d0*fac*tpibab*rhovan(ijv, isa, iss) - IF (nfft .EQ. 2) fac2 = 2.d0*fac*tpibab* & - & rhovan(ijv, isa + 1, iss) - ELSE - fac1 = fac*tpibab*rhovan(ijv, isa, iss) - IF (nfft .EQ. 2) fac2 = fac*tpibab* & - & rhovan(ijv, isa + 1, iss) - END IF - IF (nfft .EQ. 2) THEN - DO ig = 1, ngb - facg1 = CMPLX(0.d0, -gxb(ik, ig))* & - & qgb(ig, ijv, is)*fac1 - facg2 = CMPLX(0.d0, -gxb(ik, ig))* & - & qgb(ig, ijv, is)*fac2 - qv(npb(ig)) = qv(npb(ig)) & - & + eigrb(ig, isa)*facg1 & - & + ci*eigrb(ig, isa + 1)*facg2 - qv(nmb(ig)) = qv(nmb(ig)) & - & + CONJG(eigrb(ig, isa)*facg1)& - & + ci*CONJG(eigrb(ig, isa + 1)*facg2) - END DO - ELSE -! IF(lgam) THEN - DO ig = 1, ngb - facg1 = CMPLX(0.d0, -gxb(ik, ig))* & - & qgb(ig, ijv, is)*fac1 - qv(npb(ig)) = qv(npb(ig)) & - & + eigrb(ig, isa)*facg1 - qv(nmb(ig)) = qv(nmb(ig)) & - & + CONJG(eigrb(ig, isa)*facg1) - END DO -! ELSE -! facg1 = CMPLX(0.d0,-gxb(ik,ig)) * & -! & qgb(ig,ijv,is)*fac1 -! qv(npb(ig)) = qv(npb(ig)) & -! & + eigrb(ig,isa)*facg1 -! qv(nmb(ig)) = qv(nmb(ig)) & -! & + CONJG( eigrb(ig,isa)*facg1) -! ENDIF - END IF - END DO - END DO -! - CALL invfft('Box', qv, dfftb, isa) -! - fvan(ik, ia, is) = & - & boxdotgrid(irb(1, isa), 1, qv, vr(1, iss)) -! - IF (nfft .EQ. 2) fvan(ik, ia + 1, is) = & - & boxdotgrid(irb(1, isa + 1), 2, qv, vr(1, iss)) - END DO -20 isa = isa + nfft - END DO - END DO - ELSE -! ================================================================= -! case nspin=2: up and down spin fft's combined into a single fft -! ----------------------------------------------------------------- - isup = 1 - isdw = 2 - isa = 1 - DO is = 1, nvb - DO ia = 1, na(is) -#ifdef __PARA - IF (dfftb%np3(isa) <= 0) go to 25 -#endif - DO ik = 1, 3 - qv(:) = (0.d0, 0.d0) -! - DO iv = 1, nh(is) - DO jv = iv, nh(is) - ijv = (jv - 1)*jv/2 + iv - IF (iv .NE. jv) THEN - fac1 = 2.d0*fac*tpibab*rhovan(ijv, isa, isup) - fac2 = 2.d0*fac*tpibab*rhovan(ijv, isa, isdw) - ELSE - fac1 = fac*tpibab*rhovan(ijv, isa, isup) - fac2 = fac*tpibab*rhovan(ijv, isa, isdw) - END IF -! IF(lgam) THEN - DO ig = 1, ngb - facg1 = fac1*CMPLX(0.d0, -gxb(ik, ig))* & - & qgb(ig, ijv, is)*eigrb(ig, isa) - facg2 = fac2*CMPLX(0.d0, -gxb(ik, ig))* & - & qgb(ig, ijv, is)*eigrb(ig, isa) - qv(npb(ig)) = qv(npb(ig)) & - & + facg1 + ci*facg2 - qv(nmb(ig)) = qv(nmb(ig)) & - & + CONJG(facg1) + ci*CONJG(facg2) - END DO -! ELSE -! DO ig=1,ngb -! facg1 = fac1 * CMPLX(0.d0,-gxb(ik,ig)) * & -! & qgb(ig,ijv,is) * eigrb(ig,isa) -! facg2 = fac2 * CMPLX(0.d0,-gxb(ik,ig)) * & -! & qgb(ig,ijv,is) * eigrb(ig,isa) -! qv(npb(ig)) = qv(npb(ig)) & -! & + facg1 + ci*facg2 -! qv(nmb(ig)) = qv(nmb(ig)) & -! & +CONJG(facg1)+ci*CONJG(facg2) -! END DO -! ENDIF - END DO - END DO -! - CALL invfft('Box', qv, dfftb, isa) -! - fvan(ik, ia, is) = & - & boxdotgrid(irb(1, isa), isup, qv, vr(1, isup)) + & - & boxdotgrid(irb(1, isa), isdw, qv, vr(1, isdw)) - END DO -25 isa = isa + 1 - END DO - END DO - END IF - - CALL mp_sum(fvan, intra_image_comm) - - isa = 0 - DO is = 1, nvb - DO ia = 1, na(is) - isa = isa + 1 - fion(:, isa) = fion(:, isa) - fvan(:, ia, is) - END DO - END DO - -10 CONTINUE - DEALLOCATE (qv) -! - CALL stop_clock('newd') -! - RETURN -END SUBROUTINE newd - -!------------------------------------------------------------------------- -SUBROUTINE nlfl_real(bec, becdr, lambda, fion) -!----------------------------------------------------------------------- -! contribution to fion due to the orthonormality constraint -! -! - - USE kinds, ONLY: DP - USE ions_base, ONLY: na, nat - USE uspp, ONLY: nhsa => nkb, qq - USE uspp_param, ONLY: nhm, nh - USE cvan, ONLY: ish, nvb - USE electrons_base, ONLY: nbsp, nspin, iupdwn, nupdwn - USE constants, ONLY: pi, fpi - USE cp_main_variables, ONLY: nlam, nlax, descla, la_proc - USE descriptors, ONLY: nlar_, nlac_, ilar_, ilac_ - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm -! - IMPLICIT NONE - REAL(DP) bec(nhsa, nbsp), becdr(nhsa, nspin*nlax, 3), lambda(nlam, nlam, nspin) - REAL(DP) fion(3, nat) -! - INTEGER :: k, is, ia, iv, jv, i, j, inl, isa, iss, nss, istart, ir, ic, nr, nc - REAL(DP), ALLOCATABLE :: temp(:, :), tmpbec(:, :), tmpdr(:, :) - REAL(DP), ALLOCATABLE :: fion_tmp(:, :) - ! - CALL start_clock('nlfl') - ! - ALLOCATE (fion_tmp(3, nat)) - ! - fion_tmp = 0.0d0 - ! - - ALLOCATE (temp(nlax, nlax), tmpbec(nhm, nlax), tmpdr(nlax, nhm)) - - DO k = 1, 3 - isa = 0 - DO is = 1, nvb - DO ia = 1, na(is) - isa = isa + 1 - ! - DO iss = 1, nspin - ! - nss = nupdwn(iss) - istart = iupdwn(iss) - ! - tmpbec = 0.d0 - tmpdr = 0.d0 -! - IF (la_proc) THEN - ! tmpbec distributed by columns - ic = descla(ilac_, iss) - nc = descla(nlac_, iss) - DO iv = 1, nh(is) - DO jv = 1, nh(is) - inl = ish(is) + (jv - 1)*na(is) + ia - IF (ABS(qq(iv, jv, is)) .GT. 1.e-5) THEN - DO i = 1, nc - tmpbec(iv, i) = tmpbec(iv, i) + qq(iv, jv, is)*bec(inl, i + istart - 1 + ic - 1) - END DO - END IF - END DO - END DO - ! tmpdr distributed by rows - ir = descla(ilar_, iss) - nr = descla(nlar_, iss) - DO iv = 1, nh(is) - inl = ish(is) + (iv - 1)*na(is) + ia - DO i = 1, nr - tmpdr(i, iv) = becdr(inl, i + (iss - 1)*nlax, k) - END DO - END DO - END IF -! - IF (nh(is) .GT. 0) THEN - ! - IF (la_proc) THEN - ir = descla(ilar_, iss) - ic = descla(ilac_, iss) - nr = descla(nlar_, iss) - nc = descla(nlac_, iss) - CALL DGEMM('N', 'N', nr, nc, nh(is), 1.0d0, tmpdr, nlax, tmpbec, nhm, 0.0d0, temp, nlax) - DO j = 1, nc - DO i = 1, nr - fion_tmp(k, isa) = fion_tmp(k, isa) + 2D0*temp(i, j)*lambda(i, j, iss) - END DO - END DO - END IF -! - END IF - - END DO -! - END DO - END DO - END DO - ! - DEALLOCATE (temp, tmpbec, tmpdr) - ! - CALL mp_sum(fion_tmp, intra_image_comm) - ! - fion = fion + fion_tmp - ! - DEALLOCATE (fion_tmp) - ! - CALL stop_clock('nlfl') - ! - RETURN - -END SUBROUTINE nlfl_real - -!------------------------------------------------------------------------- -SUBROUTINE nlfl_cmplx(bec, becdr, lambda, fion) -!----------------------------------------------------------------------- -! contribution to fion due to the orthonormality constraint -! -! - - USE kinds, ONLY: DP - USE ions_base, ONLY: na, nat - USE uspp, ONLY: nhsa => nkb, qq - USE uspp_param, ONLY: nhm, nh - USE cvan, ONLY: ish, nvb - USE electrons_base, ONLY: nbsp, nspin, iupdwn, nupdwn - USE constants, ONLY: pi, fpi - USE cp_main_variables, ONLY: nlam, nlax, descla, la_proc - USE descriptors, ONLY: nlar_, nlac_, ilar_, ilac_ - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm -! - IMPLICIT NONE - COMPLEX(DP) bec(nhsa, nbsp), becdr(nhsa, nspin*nlax, 3), lambda(nlam, nlam, nspin) - REAL(DP) fion(3, nat) -! - INTEGER :: k, is, ia, iv, jv, i, j, inl, isa, iss, nss, istart, ir, ic, nr, nc - COMPLEX(DP), ALLOCATABLE :: temp(:, :), tmpbec(:, :), tmpdr(:, :) - REAL(DP), ALLOCATABLE :: fion_tmp(:, :) - ! - CALL start_clock('nlfl') - ! - ALLOCATE (fion_tmp(3, nat)) - ! - fion_tmp = 0.0d0 - ! - - ALLOCATE (temp(nlax, nlax), tmpbec(nhm, nlax), tmpdr(nlax, nhm)) - - DO k = 1, 3 - isa = 0 - DO is = 1, nvb - DO ia = 1, na(is) - isa = isa + 1 - ! - DO iss = 1, nspin - ! - nss = nupdwn(iss) - istart = iupdwn(iss) - ! - tmpbec = 0.d0 - tmpdr = 0.d0 -! - IF (la_proc) THEN - ! tmpbec distributed by columns - ic = descla(ilac_, iss) - nc = descla(nlac_, iss) - DO iv = 1, nh(is) - DO jv = 1, nh(is) - inl = ish(is) + (jv - 1)*na(is) + ia - IF (ABS(qq(iv, jv, is)) .GT. 1.e-5) THEN - DO i = 1, nc - tmpbec(iv, i) = tmpbec(iv, i) + qq(iv, jv, is)*bec(inl, i + istart - 1 + ic - 1) - END DO - END IF - END DO - END DO - ! tmpdr distributed by rows - ir = descla(ilar_, iss) - nr = descla(nlar_, iss) - DO iv = 1, nh(is) - inl = ish(is) + (iv - 1)*na(is) + ia - DO i = 1, nr - tmpdr(i, iv) = becdr(inl, i + (iss - 1)*nlax, k) - END DO - END DO - END IF -! - IF (nh(is) .GT. 0) THEN - ! - IF (la_proc) THEN - ir = descla(ilar_, iss) - ic = descla(ilac_, iss) - nr = descla(nlar_, iss) - nc = descla(nlac_, iss) - CALL ZGEMM('N', 'N', nr, nc, nh(is), (1.0d0, 0.d0), tmpdr, nlax, tmpbec, nhm, (0.0d0, 0.d0), temp, nlax) - DO j = 1, nc - DO i = 1, nr - fion_tmp(k, isa) = fion_tmp(k, isa) + DBLE(2D0*temp(i, j)*lambda(i, j, iss)) - END DO - END DO - END IF -! - END IF - - END DO -! - END DO - END DO - END DO - ! - DEALLOCATE (temp, tmpbec, tmpdr) - ! - CALL mp_sum(fion_tmp, intra_image_comm) - ! - fion = fion + fion_tmp - ! - DEALLOCATE (fion_tmp) - ! - CALL stop_clock('nlfl') - ! - RETURN - -END SUBROUTINE nlfl_cmplx - -!------------------------------------------------------------------------- -SUBROUTINE nlfl_twin(bec, becdr, lambda, fion, lgam) -!----------------------------------------------------------------------- -! contribution to fion due to the orthonormality constraint -! -! - - USE kinds, ONLY: DP - USE ions_base, ONLY: na, nat - USE uspp, ONLY: qq - USE uspp_param, ONLY: nhm, nh - USE cvan, ONLY: ish, nvb - USE electrons_base, ONLY: nspin, iupdwn, nupdwn - USE constants, ONLY: pi, fpi - USE cp_main_variables, ONLY: nlax, descla, la_proc - USE descriptors, ONLY: nlar_, nlac_, ilar_, ilac_ - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE twin_types !added:giovanni -! - IMPLICIT NONE - - type(twin_matrix) :: lambda(nspin) - REAL(DP) :: fion(3, nat) - TYPE(twin_matrix) :: bec - TYPE(twin_tensor) :: becdr - LOGICAL :: lgam -! - INTEGER :: k, is, ia, iv, jv, i, j, inl, isa, iss, nss, istart, ir, ic, nr, nc - REAL(DP), ALLOCATABLE :: temp(:, :), tmpbec(:, :), tmpdr(:, :) - COMPLEX(DP), ALLOCATABLE :: temp_c(:, :), tmpbec_c(:, :), tmpdr_c(:, :) - REAL(DP), ALLOCATABLE :: fion_tmp(:, :) - COMPLEX(DP), PARAMETER :: c_one = CMPLX(1.d0, 0.d0), c_zero = CMPLX(0.d0, 0.d0) - ! - CALL start_clock('nlfl') - ! - ALLOCATE (fion_tmp(3, nat)) - ! - fion_tmp = 0.0d0 - ! - IF (lgam) THEN - ALLOCATE (temp(nlax, nlax), tmpbec(nhm, nlax), tmpdr(nlax, nhm)) - ELSE - ALLOCATE (temp_c(nlax, nlax), tmpbec_c(nhm, nlax), tmpdr_c(nlax, nhm)) - END IF - - IF (lgam) THEN - DO k = 1, 3 - isa = 0 - DO is = 1, nvb - DO ia = 1, na(is) - isa = isa + 1 - ! - DO iss = 1, nspin - ! - nss = nupdwn(iss) - IF (nss > 0) THEN - istart = iupdwn(iss) - ! - tmpbec = 0.d0 - tmpdr = 0.d0 - ! - IF (la_proc) THEN - ! tmpbec distributed by columns - ic = descla(ilac_, iss) - nc = descla(nlac_, iss) - DO iv = 1, nh(is) - DO jv = 1, nh(is) - inl = ish(is) + (jv - 1)*na(is) + ia - IF (ABS(qq(iv, jv, is)) .GT. 1.e-5) THEN - DO i = 1, nc - tmpbec(iv, i) = tmpbec(iv, i) + qq(iv, jv, is)*bec%rvec(inl, i + istart - 1 + ic - 1) - END DO - END IF - END DO - END DO - ! tmpdr distributed by rows - ir = descla(ilar_, iss) - nr = descla(nlar_, iss) - DO iv = 1, nh(is) - inl = ish(is) + (iv - 1)*na(is) + ia - DO i = 1, nr - tmpdr(i, iv) = becdr%rvec(inl, i + (iss - 1)*nlax, k) - END DO - END DO - END IF - ! - IF (nh(is) .GT. 0) THEN - ! - IF (la_proc) THEN - ir = descla(ilar_, iss) - ic = descla(ilac_, iss) - nr = descla(nlar_, iss) - nc = descla(nlac_, iss) - CALL DGEMM('N', 'N', nr, nc, nh(is), 1.0d0, tmpdr, nlax, tmpbec, nhm, 0.0d0, temp, nlax) - DO j = 1, nc - DO i = 1, nr - fion_tmp(k, isa) = fion_tmp(k, isa) + 2D0*temp(i, j)*lambda(iss)%rvec(i, j) - END DO - END DO - END IF - ! - END IF - END IF - END DO - ! - END DO - END DO - END DO - ELSE - DO k = 1, 3 - isa = 0 - DO is = 1, nvb - DO ia = 1, na(is) - isa = isa + 1 - ! - DO iss = 1, nspin - ! - nss = nupdwn(iss) - istart = iupdwn(iss) - ! - tmpbec_c = CMPLX(0.d0, 0.d0) - tmpdr_c = CMPLX(0.d0, 0.d0) - ! - IF (la_proc) THEN - ! tmpbec distributed by columns - ic = descla(ilac_, iss) - nc = descla(nlac_, iss) - DO iv = 1, nh(is) - DO jv = 1, nh(is) - inl = ish(is) + (jv - 1)*na(is) + ia - IF (ABS(qq(iv, jv, is)) .GT. 1.e-5) THEN - DO i = 1, nc - tmpbec_c(iv, i) = tmpbec_c(iv, i) + qq(iv, jv, is)*bec%cvec(inl, i + istart - 1 + ic - 1) - END DO - END IF - END DO - END DO - ! tmpdr distributed by rows - ir = descla(ilar_, iss) - nr = descla(nlar_, iss) - DO iv = 1, nh(is) - inl = ish(is) + (iv - 1)*na(is) + ia - DO i = 1, nr - tmpdr_c(i, iv) = becdr%cvec(inl, i + (iss - 1)*nlax, k) - END DO - END DO - END IF - ! - IF (nh(is) .GT. 0) THEN - ! - IF (la_proc) THEN - ir = descla(ilar_, iss) - ic = descla(ilac_, iss) - nr = descla(nlar_, iss) - nc = descla(nlac_, iss) - CALL ZGEMM('N', 'N', nr, nc, nh(is), c_one, tmpdr_c, nlax, tmpbec_c, nhm, c_zero, temp_c, nlax) !warning:giovanni:check C - DO j = 1, nc - DO i = 1, nr - fion_tmp(k, isa) = fion_tmp(k, isa) + 2D0*DBLE(CONJG(temp_c(i, j))*lambda(iss)%cvec(i, j)) - END DO - END DO - END IF - ! - END IF - - END DO - ! - END DO - END DO - END DO - END IF - ! - IF (lgam) THEN - DEALLOCATE (temp, tmpbec, tmpdr) - ELSE - DEALLOCATE (temp_c, tmpbec_c, tmpdr_c) - END IF - ! - CALL mp_sum(fion_tmp, intra_image_comm) - ! - fion = fion + fion_tmp - ! - DEALLOCATE (fion_tmp) - ! - CALL stop_clock('nlfl') - ! - RETURN - -END SUBROUTINE nlfl_twin -! -! -!----------------------------------------------------------------------- -SUBROUTINE pbc(rin, a1, a2, a3, ainv, rout) -!----------------------------------------------------------------------- -! -! brings atoms inside the unit cell -! - USE kinds, ONLY: DP - - IMPLICIT NONE -! input - REAL(DP) rin(3), a1(3), a2(3), a3(3), ainv(3, 3) -! output - REAL(DP) rout(3) -! local - REAL(DP) x, y, z -! -! bring atomic positions to crystal axis -! - x = ainv(1, 1)*rin(1) + ainv(1, 2)*rin(2) + ainv(1, 3)*rin(3) - y = ainv(2, 1)*rin(1) + ainv(2, 2)*rin(2) + ainv(2, 3)*rin(3) - z = ainv(3, 1)*rin(1) + ainv(3, 2)*rin(2) + ainv(3, 3)*rin(3) -! -! bring x,y,z in the range between -0.5 and 0.5 -! - x = x - NINT(x) - y = y - NINT(y) - z = z - NINT(z) -! -! bring atomic positions back in cartesian axis -! - rout(1) = x*a1(1) + y*a2(1) + z*a3(1) - rout(2) = x*a1(2) + y*a2(2) + z*a3(2) - rout(3) = x*a1(3) + y*a2(3) + z*a3(3) -! - RETURN -END SUBROUTINE pbc - -! -!------------------------------------------------------------------------- -SUBROUTINE prefor(eigr, betae) -!----------------------------------------------------------------------- -! -! input : eigr = e^-ig.r_i -! output: betae_i,i(g) = (-i)**l beta_i,i(g) e^-ig.r_i -! - USE kinds, ONLY: DP - USE ions_base, ONLY: nsp, na, nat - USE gvecw, ONLY: ngw - USE cvan, ONLY: ish - USE uspp, ONLY: nkb, beta, nhtol - USE uspp_param, ONLY: nh -! - IMPLICIT NONE - COMPLEX(DP) :: eigr(ngw, nat) - COMPLEX(DP) :: betae(ngw, nkb) -! - INTEGER :: is, iv, ia, inl, ig, isa - COMPLEX(DP) :: ci -! - CALL start_clock('prefor') - isa = 0 - DO is = 1, nsp - DO iv = 1, nh(is) - ci = (0.0d0, -1.0d0)**nhtol(iv, is) - DO ia = 1, na(is) - inl = ish(is) + (iv - 1)*na(is) + ia - DO ig = 1, ngw - betae(ig, inl) = ci*beta(ig, iv, is)*eigr(ig, ia + isa) - END DO - END DO - END DO - isa = isa + na(is) - END DO - CALL stop_clock('prefor') -! - RETURN -END SUBROUTINE prefor -! -!----------------------------------------------------------------------- -SUBROUTINE projwfc(c, nx, eigr, betae, n, ei) -!----------------------------------------------------------------------- - ! - ! Projection on atomic wavefunctions - ! - USE kinds, ONLY: DP - USE constants, ONLY: autoev - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gstart - USE ions_base, ONLY: nsp, na, nat - USE uspp, ONLY: nhsa => nkb - USE uspp_param, ONLY: upf - USE twin_types !added:giovanni - USE cp_interfaces, ONLY: nlsm1, s_wfc !added:giovanni -! - IMPLICIT NONE - INTEGER, INTENT(IN) :: nx, n - COMPLEX(DP), INTENT(IN) :: c(ngw, nx), eigr(ngw, nat), betae(ngw, nhsa) - REAL(DP), INTENT(IN) :: ei(nx) -! - COMPLEX(DP), ALLOCATABLE :: wfc(:, :), swfc(:, :) - REAL(DP), ALLOCATABLE :: becwfc(:, :) - REAL(DP), ALLOCATABLE :: overlap(:, :), e(:), z(:, :) - REAL(DP), ALLOCATABLE :: proj(:, :), temp(:) - REAL(DP) :: somma - - INTEGER :: n_atomic_wfc - INTEGER :: is, ia, nb, l, m, k, i - - INTERFACE nlsm1_local - subroutine nlsm1_real(n, nspmn, nspmx, eigr, c, becp) !addded:giovanni - USE kinds, ONLY: DP - - implicit none - - integer, intent(in) :: n, nspmn, nspmx - complex(DP), intent(in) :: eigr(:, :), c(:, :) - REAL(DP) :: becp(:, :) - end subroutine - END INTERFACE - ! - ! calculate number of atomic states - ! - n_atomic_wfc = 0 - ! - DO is = 1, nsp - DO nb = 1, upf(is)%nwfc - l = upf(is)%lchi(nb) - n_atomic_wfc = n_atomic_wfc + (2*l + 1)*na(is) - END DO - END DO - IF (n_atomic_wfc .EQ. 0) RETURN - ! - ALLOCATE (wfc(ngw, n_atomic_wfc)) - ! - ! calculate wfc = atomic states - ! - CALL atomic_wfc(eigr, n_atomic_wfc, wfc) - ! - ! calculate bec = - ! - ALLOCATE (becwfc(nhsa, n_atomic_wfc)) - ! - CALL nlsm1_local(n_atomic_wfc, 1, nsp, eigr, wfc, becwfc) - ! - ! calculate swfc = S|wfc> - ! - ALLOCATE (swfc(ngw, n_atomic_wfc)) - ! - CALL s_wfc(n_atomic_wfc, becwfc, betae, wfc, swfc) - ! - ! calculate overlap(i,j) = - ! - ALLOCATE (overlap(n_atomic_wfc, n_atomic_wfc)) - - CALL DGEMM & - ('T', 'N', n_atomic_wfc, n_atomic_wfc, 2*ngw, 1.0d0, wfc, 2*ngw, & - swfc, 2*ngw, 0.0d0, overlap, n_atomic_wfc) - - CALL mp_sum(overlap, intra_image_comm) - - overlap = overlap*2.d0 - IF (gstart == 2) THEN - DO l = 1, n_atomic_wfc - DO m = 1, n_atomic_wfc - overlap(m, l) = overlap(m, l) - DBLE(wfc(1, m))*DBLE(swfc(1, l)) - END DO - END DO - END IF - ! - ! calculate (overlap)^(-1/2)(i,j). An orthonormal set of vectors |wfc_i> - ! is obtained by introducing |wfc_j>=(overlap)^(-1/2)(i,j)*S|wfc_i> - ! - ALLOCATE (z(n_atomic_wfc, n_atomic_wfc)) - ALLOCATE (e(n_atomic_wfc)) - ! - CALL rdiag(n_atomic_wfc, overlap, n_atomic_wfc, e, z) - ! - overlap = 0.d0 - ! - DO l = 1, n_atomic_wfc - DO m = 1, n_atomic_wfc - DO k = 1, n_atomic_wfc - overlap(l, m) = overlap(l, m) + z(m, k)*z(l, k)/SQRT(e(k)) - END DO - END DO - END DO - ! - DEALLOCATE (e) - DEALLOCATE (z) - ! - ! calculate |wfc_j>=(overlap)^(-1/2)(i,j)*S|wfc_i> (note the S matrix!) - ! - wfc = 0.d0 - DO m = 1, n_atomic_wfc - DO l = 1, n_atomic_wfc - wfc(:, m) = wfc(:, m) + overlap(l, m)*swfc(:, l) - END DO - END DO - DEALLOCATE (overlap) - DEALLOCATE (swfc) - DEALLOCATE (becwfc) - ! - ! calculate proj = - ! - ALLOCATE (proj(n, n_atomic_wfc)) - - ALLOCATE (temp(ngw)) - - DO m = 1, n - DO l = 1, n_atomic_wfc - temp(:) = DBLE(CONJG(c(:, m))*wfc(:, l)) - proj(m, l) = 2.d0*SUM(temp) - IF (gstart == 2) proj(m, l) = proj(m, l) - temp(1) - END DO - END DO - - DEALLOCATE (temp) - - CALL mp_sum(proj, intra_image_comm) - - i = 0 - WRITE (stdout, 90) - WRITE (stdout, 100) - DO is = 1, nsp - DO nb = 1, upf(is)%nwfc - l = upf(is)%lchi(nb) - DO m = -l, l - DO ia = 1, na(is) - i = i + 1 - END DO - WRITE (stdout, 110) i - na(is) + 1, i, na(is), is, nb, l, m - END DO - END DO - END DO - - WRITE (stdout, *) - DO m = 1, n - somma = 0.d0 - DO l = 1, n_atomic_wfc - somma = somma + proj(m, l)**2 - END DO - WRITE (stdout, 120) m, somma, ei(m)*autoev - WRITE (stdout, 130) (ABS(proj(m, l)), l=1, n_atomic_wfc) - END DO - -90 FORMAT(3X, 'Projection on atomic states') -100 FORMAT(3X, 'atomic state atom specie wfc l m') -110 FORMAT(3X, I4, ' - ', I4, 4X, I4, 6X, I3, I5, I4, I3) -120 FORMAT(3X, 'state # ', i4, ' sum c^2 = ', f7.4, ' eV = ', F7.2) -130 FORMAT(3X, 10f7.4) - -! - DEALLOCATE (proj) - DEALLOCATE (wfc) - RETURN -END SUBROUTINE projwfc - -! -!----------------------------------------------------------------------- -SUBROUTINE rdiag(n, h, ldh, e, v) -!----------------------------------------------------------------------- -! -! calculates all the eigenvalues and eigenvectors of a complex -! hermitean matrix H . On output, the matrix H is destroyed -! - USE kinds, ONLY: DP - USE dspev_module, ONLY: dspev_drv - ! - IMPLICIT NONE - ! - INTEGER, INTENT(in) :: n, ldh - REAL(DP), INTENT(inout):: h(ldh, n) - REAL(DP), INTENT(out) :: e(n) - REAL(DP), INTENT(out) :: v(ldh, n) -! - INTEGER :: i, j, k - REAL(DP), ALLOCATABLE :: ap(:) -! - ALLOCATE (ap(n*(n + 1)/2)) - - K = 0 - DO J = 1, n - DO I = J, n - K = K + 1 - ap(k) = h(i, j) - END DO - END DO - - CALL dspev_drv('V', 'L', n, ap, e, v, ldh) - - DEALLOCATE (ap) -! - RETURN -END SUBROUTINE rdiag - -! -! -!------------------------------------------------------------------------- -SUBROUTINE s_wfc_real(n_atomic_wfc1, becwfc, betae, wfc, swfc) !@@@@ Changed n_atomic_wfc to n_atomic_wfc1 -!----------------------------------------------------------------------- -! -! input: wfc, becwfc=, betae=|beta> -! output: swfc=S|wfc> -! - USE kinds, ONLY: DP - USE ions_base, ONLY: na - USE cvan, ONLY: nvb, ish - USE uspp, ONLY: nhsa => nkb, nhsavb => nkbus, qq - USE uspp_param, ONLY: nh - USE gvecw, ONLY: ngw - USE constants, ONLY: pi, fpi - IMPLICIT NONE -! input - INTEGER, INTENT(in) :: n_atomic_wfc1 - COMPLEX(DP), INTENT(in) :: betae(ngw, nhsa), & - & wfc(ngw, n_atomic_wfc1) - REAL(DP), INTENT(in) :: becwfc(nhsa, n_atomic_wfc1) -! output - COMPLEX(DP), INTENT(out):: swfc(ngw, n_atomic_wfc1) -! local - INTEGER is, iv, jv, ia, inl, jnl, i - REAL(DP) qtemp(nhsavb, n_atomic_wfc1) -! - swfc = wfc -! - IF (nvb .GT. 0) THEN - qtemp = 0.d0 - DO is = 1, nvb - DO iv = 1, nh(is) - DO jv = 1, nh(is) - IF (ABS(qq(iv, jv, is)) .GT. 1.e-5) THEN - DO ia = 1, na(is) - inl = ish(is) + (iv - 1)*na(is) + ia - jnl = ish(is) + (jv - 1)*na(is) + ia - DO i = 1, n_atomic_wfc1 - qtemp(inl, i) = qtemp(inl, i) + & - & qq(iv, jv, is)*becwfc(jnl, i) - END DO - END DO - END IF - END DO - END DO - END DO -! - CALL DGEMM & - ('N', 'N', 2*ngw, n_atomic_wfc1, nhsavb, 1.0d0, betae, 2*ngw, & - qtemp, nhsavb, 1.0d0, swfc, 2*ngw) -! - END IF -! -! swfc=swfc+wfc -! - RETURN -END SUBROUTINE s_wfc_real - -!------------------------------------------------------------------------- -SUBROUTINE s_wfc_twin(n_atomic_wfc1, becwfc, betae, wfc, swfc, lgam) !@@@@ Changed n_atomic_wfc to n_atomic_wfc1 -!----------------------------------------------------------------------- -! -! input: wfc, becwfc=, betae=|beta> -! output: swfc=S|wfc> -! - USE kinds, ONLY: DP - USE ions_base, ONLY: na - USE cvan, ONLY: nvb, ish - USE uspp, ONLY: nhsa => nkb, nhsavb => nkbus, qq - USE uspp_param, ONLY: nh - USE gvecw, ONLY: ngw - USE constants, ONLY: pi, fpi - USE twin_types - ! - IMPLICIT NONE -! input - INTEGER, INTENT(in) :: n_atomic_wfc1 - COMPLEX(DP), INTENT(in) :: betae(ngw, nhsa), & - & wfc(ngw, n_atomic_wfc1) - TYPE(twin_matrix) :: becwfc - LOGICAL :: lgam -! output - COMPLEX(DP), INTENT(out):: swfc(ngw, n_atomic_wfc1) -! local - INTEGER is, iv, jv, ia, inl, jnl, i - REAL(DP), ALLOCATABLE :: qtemp(:, :) - COMPLEX(DP), ALLOCATABLE :: qtemp_c(:, :) -! - swfc = wfc -! - IF (nvb .GT. 0) THEN - IF (lgam) THEN - allocate (qtemp(nhsavb, n_atomic_wfc1)) - qtemp = 0.d0 - DO is = 1, nvb - DO iv = 1, nh(is) - DO jv = 1, nh(is) - IF (ABS(qq(iv, jv, is)) .GT. 1.e-5) THEN - DO ia = 1, na(is) - inl = ish(is) + (iv - 1)*na(is) + ia - jnl = ish(is) + (jv - 1)*na(is) + ia - DO i = 1, n_atomic_wfc1 - qtemp(inl, i) = qtemp(inl, i) + & - & qq(iv, jv, is)*becwfc%rvec(jnl, i) - END DO - END DO - END IF - END DO - END DO - END DO - ! - CALL DGEMM & - ('N', 'N', 2*ngw, n_atomic_wfc1, nhsavb, 1.0d0, betae, 2*ngw, & - qtemp, nhsavb, 1.0d0, swfc, 2*ngw) - deallocate (qtemp) - ELSE - allocate (qtemp_c(nhsavb, n_atomic_wfc1)) - qtemp_c = CMPLX(0.d0, 0.d0) - DO is = 1, nvb - DO iv = 1, nh(is) - DO jv = 1, nh(is) - IF (ABS(qq(iv, jv, is)) .GT. 1.e-5) THEN - DO ia = 1, na(is) - inl = ish(is) + (iv - 1)*na(is) + ia - jnl = ish(is) + (jv - 1)*na(is) + ia - DO i = 1, n_atomic_wfc1 - qtemp_c(inl, i) = qtemp_c(inl, i) + & - & qq(iv, jv, is)*becwfc%cvec(jnl, i) - END DO - END DO - END IF - END DO - END DO - END DO - ! - CALL ZGEMM & - ('N', 'N', ngw, n_atomic_wfc1, nhsavb, (1.0d0, 0.d0), betae, ngw, & - qtemp_c, nhsavb, (1.0d0, 0.d0), swfc, ngw) - deallocate (qtemp_c) - END IF - END IF -! -! swfc=swfc+wfc -! - RETURN -END SUBROUTINE s_wfc_twin - -!----------------------------------------------------------------------- -SUBROUTINE spinsq(c, bec, rhor) -!----------------------------------------------------------------------- -! -! estimate of =s(s+1) in two different ways. -! 1) using as many-body wavefunction a single Slater determinant -! constructed with Kohn-Sham orbitals: -! -! = (Nup-Ndw)/2 * (Nup-Ndw)/2+1) + Ndw - -! \sum_up\sum_dw < psi_up | psi_dw > -! -! where Nup, Ndw = number of up and down states, the sum is over -! occupied states. Not suitable for fractionary occupancy. -! In the ultrasoft scheme (c is the smooth part of \psi): -! -! < psi_up | psi_dw > = \sum_G c*_up(G) c_dw(G) + -! \int Q_ij -! -! This is the usual formula, unsuitable for fractionary occupancy. -! 2) using the "LSD model" of Wang, Becke, Smith, JCP 102, 3477 (1995): -! -! = (Nup-Ndw)/2 * (Nup-Ndw)/2+1) + Ndw - -! \int max(rhoup(r),rhodw(r)) dr -! -! Requires on input: c=psi, bec=, rhoup(r), rhodw(r) -! Assumes real psi, with only half G vectors. -! - USE electrons_base, ONLY: nx => nbspx, n => nbsp, iupdwn, nupdwn, f, nel, nspin - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gstart - USE grid_dimensions, ONLY: nr1, nr2, nr3, & - nnr => nnrx - USE cell_base, ONLY: omega - USE cvan, ONLY: nvb, ish - USE uspp, ONLY: nhsa => nkb, qq - USE uspp_param, ONLY: nh - USE ions_base, ONLY: na -! - IMPLICIT NONE -! input - REAL(8) bec(nhsa, n), rhor(nnr, nspin) - COMPLEX(8) c(ngw, nx) -! local variables - INTEGER nup, ndw, ir, i, j, jj, ig, ia, is, iv, jv, inl, jnl - REAL(8) spin0, spin1, spin2, fup, fdw - REAL(8), ALLOCATABLE:: overlap(:, :), temp(:) - LOGICAL frac -! -! - IF (nspin .EQ. 1) RETURN -! -! find spin-up and spin-down states -! - fup = 0.0d0 - DO i = iupdwn(1), nupdwn(1) - fup = fup + f(i) - END DO - nup = NINT(fup) - ndw = nel(1) + nel(2) - nup -! -! paranoid checks -! - frac = ABS(fup - nup) .GT. 1.0d-6 - fup = 0.0d0 - DO i = 1, nup - fup = fup + f(i) - END DO - frac = frac .OR. ABS(fup - nup) .GT. 1.0d-6 - fdw = 0.0d0 - DO j = iupdwn(2), iupdwn(2) - 1 + ndw - fdw = fdw + f(j) - END DO - frac = frac .OR. ABS(fdw - ndw) .GT. 1.0d-6 -! - spin0 = ABS(fup - fdw)/2.d0*(ABS(fup - fdw)/2.d0 + 1.d0) + fdw -! -! Becke's formula for spin polarization -! - spin1 = 0.0d0 - DO ir = 1, nnr - spin1 = spin1 - MIN(rhor(ir, 1), rhor(ir, 2)) - END DO - CALL mp_sum(spin1, intra_image_comm) - spin1 = spin0 + omega/(nr1*nr2*nr3)*spin1 - IF (frac) THEN - WRITE (stdout, '(/'' Spin contamination: s(s+1)='',f5.2,'' (Becke) '',& - & f5.2,'' (expected)'')') & - & spin1, ABS(fup - fdw)/2.d0*(ABS(fup - fdw)/2.d0 + 1.d0) - RETURN - END IF -! -! Slater formula, smooth contribution to < psi_up | psi_dw > -! - ALLOCATE (overlap(nup, ndw)) - ALLOCATE (temp(ngw)) - DO j = 1, ndw - jj = j + iupdwn(2) - 1 - DO i = 1, nup - overlap(i, j) = 0.d0 - DO ig = 1, ngw - temp(ig) = DBLE(CONJG(c(ig, i))*c(ig, jj)) - END DO - overlap(i, j) = 2.d0*SUM(temp) - IF (gstart == 2) overlap(i, j) = overlap(i, j) - temp(1) - END DO - END DO - DEALLOCATE (temp) - CALL mp_sum(overlap, intra_image_comm) - DO j = 1, ndw - jj = j + iupdwn(2) - 1 - DO i = 1, nup -! -! vanderbilt contribution to < psi_up | psi_dw > -! - DO is = 1, nvb - DO iv = 1, nh(is) - DO jv = 1, nh(is) - IF (ABS(qq(iv, jv, is)) .GT. 1.e-5) THEN - DO ia = 1, na(is) - inl = ish(is) + (iv - 1)*na(is) + ia - jnl = ish(is) + (jv - 1)*na(is) + ia - overlap(i, j) = overlap(i, j) + & - & qq(iv, jv, is)*bec(inl, i)*bec(jnl, jj) - END DO - END IF - END DO - END DO - END DO - END DO - END DO -! - spin2 = spin0 - DO j = 1, ndw - DO i = 1, nup - spin2 = spin2 - overlap(i, j)**2 - END DO - END DO -! - DEALLOCATE (overlap) -! - WRITE (stdout, '(/" Spin contamination: s(s+1)=",f5.2," (Slater) ", & - & f5.2," (Becke) ",f5.2," (expected)")') & - & spin2, spin1, ABS(fup - fdw)/2.d0*(ABS(fup - fdw)/2.d0 + 1.d0) -! - RETURN -END SUBROUTINE spinsq - -! -!----------------------------------------------------------------------- -SUBROUTINE vofrho(nfi, rhor, rhog, rhos, rhoc, tfirst, tlast, & -& ei1, ei2, ei3, irb, eigrb, sfac, tau0, fion) -!----------------------------------------------------------------------- -! computes: the one-particle potential v in real space, -! the total energy etot, -! the forces fion acting on the ions, -! the derivative of total energy to cell parameters h -! rhor input : electronic charge on dense real space grid -! (plus core charge if present) -! rhog input : electronic charge in g space (up to density cutoff) -! rhos input : electronic charge on smooth real space grid -! rhor output: total potential on dense real space grid -! rhos output: total potential on smooth real space grid -! - - USE kinds, ONLY: dp - USE control_flags, ONLY: iprint, iprsta, tpre, tfor, & - tprnfor, iesr, textfor, gamma_only, do_wf_cmplx !addded:giovanni - USE io_global, ONLY: stdout - USE ions_base, ONLY: nsp, na, nat, compute_eextfor - USE gvecs - USE gvecp, ONLY: ng => ngm - USE cell_base, ONLY: omega, r_to_s - USE cell_base, ONLY: a1, a2, a3, tpiba2, h, ainv - USE reciprocal_vectors, ONLY: gstart, g, gx - USE recvecs_indexes, ONLY: np, nm - USE grid_dimensions, ONLY: nr1, nr2, nr3, & - nnr => nnrx - USE smooth_grid_dimensions, & - ONLY: nnrsx - USE electrons_base, ONLY: nspin - USE constants, ONLY: pi, fpi, au_gpa - USE energies, ONLY: etot, eself, enl, ekin, epseu, esr, eht, exc, eextfor - USE local_pseudo, ONLY: vps, rhops - USE core, ONLY: nlcc_any - USE gvecb - USE dener, ONLY: detot, dekin, dps, dh, dsr, dxc, denl, & - detot6, dekin6, dps6, dh6, dsr6 - USE cp_main_variables, ONLY: drhog, ht0 - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE funct, ONLY: dft_is_meta, dft_is_hybrid - USE pres_ai_mod, ONLY: abivol, abisur, v_vol, P_ext, volclu, & - Surf_t, surfclu - USE cp_interfaces, ONLY: fwfft, invfft, self_vofhar - USE sic_module, ONLY: self_interaction - USE energies, ONLY: self_exc, self_ehte - USE cp_interfaces, ONLY: compute_gagb, stress_hartree, & - add_drhoph, stress_local, force_loc - USE fft_base, ONLY: dfftp, dffts - USE ldaU, ONLY: e_hubbard - USE hfmod, ONLY: do_hf, hfscalfact - use eecp_mod, only: do_comp, vcorr, & - vcorr_fft, ecomp - USE efield_mod, ONLY: do_efield, efieldpotg - USE io_global, ONLY: stdout - IMPLICIT NONE -! - LOGICAL :: tlast, tfirst - INTEGER :: nfi - REAL(DP) rhor(nnr, nspin), rhos(nnrsx, nspin), fion(3, nat) - REAL(DP) rhoc(nnr), tau0(3, nat) - COMPLEX(DP) ei1(-nr1:nr1, nat), ei2(-nr2:nr2, nat), & - & ei3(-nr3:nr3, nat), eigrb(ngb, nat), & - & rhog(ng, nspin), sfac(ngs, nsp) - ! - INTEGER irb(3, nat) - ! - INTEGER iss, isup, isdw, ig, ir, i, j, k, ij, is - REAL(DP) vave, ebac, wz, eh - COMPLEX(DP) fp, fm, ci, zpseu, zh - COMPLEX(DP), ALLOCATABLE :: rhotmp(:), vtemp(:), aux(:) - ! COMPLEX(DP), ALLOCATABLE :: drhotmp(:,:,:) - COMPLEX(DP), ALLOCATABLE :: drhot(:, :) - COMPLEX(DP), ALLOCATABLE :: v(:), vs(:) - REAL(DP), ALLOCATABLE :: gagb(:, :), rhotot(:), v3d(:), v0d(:) - ! - REAL(DP), ALLOCATABLE :: fion1(:, :) - REAL(DP), ALLOCATABLE :: stmp(:, :) - ! - COMPLEX(DP), ALLOCATABLE :: self_vloc(:) - REAL(DP) :: self_ehtet - LOGICAL :: ttsic - REAL(DP) :: detmp(3, 3) - REAL(DP) :: ht(3, 3) - COMPLEX(DP) :: screen_coul(1) -! - INTEGER, DIMENSION(6), PARAMETER :: alpha = (/1, 2, 3, 2, 3, 3/) - INTEGER, DIMENSION(6), PARAMETER :: beta = (/1, 1, 1, 2, 2, 3/) - - ! ... dalbe(:) = delta( alpha(:), beta(:) ) - REAL(DP), DIMENSION(6), PARAMETER :: dalbe = & - (/1.0_DP, 0.0_DP, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP/) - LOGICAL :: lgam !added:giovanni - - CALL start_clock('vofrho') - lgam = gamma_only .and. .not. do_wf_cmplx !added:giovanni - - ci = (0.0d0, 1.0d0) - ! - ! wz = factor for g.neq.0 because of c*(g)=c(-g) - ! - wz = 2.0d0 - ! - ht = TRANSPOSE(h) - ! - ALLOCATE (v(nnr)) - ALLOCATE (vs(nnrsx)) - ALLOCATE (vtemp(ng)) - ALLOCATE (rhotmp(ng)) - if (do_comp) then - allocate (aux(nnr)) - allocate (rhotot(nnr)) - allocate (v3d(nnr)) - allocate (v0d(nnr)) - end if - ! - IF (tpre) THEN - ALLOCATE (drhot(ng, 6)) - ALLOCATE (gagb(6, ng)) - CALL compute_gagb(gagb, gx, ng, tpiba2) - END IF - ! -! -! ab-initio pressure and surface tension contributions to the potential -! - if (abivol .or. abisur) call vol_clu(rhor, rhog, nfi) - ! - ttsic = (ABS(self_interaction) /= 0) - ! - IF (ttsic) ALLOCATE (self_vloc(ng)) - ! - ! first routine in which fion is calculated: annihilation - ! - fion = 0.d0 - ! - ! forces on ions, ionic term in real space - ! - IF (tprnfor .OR. tfor .OR. tfirst .OR. tpre) THEN - ! - ALLOCATE (stmp(3, nat)) - ! - CALL r_to_s(tau0, stmp, na, nsp, ainv) - ! - CALL vofesr(iesr, esr, dsr6, fion, stmp, tpre, h) - ! - call mp_sum(fion, intra_image_comm) - ! - DEALLOCATE (stmp) - ! - END IF -! - rhotmp(1:ng) = rhog(1:ng, 1) - ! - - IF (tpre) THEN - DO ij = 1, 6 - i = alpha(ij) - j = beta(ij) - drhot(:, ij) = 0.0d0 - DO k = 1, 3 - drhot(:, ij) = drhot(:, ij) + drhog(:, 1, i, k)*ht(k, j) - END DO - END DO - END IF - ! - IF (nspin == 2) THEN - rhotmp(1:ng) = rhotmp(1:ng) + rhog(1:ng, 2) - IF (tpre) THEN - DO ij = 1, 6 - i = alpha(ij) - j = beta(ij) - DO k = 1, 3 - drhot(:, ij) = drhot(:, ij) + drhog(:, 2, i, k)*ht(k, j) - END DO - END DO - END IF - END IF - ! - ! calculation local potential energy - ! - zpseu = 0.0d0 - ! -!$omp parallel default(shared), private(ig,is) -!$omp do - DO ig = 1, SIZE(vtemp) - vtemp(ig) = CMPLX(0.d0, 0.d0) - END DO - DO is = 1, nsp -!$omp do - DO ig = 1, ngs - vtemp(ig) = vtemp(ig) + CONJG(rhotmp(ig))*sfac(ig, is)*vps(ig, is) - END DO - END DO -!$omp do reduction(+:zpseu) - DO ig = 1, ngs - zpseu = zpseu + vtemp(ig) - END DO -!$omp end parallel - - epseu = wz*DBLE(zpseu) - ! - IF (lgam) THEN - IF (gstart == 2) epseu = epseu - DBLE(vtemp(1)) - END IF - ! - CALL mp_sum(epseu, intra_image_comm) - - IF (lgam) THEN - epseu = epseu*omega - ELSE - epseu = 0.5d0*epseu*omega - END IF -! - IF (tpre) THEN - ! - CALL stress_local(dps6, gagb, sfac, rhotmp, drhot, omega) - ! - END IF - ! - ! - ! calculation hartree energy - ! - ! - self_ehtet = 0.d0 - ! - IF (ttsic) self_vloc = 0.d0 - - zh = 0.0d0 - -!$omp parallel default(shared), private(ig,is) - - DO is = 1, nsp -!$omp do - DO ig = 1, ngs - rhotmp(ig) = rhotmp(ig) + sfac(ig, is)*rhops(ig, is) !JUST-FOR-NOW - !rhotmp(ig)=rhotmp(ig) - END DO - END DO - ! -!$omp do - DO ig = gstart, ng - vtemp(ig) = CONJG(rhotmp(ig))*rhotmp(ig)/g(ig) - END DO - -!$omp do reduction(+:zh) - DO ig = gstart, ng - zh = zh + vtemp(ig) - END DO - -!$omp end parallel - IF (lgam) THEN - eh = DBLE(zh)*wz*0.5d0*fpi/tpiba2 - ELSE - eh = DBLE(zh)*wz*0.25d0*fpi/tpiba2 - END IF -! - CALL mp_sum(eh, intra_image_comm) - ! - IF (ttsic) THEN - ! - CALL self_vofhar(.false., self_ehte, self_vloc, rhog, omega, h) - ! - eh = eh - self_ehte/omega - ! - END IF - ! - IF (tpre) THEN - ! - CALL add_drhoph(drhot, sfac, gagb) - ! - CALL stress_hartree(dh6, eh*omega, rhotmp, drhot, gagb, omega) - ! - END IF - ! - IF (tpre) THEN - DEALLOCATE (drhot) - END IF - ! - ! forces on ions, ionic term in reciprocal space - ! - ALLOCATE (fion1(3, nat)) - ! - fion1 = 0.d0 - ! - IF (tprnfor .OR. tfor .OR. tpre) THEN - vtemp(1:ng) = rhog(1:ng, 1) - IF (nspin == 2) THEN - vtemp(1:ng) = vtemp(1:ng) + rhog(1:ng, 2) - END IF - CALL force_loc(.false., vtemp, fion1, rhops, vps, ei1, ei2, ei3, sfac, omega, screen_coul, lgam) - END IF - ! - ! calculation hartree + local pseudo potential - ! - IF (gstart == 2) vtemp(1) = CMPLX(0.d0, 0.d0) - -!$omp parallel default(shared), private(ig,is) -!$omp do - DO ig = gstart, ng - vtemp(ig) = rhotmp(ig)*fpi/(tpiba2*g(ig)) - END DO -! - DO is = 1, nsp -!$omp do - DO ig = 1, ngs - vtemp(ig) = vtemp(ig) + sfac(ig, is)*vps(ig, is) !JUST-FOR-NOW I do not consider the pseudopotential part - END DO - END DO - ! - if (do_comp) then - ! - call calc_compensation_potential(vcorr_fft, rhotmp, .false.) - ! - call calc_tcc_energy(ecomp, vcorr_fft, rhotmp, lgam) - ! - aux = 0.0_dp - -! IF(lgam) THEN !!!### uncomment for k points - do ig = 1, ng - aux(np(ig)) = vcorr_fft(ig) - aux(nm(ig)) = conjg(vcorr_fft(ig)) - end do -! ELSE !!!### uncomment for k points -! do ig=1,ng !!!### uncomment for k points -! aux(np(ig))=vcorr_fft(ig) !!!### uncomment for k points -! ! aux(nm(ig))=conjg(vcorr_fft(ig)) -! end do !!!### uncomment for k points -! ENDIF - call invfft('Dense', aux, dfftp) - vcorr = dble(aux) - call writetofile(vcorr, nnr, 'vcorrz.dat', dfftp, 'az') - call writetofile(vcorr, nnr, 'vcorrx.dat', dfftp, 'ax') - ! - if (tprnfor .or. tfor .or. tfirst .or. tpre) then - allocate (stmp(3, nat)) - call r_to_s(tau0, stmp, na, nsp, ainv) - call calc_fcorr(fion, vcorr, stmp, nat, na, nsp, ht0, dfftp) - deallocate (stmp) - end if - ! - aux = 0.0_dp -! IF(lgam) THEN !!!### uncomment for k points - do ig = 1, ng - aux(np(ig)) = vcorr_fft(ig) + vtemp(ig) - aux(nm(ig)) = conjg(vcorr_fft(ig) + vtemp(ig)) - end do -! ELSE !!!### uncomment for k points -! do ig=1,ng !!!### uncomment for k points -! aux(np(ig))=vcorr_fft(ig)+vtemp(ig) !!!### uncomment for k points -! end do !!!### uncomment for k points -! ENDIF !!!### uncomment for k points - ! - call invfft('Dense', aux, dfftp) - v0d = dble(aux) - ! - call writetofile(v0d, nnr, 'v0dz.dat', dfftp, 'az') - call writetofile(v0d, nnr, 'v0dx.dat', dfftp, 'ax') - ! - aux = 0.0_dp -! IF(lgam) THEN !!!### uncomment for k points - do ig = 1, ng - aux(np(ig)) = vtemp(ig) - aux(nm(ig)) = conjg(vtemp(ig)) - end do -! ELSE !!!### uncomment for k points -! do ig=1,ng !!!### uncomment for k points -! aux(np(ig))=vtemp(ig) !!!### uncomment for k points -! end do !!!### uncomment for k points -! ENDIF !!!### uncomment for k points - call invfft('Dense', aux, dfftp) - v3d = dble(aux) - call writetofile(v3d, nnr, 'v3dz.dat', dfftp, 'az') - call writetofile(v3d, nnr, 'v3dx.dat', dfftp, 'ax') - ! - aux = 0.0_dp - -! IF(lgam) THEN !!!### uncomment for k points - do ig = 1, ng - aux(np(ig)) = rhotmp(ig) - aux(nm(ig)) = conjg(rhotmp(ig)) - end do -! ELSE !!!### uncomment for k points -! do ig=1,ng !!!### uncomment for k points -! aux(np(ig))=rhotmp(ig) !!!### uncomment for k points -! end do !!!### uncomment for k points -! ENDIF !!!### uncomment for k points - call invfft('Dense', aux, dfftp) - rhotot = dble(aux) - call writetofile(rhotot, nnr, 'rhototz.dat', dfftp, 'az') - call writetofile(rhotot, nnr, 'rhototx.dat', dfftp, 'ax') - ! - vtemp = vtemp + vcorr_fft - eh = eh + ecomp/omega - ! - end if - if (do_efield) vtemp = vtemp + efieldpotg -!$omp end parallel -! -! vtemp = v_loc(g) + v_h(g) -! -! =================================================================== -! calculation exchange and correlation energy and potential -! ------------------------------------------------------------------- - IF (nlcc_any) CALL add_cc(rhoc, rhog, rhor) -! - CALL exch_corr_h(nspin, rhog, rhor, rhoc, sfac, exc, dxc, self_exc) - call writetofile(rhor, nnr, 'vxc.dat', dfftp, 'az') - ! - ! correction for traditional use of HF without - ! reference to the EXX implementation - ! - IF (do_hf .AND. .NOT. dft_is_hybrid()) THEN - ! - rhor = rhor*(1.0d0 - hfscalfact) - exc = exc*(1.0d0 - hfscalfact) - dxc = dxc*(1.0d0 - hfscalfact) - self_exc = self_exc*(1.0d0 - hfscalfact) - ! - END IF -! -! rhor contains the xc potential in r-space -! -! =================================================================== -! fourier transform of xc potential to g-space (dense grid) -! ------------------------------------------------------------------- -! - IF (nspin == 1) THEN - iss = 1 - if (abivol .or. abisur) then -!$omp parallel do - do ir = 1, nnr - v(ir) = CMPLX(rhor(ir, iss) + v_vol(ir), 0.d0) - end do - else -!$omp parallel do - do ir = 1, nnr - v(ir) = CMPLX(rhor(ir, iss), 0.d0) - end do - end if - ! - ! v_xc(r) --> v_xc(g) - ! - CALL fwfft('Dense', v, dfftp) -! -!$omp parallel do - DO ig = 1, ng - rhog(ig, iss) = vtemp(ig) + v(np(ig)) - END DO - ! - ! v_tot(g) = (v_tot(g) - v_xc(g)) +v_xc(g) - ! rhog contains the total potential in g-space - ! - ELSE - isup = 1 - isdw = 2 - if (abivol .or. abisur) then -!$omp parallel do - do ir = 1, nnr - v(ir) = CMPLX(rhor(ir, isup) + v_vol(ir), rhor(ir, isdw) + v_vol(ir)) - end do - else -!$omp parallel do - do ir = 1, nnr - v(ir) = CMPLX(rhor(ir, isup), rhor(ir, isdw)) - end do - end if - CALL fwfft('Dense', v, dfftp) -!$omp parallel do private(fp,fm) - DO ig = 1, ng - fp = v(np(ig)) + v(nm(ig)) - fm = v(np(ig)) - v(nm(ig)) - IF (ttsic) THEN - rhog(ig, isup) = vtemp(ig) - self_vloc(ig) + 0.5d0*CMPLX(DBLE(fp), AIMAG(fm)) - rhog(ig, isdw) = vtemp(ig) + self_vloc(ig) + 0.5d0*CMPLX(AIMAG(fp), -DBLE(fm)) - ELSE - rhog(ig, isup) = vtemp(ig) + 0.5d0*CMPLX(DBLE(fp), AIMAG(fm)) - rhog(ig, isdw) = vtemp(ig) + 0.5d0*CMPLX(AIMAG(fp), -DBLE(fm)) - END IF - END DO - END IF - -! -! rhog contains now the total (local+Hartree+xc) potential in g-space -! - IF (tprnfor .OR. tfor) THEN - - IF (nlcc_any) CALL force_cc(irb, eigrb, rhor, fion1) - - CALL mp_sum(fion1, intra_image_comm) - ! - ! add g-space ionic and core correction contributions to fion - ! - fion = fion + fion1 - - END IF - - DEALLOCATE (fion1) -! - IF (ttsic) DEALLOCATE (self_vloc) -! -! =================================================================== -! fourier transform of total potential to r-space (dense grid) -! ------------------------------------------------------------------- - v(:) = (0.d0, 0.d0) - IF (nspin .EQ. 1) THEN - iss = 1 -!$omp parallel do -! IF(lgam) THEN !!!### uncomment for k points - DO ig = 1, ng - v(np(ig)) = rhog(ig, iss) - v(nm(ig)) = CONJG(rhog(ig, iss)) - END DO -! ELSE !!!### uncomment for k points -! DO ig=1,ng !!!### uncomment for k points -! v(np(ig))=rhog(ig,iss) !!!### uncomment for k points -! END DO !!!### uncomment for k points -! ENDIF !!!### uncomment for k points -! -! v(g) --> v(r) -! - CALL invfft('Dense', v, dfftp) -! -!$omp parallel do - DO ir = 1, nnr - rhor(ir, iss) = DBLE(v(ir)) - END DO -! -! calculation of average potential -! - vave = SUM(rhor(:, iss))/DBLE(nr1*nr2*nr3) - ELSE - isup = 1 - isdw = 2 -!$omp parallel do -! IF(lgam) THEN !!!### uncomment for k points - DO ig = 1, ng - v(np(ig)) = rhog(ig, isup) + ci*rhog(ig, isdw) - v(nm(ig)) = CONJG(rhog(ig, isup)) + ci*CONJG(rhog(ig, isdw)) - END DO -! ELSE !!!### uncomment for k points -! DO ig=1,ng !!!### uncomment for k points -! v(np(ig))=rhog(ig,isup)+ci*rhog(ig,isdw) !!!### uncomment for k points -! v(nm(ig))=CONJG(rhog(ig,isup)) +ci*CONJG(rhog(ig,isdw)) -! END DO !!!### uncomment for k points -! ENDIF !!!### uncomment for k points -! - CALL invfft('Dense', v, dfftp) -!$omp parallel do - DO ir = 1, nnr - rhor(ir, isup) = DBLE(v(ir)) - rhor(ir, isdw) = AIMAG(v(ir)) - END DO - ! - ! calculation of average potential - ! - vave = (SUM(rhor(:, isup)) + SUM(rhor(:, isdw)))/2.0d0/DBLE(nr1*nr2*nr3) - END IF - - CALL mp_sum(vave, intra_image_comm) - - ! - ! fourier transform of total potential to r-space (smooth grid) - ! - vs(:) = CMPLX(0.d0, 0.d0) - ! - IF (nspin .EQ. 1) THEN - ! - iss = 1 -!$omp parallel do -! IF(lgam) THEN !!!### uncomment for k points - DO ig = 1, ngs - vs(nms(ig)) = CONJG(rhog(ig, iss)) - vs(nps(ig)) = rhog(ig, iss) - END DO -! ELSE !!!### uncomment for k points -! DO ig=1,ngs !!!### uncomment for k points -! write(6,*) "debug", nps(ig), nnrsx, ig, ngs !added:giovanni:debug -! vs(nps(ig))=rhog(ig,iss) !!!### uncomment for k points -! END DO !!!### uncomment for k points -! ENDIF !!!### uncomment for k points - ! - CALL invfft('Smooth', vs, dffts) - ! -!$omp parallel do - DO ir = 1, nnrsx - rhos(ir, iss) = DBLE(vs(ir)) - END DO - ! - ELSE - ! - isup = 1 - isdw = 2 -!$omp parallel do -! IF(lgam) THEN !!!### uncomment for k points - DO ig = 1, ngs - vs(nps(ig)) = rhog(ig, isup) + ci*rhog(ig, isdw) - vs(nms(ig)) = CONJG(rhog(ig, isup)) + ci*CONJG(rhog(ig, isdw)) - END DO -! ELSE !!!### uncomment for k points -! DO ig=1,ngs !!!### uncomment for k points -! vs(nps(ig))=rhog(ig,isup)+ci*rhog(ig,isdw) !!!### uncomment for k points -! vs(nms(ig))=CONJG(rhog(ig,isup)) +ci*CONJG(rhog(ig,isdw)) -! END DO !!!### uncomment for k points -! ENDIF !!!### uncomment for k points - ! - CALL invfft('Smooth', vs, dffts) - ! -!$omp parallel do - DO ir = 1, nnrsx - rhos(ir, isup) = DBLE(vs(ir)) - rhos(ir, isdw) = AIMAG(vs(ir)) - END DO - ! - END IF - ! - - IF (dft_is_meta()) CALL vofrho_meta(v, vs) !METAGGA - - ebac = 0.0d0 - ! - eht = eh*omega + esr - eself - ! - eextfor = 0.0_DP - IF (textfor) eextfor = compute_eextfor(tau0) - ! - ! etot is the total energy ; ekin, enl were calculated in rhoofr - ! - etot = ekin + eht + epseu + enl + exc + ebac + e_hubbard + eextfor - ! - ! extra contributions - ! - if (abivol) etot = etot + P_ext*volclu - if (abisur) etot = etot + Surf_t*surfclu - ! - IF (tpre) THEN - ! - detot6 = dekin6 + dh6 + dps6 + dsr6 - ! - call mp_sum(detot6, intra_image_comm) - ! - DO k = 1, 6 - detmp(alpha(k), beta(k)) = detot6(k) - detmp(beta(k), alpha(k)) = detmp(alpha(k), beta(k)) - END DO - ! - detot = MATMUL(detmp(:, :), TRANSPOSE(ainv(:, :))) - ! - detot = detot + denl + dxc - ! - END IF - ! - ! - CALL stop_clock('vofrho') - ! - ! - IF (tpre) THEN - ! - DEALLOCATE (gagb) - ! - IF ((iprsta >= 2) .AND. (MOD(nfi - 1, iprint) == 0)) THEN - ! - WRITE (stdout, *) - WRITE (stdout, *) "From vofrho:" - WRITE (stdout, *) "cell parameters h" - WRITE (stdout, 5555) (a1(i), a2(i), a3(i), i=1, 3) - ! - WRITE (stdout, *) - WRITE (stdout, *) "derivative of e(tot)" - WRITE (stdout, 5555) ((detot(i, j), j=1, 3), i=1, 3) - WRITE (stdout, *) "kbar" - detmp = -1.0d0*MATMUL(detot, TRANSPOSE(h))/omega*au_gpa*10.0d0 - WRITE (stdout, 5555) ((detmp(i, j), j=1, 3), i=1, 3) - ! - WRITE (stdout, *) - WRITE (stdout, *) "derivative of e(kin)" - WRITE (stdout, 5555) ((dekin(i, j), j=1, 3), i=1, 3) - WRITE (stdout, *) "kbar" - detmp = -1.0d0*MATMUL(dekin, TRANSPOSE(h))/omega*au_gpa*10.0d0 - WRITE (stdout, 5555) ((detmp(i, j), j=1, 3), i=1, 3) - ! - WRITE (stdout, *) "derivative of e(h)" - WRITE (stdout, 5555) ((dh(i, j), j=1, 3), i=1, 3) - WRITE (stdout, *) "kbar" - detmp = -1.0d0*MATMUL(dh, TRANSPOSE(h))/omega*au_gpa*10.0d0 - WRITE (stdout, 5555) ((detmp(i, j), j=1, 3), i=1, 3) - ! - WRITE (stdout, *) "derivative of e(sr)" - WRITE (stdout, 5555) ((dsr(i, j), j=1, 3), i=1, 3) - WRITE (stdout, *) "kbar" - detmp = -1.0d0*MATMUL(dsr, TRANSPOSE(h))/omega*au_gpa*10.0d0 - WRITE (stdout, 5555) ((detmp(i, j), j=1, 3), i=1, 3) - ! - WRITE (stdout, *) "derivative of e(ps)" - WRITE (stdout, 5555) ((dps(i, j), j=1, 3), i=1, 3) - WRITE (stdout, *) "kbar" - detmp = -1.0d0*MATMUL(dps, TRANSPOSE(h))/omega*au_gpa*10.0d0 - WRITE (stdout, 5555) ((detmp(i, j), j=1, 3), i=1, 3) - ! - WRITE (stdout, *) "derivative of e(nl)" - WRITE (stdout, 5555) ((denl(i, j), j=1, 3), i=1, 3) - WRITE (stdout, *) "kbar" - detmp = -1.0d0*MATMUL(denl, TRANSPOSE(h))/omega*au_gpa*10.0d0 - WRITE (stdout, 5555) ((detmp(i, j), j=1, 3), i=1, 3) - ! - WRITE (stdout, *) "derivative of e(xc)" - WRITE (stdout, 5555) ((dxc(i, j), j=1, 3), i=1, 3) - WRITE (stdout, *) "kbar" - detmp = -1.0d0*MATMUL(dxc, TRANSPOSE(h))/omega*au_gpa*10.0d0 - WRITE (stdout, 5555) ((detmp(i, j), j=1, 3), i=1, 3) - END IF - END IF - - DEALLOCATE (rhotmp) - DEALLOCATE (vtemp) - DEALLOCATE (v) - DEALLOCATE (vs) - if (do_comp) then - deallocate (aux) - deallocate (rhotot) - deallocate (v0d) - deallocate (v3d) - end if - - RETURN - -5555 FORMAT(1x, f12.5, 1x, f12.5, 1x, f12.5/ & - & 1x, f12.5, 1x, f12.5, 1x, f12.5/ & - & 1x, f12.5, 1x, f12.5, 1x, f12.5//) -! - -END SUBROUTINE vofrho - -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -!----------------------------------------------------------------------- -subroutine ldaU_init -!----------------------------------------------------------------------- -! - USE constants, ONLY: autoev - use ldaU, ONLY: n_atomic_wfc, atomwfc, lda_plus_u, Hubbard_U - use ldaU, ONLY: Hubbard_lmax, Hubbard_l, ns, ns_c, vupsi - use input_parameters, ONLY: atom_label, lda_plus_u_ => lda_plus_u - use input_parameters, ONLY: Hubbard_U_ => Hubbard_U - use ions_base, only: na, nsp, nat - use gvecw, only: ngw - use electrons_base, only: nspin, nx => nbspx - USE uspp_param, ONLY: upf - USE control_flags, ONLY: gamma_only, do_wf_cmplx - ! - implicit none - integer is, nb, l - integer, external :: set_Hubbard_l - logical :: lgam - - lgam = gamma_only .and. .not. do_wf_cmplx -! allocate vupsi - lda_plus_u = lda_plus_u_ - - allocate (vupsi(ngw, nx)) - - vupsi = (0.0d0, 0.0d0) - ! allocate(vpsi_con(ngw,nx)) ! step_constraint - n_atomic_wfc = 0 - - do is = 1, nsp - ! - Hubbard_U(is) = Hubbard_U_(is)/autoev - ! - do nb = 1, upf(is)%nwfc - l = upf(is)%lchi(nb) - n_atomic_wfc = n_atomic_wfc + (2*l + 1)*na(is) - end do - ! - end do -! - allocate (atomwfc(ngw, n_atomic_wfc)) - - if (lda_plus_u) then - Hubbard_lmax = -1 - do is = 1, nsp - if (Hubbard_U(is) .ne. 0.d0) then -! Hubbard_l(is)=2 - Hubbard_l(is) = set_Hubbard_l(atom_label(is)) - Hubbard_lmax = max(Hubbard_lmax, Hubbard_l(is)) - write (6, *) ' HUBBARD L FOR TYPE ', atom_label(is), ' IS ',& - & Hubbard_l(is) - end if - end do - write (6, *) ' MAXIMUM HUBBARD L IS ', Hubbard_lmax - if (Hubbard_lmax .eq. -1) call errore & - & ('setup', 'lda_plus_u calculation but Hubbard_l not set', 1) - end if - l = 2*Hubbard_lmax + 1 - ! - IF (lgam) THEN - allocate (ns(nat, nspin, l, l)) - ELSE - allocate (ns_c(nat, nspin, l, l)) - END IF - ! - return -end subroutine ldaU_init -! -!----------------------------------------------------------------------- -subroutine nksic_init -!----------------------------------------------------------------------- -! - ! - ! this routine is called anyway, even if do_nk=F - ! - use nksic, ONLY: do_orbdep, do_nk, do_nkipz, do_nkpz, do_pz, & - do_nki, do_bare_eigs, do_pz_renorm, kfact, & - do_wref, do_wxd, fref, rhobarfact, & - vanishing_rho_w, & - nknmax, do_spinsym, f_cutoff, & - nkscalfact, nksic_memusage, allocate_nksic, odd_alpha -!$$ - use nksic, only: do_innerloop, do_innerloop_empty, do_innerloop_cg, & - innerloop_dd_nstep, & - innerloop_cg_nsd, innerloop_cg_nreset, innerloop_nmax, & - innerloop_cg_ratio, innerloop_init_n, innerloop_until, & - innerloop_atleast, l_comp_cmplxfctn_index -!$$ - use input_parameters, ONLY: do_nk_ => do_nk, & - do_pz_ => do_pz, & - do_nki_ => do_nki, & - do_nkpz_ => do_nkpz, & - do_nkipz_ => do_nkipz, & - do_hf_ => do_hf, & - which_orbdep_ => which_orbdep, & - fref_ => fref, & - rhobarfact_ => rhobarfact, & - vanishing_rho_w_ => vanishing_rho_w, & - do_wref_ => do_wref, & - do_wxd_ => do_wxd, & - do_spinsym_ => do_spinsym, & - nkscalfact_ => nkscalfact, & - nknmax_ => nknmax, & - f_cutoff_ => f_cutoff, & - do_orbdep_ => do_orbdep, & - l_comp_cmplxfctn_index_ => l_comp_cmplxfctn_index -!$$ - use input_parameters, only: do_innerloop_ => do_innerloop, & - do_innerloop_empty_ => do_innerloop_empty, & - do_innerloop_cg_ => do_innerloop_cg, & - innerloop_dd_nstep_ => innerloop_dd_nstep, & - innerloop_cg_nsd_ => innerloop_cg_nsd, & - innerloop_cg_nreset_ => innerloop_cg_nreset, & - innerloop_nmax_ => innerloop_nmax, & - innerloop_init_n_ => innerloop_init_n, & - innerloop_atleast_ => innerloop_atleast, & - innerloop_cg_ratio_ => innerloop_cg_ratio, & - innerloop_until_ => innerloop_until, & - do_pz_renorm_ => do_pz_renorm, & - do_bare_eigs_ => do_bare_eigs, & - kfact_ => kfact -!$$ - USE io_global, ONLY: meta_ionode, stdout - use electrons_base, ONLY: nspin, nbspx - use gvecw, ONLY: ngw - use grid_dimensions, ONLY: nnrx - USE ions_base, ONLY: nat - ! - implicit none - ! - logical :: found, do_hybrid = .FALSE. - integer :: i - character(10) :: subname = 'nksic_init' - character(1), external :: lowercase - - ! - ! overwriten by which_orbdep, if not empty - ! - do_nk = do_nk_ - do_pz = do_pz_ - do_nki = do_nki_ - do_nkpz = do_nkpz_ - do_nkipz = do_nkipz_ - ! - do_wxd = do_wxd_ - do_wref = do_wref_ - do_pz_renorm = do_pz_renorm_ - do_bare_eigs = do_bare_eigs_ - kfact = kfact_ - ! - fref = fref_ -!$$ - do_innerloop = do_innerloop_ - do_innerloop_empty = do_innerloop_empty_ - l_comp_cmplxfctn_index = l_comp_cmplxfctn_index_ - do_innerloop_cg = do_innerloop_cg_ - innerloop_dd_nstep = innerloop_dd_nstep_ - innerloop_cg_nsd = innerloop_cg_nsd_ - innerloop_cg_nreset = innerloop_cg_nreset_ - innerloop_nmax = innerloop_nmax_ - innerloop_init_n = innerloop_init_n_ - innerloop_atleast = innerloop_atleast_ - innerloop_cg_ratio = innerloop_cg_ratio_ - innerloop_until = innerloop_until_ -!$$ - ! - ! use the collective var which_orbdep - ! - DO i = 1, LEN_TRIM(which_orbdep_) - which_orbdep_(i:i) = lowercase(which_orbdep_(i:i)) - END DO - ! - SELECT CASE (TRIM(which_orbdep_)) - CASE ("", "none") - ! do nothing - CASE ("hf", "b3lyp", "pbe0") - do_hybrid = .TRUE. - CASE ("nk", "non-koopmans") - do_nk = .TRUE. - do_wref = .TRUE. - do_wxd = .TRUE. - CASE ("nk0") - do_nk = .TRUE. - do_wref = .FALSE. - do_wxd = .FALSE. - CASE ("nki") - do_nki = .TRUE. - do_wxd = .TRUE. - fref = 1.0 - CASE ("pz", "perdew-zunger") - do_pz = .TRUE. - CASE ("nkpz", "pznk") - do_nkpz = .TRUE. - CASE ("nkipz", "pznki") - do_nkipz = .TRUE. - do_wxd = .TRUE. - fref = 1.0 - CASE DEFAULT - call errore(subname, "invalid which_orbdep = "//TRIM(which_orbdep_), 10) - END SELECT - ! - IF (.NOT. do_hybrid .AND. do_hf_) do_hybrid = .TRUE. - ! - do_orbdep = do_orbdep_ .and. .not. do_hybrid - - found = .FALSE. - ! - IF (do_orbdep) THEN - ! - if (do_nk .or. do_pz .or. do_nki .or. do_nkpz .or. do_nkipz .or. do_hybrid) found = .true. - ! - if (.not. found) CALL errore(subname, 'no compatible orbital-dependent scheme specified', 1) - ! - END IF - ! - ! - ! check only one orbital dependent scheme is used - ! - found = .FALSE. - ! - if (do_nk .and. (do_pz .or. do_nki .or. do_nkpz .or. do_nkipz)) found = .TRUE. - if (do_nki .and. (do_pz .or. do_nk .or. do_nkpz .or. do_nkipz)) found = .TRUE. - if (do_pz .and. (do_nk .or. do_nki .or. do_nkpz .or. do_nkipz)) found = .TRUE. - if (do_nkpz .and. (do_nk .or. do_nki .or. do_pz .or. do_nkipz)) found = .TRUE. - if (do_nkipz .and. (do_nk .or. do_nki .or. do_pz .or. do_nkpz)) found = .TRUE. - ! - if (found) CALL errore(subname, 'more than one orb-dependent schme used', 1) - ! - do_spinsym = do_spinsym_ - vanishing_rho_w = vanishing_rho_w_ - rhobarfact = rhobarfact_ - nkscalfact = nkscalfact_ - nknmax = nknmax_ - f_cutoff = f_cutoff_ - ! - if (do_nki .and. fref /= 1.0) CALL errore(subname, 'nki and fref /= 1.0 ', 1) - ! - if ((do_nk .or. do_nkpz) .and. meta_ionode) then - write (stdout, 2000) fref - write (stdout, 2004) rhobarfact, nkscalfact - else if (do_pz .and. meta_ionode) then - write (stdout, 2001) do_pz - else if ((do_nki .or. do_nkipz) .and. meta_ionode) then - write (stdout, 2002) do_nki - write (stdout, 2004) rhobarfact, nkscalfact - end if - ! - ! read referece alpha from file, if any | linh - ! wherein, the information of n_evc0_fixed, ref_alpha0, - ! broadening of orbitals will be readed. - ! - ! call readfile_refalpha() - ! - if (do_orbdep .and. .not. do_hybrid) call allocate_nksic(nnrx, ngw, nspin, nbspx, nat) - ! - if (do_orbdep) odd_alpha(:) = 1.d0 - ! - if ((do_nk .or. do_nkpz) .and. meta_ionode) then - write (stdout, 2010) do_wxd, do_wref, do_nkpz - end if - ! - if (do_orbdep .and. meta_ionode .and. .not. do_hybrid) then - ! - write (stdout, 2005) vanishing_rho_w - if (nknmax > 0) write (stdout, 2030) nknmax - ! - write (stdout, "(3x, 'NK memusage = ', f10.3, ' MB', /)") & - nksic_memusage() - end if - ! - if (do_orbdep .and. innerloop_until < 1) then - ! - innerloop_until = -1 - ! - end if - ! - if (meta_ionode) then - ! - write (stdout, "()") - write (stdout, 2006) f_cutoff, do_spinsym - ! - end if - ! -2000 format(3X, 'NK sic with reference occupation = ', f7.4,/) -2001 format(3X, 'PZ sic = ', l4,/) -2002 format(3X, 'NK sic with integral ref = ', l4,/) -2004 format(3X, 'NK background density factor = ', f7.4, /, & - 3X, 'NK scaling factor = ', f7.4) -2005 format(3X, 'rhothr = ', e8.1) -2006 format(3X, 'f_cutoff = ', f7.4, /, & - 3X, 'do_spinsym = ', l4) -2010 format(3X, 'NK cross-derivatives = ', l4, /, & - 3X, 'NK reference derivatives = ', l4, /, & - 3X, 'NK on top of PZ = ', l4) -2030 format(3X, 'NK applied up to orbital', i7) - -end subroutine nksic_init - -!----------------------------------------------------------------------- -subroutine hf_init -!----------------------------------------------------------------------- -! subroutine introduced by Giovanni Borghi and Andrea Ferretti, -! following Li, Y. and Dabo, I. -! Electronic levels and electrical response of -! periodic molecular structures from plane-wave -! orbital-dependent calculations. -! Physical Review B 84, 155127 (2011) -! - use hfmod, only: do_hf, hfscalfact, allocate_hf - use nksic, only: f_cutoff - use input_parameters, only: do_hf_ => do_hf, & - which_orbdep_ => which_orbdep, & - hfscalfact_ => hfscalfact, & - f_cutoff_ => f_cutoff - use io_global, only: meta_ionode, stdout - use electrons_base, only: nspin, nbspx - use gvecw, only: ngw - use grid_dimensions, only: nnrx - use funct, only: start_exx, set_dft_from_name, dft_is_hybrid - ! - implicit none - ! - logical :: ishybrid = .false. - character(30) :: dft_name - - do_hf = do_hf_ - hfscalfact = hfscalfact_ - f_cutoff = f_cutoff_ - ! - SELECT CASE (TRIM(which_orbdep_)) - CASE ("hf") - ! - do_hf = .TRUE. - ishybrid = .TRUE. - ! - CASE ("b3lyp") - ! - do_hf = .TRUE. - hfscalfact = 0.20 - ! - CASE ("pbe0") - ! - do_hf = .TRUE. - hfscalfact = 0.25 - ! - END SELECT - ! - IF (do_hf) ishybrid = .TRUE. - ! - IF (ishybrid) THEN - ! - dft_name = TRIM(which_orbdep_) - IF (LEN_TRIM(dft_name) == 0 .AND. do_hf) dft_name = "hf" - ! - CALL set_dft_from_name(dft_name) - ! - IF (meta_ionode) & - WRITE (stdout, fmt="(/,3X,'Warning XC functionals forced to be: ',A)") dft_name - ! - CALL start_exx() - ! - END IF - - ! - ! - if (do_hf .and. meta_ionode) then - ! - write (stdout, "( 3X,'HF scaling factor = ',f7.4 )") hfscalfact - write (stdout, "( 3X,' f_cutoff = ',f7.4 )") f_cutoff - write (stdout, "( 3X,' dft_is_hybrid = ',l5 )") dft_is_hybrid() - ! - end if - ! - ! allocations - ! - if (do_hf) call allocate_hf(ngw, nnrx, nspin, nbspx) - ! -end subroutine hf_init - -!----------------------------------------------------------------------- -subroutine ee_init -!----------------------------------------------------------------------- -! - use eecp_mod, only: do_comp, which_compensation, allocate_ee, & - tcc_odd - use input_parameters, only: do_ee, & - which_compensation_ => which_compensation, & - tcc_odd_ => tcc_odd - use io_global, only: meta_ionode, stdout - use grid_dimensions, only: nnrx - use reciprocal_vectors, only: ngm - ! - implicit none - ! - do_comp = do_ee - which_compensation = which_compensation_ - tcc_odd = tcc_odd_ - if (do_comp .and. meta_ionode) write (stdout, 2010) which_compensation - ! -2010 format(3X, 'EE with periodic-image correction method = ', a20) - ! - if (do_comp) call allocate_ee(nnrx, ngm) - ! -end subroutine ee_init - -!----------------------------------------------------------------------- -subroutine efield_init -!----------------------------------------------------------------------- -! - use efield_mod, only: do_efield, ampfield, allocate_efield - use input_parameters, only: do_efield_ => do_efield, & - ampfield_ => ampfield - use io_global, only: meta_ionode, stdout - use grid_dimensions, only: nnrx - use reciprocal_vectors, only: ngm - ! - implicit none - ! - do_efield = do_efield_ - ampfield = ampfield_ - if (do_efield .and. meta_ionode) write (stdout, 2015) ampfield -2015 format(3X, 'EFIELD with field = ', 3f7.4) - ! - if (do_efield) call allocate_efield(nnrx, ngm) - ! -end subroutine efield_init -! -!----------------------------------------------------------------------- -integer function set_Hubbard_l(psd) result(hubbard_l) - !----------------------------------------------------------------------- - ! - implicit none - character*3 :: psd - ! - ! TRANSITION METALS - ! - if (psd .eq. 'V' .or. psd .eq. 'Cr' .or. psd .eq. 'Mn' .or. psd .eq. 'Fe' .or. & - psd .eq. 'Co' .or. psd .eq. 'Ni' .or. psd .eq. 'Cu' .or. psd .eq. 'Fe1' .or. & - psd .eq. 'Fe2') then - hubbard_l = 2 - ! - ! RARE EARTHS - ! - elseif (psd .eq. 'Ce') then - hubbard_l = 3 - ! - ! OTHER ELEMENTS - ! - elseif (psd .eq. 'H') then - hubbard_l = 0 - elseif (psd .eq. 'O') then - hubbard_l = 1 - else - hubbard_l = -1 - call errore('set_Hubbard_l', 'pseudopotential not yet inserted', 1) - end if - return -end function set_Hubbard_l -! -!----------------------------------------------------------------------- -subroutine new_ns_real(c, eigr, betae, hpsi, hpsi_con, forceh) - !----------------------------------------------------------------------- - ! - ! This routine computes the on site occupation numbers of the Hubbard ions. - ! It also calculates the contribution of the Hubbard Hamiltonian to the - ! electronic potential and to the forces acting on ions. - ! - use control_flags, ONLY: tfor, tprnfor - use kinds, ONLY: DP - use ions_base, only: na, nat, nsp - use gvecw, only: ngw - USE uspp, ONLY: nhsa => nkb - USE uspp_param, ONLY: upf - use electrons_base, only: nspin, n => nbsp, nx => nbspx, ispin, f - USE ldaU, ONLY: Hubbard_U, Hubbard_l - USE ldaU, ONLY: n_atomic_wfc, ns, e_hubbard - USE cp_interfaces, ONLY: nlsm1, projwfc_hub, s_wfc !added:giovanni -! - implicit none -#ifdef __PARA - include 'mpif.h' -#endif - integer, parameter :: ldmx = 7 - complex(DP), intent(in) :: c(ngw, nx), eigr(ngw, nat), betae(ngw, nhsa) - complex(DP), intent(out) :: hpsi(ngw, nx), hpsi_con(1, 1) - real(DP) forceh(3, nat) - complex(DP), allocatable:: wfc(:, :), swfc(:, :), dphi(:, :, :), spsi(:, :) - real(DP), allocatable :: becwfc(:, :), bp(:, :), dbp(:, :, :), wdb(:, :, :) - real(DP), allocatable :: dns(:, :, :, :) - real(DP), allocatable :: e(:), z(:, :), proj(:, :), temp(:) - real(DP), allocatable :: ftemp1(:), ftemp2(:) - real(DP) :: lambda(ldmx), somma, ntot, nsum, & - & nsuma, x_value, g_value, step_value - real(DP) :: f1(ldmx, ldmx), vet(ldmx, ldmx) - integer is, ia, iat, nb, isp, l, m, m1, m2, k, i, counter, err, ig - integer iv, jv, inl, jnl, alpha, alpha_a, alpha_s, ipol - integer, allocatable :: offset(:, :) - complex(DP) :: tempsi - allocate (wfc(ngw, n_atomic_wfc)) - allocate (ftemp1(ldmx)) - allocate (ftemp2(ldmx)) -! -! calculate wfc = atomic states -! -!!! call ewfc(eigr,n_atomic_wfc,wfc) -! -! calculate bec = -! - allocate (becwfc(nhsa, n_atomic_wfc)) -!!! call nlsm1 (n_atomic_wfc,1,nsp,eigr,wfc,becwfc) -! - allocate (swfc(ngw, n_atomic_wfc)) -!!! call s_wfc(n_atomic_wfc,becwfc,betae,wfc,swfc) -! -! calculate proj = -! - allocate (proj(n, n_atomic_wfc)) - CALL projwfc_hub(c, nx, eigr, betae, n, n_atomic_wfc, & - & wfc, becwfc, swfc, proj) !@@ -! - allocate (offset(nsp, nat)) - counter = 0 - do is = 1, nsp - do ia = 1, na(is) - do i = 1, upf(is)%nwfc - l = upf(is)%lchi(i) - if (l .eq. Hubbard_l(is)) offset(is, ia) = counter - counter = counter + 2*l + 1 - end do - end do - end do - if (counter .ne. n_atomic_wfc) & - & call errore('new_ns', 'nstart<>counter', 1) - ns(:, :, :, :) = 0.d0 - iat = 0 - do is = 1, nsp - do ia = 1, na(is) - iat = iat + 1 - if (Hubbard_U(is) .ne. 0.d0) then - k = offset(is, ia) - do m1 = 1, 2*Hubbard_l(is) + 1 - do m2 = m1, 2*Hubbard_l(is) + 1 - do i = 1, n -! write(6,*) i,ispin(i),f(i) - ns(iat, ispin(i), m1, m2) = ns(iat, ispin(i), m1, m2) + & - & f(i)*proj(i, k + m2)*proj(i, k + m1) - end do -! ns(iat,:,m2,m1) = ns(iat,:,m1,m2) - ns(iat, 1, m2, m1) = ns(iat, 1, m1, m2) - ns(iat, 2, m2, m1) = ns(iat, 2, m1, m2) - end do - end do - end if - end do - end do - if (nspin .eq. 1) ns = 0.5d0*ns -! Contributions to total energy - e_hubbard = 0.d0 - iat = 0 - do is = 1, nsp - do ia = 1, na(is) - iat = iat + 1 - if (Hubbard_U(is) .ne. 0.d0) then - k = offset(is, ia) - do isp = 1, nspin - do m1 = 1, 2*Hubbard_l(is) + 1 - e_hubbard = e_hubbard + 0.5d0*Hubbard_U(is)* & - & ns(iat, isp, m1, m1) - do m2 = 1, 2*Hubbard_l(is) + 1 - e_hubbard = e_hubbard - 0.5d0*Hubbard_U(is)* & - & ns(iat, isp, m1, m2)*ns(iat, isp, m2, m1) - end do - end do - end do - end if - end do - end do - if (nspin .eq. 1) e_hubbard = 2.d0*e_hubbard -! if (nspin.eq.1) e_lambda = 2.d0*e_lambda -! -! Calculate the potential and forces on wavefunctions due to U -! - hpsi(:, :) = CMPLX(0.d0, 0.d0) - iat = 0 - do is = 1, nsp - do ia = 1, na(is) - iat = iat + 1 - if (Hubbard_U(is) .ne. 0.d0) then - do i = 1, n - do m1 = 1, 2*Hubbard_l(is) + 1 - tempsi = proj(i, offset(is, ia) + m1) - do m2 = 1, 2*Hubbard_l(is) + 1 - tempsi = tempsi - 2.d0*ns(iat, ispin(i), m1, m2)*& - & proj(i, offset(is, ia) + m2) - end do - tempsi = tempsi*Hubbard_U(is)/2.d0*f(i) - call ZAXPY(ngw, tempsi, swfc(1, offset(is, ia) + m1), 1, & - & hpsi(1, i), 1) - end do - end do - end if - end do - end do -! -! Calculate the potential and energy due to constraint -! - hpsi_con(:, :) = 0.d0 -! -! Calculate the contribution to forces on ions due to U and constraint -! - forceh = 0.d0 - if ((tfor) .or. (tprnfor)) then - allocate (bp(nhsa, n), dbp(nhsa, n, 3), wdb(nhsa, n_atomic_wfc, 3)) - allocate (dns(nat, nspin, ldmx, ldmx)) - allocate (spsi(ngw, n)) -! - call nlsm1(n, 1, nsp, eigr, c, bp) - call s_wfc(n, bp, betae, c, spsi) - call nlsm2_repl(ngw, nhsa, n, eigr, c, dbp) - call nlsm2_repl(ngw, nhsa, n_atomic_wfc, eigr, wfc, wdb) -! - alpha = 0 - do alpha_s = 1, nsp - do alpha_a = 1, na(alpha_s) - alpha = alpha + 1 - do ipol = 1, 3 - call dndtau_real(alpha_a, alpha_s, becwfc, spsi, bp, dbp, wdb, & - & offset, c, wfc, eigr, betae, proj, ipol, dns) - iat = 0 - do is = 1, nsp - do ia = 1, na(is) - iat = iat + 1 - if (Hubbard_U(is) .ne. 0.d0) then - do isp = 1, nspin - do m2 = 1, 2*Hubbard_l(is) + 1 - forceh(ipol, alpha) = forceh(ipol, alpha) - & - & Hubbard_U(is)*0.5d0*dns(iat, isp, m2, m2) - do m1 = 1, 2*Hubbard_l(is) + 1 - forceh(ipol, alpha) = forceh(ipol, alpha) + & - & Hubbard_U(is)*ns(iat, isp, m2, m1)* & - & dns(iat, isp, m1, m2) - end do - end do - end do - end if -! Occupation constraint add here - end do - end do - end do - end do - end do - if (nspin .eq. 1) then - forceh = 2.d0*forceh - end if -! - deallocate (wfc, becwfc, spsi, proj, offset, swfc, dns, bp, dbp, wdb) - end if - return -end subroutine new_ns_real -! -! -!----------------------------------------------------------------------- -subroutine new_ns_twin(c, eigr, betae, hpsi, hpsi_con, forceh, lgam) -!----------------------------------------------------------------------- -! -! This routine computes the on site occupation numbers of the Hubbard ions. -! It also calculates the contribution of the Hubbard Hamiltonian to the -! electronic potential and to the forces acting on ions. -! - use control_flags, ONLY: tfor, tprnfor - use kinds, ONLY: DP - use ions_base, only: na, nat, nsp - use gvecw, only: ngw - use reciprocal_vectors, only: ng0 => gstart - USE uspp, ONLY: nhsa => nkb - USE uspp_param, ONLY: upf - use electrons_base, only: nspin, n => nbsp, nx => nbspx, ispin, f - USE ldaU, ONLY: lda_plus_u, Hubbard_U, Hubbard_l - USE ldaU, ONLY: n_atomic_wfc, ns, ns_c, e_hubbard - USE cp_interfaces, ONLY: nlsm1, projwfc_hub, s_wfc !added:giovanni - USE twin_types -! - implicit none -#ifdef __PARA - include 'mpif.h' -#endif - integer, parameter :: ldmx = 7 - complex(DP), intent(in) :: c(ngw, nx), eigr(ngw, nat), & - & betae(ngw, nhsa) - complex(DP), intent(out) :: hpsi(ngw, nx), hpsi_con(1, 1) - real(DP) forceh(3, nat) - logical :: lgam -! - complex(DP), allocatable:: wfc(:, :), swfc(:, :), dphi(:, :, :), & - & spsi(:, :) - type(twin_matrix) :: bp - type(twin_tensor) :: dbp, wdb - type(twin_matrix) :: becwfc - real(DP), allocatable :: dns(:, :, :, :) - complex(DP), allocatable :: dns_c(:, :, :, :) - real(DP), allocatable :: e(:), z(:, :), & - & temp(:) - type(twin_matrix) :: proj - real(DP), allocatable :: ftemp1(:), ftemp2(:) - real(DP) :: lambda(ldmx), somma, ntot, nsum, & - & nsuma, x_value, g_value, step_value - real(DP) :: f1(ldmx, ldmx), vet(ldmx, ldmx) - integer is, ia, iat, nb, isp, l, m, m1, m2, k, i, counter, err, ig - integer iv, jv, inl, jnl, alpha, alpha_a, alpha_s, ipol - integer, allocatable :: offset(:, :) - complex(DP) :: tempsi -! -! - allocate (wfc(ngw, n_atomic_wfc)) - allocate (ftemp1(ldmx)) - allocate (ftemp2(ldmx)) -! -! calculate wfc = atomic states -! -!!! call ewfc(eigr,n_atomic_wfc,wfc) -! -! calculate bec = -! - call init_twin(becwfc, lgam) - call allocate_twin(becwfc, nhsa, n_atomic_wfc, lgam) -!!! call nlsm1 (n_atomic_wfc,1,nsp,eigr,wfc,becwfc) -! - allocate (swfc(ngw, n_atomic_wfc)) -!!! call s_wfc(n_atomic_wfc,becwfc,betae,wfc,swfc) -! -! calculate proj = -! - call init_twin(proj, lgam) - call allocate_twin(proj, n, n_atomic_wfc, lgam) - - CALL projwfc_hub(c, nx, eigr, betae, n, n_atomic_wfc, & - & wfc, becwfc, swfc, proj, lgam) !@@ -! - allocate (offset(nsp, nat)) - counter = 0 - do is = 1, nsp - do ia = 1, na(is) - do i = 1, upf(is)%nwfc - l = upf(is)%lchi(i) - if (l .eq. Hubbard_l(is)) offset(is, ia) = counter - counter = counter + 2*l + 1 - end do - end do - end do - if (counter .ne. n_atomic_wfc) & - & call errore('new_ns', 'nstart<>counter', 1) - ns(:, :, :, :) = 0.d0 - iat = 0 - do is = 1, nsp - do ia = 1, na(is) - iat = iat + 1 - if (Hubbard_U(is) .ne. 0.d0) then - k = offset(is, ia) - do m1 = 1, 2*Hubbard_l(is) + 1 - do m2 = m1, 2*Hubbard_l(is) + 1 - IF (lgam) THEN - do i = 1, n - ! write(6,*) i,ispin(i),f(i) - ns(iat, ispin(i), m1, m2) = ns(iat, ispin(i), m1, m2) + & - & f(i)*proj%rvec(i, k + m2)*proj%rvec(i, k + m1) - end do -! ns(iat,:,m2,m1) = ns(iat,:,m1,m2) - ns(iat, 1, m2, m1) = ns(iat, 1, m1, m2) - ns(iat, 2, m2, m1) = ns(iat, 2, m1, m2) - ELSE - do i = 1, n - ! write(6,*) i,ispin(i),f(i) - ns_c(iat, ispin(i), m1, m2) = ns_c(iat, ispin(i), m1, m2) + & - & f(i)*proj%cvec(i, k + m2)* & - CONJG(proj%cvec(i, k + m1)) - end do -! ns(iat,:,m2,m1) = ns(iat,:,m1,m2) - ns_c(iat, 1, m2, m1) = CONJG(ns_c(iat, 1, m1, m2)) - ns_c(iat, 2, m2, m1) = CONJG(ns_c(iat, 2, m1, m2)) - END IF - end do - end do - end if - end do - end do - if (nspin .eq. 1) THEN - IF (lgam) THEN - ns = 0.5d0*ns - ELSE - ns_c = 0.5d0*ns_c - END IF - END IF -! Contributions to total energy - e_hubbard = 0.d0 - iat = 0 - do is = 1, nsp - do ia = 1, na(is) - iat = iat + 1 - if (Hubbard_U(is) .ne. 0.d0) then - k = offset(is, ia) - do isp = 1, nspin - IF (lgam) THEN - do m1 = 1, 2*Hubbard_l(is) + 1 - e_hubbard = e_hubbard + 0.5d0*Hubbard_U(is)* & - & ns(iat, isp, m1, m1) - do m2 = 1, 2*Hubbard_l(is) + 1 - e_hubbard = e_hubbard - 0.5d0*Hubbard_U(is)* & - & ns(iat, isp, m1, m2)*ns(iat, isp, m2, m1) - end do - end do - ELSE - do m1 = 1, 2*Hubbard_l(is) + 1 - e_hubbard = e_hubbard + 0.5d0*Hubbard_U(is)* & - & DBLE(ns_c(iat, isp, m1, m1)) - do m2 = 1, 2*Hubbard_l(is) + 1 - e_hubbard = e_hubbard - 0.5d0*Hubbard_U(is)* & - & DBLE(ns_c(iat, isp, m1, m2)*ns_c(iat, isp, m2, m1)) - end do - end do - END IF - end do - end if - end do - end do - if (nspin .eq. 1) e_hubbard = 2.d0*e_hubbard -! if (nspin.eq.1) e_lambda = 2.d0*e_lambda -! -! Calculate the potential and forces on wavefunctions due to U -! - hpsi(:, :) = CMPLX(0.d0, 0.d0) - iat = 0 - do is = 1, nsp - do ia = 1, na(is) - iat = iat + 1 - if (Hubbard_U(is) .ne. 0.d0) then - IF (lgam) THEN - do i = 1, n - do m1 = 1, 2*Hubbard_l(is) + 1 - tempsi = proj%rvec(i, offset(is, ia) + m1) - do m2 = 1, 2*Hubbard_l(is) + 1 - tempsi = tempsi - 2.d0*ns(iat, ispin(i), m1, m2)*& - & proj%rvec(i, offset(is, ia) + m2) - end do - tempsi = tempsi*Hubbard_U(is)/2.d0*f(i) - call ZAXPY(ngw, tempsi, swfc(1, offset(is, ia) + m1), 1, & - & hpsi(1, i), 1) - end do - end do - ELSE - do i = 1, n - do m1 = 1, 2*Hubbard_l(is) + 1 - tempsi = proj%cvec(i, offset(is, ia) + m1) - do m2 = 1, 2*Hubbard_l(is) + 1 - tempsi = tempsi - 2.d0*ns_c(iat, ispin(i), m1, m2)*& - & proj%cvec(i, offset(is, ia) + m2) - end do - tempsi = tempsi*Hubbard_U(is)/2.d0*f(i) - call ZAXPY(ngw, tempsi, swfc(1, offset(is, ia) + m1), 1, & - & hpsi(1, i), 1) - end do - end do - END IF - end if - end do - end do -! -! Calculate the potential and energy due to constraint -! - hpsi_con(:, :) = 0.d0 -! -! Calculate the contribution to forces on ions due to U and constraint -! - forceh = 0.d0 - if ((tfor) .or. (tprnfor)) then - call init_twin(bp, lgam) - call allocate_twin(bp, nhsa, n, lgam) - call init_twin(dbp, lgam) - call allocate_twin(dbp, nhsa, n, 3, lgam) - call init_twin(wdb, lgam) - call allocate_twin(wdb, nhsa, n_atomic_wfc, 3, lgam) - - IF (lgam) THEN - allocate (dns(nat, nspin, ldmx, ldmx)) - ELSE - allocate (dns_c(nat, nspin, ldmx, ldmx)) - END IF - ! - allocate (spsi(ngw, n)) -! - call nlsm1(n, 1, nsp, eigr, c, bp, 1, lgam) - call s_wfc(n, bp, betae, c, spsi, lgam) - call nlsm2_repl(ngw, nhsa, n, eigr, c, dbp) - call nlsm2_repl(ngw, nhsa, n_atomic_wfc, eigr, wfc, wdb) -! - alpha = 0 - do alpha_s = 1, nsp - do alpha_a = 1, na(alpha_s) - alpha = alpha + 1 - do ipol = 1, 3 - IF (lgam) THEN - call dndtau_real(alpha_a, alpha_s, becwfc%rvec, spsi, bp%rvec, dbp%rvec, wdb%rvec, & - & offset, c, wfc, eigr, betae, proj%rvec, ipol, dns) - ELSE - call dndtau_cmplx(alpha_a, alpha_s, becwfc%cvec, spsi, bp%cvec, dbp%cvec, wdb%cvec, & - & offset, c, wfc, eigr, betae, proj%cvec, ipol, dns_c) - END IF - iat = 0 - do is = 1, nsp - do ia = 1, na(is) - iat = iat + 1 - if (Hubbard_U(is) .ne. 0.d0) then - do isp = 1, nspin - IF (lgam) THEN - do m2 = 1, 2*Hubbard_l(is) + 1 - forceh(ipol, alpha) = forceh(ipol, alpha) - & - & Hubbard_U(is)*0.5d0*dns(iat, isp, m2, m2) - do m1 = 1, 2*Hubbard_l(is) + 1 - forceh(ipol, alpha) = forceh(ipol, alpha) + & - & Hubbard_U(is)*ns(iat, isp, m2, m1)* & - & dns(iat, isp, m1, m2) - end do - end do - ELSE - do m2 = 1, 2*Hubbard_l(is) + 1 - forceh(ipol, alpha) = forceh(ipol, alpha) - & - & Hubbard_U(is)*0.5d0*DBLE(dns_c(iat, isp, m2, m2)) - do m1 = 1, 2*Hubbard_l(is) + 1 - forceh(ipol, alpha) = forceh(ipol, alpha) + & - & Hubbard_U(is)*DBLE(ns_c(iat, isp, m2, m1)* & - & dns_c(iat, isp, m1, m2)) - end do - end do - END IF - end do - end if -! Occupation constraint add here - end do - end do - end do - end do - end do - if (nspin .eq. 1) then - forceh = 2.d0*forceh - end if -! - deallocate (wfc, spsi, offset, swfc) - - call deallocate_twin(becwfc) - call deallocate_twin(proj) - call deallocate_twin(bp) - call deallocate_twin(dbp) - call deallocate_twin(wdb) - - IF (allocated(dns)) deallocate (dns) - IF (allocated(dns_c)) deallocate (dns_c) - ! - end if - return -end subroutine new_ns_twin -! - -!----------------------------------------------------------------------- -subroutine write_ns -!----------------------------------------------------------------------- -! -! This routine computes the occupation numbers on atomic orbitals. -! It also write the occupation number in the output file. -! - USE kinds, only: DP - USE constants, ONLY: autoev - use electrons_base, only: nspin - use electrons_base, only: n => nbsp - use ions_base, only: na, nat, nsp - use gvecw, only: ngw - USE ldaU, ONLY: lda_plus_u, Hubbard_U, Hubbard_l - USE ldaU, ONLY: n_atomic_wfc, ns, e_hubbard - USE ldaU, ONLY: Hubbard_lmax - use dspev_module, only: dspev_drv - - implicit none - - integer :: is, isp, ia, m1, m2, ldim, iat, err, k -! cpunter on atoms type -! counter on spin component -! counter on atoms -! counter on wavefn -! counters on d components - integer, parameter :: ldmx = 7 - real(DP), allocatable :: ftemp1(:), ftemp2(:) - real(DP) :: f1(ldmx*ldmx), vet(ldmx, ldmx) - real(DP) :: lambda(ldmx), nsum, nsuma - write (*, *) 'enter write_ns' - - if (2*Hubbard_lmax + 1 .gt. ldmx) & - call errore('write_ns', 'ldmx is too small', 1) - -! if (step_con) then -! do isp=1,nspin -! write (6,'(6(a,i2,a,i2,a,f8.4,6x))') & -! ('A_con(',is,',',isp,') =', A_con(is,isp),is=1,nsp) -! enddo -! write (6,'(6(a,i2,a,f8.4,6x))') & -! ('sigma_con(',is,') =', sigma_con(is), is=1,nsp) -! write (6,'(6(a,i2,a,f8.4,6x))') & -! ('alpha_con(',is,') =', alpha_con(is), is=1,nsp) -! endif - write (6, '(6(a,i2,a,f8.4,6x))') & - ('U(', is, ') =', Hubbard_U(is)*autoev, is=1, nsp) -! write (6,'(6(a,i2,a,f8.4,6x))') & -! ('alpha(',is,') =', Hubbard_alpha(is) * autoev, is=1,nsp) - nsum = 0.d0 - allocate (ftemp1(ldmx)) - allocate (ftemp2(ldmx)) - iat = 0 - write (6, *) 'nsp', nsp - do is = 1, nsp - do ia = 1, na(is) - nsuma = 0.d0 - iat = iat + 1 -! if (iat.eq.1) then - if (Hubbard_U(is) .ne. 0.d0) then - do isp = 1, nspin - do m1 = 1, 2*Hubbard_l(is) + 1 - nsuma = nsuma + ns(iat, isp, m1, m1) - end do - end do - if (nspin .eq. 1) nsuma = 2.d0*nsuma - write (6, '(a,x,i2,2x,a,f11.7)') 'atom', iat, & - & ' Tr[ns(na)]= ', nsuma - nsum = nsum + nsuma -! - do isp = 1, nspin - - k = 0 - do m1 = 1, 2*Hubbard_l(is) + 1 - do m2 = m1, 2*Hubbard_l(is) + 1 - k = k + 1 - f1(k) = ns(iat, isp, m2, m1) - end do - end do - - CALL dspev_drv('V', 'L', 2*Hubbard_l(is) + 1, f1, lambda, vet, ldmx) - - write (6, '(a,x,i2,2x,a,x,i2)') 'atom', iat, 'spin', isp - write (6, '(a,7f10.7)') 'eigenvalues: ', (lambda(m1), m1=1,& - & 2*Hubbard_l(is) + 1) - write (6, *) 'eigenvectors' - do m2 = 1, 2*Hubbard_l(is) + 1 - write (6, '(i2,2x,7(f10.7,x))') m2, (real(vet(m1, m2)),& - & m1=1, 2*Hubbard_l(is) + 1) - end do - write (6, *) 'occupations' - do m1 = 1, 2*Hubbard_l(is) + 1 - write (6, '(7(f6.3,x))') (ns(iat, isp, m1, m2), m2=1, & - & 2*Hubbard_l(is) + 1) - end do - end do - end if -! end if - end do - end do - deallocate (ftemp1, ftemp2) - return -end subroutine write_ns -!----------------------------------------------------------------------- -subroutine genatwfc(n_atomic_wfc, atwfc) -!----------------------------------------------------------------------- -! -! Compute atomic wavefunctions in G-space, in the same order as used in new_ns -! - use ions_base, only: na, nsp - use gvecw, only: ngw - use reciprocal_vectors, only: g, gx, ng0 => gstart - use cell_base, only: omega, tpiba - use constants, only: fpi - USE atom, ONLY: rgrid - USE uspp_param, ONLY: upf - USE kinds, ONLY: DP -! - implicit none - integer, intent(in) :: n_atomic_wfc - complex(DP), intent(out):: atwfc(ngw, n_atomic_wfc) -! - integer natwfc, is, ia, ir, nb, l, m, lm, i, lmax_wfc, ig - real(DP), allocatable:: ylm(:, :), q(:), jl(:), vchi(:), & - & chiq(:), gxn(:, :) -! - IF (.NOT. ALLOCATED(rgrid)) & - CALL errore(' genatwfc ', ' rgrid not allocated ', 1) -! - allocate (q(ngw)) - allocate (gxn(3, ngw)) - allocate (chiq(ngw)) -! - do ig = 1, ngw - q(ig) = sqrt(g(ig))*tpiba - end do - if (ng0 .eq. 2) gxn(1, :) = 0.0d0 - do ig = ng0, ngw - gxn(:, ig) = gx(:, ig)/sqrt(g(ig)) !ik<=>ig - end do -! - natwfc = 0 -!@@@@@ -! -! calculate max angular momentum required in wavefunctions -! - lmax_wfc = -1 - DO is = 1, nsp - lmax_wfc = MAX(lmax_wfc, MAXVAL(upf(is)%lchi(1:upf(is)%nwfc))) - END DO - ! - ALLOCATE (ylm(ngw, (lmax_wfc + 1)**2)) - ! - CALL ylmr2((lmax_wfc + 1)**2, ngw, gx, g, ylm) -!@@@@@ - - do is = 1, nsp - ALLOCATE (jl(rgrid(is)%mesh), vchi(rgrid(is)%mesh)) - do ia = 1, na(is) -! -! radial fourier transform of the chi functions -! NOTA BENE: chi is r times the radial part of the atomic wavefunction -! bess requires l+1, not l, on input -! - do nb = 1, upf(is)%nwfc - l = upf(is)%lchi(nb) - do i = 1, ngw - call sph_bes(rgrid(is)%mesh, rgrid(is)%r, q(i), l, jl) - do ir = 1, rgrid(is)%mesh - vchi(ir) = upf(is)%chi(ir, nb)*rgrid(is)%r(ir)*jl(ir) - end do - call simpson_cp90(rgrid(is)%mesh, vchi, rgrid(is)%rab, chiq(i)) - end do -! -! multiply by angular part and structure factor -! NOTA BENE: the factor i^l MUST be present!!! -! - do m = 1, 2*l + 1 - lm = l**2 + m -! call ylmr2b(lm,ngw,ngw,gxn,ylm) - natwfc = natwfc + 1 - atwfc(:, natwfc) = CMPLX(0.d0, 1.d0)**l*ylm(:, lm)*chiq(:) - end do - end do - end do - DEALLOCATE (vchi, jl) - end do -! - do i = 1, natwfc - call DSCAL(2*ngw, fpi/sqrt(omega), atwfc(1, i), 1) - end do -! - if (natwfc .ne. n_atomic_wfc) & - & call errore('atomic_wfc', 'unexpected error', natwfc) -! - deallocate (ylm) - deallocate (chiq) - deallocate (gxn) - deallocate (q) -! - return -end subroutine genatwfc -! -!------------------------------------------------------------------------- -subroutine dndtau_real(alpha_a, alpha_s, becwfc, spsi, bp, dbp, wdb, & -& offset, c, wfc, & -& eigr, betae, & -& proj, ipol, dns) -!----------------------------------------------------------------------- -! -! This routine computes the derivative of the ns with respect to the ionic -! displacement tau(alpha,ipol) used to obtain the Hubbard contribution to the -! atomic forces. -! - use ions_base, only: na, nat, nsp - use gvecw, only: ngw - use electrons_base, only: nspin, n => nbsp, nx => nbspx, ispin, f - USE uspp, ONLY: nhsa => nkb - USE ldaU, ONLY: Hubbard_U, Hubbard_l - USE ldaU, ONLY: n_atomic_wfc, ns - USE kinds, ONLY: DP -! - implicit none - integer, parameter :: ldmx = 7 - integer ibnd, is, i, ia, counter, m1, m2, l, iat, alpha, ldim -! input - integer, intent(in) :: offset(nsp, nat) - integer, intent(in) :: alpha_a, alpha_s, ipol - real(DP), intent(in) :: wfc(2, ngw, n_atomic_wfc), c(2, ngw, nx), & - & eigr(2, ngw, nat), betae(2, ngw, nhsa), & - & becwfc(nhsa, n_atomic_wfc), & - & bp(nhsa, n), dbp(nhsa, n, 3), wdb(nhsa, n_atomic_wfc, 3) - real(DP), intent(in) :: proj(n, n_atomic_wfc) - complex(DP), intent(in) :: spsi(ngw, n) -! output - real(DP), intent(out) :: dns(nat, nspin, ldmx, ldmx) -! -! dns !derivative of ns(:,:,:,:) w.r.t. tau -! - real(DP), allocatable :: dproj(:, :) -! -! dproj(n,n_atomic_wfc) ! derivative of proj(:,:) w.r.t. tau -! - allocate (dproj(n, n_atomic_wfc)) -! - dns(:, :, :, :) = 0.d0 -! - call dprojdtau_real(c, wfc, becwfc, spsi, bp, dbp, wdb, eigr, alpha_a, & -& alpha_s, ipol, offset(alpha_s, alpha_a), dproj) -! -! compute the derivative of occupation numbers (the quantities dn(m1,m2)) -! of the atomic orbitals. They are real quantities as well as n(m1,m2) -! - iat = 0 - do is = 1, nsp - do ia = 1, na(is) - iat = iat + 1 - if (Hubbard_U(is) .ne. 0.d0) then - ldim = 2*Hubbard_l(is) + 1 - do m1 = 1, ldim - do m2 = m1, ldim - do ibnd = 1, n - dns(iat, ispin(ibnd), m1, m2) = & - & dns(iat, ispin(ibnd), m1, m2) + & - & f(ibnd)*REAL(proj(ibnd, offset(is, ia) + m1)* & - & (dproj(ibnd, offset(is, ia) + m2)) + & - & dproj(ibnd, offset(is, ia) + m1)* & - & (proj(ibnd, offset(is, ia) + m2))) - end do - dns(iat, :, m2, m1) = dns(iat, :, m1, m2) - end do - end do - end if - end do - end do -! - deallocate (dproj) - return -end subroutine dndtau_real -! -! -!------------------------------------------------------------------------- -subroutine dndtau_cmplx(alpha_a, alpha_s, becwfc, spsi, bp, dbp, wdb, & -& offset, c, wfc, & -& eigr, betae, & -& proj, ipol, dns_c) -!----------------------------------------------------------------------- -! -! This routine computes the derivative of the ns with respect to the ionic -! displacement tau(alpha,ipol) used to obtain the Hubbard contribution to the -! atomic forces. -! - use ions_base, only: na, nat, nsp - use gvecw, only: ngw - use electrons_base, only: nspin, n => nbsp, nx => nbspx, ispin, f - USE uspp, ONLY: nhsa => nkb - USE ldaU, ONLY: Hubbard_U, Hubbard_l - USE ldaU, ONLY: n_atomic_wfc, ns_c - USE kinds, ONLY: DP -! - implicit none - integer, parameter :: ldmx = 7 - integer ibnd, is, i, ia, counter, m1, m2, l, iat, alpha, ldim -! input - integer, intent(in) :: offset(nsp, nat) - integer, intent(in) :: alpha_a, alpha_s, ipol - complex(DP), intent(in) :: wfc(ngw, n_atomic_wfc), c(ngw, nx), & - & eigr(ngw, nat), betae(ngw, nhsa), & - & becwfc(nhsa, n_atomic_wfc), & - & bp(nhsa, n), dbp(nhsa, n, 3), wdb(nhsa, n_atomic_wfc, 3) - complex(DP), intent(in) :: proj(n, n_atomic_wfc) - complex(DP), intent(in) :: spsi(ngw, n) -! output - complex(DP), intent(out) :: dns_c(nat, nspin, ldmx, ldmx) -! -! dns !derivative of ns(:,:,:,:) w.r.t. tau -! - complex(DP), allocatable :: dproj(:, :) -! -! dproj(n,n_atomic_wfc) ! derivative of proj(:,:) w.r.t. tau -! - allocate (dproj(n, n_atomic_wfc)) -! - dns_c(:, :, :, :) = 0.d0 -! - call dprojdtau_cmplx(c, wfc, becwfc, spsi, bp, dbp, wdb, eigr, alpha_a, & -& alpha_s, ipol, offset(alpha_s, alpha_a), dproj) -! -! compute the derivative of occupation numbers (the quantities dn(m1,m2)) -! of the atomic orbitals. They are real quantities as well as n(m1,m2) -! - iat = 0 - do is = 1, nsp - do ia = 1, na(is) - iat = iat + 1 - if (Hubbard_U(is) .ne. 0.d0) then - ldim = 2*Hubbard_l(is) + 1 - do m1 = 1, ldim - do m2 = m1, ldim - do ibnd = 1, n - dns_c(iat, ispin(ibnd), m1, m2) = & - & dns_c(iat, ispin(ibnd), m1, m2) + & - & f(ibnd)*(proj(ibnd, offset(is, ia) + m1)* & - & (dproj(ibnd, offset(is, ia) + m2)) + & - & dproj(ibnd, offset(is, ia) + m1)* & - & (proj(ibnd, offset(is, ia) + m2))) - end do - dns_c(iat, :, m2, m1) = CONJG(dns_c(iat, :, m1, m2)) - end do - end do - end if - end do - end do -! - deallocate (dproj) - return -end subroutine dndtau_cmplx -! -! -!----------------------------------------------------------------------- -subroutine dprojdtau_real(c, wfc, becwfc, spsi, bp, dbp, wdb, eigr, alpha_a, & -& alpha_s, ipol, offset, dproj) -!----------------------------------------------------------------------- -! -! This routine computes the first derivative of the projection -! <\fi^{at}_{I,m1}|S|\psi_{k,v,s}> with respect to the atomic displacement -! u(alpha,ipol) (we remember that ns_{I,s,m1,m2} = \sum_{k,v} -! f_{kv} <\fi^{at}_{I,m1}|S|\psi_{k,v,s}><\psi_{k,v,s}|S|\fi^{at}_{I,m2}>) -! - use ions_base, only: na, nat - use gvecw, only: ngw - use reciprocal_vectors, only: g, gx, ng0 => gstart - use electrons_base, only: n => nbsp, nx => nbspx -! use gvec -! use constants - USE uspp, ONLY: nhsa => nkb, qq - use cvan, ONLY: ish - USE ldaU, ONLY: Hubbard_U, Hubbard_l - USE ldaU, ONLY: n_atomic_wfc - use cell_base, ONLY: tpiba - USE uspp_param, only: nh !@@@@ - use mp_global, only: intra_image_comm - use mp, only: mp_sum - USE kinds, ONLY: DP -! - implicit none - integer, parameter :: ldmx = 7 - integer alpha_a, alpha_s, ipol, offset -! input: the displaced atom -! input: the component of displacement -! input: the offset of the wfcs of the atom "alpha_a,alpha_s" - complex(DP), intent(in) :: spsi(ngw, n), & - & c(ngw, nx), eigr(ngw, nat) -! input: the atomic wfc -! input: S|evc> - real(DP), intent(in) ::becwfc(nhsa, n_atomic_wfc), & - & wfc(2, ngw, n_atomic_wfc), & - & bp(nhsa, n), dbp(nhsa, n, 3), wdb(nhsa, n_atomic_wfc, 3) - real(DP), intent(out) :: dproj(n, n_atomic_wfc) -! output: the derivative of the projection -! - integer i, ig, m1, ibnd, iwf, ia, is, iv, jv, ldim, alpha, l, m, k, inl -! - real(DP) a1, a2 - real(kind=8), allocatable :: gk(:) -! - complex(DP), allocatable :: dwfc(:, :) - real(DP), allocatable :: betapsi(:, :), & - & dbetapsi(:, :), & - & wfcbeta(:, :), wfcdbeta(:, :), temp(:) -! dwfc(ngw,ldmx), ! the derivative of the atomic d wfc -! betapsi(nh,n), ! -! dbetapsi(nh,n), ! -! wfcbeta(n_atomic_wfc,nh), ! -! wfcdbeta(n_atomic_wfc,nh), ! - ldim = 2*Hubbard_l(alpha_s) + 1 - allocate (dwfc(ngw, ldmx), betapsi(nh(alpha_s), n)) - allocate (dbetapsi(nh(alpha_s), n), & - & wfcbeta(n_atomic_wfc, nh(alpha_s))) - allocate (wfcdbeta(n_atomic_wfc, nh(alpha_s))) - dproj(:, :) = 0.d0 -! -! At first the derivative of the atomic wfc is computed -! -! - allocate (gk(ngw)) - allocate (temp(ngw)) -! - if (Hubbard_U(alpha_s) .ne. 0.d0) then -! - do ig = 1, ngw - gk(ig) = gx(ipol, ig)*tpiba -! - do m1 = 1, ldim - dwfc(ig, m1) = cmplx(gk(ig)*wfc(2, ig, offset + m1), & -& -1*gk(ig)*wfc(1, ig, offset + m1)) - end do - end do -! - do ibnd = 1, n - do m1 = 1, ldim - temp(:) = real(conjg(dwfc(:, m1))*spsi(:, ibnd)) - dproj(ibnd, offset + m1) = 2.d0*SUM(temp) - if (ng0 .eq. 2) dproj(ibnd, offset + m1) = dproj(ibnd, offset + m1) - temp(1) - end do - end do - call mp_sum(dproj, intra_image_comm) - end if - do iv = 1, nh(alpha_s) - inl = ish(alpha_s) + (iv - 1)*na(alpha_s) + alpha_a - do i = 1, n - betapsi(iv, i) = bp(inl, i) - dbetapsi(iv, i) = dbp(inl, i, ipol) - end do - do m = 1, n_atomic_wfc -! do m1=1,2**Hubbard_l(is) + 1 - wfcbeta(m, iv) = becwfc(inl, m) - wfcdbeta(m, iv) = wdb(inl, m, ipol) - end do - end do - do ibnd = 1, n - do iv = 1, nh(alpha_s) - do jv = 1, nh(alpha_s) - do m = 1, n_atomic_wfc -! do m1=1,2**Hubbard_l(is) + 1 - dproj(ibnd, m) = & - & dproj(ibnd, m) + qq(iv, jv, alpha_s)* & - & (wfcdbeta(m, iv)*betapsi(jv, ibnd) + & - & wfcbeta(m, iv)*dbetapsi(jv, ibnd)) - end do - end do - end do - end do - deallocate (temp, gk) - deallocate (betapsi) - deallocate (dwfc) - deallocate (dbetapsi) - deallocate (wfcbeta) - deallocate (wfcdbeta) - return -end subroutine dprojdtau_real -! -!----------------------------------------------------------------------- -subroutine dprojdtau_cmplx(c, wfc, becwfc, spsi, bp, dbp, wdb, eigr, alpha_a, & -& alpha_s, ipol, offset, dproj) -!----------------------------------------------------------------------- -! -! This routine computes the first derivative of the projection -! <\fi^{at}_{I,m1}|S|\psi_{k,v,s}> with respect to the atomic displacement -! u(alpha,ipol) (we remember that ns_{I,s,m1,m2} = \sum_{k,v} -! f_{kv} <\fi^{at}_{I,m1}|S|\psi_{k,v,s}><\psi_{k,v,s}|S|\fi^{at}_{I,m2}>) -! - use ions_base, only: na, nat - use gvecw, only: ngw - use reciprocal_vectors, only: g, gx, ng0 => gstart - use electrons_base, only: n => nbsp, nx => nbspx -! use gvec -! use constants - USE uspp, ONLY: nhsa => nkb, qq - use cvan, ONLY: ish - USE ldaU, ONLY: Hubbard_U, Hubbard_l - USE ldaU, ONLY: n_atomic_wfc - use cell_base, ONLY: tpiba - USE uspp_param, only: nh !@@@@ - use mp_global, only: intra_image_comm - use mp, only: mp_sum - USE kinds, ONLY: DP -! - implicit none - integer, parameter :: ldmx = 7 - integer alpha_a, alpha_s, ipol, offset -! input: the displaced atom -! input: the component of displacement -! input: the offset of the wfcs of the atom "alpha_a,alpha_s" - complex(DP), intent(in) :: spsi(ngw, n), & - & c(ngw, nx), eigr(ngw, nat) -! input: the atomic wfc -! input: S|evc> - complex(DP), intent(in) ::becwfc(nhsa, n_atomic_wfc), & - & wfc(ngw, n_atomic_wfc), & - & bp(nhsa, n), dbp(nhsa, n, 3), wdb(nhsa, n_atomic_wfc, 3) - complex(DP), intent(out) :: dproj(n, n_atomic_wfc) -! output: the derivative of the projection -! - integer i, ig, m1, ibnd, iwf, ia, is, iv, jv, ldim, alpha, l, m, k, inl -! - real(DP) a1, a2 - real(kind=8), allocatable :: gk(:) -! - complex(DP), allocatable :: dwfc(:, :) - complex(DP), allocatable :: betapsi(:, :), & - & dbetapsi(:, :), & - & wfcbeta(:, :), wfcdbeta(:, :), temp(:) -! dwfc(ngw,ldmx), ! the derivative of the atomic d wfc -! betapsi(nh,n), ! -! dbetapsi(nh,n), ! -! wfcbeta(n_atomic_wfc,nh), ! -! wfcdbeta(n_atomic_wfc,nh), ! - ldim = 2*Hubbard_l(alpha_s) + 1 - allocate (dwfc(ngw, ldmx), betapsi(nh(alpha_s), n)) - allocate (dbetapsi(nh(alpha_s), n), & - & wfcbeta(n_atomic_wfc, nh(alpha_s))) - allocate (wfcdbeta(n_atomic_wfc, nh(alpha_s))) - dproj(:, :) = 0.d0 -! -! At first the derivative of the atomic wfc is computed -! -! - allocate (gk(ngw)) - allocate (temp(ngw)) -! - if (Hubbard_U(alpha_s) .ne. 0.d0) then -! - do ig = 1, ngw - gk(ig) = gx(ipol, ig)*tpiba -! - do m1 = 1, ldim - dwfc(ig, m1) = (0.d0, -1.d0)*gk(ig)*wfc(ig, offset + m1) - end do - end do -! - do ibnd = 1, n - do m1 = 1, ldim - temp(:) = conjg(dwfc(:, m1))*spsi(:, ibnd) - dproj(ibnd, offset + m1) = SUM(temp) - end do - end do - call mp_sum(dproj, intra_image_comm) - end if - do iv = 1, nh(alpha_s) - inl = ish(alpha_s) + (iv - 1)*na(alpha_s) + alpha_a - do i = 1, n - betapsi(iv, i) = bp(inl, i) - dbetapsi(iv, i) = dbp(inl, i, ipol) - end do - do m = 1, n_atomic_wfc -! do m1=1,2**Hubbard_l(is) + 1 - wfcbeta(m, iv) = becwfc(inl, m) - wfcdbeta(m, iv) = wdb(inl, m, ipol) - end do - end do - do ibnd = 1, n - do iv = 1, nh(alpha_s) - do jv = 1, nh(alpha_s) - do m = 1, n_atomic_wfc -! do m1=1,2**Hubbard_l(is) + 1 - dproj(ibnd, m) = & - & dproj(ibnd, m) + qq(iv, jv, alpha_s)* & - & (wfcdbeta(m, iv)*betapsi(jv, ibnd) + & - & wfcbeta(m, iv)*dbetapsi(jv, ibnd)) - end do - end do - end do - end do - deallocate (temp, gk) - deallocate (betapsi) - deallocate (dwfc) - deallocate (dbetapsi) - deallocate (wfcbeta) - deallocate (wfcdbeta) - return -end subroutine dprojdtau_cmplx -! -! -!----------------------------------------------------------------------- -subroutine stepfn(A, sigma, x_value, g_value, step_value) -!----------------------------------------------------------------------- -! This subroutine calculates the value of the gaussian and step -! functions with a given x_value. A and sigma are given in the -! input file. ... to be used in occupation_constraint... -! - USE constants, ONLY: pi - implicit none - real(kind=8) A, sigma, x_value, g_value, step_value - real(kind=8) x - integer i - step_value = 0.0d0 - g_value = 0.0d0 -! - do i = 1, 100000 - x = x_value + (i - 100000)/100000.0d0*(x_value + 5.d0*sigma) -! -! Integrate from 5 sigma before the x_value -! - g_value = A*dexp(-x*x/(2*sigma*sigma))/(sigma*dsqrt(2*pi)) -! write(6,*) 'step', step_value,'g',g_value -! if (g_value.le.0.0) g_value=0.0 - if ((x_value + 5*sigma) .ge. 0.0d0) then - step_value = step_value + g_value/100000.0d0*(x_value + 5.d0*sigma) - end if - end do - return -end subroutine stepfn -! -!----------------------------------------------------------------------- -SUBROUTINE projwfc_hub_real(c, nx, eigr, betae, n, n_atomic_wfc, & -& wfc, becwfc, swfc, proj) -!----------------------------------------------------------------------- - ! - ! Projection on atomic wavefunctions - ! Atomic wavefunctions are not orthogonized - ! - USE kinds, ONLY: DP - USE constants, ONLY: autoev - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gstart - USE ions_base, ONLY: nsp, na, nat - USE uspp, ONLY: nhsa => nkb - USE cp_interfaces, ONLY: nlsm1, projwfc_hub, s_wfc !added:giovanni -! - IMPLICIT NONE - INTEGER, INTENT(IN) :: nx, n, n_atomic_wfc - COMPLEX(DP), INTENT(IN) :: c(ngw, nx), eigr(ngw, nat), betae(ngw, nhsa) -! - COMPLEX(DP), INTENT(OUT):: wfc(ngw, n_atomic_wfc), & - & swfc(ngw, n_atomic_wfc) - real(DP), intent(out):: becwfc(nhsa, n_atomic_wfc) !DEBUG - REAL(DP), ALLOCATABLE :: overlap(:, :), e(:), z(:, :) - REAL(DP), ALLOCATABLE :: temp(:) - REAL(DP) :: somma, proj(n, n_atomic_wfc) - INTEGER :: is, ia, nb, l, m, k, i - ! - ! calculate number of atomic states - ! - ! - IF (n_atomic_wfc .EQ. 0) RETURN - ! - ! - ! calculate wfc = atomic states - ! - CALL atomic_wfc_northo(eigr, n_atomic_wfc, wfc) - ! - ! calculate bec = - ! - CALL nlsm1(n_atomic_wfc, 1, nsp, eigr, wfc, becwfc) - ! - ! calculate swfc = S|wfc> - ! - CALL s_wfc(n_atomic_wfc, becwfc, betae, wfc, swfc) - ! - ! calculate proj = - ! - ALLOCATE (temp(ngw)) - DO m = 1, n - DO l = 1, n_atomic_wfc - temp(:) = DBLE(CONJG(c(:, m))*swfc(:, l)) !@@@@ - proj(m, l) = 2.d0*SUM(temp) - IF (gstart == 2) proj(m, l) = proj(m, l) - temp(1) - END DO - END DO - DEALLOCATE (temp) - CALL mp_sum(proj, intra_image_comm) -! - RETURN -END SUBROUTINE projwfc_hub_real -! -!----------------------------------------------------------------------- -SUBROUTINE projwfc_hub_twin(c, nx, eigr, betae, n, n_atomic_wfc, & -& wfc, becwfc, swfc, proj, lgam) -!----------------------------------------------------------------------- - ! - ! Projection on atomic wavefunctions - ! Atomic wavefunctions are not orthogonized - ! - USE kinds, ONLY: DP - USE constants, ONLY: autoev - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gstart - USE ions_base, ONLY: nsp, na, nat - USE uspp, ONLY: nhsa => nkb - USE cp_interfaces, ONLY: nlsm1, s_wfc !added:giovanni - USE twin_types !added:giovanni -! - IMPLICIT NONE - INTEGER, INTENT(IN) :: nx, n, n_atomic_wfc - COMPLEX(DP), INTENT(IN) :: c(ngw, nx), eigr(ngw, nat), betae(ngw, nhsa) - LOGICAL :: lgam -! - COMPLEX(DP), INTENT(OUT):: wfc(ngw, n_atomic_wfc), & - swfc(ngw, n_atomic_wfc) -! real(DP), intent(out):: becwfc(nhsa,n_atomic_wfc) !DEBUG - type(twin_matrix) :: becwfc!(nhsa,n_atomic_wfc) !DEBUG - REAL(DP), ALLOCATABLE :: overlap(:, :), e(:), z(:, :) - REAL(DP), ALLOCATABLE :: temp(:) - COMPLEX(DP), ALLOCATABLE :: temp_c(:) - REAL(DP) :: somma - COMPLEX(DP) :: somma_c - TYPE(twin_matrix) :: proj - INTEGER :: is, ia, nb, l, m, k, i - ! - ! calculate number of atomic states - ! - ! - IF (n_atomic_wfc .EQ. 0) RETURN - ! - ! - ! calculate wfc = atomic states - ! - CALL atomic_wfc_northo(eigr, n_atomic_wfc, wfc) - ! - ! calculate bec = - ! - CALL nlsm1(n_atomic_wfc, 1, nsp, eigr, wfc, becwfc, 1, lgam) - ! - ! calculate swfc = S|wfc> - ! - CALL s_wfc(n_atomic_wfc, becwfc, betae, wfc, swfc, lgam) - ! - ! calculate proj = - ! - IF (lgam) THEN - ALLOCATE (temp(ngw)) - ELSE - ALLOCATE (temp_c(ngw)) - END IF - ! - DO m = 1, n - ! - IF (lgam) THEN - DO l = 1, n_atomic_wfc - temp(:) = DBLE(CONJG(c(:, m))*swfc(:, l)) !@@@@ - proj%rvec(m, l) = 2.d0*DBLE(SUM(temp)) - IF (gstart == 2) proj%rvec(m, l) = proj%rvec(m, l) - temp(1) - END DO - ELSE - ! - DO l = 1, n_atomic_wfc - temp_c(:) = CONJG(c(:, m))*swfc(:, l) !@@@@ - proj%cvec(m, l) = SUM(temp_c) - END DO - ! - END IF - END DO - ! - IF (lgam) THEN - DEALLOCATE (temp) - CALL mp_sum(proj%rvec, intra_image_comm) - ELSE - DEALLOCATE (temp_c) - CALL mp_sum(proj%cvec, intra_image_comm) - END IF -! - RETURN -END SUBROUTINE projwfc_hub_twin -! -!----------------------------------------------------------------------- -SUBROUTINE atomic_wfc_northo(eigr, n_atomic_wfc, wfc) -!----------------------------------------------------------------------- -! -! Compute atomic wavefunctions in G-space -! Atomic wavefunctions not orthogonalized -! - USE kinds, ONLY: DP - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gstart, g, gx - USE ions_base, ONLY: nsp, na, nat - USE cell_base, ONLY: tpiba, omega !@@@@ - USE atom, ONLY: rgrid - USE uspp_param, ONLY: upf -!@@@@@ - USE constants, ONLY: fpi -!@@@@@ -! - IMPLICIT NONE - INTEGER, INTENT(in) :: n_atomic_wfc - COMPLEX(DP), INTENT(in) :: eigr(ngw, nat) - COMPLEX(DP), INTENT(out):: wfc(ngw, n_atomic_wfc) -! - INTEGER :: natwfc, ndm, is, ia, ir, nb, l, m, lm, i, lmax_wfc, isa - REAL(DP), ALLOCATABLE :: ylm(:, :), q(:), jl(:), vchi(:), chiq(:) - - IF (.NOT. ALLOCATED(rgrid)) & - CALL errore(' atomic_wfc_northo ', ' rgrid not allocated ', 1) -! -! calculate max angular momentum required in wavefunctions -! - lmax_wfc = -1 - DO is = 1, nsp - lmax_wfc = MAX(lmax_wfc, MAXVAL(upf(is)%lchi(1:upf(is)%nwfc))) - END DO - ! - ALLOCATE (ylm(ngw, (lmax_wfc + 1)**2)) - ! - CALL ylmr2((lmax_wfc + 1)**2, ngw, gx, g, ylm) - ndm = MAXVAL(rgrid(1:nsp)%mesh) - ! - ALLOCATE (jl(ndm), vchi(ndm)) - ALLOCATE (q(ngw), chiq(ngw)) -! - DO i = 1, ngw - q(i) = SQRT(g(i))*tpiba - END DO -! - natwfc = 0 - isa = 0 - DO is = 1, nsp - ! - ! radial fourier transform of the chi functions - ! NOTA BENE: chi is r times the radial part of the atomic wavefunction - ! - DO ia = 1 + isa, na(is) + isa - DO nb = 1, upf(is)%nwfc - l = upf(is)%lchi(nb) - DO i = 1, ngw - CALL sph_bes(rgrid(is)%mesh, rgrid(is)%r, q(i), l, jl) - DO ir = 1, rgrid(is)%mesh - vchi(ir) = upf(is)%chi(ir, nb)*rgrid(is)%r(ir)*jl(ir) - END DO - CALL simpson_cp90(rgrid(is)%mesh, vchi, rgrid(is)%rab, chiq(i)) - END DO - ! - ! multiply by angular part and structure factor - ! NOTA BENE: the factor i^l MUST be present!!! - ! - DO m = 1, 2*l + 1 - lm = l**2 + m - !DO ia = 1 + isa, na(is) + isa - natwfc = natwfc + 1 - wfc(:, natwfc) = CMPLX(0.d0, 1.d0)**l*eigr(:, ia)*ylm(:, lm)*chiq(:) - !ENDDO - END DO - END DO - END DO - isa = isa + na(is) - END DO -! - IF (natwfc .NE. n_atomic_wfc) & - & CALL errore('atomic_wfc', 'unexpected error', natwfc) -! -!@@@@@ - do i = 1, n_atomic_wfc - call DSCAL(2*ngw, fpi/sqrt(omega), wfc(1, i), 1) - end do -!@@@@@ - DEALLOCATE (q, chiq, vchi, jl, ylm) -! - RETURN -END SUBROUTINE atomic_wfc_northo - -!----------------------------------------------------------------------- -SUBROUTINE compute_lambda(c0, gi, lambda, nspin, nbnd, ngw, nudx, desc_emp, nupdwn, iupdwn) - !----------------------------------------------------------------------- - ! - ! Compute matrix of lagangian multipliers (i.e. the Hamiltonian on the - ! variational orbitals) - ! - USE kinds, ONLY: DP - USE twin_types - !USE electrons_module, ONLY : nupdwn_emp, iupdwn_emp - USE reciprocal_vectors, ONLY: ng0 => gstart - USE descriptors, ONLY: descla_siz_ - USE mp_global, ONLY: intra_image_comm - USE mp, only: mp_sum - USE cp_main_variables, ONLY: distribute_lambda - ! - IMPLICIT NONE - INTEGER, INTENT(IN) :: nspin, ngw, nbnd, nudx - INTEGER, INTENT(IN) :: nupdwn(nspin), iupdwn(nspin) - INTEGER, INTENT(IN) :: desc_emp(descla_siz_, 2) - COMPLEX(DP), INTENT(IN) :: c0(ngw, nbnd) - COMPLEX(DP), INTENT(IN) :: gi(ngw, nbnd) - TYPE(twin_matrix), INTENT(INOUT) :: lambda(nspin) - INTEGER :: nss, is, i, j, ii, jj, istart, ig - REAL(DP), ALLOCATABLE :: lambda_repl(:, :) ! replicated copy of lambda - COMPLEX(DP), ALLOCATABLE :: lambda_repl_c(:, :) ! replicated copy of lambda - ! - if (.not. lambda(1)%iscmplx) then - allocate (lambda_repl(nudx, nudx)) - else - allocate (lambda_repl_c(nudx, nudx)) - end if - ! - do is = 1, nspin - ! - nss = nupdwn(is) - istart = iupdwn(is) - ! - if (.not. lambda(1)%iscmplx) then - lambda_repl = 0.d0 - else - lambda_repl_c = CMPLX(0.d0, 0.d0) - end if - ! - do i = 1, nss - ! - do j = i, nss - ! - ii = i + istart - 1 - jj = j + istart - 1 - ! - if (.not. lambda(1)%iscmplx) then - ! - do ig = 1, ngw - ! - lambda_repl(i, j) = lambda_repl(i, j) - & - 2.d0*DBLE(CONJG(c0(ig, ii))*gi(ig, jj)) - ! - end do - ! - if (ng0 == 2) then - ! - lambda_repl(i, j) = lambda_repl(i, j) + & - DBLE(CONJG(c0(1, ii))*gi(1, jj)) - ! - end if - ! - lambda_repl(j, i) = lambda_repl(i, j) - ! - else - ! - do ig = 1, ngw - ! - lambda_repl_c(i, j) = lambda_repl_c(i, j) - & - CONJG(c0(ig, ii))*gi(ig, jj) - ! - end do - ! - lambda_repl_c(j, i) = CONJG(lambda_repl_c(i, j)) - ! - end if - ! - end do - ! - end do - ! - if (.not. lambda(1)%iscmplx) then - ! - call mp_sum(lambda_repl, intra_image_comm) - call distribute_lambda(lambda_repl, lambda(is)%rvec(:, :), desc_emp(:, is)) - ! - else - ! - call mp_sum(lambda_repl_c, intra_image_comm) - call distribute_lambda(lambda_repl_c, lambda(is)%cvec(:, :), desc_emp(:, is)) - ! - end if - ! - end do - ! - if (.not. lambda(1)%iscmplx) then - deallocate (lambda_repl) - else - deallocate (lambda_repl_c) - end if - ! - RETURN - ! -END SUBROUTINE - diff --git a/quantum_espresso/kcp/CPV/cplib_meta.f90 b/quantum_espresso/kcp/CPV/cplib_meta.f90 deleted file mode 100644 index cfd8aade1..000000000 --- a/quantum_espresso/kcp/CPV/cplib_meta.f90 +++ /dev/null @@ -1,455 +0,0 @@ -! -! Copyright (C) 2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - subroutine dforce_meta (c,ca,df,da, psi,iss1,iss2,fi,fip) -!----------------------------------------------------------------------- -!computes: the generalized force df=CMPLX(dfr,dfi) acting on the i-th -! electron state at the gamma point of the brillouin zone -! represented by the vector c=CMPLX(cr,ci) -! -! contribution from metaGGA -#include "f_defs.h" - use kinds, only: dp - use reciprocal_vectors - use gvecs - use gvecw, only : ngw - use smooth_grid_dimensions, only : nnrs => nnrsx - use cell_base, only : tpiba2 - USE metagga, ONLY : kedtaus - USE cp_interfaces, ONLY : fwfft, invfft - USE fft_base, ONLY: dffts -! - implicit none -! - complex(8) c(ngw), ca(ngw), df(ngw), da(ngw),psi(nnrs) - integer iss1, iss2 - real(8) fi, fip -! local variables - integer ir,ig, ipol !metagga - complex(8) fp,fm,ci -! -! - ci=(0.0d0,1.0d0) -! - do ipol = 1, 3 - psi(:)=(0.d0,0.d0) - do ig=1,ngw - psi(nps(ig))=gx(ipol,ig)* (ci*c(ig) - ca(ig)) - psi(nms(ig))=gx(ipol,ig)* (CONJG(ci*c(ig) + ca(ig))) - end do - call invfft('Wave',psi,dffts ) -! on smooth grids--> grids for charge density - do ir=1, nnrs - psi(ir) = & - CMPLX(kedtaus(ir,iss1)*DBLE(psi(ir)), kedtaus(ir,iss2)*AIMAG(psi(ir))) - end do - call fwfft('Wave',psi, dffts ) - do ig=1,ngw - fp= (psi(nps(ig)) + psi(nms(ig))) - fm= (psi(nps(ig)) - psi(nms(ig))) - df(ig)= df(ig) - ci*fi*tpiba2*gx(ipol,ig)*CMPLX(DBLE(fp), AIMAG(fm)) - da(ig)= da(ig) - ci*fip*tpiba2*gx(ipol,ig)*CMPLX(AIMAG(fp),-DBLE(fm)) - end do - end do - -! - return - end subroutine dforce_meta -!----------------------------------------------------------------------- -! - subroutine dforce_meta_new (c,ca,df,da, psi,psi2,iss1,iss2,fi,fip,lgam) -!----------------------------------------------------------------------- -!computes: the generalized force df=CMPLX(dfr,dfi) acting on the i-th -! electron state at the gamma point of the brillouin zone -! represented by the vector c=CMPLX(cr,ci) -! -! contribution from metaGGA -#include "f_defs.h" - use kinds, only: dp - use reciprocal_vectors - use gvecs - use gvecw, only : ngw - use smooth_grid_dimensions, only : nnrs => nnrsx - use cell_base, only : tpiba2 - USE metagga, ONLY : kedtaus - USE cp_interfaces, ONLY : fwfft, invfft - USE fft_base, ONLY: dffts -! - implicit none -! - complex(8) c(ngw), ca(ngw), df(ngw), da(ngw),psi(nnrs), psi2(nnrs) - integer iss1, iss2 - real(8) fi, fip - logical, intent(IN) :: lgam -! local variables - integer ir,ig, ipol !metagga - complex(8) fp,fm,ci -! -! - ci=(0.0d0,1.0d0) -! - do ipol = 1, 3 - psi(:)=(0.d0,0.d0) - IF(lgam) THEN - do ig=1,ngw - psi(nps(ig))=gx(ipol,ig)* (ci*c(ig) - ca(ig)) - psi(nms(ig))=gx(ipol,ig)* (CONJG(ci*c(ig) + ca(ig))) - end do - ELSE - do ig=1,ngw - psi(nps(ig))=gx(ipol,ig)* (ci*c(ig)) - psi2(nps(ig))=gx(ipol,ig)* (ci*ca(ig)) - end do - ENDIF - call invfft('Wave',psi,dffts ) - IF(.not.lgam) call invfft('Wave',psi,dffts ) -! on smooth grids--> grids for charge density - IF(lgam) THEN - do ir=1, nnrs - psi(ir) = & - CMPLX(kedtaus(ir,iss1)*DBLE(psi(ir)), kedtaus(ir,iss2)*AIMAG(psi(ir))) - end do - ELSE - do ir=1, nnrs - psi(ir) = kedtaus(ir,iss1)*psi(ir) - psi2(ir) = kedtaus(ir,iss2)*psi2(ir) - end do - ENDIF - call fwfft('Wave',psi, dffts ) - IF(.not.lgam) call fwfft('Wave',psi2, dffts ) - IF(lgam) THEN - do ig=1,ngw - fp= (psi(nps(ig)) + psi(nms(ig))) - fm= (psi(nps(ig)) - psi(nms(ig))) - df(ig)= df(ig) - ci*fi*tpiba2*gx(ipol,ig)*CMPLX(DBLE(fp), AIMAG(fm)) - da(ig)= da(ig) - ci*fip*tpiba2*gx(ipol,ig)*CMPLX(AIMAG(fp),-DBLE(fm)) - end do - ELSE - do ig=1,ngw - fp= psi(nps(ig)) - fm= psi2(nps(ig)) - df(ig)= df(ig) - ci*fi*tpiba2*gx(ipol,ig)*(ci*fm) - da(ig)= da(ig) - ci*fip*tpiba2*gx(ipol,ig)*(-ci *fp) - end do - ENDIF - end do - -! - return - end subroutine dforce_meta_new - - -!----------------------------------------------------------------------- - subroutine kedtauofr_meta (c, psi, npsi, psis, npsis ) -!----------------------------------------------------------------------- -! - use kinds, only: dp - use control_flags, only: tpre - use gvecs - use gvecw, only: ngw - use reciprocal_vectors, only: gx - use recvecs_indexes, only: np, nm - use grid_dimensions, only: nnr => nnrx - use cell_base - use smooth_grid_dimensions, only: nnrsx - use electrons_base, only: nx => nbspx, n => nbsp, f, ispin, nspin - use constants, only: pi, fpi -! - use cdvan - use dener - use metagga, ONLY : kedtaur, kedtaus, kedtaug, crosstaus, gradwfc, & - dkedtaus - USE cp_interfaces, ONLY: fwfft, invfft - USE fft_base, ONLY: dffts, dfftp - - implicit none - - integer, intent(in) :: npsi, npsis - complex(8) :: c(ngw,nx) - complex(8) :: psi( npsi ), psis( npsis ) - -! local variables - integer iss, isup, isdw, iss1, iss2, i, ir, ig - integer ipol, ix,iy, ipol2xy(3,3) - real(8) sa1, sa2 - complex(8) ci,fp,fm -! - psi( : ) = (0.d0,0.d0) -! - ci=(0.0d0,1.0d0) - kedtaur(:,:)=0.d0 - kedtaus(:,:)=0.d0 - kedtaug(:,:)=(0.d0,0.d0) - if(tpre) crosstaus(:,:,:)=0.d0 - -! -! -! warning! trhor and thdyn are not compatible yet! -! -! important: if n is odd then nx must be .ge.n+1 and c(*,n+1)=0. -! - if (mod(n,2).ne.0) then - c(1:ngw,n+1)=(0.d0,0.d0) - endif - ! - do i=1,n,2 - iss1=ispin(i) - sa1=f(i)/omega - if (i.ne.n) then - iss2=ispin(i+1) - sa2=f(i+1)/omega - else - iss2=iss1 - sa2=0.0d0 - end if - - do ipol = 1, 3 - psis( : ) = (0.d0,0.d0) - do ig=1,ngw - psis(nps(ig))=tpiba*gx(ipol,ig)* (ci*c(ig,i) - c(ig,i+1)) - psis(nms(ig))=tpiba*gx(ipol,ig)*CONJG(ci*c(ig,i)+c(ig,i+1)) - end do - ! gradient of wfc in real space - call invfft('Wave',psis, dffts ) - ! on smooth grids--> grids for charge density - do ir=1, nnrsx - kedtaus(ir,iss1)=kedtaus(ir,iss1)+0.5d0*sa1*DBLE(psis(ir))**2 - kedtaus(ir,iss2)=kedtaus(ir,iss2)+0.5d0*sa2*AIMAG(psis(ir))**2 - end do - if(tpre) then - do ir=1, nnrsx - gradwfc(ir,ipol)=psis(ir) - end do - end if - end do - if(tpre) then - ipol=1 - do ix=1,3 - do iy=1,ix - ipol2xy(ix,iy)=ipol - ipol2xy(iy,ix)=ipol - do ir=1,nnrsx - crosstaus(ir,ipol,iss1) = crosstaus(ir,ipol,iss1) +& - sa1*DBLE(gradwfc(ir,ix))*DBLE(gradwfc(ir,iy)) - crosstaus(ir,ipol,iss2) = crosstaus(ir,ipol,iss2) +& - sa2*AIMAG(gradwfc(ir,ix))*AIMAG(gradwfc(ir,iy)) - end do - ipol=ipol+1 - end do - end do - end if - - ! d kedtaug / d h - if(tpre) then - do iss=1,nspin - do ix=1,3 - do iy=1,3 - do ir=1,nnrsx - dkedtaus(ir,ix,iy,iss)=-kedtaus(ir,iss)*ainv(iy,ix)& - -crosstaus(ir,ipol2xy(1,ix),iss)*ainv(iy,1)& - -crosstaus(ir,ipol2xy(2,ix),iss)*ainv(iy,2)& - -crosstaus(ir,ipol2xy(3,ix),iss)*ainv(iy,3) - end do - end do - end do - end do - end if !end metagga - ! - end do -! kinetic energy density (kedtau) in g-space (kedtaug) - if(nspin.eq.1)then - iss=1 - - psis(1:nnrsx)=CMPLX(kedtaus(1:nnrsx,iss),0.d0) - call fwfft('Smooth',psis, dffts ) - kedtaug(1:ngs,iss)=psis(nps(1:ngs)) - - else - isup=1 - isdw=2 - - psis(1:nnrsx)=CMPLX(kedtaus(1:nnrsx,isup),kedtaus(1:nnrsx,isdw)) - call fwfft('Smooth',psis, dffts ) - do ig=1,ngs - fp= psis(nps(ig)) + psis(nms(ig)) - fm= psis(nps(ig)) - psis(nms(ig)) - kedtaug(ig,isup)=0.5d0*CMPLX( DBLE(fp),AIMAG(fm)) - kedtaug(ig,isdw)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - end do - - endif -! - if(nspin.eq.1) then -! ================================================================== -! case nspin=1 -! ------------------------------------------------------------------ - iss=1 - - psi( : ) = (0.d0,0.d0) - psi(nm(1:ngs))=CONJG(kedtaug(1:ngs,iss)) - psi(np(1:ngs))= kedtaug(1:ngs,iss) - call invfft('Dense',psi, dfftp ) - kedtaur(1:nnr,iss)=DBLE(psi(1:nnr)) - - else -! ================================================================== -! case nspin=2 -! ------------------------------------------------------------------ - isup=1 - isdw=2 - - psi( : ) = (0.d0,0.d0) - - do ig=1,ngs - psi(nm(ig))=CONJG(kedtaug(ig,isup))+ci*conjg(kedtaug(ig,isdw)) - psi(np(ig))=kedtaug(ig,isup)+ci*kedtaug(ig,isdw) - end do - call invfft('Dense',psi, dfftp ) - kedtaur(1:nnr,isup)= DBLE(psi(1:nnr)) - kedtaur(1:nnr,isdw)=AIMAG(psi(1:nnr)) - - endif - -! - return - end subroutine kedtauofr_meta -! -! -!----------------------------------------------------------------------- - subroutine vofrho_meta (v, vs) -!----------------------------------------------------------------------- -! computes: the one-particle potential v in real space, -! the total energy etot, -! the forces fion acting on the ions, -! the derivative of total energy to cell parameters h -! rhor input : electronic charge on dense real space grid -! (plus core charge if present) -! rhog input : electronic charge in g space (up to density cutoff) -! rhos input : electronic charge on smooth real space grid -! rhor output: total potential on dense real space grid -! rhos output: total potential on smooth real space grid -! - use kinds, only: dp - use control_flags, only: tpre - use gvecs - use gvecp, only: ng => ngm - use cell_base, only: omega - use recvecs_indexes, only: np, nm - use grid_dimensions, only: nnr => nnrx - use smooth_grid_dimensions, only: nr1s, nr2s, nr3s,nnrs => nnrsx - use electrons_base, only: nspin - use constants, only: pi, fpi - use core - use gvecb - use dener -! use derho - use mp, ONLY : mp_sum - use metagga, ONLY : kedtaur, kedtaug, kedtaus, dkedtaus - USE cp_interfaces, ONLY: fwfft, invfft - USE fft_base, ONLY: dffts, dfftp -! - implicit none -! - integer iss, isup, isdw, ig, ir,i,j - real(8) dkedxc(3,3) !metagga - complex(8) fp, fm, ci - complex(8) v(nnr), vs(nnrs) -! - ci=(0.d0,1.d0) - - v(:)=(0.d0,0.d0) -! -! =================================================================== -! calculation exchange and correlation energy and potential -! ------------------------------------------------------------------- -! if (nlcc.gt.0) call add_cc(rhoc,rhog,rhor) -! -#ifdef VARIABLECELL -! call exch_corr_h(nspin,rhog,rhor,exc,dxc) -#else -! call exch_corr(nspin,rhog,rhor,exc) -#endif -! -! rhor contains the xc potential in r-space -! -! =================================================================== -! fourier transform of xc potential to g-space (dense grid) -! ------------------------------------------------------------------- -! - if(nspin.eq.1) then - iss=1 - do ir=1,nnr - v(ir)=CMPLX(kedtaur(ir,iss),0.0d0) - end do - call fwfft('Dense',v, dfftp ) - ! - do ig=1,ng - kedtaug(ig,iss)=v(np(ig)) - end do - else - isup=1 - isdw=2 - - v(1:nnr)=CMPLX(kedtaur(1:nnr,isup),kedtaur(1:nnr,isdw)) - call fwfft('Dense',v, dfftp ) - do ig=1,ng - fp=v(np(ig))+v(nm(ig)) - fm=v(np(ig))-v(nm(ig)) - kedtaug(ig,isup)=0.5d0*CMPLX( DBLE(fp),AIMAG(fm)) - kedtaug(ig,isdw)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - end do - - endif -! - vs(:) = (0.d0,0.d0) - if(nspin.eq.1)then - iss=1 - do ig=1,ngs - vs(nms(ig))=CONJG(kedtaug(ig,iss)) - vs(nps(ig))=kedtaug(ig,iss) - end do -! - call invfft('Smooth',vs, dffts ) -! - kedtaus(1:nnrs,iss)=DBLE(vs(1:nnrs)) - else - isup=1 - isdw=2 - do ig=1,ngs - vs(nps(ig))=kedtaug(ig,isup)+ci*kedtaug(ig,isdw) - vs(nms(ig))=CONJG(kedtaug(ig,isup)) +ci*conjg(kedtaug(ig,isdw)) - end do - call invfft('Smooth',vs, dffts ) - kedtaus(1:nnrs,isup)= DBLE(vs(1:nnrs)) - kedtaus(1:nnrs,isdw)=AIMAG(vs(1:nnrs)) - endif - !calculate dkedxc in real space on smooth grids !metagga - if(tpre) then - do iss=1,nspin - do j=1,3 - do i=1,3 - dkedxc(i,j)=0.d0 - do ir=1,nnrs - !2.d0 : because kedtau = 0.5d0 d_Exc/d_kedtau - dkedxc(i,j)= dkedxc(i,j)+kedtaus(ir,iss)*2.d0*& - dkedtaus(ir,i,j,iss) - end do - end do - end do - end do -#ifdef PARA - call mp_sum( dkedxc, intra_image_comm ) -#endif - do j=1,3 - do i=1,3 - dxc(i,j) = dxc(i,j) + omega/(nr1s*nr2s*nr3s)*dkedxc(i,j) - end do - end do - end if - return - end subroutine vofrho_meta -!----------------------------------------------------------------------- diff --git a/quantum_espresso/kcp/CPV/cpr.f90 b/quantum_espresso/kcp/CPV/cpr.f90 deleted file mode 100644 index 74ccbeb01..000000000 --- a/quantum_espresso/kcp/CPV/cpr.f90 +++ /dev/null @@ -1,1173 +0,0 @@ -! -! Copyright (C) 2002-2008 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!---------------------------------------------------------------------------- -SUBROUTINE cprmain(tau_out, fion_out, etot_out) - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY: DP - USE constants, ONLY: bohr_radius_angs, amu_au, autoev - USE control_flags, ONLY: iprint, isave, thdyn, tpre, & - iprsta, tfor, remove_rigid_rot, & - tprnfor, tsdc, lconstrain, lwf, & - lneb, lcoarsegrained, nomore, & - tsde, tortho, tnosee, tnosep, & - tsdp, tcp, tcap, tnoseh, tolp, & - tprojwfc, textfor, non_ortho - USE core, ONLY: nlcc_any - USE cvan, ONLY: nvb - USE uspp, ONLY: nkb, vkb, okvan - USE energies, ONLY: eht, epseu, exc, etot, eself, & - ekin, atot, entropy, enthal, & - ekincm, print_energies, debug_energies - USE electrons_base, ONLY: nbspx, nbsp, ispin, f, nspin - USE electrons_base, ONLY: nelt, iupdwn, nupdwn - USE electrons_module, ONLY: wfc_spreads - USE efield_module, ONLY: tefield, allocate_efield, efield_update, & - berry_energy, tefield2, allocate_efield2, & - efield_update2, berry_energy2 - USE ensemble_dft, ONLY: tens, e0, z0t, fmat0, fmat0_diag, fmat0_diag_set, & - gibbsfe, tsmear, ef, ismear, degauss => etemp, & - id_matrix_init, psihpsi, nfroz_occ - USE cg_module, ONLY: tcg, cg_update, c0old - USE gvecs, ONLY: ngs - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: mill_l - USE ions_base, ONLY: na, nat, pmass, nsp - USE ions_base, ONLY: ind_srt, ions_cofmass, ions_kinene, & - ions_temp, ions_thermal_stress, if_pos, extfor - USE ions_base, ONLY: ions_vrescal, fricp, greasp, & - iforce, ndfrz, ions_shiftvar, ityp, & - ind_bck, cdm, cdms, ions_cofmsub - USE cell_base, ONLY: a1, a2, a3, b1, b2, b3, ainv, frich, & - greash, tpiba2, omega, ibrav, & - celldm, h, hold, hnew, velh, & - wmass, press, iforceh, cell_force - USE grid_dimensions, ONLY: nnrx, nr1, nr2, nr3 - USE smooth_grid_dimensions, ONLY: nnrsx - USE local_pseudo, ONLY: allocate_local_pseudo - USE io_global, ONLY: io_global_start, & - stdout, ionode, ionode_id - USE cdvan, ONLY: dbec - USE gvecw, ONLY: ggp - USE constants, ONLY: pi, k_boltzmann_au, au_ps - USE wave_base, ONLY: wave_steepest, wave_verlet - USE wave_base, ONLY: wave_speed2, frice, grease - USE control_flags, ONLY: conv_elec, tconvthrs, gamma_only, do_wf_cmplx !added:giovanni gamma_only, do_wf_cmplx - USE check_stop, ONLY: check_stop_now - USE efcalc, ONLY: clear_nbeg, ef_force - USE ions_base, ONLY: zv, ions_vel - USE cp_electronic_mass, ONLY: emass, emass_cutoff, emass_precond - USE ions_positions, ONLY: tau0, taum, taup, taus, tausm, tausp, & - vels, velsm, velsp, ions_hmove, & - ions_move, fion, fionm - USE ions_nose, ONLY: kbt, qnp, ndega, nhpcl, nhpdim, & - nhpbeg, nhpend, & - vnhp, xnhp0, xnhpm, xnhpp, & - atm2nhp, ions_nosevel, ions_noseupd, & - tempw, ions_nose_nrg, gkbt2nhp, & - ekin2nhp - USE electrons_nose, ONLY: qne, ekincw, xnhe0, xnhep, xnhem, & - vnhe, electrons_nose_nrg, & - electrons_nose_shiftvar, & - electrons_nosevel, electrons_noseupd - USE pres_ai_mod, ONLY: P_ext, P_in, P_fin, pvar, volclu, & - surfclu, Surf_t, abivol, abisur - USE wavefunctions_module, ONLY: c0, cm, phi => cp - USE wannier_module, ONLY: allocate_wannier - USE cp_interfaces, ONLY: printout_new, move_electrons, rhoofr, new_ns - USE printout_base, ONLY: printout_base_open, & - printout_base_close, & - printout_pos, printout_cell, & - printout_stress - USE cell_nose, ONLY: xnhh0, xnhhm, xnhhp, vnhh, temph, & - qnh, cell_nosevel, cell_noseupd, & - cell_nose_nrg, cell_nose_shiftvar - USE cell_base, ONLY: cell_kinene, cell_gamma, & - cell_move, cell_hmove - USE gvecw, ONLY: ecutw - USE gvecp, ONLY: ecutp - USE time_step, ONLY: delt, tps, dt2, twodelt - USE cp_interfaces, ONLY: cp_print_rho, nlfh, print_lambda - USE cp_main_variables, ONLY: acc, bec, lambda, lambdam, lambdap, lambda_bare, & - ema0bg, sfac, eigr, ei1, ei2, ei3, & - irb, taub, eigrb, rhos, & - rhor, bephi, becp, nfi, descla, iprint_stdout, & - nlax, hamilt, collect_zmat - USE autopilot, ONLY: max_event_step, restart_p - USE cell_base, ONLY: s_to_r, r_to_s - USE wannier_subroutines, ONLY: wannier_startup, wf_closing_options, & - ef_enthalpy - USE cp_interfaces, ONLY: readfile, writefile, eigs, strucf, phfacs, eigs_non_ortho - USE cp_interfaces, ONLY: empty_cp, ortho, elec_fakekine, print_projwfc - USE constraints_module, ONLY: check_constraint, remove_constr_force - USE metadyn_base, ONLY: set_target, mean_force - USE cp_autopilot, ONLY: pilot - USE ions_nose, ONLY: ions_nose_allocate, ions_nose_shiftvar - USE orthogonalize_base, ONLY: updatc - USE control_flags, ONLY: force_pairing - USE mp, ONLY: mp_bcast - USE mp_global, ONLY: intra_image_comm - USE ldaU, ONLY: lda_plus_u, vupsi - USE nksic, ONLY: do_orbdep, complexification_index, l_comp_cmplxfctn_index - USE step_constraint - USE small_box, ONLY: ainvb - USE descriptors, ONLY: descla_siz_ - USE twin_types - USE input_parameters, ONLY: fixed_state, fixed_band - ! - IMPLICIT NONE - ! - ! ... input/output variables - ! - REAL(DP), INTENT(OUT) :: tau_out(3, nat) - REAL(DP), INTENT(OUT) :: fion_out(3, nat) - REAL(DP), INTENT(OUT) :: etot_out - ! - ! ... control variables - ! - LOGICAL :: tfirst, tlast, tstop, tconv - LOGICAL :: ttprint, tfile, tstdout - LOGICAL :: tprint_ham - ! logical variable used to control printout - ! - ! ... forces on ions - ! - REAL(DP) :: maxfion, fion_tot(3) - ! - ! ... work variables - ! - REAL(DP) :: tempp, epot, epre, & - enow, econs, econt, fccc, ccc, bigr, dt2bye - REAL(DP) :: ekinc0, ekinp, ekinpr, ekinc - REAL(DP) :: temps(nat) - REAL(DP) :: ekinh, temphc - REAL(DP) :: delta_etot - REAL(DP) :: enb, enbi - INTEGER :: is, nacc, ia, iter, i, isa, ipos - INTEGER :: iss - REAL(DP) :: hgamma(3, 3), temphh(3, 3) - REAL(DP) :: fcell(3, 3) - REAL(DP) :: deltaP, ekincf - REAL(DP) :: stress(3, 3) - ! - REAL(DP), ALLOCATABLE :: usrt_tau0(:, :), usrt_taup(:, :), usrt_fion(:, :) - ! temporary array used to store unsorted positions and forces for - INTEGER :: nspin_sub, i1, i2 - ! - REAL(DP), ALLOCATABLE :: forceh(:, :) - REAL(DP), ALLOCATABLE :: fmat0_repl(:, :) - COMPLEX(DP), ALLOCATABLE :: fmat0_repl_c(:, :) - LOGICAL :: lgam - COMPLEX(DP), PARAMETER :: c_zero = CMPLX(0.d0, 0.d0) - -!$$ - LOGICAL :: ttest -!$$ - iter = 0 - lgam = gamma_only .and. .not. do_wf_cmplx - ! - ! - dt2bye = dt2/emass - etot_out = 0.D0 - enow = 1.D9 - ! - tfirst = .TRUE. - tlast = .FALSE. - nacc = 5 - ! - nspin_sub = nspin - IF (force_pairing) nspin_sub = 1 - ! - ! ... Check for restart_p from Autopilot Feature Suite - ! - IF (restart_p) THEN - ! - ! ... do not add past nfi - ! - nomore = nomore - ! - END IF - ! - IF (lda_plus_u) ALLOCATE (forceh(3, nat)) - - ! - ! setup data to printout herm and anti-herm - ! measures of the hamiltonian H_ij = < i | h_j | j > - ! - ! matrix elements stored in hamilt - ! - tprint_ham = do_orbdep .AND. (iprsta > 1) - ! - DO iss = 1, size(hamilt) - call set_twin(hamilt(iss), c_zero) - END DO - ! - !====================================================================== - ! - ! basic loop for molecular dynamics starts here - ! - !====================================================================== - ! - main_loop: DO - ! - CALL start_clock('total_time') -!$$ For CG calculation, one minimization is enough - if (tcg) tlast = .true. -!$$ - ! - nfi = nfi + 1 - tlast = (nfi == nomore) .OR. tlast - ttprint = (MOD(nfi, iprint) == 0) .OR. tlast - tfile = (MOD(nfi, iprint) == 0) - tstdout = (MOD(nfi, iprint_stdout) == 0) .OR. tlast - ! - IF (abivol) THEN - IF (pvar) THEN - IF (nfi .EQ. 1) THEN - deltaP = (P_fin - P_in)/DBLE(nomore) - P_ext = P_in - ELSE - P_ext = P_ext + deltaP - END IF - END IF - END IF - ! - IF (ionode .AND. tstdout) & - WRITE (stdout, '(/," * Physical Quantities at step:",I6)') nfi - ! - IF (tnosee) THEN - fccc = 1.D0/(1.D0 + 0.5D0*delt*vnhe) - ELSE IF (tsde) THEN - fccc = 1.D0 - ELSE - fccc = 1.D0/(1.D0 + frice) - END IF - ! - ! ... calculation of velocity of nose-hoover variables - ! - IF (tnosep) THEN - ! - CALL ions_nosevel(vnhp, xnhp0, xnhpm, delt, nhpcl, nhpdim) - ! - END IF - ! - IF (tnosee) THEN - ! - CALL electrons_nosevel(vnhe, xnhe0, xnhem, delt) - ! - END IF - ! - IF (tnoseh) THEN - ! - CALL cell_nosevel(vnhh, xnhh0, xnhhm, delt) - ! - velh(:, :) = 2.D0*(h(:, :) - hold(:, :))/delt - velh(:, :) - ! - END IF - ! - IF ((okvan .or. nlcc_any) .AND. (tfor .OR. thdyn .OR. tfirst)) THEN - ! - CALL initbox(tau0, taub, irb, ainv, a1, a2, a3) - ! - CALL phbox(taub, eigrb, ainvb) - ! - END IF - ! - IF (tfor .OR. thdyn) THEN - ! - CALL phfacs(ei1, ei2, ei3, eigr, mill_l, taus, nr1, nr2, nr3, nat) - ! - ! ... strucf calculates the structure factor sfac - ! - CALL strucf(sfac, ei1, ei2, ei3, mill_l, ngs) - ! - END IF - ! - IF (thdyn) THEN - ! - CALL formf(tfirst, eself) - ! - END IF - ! - ! ... why this call ??? from Paolo Umari - ! - IF (tefield .or. tefield2) THEN - ! - CALL calbec(1, nsp, eigr, c0, bec) ! ATTENZIONE - ! - END IF - ! - ! Autopilot (Dynamic Rules) Implimentation - ! - call pilot(nfi) - ! - IF ((tfor .OR. tfirst) .AND. tefield) CALL efield_update(eigr) - IF ((tfor .OR. tfirst) .AND. tefield2) CALL efield_update2(eigr) - ! - IF (lda_plus_u) then - ! forceh ! Forces on ions due to Hubbard U - forceh = 0.0d0 - ! vupsi ! potentials on electrons due to Hubbard U - vupsi = (0.0d0, 0.0d0) - ! vpsi_con ! potentials on electrons due to occupation constraints ...not yet implemented... - vpsi_con = (0.0d0, 0.0d0) - ! - CALL new_ns(c0, eigr, vkb, vupsi, vpsi_con, forceh) - if (mod(nfi, iprint) .eq. 0) call write_ns - end if - - !======================================================================= - ! - ! electronic degrees of freedom are updated here - ! - !======================================================================= - ! - IF (force_pairing) THEN - c0(:, iupdwn(2):nbsp) = c0(:, 1:nupdwn(2)) - cm(:, iupdwn(2):nbsp) = cm(:, 1:nupdwn(2)) - phi(:, iupdwn(2):nbsp) = phi(:, 1:nupdwn(2)) -!begin_modified:giovanni warning: is nspin=2? - IF (.not. lambda(1)%iscmplx) THEN - lambda(2)%rvec(:, :) = lambda(1)%rvec(:, :) - ELSE - lambda(2)%cvec(:, :) = lambda(1)%cvec(:, :) - END IF -!end_modified:giovanni - END IF - ! - ! ... fake electronic kinetic energy - ! - IF (.NOT. tcg) THEN - ! - ekincf = 0.0d0 - - CALL elec_fakekine(ekincf, ema0bg, emass, cm, c0, ngw, nbsp, 1, delt) - ! - END IF - ! - CALL move_electrons(nfi, tfirst, tlast, b1, b2, b3, fion, & - enthal, enb, enbi, fccc, ccc, dt2bye, stress, & - tprint_ham=tprint_ham) - ! - IF (lda_plus_u) fion = fion + forceh - ! - IF (tpre) THEN - ! - CALL nlfh(stress, bec, dbec, lambda) - ! - CALL ions_thermal_stress(stress, pmass, omega, h, vels, nsp, na) - ! - END IF - ! - !======================================================================= - ! - ! verlet algorithm - ! - ! loop which updates cell parameters and ionic degrees of freedom - ! hnew=h(t+dt) is obtained from hold=h(t-dt) and h=h(t) - ! tausp=pos(t+dt) from tausm=pos(t-dt) taus=pos(t) h=h(t) - ! - ! guessed displacement of ions - !======================================================================= - ! - hgamma(:, :) = 0.D0 - ! - IF (thdyn) THEN - ! - CALL cell_force(fcell, ainv, stress, omega, press, wmass) - ! - CALL cell_move(hnew, h, hold, delt, iforceh, & - fcell, frich, tnoseh, vnhh, velh, tsdc) - ! - velh(:, :) = (hnew(:, :) - hold(:, :))/twodelt - ! - CALL cell_gamma(hgamma, ainv, h, velh) - ! - END IF - ! - !====================================================================== - ! - IF (tfor) THEN - ! - IF (lwf) CALL ef_force(fion, na, nsp, zv) - ! - IF (textfor) THEN - ! - FORALL (ia=1:nat) fion(:, ia) = fion(:, ia) + extfor(:, ia) - ! - fion_tot(:) = SUM(fion(:, :), DIM=2)/DBLE(nat) - ! - FORALL (ia=1:nat) fion(:, ia) = fion(:, ia) - fion_tot(:) - ! - END IF - ! - IF (remove_rigid_rot) & - CALL remove_tot_torque(nat, tau0, pmass(ityp(ind_srt(:))), fion) - ! - IF (lconstrain) THEN - ! - IF (ionode) THEN - ! - ALLOCATE (usrt_tau0(3, nat)) - ALLOCATE (usrt_taup(3, nat)) - ALLOCATE (usrt_fion(3, nat)) - ! - usrt_tau0(:, :) = tau0(:, ind_bck(:)) - usrt_fion(:, :) = fion(:, ind_bck(:)) - ! - IF (lcoarsegrained) CALL set_target() - ! - ! ... we first remove the component of the force along the - ! ... constrain gradient (this constitutes the initial guess - ! ... for the lagrange multiplier) - ! - CALL remove_constr_force(nat, usrt_tau0, if_pos, ityp, 1.D0, usrt_fion) - ! - fion(:, :) = usrt_fion(:, ind_srt(:)) - ! - END IF - ! - CALL mp_bcast(fion, ionode_id, intra_image_comm) - ! - END IF - ! - CALL ions_move(tausp, taus, tausm, iforce, pmass, fion, ainv, & - delt, na, nsp, fricp, hgamma, vels, tsdp, tnosep, & - fionm, vnhp, velsp, velsm, nhpcl, nhpdim, atm2nhp) - ! - IF (lconstrain) THEN - ! - ! ... constraints are imposed here - ! - IF (ionode) THEN - ! - CALL s_to_r(tausp, taup, na, nsp, hnew) - ! - usrt_taup(:, :) = taup(:, ind_bck(:)) - ! - CALL check_constraint(nat, usrt_taup, usrt_tau0, usrt_fion, & - if_pos, ityp, 1.D0, delt, amu_au) - ! - taup(:, :) = usrt_taup(:, ind_srt(:)) - fion(:, :) = usrt_fion(:, ind_srt(:)) - ! - ! ... average value of the lagrange multipliers - ! - IF (lcoarsegrained) CALL mean_force(nfi, etot, 1.D0) - ! - DEALLOCATE (usrt_tau0, usrt_taup, usrt_fion) - ! - END IF - ! - CALL mp_bcast(taup, ionode_id, intra_image_comm) - CALL mp_bcast(fion, ionode_id, intra_image_comm) - ! - CALL r_to_s(taup, tausp, na, nsp, ainv) - ! - END IF - ! - CALL ions_cofmass(tausp, pmass, na, nsp, cdm) - ! - IF (ndfrz == 0) & - CALL ions_cofmsub(tausp, iforce, nat, cdm, cdms) - ! - CALL s_to_r(tausp, taup, na, nsp, hnew) - ! - END IF - ! - !-------------------------------------------------------------------------- - ! initialization with guessed positions of ions - !-------------------------------------------------------------------------- - ! - ! ... if thdyn=true g vectors and pseudopotentials are recalculated for - ! ... the new cell parameters - ! - IF (tfor .OR. thdyn) THEN - ! - IF (thdyn) THEN - ! - hold = h - h = hnew - ! - CALL newinit(h) - ! - CALL newnlinit() - ! - ELSE - ! - hold = h - ! - END IF - ! - ! ... phfac calculates eigr - ! - CALL phfacs(ei1, ei2, ei3, eigr, mill_l, tausp, nr1, nr2, nr3, nat) - ! - ! ... prefor calculates vkb - ! - CALL prefor(eigr, vkb) - ! - END IF - ! - !-------------------------------------------------------------------------- - ! imposing the orthogonality - !-------------------------------------------------------------------------- - ! - ! - IF (.NOT. tcg) THEN - ! - IF (fixed_state) THEN - ! - CALL gram_swap(vkb, bec, nkb, cm, ngw, nbsp) - ! - ELSE - ! - IF (tortho) THEN - ! - CALL ortho_cp_twin(eigr(1:ngw, 1:nat), cm(1:ngw, 1:nbsp), phi(1:ngw, 1:nbsp), ngw, & - lambda(1:nspin), descla(1:descla_siz_, 1:nspin), & - bigr, iter, ccc, bephi, becp, nbsp, nspin, nupdwn, iupdwn) - ! - ELSEIF (.not. non_ortho) THEN - ! - CALL gram(vkb, bec, nkb, cm, ngw, nbsp) - ! - IF (iprsta > 4) CALL dotcsc(eigr, cm, ngw, nbsp, lgam)!added:giovanni lgam - ! - END IF - ! - ! correction to displacement of ions - ! - IF (tortho) THEN - ! - DO iss = 1, nspin_sub - i1 = (iss - 1)*nlax + 1 - i2 = iss*nlax - ! - IF (.not. lambda(iss)%iscmplx) THEN - ! - CALL updatc(ccc, nbsp, lambda(iss)%rvec, SIZE(lambda(iss)%rvec, 1), & - phi, SIZE(phi, 1), bephi%rvec(:, i1:i2), SIZE(bephi%rvec, 1), becp%rvec, & - bec%rvec, cm, nupdwn(iss), iupdwn(iss), descla(:, iss)) - ! - ELSE - ! - CALL updatc(ccc, nbsp, lambda(iss)%cvec, SIZE(lambda(iss)%cvec, 1), & - phi, SIZE(phi, 1), bephi%cvec(:, i1:i2), SIZE(bephi%cvec, 1), becp%cvec, & - bec%cvec, cm, nupdwn(iss), iupdwn(iss), descla(:, iss)) - ! - END IF - ! - END DO - ! - END IF - ! - END IF - ! - IF (force_pairing) THEN - c0(:, iupdwn(2):nbsp) = c0(:, 1:nupdwn(2)) - cm(:, iupdwn(2):nbsp) = cm(:, 1:nupdwn(2)) - phi(:, iupdwn(2):nbsp) = phi(:, 1:nupdwn(2)) - IF (.not. lambda(1)%iscmplx) THEN - lambda(2)%rvec(:, :) = lambda(1)%rvec(:, :) - ELSE - lambda(2)%cvec(:, :) = lambda(1)%cvec(:, :) - END IF - END IF - ! - CALL calbec(nvb + 1, nsp, eigr, cm, bec) - ! - IF (tpre) THEN - CALL caldbec(ngw, nkb, nbsp, 1, nsp, eigr, cm, dbec) - END IF - ! - IF (iprsta >= 3) CALL dotcsc(eigr, cm, ngw, nbsp, lgam)!added:giovanni lgam - ! - END IF - ! - !-------------------------------------------------------------------------- - ! temperature monitored and controlled - !-------------------------------------------------------------------------- - ! - ekinp = 0.D0 - ekinpr = 0.D0 - tempp = 0.D0 - temps = 0.D0 - ekinc0 = 0.0d0 - ekinc = 0.0d0 - ! - ! - ! ... ionic kinetic energy and temperature - ! - IF (tfor) THEN - ! - CALL ions_vel(vels, tausp, tausm, na, nsp, delt) - ! - CALL ions_kinene(ekinp, vels, na, nsp, hold, pmass) - ! - CALL ions_temp(tempp, temps, ekinpr, vels, na, nsp, & - hold, pmass, ndega, nhpdim, atm2nhp, ekin2nhp) - ! - END IF - ! - ! ... fake electronic kinetic energy - ! - IF (.NOT. tcg) THEN - ! - CALL elec_fakekine(ekinc0, ema0bg, emass, c0, cm, ngw, nbsp, 1, delt) - ! - ekinc0 = (ekinc0 + ekincf)*0.5d0 - ! - ekinc = ekinc0 - ! - END IF - ! - ! ... fake cell-parameters kinetic energy - ! - ekinh = 0.D0 - ! - IF (thdyn) THEN - ! - CALL cell_kinene(ekinh, temphh, velh) - ! - END IF - ! - IF (COUNT(iforceh == 1) > 0) THEN - ! - temphc = 2.D0/k_boltzmann_au*ekinh/DBLE(COUNT(iforceh == 1)) - ! - ELSE - ! - temphc = 0.D0 - ! - END IF - ! - ! ... udating nose-hoover friction variables - ! - IF (tnosep) CALL ions_noseupd(xnhpp, xnhp0, xnhpm, delt, qnp, & - ekin2nhp, gkbt2nhp, vnhp, kbt, & - nhpcl, nhpdim, nhpbeg, nhpend) - ! - IF (tnosee) CALL electrons_noseupd(xnhep, xnhe0, xnhem, & - delt, qne, ekinc, ekincw, vnhe) - ! - IF (tnoseh) CALL cell_noseupd(xnhhp, xnhh0, xnhhm, & - delt, qnh, temphh, temph, vnhh) - ! - ! ... warning: thdyn and tcp/tcap are not compatible yet!!! - ! - IF (tcp .OR. tcap .AND. tfor .AND. .NOT. thdyn) THEN - ! - IF (tempp > (tempw + tolp) .OR. & - tempp < (tempw - tolp) .AND. tempp /= 0.D0) THEN - ! - CALL ions_vrescal(tcap, tempw, tempp, taup, & - tau0, taum, na, nsp, fion, iforce, pmass, delt) - ! - END IF - ! - END IF - ! - IF (MOD(nfi, iprint) == 0 .OR. tlast) THEN - ! - ! In order to calculate the eigenvalues for CG case - ! - IF (tortho .or. tcg) THEN - ! - ! test orthonormality of wavefunctions here - ! - IF (force_pairing) THEN - IF (.not. lambda(1)%iscmplx) THEN - lambda(2)%rvec(:, :) = lambda(1)%rvec(:, :) - ELSE - lambda(2)%cvec(:, :) = lambda(1)%cvec(:, :) - END IF - IF (.not. lambdap(1)%iscmplx) THEN - lambdap(2)%rvec(:, :) = lambdap(1)%rvec(:, :) - ELSE - lambdap(2)%cvec(:, :) = lambdap(1)%cvec(:, :) - END IF - WRITE (stdout, '("Occupations in CPR:")') - WRITE (stdout, '(10F9.6)') (f(i), i=1, nbspx) - END IF - ! - IF (non_ortho) THEN - CALL eigs_non_ortho(nfi, lambdap, lambda) - ELSE - CALL eigs(nfi, lambdap, lambda) - END IF - ! - ! ... Compute empty states - ! - CALL empty_cp(nfi, c0, rhos, tcg) - ! - ELSE - ! - WRITE (stdout, '(6x,"NOTE: eigenvalues are not computed without ortho")') - ! - CALL empty_cp(nfi, c0, rhos, tcg) - ! - END IF - ! - END IF - ! - IF (lwf) CALL ef_enthalpy(enthal, tau0) - ! - ! poorman eDFT - ! occupations are re-computed according - ! to the eigenvalues (recomputed as well) - ! - IF (tsmear .AND. tortho .AND. (MOD(nfi, nfroz_occ) == 0 .OR. .NOT. fmat0_diag_set)) THEN - ! - !CALL inner_loop_smear( c0, bec, rhos, psihpsi ) - DO iss = 1, nspin - call copy_twin(psihpsi(iss), lambda(iss)) - END DO - ! - CALL inner_loop_diag(c0, bec%rvec, psihpsi, z0t, e0) - ! - CALL efermi(nelt, nbsp, degauss, 1, f, ef, e0, entropy, ismear, nspin) - ! - fmat0_diag_set = .TRUE. - ! - ! recompute the proper density matrix, once z0t is given - ! and store its diagonal components - ! - call calcmt_twin(f, z0t, fmat0, .false.) - ! - DO iss = 1, nspin - ! - IF (.not. fmat0(iss)%iscmplx) THEN - ALLOCATE (fmat0_repl(nupdwn(iss), nupdwn(iss))) - ! - CALL collect_zmat(fmat0_repl, fmat0(iss)%rvec(:, :), descla(:, iss)) - ! - DO i = 1, nupdwn(iss) - ! - fmat0_diag(i + iupdwn(iss) - 1) = fmat0_repl(i, i) - ! - END DO - ! - DEALLOCATE (fmat0_repl) - ELSE - ALLOCATE (fmat0_repl_c(nupdwn(iss), nupdwn(iss))) - ! - CALL collect_zmat(fmat0_repl_c, fmat0(iss)%cvec(:, :), descla(:, iss)) - ! - DO i = 1, nupdwn(iss) - ! - fmat0_diag(i + iupdwn(iss) - 1) = fmat0_repl_c(i, i) - ! - END DO - ! - DEALLOCATE (fmat0_repl_c) - END IF - ! - END DO - ! - END IF - ! - IF (tens) THEN - ! - IF (MOD(nfi, iprint) == 0 .OR. tlast) THEN - ! - WRITE (stdout, '("Occupations :")') - WRITE (stdout, '(10F9.6)') (f(i), i=1, nbsp) - ! - END IF - ! - END IF - ! - epot = eht + epseu + exc - ! - IF (.NOT. tcg) THEN - ! - econs = ekinp + ekinh + enthal - econt = econs + ekinc - ! - ELSE - ! - IF (.NOT. tens) THEN - ! - econs = ekinp + etot - atot = etot - econt = econs - ! - ELSE - ! - gibbsfe = atot - econs = ekinp + atot - econt = econs - ! - END IF - ! - END IF - ! - ! ... add energies of thermostats - ! - IF (tnosep) & - econt = econt + ions_nose_nrg(xnhp0, vnhp, qnp, & - gkbt2nhp, kbt, nhpcl, nhpdim) - IF (tnosee) & - econt = econt + electrons_nose_nrg(xnhe0, vnhe, qne, ekincw) - IF (tnoseh) & - econt = econt + cell_nose_nrg(qnh, xnhh0, vnhh, temph, iforceh) - ! - tps = tps + delt*au_ps - ! - if (abivol) etot = etot - P_ext*volclu - if (abisur) etot = etot - Surf_t*surfclu - ! - ! CALL debug_energies() - ! - IF (do_orbdep .and. (tstdout .or. (MOD(nfi, iprint_stdout) == 0))) THEN - ! - !Sort wavefunctions with respect to spread !!added:giovanni - ! - IF (allocated(wfc_spreads)) THEN - ! - ! Here Linh comment the below routine, to make sure orbitals, - ! and their spreads are consistent. - ! - !call spread_sort(ngw, nspin, nbsp, nudx, nupdwn, iupdwn, & - ! wfc_spreads, wfc_centers, sort_spreads) - ! - END IF - ! - IF (do_wf_cmplx .AND. l_comp_cmplxfctn_index) THEN - ! - ! Compute complexification index - ! - call compute_complexification_index(ngw, nnrx, nnrsx, nbsp, nbspx, nspin, ispin, & - iupdwn, nupdwn, c0, bec, complexification_index) - ! - END IF - ! - END IF - ! - CALL printout_new(nfi, tfirst, tfile, tstdout, ttprint, tps, hold, stress, & - tau0, vels, fion, ekinc, temphc, tempp, temps, etot, & - enthal, econs, econt, vnhh, xnhh0, vnhp, xnhp0, atot, & - ekin, epot, tprnfor, tpre, hamilt, tprint_ham, lgam) - ! - if (abivol) etot = etot + P_ext*volclu - if (abisur) etot = etot + Surf_t*surfclu - ! - IF (tfor) THEN - ! - ! ... new variables for next step - ! - CALL ions_shiftvar(taup, tau0, taum) ! real positions - CALL ions_shiftvar(tausp, taus, tausm) ! scaled positions - CALL ions_shiftvar(velsp, vels, velsm) ! scaled velocities - ! - IF (tnosep) CALL ions_nose_shiftvar(xnhpp, xnhp0, xnhpm) - IF (tnosee) CALL electrons_nose_shiftvar(xnhep, xnhe0, xnhem) - IF (tnoseh) CALL cell_nose_shiftvar(xnhhp, xnhh0, xnhhm) - ! - END IF - ! - write (6, *) "tnosep=", tnosep, "thdyn=", thdyn - ! - IF (thdyn) CALL emass_precond(ema0bg, ggp, ngw, tpiba2, emass_cutoff) - ! - ekincm = ekinc0 - ! - ! ... cm=c(t+dt) c0=c(t) - ! - IF (.NOT. tcg) THEN - ! - CALL dswap(2*ngw*nbsp, c0, 1, cm, 1) - ! - ELSE - ! - CALL cg_update(tfirst, nfi, c0) - ! - IF (tfor .AND. .NOT. (tens) .AND. & - ((MOD(nfi, isave) == 0) .OR. tlast)) THEN - ! - ! ... in this case optimize c0 and lambda for smooth - ! ... restart with CP - ! - IF (okvan .or. nlcc_any) THEN - CALL initbox(tau0, taub, irb, ainv, a1, a2, a3) - CALL phbox(taub, eigrb, ainvb) - END IF - CALL r_to_s(tau0, taus, na, nsp, ainv) - CALL phfacs(ei1, ei2, ei3, eigr, mill_l, taus, nr1, nr2, nr3, nat) - CALL strucf(sfac, ei1, ei2, ei3, mill_l, ngs) - ! - IF (thdyn) CALL formf(tfirst, eself) - IF (tefield) CALL efield_update(eigr) - IF (tefield2) CALL efield_update2(eigr) - ! - lambdam = lambda - ! - CALL move_electrons(nfi, tfirst, tlast, b1, b2, b3, & - fion, enthal, enb, enbi, fccc, ccc, dt2bye, stress) - ! - END IF - ! - END IF - ! - ! ... now: cm=c(t) c0=c(t+dt) - ! - tfirst = .FALSE. - ! - ! ... write on file ndw each isave - ! - IF ((MOD(nfi, isave) == 0) .AND. (nfi < nomore)) THEN - ! - IF (tcg) THEN - ! - CALL writefile(h, hold, nfi, c0, c0old, taus, tausm, & - vels, velsm, acc, lambda, lambdam, lambda_bare, xnhe0, xnhem, & - vnhe, xnhp0, xnhpm, vnhp, nhpcl, nhpdim, ekincm, xnhh0, & - xnhhm, vnhh, velh, fion, tps, z0t, f, rhor) - ! - ELSE - ! - CALL writefile(h, hold, nfi, c0, cm, taus, tausm, & - vels, velsm, acc, lambda, lambdam, lambda_bare, xnhe0, xnhem, & - vnhe, xnhp0, xnhpm, vnhp, nhpcl, nhpdim, ekincm, xnhh0, & - xnhhm, vnhh, velh, fion, tps, z0t, f, rhor) - ! - END IF - ! - END IF - ! - epre = enow - enow = etot - ! - frice = frice*grease - fricp = fricp*greasp - frich = frich*greash - ! - !====================================================================== - ! - CALL stop_clock('total_time') - ! - delta_etot = ABS(epre - enow) - ! - tstop = check_stop_now() .OR. tlast - ! - ttest = check_stop_now() - tstop = ttest .OR. tlast - ! - tconv = .FALSE. - ! - IF (tconvthrs%active) THEN - ! - ! ... electrons - ! - tconv = (ekinc < tconvthrs%ekin .AND. delta_etot < tconvthrs%derho) - ! - IF (tfor) THEN - ! - ! ... ions - ! - maxfion = MAXVAL(ABS(fion(:, 1:nat))) - ! - tconv = tconv .AND. (maxfion < tconvthrs%force) - ! - END IF - ! - END IF - ! - ! ... in the case cp-wf the check on convergence is done starting - ! ... from the second step - ! - IF (lwf .AND. tfirst) tconv = .FALSE. - ! - IF (tconv) THEN - ! - tlast = .TRUE. - ! - IF (ionode) THEN - ! - WRITE (stdout, & - & "(/,3X,'MAIN:',10X,'EKINC (thr)', & - & 10X,'DETOT (thr)',7X,'MAXFORCE (thr)')") - WRITE (stdout, "(3X,'MAIN: ',3(D14.6,1X,D8.1))") & - ekinc, tconvthrs%ekin, delta_etot, & - tconvthrs%derho, 0.D0, tconvthrs%force - WRITE (stdout, & - "(3X,'MAIN: convergence achieved for system relaxation')") - ! - END IF - ! - END IF - ! - IF (lwf) & - CALL wf_closing_options(nfi, c0, cm, bec, eigr, eigrb, taub, & - irb, ibrav, b1, b2, b3, taus, tausm, vels, & - velsm, acc, lambda, lambdam, lambda_bare, xnhe0, & - xnhem, & - vnhe, xnhp0, xnhpm, vnhp, nhpcl, nhpdim, & - ekincm, xnhh0, xnhhm, vnhh, velh, ecutp, & - ecutw, delt, celldm, fion, tps, z0t, f, rhor) - ! - ! exit main_loop - ! - IF (tstop) EXIT main_loop - ! - END DO main_loop - ! - !===================== end of main loop of molecular dynamics =============== - ! - ! ... Here copy relevant physical quantities into the output arrays/variables - ! - etot_out = etot - ! - isa = 0 - ! - DO is = 1, nsp - ! - DO ia = 1, na(is) - ! - isa = isa + 1 - ! - ipos = ind_srt(isa) - ! - tau_out(:, ipos) = tau0(:, isa) - ! - fion_out(:, ipos) = fion(:, isa) - ! - END DO - ! - END DO - ! - IF (lneb) fion_out(:, 1:nat) = fion(:, 1:nat)*DBLE(if_pos(:, 1:nat)) - ! - conv_elec = .TRUE. - ! - IF (tcg) cm = c0old - ! - CALL writefile(h, hold, nfi, c0, cm, taus, tausm, & - vels, velsm, acc, lambda, lambdam, lambda_bare, xnhe0, xnhem, vnhe, & - xnhp0, xnhpm, vnhp, nhpcl, nhpdim, ekincm, xnhh0, xnhhm, & - vnhh, velh, fion, tps, z0t, f, rhor) - ! - IF (tprojwfc) CALL print_projwfc(c0, lambda, eigr, vkb) - ! - IF (iprsta > 1 .OR. fixed_state) CALL print_lambda(lambda, nbsp, nbsp, 1.D0) - ! - IF (lda_plus_u) DEALLOCATE (forceh) - ! - RETURN - ! -END SUBROUTINE cprmain -! -!---------------------------------------------------------------------------- -SUBROUTINE terminate_run() - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY: DP - USE io_global, ONLY: stdout, ionode - USE cg_module, ONLY: tcg, print_clock_tcg - USE mp, ONLY: mp_report - USE control_flags, ONLY: use_task_groups - USE nksic, ONLY: do_orbdep - USE hfmod, ONLY: do_hf - ! - IMPLICIT NONE - ! - ! ... print statistics - ! - CALL printacc() - ! - CALL print_clock('initialize') - CALL print_clock('total_time') - CALL print_clock('main_loop') - CALL print_clock('formf') - CALL print_clock('rhoofr') - CALL print_clock('vofrho') - CALL print_clock('vofrho1') - CALL print_clock('vofrho2') - CALL print_clock('vofrho3') - CALL print_clock('vofrho4') - CALL print_clock('vofrho5') - CALL print_clock('dforce') - CALL print_clock('dforce1') - CALL print_clock('dforce2') - CALL print_clock('calphi') - CALL print_clock('ortho') - CALL print_clock('ortho_iter') - CALL print_clock('rsg') - CALL print_clock('rhoset') - CALL print_clock('updatc') - CALL print_clock('gram') - CALL print_clock('newd') - CALL print_clock('calbec') - CALL print_clock('prefor') - CALL print_clock('strucf') - CALL print_clock('nlfl') - CALL print_clock('nlfq') - CALL print_clock('set_cc') - CALL print_clock('rhov') - CALL print_clock('nlsm1') - CALL print_clock('nlsm2') - CALL print_clock('forcecc') - CALL print_clock('fft') - CALL print_clock('ffts') - CALL print_clock('fftw') - CALL print_clock('fftb') - CALL print_clock('cft3s') - CALL print_clock('fft_scatter') - IF (ionode) WRITE (stdout, "()") - ! - IF (do_orbdep) THEN - ! - CALL print_clock('nk_drv') - CALL print_clock('nk_orbrho') - CALL print_clock('nk_rhoref') - CALL print_clock('nk_eforce') - CALL print_clock('nk_corr') - CALL print_clock('nk_corr_h') - CALL print_clock('nk_corr_vxc') - CALL print_clock('nk_corr_fxc') - ! - IF (ionode) WRITE (stdout, "()") - CALL print_clock('nk_rot_emin') - CALL print_clock('nk_innerloop') - CALL print_clock('nk_rot_cm') - CALL print_clock('nk_get_vsicah') - CALL print_clock('nk_getOmattot') - CALL print_clock('nk_getOmat1') - CALL print_clock('nk_rotwfn') - IF (ionode) WRITE (stdout, "()") - ! - END IF - ! - IF (do_hf) THEN - ! - CALL print_clock('hf_potential') - CALL print_clock('hf_corr') - IF (ionode) WRITE (stdout, "()") - ! - END IF - ! - IF (tcg) THEN - ! - CALL print_clock('outer_loop') - CALL print_clock('inner_loop') - call print_clock_tcg() - ! - END IF - ! - IF (use_task_groups) THEN - ! - CALL print_clock('ALLTOALL') - ! - END IF - ! - CALL mp_report() - ! -END SUBROUTINE terminate_run diff --git a/quantum_espresso/kcp/CPV/cpr_mod.f90 b/quantum_espresso/kcp/CPV/cpr_mod.f90 deleted file mode 100644 index c6751a17b..000000000 --- a/quantum_espresso/kcp/CPV/cpr_mod.f90 +++ /dev/null @@ -1,55 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE dqrad_mod - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - ! - IMPLICIT NONE - SAVE - ! - REAL(DP), ALLOCATABLE :: dqrad(:,:,:,:,:,:) - ! - CONTAINS - ! - SUBROUTINE deallocate_dqrad_mod() - ! - IF ( ALLOCATED( dqrad ) ) DEALLOCATE( dqrad ) - ! - END SUBROUTINE deallocate_dqrad_mod - ! -END MODULE dqrad_mod -! -!---------------------------------------------------------------------------- -module betax - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - ! - IMPLICIT NONE - SAVE - ! - INTEGER :: mmx = 5000 - REAL(DP) :: refg - REAL(DP),ALLOCATABLE :: betagx(:,:,:), dbetagx(:,:,:), & - qradx(:,:,:,:), dqradx(:,:,:,:) - ! - CONTAINS - ! - SUBROUTINE deallocate_betax() - ! - IF ( ALLOCATED( betagx ) ) DEALLOCATE( betagx ) - IF ( ALLOCATED( dbetagx ) ) DEALLOCATE( dbetagx ) - IF ( ALLOCATED( qradx ) ) DEALLOCATE( qradx ) - IF ( ALLOCATED( dqradx ) ) DEALLOCATE( dqradx ) - ! - END SUBROUTINE deallocate_betax - ! -END MODULE betax -! diff --git a/quantum_espresso/kcp/CPV/cprstart.f90 b/quantum_espresso/kcp/CPV/cprstart.f90 deleted file mode 100644 index 4651bea18..000000000 --- a/quantum_espresso/kcp/CPV/cprstart.f90 +++ /dev/null @@ -1,149 +0,0 @@ -! -! Copyright (C) 2002-2008 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!============================================================================== -!*** Molecular Dynamics using Density-Functional Theory **** -!*** this is the main routine driver for Car-Parrinello simulations **** -!****************************************************************************** -!*** See the documentation coming with the Quantum-Espresso distribution **** -!*** for credits, references, appropriate citation of this code **** -!****************************************************************************** -! -!---------------------------------------------------------------------------- -PROGRAM main - !---------------------------------------------------------------------------- - ! - USE input, ONLY : read_input_file, iosys_pseudo, iosys - USE io_global, ONLY : io_global_start, io_global_getmeta - USE mp_global, ONLY : mp_global_start, init_pool - USE mp, ONLY : mp_end, mp_start, mp_env, mp_bcast - USE control_flags, ONLY : lneb, lsmd, program_name - USE control_flags, ONLY : use_task_groups, ortho_para - USE environment, ONLY : environment_start - USE check_stop, ONLY : check_stop_init - ! - IMPLICIT NONE - ! - INTEGER :: mpime, nproc, world, meta_ionode_id - INTEGER :: nimage, ntask_groups, nproc_ortho - LOGICAL :: meta_ionode - INTEGER, PARAMETER :: root = 0 - ! - ! ... program starts here - ! - program_name = 'CP90' - ! - ! ... Intel compilers v .ge.8 allocate a lot of stack space - ! ... Stack limit is often small, thus causing SIGSEGV and crash - CALL remove_stack_limit ( ) - ! - ! ... initialize MPI (parallel processing handling) - ! - CALL mp_start() - ! - ! ... get from communication sub-sistem basic parameters - ! ... to handle processors - ! - CALL mp_env( nproc, mpime, world ) - ! - ! ... now initialize module holding processors and groups - ! ... variables - ! - CALL mp_global_start( root, mpime, world, nproc ) - ! - ! ... mpime = processor number, starting from 0 - ! ... nproc = number of processors - ! ... world = group index of all processors - ! ... root = index of the root processor - ! - ! - ! ... initialize input output - ! - CALL io_global_start( mpime, root ) - ! - ! ... get the "meta" io node - ! - CALL io_global_getmeta( meta_ionode, meta_ionode_id ) - ! - IF ( meta_ionode ) THEN - ! - ! ... check for command line arguments - ! - CALL get_arg_nimage( nimage ) - ! - nimage = MAX( nimage, 1 ) - nimage = MIN( nimage, nproc ) - ! - CALL get_arg_ntg( ntask_groups ) - ! - CALL get_arg_northo( nproc_ortho ) - ! - END IF - ! - CALL mp_bcast( nimage, meta_ionode_id, world ) - CALL mp_bcast( ntask_groups, meta_ionode_id, world ) - CALL mp_bcast( nproc_ortho, meta_ionode_id, world ) - ! - IF( ntask_groups > 1 ) THEN - use_task_groups = .TRUE. - END IF - ! - IF( nproc_ortho > 1 ) THEN - ortho_para = nproc_ortho - END IF - ! - ! - ! ... here reorganize processors in groups - ! - CALL init_pool( nimage, ntask_groups, nproc_ortho ) - ! - ! ... start the environment - ! - ! - CALL environment_start( ) - ! - ! reset IO nodes - ! (do this to make each "image head node" an ionode) - ! KNK_nimage - ! if (nimage.gt.1) CALL io_global_start( me_image, root_image ) - ! - ! - ! ... readin the input file - CALL read_input_file() - ! - ! ... read in pseudopotentials files and then - ! ... copy pseudopotential parameters into internal variables - ! - CALL iosys_pseudo() - ! - ! ... copy-in input parameters from input_parameter module - ! - CALL iosys() - ! - CALL check_stop_init() - ! - IF ( lneb ) THEN - ! - CALL neb_loop( ) - ! - ELSE IF ( lsmd ) THEN - ! - CALL errore ( 'cpr_main', 'SMD no longer implemented', 1) - ! - ELSE - ! - CALL cpr_loop( 1 ) - ! - END IF - ! - CALL stop_run( .TRUE. ) - ! - STOP - ! -END PROGRAM main diff --git a/quantum_espresso/kcp/CPV/cprsub.f90 b/quantum_espresso/kcp/CPV/cprsub.f90 deleted file mode 100644 index dec0698f7..000000000 --- a/quantum_espresso/kcp/CPV/cprsub.f90 +++ /dev/null @@ -1,993 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!----------------------------------------------------------------------- -subroutine formf( tfirst, eself ) -!----------------------------------------------------------------------- - - !computes (a) the self-energy eself of the ionic pseudocharges; - ! (b) the form factors of: (i) pseudopotential (vps), - ! (ii) ionic pseudocharge (rhops) - ! also calculated the derivative of vps with respect to - ! g^2 (dvps) - ! - USE kinds, ONLY : DP - use mp, ONLY : mp_sum - use control_flags, ONLY : tpre, iprsta - use io_global, ONLY : stdout - use mp_global, ONLY : intra_image_comm - use gvecs, ONLY : ngs - use cell_base, ONLY : omega, tpiba2, tpiba - use ions_base, ONLY : rcmax, zv, nsp, na - use local_pseudo, ONLY : vps, vps0, rhops, dvps, drhops - use atom, ONLY : rgrid - use uspp_param, ONLY : upf, oldvan - use pseudo_base, ONLY : compute_rhops, formfn, formfa, compute_eself - use pseudopotential, ONLY : tpstab, vps_sp, dvps_sp - use cp_interfaces, ONLY : build_pstab - use splines, ONLY : spline - use reciprocal_vectors, ONLY : gstart, g - use constants, ONLY : autoev - ! - implicit none - logical :: tfirst - real(DP) :: eself, DeltaV0 - ! - real(DP) :: vpsum, rhopsum - integer :: is, ig - REAL(DP) :: cost1, xg - - call start_clock( 'formf' ) - ! - IF( .NOT. ALLOCATED( rgrid ) ) & - CALL errore( ' formf ', ' rgrid not allocated ', 1 ) - IF( .NOT. ALLOCATED( upf ) ) & - CALL errore( ' formf ', ' upf not allocated ', 1 ) - ! - ! calculation of gaussian selfinteraction - ! - eself = compute_eself( na, zv, rcmax, nsp ) - - if( tfirst .or. ( iprsta >= 4 ) )then - WRITE( stdout, 1200 ) eself - endif - ! - 1200 format(/,3x,'formf: eself=',f10.5) - ! - IF( tpstab ) THEN - ! - CALL build_pstab( ) - ! - END IF - ! - do is = 1, nsp - - IF( tpstab ) THEN - ! - ! Use interpolation table, with cubic spline - ! - cost1 = 1.0d0/omega - ! - IF( gstart == 2 ) THEN - vps (1,is) = vps_sp(is)%y(1) * cost1 - dvps(1,is) = dvps_sp(is)%y(1) * cost1 - END IF - ! - DO ig = gstart, ngs - xg = SQRT( g(ig) ) * tpiba - vps (ig,is) = spline( vps_sp(is), xg ) * cost1 - dvps(ig,is) = spline( dvps_sp(is), xg ) * cost1 - END DO - ! - ELSE - - call formfn( rgrid(is)%r, rgrid(is)%rab, & - upf(is)%vloc(1:rgrid(is)%mesh), zv(is), rcmax(is), g, & - omega, tpiba2, rgrid(is)%mesh, ngs, oldvan(is), tpre, & - vps(:,is), vps0(is), dvps(:,is) ) - -! obsolete BHS form -! call formfa( vps(:,is), dvps(:,is), rc1(is), rc2(is), wrc1(is), wrc2(is), & -! rcl(:,is,lloc(is)), al(:,is,lloc(is)), bl(:,is,lloc(is)), & -! zv(is), rcmax(is), g, omega, tpiba2, ngs, gstart, tpre ) - - END IF - ! - ! fourier transform of local pp and gaussian nuclear charge - ! - call compute_rhops( rhops(:,is), drhops(:,is), zv(is), rcmax(is), g, & - omega, tpiba2, ngs, tpre ) - - if( tfirst .or. ( iprsta >= 4 ) )then - vpsum = SUM( vps( 1:ngs, is ) ) - rhopsum = SUM( rhops( 1:ngs, is ) ) - call mp_sum( vpsum, intra_image_comm ) - call mp_sum( rhopsum, intra_image_comm ) - WRITE( stdout,1250) vps(1,is),rhops(1,is), vps(2,is), rhops(2,is)!modified:giovanni:debug - WRITE( stdout,1300) vpsum,rhopsum - endif - ! - end do - ! - ! ... DeltaV0 is the shift to be applied to eigenvalues - ! ... in order to align them to other plane wave codes - ! - DeltaV0 = 0.0_dp - DO is = 1, nsp - ! - ! ... na(is)/omega is the structure factor at G=0 - ! - DeltaV0 = DeltaV0 + na(is) / omega * vps0(is) - END DO - ! - write(6,'(" Delta V(G=0): ",f10.6,"Ry, ",f11.6,"eV")') & - deltaV0, deltaV0*autoev - ! - call stop_clock( 'formf' ) - ! - 1250 format(3x,'formf: vps(g=0)=',f12.7,' rhops(g=0)=',f12.7) - 1300 format(3x,'formf: sum_g vps(g)=',f12.7,' sum_g rhops(g)=',f12.7) - ! - return -end subroutine formf -! -!----------------------------------------------------------------------- -SUBROUTINE newnlinit() - !----------------------------------------------------------------------- - ! - ! ... this routine calculates arrays beta, qradb, qq, qgb, rhocb - ! ... and derivatives w.r.t. cell parameters dbeta, dqrad - ! ... See also comments in nlinit - ! - use control_flags, ONLY : tpre - use pseudopotential, ONLY : tpstab - use cp_interfaces, ONLY : interpolate_beta, interpolate_qradb, & - exact_beta, check_tables, exact_qradb - ! - IMPLICIT NONE - ! - LOGICAL :: recompute_table - ! - ! ... initialization for vanderbilt species - ! - IF( tpstab ) THEN - - recompute_table = tpre .AND. check_tables() - ! - IF ( recompute_table ) & - CALL errore( ' newnlinit', & - 'interpolation tables recalculation, not implemented yet', 1 ) - ! - ! initialization that is common to all species - ! - CALL interpolate_beta( tpre ) - ! - CALL interpolate_qradb( tpre ) - ! - ELSE - ! - ! ... this is mainly for testing - ! - CALL exact_beta( tpre ) - ! - CALL exact_qradb( tpre ) - ! - END IF - ! - ! ... non-linear core-correction ( rhocb(ig,is) ) - ! - CALL core_charge_ftr( tpre ) - ! - RETURN - ! -END SUBROUTINE newnlinit -! -!----------------------------------------------------------------------- -subroutine nlfh_real_x( stress, bec, dbec, lambda ) - !----------------------------------------------------------------------- - ! - ! contribution to the internal stress tensor due to the constraints - ! - USE kinds, ONLY : DP - use cvan, ONLY : nvb, ish - use uspp, ONLY : qq - use uspp_param, ONLY : nh, nhm - use ions_base, ONLY : na - use electrons_base, ONLY : nspin, nupdwn, iupdwn - use cell_base, ONLY : omega, h - use constants, ONLY : pi, fpi, au_gpa - use io_global, ONLY : stdout - use control_flags, ONLY : iprsta - USE cp_main_variables, ONLY : descla, la_proc - USE descriptors, ONLY : nlar_ , nlac_ , ilar_ , ilac_ , nlax_ - USE mp, ONLY : mp_sum - USE mp_global, ONLY : intra_image_comm - -! - implicit none - - REAL(DP), INTENT(INOUT) :: stress(3,3) - REAL(DP), INTENT(IN) :: bec( :, : ), dbec( :, :, :, : ) - REAL(DP), INTENT(IN) :: lambda( :, :, : ) -! - INTEGER :: i, j, ii, jj, inl, iv, jv, ia, is, iss, nss, istart - INTEGER :: ir, ic, nr, nc, nx - REAL(DP) :: fpre(3,3) - ! - REAL(DP), ALLOCATABLE :: tmpbec(:,:), tmpdh(:,:), temp(:,:) - ! - ! - IF( la_proc ) THEN - nx=descla( nlax_ , 1 ) - IF( nspin == 2 ) nx = MAX( nx , descla( nlax_ , 2 ) ) - ALLOCATE ( tmpbec(nhm,nx), tmpdh(nx,nhm), temp(nx,nx) ) - END IF - ! - fpre = 0.d0 - ! - do ii=1,3 - - do jj=1,3 - - do is=1,nvb - - do ia=1,na(is) - - do iss = 1, nspin - ! - istart = iupdwn( iss ) - nss = nupdwn( iss ) - ! - IF( la_proc ) THEN - - nr = descla( nlar_ , iss ) - nc = descla( nlac_ , iss ) - ir = descla( ilar_ , iss ) - ic = descla( ilac_ , iss ) - - tmpbec = 0.d0 - tmpdh = 0.d0 -! - do iv=1,nh(is) - do jv=1,nh(is) - inl=ish(is)+(jv-1)*na(is)+ia - if(abs(qq(iv,jv,is)).gt.1.e-5) then - do i = 1, nc - tmpbec(iv,i) = tmpbec(iv,i) + qq(iv,jv,is) * bec(inl, i + istart - 1 + ic - 1 ) - end do - endif - end do - end do - - do iv=1,nh(is) - inl=ish(is)+(iv-1)*na(is)+ia - do i = 1, nr - tmpdh(i,iv) = dbec( inl, i + (iss-1)*nspin, ii, jj ) - end do - end do - - if(nh(is).gt.0)then - - CALL DGEMM & - ( 'N', 'N', nr, nc, nh(is), 1.0d0, tmpdh, nx, tmpbec, nhm, 0.0d0, temp, nx ) - - do j = 1, nc - do i = 1, nr - fpre(ii,jj) = fpre(ii,jj) + 2D0 * temp( i, j ) * lambda(i,j,iss) - end do - end do - endif - - END IF - ! - end do - ! - end do - ! - end do - ! - end do - ! - end do - - CALL mp_sum( fpre, intra_image_comm ) - - do i=1,3 - do j=1,3 - stress(i,j)=stress(i,j)+ & - (fpre(i,1)*h(j,1)+fpre(i,2)*h(j,2)+fpre(i,3)*h(j,3))/omega - enddo - enddo - - IF( la_proc ) THEN - DEALLOCATE ( tmpbec, tmpdh, temp ) - END IF - - - IF( iprsta >= 2 ) THEN - WRITE( stdout,*) - WRITE( stdout,*) "constraints contribution to stress" - WRITE( stdout,5555) ((-fpre(i,j),j=1,3),i=1,3) - fpre = MATMUL( fpre, TRANSPOSE( h ) ) / omega * au_gpa * 10.0d0 - WRITE( stdout,5555) ((fpre(i,j),j=1,3),i=1,3) - WRITE( stdout,*) - END IF -! - -5555 FORMAT(1x,f12.5,1x,f12.5,1x,f12.5/ & - & 1x,f12.5,1x,f12.5,1x,f12.5/ & - & 1x,f12.5,1x,f12.5,1x,f12.5//) - - return -end subroutine nlfh_real_x - -!----------------------------------------------------------------------- -subroutine nlfh_twin_x( stress, bec, dbec, lambda ) !added:giovanni warning:dbec is only real - !----------------------------------------------------------------------- - ! - ! contribution to the internal stress tensor due to the constraints - ! - USE kinds, ONLY : DP - use cvan, ONLY : nvb, ish - use uspp, ONLY : qq - use uspp_param, ONLY : nh, nhm - use ions_base, ONLY : na - use electrons_base, ONLY : nspin, nupdwn, iupdwn - use cell_base, ONLY : omega, h - use constants, ONLY : pi, fpi, au_gpa - use io_global, ONLY : stdout - use control_flags, ONLY : iprsta - USE cp_main_variables, ONLY : descla, la_proc - USE descriptors, ONLY : nlar_ , nlac_ , ilar_ , ilac_ , nlax_ - USE mp, ONLY : mp_sum - USE mp_global, ONLY : intra_image_comm - USE twin_types !added:giovanni -! - implicit none - - REAL(DP), INTENT(INOUT) :: stress(3,3) - TYPE(twin_matrix) :: bec - REAL(DP), INTENT(IN) :: dbec( :, :, :, : ) - TYPE(twin_matrix), dimension(:), INTENT(IN) :: lambda -! - INTEGER :: i, j, ii, jj, inl, iv, jv, ia, is, iss, nss, istart - INTEGER :: ir, ic, nr, nc, nx - REAL(DP) :: fpre(3,3) - ! - REAL(DP), ALLOCATABLE :: tmpbec(:,:), tmpdh(:,:), temp(:,:) - COMPLEX(DP), ALLOCATABLE :: tmpbec_c(:,:), tmpdh_c(:,:), temp_c(:,:) - COMPLEX(DP), PARAMETER :: c_one = CMPLX(1.d0, 0.d0), c_zero = CMPLX(0.d0,0.d0) - ! - ! - IF( la_proc ) THEN - nx=descla( nlax_ , 1 ) - IF( nspin == 2 ) nx = MAX( nx , descla( nlax_ , 2 ) ) - IF(.not.bec%iscmplx) THEN - ALLOCATE ( tmpbec(nhm,nx), tmpdh(nx,nhm), temp(nx,nx) ) - ELSE - ALLOCATE ( tmpbec_c(nhm,nx), tmpdh_c(nx,nhm), temp_c(nx,nx) ) - ENDIF - END IF - ! - fpre = 0.d0 - ! - do ii=1,3 - - do jj=1,3 - - do is=1,nvb - - do ia=1,na(is) - - do iss = 1, nspin - ! - istart = iupdwn( iss ) - nss = nupdwn( iss ) - ! - IF( la_proc ) THEN - - nr = descla( nlar_ , iss ) - nc = descla( nlac_ , iss ) - ir = descla( ilar_ , iss ) - ic = descla( ilac_ , iss ) - - IF(.not.bec%iscmplx) THEN - tmpbec = 0.d0 - tmpdh = 0.d0 - ! - do iv=1,nh(is) - do jv=1,nh(is) - inl=ish(is)+(jv-1)*na(is)+ia - if(abs(qq(iv,jv,is)).gt.1.e-5) then - do i = 1, nc - tmpbec(iv,i) = tmpbec(iv,i) + qq(iv,jv,is) * bec%rvec(inl, i + istart - 1 + ic - 1 ) - end do - endif - end do - end do - - do iv=1,nh(is) - inl=ish(is)+(iv-1)*na(is)+ia - do i = 1, nr - tmpdh(i,iv) = dbec( inl, i + (iss-1)*nspin, ii, jj ) - end do - end do - - if(nh(is).gt.0)then - - CALL DGEMM & - ( 'N', 'N', nr, nc, nh(is), 1.0d0, tmpdh, nx, tmpbec, nhm, 0.0d0, temp, nx ) - - do j = 1, nc - do i = 1, nr - fpre(ii,jj) = fpre(ii,jj) + 2D0 * temp( i, j ) * lambda(iss)%rvec(i,j) - end do - end do - endif - ELSE - tmpbec_c = c_zero - tmpdh_c = c_zero - ! - do iv=1,nh(is) - do jv=1,nh(is) - inl=ish(is)+(jv-1)*na(is)+ia - if(abs(qq(iv,jv,is)).gt.1.e-5) then - do i = 1, nc - tmpbec_c(iv,i) = tmpbec_c(iv,i) + qq(iv,jv,is) * bec%cvec(inl, i + istart - 1 + ic - 1 ) - end do - endif - end do - end do - - do iv=1,nh(is) - inl=ish(is)+(iv-1)*na(is)+ia - do i = 1, nr - tmpdh_c(i,iv) = dbec( inl, i + (iss-1)*nspin, ii, jj ) - end do - end do - - if(nh(is).gt.0)then - - CALL ZGEMM & - ( 'N', 'N', nr, nc, nh(is), c_one, tmpdh_c, nx, tmpbec_c, nhm, c_zero, temp_c, nx ) - - do j = 1, nc - do i = 1, nr - fpre(ii,jj) = fpre(ii,jj) + 2D0 * temp( i, j ) * lambda(iss)%cvec(i,j) - end do - end do - endif - - ENDIF - - END IF - ! - end do - ! - end do - ! - end do - ! - end do - ! - end do - - CALL mp_sum( fpre, intra_image_comm ) - - do i=1,3 - do j=1,3 - stress(i,j)=stress(i,j)+ & - (fpre(i,1)*h(j,1)+fpre(i,2)*h(j,2)+fpre(i,3)*h(j,3))/omega - enddo - enddo - - IF( la_proc ) THEN - IF(.not.bec%iscmplx) THEN - DEALLOCATE ( tmpbec, tmpdh, temp ) - ELSE - DEALLOCATE ( tmpbec_c, tmpdh_c, temp_c ) - ENDIF - END IF - - - IF( iprsta >= 2 ) THEN - WRITE( stdout,*) - WRITE( stdout,*) "constraints contribution to stress" - WRITE( stdout,5555) ((-fpre(i,j),j=1,3),i=1,3) - fpre = MATMUL( fpre, TRANSPOSE( h ) ) / omega * au_gpa * 10.0d0 - WRITE( stdout,5555) ((fpre(i,j),j=1,3),i=1,3) - WRITE( stdout,*) - END IF -! - -5555 FORMAT(1x,f12.5,1x,f12.5,1x,f12.5/ & - & 1x,f12.5,1x,f12.5,1x,f12.5/ & - & 1x,f12.5,1x,f12.5,1x,f12.5//) - - return -end subroutine nlfh_twin_x - -!----------------------------------------------------------------------- -subroutine nlinit - !----------------------------------------------------------------------- - ! - ! this routine allocates and initalizes arrays beta, qradb, qq, qgb, - ! rhocb, and derivatives w.r.t. cell parameters dbeta, dqrad - ! - ! beta(ig,l,is) = 4pi/sqrt(omega) y^r(l,q^) - ! int_0^inf dr r^2 j_l(qr) betar(l,is,r) - ! - ! Note that beta(g)_lm,is = (-i)^l*beta(ig,l,is) (?) - ! - ! qradb(ig,l,k,is) = 4pi/omega int_0^r dr r^2 j_l(qr) q(r,l,k,is) - ! - ! qq_ij=int_0^r q_ij(r)=omega*qg(g=0) - ! - ! beta and qradb are first calculated on a fixed linear grid in |G| - ! (betax, qradx) then calculated on the box grid by interpolation - ! (this is done in routine newnlinit) - ! - use control_flags, ONLY : tpre - use io_global, ONLY : stdout, ionode - use gvecw, ONLY : ngw - use core, ONLY : allocate_core - use constants, ONLY : pi, fpi - use ions_base, ONLY : nsp - use uspp, ONLY : aainit, beta, qq, nhtol, indv - use uspp_param, ONLY : upf, lmaxq, nbetam, lmaxkb, nhm, nh - use atom, ONLY : rgrid - use qradb_mod, ONLY : qradb - use qgb_mod, ONLY : qgb - use gvecb, ONLY : ngb - use gvecp, ONLY : ngm - use cdvan, ONLY : dbeta - use dqrad_mod, ONLY : dqrad - use dqgb_mod, ONLY : dqgb - use cp_interfaces, ONLY : pseudopotential_indexes, compute_dvan, & - compute_betagx, compute_qradx - USE grid_dimensions, ONLY : nnrx - -! - implicit none -! - integer is, iv, jv - real(8) fac - - - IF( ionode ) THEN - WRITE( stdout, 100 ) - 100 FORMAT( //, & - 3X,'Pseudopotentials initialization',/, & - 3X,'-------------------------------' ) - END IF - - IF( .NOT. ALLOCATED( rgrid ) ) & - CALL errore( ' nlinit ', ' rgrid not allocated ', 1 ) - IF( .NOT. ALLOCATED( upf ) ) & - CALL errore( ' nlinit ', ' upf not allocated ', 1 ) - ! - ! initialize indexes - ! - CALL pseudopotential_indexes( ) - ! - ! initialize array ap - ! - call aainit( lmaxkb + 1 ) - ! - CALL allocate_core( nnrx, ngm, ngb, nsp ) - ! - ! - allocate( beta( ngw, nhm, nsp ) ) - allocate( qradb( ngb, nbetam*(nbetam+1)/2, lmaxq, nsp ) ) - allocate( qgb( ngb, nhm*(nhm+1)/2, nsp ) ) - allocate( qq( nhm, nhm, nsp ) ) - qradb(:,:,:,:) = 0.d0 - qq (:,:,:) =0.d0 - IF (tpre) THEN - allocate( dqrad( ngb, nbetam*(nbetam+1)/2, lmaxq, nsp, 3, 3 ) ) - allocate( dqgb( ngb, nhm*(nhm+1)/2, nsp, 3, 3 ) ) - allocate( dbeta( ngw, nhm, nsp, 3, 3 ) ) - dqrad(:,:,:,:,:,:) = 0.d0 - END IF - ! - ! initialization for vanderbilt species - ! - CALL compute_qradx( tpre ) - ! - ! initialization that is common to all species - ! - WRITE( stdout, fmt="(//,3X,'Common initialization' )" ) - - do is = 1, nsp - WRITE( stdout, fmt="(/,3X,'Specie: ',I5)" ) is - ! fac converts ry to hartree - fac=0.5d0 - do iv = 1, nh(is) - WRITE( stdout,901) iv, indv(iv,is), nhtol(iv,is) - end do - 901 format(2x,i2,' indv= ',i2,' ang. mom= ',i2) - ! - WRITE( stdout,*) - WRITE( stdout,'(20x,a)') ' dion ' - do iv = 1, upf(is)%nbeta - WRITE( stdout,'(8f20.12)') ( fac*upf(is)%dion(iv,jv), jv = 1, upf(is)%nbeta ) - end do - ! - end do - ! - ! calculation of array betagx(ig,iv,is) - ! - call compute_betagx( tpre ) - ! - ! calculate array dvan(iv,jv,is) - ! - call compute_dvan() - ! - ! newnlinit stores qgb and qq, calculates arrays beta qradb rhocb - ! and derivatives wrt cell dbeta dqrad - ! - call newnlinit() - - return -end subroutine nlinit - -!------------------------------------------------------------------------- -subroutine qvan2b(ngy,iv,jv,is,ylm,qg) - !-------------------------------------------------------------------------- - ! - ! q(g,l,k) = sum_lm (-i)^l ap(lm,l,k) yr_lm(g^) qrad(g,l,l,k) - ! - USE kinds, ONLY : DP - use qradb_mod, ONLY : qradb - use uspp, ONLY : nlx, lpx, lpl, ap, indv, nhtolm - use gvecb, ONLY : ngb - use uspp_param, ONLY : lmaxq -! - implicit none - ! - integer, intent(in) :: ngy, iv, jv, is - real(DP), intent(in) :: ylm( ngb, lmaxq*lmaxq ) - complex(DP), intent(out) :: qg( ngb ) -! - integer :: ivs, jvs, ijvs, ivl, jvl, i, l, lp, ig - complex(DP) :: sig - ! - ! iv = 1..8 s_1 p_x1 p_z1 p_y1 s_2 p_x2 p_z2 p_y2 - ! ivs = 1..4 s_1 s_2 p_1 p_2 - ! ivl = 1..4 s p_x p_z p_y - ! - ivs=indv(iv,is) - jvs=indv(jv,is) - if (ivs >= jvs) then - ijvs = ivs*(ivs-1)/2 + jvs - else - ijvs = jvs*(jvs-1)/2 + ivs - end if - ! ijvs is the packed index for (ivs,jvs) - ivl=nhtolm(iv,is) - jvl=nhtolm(jv,is) - if (ivl > nlx .OR. jvl > nlx) & - call errore (' qvan2b ', ' wrong dimensions', MAX(ivl,jvl)) - ! - qg(:) = (0.d0, 0.d0) - ! - ! lpx = max number of allowed y_lm - ! lp = composite lm to indentify them - ! - do i=1,lpx(ivl,jvl) - lp=lpl(ivl,jvl,i) - if (lp > lmaxq*lmaxq) call errore(' qvan2b ',' lp out of bounds ',lp) - ! - ! extraction of angular momentum l from lp: - ! l = int ( sqrt( DBLE(l-1) + epsilon) ) + 1 - ! - if (lp == 1) then - l=1 - else if ((lp >= 2) .and. (lp <= 4)) then - l=2 - else if ((lp >= 5) .and. (lp <= 9)) then - l=3 - else if ((lp >= 10).and.(lp <= 16)) then - l=4 - else if ((lp >= 17).and.(lp <= 25)) then - l=5 - else if ((lp >= 26).and.(lp <= 36)) then - l=6 - else if ((lp >= 37).and.(lp <= 49)) then - l=7 - else - call errore(' qvan2b ',' not implemented ',lp) - endif - ! - ! sig= (-i)^l - ! - sig=(0.d0,-1.d0)**(l-1) - sig=sig*ap(lp,ivl,jvl) - do ig=1,ngy - qg(ig)=qg(ig)+sig*ylm(ig,lp)*qradb(ig,ijvs,l,is) - end do - end do - - return -end subroutine qvan2b - -!------------------------------------------------------------------------- -subroutine dqvan2b(ngy,iv,jv,is,ylm,dylm,dqg) - !-------------------------------------------------------------------------- - ! - ! dq(i,j) derivatives wrt to h(i,j) of q(g,l,k) calculated in qvan2b - ! - USE kinds, ONLY : DP - use qradb_mod, ONLY : qradb - use uspp, ONLY : nlx, lpx, lpl, ap, indv, nhtolm - use gvecb, ONLY : ngb - use dqrad_mod, ONLY : dqrad - use uspp_param, ONLY : lmaxq - - implicit none - - integer, intent(in) :: ngy, iv, jv, is - REAL(DP), INTENT(IN) :: ylm( ngb, lmaxq*lmaxq ), dylm( ngb, lmaxq*lmaxq, 3, 3 ) - complex(DP), intent(out) :: dqg( ngb, 3, 3 ) - - integer :: ivs, jvs, ijvs, ivl, jvl, i, ii, ij, l, lp, ig - complex(DP) :: sig, z1, z2 - ! - ! - ! iv = 1..8 s_1 p_x1 p_z1 p_y1 s_2 p_x2 p_z2 p_y2 - ! ivs = 1..4 s_1 s_2 p_1 p_2 - ! ivl = 1..4 s p_x p_z p_y - ! - - ivs=indv(iv,is) - jvs=indv(jv,is) - ! - if (ivs >= jvs) then - ijvs = ivs*(ivs-1)/2 + jvs - else - ijvs = jvs*(jvs-1)/2 + ivs - end if - ! - ! ijvs is the packed index for (ivs,jvs) - ! - ivl=nhtolm(iv,is) - jvl=nhtolm(jv,is) - ! - if (ivl > nlx .OR. jvl > nlx) & - call errore (' qvan2 ', ' wrong dimensions (2)', MAX(ivl,jvl)) - ! - dqg(:,:,:) = (0.d0, 0.d0) - - ! lpx = max number of allowed y_lm - ! lp = composite lm to indentify them - - z1 = 0.0d0 - z2 = 0.0d0 - do i=1,lpx(ivl,jvl) - lp=lpl(ivl,jvl,i) - if (lp > lmaxq*lmaxq) call errore(' dqvan2b ',' lp out of bounds ',lp) - - ! extraction of angular momentum l from lp: - ! l = int ( sqrt( DBLE(l-1) + epsilon) ) + 1 - ! - if (lp == 1) then - l=1 - else if ((lp >= 2) .and. (lp <= 4)) then - l=2 - else if ((lp >= 5) .and. (lp <= 9)) then - l=3 - else if ((lp >= 10).and.(lp <= 16)) then - l=4 - else if ((lp >= 17).and.(lp <= 25)) then - l=5 - else if ((lp >= 26).and.(lp <= 36)) then - l=6 - else if ((lp >= 37).and.(lp <= 49)) then - l=7 - else - call errore(' qvan2b ',' not implemented ',lp) - endif - ! - ! sig= (-i)^l - ! - sig = (0.0d0,-1.0d0)**(l-1) - ! - sig = sig * ap( lp, ivl, jvl ) - ! - do ij=1,3 - do ii=1,3 - do ig=1,ngy - dqg(ig,ii,ij) = dqg(ig,ii,ij) + sig * & - & ( ylm(ig,lp) * dqrad(ig,ijvs,l,is,ii,ij) - & - & dylm(ig,lp,ii,ij) * qradb(ig,ijvs,l,is) ) ! SEGNO - end do - end do - end do - end do - ! - ! WRITE(6,*) 'DEBUG dqvan2b: ', z1, z2 - ! - return -end subroutine dqvan2b - -!----------------------------------------------------------------------- -subroutine dylmr2_( nylm, ngy, g, gg, ainv, dylm ) - !----------------------------------------------------------------------- - ! - ! temporary CP interface for PW routine dylmr2 - ! dylmr2 calculates d Y_{lm} /d G_ipol - ! dylmr2_ calculates G_ipol \sum_k h^(-1)(jpol,k) (dY_{lm} /dG_k) - ! - USE kinds, ONLY: DP - - implicit none - ! - integer, intent(IN) :: nylm, ngy - real(DP), intent(IN) :: g (3, ngy), gg (ngy), ainv(3,3) - real(DP), intent(OUT) :: dylm (ngy, nylm, 3, 3) - ! - integer :: ipol, jpol, lm, ig - real(DP), allocatable :: dylmaux (:,:,:) - ! - allocate ( dylmaux(ngy,nylm,3) ) - ! - dylmaux(:,:,:) = 0.d0 - ! - do ipol =1,3 - call dylmr2 (nylm, ngy, g, gg, dylmaux(1,1,ipol), ipol) - enddo - ! - do ipol =1,3 - do jpol =1,3 - do lm=1,nylm - do ig = 1, ngy - dylm (ig,lm,ipol,jpol) = (dylmaux(ig,lm,1) * ainv(jpol,1) + & - dylmaux(ig,lm,2) * ainv(jpol,2) + & - dylmaux(ig,lm,3) * ainv(jpol,3) ) & - * g(ipol,ig) - end do - end do - end do - end do - ! - deallocate ( dylmaux ) - ! - return - ! -end subroutine dylmr2_ - - -SUBROUTINE print_lambda_x_real( lambda, n, nshow, ccc, iunit ) - USE kinds, ONLY : DP - USE io_global, ONLY: stdout, ionode - USE cp_main_variables, ONLY: collect_lambda, descla - USE electrons_base, ONLY: nudx, nupdwn - USE input_parameters, ONLY: fixed_state, fixed_band - USE nksic, ONLY: f_cutoff - IMPLICIT NONE - real(DP), intent(in) :: lambda(:,:,:), ccc - integer, intent(in) :: n, nshow - integer, intent(in), optional :: iunit - ! - integer :: nnn, un, is, fixed_band_aux - real(DP), allocatable :: lambda_repl(:,:) - if( present( iunit ) ) then - un = iunit - else - un = stdout - end if - nnn = min( nudx, nshow ) - ALLOCATE( lambda_repl( nudx, nudx ) ) - IF( ionode ) WRITE( un,*) - DO is = 1, SIZE( lambda, 3 ) - CALL collect_lambda( lambda_repl, lambda(:,:,is), descla(:,is) ) - IF( ionode ) THEN - WRITE( un,3370) ' lambda nudx, spin = ', nudx, is - !IF( nnn < n ) WRITE( un,3370) ' print only first ', nnn - !DO i=1,nnn - ! WRITE( un,3380) (lambda_repl(i,j)*ccc,j=1,nnn) - !END DO - ! -! IF (fixed_state .AND. (is==1)) & -! WRITE(stdout,*) "fixed_lambda ",fixed_band,fixed_band, real(lambda_repl(fixed_band,fixed_band)*ccc/f_cutoff) - IF (fixed_state .AND. (fixed_band .le. nupdwn(1)) ) THEN - WRITE(stdout,*) "fixed_lambda ",fixed_band,fixed_band, real(lambda_repl(fixed_band,fixed_band)*ccc/f_cutoff) - ELSE - fixed_band_aux = fixed_band-nupdwn(1) - WRITE(stdout,*) "fixed_lambda ",fixed_band,fixed_band, real(lambda_repl(fixed_band_aux,fixed_band_aux)*ccc/f_cutoff) - ENDIF - - END IF - END DO - DEALLOCATE( lambda_repl ) -3370 FORMAT(26x,a,2i4) -3380 FORMAT(100f8.4) - RETURN -END SUBROUTINE print_lambda_x_real - -SUBROUTINE print_lambda_x_twin( lambda, n, nshow, ccc, iunit ) - USE kinds, ONLY : DP - USE io_global, ONLY: stdout, ionode - USE cp_main_variables, ONLY: collect_lambda, descla - USE electrons_base, ONLY: nudx, nupdwn - USE twin_types - USE input_parameters, ONLY: fixed_state, fixed_band - USE nksic, ONLY: f_cutoff - IMPLICIT NONE - real(DP), intent(in) :: ccc - type(twin_matrix), intent(in) :: lambda(:) - integer, intent(in) :: n, nshow - integer, intent(in), optional :: iunit - ! - integer :: nnn, un, is, fixed_band_aux - real(DP), allocatable :: lambda_repl(:,:) - complex(DP), allocatable :: lambda_repl_c(:,:) - ! - if( present( iunit ) ) then - un = iunit - else - un = stdout - end if - nnn = min( nudx, nshow ) - IF(.not.lambda(1)%iscmplx) THEN - ALLOCATE( lambda_repl( nudx, nudx ) ) - - IF( ionode ) WRITE( un,*) - DO is = 1, SIZE( lambda ) - CALL collect_lambda( lambda_repl, lambda(is)%rvec(:,:), descla(:,is) ) - IF( ionode ) THEN - WRITE( un,3370) ' lambda nudx, spin = ', nudx, is - !IF( nnn < n ) WRITE( un,3370) ' print only first ', nnn - !DO i=1,nnn - !WRITE( un,3380) (lambda_repl(i,j)*ccc,j=1,nnn) - !END DO - ! -! IF (fixed_state .AND. (is==1)) & -! WRITE(stdout,*) "fixed_lambda ",fixed_band,fixed_band, real(lambda_repl(fixed_band,fixed_band)*ccc/f_cutoff) - IF (fixed_state .AND. (fixed_band .le. nupdwn(1)) ) THEN - WRITE(stdout,*) "fixed_lambda ",fixed_band,fixed_band, & - real(lambda_repl(fixed_band,fixed_band)*ccc/f_cutoff) - ELSE - fixed_band_aux = fixed_band-nupdwn(1) - WRITE(stdout,*) "fixed_lambda ",fixed_band,fixed_band, & - real(lambda_repl(fixed_band_aux,fixed_band_aux)*ccc/f_cutoff) - ENDIF - END IF - END DO - DEALLOCATE( lambda_repl ) - ELSE - ALLOCATE( lambda_repl_c( nudx, nudx ) ) - IF( ionode ) WRITE( un,*) - DO is = 1, SIZE( lambda ) - CALL collect_lambda( lambda_repl_c, lambda(is)%cvec(:,:), descla(:,is) ) - IF( ionode ) THEN - WRITE( un,3370) ' lambda nudx, spin = ', nudx, is - !IF( nnn < n ) WRITE( un,3370) ' print only first ', nnn - !DO i=1,nnn - ! WRITE( un,3390) (lambda_repl_c(i,j)*ccc,j=1,nnn) - !END DO - ! -! IF (fixed_state .AND. (is==1)) & -! WRITE(stdout,*) "fixed_lambda ",fixed_band,fixed_band, real(lambda_repl_c(fixed_band,fixed_band)*ccc/f_cutoff) - IF (fixed_state .AND. (fixed_band .le. nupdwn(1)) ) THEN - WRITE(stdout,*) "fixed_lambda ",fixed_band,fixed_band, & - real(lambda_repl_c(fixed_band,fixed_band)*ccc/f_cutoff) - ELSE - fixed_band_aux = fixed_band-nupdwn(1) - WRITE(stdout,*) "fixed_lambda ",fixed_band,fixed_band, & - real(lambda_repl_c(fixed_band_aux,fixed_band_aux)*ccc/f_cutoff) - ENDIF - END IF - END DO - DEALLOCATE( lambda_repl_c ) - ENDIF - -3370 FORMAT(26x,a,2i4) -3380 FORMAT(10f8.4) -3390 FORMAT(10(2((f8.4)(4x)))) - RETURN -END SUBROUTINE print_lambda_x_twin diff --git a/quantum_espresso/kcp/CPV/dealloc.f90 b/quantum_espresso/kcp/CPV/dealloc.f90 deleted file mode 100644 index 7f8ccb11f..000000000 --- a/quantum_espresso/kcp/CPV/dealloc.f90 +++ /dev/null @@ -1,135 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!---------------------------------------------------------------------------- -SUBROUTINE deallocate_modules_var() - !---------------------------------------------------------------------------- - ! - USE uspp, ONLY : beta, qq - USE qradb_mod, ONLY : qradb - USE qgb_mod, ONLY : qgb - USE core, ONLY : rhocb - USE cdvan, ONLY : dbeta - USE dqrad_mod, ONLY : dqrad - USE dqgb_mod, ONLY : dqgb - ! - USE core, ONLY : deallocate_core - USE cvan, ONLY : deallocate_cvan - USE uspp, ONLY : deallocate_uspp - USE electrons_base, ONLY : deallocate_elct - USE efield_module, ONLY : deallocate_efield - USE ensemble_dft, ONLY : deallocate_ensemble_dft - USE cg_module, ONLY : deallocate_cg - USE reciprocal_vectors, ONLY : deallocate_recvecs - USE recvecs_indexes, ONLY : deallocate_recvecs_indexes - USE local_pseudo, ONLY : deallocate_local_pseudo - USE qgb_mod, ONLY : deallocate_qgb_mod - USE dqgb_mod, ONLY : deallocate_dqgb_mod - USE qradb_mod, ONLY : deallocate_qradb_mod - USE dqrad_mod, ONLY : deallocate_dqrad_mod - USE betax, ONLY : deallocate_betax - USE wavefunctions_module, ONLY : deallocate_wavefunctions - USE wannier_module, ONLY : deallocate_wannier - USE fft_types, ONLY : fft_dlay_descriptor, fft_dlay_deallocate - USE fft_types, ONLY : fft_box_deallocate - USE fft_base, ONLY : dfftp, dffts, dfftb - USE stick_base, ONLY : sticks_deallocate - USE electrons_module, ONLY : deallocate_electrons - USE charge_mix, ONLY : deallocate_charge_mix - USE chi2, ONLY : deallocate_chi2 - USE ions_base, ONLY : deallocate_ions_base - USE sic_module, ONLY : deallocate_sic - USE polarization, ONLY : deallocate_polarization - USE turbo, ONLY : deallocate_turbo - USE cp_main_variables, ONLY : deallocate_mainvar - USE cdvan, ONLY : deallocate_cdvan - USE pseudopotential, ONLY : deallocate_pseudopotential - USE ions_nose, ONLY : ions_nose_deallocate - USE metagga, ONLY : deallocate_metagga - USE ions_positions, ONLY : deallocate_ions_positions - USE kohn_sham_states, ONLY : ks_states_closeup - USE ldau, ONLY : deallocate_lda_plus_u - USE nksic, ONLY : deallocate_nksic - USE hfmod, ONLY : deallocate_hf - USE eecp_mod, ONLY : deallocate_ee - ! - IMPLICIT NONE - ! - ! - IF ( ALLOCATED( beta ) ) DEALLOCATE( beta ) - IF ( ALLOCATED( qradb ) ) DEALLOCATE( qradb ) - IF ( ALLOCATED( qgb ) ) DEALLOCATE( qgb ) - IF ( ALLOCATED( qq ) ) DEALLOCATE( qq ) - IF ( ALLOCATED( rhocb ) ) DEALLOCATE( rhocb ) - IF ( ALLOCATED( dqrad ) ) DEALLOCATE( dqrad ) - IF ( ALLOCATED( dqgb ) ) DEALLOCATE( dqgb ) - IF ( ALLOCATED( dbeta ) ) DEALLOCATE( dbeta ) - ! - - CALL deallocate_mainvar() -! if(ionode) then -! write(0,*) "deallocated_mainvar" -! endif - CALL deallocate_ions_positions() - CALL deallocate_cvan() - CALL deallocate_efield( ) - CALL deallocate_ensemble_dft() -! write(6,*) "deallocated ensemble_dft" - CALL deallocate_cg( ) - CALL deallocate_core() - CALL deallocate_uspp() - CALL deallocate_recvecs() - CALL deallocate_recvecs_indexes() - CALL deallocate_local_pseudo() - CALL deallocate_qgb_mod() - CALL deallocate_qradb_mod() - CALL deallocate_dqgb_mod() - CALL deallocate_cdvan() - CALL deallocate_dqrad_mod() - CALL deallocate_betax() -! write(6,*) "deallocated betax" - ! - CALL fft_dlay_deallocate( dfftp ) - CALL fft_dlay_deallocate( dffts ) - CALL fft_box_deallocate( dfftb ) - CALL sticks_deallocate() - ! - CALL deallocate_ions_base() -! write(6,*) "deallocated ions_base" - ! - CALL deallocate_wavefunctions() - CALL deallocate_wannier() - ! -! write(6,*) "deallocated wannier" - CALL deallocate_elct() -! write(6,*) "deallocated elct" - CALL deallocate_electrons() -! write(6,*) "deallocated electrons" - CALL deallocate_polarization() - CALL deallocate_pseudopotential() - CALL deallocate_turbo() - ! -! write(6,*) "deallocated turbo" - CALL deallocate_charge_mix() - CALL deallocate_chi2() - ! - CALL deallocate_sic() - CALL deallocate_metagga() - CALL ions_nose_deallocate() - CALL ks_states_closeup() - ! - CALL deallocate_lda_plus_u() - CALL deallocate_ee() - CALL deallocate_nksic() - CALL deallocate_hf() -! write(6,*) "end of deallocate" - ! - RETURN - ! -END SUBROUTINE deallocate_modules_var diff --git a/quantum_espresso/kcp/CPV/dforceb.f90 b/quantum_espresso/kcp/CPV/dforceb.f90 deleted file mode 100644 index 69dfe6b55..000000000 --- a/quantum_espresso/kcp/CPV/dforceb.f90 +++ /dev/null @@ -1,292 +0,0 @@ -! -! Copyright (C) 2002-2008 Quantum-ESPRESS0 groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -subroutine dforceb(c0, i, betae, ipol, bec0, ctabin, gqq, gqqm, qmat, dq2, df) - -! this subroutine computes the force for electrons -! in case of Berry,s phase like perturbation -! it gives the force for the i-th state - -! c0 input: Psi^0_i -! c1 input: Psi^1_i -! i input: ot computes the force for the i-th state -! v0 input: the local zeroth order potential -! v1 input: the local first order potential -! betae input: the functions beta_iR -! ipol input:the polarization of nabla_k -! bec0 input: the factors -! bec1 input: the factors -! ctabin input: the inverse-correspondence array g'+(-)1=g -! gqq input: the factors int dr Beta_Rj*Beta_Ri exp(iGr) -! gqqm input: the factors int dr Beta_Rj*Beta_Ri exp(iGr) -! qmat input: -! dq2 input: factors d^2hxc_ijR -! df output: force for the i-th state - - - use kinds, only : DP - use gvecs - use gvecw, only : ngw - use parameters - use electrons_base, only : nx => nbspx, n => nbsp, nspin, f - use constants - use cvan - use ions_base, only : nat, nas => nax, na, nsp - use cell_base, only : a1, a2, a3 - use uspp_param, only : nh, nhm - use uspp, only : nhsa => nkb - use efield_module, ONLY : ctabin_missing_1,ctabin_missing_2,n_g_missing_m,& - ctabin_missing_rev_1,ctabin_missing_rev_2 - use mp_global, only : intra_image_comm, nproc_image - use mp, only : mp_alltoall - use ensemble_dft, only : tens, tsmear - use parallel_include - - - implicit none - - - complex(DP) c0(ngw, n), betae(ngw,nhsa), df(ngw),& - & gqq(nhm,nhm,nas,nsp),gqqm(nhm,nhm,nas,nsp),& - & qmat(nx,nx) - real(DP) bec0(nhsa,n),& - & dq2(nat,nhm,nhm,nspin), gmes - - integer i, ipol, ctabin(ngw,2) - -! local variables - - integer j,ig,iv,jv,is,ia - integer jnl,inl - complex(DP) fi - complex(DP) afrc(nhsa) - complex(DP), allocatable:: dtemp(:) - complex(DP), allocatable :: sndbuf(:,:,:),rcvbuf(:,:,:) - integer :: ip - - allocate( dtemp(ngw)) - - - -! now the interaction term -! first the norm-conserving part - - do ig=1,ngw - dtemp(ig)=(0.d0,0.d0) - enddo - - do j=1,n - do ig=1,ngw - if(ctabin(ig,2) .ne. (ngw+1)) then - if(ctabin(ig,2).ge.0) then - dtemp(ig)=dtemp(ig)+c0(ctabin(ig,2),j)*qmat(j,i) - else - dtemp(ig)=dtemp(ig)+CONJG(c0(-ctabin(ig,2),j))*qmat(j,i) - endif - endif - enddo - do ig=1,ngw - if(ctabin(ig,1) .ne. (ngw+1)) then - if(ctabin(ig,1).ge.0) then - dtemp(ig)=dtemp(ig)-c0(ctabin(ig,1),j)*CONJG(qmat(j,i)) - else - dtemp(ig)=dtemp(ig)-CONJG(c0(-ctabin(ig,1),j))*conjg(qmat(j,i)) - endif - endif - enddo - -#ifdef __PARA - - if(ipol/=3) then -!allocate arrays - allocate(sndbuf(n_g_missing_m(ipol),2,nproc_image)) - sndbuf(:,:,:)=(0.d0,0.d0) - allocate(rcvbuf(n_g_missing_m(ipol),2,nproc_image)) -!copy arrays to snd buf - do ip=1,nproc_image - do ig=1,n_g_missing_m(ipol) - if(ipol==1) then - if(ctabin_missing_rev_1(ig,1,ip)>0) then - sndbuf(ig,1,ip)=-c0(ctabin_missing_rev_1(ig,1,ip),j)*CONJG(qmat(j,i)) - elseif(ctabin_missing_rev_1(ig,1,ip)<0) then - sndbuf(ig,1,ip)=-conjg(c0(-ctabin_missing_rev_1(ig,1,ip),j))*CONJG(qmat(j,i)) - endif - else - if(ctabin_missing_rev_2(ig,1,ip)>0) then - sndbuf(ig,1,ip)=-c0(ctabin_missing_rev_2(ig,1,ip),j)*CONJG(qmat(j,i)) - elseif(ctabin_missing_rev_2(ig,1,ip)<0) then - sndbuf(ig,1,ip)=-conjg(c0(-ctabin_missing_rev_2(ig,1,ip),j))*CONJG(qmat(j,i)) - endif - endif - enddo - do ig=1,n_g_missing_m(ipol) - if(ipol==1) then - if(ctabin_missing_rev_1(ig,2,ip)>0) then - sndbuf(ig,2,ip)=c0(ctabin_missing_rev_1(ig,2,ip),j)*qmat(j,i) - elseif(ctabin_missing_rev_1(ig,2,ip)<0) then - sndbuf(ig,2,ip)=conjg(c0(-ctabin_missing_rev_1(ig,2,ip),j))*qmat(j,i) - endif - else - if(ctabin_missing_rev_2(ig,2,ip)>0) then - sndbuf(ig,2,ip)=c0(ctabin_missing_rev_2(ig,2,ip),j)*qmat(j,i) - elseif(ctabin_missing_rev_2(ig,2,ip)<0) then - sndbuf(ig,2,ip)=conjg(c0(-ctabin_missing_rev_2(ig,2,ip),j))*qmat(j,i) - endif - endif - enddo - enddo - - - CALL mp_alltoall( sndbuf, rcvbuf, intra_image_comm ) - -!update sca - do ip=1,nproc_image - do ig=1,n_g_missing_m(ipol) - if(ipol==1) then - if(ctabin_missing_1(ig,1,ip)/=0) then - dtemp(ctabin_missing_1(ig,1,ip))=dtemp(ctabin_missing_1(ig,1,ip))+rcvbuf(ig,1,ip) - endif - if(ctabin_missing_1(ig,2,ip)/=0) then - dtemp(ctabin_missing_1(ig,2,ip))=dtemp(ctabin_missing_1(ig,2,ip))+rcvbuf(ig,2,ip) - endif - else - if(ctabin_missing_2(ig,1,ip)/=0) then - dtemp(ctabin_missing_2(ig,1,ip))=dtemp(ctabin_missing_2(ig,1,ip))+rcvbuf(ig,1,ip) - endif - if(ctabin_missing_2(ig,2,ip)/=0) then - dtemp(ctabin_missing_2(ig,2,ip))=dtemp(ctabin_missing_2(ig,2,ip))+rcvbuf(ig,2,ip) - endif - endif - enddo - enddo - - - - - - - -!deallocate arrays - deallocate(rcvbuf,sndbuf) - endif - -#endif - enddo - - if(ipol.eq.1) then - gmes=a1(1)**2+a1(2)**2+a1(3)**2 - gmes=2*pi/SQRT(gmes) - endif - if(ipol.eq.2) then - gmes=a2(1)**2+a2(2)**2+a2(3)**2 - gmes=2*pi/SQRT(gmes) - endif - if(ipol.eq.3) then - gmes=a3(1)**2+a3(2)**2+a3(3)**2 - gmes=2*pi/SQRT(gmes) - endif - - ! - ! properly take care of spin degeneracy - ! - fi=f(i)*ci *DBLE(nspin) /( 2.0*2.0*gmes ) - - IF ( tens .OR. tsmear ) THEN - ! - df(1:ngw)= dtemp(1:ngw) - ! - ELSE - ! - df(1:ngw)= fi*dtemp(1:ngw) - ! - ENDIF - -! now the interacting Vanderbilt term -! the term (-ie/|G|)(-beta_i'R>gqq(i',j')bec0_jRj'Q^-1_ji+ -! +beta_i'R>gqqm(i',j')bec0jRj'Q^-1_ij* - - - - if(nhsa.gt.0) then - do inl=1,nhsa - afrc(inl)=(0.d0,0.d0) - end do - - do is=1,nvb!loop on species - do iv=1,nh(is) !loop on projectors - do jv=1,nh(is) !loop on projectors - do ia=1,na(is) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - do j=1,n !loop on states - afrc(inl)=afrc(inl)+gqq(iv,jv,ia,is)*bec0(jnl,j)*qmat(j,i)& - & -CONJG(gqq(jv,iv,ia,is))*bec0(jnl,j)*conjg(qmat(i,j)) - - - end do - end do - end do - end do - enddo - - do ig=1,ngw - dtemp(ig)=(0.d0,0.d0) - end do - do inl=1,nhsa - do ig=1,ngw - dtemp(ig)=dtemp(ig)+afrc(inl)*betae(ig,inl) - enddo - enddo -! call MXMA -! & (betae,1,2*ngw,afr,1,nhsax,dtemp,1,2*ngw,2*ngw,nhsa,1) - do ig=1,ngw - df(ig)=df(ig)+fi*dtemp(ig) - end do - endif - - deallocate( dtemp) - return - end subroutine dforceb - - - - subroutine enberry( detq, ipol, enb) - - use constants - use parameters - use cell_base, ONLY : a1, a2, a3 - USE electrons_base, ONLY : nspin - - implicit none - - complex(8) detq - real(8) enb - integer ipol - real(8) gmes - - - if(ipol.eq.1) then - gmes=a1(1)**2+a1(2)**2+a1(3)**2 - gmes=2*pi/SQRT(gmes) - endif - if(ipol.eq.2) then - gmes=a2(1)**2+a2(2)**2+a2(3)**2 - gmes=2*pi/SQRT(gmes) - endif - if(ipol.eq.3) then - gmes=a3(1)**2+a3(2)**2+a3(3)**2 - gmes=2*pi/SQRT(gmes) - endif - - - enb = 2.d0/REAL(nspin,DP) * AIMAG(log(detq)) / gmes - - return - end subroutine enberry - - - diff --git a/quantum_espresso/kcp/CPV/eelib.f90 b/quantum_espresso/kcp/CPV/eelib.f90 deleted file mode 100644 index a39d399ff..000000000 --- a/quantum_espresso/kcp/CPV/eelib.f90 +++ /dev/null @@ -1,1207 +0,0 @@ -! -! Copyright (C) 2007-2008 Quantum ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! Electrostatic embedding methods -! Developed and implemented by I. Dabo (Universite Paris-Est, Ecole des Ponts, ParisTech) -! Parallelized by Andrea Ferretti (MIT) -! -!----------------------------------------------------------------------- - subroutine ee_green_0d_init(box) -!----------------------------------------------------------------------- -! -! ... initialize Green's functions for periodic-image correction -! ... in 0D setttings (e.g., isolated molecule, cluster) -! - use kinds, only : dp - use cell_base, only : a1, a2, a3, s_to_r, & - boxdimensions - use constants, only : fpi, pi - use grid_dimensions, only : nnrx, nr1l, nr2l, nr3l - use recvecs_indexes, only : np - use gvecp, only : ngm - use fft_base, only : dfftp - use cp_interfaces, only : fwfft, invfft - use eecp_mod, only : gcorr,gcorr_fft - use mp_global, only : me_image - ! - implicit none - ! - type(boxdimensions), intent(in) :: box - ! - real(dp), parameter :: sigma=2.0_dp !afcmodified:giovanni 2.d0 - real(dp), parameter :: vanishing_dist=1.0e-3_dp - ! - complex(dp), allocatable :: vtemp(:) - real(dp), allocatable :: vtempr(:) - real(dp) :: aux(dfftp%nr1,dfftp%nr2,dfftp%nr3) - ! - integer :: ig, ir1, ir2, ir3, ir, i, j, k - real(dp) :: a(3,3) - integer :: npt(3) - logical :: tperiodic(3) - real(dp), external :: qe_erf - ! - interface - ! - function afc(a,npt,tperiodic,spreadopt) - ! - real(8), intent(in), optional :: spreadopt - real(8), intent(in), dimension(3,3) :: a - integer, intent(in), dimension(3) :: npt - logical, intent(in), dimension(3) :: tperiodic - real(8) :: afc(npt(1),npt(2),npt(3)) - ! - end function - ! - end interface - ! - ! main body - ! - allocate(vtemp(nnrx)) - allocate(vtempr(nnrx)) - ! - vtemp=0.0_dp - vtempr=0.0_dp - gcorr=0.0_dp - ! - ir1=1 - ir2=1 - ir3=1 - do k=1,me_image - ir3=ir3+dfftp%npp(k) - enddo - ! - npt(1)=dfftp%nr1 - npt(2)=dfftp%nr2 - npt(3)=dfftp%nr3 - tperiodic=.false. - a(1:3,1)=a1(1:3) - a(1:3,2)=a2(1:3) - a(1:3,3)=a3(1:3) - aux=afc(a,npt,tperiodic,sigma) - ! - do k=1,nr3l - do j=1,nr2l - do i=1,nr1l - ! - ir=i+(j-1)*dfftp%nr1x+(k-1)*dfftp%nr1x*dfftp%nr2x - ! - gcorr(ir)=aux(i+ir1-1,j+ir2-1,k+ir3-1) - ! - end do - end do - end do - !call writetofile(gcorr,nnrx,'afc0d.dat',dfftp,'az') - vtemp=gcorr - call fwfft('Dense',vtemp,dfftp) - do ig=1,ngm - gcorr_fft(ig)=vtemp(np(ig)) - enddo - ! - deallocate(vtempr) - deallocate(vtemp) - ! - return - ! -!----------------------------------------------------------------------- - end subroutine ee_green_0d_init -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine ee_green_1d_init(box) -!----------------------------------------------------------------------- -! -! ... initialize Green's functions for periodic-image correction -! ... for 1D setttings (e.g., nanotube, polymer chain) -! - use kinds, only : dp - use cell_base, only : a1, a2, a3, s_to_r, & - boxdimensions - use constants, only : fpi, pi - use grid_dimensions, only : nnrx, nr1l, nr2l, nr3l - use recvecs_indexes, only : np - use gvecp, only : ngm - use fft_base, only : dfftp - use cp_interfaces, only : fwfft, invfft - use eecp_mod, only : gcorr1d,gcorr1d_fft - use mp_global, only : me_image - ! - implicit none - ! - type(boxdimensions), intent(in) :: box - ! - real(dp), parameter :: sigma=2.0_dp - real(dp), parameter :: vanishing_dist=1.0e-3_dp - real(dp), parameter :: vanishing_g=1.0e-3_dp - real(dp), parameter :: euler_gamma=0.57721566490153286061d0 - ! - complex(dp), allocatable :: vtemp(:) - real(dp), allocatable :: vtempr(:) - real(dp) :: aux(dfftp%nr1,dfftp%nr2,dfftp%nr3) - ! - integer :: ig, ir1, ir2, ir3, ir, i, j, k - real(dp) :: a(3,3) - integer :: npt(3) - logical :: tperiodic(3) - ! - real(dp), external :: qe_erf - real(dp), external :: eimlmg - ! - interface - ! - function afc(a,npt,tperiodic,spreadopt) - ! - real(8), intent(in), optional :: spreadopt - real(8), intent(in), dimension(3,3) :: a - integer, intent(in), dimension(3) :: npt - logical, intent(in), dimension(3) :: tperiodic - real(8) :: afc(npt(1),npt(2),npt(3)) - ! - end function - ! - end interface - ! - ! main body - ! - allocate(vtemp(nnrx)) - allocate(vtempr(nnrx)) - ! - vtemp=0.0_dp - vtempr=0.0_dp - gcorr1d=0.0_dp - ! - ir1=1 - ir2=1 - ir3=1 - do k=1,me_image - ir3=ir3+dfftp%npp(k) - enddo - ! - npt(1)=dfftp%nr1 - npt(2)=dfftp%nr2 - npt(3)=dfftp%nr3 - tperiodic(1)=.false. - tperiodic(2)=.false. - tperiodic(3)=.true. - a(1:3,1)=a1(1:3) - a(1:3,2)=a2(1:3) - a(1:3,3)=a3(1:3) - aux=afc(a,npt,tperiodic,sigma) - do k=1,nr3l - do j=1,nr2l - do i=1,nr1l - ! - ir=i+(j-1)*dfftp%nr1x+(k-1)*dfftp%nr1x*dfftp%nr2x - gcorr1d(ir)=aux(i+ir1-1,j+ir2-1,k+ir3-1) - ! - end do - end do - end do - call writetofile(gcorr1d,nnrx,'afc1d.dat',dfftp, 'ax') - ! - vtemp=gcorr1d - call fwfft('Dense',vtemp,dfftp) - do ig=1,ngm - gcorr1d_fft(ig)=vtemp(np(ig)) - enddo - ! - deallocate(vtempr) - deallocate(vtemp) - ! - return - ! -!----------------------------------------------------------------------- - end subroutine ee_green_1d_init -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine ee_green_2d_init(box) -!----------------------------------------------------------------------- -! -! ... initialize Green's functions for periodic-image correction -! ... for 2D setttings (e.g., surface, thin film) -! - use kinds, only : dp - use cell_base, only : a1, a2, a3, s_to_r, boxdimensions - use constants, only : fpi, pi - use grid_dimensions, only : nnrx, nr1l, nr2l, nr3l - use recvecs_indexes, only : np - use gvecp, only : ngm - use fft_base, only : dfftp - use cp_interfaces, only : fwfft, invfft - use eecp_mod, only : gcorr2d,gcorr2d_fft - use mp_global, only : me_image - ! - implicit none - ! - type(boxdimensions), intent(in) :: box - ! - real(dp), parameter :: sigma=2.0_dp - real(dp), parameter :: vanishing_dist=1.0e-3_dp - real(dp), parameter :: vanishing_g=1.0e-3_dp - real(dp), parameter :: euler_gamma=0.57721566490153286061d0 - ! - complex(dp), allocatable :: vtemp(:) - real(dp), allocatable :: vtempr(:) - real(dp) :: aux(dfftp%nr1,dfftp%nr2,dfftp%nr3) - ! - integer :: ig, ir1, ir2, ir3, ir, i, j, k - real(dp) :: a(3,3) - integer :: npt(3) - logical :: tperiodic(3) - ! - real(dp), external :: qe_erf - real(dp), external :: eimlmg - ! - interface - ! - function afc(a,npt,tperiodic,spreadopt) - ! - real(8), intent(in), optional :: spreadopt - real(8), intent(in), dimension(3,3) :: a - integer, intent(in), dimension(3) :: npt - logical, intent(in), dimension(3) :: tperiodic - real(8) :: afc(npt(1),npt(2),npt(3)) - ! - end function - ! - end interface - ! - ! main body - ! - allocate(vtemp(nnrx)) - allocate(vtempr(nnrx)) - ! - vtemp=0.0_dp - vtempr=0.0_dp - gcorr2d=0.0_dp - ! - ir1=1 - ir2=1 - ir3=1 - do k=1,me_image - ir3=ir3+dfftp%npp(k) - enddo - ! - npt(1)=dfftp%nr1 - npt(2)=dfftp%nr2 - npt(3)=dfftp%nr3 - tperiodic(1)=.true. - tperiodic(2)=.true. - tperiodic(3)=.false. - a(1:3,1)=a1(1:3) - a(1:3,2)=a2(1:3) - a(1:3,3)=a3(1:3) - aux=afc(a,npt,tperiodic,sigma) - do k=1,nr3l - do j=1,nr2l - do i=1,nr1l - ! - ir=i+(j-1)*dfftp%nr1x+(k-1)*dfftp%nr1x*dfftp%nr2x - gcorr2d(ir)=aux(i+ir1-1,j+ir2-1,k+ir3-1) - ! - end do - end do - end do - call writetofile(gcorr2d,nnrx,'afc2d.dat',dfftp, 'ax') - ! - vtemp=gcorr2d - call fwfft('Dense',vtemp,dfftp) - do ig=1,ngm - gcorr2d_fft(ig)=vtemp(np(ig)) - enddo - ! - deallocate(vtempr) - deallocate(vtemp) - ! - return - ! -!----------------------------------------------------------------------- - end subroutine ee_green_2d_init -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine calc_compensation_potential(vcorr_fft,rho_fft,odd_flag) -!----------------------------------------------------------------------- -! -! ... driver for calculating the truncated countercharge (TCC) -! ... for 0,1,2d periodicity -! - use kinds, only: dp - use gvecp, only: ngm - use eecp_mod, only: which_compensation, tcc_odd - - implicit none - complex(dp) :: rho_fft(ngm) - complex(dp) :: vcorr_fft(ngm) - logical :: odd_flag !true if compensation is being computed - !for self-interaction correction - - select case(trim(which_compensation)) - ! - case('tcc') - ! - call calc_tcc_potential(vcorr_fft,rho_fft) - ! - case('tcc1d') - ! - IF((.not.odd_flag).or.(.not.tcc_odd)) THEN - call calc_tcc1d_potential(vcorr_fft,rho_fft) - ELSE IF(odd_flag.and.tcc_odd) THEN - call calc_tcc_potential(vcorr_fft,rho_fft) - ENDIF - ! - case('tcc2d') - ! - IF((.not.odd_flag).or.(.not.tcc_odd)) THEN - call calc_tcc2d_potential(vcorr_fft,rho_fft) - ELSE IF(odd_flag.and.tcc_odd) THEN - call calc_tcc_potential(vcorr_fft,rho_fft) - ENDIF - ! - case('none') - ! - IF((.not.odd_flag).or.(.not.tcc_odd)) THEN - continue - ELSE IF(odd_flag.and.tcc_odd) THEN - call calc_tcc_potential(vcorr_fft,rho_fft) - ENDIF - ! - case default - ! - call errore('vofrho','Invalid correction: '//TRIM(which_compensation), 10) - ! - end select -!----------------------------------------------------------------------- - end subroutine calc_compensation_potential -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - subroutine calc_tcc_potential(vcorr_fft,rho_fft) -!----------------------------------------------------------------------- -! -! ... calculate the truncated countercharge (TCC) -! ... periodic-image correction potential in -! ... reciprocal space for 0D settings -! - use kinds, only: dp - use gvecp, only: ngm - use eecp_mod, only: gcorr_fft - use cell_base, only: omega - ! - implicit none - complex(dp) :: rho_fft(ngm) - complex(dp) :: vcorr_fft(ngm) - integer :: ig - ! - do ig=1,ngm - vcorr_fft(ig)=omega*gcorr_fft(ig)*rho_fft(ig) - end do - ! - return -! -!----------------------------------------------------------------------- - end subroutine calc_tcc_potential -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine calc_tcc1d_potential(vcorr_fft,rho_fft) -!----------------------------------------------------------------------- -! -! ... calculate the truncated countercharge (TCC) -! ... periodic-image correction potential in -! ... reciprocal space for 1D settings -! - use kinds, only: dp - use gvecp, only: ngm - use eecp_mod, only: gcorr1d_fft - use cell_base, only: omega - ! - implicit none - complex(dp) :: rho_fft(ngm) - complex(dp) :: vcorr_fft(ngm) - integer :: ig - ! - do ig=1,ngm - vcorr_fft(ig)=omega*gcorr1d_fft(ig)*rho_fft(ig) - end do - ! - return -! -!----------------------------------------------------------------------- - end subroutine calc_tcc1d_potential -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine calc_tcc2d_potential(vcorr_fft,rho_fft) -!----------------------------------------------------------------------- -! -! ... calculate the truncated countercharge (TCC) -! ... periodic-image correction potential in -! ... reciprocal space for 2D settings -! - use kinds, only: dp - use gvecp, only: ngm - use eecp_mod, only: gcorr2d_fft - use cell_base, only: omega - ! - implicit none - complex(dp) :: rho_fft(ngm) - complex(dp) :: vcorr_fft(ngm) - integer :: ig - ! - do ig=1,ngm - vcorr_fft(ig)=omega*gcorr2d_fft(ig)*rho_fft(ig) - end do - ! - return -! -!----------------------------------------------------------------------- - end subroutine calc_tcc2d_potential -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine calc_tcc_energy(ecomp,vcorr_fft,rho_fft) -!----------------------------------------------------------------------- -! -! ... calculate the truncated countercharge (TCC) -! ... periodic-image corrective energy in for 0D settings -! - use kinds, only : dp - use gvecp, only : ngm - use cell_base, only : omega - use reciprocal_vectors, only : gstart - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use control_flags, only : gamma_only, do_wf_cmplx!added:giovanni - ! - implicit none - ! - real(dp), intent(out) :: ecomp - complex(dp), intent(in) :: rho_fft(ngm) - complex(dp), intent(in) :: vcorr_fft(ngm) - ! - complex(dp), allocatable :: aux(:) - integer :: ig - complex(dp) :: zh - real(dp) :: wz - logical :: lgam - ! - lgam = gamma_only.and..not.do_wf_cmplx - ! - IF(lgam) THEN - wz=2.d0 - ELSE - wz=1.d0 - ENDIF - ! - allocate(aux(ngm)) - ! - aux=0.0_dp - ! - if(gstart.ne.1) then - aux(1)=0.5d0*omega*vcorr_fft(1)*conjg(rho_fft(1)) - end if - ! - do ig=gstart,ngm - aux(ig)=0.5d0*wz*omega*vcorr_fft(ig)*conjg(rho_fft(ig)) - end do - ! - zh=0.0_dp - do ig=1,ngm - zh=zh+aux(ig) - enddo - ecomp=dble(zh) - ! - call mp_sum(ecomp,intra_image_comm) - ! - deallocate(aux) - ! - return - ! -!----------------------------------------------------------------------- - end subroutine calc_tcc_energy -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine ee_efieldpot_init(box) -!----------------------------------------------------------------------- -! -! ... add electric field with a sawtooth potential in real space -! ... (the system is assumed to be centered at the origin of the cell) -! - use kinds, only : dp - use cell_base, only : s_to_r, & - boxdimensions - use constants, only : fpi, pi - use grid_dimensions, only : nr1, nr2, nr3, & - nr1l, nr2l, nr3l, nnrx - use recvecs_indexes, only : np - use gvecp, only : ngm - use fft_base, only : dfftp - use cp_interfaces, only : fwfft, invfft - use efield_mod, only : efieldpot, efieldpotg, ampfield - use mp_global, only : me_image - ! - implicit none - ! - type(boxdimensions), intent(in) :: box - ! - integer :: ig, ir1, ir2, ir3, ir, i, j, k - real(dp) :: sv(3), lv(3) - complex(dp), allocatable :: vtemp(:) - ! - allocate(vtemp(nnrx)) - ! - efieldpot=0.0_dp - efieldpotg=0.0_dp - ! - ir1=1 - ir2=1 - ir3=1 - do k=1,me_image - ir3=ir3+dfftp%npp(k) - enddo - ! - do k=1,nr3l - do j=1,nr2l - do i=1,nr1l - ! - sv(1)=dble((i-1)+(ir1-1))/nr1 - sv(2)=dble((j-1)+(ir2-1))/nr2 - sv(3)=dble((k-1)+(ir3-1))/nr3 - ! - if(sv(1)>0.5_dp) sv(1)=sv(1)-1.0_dp - if(sv(2)>0.5_dp) sv(2)=sv(2)-1.0_dp - if(sv(3)>0.5_dp) sv(3)=sv(3)-1.0_dp - ! - call s_to_r(sv,lv,box%hmat) - ! - ir=i+(j-1)*dfftp%nr1x+(k-1)*dfftp%nr1x*dfftp%nr2x - ! - efieldpot(ir)=dot_product(lv,ampfield) - ! - end do - end do - end do - ! - vtemp=efieldpot - call fwfft('Dense',vtemp,dfftp) - ! - do ig=1,ngm - efieldpotg(ig)=vtemp(np(ig)) - end do - ! - call writetofile(efieldpot,nnrx,'efieldpot.dat',dfftp, 'az') - ! - deallocate( vtemp ) - ! - return - ! -!----------------------------------------------------------------------- - end subroutine ee_efieldpot_init -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine calc_dipole(wfc,box) -!----------------------------------------------------------------------- -! -! ... calculate the electronic dipole in real space -! - use kinds, only : dp - use cell_base, only : omega, s_to_r, & - boxdimensions - use constants, only : fpi, pi - use io_global, only : stdout, meta_ionode - use gvecw, only : ngw - use grid_dimensions, only : nr1l, nr2l, nr3l, nnrx, & - nr1, nr2, nr3 - use smooth_grid_dimensions, & - only : nnrsx - use recvecs_indexes, only : np, nm - use gvecs, only : ngs, nps, nms - use gvecp, only : ngm - use fft_base, only : dfftp, dffts - use cp_interfaces, only : fwfft, invfft - use electrons_base, only : nbspx, nbsp, & - f, ispin, nspin - use mp_global, only : me_image, intra_image_comm - use mp, only : mp_sum - ! - implicit none - ! - type(boxdimensions), intent(in) :: box - complex(dp), intent(inout) :: wfc(ngw,nbspx) - ! - integer :: ig, ir1, ir2, ir3, ir, i, j, k - integer :: isup, isdw, iss1, iss2 - real(dp) :: sa1, sa2, dipole(3), sv(3), lv(3) - complex(dp) :: ci, fp, fm - ! - complex(dp), allocatable :: psi(:), psis(:), rhog(:,:) - real(dp), allocatable :: rhor(:,:), rhos(:,:) - ! - ci=(0.0d0,1.0d0) - ! - allocate(rhos(nnrsx,2)) - allocate(rhor(nnrx,2)) - allocate(rhog(ngm,2)) - ! - rhor=0.0_dp - rhos=0.0_dp - rhog=(0.0_dp,0.0_dp) - ! - ! ... calculate total charge density - ! ... (this step can be removed depending on where the - ! ... subroutine is called, ID) - ! - allocate(psis(nnrsx)) - ! - do i=1,nbsp,2 - ! - call c2psi(psis,nnrsx,wfc(1,i),wfc(1,i+1),ngw,2) - call invfft('wave',psis,dffts) - ! - iss1=ispin(i) - sa1=f(i)/omega - ! - if(i/=nbsp) then - iss2=ispin(i+1) - sa2=f(i+1)/omega - else - iss2=iss1 - sa2=0.0_dp - end if - ! - do ir=1,nnrsx - rhos(ir,iss1)=rhos(ir,iss1)+sa1*(dble(psis(ir)))**2 - rhos(ir,iss2)=rhos(ir,iss2)+sa2*(aimag(psis(ir)))**2 - end do - ! - end do - ! - deallocate(psis) - ! - allocate(psis(nnrsx)) - ! - isup=1 - isdw=2 - ! - do ir=1,nnrsx - psis(ir)=cmplx(rhos(ir,isup),rhos(ir,isdw)) - end do - ! - call fwfft('Smooth',psis,dffts) - ! - do ig=1,ngs - fp= psis(nps(ig))+psis(nms(ig)) - fm= psis(nps(ig))-psis(nms(ig)) - rhog(ig,isup)=0.5d0*cmplx(dble(fp),aimag(fm)) - rhog(ig,isdw)=0.5d0*cmplx(aimag(fp),-dble(fm)) - end do - ! - allocate(psi(nnrx)) - ! - isup=1 - isdw=2 - psi(:)=(0.0_dp,0.0_dp) - ! - do ig=1,ngs - psi(nm(ig))=conjg(rhog(ig,isup))+ci*conjg(rhog(ig,isdw)) - psi(np(ig))=rhog(ig,isup)+ci*rhog(ig,isdw) - end do - ! - call invfft('Dense',psi,dfftp) - ! - do ir=1,nnrx - rhor(ir,isup)=dble(psi(ir)) - rhor(ir,isdw)=aimag(psi(ir)) - end do - ! - call writetofile(rhor,nnrx,'rhodipolez.dat',dfftp, 'az') - call writetofile(rhor,nnrx,'rhodipolex.dat',dfftp, 'ax') - ! - deallocate(psi) - deallocate(psis) - ! - dipole(1:3)=0.0_dp - ! - ir1=1 - ir2=1 - ir3=1 - do k=1,me_image - ir3=ir3+dfftp%npp(k) - end do - ! - do k=1,nr3l - do j=1,nr2l - do i=1,nr1l - ! - sv(1)=dble((i-1)+(ir1-1))/nr1 - sv(2)=dble((j-1)+(ir2-1))/nr2 - sv(3)=dble((k-1)+(ir3-1))/nr3 - ! - if(sv(1)>0.5_dp) sv(1)=sv(1)-1.0_dp - if(sv(2)>0.5_dp) sv(2)=sv(2)-1.0_dp - if(sv(3)>0.5_dp) sv(3)=sv(3)-1.0_dp - ! - call s_to_r(sv,lv,box%hmat) - ! - dipole(:)=dipole(:)+lv(:)*sum(rhor(ir,1:nspin)) - ! - end do - end do - end do - ! - call mp_sum(dipole,intra_image_comm) - ! - if(meta_ionode) write(stdout,2015) dipole -2015 format( 3x,'electronic dipole moment = ',3f12.6) - ! - return - ! -!-------------------------------------------------------------------- - end subroutine calc_dipole -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - function eimlmg( xx ) -!-------------------------------------------------------------------- - ! - ! ... exponential integral minus logarithm minus gamma function - ! ... - ! ... calculate eimlmg( x ) = ei( x ) - ln | x | - euler_gamma - ! ... = x / 1 / 1! + x ^ 2 / 2 / 2! + ... - ! ... + x ^ n / n / n! + ... - ! - use kinds, only : dp - ! - implicit none - ! - real( dp ) :: eimlmg - real( dp ) :: xx - ! - real( dp ) :: fact - real( dp ) :: term - ! - integer :: k - ! - integer, parameter :: maxit=100000 - ! - real( dp ), parameter :: eps=1.d-20 - real( dp ), parameter :: euler_gamma=0.57721566490153286061d0 - real( dp ), parameter :: xxlim=-20.d0 - ! - if ( xx > xxlim ) then - eimlmg = 0.d0 - fact = 1.d0 - summation : do k = 1, maxit - fact = fact * xx / dble( k ) - term = fact / dble( k ) - eimlmg = eimlmg + term - if( abs( term ) .lt. eps ) exit summation - end do summation - else - eimlmg = - log( abs( xx ) ) - euler_gamma - end if - ! - return - ! -!-------------------------------------------------------------------- - end function eimlmg -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - function pinterp( x, side, bound ) -!-------------------------------------------------------------------- - ! - ! ... calculate the interpolation polynomial satifying - ! ... P'(0)=0,P'(1)=0,P(0)=1,P(1)=0 for side=0,bound=0 - ! ... P'(0)=0,P'(1)=0,P(0)=0,P(1)=1 for side=1,bound=0 - ! ... P'(1)=0,P(0)=0,P(1)=1 for side=1,bound=-1 - ! ... P'(1)=0,P(0)=1,P(1)=0 for side=0,bound=-1 - ! ... P'(0)=0,P(0)=0,P(1)=1 for side=1,bound=1 - ! ... P'(0)=0,P(0)=1,P(1)=0 for side=0,bound=1 - ! - use kinds, only : dp - ! - implicit none - ! - real( dp ) :: pinterp - real( dp ) :: x - integer :: side - integer :: bound - ! - if( bound == 0 .and. side == 1 ) then - pinterp = 3.d0 * x * x - 2.d0 * x * x * x - else if( bound == 0 .and. side == 0 ) then - pinterp = 1.d0 - 3.d0 * x * x + 2.d0 * x * x * x - else if( bound == - 1 .and. side == 0 ) then - pinterp = 1.d0 - 2.d0 * x + x * x - else if( bound == - 1 .and. side == 1 ) then - pinterp = 2.d0 * x - x * x - else if( bound == 1 .and. side == 1 ) then - pinterp = x * x - else if( bound == 1 .and. side == 0 ) then - pinterp = 1 - x * x - end if - ! - return - ! -!-------------------------------------------------------------------- - end function pinterp -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - function dpinterp( x, side, bound ) -!-------------------------------------------------------------------- - ! - ! ... calculate the derivative of P(x) - ! - use kinds, only : dp - ! - implicit none - ! - real( dp ) :: dpinterp - real( dp ) :: x - integer :: side - integer :: bound - ! - if( bound == 0 .and. side == 1 ) then - dpinterp = 6.d0 * x - 6.d0 * x * x - else if( bound == 0 .and. side == 0 ) then - dpinterp = - 6.d0 * x + 6.d0 * x * x - else if( bound == - 1 .and. side == 0 ) then - dpinterp = - 2.d0 + 2.d0 * x - else if( bound == - 1 .and. side == 1 ) then - dpinterp = 2.d0 - 2.d0 * x - else if( bound == 1 .and. side == 1 ) then - dpinterp = 2.d0 * x - else if( bound == 1 .and. side == 0 ) then - dpinterp = - 2.d0 * x - end if - ! - return - ! -!-------------------------------------------------------------------- - end function dpinterp -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - function qinterp( x, side, bound ) -!-------------------------------------------------------------------- - ! - ! ... calculate the interpolation polynomial satifying - ! ... Q'(0)=1,Q'(1)=0,Q(0)=0,Q(1)=0 for side=0,bound=0 - ! ... Q'(0)=0,Q'(1)=1,Q(0)=0,Q(1)=0 for side=1,bound=0 - ! ... Q'(1)=1,Q(0)=0,Q(1)=0 for side=1,bound=-1 - ! ... Q'(0)=1,Q(0)=0,Q(1)=0 for side=0,bound=-1 - ! ... Q'(1)=1,Q(0)=0,Q(1)=0 for side=1,bound=1 - ! ... Q'(0)=1,Q(0)=0,Q(1)=0 for side=0,bound=1 - ! - use kinds, only : dp - ! - implicit none - ! - real( dp ) :: qinterp - real( dp ) :: x - integer :: side - integer :: bound - ! - if( bound == 0 .and. side == 1 ) then - qinterp = - x * x + x * x * x - else if( bound == 0 .and. side == 0 ) then - qinterp = x - 2.d0 * x * x + x * x * x - else if( bound == - 1 .and. side == 0 ) then - qinterp = 0.d0 - else if( bound == 1 .and. side == 1 ) then - qinterp = 0.d0 - else if( bound == - 1 .and. side == 1 ) then - qinterp = - x + x * x - else if( bound == 1 .and. side == 0 ) then - qinterp = x - x * x - end if - ! - return - ! -!-------------------------------------------------------------------- - end function qinterp -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - function dqinterp( x, side, bound ) -!-------------------------------------------------------------------- - ! - ! ... calculate the derivative of Q(x) - ! - use kinds, only : dp - ! - implicit none - ! - real( dp ) :: dqinterp - real( dp ) :: x - integer :: side - integer :: bound - ! - if( bound == 0 .and. side == 1 ) then - dqinterp = - 2.d0 * x + 3.d0 * x * x - else if( bound == 0 .and. side == 0 ) then - dqinterp = 1 - 4.d0 * x + 3 * x * x - else if( bound == - 1 .and. side == 0 ) then - dqinterp = 0.d0 - else if( bound == 1 .and. side == 1 ) then - dqinterp = 0.d0 - else if( bound == - 1 .and. side == 1 ) then - dqinterp = - 1.d0 + 2.d0 * x - else if( bound == 1 .and. side == 0 ) then - dqinterp = 1.d0 - 2.d0 * x - end if - ! - return - ! -!-------------------------------------------------------------------- - end function dqinterp -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - function compmod( ir, nr ) -!-------------------------------------------------------------------- - ! - ! ... calculate the composite grid index corresponding to ir - ! - implicit none - ! - integer :: compmod - integer, intent(in) :: ir - integer, intent(in) :: nr - ! - compmod = modulo( ir - 1, nr ) + 1 - ! - return - ! -!-------------------------------------------------------------------- - end function compmod -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - function bound( i, n ) -!-------------------------------------------------------------------- - ! - ! ... return -1 if i = 0, 1 if i = n - 1, and 0 otherwise - ! - implicit none - ! - integer :: i - integer :: n - integer :: bound - ! - if( i == 1 ) then - bound = -1 - else if( i == n - 1 ) then - bound = 1 - else - bound = 0 - end if - ! - return - ! -!-------------------------------------------------------------------- - end function bound -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - subroutine calc_fcorr(fion,vcorr,taus,nat,na,nsp,box,dfft) -!-------------------------------------------------------------------- - ! - ! ... calculate the interatomic force contribution due to - ! ... the corrective potential - ! - use kinds, only : dp - use ions_base, only : zv - use cell_base, only : a1, a2, a3, s_to_r, & - boxdimensions - use io_global, only : meta_ionode_id - use mp, only : mp_sum, mp_barrier, mp_gather - use mp_global, only : intra_image_comm, me_image, & - nproc_image - use grid_dimensions, only : nr1, nr2, nr3, nr1x, nr2x, nr3x, & - nnrx - use fft_types, only : fft_dlay_descriptor - ! - implicit none - ! - real(dp) :: fion(3,nat) - real(dp) :: taus(3,nat) - real(dp) :: vcorr(nnrx) - integer :: nat,na(nsp),nsp - type(boxdimensions) :: box - type(fft_dlay_descriptor) :: dfft - ! - integer :: ir1,ir2,ir3,ia,a,b,c,& - bound1,bound2,bound3,na_loc,ia_e,ia_s, & - proc,is,isa - real(dp) :: taur(3,nat) - real(dp) :: delta1,delta2,delta3, & - t1,t2,t3,df1,df2,df3,f,g1,g2,g3 - ! - integer, allocatable :: displs(:),recvcount(:) - real(dp), allocatable :: vcomp(:) - real(dp), allocatable :: fcorr(:,:) - ! - integer, external :: compindex - integer, external :: compmod - integer, external :: bound - integer, external :: ldim_block - integer, external :: gind_block - real(dp), external :: pinterp - real(dp), external :: qinterp - real(dp), external :: dpinterp - real(dp), external :: dqinterp - ! - ! ... initializes variables - ! - delta1=a1(1)/dble(nr1) - delta2=a2(2)/dble(nr2) - delta3=a3(3)/dble(nr3) - ! - df1=0.0_dp - df2=0.0_dp - df3=0.0_dp - ! - bound1=0 - bound2=0 - bound3=0 - ! - allocate(fcorr(3,nat)) - fcorr(:,:)=0.0_dp - ! - ! ... collect vcomp and scatter across nodes (cf. old_write_rho) - ! - nr1=dfft%nr1 - nr2=dfft%nr2 - nr3=dfft%nr3 - ! - nr1x=dfft%nr1x - nr2x=dfft%nr2x - nr3x=dfft%nr3x - ! - allocate(displs(nproc_image),recvcount(nproc_image)) - allocate(vcomp(nr1x*nr2x*nr3x)) - ! - vcomp=0.0_dp - ! - if(nproc_image>1) then - ! - do proc=1,nproc_image - ! - recvcount(proc)=dfft%nnp*dfft%npp(proc) - ! - if(proc==1) then - displs(proc)=0 - else - displs(proc)=displs(proc-1)+recvcount(proc-1) - endif - ! - enddo - ! - call mp_barrier() - call mp_gather(vcorr,vcomp,recvcount,displs, & - meta_ionode_id,intra_image_comm) - call mp_sum(vcomp,intra_image_comm) - ! - else - ! - if (nr1/=nr1x.or.nr2/=nr2x.or.nr3/=nr3x) & - call errore('calc_fcorr','dimension mistmatch',10) - ! - vcomp(1:nr1x*nr2x*nr3x)=vcorr(1:nnrx) - ! - endif - ! - ! ... distributes atoms over processors (cf. vofesr) - ! - na_loc=ldim_block(nat,nproc_image,me_image) - ia_s=gind_block(1,nat,nproc_image,me_image ) - ia_e=ia_s+na_loc-1 - ! - do ia=ia_s,ia_e - ! - call s_to_r(taus(1:3,ia),taur(1:3,ia),box%hmat) - ! - t1=taur(1,ia)/delta1 - t2=taur(2,ia)/delta2 - t3=taur(3,ia)/delta3 - ! - ir1=int(t1)+1 - ir2=int(t2)+1 - ir3=int(t3)+1 - ! - t1=t1-dble(ir1-1) - t2=t2-dble(ir2-1) - t3=t3-dble(ir3-1) - ! - ir1=compmod(ir1,nr1) - ir2=compmod(ir2,nr2) - ir3=compmod(ir3,nr3) - ! - ! ... with TCC, we use a periodic interpolation - ! - !bound1=bound(ir1,nr1) - !bound2=bound(ir2,nr2) - !bound3=bound(ir3,nr3) - ! - f=0 - g1=0 - g2=0 - g3=0 - ! - do a=0,1 - do b=0,1 - do c=0,1 - ! - f=vcomp(compindex(ir1+a,ir2+b,ir3+c,nr1x,nr2x,nr3x)) - ! - g1=f*dpinterp(t1,a,bound1)*pinterp(t2,b,bound2) & - *pinterp(t3,c,bound3) - g2=f*pinterp(t1,a,bound1)*dpinterp(t2,b,bound2) & - *pinterp(t3,c,bound3) - g3=f*pinterp(t1,a,bound1)*pinterp(t2,b,bound2) & - *dpinterp(t3,c,bound3) - ! - df1=0.5_dp*(vcomp(compindex(ir1+a+1,ir2+b,ir3+c,nr1x,nr2x,nr3x)) & - -vcomp(compindex(ir1+a-1,ir2+b,ir3+c,nr1x,nr2x,nr3x))) - df2=0.5_dp*(vcomp(compindex(ir1+a,ir2+b+1,ir3+c,nr1x,nr2x,nr3x)) & - -vcomp(compindex(ir1+a,ir2+b-1,ir3+c,nr1x,nr2x,nr3x))) - df3=0.5_dp*(vcomp(compindex(ir1+a,ir2+b,ir3+c+1,nr1x,nr2x,nr3x)) & - -vcomp(compindex(ir1+a,ir2+b,ir3+c-1,nr1x,nr2x,nr3x))) - ! - fcorr(1,ia)=fcorr(1,ia)+g1 & - +df1*dqinterp(t1,a,bound1)*pinterp(t2,b,bound2) & - *pinterp(t3,c,bound3) - fcorr(2,ia)=fcorr(2,ia)+g2 & - +df2*pinterp(t1,a,bound1)*dqinterp(t2,b,bound2) & - *pinterp(t3,c,bound3) - fcorr(3,ia)=fcorr(3,ia)+g3 & - +df3*pinterp(t1,a,bound1)*pinterp(t2,b,bound2) & - *dqinterp(t3,c,bound3) - ! - end do - end do - end do - ! - fcorr(1,ia)=fcorr(1,ia)/delta1 - fcorr(2,ia)=fcorr(2,ia)/delta2 - fcorr(3,ia)=fcorr(3,ia)/delta3 - ! - end do - ! - call mp_sum(fcorr,intra_image_comm) - ! - isa=0 - do is=1,nsp - do ia=1,na(is) - isa=isa+1 - fion(1,isa)=fion(1,isa)+fcorr(1,isa)*zv(is) - fion(2,isa)=fion(2,isa)+fcorr(2,isa)*zv(is) - fion(3,isa)=fion(3,isa)+fcorr(3,isa)*zv(is) - end do - end do - ! - deallocate(displs,recvcount) - deallocate(vcomp) - deallocate(fcorr) - ! -!-------------------------------------------------------------------- - end subroutine calc_fcorr -!-------------------------------------------------------------------- - - diff --git a/quantum_espresso/kcp/CPV/eelib.old b/quantum_espresso/kcp/CPV/eelib.old deleted file mode 100644 index 42f4679e0..000000000 --- a/quantum_espresso/kcp/CPV/eelib.old +++ /dev/null @@ -1,1082 +0,0 @@ -! -! Copyright (C) 2007-2008 Quantum ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! Electrostatic embedding methods -! Developed and implemented by I. Dabo (Universite Paris-Est, Ecole des Ponts, ParisTech) -! Parallelized by Andrea Ferretti (MIT) -! -!----------------------------------------------------------------------- - subroutine ee_green_0d_init(box) -!----------------------------------------------------------------------- -! -! ... initialize Green's functions for periodic-image correction -! ... in 0D setttings (e.g., isolated molecule, cluster) -! - use kinds, only : dp - use cell_base, only : a1, a2, a3, omega, tpiba2, s_to_r, & - boxdimensions - use constants, only : fpi, pi - use io_global, only : stdout - use grid_dimensions, only : nnrx, nr1, nr2, nr3, nr1x, nr2x, & - nr3x, nr1l, nr2l, nr3l - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use gvecp, only : ngm - use fft_base, only : dfftp - use cp_interfaces, only : fwfft, invfft - use eecp_mod, only : gcorr,gcorr_fft - use mp_global, only : me_image - use control_flags, only : gamma_only, do_wf_cmplx !added:giovanni - ! - implicit none - ! - type(boxdimensions), intent(in) :: box - ! - real(dp), parameter :: sigma=2.0_dp - real(dp), parameter :: vanishing_dist=1.0e-3_dp - ! - complex(dp), allocatable :: vtemp(:) - real(dp), allocatable :: vtempr(:) - ! - integer :: ig, ir1, ir2, ir3, ir, i, j, k - real(dp) :: sv(3), lv(3) ,dist - real(dp), external :: qe_erf - logical :: lgam !added:giovanni - - ! - ! main body - ! - lgam=gamma_only.and..not.do_wf_cmplx !added:giovanni - - allocate(vtemp(nnrx)) - allocate(vtempr(nnrx)) - ! - vtemp=0.0_dp - vtempr=0.0_dp - gcorr=0.0_dp - ! - if(gstart==2) vtemp(np(1))=-pi*sigma**2/omega - ! -! IF(lgam) THEN !!!uncomment for k points - do ig=gstart,ngm - vtemp(np(ig))=exp(-0.25_dp*tpiba2*g(ig)*sigma**2) & - /omega*fpi/(tpiba2*g(ig)) - vtemp(nm(ig))=exp(-0.25_dp*tpiba2*g(ig)*sigma**2) & - /omega*fpi/(tpiba2*g(ig)) - enddo -! ELSE !!!uncomment for k points -! do ig=gstart,ngm !!!uncomment for k points -! vtemp(np(ig))=exp(-0.25_dp*tpiba2*g(ig)*sigma**2) & !!!uncomment for k points -! /omega*fpi/(tpiba2*g(ig)) !!!uncomment for k points -! enddo !!!uncomment for k points -! ENDIF !!!uncomment for k points - ! - call invfft('Dense',vtemp,dfftp) - ! - vtempr=dble(vtemp) - gcorr =-vtempr - ! - call writetofile(vtempr,nnrx,'vg3d0d.dat',dfftp, 'az') - ! - ir1=1 - ir2=1 - ir3=1 - do k=1,me_image - ir3=ir3+dfftp%npp(k) - enddo - ! - vtempr=0.0_dp - do k=1,nr3l - do j=1,nr2l - do i=1,nr1l - ! - sv(1)=dble((i-1)+(ir1-1))/nr1 - sv(2)=dble((j-1)+(ir2-1))/nr2 - sv(3)=dble((k-1)+(ir3-1))/nr3 - ! - if(sv(1)>0.5_dp) sv(1)=sv(1)-1.0_dp - if(sv(2)>0.5_dp) sv(2)=sv(2)-1.0_dp - if(sv(3)>0.5_dp) sv(3)=sv(3)-1.0_dp - ! - call s_to_r(sv,lv,box%hmat) - ! - dist=sqrt(dot_product(lv,lv)) - ! - ir=i+(j-1)*dfftp%nr1x+(k-1)*dfftp%nr1x*dfftp%nr2x - ! - if(dist > vanishing_dist ) then - vtempr(ir)=qe_erf(dist/sigma)/dist - else - vtempr(ir)=2.0_dp/sqrt(pi)/sigma - end if - ! - end do - end do - end do - ! - gcorr=gcorr+vtempr - vtemp=gcorr - ! - call fwfft('Dense',vtemp,dfftp) - ! - do ig=1,ngm - gcorr_fft(ig)=vtemp(np(ig)) - enddo - ! - call writetofile(vtempr,nnrx,'vg0d0d.dat',dfftp, 'az') - call writetofile(gcorr,nnrx,'gcorr0d.dat',dfftp, 'az') - ! - deallocate(vtempr) - deallocate(vtemp) - ! - return - ! -!----------------------------------------------------------------------- - end subroutine ee_green_0d_init -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine ee_green_1d_init(box) -!----------------------------------------------------------------------- -! -! ... initialize Green's functions for periodic-image correction -! ... for 1D setttings (e.g., nanotube, polymer chain) -! - use kinds, only : dp - use cell_base, only : a1, a2, a3, omega, tpiba2, s_to_r, & - boxdimensions - use constants, only : fpi, pi - use io_global, only : stdout - use grid_dimensions, only : nnrx, nr1, nr2, nr3, nr1x, nr2x, nr3x, & - nr1l, nr2l, nr3l - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g, gx - use gvecp, only : ngm - use fft_base, only : dfftp - use cp_interfaces, only : fwfft, invfft - use eecp_mod, only : gcorr1d,gcorr1d_fft - use mp_global, only : me_image - use control_flags, only : gamma_only, do_wf_cmplx !added:giovanni - ! - implicit none - ! - type(boxdimensions), intent(in) :: box - ! - real(dp), parameter :: sigma=2.0_dp - real(dp), parameter :: vanishing_dist=1.0e-3_dp - real(dp), parameter :: vanishing_g=1.0e-3_dp - real(dp), parameter :: euler_gamma=0.57721566490153286061d0 - ! - complex(dp), allocatable :: vtemp(:) - real(dp), allocatable :: vtempr(:) - ! - integer :: ig, ir1, ir2, ir3, ir, i, j, k - real(dp) :: sv(3), lv(3), dist - ! - real(dp), external :: qe_erf - real(dp), external :: eimlmg - logical :: lgam !added:giovanni - ! - ! main body - ! - lgam=gamma_only.and..not. do_wf_cmplx - allocate(vtemp(nnrx)) - allocate(vtempr(nnrx)) - ! - vtemp=0.0_dp - vtempr=0.0_dp - gcorr1d=0.0_dp - ! - if(gstart==2) then - ! - ! contribution of the shift to be added (ID) - ! - endif - ! - IF(lgam) THEN - do ig=gstart,ngm - if(abs(gx(3,ig))0.5_dp) sv(1) = sv(1)-1.0_dp - if(sv(2)>0.5_dp) sv(2) = sv(2)-1.0_dp - ! - call s_to_r(sv,lv,box%hmat) - ! - dist=sqrt(dot_product(lv,lv)) - ! - ir=i+(j-1)*dfftp%nr1x+(k-1)*dfftp%nr1x*dfftp%nr2x - ! - vtempr(ir)=1.0_dp/a3(3)*(eimlmg(-dist**2/sigma**2) & - +euler_gamma) - ! - end do - end do - end do - ! - gcorr1d=gcorr1d+vtempr - vtemp=gcorr1d - ! - call fwfft('Dense',vtemp,dfftp) - do ig=1,ngm - gcorr1d_fft(ig)=vtemp(np(ig)) - end do - ! - call writetofile(vtempr,nnrx,'vg0d1dz.dat',dfftp, 'az') - call writetofile(vtempr,nnrx,'vg0d1dx.dat',dfftp, 'ax') - call writetofile(gcorr1d,nnrx,'gcorr1dz.dat',dfftp, 'az') - call writetofile(gcorr1d,nnrx,'gcorr1dx.dat',dfftp, 'ax') - ! - deallocate(vtempr) - deallocate(vtemp) - ! - return - ! -!----------------------------------------------------------------------- - end subroutine ee_green_1d_init -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine calc_tcc_potential(vcorr_fft,rho_fft) -!----------------------------------------------------------------------- -! -! ... calculate the truncated countercharge (TCC) -! ... periodic-image correction potential in -! ... reciprocal space for 0D settings -! - use kinds, only: dp - use gvecp, only: ngm - use eecp_mod, only: gcorr_fft - use cell_base, only: omega - ! - implicit none - complex(dp) :: rho_fft(ngm) - complex(dp) :: vcorr_fft(ngm) - integer :: ig - ! - do ig=1,ngm - vcorr_fft(ig)=omega*gcorr_fft(ig)*rho_fft(ig) - end do - ! - return -! -!----------------------------------------------------------------------- - end subroutine calc_tcc_potential -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine calc_tcc1d_potential(vcorr_fft,rho_fft) -!----------------------------------------------------------------------- -! -! ... calculate the truncated countercharge (TCC) -! ... periodic-image correction potential in -! ... reciprocal space for 1D settings -! - use kinds, only: dp - use gvecp, only: ngm - use eecp_mod, only: gcorr1d_fft - use cell_base, only: omega - ! - implicit none - complex(dp) :: rho_fft(ngm) - complex(dp) :: vcorr_fft(ngm) - integer :: ig - ! - do ig=1,ngm - vcorr_fft(ig)=omega*gcorr1d_fft(ig)*rho_fft(ig) - end do - ! - return -! -!----------------------------------------------------------------------- - end subroutine calc_tcc1d_potential -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine calc_tcc_energy(ecomp,vcorr_fft,rho_fft, lgam) -!----------------------------------------------------------------------- -! -! ... calculate the truncated countercharge (TCC) -! ... periodic-image corrective energy in for 0D settings -! - use kinds, only : dp - use gvecp, only : ngm - use eecp_mod, only : gcorr_fft - use cell_base, only : omega - use reciprocal_vectors, only : gstart - use mp, only : mp_sum - use mp_global, only : intra_image_comm - ! - implicit none - ! - real(dp), intent(out) :: ecomp - complex(dp), intent(in) :: rho_fft(ngm) - complex(dp), intent(in) :: vcorr_fft(ngm) - logical :: lgam - ! - complex(dp), allocatable :: aux(:) - integer :: ig - complex(dp) :: zh - real(dp), parameter :: wz=2.0_dp - ! - allocate(aux(ngm)) - ! - aux=0.0_dp - ! - if(gstart.ne.1) then - aux(1)=0.5d0*omega*vcorr_fft(1)*conjg(rho_fft(1)) - end if - ! - IF(lgam) THEN - do ig=gstart,ngm - aux(ig)=0.5d0*wz*omega*vcorr_fft(ig)*conjg(rho_fft(ig)) - end do - ELSE - do ig=gstart,ngm - aux(ig)=0.5d0*omega*vcorr_fft(ig)*conjg(rho_fft(ig)) - end do - ENDIF - ! - zh=0.0_dp - do ig=1,ngm - zh=zh+aux(ig) - enddo - ecomp=dble(zh) - ! - call mp_sum(ecomp,intra_image_comm) - ! - deallocate(aux) - ! - return - ! -!----------------------------------------------------------------------- - end subroutine calc_tcc_energy -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine ee_efieldpot_init(box) -!----------------------------------------------------------------------- -! -! ... add electric field with a sawtooth potential in real space -! ... (the system is assumed to be centered at the origin of the cell) -! - use kinds, only : dp - use cell_base, only : a1, a2, a3, omega, tpiba2, s_to_r, & - boxdimensions - use constants, only : fpi, pi - use io_global, only : stdout - use grid_dimensions, only : nr1, nr2, nr3, nr1x, nr2x, nr3x, & - nr1l, nr2l, nr3l, nnrx - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use gvecp, only : ngm - use fft_base, only : dfftp - use cp_interfaces, only : fwfft, invfft - use efield_mod, only : efieldpot, efieldpotg, ampfield - use mp_global, only : me_image - ! - implicit none - ! - type(boxdimensions), intent(in) :: box - ! - integer :: ig, ir1, ir2, ir3, ir, i, j, k - real(dp) :: sv(3), lv(3) - complex(dp), allocatable :: vtemp(:) - ! - allocate(vtemp(nnrx)) - ! - efieldpot=0.0_dp - efieldpotg=0.0_dp - ! - ir1=1 - ir2=1 - ir3=1 - do k=1,me_image - ir3=ir3+dfftp%npp(k) - enddo - ! - do k=1,nr3l - do j=1,nr2l - do i=1,nr1l - ! - sv(1)=dble((i-1)+(ir1-1))/nr1 - sv(2)=dble((j-1)+(ir2-1))/nr2 - sv(3)=dble((k-1)+(ir3-1))/nr3 - ! - if(sv(1)>0.5_dp) sv(1)=sv(1)-1.0_dp - if(sv(2)>0.5_dp) sv(2)=sv(2)-1.0_dp - if(sv(3)>0.5_dp) sv(3)=sv(3)-1.0_dp - ! - call s_to_r(sv,lv,box%hmat) - ! - ir=i+(j-1)*dfftp%nr1x+(k-1)*dfftp%nr1x*dfftp%nr2x - ! - efieldpot(ir)=dot_product(lv,ampfield) - ! - end do - end do - end do - ! - vtemp=efieldpot - call fwfft('Dense',vtemp,dfftp) - ! - do ig=1,ngm - efieldpotg(ig)=vtemp(np(ig)) - end do - ! - call writetofile(efieldpot,nnrx,'efieldpot.dat',dfftp, 'az') - ! - deallocate( vtemp ) - ! - return - ! -!----------------------------------------------------------------------- - end subroutine ee_efieldpot_init -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine calc_dipole(wfc,box) -!----------------------------------------------------------------------- -! -! ... calculate the electronic dipole in real space -! - use kinds, only : dp - use cell_base, only : a1, a2, a3, omega, tpiba2, s_to_r, & - boxdimensions - use constants, only : fpi, pi - use io_global, only : stdout, meta_ionode - use gvecw, only : ngw - use grid_dimensions, only : nr1l, nr2l, nr3l, nnrx, & - nr1, nr2, nr3, nr1x, nr2x, nr3x - use smooth_grid_dimensions, & - only : nr1s, nr2s, nr3s, & - nr1sx, nr2sx, nr3sx, nnrsx - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use gvecs, only : ngs, nps, nms - use gvecp, only : ngm - use fft_base, only : dfftp, dffts - use cp_interfaces, only : fwfft, invfft - use electrons_base, only : nbspx, nbsp, & - f, ispin, nspin, nelt - use mp_global, only : me_image, intra_image_comm - use mp, only : mp_sum - ! - implicit none - ! - type(boxdimensions), intent(in) :: box - complex(dp), intent(inout) :: wfc(ngw,nbspx) - ! - integer :: ig, ir1, ir2, ir3, ir, i, j, k - integer :: iss, isup, isdw, iss1, iss2, ios - real(dp) :: sa1, sa2, dipole(3), sv(3), lv(3) - complex(dp) :: ci, fp, fm - ! - complex(dp), allocatable :: vtemp(:) - complex(dp), allocatable :: psi(:), psis(:), rhog(:,:) - real(dp), allocatable :: rhor(:,:), rhos(:,:) - ! - ci=(0.0d0,1.0d0) - ! - allocate(rhos(nnrsx,2)) - allocate(rhor(nnrx,2)) - allocate(rhog(ngm,2)) - ! - rhor=0.0_dp - rhos=0.0_dp - rhog=(0.0_dp,0.0_dp) - ! - ! ... calculate total charge density - ! ... (this step can be removed depending on where the - ! ... subroutine is called, ID) - ! - allocate(psis(nnrsx)) - ! - do i=1,nbsp,2 - ! - call c2psi(psis,nnrsx,wfc(1,i),wfc(1,i+1),ngw,2) - call invfft('wave',psis,dffts) - ! - iss1=ispin(i) - sa1=f(i)/omega - ! - if(i/=nbsp) then - iss2=ispin(i+1) - sa2=f(i+1)/omega - else - iss2=iss1 - sa2=0.0_dp - end if - ! - do ir=1,nnrsx - rhos(ir,iss1)=rhos(ir,iss1)+sa1*(dble(psis(ir)))**2 - rhos(ir,iss2)=rhos(ir,iss2)+sa2*(aimag(psis(ir)))**2 - end do - ! - end do - ! - deallocate(psis) - ! - allocate(psis(nnrsx)) - ! - isup=1 - isdw=2 - ! - do ir=1,nnrsx - psis(ir)=cmplx(rhos(ir,isup),rhos(ir,isdw)) - end do - ! - call fwfft('Smooth',psis,dffts) - ! - do ig=1,ngs - fp= psis(nps(ig))+psis(nms(ig)) - fm= psis(nps(ig))-psis(nms(ig)) - rhog(ig,isup)=0.5d0*cmplx(dble(fp),aimag(fm)) - rhog(ig,isdw)=0.5d0*cmplx(aimag(fp),-dble(fm)) - end do - ! - allocate(psi(nnrx)) - ! - isup=1 - isdw=2 - psi(:)=(0.0_dp,0.0_dp) - ! - do ig=1,ngs - psi(nm(ig))=conjg(rhog(ig,isup))+ci*conjg(rhog(ig,isdw)) - psi(np(ig))=rhog(ig,isup)+ci*rhog(ig,isdw) - end do - ! - call invfft('Dense',psi,dfftp) - ! - do ir=1,nnrx - rhor(ir,isup)=dble(psi(ir)) - rhor(ir,isdw)=aimag(psi(ir)) - end do - ! - call writetofile(rhor,nnrx,'rhodipolez.dat',dfftp, 'az') - call writetofile(rhor,nnrx,'rhodipolex.dat',dfftp, 'ax') - ! - deallocate(psi) - deallocate(psis) - ! - dipole(1:3)=0.0_dp - ! - ir1=1 - ir2=1 - ir3=1 - do k=1,me_image - ir3=ir3+dfftp%npp(k) - end do - ! - do k=1,nr3l - do j=1,nr2l - do i=1,nr1l - ! - sv(1)=dble((i-1)+(ir1-1))/nr1 - sv(2)=dble((j-1)+(ir2-1))/nr2 - sv(3)=dble((k-1)+(ir3-1))/nr3 - ! - if(sv(1)>0.5_dp) sv(1)=sv(1)-1.0_dp - if(sv(2)>0.5_dp) sv(2)=sv(2)-1.0_dp - if(sv(3)>0.5_dp) sv(3)=sv(3)-1.0_dp - ! - call s_to_r(sv,lv,box%hmat) - ! - dipole(:)=dipole(:)+lv(:)*sum(rhor(ir,1:nspin)) - ! - end do - end do - end do - ! - call mp_sum(dipole,intra_image_comm) - ! - if(meta_ionode) write(stdout,2015) dipole -2015 format( 3x,'electronic dipole moment = ',3f12.6) - ! - return - ! -!-------------------------------------------------------------------- - end subroutine calc_dipole -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - function eimlmg( xx ) -!-------------------------------------------------------------------- - ! - ! ... exponential integral minus logarithm minus gamma function - ! ... - ! ... calculate eimlmg( x ) = ei( x ) - ln | x | - euler_gamma - ! ... = x / 1 / 1! + x ^ 2 / 2 / 2! + ... - ! ... + x ^ n / n / n! + ... - ! - use kinds, only : dp - ! - implicit none - ! - real( dp ) :: eimlmg - real( dp ) :: xx - ! - real( dp ) :: fact - real( dp ) :: term - real( dp ) :: total1 - real( dp ) :: total2 - ! - integer :: k - ! - integer, parameter :: maxit=100000 - ! - real( dp ), parameter :: eps=1.d-20 - real( dp ), parameter :: euler_gamma=0.57721566490153286061d0 - real( dp ), parameter :: xxlim=-20.d0 - ! - if ( xx > xxlim ) then - eimlmg = 0.d0 - fact = 1.d0 - summation : do k = 1, maxit - fact = fact * xx / dble( k ) - term = fact / dble( k ) - eimlmg = eimlmg + term - if( abs( term ) .lt. eps ) exit summation - end do summation - else - eimlmg = - log( abs( xx ) ) - euler_gamma - end if - ! - return - ! -!-------------------------------------------------------------------- - end function eimlmg -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - function pinterp( x, side, bound ) -!-------------------------------------------------------------------- - ! - ! ... calculate the interpolation polynomial satifying - ! ... P'(0)=0,P'(1)=0,P(0)=1,P(1)=0 for side=0,bound=0 - ! ... P'(0)=0,P'(1)=0,P(0)=0,P(1)=1 for side=1,bound=0 - ! ... P'(1)=0,P(0)=0,P(1)=1 for side=1,bound=-1 - ! ... P'(1)=0,P(0)=1,P(1)=0 for side=0,bound=-1 - ! ... P'(0)=0,P(0)=0,P(1)=1 for side=1,bound=1 - ! ... P'(0)=0,P(0)=1,P(1)=0 for side=0,bound=1 - ! - use kinds, only : dp - ! - implicit none - ! - real( dp ) :: pinterp - real( dp ) :: x - integer :: side - integer :: bound - ! - if( bound == 0 .and. side == 1 ) then - pinterp = 3.d0 * x * x - 2.d0 * x * x * x - else if( bound == 0 .and. side == 0 ) then - pinterp = 1.d0 - 3.d0 * x * x + 2.d0 * x * x * x - else if( bound == - 1 .and. side == 0 ) then - pinterp = 1.d0 - 2.d0 * x + x * x - else if( bound == - 1 .and. side == 1 ) then - pinterp = 2.d0 * x - x * x - else if( bound == 1 .and. side == 1 ) then - pinterp = x * x - else if( bound == 1 .and. side == 0 ) then - pinterp = 1 - x * x - end if - ! - return - ! -!-------------------------------------------------------------------- - end function pinterp -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - function dpinterp( x, side, bound ) -!-------------------------------------------------------------------- - ! - ! ... calculate the derivative of P(x) - ! - use kinds, only : dp - ! - implicit none - ! - real( dp ) :: dpinterp - real( dp ) :: x - integer :: side - integer :: bound - ! - if( bound == 0 .and. side == 1 ) then - dpinterp = 6.d0 * x - 6.d0 * x * x - else if( bound == 0 .and. side == 0 ) then - dpinterp = - 6.d0 * x + 6.d0 * x * x - else if( bound == - 1 .and. side == 0 ) then - dpinterp = - 2.d0 + 2.d0 * x - else if( bound == - 1 .and. side == 1 ) then - dpinterp = 2.d0 - 2.d0 * x - else if( bound == 1 .and. side == 1 ) then - dpinterp = 2.d0 * x - else if( bound == 1 .and. side == 0 ) then - dpinterp = - 2.d0 * x - end if - ! - return - ! -!-------------------------------------------------------------------- - end function dpinterp -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - function qinterp( x, side, bound ) -!-------------------------------------------------------------------- - ! - ! ... calculate the interpolation polynomial satifying - ! ... Q'(0)=1,Q'(1)=0,Q(0)=0,Q(1)=0 for side=0,bound=0 - ! ... Q'(0)=0,Q'(1)=1,Q(0)=0,Q(1)=0 for side=1,bound=0 - ! ... Q'(1)=1,Q(0)=0,Q(1)=0 for side=1,bound=-1 - ! ... Q'(0)=1,Q(0)=0,Q(1)=0 for side=0,bound=-1 - ! ... Q'(1)=1,Q(0)=0,Q(1)=0 for side=1,bound=1 - ! ... Q'(0)=1,Q(0)=0,Q(1)=0 for side=0,bound=1 - ! - use kinds, only : dp - ! - implicit none - ! - real( dp ) :: qinterp - real( dp ) :: x - integer :: side - integer :: bound - ! - if( bound == 0 .and. side == 1 ) then - qinterp = - x * x + x * x * x - else if( bound == 0 .and. side == 0 ) then - qinterp = x - 2.d0 * x * x + x * x * x - else if( bound == - 1 .and. side == 0 ) then - qinterp = 0.d0 - else if( bound == 1 .and. side == 1 ) then - qinterp = 0.d0 - else if( bound == - 1 .and. side == 1 ) then - qinterp = - x + x * x - else if( bound == 1 .and. side == 0 ) then - qinterp = x - x * x - end if - ! - return - ! -!-------------------------------------------------------------------- - end function qinterp -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - function dqinterp( x, side, bound ) -!-------------------------------------------------------------------- - ! - ! ... calculate the derivative of Q(x) - ! - use kinds, only : dp - ! - implicit none - ! - real( dp ) :: dqinterp - real( dp ) :: x - integer :: side - integer :: bound - ! - if( bound == 0 .and. side == 1 ) then - dqinterp = - 2.d0 * x + 3.d0 * x * x - else if( bound == 0 .and. side == 0 ) then - dqinterp = 1 - 4.d0 * x + 3 * x * x - else if( bound == - 1 .and. side == 0 ) then - dqinterp = 0.d0 - else if( bound == 1 .and. side == 1 ) then - dqinterp = 0.d0 - else if( bound == - 1 .and. side == 1 ) then - dqinterp = - 1.d0 + 2.d0 * x - else if( bound == 1 .and. side == 0 ) then - dqinterp = 1.d0 - 2.d0 * x - end if - ! - return - ! -!-------------------------------------------------------------------- - end function dqinterp -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - function compmod( ir, nr ) -!-------------------------------------------------------------------- - ! - ! ... calculate the composite grid index corresponding to ir - ! - implicit none - ! - integer :: compmod - integer, intent(in) :: ir - integer, intent(in) :: nr - ! - compmod = modulo( ir - 1, nr ) + 1 - ! - return - ! -!-------------------------------------------------------------------- - end function compmod -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - function bound( i, n ) -!-------------------------------------------------------------------- - ! - ! ... return -1 if i = 0, 1 if i = n - 1, and 0 otherwise - ! - implicit none - ! - integer :: i - integer :: n - integer :: bound - ! - if( i == 1 ) then - bound = -1 - else if( i == n - 1 ) then - bound = 1 - else - bound = 0 - end if - ! - return - ! -!-------------------------------------------------------------------- - end function bound -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - subroutine calc_fcorr(fion,vcorr,taus,nat,na,nsp,box,dfft) -!-------------------------------------------------------------------- - ! - ! ... calculate the interatomic force contribution due to - ! ... the corrective potential - ! - use kinds, only : dp - use ions_base, only : zv - use cell_base, only : a1, a2, a3, omega, tpiba2, s_to_r, & - boxdimensions - use io_global, only : meta_ionode, meta_ionode_id - use mp, only : mp_sum, mp_barrier, mp_gather - use mp_global, only : intra_image_comm, me_image, & - nproc_image - use grid_dimensions, only : nr1, nr2, nr3, nr1x, nr2x, nr3x, & - nnrx - use fft_types, only : fft_dlay_descriptor - ! - implicit none - ! - real(dp) :: fion(3,nat) - real(dp) :: taus(3,nat) - real(dp) :: vcorr(nnrx) - integer :: nat,na(nsp),nsp - type(boxdimensions) :: box - type(fft_dlay_descriptor) :: dfft - ! - integer :: ir,ir1,ir2,ir3,ia,a,b,c,& - bound1,bound2,bound3,na_loc,ia_e,ia_s, & - proc,is,isa - real(dp) :: taur(3,nat) - real(dp) :: delta1,delta2,delta3, & - t1,t2,t3,df1,df2,df3,f,g1,g2,g3 - ! - integer, allocatable :: displs(:),recvcount(:) - real(dp), allocatable :: vcomp(:) - real(dp), allocatable :: fcorr(:,:) - complex(dp), allocatable :: aux(:) - ! - integer, external :: compindex - integer, external :: compmod - integer, external :: bound - integer, external :: ldim_block - integer, external :: gind_block - real(dp), external :: pinterp - real(dp), external :: qinterp - real(dp), external :: dpinterp - real(dp), external :: dqinterp - ! - ! ... initializes variables - ! - delta1=a1(1)/dble(nr1) - delta2=a2(2)/dble(nr2) - delta3=a3(3)/dble(nr3) - ! - df1=0.0_dp - df2=0.0_dp - df3=0.0_dp - ! - bound1=0 - bound2=0 - bound3=0 - ! - allocate(fcorr(3,nat)) - fcorr(:,:)=0.0_dp - ! - ! ... collect vcomp and scatter across nodes (cf. old_write_rho) - ! - nr1=dfft%nr1 - nr2=dfft%nr2 - nr3=dfft%nr3 - ! - nr1x=dfft%nr1x - nr2x=dfft%nr2x - nr3x=dfft%nr3x - ! - allocate(displs(nproc_image),recvcount(nproc_image)) - allocate(vcomp(nr1x*nr2x*nr3x)) - ! - vcomp=0.0_dp - ! - if(nproc_image>1) then - ! - do proc=1,nproc_image - ! - recvcount(proc)=dfft%nnp*dfft%npp(proc) - ! - if(proc==1) then - displs(proc)=0 - else - displs(proc)=displs(proc-1)+recvcount(proc-1) - endif - ! - enddo - ! - call mp_barrier() - call mp_gather(vcorr,vcomp,recvcount,displs, & - meta_ionode_id,intra_image_comm) - call mp_sum(vcomp,intra_image_comm) - ! - else - ! - if (nr1/=nr1x.or.nr2/=nr2x.or.nr3/=nr3x) & - call errore('calc_fcorr','dimension mistmatch',10) - ! - vcomp(1:nr1x*nr2x*nr3x)=vcorr(1:nnrx) - ! - endif - ! - ! ... distributes atoms over processors (cf. vofesr) - ! - na_loc=ldim_block(nat,nproc_image,me_image) - ia_s=gind_block(1,nat,nproc_image,me_image ) - ia_e=ia_s+na_loc-1 - ! - do ia=ia_s,ia_e - ! - call s_to_r(taus(1:3,ia),taur(1:3,ia),box%hmat) - ! - t1=taur(1,ia)/delta1 - t2=taur(2,ia)/delta2 - t3=taur(3,ia)/delta3 - ! - ir1=int(t1)+1 - ir2=int(t2)+1 - ir3=int(t3)+1 - ! - t1=t1-dble(ir1-1) - t2=t2-dble(ir2-1) - t3=t3-dble(ir3-1) - ! - ir1=compmod(ir1,nr1) - ir2=compmod(ir2,nr2) - ir3=compmod(ir3,nr3) - ! - ! ... with TCC, we use a periodic interpolation - ! - !bound1=bound(ir1,nr1) - !bound2=bound(ir2,nr2) - !bound3=bound(ir3,nr3) - ! - f=0 - g1=0 - g2=0 - g3=0 - ! - do a=0,1 - do b=0,1 - do c=0,1 - ! - f=vcomp(compindex(ir1+a,ir2+b,ir3+c,nr1x,nr2x,nr3x)) - ! - g1=f*dpinterp(t1,a,bound1)*pinterp(t2,b,bound2) & - *pinterp(t3,c,bound3) - g2=f*pinterp(t1,a,bound1)*dpinterp(t2,b,bound2) & - *pinterp(t3,c,bound3) - g3=f*pinterp(t1,a,bound1)*pinterp(t2,b,bound2) & - *dpinterp(t3,c,bound3) - ! - df1=0.5_dp*(vcomp(compindex(ir1+a+1,ir2+b,ir3+c,nr1x,nr2x,nr3x)) & - -vcomp(compindex(ir1+a-1,ir2+b,ir3+c,nr1x,nr2x,nr3x))) - df2=0.5_dp*(vcomp(compindex(ir1+a,ir2+b+1,ir3+c,nr1x,nr2x,nr3x)) & - -vcomp(compindex(ir1+a,ir2+b-1,ir3+c,nr1x,nr2x,nr3x))) - df3=0.5_dp*(vcomp(compindex(ir1+a,ir2+b,ir3+c+1,nr1x,nr2x,nr3x)) & - -vcomp(compindex(ir1+a,ir2+b,ir3+c-1,nr1x,nr2x,nr3x))) - ! - fcorr(1,ia)=fcorr(1,ia)+g1 & - +df1*dqinterp(t1,a,bound1)*pinterp(t2,b,bound2) & - *pinterp(t3,c,bound3) - fcorr(2,ia)=fcorr(2,ia)+g2 & - +df2*pinterp(t1,a,bound1)*dqinterp(t2,b,bound2) & - *pinterp(t3,c,bound3) - fcorr(3,ia)=fcorr(3,ia)+g3 & - +df3*pinterp(t1,a,bound1)*pinterp(t2,b,bound2) & - *dqinterp(t3,c,bound3) - ! - end do - end do - end do - ! - fcorr(1,ia)=fcorr(1,ia)/delta1 - fcorr(2,ia)=fcorr(2,ia)/delta2 - fcorr(3,ia)=fcorr(3,ia)/delta3 - ! - end do - ! - call mp_sum(fcorr,intra_image_comm) - ! - isa=0 - do is=1,nsp - do ia=1,na(is) - isa=isa+1 - fion(1,isa)=fion(1,isa)+fcorr(1,isa)*zv(is) - fion(2,isa)=fion(2,isa)+fcorr(2,isa)*zv(is) - fion(3,isa)=fion(3,isa)+fcorr(3,isa)*zv(is) - end do - end do - ! - deallocate(displs,recvcount) - deallocate(vcomp) - deallocate(fcorr) - ! -!-------------------------------------------------------------------- - end subroutine calc_fcorr -!-------------------------------------------------------------------- diff --git a/quantum_espresso/kcp/CPV/efermi.f90 b/quantum_espresso/kcp/CPV/efermi.f90 deleted file mode 100644 index c908b8c34..000000000 --- a/quantum_espresso/kcp/CPV/efermi.f90 +++ /dev/null @@ -1,729 +0,0 @@ -! -! Copyright (C) 2002-2008 Quantum-ESPRESSO groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!----------------------------------------------------------------------- -SUBROUTINE EFERMI(NEL,NBANDS,DEL,NKPTS,OCC,EF,EIGVAL, & - & entropy,ismear,nspin) -!----------------------------------------------------------------------- -! -! FERMI ENERGY & SMEARING PACKAGE WRITTEN BY A. DE VITA -! IN JULY 1992 FROM R.J. NEEDS ORIGINAL VERSION. -! -! THIS VERSION IS BY N. MARZARI. COLD SMEARING ADDED IN OCT 1995. -! -! GIVEN A SET OF WEIGHTS AND THE EIGENVALUES ASSOCIATED TO THEIR -! K-POINTS FOR BZ SAMPLING, THIS SUBROUTINE PERFORMS TWO TASKS: -! -! (1) DETERMINES THE FERMI LEVEL AND THE OCCUPANCY OF THE STATES -! ACCORDING TO THE CHOSEN (ismear) THERMAL BROADENING -! -! (2) CALCULATES -TS (for schemes 1, 2 and 4, one-half of -TS -! is the entropy correction that should be added to the -! total energy to recover the zero-broadening energy -! (i.e. the true ground-state energy). This is not really -! necessary anymore using schemes 3, 5, and 6: the free -! energy E-TS is automatically independent of the temperature (!) -! up to the fourth (3) or third order (5, 6) in T. Note that -! (5, 6) do not have negative occupation numbers, at variance -! with (3). -! -! THE SUGGESTED SMEARING SCHEME IS ismear=6 (COLD SMEARING II, -! Marzari et al., Phys. Rev. Lett. 82, 3296 (1999) ) -! -! THE SIX SMEARING SCHEMES (CHOOSE ONE WITH PARAMETER ISMEAR) ARE: -! -! (1) GAUSSIAN: -! -! SEE: C-L FU AND K-M HO, PHYS. REV. B 28, 5480 (1983). -! THEIR IMPLEMENTATION WAS VARIATIONAL BUT *NOT* CORRECTED FOR -! SECOND ORDER DEVIATION IN SIGMA, AS ALSO WAS THE SIMILAR SCHEME -! (WITH OPPOSITE SIGN DEVIATION) IN: R.J.NEEDS, R.M.MARTIN AND O.H. -! NIELSEN, PHYS. REV. B 33 , 3778 (1986). -! USING THE CORRECTION CALCULATED HEREAFTER EVERYTHING SHOULD BE OK. -! THE SMEARING FUNCTION IS A GAUSSIAN NORMALISED TO 2. -! THE OCCUPATION FUNCTION IS THE ASSOCIATED COMPLEMENTARY -! ERROR FUNCTION. -! -! (2) FERMI-DIRAC: -! -! SEE: M.J.GILLAN J. PHYS. CONDENS. MATTER 1, 689 (1989), FOLLOWING -! THE SCHEME OUTLINED IN J.CALLAWAY AND N.H.MARCH, SOLID STATE PHYS. 38, -! 136 (1984), AFTER D.N.MERMIN, PHYS. REV 137, A1441 (1965). -! THE OCCUPATION FUNCTION IS TWICE THE SINGLE ELECTRON -! FERMI-DIRAC DISTRIBUTION. -! -! (3) HERMITE-DELTA_EXPANSION: -! -! SEE: METHFESSEL AND PAXTON, PHYS. REV.B 40, 3616 (1989). -! THE SMEARING FUNCTION IS A TRUNCATED EXPANSION OF DIRAC'S DELTA -! IN HERMITE POLINOMIALS. -! FOR THE SMEARING FUNCTION IMPLEMENTED HERE THE TRUNCATION IS -! AT THE FIRST NON-TRIVIAL EXPANSION TERM D1(X). -! THE OCCUPATION FUNCTION IS THE ASSOCIATED PRIMITIVE. -! (NOTE: THE OCCUPATION FUNCTION IS NEITHER MONOTONIC NOR LIMITED -! BETWEEN 0. AND 2. : PLEASE CHECK THE COMPATIBILITY OF THIS WITH -! YOUR CODE'S VERSION AND VERIFY IN A TEST CALCULATION THAT THE -! FERMI LEVEL IS *UNIQUELY* DETERMINED). -! -! THE ENTROPY CORRECTION HOLDS UP TO THE THIRD ORDER IN DELTA AT LEAST, -! AND IT IS NOT NECESSARY (PUT = 0.) FOR THE HERMITE_DELTA EXPANSION, -! SINCE THE LINEAR ENTROPY TERM IN SIGMA IS ZERO BY CONSTRUCTION -! IN THAT CASE. (well, we still need the correct free energy. hence -! delcor is set to its true value, nmar) -! -! (4) GAUSSIAN SPLINES: -! -! similar to a Gaussian smearing, but does not require the -! function inversion to calculate the gradients on the occupancies. -! It is thus to be preferred in a scheme in which the occ are -! independent variables. (N. Marzari) -! -! (5) COLD SMEARING I: -! -! similar to Methfessel-Paxton (zeroes the linear order in the entropy), -! but now with positive-definite occupations (note they can be greater -! than 1). This version has a=-0.5634 (minimization of the bump), not -! a=-0.8165 (monotonic function in the tail) (N. Marzari) -! -! (6) COLD SMEARING II: -! -! the one to use. (5) and (6) are practically identical; this is more elegant. -! For a discussion, see Marzari et al., Phys. Rev. Lett. 82, 3296 (1999), -! or Marzari's PhD thesis (Univ. of Cambridge, 1996), at -! http://quasiamore.mit.edu/phd -! -!----------------------------------------------------------------------- -! PLEASE INQUIRE WITH ADV/NMAR FOR REFERENCE & SUGGESTIONS IF -! YOU PLAN TO USE THE PRESENT CORRECTED BZ SAMPLING SCHEME -!----------------------------------------------------------------------- -! -! INPUT -! -! NEL ..... NUMBER OF ELECTRONS PER UNIT CELL -! NBANDS .. NUMBER OF BANDS FOR EACH K-POINT -! DEL ..... WIDTH OF GAUSSIAN SMEARING FUNCTION -! NKPTS ... NUMBER OF K-POINTS -! WEIGHT .. THE WEIGHT OF EACH K-POINT -! EIGVAL .. EIGENVALUES -! ISMEAR .. SMEARING SCHEME -! NSPIN ... 1:SPIN RESTRICTED, 2:SPIN UNRESTRICTED -! -! OUTPUT -! -! OCC ..... THE OCCUPANCY OF EACH STATE -! EF ...... THE FERMI ENERGY -! entropy.. -TS (such that the variational functional, i.e. -! the free energy, is E-TS) -! -! Also available -! -! SORT .... THE EIGENVALUES ARE WRITTEN INTO SORT WHICH IS -! THEN SORTED INTO ASCENDING NUMERICAL VALUE, FROM -! WHICH BOUNDS ON EF CAN EASILY BE OBTAINED -! DELCOR THE CORRECTION -0.5*T*S (the correction is needed -! for 1,2 and 4 only) -! -!----------------------------------------------------------------------- -! NOTE : -! -! ISMEAR = 1 GAUSSIAN BROADENING -! = 2 FERMI-DIRAC BROADENING -! = 3 HERMITE EXPANSION (1ST ORD.) (right delcor now, nmar) -! = 4 SPLINE OF GAUSSIANS (nmar) -! = 5 COLD SMEARING I (nmar) -! = 6 COLD SMEARING II (nmar) -! -! JMAX THE MAX NUMBER OF BISECTIONS TO GET EF -! XACC THE DESIRED ACCURACY ON EF -!----------------------------------------------------------------------- -! ANOTHER NOTE: -! Thanks to the possible > 2 or < 0 -! orbital occupancies in the general case of smearing function, -! (e.g. in the M-P case) the algorithm to find EF has been -! chosen to be the robust bisection method (from Numerical -! Recipes) to allow for non monotonic relation between total -! NEL (see above) and EF. One value for EF which solves -! NEL(EF) - Z = 0 is always found. -!----------------------------------------------------------------------- - - - - USE kinds, ONLY : DP - - implicit none - - INTEGER, INTENT(IN) :: nel, nbands, nkpts - REAL(kind=DP), INTENT(OUT) :: occ(nbands,nkpts) - REAL(kind=DP), INTENT(OUT) :: ef - REAL(kind=DP), INTENT(IN) :: eigval(nbands, nkpts) - REAL(kind=DP), INTENT(OUT) :: entropy - INTEGER, INTENT(IN) :: ismear, nspin - REAL(kind=DP), INTENT(IN) :: del - - - - REAL(kind=DP) :: weight(nkpts), sort(nbands*nkpts) - REAL(kind=DP), EXTERNAL :: qe_erfc,FERMID,DELTHM,POSHM,POSHM2, SPLINE - INTEGER, PARAMETER :: JMAX =300 - REAL(kind=DP), PARAMETER :: XACC=1.0D-17 - - INTEGER :: isppt,j,nkp,neig,nn,n, inel, nel2, j2 - REAL(kind=DP) :: fspin, entrofac,entrospin - REAL(kind=DP) :: pi,ee,eesh,sq2i,piesqq,z,en - REAL(kind=DP) :: eigmin, eigmax, xe1,xe2,z1 - REAL(kind=DP) :: x,fmid, f, rtbis,dx,xmid,delcor,fi,a - REAL(kind=DP) :: zeta,elow, test - - - if ((nspin == 1).or.(nspin == 2)) then - continue - else - write(*,*) 'ERROR: EFERMI with nspin different from 1 or 2' - stop - end if - - fspin=DBLE(nspin) - entrofac=3.d0-fspin - entrospin=2.d0/fspin - -! if ((nspin == 2).and.(ismear == 2)) then -! write(*,*) 'ERROR: EFERMI with nspin.eq.2 and ismear.ne.2' -! stop -! end if - - if (nspin == 1) then - if (2*nbands == nel) then - DO ISPPT = 1, NKPTS - DO J = 1,NBANDS - OCC(J,ISPPT) = 2.0d0 - end do - end do - return - end if - else - if (nbands == nel) then - DO ISPPT = 1, NKPTS - DO J = 1,NBANDS - OCC(J,ISPPT) = 1.0d0 - end do - end do - return - end if - end if - - pi=acos(0.d0)*2.d0 - ee=exp(1.d0) - eesh=sqrt(ee)*0.5d0 - sq2i=sqrt(2.0d0)*0.5d0 - piesqq=sqrt(ee*pi)*0.25d0 - -! note that this has to be changed if k-points are introduced ! - - do nkp=1,nkpts - weight(nkp)=1.d0/DBLE(nkpts) - end do - - Z = DBLE (NEL) - -! COPY EIGVAL INTO SORT ARRAY. - - NEIG = 0 - DO ISPPT = 1,NKPTS - DO J = 1, NBANDS - NEIG = NEIG + 1 - SORT(NEIG) = EIGVAL(J,ISPPT) - enddo - enddo - -!----------------------------------------------------------------------- -! THE ARRAY IS ORDERED INTO ASCENDING ORDER OF EIGENVALUE -!----------------------------------------------------------------------- - - DO N=2,NKPTS*NBANDS - EN=SORT(N) - DO NN=N-1,1,-1 - IF (SORT(NN).LE.EN) THEN - EXIT - ENDIF - SORT(NN+1)=SORT(NN) - enddo - SORT(NN+1)=EN - end do - eigmin=sort(1) - eigmax=sort(NKPTS*nbands) - -!----------------------------------------------------------------------- -! if the temperature is 0 (well, le.1d-9) then set manually the -! Fermi energy between the HOMO and LUMO -!----------------------------------------------------------------------- - - - if ((abs(del).le.1.d-9).and.(nspin.eq.1)) then - if ((2*(nel/2)).ne.nel) then - write(*,*) 'EFERMI: etemp=0.0 but nel is odd !' - stop - end if - nel2=nel/2 - entropy=0.d0 - ef=0.5d0*(sort(NKPTS*nel2)+sort(NKPTS*nel2+1)) - DO ISPPT = 1,NKPTS - DO J = 1, NBANDS - if (eigval(J,ISPPT).le.ef) then - occ(j,isppt)=2.d0 - else - occ(j,isppt)=0.d0 - end if - end do - end do - TEST = 0.d0 -! write(*,'(a8,f12.6)') 'Efermi: ',ef - DO ISPPT = 1,NKPTS - DO J = 1,NBANDS -! write(*,'(a8,f12.6,f10.6)') 'Eigs,f: ',& -! & eigval(J,ISPPT),OCC(J,ISPPT) - TEST = TEST + WEIGHT(ISPPT)*OCC(J,ISPPT) - end do - end do -! this is commented since occ is normalized to 2 -! test=test*2.0 - IF ( ABS(TEST-Z) .GT. 1.0D-5) THEN - WRITE(*,*) '*** WARNING *** OCCUPANCIES MANUALLY SET' - DO ISPPT = 1,NKPTS - DO J = 1, NBANDS - if (j.le.nel2) then - occ(j,isppt)=2.d0 - else - occ(j,isppt)=0.d0 - end if -! write(*,'(a8,f12.6,f10.6)') 'Eigs,f: ', -! & eigval(J,ISPPT),OCC(J,ISPPT) - end do - end do - end if - return - else if ((abs(del).le.1.d-9).and.(nspin.ne.1)) then - if ((2*(nel/2)).ne.nel) then - write(*,*) 'EFERMI: etemp=0.0 but nel is odd !' - stop - end if - entropy=0.d0 - ef=0.5d0*(sort(NKPTS*nel)+sort(NKPTS*nel+1)) - DO ISPPT = 1,NKPTS - DO J = 1, NBANDS - if (eigval(J,ISPPT).le.ef) then - occ(j,isppt)=1.d0 - else - occ(j,isppt)=0.d0 - end if - - end do - end do - TEST = 0.d0 -! write(*,'(a8,f12.6)') 'Efermi: ',ef - - DO ISPPT = 1,NKPTS - DO J = 1,NBANDS -! write(*,'(a8,f12.6,f10.6)') 'Eigs,f: ', & -! & eigval(J,ISPPT),OCC(J,ISPPT) - TEST = TEST + WEIGHT(ISPPT)*OCC(J,ISPPT) - end do - end do -! this is commented since occ is normalized to 2 -! test=test*2.0 - IF ( ABS(TEST-Z) .GT. 1.0D-5) THEN - WRITE(*,*) '*** WARNING *** OCCUPANCIES MANUALLY SET' - DO ISPPT = 1,NKPTS - DO J = 1, NBANDS - if (j.le.nel) then - occ(j,isppt)=1.d0 - else - occ(j,isppt)=0.d0 - end if -! write(*,'(a8,f12.6,f10.6)') 'Eigs,f: ', -! & eigval(J,ISPPT),OCC(J,ISPPT) - end do - end do - end if - return - end if - - - -!----------------------------------------------------------------------- -! THE UPPER BOUND XE2 AND THE LOWER BOUND XE1 -! ARE PUT TO FIRST AND LAST EIGENVALUE, THEN -! THE ACTUAL FERMI ENERGY IS FOUND BY BISECTION -! UPPER BOUND IS ACTUALLY UPPED A BIT, JUST IN CASE -!----------------------------------------------------------------------- - - XE1=SORT(1) - XE2=SORT(NKPTS*NBANDS)+del*5.d0 -! write(*,*) NEL,NBANDS,DEL,NKPTS,ismear -! write(*,*) xe1,xe2 -! -! WRITE(*,*) ' ' - IF(ISMEAR.EQ.1) THEN -! WRITE(*,*) 'GAUSSIAN BROADENING' - ELSEIF(ISMEAR.EQ.2) THEN -! WRITE(*,*) 'FERMI-DIRAC BROADENING' - ELSEIF(ISMEAR.EQ.3) THEN -! WRITE(*,*) 'HERMITE-DIRAC BROADENING' - ELSEIF(ISMEAR.EQ.4) THEN -! WRITE(*,*) 'GAUSSIAN SPLINES BROADENING' - ELSEIF(ISMEAR.EQ.5) THEN -! WRITE(*,*) 'COLD SMEARING I' - ELSEIF(ISMEAR.EQ.6) THEN -! WRITE(*,*) 'COLD SMEARING II' - ENDIF -! -! FMID = FUNC(X2) in Numerical Recipes. -! - Z1=0.D0 - DO ISPPT = 1,NKPTS - DO J = 1,NBANDS - X = (XE2 - EIGVAL(J,ISPPT))/DEL - IF(ISMEAR.EQ.1) THEN - Z1 = Z1 + WEIGHT(ISPPT)*( 2.d0 - qe_erfc(X) )/fspin - ELSEIF(ISMEAR.EQ.2) THEN - Z1 = Z1 + WEIGHT(ISPPT)*FERMID(-X)/fspin - ELSEIF(ISMEAR.EQ.3) THEN - Z1 = Z1 + WEIGHT(ISPPT)*DELTHM(X)/fspin - ELSEIF(ISMEAR.EQ.4) THEN - Z1 = Z1 + WEIGHT(ISPPT)*SPLINE(-X)/fspin - ELSEIF(ISMEAR.EQ.5) THEN - Z1 = Z1 + WEIGHT(ISPPT)*POSHM(X)/fspin - ELSEIF(ISMEAR.EQ.6) THEN - Z1 = Z1 + WEIGHT(ISPPT)*POSHM2(X)/fspin - ENDIF - END DO - END DO - - - FMID= Z1-Z -! write(*,*) fmid,z1,z - -! F = FUNC(X1) - - Z1=0.D0 - DO ISPPT = 1,NKPTS - DO J = 1,NBANDS - X = (XE1 - EIGVAL(J,ISPPT))/DEL - IF(ISMEAR.EQ.1) THEN - Z1 = Z1 + WEIGHT(ISPPT)*( 2.d0 - qe_erfc(X) )/fspin - ELSEIF(ISMEAR.EQ.2) THEN - Z1 = Z1 + WEIGHT(ISPPT)*FERMID(-X)/fspin - ELSEIF(ISMEAR.EQ.3) THEN - Z1 = Z1 + WEIGHT(ISPPT)*DELTHM(X)/fspin - ELSEIF(ISMEAR.EQ.4) THEN - Z1 = Z1 + WEIGHT(ISPPT)*SPLINE(-X)/fspin - ELSEIF(ISMEAR.EQ.5) THEN - Z1 = Z1 + WEIGHT(ISPPT)*POSHM(X)/fspin - ELSEIF(ISMEAR.EQ.6) THEN - Z1 = Z1 + WEIGHT(ISPPT)*POSHM2(X)/fspin - ENDIF - END DO - END DO - - - F= Z1-Z -! write(*,*) f,z1,z - - IF(F*FMID .GE. 0.D0) THEN - WRITE(*,*) 'WARNING: NO FERMI ENERGY INSIDE EIGENVALUES ?' - ENDIF - IF(F .LT. 0.D0) THEN - RTBIS = XE1 - DX = XE2 - XE1 - ELSE - RTBIS = XE2 - DX = XE1 - XE2 - ENDIF - - DO J = 1, JMAX - DX = DX * 0.5D0 - XMID = RTBIS + DX - -! FMID=FUNC(XMID) - - Z1=0.D0 - DO ISPPT = 1,NKPTS - DO J2 = 1,NBANDS - X = (XMID - EIGVAL(J2,ISPPT))/DEL - IF(ISMEAR.EQ.1) THEN - Z1 = Z1 + WEIGHT(ISPPT)*( 2.d0 - qe_erfc(X) )/fspin - ELSEIF(ISMEAR.EQ.2) THEN - Z1 = Z1 + WEIGHT(ISPPT)*FERMID(-X)/fspin - ELSEIF(ISMEAR.EQ.3) THEN - Z1 = Z1 + WEIGHT(ISPPT)*DELTHM(X)/fspin - ELSEIF(ISMEAR.EQ.4) THEN - Z1 = Z1 + WEIGHT(ISPPT)*SPLINE(-X)/fspin - ELSEIF(ISMEAR.EQ.5) THEN - Z1 = Z1 + WEIGHT(ISPPT)*POSHM(X)/fspin - ELSEIF(ISMEAR.EQ.6) THEN - Z1 = Z1 + WEIGHT(ISPPT)*POSHM2(X)/fspin - ENDIF - END DO - END DO - - - FMID= Z1-Z - - IF(FMID .LE. 0.D0) RTBIS=XMID - IF(ABS(DX) .LT. XACC .OR. FMID .EQ. 0) THEN - EXIT - ENDIF - ENDDO - IF(J >= JMAX) THEN - WRITE(*,*) 'CANNOT BISECT FOREVER, CAN I ?' - CALL EXIT - ENDIF - EF = RTBIS - - - DO ISPPT = 1, NKPTS - DO J = 1,NBANDS - X = ( EF-EIGVAL(J,ISPPT))/DEL - IF(ISMEAR.EQ.1) THEN - OCC(J,ISPPT) = 2.d0 - qe_erfc(X) - ELSEIF(ISMEAR.EQ.2) THEN - OCC(J,ISPPT) = FERMID(-X) - ELSEIF(ISMEAR.EQ.3) THEN - OCC(J,ISPPT) = DELTHM(X) - ELSEIF(ISMEAR.EQ.4) THEN - OCC(J,ISPPT) = SPLINE(-X) - ELSEIF(ISMEAR.EQ.5) THEN - OCC(J,ISPPT) = POSHM(X) - ELSEIF(ISMEAR.EQ.6) THEN - OCC(J,ISPPT) = POSHM2(X) - ENDIF -! occupations are normalized to two or one depending on nspin - OCC(J,ISPPT) = OCC(J,ISPPT)/fspin - ENDDO - ENDDO - - -!------------------------------------------------------------- -! CALCULATES THE CORRECTION TERM TO GET "0 TEMPERATURE" ENERGY -!------------------------------------------------------------- - - DELCOR=0.0D0 - DO ISPPT = 1, NKPTS - DO J = 1,NBANDS - X = ( EF-EIGVAL(J,ISPPT))/DEL - IF(ISMEAR.EQ.1) THEN - DELCOR=DELCOR & - & -DEL*WEIGHT(ISPPT)*EXP(-X*X)/(2.D0*SQRT(pi)) - ELSEIF(ISMEAR.EQ.2) THEN - FI=FERMID(-X)/entrospin - IF(ABS(FI) .GT. 1.d-12) THEN - IF(ABS(FI-1.D0) .GT. 1.d-12) THEN - DELCOR=DELCOR+DEL*WEIGHT(ISPPT)* & - & (FI*LOG(FI)+(1.D0-FI)*LOG(1.D0-FI)) - ENDIF - ENDIF - ELSEIF(ISMEAR.EQ.3) THEN - DELCOR=DELCOR+DEL/2.0d0*WEIGHT(ISPPT) & - & *(2.0d0*x*x-1.d0)*exp(-x*x)/(2.0d0*sqrt(pi)) - ELSEIF(ISMEAR.EQ.4) THEN - x=abs(x) - zeta=eesh*abs(x)*exp(-(x+sq2i)**2)+piesqq*qe_erfc(x+sq2i) - delcor=delcor-del*WEIGHT(ISPPT)*zeta - ELSEIF(ISMEAR.EQ.5) THEN - a=-0.5634d0 -! a=-0.8165 - DELCOR=DELCOR-DEL/2.d0*WEIGHT(ISPPT) & -! NOTE g's are all intended to be normalized to 1 ! -! this following line is -2*int_minf^x [t*g(t)]dt - & *(2.d0*a*x**3-2.d0*x*x+1 )*exp(-x*x)/(2.d0*sqrt(pi)) - ELSEIF(ISMEAR.EQ.6) THEN - DELCOR=DELCOR-DEL/2.d0*WEIGHT(ISPPT) & -! NOTE g's are all intended to be normalized to 1 ! -! this following line is -2*int_minf^x [t*g(t)]dt - & *(1.d0-sqrt(2.d0)*x)*exp(-(x-1.d0/sqrt(2.d0))**2)/sqrt(pi) - ENDIF - END DO - END DO - - -!-------------------------------------------------------- -! the correction is also stored in sort, for compatibility, -! and -TS is stored in entropy -!-------------------------------------------------------- - - sort(1)=delcor - entropy=entrospin*delcor - -!-------------------------------------------------------- -! TEST WHETHER OCCUPANCY ADDS UP TO Z -!-------------------------------------------------------- - - TEST = 0.d0 -! write(*,'(a8,f12.6)') 'Efermi: ',ef - DO ISPPT = 1,NKPTS - DO J = 1,NBANDS -! write(*,'(a8,f12.6,f10.6)') 'Eigs,f: ', -! & eigval(J,ISPPT),OCC(J,ISPPT) - TEST = TEST + WEIGHT(ISPPT)*OCC(J,ISPPT) - end do - end do - - IF ( ABS(TEST-Z) .GT. 1.0D-5) THEN - WRITE(*,*) '*** WARNING ***' - WRITE(*,220) TEST,NEL -220 FORMAT(' SUM OF OCCUPANCIES =',F30.20 ,' BUT NEL =',I5) -! ELSE -! -!230 FORMAT(' TOTAL CHARGE = ',F15.8) - ENDIF -! -! TEST WHETHER THE MATERIAL IS A SEMICONDUCTOR -! - IF ( MOD( NEL, 2) .EQ. 1) RETURN - INEL = NEL/2 - ELOW = EIGVAL(INEL+1,1) - DO ISPPT = 2,NKPTS - ELOW =MIN( ELOW, EIGVAL(INEL+1,ISPPT)) - ENDDO - - DO ISPPT = 1,NKPTS - IF (ELOW .LT. EIGVAL(INEL,ISPPT)) RETURN - END DO - - if (NKPTS.gt.1) then - WRITE (*,*) 'MATERIAL MAY BE A SEMICONDUCTOR' - end if -! - RETURN -END SUBROUTINE efermi -!----------------------------------------------------------------------- -FUNCTION fermid(xx) - - USE kinds, ONLY : DP - - implicit none - - REAL(kind=DP), INTENT(in) :: xx - - REAL(kind=DP) :: fermid - - IF(XX .GT. 30.D0) THEN - FERMID=0.D0 - ELSEIF(XX .LT. -30.D0) THEN - FERMID=2.D0 - ELSE - FERMID=2.D0/(1.D0+EXP(XX)) - ENDIF -! - RETURN -END FUNCTION fermid -!----------------------------------------------------------------------- -FUNCTION delthm(xx) -! - USE kinds, ONLY : DP - - implicit none - - REAL(kind=DP) :: delthm - REAL(kind=DP), INTENT(in) :: xx - REAL(kind=DP), EXTERNAL :: qe_erfc - - REAL(kind=DP) :: pi - - pi=3.14159265358979d0 - IF(XX .GT. 10.D0) THEN - DELTHM=2.D0 - ELSEIF(XX .LT. -10.D0) THEN - DELTHM=0.D0 - ELSE - DELTHM=(2.D0-qe_erfc(XX))+XX*EXP(-XX*XX)/SQRT(PI) - ENDIF -! - RETURN -END FUNCTION delthm -!----------------------------------------------------------------------- -FUNCTION spline(x) - - USE kinds, ONLY : DP - - implicit none - - REAL(kind=DP) :: spline - REAL(kind=DP), INTENT(in) :: x - - REAL(kind=DP) :: eesqh,sq2i,fx - - eesqh=sqrt(exp(1.d0))*0.5d0 - sq2i=sqrt(2.d0)*0.5d0 - if (x.ge.0.d0) then - fx=eesqh*exp(-(x+sq2i)**2) - else - fx=1.d0-eesqh*exp(-(x-sq2i)**2) - endif - spline=2.d0*fx -! - return -END FUNCTION spline -!----------------------------------------------------------------------- -FUNCTION poshm(x) -! -! NOTE g's are all intended to be normalized to 1 ! -! function = 2 * int_minf^x [g(t)] dt -! - - USE kinds, ONLY : DP - - implicit none - - REAL(kind=DP) :: poshm - REAL(kind=DP), INTENT(in) :: x - REAL(kind=DP), EXTERNAL :: qe_erfc - - REAL(kind=DP) :: pi,a - - pi=3.141592653589793238d0 - a=-0.5634d0 - ! a=-0.8165 - IF(X .GT. 10.D0) THEN - POSHM=2.D0 - ELSEIF(X .LT. -10.D0) THEN - POSHM=0.D0 - ELSE - POSHM=(2.D0-qe_erfc(X))+(-2.d0*a*x*x+2*x+a)*EXP(-X*X)/SQRT(PI)/2.d0 - ENDIF -! - RETURN -END FUNCTION poshm -!----------------------------------------------------------------------- -FUNCTION poshm2(x) -! -! NOTE g's are all intended to be normalized to 1 ! -! function = 2 * int_minf^x [g(t)] dt -! - - USE kinds, ONLY : DP - - implicit none - - REAL(kind=DP) :: poshm2 - REAL(kind=DP), INTENT(in) :: x - REAL(kind=DP), EXTERNAL :: qe_erfc - - REAL(kind=DP) :: pi - - pi=3.141592653589793238d0 - IF(X .GT. 10.D0) THEN - POSHM2=2.D0 - ELSEIF(X .LT. -10.D0) THEN - POSHM2=0.D0 - ELSE - POSHM2=(2.D0-qe_erfc(X-1.d0/sqrt(2.d0)))+ & - & sqrt(2.d0)*exp(-x*x+sqrt(2.d0)*x-0.5d0)/sqrt(pi) - ENDIF -! - RETURN -END FUNCTION poshm2 -!----------------------------------------------------------------------- diff --git a/quantum_espresso/kcp/CPV/efield.f90 b/quantum_espresso/kcp/CPV/efield.f90 deleted file mode 100644 index be94f18ed..000000000 --- a/quantum_espresso/kcp/CPV/efield.f90 +++ /dev/null @@ -1,378 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -MODULE efield_module - - USE kinds, ONLY : DP - - IMPLICIT NONE - SAVE - - logical :: tefield = .FALSE. - logical :: tefield2 = .FALSE. - integer :: epol = 3 !direction electric field - real(kind=DP) :: efield = 0.d0 !intensity electric field - real(kind=DP) :: efield2 =0.d0 - real(kind=DP) evalue!strenght of electric field - real(kind=DP) evalue2 - integer epol2,ipolp2 - integer ipolp !direction of electric field - - real(kind=DP) :: pberryel = 0.0d0, pberryion = 0.0d0 - real(kind=DP) :: pberryel2 = 0.0d0, pberryion2 = 0.0d0 - -!*** -!*** Berry phase -!*** - integer, allocatable:: ctable(:,:,:)!correspondence tables for diff. polarization - integer, allocatable:: ctabin(:,:,:)!inverse correspondence table - complex(DP), allocatable:: qmat(:,:)!inverse of matrix Q, for Barry's phase - complex(DP), allocatable:: gqq(:,:,:,:)!factors int beta_Ri^*beta_Rj exp(iGr)dr - complex(DP), allocatable:: gqqm(:,:,:,:)! the same with exp(-iGr) - complex(DP), allocatable:: gqq0(:,:,:,:)!factors int beta_Ri^*beta_Rj exp(iGr)dr, at Gamma - complex(DP), allocatable:: gqqm0(:,:,:,:)! the same with exp(-iGr), at Gamma - complex(DP), allocatable:: df(:) - integer, allocatable:: ctable2(:,:,:)!correspondence tables for diff. polarization - integer, allocatable:: ctabin2(:,:,:)!inverse correspondence table - complex(DP), allocatable:: qmat2(:,:)!inverse of matrix Q, for Barry's phase - complex(DP), allocatable:: gqq2(:,:,:,:)!factors int beta_Ri^*beta_Rj exp(iGr)dr - complex(DP), allocatable:: gqqm2(:,:,:,:)! the same with exp(-iGr) - complex(DP), allocatable:: gqq02(:,:,:,:)!factors int beta_Ri^*beta_Rj exp(iGr)dr, at Gamma - complex(DP), allocatable:: gqqm02(:,:,:,:)! the same with exp(-iGr), at Gamma - complex(DP) detq - complex(DP) detq2 - real(DP) cdzp(3),cdzm(3), cdz0(3)!centers of ionic charges - -!for parallelization for direcions 1 and 2 - integer :: n_g_missing_p(2)!number of g vector with correspondence G-->G+1 is missing - integer :: n_g_missing_m(2)!number of g vector with correspondence G-->G-1 is missing - integer, allocatable :: whose_is_g(:) !correspondence G(plane waves, global) ---> processor - integer, allocatable :: ctable_missing_1(:,:,:)!correspondence G(plane waves local)--> array for mpi_alltoall - !n_g_missing*nproc - integer, allocatable :: ctable_missing_rev_1(:,:,:)!missing_g --> G (plane waves local) - integer, allocatable :: ctable_missing_2(:,:,:)!correspondence G(plane waves local)--> array for mpi_alltoall - !n_g_missing*nproc - integer, allocatable :: ctable_missing_rev_2(:,:,:)!missing_g --> G (plane waves local) - integer, allocatable :: ctabin_missing_1(:,:,:)!correspondence G(plane waves local)--> array for mpi_alltoall - !n_g_missing*nproc - integer, allocatable :: ctabin_missing_rev_1(:,:,:)!missing_g --> G (plane waves local) - integer, allocatable :: ctabin_missing_2(:,:,:)!correspondence G(plane waves local)--> array for mpi_alltoall - !n_g_missing*nproc - integer, allocatable :: ctabin_missing_rev_2(:,:,:)!missing_g --> G (plane waves local) - -!begin_added:giovanni - INTERFACE berry_energy - module procedure berry_energy_old, berry_energy_new - END INTERFACE - - INTERFACE berry_energy2 - module procedure berry_energy2_old, berry_energy2_new - END INTERFACE -!end_added:giovanni - -CONTAINS - - SUBROUTINE efield_init( epol_ , efield_ ) - USE kinds, ONLY: DP - REAL(DP), INTENT(IN) :: efield_ - INTEGER, INTENT(IN) :: epol_ - epol = epol_ - efield = efield_ - RETURN - END SUBROUTINE efield_init - - SUBROUTINE efield_info( ) - USE io_global, ONLY: ionode,stdout - if(ionode) write (stdout,401) epol, efield - -401 format (/4x,'=====================================' & - & /4x,'| BERRY PHASE ELECTRIC FIELD 1 ' & - & /4x,'=====================================' & - & /4x,'| direction =',i10,' ' & - & /4x,'| intensity =',f10.5,' a.u. ' & - & /4x,'=====================================') - - RETURN - END SUBROUTINE efield_info - - - SUBROUTINE efield_berry_setup( eigr, tau0 ) - USE io_global, ONLY: ionode,stdout - IMPLICIT NONE - COMPLEX(DP), INTENT(IN) :: eigr(:,:) - REAL(DP), INTENT(IN) :: tau0(:,:) - if(ionode) write(stdout,'(''Initialize Berry phase electric field'')') - ipolp = epol - evalue = efield -!set up for parallel calculations - -#ifdef __PARA - call find_whose_is_g - call gtable_missing - call gtable_missing_inv -#endif - - call gtable(ipolp,ctable(1,1,ipolp)) - call gtablein(ipolp,ctabin(1,1,ipolp)) - call qqberry2(gqq0,gqqm0,ipolp)!for Vanderbilt pps - call qqupdate(eigr,gqqm0,gqq,gqqm,ipolp) - !the following line was to keep the center of charge fixed - !when performing molecular dynamics in the presence of an electric - !field - !call cofcharge(tau0,cdz0) - - RETURN - END SUBROUTINE efield_berry_setup - - - SUBROUTINE efield_update( eigr ) - IMPLICIT NONE - COMPLEX(DP), INTENT(IN) :: eigr(:,:) - call qqupdate(eigr,gqqm0,gqq,gqqm,ipolp) - RETURN - END SUBROUTINE efield_update - - - SUBROUTINE allocate_efield( ngw, ngwt,nx, nhx, nas, nsp ) - IMPLICIT NONE - INTEGER, INTENT(IN) :: ngw, ngwt, nx, nhx, nas, nsp - allocate( ctable(ngw,2,3)) - allocate( ctabin(ngw,2,3)) - allocate( qmat(nx,nx)) - allocate( gqq(nhx,nhx,nas,nsp)) - allocate( gqqm(nhx,nhx,nas,nsp)) - allocate( df(ngw)) - allocate( gqq0(nhx,nhx,nas,nsp)) - allocate( gqqm0(nhx,nhx,nas,nsp)) - allocate( whose_is_g(ngwt)) - - RETURN - END SUBROUTINE allocate_efield - - - SUBROUTINE deallocate_efield( ) - IMPLICIT NONE - IF( allocated( ctable ) ) deallocate( ctable ) - IF( allocated( ctabin ) ) deallocate( ctabin ) - IF( allocated( qmat ) ) deallocate( qmat ) - IF( allocated( gqq ) ) deallocate( gqq ) - IF( allocated( gqqm ) ) deallocate( gqqm ) - IF( allocated( df ) ) deallocate( df ) - IF( allocated( gqq0 ) ) deallocate( gqq0 ) - IF( allocated( gqqm0 ) ) deallocate( gqqm0 ) - IF( allocated( whose_is_g) ) deallocate(whose_is_g) - IF( allocated( ctable_missing_1) ) deallocate( ctable_missing_1) - IF( allocated( ctable_missing_2) ) deallocate( ctable_missing_2) - IF( allocated( ctable_missing_rev_1) ) deallocate( ctable_missing_rev_1) - IF( allocated( ctable_missing_rev_1) ) deallocate( ctable_missing_rev_2) - IF( allocated( ctabin_missing_1) ) deallocate( ctabin_missing_1) - IF( allocated( ctabin_missing_2) ) deallocate( ctabin_missing_2) - IF( allocated( ctabin_missing_rev_1) ) deallocate( ctabin_missing_rev_1) - IF( allocated( ctabin_missing_rev_1) ) deallocate( ctabin_missing_rev_2) - RETURN - END SUBROUTINE deallocate_efield - -!begin_added:giovanni - SUBROUTINE berry_energy_new( enb, enbi, bec, cm, fion) - USE ions_positions, ONLY: tau0 - USE control_flags, ONLY: tfor, tprnfor, gamma_only, do_wf_cmplx - USE twin_types !added:giovanni - IMPLICIT NONE - real(DP), intent(out) :: enb, enbi - type(twin_matrix) :: bec !modified:giovanni - real(DP) :: fion(:,:) - complex(DP) :: cm(:,:) - logical :: lgam - - lgam=gamma_only.and..not.do_wf_cmplx - call qmatrixd(cm,bec,ctable(1,1,ipolp),gqq,qmat,detq,ipolp) - call enberry( detq, ipolp,enb) - call berryion(tau0,fion,tfor.or.tprnfor,ipolp,evalue,enbi) - pberryel=enb - pberryion=enbi - enb=enb*evalue - enbi=enbi*evalue - END SUBROUTINE berry_energy_new -!end_added:giovanni - - SUBROUTINE berry_energy_old( enb, enbi, bec, cm, fion) - USE ions_positions, ONLY: tau0 - USE control_flags, ONLY: tfor, tprnfor - IMPLICIT NONE - real(DP), intent(out) :: enb, enbi - real(DP) :: bec(:,:) - real(DP) :: fion(:,:) - complex(DP) :: cm(:,:) - - call qmatrixd_old(cm,bec,ctable(1,1,ipolp),gqq,qmat,detq,ipolp) - call enberry( detq, ipolp,enb) - call berryion(tau0,fion,tfor.or.tprnfor,ipolp,evalue,enbi) - pberryel=enb - pberryion=enbi - enb=enb*evalue - enbi=enbi*evalue - END SUBROUTINE berry_energy_old - - - SUBROUTINE dforce_efield (bec,i,cm,c2,c3,rhos) - USE uspp, ONLY: betae => vkb, deeq - USE gvecw, ONLY: ngw - IMPLICIT NONE - complex(DP), intent(out) :: c2(:), c3(:) - complex(DP), intent(in) :: cm(:,:) - REAL(DP) :: rhos(:,:) - real(DP) :: bec(:,:) - integer :: i - integer :: ig - call dforceb (cm, i, betae, ipolp, bec ,ctabin(1,1,ipolp), gqq, gqqm, qmat, deeq, df) - do ig=1,ngw - c2(ig)=c2(ig)+evalue*df(ig) - enddo - call dforceb (cm, i+1, betae, ipolp, bec ,ctabin(1,1,ipolp), gqq, gqqm, qmat, deeq, df) - do ig=1,ngw - c3(ig)=c3(ig)+evalue*df(ig) - enddo - END SUBROUTINE dforce_efield - - SUBROUTINE efield_init2( epol_ , efield_ ) - USE kinds, ONLY: DP - REAL(DP), INTENT(IN) :: efield_ - INTEGER, INTENT(IN) :: epol_ - epol2 = epol_ - efield2 = efield_ - RETURN - END SUBROUTINE efield_init2 - - SUBROUTINE efield_info2( ) - USE io_global, ONLY: ionode,stdout - if(ionode) write (stdout,402) epol2, efield2 - -402 format (/4x,'=====================================' & - & /4x,'| BERRY PHASE ELECTRIC FIELD 2 ' & - & /4x,'=====================================' & - & /4x,'| direction =',i10,' ' & - & /4x,'| intensity =',f10.5,' a.u. ' & - & /4x,'=====================================') - - RETURN - END SUBROUTINE efield_info2 - - - SUBROUTINE efield_berry_setup2( eigr, tau0 ) - USE io_global, ONLY: ionode,stdout - IMPLICIT NONE - COMPLEX(DP), INTENT(IN) :: eigr(:,:) - REAL(DP), INTENT(IN) :: tau0(:,:) - if(ionode) write(stdout,'(''Initialize Berry phase electric field'')') - ipolp2 = epol2 - evalue2 = efield2 - call gtable(ipolp2,ctable2(1,1,ipolp2)) - call gtablein(ipolp2,ctabin2(1,1,ipolp2)) - call qqberry2(gqq02,gqqm02,ipolp2)!for Vanderbilt pps - call qqupdate(eigr,gqqm02,gqq2,gqqm2,ipolp2) - !the following line was to keep the center of charge fixed - !when performing molecular dynamics in the presence of an electric - !field - !call cofcharge(tau0,cdz0) - RETURN - END SUBROUTINE efield_berry_setup2 - - - SUBROUTINE efield_update2( eigr ) - IMPLICIT NONE - COMPLEX(DP), INTENT(IN) :: eigr(:,:) - call qqupdate(eigr,gqqm02,gqq2,gqqm2,ipolp2) - RETURN - END SUBROUTINE efield_update2 - - - SUBROUTINE allocate_efield2( ngw, nx, nhx, nas, nsp ) - IMPLICIT NONE - INTEGER, INTENT(IN) :: ngw, nx, nhx, nas, nsp - allocate( ctable2(ngw,2,3)) - allocate( ctabin2(ngw,2,3)) - allocate( qmat2(nx,nx)) - allocate( gqq2(nhx,nhx,nas,nsp)) - allocate( gqqm2(nhx,nhx,nas,nsp)) - allocate( gqq02(nhx,nhx,nas,nsp)) - allocate( gqqm02(nhx,nhx,nas,nsp)) - RETURN - END SUBROUTINE allocate_efield2 - - - SUBROUTINE deallocate_efield2( ) - IMPLICIT NONE - IF( allocated( ctable2 ) ) deallocate( ctable2 ) - IF( allocated( ctabin2 ) ) deallocate( ctabin2 ) - IF( allocated( qmat2 ) ) deallocate( qmat2 ) - IF( allocated( gqq2 ) ) deallocate( gqq2 ) - IF( allocated( gqqm2 ) ) deallocate( gqqm2 ) - IF( allocated( gqq02 ) ) deallocate( gqq02 ) - IF( allocated( gqqm02 ) ) deallocate( gqqm02 ) - RETURN - END SUBROUTINE deallocate_efield2 - - - SUBROUTINE berry_energy2_old( enb, enbi, bec, cm, fion ) - USE ions_positions, ONLY: tau0 - USE control_flags, ONLY: tfor, tprnfor - IMPLICIT NONE - real(DP), intent(out) :: enb, enbi - real(DP) :: bec(:,:) - real(DP) :: fion(:,:) - complex(DP) :: cm(:,:) - call qmatrixd_old(cm,bec,ctable2(1,1,ipolp2),gqq2,qmat2,detq2,ipolp2) - call enberry( detq2, ipolp2,enb) - call berryion(tau0,fion,tfor.or.tprnfor,ipolp2,evalue2,enbi) - pberryel2=enb - pberryion2=enbi - enb=enb*evalue2 - enbi=enbi*evalue2 - END SUBROUTINE berry_energy2_old - - SUBROUTINE berry_energy2_new( enb, enbi, bec, cm, fion ) - USE ions_positions, ONLY: tau0 - USE control_flags, ONLY: tfor, tprnfor, gamma_only, do_wf_cmplx - USE twin_types - IMPLICIT NONE - real(DP), intent(out) :: enb, enbi - type(twin_matrix) :: bec !modified:giovanni(:,:) - real(DP) :: fion(:,:) - complex(DP) :: cm(:,:) - logical :: lgam - - lgam=gamma_only.and..not.do_wf_cmplx - call qmatrixd(cm,bec,ctable2(1,1,ipolp2),gqq2,qmat2,detq2,ipolp2) - call enberry( detq2, ipolp2,enb) - call berryion(tau0,fion,tfor.or.tprnfor,ipolp2,evalue2,enbi) - pberryel2=enb - pberryion2=enbi - enb=enb*evalue2 - enbi=enbi*evalue2 - END SUBROUTINE berry_energy2_new - - SUBROUTINE dforce_efield2 (bec,i,cm,c2,c3,rhos) - USE uspp, ONLY: betae => vkb, deeq - USE gvecw, ONLY: ngw - IMPLICIT NONE - complex(DP), intent(out) :: c2(:), c3(:) - complex(DP), intent(in) :: cm(:,:) - REAL(DP) :: rhos(:,:) - real(DP) :: bec(:,:) - integer :: i - integer :: ig - call dforceb (cm, i, betae, ipolp2, bec ,ctabin2(1,1,ipolp2), gqq2, gqqm2, qmat2, deeq, df) - do ig=1,ngw - c2(ig)=c2(ig)+evalue2*df(ig) - enddo - call dforceb (cm, i+1, betae, ipolp2, bec ,ctabin2(1,1,ipolp2), gqq2, gqqm2, qmat2, deeq, df) - do ig=1,ngw - c3(ig)=c3(ig)+evalue2*df(ig) - enddo - END SUBROUTINE dforce_efield2 - -END MODULE efield_module diff --git a/quantum_espresso/kcp/CPV/eigs0.f90 b/quantum_espresso/kcp/CPV/eigs0.f90 deleted file mode 100644 index 7b3ef37f4..000000000 --- a/quantum_espresso/kcp/CPV/eigs0.f90 +++ /dev/null @@ -1,846 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!----------------------------------------------------------------------- - subroutine eigs0( ei, tprint, nspin, nupdwn, iupdwn, lf, f, nx, lambda, nudx, desc ) -!----------------------------------------------------------------------- -! computes eigenvalues (wr) of the real symmetric matrix lambda -! Note that lambda as calculated is multiplied by occupation numbers -! so empty states yield zero. Eigenvalues are printed out in eV -! - use kinds, only : DP - use io_global, only : stdout - use constants, only : autoev - use dspev_module, only : dspev_drv, pdspev_drv - USE sic_module, only : self_interaction - USE cp_main_variables, only : nlam, la_proc - USE descriptors, ONLY : nlar_ , nlac_ , ilar_ , ilac_ , lambda_node_ , la_me_ , la_n_ , & - descla_siz_ , la_npr_ , la_npc_ , la_nrl_ , la_nrlx_ , la_comm_ , & - nlax_ , la_myc_ , la_myr_ - USE mp, only : mp_sum, mp_bcast - USE mp_global, only : intra_image_comm, root_image - use nksic, only : f_cutoff - - implicit none -! input - logical, intent(in) :: tprint, lf - integer, intent(in) :: nspin, nx, nudx, nupdwn(nspin), iupdwn(nspin) - integer, intent(in) :: desc( descla_siz_ , 2 ) - real(DP), intent(in) :: lambda( nlam, nlam, nspin ), f( nx ) - real(DP), intent(out) :: ei( nudx, nspin ) -! local variables - real(DP), allocatable :: ap(:), wr(:) - real(DP) zr(1) - integer :: iss, j, i, k, n, nspin_eig, npaired - INTEGER :: ir, nr, np - logical :: tsic - CHARACTER(LEN=80) :: msg -! - tsic = ( ABS( self_interaction) /= 0 ) - - IF( tsic ) THEN - nspin_eig = 1 - npaired = nupdwn(2) - ELSE - nspin_eig = nspin - npaired = 0 - END IF - - - do iss = 1, nspin_eig - - IF( nudx < nupdwn(iss) ) THEN - WRITE( msg, 100 ) nudx, SIZE( ei, 1 ), nupdwn(iss) -100 FORMAT( ' wrong dimension array ei = ', 3I10 ) - CALL errore( ' eigs0 ', msg, 1 ) - END IF - - IF( tsic ) THEN - n = npaired - ELSE - n = nupdwn(iss) - END IF - - allocate( wr( n ) ) - - IF( la_proc ) THEN - - np = desc( la_npc_ , iss ) * desc( la_npr_ , iss ) - - IF( np > 1 ) THEN - - ! matrix is distributed - - CALL qe_pdsyevd( .false., n, desc(1,iss), lambda(1,1,iss), SIZE(lambda,1), wr ) - - ELSE - - ! matrix is not distributed - - allocate( ap( n * ( n + 1 ) / 2 ) ) - - k = 0 - do i = 1, n - do j = i, n - k = k + 1 - ap( k ) = lambda( j, i, iss ) - end do - end do - - CALL dspev_drv( 'N', 'L', n, ap, wr, zr, 1 ) - - deallocate( ap ) - - END IF - - END IF - - call mp_bcast( wr, root_image, intra_image_comm ) - - if( lf ) then - do i = 1, n - wr(i)=wr(i)/max(f(iupdwn(iss)-1+i),f_cutoff) - end do - end if - ! - ! store eigenvalues - ! - ei( 1:n, iss ) = wr( 1:n ) - - IF( tsic ) THEN - ! - ! store unpaired state - ! - ei( 1:n, 1 ) = ei( 1:n, 1 ) / 2.0d0 - ei( nupdwn(1), 1 ) = 0.0d0 - if( la_proc ) then - IF( desc( la_myc_ , iss ) == desc( la_myr_ , iss ) ) THEN - ir = desc( ilar_ , iss ) - nr = desc( nlar_ , iss ) - IF( nupdwn(1) >= ir .AND. nupdwn(1) < ir + nr ) then - ei( nupdwn(1), 1 ) = lambda( nupdwn(1)-ir+1, nupdwn(1)-ir+1, 1 ) - end if - END IF - endif - call mp_sum( ei( nupdwn(1), 1 ), intra_image_comm ) - ! - END IF - - ! WRITE( stdout,*) '---- DEBUG ----' ! debug - ! WRITE( stdout,14) ( wr( i ) * autoev / 2.0d0, i = 1, nupdwn(iss) ) ! debug - - deallocate( wr ) - - end do - ! - ! - do iss = 1, nspin - - IF( tsic .AND. iss == 2 ) THEN - ei( 1:npaired, 2 ) = ei( 1:npaired, 1 ) - END IF - - IF( tprint ) THEN - ! - ! print out eigenvalues - ! - WRITE( stdout,12) 0.d0, 0.d0, 0.d0 - WRITE( stdout,14) ( ei( i, iss ) * autoev, i = 1, nupdwn(iss) ) - - ENDIF - - end do - - IF( tprint ) WRITE( stdout,*) - - 12 format(//' eigenvalues at k-point: ',3f6.3) - 14 format(10f8.2) -! - return - end subroutine eigs0 - -!----------------------------------------------------------------------- - subroutine eigs0_twin( ei, tprint, nspin, nupdwn, iupdwn, lf, f, nx, lambda, nudx, desc ) -!----------------------------------------------------------------------- -! computes eigenvalues (wr) of the real symmetric matrix lambda -! Note that lambda as calculated is multiplied by occupation numbers -! so empty states yield zero. Eigenvalues are printed out in eV -! - use kinds, only : DP - use io_global, only : stdout - use constants, only : autoev - use dspev_module, only : dspev_drv, pdspev_drv - use zhpev_module, only : zhpev_drv - USE sic_module, only : self_interaction - USE cp_main_variables, only : la_proc - USE descriptors, ONLY : nlar_ , nlac_ , ilar_ , ilac_ , lambda_node_ , la_me_ , la_n_ , & - descla_siz_ , la_npr_ , la_npc_ , la_nrl_ , la_nrlx_ , la_comm_ , & - nlax_ , la_myc_ , la_myr_ - USE mp, only : mp_sum, mp_bcast - USE mp_global, only : intra_image_comm, root_image - use nksic, only : f_cutoff - USE twin_types - - implicit none -! input - logical, intent(in) :: tprint, lf - integer, intent(in) :: nspin, nx, nudx, nupdwn(nspin), iupdwn(nspin) - integer, intent(in) :: desc( descla_siz_ , 2 ) - real(DP), intent(in) :: f( nx ) - type(twin_matrix), dimension(nspin), intent(in) :: lambda - real(DP), intent(out) :: ei( nudx, nspin ) -! local variables - real(DP), allocatable :: ap(:), wr(:) - complex(DP), allocatable :: ap_c(:) - real(DP) zr(1) - complex(DP) zr_c(1) - integer :: iss, j, i, k, n, nspin_eig, npaired - INTEGER :: ir, nr, np - logical :: tsic - CHARACTER(LEN=80) :: msg - ! - tsic = ( ABS( self_interaction) /= 0 ) - ! - IF ( tsic ) THEN - nspin_eig = 1 - npaired = nupdwn(2) - ELSE - nspin_eig = nspin - npaired = 0 - ENDIF - ! - do iss = 1, nspin_eig - ! - IF ( nudx < nupdwn(iss) ) THEN - ! - WRITE( msg, 100 ) nudx, SIZE( ei, 1 ), nupdwn(iss) -100 FORMAT( ' wrong dimension array ei = ', 3I10 ) - CALL errore( ' eigs0 ', msg, 1 ) - ! - ENDIF - ! - IF( tsic ) THEN - n = npaired - ELSE - n = nupdwn(iss) - END IF - ! - IF (n.gt.0) THEN - ! - allocate( wr( n ) ) - ! - IF ( la_proc ) THEN - ! - np = desc( la_npc_ , iss ) * desc( la_npr_ , iss ) - ! - IF ( np > 1 ) THEN - ! - ! matrix is distributed - ! - IF (.not.lambda(iss)%iscmplx) THEN - ! - write(6,*) "sizlambda", size(lambda(iss)%rvec,1), lambda(iss)%xdim - CALL qe_pdsyevd( .false., n, desc(1,iss), lambda(iss)%rvec(1,1), SIZE(lambda(iss)%rvec,1), wr ) - ! - ELSE - ! - write(6,*) "sizlambda", size(lambda(iss)%cvec,1), lambda(iss)%xdim - CALL qe_pzheevd( .false., n, desc(1,iss), lambda(iss)%cvec(1,1), SIZE(lambda(iss)%cvec,1), wr ) - ! - ENDIF - ! - ELSE - ! - !! matrix is not distributed - ! - IF (.not.lambda(1)%iscmplx) THEN - ! - allocate( ap( n * ( n + 1 ) / 2 ) ) - ! - k = 0 - do i = 1, n - do j = i, n - k = k + 1 - ap( k ) = lambda(iss)%rvec( j, i) - enddo - enddo - ! - CALL dspev_drv( 'N', 'L', n, ap, wr, zr, 1 ) - ! - deallocate( ap ) - ! - ELSE - ! - allocate( ap_c( n * ( n + 1 ) / 2 ) ) - ! - k = 0 - do i = 1, n - do j = i, n - k = k + 1 - ap_c( k ) = lambda(iss)%cvec( j, i) - enddo - enddo - ! - CALL zhpev_drv( 'N', 'L', n, ap_c, wr, zr_c, 1 ) - ! - deallocate( ap_c ) - ! - ENDIF - ! - ENDIF - ! - ENDIF - ! - call mp_bcast( wr, root_image, intra_image_comm ) - ! - if ( lf ) then - do i = 1, n - wr(i)=wr(i)/max(f(iupdwn(iss)-1+i),f_cutoff) - end do - endif - ! - ! store eigenvalues - ! - ei( 1:n, iss ) = wr( 1:n ) - ! - IF ( tsic ) THEN - ! - ! store unpaired state - ! - ei( 1:n, 1 ) = ei( 1:n, 1 ) / 2.0d0 - ei( nupdwn(1), 1 ) = 0.0d0 - ! - IF ( la_proc ) THEN - ! - IF ( desc( la_myc_ , iss ) == desc( la_myr_ , iss ) ) THEN - ! - ir = desc( ilar_ , iss ) - nr = desc( nlar_ , iss ) - ! - IF ( nupdwn(1) >= ir .AND. nupdwn(1) < ir + nr ) then - ! - IF (.not.lambda(1)%iscmplx) THEN - ! - ei( nupdwn(1), 1 ) = lambda(1)%rvec( nupdwn(1)-ir+1, nupdwn(1)-ir+1) - ! - ELSE - ! - ei( nupdwn(1), 1 ) = DBLE(lambda(1)%cvec( nupdwn(1)-ir+1, nupdwn(1)-ir+1)) - ! - ENDIF - ! - ENDIF - ! - ENDIF - ! - ENDIF - ! - call mp_sum( ei( nupdwn(1), 1 ), intra_image_comm ) - ! - ENDIF - ! - ! WRITE( stdout,*) '---- DEBUG ----' ! debug - ! WRITE( stdout,14) ( wr( i ) * autoev / 2.0d0, i = 1, nupdwn(iss) ) ! debug - ! - deallocate( wr ) - ! - ELSE - ! - ei( 1:n, iss ) = 0.d0 - ! - ENDIF - ! - ENDDO - ! - DO iss = 1, nspin - ! - IF ( tsic .AND. iss == 2 ) THEN - ! - ei( 1:npaired, 2 ) = ei( 1:npaired, 1 ) - ! - ENDIF - ! - IF ( tprint ) THEN - ! - ! print out eigenvalues - ! - WRITE( stdout,12) 0.d0, 0.d0, 0.d0 - WRITE( stdout,14) ( ei( i, iss ) * autoev, i = 1, nupdwn(iss) ) - ! - ENDIF - ! - ENDDO - ! - IF( tprint ) WRITE( stdout,*) - ! - 12 format(//' eigenvalues at k-point: ',3f6.3) - 14 format(10f8.2) - ! - return - ! - end subroutine eigs0_twin - -!----------------------------------------------------------------------- - subroutine eigs0_twin_non_ortho( ei, tprint, nspin, nupdwn, iupdwn, lf, f, nx, lambda, nudx, desc ) -!----------------------------------------------------------------------- -! computes eigenvalues (wr) of the real symmetric matrix lambda -! Note that lambda as calculated is multiplied by occupation numbers -! so empty states yield zero. Eigenvalues are printed out in eV -! - use kinds, only : DP - use io_global, only : stdout - use constants, only : autoev - use dspev_module, only : dspev_drv, pdspev_drv, dgeev_drv - use zhpev_module, only : zhpev_drv, zgeev_drv - USE sic_module, only : self_interaction - USE cp_main_variables, only : la_proc - USE descriptors, ONLY : nlar_ , nlac_ , ilar_ , ilac_ , lambda_node_ , la_me_ , la_n_ , & - descla_siz_ , la_npr_ , la_npc_ , la_nrl_ , la_nrlx_ , la_comm_ , & - nlax_ , la_myc_ , la_myr_ - USE mp, only : mp_sum, mp_bcast - USE mp_global, only : intra_image_comm, root_image - use nksic, only : f_cutoff - USE twin_types - - implicit none -! input - logical, intent(in) :: tprint, lf - integer, intent(in) :: nspin, nx, nudx, nupdwn(nspin), iupdwn(nspin) - integer, intent(in) :: desc( descla_siz_ , 2 ) - real(DP), intent(in) :: f( nx ) - type(twin_matrix), dimension(nspin), intent(in) :: lambda - real(DP), intent(out) :: ei( nudx, nspin ) -! local variables - real(DP), allocatable :: ap(:,:), wr(:), wi(:) - complex(DP), allocatable :: ap_c(:,:) - real(DP) zr(1,1) - complex(DP) zr_c(1,1) - integer :: iss, j, i, n, nspin_eig, npaired - INTEGER :: ir, nr, np - logical :: tsic - CHARACTER(LEN=80) :: msg - ! - tsic = ( ABS( self_interaction) /= 0 ) - ! - IF ( tsic ) THEN - nspin_eig = 1 - npaired = nupdwn(2) - ELSE - nspin_eig = nspin - npaired = 0 - ENDIF - ! - do iss = 1, nspin_eig - ! - IF( nudx < nupdwn(iss) ) THEN - WRITE( msg, 100 ) nudx, SIZE( ei, 1 ), nupdwn(iss) -100 FORMAT( ' wrong dimension array ei = ', 3I10 ) - CALL errore( ' eigs0 ', msg, 1 ) - END IF - ! - IF( tsic ) THEN - n = npaired - ELSE - n = nupdwn(iss) - END IF - ! - IF (n.gt.0) THEN - ! - allocate( wr( n ), wi( n ) ) - ! - IF ( la_proc ) THEN - ! - np = desc( la_npc_ , iss ) * desc( la_npr_ , iss ) - ! - IF ( np > 1 ) THEN - ! - ! matrix is distributed - ! - IF (.not.lambda(iss)%iscmplx) THEN - ! - write(6,*) "sizlambda", size(lambda(iss)%rvec,1), lambda(iss)%xdim - CALL qe_pdsyevd( .false., n, desc(1,iss), lambda(iss)%rvec(1,1), SIZE(lambda(iss)%rvec,1), wr ) - ! - ELSE - ! - write(6,*) "sizlambda", size(lambda(iss)%cvec,1), lambda(iss)%xdim - CALL qe_pzheevd( .false., n, desc(1,iss), lambda(iss)%cvec(1,1), SIZE(lambda(iss)%cvec,1), wr ) - ! - ENDIF - ! - ELSE - ! - !! matrix is not distributed - ! - IF (.not.lambda(1)%iscmplx) THEN - ! - allocate( ap( n, n ) ) - ! - do i = 1, n - do j = 1, n - ap( j, i ) = lambda(iss)%rvec( j, i) - end do - enddo - ! - CALL dgeev_drv( 'N', 'N', n, ap, n, wr, wi, zr, 1, zr, 1) - ! - deallocate( ap ) - ! - ELSE - ! - allocate( ap_c( n , n )) - do i = 1, n - do j = 1, n - ap_c( j, i ) = lambda(iss)%cvec( j, i) - end do - enddo - ! - CALL zgeev_drv( 'N', 'N', n, ap_c, n, wr, wi, zr_c, 1, zr_c, 1) - ! - deallocate( ap_c ) - ! - ENDIF - ! - ENDIF - ! - ENDIF - ! - call mp_bcast( wr, root_image, intra_image_comm ) - ! - ! - if ( lf ) then - do i = 1, n - wr(i)=wr(i)/max(f(iupdwn(iss)-1+i),f_cutoff) - enddo - endif - ! - ! store eigenvalues - ! - ei( 1:n, iss ) = wr( 1:n ) - ! - IF ( tsic ) THEN - ! - ! store unpaired state - ! - ei( 1:n, 1 ) = ei( 1:n, 1 ) / 2.0d0 - ei( nupdwn(1), 1 ) = 0.0d0 - if ( la_proc ) then - IF ( desc( la_myc_ , iss ) == desc( la_myr_ , iss ) ) THEN - ir = desc( ilar_ , iss ) - nr = desc( nlar_ , iss ) - IF ( nupdwn(1) >= ir .AND. nupdwn(1) < ir + nr ) then - IF (.not.lambda(1)%iscmplx) THEN - ei( nupdwn(1), 1 ) = lambda(1)%rvec( nupdwn(1)-ir+1, nupdwn(1)-ir+1) - ELSE - ei( nupdwn(1), 1 ) = DBLE(lambda(1)%cvec( nupdwn(1)-ir+1, nupdwn(1)-ir+1)) - ENDIF - endif - ENDIF - endif - call mp_sum( ei( nupdwn(1), 1 ), intra_image_comm ) - ! - ENDIF - ! - deallocate( wr ) - deallocate( wi ) - ! - ELSE - ! - ei( 1:n, iss ) = 0.d0 - ! - ENDIF - ! - enddo - ! - do iss = 1, nspin - ! - IF( tsic .AND. iss == 2 ) THEN - ei( 1:npaired, 2 ) = ei( 1:npaired, 1 ) - END IF - ! - IF( tprint ) THEN - ! - ! print out eigenvalues - ! - WRITE( stdout,12) 0.d0, 0.d0, 0.d0 - WRITE( stdout,14) ( ei( i, iss ) * autoev, i = 1, nupdwn(iss) ) - ! - ENDIF - ! - enddo - ! - IF( tprint ) WRITE( stdout,*) - 12 format(//' eigenvalues at k-point: ',3f6.3) - 14 format(10f8.2) - ! - return - ! - end subroutine eigs0_twin_non_ortho - -!----------------------------------------------------------------------- - SUBROUTINE rpackgam_x( gam, f, aux ) -!----------------------------------------------------------------------- - USE kinds, ONLY: DP - USE mp_global, ONLY: me_image, nproc_image, intra_image_comm - USE mp, ONLY: mp_sum - IMPLICIT NONE - REAL(DP), INTENT(INOUT) :: gam(:,:) - REAL(DP), INTENT(OUT), OPTIONAL :: aux(:) - REAL(DP), INTENT(IN) :: f(:) - INTEGER n, nrl, i, j, k, jl - nrl = SIZE(gam, 1) - n = SIZE(gam, 2) - IF( PRESENT( aux ) ) THEN - aux = 0.0d0 - IF( me_image < n ) THEN - DO i = 1, n - j = me_image + 1 - DO jl = 1, nrl - IF( j >= i ) THEN - ! maps (j,i) index to low-tri packed (k) index - k = (i-1)*n + j - i*(i-1)/2 - aux(k) = gam(jl,i) / f(j) - END IF - j = j + nproc_image - END DO - END DO - END IF - CALL mp_sum(aux, intra_image_comm) - ELSE - IF( me_image < n ) THEN - DO i = 1, n - j = me_image + 1 - DO jl = 1, nrl - gam(jl,i) = gam(jl,i) / f(j) - j = j + nproc_image - END DO - END DO - END IF - END IF - RETURN - END SUBROUTINE rpackgam_x - - - -!----------------------------------------------------------------------- - SUBROUTINE fermi_energy_x(eig, occ, wke, ef, qtot, temp, sume) -!----------------------------------------------------------------------- - -! this routine computes Fermi energy and weights of occupied states -! using an improved Gaussian-smearing method -! refs: C.L.Fu and K.M.Ho, Phys.Rev. B28, 5480 (1983) -! M.Methfessel and A.T.Paxton Phys.Rev. B40 (15 aug. 89). -! -! taken from APW code by J. Soler and A. Williams (jk+ss) -! added computation of occupation numbers without k-point weight - - USE kinds, ONLY: DP - USE io_global, ONLY: stdout - USE electrons_base, ONLY: nspin, iupdwn - - IMPLICIT NONE - -! ... declare subroutine arguments - REAL(DP) :: occ(:) - REAL(DP) ef, qtot, temp, sume - REAL(DP) eig(:,:), wke(:,:) - REAL(DP), PARAMETER :: tol = 1.d-10 - INTEGER, PARAMETER :: nitmax = 100 - INTEGER ne, nk - -! ... declare functions - REAL(DP) stepf - -! ... declare other variables - REAL(DP) sumq,emin,emax,fac,t,drange - INTEGER ik,ispin,ie,iter - -! end of declarations -! ---------------------------------------------- - - nk = 1 - ne = SIZE( occ, 1) - sumq=0.d0 - sume=0.d0 - emin=eig(1,1) - emax=eig(1,1) - fac=2.d0 - IF (nspin.EQ.2) fac=1.d0 - - DO ik=1,nk - DO ispin=1,nspin - DO ie=1,ne - wke(ie,ispin) = fac - occ(ie+iupdwn(ispin)-1) = fac - sumq=sumq+wke(ie,ispin) - sume=sume+wke(ie,ispin)*eig(ie,ispin) - emin=MIN(emin,eig(ie,ispin)) - emax=MAX(emax,eig(ie,ispin)) - END DO - END DO - END DO - ef=emax - IF (abs(sumq-qtot).LT.tol) RETURN - IF (sumq.LT.qtot) THEN - WRITE( stdout,*) 'FERMIE: NOT ENOUGH STATES' - WRITE( stdout,*) 'FERMIE: QTOT,SUMQ=',qtot,sumq - STOP - END IF - t = MAX(temp,1.d-6) - drange = t * SQRT( - LOG( tol*.01d0) ) - emin = emin - drange - emax = emax + drange - DO iter = 1, nitmax - ef = 0.5d0 * (emin+emax) - sumq = 0.d0 - sume = 0.d0 - DO ik = 1, nk - DO ispin = 1, nspin - DO ie = 1, ne - wke(ie,ispin) = fac / 2.d0 * stepf((eig(ie,ispin)-ef)/t) - occ(ie+iupdwn(ispin)-1) = fac / 2.d0 * stepf((eig(ie,ispin)-ef)/t) - sumq = sumq + wke(ie,ispin) - sume = sume + wke(ie,ispin) * eig(ie,ispin) - END DO - END DO - END DO - IF (ABS(sumq-qtot).LT.tol) RETURN - IF (sumq.LE.qtot) emin=ef - IF (sumq.GE.qtot) emax=ef - END DO - - WRITE( stdout,*) 'FERMIE: ITERATION HAS NOT CONVERGED.' - WRITE( stdout,*) 'FERMIE: QTOT,SUMQ=',qtot,sumq - STOP - - END SUBROUTINE fermi_energy_x - -! -! -! - -!----------------------------------------------------------------------- - SUBROUTINE cp_eigs_real_x( nfi, lambdap, lambda ) -!----------------------------------------------------------------------- - - use kinds, only: DP - use ensemble_dft, only: tens, tsmear - use electrons_base, only: nx => nbspx, f, nspin - use electrons_base, only: iupdwn, nupdwn, nudx - use electrons_module, only: ei - use cp_main_variables, only: descla - - IMPLICIT NONE - - INTEGER :: nfi - REAL(DP) :: lambda( :, :, : ), lambdap( :, :, : ) - ! - REAL(DP), ALLOCATABLE :: faux(:) - - ALLOCATE( faux(nx) ) - faux(:) = f(:) * DBLE(nspin) / 2.0d0 - - if ( tens ) then - ! - call eigs0( ei, .false. , nspin, nupdwn, iupdwn, .false. , faux, nx, lambdap, nudx, descla ) - ! - else if ( tsmear ) then - ! - call eigs0( ei, .false. , nspin, nupdwn, iupdwn, .false. , faux, nx, lambda, nudx, descla ) - ! - else - ! - call eigs0( ei, .false. , nspin, nupdwn, iupdwn, .true. , faux, nx, lambda, nudx, descla ) - ! - endif - ! - DEALLOCATE( faux ) - ! - RETURN - END SUBROUTINE cp_eigs_real_x - -!----------------------------------------------------------------------- - SUBROUTINE cp_eigs_twin_x( nfi, lambdap, lambda ) -!----------------------------------------------------------------------- - - use kinds, only: DP - use ensemble_dft, only: tens, tsmear - use electrons_base, only: nx => nbspx, f, nspin - use electrons_base, only: iupdwn, nupdwn, nudx - use electrons_module, only: ei - use cp_main_variables, only: descla - use twin_types - - IMPLICIT NONE - - INTEGER :: nfi - type(twin_matrix), dimension(nspin) :: lambda, lambdap - ! - REAL(DP), ALLOCATABLE :: faux(:) - - ALLOCATE( faux(nx) ) - faux(:) = f(:) * DBLE(nspin) / 2.0d0 - - if ( tens ) then - ! - call eigs0_twin( ei, .false. , nspin, nupdwn, iupdwn, .false. , faux, nx, lambdap, nudx, descla ) - ! - else if ( tsmear ) then - ! - call eigs0_twin( ei, .false. , nspin, nupdwn, iupdwn, .false. , faux, nx, lambda, nudx, descla ) - ! - else - ! - call eigs0_twin( ei, .false. , nspin, nupdwn, iupdwn, .true. , faux, nx, lambda, nudx, descla ) - ! - endif - ! - DEALLOCATE( faux ) - ! - RETURN - END SUBROUTINE cp_eigs_twin_x - -!----------------------------------------------------------------------- - SUBROUTINE cp_eigs_twin_non_ortho_x( nfi, lambdap, lambda ) -!----------------------------------------------------------------------- - - use kinds, only: DP - use ensemble_dft, only: tens, tsmear - use electrons_base, only: nx => nbspx, f, nspin - use electrons_base, only: iupdwn, nupdwn, nudx - use electrons_module, only: ei - use cp_main_variables, only: descla - use twin_types - - IMPLICIT NONE - - INTEGER :: nfi - type(twin_matrix), dimension(nspin) :: lambda, lambdap - ! - REAL(DP), ALLOCATABLE :: faux(:) - - ALLOCATE( faux(nx) ) - faux(:) = f(:) * DBLE(nspin) / 2.0d0 - - if ( tens ) then - ! - call eigs0_twin_non_ortho( ei, .false. , nspin, nupdwn, iupdwn, .false. , faux, nx, lambdap, nudx, descla ) - ! - else if ( tsmear ) then - ! - call eigs0_twin_non_ortho( ei, .false. , nspin, nupdwn, iupdwn, .false. , faux, nx, lambda, nudx, descla ) - ! - else - ! - call eigs0_twin_non_ortho( ei, .false. , nspin, nupdwn, iupdwn, .true. , faux, nx, lambda, nudx, descla ) - ! - endif - ! - DEALLOCATE( faux ) - ! - RETURN - END SUBROUTINE cp_eigs_twin_non_ortho_x diff --git a/quantum_espresso/kcp/CPV/electrons.f90 b/quantum_espresso/kcp/CPV/electrons.f90 deleted file mode 100644 index 0e58ab9e6..000000000 --- a/quantum_espresso/kcp/CPV/electrons.f90 +++ /dev/null @@ -1,551 +0,0 @@ -! -! Copyright (C) 2002-2009 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!=----------------------------------------------------------------------------=! -MODULE electrons_module -!=----------------------------------------------------------------------------=! -#include "f_defs.h" - USE kinds - USE dspev_module, ONLY: pdspev_drv, dspev_drv - USE electrons_base, ONLY: nbnd, nbndx, nbsp, nbspx, nspin, nel, nelt, & - nupdwn, iupdwn, telectrons_base_initval, f, & - nudx - USE ensemble_dft, ONLY: fmat0_diag - USE cp_electronic_mass, ONLY: ecutmass => emass_cutoff, emass, emass_precond - use constants, only: e2, fpi, hartree_si, electronvolt_si - - IMPLICIT NONE - SAVE - - PRIVATE - -! ... declare module-scope variables - - LOGICAL :: band_first = .TRUE. - - ! The empty-orbital-equivalents of the variables defined in Modules/electrons_base.f90 - INTEGER :: nupdwn_emp(2) = 0 ! number of empty states with spin up (1) and down (2) - INTEGER :: iupdwn_emp(2) = 0 ! first empty state with spin (1) and down (2). - INTEGER :: nudx_emp = 0 ! max (nupdw_emp(1),nupdw_emp(2)) - INTEGER :: nbsp_emp = 0 ! total number of electronic states = nupdwn_emp(1) + nupdwn_emp(2) - INTEGER :: nbspx_emp = 0 ! array dimension nbspx_emp >= nbsp_emp - ! - INTEGER :: max_emp = 0 ! maximum number of iterations for empty states - REAL(DP) :: ethr_emp, etot_emp, eodd_emp ! threshold for convergence - ! - INTEGER, ALLOCATABLE :: ib_owner(:) - INTEGER, ALLOCATABLE :: ib_local(:) - - REAL(DP), ALLOCATABLE :: ei(:, :) - REAL(DP), ALLOCATABLE :: ei_emp(:, :) - REAL(DP), ALLOCATABLE :: wfc_centers(:, :, :) !added:giovanni wfc_centers - REAL(DP), ALLOCATABLE :: wfc_centers_emp(:, :, :) !added:giovanni wfc_centers_emp - REAL(DP), ALLOCATABLE :: wfc_spreads(:, :, :) !added:giovanni wfc_spreads - REAL(DP), ALLOCATABLE :: wfc_spreads_emp(:, :, :) !added:giovanni wfc_spreads_emp - COMPLEX(DP), ALLOCATABLE :: manifold_overlap(:) !added:giovanni wfc_spreads_emp - INTEGER, ALLOCATABLE :: sort_spreads(:, :) !added:giovanni wfc_spreads_emp - INTEGER, ALLOCATABLE :: sort_spreads_emp(:, :) !added:giovanni wfc_spreads_emp - - LOGICAL :: icompute_spread = .true. !added:giovanni - -! Fourier acceleration - - LOGICAL :: toccrd = .FALSE. ! read occupation number from standard input - - PUBLIC :: electrons_empty_initval - PUBLIC :: bmeshset, occn_info - PUBLIC :: deallocate_electrons - PUBLIC :: ei_emp, ib_owner, ib_local - PUBLIC :: ei, nupdwn_emp, iupdwn_emp, nudx_emp, nbsp_emp, nbspx_emp - PUBLIC :: print_eigenvalues, print_centers_spreads - PUBLIC :: max_emp, ethr_emp - PUBLIC :: empty_print_info, empty_init - PUBLIC :: sort_spreads, sort_spreads_emp, wfc_centers, wfc_spreads, icompute_spread !added:giovanni - PUBLIC :: wfc_centers_emp, wfc_spreads_emp !added:giovanni - PUBLIC :: manifold_overlap !added:giovanni - PUBLIC :: etot_emp, eodd_emp !added:giovanni - -! -! end of module-scope declarations -! -!=----------------------------------------------------------------------------=! -CONTAINS -!=----------------------------------------------------------------------------=! - - SUBROUTINE occn_info(occ) - ! - ! This subroutine prints occupation numbers to stdout - ! - USE io_global, ONLY: stdout, ionode - ! - REAL(DP) :: occ(:) - INTEGER :: i, iss - ! - IF (ionode) THEN - WRITE (stdout, fmt="(3X,'Occupation number from init')") - IF (nspin == 1) THEN - WRITE (stdout, fmt=" (3X, 'nbnd = ', I5 ) ") nbnd - WRITE (stdout, fmt=" (3X,10F5.2)") (occ(i), i=1, nbnd) - ELSE - DO iss = 1, nspin - WRITE (stdout, fmt=" (3X,'spin = ', I3, ' nbnd = ', I5 ) ") iss, nupdwn(iss) - WRITE (stdout, fmt=" (3X,10F5.2)") (occ(i + iupdwn(iss) - 1), i=1, nupdwn(iss)) - END DO - END IF - END IF - ! - RETURN - END SUBROUTINE occn_info - -! ---------------------------------------------- -! ---------------------------------------------- - - SUBROUTINE bmeshset - - ! This subroutine initialize the variables for the - ! distribution across processors of the overlap matrixes - ! of sizes ( nx, nx ) - - USE mp_global, ONLY: me_image, nproc_image - - IMPLICIT NONE - - INTEGER :: i, ierr - - IF (band_first) THEN - CALL errore(' bmeshset ', ' module not initialized ', 0) - END IF - - IF (ALLOCATED(ib_owner)) DEALLOCATE (ib_owner) - ALLOCATE (ib_owner(MAX(nudx_emp, nbndx)), STAT=ierr) - IF (ierr /= 0) CALL errore(' bmeshset ', ' allocating ib_owner ', ierr) - IF (ALLOCATED(ib_local)) DEALLOCATE (ib_local) - ALLOCATE (ib_local(MAX(nudx_emp, nbndx)), STAT=ierr) - IF (ierr /= 0) CALL errore(' bmeshset ', ' allocating ib_local ', ierr) - - ! here define the association between processors and electronic states - ! round robin distribution is used - - ib_local = 0 - ib_owner = -1 - DO i = 1, MAX(nudx_emp, nbndx) - ib_local(i) = (i - 1)/nproc_image ! local index of the i-th band - ib_owner(i) = MOD((i - 1), nproc_image) ! owner of th i-th band - IF (me_image <= ib_owner(i)) THEN - ib_local(i) = ib_local(i) + 1 - END IF - END DO - - RETURN - END SUBROUTINE bmeshset - -! ---------------------------------------------- -! -! -! -! ---------------------------------------------- - - SUBROUTINE electrons_empty_initval(include_empty, emass_inp, ecutmass_inp) - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: include_empty - REAL(DP), INTENT(IN) :: emass_inp, ecutmass_inp - INTEGER :: ierr, i, j - - IF (.NOT. telectrons_base_initval) & - CALL errore(' electrons_empty_initval ', ' electrons_base not initialized ', 1) - - IF (include_empty) THEN - ! - IF (nspin == 2) THEN - nudx_emp = nbnd - minval(nupdwn) - ELSE - nudx_emp = nbnd - nupdwn(1) - END IF - ! - nupdwn_emp(1) = nbnd - nupdwn(1) - IF (nupdwn_emp(1) == 0) THEN - iupdwn_emp(1) = 0 - ELSE - iupdwn_emp(1) = 1 - END IF - - IF (nupdwn_emp(1) < 0) CALL errore(' electrons ', ' cannot have a negative number of empty bands') - - IF (nspin == 2) THEN - nupdwn_emp(2) = nbnd - nupdwn(2) - iupdwn_emp(2) = nupdwn_emp(1) + 1 - IF (nupdwn_emp(2) < 0) CALL errore(' electrons ', ' cannot have a negative number of empty bands') - END IF - ! - ELSE - ! nbnd was not expliclty provided, so we shouldn't perform an empty states calculation - nupdwn_emp(1) = 0 - nupdwn_emp(2) = 0 - nudx_emp = 0 - END IF - - nbsp_emp = sum(nupdwn_emp) - nbspx_emp = nbsp_emp + mod(nbsp_emp, 2) - - IF (ALLOCATED(ei)) DEALLOCATE (ei) - ALLOCATE (ei(nudx, nspin), STAT=ierr) - IF (ierr /= 0) CALL errore(' electrons ', ' allocating ei ', ierr) - ei = 0.0_DP - - IF (ALLOCATED(ei_emp)) DEALLOCATE (ei_emp) - IF (nudx_emp > 0) THEN - ALLOCATE (ei_emp(nudx_emp, nspin), STAT=ierr) - IF (ierr /= 0) CALL errore(' electrons ', ' allocating ei_emp ', ierr) - ei_emp = 0.0_DP - END IF - -!begin_added:giovanni - IF (ALLOCATED(sort_spreads)) DEALLOCATE (sort_spreads) - IF (nudx > 0) THEN - ALLOCATE (sort_spreads(nudx, nspin), STAT=ierr) - IF (ierr /= 0) CALL errore(' electrons ', ' allocating sort_spreads ', ierr) - do j = 1, nspin - do i = 1, size(sort_spreads(:, j)) - sort_spreads(i, j) = i - end do - end do - END IF - - IF (ALLOCATED(sort_spreads_emp)) DEALLOCATE (sort_spreads_emp) - IF (nudx_emp > 0) THEN - ALLOCATE (sort_spreads_emp(nudx_emp, nspin), STAT=ierr) - IF (ierr /= 0) CALL errore(' electrons ', ' allocating sort_spreads_emp ', ierr) - do j = 1, nspin - do i = 1, size(sort_spreads_emp(:, j)) - sort_spreads_emp(i, j) = i - end do - end do - END IF - - IF (ALLOCATED(wfc_centers)) DEALLOCATE (wfc_centers) - IF (nudx > 0) THEN - ALLOCATE (wfc_centers(4, nudx, nspin), STAT=ierr) - IF (ierr /= 0) CALL errore(' electrons ', ' allocating wfc_centers ', ierr) - wfc_centers = 0.0_DP - END IF - - IF (ALLOCATED(wfc_spreads)) DEALLOCATE (wfc_spreads) - IF (nudx > 0) THEN - ALLOCATE (wfc_spreads(nudx, nspin, 2), STAT=ierr) - IF (ierr /= 0) CALL errore(' electrons ', ' allocating wfc_spreads ', ierr) - wfc_spreads = 0.0_DP - END IF - - IF (ALLOCATED(manifold_overlap)) DEALLOCATE (manifold_overlap) - IF (nspin > 0) THEN - ALLOCATE (manifold_overlap(nspin), STAT=ierr) - IF (ierr /= 0) CALL errore(' electrons ', ' allocating manifold_overlap ', ierr) - manifold_overlap = 0.0_DP - END IF - -!end_added:giovanni - -!begin_added:giovanni - IF (ALLOCATED(wfc_centers_emp)) DEALLOCATE (wfc_centers_emp) - IF (nudx_emp > 0) THEN - ALLOCATE (wfc_centers_emp(4, nudx_emp, nspin), STAT=ierr) - IF (ierr /= 0) CALL errore(' electrons ', ' allocating wfc_centers_emp ', ierr) - wfc_centers_emp = 0.0_DP - END IF - - IF (ALLOCATED(wfc_spreads_emp)) DEALLOCATE (wfc_spreads_emp) - IF (nudx_emp > 0) THEN - ALLOCATE (wfc_spreads_emp(nudx_emp, nspin, 2), STAT=ierr) - IF (ierr /= 0) CALL errore(' electrons ', ' allocating wfc_spreads_emp ', ierr) - wfc_spreads_emp = 0.0_DP - END IF -!end_added:giovanni - - ecutmass = ecutmass_inp - emass = emass_inp - IF (ecutmass < 0.0_DP) & - CALL errore(' electrons ', ' ecutmass out of range ', 0) - - band_first = .FALSE. - - RETURN - END SUBROUTINE electrons_empty_initval - -!---------------------------------------------------------------------- - - SUBROUTINE empty_print_info(iunit) - ! - USE kinds, ONLY: DP - INTEGER, INTENT(IN) :: iunit - ! - IF (nbsp_emp > 0) THEN - WRITE (iunit, "(//, 3X, 'Empty states minimization')") - WRITE (iunit, "( 3X, '--------------------------')") - WRITE (iunit, "(3X, ' states = ',i8)") nbsp_emp - WRITE (iunit, "(3X, ' maxiter = ',i8)") max_emp - WRITE (iunit, "(3X, ' ethr = ',D12.4)") ethr_emp - END IF - ! - RETURN - END SUBROUTINE empty_print_info - -!---------------------------------------------------------------------- - - SUBROUTINE empty_init(max_emp_, ethr_emp_) - - USE kinds, ONLY: DP - - INTEGER, INTENT(IN) :: max_emp_ - REAL(DP), INTENT(IN) :: ethr_emp_ - - max_emp = max_emp_ - ethr_emp = ethr_emp_ - ! - RETURN - END SUBROUTINE empty_init - -! ---------------------------------------------- - - SUBROUTINE print_eigenvalues(ei_unit, tfile, tstdout, nfi, tps) - ! - use constants, only: autoev - USE io_global, ONLY: stdout - USE ensemble_dft, ONLY: tens, tsmear - ! - INTEGER, INTENT(IN) :: ei_unit - LOGICAL, INTENT(IN) :: tfile, tstdout - INTEGER, INTENT(IN) :: nfi - REAL(DP), INTENT(IN) :: tps - ! - INTEGER :: i, j, ik - REAL(DP) :: e_homo, e_lumo - ! - IF (tfile) THEN - WRITE (ei_unit, 30) nfi, tps - END IF - ! - ik = 1 - ! - IF (tstdout) THEN - IF (nspin == 1) THEN - e_homo = MAXVAL(ei(1:nupdwn(1), 1)*autoev, nupdwn(1)) - ELSE - e_homo = MAX(MAXVAL(ei(1:nupdwn(1), 1)*autoev, nupdwn(1)), MAXVAL(ei(1:nupdwn(2), 2)*autoev, nupdwn(2))) - END IF - WRITE (stdout, 1101) - WRITE (stdout, 1444) e_homo - - IF (nbsp_emp .gt. 0) THEN - IF (nspin == 1) THEN - e_lumo = MINVAL(ei_emp(1:nupdwn_emp(1), 1)*autoev, nupdwn_emp(1)) - ELSE - e_lumo = MIN(MINVAL(ei_emp(1:nupdwn_emp(1), 1)*autoev, nupdwn_emp(1)), & - MINVAL(ei_emp(1:nupdwn_emp(2), 2)*autoev, nupdwn_emp(2))) - END IF - WRITE (stdout, 1201) - WRITE (stdout, 1444) e_lumo - - IF (tstdout) WRITE (stdout, 1006) e_lumo - e_homo - IF (tfile) WRITE (ei_unit, 1021) e_lumo - e_homo - END IF - END IF - - DO j = 1, nspin - ! - IF (tstdout) THEN - - IF (nupdwn(j) > 0) THEN - WRITE (stdout, 1002) ik, j - WRITE (stdout, 1004) (ei(i, j)*autoev, i=1, nupdwn(j)) - ! - IF (tens .OR. tsmear) THEN - WRITE (stdout, 1082) ik, j - WRITE (stdout, 1084) (f(i), i=iupdwn(j), iupdwn(j) + nupdwn(j) - 1) - ! - WRITE (stdout, 1092) ik, j - WRITE (stdout, 1084) (fmat0_diag(i), i=iupdwn(j), iupdwn(j) + nupdwn(j) - 1) - END IF - END IF - ! - IF (nupdwn_emp(j) > 0) THEN - WRITE (stdout, 1005) ik, j - WRITE (stdout, 1004) (ei_emp(i, j)*autoev, i=1, nupdwn_emp(j)) - END IF - END IF - ! - IF (tfile) THEN - IF (nupdwn(j) > 0) THEN - WRITE (ei_unit, 1010) ik, j - WRITE (ei_unit, 1020) (ei(i, j)*autoev, i=1, nupdwn(j)) - END IF - IF (nupdwn_emp(j) > 0) THEN - WRITE (ei_unit, 1011) ik, j - WRITE (ei_unit, 1020) (ei_emp(i, j)*autoev, i=1, nupdwn_emp(j)) - END IF - END IF - ! - END DO - ! -30 FORMAT(2X, 'STEP:', I7, 1X, F10.2) -1002 FORMAT(/, 3X, 'Eigenvalues (eV), kp = ', I3, ' , spin = ', I2,/) -1101 FORMAT(/, 3X, 'HOMO Eigenvalue (eV)',/) !added_giovanni -1022 FORMAT(/, 3X, 'Centers (Bohr), kp = ', I3, ' , spin = ', I2,/) !added_giovanni -1222 FORMAT(/, 3X, 'Spreads (Bohr^2), kp = ', I3, ' , spin = ', I2,/) !added_giovanni -1082 FORMAT(/, 3X, 'Occupations, kp = ', I3, ' , spin = ', I2,/) -1092 FORMAT(/, 3X, 'DensityMat diag, kp = ', I3, ' , spin = ', I2,/) -1005 FORMAT(/, 3X, 'Empty States Eigenvalues (eV), kp = ', I3, ' , spin = ', I2,/) -1201 FORMAT(/, 3X, 'LUMO Eigenvalue (eV)',/) !added_giovanni -1004 FORMAT(10F10.4) -1044 FORMAT(4F8.2) -1444 FORMAT(1F10.4) -1084 FORMAT(10F8.4) -1006 FORMAT(/, 3X, 'Electronic Gap (eV) = ', F10.4,/) -1010 FORMAT(3X, 'Eigenvalues (eV), kp = ', I3, ' , spin = ', I2) -1011 FORMAT(3X, 'Empty States Eigenvalues (eV), kp = ', I3, ' , spin = ', I2) -1020 FORMAT(10F8.2) -1021 FORMAT(3X, 'Electronic Gap (eV) = ', F8.2) -1030 FORMAT(3X, 'nfill = ', I4, ', nempt = ', I4, ', kp = ', I3, ', spin = ', I2) - ! - RETURN - END SUBROUTINE print_eigenvalues - - SUBROUTINE print_centers_spreads(spread_unit, tfile, tstdout, nfi, tps) - ! - use constants, only: autoev - USE io_global, ONLY: stdout - use nksic, ONLY: complexification_index, pink, pink_emp, do_orbdep, & - pzalpha => odd_alpha, pzalpha_emp => odd_alpha_emp, & - l_comp_cmplxfctn_index - ! - INTEGER, INTENT(IN) :: spread_unit - LOGICAL, INTENT(IN) :: tfile, tstdout - INTEGER, INTENT(IN) :: nfi - REAL(DP), INTENT(IN) :: tps - ! - INTEGER :: i, j, ik - ! - ! - ik = 1 - ! - DO j = 1, nspin - ! - IF (tstdout) THEN - - IF (nupdwn(j) > 0) THEN - - WRITE (stdout, 1222) ik, j - ! - IF (do_orbdep) THEN - WRITE (stdout, 1444) (i, wfc_centers(1:4, i, j), wfc_spreads(i, j, 1), wfc_spreads(i, j, 2), & - pink(iupdwn(j) - 1 + sort_spreads(i, j))*hartree_si/electronvolt_si, & - pzalpha(iupdwn(j) - 1 + sort_spreads(i, j)), i=1, nupdwn(j)) - ELSE - WRITE (stdout, 1445) (i, wfc_centers(1:4, i, j), wfc_spreads(i, j, 1), wfc_spreads(i, j, 2), i=1, nupdwn(j)) - END IF - END IF - ! - IF (nupdwn_emp(j) > 0) THEN - WRITE (stdout, 1333) ik, j - ! - IF (do_orbdep) THEN - WRITE (stdout, 1446) (i, wfc_centers_emp(1:4, i, j), wfc_spreads_emp(i, j, 1), wfc_spreads_emp(i, j, 2), & - pink_emp(iupdwn_emp(j) - 1 + sort_spreads_emp(i, j))*hartree_si/electronvolt_si, & - pzalpha_emp(iupdwn_emp(j) - 1 + sort_spreads_emp(i, j)), i=1, nupdwn_emp(j)) - ELSE - WRITE (stdout, 1447) (i, wfc_centers_emp(1:4, i, j), wfc_spreads_emp(i, j, 1), wfc_spreads_emp(i, j, 2), & - i=1, nupdwn_emp(j)) - END IF - ! - END IF - ! - END IF - ! - ! - END DO - ! - IF (tstdout .AND. l_comp_cmplxfctn_index) THEN - ! - WRITE (stdout, '(/, " Complexification index ")') - WRITE (stdout, *) complexification_index - ! - END IF - ! -30 FORMAT(2X, 'STEP:', I7, 1X, F10.2) -1022 FORMAT(/, 3X, 'Centers (Bohr), kp = ', I3, ' , spin = ', I2,/) -1222 FORMAT(/, 3X, 'Orb -- Charge --- Centers xyz (Bohr) --- Spreads (Bohr^2) - SH(eV), kp = ', I3, ' , spin = ', I2,/) -1333 FORMAT(/, 3X, 'Orb -- Empty Charge --- Centers xyz (Bohr) --- Spreads (Bohr^2) - SH(eV), kp = ', I3, ' , spin = ', I2,/) -1005 FORMAT(/, 3X, 'Empty States Eigenvalues (eV), kp = ', I3, ' , spin = ', I2,/) -1444 FORMAT('OCC', I5, ' --', F8.2, ' ---', 3F8.2, ' ---', 4F8.3) -1446 FORMAT('EMP', I5, ' --', F8.2, ' ---', 3F8.2, ' ---', 4F8.3) -1447 FORMAT('EMP', I5, ' --', F8.2, ' ---', 3F8.2, ' ---', 2F8.3) -1445 FORMAT('OCC', I5, ' --', F8.2, ' ---', 3F8.2, ' ---', 2F8.2) -1121 FORMAT(/3X, 'Manifold complexification index = ', 2F8.4/) -1084 FORMAT(10F8.4) - ! - RETURN - END SUBROUTINE print_centers_spreads - -! ---------------------------------------------- - - SUBROUTINE deallocate_electrons - INTEGER :: ierr - IF (ALLOCATED(ei)) THEN - DEALLOCATE (ei, STAT=ierr) - IF (ierr /= 0) CALL errore(' deallocate_electrons ', ' deallocating ei ', ierr) - END IF - IF (ALLOCATED(ei_emp)) THEN - DEALLOCATE (ei_emp, STAT=ierr) - IF (ierr /= 0) CALL errore(' deallocate_electrons ', ' deallocating ei_emp ', ierr) - END IF - IF (ALLOCATED(ib_owner)) THEN - DEALLOCATE (ib_owner, STAT=ierr) - IF (ierr /= 0) CALL errore(' deallocate_electrons ', ' deallocating ib_owner ', ierr) - END IF - IF (ALLOCATED(ib_local)) THEN - DEALLOCATE (ib_local, STAT=ierr) - IF (ierr /= 0) CALL errore(' deallocate_electrons ', ' deallocating ib_local ', ierr) - END IF - IF (ALLOCATED(sort_spreads)) THEN - DEALLOCATE (sort_spreads, STAT=ierr) - IF (ierr /= 0) CALL errore(' deallocate_electrons ', ' deallocating sort_spreads ', ierr) - END IF - IF (ALLOCATED(sort_spreads_emp)) THEN - DEALLOCATE (sort_spreads_emp, STAT=ierr) - IF (ierr /= 0) CALL errore(' deallocate_electrons ', ' deallocating sort_spreads ', ierr) - END IF - IF (ALLOCATED(wfc_centers)) THEN - DEALLOCATE (wfc_centers, STAT=ierr) - IF (ierr /= 0) CALL errore(' deallocate_electrons ', ' deallocating wfc_centers ', ierr) - END IF - IF (ALLOCATED(wfc_spreads)) THEN - DEALLOCATE (wfc_spreads, STAT=ierr) - IF (ierr /= 0) CALL errore(' deallocate_electrons ', ' deallocating wfc_spreads ', ierr) - END IF - IF (ALLOCATED(manifold_overlap)) THEN - DEALLOCATE (manifold_overlap, STAT=ierr) - IF (ierr /= 0) CALL errore(' deallocate_electrons ', ' deallocating manifold_overlap ', ierr) - END IF -! write(6,*) "deallocating empty", ubound(wfc_centers_emp), ubound(wfc_spreads_emp) - IF (ALLOCATED(wfc_centers_emp)) THEN -! write(6,*) "deallocating wfc_centers_emp" - DEALLOCATE (wfc_centers_emp, STAT=ierr) -! write(6,*) "deallocated wfc_centers_emp" - IF (ierr /= 0) CALL errore(' deallocate_electrons ', ' deallocating wfc_centers_emp ', ierr) - END IF - IF (ALLOCATED(wfc_spreads_emp)) THEN - DEALLOCATE (wfc_spreads_emp, STAT=ierr) - IF (ierr /= 0) CALL errore(' deallocate_electrons ', ' deallocating wfc_spreads_emp ', ierr) - END IF -! write(6,*) "deallocated empty" - - RETURN - END SUBROUTINE deallocate_electrons - -!=----------------------------------------------------------------------------=! -END MODULE electrons_module -!=----------------------------------------------------------------------------=! diff --git a/quantum_espresso/kcp/CPV/empty_koopmans_pp.f90 b/quantum_espresso/kcp/CPV/empty_koopmans_pp.f90 deleted file mode 100644 index e5937422d..000000000 --- a/quantum_espresso/kcp/CPV/empty_koopmans_pp.f90 +++ /dev/null @@ -1,397 +0,0 @@ - -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!----------------------------------------------------------------------- -SUBROUTINE empty_koopmans_pp (n_emps_evc, ispin_evc, evc) -!----------------------------------------------------------------------- - ! - ! Performs the minimization on the empty state subspace keeping the - ! occupied manyfold fixed. A proper orthogonalization of the two - ! manyfolds is performed. - ! - USE kinds, ONLY : DP - USE constants, ONLY : autoev - USE control_flags, ONLY : gamma_only, do_wf_cmplx, & - ndr, ndw - USE io_global, ONLY : ionode, stdout - USE cp_main_variables, ONLY : eigr, rhor - USE core, ONLY : rhoc - USE electrons_base, ONLY : nspin, nbspx - USE uspp, ONLY : nkb - USE uspp_param, ONLY : nhm - USE ions_base, ONLY : nat, nsp - USE grid_dimensions, ONLY : nnrx - USE gvecw, ONLY : ngw - USE reciprocal_vectors, ONLY : ng0 => gstart - USE cp_interfaces, ONLY : readempty_twin, writeempty_twin, nlsm1, readempty - USE mp, ONLY : mp_comm_split, mp_comm_free, mp_sum - USE mp_global, ONLY : intra_image_comm - USE nksic, ONLY : do_pz, do_wxd, vsicpsi, wtot, sizwtot, & - odd_alpha, valpsi, nkscalfact, odd_alpha_emp - USE nksic, ONLY : allocate_nksic_empty - USE input_parameters, ONLY : odd_nkscalfact_empty, odd_nkscalfact, aux_empty_nbnd - USE electrons_module, ONLY : ei_emp - USE twin_types - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: n_emps_evc - INTEGER, INTENT(IN) :: ispin_evc(n_emps_evc) - COMPLEX(DP), INTENT (INOUT) :: evc(ngw, n_emps_evc) - ! - INTEGER :: i, m, ig, iss - ! - INTEGER :: n_emp ! number of empty states from input - LOGICAL :: exst - ! - INTEGER :: n_emps, n_empx, nudx_emp - INTEGER :: nupdwn_emp(nspin) - INTEGER :: iupdwn_emp(nspin) - ! - COMPLEX(DP), ALLOCATABLE :: c2(:), c3(:) - COMPLEX(DP), ALLOCATABLE :: c0_emp(:,:), gi(:,:) - REAL(DP), ALLOCATABLE :: becsum_emp(:,:,:) - ! - INTEGER, ALLOCATABLE :: ispin_emp(:) - REAL(DP), ALLOCATABLE :: fsic_emp(:) - REAL(DP), ALLOCATABLE :: vsic_emp(:,:) - REAL(DP), ALLOCATABLE :: wxd_emp(:,:) - REAL(DP), ALLOCATABLE :: deeq_sic_emp(:,:,:,:) - REAL(DP), ALLOCATABLE :: wfc_centers_emp(:,:,:) - REAL(DP), ALLOCATABLE :: wfc_spreads_emp(:,:,:) - REAL(DP), ALLOCATABLE :: old_odd_alpha(:) - LOGICAL :: icompute_spread - ! - LOGICAL :: lgam !added:giovanni - INTEGER :: ndr_loc, ndw_loc - COMPLEX(DP), PARAMETER :: c_zero=CMPLX(0.d0,0.d0) - COMPLEX(DP) :: delta_eig(n_emps_evc), scar1, scar2 - TYPE(twin_matrix) :: bec_emp - REAL(dp), allocatable :: pink_emp(:) - ! - LOGICAL :: odd_nkscalfact_old - ! - IF (aux_empty_nbnd == 0) THEN - ! - WRITE( stdout, "(/,3X,' aux_empty_nbnd == 0, no ODD correction ' )") - RETURN - ! - ENDIF - ! - lgam = gamma_only.and..not.do_wf_cmplx - ! - odd_nkscalfact_old = odd_nkscalfact - ! - ! restart directories - ! - ndr_loc = ndr - ndw_loc = ndw - ! - ! Setting number electrons - ! - n_emp = aux_empty_nbnd - ! - nupdwn_emp(1) = n_emp - iupdwn_emp(1) = 1 - IF ( nspin == 2 ) THEN - nupdwn_emp(2) = n_emp - iupdwn_emp(2) = 1 + n_emp - ! - ENDIF - ! - n_emps = nupdwn_emp( 1 ) - IF( nspin == 2 ) n_emps = n_emps + nupdwn_emp( 2 ) - ! - nudx_emp = nupdwn_emp( 1 ) - IF( nspin == 2 ) nudx_emp = MAX( nudx_emp, nupdwn_emp( 2 ) ) - ! - n_empx = nupdwn_emp( 1 ) - IF( nspin == 2 ) n_empx = n_empx + nupdwn_emp( 2 ) - n_empx = n_empx + MOD( n_empx, 2) - ! - ALLOCATE( c0_emp( ngw, n_empx ) ) - ALLOCATE( ispin_emp( n_empx ) ) - ! - call init_twin(bec_emp, lgam) - call allocate_twin(bec_emp, nkb, n_emps, lgam) - call set_twin(bec_emp, c_zero) - ! - ispin_emp (:) = 0 - ispin_emp ( 1:nupdwn_emp( 1 ) ) = 1 - IF ( nspin == 2 ) ispin_emp( iupdwn_emp(2) : ) = 2 - ! - ALLOCATE( fsic_emp( n_empx ) ) - ALLOCATE( vsic_emp(nnrx, n_empx) ) - ALLOCATE( wxd_emp (nnrx, 2) ) - ALLOCATE( deeq_sic_emp (nhm,nhm,nat,n_empx)) - ALLOCATE( becsum_emp (nhm*(nhm+1)/2,nat,nspin)) - ALLOCATE( wfc_centers_emp(4, nudx_emp, nspin )) - ALLOCATE( wfc_spreads_emp(nudx_emp, nspin, 2 )) - ALLOCATE( pink_emp(n_emps)) - ! - CALL allocate_nksic_empty(n_empx) - ! - fsic_emp = 0.0d0 - vsic_emp = 0.0d0 - wxd_emp = 0.0d0 - ! - ! read auxilary orbitals - ! - exst = readempty_twin( c0_emp, n_empx, ndr_loc ) - ! - IF ( .NOT. exst ) THEN - ! - CALL errore( 'empty_koopmans_pp', 'there is no auxilary orbital', 1 ) - ! - ENDIF - ! - CALL nlsm1 ( n_emps, 1, nsp, eigr, c0_emp, bec_emp, 1, lgam ) - ! - IF ( ionode ) THEN - ! - WRITE( stdout, "(/,3X,'Compute empty ODD correction for KS eigenvalues ' )") - ! - ENDIF - ! - ! init xd potential - ! - ! we need to use wtot from previous calls with occupied states - ! we save here wtot in wxd_emp - ! - wxd_emp(:,:) = 0.0_DP - ! - IF ( do_wxd .AND. .NOT. do_pz ) THEN - ! - wxd_emp(:,:) = wtot(:,:) - ! - ENDIF - ! - IF (odd_nkscalfact_empty) THEN - ! - allocate(old_odd_alpha (nbspx)) - old_odd_alpha(:) = odd_alpha(:) - ! here, deallocate the memory of odd_alpha for occupied states - if(allocated(odd_alpha)) deallocate(odd_alpha) - if(allocated(valpsi)) deallocate(valpsi) - ! - ! reallocate the memory of odd_alpha for empty states - allocate (odd_alpha(n_emps)) - allocate (valpsi(n_emps, ngw)) - ! - ENDIF - ! - IF (odd_nkscalfact_empty) THEN - ! - valpsi(:,:) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - CALL odd_alpha_routine(c0_emp, n_emps, n_empx, lgam, .true.) - ! - odd_nkscalfact = .true. - ! - ELSE - ! - ! here, we want to use only one value alpha for all empty states, - ! that value alpha is defined from in input file. - ! This require to deactive here the odd_nkscalfact so that - ! it does not do odd_alpha in nksic_potential. - ! - odd_nkscalfact = .false. - ! - ENDIF - ! - ! In the nksic case, we do not need to compute wxd here, - ! because no contribution comes from empty states. - ! - ! Instead, wxd from all occupied states is already computed - ! by the previous calls to nksic_potentials, and stored wxe_emp - ! - fsic_emp(:) = 0.0 - ! - icompute_spread=.true. - ! - CALL nksic_potential( n_emps, n_empx, c0_emp, fsic_emp, & - bec_emp, becsum_emp, deeq_sic_emp, & - ispin_emp, iupdwn_emp, nupdwn_emp, rhor, rhoc, & - wtot, sizwtot, vsic_emp, .false., pink_emp, nudx_emp, & - wfc_centers_emp, wfc_spreads_emp, & - icompute_spread, .true.) - ! - ! Print spreads infor - ! - WRITE( stdout, *) "sum spreads:1", sum(wfc_spreads_emp(1:nupdwn_emp(1), 1, 1)), & - sum(wfc_spreads_emp(1:nupdwn_emp(2), 2, 1)) - WRITE( stdout, *) "sum spreads:2", sum(wfc_spreads_emp(1:nupdwn_emp(1), 1, 2)), & - sum(wfc_spreads_emp(1:nupdwn_emp(2), 2, 2)) - - write(stdout, *) "Localization of orbitals from PZS localization" - do i = 1, nupdwn_emp(2) - write(stdout, *) i, wfc_spreads_emp(i, 2, 2), pink_emp (nupdwn_emp(1)+i) - enddo - ! - DO i = 1, n_emps - ! - ! Here wxd_emp <-> wtot that computed from nksic_potential of occupied states. - ! wtot is scaled with nkscalfact constant, we thus need to rescaled it here with - ! odd_alpha - ! - IF(odd_nkscalfact_empty) wxd_emp(:, ispin_emp(i)) = wxd_emp(:, ispin_emp(i))*odd_alpha(i)/nkscalfact - ! - vsic_emp(:,i) = vsic_emp(:,i) + wxd_emp(:, ispin_emp(i)) - ! - ENDDO - ! - ! Compute hpsi terms - ! - allocate( c2(ngw), c3(ngw), gi(ngw, n_emps) ) - gi(:,:) = cmplx(0.0d0, 0.0d0) - ! - DO i = 1, n_emps, 2 - ! - c2(:) = cmplx(0.0d0, 0.0d0) - c3(:) = cmplx(0.0d0, 0.0d0) - ! - IF ( odd_nkscalfact_empty ) THEN - ! - c2(:) = c2(:) + valpsi(i, :) - c3(:) = c3(:) + valpsi(i+1, :) - ! - ENDIF - ! - CALL nksic_eforce( i, n_emps, n_empx, vsic_emp, deeq_sic_emp, bec_emp, ngw, & - c0_emp(:,i), c0_emp(:,i+1), vsicpsi, lgam ) - ! - c2(:) = c2(:) + vsicpsi(:,1) - c3(:) = c3(:) + vsicpsi(:,2) - ! - gi(:, i) = c2(:) - ! - IF (i+1 <= n_emps) gi(:, i+1) = c3(:) - ! - IF (lgam .and. ng0.eq.2) THEN - ! - gi(1, i) = CMPLX(DBLE(gi(1, i)),0.d0) - ! - IF (i+1 <= n_emps) gi(1, i+1) = CMPLX(DBLE(gi(1, i+1)),0.d0) - ! - ENDIF - ! - ENDDO - ! - ! compute delta_eig(m) \sum_i - ! - delta_eig(:) = cmplx(0.0d0, 0.0d0) - DO m = 1, n_emps_evc - ! - DO i = 1, n_emps - ! - scar1 = cmplx(0.0d0, 0.0d0) - scar2 = cmplx(0.0d0, 0.0d0) - ! - IF (ispin_emp(i) == ispin_evc(m)) THEN - ! - IF (lgam) THEN - ! - DO ig = 1, ngw - ! - scar1 = scar1 + cmplx(dble(conjg(evc(ig, m)) * gi(ig, i)),0.0d0) - scar2 = scar2 + cmplx(dble(conjg(c0_emp(ig, i)) * evc(ig, m)), 0.0d0) - ! - ENDDO - ! - scar1 = 2.d0*scar1 - scar2 = 2.d0*scar2 - ! - IF (ng0.eq.2) THEN - ! - scar1 = cmplx(dble(scar1), 0.0d0) & - - cmplx(dble(conjg(evc(1, m)) * gi(1, i)), 0.0d0) - ! - scar2 = cmplx(dble(scar2), 0.0d0) & - - cmplx(dble(conjg(c0_emp(1, i)) * evc(1, m)), 0.0d0) - ! - ELSE - ! - scar1 = cmplx(dble(scar1), 0.0d0) - scar2 = cmplx(dble(scar2), 0.0d0) - ! - ENDIF - ! - ELSE - ! - DO ig = 1, ngw - ! - scar1 = scar1 + conjg(evc(ig, m)) * gi(ig, i) - scar2 = scar2 + conjg(c0_emp(ig, i)) * evc(ig, m) - ! - ENDDO - ! - ENDIF - ! - CALL mp_sum( scar1, intra_image_comm ) - CALL mp_sum( scar2, intra_image_comm ) - ! - delta_eig(m) = delta_eig(m) + scar1 * scar2 - ! - ENDIF - ! -if (m==1) then -write(stdout, *) 'Linh test Amn:', i, scar1, scar2 -endif - ! - ENDDO - ! - ENDDO - ! - DO iss = 1, nspin - i = 0 - DO m = 1, n_emps_evc - IF ( ispin_evc(m) == iss) THEN - i = i + 1 - WRITE(stdout, *) i, m, ei_emp( i, iss ) * autoev, (ei_emp( i, iss ) + dble(delta_eig(m)))*autoev - ei_emp(i, iss) = ei_emp(i, iss) + dble(delta_eig(m)) - ENDIF - ENDDO - ENDDO - ! - IF (odd_nkscalfact_empty) THEN - ! - odd_alpha_emp(:) = odd_alpha(:) - ! here, deallocate the memory of odd_alpha for empty states - if(allocated(odd_alpha)) deallocate(odd_alpha) - ! reallocate the memory of odd_alpha for occupied states - allocate (odd_alpha(nbspx)) - ! - odd_alpha (:) = old_odd_alpha(:) - ! - deallocate(old_odd_alpha) - ! - ENDIF - ! - DEALLOCATE( gi ) - DEALLOCATE( c2 ) - DEALLOCATE( c3 ) - DEALLOCATE( c0_emp ) - ! - DEALLOCATE( ispin_emp ) - DEALLOCATE( fsic_emp ) - ! - CALL deallocate_twin(bec_emp) - ! - DEALLOCATE( vsic_emp ) - DEALLOCATE( wxd_emp ) - DEALLOCATE( deeq_sic_emp ) - DEALLOCATE( becsum_emp ) - DEALLOCATE( wfc_centers_emp ) - DEALLOCATE( wfc_spreads_emp ) - DEALLOCATE( pink_emp ) - ! - RETURN - ! - END SUBROUTINE empty_koopmans_pp diff --git a/quantum_espresso/kcp/CPV/empty_koopmans_pp.f90_bk b/quantum_espresso/kcp/CPV/empty_koopmans_pp.f90_bk deleted file mode 100644 index e3fbf33e3..000000000 --- a/quantum_espresso/kcp/CPV/empty_koopmans_pp.f90_bk +++ /dev/null @@ -1,390 +0,0 @@ - -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!----------------------------------------------------------------------- -SUBROUTINE empty_koopmans_pp (n_emps_evc, ispin_evc, evc) -!----------------------------------------------------------------------- - ! - ! Performs the minimization on the empty state subspace keeping the - ! occupied manyfold fixed. A proper orthogonalization of the two - ! manyfolds is performed. - ! - USE kinds, ONLY : DP - USE constants, ONLY : autoev - USE control_flags, ONLY : gamma_only, do_wf_cmplx,tortho, & - ndr, ndw - USE io_global, ONLY : ionode, stdout - USE cp_main_variables, ONLY : bec_emp, eigr, rhor - USE core, ONLY : nlcc_any, rhoc - USE electrons_base, ONLY : nspin, nbspx - USE uspp, ONLY : nkb - USE uspp_param, ONLY : nhm - USE ions_base, ONLY : nat, nsp - USE grid_dimensions, ONLY : nnrx - USE gvecw, ONLY : ngw - USE reciprocal_vectors, ONLY : ng0 => gstart - USE cp_interfaces, ONLY : readempty_twin, writeempty_twin, nlsm1, readempty - USE mp, ONLY : mp_comm_split, mp_comm_free, mp_sum - USE mp_global, ONLY : intra_image_comm, me_image - USE nksic, ONLY : do_orbdep, do_pz, do_wxd, vsicpsi, wtot, sizwtot, & - odd_alpha, valpsi, nkscalfact, odd_alpha_emp - USE nksic, ONLY : pink_emp, allocate_nksic_empty - USE input_parameters, ONLY : odd_nkscalfact_empty, odd_nkscalfact, aux_empty_nbnd - USE electrons_module, ONLY : ei_emp - USE twin_types - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: n_emps_evc - INTEGER, INTENT(IN) :: ispin_evc(n_emps_evc) - COMPLEX(DP), INTENT (INOUT) :: evc(ngw, n_emps_evc) - ! - INTEGER :: i, m, ig, iss, nbnd - ! - INTEGER :: n_emp ! number of empty states from input - LOGICAL :: exst - ! - INTEGER :: n_emps, n_empx, nudx_emp - INTEGER :: nupdwn_emp(nspin) - INTEGER :: iupdwn_emp(nspin) - ! - COMPLEX(DP), ALLOCATABLE :: c2(:), c3(:) - COMPLEX(DP), ALLOCATABLE :: c0_emp(:,:), gi(:,:) - REAL(DP), ALLOCATABLE :: becsum_emp(:,:,:) - ! - INTEGER, ALLOCATABLE :: ispin_emp(:) - REAL(DP), ALLOCATABLE :: fsic_emp(:) - REAL(DP), ALLOCATABLE :: vsic_emp(:,:) - REAL(DP), ALLOCATABLE :: wxd_emp(:,:) - REAL(DP), ALLOCATABLE :: deeq_sic_emp(:,:,:,:) - REAL(DP), ALLOCATABLE :: wfc_centers_emp(:,:,:) - REAL(DP), ALLOCATABLE :: wfc_spreads_emp(:,:,:) - REAL(DP), ALLOCATABLE :: old_odd_alpha(:) - LOGICAL :: icompute_spread - ! - LOGICAL :: lgam !added:giovanni - INTEGER :: ndr_loc, ndw_loc - COMPLEX(DP), PARAMETER :: c_zero=CMPLX(0.d0,0.d0) - COMPLEX(DP) :: delta_eig(n_emps_evc), scar1, scar2 - ! - LOGICAL :: odd_nkscalfact_old - ! - IF (aux_empty_nbnd == 0) THEN - ! - WRITE( stdout, "(/,3X,' aux_empty_nbnd == 0, no ODD correction ' )") - RETURN - ! - ENDIF - ! - lgam = gamma_only.and..not.do_wf_cmplx - ! - odd_nkscalfact_old = odd_nkscalfact - ! - ! restart directories - ! - ndr_loc = ndr - ndw_loc = ndw - ! - ! Setting number electrons - ! - n_emp = aux_empty_nbnd - ! - nupdwn_emp(1) = n_emp - iupdwn_emp(1) = 1 - IF ( nspin == 2 ) THEN - nupdwn_emp(2) = n_emp - iupdwn_emp(2) = 1 + n_emp - ! - ENDIF - ! - n_emps = nupdwn_emp( 1 ) - IF( nspin == 2 ) n_emps = n_emps + nupdwn_emp( 2 ) - ! - nudx_emp = nupdwn_emp( 1 ) - IF( nspin == 2 ) nudx_emp = MAX( nudx_emp, nupdwn_emp( 2 ) ) - ! - n_empx = nupdwn_emp( 1 ) - IF( nspin == 2 ) n_empx = n_empx + nupdwn_emp( 2 ) - n_empx = n_empx + MOD( n_empx, 2) - ! - ALLOCATE( c0_emp( ngw, n_empx ) ) - ALLOCATE( ispin_emp( n_empx ) ) - ! - call init_twin(bec_emp, lgam) - call allocate_twin(bec_emp, nkb, n_emps, lgam) - call set_twin(bec_emp, c_zero) - ! - ispin_emp (:) = 0 - ispin_emp ( 1:nupdwn_emp( 1 ) ) = 1 - IF ( nspin == 2 ) ispin_emp( iupdwn_emp(2) : ) = 2 - ! - ALLOCATE( fsic_emp( n_empx ) ) - ALLOCATE( vsic_emp(nnrx, n_empx) ) - ALLOCATE( wxd_emp (nnrx, 2) ) - ALLOCATE( deeq_sic_emp (nhm,nhm,nat,n_empx)) - ALLOCATE( becsum_emp (nhm*(nhm+1)/2,nat,nspin)) - ALLOCATE( wfc_centers_emp(4, nudx_emp, nspin )) - ALLOCATE( wfc_spreads_emp(nudx_emp, nspin, 2 )) - ! - CALL allocate_nksic_empty(n_empx) - ! - fsic_emp = 0.0d0 - vsic_emp = 0.0d0 - wxd_emp = 0.0d0 - ! - ! read auxilary orbitals - ! - exst = readempty_twin( c0_emp, n_empx, ndr_loc ) - ! - IF ( .NOT. exst ) THEN - ! - CALL errore( 'empty_koopmans_pp', 'there is no auxilary orbital', 1 ) - ! - ENDIF - ! - CALL nlsm1 ( n_emps, 1, nsp, eigr, c0_emp, bec_emp, 1, lgam ) - ! - IF ( ionode ) THEN - ! - WRITE( stdout, "(/,3X,'Compute empty ODD correction for KS eigenvalues ' )") - ! - ENDIF - ! - ! init xd potential - ! - ! we need to use wtot from previous calls with occupied states - ! we save here wtot in wxd_emp - ! - wxd_emp(:,:) = 0.0_DP - ! - IF ( do_wxd .AND. .NOT. do_pz ) THEN - ! - wxd_emp(:,:) = wtot(:,:) - ! - ENDIF - ! - IF (odd_nkscalfact_empty) THEN - ! - allocate(old_odd_alpha (nbspx)) - old_odd_alpha(:) = odd_alpha(:) - ! here, deallocate the memory of odd_alpha for occupied states - if(allocated(odd_alpha)) deallocate(odd_alpha) - if(allocated(valpsi)) deallocate(valpsi) - ! - ! reallocate the memory of odd_alpha for empty states - allocate (odd_alpha(n_emps)) - allocate (valpsi(n_emps, ngw)) - ! - ENDIF - ! - IF (odd_nkscalfact_empty) THEN - ! - valpsi(:,:) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - CALL odd_alpha_routine(c0_emp, n_emps, n_empx, lgam, .true.) - ! - odd_nkscalfact = .true. - ! - ELSE - ! - ! here, we want to use only one value alpha for all empty states, - ! that value alpha is defined from in input file. - ! This require to deactive here the odd_nkscalfact so that - ! it does not do odd_alpha in nksic_potential. - ! - odd_nkscalfact = .false. - ! - ENDIF - ! - ! - ! In the nksic case, we do not need to compute wxd here, - ! because no contribution comes from empty states. - ! - ! Instead, wxd from all occupied states is already computed - ! by the previous calls to nksic_potentials, and stored wxe_emp - ! - fsic_emp(:) = 0.0 - ! - icompute_spread=.true. - ! - CALL nksic_potential( n_emps, n_empx, c0_emp, fsic_emp, & - bec_emp, becsum_emp, deeq_sic_emp, & - ispin_emp, iupdwn_emp, nupdwn_emp, rhor, rhoc, & - wtot, sizwtot, vsic_emp, .false., pink_emp, nudx_emp, & - wfc_centers_emp, wfc_spreads_emp, & - icompute_spread, .true.) - ! - ! Print spreads infor - ! - WRITE( stdout, *) "sum spreads:1", sum(wfc_spreads_emp(1:nupdwn_emp(1), 1, 1)), & - sum(wfc_spreads_emp(1:nupdwn_emp(2), 2, 1)) - WRITE( stdout, *) "sum spreads:2", sum(wfc_spreads_emp(1:nupdwn_emp(1), 1, 2)), & - sum(wfc_spreads_emp(1:nupdwn_emp(2), 2, 2)) - - write(stdout, *) "Localization of orbitals from PZS localization" - do i = 1, nupdwn_emp(2) - write(stdout, *) i, wfc_spreads_emp(i, 2, 2), pink_emp (nupdwn_emp(1)+i) - enddo - ! - DO i = 1, n_emps - ! - ! Here wxd_emp <-> wtot that computed from nksic_potential of occupied states. - ! wtot is scaled with nkscalfact constant, we thus need to rescaled it here with - ! odd_alpha - ! - IF(odd_nkscalfact_empty) wxd_emp(:, ispin_emp(i)) = wxd_emp(:, ispin_emp(i))*odd_alpha(i)/nkscalfact - ! - vsic_emp(:,i) = vsic_emp(:,i) + wxd_emp(:, ispin_emp(i)) - ! - ENDDO - ! - ! Compute hpsi terms - ! - allocate( c2(ngw), c3(ngw), gi(ngw, n_emps) ) - gi(:,:) = cmplx(0.0d0, 0.0d0) - ! - DO i = 1, n_emps, 2 - ! - c2(:) = cmplx(0.0d0, 0.0d0) - c3(:) = cmplx(0.0d0, 0.0d0) - ! - IF ( odd_nkscalfact_empty ) THEN - ! - c2(:) = c2(:) + valpsi(i, :) - c3(:) = c3(:) + valpsi(i+1, :) - ! - ENDIF - ! - CALL nksic_eforce( i, n_emps, n_empx, vsic_emp, deeq_sic_emp, bec_emp, ngw, & - c0_emp(:,i), c0_emp(:,i+1), vsicpsi, lgam ) - ! - c2(:) = c2(:) + vsicpsi(:,1) - c3(:) = c3(:) + vsicpsi(:,2) - ! - gi(:, i) = c2(:) - ! - IF (i+1 <= n_emps) gi(:, i+1) = c3(:) - ! - IF (lgam .and. ng0.eq.2) THEN - ! - gi(1, i) = CMPLX(DBLE(gi(1, i)),0.d0) - ! - IF (i+1 <= n_emps) gi(1, i+1) = CMPLX(DBLE(gi(1, i+1)),0.d0) - ! - ENDIF - ! - ENDDO - ! - ! compute delta_eig(m) \sum_i - ! - delta_eig(:) = cmplx(0.0d0, 0.0d0) - DO m = 1, n_emps_evc - ! - DO i = 1, n_emps - ! - scar1 = cmplx(0.0d0, 0.0d0) - scar2 = cmplx(0.0d0, 0.0d0) - ! - IF (ispin_emp(i) == ispin_evc(m)) THEN - ! - IF (lgam) THEN - ! - DO ig = 1, ngw - ! - scar1 = scar1 + cmplx(dble(conjg(evc(ig, m)) * gi(ig, i)),0.0d0) - scar2 = scar2 + cmplx(dble(conjg(c0_emp(ig, i)) * evc(ig, m)), 0.0d0) - ! - ENDDO - ! - scar1 = 2.d0*scar1 - scar2 = 2.d0*scar2 - ! - IF (ng0.eq.2) THEN - ! - scar1 = cmplx(dble(scar1), 0.0d0) & - - cmplx(dble(conjg(evc(1, m)) * gi(1, i)), 0.0d0) - ! - scar2 = cmplx(dble(scar2), 0.0d0) & - - cmplx(dble(conjg(c0_emp(1, i)) * evc(1, m)), 0.0d0) - ! - ELSE - ! - scar1 = cmplx(dble(scar1), 0.0d0) - scar2 = cmplx(dble(scar2), 0.0d0) - ! - ENDIF - ! - ELSE - ! - DO ig = 1, ngw - ! - scar1 = scar1 + conjg(evc(ig, m)) * gi(ig, i) - scar2 = scar2 + conjg(c0_emp(ig, i)) * evc(ig, m) - ! - ENDDO - ! - ENDIF - ! - CALL mp_sum( scar1, intra_image_comm ) - CALL mp_sum( scar2, intra_image_comm ) - ! - delta_eig(m) = delta_eig(m) + scar1 * scar2 - ! - ENDIF - ! - ENDDO - ! - ENDDO - ! - DO iss = 1, nspin - i = 0 - DO m = 1, n_emps_evc - IF ( ispin_evc(m) == iss) THEN - i = i + 1 - WRITE(stdout, *) i, m, ei_emp( i, iss ) * autoev, (ei_emp( i, iss ) + dble(delta_eig(m)))*autoev - ei_emp(i, iss) = ei_emp(i, iss) + dble(delta_eig(m)) - ENDIF - ENDDO - ENDDO - ! - IF (odd_nkscalfact_empty) THEN - ! - odd_alpha_emp(:) = odd_alpha(:) - ! here, deallocate the memory of odd_alpha for empty states - if(allocated(odd_alpha)) deallocate(odd_alpha) - ! reallocate the memory of odd_alpha for occupied states - allocate (odd_alpha(nbspx)) - ! - odd_alpha (:) = old_odd_alpha(:) - ! - deallocate(old_odd_alpha) - ! - ENDIF - ! - DEALLOCATE( gi ) - DEALLOCATE( c2 ) - DEALLOCATE( c3 ) - DEALLOCATE( c0_emp ) - ! - DEALLOCATE( ispin_emp ) - DEALLOCATE( fsic_emp ) - ! - CALL deallocate_twin(bec_emp) - ! - DEALLOCATE( vsic_emp ) - DEALLOCATE( wxd_emp ) - DEALLOCATE( deeq_sic_emp ) - DEALLOCATE( becsum_emp ) - DEALLOCATE( wfc_centers_emp ) - DEALLOCATE( wfc_spreads_emp ) - ! - RETURN - ! - END SUBROUTINE empty_koopmans_pp diff --git a/quantum_espresso/kcp/CPV/emptystates.f90 b/quantum_espresso/kcp/CPV/emptystates.f90 deleted file mode 100644 index f6fa6341a..000000000 --- a/quantum_espresso/kcp/CPV/emptystates.f90 +++ /dev/null @@ -1,1596 +0,0 @@ - -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - -!----------------------------------------------------------------------- - SUBROUTINE empty_cp_twin_x(nfi, c0, v, tcg) -!----------------------------------------------------------------------- -! -! Performs the minimization on the empty state subspace keeping the -! occupied manyfold fixed. A proper orthogonalization of the two -! manyfolds is performed. -! - USE kinds, ONLY: DP - USE constants, ONLY: autoev - USE control_flags, ONLY: tsde, gamma_only, do_wf_cmplx, & - tortho - USE io_global, ONLY: ionode, stdout - USE cp_main_variables, ONLY: eigr, ema0bg, collect_lambda, & - rhor, rhog, rhos, eigr, eigrb, irb, bec, bec_emp - USE descriptors, ONLY: descla_siz_, descla_init, nlax_, lambda_node_ - USE uspp, ONLY: vkb, nkb - USE uspp_param, ONLY: nhm - USE grid_dimensions, ONLY: nnrx - USE electrons_base, ONLY: nbsp, nbspx, ispin, nspin, f, iupdwn, nupdwn - USE electrons_module, ONLY: iupdwn_emp, nupdwn_emp, nbsp_emp, ei_emp, & - max_emp, ethr_emp, etot_emp, eodd_emp, & - nudx_emp, nbsp_emp, nbspx_emp - USE ions_base, ONLY: nat, nsp - USE gvecw, ONLY: ngw - USE orthogonalize_base, ONLY: calphi, updatc - USE reciprocal_vectors, ONLY: gzero, gstart - USE wave_base, ONLY: wave_steepest, wave_verlet, frice - USE cvan, ONLY: nvb - USE cp_electronic_mass, ONLY: emass - USE time_step, ONLY: delt - USE check_stop, ONLY: check_stop_now - USE cp_interfaces, ONLY: writeempty, readempty, gram_empty, ortho, & - wave_rand_init, wave_atom_init, elec_fakekine, & - crot, dforce, nlsm1, grabec, & - bec_csv, readempty_twin, writeempty_twin, & - write_hamiltonian, ortho_check, symm_wannier - USE mp, ONLY: mp_comm_split, mp_comm_free, mp_sum - USE mp_global, ONLY: intra_image_comm, me_image - USE nksic, ONLY: do_orbdep, do_pz, do_wxd, vsicpsi, wtot, sizwtot, & - odd_alpha, valpsi, nkscalfact, odd_alpha_emp - USE nksic, ONLY: do_spinsym, pink_emp, allocate_nksic_empty - USE hfmod, ONLY: do_hf - USE twin_types !added:giovanni - USE control_flags, ONLY: tatomicwfc, ndr, ndw - USE electrons_module, ONLY: wfc_centers_emp, wfc_spreads_emp, icompute_spread - USE core, ONLY: rhoc - USE input_parameters, ONLY: odd_nkscalfact_empty, restart_mode, & - restart_from_wannier_cp, wannier_empty_only, & - fixed_band, print_wfc_anion, wo_odd_in_empty_run, & - odd_nkscalfact, index_empty_to_save, write_hr, & - impose_bloch_symm - USE wavefunctions_module, ONLY: c0fixed_emp - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nfi - COMPLEX(DP) :: c0(:, :) - REAL(DP) :: v(:, :) - logical, optional, intent(IN) :: tcg - ! - INTEGER :: i, iss, j, in, in_emp, iter, iter_ortho - INTEGER :: issw, n - INTEGER :: nlax_emp, nlam_emp - LOGICAL :: exst, tcg_ - ! - REAL(DP) :: fccc, ccc, dt2bye, bigr - REAL(DP) :: verl1, verl2, verl3 - REAL(DP) :: dek, ekinc, ekinc_old - ! - REAL(DP), ALLOCATABLE :: emadt2(:) - REAL(DP), ALLOCATABLE :: emaver(:) - COMPLEX(DP), ALLOCATABLE :: c2(:), c3(:) - COMPLEX(DP), ALLOCATABLE :: c0_emp(:, :), cm_emp(:, :), phi_emp(:, :) - REAL(DP), ALLOCATABLE :: becsum_emp(:, :, :) - type(twin_matrix) :: bephi_emp! !modified:giovanni - type(twin_matrix) :: becp_emp !modified:giovanni - type(twin_matrix) :: bec_occ !(:,:) !modified:giovanni - type(twin_matrix), dimension(:), ALLOCATABLE :: lambda_emp !(:,:,:) !, - REAL(DP), ALLOCATABLE :: f_emp(:) - REAL(DP), ALLOCATABLE :: f_aux(:) - REAL(DP), ALLOCATABLE :: lambda_rep(:, :) - COMPLEX(DP), ALLOCATABLE :: lambda_rep_c(:, :) - INTEGER, ALLOCATABLE :: ispin_emp(:) - REAL(DP), ALLOCATABLE :: fsic_emp(:) - REAL(DP), ALLOCATABLE :: vsic_emp(:, :) - REAL(DP), ALLOCATABLE :: wxd_emp(:, :) - REAL(DP), ALLOCATABLE :: deeq_sic_emp(:, :, :, :) - COMPLEX(DP), ALLOCATABLE :: vxxpsi_emp(:, :) - REAL(DP), ALLOCATABLE :: exx_emp(:) - REAL(DP), ALLOCATABLE :: old_odd_alpha(:) - ! - INTEGER, SAVE :: np_emp(2), me_emp(2), emp_comm, color - INTEGER, SAVE :: desc_emp(descla_siz_, 2) - LOGICAL, SAVE :: first = .true. - LOGICAL :: lgam !added:giovanni - LOGICAL :: done_extra !added:giovanni - COMPLEX(DP), PARAMETER :: c_zero = CMPLX(0.d0, 0.d0) - INTEGER :: sizvsic_emp - INTEGER :: ndr_loc, ndw_loc - ! - LOGICAL :: odd_nkscalfact_old - INTEGER :: nbnd_, ib, start_is - COMPLEX(DP), ALLOCATABLE :: c0_anion(:, :) - INTEGER :: spin_to_save - ! - lgam = gamma_only .and. .not. do_wf_cmplx - ! - odd_nkscalfact_old = odd_nkscalfact - ! - if (present(tcg)) THEN - ! - tcg_ = tcg - ! - ELSE - ! - tcg_ = .false. - ! - END IF - ! - ! ... quick exit if empty states have not to be computed - ! - IF (nbsp_emp < 1) RETURN - ! - ! restart directories - ! - IF (first) THEN - ndr_loc = ndr - ndw_loc = ndw - ELSE - ndr_loc = ndw - ndw_loc = ndw - END IF - ! - ! Here set the group of processors for empty states - ! - IF (.NOT. first) THEN - CALL mp_comm_free(emp_comm) - END IF - ! - np_emp = 1 - IF (me_image < np_emp(1)*np_emp(2)) THEN - color = 1 - ELSE - color = 0 - END IF - CALL mp_comm_split(intra_image_comm, color, me_image, emp_comm) - - if (me_image < np_emp(1)*np_emp(2)) then - me_emp(1) = me_image/np_emp(1) - me_emp(2) = MOD(me_image, np_emp(1)) - else - me_emp(1) = me_image - me_emp(2) = me_image - end if - ! - first = .FALSE. - ! - ! Done with the group - ! - DO iss = 1, nspin - CALL descla_init(desc_emp(:, iss), nupdwn_emp(iss), nudx_emp, np_emp, me_emp, emp_comm, color) - END DO - ! - nlax_emp = MAXVAL(desc_emp(nlax_, 1:nspin)) - nlam_emp = 1 - IF (ANY(desc_emp(lambda_node_, :) > 0)) nlam_emp = nlax_emp - ! - ALLOCATE (c0_emp(ngw, nbspx_emp)) - ALLOCATE (cm_emp(ngw, nbspx_emp)) - ALLOCATE (phi_emp(ngw, nbspx_emp)) - ! - IF (wannier_empty_only .and. odd_nkscalfact_empty) THEN - ! - ALLOCATE (c0fixed_emp(ngw, nbspx_emp)) - ! - END IF - ! - call init_twin(bec_emp, lgam) - call allocate_twin(bec_emp, nkb, nbsp_emp, lgam) - call init_twin(becp_emp, lgam) - call allocate_twin(becp_emp, nkb, nbsp_emp, lgam) - call init_twin(bec_occ, lgam) - call allocate_twin(bec_occ, nkb, nbsp, lgam) - call init_twin(bephi_emp, lgam) - call allocate_twin(bephi_emp, nkb, nbsp_emp, lgam) - ! - ALLOCATE (lambda_emp(nspin)) - ! - DO iss = 1, nspin - CALL init_twin(lambda_emp(iss), lgam) - CALL allocate_twin(lambda_emp(iss), nlam_emp, nlam_emp, lgam) - END DO - ! - ALLOCATE (f_emp(nbspx_emp)) - ALLOCATE (f_aux(nbspx_emp)) - ALLOCATE (ispin_emp(nbspx_emp)) - ! - c0_emp = 0.0 - cm_emp = 0.0 - ! - phi_emp = 0.0d0 - - call set_twin(bec_emp, c_zero) - call set_twin(bec_occ, c_zero) - call set_twin(bephi_emp, c_zero) - call set_twin(becp_emp, c_zero) - ! - DO iss = 1, nspin - call set_twin(lambda_emp(iss), c_zero) - END DO - ! - f_emp = 2.0d0/DBLE(nspin) - f_aux = 1.0d0 - ! - ispin_emp = 0 - ispin_emp(1:nupdwn_emp(1)) = 1 - IF (nspin == 2) ispin_emp(iupdwn_emp(2):) = 2 - ! - IF (do_orbdep) THEN - ! - ALLOCATE (fsic_emp(nbspx_emp)) - ! n_empx_odd=n_empx - ALLOCATE (vsic_emp(nnrx, nbspx_emp)) - ALLOCATE (wxd_emp(nnrx, 2)) - ALLOCATE (deeq_sic_emp(nhm, nhm, nat, nbspx_emp)) - ALLOCATE (becsum_emp(nhm*(nhm + 1)/2, nat, nspin)) - CALL allocate_nksic_empty(nbspx_emp) - sizvsic_emp = nnrx - ! - fsic_emp = 0.0d0 - vsic_emp = 0.0d0 - wxd_emp = 0.0d0 - ! - ELSE - ! - ALLOCATE (fsic_emp(nbspx_emp)) - ! n_empx_odd=1 - ALLOCATE (vsic_emp(1, nbspx_emp)) - ALLOCATE (wxd_emp(1, 2)) - ALLOCATE (deeq_sic_emp(nhm, nhm, nat, nbspx_emp)) - ALLOCATE (becsum_emp(nhm*(nhm + 1)/2, nat, nspin)) - ! - call allocate_nksic_empty(nbspx_emp) - sizvsic_emp = 1 - ! - END IF - ! - IF (do_hf) THEN - ! - !ALLOCATE( fsic_emp(nbspx_emp ) ) - ALLOCATE (vxxpsi_emp(ngw, nbspx_emp)) - ALLOCATE (exx_emp(nbspx_emp)) - ! - !fsic_emp = 0.0d0 - vxxpsi_emp = 0.0d0 - exx_emp = 0.0d0 - ! - END IF - ! - CALL prefor(eigr, vkb) - ! - CALL nlsm1(nbsp, 1, nvb, eigr, c0, bec_occ, 1, lgam) - ! - ! here is initialize wfcs - ! - IF (wannier_empty_only .and. (.not. odd_nkscalfact_empty)) THEN - ! - ! (1) read canonical orbital evctot_empty - ! - exst = readempty(c0_emp, nbspx_emp, ndr_loc) - ! - IF (exst) THEN - ! - ! (2) tranform evc to wannier evc0 - ! - CALL wave_init_wannier_cp(c0_emp, ngw, nbspx_emp, .false.) - ! - ELSE - ! - CALL errore('empty_run ', 'A restart from wannier orbitals needs evctot_empty in ./our dir', 1) - ! - END IF - ! - ELSEIF (wannier_empty_only .and. odd_nkscalfact_empty) THEN - ! - ! (3) read wannier evc0_empty - ! - !exst = readempty_twin( c0_emp, nbspx_emp, ndr_loc, .true., .false.) - ! - !exst = readempty_twin( c0fixed_emp, nbspx_emp, ndr_loc, .false., .false.) - ! - ELSE - ! - ! here is restart from the minimizing empty orbitals (evctot_empty) - ! it can be the wannierized orbitals - ! - IF (.not. wo_odd_in_empty_run) THEN - exst = readempty_twin(c0_emp, nbspx_emp, ndr_loc) - ELSE - exst = readempty(c0_emp, nbspx_emp, ndr_loc) - END IF - ! - IF (.NOT. exst .OR. TRIM(restart_mode) == 'from_scratch') THEN - ! - write (stdout, '(/)') - IF (.NOT. exst) write (stdout, '(3X "Empty-states WFCs file NOT FOUND")') - write (stdout, '(3X, "Initializing random WFCs and orthogonlizing to the occupied manifold ",/)') - ! - ! ... initial random states orthogonal to filled ones - ! - IF (.NOT. do_spinsym .OR. nspin == 1) THEN - ! - IF (tatomicwfc) THEN - ! - CALL wave_atom_init(c0_emp, nbsp_emp, 1) - ! - ELSE - ! - CALL wave_rand_init(c0_emp, nbsp_emp, 1) - ! - END IF - ! - ELSE - ! - IF (nupdwn_emp(1) > nupdwn_emp(2)) THEN - CALL errore('empty_cp', 'More spin-up empty states than spin-down; this is not allowed', 10) - END IF - ! - IF (tatomicwfc) THEN - ! - CALL wave_atom_init(c0_emp, nupdwn_emp(2), nupdwn_emp(1) + 1) - ! - ELSE - ! - CALL wave_rand_init(c0_emp, nupdwn_emp(2), nupdwn_emp(1) + 1) - ! - END IF - ! - DO i = 1, nupdwn_emp(1) - ! - j = i + iupdwn_emp(2) - 1 - c0_emp(:, i) = c0_emp(:, j) - ! - END DO - ! - IF (ionode) write (stdout, "(24x, 'spin symmetry applied to init wave')") - ! - END IF - ! - IF (gzero) THEN - ! - c0_emp(1, :) = (0.0d0, 0.0d0) - ! - END IF - ! - CALL nlsm1(nbsp_emp, 1, nvb, eigr, c0_emp, bec_emp, 1, lgam) - ! - DO iss = 1, nspin - ! - in_emp = iupdwn_emp(iss) - ! - issw = iupdwn(iss) - ! - CALL gram_empty(.false., eigr, vkb, bec_emp, bec_occ, nkb, & - c0_emp(:, in_emp:), c0(:, issw:), ngw, nupdwn_emp(iss), nupdwn(iss), in_emp, issw) - ! - END DO - ! - ELSE - ! - write (stdout, '(/, 3X, "Empty-states: WFCs read from file")') - write (stdout, '( 3X, "Empty-states: Going to re-orthogonalize to occ manifold")') - ! - ! Here we orthogonalize to the occupied manifold. Just in case this was changed after the restart - ! - DO iss = 1, nspin - ! - in_emp = iupdwn_emp(iss) - ! - issw = iupdwn(iss) - ! - IF (nupdwn(iss) > 0 .and. nupdwn_emp(iss) > 0) THEN - ! - CALL gram_empty(.false., eigr, vkb, bec_emp, bec_occ, nkb, & - c0_emp(:, in_emp:), c0(:, issw:), ngw, nupdwn_emp(iss), nupdwn(iss), in_emp, issw) - ! - END IF - ! - END DO - ! - ! - END IF - ! - END IF - ! - IF (impose_bloch_symm) CALL symm_wannier(c0_emp, nbspx_emp, .true.) - ! - ! - CALL nlsm1(nbsp_emp, 1, nsp, eigr, c0_emp, bec_emp, 1, lgam) - ! - ! ... set verlet variables - ! - IF (tsde) THEN - fccc = 1.0d0 - ELSE - fccc = 1.0d0/(1.0d0 + frice) - END IF - ! - verl1 = 2.0d0*fccc - verl2 = 1.0d0 - verl1 - verl3 = 1.0d0*fccc - ! - ALLOCATE (c2(ngw)) - ALLOCATE (c3(ngw)) - ALLOCATE (emadt2(ngw)) - ALLOCATE (emaver(ngw)) - - dt2bye = delt*delt/emass - - ccc = fccc*dt2bye - emadt2 = dt2bye*ema0bg - emaver = emadt2*verl3 - ! - cm_emp = c0_emp - - ekinc_old = 0.0 - ekinc = 0.0 - ! - ! init xd potential - ! - ! we need to use wtot from previous calls with occupied states - ! we save here wtot in wxd_emp - ! - IF (do_orbdep .and. (.not. wo_odd_in_empty_run)) THEN - ! - wxd_emp(:, :) = 0.0_DP - ! - IF (do_wxd .AND. .NOT. do_pz) THEN - ! - wxd_emp(:, :) = wtot(:, :) - ! - END IF - END IF - ! - IF (do_orbdep .and. (.not. wo_odd_in_empty_run)) THEN - ! - IF (odd_nkscalfact_empty) THEN - ! - allocate (old_odd_alpha(nbspx)) - old_odd_alpha(:) = odd_alpha(:) - ! here, deallocate the memory of odd_alpha for occupied states - if (allocated(odd_alpha)) deallocate (odd_alpha) - if (allocated(valpsi)) deallocate (valpsi) - ! - ! reallocate the memory of odd_alpha for empty states - allocate (odd_alpha(nbspx_emp)) - allocate (valpsi(nbspx_emp, ngw)) - ! - END IF - ! - END IF - ! - IF (ionode) THEN - WRITE (stdout, "(/,3X,'Empty states minimization starting ', & - & /,3x,'nfi dekinc ekinc' )") - END IF - ! - IF (tcg_) THEN ! compute empty states with conjugate gradient - ! - call runcg_uspp_emp(c0_emp, cm_emp, bec_emp, f_emp, fsic_emp, nbspx_emp, & - nbsp_emp, ispin_emp, iupdwn_emp, nupdwn_emp, phi_emp, lambda_emp, & - max_emp, wxd_emp, vsic_emp, sizvsic_emp, pink_emp, becsum_emp, & - deeq_sic_emp, nudx_emp, eodd_emp, etot_emp, v, & - nfi, .true., eigr, bec, irb, eigrb, & - rhor, rhoc, ema0bg, desc_emp) !!! Added rhoc NICOLA - ! - ELSE ! compute empty states with damped dynamics - ! - done_extra = .false. - ! - ITERATIONS: DO iter = 1, max_emp - ! - IF (do_orbdep .and. (.not. wo_odd_in_empty_run)) THEN - ! - IF (odd_nkscalfact_empty) THEN - ! - valpsi(:, :) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - CALL odd_alpha_routine(c0_emp, nbsp_emp, nbspx_emp, lgam, .true.) - ! - - ELSE - ! - ! here, we want to use only one value alpha for all empty states, - ! that value alpha is defined from in input file. - ! This require to deactive the odd_nkscalfact here so that - ! it does not do odd_alpha in nksic_potential. - ! - odd_nkscalfact = .false. - ! - END IF - ! - ! In the nksic case, we do not need to compute wxd here, - ! because no contribution comes from empty states. - ! - ! Instead, wxd from all occupied states is already computed - ! by the previous calls to nksic_potentials, and stored wxe_emp - ! - fsic_emp(:) = 0.0 - ! - ! the two lines below were removed by Giovanni, passing do_wxd as input to nksic_potential - !do_wxd_ = do_wxd - !do_wxd = .FALSE. - ! - !IF(done_extra.or.iter==max_emp) THEN - ! - icompute_spread = .true. - ! - !ENDIF - ! - call nksic_potential(nbsp_emp, nbspx_emp, c0_emp, fsic_emp, & - bec_emp, becsum_emp, deeq_sic_emp, & - ispin_emp, iupdwn_emp, nupdwn_emp, rhor, rhoc, & - wtot, sizwtot, vsic_emp, .false., pink_emp, nudx_emp, & - wfc_centers_emp, wfc_spreads_emp, & - icompute_spread, .false.) - ! - ! line below removed by Giovanni, introduced do_wxd=.false. into call to nksic_potential - !do_wxd = do_wxd_ - ! - ! Print spreads infor - ! - WRITE (stdout, *) "sum spreads:1", sum(wfc_spreads_emp(1:nupdwn_emp(1), 1, 1)), & - sum(wfc_spreads_emp(1:nupdwn_emp(2), 2, 1)) - WRITE (stdout, *) "sum spreads:2", sum(wfc_spreads_emp(1:nupdwn_emp(1), 1, 2)), & - sum(wfc_spreads_emp(1:nupdwn_emp(2), 2, 2)) - ! - DO i = 1, nbsp_emp - ! - ! Here wxd_emp <-> wtot that computed from nksic_potential of occupied states. - ! wtot is scaled with nkscalfact constant, we thus need to rescaled it here with - ! odd_alpha - ! - IF (odd_nkscalfact_empty) wxd_emp(:, :) = wxd_emp(:, :)*odd_alpha(i)/nkscalfact - ! - vsic_emp(:, i) = vsic_emp(:, i) + wxd_emp(:, ispin_emp(i)) - ! - END DO - ! - ! - END IF - ! - ! HF contribution - ! - IF (do_hf) THEN - ! - vxxpsi_emp = 0.0d0 - ! - CALL hf_potential(nbsp, nbspx, c0, f, ispin, iupdwn, nupdwn, & - nbsp_emp, nbspx_emp, c0_emp, fsic_emp, ispin_emp, & - iupdwn_emp, nupdwn_emp, rhor, rhog, vxxpsi_emp, exx_emp) - ! - END IF - ! - ! standard terms - ! - DO i = 1, nbsp_emp, 2 - ! - CALL dforce(i, bec_emp, vkb, c0_emp, c2, c3, v, SIZE(v, 1), ispin_emp, f_aux, nbsp_emp, nspin) - ! - ! ODD terms - ! - IF (do_orbdep .and. (.not. wo_odd_in_empty_run)) THEN - ! - IF (odd_nkscalfact_empty) THEN - ! - c2(:) = c2(:) - valpsi(i, :)*f_aux(i) - c3(:) = c3(:) - valpsi(i + 1, :)*f_aux(i + 1) - ! - END IF - ! - CALL nksic_eforce(i, nbsp_emp, nbspx_emp, vsic_emp, deeq_sic_emp, bec_emp, ngw, & - c0_emp(:, i), c0_emp(:, i + 1), vsicpsi, lgam) - ! - c2(:) = c2(:) - vsicpsi(:, 1)*f_aux(i) - c3(:) = c3(:) - vsicpsi(:, 2)*f_aux(i + 1) - ! - END IF - ! - ! HF terms - ! - IF (do_hf) THEN - ! - c2(:) = c2(:) - vxxpsi_emp(:, i)*f_aux(i) - c3(:) = c3(:) - vxxpsi_emp(:, i + 1)*f_aux(i + 1) - ! - END IF - ! - IF (tsde) THEN - CALL wave_steepest(cm_emp(:, i), c0_emp(:, i), emaver, c2) - CALL wave_steepest(cm_emp(:, i + 1), c0_emp(:, i + 1), emaver, c3) - ELSE - CALL wave_verlet(cm_emp(:, i), c0_emp(:, i), verl1, verl2, emaver, c2) - CALL wave_verlet(cm_emp(:, i + 1), c0_emp(:, i + 1), verl1, verl2, emaver, c3) - END IF - ! - IF (lgam) THEN - IF (gstart == 2) THEN - cm_emp(1, i) = CMPLX(DBLE(cm_emp(1, i)), 0.d0) - cm_emp(1, i + 1) = CMPLX(DBLE(cm_emp(1, i + 1)), 0.d0) - END IF - END IF - ! - END DO - ! - ! ortho cm_emp with c0 - ! - DO iss = 1, nspin - ! - in = iupdwn(iss) - in_emp = iupdwn_emp(iss) - ! - issw = iupdwn(iss) - ! - IF (nupdwn(iss) > 0 .and. nupdwn_emp(iss) > 0) THEN - ! - CALL gram_empty(.true., eigr, vkb, bec_emp, bec_occ, nkb, & - cm_emp(:, in_emp:), c0(:, issw:), ngw, nupdwn_emp(iss), nupdwn(iss), in_emp, issw) - ! - END IF - ! - END DO - ! - ! ... calphi calculates phi - ! ... the electron mass rises with g**2 - ! - CALL calphi(c0_emp, ngw, bec_emp, nkb, vkb, phi_emp, nbsp_emp, lgam, ema0bg) - ! - IF (tortho) THEN - ! - CALL ortho_cp_twin(eigr(1:ngw, 1:nat), cm_emp(1:ngw, 1:nbsp_emp), phi_emp(1:ngw, 1:nbsp_emp), & - ngw, lambda_emp(1:nspin), desc_emp(1:descla_siz_, 1:nspin), & - bigr, iter_ortho, ccc, bephi_emp, becp_emp, nbsp_emp, nspin, & - nupdwn_emp, iupdwn_emp) - ! - ELSE - ! - CALL gram(vkb, bec_emp, nkb, cm_emp, ngw, nbsp_emp) - ! - END IF - ! - DO iss = 1, nspin - ! - IF (.not. lambda_emp(iss)%iscmplx) THEN - CALL updatc(ccc, nbsp_emp, lambda_emp(iss)%rvec(:, :), SIZE(lambda_emp(iss)%rvec, 1), & - phi_emp, ngw, bephi_emp%rvec, nkb, becp_emp%rvec, bec_emp%rvec, & - cm_emp, nupdwn_emp(iss), iupdwn_emp(iss), desc_emp(:, iss)) - ELSE - CALL updatc(ccc, nbsp_emp, lambda_emp(iss)%cvec(:, :), SIZE(lambda_emp(iss)%cvec, 1), & - phi_emp, ngw, bephi_emp%cvec(:, :), nkb, becp_emp%cvec(:, :), bec_emp%cvec(:, :), & - cm_emp, nupdwn_emp(iss), iupdwn_emp(iss), desc_emp(:, iss)) - END IF - ! - END DO - ! - CALL nlsm1(nbsp_emp, 1, nsp, eigr, cm_emp, bec_emp, 1, lgam) - ! - CALL elec_fakekine(ekinc, ema0bg, emass, c0_emp, cm_emp, ngw, nbsp_emp, 1, delt) - ! - CALL dswap(2*SIZE(c0_emp), c0_emp, 1, cm_emp, 1) - ! - dek = ekinc - ekinc_old - ! - IF (ionode) WRITE (stdout, 113) ITER, dek, ekinc - ! - ! ... check for exit - ! - IF (check_stop_now()) THEN - EXIT ITERATIONS - END IF - - ! ... check for convergence - ! - IF ((ekinc < ethr_emp) .AND. (iter > 3)) THEN - IF (done_extra) THEN - IF (ionode) WRITE (stdout, 112) - EXIT ITERATIONS - ELSE - done_extra = .true. - END IF - END IF - ! - ekinc_old = ekinc - ! - END DO ITERATIONS - ! - END IF !if clause to choose between cg and damped dynamics - ! - IF (ionode) WRITE (stdout, "()") - ! - CALL ortho_check(c0_emp, lgam) - ! - ! ... Compute eigenvalues and bring wave functions on Kohn-Sham orbitals - ! - IF (.not. lambda_emp(1)%iscmplx) THEN - ALLOCATE (lambda_rep(nudx_emp, nudx_emp)) - ELSE - ALLOCATE (lambda_rep_c(nudx_emp, nudx_emp)) - END IF - ! - DO iss = 1, nspin - ! - i = iupdwn_emp(iss) - n = nupdwn_emp(iss) - ! - IF (.not. lambda_emp(iss)%iscmplx) THEN - CALL collect_lambda(lambda_rep, lambda_emp(iss)%rvec(:, :), desc_emp(:, iss)) -! IF (iss==1) THEN -! OPEN(27,FILE='hamiltonian_emp.dat',FORM='formatted',status='UNKNOWN') -! WRITE(27,'(1E16.10)') lambda_rep -! CLOSE(27) -! ENDIF - CALL crot(cm_emp, c0_emp, ngw, n, i, i, lambda_rep, nudx_emp, ei_emp(:, iss)) - IF (write_hr) CALL write_hamiltonian(lambda_rep, n, iss, .true.) - ELSE - CALL collect_lambda(lambda_rep_c, lambda_emp(iss)%cvec(:, :), desc_emp(:, iss)) - CALL crot(cm_emp, c0_emp, ngw, n, i, i, lambda_rep_c, nudx_emp, ei_emp(:, iss)) - IF (write_hr) CALL write_hamiltonian(lambda_rep_c, n, iss, .true.) - END IF - ! - ei_emp(1:n, iss) = ei_emp(1:n, iss)/f_aux(i:i + n - 1) - ! - END DO - ! - IF (.not. lambda_emp(1)%iscmplx) THEN - DEALLOCATE (lambda_rep) - ELSE - DEALLOCATE (lambda_rep_c) - END IF - ! -!write(stdout,*) "Empty Eigenvalues" -!write(stdout,*) ei_emp - ! - IF (do_orbdep .and. wo_odd_in_empty_run) THEN - ! - CALL empty_koopmans_pp(nbsp_emp, ispin_emp, cm_emp) - ! - END IF - ! - ! ... Save canonical empty orbitals to disk - ! - CALL writeempty(cm_emp, nbspx_emp, ndw_loc) - ! - ! ... Save minimizing empty orbitals to disk - ! - CALL writeempty_twin(c0_emp, nbspx_emp, ndw_loc, .false.) - ! - IF (print_wfc_anion) THEN - ! - write (stdout, *) "\n Writing on file the anion WFC \n" - ! ... Save N+1 orbitals to disk to be used in the future anion calculation - ! - ! Here check if the orbital to save is from spin up or spin dw according to - ! the value of index_empty_to_save - ! - WRITE (*, '("NsC: nupdwn_emp =", 2I5)') nupdwn_emp(:) ! DEBUG - IF (index_empty_to_save .le. nupdwn_emp(1)) THEN - ! This is the case the extra electron is from the spin-up channel - spin_to_save = 1 - ELSE - ! This is the case the extra electron is from the spin-dwn channel - spin_to_save = 2 - END IF - WRITE (*, '("orbital to save, spin ", 2I5)'), index_empty_to_save, spin_to_save - WRITE (*, '("iupdwn(1) ", I5)'), iupdwn(1) - IF (nspin == 2) WRITE (*, '("iupdwn(2) ", I5)'), iupdwn(2) - ! - allocate (c0_anion(ngw, nbsp + 1)) - ! - DO iss = 1, nspin - ! - start_is = iupdwn(iss) - !!!! IF (iss == 2) start_is = start_is+1 - ! - IF (spin_to_save == 1) THEN - ! - IF (iss == 1) THEN - c0_anion(:, start_is:start_is + nupdwn(1) - 1) = c0(:, start_is:start_is + nupdwn(1) - 1) - c0_anion(:, start_is + nupdwn(1)) = c0_emp(:, index_empty_to_save) - ELSE - ! The new wfc for spin-dw start from start_is+1 to keep track that the sin-up channel has one more band - c0_anion(:, start_is + 1:start_is + 1 + nupdwn(2) - 1) = c0(:, start_is:start_is + nupdwn(2) - 1) - END IF - ! - ELSE - ! - IF (iss == 1) THEN - c0_anion(:, start_is:start_is + nupdwn(1) - 1) = c0(:, start_is:start_is + nupdwn(1) - 1) - ELSE - c0_anion(:, start_is:start_is + nupdwn(2) - 1) = c0(:, start_is:start_is + nupdwn(2) - 1) - c0_anion(:, start_is + nupdwn(2)) = c0_emp(:, index_empty_to_save) - END IF - ! - END IF - ! - END DO - ! - CALL writeempty_twin(c0_anion, nbsp + 1, ndw_loc, .true., spin_to_save) - ! - DEALLOCATE (c0_anion) - ! - END IF - ! - odd_nkscalfact = odd_nkscalfact_old - ! - IF (do_orbdep .and. (.not. wo_odd_in_empty_run)) THEN - ! - IF (odd_nkscalfact_empty) THEN - ! - odd_alpha_emp(:) = odd_alpha(:) - ! here, deallocate the memory of odd_alpha for empty states - if (allocated(odd_alpha)) deallocate (odd_alpha) - ! reallocate the memory of odd_alpha for occupied states - allocate (odd_alpha(nbspx)) - ! - odd_alpha(:) = old_odd_alpha(:) - ! - deallocate (old_odd_alpha) - ! - END IF - ! - END IF - ! - DEALLOCATE (ispin_emp) - DEALLOCATE (f_emp) - DEALLOCATE (f_aux) - DEALLOCATE (emadt2) - DEALLOCATE (emaver) - DEALLOCATE (c2) - DEALLOCATE (c3) - DEALLOCATE (c0_emp) - DEALLOCATE (cm_emp) - DEALLOCATE (phi_emp) - IF (ALLOCATED(c0fixed_emp)) DEALLOCATE (c0fixed_emp) - ! - CALL deallocate_twin(bec_emp) - CALL deallocate_twin(bec_occ) - CALL deallocate_twin(bephi_emp) - CALL deallocate_twin(becp_emp) - ! - DO iss = 1, nspin - CALL deallocate_twin(lambda_emp(iss)) - END DO - ! - DEALLOCATE (fsic_emp) - ! - DEALLOCATE (vsic_emp) - DEALLOCATE (wxd_emp) - DEALLOCATE (deeq_sic_emp) - DEALLOCATE (becsum_emp) - ! - IF (do_hf) THEN - DEALLOCATE (vxxpsi_emp) - DEALLOCATE (exx_emp) - END IF - -112 FORMAT(/, 3X, 'Empty states: convergence achieved') -113 FORMAT(I5, 2X, 2D14.6) - - RETURN - END SUBROUTINE empty_cp_twin_x - -!------------------------------------------------------------------------- - SUBROUTINE gram_empty_real_x & - (tortho, eigr, betae, bec_emp, bec_occ, nkbx, c_emp, c_occ, ngwx, n_emp, n_occ) -!----------------------------------------------------------------------- -! gram-schmidt orthogonalization of the empty states ( c_emp ) -! c_emp are orthogonalized among themself and to the occupied states c_occ -! - USE uspp, ONLY: nkb, nkbus - USE cvan, ONLY: nvb - USE gvecw, ONLY: ngw - USE kinds, ONLY: DP - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE ions_base, ONLY: nat - USE cp_interfaces, ONLY: bec_csv, smooth_csv, grabec -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: nkbx, ngwx, n_emp, n_occ - COMPLEX(DP) :: eigr(ngwx, nat) - REAL(DP) :: bec_emp(nkbx, n_emp) - REAL(DP) :: bec_occ(nkbx, n_occ) - COMPLEX(DP) :: betae(ngwx, nkb) - COMPLEX(DP) :: c_emp(ngwx, n_emp) - COMPLEX(DP) :: c_occ(ngwx, n_occ) - LOGICAL, INTENT(IN) :: tortho -! - REAL(DP) :: anorm, cscnorm - REAL(DP), ALLOCATABLE :: csc_emp(:) - REAL(DP), ALLOCATABLE :: csc_occ(:) - INTEGER :: i, k, inl - EXTERNAL cscnorm -! - ALLOCATE (csc_emp(n_emp)) - ALLOCATE (csc_occ(n_occ)) - ! - ! orthogonalize empty states to the occupied one and among each other - ! - DO i = 1, n_emp - ! - csc_emp = 0.0d0 - csc_occ = 0.0d0 - ! - ! compute scalar product csc_occ(k) = - ! - CALL smooth_csv(c_emp(1:, i), c_occ(1:, 1:), ngwx, csc_occ, n_occ) - ! - IF (.NOT. tortho) THEN - ! - ! compute scalar product csc_emp(k) = - ! - CALL smooth_csv(c_emp(1:, i), c_emp(1:, 1:), ngwx, csc_emp, i - 1) - ! - CALL mp_sum(csc_emp, intra_image_comm) - ! - END IF - ! - CALL mp_sum(csc_occ, intra_image_comm) - ! - IF (nvb > 1) THEN - ! - CALL grabec(bec_emp(1:, i), nkbx, betae, c_emp(1:, i:), ngwx) - ! - CALL mp_sum(bec_emp(1:nkbus, i), intra_image_comm) - ! - CALL bec_csv(bec_emp(1:, i), bec_occ, nkbx, csc_occ, n_occ) - ! - IF (.NOT. tortho) THEN - CALL bec_csv(bec_emp(1:, i), bec_emp, nkbx, csc_emp, i - 1) - END IF - ! - DO k = 1, n_occ - DO inl = 1, nkbx - bec_emp(inl, i) = bec_emp(inl, i) - csc_occ(k)*bec_occ(inl, k) - END DO - END DO - ! - IF (.NOT. tortho) THEN - DO k = 1, i - 1 - DO inl = 1, nkbx - bec_emp(inl, i) = bec_emp(inl, i) - csc_emp(k)*bec_emp(inl, k) - END DO - END DO - END IF - ! - END IF - ! - ! calculate orthogonalized c_emp(i) : |c_emp(i)> = |c_emp(i)> - SUM_k csv(k)|c_occ(k)> - ! c_emp(i) : |c_emp(i)> = |c_emp(i)> - SUM_k - ! - DO k = 1, n_occ - CALL DAXPY(2*ngw, -csc_occ(k), c_occ(1, k), 1, c_emp(1, i), 1) - END DO - IF (.NOT. tortho) THEN - DO k = 1, i - 1 - CALL DAXPY(2*ngw, -csc_emp(k), c_emp(1, k), 1, c_emp(1, i), 1) - END DO - END IF - ! - ! - IF (.NOT. tortho) THEN - anorm = cscnorm(bec_emp, nkbx, c_emp, ngwx, i, n_emp) - ! - CALL DSCAL(2*ngw, 1.0d0/anorm, c_emp(1, i), 1) - ! - IF (nvb > 1) THEN - CALL DSCAL(nkbx, 1.0d0/anorm, bec_emp(1, i), 1) - END IF - END IF - ! - END DO - - DEALLOCATE (csc_emp) - DEALLOCATE (csc_occ) - ! - RETURN - END SUBROUTINE gram_empty_real_x - -!------------------------------------------------------------------------- - SUBROUTINE gram_empty_twin_x & - (tortho, eigr, betae, bec_emp, bec_occ, nkbx, c_emp, c_occ, ngwx, n_emp, n_occ, l_emp, l_occ) -!----------------------------------------------------------------------- -! -! gram-schmidt orthogonalization of the empty states ( c_emp ) -! c_emp are orthogonalized among themself and to the occupied states c_occ -! - USE uspp, ONLY: nkb, nkbus - USE cvan, ONLY: nvb - USE gvecw, ONLY: ngw - USE kinds, ONLY: DP - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - USE ions_base, ONLY: nat - USE control_flags, ONLY: gamma_only, do_wf_cmplx !added:giovanni - USE cp_interfaces, ONLY: grabec, smooth_csv, bec_csv - USE twin_types - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nkbx, ngwx, n_emp, n_occ, l_emp, l_occ - COMPLEX(DP) :: eigr(ngwx, nat) - type(twin_matrix) :: bec_emp !( nkbx, n_emp ) - type(twin_matrix) :: bec_occ !( nkbx, n_occ ) - COMPLEX(DP) :: betae(ngwx, nkb) - COMPLEX(DP) :: c_emp(ngwx, n_emp) - COMPLEX(DP) :: c_occ(ngwx, n_occ) - LOGICAL, INTENT(IN) :: tortho - ! - REAL(DP) :: anorm, cscnorm - type(twin_matrix) :: csc_emp, csc_occ - INTEGER :: i, k, inl - LOGICAL :: lgam - EXTERNAL cscnorm - ! - lgam = gamma_only .and. .not. do_wf_cmplx - ! - ! Quick return if there are either no filled or no empty states with this spin (no need to orthogonalize them) - ! - IF (n_emp .le. 0) THEN - ! - return - ! - END IF - ! - call init_twin(csc_emp, lgam) - call allocate_twin(csc_emp, n_emp, 1, lgam) - ! - IF (n_occ > 0) THEN - call init_twin(csc_occ, lgam) - call allocate_twin(csc_occ, n_occ, 1, lgam) - END IF - ! - ! orthogonalize empty states to the occupied one and among each other - ! - DO i = 1, n_emp - ! - call set_twin(csc_emp, CMPLX(0.d0, 0.d0)) - IF (n_occ > 0) call set_twin(csc_occ, CMPLX(0.d0, 0.d0)) - ! - ! compute scalar product csc_occ(k) = .. is it ? Yes! watch out! - ! - IF (n_occ > 0) CALL smooth_csv(c_emp(1:ngwx, i), c_occ(1:ngwx, 1:n_occ), ngwx, csc_occ, n_occ) - ! - IF (.NOT. tortho) THEN - ! - ! compute scalar product csc_emp(k) = - ! - CALL smooth_csv(c_emp(1:, i), c_emp(1:, 1:), ngwx, csc_emp, i - 1) - ! - IF (.not. csc_emp%iscmplx) THEN - CALL mp_sum(csc_emp%rvec(1:n_emp, 1:1), intra_image_comm) - ELSE - CALL mp_sum(csc_emp%cvec(1:n_emp, 1:1), intra_image_comm) - END IF - ! - END IF - ! - IF (n_occ > 0) THEN - IF (.not. csc_occ%iscmplx) THEN - CALL mp_sum(csc_occ%rvec(1:n_occ, 1:1), intra_image_comm) - ELSE - CALL mp_sum(csc_occ%cvec(1:n_occ, 1:1), intra_image_comm) - END IF - END IF - ! - IF (nvb > 1) THEN - ! - CALL grabec(bec_emp, nkbx, betae, c_emp(1:, i:), ngwx, i) - ! - IF (.not. bec_emp%iscmplx) THEN - CALL mp_sum(bec_emp%rvec(1:nkbus, i), intra_image_comm) - ELSE - CALL mp_sum(bec_emp%cvec(1:nkbus, i), intra_image_comm) - END IF - ! - IF (n_occ > 0) CALL bec_csv(bec_emp, bec_occ, nkbx, csc_occ, n_occ, i) - ! - IF (.NOT. tortho) THEN - CALL bec_csv(bec_emp, bec_emp, nkbx, csc_emp, i - 1, i) - END IF - ! - IF (n_occ > 0) THEN - IF (.not. bec_emp%iscmplx) THEN - ! - DO k = 1, n_occ - DO inl = 1, nkbx - bec_emp%rvec(inl, i) = bec_emp%rvec(inl, i) - csc_occ%rvec(k, 1)*bec_occ%rvec(inl, k) - END DO - END DO - ! - ELSE - ! - DO k = 1, n_occ - DO inl = 1, nkbx - bec_emp%cvec(inl, i) = bec_emp%cvec(inl, i) - CONJG(csc_occ%cvec(k, 1))*bec_occ%cvec(inl, k) - END DO - END DO - ! - END IF - END IF - ! - IF (.NOT. tortho) THEN - IF (.not. bec_emp%iscmplx) THEN - DO k = 1, i - 1 - DO inl = 1, nkbx - bec_emp%rvec(inl, i) = bec_emp%rvec(inl, i) - csc_emp%rvec(k, 1)*bec_emp%rvec(inl, k) - END DO - END DO - ELSE - DO k = 1, i - 1 - DO inl = 1, nkbx - bec_emp%cvec(inl, i) = bec_emp%cvec(inl, i) - CONJG(csc_emp%cvec(k, 1))*bec_emp%cvec(inl, k) - END DO - END DO - END IF - END IF - ! - END IF - ! - ! calculate orthogonalized c_emp(i) : |c_emp(i)> = |c_emp(i)> - SUM_k csv(k)|c_occ(k)> - ! c_emp(i) : |c_emp(i)> = |c_emp(i)> - SUM_k - ! - IF (n_occ > 0) THEN - IF (.not. csc_occ%iscmplx) THEN - ! - DO k = 1, n_occ - CALL DAXPY(2*ngw, -csc_occ%rvec(k, 1), c_occ(:, k), 1, c_emp(:, i), 1)!warning:giovanni tochange - END DO - ! - IF (.NOT. tortho) THEN - DO k = 1, i - 1 - CALL DAXPY(2*ngw, -csc_emp%rvec(k, 1), c_emp(:, k), 1, c_emp(:, i), 1)!warning:giovanni tochange - END DO - END IF - ! - ELSE - ! - DO k = 1, n_occ - CALL ZAXPY(ngw, -csc_occ%cvec(k, 1), c_occ(:, k), 1, c_emp(:, i), 1) - END DO - ! - IF (.NOT. tortho) THEN - DO k = 1, i - 1 - CALL ZAXPY(ngw, -csc_emp%cvec(k, 1), c_emp(:, k), 1, c_emp(:, i), 1) - END DO - END IF - ! - END IF - END IF - ! - IF (.NOT. tortho) THEN - ! - anorm = cscnorm(bec_emp, nkbx, c_emp, ngwx, i, n_emp, lgam) - ! - IF (.not. bec_emp%iscmplx) THEN - ! - CALL DSCAL(2*ngw, 1.0d0/anorm, c_emp(:, i), 1) - ! - IF (nvb > 1) THEN - CALL DSCAL(nkbx, 1.0d0/anorm, bec_emp%rvec(:, i), 1) - END IF - ! - ELSE - ! - CALL ZSCAL(ngw, CMPLX(1.0d0/anorm, 0.d0), c_emp(:, i), 1) - ! - IF (nvb > 1) THEN - CALL ZSCAL(nkbx, CMPLX(1.0d0/anorm, 0.d0), bec_emp%cvec(:, i), 1) - END IF - ! - END IF - ! - END IF - ! - END DO - ! - call deallocate_twin(csc_emp) - IF (n_occ > 0) call deallocate_twin(csc_occ) - ! - RETURN - ! - END SUBROUTINE gram_empty_twin_x - -!----------------------------------------------------------------------- - LOGICAL FUNCTION readempty_x(c_emp, ne, ndi) -!----------------------------------------------------------------------- - ! - ! ... This subroutine reads canonical empty states from unit emptyunit - ! - USE kinds, ONLY: DP - USE mp_global, ONLY: me_image, nproc_image, intra_image_comm - USE io_global, ONLY: stdout, ionode, ionode_id - USE mp, ONLY: mp_bcast, mp_sum - USE mp_wave, ONLY: splitwf - USE io_files, ONLY: outdir - USE io_files, ONLY: emptyunit - USE reciprocal_vectors, ONLY: ig_l2g - USE gvecw, ONLY: ngw - USE xml_io_base, ONLY: restart_dir, wfc_filename - USE electrons_base, ONLY: nspin - USE electrons_module, ONLY: iupdwn_emp, nupdwn_emp - - IMPLICIT none - - COMPLEX(DP), INTENT(OUT) :: c_emp(:, :) - INTEGER, INTENT(IN) :: ne - INTEGER, INTENT(IN) :: ndi - - LOGICAL :: exst - INTEGER :: ig, i, iss - INTEGER :: ngw_rd, ne_rd, ngw_l - INTEGER :: ngw_g - - CHARACTER(LEN=256) :: fileempty, dirname - - COMPLEX(DP), ALLOCATABLE :: ctmp(:) - ! - ! ... Subroutine Body - ! - ngw_g = ngw - ngw_l = ngw - ! - CALL mp_sum(ngw_g, intra_image_comm) - ! - ALLOCATE (ctmp(ngw_g)) - ! - dirname = restart_dir(outdir, ndi) - ! - DO iss = 1, nspin - IF (ionode) THEN - fileempty = TRIM(wfc_filename(dirname, 'evc_empty', 1, iss)) - INQUIRE (FILE=TRIM(fileempty), EXIST=EXST) - - IF (EXST) THEN - ! - OPEN (UNIT=emptyunit, FILE=TRIM(fileempty), STATUS='OLD', FORM='UNFORMATTED') - ! - READ (emptyunit) ngw_rd, ne_rd - ! - IF (nupdwn_emp(iss) > ne_rd) THEN - EXST = .false. - WRITE (stdout, 10) TRIM(fileempty) - WRITE (stdout, 20) ngw_rd, ne_rd - WRITE (stdout, 20) ngw_g, nupdwn_emp(iss) - END IF - ! - END IF - ! - END IF - -10 FORMAT('*** EMPTY STATES : wavefunctions dimensions changed ', A) -20 FORMAT('*** NGW = ', I8, ' NE = ', I4) - - CALL mp_bcast(exst, ionode_id, intra_image_comm) - CALL mp_bcast(ne_rd, ionode_id, intra_image_comm) - CALL mp_bcast(ngw_rd, ionode_id, intra_image_comm) - - IF (exst) THEN - - DO i = 1, nupdwn_emp(iss) - IF (ionode) THEN - READ (emptyunit) (ctmp(ig), ig=1, MIN(SIZE(ctmp), ngw_rd)) - END IF - CALL splitwf(c_emp(:, i + iupdwn_emp(iss) - 1), ctmp, ngw_l, ig_l2g, me_image, & - nproc_image, ionode_id, intra_image_comm) - END DO - - END IF - - IF (ionode .AND. EXST) THEN - CLOSE (emptyunit) - END IF - - readempty_x = exst - - IF (.NOT. readempty_x) RETURN - END DO - - DEALLOCATE (ctmp) - - RETURN - END FUNCTION readempty_x - -!----------------------------------------------------------------------- - SUBROUTINE writeempty_x(c_emp, ne, ndi) -!----------------------------------------------------------------------- - ! - ! ... This subroutine write canonical empty states from unit emptyunit - ! - USE kinds, ONLY: DP - USE mp_global, ONLY: me_image, nproc_image, intra_image_comm - USE mp_wave, ONLY: mergewf - USE mp, ONLY: mp_sum - USE io_files, ONLY: emptyunit, outdir - USE io_global, ONLY: ionode, ionode_id - USE reciprocal_vectors, ONLY: ig_l2g - USE gvecw, ONLY: ngw - USE xml_io_base, ONLY: restart_dir, wfc_filename - USE wrappers, ONLY: f_mkdir - USE electrons_base, ONLY: nspin - USE electrons_module, ONLY: iupdwn_emp, nupdwn_emp - ! - IMPLICIT NONE - - COMPLEX(DP), INTENT(IN) :: c_emp(:, :) - INTEGER, INTENT(IN) :: ne - INTEGER, INTENT(IN) :: ndi - - INTEGER :: ig, i, ngw_g, iss, ngw_l - LOGICAL :: ierr - COMPLEX(DP), ALLOCATABLE :: ctmp(:) - CHARACTER(LEN=256) :: fileempty, dirname - ! - ! ... Subroutine Body - ! - ngw_g = ngw - ngw_l = ngw - ! - CALL mp_sum(ngw_g, intra_image_comm) - ! - ALLOCATE (ctmp(ngw_g)) - ! - dirname = restart_dir(outdir, ndi) - ! - ierr = f_mkdir(TRIM(dirname)//"/K00001") - ! - DO iss = 1, nspin - fileempty = TRIM(wfc_filename(dirname, 'evc_empty', 1, iss)) - IF (ionode) THEN - OPEN (UNIT=emptyunit, FILE=TRIM(fileempty), status='unknown', FORM='UNFORMATTED') - REWIND (emptyunit) - WRITE (emptyunit) ngw_g, ne - END IF - -10 FORMAT('*** EMPTY STATES : writing wavefunctions ', A) -20 FORMAT('*** NGW = ', I8, ' NE = ', I4) - - DO i = 1, nupdwn_emp(iss) - ctmp = 0.0d0 - CALL MERGEWF(c_emp(:, i + iupdwn_emp(iss) - 1), ctmp(:), ngw_l, ig_l2g, me_image, & - nproc_image, ionode_id, intra_image_comm) - IF (ionode) THEN - WRITE (emptyunit) (ctmp(ig), ig=1, ngw_g) - END IF - END DO - - IF (ionode) THEN - CLOSE (emptyunit) - END IF - END DO - - DEALLOCATE (ctmp) - - RETURN - END SUBROUTINE writeempty_x - -!----------------------------------------------------------------------- - LOGICAL FUNCTION reademptytwin_x(c_emp, ne, ndi) -!----------------------------------------------------------------------- - ! - ! ... This subroutine reads canonical, or mininimzing empty states - ! - USE kinds, ONLY: DP - USE mp_global, ONLY: me_image, nproc_image, intra_image_comm - USE io_global, ONLY: stdout, ionode, ionode_id - USE mp, ONLY: mp_bcast, mp_sum - USE mp_wave, ONLY: splitwf - USE io_files, ONLY: outdir - USE io_files, ONLY: emptyunitc0 - USE reciprocal_vectors, ONLY: ig_l2g - USE gvecw, ONLY: ngw - USE xml_io_base, ONLY: restart_dir, wfc_filename - USE electrons_base, ONLY: nspin - USE electrons_module, ONLY: iupdwn_emp, nupdwn_emp - ! - IMPLICIT none - ! - COMPLEX(DP), INTENT(OUT) :: c_emp(:, :) - INTEGER, INTENT(IN) :: ne - INTEGER, INTENT(IN) :: ndi - ! - LOGICAL :: exst - INTEGER :: ig, i, iss - INTEGER :: ngw_rd, ne_rd, ngw_l - INTEGER :: ngw_g - ! - CHARACTER(LEN=256) :: fileempty, dirname - ! - COMPLEX(DP), ALLOCATABLE :: ctmp(:) - ! - ! ... Subroutine Body - ! - ngw_g = ngw - ngw_l = ngw - ! - CALL mp_sum(ngw_g, intra_image_comm) - ! - ALLOCATE (ctmp(ngw_g)) - ! - dirname = restart_dir(outdir, ndi) - ! - DO iss = 1, nspin - fileempty = TRIM(wfc_filename(dirname, 'evc0_empty', 1, iss)) - ! - IF (ionode) THEN - ! - INQUIRE (FILE=TRIM(fileempty), EXIST=EXST) - ! - IF (exst) THEN - ! - OPEN (UNIT=emptyunitc0, FILE=TRIM(fileempty), STATUS='OLD', FORM='UNFORMATTED') - ! - READ (emptyunitc0) ngw_rd, ne_rd - ! - IF (nupdwn_emp(iss) > ne_rd) THEN - ! - exst = .false. - WRITE (stdout, 10) TRIM(fileempty) - WRITE (stdout, 20) ngw_rd, ne_rd - WRITE (stdout, 20) ngw_g, nupdwn_emp(iss) - ! - END IF - ! - END IF - ! - END IF - ! -10 FORMAT('*** EMPTY STATES : wavefunctions dimensions changed ', A) -20 FORMAT('*** NGW = ', I8, ' NE = ', I4) - ! - CALL mp_bcast(exst, ionode_id, intra_image_comm) - CALL mp_bcast(ne_rd, ionode_id, intra_image_comm) - CALL mp_bcast(ngw_rd, ionode_id, intra_image_comm) - ! - IF (exst) THEN - ! - DO i = 1, nupdwn_emp(iss) - ! - IF (ionode) THEN - ! - READ (emptyunitc0) (ctmp(ig), ig=1, MIN(SIZE(ctmp), ngw_rd)) - ! - END IF - ! - CALL splitwf(c_emp(:, i + iupdwn_emp(iss) - 1), ctmp, ngw_l, ig_l2g, me_image, & - nproc_image, ionode_id, intra_image_comm) - ! - END DO - ! - END IF - ! - IF (ionode .AND. exst) THEN - ! - CLOSE (emptyunitc0) - ! - END IF - ! - reademptytwin_x = exst - ! - IF (.NOT. reademptytwin_x) RETURN - END DO - ! - DEALLOCATE (ctmp) - ! - RETURN - ! - END FUNCTION reademptytwin_x - -!----------------------------------------------------------------------- - SUBROUTINE writeemptytwin_x(c_emp, ne, ndi, fixed, spin_to_save) -!----------------------------------------------------------------------- - ! - ! ... This subroutine writes empty states to unit emptyunitc0 - ! - USE kinds, ONLY: DP - USE mp_global, ONLY: me_image, nproc_image, intra_image_comm - USE mp_wave, ONLY: mergewf - USE mp, ONLY: mp_sum - USE io_files, ONLY: outdir, emptyunitc0, emptyunitc0fixed - USE io_global, ONLY: ionode, ionode_id - USE reciprocal_vectors, ONLY: ig_l2g - USE gvecw, ONLY: ngw - USE xml_io_base, ONLY: restart_dir, wfc_filename - USE wrappers, ONLY: f_mkdir - USE electrons_base, ONLY: nspin, nupdwn, iupdwn - USE electrons_module, ONLY: iupdwn_emp, nupdwn_emp - ! - IMPLICIT NONE - ! - COMPLEX(DP), INTENT(IN) :: c_emp(:, :) - INTEGER, INTENT(IN) :: ne - INTEGER, INTENT(IN) :: ndi - LOGICAL, INTENT(IN) :: fixed - INTEGER, OPTIONAL, INTENT(IN) :: spin_to_save - ! - INTEGER :: ig, i, ngw_g, iss, ngw_l, funit, ne_loc, i_start - LOGICAL :: ierr - COMPLEX(DP), ALLOCATABLE :: ctmp(:) - CHARACTER(LEN=256) :: fileempty, dirname, filename - ! - ! ... Subroutine Body - ! - ngw_g = ngw - ngw_l = ngw - ! - IF (fixed) THEN - funit = emptyunitc0 - ELSE - funit = emptyunitc0fixed - END IF - ! - CALL mp_sum(ngw_g, intra_image_comm) - ! - ALLOCATE (ctmp(ngw_g)) - ! - dirname = restart_dir(outdir, ndi) - ! - ierr = f_mkdir(TRIM(dirname)//"/K00001") - ! - filename = 'evc0_empty' - IF (fixed) filename = 'evcfixed_empty' - - DO iss = 1, nspin - ! - fileempty = TRIM(wfc_filename(dirname, filename, 1, iss)) - ne_loc = nupdwn_emp(iss) - i_start = iupdwn_emp(iss) - ! - IF (fixed) THEN - ne_loc = nupdwn(iss) - i_start = iupdwn(iss) - IF (iss == spin_to_save) ne_loc = ne_loc + 1 - IF (iss == 2 .AND. spin_to_save == 1) i_start = i_start + 1 - END IF - ! - IF (ionode) THEN - OPEN (UNIT=funit, FILE=TRIM(fileempty), status='unknown', FORM='UNFORMATTED') - ! - REWIND (funit) - ! - WRITE (funit) ngw_g, ne_loc - END IF - ! -10 FORMAT('*** EMPTY STATES : writing wavefunctions ', A) -20 FORMAT('*** NGW = ', I8, ' NE = ', I4) - ! - DO i = 1, ne_loc - ! - ctmp = 0.0d0 - ! - CALL MERGEWF(c_emp(:, i + i_start - 1), ctmp(:), ngw_l, ig_l2g, me_image, & - nproc_image, ionode_id, intra_image_comm) - ! - IF (ionode) THEN - ! - WRITE (funit) (ctmp(ig), ig=1, ngw_g) - ! - END IF - ! - END DO - ! - IF (ionode) CLOSE (funit) - - ! For evc0_fixed, exit this 'spin' loop - !IF (.NOT. write_evc0) EXIT - END DO - - DEALLOCATE (ctmp) - - ! - RETURN - ! - END SUBROUTINE writeemptytwin_x diff --git a/quantum_espresso/kcp/CPV/emptystates_tocg.f90 b/quantum_espresso/kcp/CPV/emptystates_tocg.f90 deleted file mode 100644 index 24544ae4f..000000000 --- a/quantum_espresso/kcp/CPV/emptystates_tocg.f90 +++ /dev/null @@ -1,1353 +0,0 @@ - -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - - -!----------------------------------------------------------------------- - SUBROUTINE empty_cp_twin_x ( nfi, c0, v, tcg ) -!----------------------------------------------------------------------- -! -! Performs the minimization on the empty state subspace keeping the -! occupied manyfold fixed. A proper orthogonalization of the two -! manyfolds is performed. -! - USE kinds, ONLY : DP - USE control_flags, ONLY : iprsta, tsde, program_name, gamma_only, do_wf_cmplx, & - tortho - USE io_global, ONLY : ionode, stdout - USE cp_main_variables, ONLY : eigr, ema0bg, collect_lambda, & - rhor, rhog, rhos, eigr, eigrb, irb, bec - USE descriptors, ONLY : descla_siz_ , descla_init, nlax_, lambda_node_ - USE cell_base, ONLY : omega - USE uspp, ONLY : vkb, nkb, okvan - USE uspp_param, ONLY : nhm - USE grid_dimensions, ONLY : nnrx - USE electrons_base, ONLY : nbsp, nbspx, ispin, nspin, f, nudx, iupdwn, nupdwn - USE electrons_module, ONLY : iupdwn_emp, nupdwn_emp, n_emp, ei_emp, & - max_emp, ethr_emp, etot_emp, eodd_emp - USE ions_base, ONLY : nat, nsp - USE gvecw, ONLY : ngw - USE orthogonalize_base, ONLY : calphi, updatc - USE reciprocal_vectors, ONLY : gzero, gstart - USE wave_base, ONLY : wave_steepest, wave_verlet, frice - USE cvan, ONLY : nvb - USE cp_electronic_mass, ONLY : emass - USE time_step, ONLY : delt - USE check_stop, ONLY : check_stop_now - USE cp_interfaces, ONLY : writeempty, readempty, gram_empty, ortho, & - wave_rand_init, wave_atom_init, elec_fakekine, & - crot, dforce, nlsm1, grabec, & - bec_csv, reademptyc0, writeemptyc0 - USE mp, ONLY : mp_comm_split, mp_comm_free, mp_sum - USE mp_global, ONLY : intra_image_comm, me_image - USE nksic, ONLY : do_orbdep, do_pz, do_wxd, vsicpsi, wtot, sizwtot, & - odd_alpha, valpsi, nkscalfact - USE nksic, ONLY : do_spinsym, pink_emp, allocate_nksic_empty - USE hfmod, ONLY : do_hf, vxxpsi - USE twin_types !added:giovanni - USE control_flags, ONLY : tatomicwfc, trane, ndr, ndw - USE electrons_module, ONLY : wfc_centers_emp, wfc_spreads_emp, icompute_spread - USE core, ONLY : nlcc_any, rhoc - USE input_parameters, ONLY : odd_nkscalfact, print_wfc_empty - USE wavefunctions_module, ONLY : c0_fixed, c0_emp_aux, cm_emp_aux - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nfi - COMPLEX(DP) :: c0(:,:) - REAL(DP) :: v(:,:) - logical, optional, intent(IN) :: tcg - ! - INTEGER :: i, iss, j, in, in_emp, iter, iter_ortho - INTEGER :: n_occs, n_emps, n_empx, nudx_emp, issw, n - INTEGER :: nlax_emp, nlam_emp - LOGICAL :: exst, do_wxd_, tcg_ - ! - REAL(DP) :: fccc, ccc, csv, dt2bye, bigr - REAL(DP) :: verl1, verl2, verl3 - REAL(DP) :: dek, ekinc, ekinc_old, detothf - ! - REAL(DP), ALLOCATABLE :: emadt2(:) - REAL(DP), ALLOCATABLE :: emaver(:) - COMPLEX(DP), ALLOCATABLE :: c2(:), c3(:) - COMPLEX(DP), ALLOCATABLE :: c0_emp(:,:), cm_emp(:,:), phi_emp(:,:) -! REAL(DP), ALLOCATABLE :: bec_emp(:,:) - type(twin_matrix) :: bec_emp !modified:giovanni - REAL(DP), ALLOCATABLE :: becsum_emp(:,:,:) - type(twin_matrix) :: bephi_emp! !modified:giovanni - type(twin_matrix) :: becp_emp !modified:giovanni - type(twin_matrix) :: bec_occ !(:,:) !modified:giovanni - type(twin_matrix), dimension(:), ALLOCATABLE :: lambda_emp !(:,:,:) !, - REAL(DP), ALLOCATABLE :: f_emp(:) - REAL(DP), ALLOCATABLE :: lambda_rep(:,:) - COMPLEX(DP), ALLOCATABLE :: lambda_rep_c(:,:) - INTEGER, ALLOCATABLE :: ispin_emp(:) - REAL(DP), ALLOCATABLE :: fsic_emp(:) - REAL(DP), ALLOCATABLE :: vsic_emp(:,:) - REAL(DP), ALLOCATABLE :: wxd_emp(:,:) - REAL(DP), ALLOCATABLE :: deeq_sic_emp(:,:,:,:) - COMPLEX(DP), ALLOCATABLE :: vxxpsi_emp(:,:) - REAL(DP), ALLOCATABLE :: exx_emp(:) -! REAL(DP), ALLOCATABLE :: pink_emp(:) - ! - INTEGER, SAVE :: np_emp(2), me_emp(2), emp_comm, color - INTEGER, SAVE :: desc_emp( descla_siz_ , 2 ) - LOGICAL, SAVE :: first = .true. - LOGICAL :: lgam !added:giovanni - LOGICAL :: done_extra !added:giovanni - COMPLEX(DP), PARAMETER :: c_zero=CMPLX(0.d0,0.d0) - INTEGER :: sizvsic_emp - INTEGER :: ndr_loc, ndw_loc - - lgam=gamma_only.and..not.do_wf_cmplx - ! - if(present(tcg)) THEN - ! - tcg_=tcg - ! - ELSE - ! - tcg_=.false. - ! - ENDIF - ! - ! ... quick exit if empty states have not to be computed - ! - IF( n_emp < 1 ) RETURN - - ! - ! restart directories - ! - IF ( first ) THEN - ndr_loc = ndr - ndw_loc = ndw - ELSE - ndr_loc = ndw - ndw_loc = ndw - ENDIF - - ! - ! Here set the group of processors for empty states - ! - IF( .NOT. first ) THEN - CALL mp_comm_free( emp_comm ) - END IF - ! - np_emp = 1 - IF( me_image < np_emp(1) * np_emp(2) ) THEN - color = 1 - ELSE - color = 0 - END IF - CALL mp_comm_split( intra_image_comm, color, me_image, emp_comm ) - - if( me_image < np_emp(1) * np_emp(2) ) then - me_emp(1) = me_image / np_emp(1) - me_emp(2) = MOD( me_image, np_emp(1) ) - else - me_emp(1) = me_image - me_emp(2) = me_image - endif - ! - first = .FALSE. - ! - ! Done with the group - ! - ! n_occs == nbsp - ! n_emps => nbsp (corresponds to) - ! n_empx => nbspx - ! nudx_emp => nudx - ! - n_occs = nupdwn( 1 ) - IF( nspin == 2 ) n_occs = n_occs + nupdwn( 2 ) - ! - n_emps = nupdwn_emp( 1 ) - IF( nspin == 2 ) n_emps = n_emps + nupdwn_emp( 2 ) - ! - nudx_emp = nupdwn_emp( 1 ) !+ MOD( nupdwn_emp( 1 ), 2) - IF( nspin == 2 ) nudx_emp = MAX( nudx_emp, nupdwn_emp( 2 ) ) - ! - n_empx = nupdwn_emp( 1 ) - IF( nspin == 2 ) n_empx = n_empx + nupdwn_emp( 2 ) - n_empx = n_empx + MOD( n_empx, 2) - ! - DO iss = 1, nspin - CALL descla_init( desc_emp( :, iss ), nupdwn_emp( iss ), nudx_emp, np_emp, me_emp, emp_comm, color ) - END DO - ! - nlax_emp = MAXVAL( desc_emp( nlax_, 1:nspin ) ) - nlam_emp = 1 - IF ( ANY( desc_emp( lambda_node_, : ) > 0 ) ) nlam_emp = nlax_emp - ! - ALLOCATE( c0_emp( ngw, n_empx ) ) - ALLOCATE( cm_emp( ngw, n_empx ) ) - ALLOCATE( phi_emp( ngw, n_empx ) ) - ! - call init_twin(bec_emp, lgam) - call allocate_twin(bec_emp, nkb, n_emps, lgam) - call init_twin(becp_emp, lgam) - call allocate_twin(becp_emp, nkb, n_emps, lgam) - call init_twin(bec_occ, lgam) - call allocate_twin(bec_occ, nkb, n_occs, lgam) - call init_twin(bephi_emp, lgam) - call allocate_twin(bephi_emp, nkb, n_emps, lgam) - - ALLOCATE(lambda_emp(nspin)) - ! - DO iss=1,nspin - CALL init_twin(lambda_emp(iss), lgam) - CALL allocate_twin(lambda_emp(iss), nlam_emp, nlam_emp, lgam) - ENDDO - - ALLOCATE( f_emp( n_empx ) ) - ALLOCATE( ispin_emp( n_empx ) ) - ! - c0_emp = 0.0 - cm_emp = 0.0 - ! - phi_emp = 0.0d0 - - call set_twin(bec_emp,c_zero) - call set_twin(bec_occ,c_zero) - call set_twin(bephi_emp,c_zero) - call set_twin(becp_emp,c_zero) - ! - DO iss=1,nspin - call set_twin(lambda_emp(iss),c_zero) - ENDDO - - f_emp = 2.0d0 / DBLE(nspin) - ! - ispin_emp = 0 - ispin_emp( 1:nupdwn_emp( 1 ) ) = 1 - IF( nspin == 2 ) ispin_emp( iupdwn_emp(2) : ) = 2 - ! - ! - IF ( do_orbdep ) THEN - ! - ALLOCATE( fsic_emp( n_empx ) ) - ! n_empx_odd=n_empx - ALLOCATE( vsic_emp(nnrx, n_empx) ) - ALLOCATE( wxd_emp (nnrx, 2) ) - ALLOCATE( deeq_sic_emp (nhm,nhm,nat,n_empx) ) - ALLOCATE( becsum_emp(nhm*(nhm+1)/2,nat,nspin)) - CALL allocate_nksic_empty(n_empx) - sizvsic_emp=nnrx - ! - fsic_emp = 0.0d0 - vsic_emp = 0.0d0 - wxd_emp = 0.0d0 - ! - ELSE - ! - ALLOCATE( fsic_emp( n_empx ) ) - ! n_empx_odd=1 - ALLOCATE( vsic_emp(1, n_empx) ) - ALLOCATE( wxd_emp (1, 2) ) - ALLOCATE( deeq_sic_emp (nhm,nhm,nat,n_empx) ) - ALLOCATE( becsum_emp(nhm*(nhm+1)/2,nat,nspin) ) - ! - call allocate_nksic_empty(n_empx) - sizvsic_emp=1 - ! - ENDIF - ! - IF ( do_hf ) THEN - ! - !ALLOCATE( fsic_emp(n_empx ) ) - ALLOCATE( vxxpsi_emp( ngw, n_empx) ) - ALLOCATE( exx_emp( n_empx ) ) - ! - !fsic_emp = 0.0d0 - vxxpsi_emp = 0.0d0 - exx_emp = 0.0d0 - ! - ENDIF - ! - CALL prefor( eigr, vkb ) - ! - DO iss = 1, nspin - issw = iupdwn( iss ) - CALL nlsm1 ( nupdwn( iss ), 1, nvb, eigr, c0( 1:1, issw:issw ), bec_occ, iupdwn(iss), lgam ) !warning:giovanni:definition - ENDDO - ! - ! init wfcs - ! - exst = reademptyc0( c0_emp, n_empx, ndr_loc ) - ! - IF( .NOT. exst ) THEN - ! - ! ... initial random states orthogonal to filled ones - ! - IF ( .NOT. do_spinsym .OR. nspin == 1 ) THEN - ! - IF(tatomicwfc) THEN - ! - call wave_atom_init( c0_emp, n_emps, 1 ) - ! - ELSE - ! - CALL wave_rand_init( c0_emp, n_emps, 1 ) - ! - ENDIF - ! - ELSE - ! - IF ( nupdwn_emp(1) < nupdwn_emp(2) ) CALL errore('empty_cp','unexpec emp nupdwn(1) < nupdwn(2)',10) - ! - IF(tatomicwfc) THEN - ! - call wave_atom_init( c0_emp, nupdwn_emp(1), 1 ) - ! - ELSE - ! - CALL wave_rand_init( c0_emp, nupdwn_emp(1) , 1 ) - ! - ENDIF - ! - DO i = 1, MIN(nupdwn_emp(1),nupdwn_emp(2)) - ! - j=i+iupdwn_emp(2)-1 - c0_emp(:,j)=c0_emp(:,i) - ! - ENDDO - ! - IF( ionode ) write(stdout, "(24x, 'spin symmetry applied to init wave')" ) - ! - ENDIF - ! - IF ( gzero ) THEN - c0_emp( 1, : ) = (0.0d0, 0.0d0) - END IF - ! - CALL nlsm1 ( n_emps, 1, nvb, eigr, c0_emp, bec_emp, 1, lgam ) - ! - DO iss = 1, nspin - ! - in = iupdwn(iss) - in_emp = iupdwn_emp(iss) - ! - issw = iupdwn( iss ) - ! - if(nupdwn(iss)>0.and.nupdwn_emp(iss)>0) THEN - ! - CALL gram_empty( .false. , eigr, vkb, bec_emp, bec_occ, nkb, & - c0_emp( :, in_emp: ), c0( :, issw: ), ngw, nupdwn_emp(iss), nupdwn(iss), in_emp, in ) - ! - ENDIF - ! - ! - END DO - ! - END IF - ! - CALL nlsm1 ( n_emps, 1, nsp, eigr, c0_emp, bec_emp, 1, lgam ) - ! - ! ... set verlet variables - ! - IF( tsde ) THEN - fccc = 1.0d0 - ELSE - fccc = 1.0d0 / ( 1.0d0 + frice ) - END IF - ! - verl1 = 2.0d0 * fccc - verl2 = 1.0d0 - verl1 - verl3 = 1.0d0 * fccc - ! - ALLOCATE( c2( ngw ) ) - ALLOCATE( c3( ngw ) ) - ALLOCATE( emadt2( ngw ) ) - ALLOCATE( emaver( ngw ) ) - - dt2bye = delt * delt / emass - - ccc = fccc * dt2bye - emadt2 = dt2bye * ema0bg - emaver = emadt2 * verl3 - ! - cm_emp = c0_emp - - ekinc_old = 0.0 - ekinc = 0.0 - ! - ! init xd potential - ! - ! we need to use wtot from previous calls with occupied states - ! we save here wtot in wxd_emp - ! - IF ( do_orbdep ) THEN - ! - wxd_emp(:,:) = 0.0_DP - ! - IF ( do_wxd .AND. .NOT. do_pz ) THEN - ! - wxd_emp(:,:) = wtot(:,:) - ! - ENDIF - ENDIF - ! - ! - IF( ionode ) THEN - WRITE( stdout, "(/,3X,'Empty states minimization starting ', & - & /,3x,'nfi dekinc ekinc' )") - ENDIF - - IF(tcg_) THEN ! compute empty states with conjugate gradient - write(6,*) "runcg_uspp_emp subroutine not active; stopping" - stop -! call runcg_uspp_emp(c0_emp, cm_emp, bec_emp, f_emp, fsic_emp, n_empx,& -! n_emps, ispin_emp, iupdwn_emp, nupdwn_emp, phi_emp, lambda_emp, & -! max_emp, wxd_emp, vsic_emp, sizvsic_emp, pink_emp, becsum_emp, & -! deeq_sic_emp, nudx_emp, eodd_emp, etot_emp, v, & -! nfi, .true., eigr, bec, irb, eigrb, & -! rhor, ema0bg, desc_emp) - - ELSE ! compute empty states with damped dynamics - ! - done_extra=.false. - ! - ITERATIONS: DO iter = 1, max_emp - ! - IF ( do_orbdep ) THEN - ! - IF (odd_nkscalfact) THEN - ! - valpsi(:,:) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - CALL odd_alpha_routine(n_empx) - ! - ENDIF - ! - ! In the nksic case, we do not need to compute wxd here, - ! because no contribution comes from empty states. - ! - ! Instead, wxd from all occupied states is already computed - ! by the previous calls to nksic_potentials, and stored wxe_emp - ! - fsic_emp(:) = 0.0 - ! - ! the two lines below were removed by Giovanni, passing do_wxd as input to nksic_potential - !do_wxd_ = do_wxd - !do_wxd = .FALSE. - ! - IF(done_extra.or.iter==max_emp) THEN - ! - icompute_spread=.true. - ! - ENDIF - ! - ! write(6,*) "checkbounds", ubound(wfc_centers_emp), ubound(wfc_spreads_emp), nudx_emp, nspin - ! - call nksic_potential( n_emps, n_empx, c0_emp, fsic_emp, & - bec_emp, becsum_emp, deeq_sic_emp, & - ispin_emp, iupdwn_emp, nupdwn_emp, rhor, rhoc, & - wtot, sizwtot, vsic_emp, .false., pink_emp, nudx_emp, & - wfc_centers_emp, wfc_spreads_emp, & - icompute_spread, .false.) - !write(6,*) "checkbounds", ubound(wfc_centers_emp), ubound(wfc_spreads_emp), nudx_emp, nspin - - ! line below removed by Giovanni, introduced do_wxd=.false. into call to nksic_potential - !do_wxd = do_wxd_ - ! - DO i = 1, n_emps - ! - ! Here wxd_emp <-> wtot that computed from nksic_potential of occupied states. - ! wtot is scaled with nkscalfact constant, we thus need to rescaled it here with - ! odd_alpha - ! - IF(odd_nkscalfact) wxd_emp(:,:) = wxd_emp(:,:)*odd_alpha(i)/nkscalfact - ! - vsic_emp(:,i) = vsic_emp(:,i) + wxd_emp(:, ispin_emp(i)) - ! - ENDDO - ! - ! - ENDIF - ! - ! HF contribution - ! - IF ( do_hf ) THEN - ! - vxxpsi_emp = 0.0d0 - ! - CALL hf_potential( nbsp, nbspx, c0, f, ispin, iupdwn, nupdwn, & - n_emps, n_empx, c0_emp, fsic_emp, ispin_emp, & - iupdwn_emp, nupdwn_emp, rhor, rhog, vxxpsi_emp, exx_emp ) - ! - ENDIF - ! - ! standard terms - ! - DO i = 1, n_emps, 2 - ! - CALL dforce( i, bec_emp, vkb, c0_emp, c2, c3, v, SIZE(v,1), ispin_emp, f_emp, n_emps, nspin ) - ! - ! ODD terms - ! - IF ( do_orbdep ) THEN - ! - IF ( odd_nkscalfact ) THEN - ! - c2(:) = c2(:) - valpsi(i, :) * f_emp(i) - c3(:) = c3(:) - valpsi(i+1, :) * f_emp(i+1) - ! - ENDIF - ! - CALL nksic_eforce( i, n_emps, n_empx, vsic_emp, deeq_sic_emp, bec_emp, ngw, & - c0_emp(:,i), c0_emp(:,i+1), vsicpsi, lgam ) - ! - c2(:) = c2(:) - vsicpsi(:,1) * f_emp(i) - c3(:) = c3(:) - vsicpsi(:,2) * f_emp(i+1) - ! - ENDIF - ! - ! HF terms - ! - IF ( do_hf ) THEN - ! - c2(:) = c2(:) - vxxpsi_emp(:,i) * f_emp(i) - c3(:) = c3(:) - vxxpsi_emp(:,i+1) * f_emp(i+1) - ! - ENDIF - ! - IF( tsde ) THEN - CALL wave_steepest( cm_emp(:, i ), c0_emp(:, i ), emaver, c2 ) - CALL wave_steepest( cm_emp(:, i+1), c0_emp(:, i+1), emaver, c3 ) - ELSE - CALL wave_verlet( cm_emp(:, i ), c0_emp(:, i ), verl1, verl2, emaver, c2 ) - CALL wave_verlet( cm_emp(:, i+1), c0_emp(:, i+1), verl1, verl2, emaver, c3 ) - ENDIF - ! - IF(lgam) THEN - IF ( gstart == 2) THEN - cm_emp(1, i)=CMPLX(DBLE(cm_emp(1, i)),0.d0) - cm_emp(1,i+1)=CMPLX(DBLE(cm_emp(1,i+1)),0.d0) - ENDIF - ENDIF - ! - ENDDO - - DO iss = 1, nspin - ! - in = iupdwn(iss) - in_emp = iupdwn_emp(iss) - ! - issw = iupdwn( iss ) - ! - IF(nupdwn(iss)>0.and.nupdwn_emp(iss)>0) THEN - ! - CALL gram_empty( .true. , eigr, vkb, bec_emp, bec_occ, nkb, & - cm_emp( :, in_emp: ), c0( :, issw: ), ngw, nupdwn_emp(iss), nupdwn(iss), in_emp, in ) - ! - ENDIF - ! - ENDDO - ! - ! ... calphi calculates phi - ! ... the electron mass rises with g**2 - ! - CALL calphi( c0_emp, ngw, bec_emp, nkb, vkb, phi_emp, n_emps, lgam, ema0bg ) - ! - ! - IF( tortho ) THEN - ! - CALL ortho_cp_twin( eigr(1:ngw,1:nat), cm_emp(1:ngw,1:n_emps), phi_emp(1:ngw,1:n_emps), & - ngw, lambda_emp(1:nspin), desc_emp(1:descla_siz_,1:nspin), & - bigr, iter_ortho, ccc, bephi_emp, becp_emp, n_emps, nspin, & - nupdwn_emp, iupdwn_emp ) - ! - ELSE - ! - CALL gram( vkb, bec_emp, nkb, cm_emp, ngw, n_emps ) - ! - ENDIF - ! - DO iss = 1, nspin - ! - IF(.not.lambda_emp(iss)%iscmplx) THEN - CALL updatc( ccc, n_emps, lambda_emp(iss)%rvec(:,:), SIZE(lambda_emp(iss)%rvec,1), & - phi_emp, ngw, bephi_emp%rvec, nkb, becp_emp%rvec, bec_emp%rvec, & - cm_emp, nupdwn_emp(iss), iupdwn_emp(iss), desc_emp(:,iss) ) - ELSE - CALL updatc( ccc, n_emps, lambda_emp(iss)%cvec(:,:), SIZE(lambda_emp(iss)%cvec,1), & - phi_emp, ngw, bephi_emp%cvec(:,:), nkb, becp_emp%cvec(:,:), bec_emp%cvec(:,:), & - cm_emp, nupdwn_emp(iss), iupdwn_emp(iss), desc_emp(:,iss) ) - ENDIF - ! - ENDDO - ! - CALL nlsm1 ( n_emps, 1, nsp, eigr, cm_emp, bec_emp, 1, lgam ) - ! - CALL elec_fakekine( ekinc, ema0bg, emass, c0_emp, cm_emp, ngw, n_emps, 1, delt ) - ! - CALL dswap( 2*SIZE( c0_emp ), c0_emp, 1, cm_emp, 1 ) - ! - dek = ekinc - ekinc_old - ! - IF( ionode ) WRITE( stdout,113) ITER, dek, ekinc - ! - ! ... check for exit - ! - IF ( check_stop_now() ) THEN - EXIT ITERATIONS - ENDIF - - ! ... check for convergence - ! - IF( ( ekinc < ethr_emp ) .AND. ( iter > 3 ) ) THEN - IF(done_extra) THEN - IF( ionode ) WRITE( stdout,112) - EXIT ITERATIONS - ELSE - done_extra=.true. - ENDIF - ENDIF - ! - ekinc_old = ekinc - ! - ENDDO ITERATIONS - ! - ENDIF !if clause to choose between cg and damped dynamics - ! - IF ( ionode ) WRITE( stdout, "()") - ! - ! Linh: add a flag for print c0_emp cm_emp to iotk format - ! Here, we allocate the a global vars to pass c0_emp and cm_emp to - ! They will be used to print out using iotk in cp_restart. - ! - IF (print_wfc_empty) THEN - ALLOCATE (c0_emp_aux (ngw, n_empx)) - ALLOCATE (cm_emp_aux (ngw, n_empx)) - c0_emp_aux(:,:) = c0_emp(:,:) - cm_emp_aux(:,:) = cm_emp(:,:) - ENDIF - ! - ! ... Compute eigenvalues and bring wave functions on Kohn-Sham orbitals - ! - IF(.not.lambda_emp(1)%iscmplx) THEN - ALLOCATE( lambda_rep( nudx_emp, nudx_emp ) ) - ELSE - ALLOCATE( lambda_rep_c( nudx_emp, nudx_emp ) ) - ENDIF - ! - DO iss = 1, nspin - ! - i = iupdwn_emp(iss) - n = nupdwn_emp(iss) - ! - IF(.not.lambda_emp(iss)%iscmplx) THEN - CALL collect_lambda( lambda_rep, lambda_emp(iss)%rvec(:,:), desc_emp( :, iss ) ) - CALL crot( cm_emp, c0_emp, ngw, n, i, i, lambda_rep, nudx_emp, ei_emp(:,iss) ) - ELSE - CALL collect_lambda( lambda_rep_c, lambda_emp(iss)%cvec(:,:), desc_emp( :, iss ) ) - CALL crot( cm_emp, c0_emp, ngw, n, i, i, lambda_rep_c, nudx_emp, ei_emp(:,iss) ) - ENDIF - ei_emp( 1:n, iss ) = ei_emp( 1:n, iss ) / f_emp( i : i + n - 1 ) - ! - ENDDO - ! - IF(.not.lambda_emp(1)%iscmplx) THEN - DEALLOCATE( lambda_rep) - ELSE - DEALLOCATE( lambda_rep_c) - ENDIF - ! - ! ... Save emptystates to disk canonical orbitals - ! - CALL writeempty( cm_emp, n_empx, ndw_loc ) - ! - ! ... Save emptystates to disk minimizing orbitals - ! - CALL writeemptyc0( c0_emp, n_empx, ndw_loc ) - ! - DEALLOCATE( ispin_emp ) - DEALLOCATE( f_emp ) - DEALLOCATE( emadt2 ) - DEALLOCATE( emaver ) - DEALLOCATE( c2 ) - DEALLOCATE( c3 ) - DEALLOCATE( c0_emp ) - DEALLOCATE( cm_emp ) - DEALLOCATE( phi_emp ) - ! - CALL deallocate_twin(bec_emp) - CALL deallocate_twin(bec_occ) - CALL deallocate_twin(bephi_emp) - CALL deallocate_twin(becp_emp) - ! - DO iss=1,nspin - CALL deallocate_twin(lambda_emp(iss)) - ENDDO - ! - DEALLOCATE( fsic_emp ) - ! - IF ( do_orbdep ) THEN - DEALLOCATE( vsic_emp ) - DEALLOCATE( wxd_emp ) - DEALLOCATE( deeq_sic_emp ) - DEALLOCATE( becsum_emp ) - ENDIF - ! - IF ( do_hf ) THEN - DEALLOCATE( vxxpsi_emp ) - DEALLOCATE( exx_emp ) - ENDIF - -112 FORMAT(/,3X,'Empty states: convergence achieved') -113 FORMAT(I5,2X,2D14.6) - - RETURN - END SUBROUTINE empty_cp_twin_x - - -!------------------------------------------------------------------------- - SUBROUTINE gram_empty_real_x & - ( tortho, eigr, betae, bec_emp, bec_occ, nkbx, c_emp, c_occ, ngwx, n_emp, n_occ ) -!----------------------------------------------------------------------- -! gram-schmidt orthogonalization of the empty states ( c_emp ) -! c_emp are orthogonalized among themself and to the occupied states c_occ -! - USE uspp, ONLY : nkb, nkbus - USE cvan, ONLY : nvb - USE gvecw, ONLY : ngw - USE kinds, ONLY : DP - USE mp, ONLY : mp_sum - USE mp_global, ONLY : intra_image_comm - USE ions_base, ONLY : nat - USE cp_interfaces, ONLY : bec_csv, smooth_csv, grabec -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: nkbx, ngwx, n_emp, n_occ - COMPLEX(DP) :: eigr(ngwx,nat) - REAL(DP) :: bec_emp( nkbx, n_emp ) - REAL(DP) :: bec_occ( nkbx, n_occ ) - COMPLEX(DP) :: betae( ngwx, nkb ) - COMPLEX(DP) :: c_emp( ngwx, n_emp ) - COMPLEX(DP) :: c_occ( ngwx, n_occ ) - LOGICAL, INTENT(IN) :: tortho -! - REAL(DP) :: anorm, cscnorm - REAL(DP), ALLOCATABLE :: csc_emp( : ) - REAL(DP), ALLOCATABLE :: csc_occ( : ) - INTEGER :: i, k, inl - EXTERNAL cscnorm -! - ALLOCATE( csc_emp( n_emp ) ) - ALLOCATE( csc_occ( n_occ ) ) - ! - ! orthogonalize empty states to the occupied one and among each other - ! - DO i = 1, n_emp - ! - csc_emp = 0.0d0 - csc_occ = 0.0d0 - ! - ! compute scalar product csc_occ(k) = - ! - CALL smooth_csv( c_emp(1:,i), c_occ(1:,1:), ngwx, csc_occ, n_occ ) - ! - IF( .NOT. tortho ) THEN - ! - ! compute scalar product csc_emp(k) = - ! - CALL smooth_csv( c_emp(1:,i), c_emp(1:,1:), ngwx, csc_emp, i-1 ) - ! - CALL mp_sum( csc_emp, intra_image_comm ) - ! - END IF - ! - CALL mp_sum( csc_occ, intra_image_comm ) - ! - IF( nvb > 1 ) THEN - ! - CALL grabec( bec_emp(1:,i), nkbx, betae, c_emp(1:,i:), ngwx ) - ! - CALL mp_sum( bec_emp(1:nkbus,i), intra_image_comm ) - ! - CALL bec_csv( bec_emp(1:,i), bec_occ, nkbx, csc_occ, n_occ ) - ! - IF( .NOT. tortho ) THEN - CALL bec_csv( bec_emp(1:,i), bec_emp, nkbx, csc_emp, i-1 ) - END IF - ! - DO k = 1, n_occ - DO inl = 1, nkbx - bec_emp( inl, i ) = bec_emp( inl, i ) - csc_occ(k) * bec_occ( inl, k ) - END DO - END DO - ! - IF( .NOT. tortho ) THEN - DO k = 1, i-1 - DO inl = 1, nkbx - bec_emp( inl, i ) = bec_emp( inl, i ) - csc_emp(k) * bec_emp( inl, k ) - END DO - END DO - END IF - ! - END IF - ! - ! calculate orthogonalized c_emp(i) : |c_emp(i)> = |c_emp(i)> - SUM_k csv(k)|c_occ(k)> - ! c_emp(i) : |c_emp(i)> = |c_emp(i)> - SUM_k - ! - DO k = 1, n_occ - CALL DAXPY( 2*ngw, -csc_occ(k), c_occ(1,k), 1, c_emp(1,i), 1 ) - END DO - IF( .NOT. tortho ) THEN - DO k = 1, i - 1 - CALL DAXPY( 2*ngw, -csc_emp(k), c_emp(1,k), 1, c_emp(1,i), 1 ) - END DO - END IF - ! - ! - IF( .NOT. tortho ) THEN - anorm = cscnorm( bec_emp, nkbx, c_emp, ngwx, i, n_emp ) - ! - CALL DSCAL( 2*ngw, 1.0d0/anorm, c_emp(1,i), 1 ) - ! - IF( nvb > 1 ) THEN - CALL DSCAL( nkbx, 1.0d0/anorm, bec_emp(1,i), 1 ) - END IF - END IF - ! - END DO - - DEALLOCATE( csc_emp ) - DEALLOCATE( csc_occ ) - ! - RETURN - END SUBROUTINE gram_empty_real_x - -!------------------------------------------------------------------------- - SUBROUTINE gram_empty_twin_x & - ( tortho, eigr, betae, bec_emp, bec_occ, nkbx, c_emp, c_occ, ngwx, n_emp, n_occ, l_emp, l_occ ) -!----------------------------------------------------------------------- -! -! gram-schmidt orthogonalization of the empty states ( c_emp ) -! c_emp are orthogonalized among themself and to the occupied states c_occ -! - USE uspp, ONLY : nkb, nkbus - USE cvan, ONLY : nvb - USE gvecw, ONLY : ngw - USE kinds, ONLY : DP - USE mp, ONLY : mp_sum - USE mp_global, ONLY : intra_image_comm - USE ions_base, ONLY : nat - USE control_flags, ONLY : gamma_only, do_wf_cmplx !added:giovanni - USE cp_interfaces, ONLY : grabec, smooth_csv,bec_csv - USE twin_types -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: nkbx, ngwx, n_emp, n_occ, l_emp, l_occ - COMPLEX(DP) :: eigr(ngwx,nat) - type(twin_matrix) :: bec_emp !( nkbx, n_emp ) - type(twin_matrix) :: bec_occ !( nkbx, n_occ ) - COMPLEX(DP) :: betae( ngwx, nkb ) - COMPLEX(DP) :: c_emp( ngwx, n_emp ) - COMPLEX(DP) :: c_occ( ngwx, n_occ ) - LOGICAL, INTENT(IN) :: tortho -! - REAL(DP) :: anorm, cscnorm - type(twin_matrix) :: csc_emp, csc_occ -! COMPLEX(DP), ALLOCATABLE :: csc_emp!( : ) -! COMPLEX(DP), ALLOCATABLE :: csc_occ !( : ) - INTEGER :: i, k, inl - LOGICAL :: lgam - EXTERNAL cscnorm - - lgam=gamma_only.and..not.do_wf_cmplx - - !Quick return if there are either no filled or no empty states with this spin (no need to orthogonalize them) - IF(n_emp.le.0.or.n_occ.le.0) THEN - ! - return - ! - ENDIF - - call init_twin(csc_emp, lgam) - call allocate_twin(csc_emp, n_emp, 1, lgam) - - call init_twin(csc_occ, lgam) - call allocate_twin(csc_occ, n_occ, 1, lgam) - ! - ! orthogonalize empty states to the occupied one and among each other - ! - DO i = 1, n_emp - ! - call set_twin(csc_emp, CMPLX(0.d0,0.d0)) - call set_twin(csc_occ, CMPLX(0.d0,0.d0)) - ! - ! compute scalar product csc_occ(k) = .. is it ? Yes! watch out! - ! - CALL smooth_csv( c_emp(1:ngwx,i), c_occ(1:ngwx,1:n_occ), ngwx, csc_occ, n_occ ) - ! - ! - IF( .NOT. tortho ) THEN - ! - ! compute scalar product csc_emp(k) = - ! - CALL smooth_csv( c_emp(1:,i), c_emp(1:,1:), ngwx, csc_emp, i-1 ) - ! - IF(.not.csc_emp%iscmplx) THEN - CALL mp_sum( csc_emp%rvec(1:n_emp,1:1), intra_image_comm ) - ELSE - CALL mp_sum( csc_emp%cvec(1:n_emp,1:1), intra_image_comm ) - ENDIF - ! - ENDIF - ! - IF(.not.csc_occ%iscmplx) THEN - CALL mp_sum( csc_occ%rvec(1:n_occ,1:1), intra_image_comm ) - ELSE - CALL mp_sum( csc_occ%cvec(1:n_occ, 1:1), intra_image_comm ) - ENDIF - ! - IF( nvb > 1 ) THEN - ! - CALL grabec( bec_emp, nkbx, betae, c_emp(1:,i:), ngwx,i ) - ! - IF(.not. bec_emp%iscmplx) THEN - CALL mp_sum( bec_emp%rvec(1:nkbus,i), intra_image_comm ) - ELSE - CALL mp_sum( bec_emp%cvec(1:nkbus,i), intra_image_comm ) - ENDIF - ! - CALL bec_csv( bec_emp, bec_occ, nkbx, csc_occ, n_occ, i ) - ! - IF( .NOT. tortho ) THEN - CALL bec_csv( bec_emp, bec_emp, nkbx, csc_emp, i-1, i ) - END IF - ! - IF(.not.bec_emp%iscmplx) THEN - ! - DO k = 1, n_occ - DO inl = 1, nkbx - bec_emp%rvec( inl, i ) = bec_emp%rvec( inl, i ) - csc_occ%rvec(k,1) * bec_occ%rvec( inl, k ) - ENDDO - ENDDO - ! - ELSE - ! - DO k = 1, n_occ - DO inl = 1, nkbx - bec_emp%cvec( inl, i ) = bec_emp%cvec( inl, i ) - CONJG(csc_occ%cvec(k,1)) * bec_occ%cvec( inl, k ) - ENDDO - ENDDO - ! - ENDIF - ! - IF( .NOT. tortho ) THEN - IF(.not.bec_emp%iscmplx) THEN - DO k = 1, i-1 - DO inl = 1, nkbx - bec_emp%rvec( inl, i ) = bec_emp%rvec( inl, i ) - csc_emp%rvec(k,1) * bec_emp%rvec( inl, k ) - END DO - END DO - ELSE - DO k = 1, i-1 - DO inl = 1, nkbx - bec_emp%cvec( inl, i ) = bec_emp%cvec( inl, i ) - CONJG(csc_emp%cvec(k,1)) * bec_emp%cvec( inl, k ) - END DO - END DO - ENDIF - END IF - ! - END IF - ! - ! calculate orthogonalized c_emp(i) : |c_emp(i)> = |c_emp(i)> - SUM_k csv(k)|c_occ(k)> - ! c_emp(i) : |c_emp(i)> = |c_emp(i)> - SUM_k - ! - IF(.not.csc_occ%iscmplx) THEN - DO k = 1, n_occ - CALL DAXPY( 2*ngw, -csc_occ%rvec(k,1), c_occ(1,k), 1, c_emp(1,i), 1 )!warning:giovanni tochange - END DO - IF( .NOT. tortho ) THEN - DO k = 1, i - 1 - CALL DAXPY( 2*ngw, -csc_emp%rvec(k,1), c_emp(1,k), 1, c_emp(1,i), 1 )!warning:giovanni tochange - END DO - END IF - ELSE - DO k = 1, n_occ - CALL ZAXPY( ngw, -csc_occ%cvec(k,1), c_occ(1,k), 1, c_emp(1,i), 1 ) - END DO - IF( .NOT. tortho ) THEN - DO k = 1, i - 1 - CALL ZAXPY( ngw, -csc_emp%cvec(k,1), c_emp(1,k), 1, c_emp(1,i), 1 ) - END DO - END IF - ENDIF - ! - ! - IF( .NOT. tortho ) THEN - anorm = cscnorm( bec_emp, nkbx, c_emp, ngwx, i, n_emp, lgam) - IF(.not.bec_emp%iscmplx) THEN - ! - CALL DSCAL( 2*ngw, 1.0d0/anorm, c_emp(1,i), 1 ) - ! - IF( nvb > 1 ) THEN - CALL DSCAL( nkbx, 1.0d0/anorm, bec_emp%rvec(1,i), 1 ) - END IF - ELSE -! anorm = cscnorm( bec_emp, nkbx, c_emp, ngwx, i, n_emp, lgam) - ! - CALL ZSCAL( ngw, CMPLX(1.0d0/anorm,0.d0), c_emp(1,i), 1 ) - ! - IF( nvb > 1 ) THEN - CALL ZSCAL( nkbx, CMPLX(1.0d0/anorm,0.d0), bec_emp%cvec(1,i), 1 ) - END IF - ENDIF - END IF - ! - END DO - ! - call deallocate_twin( csc_emp ) - call deallocate_twin( csc_occ ) - ! - RETURN - END SUBROUTINE gram_empty_twin_x - -!----------------------------------------------------------------------- - LOGICAL FUNCTION readempty_x( c_emp, ne, ndi ) -!----------------------------------------------------------------------- - - ! ... This subroutine reads empty states from unit emptyunit - - USE kinds, ONLY: DP - USE mp_global, ONLY: me_image, nproc_image, intra_image_comm - USE io_global, ONLY: stdout, ionode, ionode_id - USE mp, ONLY: mp_bcast, mp_sum - USE mp_wave, ONLY: splitwf - USE io_files, ONLY: outdir, prefix - USE io_files, ONLY: empty_file, emptyunit - USE reciprocal_vectors, ONLY: ig_l2g - USE gvecw, ONLY: ngw - !USE control_flags, ONLY: ndr - USE xml_io_base, ONLY: restart_dir, wfc_filename - - IMPLICIT none - - COMPLEX(DP), INTENT(OUT) :: c_emp(:,:) - INTEGER, INTENT(IN) :: ne - INTEGER, INTENT(IN) :: ndi - - LOGICAL :: exst - INTEGER :: ierr, ig, i, iss - INTEGER :: ngw_rd, ne_rd, ngw_l - INTEGER :: ngw_g - - CHARACTER(LEN=256) :: fileempty, dirname - - COMPLEX(DP), ALLOCATABLE :: ctmp(:) - ! - ! ... Subroutine Body - ! - ngw_g = ngw - ngw_l = ngw - ! - CALL mp_sum( ngw_g, intra_image_comm ) - ! - ALLOCATE( ctmp(ngw_g) ) - ! - dirname = restart_dir( outdir, ndi ) - fileempty = TRIM( wfc_filename( dirname, 'evctot_empty', 1 ) ) - ! - IF ( ionode ) THEN - - INQUIRE( FILE = TRIM(fileempty), EXIST = EXST ) - - IF ( EXST ) THEN - ! - OPEN( UNIT=emptyunit, FILE=TRIM(fileempty), STATUS='OLD', FORM='UNFORMATTED' ) - ! - READ(emptyunit) ngw_rd, ne_rd - ! - IF( ne > ne_rd ) THEN - EXST = .false. - WRITE( stdout,10) TRIM(fileempty) - WRITE( stdout,20) ngw_rd, ne_rd - WRITE( stdout,20) ngw_g, ne - END IF - ! - END IF - - END IF - - 10 FORMAT('*** EMPTY STATES : wavefunctions dimensions changed ', A ) - 20 FORMAT('*** NGW = ', I8, ' NE = ', I4) - - CALL mp_bcast(exst, ionode_id, intra_image_comm) - CALL mp_bcast(ne_rd, ionode_id, intra_image_comm) - CALL mp_bcast(ngw_rd, ionode_id, intra_image_comm) - - IF ( exst ) THEN - - DO i = 1, MIN( ne, ne_rd ) - IF ( ionode ) THEN - READ(emptyunit) ( ctmp(ig), ig = 1, MIN( SIZE(ctmp), ngw_rd ) ) - END IF - IF( i <= ne ) THEN - CALL splitwf(c_emp(:,i), ctmp, ngw_l, ig_l2g, me_image, & - nproc_image, ionode_id, intra_image_comm) - END IF - END DO - - END IF - - IF ( ionode .AND. EXST ) THEN - CLOSE(emptyunit) - END IF - - readempty_x = exst - DEALLOCATE(ctmp) - - RETURN - END FUNCTION readempty_x - - -!----------------------------------------------------------------------- - SUBROUTINE writeempty_x( c_emp, ne, ndi ) -!----------------------------------------------------------------------- - - ! ... This subroutine writes empty states to unit emptyunit - - USE kinds, ONLY: DP - USE mp_global, ONLY: me_image, nproc_image, intra_image_comm - USE mp_wave, ONLY: mergewf - USE mp, ONLY: mp_sum - USE io_files, ONLY: empty_file, emptyunit, outdir, prefix - USE io_global, ONLY: ionode, ionode_id, stdout - USE reciprocal_vectors, ONLY: ig_l2g - USE gvecw, ONLY: ngw - !USE control_flags, ONLY: ndw - USE xml_io_base, ONLY: restart_dir, wfc_filename - USE wrappers, ONLY: f_mkdir - ! - IMPLICIT NONE - - COMPLEX(DP), INTENT(IN) :: c_emp(:,:) - INTEGER, INTENT(IN) :: ne - INTEGER, INTENT(IN) :: ndi - - INTEGER :: ig, i, ngw_g, iss, ngw_l - LOGICAL :: exst, ierr - COMPLEX(DP), ALLOCATABLE :: ctmp(:) - CHARACTER(LEN=256) :: fileempty, dirname - ! - ! ... Subroutine Body - ! - ngw_g = ngw - ngw_l = ngw - ! - CALL mp_sum( ngw_g, intra_image_comm ) - ! - ALLOCATE( ctmp( ngw_g ) ) - ! - dirname = restart_dir( outdir, ndi ) - fileempty = TRIM( wfc_filename( dirname, 'evctot_empty', 1 ) ) - ! - ierr = f_mkdir( TRIM(dirname)//"/K00001" ) - ! - IF( ionode ) THEN - OPEN( UNIT = emptyunit, FILE = TRIM(fileempty), status = 'unknown', FORM = 'UNFORMATTED' ) - REWIND( emptyunit ) - WRITE (emptyunit) ngw_g, ne - END IF - - 10 FORMAT('*** EMPTY STATES : writing wavefunctions ', A ) - 20 FORMAT('*** NGW = ', I8, ' NE = ', I4) - - DO i = 1, ne - ctmp = 0.0d0 - CALL MERGEWF( c_emp(:,i), ctmp(:), ngw_l, ig_l2g, me_image, & - nproc_image, ionode_id, intra_image_comm ) - IF( ionode ) THEN - WRITE (emptyunit) ( ctmp(ig), ig=1, ngw_g ) - END IF - END DO - - IF( ionode ) THEN - CLOSE (emptyunit) - END IF - - DEALLOCATE(ctmp) - - RETURN - END SUBROUTINE writeempty_x - -!----------------------------------------------------------------------- - LOGICAL FUNCTION reademptyc0_x( c_emp, ne, ndi ) -!----------------------------------------------------------------------- - - ! ... This subroutine reads empty states from unit emptyunitc0 - - USE kinds, ONLY: DP - USE mp_global, ONLY: me_image, nproc_image, intra_image_comm - USE io_global, ONLY: stdout, ionode, ionode_id - USE mp, ONLY: mp_bcast, mp_sum - USE mp_wave, ONLY: splitwf - USE io_files, ONLY: outdir, prefix - USE io_files, ONLY: empty_file, emptyunitc0 - USE reciprocal_vectors, ONLY: ig_l2g - USE gvecw, ONLY: ngw - !USE control_flags, ONLY: ndr - USE xml_io_base, ONLY: restart_dir, wfc_filename - - IMPLICIT none - - COMPLEX(DP), INTENT(OUT) :: c_emp(:,:) - INTEGER, INTENT(IN) :: ne - INTEGER, INTENT(IN) :: ndi - - LOGICAL :: exst - INTEGER :: ierr, ig, i, iss - INTEGER :: ngw_rd, ne_rd, ngw_l - INTEGER :: ngw_g - - CHARACTER(LEN=256) :: fileempty, dirname - - COMPLEX(DP), ALLOCATABLE :: ctmp(:) - ! - ! ... Subroutine Body - ! - ngw_g = ngw - ngw_l = ngw - ! - CALL mp_sum( ngw_g, intra_image_comm ) - ! - ALLOCATE( ctmp(ngw_g) ) - ! - dirname = restart_dir( outdir, ndi ) - fileempty = TRIM( wfc_filename( dirname, 'evc0_empty', 1 ) ) - ! - IF ( ionode ) THEN - - INQUIRE( FILE = TRIM(fileempty), EXIST = EXST ) - - IF ( EXST ) THEN - ! - OPEN( UNIT=emptyunitc0, FILE=TRIM(fileempty), STATUS='OLD', FORM='UNFORMATTED' ) - ! - READ(emptyunitc0) ngw_rd, ne_rd - ! - IF( ne > ne_rd ) THEN - EXST = .false. - WRITE( stdout,10) TRIM(fileempty) - WRITE( stdout,20) ngw_rd, ne_rd - WRITE( stdout,20) ngw_g, ne - END IF - ! - END IF - - END IF - - 10 FORMAT('*** EMPTY STATES : wavefunctions dimensions changed ', A ) - 20 FORMAT('*** NGW = ', I8, ' NE = ', I4) - - CALL mp_bcast(exst, ionode_id, intra_image_comm) - CALL mp_bcast(ne_rd, ionode_id, intra_image_comm) - CALL mp_bcast(ngw_rd, ionode_id, intra_image_comm) - - IF ( exst ) THEN - - DO i = 1, MIN( ne, ne_rd ) - IF ( ionode ) THEN - READ(emptyunitc0) ( ctmp(ig), ig = 1, MIN( SIZE(ctmp), ngw_rd ) ) - END IF - IF( i <= ne ) THEN - CALL splitwf(c_emp(:,i), ctmp, ngw_l, ig_l2g, me_image, & - nproc_image, ionode_id, intra_image_comm) - END IF - END DO - - END IF - - IF ( ionode .AND. EXST ) THEN - CLOSE(emptyunitc0) - END IF - - reademptyc0_x = exst - DEALLOCATE(ctmp) - - RETURN - END FUNCTION reademptyc0_x - - -!----------------------------------------------------------------------- - SUBROUTINE writeemptyc0_x( c_emp, ne, ndi ) -!----------------------------------------------------------------------- - - ! ... This subroutine writes empty states to unit emptyunitc0 - - USE kinds, ONLY: DP - USE mp_global, ONLY: me_image, nproc_image, intra_image_comm - USE mp_wave, ONLY: mergewf - USE mp, ONLY: mp_sum - USE io_files, ONLY: empty_file, emptyunitc0, outdir, prefix - USE io_global, ONLY: ionode, ionode_id, stdout - USE reciprocal_vectors, ONLY: ig_l2g - USE gvecw, ONLY: ngw - !USE control_flags, ONLY: ndw - USE xml_io_base, ONLY: restart_dir, wfc_filename - USE wrappers, ONLY: f_mkdir - ! - IMPLICIT NONE - - COMPLEX(DP), INTENT(IN) :: c_emp(:,:) - INTEGER, INTENT(IN) :: ne - INTEGER, INTENT(IN) :: ndi - - INTEGER :: ig, i, ngw_g, iss, ngw_l - LOGICAL :: exst, ierr - COMPLEX(DP), ALLOCATABLE :: ctmp(:) - CHARACTER(LEN=256) :: fileempty, dirname - ! - ! ... Subroutine Body - ! - ngw_g = ngw - ngw_l = ngw - ! - CALL mp_sum( ngw_g, intra_image_comm ) - ! - ALLOCATE( ctmp( ngw_g ) ) - ! - dirname = restart_dir( outdir, ndi ) - fileempty = TRIM( wfc_filename( dirname, 'evc0_empty', 1 ) ) - ! - ierr = f_mkdir( TRIM(dirname)//"/K00001" ) - ! - IF( ionode ) THEN - OPEN( UNIT = emptyunitc0, FILE = TRIM(fileempty), status = 'unknown', FORM = 'UNFORMATTED' ) - REWIND( emptyunitc0 ) - WRITE (emptyunitc0) ngw_g, ne - ! WRITE( stdout,10) TRIM(fileempty) - ! WRITE( stdout,20) ngw_g, ne - END IF - - 10 FORMAT('*** EMPTY STATES : writing wavefunctions ', A ) - 20 FORMAT('*** NGW = ', I8, ' NE = ', I4) - - DO i = 1, ne - ctmp = 0.0d0 - CALL MERGEWF( c_emp(:,i), ctmp(:), ngw_l, ig_l2g, me_image, & - nproc_image, ionode_id, intra_image_comm ) - IF( ionode ) THEN - WRITE (emptyunitc0) ( ctmp(ig), ig=1, ngw_g ) - END IF - END DO - - IF( ionode ) THEN - CLOSE (emptyunitc0) - END IF - - DEALLOCATE(ctmp) - - RETURN - END SUBROUTINE writeemptyc0_x diff --git a/quantum_espresso/kcp/CPV/ensemble_dft.f90 b/quantum_espresso/kcp/CPV/ensemble_dft.f90 deleted file mode 100644 index 7e215c8b8..000000000 --- a/quantum_espresso/kcp/CPV/ensemble_dft.f90 +++ /dev/null @@ -1,361 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -MODULE ensemble_dft - - USE kinds, ONLY: DP - USE twin_types !added:giovanni - - IMPLICIT NONE - SAVE - - logical :: tsmear = .false. ! smearing - logical :: tuseocc = .true. ! use occupations when applying the forces - ! - logical :: tens = .false. ! whether to do ensemble calculations. - logical :: tgrand = .false. ! whether to do grand canonical - ! ensemble calculations. - integer :: ninner = 0 ! number of inner loops per CP step. - integer :: nfroz_occ = 25 ! number of steps with frozen occupations - integer :: ismear = 2 ! type of smearing: - ! 1 => gaussian - ! 2 => fermi-dirac - ! 3 => hermite-delta_function - ! 4 => gaussian splines - ! 5 => cold smearing i - ! 6 => cold smearing ii - real(DP) :: etemp = 0 ! smearing temperature. - real(DP) :: ef = 0 ! Fermi energy (relevant if tgrand=.true.). - - integer :: niter_cold_restart !frequency for accuarate cold smearing (in iterations) - real(DP) :: lambda_cold !step for cold smearing for not accurate iterations - -!***ensemble-DFT -! real(DP), allocatable:: z0t(:,:,:) ! transpose of z0 - type(twin_matrix), dimension(:), allocatable :: z0t - complex(DP), allocatable:: c0diag(:,:) - type(twin_matrix):: becdiag!(:,:) !modified:giovanni - real(DP), allocatable:: e0(:) - type(twin_matrix), dimension(:), allocatable :: fmat0 !modified:giovanni - real(DP), allocatable:: fmat0_diag(:) - logical :: fmat0_diag_set = .FALSE. - real(DP) :: gibbsfe -! variables for cold-smearing - type(twin_matrix), dimension(:), allocatable :: psihpsi !modified:giovanni -CONTAINS - - - SUBROUTINE compute_entropy( entropy, f, nspin ) - implicit none - real(DP), intent(out) :: entropy - real(DP), intent(in) :: f - integer, intent(in) :: nspin - real(DP) :: f2 - entropy=0.0d0 - if ((f.gt.1.0d-20).and.(f.lt.(2.0/DBLE(nspin)-1.0d-20))) then - f2=DBLE(nspin)*f/2.0d0 - entropy=-f2*log(f2)-(1.d0-f2)*log(1.d0-f2) - end if - entropy=-etemp*2.0d0*entropy/DBLE(nspin) - END SUBROUTINE compute_entropy - - - SUBROUTINE compute_entropy2( entropy, f, n, nspin ) - implicit none - real(DP), intent(out) :: entropy - real(DP), intent(in) :: f(:) - integer, intent(in) :: n, nspin - real(DP) :: f2 - integer :: i - entropy=0.0d0 - do i=1,n - if ((f(i).gt.1.0d-20).and.(f(i).lt.(2.0/DBLE(nspin)-1.0d-20))) then - f2=DBLE(nspin)*f(i)/2.0d0 - entropy=entropy-f2*log(f2)-(1.d0-f2)*log(1.d0-f2) - end if - end do - entropy=-etemp*2.0d0*entropy/DBLE(nspin) - return - END SUBROUTINE compute_entropy2 - - - SUBROUTINE compute_entropy_der( ex, fx, n, nspin ) - implicit none - real(DP), intent(out) :: ex(:) - real(DP), intent(in) :: fx(:) - integer, intent(in) :: n, nspin - real(DP) :: xx - integer :: i - ! calculation of the entropy derivative at x - do i=1,n - if ((fx(i).gt.1.0d-200).and.(fx(i).lt.(2.0/DBLE(nspin)-1.0d-200))) then - ex(i)=(log((2.0d0/DBLE(nspin)-fx(i))/fx(i))) - else if (fx(i).le.1.0d-200) then - xx=1.0d-200 - ex(i)=log(2.0d0/DBLE(nspin)/xx-1) - else - ! the calculation of ex_i is done using ex_i=-log(mf/(1-f_i)-1) - ! instead of ex_i=log(mf/f_i-1) - ! to avoid numerical errors - xx=1.0d-200 - ex(i)=-log(2.0d0/DBLE(nspin)/xx-1) - end if - end do - - return - END SUBROUTINE compute_entropy_der - - - - SUBROUTINE id_matrix_init( descla, nspin ) - ! initialization of the matrix identity - USE descriptors, ONLY: lambda_node_ , la_npc_ , la_npr_ , descla_siz_ , & - la_comm_ , la_me_ , la_nrl_ - USE twin_types - IMPLICIT NONE - INTEGER, INTENT(IN) :: nspin - INTEGER, INTENT(IN) :: descla( descla_siz_ , nspin ) - INTEGER :: is, i, ii - INTEGER :: np, me - COMPLEX(DP), PARAMETER :: c_zero = CMPLX(0.d0,0.d0) - - do is=1,nspin - call set_twin(z0t(is), c_zero) - enddo - - do is = 1, nspin - np = descla( la_npc_ , is ) * descla( la_npr_ , is ) - me = descla( la_me_ , is ) - IF( descla( lambda_node_ , is ) > 0 ) THEN - ii = me + 1 - DO i = 1, descla( la_nrl_ , is ) - IF(.not.z0t(is)%iscmplx) THEN - z0t(is)%rvec( i, ii) = 1.d0 - ELSE - z0t(is)%cvec( i, ii) = 1.d0 - ENDIF - ii = ii + np - END DO - END IF - end do - RETURN - END SUBROUTINE id_matrix_init - - - SUBROUTINE h_matrix_init( descla, nspin ) - ! initialization of the psihpsi matrix - USE descriptors, ONLY: lambda_node_ , nlar_ , la_myr_ , la_myc_ - USE twin_types - IMPLICIT NONE - INTEGER, INTENT(IN) :: nspin - INTEGER, INTENT(IN) :: descla(:,:) - INTEGER :: is, i, nr - COMPLEX(DP), PARAMETER :: czero = CMPLX(0.d0,0.d0) - - do is=1,nspin - call set_twin(psihpsi(is), czero) - enddo - - do is = 1, nspin - IF( descla( lambda_node_ , is ) > 0 ) THEN - ! - nr = descla( nlar_ , is ) - ! -! IF( descla( la_myr_ , is ) == descla( la_myc_ , is ) ) THEN - IF(.not.psihpsi(is)%iscmplx) THEN - DO i = 1, nr - psihpsi(is)%rvec(i,i) = 1.0d0 - END DO - ELSE - DO i = 1, nr - psihpsi(is)%cvec(i,i) = CMPLX(1.0d0,0.d0) - END DO - ENDIF -! END IF - END IF - end do - RETURN - END SUBROUTINE h_matrix_init - - - - SUBROUTINE ensemble_initval & - ( occupations_ , n_inner_ , fermi_energy_ ,niter_cold_restart_, lambda_cold_, rotmass_ , occmass_ , rotation_damping_ , & - occupation_damping_ , occupation_dynamics_ , rotation_dynamics_ , degauss_ , smearing_) - - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: occupations_ - CHARACTER(LEN=*), INTENT(IN) :: rotation_dynamics_ - CHARACTER(LEN=*), INTENT(IN) :: occupation_dynamics_ - CHARACTER(LEN=*), INTENT(IN) :: smearing_ - INTEGER, INTENT(IN) :: n_inner_ - REAL(DP), INTENT(IN) :: fermi_energy_ , rotmass_ , occmass_ , rotation_damping_ - REAL(DP), INTENT(IN) :: occupation_damping_ , degauss_ - INTEGER, INTENT(in) :: niter_cold_restart_ - REAL(DP), INTENT(in) :: lambda_cold_ - - SELECT CASE ( TRIM( occupations_ ) ) - ! - CASE ('bogus') - ! - CASE ('from_input') - ! - CASE ('fixed','smearing') - ! - CASE ('grand-canonical','g-c','gc') - ! - tens =.true. - tgrand =.true. - CALL errore(' ensemble_initval ','grand-canonical not yet implemented ', 1 ) - ! - CASE ('ensemble','ensemble-dft','edft') - ! - tens =.true. - ninner = n_inner_ - etemp = degauss_ - ef = fermi_energy_ - niter_cold_restart = niter_cold_restart_ - lambda_cold = lambda_cold_ - - SELECT CASE ( TRIM( smearing_ ) ) - CASE ( 'gaussian','g' ) - ismear = 1 - CASE ( 'fermi-dirac','f-d', 'fd' ) - ismear = 2 - CASE ( 'hermite-delta','h-d','hd' ) - ismear = 3 - CASE ( 'gaussian-splines','g-s','gs' ) - ismear = 4 - CASE ( 'cold-smearing','c-s','cs','cs1' ) - ismear = 5 - CASE ( 'marzari-vanderbilt','m-v','mv','cs2' ) - ismear = 6 - CASE ( '0') - ismear = 0 - CASE ( '-1') - ismear = -1 - CASE DEFAULT - CALL errore(' ensemble_initval ',' smearing not implemented', 1 ) - END SELECT - ! - CASE DEFAULT - ! - CALL errore(' ensemble_initval ',' occupation method not implemented', 1 ) - ! - END SELECT - - IF(tens) CALL ensemble_dft_info() - - RETURN - END SUBROUTINE ensemble_initval - - - SUBROUTINE ensemble_dft_info() - USE io_global, ONLY: stdout - write(stdout,250) tens - write(stdout,252) tgrand -250 format (4x,' ensemble-DFT calculation =',l5) -252 format (4x,' grand-canonical calculation =',l5) - - if(tens) then - write (stdout,251) ninner,etemp,ismear,ef - endif -251 format (/4x,'=====================================' & - & /4x,'| ensemble-DFT parameters |' & - & /4x,'=====================================' & - & /4x,'| ninner =',i10,' |' & - & /4x,'| etemp =',f10.5,' a.u. |' & - & /4x,'| ismear =',i10,' |' & - & /4x,'| fermi energy =',f10.5,' a.u. |' & - & /4x,'=====================================') - - if(tens.and. ismear /= 2) then - write(stdout,*) 'Full inner-cycle every: ', niter_cold_restart, ' Iterations' - write(stdout, *) 'With step :', lambda_cold - endif - - RETURN - END SUBROUTINE ensemble_dft_info - - SUBROUTINE allocate_ensemble_dft( nhsa, n, ngw, nudx, nspin, nx, nnrsx, nat, nlax, nrlx , lgam) - IMPLICIT NONE - INTEGER, INTENT(IN) :: nhsa, n, ngw, nudx, nspin, nx, nnrsx, nat, nlax, nrlx - LOGICAL, INTENT(IN) :: lgam - ! - INTEGER :: ispin - ! -! write(6,*) "allocating ensemble_dft", lgam - allocate(c0diag(ngw,nx)) -! allocate(z0t(nrlx,nudx,nspin)) -! allocate(becdiag(nhsa,n)) - allocate(e0(nx)) - allocate(fmat0_diag(nx)) - - call init_twin(becdiag, lgam) - call allocate_twin(becdiag,nhsa,n, lgam) - - allocate(fmat0(nspin)) - allocate(psihpsi(nspin)) - allocate(z0t(nspin)) - - do ispin=1,nspin - call init_twin(fmat0(ispin), lgam) - call allocate_twin(fmat0(ispin),nrlx,nudx, lgam) - call init_twin(psihpsi(ispin), lgam) - call allocate_twin(psihpsi(ispin),nlax,nlax, lgam) - call init_twin(z0t(ispin), lgam) - call allocate_twin(z0t(ispin),nrlx,nudx, lgam) - enddo - !end_added:giovanni - ! - fmat0_diag(:) = 0.0 - RETURN - END SUBROUTINE allocate_ensemble_dft - - SUBROUTINE deallocate_ensemble_dft( ) - IMPLICIT NONE - INTEGER :: ispin - IF( ALLOCATED( c0diag ) ) deallocate(c0diag ) - call deallocate_twin(becdiag) - ! - IF(allocated(fmat0)) THEN - ! - do ispin=1,size(fmat0) - ! - call deallocate_twin(fmat0(ispin)) - ! - enddo - ! - deallocate(fmat0) - ! - ENDIF - ! - IF(allocated(psihpsi)) THEN - ! - do ispin=1,size(psihpsi) - ! - call deallocate_twin(psihpsi(ispin)) - call deallocate_twin(z0t(ispin)) - ! -! IF(ionode) THEN -! write(6,*) "debug3" -! ENDIF - ! - enddo - ! - deallocate(psihpsi) - deallocate(z0t) - ! - ENDIF - !end_modified:giovanni - IF( ALLOCATED( e0 ) ) deallocate(e0 ) - IF( ALLOCATED( fmat0_diag ) ) deallocate(fmat0_diag ) - RETURN - END SUBROUTINE deallocate_ensemble_dft - - -END MODULE ensemble_dft diff --git a/quantum_espresso/kcp/CPV/entropy.f90 b/quantum_espresso/kcp/CPV/entropy.f90 deleted file mode 100644 index bd1e01abc..000000000 --- a/quantum_espresso/kcp/CPV/entropy.f90 +++ /dev/null @@ -1,66 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! AB INITIO COSTANT PRESSURE MOLECULAR DYNAMICS -! ---------------------------------------------- -! Car-Parrinello Parallel Program -! Carlo Cavazzoni - Gerardo Ballabio -! SISSA, Trieste, Italy - 1997-99 -! Last modified: Tue Nov 30 10:59:55 MET 1999 -! ---------------------------------------------- -! BEGIN manual - - SUBROUTINE entropy(f,temp,nx,ent) - -! this routine computes the entropic contribution due to the finite -! temperature assigned to electrons when computing occupation numbers -! ---------------------------------------------- -! END manual - - USE kinds - IMPLICIT NONE - -! ... declare subroutine arguments - INTEGER nx - REAL(DP) f(nx),temp,ent - -! ... declare other variables - INTEGER i - REAL(DP) fm - REAL(DP), PARAMETER :: eps = 1.0d-10 - -! end of declarations -! ---------------------------------------------- - - ent=0.d0 - DO i=1,nx - fm=0.5d0*f(i) - ent = ent+ fm*log(eps+fm)+(1.d0-fm)*log(eps+1.d0-fm) - END DO - ent=-2.d0*temp*ent - - RETURN - END SUBROUTINE entropy - - subroutine entropy_s(f,temp,nx,ent) - use kinds - implicit none - integer nx - integer i - real(DP) f(nx),temp,ent, fm,eps - parameter(eps=1.d-10) - - ent=0.d0 - do i=1,nx - fm=0.5d0*f(i) - ent = ent+ fm*log(eps+fm)+(1.d0-fm)*log(eps+1.d0-fm) - enddo - ent=-2.d0*temp*ent - - return - end subroutine entropy_s - diff --git a/quantum_espresso/kcp/CPV/environment.f90 b/quantum_espresso/kcp/CPV/environment.f90 deleted file mode 100644 index 3968802fc..000000000 --- a/quantum_espresso/kcp/CPV/environment.f90 +++ /dev/null @@ -1,196 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!==-----------------------------------------------------------------------==! - MODULE environment -!==-----------------------------------------------------------------------==! - - USE kinds - USE io_files, ONLY: crash_file, crashunit, & - stop_file, stopunit - - IMPLICIT NONE - SAVE - - PRIVATE - - REAL(DP) :: start_cclock_val - - PUBLIC :: environment_start - PUBLIC :: environment_end - PUBLIC :: opening_date_and_time, closing_date_and_time - PUBLIC :: start_cclock_val - -!==-----------------------------------------------------------------------==! - CONTAINS -!==-----------------------------------------------------------------------==! - - - SUBROUTINE environment_start( ) - - USE io_global, ONLY: stdout, meta_ionode - USE mp_global, ONLY: mpime, nproc, me_image, & - my_image_id, root_image - USE cp_version - - LOGICAL :: texst - INTEGER :: nchar - CHARACTER(LEN=80) :: uname - CHARACTER(LEN=80) :: version_str - REAL(DP), EXTERNAL :: cclock - CHARACTER(LEN=6), EXTERNAL :: int_to_char - -#if defined __OPENMP - INTEGER, EXTERNAL :: omp_get_max_threads -#endif - - CALL init_clocks( .TRUE. ) - CALL start_clock( 'CP' ) - - start_cclock_val = cclock( ) - - version_str = TRIM (version_number) // " - " // TRIM (version_date) - - ! ... search for file CRASH and delete it - - IF( meta_ionode ) THEN - INQUIRE( FILE=TRIM(crash_file), EXIST=texst ) - IF( texst ) THEN - OPEN( UNIT=crashunit, FILE=TRIM(crash_file), STATUS='OLD' ) - CLOSE( UNIT=crashunit, STATUS='DELETE' ) - END IF - END IF - - ! ... each processor other than me=1 opens its own standard output file, - ! ... this is mainly for debugging, usually only ionode writes to stdout - - IF( .NOT. meta_ionode ) THEN - - uname = 'out.' // trim(int_to_char( my_image_id )) // '_' // & - trim(int_to_char( me_image)) - nchar = INDEX(uname,' ') - 1 - - ! - ! useful for debugging purposes - if (me_image == root_image) then - open( unit = stdout, file = uname(1:nchar),status='unknown') - else - open( unit = stdout, file='/dev/null', status='unknown' ) - endif - !open( unit = stdout, file = uname(1:nchar),status='unknown') - ! - !open( unit = stdout, file='/dev/null', status='unknown' ) - - END IF -! - CALL opening_date_and_time( version_str ) - -#if defined __MPI - - WRITE( stdout,100) nproc, mpime -100 FORMAT(3X,'MPI Parallel Build',/,3X,'Tasks =',I5,' This task id =',I5) - -#else - - WRITE( stdout,100) -100 FORMAT(3X,'Serial Build') - -#endif - -#if defined __OPENMP - WRITE( stdout,110) omp_get_max_threads() -110 FORMAT(3X,'Using OpenMP with',I5,' threads') -#endif - - RETURN - END SUBROUTINE environment_start - -!==-----------------------------------------------------------------------==! - - SUBROUTINE environment_end( ) - - USE io_global, ONLY: stdout, meta_ionode - - IF ( meta_ionode ) WRITE( stdout, * ) - - CALL stop_clock( 'CP' ) - CALL print_clock( 'CP' ) - - CALL closing_date_and_time( ) - - IF( meta_ionode ) THEN - WRITE( stdout,'(A)') ' JOB DONE.' - WRITE( stdout,3335) - END IF - 3335 FORMAT('=',78('-'),'=') - - RETURN - END SUBROUTINE environment_end - -!==-----------------------------------------------------------------------==! - - SUBROUTINE opening_date_and_time( version_str ) - - USE io_global, ONLY: stdout, meta_ionode - - CHARACTER(LEN=*), INTENT(IN) :: version_str - CHARACTER(LEN=9) :: cdate, ctime - CHARACTER(LEN=80) :: time_str - - CALL date_and_tim( cdate, ctime ) - time_str = 'This run was started on: ' // ctime // ' ' // cdate - -! ... write program heading - - - IF( meta_ionode ) THEN - WRITE( stdout,3331) - WRITE( stdout,3332) version_str - WRITE( stdout,3331) - WRITE( stdout,3334) time_str - END IF - - 3331 FORMAT('=',78('-'),'=') - 3332 FORMAT( /, 5X,'CP: variable-cell Car-Parrinello molecular dynamics',/& - & ,5X,'using norm-conserving and ultrasoft Vanderbilt pseudopotentials',//& - & ,5X,'Version: ',A60,/& - & ,5X,'Authors: Alfredo Pasquarello, Kari Laasonen, Andrea Trave, Roberto Car,',/& - & ,5X,' Paolo Giannozzi, Nicola Marzari, Carlo Cavazzoni, Guido Chiarotti,',/& - & ,5X,' Sandro Scandolo, Paolo Focher, Gerardo Ballabio, and others',/) - - 3334 FORMAT(/,3X,A60,/) - RETURN - END SUBROUTINE opening_date_and_time - -!==-----------------------------------------------------------------------==! - - SUBROUTINE closing_date_and_time( ) - - USE io_global, ONLY: stdout, meta_ionode - - CHARACTER(LEN=9) :: cdate, ctime - CHARACTER(LEN=80) :: time_str - - CALL date_and_tim( cdate, ctime ) - - time_str = 'This run was terminated on: ' // ctime // ' ' // cdate - - IF( meta_ionode ) THEN - WRITE( stdout,*) - WRITE( stdout,3334) time_str - WRITE( stdout,3335) - END IF - - 3334 FORMAT(3X,A60,/) - 3335 FORMAT('=',78('-'),'=') - - RETURN - END SUBROUTINE closing_date_and_time - -!==-----------------------------------------------------------------------==! - END MODULE environment -!==-----------------------------------------------------------------------==! diff --git a/quantum_espresso/kcp/CPV/exch_corr.f90 b/quantum_espresso/kcp/CPV/exch_corr.f90 deleted file mode 100644 index 7332dc991..000000000 --- a/quantum_espresso/kcp/CPV/exch_corr.f90 +++ /dev/null @@ -1,983 +0,0 @@ -! -! Copyright (C) 2002-2008 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - -! ... Gradient Correction & exchange and correlation - -!=----------------------------------------------------------------------------=! - SUBROUTINE v2gc_x( v2xc, grho, rhor, vpot ) -!=----------------------------------------------------------------------------=! - - USE kinds, ONLY: DP - USE fft_base, ONLY: dfftp - USE cell_base, ONLY: tpiba - USE reciprocal_vectors, ONLY: gstart, gx - use grid_dimensions, only: nnrx - USE gvecp, ONLY: ngm - USE cp_interfaces, ONLY: fwfft, invfft -! - implicit none -! - REAL(DP) :: vpot(:,:) - REAL(DP), intent(in) :: v2xc(:,:,:) - REAL(DP), intent(in) :: grho(:,:,:) - REAL(DP), intent(in) :: rhor(:,:) -! - integer :: ig, ipol, is, js, nspin - COMPLEX(DP), allocatable :: psi(:) - COMPLEX(DP), allocatable :: vtemp(:) - COMPLEX(DP), allocatable :: vtemp_pol(:) - REAL(DP) :: fac -! ... - nspin = SIZE(rhor,2) - - fac = 1.0d0 - - ALLOCATE( vtemp( ngm ) ) - ALLOCATE( vtemp_pol( ngm ) ) - ALLOCATE( psi( nnrx ) ) - - DO js = 1, nspin - ! - vtemp = 0.0d0 - - DO ipol = 1, 3 - DO is = 1, nspin - ! - psi( 1:nnrx ) = fac * v2xc( 1:nnrx, js, is ) * grho( 1:nnrx, ipol, is ) - ! - CALL fwfft( 'Dense', psi, dfftp ) - CALL psi2rho( 'Dense', psi, dfftp%nnr, vtemp_pol, ngm ) - ! - DO ig = gstart, ngm - vtemp(ig) = vtemp(ig) + vtemp_pol(ig) * CMPLX( 0.d0, tpiba * gx( ipol, ig ) ) - END DO - ! - END DO - END DO - ! - CALL rho2psi( 'Dense', psi, dfftp%nnr, vtemp, ngm ) - CALL invfft( 'Dense', psi, dfftp ) - - vpot( 1:nnrx, js ) = vpot( 1:nnrx, js) - DBLE( psi( 1:nnrx ) ) - - END DO - - DEALLOCATE( psi ) - DEALLOCATE( vtemp_pol ) - DEALLOCATE( vtemp ) - - RETURN - END SUBROUTINE v2gc_x - - -!=----------------------------------------------------------------------------=! - SUBROUTINE stress_gc_x(grho, v2xc, gcpail, omega) -!=----------------------------------------------------------------------------=! -! - USE kinds, ONLY: DP - use grid_dimensions, only: nr1, nr2, nr3, nnrx - - IMPLICIT NONE -! - REAL(DP) :: v2xc(:,:,:) - REAL(DP) :: grho(:,:,:) - REAL(DP) :: gcpail(6) - REAL(DP) :: omega -! - REAL(DP) :: stre - INTEGER :: i, ipol, jpol, ic, is, js, nspin - INTEGER, DIMENSION(6), PARAMETER :: alpha = (/ 1,2,3,2,3,3 /) - INTEGER, DIMENSION(6), PARAMETER :: beta = (/ 1,1,1,2,2,3 /) -! ... - nspin = SIZE(grho,3) - - DO ic = 1, 6 - ipol = alpha(ic) - jpol = beta(ic) - stre = 0.0d0 - DO is = 1, nspin - DO js = 1, nspin - DO i = 1, nnrx - stre = stre + v2xc(i,is,js) * grho(i,ipol,js) * grho(i,jpol,is) - END DO - END DO - END DO - gcpail(ic) = - stre * omega / DBLE(nr1*nr2*nr3) - END DO - - RETURN - END SUBROUTINE stress_gc_x - - -!=----------------------------------------------------------------------------=! - SUBROUTINE stress_xc_x( dexc, strvxc, sfac, vxc, grho, v2xc, & - gagb, tnlcc, rhocp, box) -!=----------------------------------------------------------------------------=! - - USE kinds, ONLY: DP - USE ions_base, ONLY: nsp - USE cell_base, ONLY: tpiba, boxdimensions - USE funct, ONLY: dft_is_gradient - USE reciprocal_vectors, ONLY: gstart, g - USE gvecp, ONLY: ngm - USE cp_interfaces, ONLY: stress_gc - - IMPLICIT NONE - - ! -- ARGUMENT - - type (boxdimensions), intent(in) :: box - LOGICAL :: tnlcc(:) - COMPLEX(DP) :: vxc(:,:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - REAL(DP) :: dexc(:), strvxc - REAL(DP) :: grho(:,:,:) - REAL(DP) :: v2xc(:,:,:) - REAL(DP) :: gagb(:,:) - REAL(DP) :: rhocp(:,:) - - INTEGER, DIMENSION(6), PARAMETER :: alpha = (/ 1,2,3,2,3,3 /) - INTEGER, DIMENSION(6), PARAMETER :: beta = (/ 1,1,1,2,2,3 /) - ! ... dalbe(:) = delta(alpha(:),beta(:)) - REAL(DP), DIMENSION(6), PARAMETER :: dalbe = & - (/ 1.0_DP, 0.0_DP, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP /) - - COMPLEX(DP) :: tex1, tex2, tex3 - REAL(DP) :: gcpail(6), omega - REAL(DP) :: dcc( 6 ) - INTEGER :: ig, is, ispin, nspin - - omega = box%deth - nspin = SIZE(vxc, 2) - - DEXC = 0.0d0 - dcc = 0.0d0 - - ! ... computes omega * \sum_{G}[ S(G)*rhopr(G)* G_{alpha} G_{beta}/|G|] - ! ... (252) Phd thesis Dal Corso. Opposite sign. - - IF ( ANY( tnlcc ) ) THEN - - DO ig = gstart, ngm - tex1 = ( 0.0d0 , 0.0d0 ) - DO is=1,nsp - IF ( tnlcc(is) ) THEN - tex1 = tex1 + sfac( ig, is ) * CMPLX(rhocp(ig,is), 0.d0) - END IF - END DO - tex2 = 0.0d0 - DO ispin = 1, nspin - tex2 = tex2 + CONJG( vxc(ig, ispin) ) - END DO - tex3 = DBLE(tex1 * tex2) / SQRT( g( ig ) ) / tpiba - dcc = dcc + tex3 * gagb(:,ig) - END DO - dcc = dcc * 2.0d0 * omega - - ! DEBUG - !DO k=1,6 - ! detmp(alpha(k),beta(k)) = dcc(k) - ! detmp(beta(k),alpha(k)) = detmp(alpha(k),beta(k)) - !END DO - !detmp = MATMUL( detmp(:,:), box%m1(:,:) ) - !WRITE( stdout,*) "derivative of e(xc) - nlcc part" - !WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3) - !WRITE( stdout,*) SUM( rhocp(:,1) ) - - - END IF - - ! ... (E_{xc} - \int dr v_{xc}(n) n(r))/omega part of the stress - ! ... this part of the stress is diagonal. - - dexc = strvxc * dalbe - - IF ( dft_is_gradient() ) THEN - CALL stress_gc(grho, v2xc, gcpail, omega) - dexc = dexc + gcpail - END IF - - ! DEBUG - !DO k=1,6 - ! detmp(alpha(k),beta(k)) = dexc(k) - ! detmp(beta(k),alpha(k)) = detmp(alpha(k),beta(k)) - !END DO - !detmp = MATMUL( detmp(:,:), box%m1(:,:) ) - !WRITE( stdout,*) "derivative of e(xc)" - !WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3) - - dexc = dexc + dcc - - RETURN - -5555 format(1x,f12.5,1x,f12.5,1x,f12.5/ & - & 1x,f12.5,1x,f12.5,1x,f12.5/ & - & 1x,f12.5,1x,f12.5,1x,f12.5//) - - END SUBROUTINE stress_xc_x - - - - -!=----------------------------------------------------------------------------=! - SUBROUTINE exch_corr_energy_x(rhoetr, grho, vpot, exc, vxc, v2xc) -!=----------------------------------------------------------------------------=! - - USE kinds, ONLY: DP - use grid_dimensions, ONLY: nnrx - USE funct, ONLY: dft_is_gradient - USE cp_interfaces, ONLY: v2gc - - implicit none - - REAL (DP) :: rhoetr(:,:) - REAL (DP) :: grho(:,:,:) - REAL (DP) :: vpot(:,:) - REAL (DP) :: exc ! E_xc energy ( not multiplied by Omega/nnr ) - REAL (DP) :: vxc ! SUM ( v(r) * rho(r) ) - REAL (DP) :: v2xc(:,:,:) - ! - REAL (DP), EXTERNAL :: ddot - - INTEGER :: nspin, ispin - logical :: is_gradient - - is_gradient = dft_is_gradient() - - - ! vpot = vxc(rhoetr); vpot(r) <-- u(r) - - nspin = SIZE( rhoetr, 2 ) - ! - IF( SIZE( vpot, 1 ) /= nnrx ) & - CALL errore(" exch_corr_energy ", " inconsistent size for vpot ", 1 ) - ! - CALL exch_corr_wrapper( nnrx, nspin, grho(1,1,1), rhoetr(1,1), exc, vpot(1,1), v2xc(1,1,1) ) - ! - IF( dft_is_gradient() ) THEN - ! ... vpot additional term for gradient correction - CALL v2gc( v2xc, grho, rhoetr, vpot ) - END If - - ! - ! vxc = SUM( vpot * rhoetr ) - ! - vxc = 0.0d0 - DO ispin = 1, nspin - vxc = vxc + DDOT ( nnrx, vpot(1,ispin), 1, rhoetr(1,ispin), 1 ) - END DO - - - RETURN - END SUBROUTINE exch_corr_energy_x - - - - -!=----------------------------------------------------------------------------=! -! CP subroutines -!=----------------------------------------------------------------------------=! - - subroutine exch_corr_h( nspin, rhog, rhor, rhoc, sfac, exc, dxc, self_exc ) -! -! calculate exch-corr potential, energy, and derivatives dxc(i,j) -! of e(xc) with respect to to cell parameter h(i,j) -! - use funct, only : dft_is_gradient, dft_is_meta - use gvecp, only : ng => ngm - use gvecs, only : ngs - use grid_dimensions, only : nr1, nr2, nr3, nnr => nnrx - use cell_base, only : ainv, omega, h - use ions_base, only : nsp - use control_flags, only : tpre, iprsta, gamma_only, do_wf_cmplx - use core, only : drhocg, nlcc_any - use mp, only : mp_sum - use metagga, ONLY : kedtaur - USE io_global, ONLY : stdout - USE mp_global, ONLY : intra_image_comm - use kinds, ONLY : DP - use constants, ONLY : au_gpa - USE sic_module, ONLY : self_interaction, sic_alpha - USE cp_interfaces, ONLY : fillgrad - use cp_main_variables, only : drhor -! - implicit none - - ! input - ! - integer nspin - ! - ! rhog contains the charge density in G space - ! rhor contains the charge density in R space - ! - complex(DP) :: rhog( ng, nspin ) - complex(DP) :: sfac( ngs, nsp ) - ! - ! output - ! rhor contains the exchange-correlation potential - ! - real(DP) :: rhor( nnr, nspin ), rhoc( nnr ) - real(DP) :: dxc( 3, 3 ), exc - real(DP) :: dcc( 3, 3 ), drc( 3, 3 ) - ! - ! local - ! - integer :: i, j, ir, iss - real(DP) :: dexc(3,3) - real(DP), allocatable :: gradr(:,:,:) - logical :: lgam - ! - !sic - REAL(DP) :: self_exc - REAL(DP), ALLOCATABLE :: self_rho( :,: ), self_gradr(:,:,:) - complex(DP), ALLOCATABLE :: self_rhog( :,: ) - LOGICAL :: ttsic - real(DP) :: detmp(3,3) - - lgam=gamma_only.and..not.do_wf_cmplx - ! - ! filling of gradr with the gradient of rho using fft's - ! - if ( dft_is_gradient() ) then - ! - allocate( gradr( nnr, 3, nspin ) ) - call fillgrad( nspin, rhog, gradr, lgam ) - ! - else - allocate( gradr( 1, 1, 2) ) - end if - - - ttsic = (self_interaction /= 0 ) - ! - IF ( ttsic ) THEN - ! - IF ( dft_is_meta() ) CALL errore ('exch_corr_h', & - 'SIC and metadynamics not together', 1) - IF ( tpre ) CALL errore( 'exch_corr_h', 'SIC and stress not implemented', 1) - - ! allocate the sic_arrays - ! - ALLOCATE( self_rho( nnr, nspin ) ) - ALLOCATE( self_rhog( ng, nspin ) ) - IF( dft_is_gradient() ) ALLOCATE( self_gradr( nnr, 3, nspin ) ) - - self_rho(:, 1) = rhor( :, 2) - self_rho(:, 2) = rhor( :, 2) - - IF( dft_is_gradient() ) THEN - self_gradr(:, :, 1) = gradr(:, :, 2) - self_gradr(:, :, 2) = gradr(:, :, 2) - ENDIF - - self_rhog(:, 1) = rhog( :, 2) - self_rhog(:, 2) = rhog( :, 2) -! - END IF -! - self_exc = 0.d0 -! - if( dft_is_meta() ) then - ! - call tpssmeta( nnr, nspin, gradr, rhor, kedtaur, exc ) - ! - else - ! - CALL exch_corr_cp(nnr, nspin, gradr, rhor, exc) - ! - IF ( ttsic ) THEN - CALL exch_corr_cp(nnr, nspin, self_gradr, self_rho, self_exc) - self_exc = sic_alpha * (exc - self_exc) - exc = exc - self_exc - END IF - ! - end if - - call mp_sum( exc, intra_image_comm ) - IF ( ttsic ) call mp_sum( self_exc, intra_image_comm ) - - exc = exc * omega / DBLE( nr1 * nr2 * nr3 ) - IF ( ttsic ) self_exc = self_exc * omega/DBLE(nr1 * nr2 *nr3 ) - - ! WRITE(*,*) 'Debug: calcolo exc', exc, 'eself', self_exc - ! - ! exchange-correlation contribution to pressure - ! - dxc = 0.0d0 - ! - if ( tpre ) then - ! - ! Add term: Vxc( r ) * Drhovan( r )_ij - Vxc( r ) * rho( r ) * ((H^-1)^t)_ij - ! - do iss = 1, nspin - do j=1,3 - do i=1,3 - do ir=1,nnr - dxc(i,j) = dxc(i,j) + rhor( ir, iss ) * drhor( ir, iss, i, j ) - end do - end do - end do - end do - ! - dxc = dxc * omega / ( nr1*nr2*nr3 ) - ! - call mp_sum ( dxc, intra_image_comm ) - ! - do j = 1, 3 - do i = 1, 3 - dxc( i, j ) = dxc( i, j ) + exc * ainv( j, i ) - end do - end do - ! - ! DEBUG - ! - ! write (stdout,*) "derivative of e(xc)" - ! write (stdout,5555) ((dxc(i,j),j=1,3),i=1,3) - ! - IF( iprsta >= 2 ) THEN - DO i=1,3 - DO j=1,3 - detmp(i,j)=exc*ainv(j,i) - END DO - END DO - WRITE( stdout,*) "derivative of e(xc) - diag - kbar" - detmp = -1.0d0 * MATMUL( detmp, TRANSPOSE( h ) ) / omega * au_gpa * 10.0d0 - WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3) - END IF - ! - end if - ! - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! - call gradh( nspin, gradr, rhog, rhor, dexc, lgam) - ! - if (tpre) then - ! - call mp_sum ( dexc, intra_image_comm ) - ! - dxc = dxc + dexc - ! - end if - ! - end if - ! - - IF( ttsic ) THEN -! - IF (dft_is_gradient()) then - - call gradh( nspin, self_gradr, self_rhog, self_rho, dexc, lgam) - - gradr(:,:, 1) = (1.d0 - sic_alpha ) * gradr(:,:, 1) - gradr(:,:, 2) = (1.d0 - sic_alpha ) * gradr(:,:, 2) + & - & sic_alpha * ( self_gradr(:,:,1) + self_gradr(:,:,2) ) - ENDIF - - rhor(:, 1) = (1.d0 - sic_alpha ) * rhor(:, 1) - rhor(:, 2) = (1.d0 - sic_alpha ) * rhor(:, 2) + & - & sic_alpha * ( self_rho(:,1) + self_rho(:,2) ) - - IF(ALLOCATED(self_gradr)) DEALLOCATE(self_gradr) - IF(ALLOCATED(self_rhog)) DEALLOCATE(self_rhog) - IF(ALLOCATED(self_rho)) DEALLOCATE(self_rho) -! - ENDIF - - IF( tpre ) THEN - ! - dcc = 0.0d0 - ! - IF( nlcc_any ) CALL denlcc( nnr, nspin, rhor, sfac, drhocg, dcc ) - ! - ! DEBUG - ! - ! write (stdout,*) "derivative of e(xc) - nlcc part" - ! write (stdout,5555) ((dcc(i,j),j=1,3),i=1,3) - ! - dxc = dxc + dcc - ! - do iss = 1, nspin - drc = 0.0d0 - IF( nlcc_any ) THEN - do j=1,3 - do i=1,3 - do ir=1,nnr - drc(i,j) = drc(i,j) + rhor( ir, iss ) * rhoc( ir ) * ainv(j,i) - end do - end do - end do - call mp_sum ( drc, intra_image_comm ) - END IF - dxc = dxc - drc * ( 1.0d0 / nspin ) * omega / ( nr1*nr2*nr3 ) - end do - ! - END IF - ! - - IF( ALLOCATED( gradr ) ) DEALLOCATE( gradr ) - -5555 format(1x,f12.5,1x,f12.5,1x,f12.5/ & - & 1x,f12.5,1x,f12.5,1x,f12.5/ & - & 1x,f12.5,1x,f12.5,1x,f12.5//) - ! - return - end subroutine exch_corr_h - - -!=----------------------------------------------------------------------------=! - - subroutine gradh( nspin, gradr, rhog, rhor, dexc, lgam ) -! _________________________________________________________________ -! -! calculate the second part of gradient corrected xc potential -! plus the gradient-correction contribution to pressure -! - USE kinds, ONLY: DP - use control_flags, only: tpre - use reciprocal_vectors, only: gx - use recvecs_indexes, only: np, nm - use gvecp, only: ng => ngm - use grid_dimensions, only: nnr => nnrx - use cell_base, only: ainv, tpiba, omega - use cp_main_variables, only: drhog - USE cp_interfaces, ONLY: fwfft, invfft - USE fft_base, ONLY: dfftp - !USE nksic, ONLY: do_orbdep !added:giovanni to avoid calculation of dexc ... - !but this probably does not speed up the calculation -! - implicit none -! input - integer nspin - real(DP) :: gradr( nnr, 3, nspin ), rhor( nnr, nspin ), dexc( 3, 3 ) - complex(DP) :: rhog( ng, nspin ) - logical :: lgam -! - complex(DP), allocatable:: v(:) - complex(DP), allocatable:: x(:), vtemp(:) - complex(DP) :: ci, fp, fm - integer :: iss, ig, ir, i,j -! - allocate(v(nnr)) - allocate(x(ng)) - allocate(vtemp(ng)) - ! - ci=CMPLX(0.0d0,1.0d0) - ! - dexc = 0.0d0 - ! - do iss=1, nspin -! _________________________________________________________________ -! second part xc-potential: 3 forward ffts -! - do ir=1,nnr - v(ir)=CMPLX(gradr(ir,1,iss),0.d0) - end do - call fwfft('Dense',v, dfftp ) - do ig=1,ng - x(ig)=ci*tpiba*gx(1,ig)*v(np(ig)) - end do -! - if(tpre) then - do i=1,3 - do j=1,3 - do ig=1,ng - vtemp(ig) = omega*ci*CONJG(v(np(ig)))* & - & tpiba*(-rhog(ig,iss)*gx(i,ig)*ainv(j,1)+ & - & gx(1,ig)*drhog(ig,iss,i,j)) - end do - dexc(i,j) = dexc(i,j) + DBLE(SUM(vtemp))*2.0d0 - end do - end do - endif -! - do ir=1,nnr - v(ir)=CMPLX(gradr(ir,2,iss),gradr(ir,3,iss)) - end do - call fwfft('Dense',v, dfftp ) -! -! IF(lgam) THEN !!!uncomment for k-points - do ig=1,ng - fp=v(np(ig))+v(nm(ig)) - fm=v(np(ig))-v(nm(ig)) - x(ig) = x(ig) + & - & ci*tpiba*gx(2,ig)*0.5d0*CMPLX( DBLE(fp),AIMAG(fm)) - x(ig) = x(ig) + & - & ci*tpiba*gx(3,ig)*0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - end do -! ELSE !!!uncomment for k-points -! do ig=1,ng !!!uncomment for k-points -! fp=v(np(ig)) !!!uncomment for k-points -! fm=v(np(ig))!-v(nm(ig)) !!!uncomment for k-points -! x(ig) = x(ig) + & !!!uncomment for k-points -! & ci*tpiba*gx(2,ig)*0.5d0*CMPLX( DBLE(fp),AIMAG(fm)) !!!uncomment for k-points -! x(ig) = x(ig) + & !!!uncomment for k-points -! & ci*tpiba*gx(3,ig)*0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) !!!uncomment for k-points -! end do !!!uncomment for k-points -! ENDIF !!!uncomment for k-points -! - if(tpre) then -! IF(lgam) THEN !!!uncomment for k-points - do i=1,3 - do j=1,3 - do ig=1,ng - fp=v(np(ig))+v(nm(ig)) - fm=v(np(ig))-v(nm(ig)) - vtemp(ig) = omega*ci* & - & (0.5d0*CMPLX(DBLE(fp),-AIMAG(fm))* & - & tpiba*(-rhog(ig,iss)*gx(i,ig)*ainv(j,2)+ & - & gx(2,ig)*drhog(ig,iss,i,j))+ & - & 0.5d0*CMPLX(AIMAG(fp),DBLE(fm))*tpiba* & - & (-rhog(ig,iss)*gx(i,ig)*ainv(j,3)+ & - & gx(3,ig)*drhog(ig,iss,i,j))) - end do - dexc(i,j) = dexc(i,j) + 2.0d0*DBLE(SUM(vtemp)) - end do - end do -! ELSE !!!uncomment for k-points -! do i=1,3 !!!uncomment for k-points -! do j=1,3 !!!uncomment for k-points -! do ig=1,ng !!!uncomment for k-points -! fp=v(np(ig))!+v(nm(ig)) !!!uncomment for k-points -! fm=v(np(ig))!-v(nm(ig)) !!!uncomment for k-points -! vtemp(ig) = omega*ci* & !!!uncomment for k-points -! & (0.5d0*CMPLX(DBLE(fp),-AIMAG(fm))* & !!!uncomment for k-points -! & tpiba*(-rhog(ig,iss)*gx(i,ig)*ainv(j,2)+ & !!!uncomment for k-points -! & gx(2,ig)*drhog(ig,iss,i,j))+ & !!!uncomment for k-points -! & 0.5d0*CMPLX(AIMAG(fp),DBLE(fm))*tpiba* & !!!uncomment for k-points -! & (-rhog(ig,iss)*gx(i,ig)*ainv(j,3)+ & !!!uncomment for k-points -! & gx(3,ig)*drhog(ig,iss,i,j))) !!!uncomment for k-points -! end do !!!uncomment for k-points -! dexc(i,j) = dexc(i,j) + 2.0d0*DBLE(SUM(vtemp)) !!!uncomment for k-points -! end do !!!uncomment for k-points -! end do !!!uncomment for k-points -! ENDIF !!!uncomment for k-points - endif -! _________________________________________________________________ -! second part xc-potential: 1 inverse fft -! - do ig=1,nnr - v(ig)=CMPLX(0.0d0,0.0d0) - end do -! IF(lgam) THEN !!!uncomment for k-points - do ig=1,ng - v(np(ig))=x(ig) - v(nm(ig))=CONJG(x(ig)) - end do -! ELSE !!!uncomment for k-points -! do ig=1,ng !!!uncomment for k-points -! v(np(ig))=x(ig) !!!uncomment for k-points -! ! v(nm(ig))=CONJG(x(ig)) !!!uncomment for k-points -! end do !!!uncomment for k-points -! ENDIF !!!uncomment for k-points - call invfft('Dense',v, dfftp ) - ! - do ir=1,nnr - rhor(ir,iss)=rhor(ir,iss)-DBLE(v(ir)) - end do - ! - end do -! - deallocate(vtemp) - deallocate(x) - deallocate(v) -! - return - end subroutine gradh - -!=----------------------------------------------------------------------------=! -! -! This wrapper interface CP/FPMD to the PW xc and gga functionals -! -! tested with PP/xctest.f90 code -! -!=----------------------------------------------------------------------------=! - -subroutine exch_corr_wrapper(nnr, nspin, grhor, rhor, etxc, v, h) - use kinds, only: DP - use funct, only: dft_is_gradient, get_igcc, & - xc, xc_spin, gcxc, gcx_spin, gcc_spin, gcc_spin_more - implicit none - integer, intent(in) :: nnr - integer, intent(in) :: nspin - real(DP), intent(in) :: grhor( nnr, 3, nspin ) - real(DP) :: h( nnr, nspin, nspin ) - real(DP), intent(in) :: rhor( nnr, nspin ) - real(DP) :: v( nnr, nspin ) - real(DP) :: etxc - integer :: ir, is, k - real(DP) :: rup, rdw, ex, ec, vx(2), vc(2) - real(DP) :: rh, grh2, zeta - real(DP) :: sx, sc, v1x, v2x, v1c, v2c - real(DP) :: rhox, arhox, e2 - real(DP) :: grho2(2), arho, segno - real(DP) :: v1xup, v1xdw, v2xup, v2xdw - real(DP) :: v1cup, v1cdw - real(DP) :: grhoup, grhodw, grhoud - real(DP) :: v2cup, v2cdw, v2cud - integer :: neg(3) - real(DP), parameter :: epsr = 1.0d-10, epsg = 1.0d-10 - real(DP), parameter :: epsr2 = 1.0d-30 - logical :: debug_xc = .false. - logical :: igcc_is_lyp - - igcc_is_lyp = (get_igcc() == 3) - ! - e2 = 1.0d0 - etxc = 0.0d0 - if( nspin == 1 ) then - ! - ! spin-unpolarized case - ! -!$omp parallel do private( rhox, arhox, ex, ec, vx, vc ), reduction(+:etxc) - do ir = 1, nnr - rhox = rhor (ir, nspin) - arhox = abs (rhox) - if (arhox.gt.epsr2) then - CALL xc( arhox, ex, ec, vx(1), vc(1) ) - v(ir,nspin) = e2 * (vx(1) + vc(1))!modified:giovanni sign - etxc = etxc + e2 * (ex + ec) * rhox !modified:giovanni rhox->arhox - endif - enddo -!$omp end parallel do - ! - else - ! - ! spin-polarized case - ! - neg (1) = 0 - neg (2) = 0 - neg (3) = 0 - do ir = 1, nnr - ! - rup=rhor(ir,1) - rdw=rhor(ir,2) - ! - IF(abs(rup).lt.epsr2) rup=0.d0 !added:giovanni - IF(abs(rdw).lt.epsr2) rdw=0.d0 !added:giovanni - ! - rhox=rup+rdw - arhox = abs(rhox) - ! - if (arhox.gt.epsr2) then - zeta = ( rup - rdw ) / (arhox) !modified:giovanni abs(rup+rdw)-> abs(rup) + abs(rdw) - if (abs(zeta) .gt.1.d0) then - neg(3) = neg(3) + 1 - zeta = sign(1.d0,zeta) - endif - ! WRITE(6,*) rhox, zeta - if (rhor(ir,1) < 0.d0) neg(1) = neg(1) + 1 - if (rhor(ir,2) < 0.d0) neg(2) = neg(2) + 1 - call xc_spin (arhox, zeta, ex, ec, vx(1), vx(2), vc(1), vc(2) ) - do is = 1, nspin - v(ir,is) = e2 * (vx(is) + vc(is)) !modified:giovanni sign - enddo - etxc = etxc + e2 * (ex + ec) * rhox !modified:giovanni rhox->arhox - endif - enddo - endif - - if( debug_xc ) then - open(unit=17,form='unformatted') - write(17) nnr, nspin - write(17) rhor - write(17) grhor - close(17) - debug_xc = .false. - end if - - ! now come the corrections - - if( dft_is_gradient() .and. .true.) then !supercalifragilistichespiralidoso - - if (nspin == 1) then - ! - ! This is the spin-unpolarised case - ! -!$omp parallel do & -!$omp private( is, grho2, arho, segno, sx, sc, v1x, v2x, v1c, v2c ), reduction(+:etxc) - do k = 1, nnr - ! - grho2 (1) = grhor(k, 1, 1)**2 + grhor(k, 2, 1)**2 + grhor(k, 3, 1)**2 - arho = abs (rhor (k, 1) ) - segno = sign (1.d0, rhor (k, 1) ) - if (arho > epsr .and. grho2 (1) > epsg) then - - call gcxc (arho, grho2(1), sx, sc, v1x, v2x, v1c, v2c) - ! - ! first term of the gradient correction : D(rho*Exc)/D(rho) - - v (k, 1) = v (k, 1) + e2 * (v1x + v1c) - - ! HERE h contains D(rho*Exc)/D(|grad rho|) / |grad rho| - ! - h (k, 1, 1) = e2 * (v2x + v2c) - etxc = etxc + e2 * (sx + sc) * segno - - else - h (k, 1, 1) = 0.d0 - endif - ! - end do -!$omp end parallel do - ! - else - ! - ! spin-polarised case - ! -! do k=100,150 -! write(6,*) dlog((rhor(k,1)-rhor(k,2))/(rhor(k,1)+rhor(k,2))), "rhor" -! enddo - do k = 1, nnr - do is = 1, nspin - grho2 (is) = grhor(k, 1, is)**2 + grhor(k, 2, is)**2 + grhor(k, 3, is)**2 - enddo - rup = rhor (k, 1) - rdw = rhor (k, 2) !!supercalifragilistichespiralidoso - ! - IF(rup.lt.epsr) rup=0.d0 - IF(rdw.lt.epsr) rdw=0.d0 - call gcx_spin ( rup, rdw, grho2 (1), grho2 (2), sx, v1xup, v1xdw, v2xup, v2xdw) - ! - rh = rup+rdw !rhor (k, 1) + rhor (k, 2) - ! - if (rh.gt.epsr) then !supercalifragilistichespiralidoso - if( igcc_is_lyp ) then - grhoup = grhor(k,1,1)**2 + grhor(k,2,1)**2 + grhor(k,3,1)**2 - grhodw = grhor(k,1,2)**2 + grhor(k,2,2)**2 + grhor(k,3,2)**2 - grhoud = grhor(k,1,1)* grhor(k,1,2) - grhoud = grhoud + grhor(k,2,1)* grhor(k,2,2) - grhoud = grhoud + grhor(k,3,1)* grhor(k,3,2) - call gcc_spin_more(rup, rdw, grhoup, grhodw, grhoud, sc, & - v1cup, v1cdw, v2cup, v2cdw, v2cud) - else - zeta = (rup-rdw) / rh - ! - grh2 = (grhor (k, 1, 1) + grhor (k, 1, 2) ) **2 + & - (grhor (k, 2, 1) + grhor (k, 2, 2) ) **2 + & - (grhor (k, 3, 1) + grhor (k, 3, 2) ) **2 - call gcc_spin (rh, zeta, grh2, sc, v1cup, v1cdw, v2c) - v2cup = v2c - v2cdw = v2c - v2cud = v2c - end if - else - sc = 0.d0 - v1cup = 0.d0 - v1cdw = 0.d0 - v2c = 0.d0 - v2cup = 0.0d0 - v2cdw = 0.0d0 - v2cud = 0.0d0 - endif -! sc = 0.d0 -! v1cup = 0.d0 - !v1cdw = 0.d0 -! v2c = 0.d0 -! v2cup = 0.0d0 - !v2cdw = 0.0d0 -! v2cud = 0.0d0 - ! - ! first term of the gradient correction : D(rho*Exc)/D(rho) - ! - v (k, 1) = v (k, 1) + e2 * (v1xup + v1cup) - v (k, 2) = v (k, 2) + e2 * (v1xdw + v1cdw) ! - ! - ! HERE h contains D(rho*Exc)/D(|grad rho|) / |grad rho| - ! - h (k, 1, 1) = e2 * (v2xup + v2cup) ! Spin UP-UP - h (k, 1, 2) = e2 * v2cud ! Spin UP-DW - h (k, 2, 1) = e2 * v2cud ! Spin DW-UP - h (k, 2, 2) = e2 * (v2xdw + v2cdw) ! Spin DW-DW - ! - etxc = etxc + e2 * (sx + sc) - ! - ! - enddo - ! - endif - ! - end if - - return -end subroutine exch_corr_wrapper - - -!=----------------------------------------------------------------------------=! -! -! For CP we need a further small interface subroutine -! -!=----------------------------------------------------------------------------=! - -subroutine exch_corr_cp(nnr,nspin,grhor,rhor,etxc) - use kinds, only: DP - use funct, only: dft_is_gradient - implicit none - integer, intent(in) :: nnr - integer, intent(in) :: nspin - real(DP) :: grhor( nnr, 3, nspin ) - real(DP) :: rhor( nnr, nspin ) - real(DP) :: etxc - integer :: k, ipol - real(DP) :: grup, grdw - real(DP), allocatable :: v(:,:) - real(DP), allocatable :: h(:,:,:) - ! - allocate( v( nnr, nspin ) ) - if( dft_is_gradient() ) then - allocate( h( nnr, nspin, nspin ) ) - else - allocate( h( 1, 1, 1 ) ) - endif - ! - call exch_corr_wrapper(nnr,nspin,grhor,rhor,etxc,v,h) - - if( dft_is_gradient() ) then - ! -!$omp parallel default(shared), private(ipol,k,grup,grdw) - if( nspin == 1 ) then - ! - ! h contains D(rho*Exc)/D(|grad rho|) * (grad rho) / |grad rho| - ! - do ipol = 1, 3 -!$omp do - do k = 1, nnr - grhor (k, ipol, 1) = h (k, 1, 1) * grhor (k, ipol, 1) - enddo -!$omp end do - end do - ! - ! - else - ! - do ipol = 1, 3 -!$omp do - do k = 1, nnr - grup = grhor (k, ipol, 1) - grdw = grhor (k, ipol, 2) - grhor (k, ipol, 1) = h (k, 1, 1) * grup + h (k, 1, 2) * grdw - grhor (k, ipol, 2) = h (k, 2, 2) * grdw + h (k, 2, 1) * grup - enddo -!$omp end do - enddo - ! - end if -!$omp end parallel - ! - end if - - rhor = v - - deallocate( v ) - deallocate( h ) - - return -end subroutine exch_corr_cp diff --git a/quantum_espresso/kcp/CPV/exx_divergence.f90 b/quantum_espresso/kcp/CPV/exx_divergence.f90 deleted file mode 100644 index c9020b7e8..000000000 --- a/quantum_espresso/kcp/CPV/exx_divergence.f90 +++ /dev/null @@ -1,154 +0,0 @@ -! -! Copyright (C) 2005 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!----------------------------------------------------------------------- -FUNCTION exx_divergence() - !----------------------------------------------------------------------- - ! - ! ... This function calculates the G=0 term of the Coulomb potential - ! ... in presence of a unitary charge (q=1). Used for counter-charge - ! ... corrections. - ! - USE kinds, ONLY : DP - USE constants, ONLY : fpi, e2 - USE cell_base, ONLY : bg, at, alat, omega - USE reciprocal_vectors, ONLY : gx - USE gvecp, ONLY : ngm - USE gvecw, ONLY : ecutw - USE io_global, ONLY : stdout - USE control_flags, ONLY : gamma_only, do_wf_cmplx - USE mp_global, ONLY : intra_pool_comm - USE mp, ONLY : mp_sum - ! - ! - IMPLICIT NONE - ! - REAL(DP) :: exx_divergence - ! - REAL(DP) :: yukawa = 0.d0 - INTEGER :: nq1=1, nq2=1, nq3=1 ! integers defining the X integration mesh - INTEGER :: nqs ! number of points in the q-grid - LOGICAL :: x_gamma_extrapolation=.false. - LOGICAL :: on_double_grid=.false. - REAL(DP) :: grid_factor = 8.d0/7.d0 - REAL(DP) :: eps=1.d-6 - INTEGER :: iq1,iq2,iq3, ig - REAL(DP) :: div, dq1, dq2, dq3, xq(3), q_, qq, tpiba2, alpha, x, q(3) - INTEGER :: nqq, iq - REAL(DP) :: aa, dq - ! - ! - CALL start_clock( 'exx_div' ) - ! - WRITE( stdout, '(/,A,3I4)' ) " EXX : q-grid dimensions are ", nq1, nq2, nq3 - WRITE( stdout, '(A,5X,L)' ) " EXX : Gamma Extrapolation", x_gamma_extrapolation - ! - IF ( x_gamma_extrapolation ) THEN - WRITE( stdout, '(A)' ) " EXX : q->0 dealt with 8/7 -1/7 trick" - grid_factor = 8.d0 / 7.d0 - ELSE - WRITE( stdout, '(A)' ) " EXX : q->0 term not estimated" - grid_factor = 1.d0 - ENDIF - ! - nqs = nq1 * nq2 * nq3 - tpiba2 = ( fpi / 2.d0 / alat ) ** 2 - alpha = 10.d0 * tpiba2 / ecutw - ! - dq1= 1.d0/DBLE(nq1) - dq2= 1.d0/DBLE(nq2) - dq3= 1.d0/DBLE(nq3) - ! - div = 0.d0 - ! - DO iq1 = 1, nq1 - DO iq2 = 1, nq2 - DO iq3 = 1, nq3 - ! - xq(:) = bg(:,1) * (iq1-1) * dq1 + & - bg(:,2) * (iq2-1) * dq2 + & - bg(:,3) * (iq3-1) * dq3 - ! - DO ig = 1, ngm - ! - q(1) = xq(1) + gx(1,ig) - q(2) = xq(2) + gx(2,ig) - q(3) = xq(3) + gx(3,ig) - qq = q(1)*q(1) + q(2)*q(2) + q(3)*q(3) - ! - IF ( x_gamma_extrapolation ) THEN - ! - on_double_grid = .true. - x = 0.5d0*(q(1)*at(1,1)+q(2)*at(2,1)+q(3)*at(3,1))*nq1 - on_double_grid = on_double_grid .AND. (abs(x-nint(x)) 1.d-8 ) THEN - div = div + EXP( - alpha * qq ) / ( qq + yukawa / tpiba2 ) & - * grid_factor - ENDIF - ENDIF - ! - ENDDO - ENDDO - ENDDO - ENDDO - ! - CALL mp_sum( div, intra_pool_comm ) - ! - IF ( gamma_only .AND. .NOT. do_wf_cmplx ) div = 2.d0 * div - ! - IF ( .NOT. x_gamma_extrapolation ) THEN - IF ( yukawa < 1.d-8) THEN - div = div - alpha - ELSE - div = div + tpiba2 / yukawa - ENDIF - ENDIF - ! - div = div * e2 * fpi / tpiba2 / nqs - ! - alpha = alpha / tpiba2 - ! - nqq = 100000 - dq = 5.0d0 / SQRT( alpha ) / nqq - aa = 0.d0 - ! - DO iq = 0, nqq - ! - q_ = dq * ( iq + 0.5d0 ) - qq = q_ * q_ - aa = aa - EXP( - alpha * qq ) * yukawa / ( qq + yukawa ) * dq - ! - ENDDO - ! - aa = aa * 8.d0 / fpi - aa = aa + 1.d0 / SQRT( alpha * 0.25d0 * fpi ) - ! - div = div - e2 * omega * aa - ! - ! RdG: not clear what is this (absent in recent QE) - !div = div - e2 * omega / SQRT( alpha * 0.25d0 * fpi ) - ! - exx_divergence = div * nqs - ! - WRITE( stdout, '(A,1ES15.5,/)' ) " EXX : Coulomb G0 ", exx_divergence - ! - CALL stop_clock( 'exx_div' ) - !CALL print_clock( 'exx_div' ) - ! - RETURN - ! - ! -END FUNCTION exx_divergence diff --git a/quantum_espresso/kcp/CPV/fft.f90 b/quantum_espresso/kcp/CPV/fft.f90 deleted file mode 100644 index 2f05912b4..000000000 --- a/quantum_espresso/kcp/CPV/fft.f90 +++ /dev/null @@ -1,669 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! ---------------------------------------------- -! This Subroutines written by Carlo Cavazzoni -! Last modified December 2008 -! ---------------------------------------------- - -#include "f_defs.h" - - -!----------------------------------------------------------------------- - subroutine invfft_x( grid_type, f, dfft, ia ) -!----------------------------------------------------------------------- -! grid_type = 'Dense' -! inverse fourier transform of potentials and charge density -! on the dense grid . On output, f is overwritten -! grid_type = 'Smooth' -! inverse fourier transform of potentials and charge density -! on the smooth grid . On output, f is overwritten -! grid_type = 'Wave' -! inverse fourier transform of wave functions -! on the smooth grid . On output, f is overwritten -! grid_type = 'Box' -! not-so-parallel 3d fft for box grid, implemented only for sign=1 -! G-space to R-space, output = \sum_G f(G)exp(+iG*R) -! The array f (overwritten on output) is NOT distributed: -! a copy is present on each processor. -! The fft along z is done on the entire grid. -! The fft along xy is done only on planes that have components on the -! dense grid for each processor. Note that the final array will no -! longer be the same on all processors. -! - -! - USE kinds, ONLY: DP - use fft_base, only: dfftp, dffts, dfftb - use fft_scalar, only: cfft3d, cfft3ds, cft_b - use fft_parallel, only: tg_cft3s - use control_flags, only: use_task_groups - USE fft_types, only: fft_dlay_descriptor - - IMPLICIT none - - TYPE(fft_dlay_descriptor), INTENT(IN) :: dfft - INTEGER, OPTIONAL, INTENT(IN) :: ia - CHARACTER(LEN=*), INTENT(IN) :: grid_type - COMPLEX(DP) :: f(:) - ! - INTEGER :: imin3, imax3, np3 - - IF( grid_type == 'Dense' ) THEN - IF( dfft%nr1 /= dfftp%nr1 .OR. dfft%nr2 /= dfftp%nr2 .OR. dfft%nr3 /= dfftp%nr3 .OR. & - dfft%nr1x /= dfftp%nr1x .OR. dfft%nr2x /= dfftp%nr2x .OR. dfft%nr3x /= dfftp%nr3x ) & - CALL errore( ' invfft ', ' inconsistent descriptor for Dense fft ' , 1 ) - call start_clock( 'fft' ) - ELSE IF( grid_type == 'Smooth' ) THEN - IF( dfft%nr1 /= dffts%nr1 .OR. dfft%nr2 /= dffts%nr2 .OR. dfft%nr3 /= dffts%nr3 .OR. & - dfft%nr1x /= dffts%nr1x .OR. dfft%nr2x /= dffts%nr2x .OR. dfft%nr3x /= dffts%nr3x ) & - CALL errore( ' invfft ', ' inconsistent descriptor for Smooth fft ' , 1 ) - call start_clock( 'ffts' ) - ELSE IF( grid_type == 'Wave' ) THEN - IF( dfft%nr1 /= dffts%nr1 .OR. dfft%nr2 /= dffts%nr2 .OR. dfft%nr3 /= dffts%nr3 .OR. & - dfft%nr1x /= dffts%nr1x .OR. dfft%nr2x /= dffts%nr2x .OR. dfft%nr3x /= dffts%nr3x ) & - CALL errore( ' invfft ', ' inconsistent descriptor for Wave fft ' , 1 ) - call start_clock('fftw') - ELSE IF( grid_type == 'Box' ) THEN - IF( dfft%nr1 /= dfftb%nr1 .OR. dfft%nr2 /= dfftb%nr2 .OR. dfft%nr3 /= dfftb%nr3 .OR. & - dfft%nr1x /= dfftb%nr1x .OR. dfft%nr2x /= dfftb%nr2x .OR. dfft%nr3x /= dfftb%nr3x ) & - CALL errore( ' invfft ', ' inconsistent descriptor for Box fft ' , 1 ) - call start_clock( 'fftb' ) - ELSE - call errore( ' invfft ', ' unknown grid: '//grid_type , 1 ) - END IF - -#if defined __PARA && !defined __USE_3D_FFT - - IF( grid_type == 'Box' ) THEN - imin3 = dfftb%imin3( ia ) - imax3 = dfftb%imax3( ia ) - np3 = dfftb%np3( ia ) ! imax3 - imin3 + 1 - END IF - - IF( grid_type == 'Dense' ) THEN - call tg_cft3s( f, dfftp, 1 ) - ELSE IF( grid_type == 'Smooth' ) THEN - call tg_cft3s( f, dffts, 1 ) - ELSE IF( grid_type == 'Wave' ) THEN - call tg_cft3s( f, dffts, 2, use_task_groups ) - ELSE IF( grid_type == 'Box' .AND. np3 > 0 ) THEN - call cft_b( f, dfftb%nr1, dfftb%nr2, dfftb%nr3, dfftb%nr1x, dfftb%nr2x, dfftb%nr3x, imin3, imax3, 1 ) - END IF - -#else - -# if defined __SCSL || __SX6 || __USE_3D_FFT - - IF( grid_type == 'Dense' ) THEN - call cfft3d( f, dfftp%nr1, dfftp%nr2, dfftp%nr3, dfftp%nr1x, dfftp%nr2x, dfftp%nr3x, 1) - ELSE IF( grid_type == 'Smooth' ) THEN - call cfft3d( f, dffts%nr1, dffts%nr2, dffts%nr3, dffts%nr1x, dffts%nr2x, dffts%nr3x, 1) - ELSE IF( grid_type == 'Wave' ) THEN - call cfft3d( f, dffts%nr1, dffts%nr2, dffts%nr3, dffts%nr1x, dffts%nr2x, dffts%nr3x, 1) - ELSE IF( grid_type == 'Box' ) THEN - call cfft3d( f, dfftb%nr1, dfftb%nr2, dfftb%nr3, dfftb%nr1x, dfftb%nr2x, dfftb%nr3x, 1) - END IF - -# elif defined __ESSL || __LINUX_ESSL || __FFTW || __FFTW3 || __ACML - - IF( grid_type == 'Dense' ) THEN - call cfft3d( f, dfftp%nr1, dfftp%nr2, dfftp%nr3, dfftp%nr1x, dfftp%nr2x, dfftp%nr3x, 1) - ELSE IF( grid_type == 'Smooth' ) THEN - call cfft3d( f, dffts%nr1, dffts%nr2, dffts%nr3, dffts%nr1x, dffts%nr2x, dffts%nr3x, 1) - ELSE IF( grid_type == 'Wave' ) THEN - call cfft3ds( f, dffts%nr1, dffts%nr2, dffts%nr3, dffts%nr1x, dffts%nr2x, dffts%nr3x, 1, dffts%isind, dffts%iplw ) - ELSE IF( grid_type == 'Box' ) THEN - call cfft3d( f, dfftb%nr1, dfftb%nr2, dfftb%nr3, dfftb%nr1x, dfftb%nr2x, dfftb%nr3x, 1) - END IF - -# endif - -#endif - - IF( grid_type == 'Dense' ) THEN - call stop_clock( 'fft' ) - ELSE IF( grid_type == 'Smooth' ) THEN - call stop_clock( 'ffts' ) - ELSE IF( grid_type == 'Wave' ) THEN - call stop_clock('fftw') - ELSE IF( grid_type == 'Box' ) THEN - call stop_clock( 'fftb' ) - END IF -! - return - end subroutine invfft_x - - - -!----------------------------------------------------------------------- - subroutine fwfft_x( grid_type, f, dfft ) -!----------------------------------------------------------------------- -! grid_type = 'Dense' -! forward fourier transform of potentials and charge density -! on the dense grid . On output, f is overwritten -! grid_type = 'Smooth' -! forward fourier transform of potentials and charge density -! on the smooth grid . On output, f is overwritten -! grid_type = 'Wave' -! forward fourier transform of wave functions -! on the smooth grid . On output, f is overwritten -! - USE kinds, ONLY: DP - use fft_base, only: dfftp, dffts - use fft_scalar, only: cfft3d, cfft3ds - use fft_parallel, only: tg_cft3s - use control_flags, only: use_task_groups - USE fft_types, only: fft_dlay_descriptor - - implicit none - - TYPE(fft_dlay_descriptor), INTENT(IN) :: dfft - CHARACTER(LEN=*), INTENT(IN) :: grid_type - COMPLEX(DP) :: f(:) - - IF( grid_type == 'Dense' ) THEN - IF( dfft%nr1 /= dfftp%nr1 .OR. dfft%nr2 /= dfftp%nr2 .OR. dfft%nr3 /= dfftp%nr3 .OR. & - dfft%nr1x /= dfftp%nr1x .OR. dfft%nr2x /= dfftp%nr2x .OR. dfft%nr3x /= dfftp%nr3x ) & - CALL errore( ' fwfft ', ' inconsistent descriptor for Dense fft ' , 1 ) - call start_clock( 'fft' ) - ELSE IF( grid_type == 'Smooth' ) THEN - IF( dfft%nr1 /= dffts%nr1 .OR. dfft%nr2 /= dffts%nr2 .OR. dfft%nr3 /= dffts%nr3 .OR. & - dfft%nr1x /= dffts%nr1x .OR. dfft%nr2x /= dffts%nr2x .OR. dfft%nr3x /= dffts%nr3x ) & - CALL errore( ' fwfft ', ' inconsistent descriptor for Smooth fft ' , 1 ) - call start_clock( 'ffts' ) - ELSE IF( grid_type == 'Wave' ) THEN - IF( dfft%nr1 /= dffts%nr1 .OR. dfft%nr2 /= dffts%nr2 .OR. dfft%nr3 /= dffts%nr3 .OR. & - dfft%nr1x /= dffts%nr1x .OR. dfft%nr2x /= dffts%nr2x .OR. dfft%nr3x /= dffts%nr3x ) & - CALL errore( ' fwfft ', ' inconsistent descriptor for Wave fft ' , 1 ) - call start_clock( 'fftw' ) - ELSE - call errore( ' fwfft ', ' unknown grid: '//grid_type , 1 ) - END IF - -#if defined __PARA && !defined __USE_3D_FFT - - IF( grid_type == 'Dense' ) THEN - call tg_cft3s(f,dfftp,-1) - ELSE IF( grid_type == 'Smooth' ) THEN - call tg_cft3s(f,dffts,-1) - ELSE IF( grid_type == 'Wave' ) THEN - call tg_cft3s(f,dffts,-2, use_task_groups ) - END IF - -#else - -# if defined __SCSL || __SX6 || __USE_3D_FFT - - IF( grid_type == 'Dense' ) THEN - call cfft3d( f, dfftp%nr1, dfftp%nr2, dfftp%nr3, dfftp%nr1x, dfftp%nr2x, dfftp%nr3x, -1) - ELSE IF( grid_type == 'Smooth' ) THEN - call cfft3d( f, dffts%nr1, dffts%nr2, dffts%nr3, dffts%nr1x, dffts%nr2x, dffts%nr3x, -1) - ELSE IF( grid_type == 'Wave' ) THEN - call cfft3d( f, dffts%nr1, dffts%nr2, dffts%nr3, dffts%nr1x, dffts%nr2x, dffts%nr3x, -1) - END IF - -# elif defined __ESSL || __LINUX_ESSL || __FFTW || __FFTW3 || __ACML - - IF( grid_type == 'Dense' ) THEN - call cfft3d( f, dfftp%nr1, dfftp%nr2, dfftp%nr3, dfftp%nr1x, dfftp%nr2x, dfftp%nr3x, -1) - ELSE IF( grid_type == 'Smooth' ) THEN - call cfft3d( f, dffts%nr1, dffts%nr2, dffts%nr3, dffts%nr1x, dffts%nr2x, dffts%nr3x, -1) - ELSE IF( grid_type == 'Wave' ) THEN - call cfft3ds( f, dffts%nr1, dffts%nr2, dffts%nr3, dffts%nr1x, dffts%nr2x, dffts%nr3x, -1, dffts%isind, dffts%iplw ) - END IF - -# endif - -#endif - - IF( grid_type == 'Dense' ) THEN - call stop_clock( 'fft' ) - ELSE IF( grid_type == 'Smooth' ) THEN - call stop_clock( 'ffts' ) - ELSE IF( grid_type == 'Wave' ) THEN - call stop_clock( 'fftw' ) - END IF - - return - end subroutine fwfft_x - - - -!----------------------------------------------------------------------- - - - SUBROUTINE c2psi( psi, nnr, c, ca, ng, iflg ) - ! - use gvecs, only: nms, nps - use kinds, only: DP - - implicit none - - complex(DP) :: psi(*), c(*), ca(*) - integer, intent(in) :: nnr, ng, iflg - - complex(DP), parameter :: ci=(0.0d0,1.0d0) - integer :: ig - - psi( 1 : nnr ) = 0.0d0 - - ! - ! iflg "cases" - ! - ! 0 Do not use gamma symmetry - ! - ! 1 set psi using a wf with Gamma symmetry - - ! 2 set psi combining two wf with Gamma symmetry - ! - - SELECT CASE ( iflg ) - ! - ! Case 0, 1 and 2 SMOOTH MESH - ! - CASE ( 0 ) - ! - do ig = 1, ng - psi( nps( ig ) ) = c( ig ) - end do - ! - CASE ( 1 ) - ! - do ig = 1, ng - psi( nms( ig ) ) = CONJG( c( ig ) ) - psi( nps( ig ) ) = c( ig ) - end do - ! - CASE ( 2 ) - ! - do ig = 1, ng - psi( nms( ig ) ) = CONJG( c( ig ) ) + ci * conjg( ca( ig ) ) - psi( nps( ig ) ) = c( ig ) + ci * ca( ig ) - end do - - CASE DEFAULT - ! - CALL errore(" c2psi "," wrong value for iflg ", ABS( iflg ) ) - - END SELECT - - return - END SUBROUTINE c2psi - -! -! -! - - SUBROUTINE rho2psi( grid_type, psi, nnr, rho, ng ) - ! - use recvecs_indexes, only: nm, np - use gvecs, only: nms, nps - use kinds, only: DP - - implicit none - - complex(DP) :: psi(*), rho(*) - integer, intent(in) :: nnr, ng - character(len=*), intent(in) :: grid_type - - integer :: ig - - psi( 1 : nnr ) = 0.0d0 - - SELECT CASE ( grid_type ) - ! - ! Case 0, 1 and 2 SMOOTH MESH - ! - CASE ( 'Smooth' ) - ! - ! without gamma sym - ! do ig = 1, ng - ! psi( nps( ig ) ) = rho( ig ) - ! end do - ! - do ig = 1, ng - psi( nms( ig ) ) = CONJG( rho( ig ) ) - psi( nps( ig ) ) = rho( ig ) - end do - ! - CASE ( 'Dense' ) - ! - ! do ig = 1, ng - ! psi( np( ig ) ) = rho( ig ) - ! end do - ! - do ig = 1, ng - psi( nm( ig ) ) = CONJG( rho( ig ) ) - psi( np( ig ) ) = rho( ig ) - end do - ! - CASE DEFAULT - ! - CALL errore(" rho2psi "," wrong grid "//grid_type , 1 ) - - END SELECT - - return - END SUBROUTINE rho2psi - -!----------------------------------------------------------------------- - - SUBROUTINE psi2c( psi, nnr, c, ca, ng, iflg ) - - use recvecs_indexes, only: nm, np - use gvecs, only: nms, nps - use kinds, only: DP - - implicit none - - complex(DP) :: psi(*), c(*), ca(*) - integer, intent(in) :: nnr, ng, iflg - - complex(DP), parameter :: ci=(0.0d0,1.0d0) - integer :: ig - - ! - ! iflg "cases" - ! - ! 0, 10 Do not use gamma symmetry - ! - ! 1, 11 set psi using a wf with Gamma symmetry - ! - ! 2, 12 set psi combining two wf with Gamma symmetry - ! - - SELECT CASE ( iflg ) - - ! - ! Case 0, 1 and 2 SMOOTH MESH - ! - CASE ( 0 ) - ! - do ig = 1, ng - c( ig ) = psi( nps( ig ) ) - end do - ! - CASE ( 1 ) - ! - CALL errore(" psi2c "," wrong value for iflg ", 11 ) - ! - CASE ( 2 ) - ! - DO ig = 1, ng - ca(ig) = psi( nms( ig ) ) - c (ig) = psi( nps( ig ) ) - END DO - - ! - ! Case 10, 11 and 12 DENSE MESH - ! - CASE ( 10 ) - ! - do ig = 1, ng - c( ig ) = psi( np( ig ) ) - end do - ! - CASE ( 11 ) - ! - CALL errore(" psi2c "," wrong value for iflg ", 1 ) - ! - CASE ( 12 ) - ! - DO ig = 1, ng - ca(ig) = psi( nm( ig ) ) - c (ig) = psi( np( ig ) ) - END DO - - CASE DEFAULT - ! - CALL errore(" psi2c "," wrong value for iflg ", ABS( iflg ) ) - - END SELECT - - return - END SUBROUTINE psi2c - -!----------------------------------------------------------------------- - - SUBROUTINE psi2rho( grid_type, psi, nnr, rho, ng ) - - use recvecs_indexes, only: np - use gvecs, only: nps - use kinds, only: DP - - implicit none - - complex(DP) :: psi(*), rho(*) - integer, intent(in) :: nnr, ng - character(len=*), intent(in) :: grid_type - - integer :: ig - - SELECT CASE ( grid_type ) - ! - CASE ( 'Smooth' ) - ! - do ig = 1, ng - rho( ig ) = psi( nps( ig ) ) - end do - ! - CASE ( 'Dense' ) - ! - do ig = 1, ng - rho( ig ) = psi( np( ig ) ) - end do - ! - CASE DEFAULT - ! - CALL errore(" psi2rho "," wrong grid "//grid_type , 1 ) - - END SELECT - - return - END SUBROUTINE psi2rho - - - -!----------------------------------------------------------------------- - SUBROUTINE box2grid(irb,nfft,qv,vr) -!----------------------------------------------------------------------- -! -! add array qv(r) on box grid to array vr(r) on dense grid -! irb : position of the box in the dense grid -! nfft=1 add real part of qv(r) to real part of array vr(r) -! nfft=2 add imaginary part of qv(r) to real part of array vr(r) -! - USE grid_dimensions, ONLY: nr1, nr2, nr3, & - nr1x, nr2x, nnr => nnrx - USE smallbox_grid_dimensions, ONLY: nr1b, nr2b, nr3b, & - nr1bx, nr2bx, nnrb => nnrbx - USE fft_base, ONLY: dfftp - USE mp_global, ONLY: me_image - - IMPLICIT NONE - INTEGER, INTENT(in):: nfft, irb(3) - REAL(8), INTENT(in):: qv(2,nnrb) - COMPLEX(8), INTENT(inout):: vr(nnr) -! - INTEGER ir1, ir2, ir3, ir, ibig1, ibig2, ibig3, ibig - INTEGER me - - IF(nfft.LE.0.OR.nfft.GT.2) CALL errore('box2grid','wrong data',nfft) - - me = me_image + 1 - - DO ir3=1,nr3b - ibig3=irb(3)+ir3-1 - ibig3=1+MOD(ibig3-1,nr3) - IF(ibig3.LT.1.OR.ibig3.GT.nr3) & - & CALL errore('box2grid','ibig3 wrong',ibig3) - ibig3=ibig3-dfftp%ipp(me) - IF ( ibig3 .GT. 0 .AND. ibig3 .LE. ( dfftp%npp(me) ) ) THEN - DO ir2=1,nr2b - ibig2=irb(2)+ir2-1 - ibig2=1+MOD(ibig2-1,nr2) - IF(ibig2.LT.1.OR.ibig2.GT.nr2) & - & CALL errore('box2grid','ibig2 wrong',ibig2) - DO ir1=1,nr1b - ibig1=irb(1)+ir1-1 - ibig1=1+MOD(ibig1-1,nr1) - IF(ibig1.LT.1.OR.ibig1.GT.nr1) & - & CALL errore('box2grid','ibig1 wrong',ibig1) - ibig=ibig1+(ibig2-1)*nr1x+(ibig3-1)*nr1x*nr2x - ir=ir1+(ir2-1)*nr1bx+(ir3-1)*nr1bx*nr2bx - vr(ibig) = vr(ibig)+qv(nfft,ir) - END DO - END DO - END IF - END DO -! - RETURN - END SUBROUTINE box2grid - - -!----------------------------------------------------------------------- - SUBROUTINE box2grid2(irb,qv,v) -!----------------------------------------------------------------------- -! -! add array qv(r) on box grid to array v(r) on dense grid -! irb : position of the box in the dense grid -! - USE grid_dimensions, ONLY: nr1, nr2, nr3, & - nr1x, nr2x, nnr => nnrx - USE smallbox_grid_dimensions, ONLY: nr1b, nr2b, nr3b, & - nr1bx, nr2bx, nnrb => nnrbx - USE fft_base, ONLY: dfftp - USE mp_global, ONLY: me_image - ! - IMPLICIT NONE - ! - INTEGER, INTENT(in):: irb(3) - COMPLEX(8), INTENT(in):: qv(nnrb) - COMPLEX(8), INTENT(inout):: v(nnr) -! - INTEGER ir1, ir2, ir3, ir, ibig1, ibig2, ibig3, ibig - INTEGER me - - me = me_image + 1 - - DO ir3=1,nr3b - ibig3=irb(3)+ir3-1 - ibig3=1+MOD(ibig3-1,nr3) - IF(ibig3.LT.1.OR.ibig3.GT.nr3) & - & CALL errore('box2grid2','ibig3 wrong',ibig3) - ibig3=ibig3-dfftp%ipp(me) - IF (ibig3.GT.0.AND.ibig3.LE. dfftp%npp(me) ) THEN - DO ir2=1,nr2b - ibig2=irb(2)+ir2-1 - ibig2=1+MOD(ibig2-1,nr2) - IF(ibig2.LT.1.OR.ibig2.GT.nr2) & - & CALL errore('box2grid2','ibig2 wrong',ibig2) - DO ir1=1,nr1b - ibig1=irb(1)+ir1-1 - ibig1=1+MOD(ibig1-1,nr1) - IF(ibig1.LT.1.OR.ibig1.GT.nr1) & - & CALL errore('box2grid2','ibig1 wrong',ibig1) - ibig=ibig1+(ibig2-1)*nr1x+(ibig3-1)*nr1x*nr2x - ir=ir1+(ir2-1)*nr1bx+(ir3-1)*nr1bx*nr2bx - v(ibig) = v(ibig)+qv(ir) - END DO - END DO - END IF - END DO - - RETURN - END SUBROUTINE box2grid2 - - -!----------------------------------------------------------------------- - REAL(8) FUNCTION boxdotgrid(irb,nfft,qv,vr) -!----------------------------------------------------------------------- -! -! Calculate \sum_i qv(r_i)*vr(r_i) with r_i on box grid -! array qv(r) is defined on box grid, array vr(r)on dense grid -! irb : position of the box in the dense grid -! nfft=1 (2): use real (imaginary) part of qv(r) -! Parallel execution: remember to sum the contributions from other nodes -! - USE grid_dimensions, ONLY: nr1, nr2, nr3, & - nr1x, nr2x, nnr => nnrx - USE smallbox_grid_dimensions, ONLY: nr1b, nr2b, nr3b, & - nr1bx, nr2bx, nnrb => nnrbx - USE fft_base, ONLY: dfftp - USE mp_global, ONLY: me_image - IMPLICIT NONE - INTEGER, INTENT(in):: nfft, irb(3) - REAL(8), INTENT(in):: qv(2,nnrb), vr(nnr) -! - INTEGER ir1, ir2, ir3, ir, ibig1, ibig2, ibig3, ibig - INTEGER me -! -! - IF(nfft.LE.0.OR.nfft.GT.2) CALL errore('boxdotgrid','wrong data',nfft) - - me = me_image + 1 - - boxdotgrid=0.d0 - - DO ir3=1,nr3b - ibig3=irb(3)+ir3-1 - ibig3=1+MOD(ibig3-1,nr3) - ibig3=ibig3-dfftp%ipp(me) - IF (ibig3.GT.0.AND.ibig3.LE. dfftp%npp(me) ) THEN - DO ir2=1,nr2b - ibig2=irb(2)+ir2-1 - ibig2=1+MOD(ibig2-1,nr2) - DO ir1=1,nr1b - ibig1=irb(1)+ir1-1 - ibig1=1+MOD(ibig1-1,nr1) - ibig=ibig1 + (ibig2-1)*nr1x + (ibig3-1)*nr1x*nr2x - ir =ir1 + (ir2-1)*nr1bx + (ir3-1)*nr1bx*nr2bx - boxdotgrid = boxdotgrid + qv(nfft,ir)*vr(ibig) - END DO - END DO - ENDIF - END DO - - RETURN - END FUNCTION boxdotgrid - - -! -!---------------------------------------------------------------------- - subroutine parabox(nr3b,irb3,nr3,imin3,imax3) -!---------------------------------------------------------------------- -! -! find if box grid planes in the z direction have component on the dense -! grid on this processor, and if, which range imin3-imax3 -! - use mp_global, only: me_image - use fft_base, only: dfftp -! input - integer nr3b,irb3,nr3 -! output - integer imin3,imax3 -! local - integer ir3, ibig3, me -! - me = me_image + 1 - imin3=nr3b - imax3=1 - do ir3=1,nr3b - ibig3=1+mod(irb3+ir3-2,nr3) - if(ibig3.lt.1.or.ibig3.gt.nr3) & - & call errore('cfftpb','ibig3 wrong',ibig3) - ibig3=ibig3-dfftp%ipp(me) - if (ibig3.gt.0.and.ibig3.le.dfftp%npp(me)) then - imin3=min(imin3,ir3) - imax3=max(imax3,ir3) - end if - end do -! - return - end subroutine parabox - diff --git a/quantum_espresso/kcp/CPV/forceconv.f90 b/quantum_espresso/kcp/CPV/forceconv.f90 deleted file mode 100644 index f8c9d331e..000000000 --- a/quantum_espresso/kcp/CPV/forceconv.f90 +++ /dev/null @@ -1,48 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - - subroutine force_conv(FNEW,FOLD,DF,NA,NAX,NSP) - - USE kinds - implicit none - - integer nax,nsp,na(nsp) - REAL(DP) fnew(3,nax,nsp) - REAL(DP) fold(3,nax,nsp) - - REAL(DP) df - - integer is,ia,j,nat - REAL(DP) diffnorm, normold, normnew - - - nat = 0 - diffnorm = 0.0d0 - normold = 0.0d0 - normnew = 0.0d0 - do is = 1,nsp - do ia = 1,na(is) - do j = 1,3 - diffnorm = diffnorm + (fnew(j,ia,is)-fold(j,ia,is))**2 - normold = normold + fold(j,ia,is)**2 - normnew = normnew + fnew(j,ia,is)**2 - end do - nat = nat + na(is) - end do - end do - - df = (normold**0.25d0 * normnew**0.25d0) - if(df.gt.0.0d0) then - df = sqrt(diffnorm)/ df - else - df = sqrt(diffnorm)/ 1.d-10 - end if - - return - end subroutine force_conv diff --git a/quantum_espresso/kcp/CPV/forces.f90 b/quantum_espresso/kcp/CPV/forces.f90 deleted file mode 100644 index 872909289..000000000 --- a/quantum_espresso/kcp/CPV/forces.f90 +++ /dev/null @@ -1,702 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -! Written and revised by Carlo Cavazzoni -! Task Groups parallelization by C. Bekas (IBM Research Zurich). -! - -#include "f_defs.h" - - -! -!------------------------------------------------------------------------- - SUBROUTINE dforce_x_new ( i, bec, vkb, c, df, da, v, ldv, ispin, f, n, nspin, v1 ) -!----------------------------------------------------------------------- -!computes: the generalized force df=CMPLX(dfr,dfi) acting on the i-th -! electron state at the gamma point of the brillouin zone -! represented by the vector c=CMPLX(cr,ci) -! -! d_n(g) = f_n { 0.5 g^2 c_n(g) + [vc_n](g) + -! sum_i,ij d^q_i,ij (-i)**l beta_i,i(g) -! e^-ig.r_i < beta_i,j | c_n >} !warning:giovanni check this expression -! - USE parallel_include - USE kinds, ONLY: dp - USE control_flags, ONLY: use_task_groups, program_name, & - gamma_only, do_wf_cmplx - USE gvecs, ONLY: nms, nps - USE cvan, ONLY: ish - USE uspp, ONLY: nhsa=>nkb, dvan, deeq - USE uspp_param, ONLY: nh - USE smooth_grid_dimensions, ONLY: nr1sx, nr2sx, nr3sx, nnrsx - USE constants, ONLY: pi, fpi - USE ions_base, ONLY: nsp, na - USE gvecw, ONLY: ngw, ggp - USE cell_base, ONLY: tpiba2 - USE ensemble_dft, ONLY: tens, tsmear - USE fft_base, ONLY: dffts - USE funct, ONLY: dft_is_meta - USE cp_interfaces, ONLY: fwfft, invfft - USE mp_global, ONLY: nogrp, me_image - USE twin_types !added:giovanni -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: i - type(twin_matrix) :: bec !(:,:)!modified:giovanni - COMPLEX(DP) :: vkb(:,:) - COMPLEX(DP) :: c(:,:) - COMPLEX(DP) :: df(:), da(:) - INTEGER, INTENT(IN) :: ldv - REAL(DP) :: v( ldv, * ) - INTEGER :: ispin( : ) - REAL(DP) :: f( : ) - INTEGER, INTENT(IN) :: n, nspin - REAL(DP), OPTIONAL :: v1( ldv, * ) - ! - ! - ! local variables - ! - INTEGER :: iv, jv, ia, is, isa, ism, iss1, iss2, ir, ig, inl, jnl - INTEGER :: ivoff, jvoff, igoff, igno, igrp - INTEGER :: idx, eig_offset, nogrp_ - REAL(DP) :: fi, fip, dd, dv - COMPLEX(DP) :: fp, fm, ci - COMPLEX(DP), ALLOCATABLE :: af( :, : ), aa( :, : ) !modified:giovanni - COMPLEX(DP), ALLOCATABLE :: psi(:), psi2(:) - LOGICAL :: lgam !added:giovanni - INTEGER :: nwav - COMPLEX(DP), PARAMETER :: c_one = CMPLX(1.d0, 0.d0) - ! - CALL start_clock( 'dforce' ) - ! - lgam=gamma_only.and..not.do_wf_cmplx - ! - nwav=2 - ! - IF( use_task_groups ) THEN - nogrp_ = nogrp - ALLOCATE( psi( dffts%nnrx * nogrp ) ) - IF(.not.lgam) ALLOCATE( psi2( dffts%nnrx * nogrp ) ) - ELSE - nogrp_ = 1 - ALLOCATE( psi( nnrsx ) ) - IF(.not.lgam) ALLOCATE( psi2( nnrsx ) ) - END IF - ! - ci = CMPLX( 0.0d0, 1.0d0 ) - ! - psi( : ) = CMPLX(0.d0, 0.d0) - ! - IF(.not.lgam) psi2( : ) = CMPLX(0.d0, 0.d0) - ! - igoff = 0 - ! - DO idx = 1, nwav*nogrp_, nwav !warning:giovanni:parallel - ! - ! This loop is executed only ONCE when NOGRP=1. - ! Equivalent to the case with no task-groups - ! dfft%nsw(me) holds the number of z-sticks for the current processor per wave-function - ! We can either send these in the group with an mpi_allgather...or put the - ! in the PSIS vector (in special positions) and send them with them. - ! Otherwise we can do this once at the beginning, before the loop. - ! we choose to do the latter one. - ! - ! important: if n is odd => c(*,n+1)=0. - ! - IF ( ( idx + i - 1 ) == n ) c( : , idx + i ) = CMPLX(0.0d0,0.d0) - ! - IF( idx + i - 1 <= n ) THEN - IF(lgam) THEN - DO ig=1,ngw - psi(nms(ig)+igoff) = CONJG( c(ig,idx+i-1) - ci * c(ig,idx+i) ) - psi(nps(ig)+igoff) = c(ig,idx+i-1) + ci * c(ig,idx+i) - END DO - ELSE - DO ig=1,ngw - psi(nps(ig)+igoff) = c(ig,idx+i-1) - psi2(nps(ig)+igoff) = c(ig,idx+i) - END DO - ENDIF - END IF - ! - igoff = igoff + dffts%nnrx - ! - ENDDO - ! - CALL invfft( 'Wave', psi, dffts ) - IF (.not.lgam) CALL invfft( 'Wave', psi2, dffts ) - ! - ! the following avoids a potential out-of-bounds error - ! - IF ( i < n ) THEN - iss1 = ispin(i) - iss2 = ispin(i+1) - ELSE - iss1 = ispin(i) - iss2 = iss1 - END IF - ! - IF( use_task_groups ) THEN - ! -!$omp parallel do - - IF(lgam) THEN - DO ir = 1, nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ) - psi(ir) = CMPLX( v(ir,iss1) * DBLE( psi(ir) ), v(ir,iss2) * AIMAG( psi(ir) ) ) - END DO - ELSE !warning:giovanni:parallel - DO ir = 1, nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ) - psi(ir) = v(ir,iss1) * psi(ir) - psi2(ir) = v(ir,iss2) * psi2(ir) - END DO - ENDIF -!$omp end parallel do - ! - ELSE - ! - IF( PRESENT( v1 ) ) THEN -!$omp parallel do - IF(lgam) THEN - DO ir=1,nnrsx - psi(ir)=CMPLX(v(ir,iss1)* DBLE(psi(ir)), v1(ir,iss2)*AIMAG(psi(ir)) ) - END DO - ELSE - DO ir=1,nnrsx - psi(ir) =v(ir,iss1) * psi(ir) - psi2(ir)=v1(ir,iss2)* psi2(ir) - END DO - ENDIF -!$omp end parallel do - ELSE -!$omp parallel do - IF(lgam) THEN - DO ir=1,nnrsx - psi(ir)=CMPLX(v(ir,iss1)* DBLE(psi(ir)), v(ir,iss2)*AIMAG(psi(ir)) ) - END DO - ELSE - DO ir=1,nnrsx - psi(ir)=v(ir,iss1)* psi(ir) - psi2(ir)=v(ir,iss2)* psi2(ir) - END DO - ENDIF -!$omp end parallel do - END IF - ! - END IF - ! - CALL fwfft( 'Wave', psi, dffts ) - IF(.not.lgam) CALL fwfft( 'Wave', psi2, dffts ) - ! - ! note : the factor 0.5 appears - ! in the kinetic energy because it is defined as 0.5*g**2 - ! in the potential part because of the logics - ! - ! Each processor will treat its own part of the eigenstate - ! assigned to its ORBITAL group - ! - eig_offset = 0 - igno = 1 - ! - DO idx = 1, nwav*nogrp_ , nwav !warning:giovanni:parallel - ! - IF( idx + i - 1 <= n ) THEN - ! - if ( tens .or. tsmear ) then - fi = -0.5d0 - fip = -0.5d0 - else - ! - ! spin multiplicity is taken into account - ! before the call - ! - fi = -0.5d0*f(i+idx-1) - fip = -0.5d0*f(i+idx) - endif - ! - IF( use_task_groups ) THEN -!$omp parallel do private( fp, fm ) - IF(lgam) THEN - DO ig=1,ngw - fp= psi(nps(ig)+eig_offset) + psi(nms(ig)+eig_offset) - fm= psi(nps(ig)+eig_offset) - psi(nms(ig)+eig_offset) - df(ig+igno-1)= fi *(tpiba2 * ggp(ig) * c(ig,idx+i-1)+CMPLX(DBLE (fp), AIMAG(fm))) - da(ig+igno-1)= fip*(tpiba2 * ggp(ig) * c(ig,idx+i )+CMPLX(AIMAG(fp),-DBLE (fm))) - END DO - ELSE - DO ig=1,ngw - fp= psi(nps(ig)+eig_offset) !+ psi(nms(ig)+eig_offset) - fm= psi2(nps(ig)+eig_offset)! - psi(nms(ig)+eig_offset) - df(ig+igno-1)= fi *(tpiba2 * ggp(ig) * c(ig,idx+i-1)+2.d0*fp) - da(ig+igno-1)= fip*(tpiba2 * ggp(ig) * c(ig,idx+i )+2.d0*fm) - END DO - ENDIF -!$omp end parallel do - igno = igno + ngw - ELSE - IF(lgam) THEN -!$omp parallel do private( fp, fm ) - DO ig=1,ngw - fp= psi(nps(ig)) + psi(nms(ig)) - fm= psi(nps(ig)) - psi(nms(ig)) - df(ig)= fi*(tpiba2*ggp(ig)* c(ig,idx+i-1)+CMPLX(DBLE(fp), AIMAG(fm))) - da(ig)=fip*(tpiba2*ggp(ig)* c(ig,idx+i )+CMPLX(AIMAG(fp),-DBLE(fm))) - END DO -!$omp end parallel do - ELSE -!$omp parallel do private( fp, fm ) - DO ig=1,ngw - fp= psi(nps(ig)) !+ psi(nms(ig)) - fm= psi2(nps(ig)) !- psi(nms(ig)) - df(ig)= fi*(tpiba2*ggp(ig)* c(ig,idx+i-1)+2.d0*fp) - da(ig)=fip*(tpiba2*ggp(ig)* c(ig,idx+i )+2.d0*fm) - END DO -!$omp end parallel do - ENDIF - ENDIF - ENDIF - ! - eig_offset = eig_offset + nr3sx * dffts%nsw(me_image+1) - ! We take into account the number of elements received from other members of the orbital group - ! - ENDDO - ! - IF(dft_is_meta()) THEN - CALL dforce_meta_new(c(1,i),c(1,i+1),df,da,psi,psi2,iss1,iss2,fi,fip) !METAGGA !modified:giovanni - END IF - ! - IF( nhsa > 0 ) THEN - ! - ! aa_i,i,n = sum_j d_i,ij - ! - ALLOCATE( af( nhsa, nogrp_ ), aa( nhsa, nogrp_ ) ) - ! - af = CMPLX(0.0d0, 0.d0) - aa = CMPLX(0.0d0, 0.d0) - ! - igrp = 1 - ! - DO idx = 1, 2*nogrp_ , 2 - ! - IF ( idx + i - 1 <= n ) THEN - ! - IF ( tens .or. tsmear ) THEN - fi = 1.0d0 - fip= 1.0d0 - ELSE - ! - ! spin multiplicity is taken into account - ! before the call - ! - fi = f(i+idx-1) - fip= f(i+idx) - ! - ENDIF - ! - DO is = 1, nsp - ! - DO iv = 1, nh(is) - IF( program_name == 'FPMD' ) THEN !warning:giovanni:fpmd not implemented - ivoff = ish(is) + (iv-1) * na(is) - dd = dvan( iv, iv, is ) - DO inl = ivoff + 1, ivoff + na(is) - af(inl,igrp) = af(inl,igrp) - fi * dd * bec%rvec(inl,i+idx-1) - END DO - IF( i + idx - 1 /= n ) THEN - DO inl = ivoff + 1, ivoff + na(is) - aa(inl,igrp) = aa(inl,igrp) - fip * dd * bec%rvec(inl,i+idx) - END DO - END IF - ELSE - IF(.not.bec%iscmplx) THEN - DO jv = 1, nh(is) - isa = 0 - DO ism = 1, is-1 - isa = isa + na( ism ) - END DO - dv = dvan(iv,jv,is) - ivoff = ish(is)+(iv-1)*na(is) - jvoff = ish(is)+(jv-1)*na(is) - IF( i + idx - 1 /= n ) THEN - !$omp do - DO ia=1,na(is) - inl = ivoff + ia - jnl = jvoff + ia - isa = isa + 1 - dd = deeq(iv,jv,isa,iss1) + dv - af(inl,igrp) = af(inl,igrp) - fi * dd * bec%rvec(jnl,i+idx-1) - dd = deeq(iv,jv,isa,iss2) + dv - aa(inl,igrp) = aa(inl,igrp) - fip * dd * bec%rvec(jnl,i+idx) - END DO - ELSE - !$omp do - DO ia=1,na(is) - inl = ivoff + ia - jnl = jvoff + ia - isa = isa + 1 - dd = deeq(iv,jv,isa,iss1) + dv - af(inl,igrp) = af(inl,igrp) - fi * dd * bec%rvec(jnl,i+idx-1) - END DO - END IF - END DO - ELSE -!begin_added:giovanni - DO jv = 1, nh(is) - isa = 0 - DO ism = 1, is-1 - isa = isa + na( ism ) - END DO - dv = dvan(iv,jv,is) - ivoff = ish(is)+(iv-1)*na(is) - jvoff = ish(is)+(jv-1)*na(is) - IF( i + idx - 1 /= n ) THEN - !$omp do - DO ia=1,na(is) - inl = ivoff + ia - jnl = jvoff + ia - isa = isa + 1 - dd = deeq(iv,jv,isa,iss1) + dv - af(inl,igrp) = af(inl,igrp) - fi * dd * (bec%cvec(jnl,i+idx-1)) - dd = deeq(iv,jv,isa,iss2) + dv - aa(inl,igrp) = aa(inl,igrp) - fip * dd * (bec%cvec(jnl,i+idx)) - END DO - ELSE - !$omp do - DO ia=1,na(is) - inl = ivoff + ia - jnl = jvoff + ia - isa = isa + 1 - dd = deeq(iv,jv,isa,iss1) + dv - af(inl,igrp) = af(inl,igrp) - fi * dd * (bec%cvec(jnl,i+idx-1)) - END DO - END IF - END DO - ENDIF -!end_added:giovanni - END IF - END DO - END DO - ! -!$omp end parallel - - ENDIF - ! - igrp = igrp + 1 - ! - ENDDO - ! - CALL ZGEMM ( 'N', 'N', ngw, nogrp_ , nhsa, c_one, vkb, ngw, af, nhsa, c_one, df, ngw) !df=df+beta*af !!! beta_j*af_jk= beta_j> d_ij - CALL ZGEMM ( 'N', 'N', ngw, nogrp_ , nhsa, c_one, vkb, ngw, aa, nhsa, c_one, da, ngw) - ! - DEALLOCATE( aa, af ) - ! - ENDIF - - DEALLOCATE( psi ) - IF(.not.lgam) DEALLOCATE(psi2) -! - CALL stop_clock( 'dforce' ) -! - RETURN - END SUBROUTINE dforce_x_new - -! -!------------------------------------------------------------------------- - SUBROUTINE dforce_x ( i, bec, vkb, c, df, da, v, ldv, ispin, f, n, nspin, v1 ) -!----------------------------------------------------------------------- -!computes: the generalized force df=CMPLX(dfr,dfi) acting on the i-th -! electron state at the gamma point of the brillouin zone -! represented by the vector c=CMPLX(cr,ci) -! -! d_n(g) = f_n { 0.5 g^2 c_n(g) + [vc_n](g) + -! sum_i,ij d^q_i,ij (-i)**l beta_i,i(g) -! e^-ig.r_i < beta_i,j | c_n >} -! - USE parallel_include - USE kinds, ONLY: dp - USE control_flags, ONLY: use_task_groups, program_name - USE gvecs, ONLY: nms, nps - USE cvan, ONLY: ish - USE uspp, ONLY: nhsa=>nkb, dvan, deeq - USE uspp_param, ONLY: nh - USE smooth_grid_dimensions, ONLY: nr1sx, nr2sx, nr3sx, nnrsx - USE constants, ONLY: pi, fpi - USE ions_base, ONLY: nsp, na - USE gvecw, ONLY: ngw, ggp - USE cell_base, ONLY: tpiba2 - USE ensemble_dft, ONLY: tens, tsmear - USE fft_base, ONLY: dffts - USE funct, ONLY: dft_is_meta - USE cp_interfaces, ONLY: fwfft, invfft - USE mp_global, ONLY: nogrp, me_image -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: i - REAL(DP) :: bec(:,:) - COMPLEX(DP) :: vkb(:,:) - COMPLEX(DP) :: c(:,:) - COMPLEX(DP) :: df(:), da(:) - INTEGER, INTENT(IN) :: ldv - REAL(DP) :: v( ldv, * ) - INTEGER :: ispin( : ) - REAL(DP) :: f( : ) - INTEGER, INTENT(IN) :: n, nspin - REAL(DP), OPTIONAL :: v1( ldv, * ) - ! - ! - ! local variables - ! - INTEGER :: iv, jv, ia, is, isa, ism, iss1, iss2, ir, ig, inl, jnl - INTEGER :: ivoff, jvoff, igoff, igno, igrp - INTEGER :: idx, eig_offset, nogrp_ - REAL(DP) :: fi, fip, dd, dv - COMPLEX(DP) :: fp, fm, ci - REAL(DP), ALLOCATABLE :: af( :, : ), aa( :, : ) - COMPLEX(DP), ALLOCATABLE :: psi(:) - ! - CALL start_clock( 'dforce' ) - ! - IF( use_task_groups ) THEN - nogrp_ = nogrp - ALLOCATE( psi( dffts%nnrx * nogrp ) ) - ELSE - nogrp_ = 1 - ALLOCATE( psi( nnrsx ) ) - END IF - ! - ci = ( 0.0d0, 1.0d0 ) - ! - psi( : ) = (0.d0, 0.d0) - - igoff = 0 - - DO idx = 1, 2*nogrp_ , 2 - ! - ! This loop is executed only ONCE when NOGRP=1. - ! Equivalent to the case with no task-groups - ! dfft%nsw(me) holds the number of z-sticks for the current processor per wave-function - ! We can either send these in the group with an mpi_allgather...or put the - ! in the PSIS vector (in special positions) and send them with them. - ! Otherwise we can do this once at the beginning, before the loop. - ! we choose to do the latter one. - ! - ! important: if n is odd => c(*,n+1)=0. - ! - IF ( ( idx + i - 1 ) == n ) c( : , idx + i ) = 0.0d0 - ! - IF( idx + i - 1 <= n ) THEN - DO ig=1,ngw - psi(nms(ig)+igoff) = conjg( c(ig,idx+i-1) - ci * c(ig,idx+i) ) - psi(nps(ig)+igoff) = c(ig,idx+i-1) + ci * c(ig,idx+i) - END DO - END IF - ! - igoff = igoff + dffts%nnrx - ! - END DO - - CALL invfft( 'Wave', psi, dffts ) - ! - ! the following avoids a potential out-of-bounds error - ! - IF ( i < n ) THEN - iss1 = ispin(i) - iss2 = ispin(i+1) - ELSE - iss1 = ispin(i) - iss2 = iss1 - END IF - ! - IF( use_task_groups ) THEN - ! -!$omp parallel do - DO ir = 1, nr1sx * nr2sx * dffts%tg_npp( me_image + 1 ) - psi(ir) = CMPLX( v(ir,iss1) * DBLE( psi(ir) ), v(ir,iss2) * AIMAG( psi(ir) ) ) - END DO -!$omp end parallel do - ! - ELSE - ! - IF( PRESENT( v1 ) ) THEN -!$omp parallel do - DO ir=1,nnrsx - psi(ir)=CMPLX(v(ir,iss1)* DBLE(psi(ir)), v1(ir,iss2)*AIMAG(psi(ir)) ) - END DO -!$omp end parallel do - ELSE -!$omp parallel do - DO ir=1,nnrsx - psi(ir)=CMPLX(v(ir,iss1)* DBLE(psi(ir)), v(ir,iss2)*AIMAG(psi(ir)) ) - END DO -!$omp end parallel do - END IF - ! - END IF - ! - CALL fwfft( 'Wave', psi, dffts ) - ! - ! note : the factor 0.5 appears - ! in the kinetic energy because it is defined as 0.5*g**2 - ! in the potential part because of the logics - ! - ! Each processor will treat its own part of the eigenstate - ! assigned to its ORBITAL group - ! - eig_offset = 0 - igno = 1 - - DO idx = 1, 2*nogrp_ , 2 - - IF( idx + i - 1 <= n ) THEN - ! - if ( tens .or. tsmear ) then - fi = -0.5d0 - fip = -0.5d0 - else - ! - ! spin multiplicity is taken into account - ! before the call - ! - fi = -0.5d0*f(i+idx-1) - fip = -0.5d0*f(i+idx) - endif - IF( use_task_groups ) THEN -!$omp parallel do private( fp, fm ) - DO ig=1,ngw - fp= psi(nps(ig)+eig_offset) + psi(nms(ig)+eig_offset) - fm= psi(nps(ig)+eig_offset) - psi(nms(ig)+eig_offset) - df(ig+igno-1)= fi *(tpiba2 * ggp(ig) * c(ig,idx+i-1)+CMPLX(DBLE (fp), AIMAG(fm))) - da(ig+igno-1)= fip*(tpiba2 * ggp(ig) * c(ig,idx+i )+CMPLX(AIMAG(fp),-DBLE (fm))) - END DO -!$omp end parallel do - igno = igno + ngw - ELSE -!$omp parallel do private( fp, fm ) - DO ig=1,ngw - fp= psi(nps(ig)) + psi(nms(ig)) - fm= psi(nps(ig)) - psi(nms(ig)) - df(ig)= fi*(tpiba2*ggp(ig)* c(ig,idx+i-1)+CMPLX(DBLE(fp), AIMAG(fm))) - da(ig)=fip*(tpiba2*ggp(ig)* c(ig,idx+i )+CMPLX(AIMAG(fp),-DBLE(fm))) - END DO -!$omp end parallel do - END IF - END IF - - eig_offset = eig_offset + nr3sx * dffts%nsw(me_image+1) - - ! We take into account the number of elements received from other members of the orbital group - - ENDDO - - ! - IF(dft_is_meta()) THEN - CALL dforce_meta(c(1,i),c(1,i+1),df,da,psi,iss1,iss2,fi,fip) !METAGGA - END IF - - - IF( nhsa > 0 ) THEN - ! - ! aa_i,i,n = sum_j d_i,ij - ! - ALLOCATE( af( nhsa, nogrp_ ), aa( nhsa, nogrp_ ) ) - ! - af = 0.0d0 - aa = 0.0d0 - ! - igrp = 1 - ! - DO idx = 1, 2*nogrp_ , 2 - ! - IF ( idx + i - 1 <= n ) THEN - ! - IF ( tens .or. tsmear ) THEN - fi = 1.0d0 - fip= 1.0d0 - ELSE - ! - ! spin multiplicity is taken into account - ! before the call - ! - fi = f(i+idx-1) - fip= f(i+idx) - ! - ENDIF - ! -!$omp parallel default(shared), private(iv,jv,ivoff,jvoff,dd,dv,inl,jnl,is,isa,ism) - ! - DO is = 1, nsp - DO iv = 1, nh(is) - IF( program_name == 'FPMD' ) THEN - ivoff = ish(is) + (iv-1) * na(is) - dd = dvan( iv, iv, is ) - DO inl = ivoff + 1, ivoff + na(is) - af(inl,igrp) = af(inl,igrp) - fi * dd * bec(inl,i+idx-1) - END DO - IF( i + idx - 1 /= n ) THEN - DO inl = ivoff + 1, ivoff + na(is) - aa(inl,igrp) = aa(inl,igrp) - fip * dd * bec(inl,i+idx) - END DO - END IF - ELSE - DO jv = 1, nh(is) - isa = 0 - DO ism = 1, is-1 - isa = isa + na( ism ) - END DO - dv = dvan(iv,jv,is) - ivoff = ish(is)+(iv-1)*na(is) - jvoff = ish(is)+(jv-1)*na(is) - IF( i + idx - 1 /= n ) THEN -!$omp do - DO ia=1,na(is) - inl = ivoff + ia - jnl = jvoff + ia - isa = isa + 1 - dd = deeq(iv,jv,isa,iss1) + dv - af(inl,igrp) = af(inl,igrp) - fi * dd * bec(jnl,i+idx-1) - dd = deeq(iv,jv,isa,iss2) + dv - aa(inl,igrp) = aa(inl,igrp) - fip * dd * bec(jnl,i+idx) - END DO - ELSE -!$omp do - DO ia=1,na(is) - inl = ivoff + ia - jnl = jvoff + ia - isa = isa + 1 - dd = deeq(iv,jv,isa,iss1) + dv - af(inl,igrp) = af(inl,igrp) - fi * dd * bec(jnl,i+idx-1) - END DO - END IF - END DO - END IF - END DO - END DO - -!$omp end parallel - - END IF - - igrp = igrp + 1 - - END DO -! - CALL DGEMM ( 'N', 'N', 2*ngw, nogrp_ , nhsa, 1.0d0, vkb, 2*ngw, af, nhsa, 1.0d0, df, 2*ngw) - - CALL DGEMM ( 'N', 'N', 2*ngw, nogrp_ , nhsa, 1.0d0, vkb, 2*ngw, aa, nhsa, 1.0d0, da, 2*ngw) - ! - DEALLOCATE( aa, af ) - ! - ENDIF - - DEALLOCATE( psi ) -! - CALL stop_clock( 'dforce' ) -! - RETURN - END SUBROUTINE dforce_x diff --git a/quantum_espresso/kcp/CPV/fpmdpp.f90 b/quantum_espresso/kcp/CPV/fpmdpp.f90 deleted file mode 100644 index ce9239211..000000000 --- a/quantum_espresso/kcp/CPV/fpmdpp.f90 +++ /dev/null @@ -1,955 +0,0 @@ -! -! Copyright (C) 2002-2008 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -! This file holds XSF (=Xcrysden Structure File) utilities. -! Routines written by Tone Kokalj on Mon Jan 27 18:51:17 CET 2003 -! modified by Gerardo Ballabio and Carlo Cavazzoni -! on Thu Jul 22 18:57:26 CEST 2004 -! -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . - -! -------------------------------------------------------------------- -! this routine writes the crystal structure in XSF, GRD and PDB format -! from a FPMD output files -! -------------------------------------------------------------------- -PROGRAM fpmd_postproc - - USE kinds, ONLY : DP - USE constants, ONLY : bohr => BOHR_RADIUS_ANGS - USE io_files, ONLY : prefix, xmlpun, outdir - USE io_global, ONLY : io_global_start, io_global_getmeta - USE mp_global, ONLY : mp_global_start, init_pool - USE mp, ONLY : mp_end, mp_start, mp_env - - USE iotk_module - USE xml_io_base - - IMPLICIT NONE - - INTEGER, PARAMETER :: maxsp = 20 - - INTEGER :: natoms, nsp, na(maxsp), atomic_number(maxsp) - INTEGER :: ounit, cunit, punit, funit, dunit, bunit, ksunit - INTEGER :: nr1, nr2, nr3, ns1, ns2, ns3 - INTEGER :: np1, np2, np3, np, ispin - INTEGER, ALLOCATABLE :: ityp(:) - REAL(DP) :: at(3, 3), atinv(3, 3), ht0(3, 3), h0(3, 3) - REAL(DP), ALLOCATABLE :: rho_in(:,:,:), rho_out(:,:,:) - REAL(DP), ALLOCATABLE :: tau_in(:,:), tau_out(:,:) - REAL(DP), ALLOCATABLE :: sigma(:,:), force(:,:) - REAL(DP), ALLOCATABLE :: stau0(:,:), svel0(:,:), force0(:,:) - - CHARACTER(len=256) :: filepp, fileout, output - CHARACTER(len=256) :: filecel, filepos, filefor, filepdb - CHARACTER(len=256) :: print_state - CHARACTER(len=3) :: atm( maxsp ), lab - CHARACTER(len=4) :: charge_density - LOGICAL :: lcharge, lforces, ldynamics, lpdb, lrotation - LOGICAL :: lbinary, found - INTEGER :: nframes - INTEGER :: ios, nat, ndr - INTEGER :: nproc, mpime, world, root - - INTEGER :: i, j, k, n, ix, iy, iz - - REAL(DP) :: euler(6) - - NAMELIST /inputpp/ prefix, fileout, output, outdir, & - lcharge, lforces, ldynamics, lpdb, lrotation, & - ns1, ns2, ns3, np1, np2, np3, print_state, & - atomic_number, nframes, ndr, charge_density, & - lbinary - - ! default values - - dunit = 14 - - ! ... Intel compilers v .ge.8 allocate a lot of stack space - ! ... Stack limit is often small, thus causing SIGSEGV and crash - CALL remove_stack_limit ( ) - - ! see cprstart.f90 for the meaning of the following 4 calls - CALL mp_start() - CALL mp_env( nproc, mpime, world ) - CALL mp_global_start( root, mpime, world, nproc ) - CALL io_global_start( mpime, root ) - - CALL get_env( 'ESPRESSO_TMPDIR', outdir ) - IF ( TRIM( outdir ) == ' ' ) outdir = './' - prefix = 'cp' - fileout = 'out' - output = 'xsf' ! 'grd' - outdir = './' - lcharge = .false. - lforces = .false. - ldynamics = .false. - lpdb = .false. - lrotation = .false. - ns1 = 0 - ns2 = 0 - ns3 = 0 - np1 = 1 - np2 = 1 - np3 = 1 ! - nframes = 1 ! number of MD step to be read to buind the trajectory - ndr = 51 ! restart file number - atomic_number = 1 ! atomic number of the species in the restart file - charge_density = 'full' ! specify the component to plot: 'full', 'spin' - print_state = ' ' ! specify the Kohn-Sham state to plot: 'KS_1' - lbinary = .TRUE. - - - - call input_from_file() - - ! read namelist - READ( 5, inputpp, iostat=ios) - - ! set file names - ! - filecel = TRIM(outdir) // TRIM(prefix) // '.cel' - filepos = TRIM(outdir) // TRIM(prefix) // '.pos' - filefor = TRIM(outdir) // TRIM(prefix) // '.for' - ! - filepdb = TRIM(fileout) // '.pdb' - ! - ! append extension - ! - IF (output == 'xsf') THEN - IF (ldynamics) THEN - fileout = TRIM(fileout) // '.axsf' - ELSE - fileout = TRIM(fileout) // '.xsf' - END IF - ELSE IF (output == 'grd') THEN - fileout = TRIM(fileout) // '.grd' - END IF - - np = np1 * np2 * np3 - IF (np1 < 1 .OR. np2 < 1 .OR. np3 < 1) THEN - WRITE(*,*) 'Error: zero or negative replicas not allowed' - STOP - END IF - - - ! check for wrong input - IF (ldynamics .AND. nframes < 2) THEN - WRITE(*,*) 'Error: dynamics requested, but only one frame' - STOP - END IF - IF (.NOT. ldynamics) nframes = 1 - - IF (ldynamics .AND. lcharge) THEN - WRITE(*,*) 'Error: dynamics with charge density not supported' - STOP - END IF - - IF (ldynamics .AND. ( print_state /= ' ' ) ) THEN - WRITE(*,*) 'Error: dynamics with print_state not supported' - STOP - END IF - - ! - ! Now read the XML data file - ! - - filepp = restart_dir( outdir, ndr ) - ! - filepp = TRIM( filepp ) // '/' // TRIM(xmlpun) - ! - CALL iotk_open_read( dunit, file = TRIM( filepp ), BINARY = .FALSE., ROOT = attr ) - - CALL iotk_scan_begin( dunit, "IONS", FOUND = found ) - - IF( .NOT. found ) THEN - CALL errore( ' cppp ', ' IONS not found in data-file.xml ', 1 ) - END IF - - CALL iotk_scan_dat( dunit, "NUMBER_OF_ATOMS", nat ) - CALL iotk_scan_dat( dunit, "NUMBER_OF_SPECIES", nsp ) - - ALLOCATE( ityp( nat * np ) ) ! atomic species - - DO i = 1, nsp - ! - CALL iotk_scan_begin( dunit, "SPECIE" // TRIM( iotk_index( i ) ), FOUND = found ) - ! - IF( .NOT. found ) THEN - CALL errore( ' cppp ', "SPECIE" // TRIM( iotk_index( i ) ) // ' not found in data-file.xml ', 1 ) - END IF - - CALL iotk_scan_dat( dunit, "ATOM_TYPE", atm(i) ) - ! - ! CALL iotk_scan_dat( dunit, & - ! TRIM( atm(i) )//"_MASS", amass(i), ATTR = attr ) - ! - ! CALL iotk_scan_dat( dunit, & - ! "PSEUDO_FOR_" // TRIM( atm(i) ), psfile(i) ) - ! - CALL iotk_scan_end( dunit, "SPECIE" // TRIM( iotk_index( i ) ) ) - ! - END DO - - ! - ! CALL iotk_scan_empty( dunit, "UNITS_FOR_ATOMIC_POSITIONS", attr ) - ! CALL iotk_scan_attr( attr, "UNIT", pos_unit ) - ! - DO i = 1, nat - ! - CALL iotk_scan_empty( dunit, "ATOM" // TRIM( iotk_index( i ) ), attr ) - CALL iotk_scan_attr( attr, "SPECIES", lab ) - CALL iotk_scan_attr( attr, "INDEX", ityp(i) ) - ! CALL iotk_scan_attr( attr, "tau", tau(:,i) ) - ! CALL iotk_scan_attr( attr, "if_pos", if_pos(:,i) ) - ! - END DO - - CALL iotk_scan_end( dunit, "IONS" ) - - CALL iotk_scan_begin( dunit, "PLANE_WAVES" ) - CALL iotk_scan_empty( dunit, "FFT_GRID", attr ) - CALL iotk_scan_attr( attr, "nr1", nr1 ) - CALL iotk_scan_attr( attr, "nr2", nr2 ) - CALL iotk_scan_attr( attr, "nr3", nr3 ) - CALL iotk_scan_end( dunit, "PLANE_WAVES" ) - - ALLOCATE( stau0( 3, nat ) ) - ALLOCATE( svel0( 3, nat ) ) - ALLOCATE( force0( 3, nat ) ) ! forces, atomic units - - CALL iotk_scan_begin( dunit, "TIMESTEPS", attr ) - CALL iotk_scan_begin( dunit, "STEP0" ) - CALL iotk_scan_begin( dunit, "IONS_POSITIONS" ) - CALL iotk_scan_dat( dunit, "stau", stau0 ) - CALL iotk_scan_dat( dunit, "svel", svel0 ) - CALL iotk_scan_dat( dunit, "force", force0 ) - CALL iotk_scan_end( dunit, "IONS_POSITIONS" ) - CALL iotk_scan_begin( dunit, "CELL_PARAMETERS" ) - CALL iotk_scan_dat( dunit, "ht", ht0 ) - CALL iotk_scan_end( dunit, "CELL_PARAMETERS" ) - CALL iotk_scan_end( dunit, "STEP0" ) - CALL iotk_scan_end( dunit, "TIMESTEPS" ) - ! - ispin = 1 - ! - ! - CALL iotk_close_read( dunit ) - - ! - ! End of reading from data file - ! - - IF ( nsp > maxsp ) THEN - WRITE(*,*) 'Error: too many atomic species' - STOP - END IF - - natoms = nat - ! - ! Count atoms in each species - ! - na = 0 - DO i = 1, nat - na( ityp( i ) ) = na( ityp( i ) ) + 1 ! total number of atoms - END DO - - ! assign species (from input) to each atom - ! - k = 0 - DO i = 1, nsp - DO j = 1, na(i) - k = k + 1 - ityp(k) = atomic_number(i) - END DO - END DO - - - ! allocate arrays - ALLOCATE(tau_in(3, nat)) ! atomic positions, angstroms - ALLOCATE(tau_out(3, nat * np)) ! replicated positions - ALLOCATE(sigma(3, nat ) ) ! scaled coordinates - ! - IF (lforces) ALLOCATE( force( 3, nat * np ) ) - - ! charge density - IF ( lcharge .OR. print_state /= ' ' ) THEN - IF (ns1 == 0) ns1 = nr1 - IF (ns2 == 0) ns2 = nr2 - IF (ns3 == 0) ns3 = nr3 - ALLOCATE( rho_in ( nr1, nr2, nr3 ) ) ! original charge density - ALLOCATE( rho_out( ns1, ns2, ns3 ) ) ! rescaled charge density - END IF - - ! open output file for trajectories or charge density - ! - ounit = 10 - OPEN(ounit, file=fileout, status='unknown') - - ! open Cell trajectory file - ! - cunit = 11 - OPEN(cunit, file=filecel, status='old') - - ! open Positions trajectory file - ! - punit = 12 - OPEN(punit, file=filepos, status='old') - - ! open Force trajectory file - ! - funit = 13 - if (lforces) OPEN(funit, file=filefor, status='old') - - ! open PDB file - ! - bunit = 15 - OPEN(bunit, file=filepdb, status='unknown') - - ! Unit for KS states - ! - ksunit = 16 - - ! XSF file header - ! - IF ( output == 'xsf' ) THEN - IF ( ldynamics ) WRITE(ounit,*) 'ANIMSTEPS', nframes - WRITE( ounit, * ) 'CRYSTAL' - END IF - - DO n = 1, nframes - ! - IF ( ldynamics ) WRITE(*,'("frame",1X,I4)') n - - ! read data from files produced by fpmd - ! - CALL read_fpmd( lforces, lcharge, lbinary, cunit, punit, funit, dunit, & - natoms, nr1, nr2, nr3, at, tau_in, force, & - rho_in, outdir, ndr, charge_density ) - - IF( nframes == 1 ) THEN - ! - ! use values from the XML file - ! - IF( lforces ) force( 1:3, 1:nat ) = force0( 1:3, 1:nat ) - ! - h0 = TRANSPOSE( ht0 ) - ! - ! from scaled to real coordinates - ! - tau_in( :, : ) = MATMUL( h0( :, : ), stau0( :, : ) ) - ! - ! convert atomic units to Angstroms - ! - at = h0 * bohr - tau_in = tau_in * bohr - ! - END IF - - WRITE(*,'(2x,"Cell parameters (Angstroms):")') - WRITE(*,'(3(2x,f10.6))') ((at(i, j), i=1,3), j=1,3) - ! - WRITE(*,'(2x,"Atomic coordinates (Angstroms):")') - WRITE(*,'(3(2x,f10.6))') ((tau_in(i, j), i=1,3), j=1,natoms) - - ! compute scaled coordinates - ! - CALL inverse( at, atinv ) - sigma(:,:) = MATMUL(atinv(:,:), tau_in(:,:)) - - ! compute cell dimensions and Euler angles - CALL at_to_euler( at, euler ) - - IF (lpdb) THEN - ! apply periodic boundary conditions - DO i = 1, natoms - DO j = 1, 3 - sigma(j, i) = sigma(j, i) - FLOOR(sigma(j, i)) - END DO - END DO - ! recompute Cartesian coordinates - tau_in(:,:) = MATMUL(at(:,:), sigma(:,:)) - END IF - - IF (lrotation) THEN - ! compute rotated cell - CALL euler_to_at( euler, at ) - ! rotate atomic positions as well - tau_in(:,:) = MATMUL(at(:,:), sigma(:,:)) - END IF - - ! replicate atoms - k = 0 - DO ix = 1, np1 - DO iy = 1, np2 - DO iz = 1, np3 - DO j = 1, natoms - k = k + 1 - tau_out(:, k) = tau_in(:, j) + (ix-1) * at(:, 1) + & - (iy-1) * at(:, 2) + (iz-1) * at(:, 3) - ityp(k) = ityp(j) - IF (lforces) force(:, k) = force(:, j) - END DO - END DO - END DO - END DO - natoms = natoms * np - - ! compute supercell - at(:, 1) = at(:, 1) * np1 - at(:, 2) = at(:, 2) * np2 - at(:, 3) = at(:, 3) * np3 - euler(1) = euler(1) * np1 - euler(2) = euler(2) * np2 - euler(3) = euler(3) * np3 - - IF ( lcharge ) & - CALL scale_charge( rho_in, rho_out, nr1, nr2, nr3, ns1, ns2, ns3, & - np1, np2, np3 ) - - IF ( output == 'xsf' ) THEN - ! write data as XSF format - CALL write_xsf( ldynamics, lforces, lcharge, ounit, n, at, & - natoms, ityp, tau_out, force, rho_out, & - ns1, ns2, ns3 ) - ELSE IF( output == 'grd' ) THEN - ! write data as GRD format - CALL write_grd( ounit, at, rho_out, ns1, ns2, ns3 ) - END IF - - END DO - - CLOSE(ounit) - - IF ( print_state /= ' ' ) THEN - ! - CALL read_density( TRIM( print_state ) // '.xml', dunit, nr1, nr2, nr3, rho_in, lbinary ) - CALL scale_charge( rho_in, rho_out, nr1, nr2, nr3, ns1, ns2, ns3, np1, np2, np3 ) - ! - IF (output == 'xsf') THEN - ! write data as XSF format - OPEN( unit = ksunit, file = TRIM( print_state ) // '.xsf' ) - WRITE( ksunit, * ) 'CRYSTAL' ! XSF files need this one line header - CALL write_xsf( ldynamics, lforces, .true., ksunit, n, at, & - natoms, ityp, tau_out, force, rho_out, ns1, ns2, ns3 ) - ELSE IF( output == 'grd' ) THEN - OPEN( unit = ksunit, file = TRIM( print_state ) // '.grd' ) - CALL write_grd( ksunit, at, rho_out, ns1, ns2, ns3 ) - END IF - ! - CLOSE( ksunit ) - ! - END IF - - ! write atomic positions as PDB format - CALL write_pdb( bunit, tau_out, natoms, ityp, euler, lrotation ) - - ! free allocated resources - CLOSE(punit) - CLOSE(cunit) - IF (lforces) CLOSE(funit) - - DEALLOCATE(tau_in) - DEALLOCATE(tau_out) - DEALLOCATE(ityp) - IF( ALLOCATED( force ) ) DEALLOCATE(force) - IF( ALLOCATED( rho_in ) ) DEALLOCATE(rho_in) - IF( ALLOCATED( rho_out ) ) DEALLOCATE(rho_out) - DEALLOCATE( stau0 ) - DEALLOCATE( svel0 ) - DEALLOCATE( force0 ) - - CALL mp_end() - STOP -END PROGRAM fpmd_postproc - - -! -! -! - - -SUBROUTINE read_fpmd( lforces, lcharge, lbinary, cunit, punit, funit, dunit, & - natoms, nr1, nr2, nr3, at, tau, force, & - rho, outdir, ndr, charge_density ) - - USE kinds, ONLY: DP - USE constants, ONLY: bohr => BOHR_RADIUS_ANGS - USE xml_io_base - USE iotk_module - - IMPLICIT NONE - - LOGICAL, INTENT(in) :: lforces, lcharge, lbinary - INTEGER, INTENT(in) :: cunit, punit, funit, dunit - INTEGER, INTENT(in) :: natoms, nr1, nr2, nr3, ndr - REAL(DP), INTENT(out) :: at(3, 3), tau(3, natoms), force(3, natoms) - REAL(DP), INTENT(out) :: rho(nr1, nr2, nr3) - CHARACTER(LEN=*), INTENT(IN) :: outdir - CHARACTER(LEN=*), INTENT(IN) :: charge_density - - INTEGER :: i, j - REAL(DP) :: x, y, z, fx, fy, fz - CHARACTER(LEN=256) :: filename - - ! read cell vectors - ! NOTE: colums are lattice vectors - ! - READ(cunit,*) - DO i = 1, 3 - READ(cunit,*) ( at(i, j), j=1,3 ) - END DO - at(:, :) = at(:, :) * bohr - - ! read atomic coordinates - READ(punit,*) - IF (lforces) READ(funit,*) - DO i = 1, natoms - ! convert atomic units to Angstroms - READ(punit,*) x, y, z - tau(1, i) = x * bohr - tau(2, i) = y * bohr - tau(3, i) = z * bohr - - IF (lforces) THEN - ! read forces - READ (funit,*) fx, fy, fz - force(1, i) = fx - force(2, i) = fy - force(3, i) = fz - END IF - END DO - - IF (lcharge) THEN - - filename = restart_dir( outdir, ndr ) - ! - IF( charge_density == 'spin' ) THEN - filename = TRIM( filename ) // '/' // 'spin-polarization' - ELSE - filename = TRIM( filename ) // '/' // 'charge-density' - END IF - ! - ! - IF ( check_file_exst ( TRIM(filename)//'.dat' ) ) THEN - ! - CALL read_density( TRIM(filename)//'.dat', dunit, nr1, nr2, nr3, rho, lbinary ) - ! - ELSEIF ( check_file_exst ( TRIM(filename)//'.xml' ) ) THEN - ! - CALL read_density( TRIM(filename)//'.xml', dunit, nr1, nr2, nr3, rho, lbinary ) - ! - ELSE - CALL infomsg ('read_fpmd', 'file '//TRIM(filename)//' not found' ) - ENDIF - ! - END IF - - RETURN -END SUBROUTINE read_fpmd - - - -SUBROUTINE read_density( filename, dunit, nr1, nr2, nr3, rho, lbinary ) - - USE kinds, ONLY: DP - USE xml_io_base - USE iotk_module - - IMPLICIT NONE - - LOGICAL, INTENT(in) :: lbinary - INTEGER, INTENT(in) :: dunit - INTEGER, INTENT(in) :: nr1, nr2, nr3 - REAL(DP), INTENT(out) :: rho(nr1, nr2, nr3) - CHARACTER(LEN=*), INTENT(IN) :: filename - - INTEGER :: ix, iy, iz, ierr - REAL(DP) :: rhomin, rhomax - INTEGER :: n1, n2, n3 - REAL(DP), ALLOCATABLE :: rho_plane(:) - - ! - WRITE(*,'("Reading density from: ", A80)' ) TRIM( filename ) - ! - CALL iotk_open_read( dunit, file = TRIM( filename ) , BINARY = lbinary, ROOT = attr, IERR = ierr ) - ! - - CALL iotk_scan_begin( dunit, "CHARGE-DENSITY" ) - CALL iotk_scan_empty( dunit, "INFO", attr ) - CALL iotk_scan_attr( attr, "nr1", n1 ) - CALL iotk_scan_attr( attr, "nr2", n2 ) - CALL iotk_scan_attr( attr, "nr3", n3 ) - ! - ALLOCATE( rho_plane( n1 * n2 ) ) - - ! read charge density from file - ! note: must transpose - DO iz = 1, n3 - CALL iotk_scan_dat( dunit, "z" // iotk_index( iz ), rho_plane ) - IF( iz <= nr3 ) THEN - DO iy = 1, MIN( n2, nr2 ) - DO ix = 1, MIN( n1, nr1 ) - rho(ix, iy, iz) = rho_plane( ix + ( iy - 1 ) * n1 ) - END DO - END DO - END IF - END DO - - CALL iotk_scan_end( dunit, "CHARGE-DENSITY" ) - CALL iotk_close_read( dunit ) - - rhomin = MINVAL(rho(:,:,:)) - rhomax = MAXVAL(rho(:,:,:)) - - ! print some info - WRITE(*,'(2x,"Density grid:")') - WRITE(*,'(3(2x,i6))') nr1, nr2, nr3 - WRITE(*,'(2x,"spin = ",A4)') filename - WRITE(*,'(2x,"Minimum and maximum values:")') - WRITE(*,'(3(2x,1pe12.4))') rhomin, rhomax - - RETURN -END SUBROUTINE read_density - -! -! -! -! compute inverse of 3*3 matrix -! -SUBROUTINE inverse( at, atinv ) - IMPLICIT NONE - - INTEGER, PARAMETER :: DP = KIND(0.0d0) - - REAL(DP), INTENT(in) :: at(3, 3) - REAL(DP), INTENT(out) :: atinv(3, 3) - - REAL(DP) :: det - - atinv(1, 1) = at(2, 2) * at(3, 3) - at(2, 3) * at(3, 2) - atinv(2, 1) = at(2, 3) * at(3, 1) - at(2, 1) * at(3, 3) - atinv(3, 1) = at(2, 1) * at(3, 2) - at(2, 2) * at(3, 1) - atinv(1, 2) = at(1, 3) * at(3, 2) - at(1, 2) * at(3, 3) - atinv(2, 2) = at(1, 1) * at(3, 3) - at(1, 3) * at(3, 1) - atinv(3, 2) = at(1, 2) * at(3, 1) - at(1, 1) * at(3, 2) - atinv(1, 3) = at(1, 2) * at(2, 3) - at(1, 3) * at(2, 2) - atinv(2, 3) = at(1, 3) * at(2, 1) - at(1, 1) * at(2, 3) - atinv(3, 3) = at(1, 1) * at(2, 2) - at(1, 2) * at(2, 1) - - det = at(1, 1) * atinv(1, 1) + at(1, 2) * atinv(2, 1) + & - at(1, 3) * atinv(3, 1) - atinv(:,:) = atinv(:,:) / det; - - RETURN -END SUBROUTINE inverse - -! generate cell dimensions and Euler angles from cell vectors -! euler(1:6) = a, b, c, alpha, beta, gamma -! I didn't call the array "celldm" because that could be confusing, -! since in PWscf the convention is different: -! celldm(1:6) = a, b/a, c/a, cos(alpha), cos(beta), cos(gamma) -SUBROUTINE at_to_euler( at, euler ) - IMPLICIT NONE - - INTEGER, PARAMETER :: DP = KIND(0.0d0) - - REAL(DP), INTENT(in) :: at(3, 3) - REAL(DP), INTENT(out) :: euler(6) - - REAL(DP), PARAMETER :: rad2deg = 180.0d0 / 3.14159265358979323846d0 - REAL(DP) :: dot(3, 3) - INTEGER :: i, j - - DO i = 1, 3 - DO j = i, 3 - dot(i, j) = dot_product(at(:,i), at(:,j)) - END DO - END DO - DO i = 1, 3 - euler(i) = sqrt(dot(i, i)) - END DO - euler(4) = acos(dot(2, 3) / (euler(2) * euler(3))) * rad2deg - euler(5) = acos(dot(1, 3) / (euler(1) * euler(3))) * rad2deg - euler(6) = acos(dot(1, 2) / (euler(1) * euler(2))) * rad2deg - - RETURN -END SUBROUTINE at_to_euler - -! generate cell vectors back from cell dimensions and Euler angles -! euler(1:6) = a, b, c, alpha, beta, gamma -! here I follow the PDB convention, namely, c is oriented along the z -! axis and b lies in the yz plane, or to put it another way, at is -! lower triangular -SUBROUTINE euler_to_at( euler, at ) - IMPLICIT NONE - - INTEGER, PARAMETER :: DP = KIND(0.0d0) - - REAL(DP), PARAMETER :: deg2rad = 3.14159265358979323846d0 / 180.0d0 - - REAL(DP), INTENT(in) :: euler(6) - REAL(DP), INTENT(out) :: at(3, 3) - - REAL(DP) :: cos_ab, cos_ac, cos_bc, temp1, temp2 - - cos_bc = COS(euler(4) * deg2rad) - cos_ac = COS(euler(5) * deg2rad) - cos_ab = COS(euler(6) * deg2rad) - - temp1 = SQRT(1.0d0 - cos_bc*cos_bc) ! sin_bc - temp2 = (cos_ab - cos_bc*cos_ac) / temp1 - - at(1, 1) = SQRT(1.0d0 - cos_ac*cos_ac - temp2*temp2) * euler(1) - at(2, 1) = temp2 * euler(1) - at(3, 1) = cos_ac * euler(1) - at(1, 3) = 0.0d0 - at(2, 3) = 0.0d0 - at(3, 3) = euler(3) - at(1, 2) = 0.0d0 - at(2, 2) = temp1 * euler(2) - at(3, 2) = cos_bc * euler(2) - - RETURN -END SUBROUTINE euler_to_at - -! map charge density from a grid to another by linear interpolation -! along the three axes -SUBROUTINE scale_charge( rho_in, rho_out, nr1, nr2, nr3, ns1, ns2, ns3, & - np1, np2, np3 ) - IMPLICIT NONE - - INTEGER, PARAMETER :: DP = KIND(0.0d0) - - INTEGER, INTENT(in) :: nr1, nr2, nr3, ns1, ns2, ns3, np1, np2, np3 - REAL(DP), INTENT(in) :: rho_in( nr1, nr2, nr3 ) - REAL(DP), INTENT(out) :: rho_out( ns1, ns2, ns3 ) - - INTEGER :: i, j, k - INTEGER :: i0(ns1), j0(ns2), k0(ns3), i1(ns1), j1(ns2), k1(ns3) - REAL(DP) :: x0(ns1), y0(ns2), z0(ns3), x1(ns1), y1(ns2), z1(ns3) - - ! precompute interpolation data - DO i = 1, ns1 - CALL scale_linear( i, nr1, ns1, np1, i0(i), i1(i), x0(i), x1(i) ) - END DO - DO j = 1, ns2 - CALL scale_linear( j, nr2, ns2, np2, j0(j), j1(j), y0(j), y1(j) ) - END DO - DO k = 1, ns3 - CALL scale_linear( k, nr3, ns3, np3, k0(k), k1(k), z0(k), z1(k) ) - END DO - - ! interpolate linearly along three axes - DO i = 1, ns1 - DO j = 1, ns2 - DO k = 1, ns3 - rho_out(i, j, k) = & - rho_in(i1(i), j1(j), k1(k)) * x0(i) * y0(j) * z0(k) + & - rho_in(i0(i), j1(j), k1(k)) * x1(i) * y0(j) * z0(k) + & - rho_in(i1(i), j0(j), k1(k)) * x0(i) * y1(j) * z0(k) + & - rho_in(i1(i), j1(j), k0(k)) * x0(i) * y0(j) * z1(k) + & - rho_in(i0(i), j0(j), k1(k)) * x1(i) * y1(j) * z0(k) + & - rho_in(i0(i), j1(j), k0(k)) * x1(i) * y0(j) * z1(k) + & - rho_in(i1(i), j0(j), k0(k)) * x0(i) * y1(j) * z1(k) + & - rho_in(i0(i), j0(j), k0(k)) * x1(i) * y1(j) * z1(k) - END DO - END DO - END DO - - RETURN -END SUBROUTINE scale_charge - -! compute grid parameters for linear interpolation -SUBROUTINE scale_linear( n, nr, ns, np, n0, n1, r0, r1 ) - IMPLICIT NONE - - INTEGER, PARAMETER :: DP = KIND(0.0d0) - - INTEGER, INTENT(in) :: n, nr, ns, np - INTEGER, INTENT(out) :: n0, n1 - REAL(DP), INTENT(out) :: r0, r1 - - ! map new grid point onto old grid - ! mapping is: 1 --> 1, ns+1 --> (nr*np)+1 - r0 = REAL((n-1) * nr*np, DP) / ns + 1.0d0 - ! indices of neighbors - n0 = int(r0) - n1 = n0 + 1 - ! distances from neighbors - r0 = r0 - n0 - r1 = 1.0d0 - r0 - ! apply periodic boundary conditions - n0 = MOD(n0 - 1, nr) + 1 - n1 = MOD(n1 - 1, nr) + 1 - - RETURN -END SUBROUTINE scale_linear - -SUBROUTINE write_xsf( ldynamics, lforces, lcharge, ounit, n, at, & - natoms, ityp, tau, force, rho, nr1, nr2, nr3 ) - IMPLICIT NONE - - INTEGER, PARAMETER :: DP = KIND(0.0d0) - - LOGICAL, INTENT(in) :: ldynamics, lforces, lcharge - INTEGER, INTENT(in) :: ounit, n, natoms, ityp(natoms) - INTEGER, INTENT(in) :: nr1, nr2, nr3 - REAL(DP), INTENT(in) :: at(3, 3), tau(3, natoms), force(3, natoms) - REAL(DP), INTENT(in) :: rho(nr1, nr2, nr3) - - INTEGER :: i, j, ix, iy, iz - - ! write cell - IF (ldynamics) THEN - WRITE(ounit,*) 'PRIMVEC', n - ELSE - WRITE(ounit,*) 'PRIMVEC' - END IF - WRITE(ounit,'(2(3f15.9/),3f15.9)') at - IF (ldynamics) THEN - WRITE(ounit,*) 'CONVVEC', n - WRITE(ounit,'(2(3f15.9/),3f15.9)') at - END IF - - ! write atomic coordinates (and forces) - IF (ldynamics) THEN - WRITE(ounit,*) 'PRIMCOORD', n - ELSE - WRITE(ounit,*) 'PRIMCOORD' - END IF - WRITE(ounit,*) natoms, 1 - DO i = 1, natoms - IF (lforces) THEN - WRITE (ounit,'(i3,3x,3f15.9,1x,3f12.5)') ityp(i), & - (tau(j, i), j=1,3), (force(j, i), j=1,3) - ELSE - WRITE (ounit,'(i3,3x,3f15.9,1x,3f12.5)') ityp(i), & - (tau(j, i), j=1,3) - END IF - END DO - - ! write charge density - IF (lcharge) THEN - ! XSF scalar-field header - WRITE(ounit,'(a)') 'BEGIN_BLOCK_DATAGRID_3D' - WRITE(ounit,'(a)') '3D_PWSCF' - WRITE(ounit,'(a)') 'DATAGRID_3D_UNKNOWN' - - ! mesh dimensions - WRITE(ounit,*) nr1, nr2, nr3 - ! origin - WRITE(ounit,'(3f10.6)') 0.0d0, 0.0d0, 0.0d0 - ! lattice vectors - WRITE(ounit,'(3f10.6)') ((at(i, j), i=1,3), j=1,3) - ! charge density - WRITE(ounit,'(6e13.5)') & - (((rho(ix, iy, iz), ix=1,nr1), iy=1,nr2), iz=1,nr3) - - WRITE(ounit,'(a)') 'END_DATAGRID_3D' - WRITE(ounit,'(a)') 'END_BLOCK_DATAGRID_3D' - END IF - - RETURN -END SUBROUTINE write_xsf - -SUBROUTINE write_grd( ounit, at, rho, nr1, nr2, nr3 ) - IMPLICIT NONE - - INTEGER, PARAMETER :: DP = KIND(0.0d0) - - INTEGER, INTENT(in) :: ounit - INTEGER, INTENT(in) :: nr1, nr2, nr3 - REAL(DP), INTENT(in) :: at(3, 3), rho(nr1, nr2, nr3) - - INTEGER :: i, j, k - REAL(DP) :: euler(6) - - CALL at_to_euler( at, euler ) - - WRITE(ounit,*) 'charge density' - WRITE(ounit,*) '(1p,e12.5)' - WRITE(ounit,fmt='(6f9.3)') (euler(i), i=1,6) - WRITE(ounit,fmt='(3i5)') nr1 - 1, nr2 - 1, nr3 - 1 - WRITE(ounit,fmt='(7i5)') 1, 0, 0, 0, nr1 - 1, nr2 - 1, nr3 - 1 - WRITE(ounit,fmt='(1p,e12.5)') (((rho(i, j, k), i=1,nr1), j=1,nr2), k=1,nr3) - - RETURN -END SUBROUTINE write_grd - -SUBROUTINE write_pdb( bunit, tau, natoms, ityp, euler, lrotation ) - IMPLICIT NONE - - INTEGER, PARAMETER :: DP = KIND(0.0d0) - - INTEGER, INTENT(in) :: bunit, natoms - INTEGER, INTENT(in) :: ityp(natoms) - REAL(DP), INTENT(in) :: tau(3, natoms), euler(6) - LOGICAL, INTENT(in) :: lrotation - - INTEGER :: i, j - CHARACTER*2 :: label(103) - DATA label /" H", "He", "Li", "Be", " B", " C", " N", " O", " F", "Ne", & - "Na", "Mg", "Al", "Si", " P", " S", "Cl", "Ar", " K", "Ca", & - "Sc", "Ti", " V", "Cr", "Mn", "Fe", "Co", "Ni", "Cu", "Zn", & - "Ga", "Ge", "As", "Se", "Br", "Kr", "Rb", "Sr", " Y", "Zr", & - "Nb", "Mo", "Tc", "Ru", "Rh", "Pd", "Ag", "Cd", "In", "St", & - "Sb", "Te", " I", "Xe", "Cs", "Ba", "La", "Ce", "Pr", "Nd", & - "Pm", "Sm", "Eu", "Gd", "Tb", "Dy", "Ho", "Er", "Tm", "Yb", & - "Lu", "Hf", "Ta", " W", "Re", "Os", "Ir", "Pt", "Au", "Hg", & - "Tl", "Pb", "Bi", "Po", "At", "Rn", "Fr", "Ra", "Ac", "Th", & - "Pa", " U", "Np", "Pu", "Am", "Cm", "Bk", "Cf", "Es", "Fm", & - "Md", "No", "Lr"/ - - WRITE(bunit,'("HEADER PROTEIN")') - WRITE(bunit,'("COMPND UNNAMED")') - WRITE(bunit,'("AUTHOR GENERATED BY ...")') - - IF (lrotation) & - WRITE(bunit,'("CRYST1",3F9.3,3F7.2,1X,A10,I3)') euler, "P 1", 1 - - DO i = 1, natoms - WRITE(bunit,'("ATOM ",I5,1X,A2,3X,2A3,I3,3X,F9.3,2F8.3,2F6.2," ")') & - i, label(ityp(i)), "UKN", "", 1, (tau(j, i), j=1,3), 1.0d0, 0.0d0 - END DO - - WRITE(bunit,'("MASTER 0 0 0 0 0 0 0 0 ", I4," 0 ",I4," 0")') natoms, natoms - WRITE(bunit,'("END")') - - RETURN -END SUBROUTINE write_pdb - -! PDB File Format -!--------------------------------------------------------------------------- -!Field | Column | FORTRAN | -! No. | range | format | Description -!--------------------------------------------------------------------------- -! 1. | 1 - 6 | A6 | Record ID (eg ATOM, HETATM) -! 2. | 7 - 11 | I5 | Atom serial number -! - | 12 - 12 | 1X | Blank -! 3. | 13 - 16 | A4 | Atom name (eg " CA " , " ND1") -! 4. | 17 - 17 | A1 | Alternative location code (if any) -! 5. | 18 - 20 | A3 | Standard 3-letter amino acid code for residue -! - | 21 - 21 | 1X | Blank -! 6. | 22 - 22 | A1 | Chain identifier code -! 7. | 23 - 26 | I4 | Residue sequence number -! 8. | 27 - 27 | A1 | Insertion code (if any) -! - | 28 - 30 | 3X | Blank -! 9. | 31 - 38 | F8.3 | Atom's x-coordinate -! 10. | 39 - 46 | F8.3 | Atom's y-coordinate -! 11. | 47 - 54 | F8.3 | Atom's z-coordinate -! 12. | 55 - 60 | F6.2 | Occupancy value for atom -! 13. | 61 - 66 | F6.2 | B-value (thermal factor) -! - | 67 - 67 | 1X | Blank -! 14. | 68 - 68 | I3 | Footnote number -!--------------------------------------------------------------------------- - - - diff --git a/quantum_espresso/kcp/CPV/fromscra.f90 b/quantum_espresso/kcp/CPV/fromscra.f90 deleted file mode 100644 index 20a0edad6..000000000 --- a/quantum_espresso/kcp/CPV/fromscra.f90 +++ /dev/null @@ -1,442 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -SUBROUTINE from_scratch( ) - ! - USE kinds, ONLY : DP - USE control_flags, ONLY : tranp, iprsta, tpre, tfor, thdyn, & - tprnfor, non_ortho, tortho, amprp, & - tsde, program_name, force_pairing, & - gamma_only, do_wf_cmplx !added:giovanni gamma_only, do_wf_cmplx - USE ions_positions, ONLY : taus, tau0, tausm, vels, fion, fionm, atoms0 - USE ions_base, ONLY : na, nsp, randpos, ions_vel - USE ions_base, ONLY : nat, iforce - USE ions_nose, ONLY : xnhp0, xnhpm, vnhp - USE cell_base, ONLY : ainv, h, s_to_r, omega, a1, a2, a3, & - hold, r_to_s, deth, cell_force, & - boxdimensions, velh - USE cell_nose, ONLY : xnhh0, xnhhm, vnhh - USE electrons_nose, ONLY : xnhe0, xnhem, vnhe - use electrons_base, ONLY : nbsp, f, nspin, nupdwn, iupdwn - USE electrons_module, ONLY : occn_info - USE energies, ONLY : entropy, eself, enl, ekin, etot, ekincm - USE energies, ONLY : dft_energy_type, debug_energies - USE dener, ONLY : denl, dekin6, detot - USE uspp, ONLY : vkb, becsum, nkb, okvan - USE io_global, ONLY : stdout, ionode, meta_ionode - USE core, ONLY : nlcc_any, rhoc - USE gvecw, ONLY : ngw - USE gvecs, ONLY : ngs - USE reciprocal_vectors, ONLY : mill_l - USE cvan, ONLY : nvb - USE cp_electronic_mass, ONLY : emass - USE efield_module, ONLY : tefield, efield_berry_setup, berry_energy, & - tefield2, efield_berry_setup2, berry_energy2 - USE cg_module, ONLY : tcg - USE ensemble_dft, ONLY : tens, compute_entropy - USE cp_interfaces, ONLY : runcp_uspp, runcp_uspp_force_pairing, & - strucf, phfacs, nlfh, nlfl - USE cp_interfaces, ONLY : rhoofr, ortho, wave_rand_init, elec_fakekine, & - wave_sine_init, wave_atom_init - USE cp_interfaces, ONLY : vofrhos, compute_stress - USE cp_interfaces, ONLY : printout, print_lambda - USE printout_base, ONLY : printout_pos - USE orthogonalize_base, ONLY : updatc, calphi - USE atoms_type_module, ONLY : atoms_type - USE wave_base, ONLY : wave_steepest - USE wavefunctions_module, ONLY : c0, cm, phi => cp, cdual - USE grid_dimensions, ONLY : nr1, nr2, nr3 - USE time_step, ONLY : delt - USE cp_main_variables, ONLY : setval_lambda, descla, bephi, becp, becdr, nfi, & - sfac, eigr, ei1, ei2, ei3, bec, taub, irb, eigrb, & - lambda, lambdam, ema0bg, rhog, rhor, rhos, & - vpot, ht0, edft, nlax, becdual - USE small_box, ONLY : ainvb - USE cdvan, ONLY : dbec - USE nksic, ONLY : do_spinsym - USE control_flags, ONLY : tatomicwfc - USE descriptors, ONLY: descla_siz_ - - ! - IMPLICIT NONE - ! - REAL(DP) :: bigr - INTEGER :: i, j, iter, iss, nspin_wfc - LOGICAL :: tlast = .FALSE. - REAL(DP) :: ccc, enb, enbi, fccc - LOGICAL :: ttforce - LOGICAL :: tstress - LOGICAL, PARAMETER :: ttprint = .TRUE. - REAL(DP) :: ei_unp - REAL(DP) :: dt2bye - LOGICAL :: tfirst = .TRUE. - REAL(DP) :: stress(3,3) - INTEGER :: i1, i2 - LOGICAL :: lgam !added:giovanni - COMPLEX(DP), parameter :: c_zero = CMPLX(0.d0,0.d0) !added:giovanni - ! - ! ... Subroutine body - ! - lgam=gamma_only.and..not.do_wf_cmplx !added:giovanni - nfi = 0 - ! - ttforce = tfor .or. tprnfor - tstress = thdyn .or. tpre - ! - stress = 0.0d0 - ! - IF( tsde ) THEN - fccc = 1.0d0 - ELSE - fccc = 0.5d0 - END IF - ! - dt2bye = delt * delt / emass - ! - IF( ANY( tranp( 1:nsp ) ) ) THEN - ! - CALL invmat( 3, h, ainv, deth ) - ! - CALL randpos( taus, na, nsp, tranp, amprp, ainv, iforce ) - ! - CALL s_to_r( taus, tau0, na, nsp, h ) - ! - END IF - ! - CALL phfacs( ei1, ei2, ei3, eigr, mill_l, atoms0%taus, nr1, nr2, nr3, atoms0%nat ) - ! - CALL strucf( sfac, ei1, ei2, ei3, mill_l, ngs ) - ! - IF ( okvan .OR. nlcc_any ) THEN - CALL initbox ( tau0, taub, irb, ainv, a1, a2, a3 ) - CALL phbox( taub, eigrb, ainvb ) - END IF - ! - ! wfc initialization with random numbers - ! - IF ( ionode ) & - WRITE( stdout, fmt = '(//,3X, "Wave Initialization: random initial wave-functions" )' ) - ! - IF ( .NOT. do_spinsym .OR. nspin == 1 ) then - ! - IF(tatomicwfc) THEN - ! - call wave_atom_init( cm, nbsp, 1 ) - ! - ELSE - ! - CALL wave_rand_init( cm, nbsp, 1 )!modified:giovanni - ! - ENDIF -! !begin_added:giovanni:debug -! DO i=1,size(cm(:,1)) -! write(201+mpime,'(5((F18.12)5x))') gx(1:3,i), cm(i,1) -! ENDDO -! !end_added:giovanni:debug - ! - ELSE - ! - IF ( nupdwn(1) < nupdwn(2) ) CALL errore('from_scratch','unexpec nupdwn(1) < nupdwn(2)',10) - ! - CALL wave_rand_init( cm, nupdwn(1) , 1 ) - ! - DO i = 1, MIN(nupdwn(1),nupdwn(2)) - ! - j=i+iupdwn(2)-1 - cm(:,j)=cm(:,i) - ! - ENDDO - ! - IF( meta_ionode ) write(stdout, "(24x, 'spin symmetry applied to init wave')" ) - ! - ENDIF - - ! - ! ... prefor calculates vkb (used by gram) - ! - CALL prefor( eigr, vkb ) - ! - nspin_wfc = nspin - IF( force_pairing ) nspin_wfc = 1 - ! - - DO iss = 1, nspin_wfc - ! - CALL gram( vkb, bec, nkb, cm(1,iupdwn(iss)), ngw, nupdwn(iss) ) - ! - END DO -! begin_added:giovanni:debug -! DO i=1,size(cm(:,1)) -! write(201+mpime,'(5((F18.12)5x))') gx(1:3,i), cm(i,1) -! ENDDO -! stop -! end_added:giovanni:debug - ! - IF( force_pairing ) cm(:,iupdwn(2):iupdwn(2)+nupdwn(2)-1) = cm(:,1:nupdwn(2)) - ! - if( iprsta >= 3 ) CALL dotcsc( eigr, cm, ngw, nbsp, lgam )!added:giovanni lgam - ! - ! ... initialize bands - ! - CALL occn_info( f ) - ! - atoms0%for = 0.D0 - atoms0%vels = 0.D0 - hold = h - velh = 0.0d0 - fion = 0.0d0 - tausm = taus - ! - ! ... compute local form factors - ! - CALL formf( tfirst, eself ) - ! - edft%eself = eself - - IF( tefield ) THEN - CALL efield_berry_setup( eigr, tau0 ) - END IF - IF( tefield2 ) THEN - CALL efield_berry_setup2( eigr, tau0 ) - END IF - ! - IF( .NOT. tcg ) THEN - ! -! ! begin_added:giovanni:debug -! DO i=1,size(cm(:,1)) -! write(202,'(5((F18.12)5x))') gx(1:3,i), eigr( i,1) -! ENDDO -! ! end_added:giovanni:debug - CALL calbec ( 1, nsp, eigr, cm, bec ) - ! - if ( tstress ) CALL caldbec( ngw, nkb, nbsp, 1, nsp, eigr, cm, dbec ) !warning:giovanni still to be modified - ! - IF(non_ortho) THEN - call compute_duals(cm,cdual,nbsp,1) - call calbec(1,nsp,eigr,cdual,becdual) - ENDIF - ! - CALL rhoofr ( nfi, cm(:,:), irb, eigrb, bec, becsum, rhor, rhog, rhos, enl, denl, ekin, dekin6 ) - ! - edft%enl = enl - edft%ekin = ekin - ! - END IF - - ! - ! put core charge (if present) in rhoc(r) - ! - if ( nlcc_any ) CALL set_cc( irb, eigrb, rhoc ) !warning:giovanni not yet implemented - ! - IF( program_name == 'CP90' ) THEN - - IF( .NOT. tcg ) THEN - - IF( tens ) THEN - CALL compute_entropy( entropy, f(1), nspin ) - entropy = entropy * nbsp - END IF - ! - vpot = rhor - ! - CALL vofrho( nfi, vpot, rhog, rhos, rhoc, tfirst, tlast, & - & ei1, ei2, ei3, irb, eigrb, sfac, tau0, fion ) - - IF( tefield ) THEN !warning:giovanni modified but not checked - CALL berry_energy( enb, enbi, bec, cm(:,:), fion ) - etot = etot + enb + enbi - END IF - IF( tefield2 ) THEN !warning:giovanni modified but not checked - CALL berry_energy2( enb, enbi, bec, cm(:,:), fion ) - etot = etot + enb + enbi - END IF - - CALL compute_stress( stress, detot, h, omega ) - - if(iprsta.gt.2) & - CALL printout_pos( stdout, fion, nat, head = ' fion ' ) - - CALL newd( vpot, irb, eigrb, becsum, fion ) - ! - IF( force_pairing ) THEN - ! - CALL runcp_uspp_force_pairing( fccc, ccc, ema0bg, dt2bye, rhos, bec%rvec, cm, & - & c0, ei_unp, fromscra = .TRUE. ) !warning:giovanni not yet modified - ! - IF(.not.lambda(2)%iscmplx) THEN - CALL setval_lambda( lambda(2)%rvec, nupdwn(1), nupdwn(1), 0.d0, descla(:,1) ) - ELSE - CALL setval_lambda( lambda(2)%cvec, nupdwn(1), nupdwn(1), c_zero, descla(:,1) ) - ENDIF - ! - ELSE - ! -! !begin_added:giovanni:debug ---- RUNCP WAVEFUNCTION -! write(6,*) "wavefunctions before runcp" -! write(6,*) "wavefunction_0", c0(1,2), c0(2,2), c0(3,2) -! write(6,*) "wavefunction_m", cm(1,2), cm(2,2), cm(3,2) -! !end_added:giovanni:debug ---- RUNCP WAVEFUNCTION - CALL runcp_uspp( nfi, fccc, ccc, ema0bg, dt2bye, rhos, bec, cm, c0, fromscra = .TRUE. ) -! !begin_added:giovanni:debug ---- RUNCP WAVEFUNCTION -! write(6,*) "wavefunctions after runcp" -! write(6,*) "check_allocated_5", associated(bec%rvec), ubound(bec%rvec)!added:giovanni:debug -! write(6,*) "wavefunction_0", c0(1,2), c0(2,2), c0(3,2) -! write(6,*) "wavefunction_m", cm(1,2), cm(2,2), cm(3,2) -! !end_added:giovanni:debug ---- RUNCP WAVEFUNCTION - ! - ENDIF - ! - ! nlfq needs deeq bec - ! - if( ttforce ) CALL nlfq( cm, eigr, bec, becdr, fion, lgam ) - ! - ! calphi calculates phi - ! the electron mass rises with g**2 - ! - CALL calphi( cm, ngw, bec, nkb, vkb, phi, nbsp, lgam, ema0bg) - ! - IF( force_pairing ) & - & phi( :, iupdwn(2):(iupdwn(2)+nupdwn(2)-1) ) = phi( :, 1:nupdwn(2)) - - - IF( tortho ) THEN - CALL ortho_cp_twin( eigr(1:ngw,1:nat), c0(1:ngw,1:nbsp), & - phi(1:ngw,1:nbsp), ngw, lambda, descla(1:descla_siz_ , 1:nspin), & - bigr, iter, ccc, bephi, becp, nbsp, nspin, nupdwn, iupdwn ) - ELSE IF(.not.non_ortho) THEN - ! - CALL gram( vkb, bec, nkb, c0, ngw, nbsp ) - ! - ENDIF - ! - ! - if ( ttforce ) CALL nlfl_twin( bec, becdr, lambda, fion, lgam ) !warning:giovanni may not work - - if ( iprsta >= 3 ) CALL print_lambda( lambda, nbsp, 9, ccc ) - - if ( tstress ) CALL nlfh( stress, bec, dbec, lambda ) - ! - IF ( tortho ) THEN - DO iss = 1, nspin_wfc - i1 = (iss-1)*nlax+1 - i2 = iss*nlax - IF(.not.bec%iscmplx) THEN - CALL updatc( ccc, nbsp, lambda(iss)%rvec, SIZE(lambda(iss)%rvec,1), phi, SIZE(phi,1), & - bephi%rvec(:,i1:i2), SIZE(bephi%rvec,1), becp%rvec, bec%rvec, c0, nupdwn(iss), iupdwn(iss), & - descla(:,iss) ) - ELSE - CALL updatc( ccc, nbsp, lambda(iss)%cvec, SIZE(lambda(iss)%cvec,1), phi, SIZE(phi,1), & - bephi%cvec(:,i1:i2), SIZE(bephi%cvec,1), becp%cvec, bec%cvec, c0, nupdwn(iss), iupdwn(iss), & - descla(:,iss) ) - ENDIF - END DO - END IF - ! - IF( force_pairing ) THEN - ! - c0 ( :, iupdwn(2):(iupdwn(2)+nupdwn(2)-1) ) = c0( :, 1:nupdwn(2)) - phi( :, iupdwn(2):(iupdwn(2)+nupdwn(2)-1) ) = phi( :, 1:nupdwn(2)) - - IF(.not.lambda(1)%iscmplx) THEN - lambda(2)%rvec(:,:) = lambda(1)%rvec(:,:) - ELSE - lambda(2)%cvec(:,:) = lambda(1)%cvec(:,:) - ENDIF - ! - ENDIF - ! - CALL calbec ( nvb+1, nsp, eigr, c0, bec) - - if ( tstress ) CALL caldbec( ngw, nkb, nbsp, 1, nsp, eigr, cm, dbec ) - - if ( iprsta >= 3 ) CALL dotcsc( eigr, c0, ngw, nbsp , lgam) - ! - xnhp0 = 0.0d0 - xnhpm = 0.0d0 - vnhp = 0.0d0 - fionm = 0.0d0 - ! - CALL ions_vel( vels, taus, tausm, na, nsp, delt ) - ! - xnhh0(:,:) = 0.0d0 - xnhhm(:,:) = 0.0d0 - vnhh (:,:) = 0.0d0 - velh (:,:) = ( h(:,:) - hold(:,:) ) / delt - ! - CALL elec_fakekine( ekincm, ema0bg, emass, c0, cm, ngw, nbsp, 1, delt ) - - xnhe0 = 0.0d0 - xnhem = 0.0d0 - vnhe = 0.0d0 - - DO iss=1,nspin - IF(.not.lambda(iss)%iscmplx) THEN - lambdam(iss)%rvec = lambda(iss)%rvec - ELSE - lambdam(iss)%cvec = lambda(iss)%cvec - ENDIF - ENDDO - ! - ELSE - ! - c0 = cm - ! - END IF - - ELSE - ! - IF( ttforce ) call nlfq( cm, eigr, bec, becdr, atoms0%for, lgam ) - ! - CALL vofrhos( ttprint, ttforce, tstress, rhor, rhog, atoms0, & - vpot, bec%rvec, cm, f, eigr, ei1, ei2, ei3, sfac, ht0, edft ) - ! - IF( iprsta > 1 ) CALL debug_energies( edft ) - ! - IF ( .NOT. force_pairing ) THEN - ! - CALL runcp_uspp( nfi, fccc, ccc, ema0bg, dt2bye, vpot, bec, cm, c0, fromscra = .TRUE. ) - ! - ELSE - ! - c0 = cm - ! - END IF - ! - IF ( tortho .AND. ( .NOT. force_pairing ) ) THEN - ! - ccc = fccc * dt2bye - ! - CALL ortho( cm, c0, lambda, descla, ccc, nupdwn, iupdwn, nspin ) - ! - ELSE IF(.not. non_ortho) THEN - ! - DO iss = 1, nspin_wfc - ! - CALL gram( vkb, bec, nkb, c0(1,iupdwn(iss)), SIZE(c0,1), nupdwn( iss ) ) - ! - END DO - ! - IF( force_pairing ) c0(1,iupdwn(2):iupdwn(2)+nupdwn(2)-1) = c0(1,1:nupdwn(2)) - ! - END IF - ! - ! - END IF - - IF( iprsta > 1 ) THEN - ! - ! Printout values at step 0, useful for debugging - ! - CALL printout( nfi, atoms0, 0.0d0, 0.0d0, ttprint, ht0, edft ) - ! - END IF - ! - RETURN - ! -END SUBROUTINE from_scratch diff --git a/quantum_espresso/kcp/CPV/geninv.f90 b/quantum_espresso/kcp/CPV/geninv.f90 deleted file mode 100644 index 521bc914e..000000000 --- a/quantum_espresso/kcp/CPV/geninv.f90 +++ /dev/null @@ -1,666 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! AB INITIO COSTANT PRESSURE MOLECULAR DYNAMICS -! ---------------------------------------------- -! Car-Parrinello Parallel Program -! Carlo Cavazzoni - Gerardo Ballabio -! SISSA, Trieste, Italy - 1997-99 -! Last modified: Sat Nov 13 11:04:11 MET 1999 -! ---------------------------------------------- - -#include "f_defs.h" - -! routines in this file: -! SUBROUTINE geninv(a,ld,n,mrank,cond,u,v,work,toleig,info,iopt) -! SUBROUTINE zgeninv(a,ld,n,mrank,cond,u,v,work,toleig,info,iopt) -! ---------------------------------------------- -! ---------------------------------------------- -! BEGIN manual - - SUBROUTINE geninv( a, ld, n, mrank, cond, u, v, & - work, toleig, info, iopt) - -! get a general inverse matrix -! -! iopt = 0: using calculated rank for pseudo inverse -! iopt = 1 : rank is assumed to be n-6 for pseudo inverse -! iopt > 10: scale matrix before decomposition -! ---------------------------------------------- -! END manual -! end of declarations -! ---------------------------------------------- - - USE kinds - IMPLICIT NONE - - INTEGER :: ld, n, mrank, info, iopt - REAL(DP) :: cond, toleig - - REAL(DP) :: a(ld,n), u(ld,n), v(ld,n), work(4*n) - REAL(DP) :: zero=0.0d0 - REAL(DP) :: one=1.0d0 - - INTEGER :: n3, i, j, k, m - -! ... scale matrix before inversion - IF ( iopt >= 10 ) THEN - n3 = 3 * n - DO i = 1, n - work( n3 + i ) = one - IF ( ABS( a(i,i) ) >= 1.d-13 ) & - work( n3 + i ) = one / SQRT( ABS( a(i,i) ) ) - END DO - DO i = 1, n - DO j = 1, n - a(i,j) = a(i,j) * work( n3 + i ) * work( n3 + j ) - END DO - END DO - END IF - -! ... get singular values - CALL dsvdc( a, ld, n, n, work, work(n+1), u, ld, v, ld, work(2*n+1), 11, info) - mrank = 0 - DO i = 1, n - IF ( ABS( work(i) ) > toleig ) mrank = mrank + 1 - END DO - - m = mrank - IF ( iopt == 1 .OR. iopt == 11 ) m = n - 6 - cond = work(1) / work(m) - DO i = 1, m - work(i) = one / work(i) - END DO - - DO j = 1, n - DO i = 1, n - a(i,j) = zero - END DO - DO k = 1, m - DO i = 1, n - a(i,j) = a(i,j) + v(i,k) * work(k) * u(j,k) - END DO - END DO - END DO - -! ... rescale matrix after inversion - IF ( iopt >= 10 ) THEN - DO i = 1, n - DO j = 1, n - a(i,j) = a(i,j) * work( n3 + i ) * work( n3 + j ) - END DO - END DO - END IF - - RETURN - END SUBROUTINE geninv - -! ---------------------------------------------- -! ---------------------------------------------- -! BEGIN manual - SUBROUTINE zgeninv(a,ld,n,mrank,cond,u,v,work,toleig,info,iopt) - -! get a general inverse matrix -! -! iopt = 0: using calculated rank for pseudo inverse -! iopt = 1 : rank is assumed to be n-6 for pseudo inverse -! iopt > 10: scale matrix before decomposition -! ---------------------------------------------- -! END manual -! end of declarations -! ---------------------------------------------- - - USE kinds - IMPLICIT NONE - - INTEGER :: ld, n, mrank, info, iopt - REAL(DP) :: cond, toleig - - COMPLEX(DP) a(ld,n),u(ld,n),v(ld,n),work(4*n) - REAL(DP) :: zero=0.0d0 - REAL(DP) :: one=1.0d0 - - INTEGER :: n3, i, j, k, m - -! ... scale matrix before inversion - IF (iopt.GE.10) THEN - n3=3*n - DO i=1,n - work(n3+i)=one - IF (abs(a(i,i)).GE.1.d-13) & - work(n3+i)=one/dsqrt(abs(a(i,i))) - END DO - DO i=1,n - DO j=1,n - a(i,j)=a(i,j)*work(n3+i)*work(n3+j) - END DO - END DO - END IF - -! ... get singular values - CALL dsvdc(a,ld,n,n,work,work(n+1),u,ld,v,ld,work(2*n+1),11,info) - mrank=0 - DO i=1,n - IF (abs(work(i)).GT.toleig) mrank=mrank+1 - END DO - - m=mrank - IF (iopt.EQ.1.OR.iopt.EQ.11) m=n-6 - cond=work(1)/work(m) - DO i=1,m - work(i)=one/work(i) - END DO - - DO j=1,n - DO i=1,n - a(i,j)=zero - END DO - DO k=1,m - DO i=1,n - a(i,j)=a(i,j)+v(i,k)*work(k)*u(j,k) - END DO - END DO - END DO - -! ... rescale matrix after inversion - IF (iopt.GE.10) THEN - DO i=1,n - DO j=1,n - a(i,j)=a(i,j)*work(n3+i)*work(n3+j) - END DO - END DO - END IF - - RETURN - END SUBROUTINE zgeninv - -! ---------------------------------------------- -! ---------------------------------------------- - SUBROUTINE dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info) - -! (describe briefly what this routine does...) -! ---------------------------------------------- - -! DSVDC IS A SUBROUTINE TO REDUCE A DOUBLE PRECISION NXP MATRIX X -! BY ORTHOGONAL TRANSFORMATIONS U AND V TO DIAGONAL FORM. THE -! DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X. THE -! COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS, -! AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS. -! -! ON ENTRY -! -! X DOUBLE PRECISION(LDX,P), WHERE LDX.GE.N. -! X CONTAINS THE MATRIX WHOSE SINGULAR VALUE -! DECOMPOSITION IS TO BE COMPUTED. X IS -! DESTROYED BY DSVDC. -! -! LDX INTEGER. -! LDX IS THE LEADING DIMENSION OF THE ARRAY X. -! -! N INTEGER. -! N IS THE NUMBER OF ROWS OF THE MATRIX X. -! -! P INTEGER. -! P IS THE NUMBER OF COLUMNS OF THE MATRIX X. -! -! LDU INTEGER. -! LDU IS THE LEADING DIMENSION OF THE ARRAY U. -! (SEE BELOW). -! -! LDV INTEGER. -! LDV IS THE LEADING DIMENSION OF THE ARRAY V. -! (SEE BELOW). -! -! WORK DOUBLE PRECISION(N). -! WORK IS A SCRATCH ARRAY. -! -! JOB INTEGER. -! JOB CONTROLS THE COMPUTATION OF THE SINGULAR -! VECTORS. IT HAS THE DECIMAL EXPANSION AB -! WITH THE FOLLOWING MEANING -! -! A.EQ.0 DO NOT COMPUTE THE LEFT SINGULAR -! VECTORS. -! A.EQ.1 RETURN THE N LEFT SINGULAR VECTORS -! IN U. -! A.GE.2 RETURN THE FIRST MIN(N,P) SINGULAR -! VECTORS IN U. -! B.EQ.0 DO NOT COMPUTE THE RIGHT SINGULAR -! VECTORS. -! B.EQ.1 RETURN THE RIGHT SINGULAR VECTORS -! IN V. -! -! ON RETURN -! -! S DOUBLE PRECISION(MM), WHERE MM=MIN(N+1,P). -! THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE -! SINGULAR VALUES OF X ARRANGED IN DESCENDING -! ORDER OF MAGNITUDE. -! -! E DOUBLE PRECISION(P), -! E ORDINARILY CONTAINS ZEROS. HOWEVER SEE THE -! DISCUSSION OF INFO FOR EXCEPTIONS. -! -! U DOUBLE PRECISION(LDU,K), WHERE LDU.GE.N. IF -! JOBA.EQ.1 THEN K.EQ.N, IF JOBA.GE.2 -! THEN K.EQ.MIN(N,P). -! U CONTAINS THE MATRIX OF LEFT SINGULAR VECTORS. -! U IS NOT REFERENCED IF JOBA.EQ.0. IF N.LE.P -! OR IF JOBA.EQ.2, THEN U MAY BE IDENTIFIED WITH X -! IN THE SUBROUTINE CALL. -! -! V DOUBLE PRECISION(LDV,P), WHERE LDV.GE.P. -! V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS. -! V IS NOT REFERENCED IF JOB.EQ.0. IF P.LE.N, -! THEN V MAY BE IDENTIFIED WITH X IN THE -! SUBROUTINE CALL. -! -! INFO INTEGER. -! THE SINGULAR VALUES (AND THEIR CORRESPONDING -! SINGULAR VECTORS) S(INFO+1),S(INFO+2),...,S(M) -! ARE CORRECT (HERE M=MIN(N,P)). THUS IF -! INFO.EQ.0, ALL THE SINGULAR VALUES AND THEIR -! VECTORS ARE CORRECT. IN ANY EVENT, THE MATRIX -! B = TRANS(U)*X*V IS THE BIDIAGONAL MATRIX -! WITH THE ELEMENTS OF S ON ITS DIAGONAL AND THE -! ELEMENTS OF E ON ITS SUPER-DIAGONAL (TRANS(U) -! IS THE TRANSPOSE OF U). THUS THE SINGULAR -! VALUES OF X AND B ARE THE SAME. -! -! LINPACK. THIS VERSION DATED 08/14/78 . -! CORRECTION MADE TO SHIFT 2/84. -! G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. -! -! DSVDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS. -! -! EXTERNAL DROT -! BLAS DAXPY,DDOT,DSCAL,DSWAP,DNRM2,DROTG -! FORTRAN DABS,DMAX1,MAX0,MIN0,MOD,DSQRT -! - - USE kinds - INTEGER LDX,N,P,LDU,LDV,JOB,INFO - REAL(DP) X(LDX,1),S(1),E(1),U(LDU,1),V(LDV,1),WORK(1) - -! INTERNAL VARIABLES -! - INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT, & - & MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1 - REAL(DP) DDOT,T,R - REAL(DP) B,C,CS,EL,EMM1,F,G,DNRM2,SCALEF,SHIFT,SL,SM,SN, & - & SMM1,T1,TEST,ZTEST - LOGICAL WANTU,WANTV -! -! -! SET THE MAXIMUM NUMBER OF ITERATIONS. -! - MAXIT = 30 -! -! DETERMINE WHAT IS TO BE COMPUTED. -! - WANTU = .FALSE. - WANTV = .FALSE. - JOBU = MOD(JOB,100)/10 - NCU = N - IF (JOBU .GT. 1) NCU = MIN0(N,P) - IF (JOBU .NE. 0) WANTU = .TRUE. - IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE. -! -! REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS -! IN S AND THE SUPER-DIAGONAL ELEMENTS IN E. -! - INFO = 0 - NCT = MIN0(N-1,P) - NRT = MAX0(0,MIN0(P-2,N)) - LU = MAX0(NCT,NRT) - IF (LU .LT. 1) GO TO 170 - DO 160 L = 1, LU - LP1 = L + 1 - IF (L .GT. NCT) GO TO 20 -! -! COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND -! PLACE THE L-TH DIAGONAL IN S(L). -! - s(l) = DNRM2(n-l+1,x(l,l),1) - IF (S(L) .EQ. 0.0D0) GO TO 10 - IF (X(L,L) .NE. 0.0D0) S(L) = SIGN(S(L),X(L,L)) - call DSCAL(n-l+1,1.0d0/s(l),x(l,l),1) - X(L,L) = 1.0D0 + X(L,L) - 10 CONTINUE - S(L) = -S(L) - 20 CONTINUE - IF (P .LT. LP1) GO TO 50 - DO 40 J = LP1, P - IF (L .GT. NCT) GO TO 30 - IF (S(L) .EQ. 0.0D0) GO TO 30 -! -! APPLY THE TRANSFORMATION. -! - t = - DDOT(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) - call DAXPY(n-l+1,t,x(l,l),1,x(l,j),1) - 30 CONTINUE -! -! PLACE THE L-TH ROW OF X INTO E FOR THE -! SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION. -! - E(J) = X(L,J) - 40 CONTINUE - 50 CONTINUE - IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70 -! -! PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK -! MULTIPLICATION. -! - DO 60 I = L, N - U(I,L) = X(I,L) - 60 CONTINUE - 70 CONTINUE - IF (L .GT. NRT) GO TO 150 -! -! COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE -! L-TH SUPER-DIAGONAL IN E(L). -! - e(l) = DNRM2(p-l,e(lp1),1) - IF (E(L) .EQ. 0.0D0) GO TO 80 - IF (E(LP1) .NE. 0.0D0) E(L) = SIGN(E(L),E(LP1)) - call DSCAL(p-l,1.0d0/e(l),e(lp1),1) - E(LP1) = 1.0D0 + E(LP1) - 80 CONTINUE - E(L) = -E(L) - IF (LP1 .GT. N .OR. E(L) .EQ. 0.0D0) GO TO 120 -! -! APPLY THE TRANSFORMATION. -! - DO 90 I = LP1, N - WORK(I) = 0.0D0 - 90 CONTINUE - DO 100 J = LP1, P - call DAXPY(n-l,e(j),x(lp1,j),1,work(lp1),1) - 100 CONTINUE - DO 110 J = LP1, P - call DAXPY(n-l,-e(j)/e(lp1),work(lp1),1,x(lp1,j),1) - 110 CONTINUE - 120 CONTINUE - IF (.NOT.WANTV) GO TO 140 -! -! PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT -! BACK MULTIPLICATION. -! - DO 130 I = LP1, P - V(I,L) = E(I) - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE -! -! SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M. -! - M = MIN0(P,N+1) - NCTP1 = NCT + 1 - NRTP1 = NRT + 1 - IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1) - IF (N .LT. M) S(M) = 0.0D0 - IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M) - E(M) = 0.0D0 -! -! IF REQUIRED, GENERATE U. -! - IF (.NOT.WANTU) GO TO 300 - IF (NCU .LT. NCTP1) GO TO 200 - DO 190 J = NCTP1, NCU - DO 180 I = 1, N - U(I,J) = 0.0D0 - 180 CONTINUE - U(J,J) = 1.0D0 - 190 CONTINUE - 200 CONTINUE - IF (NCT .LT. 1) GO TO 290 - DO 280 LL = 1, NCT - L = NCT - LL + 1 - IF (S(L) .EQ. 0.0D0) GO TO 250 - LP1 = L + 1 - IF (NCU .LT. LP1) GO TO 220 - DO 210 J = LP1, NCU - t = - DDOT(n-l+1,u(l,l),1,u(l,j),1)/u(l,l) - call DAXPY(n-l+1,t,u(l,l),1,u(l,j),1) - 210 CONTINUE - 220 CONTINUE - call DSCAL(n-l+1,-1.0d0,u(l,l),1) - U(L,L) = 1.0D0 + U(L,L) - LM1 = L - 1 - IF (LM1 .LT. 1) GO TO 240 - DO 230 I = 1, LM1 - U(I,L) = 0.0D0 - 230 CONTINUE - 240 CONTINUE - GO TO 270 - 250 CONTINUE - DO 260 I = 1, N - U(I,L) = 0.0D0 - 260 CONTINUE - U(L,L) = 1.0D0 - 270 CONTINUE - 280 CONTINUE - 290 CONTINUE - 300 CONTINUE -! -! IF IT IS REQUIRED, GENERATE V. -! - IF (.NOT.WANTV) GO TO 350 - DO 340 LL = 1, P - L = P - LL + 1 - LP1 = L + 1 - IF (L .GT. NRT) GO TO 320 - IF (E(L) .EQ. 0.0D0) GO TO 320 - DO 310 J = LP1, P - t = - DDOT(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l) - call DAXPY(p-l,t,v(lp1,l),1,v(lp1,j),1) - 310 CONTINUE - 320 CONTINUE - DO 330 I = 1, P - V(I,L) = 0.0D0 - 330 CONTINUE - V(L,L) = 1.0D0 - 340 CONTINUE - 350 CONTINUE -! -! MAIN ITERATION LOOP FOR THE SINGULAR VALUES. -! - MM = M - ITER = 0 - 360 CONTINUE -! -! QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND. -! -! ...EXIT - IF (M .EQ. 0) GO TO 620 -! -! IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET -! FLAG AND RETURN. -! - IF (ITER .LT. MAXIT) GO TO 370 - INFO = M -! ......EXIT - GO TO 620 - 370 CONTINUE -! -! THIS SECTION OF THE PROGRAM INSPECTS FOR -! NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON -! COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. -! -! KASE = 1 IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M -! KASE = 2 IF S(L) IS NEGLIGIBLE AND L.LT.M -! KASE = 3 IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND -! S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP). -! KASE = 4 IF E(M-1) IS NEGLIGIBLE (CONVERGENCE). -! - DO 390 LL = 1, M - L = M - LL -! ...EXIT - IF (L .EQ. 0) GO TO 400 - TEST = DABS(S(L)) + DABS(S(L+1)) - ZTEST = TEST + DABS(E(L)) - IF (ZTEST .NE. TEST) GO TO 380 - E(L) = 0.0D0 -! ......EXIT - GO TO 400 - 380 CONTINUE - 390 CONTINUE - 400 CONTINUE - IF (L .NE. M - 1) GO TO 410 - KASE = 4 - GO TO 480 - 410 CONTINUE - LP1 = L + 1 - MP1 = M + 1 - DO 430 LLS = LP1, MP1 - LS = M - LLS + LP1 -! ...EXIT - IF (LS .EQ. L) GO TO 440 - TEST = 0.0D0 - IF (LS .NE. M) TEST = TEST + DABS(E(LS)) - IF (LS .NE. L + 1) TEST = TEST + DABS(E(LS-1)) - ZTEST = TEST + DABS(S(LS)) - IF (ZTEST .NE. TEST) GO TO 420 - S(LS) = 0.0D0 -! ......EXIT - GO TO 440 - 420 CONTINUE - 430 CONTINUE - 440 CONTINUE - IF (LS .NE. L) GO TO 450 - KASE = 3 - GO TO 470 - 450 CONTINUE - IF (LS .NE. M) GO TO 460 - KASE = 1 - GO TO 470 - 460 CONTINUE - KASE = 2 - L = LS - 470 CONTINUE - 480 CONTINUE - L = L + 1 -! -! PERFORM THE TASK INDICATED BY KASE. -! - GO TO (490,520,540,570), KASE -! -! DEFLATE NEGLIGIBLE S(M). -! - 490 CONTINUE - MM1 = M - 1 - F = E(M-1) - E(M-1) = 0.0D0 - DO 510 KK = L, MM1 - K = MM1 - KK + L - T1 = S(K) - CALL DROTG(T1,F,CS,SN) - S(K) = T1 - IF (K .EQ. L) GO TO 500 - F = -SN*E(K-1) - E(K-1) = CS*E(K-1) - 500 CONTINUE - IF (WANTV) CALL DROT(P,V(1,K),1,V(1,M),1,CS,SN) - 510 CONTINUE - GO TO 610 -! -! SPLIT AT NEGLIGIBLE S(L). -! - 520 CONTINUE - F = E(L-1) - E(L-1) = 0.0D0 - DO 530 K = L, M - T1 = S(K) - CALL DROTG(T1,F,CS,SN) - S(K) = T1 - F = -SN*E(K) - E(K) = CS*E(K) - IF (WANTU) CALL DROT(N,U(1,K),1,U(1,L-1),1,CS,SN) - 530 CONTINUE - GO TO 610 -! -! PERFORM ONE QR STEP. -! - 540 CONTINUE -! -! CALCULATE THE SHIFT. -! - SCALEF = DMAX1(DABS(S(M)),DABS(S(M-1)),DABS(E(M-1)), & - & DABS(S(L)),DABS(E(L))) - SM = S(M)/SCALEF - SMM1 = S(M-1)/SCALEF - EMM1 = E(M-1)/SCALEF - SL = S(L)/SCALEF - EL = E(L)/SCALEF - B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0D0 - C = (SM*EMM1)**2 - SHIFT = 0.0D0 - IF (B .EQ. 0.0D0 .AND. C .EQ. 0.0D0) GO TO 550 - SHIFT = DSQRT(B**2+C) - IF (B .LT. 0.0D0) SHIFT = -SHIFT - SHIFT = C/(B + SHIFT) - 550 CONTINUE - F = (SL + SM)*(SL - SM) + SHIFT - G = SL*EL -! -! CHASE ZEROS. -! - MM1 = M - 1 - DO 560 K = L, MM1 - CALL DROTG(F,G,CS,SN) - IF (K .NE. L) E(K-1) = F - F = CS*S(K) + SN*E(K) - E(K) = CS*E(K) - SN*S(K) - G = SN*S(K+1) - S(K+1) = CS*S(K+1) - IF (WANTV) CALL DROT(P,V(1,K),1,V(1,K+1),1,CS,SN) - CALL DROTG(F,G,CS,SN) - S(K) = F - F = CS*E(K) + SN*S(K+1) - S(K+1) = -SN*E(K) + CS*S(K+1) - G = SN*E(K+1) - E(K+1) = CS*E(K+1) - IF (WANTU .AND. K .LT. N) & - & CALL DROT(N,U(1,K),1,U(1,K+1),1,CS,SN) - 560 CONTINUE - E(M-1) = F - ITER = ITER + 1 - GO TO 610 -! -! CONVERGENCE. -! - 570 CONTINUE -! -! MAKE THE SINGULAR VALUE POSITIVE. -! - IF (S(L) .GE. 0.0D0) GO TO 580 - S(L) = -S(L) - if(wantv)call DSCAL(p,-1.0d0,v(1,l),1) - 580 CONTINUE -! -! ORDER THE SINGULAR VALUE. -! - 590 IF (L .EQ. MM) GO TO 600 -! ...EXIT - IF (S(L) .GE. S(L+1)) GO TO 600 - T = S(L) - S(L) = S(L+1) - S(L+1) = T - if(wantv.and.l.lt.p)call DSWAP(p,v(1,l),1,v(1,l+1),1) - if(wantu.and.l.lt.n)call DSWAP(n,u(1,l),1,u(1,l+1),1) - L = L + 1 - GO TO 590 - 600 CONTINUE - ITER = 0 - M = M - 1 - 610 CONTINUE - GO TO 360 - 620 CONTINUE - RETURN - END SUBROUTINE dsvdc diff --git a/quantum_espresso/kcp/CPV/gradrho.f90 b/quantum_espresso/kcp/CPV/gradrho.f90 deleted file mode 100644 index 78dc006ce..000000000 --- a/quantum_espresso/kcp/CPV/gradrho.f90 +++ /dev/null @@ -1,131 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -#include "f_defs.h" - -! -!---------------------------------------------------------------------- - subroutine gradrho(nspin,rhog,drho,d2rho,dxdyrho,dxdzrho,dydzrho) -!---------------------------------------------------------------------- -! -! calculates gradient of charge density for gradient corrections -! in: charge density on G-space out: gradient in R-space -! - use cell_base - use gvecp, only: ng => ngm - use reciprocal_vectors - use recvecs_indexes - USE cp_interfaces, ONLY: fwfft, invfft - USE fft_base, ONLY: dfftp - use grid_dimensions, only : nnr=> nnrx -! use grid_dimensions, only: nr1, nr2, nr3, & -! nr1x, nr2x, nr3x, nnr => nnrx -! - implicit none -! input - integer nspin - complex(kind=8) rhog(ng,nspin) -! output - real(kind=8) drho(3,nnr), d2rho(3,nnr), & - & dxdyrho(nnr), dxdzrho(nnr), & - & dydzrho(nnr) -! local - complex(kind=8), allocatable:: v(:), w(:) - complex(kind=8) ci - integer iss, ig, ir, j -! -! - allocate(v(nnr)) - allocate(w(nnr)) - ci=(0.0d0,1.0d0) - do ir = 1,nnr - do j = 1,3 - drho(j,ir) = 0.d0 - d2rho(j,ir) = 0.d0 - end do - dxdyrho(ir) = 0.d0 - dxdzrho(ir) = 0.d0 - dydzrho(ir) = 0.d0 - end do - do iss=1,nspin - - do ig=1,nnr - v(ig)=(0.0d0,0.0d0) - w(ig)=(0.0d0,0.0d0) - end do - do ig=1,ng - v(np(ig))= ci*tpiba*gx(1,ig)*rhog(ig,iss) - v(nm(ig))=conjg(ci*tpiba*gx(1,ig)*rhog(ig,iss)) - w(np(ig))= -1.d0*tpiba**2*gx(1,ig)**2*rhog(ig,iss) - w(nm(ig))=conjg(-1.d0*tpiba**2*gx(1,ig)**2*rhog(ig,iss)) - end do - call invfft('Dense',v, dfftp ) - call invfft('Dense',w, dfftp ) - do ir=1,nnr - drho(1,ir)=drho(1,ir)+real(v(ir)) - d2rho(1,ir)=d2rho(1,ir)+real(w(ir)) - end do -! - do ig=1,nnr - v(ig)=(0.0d0,0.0d0) - w(ig)=(0.0d0,0.0d0) - end do - do ig=1,ng - v(np(ig))= tpiba*( ci*gx(2,ig)*rhog(ig,iss)- & - & gx(3,ig)*rhog(ig,iss) ) - v(nm(ig))= tpiba*(conjg(ci*gx(2,ig)*rhog(ig,iss))+ & - & ci*conjg(ci*gx(3,ig)*rhog(ig,iss))) - w(np(ig))= -1.d0*tpiba**2*( gx(2,ig)**2*rhog(ig,iss) + & - & ci*gx(3,ig)**2*rhog(ig,iss) ) - w(nm(ig))= -1.d0*tpiba**2*(conjg(gx(2,ig)**2*rhog(ig,iss))+ & - & ci*conjg(gx(3,ig)**2*rhog(ig,iss))) - end do - call invfft('Dense',v, dfftp ) - call invfft('Dense',w, dfftp ) - do ir=1,nnr - drho(2,ir)=drho(2,ir)+real(v(ir)) - drho(3,ir)=drho(3,ir)+aimag(v(ir)) - d2rho(2,ir)=d2rho(2,ir)+real(w(ir)) - d2rho(3,ir)=d2rho(3,ir)+aimag(w(ir)) - end do - - do ig=1,nnr - v(ig)=(0.0d0,0.0d0) - end do - do ig=1,ng - v(np(ig))= -1.d0*tpiba**2*gx(1,ig)*gx(2,ig)*rhog(ig,iss) - v(nm(ig))=conjg(v(np(ig))) - end do - call invfft('Dense',v, dfftp ) - do ir=1,nnr - dxdyrho(ir)=dxdyrho(ir)+real(v(ir)) - end do -! - do ig=1,nnr - v(ig)=(0.0d0,0.0d0) - end do - do ig=1,ng - v(np(ig))= -1.d0*tpiba**2*(gx(1,ig)*gx(3,ig)*rhog(ig,iss) + & - & ci*gx(2,ig)*gx(3,ig)*rhog(ig,iss) ) - v(nm(ig))= -1.d0*tpiba**2* & - & (conjg(gx(1,ig)*gx(3,ig)*rhog(ig,iss))+ & - & ci*conjg(gx(2,ig)*gx(3,ig)*rhog(ig,iss))) - end do - call invfft('Dense',v, dfftp ) - do ir=1,nnr - dxdzrho(ir)=dxdzrho(ir)+real(v(ir)) - dydzrho(ir)=dydzrho(ir)+aimag(v(ir)) - end do - - end do - deallocate(v) - deallocate(w) - - return - end - diff --git a/quantum_espresso/kcp/CPV/gram_swap.f90 b/quantum_espresso/kcp/CPV/gram_swap.f90 deleted file mode 100644 index f2b0612d4..000000000 --- a/quantum_espresso/kcp/CPV/gram_swap.f90 +++ /dev/null @@ -1,85 +0,0 @@ -!------------------------------------------------------------------------- -SUBROUTINE gram_swap( betae, bec, nkbx, cp, ngwx, n, fixed_index ) -!----------------------------------------------------------------------- -! -! This is a modified gram-schmidt orthogonalization -! to adapt the case 1 wfc is fixed. -! Using the fact that gram-schmidt does not change the first vector, -! we swap the fixed wfc with the first one, then do as normal, -! then in the end, we do another swap to return to input order. -! - USE uspp, ONLY : nkb - USE gvecw, ONLY : ngw - USE kinds, ONLY : DP - USE control_flags, ONLY : gamma_only, do_wf_cmplx !added:giovanni - USE electrons_base, ONLY : ispin - USE twin_types !added:giovanni - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nkbx, ngwx, n, fixed_index - type(twin_matrix) :: bec!( nkbx, n )!modified:giovanni - COMPLEX(DP) :: cp( ngwx, n ), betae( ngwx, nkb ) - ! - REAL(DP) :: anorm, cscnorm - COMPLEX(DP), ALLOCATABLE :: csc( : ) !modified:giovanni - INTEGER :: i,k, ispin_aux - LOGICAL :: lgam !i added:giovanni - EXTERNAL cscnorm - ! - lgam=gamma_only.and..not.do_wf_cmplx !added:giovanni - ! - CALL start_clock( 'gram_swap' ) - ! - ALLOCATE( csc( n ) ) - ! - csc=CMPLX(0.d0,0.d0) - ! - CALL zswap( ngwx, cp(:,fixed_index), 1, cp(:,1), 1 ) - ! NsC Exchange the spin indeces as well - ispin_aux = ispin(fixed_index) ! Store the original spin - ispin(1) = ispin(fixed_index) - ispin(fixed_index) = 1 - - DO i = 1, n - ! - CALL gracsc( bec, nkbx, betae, cp, ngwx, i, csc, n, lgam )!added:giovanni lgam - ! - ! calculate orthogonalized cp(i) : |cp(i)>=|cp(i)>-\sum_k - ! - DO k = 1, i - 1 - CALL ZAXPY(ngw,-csc(k),cp(1,k),1,cp(1,i),1)!modified:giovanni - END DO - ! - anorm = cscnorm( bec, nkbx, cp, ngwx, i, n, lgam) - ! - ! below is the same CALL ZSCAL( ngw, CMPLX(1.0d0/anorm, 0.d0) , cp(1,i), 1 ) - ! - DO k = 1, ngw - cp(k,i) = cp(k,i)*CMPLX(1.0d0/anorm, 0.d0) - ENDDO - ! - ! these are the final bec's - ! - IF (nkbx > 0 ) THEN - IF(.not.bec%iscmplx) THEN - CALL DSCAL( nkbx, 1.0d0/anorm, bec%rvec(1:nkbx,i), 1 )!modified:giovanni - ELSE - CALL ZSCAL( nkbx, CMPLX(1.0d0/anorm,0.d0) , bec%cvec(1:nkbx,i), 1 )!added:giovanni - ENDIF - ENDIF - ! - END DO - ! - DEALLOCATE( csc ) - ! - CALL zswap( ngwx, cp(:,1), 1, cp(:,fixed_index), 1 ) - ! Nsc - ispin(1) = 1 - ispin(fixed_index) = ispin_aux - ! - CALL stop_clock( 'gram_swap' ) - ! - RETURN - ! -END SUBROUTINE gram_swap diff --git a/quantum_espresso/kcp/CPV/gtable.f90 b/quantum_espresso/kcp/CPV/gtable.f90 deleted file mode 100644 index b57314f0c..000000000 --- a/quantum_espresso/kcp/CPV/gtable.f90 +++ /dev/null @@ -1,652 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -subroutine gtable( ipol, ctable) - - ! this subroutine prepares the correspondence array to - ! compute the operator exp(iG_ipol.r) - - ! ctable : output correspondence table - ! in (ig,1) correspondence for g+1 - ! in (ig,2) correspondence for (-g)+1 - ! we use the rule: if non point ngw+1 - ! if found positive = normal - ! negative = conjugate - ! ipol : input polarization direction - ! a orthorombic primitive cell is supposed - - use gvecw, only: ngw - use reciprocal_vectors, only: mill_l - use mp, only: mp_sum - use io_global, only: ionode, stdout - use mp_global, only: intra_image_comm - - implicit none - integer :: ipol, ctable(ngw,2) - !local variables - integer :: i,j,k, ig, jg - logical :: found - real(8) :: test - - test=0.d0 - do ig=1,ngw!loop on g vectors - ! first +g - i = mill_l(1,ig) - j = mill_l(2,ig) - k = mill_l(3,ig) - if(ipol.eq.1) i=i+1 - if(ipol.eq.2) j=j+1 - if(ipol.eq.3) k=k+1 - - found = .false. - - do jg=1,ngw - if(mill_l(1,jg).eq.i .and. mill_l(2,jg).eq.j .and. mill_l(3,jg).eq.k) then - found=.true. - ctable(ig,1)=jg - endif - enddo - - if(.not. found) then - do jg=1,ngw - if(-mill_l(1,jg).eq.i .and. -mill_l(2,jg).eq.j .and. -mill_l(3,jg).eq.k) then - found=.true. - ctable(ig,1)=-jg - endif - enddo - if(.not. found) then - ctable(ig,1)= ngw+1 - test=test+1.d0 - endif - endif - - ! now -g - i = -mill_l(1,ig) - j = -mill_l(2,ig) - k = -mill_l(3,ig) - if(ipol.eq.1) i=i+1 - if(ipol.eq.2) j=j+1 - if(ipol.eq.3) k=k+1 - - found = .false. - - do jg=1,ngw - if (-mill_l(1,jg).eq.i .and. -mill_l(2,jg).eq.j .and. -mill_l(3,jg).eq.k)then - found=.true. - ctable(ig,2)=-jg - endif - enddo - - if(.not.found) then - do jg=1,ngw - if(mill_l(1,jg).eq.i .and. mill_l(2,jg).eq.j .and. mill_l(3,jg).eq.k)then - found=.true. - ctable(ig,2)=jg - endif - enddo - if(.not.found) then - ctable(ig,2)=ngw+1 - test=test+1.d0 - endif - endif - enddo - - call mp_sum(test, intra_image_comm) - if(ionode) write(stdout,*) '#not found, gtable: ', test - - return -end subroutine gtable - -subroutine gtablein( ipol, ctabin) - - ! this subroutine prepare the inverse correspondence array to - ! compute the operator exp(iG_ipol.r) - - ! ctabin(ngw,2) : output correspondence table - ! if negative to take complex conjugate, 1 g'+1, 2 g' -1 - ! if not found = ngw+1 - ! ipol : input polarization direction - ! a orthorombic primitive cell is supposed - - use gvecw, only: ngw - use reciprocal_vectors, only: mill_l - use mp, only: mp_sum - use io_global, only: ionode, stdout - use mp_global, only: intra_image_comm - - implicit none - - integer :: ipol, ctabin(ngw,2) - - !local variables - integer :: i,j,k, ig, jg - logical :: found - real(8) :: test - - test=0.d0 - - do ig=1,ngw!loop on g vectors - i = mill_l(1,ig) - j = mill_l(2,ig) - k = mill_l(3,ig) - if(ipol.eq.1) i=i+1 - if(ipol.eq.2) j=j+1 - if(ipol.eq.3) k=k+1 - found = .false. - - do jg=1,ngw - if(i.eq.mill_l(1,jg).and. j.eq.mill_l(2,jg) .and. k.eq.mill_l(3,jg))then - found = .true. - ctabin(ig,1)=jg - else if(i.eq.-mill_l(1,jg).and. j.eq.-mill_l(2,jg) .and. k.eq.-mill_l(3,jg))then - found=.true. - ctabin(ig,1)=-jg - endif - enddo - if(.not.found) then - ctabin(ig,1)=ngw+1 - test=test+1 - endif - enddo - - do ig=1,ngw!loop on g vectors - i = mill_l(1,ig) - j = mill_l(2,ig) - k = mill_l(3,ig) - if(ipol.eq.1) i=i-1 - if(ipol.eq.2) j=j-1 - if(ipol.eq.3) k=k-1 - found = .false. - - do jg=1,ngw - if(i.eq.mill_l(1,jg).and. j.eq.mill_l(2,jg) .and. k.eq.mill_l(3,jg))then - found = .true. - ctabin(ig,2)=jg - else if(i.eq.-mill_l(1,jg).and. j.eq.-mill_l(2,jg) .and. k.eq.-mill_l(3,jg))then - found=.true. - ctabin(ig,2)=-jg - endif - enddo - if(.not.found) then - ctabin(ig,2)=ngw+1 - test=test+1 - endif - enddo - - call mp_sum(test, intra_image_comm) - if(ionode) write(stdout,*) '#not found, gtabin: ', test - - return - -end subroutine gtablein - - - -subroutine find_whose_is_g -!this subroutine set the correspondence G-->Proc - - USE gvecw, ONLY : ngw, ngwt - USE reciprocal_vectors, ONLY : ig_l2g - USE mp, ONLY : mp_sum - USE io_global, ONLY : stdout - USE mp_global, ONLY : me_image, intra_image_comm - USE efield_module, ONLY : whose_is_g - - implicit none - - INTEGER :: ig - - whose_is_g(:)=0 - - - do ig=1,ngw - if(ig_l2g(ig) > ngwt) then - write(stdout,*) 'find_whose_is_g: too large' - stop - endif - whose_is_g(ig_l2g(ig))=me_image+1 - enddo - call mp_sum(whose_is_g,intra_image_comm) - whose_is_g(:)=whose_is_g(:)-1 - - -return -end subroutine find_whose_is_g - - -subroutine gtable_missing - - USE efield_module, ONLY : ctable_missing_1,ctable_missing_2, whose_is_g,n_g_missing_p,& - & ctable_missing_rev_1,ctable_missing_rev_2 - USE gvecw, ONLY : ngw, ngwt - USE reciprocal_vectors, ONLY : ig_l2g, mill_g, mill_l, gstart - USE mp, ONLY : mp_sum, mp_max, mp_alltoall - USE io_global, ONLY : stdout - USE mp_global, ONLY : me_image, nproc_image, intra_image_comm - USE parallel_include - - - implicit none - - INTEGER :: ipol, i,j,k,ig,igg, nfound_max, ip - LOGICAL :: found - INTEGER :: nfound_proc(nproc_image,2) - INTEGER, ALLOCATABLE :: igg_found(:,:,:), ig_send(:,:,:), igg_found_snd(:,:,:) - INTEGER, ALLOCATABLE :: igg_found_rcv(:,:,:) - - - - allocate(igg_found(ngwt,2, nproc_image),ig_send(ngwt,2,nproc_image)) - do ipol=1,2 - - nfound_max=0 - nfound_proc(:,:)=0 - ig_send(:,:,:)=0 - - do ig=1,ngw!loop on g vectors - ! first +g - i = mill_l(1,ig) - j = mill_l(2,ig) - k = mill_l(3,ig) - if(ipol.eq.1) i=i+1 - if(ipol.eq.2) j=j+1 - if(ipol.eq.3) k=k+1 - do igg=1,ngwt - if( i==mill_g(1,igg) .and. j==mill_g(2,igg) .and. k==mill_g(3,igg)) then - if(whose_is_g(igg) /= -1 .and. whose_is_g(igg) /= me_image) then - nfound_max=nfound_max+1 - nfound_proc(whose_is_g(igg)+1,1)=nfound_proc(whose_is_g(igg)+1,1)+1 - ig_send(nfound_proc(whose_is_g(igg)+1,1),1,whose_is_g(igg)+1)=ig - igg_found(nfound_proc(whose_is_g(igg)+1,1),1,whose_is_g(igg)+1)=igg - endif - - else if( i==-mill_g(1,igg) .and. j==-mill_g(2,igg) .and. k==-mill_g(3,igg)) then - if(whose_is_g(igg) /= -1 .and. whose_is_g(igg) /= me_image) then - nfound_max=nfound_max+1 - nfound_proc(whose_is_g(igg)+1,1)=nfound_proc(whose_is_g(igg)+1,1)+1 - ig_send(nfound_proc(whose_is_g(igg)+1,1),1,whose_is_g(igg)+1)=ig - igg_found(nfound_proc(whose_is_g(igg)+1,1),1,whose_is_g(igg)+1)=-igg - endif - endif - - enddo - enddo - - do ig=gstart,ngw!loop on g vectors - ! first +g - i = -mill_l(1,ig) - j = -mill_l(2,ig) - k = -mill_l(3,ig) - if(ipol.eq.1) i=i+1 - if(ipol.eq.2) j=j+1 - if(ipol.eq.3) k=k+1 - do igg=1,ngwt - if( i==mill_g(1,igg) .and. j==mill_g(2,igg) .and. k==mill_g(3,igg)) then - if(whose_is_g(igg) /= -1 .and. whose_is_g(igg) /= me_image) then - nfound_max=nfound_max+1 - nfound_proc(whose_is_g(igg)+1,2)=nfound_proc(whose_is_g(igg)+1,2)+1 - ig_send(nfound_proc(whose_is_g(igg)+1,2),2,whose_is_g(igg)+1)=ig - igg_found(nfound_proc(whose_is_g(igg)+1,2),2,whose_is_g(igg)+1)=igg - endif - - else if( i==-mill_g(1,igg) .and. j==-mill_g(2,igg) .and. k==-mill_g(3,igg)) then - if(whose_is_g(igg) /= -1 .and. whose_is_g(igg) /= me_image) then - nfound_max=nfound_max+1 - nfound_proc(whose_is_g(igg)+1,2)=nfound_proc(whose_is_g(igg)+1,2)+1 - ig_send(nfound_proc(whose_is_g(igg)+1,2),2,whose_is_g(igg)+1)=ig - igg_found(nfound_proc(whose_is_g(igg)+1,2),2,whose_is_g(igg)+1)=-igg - endif - endif - - enddo - enddo - - -!determine the largest nfound for processor and set it as dimensione for ctable_missing and ctable_missing_rev -!copy ig_send to ctable_missing - - call mp_sum(nfound_max, intra_image_comm) - write(stdout,*) 'Additional found:', nfound_max - - n_g_missing_p(ipol)=maxval(nfound_proc(:,:)) - - call mp_max(n_g_missing_p(ipol), intra_image_comm) - - - if(ipol==1) then - allocate(ctable_missing_1(n_g_missing_p(ipol),2,nproc_image)) - ctable_missing_1(:,:,:)=0 - do ip=1,nproc_image - ctable_missing_1(1:nfound_proc(ip,1),1,ip)=ig_send(1:nfound_proc(ip,1),1,ip) - ctable_missing_1(1:nfound_proc(ip,2),2,ip)=ig_send(1:nfound_proc(ip,2),2,ip) - enddo - else - allocate(ctable_missing_2(n_g_missing_p(ipol),2,nproc_image)) - ctable_missing_2(:,:,:)=0 - do ip=1,nproc_image - ctable_missing_2(1:nfound_proc(ip,1),1,ip)=ig_send(1:nfound_proc(ip,1),1,ip) - ctable_missing_2(1:nfound_proc(ip,2),2,ip)=ig_send(1:nfound_proc(ip,2),2,ip) - enddo - endif - - -!mpi all to all for igg_found - - allocate(igg_found_snd(n_g_missing_p(ipol),2,nproc_image)) - allocate(igg_found_rcv(n_g_missing_p(ipol),2,nproc_image)) - igg_found_snd(:,:,:)=0 - do ip=1,nproc_image - igg_found_snd(1:nfound_proc(ip,1),1,ip)=igg_found(1:nfound_proc(ip,1),1,ip) - igg_found_snd(1:nfound_proc(ip,2),2,ip)=igg_found(1:nfound_proc(ip,2),2,ip) - enddo - - - call mp_alltoall( igg_found_snd, igg_found_rcv, intra_image_comm ) - - if(ipol==1) then - allocate(ctable_missing_rev_1(n_g_missing_p(ipol),2,nproc_image)) - ctable_missing_rev_1(:,:,:)=0 - else - allocate(ctable_missing_rev_2(n_g_missing_p(ipol),2,nproc_image)) - ctable_missing_rev_2(:,:,:)=0 - endif - - - - nfound_max=0 - - do ip=1,nproc_image - do igg=1, n_g_missing_p(ipol) - if(igg_found_rcv(igg,1,ip) /= 0 ) then - found=.false. - do ig=1,ngw - if(igg_found_rcv(igg,1,ip)>0) then - if(ig_l2g(ig)==igg_found_rcv(igg,1,ip)) then - nfound_max=nfound_max+1 - if(ipol==1) then - ctable_missing_rev_1(igg,1,ip)=ig - else - ctable_missing_rev_2(igg,1,ip)=ig - endif - found=.true. - endif - else - if(ig_l2g(ig)==-igg_found_rcv(igg,1,ip)) then - nfound_max=nfound_max+1 - if(ipol==1) then - ctable_missing_rev_1(igg,1,ip)=-ig - else - ctable_missing_rev_2(igg,1,ip)=-ig - endif - found=.true. - endif - endif - enddo - if(.not.found) write(stdout,*) 'NOT FOUND:', igg_found_rcv(igg,1,ip) - endif - enddo - do igg=1, n_g_missing_p(ipol) - if(igg_found_rcv(igg,2,ip) /= 0 ) then - found=.false. - do ig=1,ngw - if(igg_found_rcv(igg,2,ip)>0) then - if(ig_l2g(ig)==igg_found_rcv(igg,2,ip)) then - nfound_max=nfound_max+1 - if(ipol==1) then - ctable_missing_rev_1(igg,2,ip)=ig - else - ctable_missing_rev_2(igg,2,ip)=ig - endif - found=.true. - endif - else - if(ig_l2g(ig)==-igg_found_rcv(igg,2,ip)) then - nfound_max=nfound_max+1 - if(ipol==1) then - ctable_missing_rev_1(igg,2,ip)=-ig - else - ctable_missing_rev_2(igg,2,ip)=-ig - endif - found=.true. - endif - endif - enddo - if(.not.found) write(stdout,*) 'NOT FOUND:', igg_found_rcv(igg,2,ip) - endif - enddo - - enddo - call mp_sum(nfound_max, intra_image_comm) - !write(stdout,*) 'Found check', nfound_max - deallocate(igg_found_snd,igg_found_rcv) - enddo - - - - deallocate(igg_found, ig_send) -return - -end subroutine gtable_missing - - - - -subroutine gtable_missing_inv - - USE efield_module, ONLY : ctabin_missing_1,ctabin_missing_2, whose_is_g,n_g_missing_m,& - & ctabin_missing_rev_1,ctabin_missing_rev_2 - USE gvecw, ONLY : ngw, ngwt - USE reciprocal_vectors, ONLY : ig_l2g, mill_g, mill_l - USE mp, ONLY : mp_sum, mp_max, mp_alltoall - USE io_global, ONLY : stdout - USE mp_global, ONLY : me_image, nproc_image, intra_image_comm - USE parallel_include - - - implicit none - - INTEGER :: ipol, i,j,k,ig,igg, nfound_max, ip - LOGICAL :: found - INTEGER :: nfound_proc(nproc_image,2) - INTEGER, ALLOCATABLE :: igg_found(:,:,:), ig_send(:,:,:), igg_found_snd(:,:,:) - INTEGER, ALLOCATABLE :: igg_found_rcv(:,:,:) - - - - allocate(igg_found(ngwt,2, nproc_image),ig_send(ngwt,2,nproc_image)) - do ipol=1,2 - - - - nfound_max=0 - nfound_proc(:,:)=0 - ig_send(:,:,:)=0 - - do ig=1,ngw!loop on g vectors - ! first +g - i = mill_l(1,ig) - j = mill_l(2,ig) - k = mill_l(3,ig) - if(ipol.eq.1) i=i+1 - if(ipol.eq.2) j=j+1 - if(ipol.eq.3) k=k+1 - do igg=1,ngwt - if( i==mill_g(1,igg) .and. j==mill_g(2,igg) .and. k==mill_g(3,igg)) then - if(whose_is_g(igg) /= -1 .and. whose_is_g(igg) /= me_image) then - nfound_max=nfound_max+1 - nfound_proc(whose_is_g(igg)+1,1)=nfound_proc(whose_is_g(igg)+1,1)+1 - ig_send(nfound_proc(whose_is_g(igg)+1,1),1,whose_is_g(igg)+1)=ig - igg_found(nfound_proc(whose_is_g(igg)+1,1),1,whose_is_g(igg)+1)=igg - endif - - else if( i==-mill_g(1,igg) .and. j==-mill_g(2,igg) .and. k==-mill_g(3,igg)) then - if(whose_is_g(igg) /= -1 .and. whose_is_g(igg) /= me_image) then - nfound_max=nfound_max+1 - nfound_proc(whose_is_g(igg)+1,1)=nfound_proc(whose_is_g(igg)+1,1)+1 - ig_send(nfound_proc(whose_is_g(igg)+1,1),1,whose_is_g(igg)+1)=ig - igg_found(nfound_proc(whose_is_g(igg)+1,1),1,whose_is_g(igg)+1)=-igg - endif - endif - - enddo - enddo - - do ig=1,ngw!loop on g vectors - ! first +g - i = mill_l(1,ig) - j = mill_l(2,ig) - k = mill_l(3,ig) - if(ipol.eq.1) i=i-1 - if(ipol.eq.2) j=j-1 - if(ipol.eq.3) k=k-1 - do igg=1,ngwt - if( i==mill_g(1,igg) .and. j==mill_g(2,igg) .and. k==mill_g(3,igg)) then - if(whose_is_g(igg) /= -1 .and. whose_is_g(igg) /= me_image) then - nfound_max=nfound_max+1 - nfound_proc(whose_is_g(igg)+1,2)=nfound_proc(whose_is_g(igg)+1,2)+1 - ig_send(nfound_proc(whose_is_g(igg)+1,2),2,whose_is_g(igg)+1)=ig - igg_found(nfound_proc(whose_is_g(igg)+1,2),2,whose_is_g(igg)+1)=igg - endif - - else if( i==-mill_g(1,igg) .and. j==-mill_g(2,igg) .and. k==-mill_g(3,igg)) then - if(whose_is_g(igg) /= -1 .and. whose_is_g(igg) /= me_image) then - nfound_max=nfound_max+1 - nfound_proc(whose_is_g(igg)+1,2)=nfound_proc(whose_is_g(igg)+1,2)+1 - ig_send(nfound_proc(whose_is_g(igg)+1,2),2,whose_is_g(igg)+1)=ig - igg_found(nfound_proc(whose_is_g(igg)+1,2),2,whose_is_g(igg)+1)=-igg - endif - endif - - enddo - enddo - - -!determine the largest nfound for processor and set it as dimensione for ctabin_missing and ctabin_missing_rev -!copy ig_send to ctabin_missing - - call mp_sum(nfound_max, intra_image_comm) - write(stdout,*) 'Additional found:', nfound_max - - - n_g_missing_m(ipol)=maxval(nfound_proc(:,:)) - call mp_max(n_g_missing_m(ipol), intra_image_comm) - - - if(ipol==1) then - allocate(ctabin_missing_1(n_g_missing_m(ipol),2,nproc_image)) - ctabin_missing_1(:,:,:)=0 - do ip=1,nproc_image - ctabin_missing_1(1:nfound_proc(ip,1),1,ip)=ig_send(1:nfound_proc(ip,1),1,ip) - ctabin_missing_1(1:nfound_proc(ip,2),2,ip)=ig_send(1:nfound_proc(ip,2),2,ip) - enddo - else - allocate(ctabin_missing_2(n_g_missing_m(ipol),2,nproc_image)) - ctabin_missing_2(:,:,:)=0 - do ip=1,nproc_image - ctabin_missing_2(1:nfound_proc(ip,1),1,ip)=ig_send(1:nfound_proc(ip,1),1,ip) - ctabin_missing_2(1:nfound_proc(ip,2),2,ip)=ig_send(1:nfound_proc(ip,2),2,ip) - enddo - endif - - -!mpi all to all for igg_found - - allocate(igg_found_snd(n_g_missing_m(ipol),2,nproc_image)) - allocate(igg_found_rcv(n_g_missing_m(ipol),2,nproc_image)) - igg_found_snd(:,:,:)=0 - do ip=1,nproc_image - igg_found_snd(1:nfound_proc(ip,1),1,ip)=igg_found(1:nfound_proc(ip,1),1,ip) - igg_found_snd(1:nfound_proc(ip,2),2,ip)=igg_found(1:nfound_proc(ip,2),2,ip) - enddo - - - CALL mp_alltoall( igg_found_snd, igg_found_rcv, intra_image_comm ) - - if(ipol==1) then - allocate(ctabin_missing_rev_1(n_g_missing_m(ipol),2,nproc_image)) - ctabin_missing_rev_1(:,:,:)=0 - else - allocate(ctabin_missing_rev_2(n_g_missing_m(ipol),2,nproc_image)) - ctabin_missing_rev_2(:,:,:)=0 - endif - - - - nfound_max=0 - - do ip=1,nproc_image - do igg=1, n_g_missing_m(ipol) - if(igg_found_rcv(igg,1,ip) /= 0 ) then - found=.false. - do ig=1,ngw - if(igg_found_rcv(igg,1,ip)>0) then - if(ig_l2g(ig)==igg_found_rcv(igg,1,ip)) then - nfound_max=nfound_max+1 - if(ipol==1) then - ctabin_missing_rev_1(igg,1,ip)=ig - else - ctabin_missing_rev_2(igg,1,ip)=ig - endif - found=.true. - endif - else - if(ig_l2g(ig)==-igg_found_rcv(igg,1,ip)) then - nfound_max=nfound_max+1 - if(ipol==1) then - ctabin_missing_rev_1(igg,1,ip)=-ig - else - ctabin_missing_rev_2(igg,1,ip)=-ig - endif - found=.true. - endif - endif - enddo - if(.not.found) write(stdout,*) 'NOT FOUND:', igg_found_rcv(igg,1,ip) - endif - enddo - do igg=1, n_g_missing_m(ipol) - if(igg_found_rcv(igg,2,ip) /= 0 ) then - found=.false. - do ig=1,ngw - if(igg_found_rcv(igg,2,ip)>0) then - if(ig_l2g(ig)==igg_found_rcv(igg,2,ip)) then - nfound_max=nfound_max+1 - if(ipol==1) then - ctabin_missing_rev_1(igg,2,ip)=ig - else - ctabin_missing_rev_2(igg,2,ip)=ig - endif - found=.true. - endif - else - if(ig_l2g(ig)==-igg_found_rcv(igg,2,ip)) then - nfound_max=nfound_max+1 - if(ipol==1) then - ctabin_missing_rev_1(igg,2,ip)=-ig - else - ctabin_missing_rev_2(igg,2,ip)=-ig - endif - found=.true. - endif - endif - enddo - if(.not.found) write(stdout,*) 'NOT FOUND:', igg_found_rcv(igg,2,ip) - endif - enddo - - enddo - call mp_sum(nfound_max, intra_image_comm) - !write(stdout,*) 'Found check', nfound_max - deallocate(igg_found_snd,igg_found_rcv) - enddo - - - deallocate(igg_found, ig_send) -return - -end subroutine gtable_missing_inv diff --git a/quantum_espresso/kcp/CPV/hflib.f90 b/quantum_espresso/kcp/CPV/hflib.f90 deleted file mode 100644 index 6c2773c1b..000000000 --- a/quantum_espresso/kcp/CPV/hflib.f90 +++ /dev/null @@ -1,413 +0,0 @@ -! -! Copyright (C) 2007-2008 Quantum ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! Hartree-Fock method -! Implemented by I. Dabo (Universite Paris-Est, Ecole des Ponts, ParisTech) -! Optimized and Parallelized by Andrea Ferretti (MIT) -! -!----------------------------------------------------------------------- - subroutine hf_potential(nbsp1, nx1, c1, f1, ispin1, iupdwn1, nupdwn1, & - nbsp2, nx2, c2, f2, ispin2, iupdwn2, nupdwn2, & - rhor, rhog, vxxpsi, exx ) -!----------------------------------------------------------------------- -! -! Calculate orbital densities and Hartree-Fock potentials -! (the calculation of the exchange potential uses -! periodic-image corrections) -! -! 1 -> inner quantities (those used to build the density matrix) -! 2 -> outer quantities (those referring to the wfcs to which the -! HF potential is applied) -! -! - use kinds, only: dp - use gvecp, only: ngm - use gvecs, only: ngs, nps, nms - use gvecw, only: ngw - use recvecs_indexes, only: np, nm - use grid_dimensions, only: nnrx - use cell_base, only: omega - use smooth_grid_dimensions, only: nnrsx - use electrons_base, only: nspin - use constants, only: pi, fpi - use mp, only: mp_sum - use funct, only: dft_is_gradient - use cp_interfaces, only: fwfft, invfft, fillgrad - use fft_base, only: dffts, dfftp - use hfmod, only: hfscalfact - ! - implicit none - ! - ! I/O vars - ! - integer, intent(in) :: nbsp1, nx1 - complex(dp), intent(in) :: c1(ngw,nx1) - integer, intent(in) :: ispin1(nx1) - integer, intent(in) :: iupdwn1(nspin), nupdwn1(nspin) - real(dp), intent(in) :: f1(nx1) - ! - integer, intent(in) :: nbsp2, nx2 - complex(dp), intent(in) :: c2(ngw,nx2) - integer, intent(in) :: ispin2(nx2) - integer, intent(in) :: iupdwn2(nspin), nupdwn2(nspin) - real(dp), intent(in) :: f2(nx2) - ! - real(dp), intent(in) :: rhor(nnrx,nspin) - complex(dp), intent(in) :: rhog(ngm,nspin) - complex(dp), intent(out) :: vxxpsi(ngw,nx2) - real(dp), intent(out) :: exx(nx2) - ! - ! local vars - ! - real(dp), parameter :: vanishing_f = 1.e-6_dp - ! - integer :: i, ir, ig, j - integer :: istart, iend - real(dp) :: sa1, eaux(2) - real(dp) :: faux_i, faux_j0, faux_jp - complex(dp) :: ci,fp,fm - ! - character(6), external :: int_to_char - complex(dp), allocatable :: psi(:), psis1(:), psis2(:), & - vxxs(:), vxxd(:), & - vxxpsis(:), psis(:) - complex(dp), allocatable :: orbitalrhog(:,:) - real(dp), allocatable :: orbitalrhos(:,:) - real(dp), allocatable :: orbitalrhor(:,:) - real(dp), allocatable :: aux(:,:) - ! - ci=(0.0d0,1.0d0) - - ! - CALL start_clock( 'hf_potential' ) - ! - ! ... local workspace - ! - allocate(psis1(nnrsx)) - allocate(psis2(nnrsx)) - ! - vxxpsi=0.0_dp - exx=0.0_dp - ! - ! main loop over states - ! - outer_loop: & - do i = 1, nbsp2 - ! - ! psi_i on the smooth grid - ! - psis2=0.d0 - do ig=1,ngw - psis2(nms(ig))=conjg(c2(ig,i)) - psis2(nps(ig))=c2(ig,i) - enddo - call invfft('Wave',psis2,dffts) - ! - ! inner loop - ! - if ( nspin == 1 ) then - istart = 1 - iend = nbsp1 - else - istart = iupdwn1( ispin2(i) ) - iend = iupdwn1( ispin2(i) ) + nupdwn1( ispin2(i) ) -1 - endif - ! - inner_loop: & - do j = istart, iend, 2 - ! - ! if( ispin(i) /= ispin(j) ) cycle - ! - ! take into account spin multiplicity - ! - faux_i = f2(i) * dble( nspin ) / 2.0_dp - faux_j0 = f1(j) * dble( nspin ) / 2.0_dp - ! - if ( j+1 <= iend ) then - faux_jp = f1(j+1) * dble( nspin ) / 2.0_dp - else - faux_jp = 0 - endif - ! - !if ( faux_j < 1.0e-6 ) cycle - !if ( faux_i < 1.0e-6 ) cycle - ! - ! allocate mem - ! - allocate(orbitalrhog(ngm,2)) - allocate(orbitalrhos(nnrsx,2)) - allocate(orbitalrhor(nnrx,2)) - ! - orbitalrhog(1:ngw,1) = c1(1:ngw, j) - ! - if ( j+1 <= iend ) then - orbitalrhog(1:ngw,2) = c1(1:ngw, j+1) - else - orbitalrhog(1:ngw,2) = 0.0_dp - endif - - ! - ! psi_j's on the smooth grid - ! - call c2psi( psis1, nnrsx, orbitalrhog(:,1), & - orbitalrhog(:,2), ngw, 2) - ! - call invfft('Wave', psis1, dffts) - ! - ! psi_i * psi_j on the smooth grid - ! psis2 <= psi_i - ! psis1 <= psi_j, psi_j+1 - ! - sa1=1.d0/omega - orbitalrhos=0.d0 - ! - do ir=1,nnrsx - orbitalrhos(ir,1) = sa1*dble(psis2(ir))*dble(psis1(ir)) - orbitalrhos(ir,2) = sa1*dble(psis2(ir))*aimag(psis1(ir)) - enddo - - - ! - ! move to the dense grid - ! - if ( nnrsx == nnrx ) then - ! - orbitalrhor(:,:) = orbitalrhos(:,:) - ! - else - ! - ! transform to reciprocal space - ! - allocate(psis(nnrsx)) - ! - psis=0.0_dp - do ir=1,nnrsx - psis(ir) = cmplx( orbitalrhos(ir,1), & - orbitalrhos(ir,2) ) - enddo - ! - call fwfft('Smooth',psis,dffts) - orbitalrhog=(0.d0,0.d0) - do ig=1,ngs - fp=psis(nps(ig))+psis(nms(ig)) - fm=psis(nps(ig))-psis(nms(ig)) - orbitalrhog(ig,1)=0.5d0*cmplx(dble(fp),aimag(fm)) - orbitalrhog(ig,2)=0.5d0*cmplx(aimag(fp),-dble(fm)) - enddo - ! - ! switch to dense grid in real space - ! - allocate(psi(nnrx)) - ! - psi(:)=(0.d0,0.d0) - do ig=1,ngs - psi(nm(ig)) = conjg(orbitalrhog(ig,1)) & - + ci*conjg(orbitalrhog(ig,2)) - psi(np(ig)) = orbitalrhog(ig,1)& - + ci*orbitalrhog(ig,2) - enddo - ! - call invfft('Dense',psi,dfftp) - do ir=1,nnrx - orbitalrhor(ir,1) = dble(psi(ir)) - orbitalrhor(ir,2) = aimag(psi(ir)) - enddo - ! - deallocate(psi) - deallocate(psis) - ! - endif - ! - deallocate(orbitalrhog) - deallocate(orbitalrhos) - ! - !! - !! The following is left here for DEBUG purposes only, - !! it is definitely too bad for the performance in real calculations - !! - !if(i.eq.j) then - ! call writetofile(orbitalrhor(:,1),nnrx, & - ! 'rhoup'//TRIM(int_to_char(i))//'.dat',dfftp,'az') - ! call writetofile(orbitalrhor(:,2),nnrx, & - ! 'rhodw'//TRIM(int_to_char(i))//'.dat',dfftp,'az') - !end if - - ! - ! calculate exchange contribution - ! - allocate( aux( nnrx,2) ) - ! - call hf_correction( orbitalrhor(:,1), aux(:,1), eaux(1) ) - call hf_correction( orbitalrhor(:,2), aux(:,2), eaux(2) ) - ! - deallocate(orbitalrhor) - allocate(vxxd(nnrx)) - ! - vxxd(1:nnrx) = cmplx( faux_j0 * aux(1:nnrx,1), & - faux_jp * aux(1:nnrx,2) ) - ! - exx(i)=exx(i) - 0.5_dp*faux_i*faux_j0*eaux(1) & - - 0.5_dp*faux_i*faux_jp*eaux(2) - ! - deallocate(aux) - - - ! - ! change grid if the case - ! - allocate(vxxs(nnrsx)) - ! - if ( nnrsx == nnrx ) then - ! - vxxs(1:nnrsx) = vxxd(1:nnrx) - ! - else - ! - call fwfft('Dense',vxxd,dfftp ) - ! - vxxs=0.0_dp - do ig=1,ngs - vxxs(ig) = vxxd(np(ig)) - enddo - ! - call invfft('Smooth',vxxs,dffts) - ! - endif - ! - deallocate(vxxd) - - - allocate(vxxpsis(nnrsx)) - ! - vxxpsis=0.0_dp - do ir=1,nnrsx - vxxpsis(ir)= cmplx( dble(vxxs(ir)) * dble(psis1(ir)), & - aimag(vxxs(ir)) *aimag(psis1(ir)) ) - enddo - call fwfft('Wave',vxxpsis,dffts) - ! - deallocate(vxxs) - ! - do ig=1,ngw - ! - fp = vxxpsis(nps(ig)) +vxxpsis(nms(ig)) - fm = vxxpsis(nps(ig)) -vxxpsis(nms(ig)) - ! - vxxpsi(ig,i) = vxxpsi(ig,i) & - - 0.5_dp * cmplx( dble(fp),aimag(fm) ) & - - 0.5_dp * cmplx( aimag(fp),-dble(fm) ) - enddo - ! - deallocate(vxxpsis) - ! - enddo inner_loop - ! - if ( nspin == 1 ) exx(i) = 2.0_dp * exx(i) - ! - enddo outer_loop - ! - vxxpsi = hfscalfact *vxxpsi - exx = hfscalfact *exx - - deallocate(psis2) - deallocate(psis1) - ! - CALL stop_clock( 'hf_potential' ) - ! - return - ! -!----------------------------------------------------------------------- - end subroutine hf_potential -!----------------------------------------------------------------------- - -!--------------------------------------------------------------- - SUBROUTINE hf_correction(rhoele,vxx,exx) -!--------------------------------------------------------------- - ! - ! ... calculate Hartree-Fock potential from orbital density - ! - use kinds, only : dp - use constants, only : e2, fpi - use cell_base, only : tpiba2,omega - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use eecp_mod, only : do_comp - use cp_interfaces, only : fwfft, invfft - use fft_base, only : dfftp - use mp, only : mp_sum - use mp_global, only : intra_image_comm - ! - implicit none - ! - real(dp), intent(in) :: rhoele(nnrx) - real(dp), intent(out) :: vxx(nnrx) - real(dp), intent(out) :: exx - ! - integer :: ig - real(dp) :: fact - complex(dp),allocatable :: aux(:) - complex(dp),allocatable :: rhotmp(:) - complex(dp),allocatable :: vtemp(:) - complex(dp),allocatable :: vcorrtmp(:) - - - CALL start_clock( 'hf_corr' ) - ! - allocate(rhotmp(ngm)) - allocate(vtemp(ngm)) - allocate(vcorrtmp(ngm)) - allocate(aux(nnrx)) - ! - ! ... compute self-hartree potential - ! - aux(:)=rhoele(:) - call fwfft('Dense',aux,dfftp) - ! - rhotmp=0.0_dp - do ig=1,ngm - rhotmp(ig) = aux(np(ig)) - enddo - ! - if(gstart==2) vtemp(1)=(0.d0,0.d0) - DO ig=gstart,ngm - vtemp(ig)=rhotmp(ig)*fpi/(tpiba2*g(ig)) - END DO - ! - if(do_comp) then - call calc_tcc_potential(vcorrtmp,rhotmp) - vtemp=vtemp+vcorrtmp - endif - ! - aux=0.0_dp - do ig=1,ngm - aux(np(ig))=vtemp(ig) - aux(nm(ig))=conjg(vtemp(ig)) - enddo - call invfft('Dense',aux,dfftp) - ! - vxx=dble(aux) - ! - fact=omega/dble(nr1*nr2*nr3) - exx=sum(vxx(1:nnrx)*rhoele(1:nnrx))*fact - ! - CALL mp_sum(exx,intra_image_comm) - ! - deallocate(rhotmp) - deallocate(vtemp) - deallocate(vcorrtmp) - deallocate(aux) - ! - CALL stop_clock( 'hf_corr' ) - return - ! -!--------------------------------------------------------------- - end subroutine hf_correction -!--------------------------------------------------------------- - - diff --git a/quantum_espresso/kcp/CPV/indices.f90 b/quantum_espresso/kcp/CPV/indices.f90 deleted file mode 100644 index 3965691aa..000000000 --- a/quantum_espresso/kcp/CPV/indices.f90 +++ /dev/null @@ -1,307 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! AB INITIO COSTANT PRESSURE MOLECULAR DYNAMICS -! ---------------------------------------------- -! Car-Parrinello Parallel Program -! Carlo Cavazzoni - Gerardo Ballabio -! SISSA, Trieste, Italy - 1997-99 -! Last modified: Fri Oct 8 15:46:10 MDT; 1999 -! ---------------------------------------------- -! BEGIN manual -! -! SUBROUTINE miller2nxh(i,j,k,n1h,n2h,n3h,nr1,nr2,nr3) -! SUBROUTINE miller2inxh(i,j,k,in1h,in2h,in3h,nr1,nr2,nr3) -! SUBROUTINE miller2indx(i,j,k,ind1,ind2,ind3,nr1,nr2,nr3) -! SUBROUTINE inxh2miller(in1h,in2h,in3h,i,j,k,nr1,nr2,nr3) -! SUBROUTINE inxh2nxh(in1h,in2h,in3h,n1h,n2h,n3h,nr1,nr2,nr3) -! SUBROUTINE inxh2indx(in1h,in2h,in3h,ind1,ind2,ind3,nr1,nr2,nr3) -! ---------------------------------------------- -! these routines perform conversions between Miller indices and matrix -! indices. We use two sets of matrix indices, that we label -! n1h,n2h,n3h and in1h,in2h,in3h respectively. Miller indices are -! labelled i,j,k -! allowed ranges for Miller indices: -nr1=0 n2h = j+1, j>=0 n3h = k+1, k>=0 -! i+1+nr1, i<0 j+1+nr2, j<0 k+1+nr3, k<0 -! n1h,n2h,n3h range from 1 to nr1,nr2,nr3 respectively. Indices derived -! from different Miller indices do not overlap as long as abs(i)=0 in2h = j+1, j>=0 in3h = k+1, k>=0 -! -i+nr1, i<0 -j+nr2, j<0 -k+nr3, k<0 -! in1h,in2h,in3h range from 1 to 2*nr1-1, 2*nr2-1, 2*nr3-1 -! respectively. There is 1-to-1 correspondence with Miller indices -! n1h,n2h,n3h indices are used for Fourier transforms. The mapping from -! Miller indices to n1h,n2h,n3h introduces a factor exp(m*2*pi*i)=1 in -! the Fourier transform -! ---------------------------------------------- -! END manual -! ---------------------------------------------- -! ---------------------------------------------- - SUBROUTINE miller2nxh(i,j,k,n1h,n2h,n3h,nr1,nr2,nr3) - -! convert Miller indices to n1h, n2h, n3h ones -! ---------------------------------------------- - - IMPLICIT NONE - -! declare subroutine arguments - INTEGER, INTENT(IN) :: i,j,k - INTEGER, INTENT(OUT) :: n1h,n2h,n3h - INTEGER, INTENT(IN) :: nr1,nr2,nr3 - -! end of declarations -! ---------------------------------------------- - - IF (i .GE. 0) THEN - n1h = i+1 - ELSE - n1h = i+1+nr1 - END IF - - IF (j .GE. 0) THEN - n2h = j+1 - ELSE - n2h = j+1+nr2 - END IF - - IF (k .GE. 0) THEN - n3h = k+1 - ELSE - n3h = k+1+nr3 - END IF - - RETURN - END SUBROUTINE miller2nxh - -! ---------------------------------------------- -! ---------------------------------------------- - SUBROUTINE miller2inxh(i,j,k,in1h,in2h,in3h,nr1,nr2,nr3) - -! convert Miller indices to in1h, in2h, in3h ones -! ---------------------------------------------- - - IMPLICIT NONE - -! declare subroutine arguments - INTEGER, INTENT(IN) :: i,j,k - INTEGER, INTENT(OUT) :: in1h,in2h,in3h - INTEGER, INTENT(IN) :: nr1,nr2,nr3 - -! end of declarations -! ---------------------------------------------- - - IF (i .GE. 0) THEN - in1h = i+1 - ELSE - in1h = -i+nr1 - END IF - - IF (j .GE. 0) THEN - in2h = j+1 - ELSE - in2h = -j+nr2 - END IF - - IF (k .GE. 0) THEN - in3h = k+1 - ELSE - in3h = -k+nr3 - END IF - - RETURN - END SUBROUTINE miller2inxh - -! ---------------------------------------------- -! ---------------------------------------------- - SUBROUTINE miller2indx(i,j,k,ind1,ind2,ind3,nr1,nr2,nr3) - -! convert Miller indices to n1h, n2h, n3h ones for the opposite G-point -! (by convention we call them ind1, ind2. ind3) -! ---------------------------------------------- - - IMPLICIT NONE - -! declare subroutine arguments - INTEGER, INTENT(IN) :: i,j,k - INTEGER, INTENT(OUT) :: ind1,ind2,ind3 - INTEGER, INTENT(IN) :: nr1,nr2,nr3 - -! end of declarations -! ---------------------------------------------- - - IF (i .LE. 0) THEN - ind1 = -i+1 - ELSE - ind1 = -i+1+nr1 - END IF - - IF (j .LE. 0) THEN - ind2 = -j+1 - ELSE - ind2 = -j+1+nr2 - END IF - - IF (k .LE. 0) THEN - ind3 = -k+1 - ELSE - ind3 = -k+1+nr3 - END IF - - RETURN - END SUBROUTINE miller2indx - -! ---------------------------------------------- -! ---------------------------------------------- - SUBROUTINE inxh2miller(in1h,in2h,in3h,i,j,k,nr1,nr2,nr3) - -! convert in1h, in2h, in3h indices to Miller ones -! ---------------------------------------------- - - IMPLICIT NONE - -! declare subroutine arguments - INTEGER, INTENT(OUT) :: i,j,k - INTEGER, INTENT(IN) :: in1h,in2h,in3h - INTEGER, INTENT(IN) :: nr1,nr2,nr3 - -! end of declarations -! ---------------------------------------------- - - IF (in1h .LE. nr1) THEN - i = in1h-1 - ELSE - i = -in1h+nr1 - END IF - - IF (in2h .LE. nr2) THEN - j = in2h-1 - ELSE - j = -in2h+nr2 - END IF - - IF (in3h .LE. nr3) THEN - k = in3h-1 - ELSE - k = -in3h+nr3 - END IF - - RETURN - END SUBROUTINE inxh2miller - -! ---------------------------------------------- -! ---------------------------------------------- - SUBROUTINE inxh2nxh(in1h,in2h,in3h,n1h,n2h,n3h,nr1,nr2,nr3) - -! convert in1h, in2h, in3h indices to n1h, n2h, n3h ones -! ---------------------------------------------- - - IMPLICIT NONE - -! declare subroutine arguments - INTEGER, INTENT(OUT) :: n1h,n2h,n3h - INTEGER, INTENT(IN) :: in1h,in2h,in3h - INTEGER, INTENT(IN) :: nr1,nr2,nr3 - -! end of declarations -! ---------------------------------------------- - - IF (in1h .LE. nr1) THEN - n1h = in1h - ELSE - n1h = -in1h+1+2*nr1 - END IF - - IF (in2h .LE. nr2) THEN - n2h = in2h - ELSE - n2h = -in2h+1+2*nr2 - END IF - - IF (in3h .LE. nr3) THEN - n3h = in3h - ELSE - n3h = -in3h+1+2*nr3 - END IF - - RETURN - END SUBROUTINE inxh2nxh - -! ---------------------------------------------- -! ---------------------------------------------- - SUBROUTINE inxh2indx(in1h,in2h,in3h,ind1,ind2,ind3,nr1,nr2,nr3) - -! convert in1h, in2h, in3h indices to n1h, n2h, n3h ones for the -! opposite G-point (which we call ind1, ind2. ind3) -! ---------------------------------------------- - - IMPLICIT NONE - -! declare subroutine arguments - INTEGER, INTENT(OUT) :: ind1,ind2,ind3 - INTEGER, INTENT(IN) :: in1h,in2h,in3h - INTEGER, INTENT(IN) :: nr1,nr2,nr3 - -! end of declarations -! ---------------------------------------------- - - IF (in1h .EQ. 1) THEN - ind1 = 1 - ELSE IF (in1h .LE. nr1) THEN - ind1 = 2-in1h+nr1 - ELSE - ind1 = in1h-nr1+1 - END IF - - IF (in2h .EQ. 1) THEN - ind2 = 1 - ELSE IF (in2h .LE. nr2) THEN - ind2 = 2-in2h+nr2 - ELSE - ind2 = in2h-nr2+1 - END IF - - IF (in3h .EQ. 1) THEN - ind3 = 1 - ELSE IF (in3h .LE. nr3) THEN - ind3 = 2-in3h+nr3 - ELSE - ind3 = in3h-nr3+1 - END IF - - RETURN - END SUBROUTINE inxh2indx - -! ---------------------------------------------- -! ---------------------------------------------- - FUNCTION miller2gsq(i,j,k,b1,b2,b3) - -! calculate squared modulus of G -! ---------------------------------------------- - - USE kinds - IMPLICIT NONE - REAL(DP) miller2gsq -! declare subroutine arguments - INTEGER i,j,k - REAL(DP) b1(3), b2(3), b3(3) - -! declare other variables - REAL(DP) gsq - -! end of declarations -! ---------------------------------------------- - - gsq = ( DBLE(i)*b1(1) + DBLE(j)*b2(1) + DBLE(k)*b3(1) ) ** 2 - gsq = gsq + ( DBLE(i)*b1(2) + DBLE(j)*b2(2) + DBLE(k)*b3(2) ) ** 2 - gsq = gsq + ( DBLE(i)*b1(3) + DBLE(j)*b2(3) + DBLE(k)*b3(3) ) ** 2 - - miller2gsq = gsq - - RETURN - END FUNCTION miller2gsq diff --git a/quantum_espresso/kcp/CPV/init.f90 b/quantum_espresso/kcp/CPV/init.f90 deleted file mode 100644 index 7affa8575..000000000 --- a/quantum_espresso/kcp/CPV/init.f90 +++ /dev/null @@ -1,382 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -!=----------------------------------------------------------------------=! -! -! CP90 / FPMD common init subroutine -! -!=----------------------------------------------------------------------=! - - - subroutine init_dimensions( ) - - ! - ! initialize G-vectors and related quantities - ! - - use io_global, only: stdout, ionode - use control_flags, only: program_name, do_wf_cmplx, gamma_only, use_task_groups !added:giovanni do_wf_cmplx - use grid_dimensions, only: nr1, nr2, nr3, nr1x, nr2x, nr3x - use cell_base, only: ainv, a1, a2, a3 - use cell_base, only: omega, alat - use small_box, only: tpibab, small_box_set - use small_box, only: b1b, b2b, b3b - use smallbox_grid_dimensions, only: nr1b, nr2b, nr3b, nr1bx, nr2bx, nr3bx - use smooth_grid_dimensions, only: nr1s, nr2s, nr3s, nr1sx, nr2sx, nr3sx - USE grid_subroutines, ONLY: realspace_grids_init, realspace_grids_para - USE reciprocal_vectors, ONLY: mill_g, g2_g, bi1, bi2, bi3 - USE recvecs_subroutines, ONLY: recvecs_init - use gvecw, only: gkcut, ngw - use gvecp, only: ecut => ecutp, gcut => gcutp, ngm - use gvecs, only: gcuts, ngs - use gvecb, only: gcutb - USE fft_base, ONLY: dfftp, dffts - USE stick_base, ONLY: pstickset - USE control_flags, ONLY: tdipole - USE berry_phase, ONLY: berry_setup - USE electrons_module, ONLY: bmeshset - USE problem_size, ONLY: cpsizes - USE task_groups, ONLY: task_groups_init - USE core, ONLY: nlcc_any - USE uspp, ONLY: okvan - - implicit none -! - integer :: i - real(8) :: rat1, rat2, rat3 - real(8) :: b1(3), b2(3), b3(3) - integer :: ng_ , ngs_ , ngm_ , ngw_ - logical :: lgam !added:giovanni - - lgam = gamma_only.and..not.do_wf_cmplx !added:giovanni - -! IF((do_wf_cmplx).and.(okvan.or.nlcc_any)) THEN -! CALL errore( 'init_dimensions ', 'ultrasoft and non-linear core correction not working with complex wavefunctions', 1 ) !warning:giovanni not yet implemented -! ENDIF - - IF( ionode ) THEN - WRITE( stdout, 100 ) - 100 FORMAT( //, & - 3X,'Simulation dimensions initialization',/, & - 3X,'------------------------------------' ) - END IF - ! - ! ... Initialize bands indexes for parallel linear algebra - ! ... (distribute bands to processors) - ! - CALL bmeshset( ) - - ! - ! ... Initialize (global) real and compute global reciprocal dimensions - ! - - CALL realspace_grids_init( alat, a1, a2, a3, gcut, gcuts, ng_ , ngs_ ) - - ! - ! ... cell dimensions and lattice vectors - ! - - call recips( a1, a2, a3, b1, b2, b3 ) - - ! Store the base vectors used to generate the reciprocal space - - bi1 = b1 - bi2 = b2 - bi3 = b3 - - ! Change units: b1, b2, b3 are the 3 basis vectors generating - ! the reciprocal lattice in 2pi/alat units - ! - ! Normally if a1, a2 and a3 are in cartesian coordinates - ! and in a.u. units the corresponding bs are in cartesian - ! coordinate too and in unit of 2 PI / a.u. - ! now bring b1, b2 and b3 in units of 2 PI / alat - - b1 = b1 * alat - b2 = b2 * alat - b3 = b3 * alat - - IF( ionode ) THEN - - WRITE( stdout,210) -210 format(/,3X,'unit vectors of full simulation cell',& - &/,3X,'in real space:',25x,'in reciprocal space (units 2pi/alat):') - WRITE( stdout,'(3X,I1,1X,3f10.4,10x,3f10.4)') 1,a1,b1 - WRITE( stdout,'(3X,I1,1X,3f10.4,10x,3f10.4)') 2,a2,b2 - WRITE( stdout,'(3X,I1,1X,3f10.4,10x,3f10.4)') 3,a3,b3 - - END IF - - ! - do i=1,3 - ainv(1,i)=b1(i)/alat - ainv(2,i)=b2(i)/alat - ainv(3,i)=b3(i)/alat - end do - - ! - ! ainv is transformation matrix from cartesian to crystal coordinates - ! if r=x1*a1+x2*a2+x3*a3 => x(i)=sum_j ainv(i,j)r(j) - ! Note that ainv is really the inverse of a=(a1,a2,a3) - ! (but only if the axis triplet is right-handed, otherwise - ! for a left-handed triplet, ainv is minus the inverse of a) - ! - - ! ... set the sticks mesh and distribute g vectors among processors - ! - - CALL pstickset( dfftp, dffts, alat, a1, a2, a3, gcut, gkcut, gcuts, & - nr1, nr2, nr3, nr1x, nr2x, nr3x, nr1s, nr2s, nr3s, nr1sx, nr2sx, & - nr3sx, ngw_ , ngm_ , ngs_ ) - ! - ! - ! ... Initialize reciprocal space local and global dimensions - ! NOTE in a parallel run ngm_ , ngw_ , ngs_ here are the - ! local number of reciprocal vectors - ! - ! - ! - ! ... Initialize (local) real space dimensions - ! - CALL realspace_grids_para( dfftp, dffts ) - ! - ! - ! ... generate g-space - ! - call ggencp( b1, b2, b3, nr1, nr2, nr3, nr1s, nr2s, nr3s, gcut, gcuts, gkcut, lgam) !added:giovanni do_wf_cmplx - ! - ngw_=ngw !dirtyfix:giovanni - ngm_=ngm - ngs_=ngs - CALL recvecs_init( ngm_ , ngw_ , ngs_ ) !dirtyfix:giovanni - !write(6,*) "init_recvecs", ngw_ - ! - ! Allocate index required to compute polarizability - ! - IF( tdipole ) THEN - CALL berry_setup( ngw_ , mill_g ) - END IF - - ! - ! global arrays are no more needed - ! - if( allocated( g2_g ) ) deallocate( g2_g ) - !if( allocated( mill_g ) ) deallocate( mill_g )!required for berry's phase e-field now - - ! - ! generation of little box g-vectors - ! - IF ( nr1b > 0 .AND. nr2b > 0 .AND. nr3b > 0 ) THEN - - ! sets the small box parameters - - rat1 = DBLE( nr1b ) / DBLE( nr1 ) - rat2 = DBLE( nr2b ) / DBLE( nr2 ) - rat3 = DBLE( nr3b ) / DBLE( nr3 ) - CALL small_box_set( alat, omega, a1, a2, a3, rat1, rat2, rat3 ) - - ! now set gcutb - - gcutb = ecut / tpibab / tpibab - ! - CALL ggenb ( b1b, b2b, b3b, nr1b, nr2b, nr3b, nr1bx, nr2bx, nr3bx, gcutb ) - - ELSE IF( okvan .OR. nlcc_any ) THEN - - CALL errore( ' init_dimensions ', ' nr1b, nr2b, nr3b must be given for ultrasoft and core corrected pp ', 1 ) - - END IF - - ! ... printout g vector distribution summary - ! - CALL gmeshinfo() - ! - IF( program_name == 'FPMD' ) THEN - ! - CALL cpsizes( ) - ! - END IF - ! - IF( use_task_groups ) THEN - ! - ! Initialize task groups. - ! Note that this call modify dffts adding task group data. - ! - CALL task_groups_init( dffts ) - ! - END IF - ! - ! Flush stdout - ! - CALL flush_unit( stdout ) - ! - return - end subroutine init_dimensions - - - - -!----------------------------------------------------------------------- - subroutine init_geometry ( ) -!----------------------------------------------------------------------- -! - USE kinds, ONLY: DP - use control_flags, only: ndr, nbeg, tbeg - use io_global, only: stdout, ionode - use mp_global, only: nproc_image - USE io_files, ONLY: outdir - use ions_base, only: na, nsp, nat, tau_srt, ind_srt, if_pos, atm, na, pmass - use cell_base, only: a1, a2, a3, r_to_s, cell_init, deth - - use cell_base, only: ibrav, ainv, h, hold, tcell_base_init - USE ions_positions, ONLY: allocate_ions_positions, atoms_init, & - atoms0, atomsm, atomsp - use cp_restart, only: cp_read_cell - USE fft_base, ONLY: dfftb - USE fft_types, ONLY: fft_box_allocate - USE cp_main_variables, ONLY: ht0, htm, taub - USE atoms_type_module, ONLY: atoms_type - - implicit none - ! - ! local - ! - integer :: i, j - real(DP) :: gvel(3,3), ht(3,3) - real(DP) :: xnhh0(3,3), xnhhm(3,3), vnhh(3,3), velh(3,3) - REAL(DP), ALLOCATABLE :: taus_srt( :, : ) - - IF( .NOT. tcell_base_init ) & - CALL errore( ' init_geometry ', ' cell_base_init has not been call yet! ', 1 ) - - IF( ionode ) THEN - WRITE( stdout, 100 ) - 100 FORMAT( //, & - 3X,'System geometry initialization',/, & - 3X,'------------------------------' ) - END IF - - ! Set ht0 and htm, cell at time t and t-dt - ! - CALL cell_init( ht0, a1, a2, a3 ) - CALL cell_init( htm, a1, a2, a3 ) - - CALL allocate_ions_positions( nsp, nat ) - ! - ! Scale positions that have been read from standard input - ! according to the cell given in the standard input too - ! taus_srt = scaled, tau_srt = atomic units - ! - ALLOCATE( taus_srt( 3, nat ) ) - - CALL r_to_s( tau_srt, taus_srt, na, nsp, ainv ) - - CALL atoms_init( atomsm, atoms0, atomsp, taus_srt, ind_srt, if_pos, atm, ht0%hmat, nat, nsp, na, pmass ) - ! - DEALLOCATE( taus_srt ) - ! - ! Allocate box descriptor - ! - ALLOCATE( taub( 3, nat ) ) - ! - CALL fft_box_allocate( dfftb, nproc_image, nat ) - ! - ! if tbeg = .true. the geometry is given in the standard input even if - ! we are restarting a previous run - ! - if( ( nbeg > -1 ) .and. ( .not. tbeg ) ) then - ! - ! read only h and hold from restart file "ndr" - ! - CALL cp_read_cell( ndr, outdir, .TRUE., ht, hold, velh, gvel, xnhh0, xnhhm, vnhh ) - - CALL cell_init( 't', ht0, ht ) - CALL cell_init( 't', htm, hold ) - ht0%hvel = velh ! set cell velocity - ht0%gvel = gvel - - h = TRANSPOSE( ht ) - ht = TRANSPOSE( hold ) - hold = ht - ht = TRANSPOSE( velh ) - velh = ht - - WRITE( stdout,344) ibrav - do i=1,3 - WRITE( stdout,345) (h(i,j),j=1,3) - enddo - WRITE( stdout,*) - - - else - ! - ! geometry is set to the cell parameters read from stdin ( a1, a2, a3 ) - ! - do i = 1, 3 - h(i,1) = a1(i) - h(i,2) = a2(i) - h(i,3) = a3(i) - enddo - - hold = h - - end if - ! - ! generate true g-space - ! - call newinit( ht0%hmat ) - ! - CALL invmat( 3, h, ainv, deth ) - ! - 344 format(3X,'ibrav = ',i4,' cell parameters ',/) - 345 format(3(4x,f10.5)) - return - end subroutine init_geometry - - - -!----------------------------------------------------------------------- - - subroutine newinit( h ) - ! - ! re-initialization of lattice parameters and g-space vectors. - ! Note that direct and reciprocal lattice primitive vectors - ! a1,a2,a3, ainv, and corresponding quantities for small boxes - ! are recalculated according to the value of cell parameter h - ! - USE kinds, ONLY : DP - USE cell_base, ONLY : a1, a2, a3, omega, alat, cell_base_reinit - ! - implicit none - ! - REAL(DP) :: h(3,3) - ! local - ! - REAL(DP) :: gmax, b1(3), b2(3), b3(3) - ! - !WRITE( stdout, 344 ) - !do i=1,3 - ! WRITE( stdout, 345 ) (h(i,j),j=1,3) - !enddo - ! - ! re-initialize the cell base module with the new geometry - ! - CALL cell_base_reinit( TRANSPOSE( h ) ) - ! - call recips( a1, a2, a3, b1, b2, b3 ) - ! - call gcal( alat, b1, b2, b3, gmax ) - ! - ! generation of little box g-vectors - ! - call newgb( a1, a2, a3, omega, alat ) - ! - return - 344 format(4x,'h from newinit') - 345 format(3(4x,f12.7)) - end subroutine newinit diff --git a/quantum_espresso/kcp/CPV/init_run.f90 b/quantum_espresso/kcp/CPV/init_run.f90 deleted file mode 100644 index 5d0c1f923..000000000 --- a/quantum_espresso/kcp/CPV/init_run.f90 +++ /dev/null @@ -1,436 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!---------------------------------------------------------------------------- -SUBROUTINE init_run() - !---------------------------------------------------------------------------- - ! - ! ... this routine initialise the cp code and allocates (calling the - ! ... appropriate routines) the memory - ! - USE kinds, ONLY: DP - USE control_flags, ONLY: nbeg, nomore, lwf, iprsta, iprint, & - tfor, tprnfor, tpre, & - newnfi, tnewnfi, ndw, non_ortho, & - iprint_manifold_overlap - !above, added:giovanni non_ortho, iprint_manifold_overlap - USE cp_electronic_mass, ONLY: emass_cutoff - USE ions_base, ONLY: na, nax, nat, nsp, pmass, cdms - USE ions_positions, ONLY: tau0, taum, taup, taus, tausm, tausp, & - vels, velsm, velsp, fion - USE gvecw, ONLY: ngw, ngwt, ggp - USE gvecb, ONLY: ngb - USE gvecs, ONLY: ngs - USE gvecp, ONLY: ngm - USE reciprocal_vectors, ONLY: gzero - USE grid_dimensions, ONLY: nnrx, nr1, nr2, nr3 - USE fft_base, ONLY: dfftp - USE electrons_base, ONLY: nspin, nbsp, nbspx, nupdwn, f - USE uspp, ONLY: nkb, vkb, deeq, becsum, nkbus - USE smooth_grid_dimensions, ONLY: nnrsx - USE wavefunctions_module, ONLY: c0, cm, cp, cdual, cmdual, cstart - USE cdvan, ONLY: dbec, drhovan - USE ensemble_dft, ONLY: tens, z0t, tsmear - USE cg_module, ONLY: tcg - USE electrons_base, ONLY: nudx - USE efield_module, ONLY: tefield, tefield2 - USE uspp_param, ONLY: nhm - USE ions_nose, ONLY: xnhp0, xnhpm, vnhp, nhpcl, nhpdim - USE cell_base, ONLY: h, hold, hnew, velh, tpiba2, ibrav, & - alat, a1, a2, a3, b1, b2, b3 - USE cp_main_variables, ONLY: lambda, lambdam, ema0bg, & - acc, acc_this_run, wfill, hamilt, & - edft, nfi, ht0, iprint_stdout, & - gamma_only, do_wf_cmplx !added:giovanni gamma_only, do_wf_cmplx - USE cp_main_variables, ONLY: allocate_mainvar, nlax, descla, nrlx, nlam - USE energies, ONLY: ekincm - USE time_step, ONLY: tps - USE electrons_nose, ONLY: xnhe0, xnhem, vnhe - USE cell_nose, ONLY: xnhh0, xnhhm, vnhh - USE funct, ONLY: dft_is_meta - USE metagga, ONLY: crosstaus, dkedtaus, gradwfc - ! - USE efcalc, ONLY: clear_nbeg - USE local_pseudo, ONLY: allocate_local_pseudo - USE cp_electronic_mass, ONLY: emass_precond - USE wannier_subroutines, ONLY: wannier_startup - USE cp_interfaces, ONLY: readfile, symm_wannier - USE ions_base, ONLY: ions_cofmass - USE ensemble_dft, ONLY: id_matrix_init, allocate_ensemble_dft, h_matrix_init - USE efield_module, ONLY: allocate_efield, allocate_efield2 - USE cg_module, ONLY: allocate_cg - USE wannier_module, ONLY: allocate_wannier - USE io_files, ONLY: outdir, prefix - USE io_global, ONLY: stdout - USE printout_base, ONLY: printout_base_init - USE wave_types, ONLY: wave_descriptor_info - USE xml_io_base, ONLY: restart_dir, create_directory - USE orthogonalize_base, ONLY: mesure_diag_perf, mesure_mmul_perf - USE step_constraint, ONLY: step_con - USE ions_base, ONLY: ions_reference_positions - USE ldau - use eecp_mod, ONLY: do_comp, which_compensation, tcc_odd - use efield_mod, ONLY: do_efield - USE nksic, ONLY: do_orbdep - use input_parameters, ONLY: odd_nkscalfact, restart_odd_nkscalfact, restart_mode, & - restart_from_wannier_cp, wannier_empty_only, & - restart_from_wannier_pwscf, impose_bloch_symm - use wavefunctions_module, ONLY: c0_fixed - USE twin_types !added:giovanni - ! - IMPLICIT NONE - ! - INTEGER :: i, iss, ndim - CHARACTER(LEN=256) :: dirname - LOGICAL :: lgam - ! - ! - CALL start_clock('initialize') - ! - lgam = gamma_only .and. .not. do_wf_cmplx - ! - ! ... initialize directories - ! - write (6, *) "nbeg", nbeg - IF (nbeg < 0) THEN - CALL create_directory(outdir) - END IF - ! - CALL printout_base_init(outdir, prefix) - ! - dirname = restart_dir(outdir, ndw) - ! - ! ... Create main restart directory - ! - CALL create_directory(dirname) - ! - ! ... initialize g-vectors, fft grids - ! ... The number of g-vectors are based on the input celldm! - ! - CALL init_dimensions() - ! - ! ... initialize atomic positions and cell - ! - CALL init_geometry() - ! - ! ... mesure performances of parallel routines - ! - CALL mesure_mmul_perf(nudx) - ! - CALL mesure_diag_perf(nudx) - ! - IF (lwf) CALL clear_nbeg(nbeg) - ! - !======================================================================= - ! allocate and initialize nonlocal potentials - !======================================================================= - ! - CALL nlinit() - ! - !======================================================================= - ! allocation of all arrays not already allocated in init and nlinit - !======================================================================= - ! - CALL allocate_mainvar(ngw, ngwt, ngb, ngs, ngm, nr1, nr2, nr3, dfftp%nr1x, & - dfftp%nr2x, dfftp%npl, nnrx, nnrsx, nat, nax, nsp, & - nspin, nbsp, nbspx, nupdwn, nkb, gzero, nudx, & - tpre) - ! - CALL allocate_local_pseudo(ngs, nsp) - ! - ! initialize wave functions descriptors and allocate wf - ! - ALLOCATE (c0(ngw, nbspx)) - !gvn23 ALLOCATE(c0i(ngw, nbspx)) - ALLOCATE (cm(ngw, nbspx)) - !gvn23 ALLOCATE(cmi(ngw, nbspx)) - ALLOCATE (cp(ngw, nbspx)) - !gvn23 ALLOCATE(cpi(ngw, nbspx)) - IF (iprint_manifold_overlap > 0) THEN - ALLOCATE (cstart(ngw, nbspx)) - END IF - ! - IF (odd_nkscalfact) ALLOCATE (c0_fixed(ngw, nbspx)) - ! - IF (non_ortho) THEN - ALLOCATE (cdual(ngw, nbspx)) - ALLOCATE (cmdual(ngw, nbspx)) - END IF - ! - IF (iprsta > 2) THEN - ! - CALL wave_descriptor_info(wfill, 'wfill', stdout) - ! - END IF - ! - ! Depending on the verbosity set the frequency of - ! verbose information to stdout - ! - IF (iprsta < 1) iprint_stdout = 100*iprint - IF (iprsta == 1) iprint_stdout = 10*iprint - IF (iprsta > 1) iprint_stdout = iprint - ! - acc = 0.D0 - acc_this_run = 0.D0 - ! - edft%ent = 0.D0 - edft%esr = 0.D0 - edft%evdw = 0.D0 - edft%ekin = 0.D0 - edft%enl = 0.D0 - edft%etot = 0.D0 - ! - ALLOCATE (becsum(nhm*(nhm + 1)/2, nat, nspin)) - ALLOCATE (deeq(nhm, nhm, nat, nspin)) - IF (tpre) THEN - ALLOCATE (dbec(nkb, 2*nlam, 3, 3)) - ALLOCATE (drhovan(nhm*(nhm + 1)/2, nat, nspin, 3, 3)) - END IF - ! - ALLOCATE (vkb(ngw, nkb)) - ! - IF (dft_is_meta() .AND. tens) & - CALL errore('cprmain ', 'ensemble_dft not implimented for metaGGA', 1) - ! - IF (dft_is_meta() .AND. tpre) THEN - ! - ALLOCATE (crosstaus(nnrsx, 6, nspin)) - ALLOCATE (dkedtaus(nnrsx, 3, 3, nspin)) - ALLOCATE (gradwfc(nnrsx, 3)) - ! - END IF - ! - IF (lwf) CALL allocate_wannier(nbsp, nnrsx, nspin, ngm) - ! - IF (tens .OR. tcg .OR. tsmear) & - CALL allocate_ensemble_dft(nkb, nbsp, ngw, nudx, nspin, nbspx, nnrsx, nat, nlax, nrlx, lgam) - ! - IF (tcg) CALL allocate_cg(ngw, nbspx, nkbus) - ! - IF (tefield) CALL allocate_efield(ngw, ngwt, nbspx, nhm, nax, nsp) - IF (tefield2) CALL allocate_efield2(ngw, nbspx, nhm, nax, nsp) - ! - IF (ALLOCATED(deeq)) deeq(:, :, :, :) = 0.D0 - ! - IF (ALLOCATED(lambda)) THEN - DO iss = 1, size(lambda) - IF (lambda(iss)%isalloc) THEN - IF (.not. lambda(iss)%iscmplx) THEN - lambda(iss)%rvec = 0.D0 - ELSE - lambda(iss)%cvec = CMPLX(0.D0, 0.D0) - END IF - END IF - END DO - END IF - - IF (ALLOCATED(lambdam)) THEN - DO iss = 1, size(lambdam) - IF (lambdam(iss)%isalloc) THEN - IF (.not. lambdam(iss)%iscmplx) THEN - lambdam(iss)%rvec = 0.D0 - ELSE - lambdam(iss)%cvec = CMPLX(0.D0, 0.D0) - END IF - END IF - END DO - END IF - ! - taum = tau0 - taup = 0.D0 - tausm = taus - tausp = 0.D0 - vels = 0.D0 - velsm = 0.D0 - velsp = 0.D0 - ! - hnew = h - ! - cm = (0.D0, 0.D0) - !gvn23 cmi = (0.D0, 0.D0) - c0 = (0.D0, 0.D0) - !gvn23 c0i = (0.D0, 0.D0) - cp = (0.D0, 0.D0) - !gvn23 cpi = (0.D0, 0.D0) - ! - IF (odd_nkscalfact) c0_fixed = (0.D0, 0.D0) - ! - IF (tens .OR. tsmear) then - ! - CALL id_matrix_init(descla, nspin) - CALL h_matrix_init(descla, nspin) - ! - END IF - ! - IF (lwf) CALL wannier_startup(ibrav, alat, a1, a2, a3, b1, b2, b3) - ! - ! ... Calculate: ema0bg = ecutmass / MAX( 1.0d0, (2pi/alat)^2 * |G|^2 ) - ! - CALL emass_precond(ema0bg, ggp, ngw, tpiba2, emass_cutoff) - ! - CALL print_legend() - ! - step_con = .FALSE. - ! - CALL ldau_init() - ! - CALL nksic_init() - ! - CALL hf_init() - ! - CALL ee_init() - ! - CALL efield_init() - ! - IF (do_comp) THEN - ! - write (stdout, *) "USING TCC FOR ODD", tcc_odd - ! - IF (trim(which_compensation) == 'tcc1d') THEN - CALL ee_green_1d_init(ht0) - IF (tcc_odd) THEN - CALL ee_green_0d_init(ht0) - END IF - ELSE IF (trim(which_compensation) == 'tcc2d') THEN - CALL ee_green_2d_init(ht0) - IF (tcc_odd) THEN - CALL ee_green_0d_init(ht0) - END IF - ELSE - CALL ee_green_0d_init(ht0) - END IF - ! - END IF - ! - IF (do_orbdep .AND. iprsta > 1) THEN - ! - ndim = MAXVAL(nupdwn(:)) - - ALLOCATE (hamilt(nspin)) - DO iss = 1, nspin - call init_twin(hamilt(iss), lgam) - call allocate_twin(hamilt(iss), ndim, ndim, lgam) - END DO -! ALLOCATE( hamilt( ndim, ndim, nspin) ) - ! - ELSE - ALLOCATE (hamilt(1)) - call init_twin(hamilt(1), lgam) - call allocate_twin(hamilt(1), 1, 1, lgam) - END IF - ! - DO iss = 1, size(hamilt) - if (.not. hamilt(iss)%iscmplx) then - hamilt(iss)%rvec = 0.0d0 - else - hamilt(iss)%cvec = CMPLX(0.0d0, 0.d0) - end if - END DO - - IF (do_efield) CALL ee_efieldpot_init(ht0) - - IF (nbeg < 0) THEN - ! - !====================================================================== - ! Initialize from scratch nbeg = -1 - !====================================================================== - ! - nfi = 0 - ! - CALL from_scratch() - ! - ELSE - ! - !====================================================================== - ! nbeg = 0, nbeg = 1 - !====================================================================== - ! - i = 1 - !gvn22 !change readfile? - CALL readfile(i, h, hold, nfi, c0, cm, taus, & - tausm, vels, velsm, acc, lambda, lambdam, xnhe0, xnhem, & - vnhe, xnhp0, xnhpm, vnhp, nhpcl, nhpdim, ekincm, xnhh0, xnhhm, & - vnhh, velh, fion, tps, z0t, f) - ! - CALL from_restart() - ! - END IF - ! - !======================================================================= - ! restart with new averages and nfi=0 - !======================================================================= - ! - ! ... reset some variables if nbeg < 0 - ! ... ( new simulation or step counter reset to 0 ) - ! - IF (nbeg <= 0) THEN - ! - acc = 0.D0 - nfi = 0 - ! - END IF - ! - IF (.NOT. tfor .AND. .NOT. tprnfor) fion(:, :) = 0.D0 - ! - IF (tnewnfi) nfi = newnfi - ! - nomore = nomore + nfi - ! - ! Set center of mass for scaled coordinates - ! - CALL ions_cofmass(taus, pmass, na, nsp, cdms) - ! - IF (nbeg <= 0 .OR. lwf) THEN - ! - CALL ions_reference_positions(tau0) - ! - END IF - ! - ! here we provide an option to restart wfc from wannier orbitals - ! for occupied many-folds - ! - IF (restart_from_wannier_cp .or. restart_from_wannier_pwscf .and. .not. wannier_empty_only) THEN - ! - write (stdout, *) "in init_run from wannier start Linh" - ! - IF (TRIM(restart_mode) == "from_scratch") THEN - ! - CALL errore('init_run ', 'A restart from wannier orbitals needs restart_mode = restart', 1) - ! - END IF - ! - IF (restart_from_wannier_cp .and. restart_from_wannier_pwscf) THEN - ! - CALL errore('init_run ', 'choose either restart_from_wannier_pwscf or restart_from_wannier_cp == true', 1) - ! - END IF - ! - IF (restart_from_wannier_pwscf) CALL wave_init_wannier_pwscf(c0, nbspx) - ! - IF (restart_from_wannier_cp) CALL wave_init_wannier_cp(c0, ngw, nbspx, .True.) - ! - write (stdout, *) "in init_run from wannier end Linh" - ! - END IF - ! - IF (odd_nkscalfact) THEN - ! - IF (.not. restart_odd_nkscalfact) then - c0_fixed(:, :) = c0(:, :) - END IF - ! - END IF - ! - CALL stop_clock('initialize') - ! - IF (impose_bloch_symm) CALL symm_wannier(c0, nbspx, .false.) - ! - RETURN - ! -END SUBROUTINE init_run diff --git a/quantum_espresso/kcp/CPV/inner_loop.f90 b/quantum_espresso/kcp/CPV/inner_loop.f90 deleted file mode 100644 index 883dbf0ec..000000000 --- a/quantum_espresso/kcp/CPV/inner_loop.f90 +++ /dev/null @@ -1,642 +0,0 @@ -! -! Copyright (C) 2002-2007 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!==================================================================== - SUBROUTINE inner_loop( nfi, tfirst, tlast, eigr, irb, eigrb, & - rhor, rhog, rhos, rhoc, ei1, ei2, ei3, & - sfac, c0, bec, firstiter, vpot, lgam ) -!==================================================================== - ! - ! minimizes the total free energy with respect to the - ! occupation matrix f_ij at fixed Kohn-Sham orbitals - ! Cf. Marzari, Vanderbilt, Payne PRL 79, 1337 (1997) - ! - - ! declares modules - USE kinds, ONLY: dp - USE core, ONLY: nlcc_any - USE energies, ONLY: etot, enl, & - ekin, atot, entropy - USE electrons_base, ONLY: f, nspin, iupdwn, nupdwn, nudx, & - nelt, nx => nbspx, n => nbsp, ispin - - USE ensemble_dft, ONLY: ninner, ismear, etemp, & - z0t, c0diag, becdiag, & - fmat0, & - e0, & - compute_entropy2, & - compute_entropy_der, compute_entropy - USE gvecp, ONLY: ngm - USE gvecs, ONLY: ngs - USE gvecb, ONLY: ngb - USE gvecw, ONLY: ngw - USE reciprocal_vectors, & - ONLY: ng0 => gstart - USE ions_base, ONLY: nat, nsp - USE grid_dimensions, & - ONLY: nnr => nnrx, nr1, nr2, nr3 - USE smooth_grid_dimensions, & - ONLY: nnrsx - USE io_global, ONLY: io_global_start, ionode, & - ionode_id - USE mp_global, ONLY: intra_image_comm - USE dener - ! USE derho - USE cdvan - USE uspp, ONLY: nhsa=> nkb, betae => vkb, & - rhovan => becsum - USE cg_module, ONLY: ene_ok, & - enever - USE ions_positions, ONLY: tau0 - USE mp, ONLY: mp_sum,mp_bcast - use cp_interfaces, only: rhoofr, dforce - USE twin_types !added:giovanni - - ! - IMPLICIT NONE - - ! declares local variables and counters - INTEGER :: nfi - LOGICAL :: tfirst - LOGICAL :: tlast - COMPLEX(DP) :: eigr( ngw, nat ) - COMPLEX(DP) :: c0( ngw, n ) - REAL(DP) :: bec( nhsa, n ) - LOGICAL :: firstiter - - - INTEGER :: irb( 3, nat ) - COMPLEX (DP) :: eigrb( ngb, nat ) - REAL(DP) :: rhor( nnr, nspin ) - REAL(DP) :: vpot( nnr, nspin ) - COMPLEX(DP) :: rhog( ngm, nspin ) - REAL(DP) :: rhos( nnrsx, nspin ) - REAL(DP) :: rhoc( nnr ) - COMPLEX(DP) :: ei1( nr1:nr1, nat ) - COMPLEX(DP) :: ei2( nr2:nr2, nat ) - COMPLEX(DP) :: ei3( nr3:nr3, nat ) - COMPLEX(DP) :: sfac( ngs, nsp ) - LOGICAL :: lgam - - INTEGER :: i - INTEGER :: j - INTEGER :: ig - INTEGER :: k - INTEGER :: is - REAL(DP) :: entmp - INTEGER :: npt - REAL(DP) :: deltax - REAL(DP) :: deltaxmin - REAL(DP) :: xinit - REAL(kind=DP), ALLOCATABLE :: dval(:), ex(:)!, ztmp(:,:) - COMPLEX(DP), ALLOCATABLE :: dx_c(:) - REAL(kind=DP), ALLOCATABLE :: fion2(:,:) - type(twin_matrix), dimension(:), allocatable :: c0hc0, z1, zx, zxt, zaux - COMPLEX(kind=DP), ALLOCATABLE :: h0c0(:,:) - REAL(kind=DP), ALLOCATABLE :: f0(:),f1(:),fx(:), faux(:) - type(twin_matrix), dimension(:), allocatable :: fmat1, fmatx, dfmat -! REAL(kind=DP), ALLOCATABLE :: epsi0(:,:,:) - type(twin_matrix), dimension(:), allocatable :: epsi0 - REAL(kind=DP) :: atot0,atot1,atotmin,etot0,etot1, ef1, enocc - REAL(kind=DP) :: eqa,eqb,eqc, etot2, entropy2 - COMPLEX(DP) :: dentdx1_c, dedx1_c, dadx1_c - REAL(kind=DP) :: f2,x,xmin - INTEGER :: niter,nss,istart,il - - CALL errore( " inner_loop ", " sub. not updated ", 1 ) - - CALL start_clock( 'inner_loop' ) - ! initializes variables - allocate(fion2(3,nat)) - allocate(h0c0(ngw,nx)) - allocate(dval(nx),ex(nx),dx_c(nx),f0(nx),f1(nx),fx(nx),faux(nx)) - allocate(z1(nspin),zx(nspin),zxt(nspin),zaux(nspin)) - allocate(fmat1(nspin),fmatx(nspin),dfmat(nspin)) - allocate(c0hc0(nspin), epsi0(nspin)) -! allocate(epsi0(nudx,nudx,nspin)) -! - do is=1,nspin - call init_twin(z1(is),lgam) - call allocate_twin(z1(is),nudx,nudx,lgam) - call init_twin(zx(is),lgam) - call allocate_twin(zx(is),nudx,nudx,lgam) - call init_twin(zxt(is),lgam) - call allocate_twin(zxt(is),nudx,nudx,lgam) - call init_twin(zaux(is),lgam) - call allocate_twin(zaux(is),nudx,nudx,lgam) - call init_twin(c0hc0(is),lgam) - call allocate_twin(c0hc0(is),nudx,nudx,lgam) - call init_twin(epsi0(is),lgam) - call allocate_twin(epsi0(is),nudx,nudx,lgam) - call init_twin(fmat1(is),lgam) - call allocate_twin(fmat1(is),nudx,nudx,lgam) - call init_twin(fmatx(is),lgam) - call allocate_twin(fmatx(is),nudx,nudx,lgam) - call init_twin(dfmat(is),lgam) - call allocate_twin(dfmat(is),nudx,nudx,lgam) - enddo -! - fion2( :, : )= 0.D0 - npt=10 - deltaxmin=1.D-8 - ! calculates the initial free energy if necessary - IF( .not. ene_ok ) THEN - ! calculates the overlaps bec between the wavefunctions c0 - ! and the beta functions - CALL calbec( 1, nsp, eigr, c0, bec ) - - ! rotates the wavefunctions c0 and the overlaps bec - ! (the occupation matrix f_ij becomes diagonal f_i) - CALL rotate_twin( z0t, c0(:,:), bec, c0diag, becdiag, firstiter) - - ! calculates the electronic charge density - CALL rhoofr( nfi, c0diag, irb, eigrb, becdiag, rhovan, & - rhor, rhog, rhos, enl, denl, ekin, dekin6 ) - IF(nlcc_any) CALL set_cc( irb, eigrb, rhoc ) - - vpot = rhor - - ! calculates the SCF potential, the total energy - ! and the ionic forces - CALL vofrho( nfi, vpot, rhog, rhos, rhoc, tfirst, & - tlast, ei1, ei2, ei3, irb, eigrb, sfac, & - tau0, fion2 ) - - ! calculates the entropy - CALL compute_entropy2( entropy, f, n, nspin ) - - END IF - ene_ok=.FALSE. - atot0=etot+entropy - etot0=etot - - ! calculates the occupation matrix - ! fmat_ij = \sum_k z_ki * f_k * z_kj - CALL calcmt_twin( f, z0t, fmat0,firstiter ) - - ! calculateas the energy contribution associated with - ! the augmentation charges and the - ! corresponding contribution to the ionic force - CALL newd( vpot, irb, eigrb, rhovan, fion2 ) - CALL prefor( eigr, betae ) ! ATTENZIONE - - ! iterates on niter - INNERLOOP : DO niter= 1, ninner - - ! operates the Hamiltonian on the wavefunction c0 - h0c0( :, : )= 0.D0 - DO i= 1, n, 2 - CALL dforce( i, bec, betae, c0, h0c0(:,i), h0c0(:,i+1), rhos, nnrsx, ispin, f, n, nspin ) - END DO - - ! calculates the Hamiltonian matrix in the basis {c0} - DO is=1,nspin - call set_twin(c0hc0(is), CMPLX(0.d0,0.d0)) - ENDDO - - DO is= 1, nspin - nss= nupdwn( is ) - istart= iupdwn( is ) - DO i= 1, nss - DO k= 1, nss - IF(.not.c0hc0(is)%iscmplx) THEN - DO ig= 1, ngw - c0hc0(is)%rvec(k,i)= c0hc0(is)%rvec(k,i) & - - 2.0d0*DBLE( CONJG( c0( ig,k+istart-1 ) ) & - * h0c0( ig, i+istart-1 ) ) - END DO - IF( ng0 .eq. 2 ) THEN - c0hc0(is)%rvec(k,i)= c0hc0(is)%rvec(k,i) & - + DBLE( CONJG( c0( 1, k+istart-1 ) ) & - * h0c0( 1, i+istart-1 ) ) - END IF - ELSE - DO ig= 1, ngw - c0hc0(is)%cvec(k,i)= c0hc0(is)%cvec(k,i) & - - ( CONJG( c0( ig,k+istart-1 ) ) & - * h0c0( ig, i+istart-1 ) ) - END DO - ENDIF - END DO - END DO - IF(.not.c0hc0(is)%iscmplx) THEN - CALL mp_sum( c0hc0(is)%rvec( 1:nss, 1:nss), intra_image_comm ) - ELSE - CALL mp_sum( c0hc0(is)%cvec( 1:nss, 1:nss), intra_image_comm ) - ENDIF - END DO - - DO is= 1, nspin - nss= nupdwn( is ) - call copy_twin(epsi0(is), c0hc0(is)) -! epsi0( 1:nss, 1:nss, is )= c0hc0( 1:nss, 1:nss, is ) ! ATTENZIONE - END DO - - ! diagonalizes the Hamiltonian matrix - !e0( : )= 0.D0 This is not set to 0 anymore ecause of blockocc - DO is= 1, nspin - istart= iupdwn( is ) - nss= nupdwn( is ) - IF( ionode ) THEN - if(epsi0(is)%iscmplx) then - CALL ddiag( nss, nss, epsi0(is)%rvec(1,1), dval(1), & - z1(is)%rvec(1,1), 1 ) - else - CALL ddiag( nss, nss, epsi0(is)%cvec(1,1), dval(1), & - z1(is)%cvec(1,1), 1 ) - endif - END IF - CALL mp_bcast( dval, ionode_id, intra_image_comm ) - CALL twin_mp_bcast( z1(is), ionode_id) - DO i= 1, nss - e0( i+istart-1 )= dval( i ) - END DO - END DO - - - ! calculates the occupations and the fermi energy at the - ! end of the search direction - CALL efermi( nelt, n, etemp, 1, f1, ef1, e0, enocc, ismear, & - nspin ) - - ! fmat1_ij = \sum_k z_ik * f_k * z_jk - CALL calcm( f1, z1, fmat1, firstiter) - - ! calculates of dfmat_ij - ! ( dfmat defines the search direction in occupation space) - DO is= 1, nspin - nss= nupdwn( is ) - if(.not.dfmat(is)%iscmplx) then - dfmat(is)%rvec(1:nss,1:nss) = - fmat0(is)%rvec(1:nss,1:nss) & - + fmat1(is)%rvec(1:nss,1:nss) - else - dfmat(is)%cvec(1:nss,1:nss) = - fmat0(is)%cvec(1:nss,1:nss) & - + fmat1(is)%cvec(1:nss,1:nss) - endif - END DO - - ! - f0( 1:n )= f( 1:n ) - - ! calculates fmatx= fmat0 + x* dfmat - ! (here x=1) - x=1.D0 - DO is= 1, nspin - nss= nupdwn( is ) - IF(.not.fmatx(is)%iscmplx) THEN - fmatx(is)%rvec(1:nss,1:nss) = fmat0(is)%rvec(1:nss,1:nss) & - + x * dfmat(is)%rvec( 1:nss, 1:nss) - ELSE - fmatx(is)%cvec(1:nss,1:nss) = fmat0(is)%cvec(1:nss,1:nss) & - + x * dfmat(is)%cvec(1:nss,1:nss) - ENDIF - END DO - - ! diagonalizes fmatx - fx( : ) = 0.0d0 - DO is=1, nspin - nss= nupdwn( is ) - istart= iupdwn( is ) - IF( ionode ) THEN - if(lgam) then - CALL ddiag( nss, nss, fmatx(is)%rvec(1,1), dval(1), & - zaux(is)%rvec(1,1), 1 ) - else - CALL zdiag( nss, nss, fmatx(is)%cvec(1,1), dval(1), & - zaux(is)%cvec(1,1), 1 ) - endif - END IF - CALL mp_bcast( dval, ionode_id, intra_image_comm ) - CALL twin_mp_bcast( zaux(is), ionode_id) - DO i= 1, nss - faux( i+istart-1 )= dval( i ) - END DO - DO i= 1, nss - fx( i+istart-1 )= faux( nss-i+istart ) - IF(.not.zx(is)%iscmplx) then - DO j=1, nss - zx(is)%rvec( i, j)= zaux(is)%rvec( i, nss-j+1 ) - END DO - ELSE - DO j=1, nss - zx(is)%cvec( i, j )= zaux(is)%cvec( i, nss-j+1) - END DO - ENDIF - END DO - IF(.not.zxt(is)%iscmplx) then - DO i= 1, nss - DO k= 1, nss - zxt(is)%rvec( k, i)= zx(is)%rvec( i, k ) - END DO - END DO - ELSE - DO i= 1, nss - DO k= 1, nss - zxt(is)%cvec(k, i)= zx(is)%cvec(i, k) - END DO - END DO - ENDIF - END DO - - ! updates f - f( 1:n )= fx( 1:n ) - - ! re-calculates fmatx - CALL calcmt_twin( f, zxt, fmatx, firstiter) - - ! calculates the entropy and its derivatives with respect - ! to each occupation at x - CALL compute_entropy2( entropy, fx, n, nspin ) - CALL compute_entropy_der( ex, fx, n, nspin ) - - ! calculates the free energy at x - CALL rotate( zxt, c0(:,:), bec, c0diag, becdiag, firstiter) - CALL rhoofr( nfi, c0diag, irb, eigrb, becdiag, rhovan, & - rhor, rhog, rhos, enl, denl, ekin, dekin6 ) - IF(nlcc_any) CALL set_cc( irb, eigrb, rhoc ) - vpot = rhor - CALL vofrho( nfi, vpot, rhog, rhos, rhoc, tfirst, tlast, & - ei1, ei2, ei3, irb, eigrb, sfac, tau0, fion2 ) - CALL newd( vpot, irb, eigrb, rhovan, fion2 ) - CALL prefor( eigr, betae ) - atot1=etot+entropy - etot1=etot - - ! calculates the Hamiltonian matrix - h0c0( :, : )= 0.D0 - DO i= 1, n, 2 - CALL dforce( i, bec, betae, c0, h0c0(:,i), h0c0(:,i+1), rhos, nnrsx, ispin, f, n, nspin ) - END DO - - do is=1,nspin - call set_twin(c0hc0(is), CMPLX(0.d0,0.d0)) - enddo -! c0hc0(:,:,:)=0.d0 - - DO is= 1, nspin - nss= nupdwn( is ) - istart= iupdwn( is ) - DO i= 1, nss - DO k= 1, nss - IF(lgam) THEN - DO ig= 1, ngw - c0hc0(is)%rvec( k, i)= c0hc0(is)%rvec(k, i) & - - 2.0d0*DBLE( CONJG( c0( ig,k+istart-1 ) ) & - * h0c0( ig, i+istart-1 ) ) - END DO - IF( ng0 .eq. 2 ) THEN - c0hc0(is)%rvec( k, i ) = c0hc0(is)%rvec(k, i) & - + DBLE(CONJG(c0( 1, k+istart-1)) & - * h0c0(1, i+istart-1)) - END IF - ELSE - DO ig= 1, ngw - c0hc0(is)%cvec( k, i)= c0hc0(is)%cvec(k, i) & - - ( CONJG( c0( ig,k+istart-1 ) ) & - * h0c0( ig, i+istart-1 ) ) - END DO - ENDIF - END DO - END DO - CALL twin_mp_sum( c0hc0(is)) - ENDDO - - - DO is= 1, nspin - nss= nupdwn( is ) - call copy_twin(epsi0(is), c0hc0(is)) - END DO - - ! calculates - ! (1) the energy derivative - ! dE / dx (1) = dE / df_ji * (f1_ji - f0_ji) - ! (2) the entropy derivative - ! d Tr S(f) / df_ij = S'(f)_ji - ! ( d( -T S )/dx is calculated as - ! (ex)_j [(zt)_ji (dfmat)_ik (zt)_jk] - ! instead of as - ! [(zt)_jk (ex)_j (zt)_ji] (dfmat)_ik ) - ! (3) the free energy derivative - dedx1_c= CMPLX(0.D0,0.d0) - dentdx1_c= CMPLX(0.D0, 0.d0) - DO is= 1,nspin - nss= nupdwn( is ) - istart= iupdwn( is ) - DO i= 1, nss - dx_c( i+istart-1 )= CMPLX(0.D0,0.D0) - IF(zxt(is)%iscmplx) THEN - DO k= 1, nss - DO j= 1, nss - dx_c( i+istart-1 )= dx_c( i+istart-1 ) & - - zxt(is)%rvec(i,k) * fmat0(is)%rvec(k,j) & - * zxt(is)%rvec(i,j) - END DO - END DO - ELSE - DO k= 1, nss - DO j= 1, nss - dx_c( i+istart-1 )= dx_c( i+istart-1 ) & - - zxt(is)%cvec(i,k) * fmat0(is)%cvec(k,j) & - * CONJG(zxt(is)%cvec(i,j)) - END DO - END DO - ENDIF - dx_c( i+istart-1 )= dx_c( i+istart-1 ) + fx( i+istart-1 ) - END DO - END DO - DO is= 1, nspin - nss= nupdwn( is ) - istart= iupdwn( is ) - DO i= 1, nss - dentdx1_c= dentdx1_c - etemp * dx_c( i+istart-1 ) & - * ex(i+istart-1) - IF(.not.dfmat(is)%iscmplx) THEN - DO k= 1, nss - dedx1_c= dedx1_c + dfmat(is)%rvec(i, k) * epsi0(is)%rvec(k, i) - END DO - ELSE - DO k= 1, nss - dedx1_c= dedx1_c + dfmat(is)%cvec(i, k) * epsi0(is)%cvec(k, i) - END DO - ENDIF - END DO - END DO - dadx1_c = dedx1_c + dentdx1_c - - ! performs the line minimization - ! (a) the energy contribution is approximated - ! by a second order polynomial - ! (b) the entropic term is approximated by a function - ! of the form \sum_i s(a_i*x**2+b_i*x+c_i) - ! (where s(f)=-f*ln(f)-(1-f)*ln(1-f) ). - ! The coefficients a_i, b_i and c_i are calculated - ! by first-order perturbation - eqc= etot0 - eqa= dedx1_c - etot1 + etot0 !note that we expect dedx1_c to be real - eqb= etot1 - etot0 - eqa - atotmin= atot0 - xmin= 0.D0 - xinit=0.D0 - deltax= 1.D0 / DBLE( npt ) - DO WHILE ( deltax .gt. deltaxmin ) - SAMPLING : DO il= 0, npt - x= xinit + deltax * DBLE( il ) - IF( x .gt. 1.D0 ) EXIT SAMPLING - entropy2= 0.D0 - DO is=1,nspin - nss= nupdwn( is ) - istart= iupdwn( is ) - DO i= 1, nss - f2= fx( i+istart-1 ) + ( x-1 ) * dx_c( i+istart-1 ) & - + ( - fx( i+istart-1 ) + dx_c( i+istart-1 ) + & - f0( i+istart-1 ) ) * ( x-1 )**2 - CALL compute_entropy( entmp, f2, nspin ) - entropy2 = entropy2 + entmp - END DO - END DO - etot2= eqa * x ** 2 + eqb * x + eqc - IF ( ( etot2 + entropy2 ) .lt. atotmin ) THEN - xmin= x - atotmin= etot2+ entropy2 - END IF - END DO SAMPLING - xinit= MAX( 0.D0, xmin - deltax ) - deltax= 2.D0 * deltax / DBLE( npt ) - END DO - - IF( ionode ) THEN - WRITE(37,'(a5,3f15.10)') & - 'XMIN', xmin, atotmin, atotmin-atot0 - IF ( atotmin-atot0 .gt. 0.D0 ) & - WRITE(37,*) "INNER LOOP, WARNING : increasing free energy" - END IF - - ! - IF ( xmin .eq. 1.0D0 ) GOTO 300 - - ! calculates the occupation matrix at xmin - DO is= 1, nspin - nss= nupdwn( is ) - IF(.not.fmat0(is)%iscmplx) THEN - DO i= 1, nss - DO j= 1, nss - fmatx(is)%rvec( i, j )= fmat0(is)%rvec( i, j) & - + xmin * dfmat(is)%rvec( i, j) - END DO - END DO - ELSE - DO i= 1, nss - DO j= 1, nss - fmatx(is)%cvec( i, j )= fmat0(is)%cvec( i, j) & - + xmin * dfmat(is)%cvec( i, j ) - END DO - END DO - ENDIF - END DO - - ! diagonalizes the occupation matrix at xmin - fx( : )= 0.D0 - DO is= 1, nspin - nss= nupdwn( is ) - istart= iupdwn( is ) -! - IF(lgam) THEN - IF(ionode) CALL ddiag( nss, nss, fmatx(is)%rvec(1,1), & - dval(1), zaux(is)%rvec(1,1), 1 ) - ELSE - IF(ionode) CALL ddiag( nss, nss, fmatx(is)%cvec(1,1), & - dval(1), zaux(is)%cvec(1,1), 1 ) - ENDIF -! - CALL mp_bcast( dval, ionode_id, intra_image_comm ) - CALL twin_mp_bcast( zaux(is), ionode_id) - DO i= 1, n - faux( i+istart-1 )= dval( i ) - END DO - DO i= 1, nss - fx( i+istart-1 )= faux( nss-i+istart ) - IF(.not.zx(is)%iscmplx) THEN - DO j= 1, nss - zx(is)%rvec( i, j ) = zaux(is)%rvec( i, nss-j+1 ) - END DO - ELSE - DO j= 1, nss - zx(is)%cvec( i, j) = zaux(is)%cvec( i, nss-j+1 ) - END DO - ENDIF - END DO - END DO - - ! updates f - f( 1:n )= fx( 1:n ) - - 300 CONTINUE - - ! updates z0t - DO is= 1, nspin - nss= nupdwn( is ) - if(.not.z0t(is)%iscmplx) THEN - DO i= 1, nss - DO k= 1, nss - z0t(is)%rvec(k, i)= zx(is)%rvec(k, i) - END DO - END DO - ELSE - DO i= 1, nss - DO k= 1, nss - z0t(is)%cvec(k, i)= zx(is)%cvec(k, i) - END DO - END DO - ENDIF - END DO - - ! calculates the total free energy - CALL calcmt_twin( f, z0t, fmat0, firstiter) - CALL rotate( z0t, c0(:,:), bec, c0diag, becdiag, firstiter ) - CALL rhoofr( nfi, c0diag, irb, eigrb, becdiag, & - rhovan, rhor, rhog, rhos, enl, denl, ekin, dekin6 ) - IF(nlcc_any) CALL set_cc(irb,eigrb,rhoc) - vpot = rhor - CALL vofrho( nfi, vpot, rhog, rhos, rhoc, tfirst, tlast, & - ei1, ei2, ei3, irb, eigrb, sfac, tau0, fion2 ) - CALL newd( vpot, irb, eigrb, rhovan, fion2 ) - CALL compute_entropy2( entropy, f, n, nspin ) - CALL prefor( eigr, betae ) - ene_ok= .TRUE. - atotmin = etot + entropy - IF (ionode) write(37,'(a3,i2,2f15.10)') 'CI',niter,atot0,atotmin - atot0=atotmin - atot=atotmin - etot0=etot - enever=etot - if(xmin==0.d0) exit - END DO INNERLOOP -! - do is=1,nspin - call deallocate_twin(z1(is)) - call deallocate_twin(zx(is)) - call deallocate_twin(zxt(is)) - call deallocate_twin(zaux(is)) - call deallocate_twin(c0hc0(is)) - call deallocate_twin(epsi0(is)) - call deallocate_twin(fmat1(is)) - call deallocate_twin(fmatx(is)) - call deallocate_twin(dfmat(is)) - enddo - - deallocate(fion2,c0hc0,h0c0,z1) - deallocate(zx,zxt,zaux,dval,ex,dx_c) - deallocate(f0,f1,fx,faux) - deallocate(dfmat,epsi0) -! - CALL stop_clock( 'inner_loop' ) - return -!==================================================================== - END SUBROUTINE inner_loop -!==================================================================== diff --git a/quantum_espresso/kcp/CPV/inner_loop_cold.f90 b/quantum_espresso/kcp/CPV/inner_loop_cold.f90 deleted file mode 100644 index 96edd822c..000000000 --- a/quantum_espresso/kcp/CPV/inner_loop_cold.f90 +++ /dev/null @@ -1,695 +0,0 @@ -! -! Copyright (C) 2002 CP90 group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!==================================================================== - SUBROUTINE inner_loop_cold( nfi, tfirst, tlast, eigr, irb, eigrb, & - rhor, rhog, rhos, rhoc, ei1, ei2, ei3, & - sfac, c0, bec, firstiter, vpot ) -!==================================================================== - ! - ! minimizes the total free energy - ! using cold smearing, - ! - ! - - ! declares modules - USE kinds, ONLY: dp - USE control_flags, ONLY: iprint, thdyn, tpre, iprsta, & - tfor, taurdr, & - tprnfor, ndr, ndw, nbeg, nomore, & - tsde, tortho, tnosee, tnosep, trane, & - tranp, tsdp, tcp, tcap, ampre, & - amprp, tnoseh, gamma_only, do_wf_cmplx !added:giovanni gamma_only do_wf_cmplx - USE core, ONLY: nlcc_any - USE energies, ONLY: eht, epseu, exc, etot, eself, enl, & - ekin, atot, entropy, egrand - USE electrons_base, ONLY: f, nspin, nel, iupdwn, nupdwn, nudx, & - nelt, nx => nbspx, n => nbsp, ispin - - USE ensemble_dft, ONLY: tens, ninner, ismear, etemp, & - ef, z0t, c0diag, becdiag, & - e0, psihpsi, compute_entropy2, & - compute_entropy_der, compute_entropy, & - niter_cold_restart, lambda_cold - USE gvecp, ONLY: ngm - USE gvecs, ONLY: ngs - USE gvecb, ONLY: ngb - USE gvecw, ONLY: ngw - USE reciprocal_vectors, & - ONLY: gstart - USE cvan, ONLY: nvb, ish - USE ions_base, ONLY: na, nat, pmass, nax, nsp, rcmax - USE grid_dimensions, & - ONLY: nnr => nnrx, nr1, nr2, nr3 - USE cell_base, ONLY: ainv, a1, a2, a3 - USE cell_base, ONLY: omega, alat - USE cell_base, ONLY: h, hold, deth, wmass, tpiba2 - USE smooth_grid_dimensions, & - ONLY: nnrsx, nr1s, nr2s, nr3s - USE smallbox_grid_dimensions, & - ONLY: nnrb => nnrbx, nr1b, nr2b, nr3b - USE local_pseudo, ONLY: vps, rhops - USE io_global, ONLY: io_global_start, stdout, ionode, & - ionode_id - USE mp_global, ONLY: intra_image_comm, leg_ortho - USE dener - !USE derho - USE cdvan - USE io_files, ONLY: psfile, pseudo_dir, outdir - USE uspp, ONLY: nhsa=> nkb, betae => vkb, & - rhovan => becsum, deeq - USE uspp_param, ONLY: nh - USE cg_module, ONLY: ene_ok - USE ions_positions, ONLY: tau0 - USE mp, ONLY: mp_sum,mp_bcast, mp_root_sum - - USE cp_interfaces, ONLY: rhoofr, dforce - USE cg_module, ONLY: itercg - USE cp_main_variables, ONLY: distribute_lambda, descla, nlax, collect_lambda - USE descriptors, ONLY: lambda_node_ , la_npc_ , la_npr_ , descla_siz_ , & - descla_init , la_comm_ , ilar_ , ilac_ , nlar_ , & - nlac_ , la_myr_ , la_myc_ , la_nx_ , la_n_ , la_me_ , la_nrl_ - USE dspev_module, ONLY: pdspev_drv, dspev_drv - USE twin_types !added:giovanni - - - ! - IMPLICIT NONE - -!input variables - INTEGER :: nfi - LOGICAL :: tfirst - LOGICAL :: tlast - COMPLEX(kind=DP) :: eigr( ngw, nat ) - COMPLEX(kind=DP) :: c0( ngw, n ) - TYPE(twin_matrix) :: bec!( nhsa, n ) - LOGICAL :: firstiter - - - INTEGER :: irb( 3, nat ) - COMPLEX (kind=DP) :: eigrb( ngb, nat ) - REAL(kind=DP) :: rhor( nnr, nspin ) - REAL(kind=DP) :: vpot( nnr, nspin ) - COMPLEX(kind=DP) :: rhog( ngm, nspin ) - REAL(kind=DP) :: rhos( nnrsx, nspin ) - REAL(kind=DP) :: rhoc( nnr ) - COMPLEX(kind=DP) :: ei1( nr1:nr1, nat ) - COMPLEX(kind=DP) :: ei2( nr2:nr2, nat ) - COMPLEX(kind=DP) :: ei3( nr3:nr3, nat ) - COMPLEX(kind=DP) :: sfac( ngs, nsp ) - -!local variables - REAL(kind=DP) :: atot0, atot1, atotl, atotmin - REAL(kind=DP), ALLOCATABLE :: fion2(:,:) - type(twin_matrix), dimension(:), allocatable :: c0hc0(:)!modified:giovanni - REAL(kind=DP), ALLOCATABLE :: mtmp(:,:) - COMPLEX(kind=DP), ALLOCATABLE :: mtmp_c(:,:) - COMPLEX(kind=DP), ALLOCATABLE :: h0c0(:,:) - INTEGER :: niter - INTEGER :: i,k, is, nss, istart, ig, iss - REAL(kind=DP) :: lambda, lambdap - REAL(kind=DP), ALLOCATABLE :: epsi0(:,:) - - INTEGER :: np(2), coor_ip(2), ipr, ipc, nr, nc, ir, ic, ii, jj, root, j - INTEGER :: desc_ip( descla_siz_ ) - INTEGER :: np_rot, me_rot, comm_rot, nrl - ! - LOGICAL :: lgam !added:giovanni - - CALL start_clock( 'inner_loop') - - lgam=gamma_only.and..not.do_wf_cmplx !added:giovanni - ! - allocate(fion2(3,nat)) -! allocate(c0hc0(nlax,nlax,nspin)) - allocate(h0c0(ngw,nx)) - !begin_added:giovanni - allocate(c0hc0(nspin)) - do j=1,nspin - call init_twin(c0hc0(j), lgam) - call allocate_twin(c0hc0(j),nlax,nlax, lgam) - enddo - !end_added:giovanni - lambdap=0.3d0!small step for free-energy calculation - - ! calculates the initial free energy if necessary - IF( .not. ene_ok ) THEN - - ! calculates the overlaps bec between the wavefunctions c0 - ! and the beta functions - CALL calbec( 1, nsp, eigr, c0, bec ) - - ! rotates the wavefunctions c0 and the overlaps bec - ! (the occupation matrix f_ij becomes diagonal f_i) - - CALL rotate_twin( z0t, c0, bec, c0diag, becdiag, .false. ) - - ! calculates the electronic charge density - CALL rhoofr( nfi, c0diag, irb, eigrb, becdiag, rhovan, & - rhor, rhog, rhos, enl, denl, ekin, dekin6 ) - IF(nlcc_any) CALL set_cc( irb, eigrb, rhoc ) - - ! calculates the SCF potential, the total energy - ! and the ionic forces - vpot = rhor - CALL vofrho( nfi, vpot, rhog, rhos, rhoc, tfirst, & - tlast, ei1, ei2, ei3, irb, eigrb, sfac, & - tau0, fion2 ) - !entropy value already been calculated - - END IF - - atot0=etot+entropy - - -!starts inner loop - do niter=1,ninner -!calculates c0hc0, which defines the search line (1-\labda)* psihpsi+\labda*c0hc0 - - ! calculateas the energy contribution associated with - ! the augmentation charges and the - ! corresponding contribution to the ionic force - - CALL newd( vpot, irb, eigrb, rhovan, fion2 ) - - ! operates the Hamiltonian on the wavefunction c0 - h0c0( :, : )= 0.D0 - DO i= 1, n, 2 - CALL dforce( i, bec, betae, c0, h0c0(:,i), h0c0(:,i+1), rhos, nnrsx, ispin, f, n, nspin ) - END DO - - - - ! calculates the Hamiltonian matrix in the basis {c0} -! c0hc0(:,:,:)=0.d0 - do i=1,nspin - call set_twin(c0hc0(i), CMPLX(0.d0,0.d0)) - enddo - ! - DO is= 1, nspin - - nss= nupdwn( is ) - istart= iupdwn( is ) - - np(1) = descla( la_npr_ , is ) - np(2) = descla( la_npc_ , is ) - - DO ipc = 1, np(2) - DO ipr = 1, np(1) - - coor_ip(1) = ipr - 1 - coor_ip(2) = ipc - 1 - CALL descla_init( desc_ip, descla( la_n_ , is ), descla( la_nx_ , is ), np, coor_ip, descla( la_comm_ , is ), 1 ) - - nr = desc_ip( nlar_ ) - nc = desc_ip( nlac_ ) - ir = desc_ip( ilar_ ) - ic = desc_ip( ilac_ ) - - CALL GRID2D_RANK( 'R', desc_ip( la_npr_ ), desc_ip( la_npc_ ), & - desc_ip( la_myr_ ), desc_ip( la_myc_ ), root ) - ! - root = root * leg_ortho - - IF(.not.c0hc0(iss)%iscmplx) THEN - ALLOCATE( mtmp( nr, nc ) ) - mtmp = 0.0d0 - CALL DGEMM( 'T', 'N', nr, nc, 2*ngw, - 2.0d0, c0( 1, istart + ir - 1 ), 2*ngw, & - h0c0( 1, istart + ic - 1 ), 2*ngw, 0.0d0, mtmp, nr ) - IF (gstart == 2) THEN - DO jj = 1, nc - DO ii = 1, nr - i = ii + ir - 1 - j = jj + ic - 1 - mtmp(ii,jj) = mtmp(ii,jj) + DBLE( c0( 1, i + istart - 1 ) ) * DBLE( h0c0( 1, j + istart - 1 ) ) - END DO - END DO - END IF - ELSE - ALLOCATE( mtmp_c( nr, nc ) ) - mtmp_c = CMPLX(0.0d0,0.d0) - CALL ZGEMM( 'C', 'N', nr, nc, ngw, CMPLX(- 1.0d0,0.d0), c0( 1, istart + ir - 1 ),ngw, & - h0c0( 1, istart + ic - 1 ), ngw, CMPLX(0.0d0,0.d0), mtmp_c, nr ) - ENDIF - - IF(.not.c0hc0(is)%iscmplx) THEN - CALL mp_root_sum( mtmp, c0hc0(is)%rvec(1:nr,1:nc), root, intra_image_comm ) - DEALLOCATE( mtmp ) - ELSE - CALL mp_root_sum( mtmp_c, c0hc0(is)%cvec(1:nr,1:nc), root, intra_image_comm ) - DEALLOCATE( mtmp_c ) - ENDIF -! IF( coor_ip(1) == descla( la_myr_ , is ) .AND. & -! coor_ip(2) == descla( la_myc_ , is ) .AND. descla( lambda_node_ , is ) > 0 ) THEN -! c0hc0(1:nr,1:nc,is) = mtmp -! END IF - END DO - END DO - END DO - - - if(mod(itercg,niter_cold_restart) == 0) then -!calculates free energy at lamda=1. - CALL inner_loop_lambda( nfi, tfirst, tlast, eigr, irb, eigrb, & - rhor, rhog, rhos, rhoc, ei1, ei2, ei3, & - sfac, c0, bec, firstiter,psihpsi,c0hc0,1.d0,atot1, vpot) -!calculates free energy at lamda=lambdap - - CALL inner_loop_lambda( nfi, tfirst, tlast, eigr, irb, eigrb, & - rhor, rhog, rhos, rhoc, ei1, ei2, ei3, & - sfac, c0, bec, firstiter,psihpsi,c0hc0,lambdap,atotl, vpot) -!find minimum point lambda - - CALL three_point_min(atot0,atotl,atot1,lambdap,lambda,atotmin) - - else - atotl=atot0 - atot1=atot0 - lambda=lambda_cold - endif - -!calculates free energy and rho at lambda - - - ! calculates the new matrix psihpsi - - IF(lgam) THEN - DO is= 1, nspin - psihpsi(is)%rvec(:,:) = (1.d0-lambda) * psihpsi(is)%rvec(:,:) + lambda * c0hc0(is)%rvec(:,:) - END DO - ELSE - DO is= 1, nspin - psihpsi(is)%cvec(:,:) = (1.d0-lambda) * psihpsi(is)%cvec(:,:) + lambda * c0hc0(is)%cvec(:,:) - END DO - ENDIF - - ! diagonalize and calculates energies - - e0( : )= 0.D0 - - CALL inner_loop_diag( c0, bec, psihpsi, z0t, e0 ) - - !calculates fro e0 the new occupation and the entropy - - CALL efermi( nelt, n, etemp, 1, f, ef, e0, entropy, ismear, nspin ) - - - !calculates new charge and new energy - - - ! calculates the electronic charge density - CALL rhoofr( nfi, c0diag, irb, eigrb, becdiag, rhovan, & - rhor, rhog, rhos, enl, denl, ekin, dekin6 ) - IF(nlcc_any) CALL set_cc( irb, eigrb, rhoc ) - - ! calculates the SCF potential, the total energy - ! and the ionic forces - vpot = rhor - CALL vofrho( nfi, vpot, rhog, rhos, rhoc, tfirst, & - tlast, ei1, ei2, ei3, irb, eigrb, sfac, & - tau0, fion2 ) - !entropy value already been calculated - if(ionode) then - write(37,*) niter - write(37,*) atot0,atotl,atot1 - write(37,*) lambda,atotmin,etot+entropy - endif - atotl=atot0 - atot0=etot+entropy - - - if(lambda==0.d0) exit - - - - enddo - - - atot=atot0 - -!ATTENZIONE -!the following is of capital importance - ene_ok= .TRUE. -!but it would be better to avoid it - do is=1,nspin - call deallocate_twin(c0hc0(is)) - enddo - - DEALLOCATE(fion2) - DEALLOCATE(c0hc0) - DEALLOCATE(h0c0) - - CALL stop_clock( 'inner_loop' ) - return -!==================================================================== - END SUBROUTINE inner_loop_cold -!==================================================================== - - - SUBROUTINE inner_loop_lambda( nfi, tfirst, tlast, eigr, irb, eigrb, & - rhor, rhog, rhos, rhoc, ei1, ei2, ei3, & - sfac, c0, bec, firstiter,c0hc0,c1hc1,lambda, & - free_energy, vpot ) - -!this subroutine for the energy matrix (1-lambda)c0hc0+labda*c1hc1 -!calculates the corresponding free energy - - - ! declares modules - USE kinds, ONLY: dp - USE control_flags, ONLY: iprint, thdyn, tpre, iprsta, & - tfor, taurdr, & - tprnfor, ndr, ndw, nbeg, nomore, & - tsde, tortho, tnosee, tnosep, trane, & - tranp, tsdp, tcp, tcap, ampre, & - amprp, tnoseh - USE core, ONLY: nlcc_any - USE energies, ONLY: eht, epseu, exc, etot, eself, enl, & - ekin, atot, entropy, egrand - USE electrons_base, ONLY: f, nspin, nel, iupdwn, nupdwn, nudx, & - nelt, nx => nbspx, n => nbsp, ispin - - USE ensemble_dft, ONLY: tens, ninner, ismear, etemp, & - c0diag, becdiag - USE gvecp, ONLY: ngm - USE gvecs, ONLY: ngs - USE gvecb, ONLY: ngb - USE gvecw, ONLY: ngw - USE reciprocal_vectors, & - ONLY: gstart - USE cvan, ONLY: nvb, ish - USE ions_base, ONLY: na, nat, pmass, nax, nsp, rcmax - USE grid_dimensions, & - ONLY: nnr => nnrx, nr1, nr2, nr3 - USE cell_base, ONLY: ainv, a1, a2, a3 - USE cell_base, ONLY: omega, alat - USE cell_base, ONLY: h, hold, deth, wmass, tpiba2 - USE smooth_grid_dimensions, & - ONLY: nnrsx, nr1s, nr2s, nr3s - USE smallbox_grid_dimensions, & - ONLY: nnrb => nnrbx, nr1b, nr2b, nr3b - USE local_pseudo, ONLY: vps, rhops - USE io_global, ONLY: io_global_start, stdout, ionode, & - ionode_id - USE mp_global, ONLY: intra_image_comm - USE dener - !USE derho - USE cdvan - USE io_files, ONLY: psfile, pseudo_dir, outdir - USE uspp, ONLY: nhsa=> nkb, betae => vkb, & - rhovan => becsum, deeq - USE uspp_param, ONLY: nh - USE cg_module, ONLY: ene_ok - USE ions_positions, ONLY: tau0 - USE mp, ONLY: mp_sum,mp_bcast - use cp_interfaces, only: rhoofr, dforce - USE cp_main_variables, ONLY: descla, nlax, nrlx - - ! - IMPLICIT NONE - -!input variables - INTEGER :: nfi - LOGICAL :: tfirst - LOGICAL :: tlast - COMPLEX(kind=DP) :: eigr( ngw, nat ) - COMPLEX(kind=DP) :: c0( ngw, n ) - REAL(kind=DP) :: bec( nhsa, n ) - LOGICAL :: firstiter - - - INTEGER :: irb( 3, nat ) - COMPLEX (kind=DP) :: eigrb( ngb, nat ) - REAL(kind=DP) :: rhor( nnr, nspin ) - REAL(kind=DP) :: vpot( nnr, nspin ) - COMPLEX(kind=DP) :: rhog( ngm, nspin ) - REAL(kind=DP) :: rhos( nnrsx, nspin ) - REAL(kind=DP) :: rhoc( nnr ) - COMPLEX(kind=DP) :: ei1( nr1:nr1, nat ) - COMPLEX(kind=DP) :: ei2( nr2:nr2, nat ) - COMPLEX(kind=DP) :: ei3( nr3:nr3, nat ) - COMPLEX(kind=DP) :: sfac( ngs, nsp ) - - REAL(kind=DP), INTENT(in) :: c0hc0(nlax,nlax,nspin) - REAL(kind=DP), INTENT(in) :: c1hc1(nlax,nlax,nspin) - REAL(kind=DP), INTENT(in) :: lambda - REAL(kind=DP), INTENT(out) :: free_energy - - -!local variables - REAL(kind=DP), ALLOCATABLE :: clhcl(:,:,:), fion2(:,:) - INTEGER :: i,k, is, nss, istart, ig - REAL(kind=DP), ALLOCATABLE :: eaux(:), faux(:), zauxt(:,:,:) - REAL(kind=DP) :: entropy_aux, ef_aux - - CALL start_clock( 'inner_lambda') - - allocate(clhcl(nlax,nlax,nspin)) - allocate(eaux(nx)) - allocate(faux(nx)) - allocate(zauxt(nrlx,nudx,nspin)) - allocate(fion2(3,nat)) - - -!calculates the matrix clhcl - - DO is= 1, nspin - clhcl(:,:,is)=(1.d0-lambda)*c0hc0(:,:,is)+lambda*c1hc1(:,:,is) - END DO - - CALL inner_loop_diag( c0, bec, clhcl, zauxt, eaux ) - - faux(:)=f(:) - - CALL efermi( nelt, n, etemp, 1, f, ef_aux, eaux, entropy_aux, ismear, nspin ) - - - ! calculates the electronic charge density - CALL rhoofr( nfi, c0diag, irb, eigrb, becdiag, rhovan, & - rhor, rhog, rhos, enl, denl, ekin, dekin6 ) - IF(nlcc_any) CALL set_cc( irb, eigrb, rhoc ) - - ! calculates the SCF potential, the total energy - ! and the ionic forces - vpot = rhor - CALL vofrho( nfi, vpot, rhog, rhos, rhoc, tfirst, & - tlast, ei1, ei2, ei3, irb, eigrb, sfac, & - tau0, fion2 ) - !entropy value already been calculated - - free_energy=etot+entropy_aux - - f(:)=faux(:) - - deallocate(clhcl) - deallocate(faux) - deallocate(eaux) - deallocate(zauxt) - deallocate(fion2) - - CALL stop_clock( 'inner_lambda') - - return - - END SUBROUTINE inner_loop_lambda - - - SUBROUTINE three_point_min(y0,yl,y1,l,lambda,amin) -!calculates the estimate for the minimum - - USE kinds, ONLY : DP - - - implicit none - - REAL(kind=DP), INTENT(in) :: y0,yl,y1, l - REAL(kind=DP), INTENT(out) :: lambda, amin - - - REAL(kind=DP) :: a,b,c, x_min, y_min - -! factors for f(x)=ax**2+b*x+c - c=y0 - b=(yl-y0-y1*l**2.d0+y0*l**2.d0)/(l-l**2.d0) - a=y1-y0-b - - - x_min=-b/(2.d0*a) - if( x_min <= 1.d0 .and. x_min >= 0.d0) then - y_min=a*x_min**2.d0+b*x_min+c - if(y_min <= y0 .and. y_min <= y1) then - lambda=x_min - amin=y_min - else - if(y0 < y1) then - lambda=0.d0 - amin=y0 - else - lambda=1.d0 - amin=y1 - endif - endif - else - if(y0 < y1) then - lambda=0.d0 - amin=y0 - else - lambda=1.d0 - amin=y1 - endif - endif - - - return - - END SUBROUTINE three_point_min - - -!==================================================================== - SUBROUTINE inner_loop_diag( c0, bec, psihpsi, z0t, e0 ) -!==================================================================== - ! - ! minimizes the total free energy - ! using cold smearing, - ! - ! declares modules - USE kinds, ONLY: dp - USE control_flags, ONLY: iprint, thdyn, tpre, iprsta, & - tfor, taurdr, & - tprnfor, ndr, ndw, nbeg, nomore, & - tsde, tortho, tnosee, tnosep, trane, & - tranp, tsdp, tcp, tcap, ampre, & - amprp, tnoseh - USE energies, ONLY: eht, epseu, exc, etot, eself, enl, & - ekin, atot, entropy, egrand - USE electrons_base, ONLY: f, nspin, nel, iupdwn, nupdwn, nudx, & - nelt, nx => nbspx, n => nbsp, ispin - - USE ensemble_dft, ONLY: tens, ninner, ismear, etemp, & - ef, c0diag, becdiag, & - compute_entropy2, & - compute_entropy_der, compute_entropy, & - niter_cold_restart, lambda_cold - USE gvecp, ONLY: ngm - USE gvecs, ONLY: ngs - USE gvecb, ONLY: ngb - USE gvecw, ONLY: ngw - USE reciprocal_vectors, & - ONLY: gstart - USE cvan, ONLY: nvb, ish - USE ions_base, ONLY: na, nat, pmass, nax, nsp, rcmax - USE grid_dimensions, & - ONLY: nnr => nnrx, nr1, nr2, nr3 - USE cell_base, ONLY: ainv, a1, a2, a3 - USE cell_base, ONLY: omega, alat - USE cell_base, ONLY: h, hold, deth, wmass, tpiba2 - USE smooth_grid_dimensions, & - ONLY: nnrsx, nr1s, nr2s, nr3s - USE smallbox_grid_dimensions, & - ONLY: nnrb => nnrbx, nr1b, nr2b, nr3b - USE local_pseudo, ONLY: vps, rhops - USE io_global, ONLY: io_global_start, stdout, ionode, & - ionode_id - USE mp_global, ONLY: intra_image_comm - USE dener - !USE derho - USE cdvan - USE io_files, ONLY: psfile, pseudo_dir, outdir - USE uspp, ONLY: nhsa=> nkb, betae => vkb, & - rhovan => becsum, deeq - USE uspp_param, ONLY: nh - USE cg_module, ONLY: ene_ok - USE ions_positions, ONLY: tau0 - USE mp, ONLY: mp_sum,mp_bcast, mp_root_sum - - USE cp_interfaces, ONLY: rhoofr, dforce - USE cg_module, ONLY: itercg - USE cp_main_variables, ONLY: distribute_lambda, descla, nlax, collect_lambda, nrlx - USE descriptors, ONLY: lambda_node_ , la_npc_ , la_npr_ , descla_siz_ , & - descla_init , la_comm_ , ilar_ , ilac_ , nlar_ , & - nlac_ , la_myr_ , la_myc_ , la_nx_ , la_n_ , & - la_me_ , la_nrl_ - USE dspev_module, ONLY: pdspev_drv, dspev_drv - - - ! - IMPLICIT NONE - - COMPLEX(kind=DP) :: c0( ngw, n ) - REAL(kind=DP) :: bec( nhsa, n ) - REAL(kind=DP) :: psihpsi( nlax, nlax, nspin ) - REAL(kind=DP) :: z0t( nrlx, nudx, nspin ) - REAL(kind=DP) :: e0( nx ) - - INTEGER :: i,k, is, nss, istart, ig - REAL(kind=DP), ALLOCATABLE :: epsi0(:,:), dval(:), zaux(:,:), mtmp(:,:) - - INTEGER :: np(2), coor_ip(2), ipr, ipc, nr, nc, ir, ic, ii, jj, root, j - INTEGER :: np_rot, me_rot, comm_rot, nrl, kk - - CALL start_clock( 'inner_diag') - - e0( : )= 0.D0 - - DO is = 1, nspin - - istart = iupdwn( is ) - nss = nupdwn( is ) - np_rot = descla( la_npr_ , is ) * descla( la_npc_ , is ) - me_rot = descla( la_me_ , is ) - nrl = descla( la_nrl_ , is ) - comm_rot = descla( la_comm_ , is ) - - allocate( dval( nx ) ) - - dval = 0.0d0 - - IF( descla( lambda_node_ , is ) > 0 ) THEN - ! - ALLOCATE( epsi0( nrl, nss ), zaux( nrl, nss ) ) - - CALL blk2cyc_redist( nss, epsi0, nrl, nss, psihpsi(1,1,is), SIZE(psihpsi,1), SIZE(psihpsi,2), descla(1,is) ) - - CALL pdspev_drv( 'V', epsi0, nrl, dval, zaux, nrl, nrl, nss, np_rot, me_rot, comm_rot ) - ! - IF( me_rot /= 0 ) dval = 0.0d0 - ! - ELSE - - ALLOCATE( epsi0( 1, 1 ), zaux( 1, 1 ) ) - - END IF - - CALL mp_sum( dval, intra_image_comm ) - - DO i = 1, nss - e0( i+istart-1 )= dval( i ) - END DO - - z0t(:,:,is) = 0.0d0 - - IF( descla( lambda_node_ , is ) > 0 ) THEN - !NB zaux is transposed - !ALLOCATE( mtmp( nudx, nudx ) ) - z0t( 1:nrl , 1:nss, is ) = zaux( 1:nrl, 1:nss ) - END IF - - DEALLOCATE( epsi0 , zaux, dval ) - - END DO - - ! rotates the wavefunctions c0 and the overlaps bec - ! (the occupation matrix f_ij becomes diagonal f_i) - - CALL rotate ( z0t, c0, bec, c0diag, becdiag, .false. ) - - CALL stop_clock( 'inner_diag') - - RETURN -END SUBROUTINE diff --git a/quantum_espresso/kcp/CPV/inner_loop_generalize.f90 b/quantum_espresso/kcp/CPV/inner_loop_generalize.f90 deleted file mode 100644 index 080e5a27c..000000000 --- a/quantum_espresso/kcp/CPV/inner_loop_generalize.f90 +++ /dev/null @@ -1,941 +0,0 @@ -subroutine nksic_rot_emin_cg_general(nouter, init_n, ninner, etot, rot_threshold, lgam, & - nbsp, nbspx, nudx, iupdwn, nupdwn, ispin, c0, becsum, bec, rhor, rhoc, & - vsic, pink, deeq_sic, wtot, fsic, sizwtot, do_wxd, wfc_centers, wfc_spreads, is_empty) - ! - ! ... Finds the orthogonal rotation matrix Omattot that minimizes - ! the orbital-dependent and hence the total energy, and then - ! rotate the wavefunction c0 accordingly using cg minimization. - ! We may need Omattot for further rotation of the gradient for outer loop CG. - ! Right now we do not do that because we set resetcg=.true. after inner loop - ! minimization routine, i.e., setting the search direction to be gradient direction. - ! (Ultrasoft pseudopotential case is not implemented.) - ! - use kinds, only: dp - use io_global, only: stdout, ionode - use cp_interfaces, only: invfft - use grid_dimensions, only: nnrx - use gvecw, only: ngw - use electrons_base, only: nspin - use ions_base, only: nat - use uspp_param, only: nhm - use nksic, only: innerloop_cg_nsd, & - innerloop_cg_nreset, & - innerloop_nmax, & - innerloop_atleast - use uspp, only: nkb - use control_flags, only: esic_conv_thr - use twin_types - ! - implicit none - ! - ! in/out vars - ! - integer :: nouter, ninner, init_n - integer :: nbsp, nbspx, nudx, sizwtot - integer :: ispin(nbspx) - integer, intent(in) :: iupdwn(nspin), nupdwn(nspin) - real(dp), intent(in) :: etot - real(dp), intent(in) :: rot_threshold - real(dp), intent(in) :: becsum(nhm*(nhm + 1)/2, nat, nspin) - real(dp), intent(in) :: fsic(nbspx) - real(dp) :: rhor(nnrx, nspin) - real(dp), intent(in) :: rhoc(nnrx) - real(dp), intent(out) :: vsic(nnrx, nbspx), wtot(sizwtot, 2) - real(dp), intent(out) :: deeq_sic(nhm, nhm, nat, nbspx) - logical, intent(in) :: do_wxd - real(DP) :: wfc_centers(4, nudx, nspin) - real(DP) :: wfc_spreads(nudx, nspin, 2) - complex(dp), intent(inout) :: c0(ngw, nbspx) - real(dp), intent(inout) :: pink(nbspx) - ! - logical :: lgam, is_empty - type(twin_matrix), intent(inout) :: bec - ! - ! local variables for cg routine - ! - integer :: nbnd1, nbnd2 - integer :: isp - integer :: nidx1, nidx2 - integer :: iter3, nfail - integer :: maxiter3, numok, minsteps - ! - real(dp) :: dtmp - real(dp) :: ene0, ene1, enesti, enever, dene0 - real(dp) :: passo, passov, passof, passomax, spasso - real(dp) :: vsicah2sum, vsicah2sum_prev - real(dp) :: dPI, dalpha, dmaxeig, deigrms - real(dp) :: pinksumprev, passoprod - real(dp) :: signalpha - real(dp) :: conv_thr - ! - real(dp), allocatable :: Heigbig(:) - real(dp), allocatable :: Heig(:) - real(dp), allocatable :: vsic1(:, :), vsic2(:, :) - real(dp), allocatable :: pink1(:), pink2(:) - ! - complex(dp), allocatable :: Umatbig(:, :) - complex(dp), allocatable :: Omat1tot(:, :), Omat2tot(:, :) - complex(dp), allocatable :: Omattot(:, :) - complex(dp), allocatable :: wfc_ctmp(:, :), wfc_ctmp2(:, :) - complex(dp), allocatable :: gi(:, :), hi(:, :) - ! - complex(dp), allocatable :: Umat(:, :) - complex(dp), allocatable :: vsicah(:, :) - ! - type(twin_matrix) :: bec1, bec2 - ! - logical :: restartcg_innerloop, ene_ok_innerloop, ltresh, setpassomax - logical :: ldotest - character(len=4) :: marker - ! - ! for numerial derivative testing - integer :: i - real(dp) :: odd_test1, odd_test2, tmppasso - ! - ! main body - ! - CALL start_clock('nk_rot_emin') - ! - marker = " " - maxiter3 = 4 - minsteps = 2 - restartcg_innerloop = .true. - ene_ok_innerloop = .false. - ltresh = .false. - setpassomax = .false. - nfail = 0 - numok = 0 - ! - if (nouter < init_n) then - ! - conv_thr = esic_conv_thr - ! - else - ! - conv_thr = rot_threshold - ! - end if - ! - pinksumprev = 1.d8 - dPI = 2.0_DP*asin(1.0_DP) - passoprod = 0.3d0 - ! - ! local workspace - ! - allocate (Omat1tot(nbspx, nbspx), Omat2tot(nbspx, nbspx), Omattot(nbspx, nbspx)) - allocate (Umatbig(nbspx, nbspx)) - allocate (Heigbig(nbspx)) - allocate (wfc_ctmp(ngw, nbspx), wfc_ctmp2(ngw, nbspx)) - allocate (hi(nbsp, nbsp)) - allocate (gi(nbsp, nbsp)) - allocate (pink1(nbspx), pink2(nbspx)) - allocate (vsic1(nnrx, nbspx), vsic2(nnrx, nbspx)) - ! - call init_twin(bec1, lgam) - call allocate_twin(bec1, nkb, nbsp, lgam) - call init_twin(bec2, lgam) - call allocate_twin(bec2, nkb, nbsp, lgam) - ! - Umatbig(:, :) = CMPLX(0.d0, 0.d0) - Heigbig(:) = 0.d0 - deigrms = 0.d0 - hi(:, :) = 0.d0 - gi(:, :) = 0.d0 - ! - Omattot(:, :) = CMPLX(0.d0, 0.d0) - do nbnd1 = 1, nbspx - ! - Omattot(nbnd1, nbnd1) = CMPLX(1.d0, 0.d0) - ! - end do - ! - ninner = 0 - ldotest = .false. - ! - if (ionode) write (stdout, "(14x,'# iter',6x,'etot',17x,'esic',17x,'deigrms', 17x,'Pede_cond')") - ! - ! main loop - ! - inner_loop: & - do while (.true.) - ! - call start_clock("nk_innerloop") - ! - ninner = ninner + 1 - ! - if (ninner > innerloop_nmax) then - ! - if (ionode) then - ! - write (stdout, "(14x,'# innerloop_nmax reached.',/)") - ! - end if - ! - call stop_clock("nk_innerloop") - ! - exit inner_loop - ! - end if - ! - ! print out ESIC part & other total energy - ! - ene0 = sum(pink(1:nbsp)) - ! - ! test convergence - ! - if (abs(ene0 - pinksumprev) < conv_thr) then - ! - numok = numok + 1 - ! - else - ! - numok = 0 - ! - end if - ! - if (numok >= minsteps .and. ninner >= innerloop_atleast) ltresh = .true. - ! - if (ltresh) then - ! - if (ionode) then - ! - write (stdout, "(a,/)") '# inner-loop converged.' - ! - end if - ! - call stop_clock("nk_innerloop") - ! - exit inner_loop - ! - end if - ! - pinksumprev = ene0 - ! - ! This part calculates the anti-hermitian part of the Hamiltonian vsicah - ! and see whether a convergence has been achieved - ! - ! For this run, we obtain the gradient - ! - vsicah2sum = 0.0d0 - ! - do isp = 1, nspin - ! - allocate (vsicah(nupdwn(isp), nupdwn(isp))) - ! - call nksic_getvsicah_general(ngw, nbsp, nbspx, c0, & - bec, isp, nupdwn, iupdwn, vsic, deeq_sic, vsicah, dtmp, lgam) - ! - gi(iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp), & - iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp)) = vsicah(:, :) - ! - vsicah2sum = vsicah2sum + dtmp - ! - deallocate (vsicah) - ! - end do - ! - if (ninner /= 1) dtmp = vsicah2sum/vsicah2sum_prev - ! - if (ninner <= innerloop_cg_nsd .or. & - mod(ninner, innerloop_cg_nreset) == 0 .or. restartcg_innerloop) then - ! - restartcg_innerloop = .false. - setpassomax = .false. - ! - hi(:, :) = gi(:, :) - ! - else - ! - hi(:, :) = gi(:, :) + dtmp*hi(:, :) - ! - end if - ! - spin_loop: do isp = 1, nspin - ! - if (nupdwn(isp) .gt. 1) then - ! - allocate (vsicah(nupdwn(isp), nupdwn(isp))) - allocate (Umat(nupdwn(isp), nupdwn(isp))) - allocate (Heig(nupdwn(isp))) - ! - vsicah(:, :) = hi(iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp), & - iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp)) - ! - call nksic_getHeigU_general(isp, nupdwn, vsicah, Heig, Umat) - ! - deigrms = deigrms + sum(Heig(:)**2) - ! - Umatbig(iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp), & - iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp)) = Umat(:, :) - Heigbig(iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp)) = Heig(:) - ! - deallocate (vsicah) - deallocate (Umat) - deallocate (Heig) - ! - else - ! - Umatbig(iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp), & - iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp)) = 1.d0 - Heigbig(iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp)) = 0.d0 - ! - end if - ! - end do spin_loop - ! - ! how severe the transform is - ! - deigrms = sqrt(deigrms/nbsp) - ! - if (ionode) write (stdout, '(10x,A3,2i4,4F18.13)') marker, ninner, nouter, etot, ene0, deigrms, vsicah2sum - ! - dmaxeig = max(dabs(Heigbig(iupdwn(1))), dabs(Heigbig(iupdwn(1) + nupdwn(1) - 1))) - ! - do isp = 2, nspin - ! - dmaxeig = max(dmaxeig, dabs(Heigbig(iupdwn(isp)))) - dmaxeig = max(dmaxeig, dabs(Heigbig(iupdwn(isp) + nupdwn(isp) - 1))) - ! - end do - ! - passomax = passoprod/dmaxeig - ! - if (ninner == 1 .or. setpassomax) then - ! - passof = passomax - setpassomax = .false. - ! - if (ionode) write (stdout, *) '# passof set to passomax' - ! - end if - ! - vsicah2sum_prev = vsicah2sum - ! - dene0 = 0.d0 - ! - do isp = 1, nspin - ! - do nbnd1 = 1, nupdwn(isp) - ! - do nbnd2 = 1, nupdwn(isp) - ! - nidx1 = nbnd1 - 1 + iupdwn(isp) - nidx2 = nbnd2 - 1 + iupdwn(isp) - ! - if (nidx1 .ne. nidx2) then - ! - dene0 = dene0 - DBLE(CONJG(gi(nidx1, nidx2))*hi(nidx1, nidx2)) - ! - end if - ! - end do - ! - end do - ! - end do - ! - ! Be careful, the following is correct because A_ji = - A_ij, i.e., the number of - ! linearly independent variables is half the number of total variables! - ! - dene0 = dene0*1.d0/nspin - ! - spasso = 1.d0 - ! - if (dene0 > 0.d0) spasso = -1.d0 - ! - ! here is for testing: compare numerical and analytical derivates - ! - if (.false.) then - ! - odd_test1 = 0.0 - odd_test2 = 0.0 - ! - do i = 1, 2 - ! - if (i == 1) tmppasso = 1.d-3 - if (i == 2) tmppasso = -1.d-3 - ! - dalpha = spasso*tmppasso - ! - call nksic_getOmattot_general(nbsp, nbspx, nudx, ispin, & - iupdwn, nupdwn, wfc_centers, wfc_spreads, & - dalpha, Heigbig, Umatbig, & - c0, wfc_ctmp, Omat1tot, bec1, rhor, rhoc, & - becsum, deeq_sic, wtot, fsic, sizwtot, do_wxd, & - vsic1, pink1, ene1, lgam, is_empty) - if (i == 1) odd_test1 = ene1 - if (i == 2) odd_test2 = ene1 - end do - ! - write (stdout, *) " odd_test1 odd_test2 ", odd_test1, odd_test2, dene0 - write (stdout, *) "ratio bw numerial and analytic derivative = ", ((odd_test1 - odd_test2)/(tmppasso*2.0))/dene0 - write (stdout, *) "ratio bw numerial and analytic derivative = ", ((odd_test1 - ene0)/(tmppasso))/dene0 - ! - end if - ! - dalpha = spasso*passof - ! - call nksic_getOmattot_general(nbsp, nbspx, nudx, ispin, & - iupdwn, nupdwn, wfc_centers, wfc_spreads, & - dalpha, Heigbig, Umatbig, & - c0, wfc_ctmp, Omat1tot, bec1, rhor, rhoc, & - becsum, deeq_sic, wtot, fsic, sizwtot, do_wxd, & - vsic1, pink1, ene1, lgam, is_empty) - ! - call minparabola(ene0, spasso*dene0, ene1, passof, passo, enesti) - ! - ! We neglect this step for paper writing purposes - ! - if (passo > passomax) then - ! - passo = passomax - ! - if (ionode) write (stdout, *) '# passo > passomax' - ! - end if - ! - passov = passof - ! - passof = 2.d0*passo - ! - dalpha = spasso*passo - ! - call nksic_getOmattot_general(nbsp, nbspx, nudx, ispin, & - iupdwn, nupdwn, wfc_centers, wfc_spreads, & - dalpha, Heigbig, Umatbig, & - c0, wfc_ctmp2, Omat2tot, bec2, rhor, rhoc, & - becsum, deeq_sic, wtot, fsic, sizwtot, do_wxd, & - vsic2, pink2, enever, lgam, is_empty) - ! - if (ene0 < ene1 .and. ene0 < enever) then !missed minimum case 3 - ! - write (stdout, '("# WARNING: innerloop missed minimum, case 3",/)') - ! - iter3 = 0 - signalpha = 1.d0 - restartcg_innerloop = .true. - ! - do while (enever .ge. ene0 .and. iter3 .lt. maxiter3) - ! - iter3 = iter3 + 1 - ! - signalpha = signalpha*(-0.717d0) - ! - dalpha = spasso*passo*signalpha - ! - call nksic_getOmattot_general(nbsp, nbspx, nudx, ispin, & - iupdwn, nupdwn, wfc_centers, wfc_spreads, & - dalpha, Heigbig, Umatbig, & - c0, wfc_ctmp2, Omat2tot, bec2, rhor, rhoc, & - becsum, deeq_sic, wtot, fsic, sizwtot, do_wxd, & - vsic2, pink2, enever, lgam, is_empty) - ! - end do - ! - if (enever .lt. ene0) then - ! - pink(:) = pink2(:) - vsic(:, :) = vsic2(:, :) - c0(:, :) = wfc_ctmp2(:, :) - call copy_twin(bec, bec2) - Omattot = MATMUL(Omattot, Omat2tot) - ! - write (stdout, '(i1)') iter3 - marker = '*'//marker - passof = passo*abs(signalpha) - nfail = 0 - ! - else - ! - marker = '***' - ninner = ninner + 1 - nfail = nfail + 1 - numok = 0 - passof = passo*abs(signalpha) - ! - if (nfail > 2) then - ! - write (stdout, '("# WARNING: innerloop not converged, exit",/)') - call stop_clock("nk_innerloop") - exit - end if - ! - end if - ! - elseif (ene1 >= enever) then !found minimum - ! - pink(:) = pink2(:) - vsic(:, :) = vsic2(:, :) - c0(:, :) = wfc_ctmp2(:, :) - call copy_twin(bec, bec2) - Omattot = MATMUL(Omattot, Omat2tot) - marker = " " - nfail = 0 - ! - else !missed minimum, case 1 or 2 - ! - write (stdout, '("# WARNING: innerloop missed minimum case 1 or 2",/)') - ! - pink(:) = pink1(:) - vsic(:, :) = vsic1(:, :) - c0(:, :) = wfc_ctmp(:, :) - call copy_twin(bec, bec1) - Omattot = MATMUL(Omattot, Omat1tot) - restartcg_innerloop = .true. - ! - if (enever < ene0) then - ! - marker = "* " - passof = min(1.5d0*passov, passomax) - ! - else - ! - marker = "** " - passof = passov - ! - end if - ! - nfail = 0 - ! - end if - ! - call stop_clock("nk_innerloop") - ! - end do inner_loop - ! - ! clean local workspace - ! - deallocate (Omat1tot, Omat2tot) - deallocate (Umatbig) - deallocate (Heigbig) - deallocate (wfc_ctmp, wfc_ctmp2) - deallocate (hi) - deallocate (gi) - deallocate (pink1, pink2) - deallocate (vsic1, vsic2) - call deallocate_twin(bec1) - call deallocate_twin(bec2) - call stop_clock('nk_rot_emin') - ! - return - ! -end subroutine nksic_rot_emin_cg_general -! -! -! -subroutine nksic_getvsicah_general(ngw, nbsp, nbspx, c0, bec, & - isp, nupdwn, iupdwn, vsic, deeq_sic, vsicah, vsicah2sum, lgam) - ! - ! ... Calculates the anti-hermitian part of the SIC hamiltonian, vsicah. - ! makes use of nksic_eforce to compute h_i | phi_i > - ! and then computes < phi_j | h_i | phi_i > in reciprocal space. - ! - use kinds, only: dp - use grid_dimensions, only: nnrx - use reciprocal_vectors, only: gstart - use mp, only: mp_sum - use mp_global, only: intra_image_comm - use cp_interfaces, only: invfft - use uspp_param, only: nhm - use ions_base, only: nat - use electrons_base, only: nspin - use twin_types - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp, ngw, nbsp, nbspx, & - nupdwn(nspin), iupdwn(nspin) - real(dp) :: vsicah2sum - real(dp) :: vsic(nnrx, nbspx) - real(dp) :: deeq_sic(nhm, nhm, nat, nbspx) - complex(dp) :: vsicah(nupdwn(isp), nupdwn(isp)), c0(ngw, nbsp) - logical :: lgam - type(twin_matrix) :: bec - ! - ! local variables - ! - integer :: nbnd1, nbnd2 - integer :: j1, jj1, j2 - real(dp) :: cost - complex(dp), allocatable :: hmat(:, :) - complex(dp), allocatable :: vsicpsi(:, :) - ! - call start_clock('nk_get_vsicah') - ! - !cost = DBLE( nspin ) * 2.0d0 - cost = 2.0d0 - ! - allocate (hmat(nupdwn(isp), nupdwn(isp))) - allocate (vsicpsi(ngw, 2)) - ! - ! compute < phi_j | Delta h_i | phi_i > - ! - do nbnd1 = 1, nupdwn(isp), 2 - ! - ! NOTE: USPP not implemented - ! - j1 = nbnd1 + iupdwn(isp) - 1 - ! - call nksic_eforce(j1, nbsp, nbspx, vsic, & - deeq_sic, bec, ngw, c0(:, j1), c0(:, j1 + 1), vsicpsi, lgam) - ! - do jj1 = 1, 2 - ! - if (nbnd1 + jj1 - 1 > nupdwn(isp)) cycle - ! - do nbnd2 = 1, nupdwn(isp) - ! - j2 = nbnd2 + iupdwn(isp) - 1 - ! - if (lgam) then - ! - hmat(nbnd2, nbnd1 + jj1 - 1) = 2.d0*DBLE(DOT_PRODUCT(c0(:, j2), vsicpsi(:, jj1))) - ! - if (gstart == 2) then - ! - hmat(nbnd2, nbnd1 + jj1 - 1) = hmat(nbnd2, nbnd1 + jj1 - 1) - & - DBLE(c0(1, j2)*vsicpsi(1, jj1)) - end if - ! - else - ! - hmat(nbnd2, nbnd1 + jj1 - 1) = DOT_PRODUCT(c0(:, j2), vsicpsi(:, jj1)) - ! - end if - ! - end do - ! - end do - ! - end do - ! - call mp_sum(hmat, intra_image_comm) - ! - hmat = hmat*cost - ! - ! Imposing Pederson condition - ! - vsicah(:, :) = 0.0d0 - vsicah2sum = 0.0d0 - ! - do nbnd1 = 1, nupdwn(isp) - ! - do nbnd2 = 1, nbnd1 - 1 - ! - if (lgam) then - ! - vsicah(nbnd2, nbnd1) = DBLE(hmat(nbnd2, nbnd1) - CONJG(hmat(nbnd1, nbnd2))) - vsicah(nbnd1, nbnd2) = DBLE(hmat(nbnd1, nbnd2) - CONJG(hmat(nbnd2, nbnd1))) - ! - else - ! - vsicah(nbnd2, nbnd1) = hmat(nbnd2, nbnd1) - CONJG(hmat(nbnd1, nbnd2)) - vsicah(nbnd1, nbnd2) = hmat(nbnd1, nbnd2) - CONJG(hmat(nbnd2, nbnd1)) - ! - end if - ! - vsicah2sum = vsicah2sum + DBLE(CONJG(vsicah(nbnd2, nbnd1))*vsicah(nbnd2, nbnd1)) - ! - end do - ! - end do - ! - deallocate (hmat) - deallocate (vsicpsi) - ! - call stop_clock('nk_get_vsicah') - ! - return - ! -end subroutine nksic_getvsicah_general -! -! -! -subroutine nksic_getHeigU_general(isp, nupdwn, vsicah, Heig, Umat) - ! - ! ... solves the eigenvalues (Heig) and eigenvectors (Umat) of the force - ! matrix vsicah. - ! (Ultrasoft pseudopotential case is not implemented.) - ! - use kinds, only: dp - use mp, only: mp_bcast - use electrons_base, only: nspin - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp, nupdwn(nspin) - real(dp) :: Heig(nupdwn(isp)) - complex(dp) :: Umat(nupdwn(isp), nupdwn(isp)) - complex(dp) :: vsicah(nupdwn(isp), nupdwn(isp)) - ! - ! local variables - ! - complex(dp) :: Hmat(nupdwn(isp), nupdwn(isp)) - complex(dp) :: ci - ! - ci = CMPLX(0.d0, 1.d0) - ! - ! this part diagonalizes Hmat = iWmat - ! - Hmat(:, :) = ci*vsicah(:, :) - ! - ! diagonalize Hmat - ! - CALL zdiag(nupdwn(isp), nupdwn(isp), Hmat(1, 1), Heig(1), Umat(1, 1), 1) - ! - return - ! -end subroutine nksic_getHeigU_general -! -! -! -subroutine nksic_getOmattot_general(nbsp, nbspx, nudx, ispin, & - iupdwn, nupdwn, wfc_centers, wfc_spreads, & - dalpha, Heigbig, Umatbig, & - wfc0, wfc1, Omat1tot, bec1, rhor, rhoc, & - becsum, deeq_sic, wtot, fsic, sizwtot, do_wxd, & - vsic1, pink1, ene1, lgam, is_empty) - ! - ! ... This routine rotates the wavefunction wfc0 into wfc1 according to - ! the force matrix (Heigbig, Umatbig) and the step of size dalpha. - ! Other quantities such as bec, vsic, pink are also calculated for wfc1. - ! - use kinds, only: dp - use grid_dimensions, only: nnrx - use gvecw, only: ngw - use ions_base, only: nsp, nat - use electrons_base, only: nspin - use uspp_param, only: nhm - use cp_main_variables, only: eigr - use electrons_module, only: icompute_spread - use cp_interfaces, only: nlsm1 - use twin_types - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: nbsp, nbspx, nudx - integer, intent(in) :: ispin(nbspx), nupdwn(nspin), & - iupdwn(nspin) - real(dp), intent(in) :: dalpha - complex(dp), intent(in) :: Umatbig(nbspx, nbspx) - real(dp), intent(in) :: Heigbig(nbspx), wfc_centers(4, nudx, nspin), & - wfc_spreads(nudx, nspin, 2) - complex(dp), intent(in) :: wfc0(ngw, nbspx) - ! - complex(dp) :: wfc1(ngw, nbspx) - complex(dp) :: Omat1tot(nbspx, nbspx) - type(twin_matrix) :: bec1 - real(dp) :: vsic1(nnrx, nbspx) - real(dp) :: pink1(nbspx) - real(dp) :: ene1 - integer, intent(in) :: sizwtot - real(dp), intent(in) :: becsum(nhm*(nhm + 1)/2, nat, nspin) - real(dp), intent(in) :: deeq_sic(nhm, nhm, nat, nbspx) - real(dp), intent(in) :: wtot(sizwtot, 2) - real(dp), intent(in) :: fsic(nbspx) - real(dp), intent(in) :: rhor(nnrx, nspin) - real(dp), intent(in) :: rhoc(nnrx) - logical, intent(in) :: do_wxd - logical, intent(in) :: lgam, is_empty - ! - ! local variables for cg routine - ! - integer :: isp, nbnd1 - real(dp) :: dmaxeig - complex(dp), allocatable :: Omat1(:, :) - complex(dp), allocatable :: Umat(:, :) - real(dp), allocatable :: Heig(:) - ! - call start_clock("nk_getOmattot") - ! - Omat1tot(:, :) = 0.d0 - ! - do nbnd1 = 1, nbspx - ! - Omat1tot(nbnd1, nbnd1) = 1.d0 - ! - end do - ! - wfc1(:, :) = CMPLX(0.d0, 0.d0) - ! - dmaxeig = max(abs(Heigbig(iupdwn(1))), abs(Heigbig(iupdwn(1) + nupdwn(1) - 1))) - ! - do isp = 2, nspin - ! - dmaxeig = max(dmaxeig, abs(Heigbig(iupdwn(isp)))) - dmaxeig = max(dmaxeig, abs(Heigbig(iupdwn(isp) + nupdwn(isp) - 1))) - ! - end do - ! - spin_loop: & - do isp = 1, nspin - ! - if (nupdwn(isp) .gt. 1) then - ! - allocate (Umat(nupdwn(isp), nupdwn(isp))) - allocate (Heig(nupdwn(isp))) - allocate (Omat1(nupdwn(isp), nupdwn(isp))) - ! - Umat(:, :) = Umatbig(iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp), iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp)) - Heig(:) = Heigbig(iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp)) - ! - call nksic_getOmat1_general(nupdwn(isp), Heig, Umat, dalpha, Omat1, lgam) - ! - ! Wavefunction wfc0 is rotated into wfc1 using Omat1 - ! - call nksic_rotwfn_general(nbspx, nupdwn(isp), iupdwn(isp), Omat1, wfc0, wfc1) - ! - ! Assigning the rotation matrix for a specific spin isp - ! - Omat1tot(iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp), iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp)) = Omat1(:, :) - ! - deallocate (Umat) - deallocate (Heig) - deallocate (Omat1) - ! - else - ! - Omat1tot(iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp), iupdwn(isp):iupdwn(isp) - 1 + nupdwn(isp)) = 1.d0 - ! - end if - ! - end do spin_loop - ! - ! recalculate bec & vsic according to the new wavefunction - ! - call nlsm1(nbsp, 1, nsp, eigr, wfc1, bec1, 1, lgam) - !call calbec(1,nsp,eigr,wfc1,bec) - ! - vsic1(:, :) = 0.d0 - pink1(:) = 0.d0 - ! - call nksic_potential(nbsp, nbspx, wfc1, fsic, bec1, becsum, deeq_sic, & - ispin, iupdwn, nupdwn, rhor, rhoc, wtot, sizwtot, vsic1, do_wxd, pink1, nudx, wfc_centers, & - wfc_spreads, icompute_spread, is_empty) - ! - ene1 = sum(pink1(:)) - ! - call stop_clock("nk_getOmattot") - ! - return - ! -end subroutine nksic_getOmattot_general -! -! -subroutine nksic_getOmat1_general(nupdwn_isp, Heig, Umat, passof, Omat1, lgam) -! -! ... Obtains the rotation matrix from the force-related matrices Heig and Umat -! and also from the step size (passof). -! - use kinds, only: dp - use constants, only: ci - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: nupdwn_isp - real(dp), intent(in) :: Heig(nupdwn_isp) - complex(dp), intent(in) :: Umat(nupdwn_isp, nupdwn_isp) - real(dp), intent(in) :: passof - complex(dp) :: Omat1(nupdwn_isp, nupdwn_isp) - logical :: lgam - ! - ! local variables - ! - complex(dp) :: Cmattmp(nupdwn_isp, nupdwn_isp) - complex(dp) :: exp_iHeig(nupdwn_isp) - ! - integer :: nbnd1 - real(dp) :: dtmp - ! - call start_clock("nk_getOmat1") - ! - !$$ We set the step size in such a way that the phase change - !$$ of the wavevector with largest eigenvalue upon rotation is fixed - ! passof = passoprod/max(abs(Heig(1)),abs(Heig(nupdwn(isp)))) - !$$ Now the above step is done outside. - ! - do nbnd1 = 1, nupdwn_isp - ! - dtmp = passof*Heig(nbnd1) - exp_iHeig(nbnd1) = DCOS(dtmp) + ci*DSIN(dtmp) - ! - end do - ! - ! Cmattmp = exp(i * passof * Heig) * Umat^dagger ; Omat = Umat * Cmattmp - ! - do nbnd1 = 1, nupdwn_isp - ! - Cmattmp(nbnd1, :) = exp_iHeig(nbnd1)*CONJG(Umat(:, nbnd1)) - ! - end do - ! - if (lgam) then - ! - Omat1 = DBLE(MATMUL(Umat, Cmattmp)) !modified:giovanni - ! - else - ! - Omat1 = MATMUL(Umat, Cmattmp) !modified:giovanni - ! - end if - ! - call stop_clock("nk_getOmat1") - ! - return - ! -end subroutine nksic_getOmat1_general -! -! -! -subroutine nksic_rotwfn_general(nbspx, nupdwn_isp, iupdwn_isp, Omat1, wfc1, wfc2) - ! - ! ... Simple rotation of wfc1 into wfc2 by Omat1. - ! wfc2(n) = sum_m wfc1(m) Omat1(m,n) - ! - use gvecw, only: ngw - use kinds, only: dp - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: nbspx, nupdwn_isp, iupdwn_isp - complex(dp), intent(in) :: Omat1(nupdwn_isp, nupdwn_isp) - complex(dp), intent(in) :: wfc1(ngw, nbspx) - complex(dp) :: wfc2(ngw, nbspx) - ! - ! local variables for cg routine - ! - integer :: nbnd1, nbnd2 - - CALL start_clock('nk_rotwfn') - ! - wfc2(:, iupdwn_isp:iupdwn_isp - 1 + nupdwn_isp) = CMPLX(0.d0, 0.d0) - ! - ! a blas could be used here XXX - ! - do nbnd1 = 1, nupdwn_isp - ! - do nbnd2 = 1, nupdwn_isp - ! - wfc2(:, iupdwn_isp - 1 + nbnd1) = wfc2(:, iupdwn_isp - 1 + nbnd1) & - + wfc1(:, iupdwn_isp - 1 + nbnd2)*Omat1(nbnd2, nbnd1) - ! - end do - ! - end do - ! - call stop_clock('nk_rotwfn') - ! - return - ! - -end subroutine nksic_rotwfn_general diff --git a/quantum_espresso/kcp/CPV/inner_loop_smear.f90 b/quantum_espresso/kcp/CPV/inner_loop_smear.f90 deleted file mode 100644 index 0ddefe175..000000000 --- a/quantum_espresso/kcp/CPV/inner_loop_smear.f90 +++ /dev/null @@ -1,170 +0,0 @@ -! -! Copyright (C) 2002 CP90 group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!==================================================================== - SUBROUTINE inner_loop_smear( c0, bec, rhos, psihpsi ) -!==================================================================== - ! - ! minimizes the total free energy - ! using cold smearing, - ! - ! - - ! declares modules - USE kinds, ONLY: dp - USE control_flags, ONLY: iprint, thdyn, tpre, iprsta, & - tfor, taurdr, & - tprnfor, ndr, ndw, nbeg, nomore, & - tsde, tortho, tnosee, tnosep, trane, & - tranp, tsdp, tcp, tcap, ampre, & - amprp, tnoseh - USE core, ONLY: nlcc_any - USE energies, ONLY: eht, epseu, exc, etot, eself, enl, & - ekin, atot, entropy, egrand - USE electrons_base, ONLY: f, nspin, nel, iupdwn, nupdwn, nudx, & - nelt, nx => nbspx, n => nbsp, ispin - - USE gvecp, ONLY: ngm - USE gvecs, ONLY: ngs - USE gvecb, ONLY: ngb - USE gvecw, ONLY: ngw - USE reciprocal_vectors, & - ONLY: gstart - USE cvan, ONLY: nvb, ish - USE ions_base, ONLY: na, nat, pmass, nax, nsp, rcmax - USE grid_dimensions, & - ONLY: nnr => nnrx, nr1, nr2, nr3 - USE cell_base, ONLY: ainv, a1, a2, a3 - USE cell_base, ONLY: omega, alat - USE cell_base, ONLY: h, hold, deth, wmass, tpiba2 - USE smooth_grid_dimensions, & - ONLY: nnrsx, nr1s, nr2s, nr3s - USE smallbox_grid_dimensions, & - ONLY: nnrb => nnrbx, nr1b, nr2b, nr3b - USE local_pseudo, ONLY: vps, rhops - USE io_global, ONLY: io_global_start, stdout, ionode, & - ionode_id - USE mp_global, ONLY: intra_image_comm, leg_ortho - USE dener - !USE derho - USE cdvan - USE io_files, ONLY: psfile, pseudo_dir, outdir - USE uspp, ONLY: nhsa=> nkb, betae => vkb, & - rhovan => becsum, deeq - USE uspp_param, ONLY: nh - USE ions_positions, ONLY: tau0 - USE mp, ONLY: mp_sum,mp_bcast, mp_root_sum - - USE cp_interfaces, ONLY: rhoofr, dforce - USE cp_main_variables, ONLY: distribute_lambda, descla, nlax, collect_lambda - USE descriptors, ONLY: lambda_node_ , la_npc_ , la_npr_ , descla_siz_ , & - descla_init , la_comm_ , ilar_ , ilac_ , nlar_ , & - nlac_ , la_myr_ , la_myc_ , la_nx_ , la_n_ , la_me_ , la_nrl_ - - - ! - IMPLICIT NONE - -!input variables - COMPLEX(kind=DP), INTENT(IN) :: c0( ngw, n ) - REAL(kind=DP), INTENT(IN) :: bec( nhsa, n ) - REAL(kind=DP), INTENT(IN) :: rhos( nnrsx, nspin ) - REAL(kind=DP), INTENT(OUT) :: psihpsi( nlax, nlax, nspin ) - - -!local variables - REAL(kind=DP), ALLOCATABLE :: c0hc0(:,:,:) - REAL(kind=DP), ALLOCATABLE :: mtmp(:,:) - COMPLEX(kind=DP), ALLOCATABLE :: h0c0(:,:) - INTEGER :: i,k, is, nss, istart, ig, iss - - INTEGER :: np(2), coor_ip(2), ipr, ipc, nr, nc, ir, ic, ii, jj, root, j - INTEGER :: desc_ip( descla_siz_ ) - INTEGER :: np_rot, me_rot, comm_rot, nrl - - - allocate(c0hc0(nlax,nlax,nspin)) - allocate(h0c0(ngw,nx)) - - - ! operates the Hamiltonian on the wavefunction c0 - h0c0( :, : )= 0.D0 - DO i= 1, n, 2 - CALL dforce( i, bec, betae, c0, h0c0(:,i), h0c0(:,i+1), rhos, nnrsx, ispin, f, n, nspin ) - END DO - - - - ! calculates the Hamiltonian matrix in the basis {c0} - c0hc0(:,:,:)=0.d0 - ! - DO is= 1, nspin - - nss= nupdwn( is ) - istart= iupdwn( is ) - - np(1) = descla( la_npr_ , is ) - np(2) = descla( la_npc_ , is ) - - DO ipc = 1, np(2) - DO ipr = 1, np(1) - - coor_ip(1) = ipr - 1 - coor_ip(2) = ipc - 1 - CALL descla_init( desc_ip, descla( la_n_ , is ), & - descla( la_nx_ , is ), np, coor_ip, descla( la_comm_ , is ), 1 ) - - nr = desc_ip( nlar_ ) - nc = desc_ip( nlac_ ) - ir = desc_ip( ilar_ ) - ic = desc_ip( ilac_ ) - - CALL GRID2D_RANK( 'R', desc_ip( la_npr_ ), desc_ip( la_npc_ ), & - desc_ip( la_myr_ ), desc_ip( la_myc_ ), root ) - ! - root = root * leg_ortho - - ALLOCATE( mtmp( nr, nc ) ) - mtmp = 0.0d0 - - CALL DGEMM( 'T', 'N', nr, nc, 2*ngw, - 2.0d0, c0( 1, istart + ir - 1 ), 2*ngw, & - h0c0( 1, istart + ic - 1 ), 2*ngw, 0.0d0, mtmp, nr ) - - IF (gstart == 2) THEN - DO jj = 1, nc - DO ii = 1, nr - i = ii + ir - 1 - j = jj + ic - 1 - mtmp(ii,jj) = mtmp(ii,jj) + DBLE( c0( 1, i + istart - 1 ) ) * DBLE( h0c0( 1, j + istart - 1 ) ) - END DO - END DO - END IF - - CALL mp_root_sum( mtmp, c0hc0(1:nr,1:nc,is), root, intra_image_comm ) - - DEALLOCATE( mtmp ) - - END DO - END DO - END DO - - - psihpsi(:,:,:) = c0hc0(:,:,:) - - - DEALLOCATE(c0hc0) - DEALLOCATE(h0c0) - - return -!==================================================================== - END SUBROUTINE inner_loop_smear -!==================================================================== - - - diff --git a/quantum_espresso/kcp/CPV/input.f90 b/quantum_espresso/kcp/CPV/input.f90 deleted file mode 100644 index 5313a40ed..000000000 --- a/quantum_espresso/kcp/CPV/input.f90 +++ /dev/null @@ -1,1311 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE input - !--------------------------------------------------------------------------- - ! - USE kinds, ONLY: DP - ! - IMPLICIT NONE - SAVE - ! - PRIVATE ! Input Subroutines - ! should be called in the following order - ! - PUBLIC :: read_input_file ! a) This sub. should be called first - PUBLIC :: iosys_pseudo ! b) then read pseudo files - PUBLIC :: iosys ! c) finally copy variables to modules - PUBLIC :: modules_setup, set_control_flags - ! - LOGICAL :: has_been_read = .FALSE. - ! -CONTAINS - ! - !------------------------------------------------------------------------- - SUBROUTINE read_input_file() - !------------------------------------------------------------------------- - ! - USE read_namelists_module, ONLY: read_namelists - USE read_cards_module, ONLY: read_cards - USE input_parameters, ONLY: calculation, title - USE control_flags, ONLY: lneb, lpath, lwf, lmetadyn, & - program_name - USE printout_base, ONLY: title_ => title - USE io_global, ONLY: meta_ionode, stdout - USE xml_input, ONLY: xml_input_dump - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog - ! - ! - prog = 'CP' - ! - IF (meta_ionode) THEN - CALL xml_input_dump() - CALL input_from_file() - END IF - ! - ! ... Read NAMELISTS - ! - CALL read_namelists(prog) - ! - ! ... Read CARDS - ! - CALL read_cards(prog) - ! - IF (TRIM(calculation) == 'fpmd') program_name = 'FPMD' - ! - IF (TRIM(calculation) == 'fpmd-neb') THEN - ! - program_name = 'FPMD' - lneb = .TRUE. - ! - ELSE - ! - lneb = (TRIM(calculation) == 'neb') - ! - END IF - ! - lpath = lneb - ! - lmetadyn = (TRIM(calculation) == 'metadyn') - ! - lwf = (TRIM(calculation) == 'cp-wf') - ! - ! ... Set job title and print it on standard output - ! - title_ = title - ! - WRITE (stdout, '(/,3X,"Job Title: ",A )') TRIM(title_) - ! - has_been_read = .TRUE. - ! - RETURN - ! - END SUBROUTINE read_input_file - ! - !------------------------------------------------------------------------- - SUBROUTINE iosys_pseudo() - !------------------------------------------------------------------------- - ! - USE input_parameters, ONLY: atom_pfile, pseudo_dir, ntyp, nat, & - prefix, outdir, input_dft - USE read_pseudo_module_fpmd, ONLY: readpp - USE io_files, ONLY: psfile_ => psfile, & - pseudo_dir_ => pseudo_dir, & - outdir_ => outdir, & - prefix_ => prefix - USE ions_base, ONLY: nsp_ => nsp, nat_ => nat - ! - IMPLICIT NONE - ! - ! - IF (.NOT. has_been_read) & - CALL errore('iosys_pseudo ', 'input file has not been read yet!', 1) - ! - prefix_ = TRIM(prefix) - outdir_ = TRIM(outdir) - ! - ! ... Set internal variables for the number of species and number of atoms - ! - nsp_ = ntyp - nat_ = nat - ! - psfile_ = ' ' - psfile_(1:nsp_) = atom_pfile(1:nsp_) - pseudo_dir_ = TRIM(pseudo_dir) - ! - ! ... read in pseudopotentials and wavefunctions files - ! - CALL readpp(input_dft) - ! - RETURN - ! - END SUBROUTINE iosys_pseudo - ! - !------------------------------------------------------------------------- - SUBROUTINE iosys() - !------------------------------------------------------------------------- - ! - USE control_flags, ONLY: fix_dependencies, program_name, & - lconstrain, lmetadyn - USE io_global, ONLY: meta_ionode, stdout - USE ions_base, ONLY: nat, tau, ityp - USE constraints_module, ONLY: init_constraint - USE metadyn_vars, ONLY: init_metadyn_vars - ! - IMPLICIT NONE - ! - ! - IF (meta_ionode) THEN - ! - WRITE (UNIT=stdout, & - FMT="(//,3X,'Main Simulation Parameters (from input)',/ & - & ,3X,'---------------------------------------')") - ! - END IF - ! - ! ... Set internal flags according to the input - ! - CALL set_control_flags() - ! - ! ... write to stdout basic simulation parameters - ! - CALL input_info() - ! - ! ... call the module specific setup routine - ! - CALL modules_setup() - ! - IF (lconstrain) CALL init_constraint(nat, tau, ityp, 1.D0) - ! - IF (lmetadyn) CALL init_metadyn_vars() - ! - ! ... fix values for dependencies - ! - IF (program_name == 'FPMD') THEN - ! - IF (lconstrain .OR. lmetadyn) THEN - - ! ... Apply sort to constraints atomic index - - CALL new_atomind_constraints() - - END IF - - CALL fix_dependencies() - ! - END IF - ! - ! ... write to stdout input module information - ! - CALL modules_info() - ! - RETURN - ! - END SUBROUTINE iosys - ! - !------------------------------------------------------------------------- - SUBROUTINE set_control_flags() - !------------------------------------------------------------------------- - ! - USE io_global, ONLY: stdout - USE autopilot, ONLY: auto_check - USE autopilot, ONLY: restart_p - USE control_flags, ONLY: lcoarsegrained, ldamped, lmetadyn - USE control_flags, ONLY: program_name - USE control_flags, ONLY: ndw_ => ndw, & - ndr_ => ndr, & - iprint_ => iprint, & - isave_ => isave, & - tstress_ => tstress, & - tprnfor_ => tprnfor, & - tprnsfac_ => tprnsfac, & - ampre_ => ampre, & - trane_ => trane, & - newnfi_ => newnfi, & - tnewnfi_ => tnewnfi, & - tdipole_ => tdipole, & - nomore_ => nomore, & - memchk_ => memchk, & - tpre_ => tpre, & - timing_ => timing, & - iprsta_ => iprsta, & - taurdr_ => taurdr, & - nbeg_ => nbeg, & - do_wf_cmplx_ => do_wf_cmplx, & !added:giovanni - gamma_only_ => gamma_only, & - tchi2_ => tchi2, & - tatomicwfc_ => tatomicwfc, & - printwfc_ => printwfc, & - tortho_ => tortho, & - non_ortho_ => non_ortho, & - nstep_ => nstep, & - iprint_manifold_overlap_ => iprint_manifold_overlap, & - hartree_only_sic_ => hartree_only_sic, & - iprint_spreads_ => iprint_spreads - USE control_flags, ONLY: tsde_ => tsde, & - tsteepdesc_ => tsteepdesc, & - tzeroe_ => tzeroe, & - tdamp_ => tdamp, & - trhor_ => trhor, & - trhow_ => trhow, & - tksw_ => tksw, & - evc_restart_ => evc_restart, & - ortho_eps_ => ortho_eps, & - ortho_max_ => ortho_max, & - tnosee_ => tnosee - USE control_flags, ONLY: tdampions_ => tdampions, & - tfor_ => tfor, & - tsdp_ => tsdp, & - lfixatom, tconvthrs - USE control_flags, ONLY: tnosep_ => tnosep, & - tcap_ => tcap, & - tcp_ => tcp, & - tolp_ => tolp, & - tzerop_ => tzerop, & - tv0rd_ => tv0rd, & - tranp_ => tranp, & - amprp_ => amprp, & - dt_old_ => dt_old - USE control_flags, ONLY: tionstep_ => tionstep, & - nstepe_ => nstepe - USE control_flags, ONLY: tzeroc_ => tzeroc, & - tnoseh_ => tnoseh, & - thdyn_ => thdyn, & - tsdc_ => tsdc, & - tbeg_ => tbeg - USE control_flags, ONLY: ekin_conv_thr_ => ekin_conv_thr, & - etot_conv_thr_ => etot_conv_thr, & - !$$ - esic_conv_thr_ => esic_conv_thr, & - !$$ - forc_conv_thr_ => forc_conv_thr, & - ekin_maxiter_ => ekin_maxiter - USE control_flags, ONLY: force_pairing_ => force_pairing - USE control_flags, ONLY: remove_rigid_rot_ => remove_rigid_rot - USE control_flags, ONLY: iesr, tvhmean, vhrmin, vhrmax, vhasse - USE control_flags, ONLY: tprojwfc - USE control_flags, ONLY: textfor - USE control_flags, ONLY: do_makov_payne - ! - ! ... Other modules - ! - USE cp_main_variables, ONLY: nprint_nfi - USE wave_base, ONLY: frice_ => frice - USE ions_base, ONLY: fricp_ => fricp - USE cell_base, ONLY: frich_ => frich - USE time_step, ONLY: set_time_step - USE cp_electronic_mass, ONLY: emass_ => emass, & - emaec_ => emass_cutoff - ! - USE efield_module, ONLY: tefield_ => tefield, & - epol_ => epol, & - efield_ => efield, & - tefield2_ => tefield2, & - epol2_ => epol2, & - efield2_ => efield2 - ! - USE cvan, ONLY: nvb - USE control_flags, ONLY: ortho_para_ => ortho_para - ! - USE input_parameters, ONLY: & - electron_dynamics, electron_damping, electron_temperature, & - ion_dynamics, ekin_conv_thr, etot_conv_thr, forc_conv_thr, & - !$$ - esic_conv_thr, & - !$$ - electron_maxstep, ion_damping, ion_temperature, ion_velocities, tranp, & - amprp, ion_nstepe, cell_nstepe, cell_dynamics, cell_damping, & - cell_parameters, cell_velocities, cell_temperature, force_pairing, & - tapos, tavel, emass, emass_cutoff, taspc, trd_ht, ibrav, & - ortho_eps, ortho_max, ntyp, tolp, tchi2_inp, calculation, disk_io, dt, & - tcg, ndr, ndw, iprint, isave, tstress, k_points, tprnfor, verbosity, & - tdipole_card, tnewnfi_card, newnfi_card, occupations, & ! added:giovanni occupations - ampre, nstep, restart_mode, ion_positions, startingwfc, printwfc, & - orthogonalization, electron_velocities, nat, if_pos, phase_space, & - tefield, epol, efield, tefield2, epol2, efield2, remove_rigid_rot, & - iesr_inp, vhrmax_inp, vhrmin_inp, tvhmean_inp, vhasse_inp, saverho, & - ortho_para, rd_for, do_wf_cmplx, & !added:giovanni do_wf_cmplx, empty_states_nbnd - iprint_manifold_overlap, iprint_spreads, hartree_only_sic, & - assume_isolated - USE input_parameters, ONLY: evc_restart - ! - IMPLICIT NONE - ! - ! - IF (.NOT. has_been_read) & - CALL errore('iosys ', 'input file has not been read yet!', 1) - ! - ndr_ = ndr - ndw_ = ndw - iprint_ = iprint - isave_ = isave - tstress_ = tstress - tpre_ = tstress - do_wf_cmplx_ = do_wf_cmplx !added:giovanni - gamma_only_ = (TRIM(k_points) == 'gamma') - tprnfor_ = tprnfor - printwfc_ = printwfc - tchi2_ = tchi2_inp - ekin_conv_thr_ = ekin_conv_thr - etot_conv_thr_ = etot_conv_thr -!$$ - esic_conv_thr_ = esic_conv_thr -!$$ - hartree_only_sic_ = hartree_only_sic - iprint_manifold_overlap_ = iprint_manifold_overlap !added:giovanni spreads and manifold overlap - iprint_spreads_ = iprint_spreads - forc_conv_thr_ = forc_conv_thr - ekin_maxiter_ = electron_maxstep - iesr = iesr_inp - ! - tvhmean = tvhmean_inp - vhrmin = vhrmin_inp - vhrmax = vhrmax_inp - vhasse = vhasse_inp - ! - remove_rigid_rot_ = remove_rigid_rot - ! - ! Options for isolated system - SELECT CASE (TRIM(assume_isolated)) - ! - CASE ('makov-payne', 'm-p', 'mp') - ! - do_makov_payne = .TRUE. - ! - CASE ('none') - ! - do_makov_payne = .FALSE. - ! - CASE DEFAULT - ! - do_makov_payne = .FALSE. - ! - END SELECT - ! - tefield_ = tefield - epol_ = epol - efield_ = efield - tefield2_ = tefield2 - epol2_ = epol2 - efield2_ = efield2 - ! - ! ... Set internal time step variables ( delt, twodelt, dt2 ... ) - ! - CALL set_time_step(dt) - ! - ! ... Set electronic fictitius mass and its cut-off for fourier - ! ... acceleration - ! - emass_ = emass - emaec_ = emass_cutoff - ! - ! ... set the level of output, the code verbosity - ! - iprsta_ = 1 - timing_ = .FALSE. - ! The code write to files fort.8 fort.41 fort.42 fort.43 - ! a detailed report of subroutines timing - memchk_ = .FALSE. - ! The code performs a memory check, write on standard - ! output the allocated memory at each step. - ! Architecture Dependent - tprnsfac_ = .FALSE. - ! Print on file STRUCTURE_FACTOR the structure factor - ! gvectors and charge density, in reciprocal space. - ! - trhor_ = (TRIM(calculation) == 'nscf') - trhow_ = saverho - tksw_ = (TRIM(disk_io) == 'high') - evc_restart_ = evc_restart - ! - SELECT CASE (TRIM(verbosity)) - CASE ('minimal') - ! - iprsta_ = 0 - ! - CASE ('low', 'default') - ! - iprsta_ = 1 - timing_ = .TRUE. - ! - CASE ('default+projwfc') - ! - iprsta_ = 1 - timing_ = .TRUE. - tprojwfc = .TRUE. - ! - CASE ('medium') - ! - iprsta_ = 2 - timing_ = .TRUE. - tprnsfac_ = .TRUE. - ! - CASE ('high') - ! - iprsta_ = 3!modified:giovanni 3->4 - memchk_ = .TRUE. - timing_ = .TRUE. - tprnsfac_ = .TRUE. - tprojwfc = .TRUE. - ! - CASE DEFAULT - ! - CALL errore('control_flags ', & - 'unknown verbosity '//TRIM(verbosity), 1) - ! - END SELECT - ! - tdipole_ = tdipole_card - newnfi_ = newnfi_card - tnewnfi_ = tnewnfi_card - ! - ! ... set the restart flags - ! - trane_ = .FALSE. - ampre_ = ampre - taurdr_ = .FALSE. - ! - SELECT CASE (TRIM(restart_mode)) - ! - CASE ('from_scratch') - ! - nbeg_ = -1 - nomore_ = nstep - nstep_ = nstep - trane_ = (startingwfc == 'random') - ! - IF (ampre_ == 0.D0) ampre_ = 0.02D0 - ! - IF (iprint_manifold_overlap > 0) THEN - ! - WRITE (6, *) "**************************** ERROR ***********************************************************" - WRITE (6, *) "Setting control flags, it makes no sense to print manifold overlap if I start from scratch, I exit" - WRITE (6, *) "**************************** ERROR ***********************************************************" - stop - ! - END IF - ! - CASE ('reset_counters') - ! - nbeg_ = 0 - nomore_ = nstep - nstep_ = nstep - ! - CASE ('restart') - ! - nbeg_ = 1 - nomore_ = nstep - nstep_ = nstep - nprint_nfi = -2 - ! - CASE ('auto') - ! - IF (auto_check(ndr, ' ')) THEN - ! - WRITE (stdout, '("autopilot: Auto Check detects restart.xml")') - WRITE (stdout, '(" adjusting restart_mode to restart")') - ! - restart_mode = 'restart' - ! - nbeg_ = 1 - ! - ! ... Also handle NSTEPS adjustment so that - ! ... nomore does not include past nfi in cpr.f90 - ! - restart_p = .TRUE. - nomore_ = nstep - nstep_ = nstep - nprint_nfi = -2 - ! - IF (ion_positions == 'from_input') THEN - ! - taurdr_ = .TRUE. - nbeg_ = -1 - ! - END IF - ! - ELSE - ! - WRITE (stdout, & - '("autopilot: Auto Check did not detect restart.xml")') - ! - WRITE (stdout, & - '(" adjusting restart_mode to from_scratch")') - ! - restart_mode = 'from_scratch' - ! - nbeg_ = -2 - ! - IF (ion_positions == 'from_input') nbeg_ = -1 - ! - nomore_ = nstep - nstep_ = nstep - ! - trane_ = (startingwfc == 'random') - ! - IF (ampre_ == 0.d0) ampre_ = 0.02D0 - ! - END IF - ! - CASE DEFAULT - ! - CALL errore('iosys ', & - 'unknown restart_mode '//TRIM(restart_mode), 1) - ! - END SELECT - ! - ! ... Starting/Restarting Atomic positions - ! - SELECT CASE (TRIM(ion_positions)) - CASE ('from_input') - taurdr_ = .TRUE. ! Positions read from standard input - CASE ('default') - taurdr_ = .FALSE. - CASE DEFAULT - CALL errore(' control_flags ', ' unknown ion_positions '//TRIM(ion_positions), 1) - END SELECT - - ! ... Electronic randomization - - tatomicwfc_ = .FALSE. - SELECT CASE (TRIM(startingwfc)) - CASE ('default', 'none') - trane_ = .FALSE. - CASE ('random') - trane_ = .TRUE. - CASE ('atomic') - tatomicwfc_ = .TRUE. - CASE ('atomic+random') - tatomicwfc_ = .TRUE. - trane_ = .TRUE. - CASE DEFAULT - CALL errore(' control_flags ', ' unknown startingwfc '//TRIM(startingwfc), 1) - END SELECT - IF (ampre_ == 0) trane_ = .FALSE. - - ! ... TORTHO - - SELECT CASE (orthogonalization) - CASE ('Gram-Schmidt') - tortho_ = .FALSE. - CASE ('ortho') - tortho_ = .TRUE. - CASE ('non_ortho') - tortho_ = .FALSE. - non_ortho_ = .TRUE. - CASE DEFAULT - CALL errore(' iosys ', ' unknown orthogonalization '// & - TRIM(orthogonalization), 1) - END SELECT - - ortho_max_ = ortho_max - ortho_eps_ = ortho_eps - IF (ortho_para_ < 1) ortho_para_ = ortho_para - - ! ... Electrons initial velocity - - SELECT CASE (TRIM(electron_velocities)) - CASE ('default') - tzeroe_ = .FALSE. - CASE ('zero') - tzeroe_ = .TRUE. - IF (program_name == 'CP90') & - WRITE (stdout, & - '("Warning: electron_velocities keyword has no effect")') - CASE DEFAULT - CALL errore(' control_flags ', ' unknown electron_velocities '//TRIM(electron_velocities), 1) - END SELECT - - ! ... Electron dynamics - - tdamp_ = .FALSE. - tsteepdesc_ = .FALSE. - frice_ = 0.d0 - SELECT CASE (TRIM(electron_dynamics)) - CASE ('sd', 'default') - tsde_ = .TRUE. - CASE ('verlet') - tsde_ = .FALSE. - CASE ('cg') - tsde_ = .FALSE. - IF (program_name == 'CP90') THEN - tcg = .TRUE. - tortho_ = .FALSE. - ELSE - CALL errore(' control_flags ', ' conjugate gradient not yet implemented in FPMD ', 1) - END IF - IF (occupations == 'from_input') THEN - CALL errore(' control_flags ', ' conjugate gradient does not work with occupations=from_input ', 1) - END IF - CASE ('damp') - tsde_ = .FALSE. - tdamp_ = .TRUE. - frice_ = electron_damping - CASE ('diis') - CALL errore("iosys ", " electron_dynamics keyword diis not yet implemented ", 1) - CASE ('none') - tsde_ = .FALSE. - CASE DEFAULT - CALL errore(' control_flags ', ' unknown electron_dynamics '//TRIM(electron_dynamics), 1) - END SELECT - - ! ... Electronic Temperature - - tnosee_ = .FALSE. - SELECT CASE (TRIM(electron_temperature)) - ! temperature control of electrons via Nose' thermostat - CASE ('nose') - tnosee_ = .TRUE. - CASE ('not_controlled', 'default') - tnosee_ = .FALSE. - CASE DEFAULT - CALL errore(' control_flags ', ' unknown electron_temperature '//TRIM(electron_temperature), 1) - END SELECT - - SELECT CASE (TRIM(phase_space)) - CASE ('full') - ! - lcoarsegrained = .FALSE. - ! - CASE ('coarse-grained') - ! - lcoarsegrained = .TRUE. - ! - END SELECT - ! - IF (lmetadyn) lcoarsegrained = .TRUE. - - ! ... Ions dynamics - - tdampions_ = .FALSE. - tconvthrs%active = .FALSE. - tconvthrs%nstep = 1 - tconvthrs%ekin = 0.0d0 - tconvthrs%derho = 0.0d0 - tconvthrs%force = 0.0d0 - SELECT CASE (TRIM(ion_dynamics)) - CASE ('sd') - tsdp_ = .TRUE. - tfor_ = .TRUE. - fricp_ = 0.d0 - tconvthrs%ekin = ekin_conv_thr - tconvthrs%derho = etot_conv_thr - tconvthrs%force = forc_conv_thr - tconvthrs%active = .TRUE. - tconvthrs%nstep = 1 - CASE ('verlet') - tsdp_ = .FALSE. - tfor_ = .TRUE. - fricp_ = 0.d0 - CASE ('cg') ! Conjugate Gradient minimization for ions - CALL errore("iosys ", " ion_dynamics = '//TRIM(ion_dynamics)//' not yet implemented ", 1) - CASE ('damp') - ldamped = .TRUE. - tsdp_ = .FALSE. - tfor_ = .TRUE. - tdampions_ = .TRUE. - fricp_ = ion_damping - tconvthrs%ekin = ekin_conv_thr - tconvthrs%derho = etot_conv_thr - tconvthrs%force = forc_conv_thr - tconvthrs%active = .TRUE. - tconvthrs%nstep = 1 - CASE ('none', 'default') - tsdp_ = .FALSE. - tfor_ = .FALSE. - fricp_ = 0.d0 - CASE DEFAULT - CALL errore(' control_flags ', ' unknown ion_dynamics '//TRIM(ion_dynamics), 1) - END SELECT - - ! External Forces on Ions has been specified - ! - IF (ANY(rd_for(:, 1:nat) /= 0.0_DP)) textfor = .TRUE. - - ! some atoms are kept fixed - ! - IF (ANY(if_pos(:, 1:nat) == 0)) lfixatom = .TRUE. - - ! ... Ionic Temperature - - tcp_ = .FALSE. - tnosep_ = .FALSE. - tolp_ = tolp - SELECT CASE (TRIM(ion_temperature)) - ! temperature control of ions via Nose' thermostat - CASE ('nose') - tnosep_ = .TRUE. - tcp_ = .FALSE. - CASE ('not_controlled', 'default') - tnosep_ = .FALSE. - tcp_ = .FALSE. - CASE ('rescaling') - tnosep_ = .FALSE. - tcp_ = .TRUE. - CASE DEFAULT - CALL errore(' control_flags ', ' unknown ion_temperature '//TRIM(ion_temperature), 1) - END SELECT - - ! ... Starting/Restarting ionic velocities - - tcap_ = .FALSE. - SELECT CASE (TRIM(ion_velocities)) - CASE ('default') - tzerop_ = .FALSE. - tv0rd_ = .FALSE. - tcap_ = .FALSE. - CASE ('change_step') - tzerop_ = .FALSE. - tv0rd_ = .FALSE. - tcap_ = .FALSE. - dt_old_ = tolp - CASE ('zero') - tzerop_ = .TRUE. - tv0rd_ = .FALSE. - CASE ('from_input') - tzerop_ = .TRUE. - tv0rd_ = .TRUE. - CASE ('random') - tcap_ = .TRUE. - IF (program_name == 'FPMD') & - WRITE (stdout) " ion_velocities = '//TRIM(ion_velocities)//' has no effects " - CASE DEFAULT - CALL errore(' control_flags ', ' unknown ion_velocities '//TRIM(ion_velocities), 1) - END SELECT - - ! ... Ionic randomization - - tranp_(1:ntyp) = tranp(1:ntyp) - amprp_(1:ntyp) = amprp(1:ntyp) - - ! ... Ionic/electronic step ratio - - tionstep_ = .FALSE. - nstepe_ = 1 - IF ((ion_nstepe > 1) .OR. (cell_nstepe > 1)) THEN - ! This card is used to control the ionic step, when active ionic step are - ! allowed only when the two criteria are met, i.e. the ions are allowed - ! to move if MOD( NFI, NSTEP ) == 0 and EKIN < EKIN_THR . - tionstep_ = .TRUE. - nstepe_ = MAX(ion_nstepe, cell_nstepe) - IF (program_name == 'CP90') & - WRITE (stdout, *) " ion_nstepe or cell_nstepe have no effects " - END IF - - ! Cell dynamics - - SELECT CASE (TRIM(cell_dynamics)) - CASE ('sd') - tpre_ = .TRUE. - thdyn_ = .TRUE. - tsdc_ = .TRUE. - frich_ = 0.d0 - CASE ('damp', 'damp-pr') - thdyn_ = .TRUE. - tsdc_ = .FALSE. - frich_ = cell_damping - tpre_ = .TRUE. - CASE ('pr') - thdyn_ = .TRUE. - tsdc_ = .FALSE. - tpre_ = .TRUE. - frich_ = 0.d0 - CASE ('none', 'default') - thdyn_ = .FALSE. - tsdc_ = .FALSE. - frich_ = 0.d0 - CASE DEFAULT - CALL errore(' control_flags ', ' unknown cell_dynamics '//TRIM(cell_dynamics), 1) - END SELECT - - ! ... Starting/Restarting Cell parameters - - SELECT CASE (TRIM(cell_parameters)) - CASE ('default') - tbeg_ = .FALSE. - CASE ('from_input') - tbeg_ = .TRUE. - IF (program_name == 'CP90' .AND. force_pairing_) & - WRITE (stdout) " cell_parameters have no effects " - CASE DEFAULT - CALL errore(' control_flags ', ' unknown cell_parameters '//TRIM(cell_parameters), 1) - END SELECT - - ! ... Cell initial velocities - - SELECT CASE (TRIM(cell_velocities)) - CASE ('default') - tzeroc_ = .FALSE. - CASE ('zero') - tzeroc_ = .TRUE. - CASE DEFAULT - CALL errore(' control_flags ', ' unknown cell_velocities '//TRIM(cell_velocities), 1) - END SELECT - - ! ... Cell Temperature - - SELECT CASE (TRIM(cell_temperature)) -! cell temperature control of ions via Nose' thermostat - CASE ('nose') - tnoseh_ = .TRUE. - CASE ('not_controlled', 'default') - tnoseh_ = .FALSE. - CASE DEFAULT - CALL errore(' control_flags ', ' unknown cell_temperature '//TRIM(cell_temperature), 1) - END SELECT - - ! .. If only electron are allowed to move - ! .. check for SCF convergence on the ground state - - IF (ion_dynamics == 'none' .AND. cell_dynamics == 'none') THEN - tconvthrs%ekin = ekin_conv_thr - tconvthrs%derho = etot_conv_thr - tconvthrs%force = 1.D+10 - tconvthrs%active = .TRUE. - tconvthrs%nstep = 1 - END IF - - ! force pairing - - force_pairing_ = force_pairing - ! - IF ((nvb > 0) .and. (program_name == 'FPMD')) & - CALL errore(' iosys ', ' USPP not yet implemented in FPMD ', 1) - - ! ... the 'ATOMIC_SPECIES' card must be present, check it - - IF (.NOT. taspc) & - CALL errore(' iosys ', ' ATOMIC_SPECIES not found in stdin ', 1) - - ! ... the 'ATOMIC_POSITIONS' card must be present, check it - - IF (.NOT. tapos) & - CALL errore(' iosys ', ' ATOMIC_POSITIONS not found in stdin ', 1) - - IF (.NOT. trd_ht .AND. TRIM(cell_parameters) == 'from_input') & - CALL errore(' iosys ', ' CELL_PARAMETERS not present in stdin ', 1) - - IF (.NOT. trd_ht .AND. ibrav == 0) & - CALL errore(' iosys ', ' ibrav = 0 but CELL_PARAMETERS not present in stdin ', 1) - - IF (.NOT. tavel .AND. TRIM(ion_velocities) == 'from_input') & - CALL errore(' iosys ', ' ION_VELOCITIES not present in stdin ', 1) - - IF ((TRIM(calculation) == 'smd') .AND. (TRIM(cell_dynamics) /= 'none')) THEN - CALL errore(' smiosys ', ' cell_dynamics not implemented : '//TRIM(cell_dynamics), 1) - END IF - - IF (do_wf_cmplx_) THEN !warning:giovanni not yet implemented -! - IF (tfor_ .or. tprnfor_ .or. thdyn_ .or. tpre_) THEN - write (6, *) tfor_, tprnfor_, thdyn_, tpre_ - END IF -! - IF (program_name == 'FPMD') THEN - CALL errore(' iosys ', 'FPMD not working with complex wavefunctions', 1) - END IF - -! IF ( which_orbdep .ne. 'or' ) THEN -! CALL errore(' iosys ','hf not working with complex wavefunctions', 1 ) -! ENDIF -! IF(empty_states_nbnd>0) THEN -! CALL errore(' iosys ',' empty states not yet implemented with complex wavefunctions', 1 ) -! ENDIF - - END IF - - RETURN - END SUBROUTINE set_control_flags - ! - !------------------------------------------------------------------------- - SUBROUTINE modules_setup() - !------------------------------------------------------------------------- - ! - USE control_flags, ONLY: program_name, lconstrain, lneb, & - tpre, thdyn, tksw, nbeg - - USE constants, ONLY: amu_au, pi - ! - USE input_parameters, ONLY: ibrav, celldm, trd_ht, & - cell_symmetry, rd_ht, a, b, c, cosab, cosac, cosbc, ntyp, nat, & - na_inp, sp_pos, rd_pos, rd_vel, atom_mass, atom_label, if_pos, & - atomic_positions, id_loc, sic, sic_epsilon, sic_rloc, ecutwfc, & - ecutrho, ecfixed, qcutz, q2sigma, tk_inp, wmass, & - ion_radius, emass, emass_cutoff, temph, fnoseh, nr1b, nr2b, nr3b, & - tempw, fnosep, nr1, nr2, nr3, nr1s, nr2s, nr3s, ekincw, fnosee, & - tturbo_inp, nturbo_inp, outdir, prefix, nkstot, & - xk, occupations, n_inner, fermi_energy, rotmass, occmass, & - rotation_damping, occupation_damping, occupation_dynamics, & - rotation_dynamics, degauss, smearing, nhpcl, nhptyp, ndega, & - nhgrp, fnhscl, cell_units, restart_mode, sic_alpha, & - niter_cold_restart, lambda_cold, rd_for - - USE input_parameters, ONLY: empty_states_maxstep, & - empty_states_ethr, & - iprnks_empty, nconstr_inp, iprnks, nprnks, & - ekin_conv_thr, nspin, f_inp, nelup, neldw, nbnd, & - nelec, press, cell_damping, cell_dofree, nprnks_empty, & - refg, greash, grease, greasp, epol, efield, tcg, maxiter, conv_thr, & - passop, tot_charge, multiplicity, tot_magnetization, ncolvar_inp, & - niter_cg_restart - ! - USE input_parameters, ONLY: wf_efield, wf_switch, sw_len, efx0, efy0, & - efz0, efx1, efy1, efz1, wfsd, wfdt, maxwfdt, & - wf_q, wf_friction, nit, nsd, nsteps, tolw, & - adapt, calwf, nwf, wffort, writev, & - wannier_index - ! - USE input_parameters, ONLY: abivol, abisur, pvar, fill_vac, & - scale_at, t_gauss, jellium, cntr, & - P_ext, P_in, P_fin, rho_thr, & - step_rad, Surf_t, dthr, R_j, h_j, & - delta_eps, delta_sigma, n_cntr, & - axis - ! - USE ions_base, ONLY: zv - USE cell_base, ONLY: cell_base_init, a1, a2, a3, cell_alat - USE cell_nose, ONLY: cell_nose_init - USE ions_base, ONLY: ions_base_init, greasp_ => greasp - USE sic_module, ONLY: sic_initval - USE ions_nose, ONLY: ions_nose_init - USE wave_base, ONLY: grease_ => grease - USE electrons_nose, ONLY: electrons_nose_init - USE printout_base, ONLY: printout_base_init - USE turbo, ONLY: turbo_init - USE efield_module, ONLY: efield_init - USE cg_module, ONLY: cg_init - USE pres_ai_mod, ONLY: pres_ai_init - ! - USE smallbox_grid_dimensions, ONLY: & - nr1b_ => nr1b, & - nr2b_ => nr2b, & - nr3b_ => nr3b - USE grid_dimensions, ONLY: & - nr1_ => nr1, & - nr2_ => nr2, & - nr3_ => nr3 - USE smooth_grid_dimensions, ONLY: & - nr1s_ => nr1s, & - nr2s_ => nr2s, & - nr3s_ => nr3s - USE charge_mix, ONLY: charge_mix_setup - USE kohn_sham_states, ONLY: ks_states_init - USE electrons_module, ONLY: electrons_empty_initval, empty_init, nupdwn_emp - USE electrons_base, ONLY: electrons_base_initval, nupdwn - !USE ensemble_dft, ONLY : ensemble_initval,tens, degauss, tsmear, etemp - USE ensemble_dft, ONLY: ensemble_initval, tens, tsmear, etemp - ! - USE wannier_base, ONLY: wannier_init - USE xml_io_base, ONLY: create_directory - ! - IMPLICIT NONE - ! - REAL(DP) :: alat_, massa_totale - REAL(DP) :: ethr_emp_inp - LOGICAL :: nbnd_provided - ! ... DIIS - INTEGER :: iss - ! - ! Subroutine Body - ! - IF (.NOT. has_been_read) & - CALL errore(' modules_setup ', ' input file has not been read yet! ', 1) - ! - ! ... Set cell base module - ! - massa_totale = SUM(atom_mass(1:ntyp)*na_inp(1:ntyp)) - ! - CALL cell_base_init(ibrav, celldm, trd_ht, cell_symmetry, rd_ht, & - cell_units, a, b, c, cosab, cosac, cosbc, wmass, & - massa_totale, press, cell_damping, greash, & - cell_dofree) - ! - alat_ = cell_alat() - - ! ... Set ions base module - - CALL ions_base_init(ntyp, nat, na_inp, sp_pos, rd_pos, rd_vel, & - atom_mass, atom_label, if_pos, atomic_positions, & - alat_, a1, a2, a3, ion_radius, rd_for) - - ! ... Set Values for the cutoff - - CALL ecutoffs_setup(ecutwfc, ecutrho, ecfixed, qcutz, q2sigma, refg) - - CALL gcutoffs_setup(alat_, tk_inp, nkstot, xk) - - ! ... - - grease_ = grease - greasp_ = greasp - ! - ! ... set thermostat parameter for cell, ions and electrons - ! - CALL cell_nose_init(temph, fnoseh) - ! - CALL ions_nose_init(tempw, fnosep, nhpcl, nhptyp, ndega, nhgrp, fnhscl) - ! - CALL electrons_nose_init(ekincw, fnosee) - - ! set box grid module variables - - nr1b_ = nr1b - nr2b_ = nr2b - nr3b_ = nr3b - - ! set size for potentials and charge density - ! (re-calculated automatically) - - nr1_ = nr1 - nr2_ = nr2 - nr3_ = nr3 - - ! set size for wavefunctions - ! (re-calculated automatically) - - nr1s_ = nr1s - nr2s_ = nr2s - nr3s_ = nr3s - ! - CALL turbo_init(tturbo_inp, nturbo_inp) - ! - write (6, *) "nbeg", nbeg - ! - if (nbeg < 0) THEN - call create_directory(outdir) - END IF - ! - - IF (.NOT. lneb) & - CALL printout_base_init(outdir, prefix) - - CALL efield_init(epol, efield) - - CALL cg_init(tcg, maxiter, conv_thr, passop, niter_cg_restart) - - ! - IF ((TRIM(sic) /= 'none') .and. (tpre .or. thdyn)) & - CALL errore(' module setup ', ' Stress is not yet implemented with SIC ', 1) - ! - CALL sic_initval(nat, id_loc, sic, sic_epsilon, sic_alpha, sic_rloc) - - ! - ! empty states - ! - ethr_emp_inp = ekin_conv_thr - IF (empty_states_ethr > 0.d0) ethr_emp_inp = empty_states_ethr - CALL empty_init(empty_states_maxstep, ethr_emp_inp) - - ! - CALL ks_states_init(nspin, nprnks, iprnks, nprnks_empty, iprnks_empty) - ! - ! kohn-sham states implies disk-io = 'high' - ! - DO iss = 1, nspin - tksw = tksw .OR. (nprnks(iss) > 0) - tksw = tksw .OR. (nprnks_empty(iss) > 0) - END DO - - ! Need to store if nbnd was provided in the input file prior to calling electrons_base_initval - nbnd_provided = (nbnd /= 0) - - CALL electrons_base_initval(zv, na_inp, ntyp, nelec, nelup, & - neldw, nbnd, nspin, occupations, f_inp, & - tot_charge, multiplicity, tot_magnetization) - - IF (TRIM(occupations) == "smearing") THEN - ! - etemp = degauss - tsmear = .TRUE. - ! - END IF - - CALL electrons_empty_initval(nbnd_provided, emass, emass_cutoff) - - CALL ensemble_initval(occupations, n_inner, fermi_energy, & - niter_cold_restart, lambda_cold, rotmass, & - occmass, rotation_damping, occupation_damping, & - occupation_dynamics, rotation_dynamics, degauss, & - smearing) - IF ((program_name == 'CP90') .AND. .NOT. tcg .AND. tens) & - CALL errore(' modules_setup ', 'Ensemble DFT implemented only with CG ', 1) - ! - ! ... variables for constrained dynamics are set here - ! - lconstrain = (ncolvar_inp + nconstr_inp > 0) - ! - ! - CALL wannier_init(wf_efield, wf_switch, sw_len, efx0, efy0, efz0, & - efx1, efy1, efz1, wfsd, wfdt, maxwfdt, wf_q, & - wf_friction, nit, nsd, nsteps, tolw, adapt, & - calwf, nwf, wffort, writev, wannier_index, & - restart_mode) - ! - ! ... initialize variables for clusters under pressure - ! - CALL pres_ai_init(abivol, abisur, pvar, fill_vac, scale_at, & - t_gauss, jellium, cntr, P_ext, P_in, P_fin, & - rho_thr, step_rad, Surf_t, dthr, R_j, h_j, & - delta_eps, delta_sigma, n_cntr, axis) - ! - RETURN - ! - END SUBROUTINE modules_setup - ! - ! -------------------------------------------------------- - ! - ! print out heading - ! - SUBROUTINE input_info() - - ! this subroutine print to standard output some parameters read from input - ! ---------------------------------------------- - - USE input_parameters, ONLY: restart_mode - USE control_flags, ONLY: nbeg, iprint, ndr, ndw, nomore - USE time_step, ONLY: delt - USE cp_electronic_mass, ONLY: emass, emass_cutoff - USE io_global, ONLY: meta_ionode, stdout - - IMPLICIT NONE - - IF (.NOT. has_been_read) & - CALL errore(' iosys ', ' input file has not been read yet! ', 1) - - IF (meta_ionode) THEN - WRITE (stdout, 500) nbeg, restart_mode, nomore, iprint, ndr, ndw - WRITE (stdout, 505) delt - WRITE (stdout, 510) emass - WRITE (stdout, 511) emass_cutoff - END IF - -500 FORMAT(3X, 'Restart Mode = ', I7, 3X, A15, /, & - 3X, 'Number of MD Steps = ', I7, /, & - 3X, 'Print out every ', I7, ' MD Steps', / & - 3X, 'Reads from unit = ', I7, /, & - 3X, 'Writes to unit = ', I7) -505 FORMAT(3X, 'MD Simulation time step = ', F10.2) -510 FORMAT(3X, 'Electronic fictitious mass (emass) = ', F10.2) -511 FORMAT(3X, 'emass cut-off = ', F10.2) -509 FORMAT(3X, 'Verlet algorithm for electron dynamics') -502 FORMAT(3X, 'An initial quench is performed') - - RETURN - END SUBROUTINE input_info - ! - ! ---------------------------------------------------------------- - ! - SUBROUTINE modules_info() - - USE input_parameters, ONLY: electron_dynamics - - USE control_flags, ONLY: program_name, tortho, tnosee, trane, ampre, & - trhor, tksw, evc_restart, tfor, tnosep, iprsta, & - thdyn, tnoseh - ! - USE electrons_nose, ONLY: electrons_nose_info - USE electrons_module, ONLY: empty_print_info - USE sic_module, ONLY: sic_info - USE wave_base, ONLY: frice, grease - USE ions_base, ONLY: fricp - USE ions_nose, ONLY: ions_nose_info - USE cell_nose, ONLY: cell_nose_info - USE cell_base, ONLY: frich - USE efield_module, ONLY: tefield, efield_info, tefield2, efield_info2 - USE io_global, ONLY: meta_ionode, stdout - ! - ! - IMPLICIT NONE - ! - IF (.NOT. has_been_read) & - CALL errore(' iosys ', ' input file has not been read yet! ', 1) - - IF (meta_ionode) THEN - ! - CALL cutoffs_print_info() - ! - IF (tortho) THEN - CALL orthogonalize_info() - ELSE - WRITE (stdout, 512) - END IF - ! - IF (TRIM(electron_dynamics) == 'sd') THEN - WRITE (stdout, 513) - ELSE IF (TRIM(electron_dynamics) == 'verlet') THEN - WRITE (stdout, 510) - frice = 0.d0 - ELSE IF (TRIM(electron_dynamics) == 'damp') THEN - tnosee = .FALSE. - WRITE (stdout, 509) - WRITE (stdout, 514) frice, grease - ELSE IF (TRIM(electron_dynamics) == 'cg') THEN - WRITE (stdout, 511) - ELSE - CALL errore(' input_info ', ' unknown electron dynamics ', 1) - END IF - ! - IF (tnosee) THEN - WRITE (stdout, 590) - CALL electrons_nose_info() - ELSE - WRITE (stdout, 535) - END IF - ! - IF (trane) THEN - WRITE (stdout, 515) ampre - END IF - ! - CALL electrons_print_info() - ! - CALL empty_print_info(stdout) - ! - CALL exch_corr_print_info() - - IF (trhor) THEN - WRITE (stdout, 720) - END IF - IF (tksw) THEN - WRITE (stdout, 722) - END IF - IF (evc_restart) THEN - WRITE (stdout, 7222) - END IF - ! - IF (tfor .AND. tnosep) fricp = 0.0d0 - ! - CALL ions_print_info() - ! - IF (tfor .AND. tnosep) CALL ions_nose_info() - ! - CALL constraint_info() - ! - IF (thdyn .AND. tnoseh) frich = 0.0d0 - ! - CALL cell_print_info() - ! - IF (thdyn .AND. tnoseh) CALL cell_nose_info() - ! - IF (program_name == 'FPMD') THEN - ! - CALL potential_print_info(stdout) - CALL sic_info() - ! - END IF - ! - IF (tefield) call efield_info() - IF (tefield2) call efield_info2() - - WRITE (stdout, 700) iprsta - - END IF - ! - RETURN - ! -509 FORMAT(3X, 'verlet algorithm for electron dynamics') -510 FORMAT(3X, 'Electron dynamics with newton equations') -511 FORMAT(3X, 'Electron dynamics with conjugate gradient') -512 FORMAT(3X, 'Orthog. with Gram-Schmidt') -513 FORMAT(3X, 'Electron dynamics with steepest descent') -514 FORMAT(3X, 'with friction frice = ', f7.4, ' , grease = ', f7.4) -515 FORMAT(3X, 'initial random displacement of el. coordinates with ', & - ' amplitude=', f10.6) -535 FORMAT(3X, 'Electron dynamics : the temperature is not controlled') -590 FORMAT(3X, 'Electron temperature control via nose thermostat') - ! -700 FORMAT(/, 3X, 'Verbosity: iprsta = ', i2,/) -720 FORMAT(3X, 'charge density is read from file') -722 FORMAT(3X, 'Wavefunctions will be written to file as Kohn-Sham states') -7222 FORMAT(3X, 'Kohn-Sham eigenfunctions will be written as restart wavefunctions') - ! - END SUBROUTINE modules_info - ! -END MODULE input diff --git a/quantum_espresso/kcp/CPV/io_pot_sic_xml.f90 b/quantum_espresso/kcp/CPV/io_pot_sic_xml.f90 deleted file mode 100644 index ef4b186fd..000000000 --- a/quantum_espresso/kcp/CPV/io_pot_sic_xml.f90 +++ /dev/null @@ -1,115 +0,0 @@ -! -! Copyright (C) 2001-2008 Quantum ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!---------------------------------------------------------------------------- -MODULE io_pot_sic_xml - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE xml_io_base, ONLY : create_directory, write_pot_xml, read_pot_xml, & - restart_dir - ! - PRIVATE - ! - PUBLIC :: write_pot_sic, read_pot_sic - ! - ! {read|write}_pot_only: read or write the real space charge density - ! {read|write}_pot_general: as above, plus read or write ldaU ns coeffs - ! and PAW becsum coeffs. - - INTERFACE write_pot_sic - MODULE PROCEDURE write_pot_sic_only - END INTERFACE - - INTERFACE read_pot_sic - MODULE PROCEDURE read_pot_sic_only - END INTERFACE - - CONTAINS - - !------------------------------------------------------------------------ - SUBROUTINE write_pot_sic_only( pot, extension ) - !------------------------------------------------------------------------ - ! - ! ... this routine writes the charge-density in xml format into the - ! ... '.save' directory - ! ... the '.save' directory is created if not already present - ! - USE io_files, ONLY : outdir, prefix - USE fft_base, ONLY : dfftp - USE io_global, ONLY : ionode - USE mp_global, ONLY : intra_pool_comm, inter_pool_comm - USE control_flags, ONLY : ndw - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: pot(dfftp%nnr) - CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: extension - ! - CHARACTER(LEN=256) :: dirname, file_base - CHARACTER(LEN=256) :: ext - REAL(DP), ALLOCATABLE :: potaux(:) - ! - ! - ext = ' ' - ! - !dirname = TRIM( tmp_dir ) // TRIM( prefix ) // '.save' - dirname = restart_dir( outdir, ndw ) - ! - CALL create_directory( dirname ) - ! - IF ( PRESENT( extension ) ) ext = '.' // TRIM( extension ) - ! - file_base = TRIM( dirname ) // '/sic_potential' // TRIM( ext ) - ! - ! - CALL write_pot_xml( file_base, pot(:), dfftp%nr1, dfftp%nr2, & - dfftp%nr3, dfftp%nr1x, dfftp%nr2x, dfftp%ipp, dfftp%npp, & - ionode, intra_pool_comm, inter_pool_comm ) - RETURN - ! - END SUBROUTINE write_pot_sic_only - ! - !------------------------------------------------------------------------ - SUBROUTINE read_pot_sic_only( pot, extension ) - !------------------------------------------------------------------------ - ! - ! ... this routine reads the effective potential in xml format from the - ! ... files saved into the '.save' directory - ! - USE io_files, ONLY : tmp_dir, prefix - USE fft_base, ONLY : dfftp - USE io_global, ONLY : ionode - USE mp_global, ONLY : intra_pool_comm, inter_pool_comm - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(OUT) :: pot(dfftp%nnr) - CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: extension - ! - CHARACTER(LEN=256) :: dirname, file_base - CHARACTER(LEN=256) :: ext - ! - ext = ' ' - ! - dirname = TRIM( tmp_dir ) // TRIM( prefix ) // '.save' - ! - IF ( PRESENT( extension ) ) ext = '.' // TRIM( extension ) - ! - file_base = TRIM( dirname ) // '/sic-potential' // TRIM( ext ) - ! - ! - CALL read_pot_xml( file_base, pot(:), dfftp%nr1, dfftp%nr2, & - dfftp%nr3, dfftp%nr1x, dfftp%nr2x, dfftp%ipp, dfftp%npp, & - ionode, intra_pool_comm, inter_pool_comm ) - ! - RETURN - ! - END SUBROUTINE read_pot_sic_only - ! -END MODULE io_pot_sic_xml diff --git a/quantum_espresso/kcp/CPV/ions_positions.f90 b/quantum_espresso/kcp/CPV/ions_positions.f90 deleted file mode 100644 index 602643e99..000000000 --- a/quantum_espresso/kcp/CPV/ions_positions.f90 +++ /dev/null @@ -1,514 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!------------------------------------------------------------------------------! -MODULE ions_positions -!------------------------------------------------------------------------------! - ! - USE kinds, ONLY : DP - USE atoms_type_module, ONLY : atoms_type, atoms_type_init - ! - IMPLICIT NONE - ! - ! ... Atomic positions arrays used in the cp codes during the dynamic - ! - REAL(DP), TARGET, ALLOCATABLE :: tau0(:,:), taum(:,:), taup(:,:) - REAL(DP), TARGET, ALLOCATABLE :: taus(:,:), tausm(:,:), tausp(:,:) - REAL(DP), TARGET, ALLOCATABLE :: vels(:,:), velsm(:,:), velsp(:,:) - REAL(DP), TARGET, ALLOCATABLE :: fion(:,:), fionm(:,:), fionp(:,:) - INTEGER, TARGET, ALLOCATABLE :: ityp(:), mobil(:,:) - ! - TYPE (atoms_type) :: atoms0, atomsp, atomsm - ! - CONTAINS - ! - ! ... meaning of some variables appearing in the folloving subs. - ! - ! nsp number of atomic species - ! nax maximum number of atoms per specie - ! nat total number of atoms - ! na(:) number of atoms per specie - ! pmass(:) mass (converted to a.u.) of ions - ! - ! - ! - SUBROUTINE allocate_ions_positions( nsp, nat ) - INTEGER, INTENT(IN) :: nsp, nat - ! - IF( ALLOCATED( tau0 ) ) DEALLOCATE( tau0 ) - IF( ALLOCATED( taum ) ) DEALLOCATE( taum ) - IF( ALLOCATED( taup ) ) DEALLOCATE( taup ) - IF( ALLOCATED( taus ) ) DEALLOCATE( taus ) - IF( ALLOCATED( tausm ) ) DEALLOCATE( tausm ) - IF( ALLOCATED( tausp ) ) DEALLOCATE( tausp ) - IF( ALLOCATED( vels ) ) DEALLOCATE( vels ) - IF( ALLOCATED( velsm ) ) DEALLOCATE( velsm ) - IF( ALLOCATED( velsp ) ) DEALLOCATE( velsp ) - IF( ALLOCATED( fion ) ) DEALLOCATE( fion ) - IF( ALLOCATED( fionm ) ) DEALLOCATE( fionm ) - IF( ALLOCATED( fionp ) ) DEALLOCATE( fionp ) - IF( ALLOCATED( ityp ) ) DEALLOCATE( ityp ) - IF( ALLOCATED( mobil ) ) DEALLOCATE( mobil ) - ! - ALLOCATE( tau0( 3, nat ) ) - ALLOCATE( taum( 3, nat ) ) - ALLOCATE( taup( 3, nat ) ) - ALLOCATE( taus( 3, nat ) ) - ALLOCATE( tausm( 3, nat ) ) - ALLOCATE( tausp( 3, nat ) ) - ALLOCATE( vels( 3, nat ) ) - ALLOCATE( velsm( 3, nat ) ) - ALLOCATE( velsp( 3, nat ) ) - ALLOCATE( fion( 3, nat ) ) - ALLOCATE( fionm( 3, nat ) ) - ALLOCATE( fionp( 3, nat ) ) - ALLOCATE( ityp( nat ) ) - ALLOCATE( mobil( 3, nat ) ) - ! - NULLIFY( atoms0 % taur ) - NULLIFY( atoms0 % taus ) - NULLIFY( atoms0 % vels ) - NULLIFY( atoms0 % for ) - NULLIFY( atoms0 % mobile ) - NULLIFY( atoms0 % ityp ) - NULLIFY( atomsm % taur ) - NULLIFY( atomsm % taus ) - NULLIFY( atomsm % vels ) - NULLIFY( atomsm % for ) - NULLIFY( atomsm % mobile ) - NULLIFY( atomsm % ityp ) - NULLIFY( atomsp % taur ) - NULLIFY( atomsp % taus ) - NULLIFY( atomsp % vels ) - NULLIFY( atomsp % for ) - NULLIFY( atomsp % mobile ) - NULLIFY( atomsp % ityp ) - ! - atoms0 % taur => tau0 - atoms0 % taus => taus - atoms0 % vels => vels - atoms0 % for => fion - atoms0 % mobile => mobil - atoms0 % ityp => ityp - atomsm % taur => taum - atomsm % taus => tausm - atomsm % vels => velsm - atomsm % for => fionm - atomsm % mobile => mobil - atomsm % ityp => ityp - atomsp % taur => taup - atomsp % taus => tausp - atomsp % vels => velsp - atomsp % for => fionp - atomsp % mobile => mobil - atomsp % ityp => ityp - ! - RETURN - END SUBROUTINE allocate_ions_positions - - !-------------------------------------------------------------------------- - - SUBROUTINE deallocate_ions_positions( ) - IF( ALLOCATED( tau0 ) ) DEALLOCATE( tau0 ) - IF( ALLOCATED( taum ) ) DEALLOCATE( taum ) - IF( ALLOCATED( taup ) ) DEALLOCATE( taup ) - IF( ALLOCATED( taus ) ) DEALLOCATE( taus ) - IF( ALLOCATED( tausm ) ) DEALLOCATE( tausm ) - IF( ALLOCATED( tausp ) ) DEALLOCATE( tausp ) - IF( ALLOCATED( vels ) ) DEALLOCATE( vels ) - IF( ALLOCATED( velsm ) ) DEALLOCATE( velsm ) - IF( ALLOCATED( velsp ) ) DEALLOCATE( velsp ) - IF( ALLOCATED( fion ) ) DEALLOCATE( fion ) - IF( ALLOCATED( fionm ) ) DEALLOCATE( fionm ) - IF( ALLOCATED( fionp ) ) DEALLOCATE( fionp ) - IF( ALLOCATED( ityp ) ) DEALLOCATE( ityp ) - IF( ALLOCATED( mobil ) ) DEALLOCATE( mobil ) - NULLIFY( atoms0 % taur ) - NULLIFY( atoms0 % taus ) - NULLIFY( atoms0 % vels ) - NULLIFY( atoms0 % for ) - NULLIFY( atoms0 % mobile ) - NULLIFY( atoms0 % ityp ) - NULLIFY( atomsm % taur ) - NULLIFY( atomsm % taus ) - NULLIFY( atomsm % vels ) - NULLIFY( atomsm % for ) - NULLIFY( atomsm % mobile ) - NULLIFY( atomsm % ityp ) - NULLIFY( atomsp % taur ) - NULLIFY( atomsp % taus ) - NULLIFY( atomsp % vels ) - NULLIFY( atomsp % for ) - NULLIFY( atomsp % mobile ) - NULLIFY( atomsp % ityp ) - RETURN - END SUBROUTINE deallocate_ions_positions - - - - !-------------------------------------------------------------------------- - SUBROUTINE ions_hmove( taus, tausm, iforce, pmass, fion, ainv, delt, na, nsp ) - !-------------------------------------------------------------------------- - ! - REAL(DP), INTENT(IN) :: tausm(:,:), pmass(:), fion(:,:) - INTEGER, INTENT(IN) :: iforce(:,:) - REAL(DP), INTENT(IN) :: ainv(3,3), delt - REAL(DP), INTENT(OUT) :: taus(:,:) - INTEGER, INTENT(IN) :: na(:), nsp - INTEGER :: is, ia, i, isa - REAL(DP) :: dt2by2, fac, fions(3) - ! - ! - dt2by2 = 0.5D0 * delt * delt - ! - isa = 0 - ! - DO is = 1, nsp - ! - fac = dt2by2 / pmass(is) - ! - DO ia = 1, na(is) - ! - isa = isa + 1 - ! - DO i = 1, 3 - ! - fions(i) = fion(1,isa) * ainv(i,1) + & - fion(2,isa) * ainv(i,2) + & - fion(3,isa) * ainv(i,3) - ! - END DO - ! - taus(:,isa) = tausm(:,isa) + iforce(:,isa) * fac * fions(:) - ! - END DO - - END DO - ! - RETURN - ! - END SUBROUTINE ions_hmove - ! - !-------------------------------------------------------------------------- - SUBROUTINE ions_move( tausp, taus, tausm, iforce, pmass, fion, ainv, & - delt, na, nsp, fricp, hgamma, vels, tsdp, tnosep, & - fionm, vnhp, velsp, velsm, nhpcl, nhpdim, atm2nhp ) - !-------------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: taus(:,:), tausm(:,:), pmass(:), fion(:,:) - INTEGER, INTENT(IN) :: iforce(:,:) - REAL(DP), INTENT(IN) :: ainv(3,3), delt - REAL(DP), INTENT(OUT) :: tausp(:,:) - INTEGER, INTENT(IN) :: na(:), nsp, nhpcl, nhpdim, atm2nhp(:) - REAL(DP), INTENT(IN) :: fricp, hgamma(3,3), vels(:,:) - LOGICAL, INTENT(IN) :: tsdp, tnosep - REAL(DP), INTENT(INOUT) :: fionm(:,:) - REAL(DP), INTENT(IN) :: vnhp(nhpcl,nhpdim) - REAL(DP), INTENT(OUT) :: velsp(:,:) - REAL(DP), INTENT(IN) :: velsm(:,:) - INTEGER :: is, ia, i, isa - REAL(DP) :: dt2by2, dt2, twodel - REAL(DP) :: verl1, verl2, verl3 - ! - ! - dt2by2 = 0.5D0 * delt * delt - dt2 = delt * delt - twodel = 2.D0 * delt - ! - verl1 = 2.D0 / ( 1.D0 + fricp ) - verl2 = 1.D0 - verl1 - verl3 = dt2 / ( 1.D0 + fricp ) - ! - IF ( tsdp ) THEN - ! - isa = 0 - ! - DO is = 1, nsp - ! - DO ia = 1, na(is) - ! - isa = isa + 1 - ! - DO i = 1, 3 - ! - tausp(i,isa) = taus(i,isa) - pmass(is) * & - ( hgamma(i,1) * vels(1,isa) + & - hgamma(i,2) * vels(2,isa) + & - hgamma(i,3) * vels(3,isa) ) + & - iforce(i,isa) * dt2 / pmass(is) * & - ( fion(1,isa) * ainv(i,1) + & - fion(2,isa) * ainv(i,2) + & - fion(3,isa) * ainv(i,3) ) - ! - END DO - ! - END DO - ! - END DO - ! - ELSE IF ( tnosep ) THEN - ! - isa = 0 - ! - DO is = 1, nsp - ! - DO ia = 1, na(is) - ! - isa = isa + 1 - ! - DO i = 1, 3 - ! - fionm(i,isa) = ainv(i,1) * fion(1,isa) + & - ainv(i,2) * fion(2,isa) + & - ainv(i,3) * fion(3,isa) - & - vnhp(1,atm2nhp(isa)) * vels(i,isa) * pmass(is) - & - pmass(is) * ( hgamma(i,1) * vels(1,isa) + & - hgamma(i,2) * vels(2,isa) + & - hgamma(i,3) * vels(3,isa) ) - ! - END DO - ! - tausp(:,isa) = 2.D0 * taus(:,isa) - tausm(:,isa) + & - dt2 * iforce(:,isa) * fionm(:,isa) / pmass(is) - ! - velsp(:,isa) = velsm(:,isa) + twodel * fionm(:,isa) / pmass(is) - ! - END DO - ! - END DO - ! - ELSE - ! - isa = 0 - ! - DO is = 1, nsp - ! - DO ia = 1, na(is) - ! - isa = isa + 1 - ! - DO i = 1, 3 - ! - tausp(i,isa) = verl1 * taus(i,isa) + verl2 * tausm(i,isa) + & - verl3 / pmass(is) * iforce(i,isa) * & - ( ainv(i,1) * fion(1,isa) + & - ainv(i,2) * fion(2,isa) + & - ainv(i,3) * fion(3,isa) ) - & - verl3 * iforce(i,isa) * & - ( hgamma(i,1) * vels(1,isa) + & - hgamma(i,2) * vels(2,isa) + & - hgamma(i,3) * vels(3,isa) ) - ! - velsp(i,isa) = velsm(i,isa) - 4.D0 * fricp * vels(i,isa) + & - twodel / pmass(is) * iforce(i,isa) * & - ( ainv(i,1) * fion(1,isa) + & - ainv(i,2) * fion(2,isa) + & - ainv(i,3) * fion(3,isa) ) - & - twodel * iforce(i,isa) * & - ( hgamma(i,1) * vels(1,isa) + & - hgamma(i,2) * vels(2,isa) + & - hgamma(i,3) * vels(3,isa) ) - ! - END DO - ! - END DO - ! - END DO - ! - END IF - ! - RETURN - ! - END SUBROUTINE ions_move - ! - ! - SUBROUTINE set_velocities( tausm, taus0, vels, iforce, nat, delt) - USE kinds, ONLY : DP - IMPLICIT NONE - INTEGER, INTENT(IN) :: nat - REAL(DP) :: tausm( 3, nat ), taus0( 3, nat ) - REAL(DP), INTENT(IN) :: delt - REAL(DP), INTENT(IN) :: vels( 3, nat ) - INTEGER, INTENT(IN) :: iforce( 3, nat ) - INTEGER :: i, ia - DO ia = 1, nat - tausm( :, ia ) = taus0( :, ia ) - DO i = 1, 3 - IF( iforce( i, ia ) > 0 ) THEN - taus0( i, ia ) = taus0( i, ia ) + vels( i, ia ) * delt - END IF - ENDDO - END DO - RETURN - END SUBROUTINE set_velocities - ! - ! - ! - ! - - SUBROUTINE atoms_init(atoms_m, atoms_0, atoms_p, stau, ind_srt, if_pos, atml, h, nat, nsp, na, pmass ) - - ! Allocate and fill the three atoms structure using scaled position an cell - - USE printout_base, ONLY : printout_pos - USE io_global, ONLY : ionode, stdout - - IMPLICIT NONE - - TYPE (atoms_type) :: atoms_0, atoms_p, atoms_m - REAL(DP), INTENT(IN) :: h( 3, 3 ) - REAL(DP), INTENT(IN) :: stau(:,:) - CHARACTER(LEN=3), INTENT(IN) :: atml(:) - INTEGER, INTENT(IN) :: ind_srt( : ) - INTEGER, INTENT(IN) :: if_pos( :, : ) - INTEGER, INTENT(IN) :: nat, nsp - INTEGER, INTENT(IN) :: na( : ) - REAL(DP), INTENT(IN) :: pmass( : ) - - CHARACTER(LEN=3), ALLOCATABLE :: labels( : ) - LOGICAL, ALLOCATABLE :: ismb(:,:) - INTEGER :: ia, is, isa - LOGICAL :: nofx - - ALLOCATE( ismb( 3, nat ) ) - - ismb = .TRUE. - nofx = .TRUE. - DO isa = 1, nat - ia = ind_srt( isa ) - ismb( 1, isa ) = ( if_pos( 1, ia ) /= 0 ) - ismb( 2, isa ) = ( if_pos( 2, ia ) /= 0 ) - ismb( 3, isa ) = ( if_pos( 3, ia ) /= 0 ) - nofx = nofx .AND. ismb( 1, isa ) - nofx = nofx .AND. ismb( 2, isa ) - nofx = nofx .AND. ismb( 3, isa ) - END DO - - CALL atoms_type_init(atoms_m, stau, ismb, atml, pmass, na, nsp, h) - CALL atoms_type_init(atoms_0, stau, ismb, atml, pmass, na, nsp, h) - CALL atoms_type_init(atoms_p, stau, ismb, atml, pmass, na, nsp, h) - - IF( ionode ) THEN - ! - ALLOCATE( labels( nat ) ) - ! - isa = 0 - DO is = 1, nsp - DO ia = 1, na( is ) - isa = isa + 1 - labels( isa ) = atml( is ) - END DO - END DO - - WRITE( stdout, * ) - - CALL printout_pos( stdout, stau, nat, label = labels, & - head = 'Scaled positions from standard input' ) - - IF( .NOT. nofx ) THEN - WRITE( stdout, 10 ) - 10 FORMAT( /, & - 3X, 'Position components with 0 are kept fixed', /, & - 3X, ' ia x y z ' ) - DO isa = 1, nat - ia = ind_srt( isa ) - WRITE( stdout, 20 ) isa, if_pos( 1, ia ), if_pos( 2, ia ), if_pos( 3, ia ) - END DO - 20 FORMAT( 3X, I4, I3, I3, I3 ) - END IF - - DEALLOCATE( labels ) - - END IF - - DEALLOCATE( ismb ) - - RETURN - END SUBROUTINE atoms_init - -! -------------------------------------------------------------------------- - - SUBROUTINE ions_shiftval(atoms_m, atoms_0, atoms_p) - - ! Update ionic positions and velocities in atoms structures - - IMPLICIT NONE - TYPE(atoms_type) :: atoms_m, atoms_0, atoms_p - INTEGER :: ub - - ub = atoms_m%nat - atoms_m%taus(1:3,1:ub) = atoms_0%taus(1:3,1:ub) - atoms_m%vels(1:3,1:ub) = atoms_0%vels(1:3,1:ub) - atoms_m%for(1:3,1:ub) = atoms_0%for(1:3,1:ub) - atoms_0%taus(1:3,1:ub) = atoms_p%taus(1:3,1:ub) - atoms_0%vels(1:3,1:ub) = atoms_p%vels(1:3,1:ub) - atoms_0%for(1:3,1:ub) = atoms_p%for(1:3,1:ub) - - RETURN - END SUBROUTINE ions_shiftval - - - - - REAL(DP) FUNCTION max_ion_forces( atoms ) - - IMPLICIT NONE - TYPE (atoms_type) :: atoms - INTEGER :: ia - REAL(DP) :: fmax - fmax = 0.0d0 - DO ia = 1, atoms%nat - IF( atoms%mobile(1, ia) > 0 ) fmax = MAX( fmax, ABS( atoms%for(1, ia) ) ) - IF( atoms%mobile(2, ia) > 0 ) fmax = MAX( fmax, ABS( atoms%for(2, ia) ) ) - IF( atoms%mobile(3, ia) > 0 ) fmax = MAX( fmax, ABS( atoms%for(3, ia) ) ) - END DO - max_ion_forces = fmax - RETURN - END FUNCTION max_ion_forces - -! -! - - SUBROUTINE resort_position( pos, fion, atoms, isrt, ht ) - - - ! This subroutine copys positions and forces into - ! array "pos" and "for" using the same atoms sequence - ! as in the input file - - USE cell_base, ONLY: s_to_r - USE cell_base, ONLY: boxdimensions, pbcs - - IMPLICIT NONE - - REAL(DP), INTENT(OUT) :: pos(:,:), fion(:,:) - TYPE (atoms_type), INTENT(IN) :: atoms - TYPE (boxdimensions), INTENT(IN) :: ht - INTEGER, INTENT(IN) :: isrt( : ) - INTEGER :: ia, is, isa, ipos - - isa = 0 - DO is = 1, atoms%nsp - DO ia = 1, atoms%na(is) - isa = isa + 1 - ipos = isrt( isa ) - CALL s_to_r( atoms%taus( : , isa ), pos( :, ipos ), ht ) - fion( :, ipos ) = atoms%for( : , isa ) - END DO - END DO - - RETURN - END SUBROUTINE resort_position - - - - ! -!------------------------------------------------------------------------------! -END MODULE ions_positions -!------------------------------------------------------------------------------! diff --git a/quantum_espresso/kcp/CPV/ksstates.f90 b/quantum_espresso/kcp/CPV/ksstates.f90 deleted file mode 100644 index b579dfc7f..000000000 --- a/quantum_espresso/kcp/CPV/ksstates.f90 +++ /dev/null @@ -1,224 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - - -MODULE kohn_sham_states - - - USE io_files, ONLY: ksunit, ks_file, ks_emp_file - - IMPLICIT NONE - SAVE - - PRIVATE - - ! ... print KS states to file KS.indx_ksout if ksout true - LOGICAL :: tksout - LOGICAL :: tksout_emp - - INTEGER, ALLOCATABLE :: indx_ksout(:,:) ! (state inds, spin indxs) - INTEGER, ALLOCATABLE :: n_ksout(:) ! (spin indxs) - INTEGER, ALLOCATABLE :: indx_ksout_emp(:,:) ! (state inds, spin indxs) - INTEGER, ALLOCATABLE :: n_ksout_emp(:) ! (spin indxs) - - PUBLIC :: ks_states_init, ks_states_closeup - PUBLIC :: n_ksout, indx_ksout, tksout, print_all_states - -! ---------------------------------------------- -CONTAINS -! ---------------------------------------------- - - - SUBROUTINE ks_states_init( nspin, nprnks, iprnks, nprnks_emp, iprnks_emp ) - - INTEGER, INTENT(IN) :: nspin, nprnks(:), nprnks_emp(:) - INTEGER, INTENT(IN) :: iprnks(:,:) - INTEGER, INTENT(IN) :: iprnks_emp(:,:) - - INTEGER :: i, k, nstates - - ! ... Tell the code which Kohn-Sham state should be printed to file - ! - IF( ALLOCATED( n_ksout ) ) DEALLOCATE( n_ksout ) - IF( ALLOCATED( indx_ksout ) ) DEALLOCATE( indx_ksout ) - ! - tksout = ANY( nprnks > 0 ) - ! - IF( tksout ) THEN - nstates = MAXVAL( nprnks ) - ALLOCATE( n_ksout( nspin ) ) - ALLOCATE( indx_ksout( nstates, nspin) ) - n_ksout( 1:nspin ) = nprnks( 1:nspin ) - DO i = 1, nspin - DO k = 1, nprnks( i ) - indx_ksout( k, i ) = iprnks( k, i ) - END DO - END DO - END IF - - IF( ALLOCATED( n_ksout_emp ) ) DEALLOCATE( n_ksout_emp ) - IF( ALLOCATED( indx_ksout_emp ) ) DEALLOCATE( indx_ksout_emp ) - ! - tksout_emp = ANY( nprnks_emp > 0 ) - ! - IF( tksout_emp ) THEN - nstates = MAXVAL( nprnks_emp ) - ALLOCATE( n_ksout_emp( nspin ) ) - ALLOCATE( indx_ksout_emp( nstates, nspin ) ) - n_ksout_emp( 1:nspin ) = nprnks_emp( 1:nspin ) - DO i = 1, nspin - DO k = 1, n_ksout_emp( i ) - indx_ksout_emp( k, i ) = iprnks_emp( k, i ) - END DO - END DO - END IF - - RETURN - END SUBROUTINE ks_states_init - -! ---------------------------------------------- - - SUBROUTINE ks_states_closeup() - IF( ALLOCATED( indx_ksout ) ) DEALLOCATE( indx_ksout ) - IF( ALLOCATED( n_ksout ) ) DEALLOCATE( n_ksout ) - tksout = .FALSE. - IF( ALLOCATED( indx_ksout_emp ) ) DEALLOCATE( indx_ksout_emp ) - IF( ALLOCATED( n_ksout_emp ) ) DEALLOCATE( n_ksout_emp ) - tksout_emp = .FALSE. - RETURN - END SUBROUTINE ks_states_closeup - -! ---------------------------------------------- -! ---------------------------------------------- - - SUBROUTINE print_all_states( ctot, iupdwn_tot, nupdwn_tot ) - - USE kinds, ONLY : DP - USE io_global, ONLY : ionode - USE io_global, ONLY : stdout - USE electrons_module, ONLY : nupdwn_emp - USE electrons_base, ONLY : nupdwn, nspin - - IMPLICIT NONE - - ! ... declare subroutine arguments - COMPLEX(DP), INTENT(IN) :: ctot(:,:) - INTEGER, INTENT(IN) :: iupdwn_tot(2) - INTEGER, INTENT(IN) :: nupdwn_tot(2) - - ! ... declare other variables - INTEGER :: i, iss, iks, itot - - CHARACTER(LEN=256) :: file_name - CHARACTER(LEN=10), DIMENSION(2) :: spin_name - CHARACTER (LEN=6), EXTERNAL :: int_to_char - - IF( tksout .OR. tksout_emp ) THEN - - IF (ionode) THEN - WRITE( stdout,*) - WRITE( stdout,'( " Khon Sham state")') - WRITE( stdout,'( " ---------------")') - END IF - - IF( nspin == 2 ) THEN - spin_name(1) = '_UP_' - spin_name(2) = '_DW_' - ELSE - spin_name(1) = '_' - spin_name(2) = '_' - END IF - - DO iss = 1, nspin - IF( tksout ) THEN - DO i = 1, n_ksout(iss) - iks = indx_ksout(i, iss) - IF( ( iks > 0 ) .AND. ( iks <= nupdwn( iss ) ) ) THEN - itot = iks + iupdwn_tot(iss) - 1 - file_name = TRIM( ks_file ) // & - & trim(spin_name(iss)) // trim( int_to_char( iks ) ) - CALL print_ks_states( ctot( :, itot ), file_name ) - END IF - END DO - END IF - IF( tksout_emp ) THEN - DO i = 1, n_ksout_emp(iss) - iks = indx_ksout_emp(i, iss) - IF( ( iks > 0 ) .AND. ( iks <= nupdwn_emp( iss ) ) ) THEN - itot = iks + iupdwn_tot(iss) + nupdwn( iss ) - 1 - file_name = TRIM( ks_emp_file ) // & - & trim(spin_name(iss)) // trim( int_to_char( iks ) ) - CALL print_ks_states( ctot( :, itot ), file_name ) - END IF - END DO - END IF - END DO - - END IF - - RETURN - ! ... - END SUBROUTINE print_all_states - - -! ---------------------------------------------- -! ---------------------------------------------- - - SUBROUTINE print_ks_states( c, file_name ) - - USE kinds - USE mp, ONLY: mp_sum - USE io_global, ONLY: ionode - USE io_global, ONLY: stdout - USE gvecw, ONLY: ngw - USE fft_base, ONLY: dfftp, dffts - USE grid_dimensions, ONLY: nr1, nr2, nr3, nr1x, nr2x, nnrx - USE cp_interfaces, ONLY: invfft - USE xml_io_base, ONLY: write_rho_xml - USE mp_global, ONLY: intra_image_comm - - IMPLICIT NONE - - COMPLEX(DP), INTENT(IN) :: c(:) - CHARACTER(LEN=*), INTENT(IN) :: file_name - REAL(DP), ALLOCATABLE :: rpsi2(:) - COMPLEX(DP), ALLOCATABLE :: psi(:) - INTEGER :: i - REAL(DP) :: charge - - ALLOCATE( psi( nnrx ) ) - ALLOCATE( rpsi2( nnrx ) ) - - CALL c2psi( psi, dffts%nnr, c, c, ngw, 1 ) - CALL invfft( 'Wave', psi, dffts ) - - DO i = 1, nnrx - rpsi2( i ) = DBLE( psi( i ) )**2 - END DO - charge = SUM( rpsi2 ) - - CALL write_rho_xml( file_name, rpsi2, & - nr1, nr2, nr3, nr1x, nr2x, dfftp%ipp, dfftp%npp ) - - CALL mp_sum( charge, intra_image_comm ) - - IF ( ionode ) THEN - WRITE( stdout,'(3X,A15," integrated charge : ",F14.5)') & - & TRIM(file_name), charge / DBLE(nr1*nr2*nr3) - END IF - - DEALLOCATE( rpsi2, psi ) - ! ... - RETURN - ! ... - END SUBROUTINE print_ks_states - -! ---------------------------------------------- -! -END MODULE kohn_sham_states diff --git a/quantum_espresso/kcp/CPV/main.f90 b/quantum_espresso/kcp/CPV/main.f90 deleted file mode 100644 index 79d5dcdc8..000000000 --- a/quantum_espresso/kcp/CPV/main.f90 +++ /dev/null @@ -1,683 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . - -SUBROUTINE cpmain_x(tau, fion, etot) - -! this routine does some initialization, then handles for the main loop -! for Car-Parrinello dynamics -! ---------------------------------------------- -! this version features: -! Parrinello-Rahman dynamics -! generic k-points calculation -! Nose' thermostat for ions and electrons -! velocity rescaling for ions -! Kleinman-Bylander fully non-local pseudopotentials -! support for local and s, p and d nonlocality -! generalized gradient corrections -! core corrections -! calculus of polarizability -! DIIS minimization for electrons -! ions dynamics with DIIS electronic minimization at each step -! -------------------------------------------- -! -! input units -! NDR > 50: system configuration at start (not used if nbeg.LT.0) -! (generated by a previous run, see NDW below) -! 5 : standard input (may be redirected, see start.F) -! 10 : pseudopotential data (must exist for the program to run) -! -! output units -! NDW > 50: system configuration (may be used to restart the program, -! see NDR above) -! 6 : standard output (may be redirected, see start.F) -! 17 : charge density ( file name CHARGE_DENSITY ) -! 18 : Kohn Sham states ( file name KS... ) -! 19 : file EMPTY_STATES.WF -! 20 : file STRUCTUR_FACTOR -! 29 : atomic velocities -! 30 : conductivity -! 31 : eigenvalues -! 32 : polarization -! 33 : energies + pressure + volume + msd -! 34 : energies -! 35 : atomic trajectories -! 36 : cell trajectories -! 37 : atomic forces -! 38 : internal stress tensor -! 39 : thermostats energies -! 40 : thermal stress tensor -! ---------------------------------------------- - -! ... declare modules - USE kinds - USE control_flags, ONLY: nomore, tprnfor, tpre, & - isave, iprint, & - tfor, thdyn, tsde, tsdp, tsdc, & - tortho, iprsta, tprnsfac, tdipole, textfor, & - tnosee, tnosep, force_pairing, tconvthrs, convergence_criteria, tionstep, nstepe, & - ekin_conv_thr, conv_elec, lneb, tnoseh, & - gamma_only, do_wf_cmplx - USE atoms_type_module, ONLY: atoms_type - USE cell_base, ONLY: press, wmass, boxdimensions, cell_force, cell_move, gethinv, & - cell_update_vel, cell_init - USE polarization, ONLY: ddipole - USE energies, ONLY: dft_energy_type, debug_energies - USE dener, ONLY: dekin6, denl - - USE cp_interfaces, ONLY: printout, print_sfac - USE cp_interfaces, ONLY: empty_cp - USE cp_interfaces, ONLY: vofrhos, localisation - USE cp_interfaces, ONLY: rhoofr - USE cp_interfaces, ONLY: eigs, ortho, elec_fakekine - USE cp_interfaces, ONLY: writefile, readfile, strucf, phfacs - USE cp_interfaces, ONLY: runcp_uspp, runcp_uspp_force_pairing - - USE electrons_module, ONLY: nbsp_emp - USE check_stop, ONLY: check_stop_now - USE time_step, ONLY: tps, delt - USE wave_types - use wave_base, only: frice - USE io_global, ONLY: ionode - USE io_global, ONLY: stdout - USE input, ONLY: iosys - USE cell_base, ONLY: cell_kinene, velh - USE cell_base, ONLY: frich, greash, iforceh, tpiba2 - USE stick_base, ONLY: pstickset - USE ions_base, ONLY: taui, cdmi, nat, nsp, fricp, pmass, iforce, extfor - USE sic_module, ONLY: self_interaction, nat_localisation - USE ions_base, ONLY: if_pos, ind_srt, ions_thermal_stress, ions_vel, ions_kinene - USE ions_base, ONLY: ions_temp - USE constants, ONLY: au_ps - USE electrons_base, ONLY: nupdwn, nspin, f, iupdwn, nbsp - USE electrons_nose, ONLY: electrons_nosevel, electrons_nose_shiftvar, electrons_noseupd, & - vnhe, xnhe0, xnhem, xnhep, qne, ekincw - USE cell_nose, ONLY: cell_nosevel, cell_noseupd, cell_nose_shiftvar, & - vnhh, xnhh0, xnhhm, xnhhp, qnh, temph - USE cell_base, ONLY: cell_gamma, s_to_r - USE grid_subroutines, ONLY: realspace_grids_init, realspace_grids_para - USE uspp, ONLY: vkb, nkb, becsum - USE cdvan, ONLY: dbec - ! - USE reciprocal_vectors, ONLY: & - g, & ! G-vectors square modulus - ggp, & ! - gx, & ! G-vectors component - mill_l, & ! G-vectors generators - gcutw, & ! Wave function cut-off ( units of (2PI/alat)^2 => tpiba2 ) - gcutp, & ! Potentials and Charge density cut-off ( same units ) - gcuts, & ! Smooth mesh Potentials and Charge density cut-off ( same units ) - gkcut, & ! Wave function augmented cut-off (take into account all G + k_i , same units) - ngw, & ! - ngm - ! - USE recvecs_subroutines, ONLY: recvecs_init - ! - USE wavefunctions_module, ONLY: & ! electronic wave functions - c0, & ! c0(:,:) ! wave functions at time t - cm, & ! cm(:,:) ! wave functions at time t-delta t - cp ! cp(:,:) ! wave functions at time t+delta t - ! - USE grid_dimensions, ONLY: nr1, nr2, nr3 - ! - USE ions_nose, ONLY: ions_nose_shiftvar, vnhp, xnhpp, xnhp0, xnhpm, ions_nosevel, ndega, atm2nhp, & - ions_noseupd, qnp, kbt, nhpcl, nhpdim, nhpbeg, nhpend, gkbt2nhp, ekin2nhp - USE core, ONLY: deallocate_core - USE local_pseudo, ONLY: deallocate_local_pseudo - USE printout_base, ONLY: printout_base_init - USE cp_main_variables, ONLY: ei1, ei2, ei3, eigr, sfac, lambda, & - ht0, htm, htp, rhor, vpot, rhog, rhos, wfill, & - acc, edft, nfi, bec, becdr, & - ema0bg, descla, irb, eigrb, iprint_stdout - USE ions_positions, ONLY: atoms0, atomsp, atomsm, ions_move, & - max_ion_forces, ions_shiftval, resort_position - USE cg_module, ONLY: tcg - USE cp_electronic_mass, ONLY: emass, emass_cutoff, emass_precond - ! - IMPLICIT NONE - ! - REAL(DP) :: tau(:, :) - REAL(DP) :: fion(:, :) - REAL(DP) :: etot - -! ... declare functions - -! ... declare other variables - INTEGER :: nstep_this_run, iunit, is, i - - REAL(DP) :: ekinc, ekcell, ekinp, erhoold, maxfion, ekinpr - REAL(DP) :: derho - REAL(DP) :: hgamma(3, 3) = 0.0d0 - REAL(DP) :: temphh(3, 3) = 0.0d0 - REAL(DP) :: fcell(3, 3) = 0.0d0 - REAL(DP) :: newh(3, 3) = 0.0d0 - REAL(DP) :: fion_tot(3) = 0.0d0 - - LOGICAL :: ttforce, tstress - LOGICAL :: ttprint, ttsave, ttdipole, ttexit - LOGICAL :: tstop, tconv, doions - LOGICAL :: topen, ttempst - LOGICAL :: ttconvchk - LOGICAL :: tstdout - - REAL(DP) :: fccc, ccc, dt2bye, intermed - REAL(DP) :: temps(nat), tempp - REAL(DP), DIMENSION(:, :, :), ALLOCATABLE :: lambda_dumb - - LOGICAL :: lgam - - ! - ! ... end of declarations - ! - lgam = gamma_only .and. .not. do_wf_cmplx - ! - erhoold = 1.0d+20 ! a very large number - ekinc = 0.0_DP - ekcell = 0.0_DP - fccc = 1.0d0 - nstep_this_run = 0 - - IF (tcg) & - CALL errore(' fpmd ', ' CG not allowed, use CP instead ', 1) - - ttexit = .FALSE. - - MAIN_LOOP: DO - - call start_clock('main_loop') - - ! ... increment simulation steps counter - ! - nfi = nfi + 1 - - ! ... increment run steps counter - ! - nstep_this_run = nstep_this_run + 1 - - ! ... Increment the integral time of the simulation - ! - tps = tps + delt*au_ps - - ! ... set the right flags for the current MD step - ! - ttprint = (MOD(nfi, iprint) == 0) .OR. (iprsta > 2) .OR. ttexit - tstdout = (MOD(nfi, iprint_stdout) == 0) .OR. (iprsta > 2) .OR. ttexit - ! - ttsave = MOD(nfi, isave) == 0 - ! - ttconvchk = tconvthrs%active .AND. (MOD(nfi, tconvthrs%nstep) == 0) - ! - ttdipole = ttprint .AND. tdipole - ttforce = tfor .OR. (ttprint .AND. tprnfor) - tstress = thdyn .OR. (ttprint .AND. tpre) - ttempst = ttprint .AND. (nbsp_emp > 0) - doions = .TRUE. - - IF (ionode .AND. tstdout) THEN - ! - WRITE (stdout, fmt='( /, " * Physical Quantities at step:", I6 )') nfi - WRITE (stdout, fmt='( /, " Simulated time t = ", D15.8, " ps" )') tps - ! - END IF - - IF (tnosee) THEN - fccc = 1.0d0/(1.0d0 + vnhe*delt*0.5d0) - ELSE IF (tsde) THEN - fccc = 1.0d0 - ELSE - fccc = 1.0d0/(1.0d0 + frice) - END IF - - ! - ! ... calculate thermostat velocity - ! - - IF (tfor .AND. tnosep .AND. doions) THEN - ! - ! ... Determines D(Xnos)/DT dynamically - ! - CALL ions_nosevel(vnhp, xnhp0, xnhpm, delt, nhpcl, nhpdim) - ! - END IF - - IF (tnosee) THEN - ! - call electrons_nosevel(vnhe, xnhe0, xnhem, delt) - ! - END IF - - IF (thdyn .AND. tnoseh) THEN - ! - CALL cell_nosevel(vnhh, xnhh0, xnhhm, delt) - ! - velh(:, :) = 2.d0*(ht0%hmat(:, :) - htm%hmat(:, :))/delt - velh(:, :) - ! - END IF - - IF (thdyn) THEN - ! - ! ... the simulation cell isn't fixed, recompute the reciprocal lattice - ! - CALL newinit(ht0%hmat) - ! - CALL newnlinit() - ! - CALL emass_precond(ema0bg, ggp, ngw, tpiba2, emass_cutoff) - ! - END IF - - IF (tfor .OR. thdyn) THEN - ! - ! ... ionic positions aren't fixed, recompute structure factors - ! - CALL phfacs(ei1, ei2, ei3, eigr, mill_l, atoms0%taus, nr1, nr2, nr3, atoms0%nat) - ! - CALL strucf(sfac, ei1, ei2, ei3, mill_l, ngm) - ! - CALL prefor(eigr, vkb) - ! - END IF - - IF (thdyn) THEN - ! - ! the simulation cell isn't fixed, recompute local - ! pseudopotential Fourier expansion - ! - CALL formf(.false., edft%eself) - ! - END IF - - ! ... - ! - CALL calbec(1, nsp, eigr, c0, bec) - ! - IF (tstress) THEN - ! - CALL caldbec(ngw, nkb, nbsp, 1, nsp, eigr, c0, dbec) - ! - END IF - - atoms0%for = 0.0d0 - ! - IF (ttforce .OR. thdyn) THEN - ! - call nlfq(c0, eigr, bec, becdr, atoms0%for, lgam) - ! - END IF - ! - ! ... compute the new charge density "rhor" - ! - CALL rhoofr(nfi, c0, irb, eigrb, bec, becsum, rhor, rhog, rhos, edft%enl, denl, edft%ekin, dekin6, tstress) - ! - ! ... vofrhos compute the new DFT potential "vpot", and energies "edft", - ! ... ionc forces "fion" and stress "paiu". - ! - CALL vofrhos(ttprint, ttforce, tstress, rhor, rhog, atoms0, & - vpot, bec%rvec, c0, f, eigr, ei1, ei2, ei3, sfac, ht0, edft) - - ! CALL debug_energies( edft ) ! DEBUG - - ! ... Car-Parrinello dynamics for the electrons - ! - ! move electronic degrees of freedom by Verlet's algorithm - ! on input, c0 are the wave functions at time "t" , cm at time "t-dt" - ! on output cp are the new wave functions at time "t+dt" - ! - dt2bye = delt*delt/emass - ! - cp = cm - ! - ! write(6,*) 'ema0bg=', ema0bg(1), ema0bg( SIZE(ema0bg)/2 ) ! debug - ! write(6,*) 'alat=', alat ! debug - ! - if (force_pairing) then - ! - ! unpaired electron is assumed of spinup and in highest - ! index band; and put equal for paired wf spin up and down - ! - CALL runcp_uspp_force_pairing(fccc, ccc, ema0bg, dt2bye, vpot, bec%rvec, c0, cp, intermed) - ! - ELSE - ! - CALL runcp_uspp(nfi, fccc, ccc, ema0bg, dt2bye, vpot, bec, c0, cp) - ! - END IF - ! - ! Orthogonalize the new wave functions "cp" - - IF (tortho) THEN - ! - ccc = fccc*dt2bye - ! - CALL ortho(c0, cp, lambda, descla, ccc, nupdwn, iupdwn, nspin) - ! - IF (ttprint) CALL eigs(nfi, lambda, lambda) - ! - ELSE - DO is = 1, nspin - CALL gram(vkb, bec, nkb, cp(1, iupdwn(is)), SIZE(cp, 1), nupdwn(is)) - END DO - END IF - - ! Compute fictitious kinetic energy of the electrons at time t - - ekinc = 0 - - CALL elec_fakekine(ekinc, ema0bg, emass, cp, cm, ngw, nbsp, 1, 2.0d0*delt) - - ! - ! check if ions should be moved - ! - IF (tfor .AND. tionstep) THEN - ! - doions = .FALSE. - IF ((ekinc < ekin_conv_thr) .AND. (MOD(nfi, nstepe) == 0)) THEN - doions = .TRUE. - END IF - ! - WRITE (stdout, fmt="(3X,'MAIN: doions = ',L1)") doions - ! - END IF - ! - - IF (tfor .AND. doions) THEN - ! - ! Add thermal stress to paiu - ! - CALL ions_thermal_stress(ht0%paiu, atoms0%m, 1.0d0, ht0%hmat, atoms0%vels, atoms0%nsp, atoms0%na) - ! - END IF - - ! ... Cell Dynamics - - ekcell = 0.0d0 ! kinetic energy of the cell (Parrinello-Rahman scheme) - - hgamma = 0.0d0 - - IF (thdyn .AND. doions) THEN - - ! move cell coefficients - ! - CALL cell_force(fcell, ht0%hinv, ht0%paiu, 1.0d0, press, wmass) - - CALL cell_move(newh, ht0%hmat, htm%hmat, delt, & - iforceh, fcell, frich, tnoseh, vnhh, velh, tsdc) - - CALL cell_init('n', htp, newh) - ! - CALL cell_update_vel(htp, ht0, htm, delt, velh) - - CALL cell_gamma(hgamma, ht0%hinv, ht0%hmat, velh) - - ! Kinetic energy of the box - - CALL cell_kinene(ekcell, temphh, velh) - - END IF - - ! - ! ... Ions Dynamics - ! - ekinp = 0.d0 ! kinetic energy of ions - ! - IF (tfor .AND. doions) THEN - ! - IF (textfor) FORALL (i=1:nat) fion(:, i) = fion(:, i) + extfor(:, i) - ! - fion_tot(:) = SUM(fion(:, :), DIM=2)/DBLE(nat) - ! - FORALL (i=1:nat) fion(:, i) = fion(:, i) - fion_tot(:) - ! - ! ... move ionic degrees of freedom - ! - CALL ions_move(atomsp%taus, atoms0%taus, atomsm%taus, iforce, pmass, atoms0%for, ht0%hinv, & - delt, atoms0%na, atoms0%nsp, fricp, hgamma, atoms0%vels, tsdp, tnosep, & - atomsm%for, vnhp, atomsp%vels, atomsm%vels, nhpcl, nhpdim, atm2nhp) - ! - CALL s_to_r(atomsp%taus, atomsp%taur, atomsp%na, atomsp%nsp, htp%hmat) - ! - END IF - - ekinpr = 0.0d0 - - IF (tfor .AND. doions) THEN - ! - CALL ions_vel(atoms0%vels, atomsp%taus, atomsm%taus, atoms0%na, atoms0%nsp, delt) - ! - CALL ions_kinene(ekinp, atoms0%vels, atoms0%na, atoms0%nsp, ht0%hmat, pmass) - ! - atoms0%ekint = ekinp - ! - CALL ions_temp(tempp, temps, ekinpr, atoms0%vels, atoms0%na, atoms0%nsp, & - ht0%hmat, atoms0%m, ndega, nhpdim, atm2nhp, ekin2nhp) - ! - END IF - ! - ! - ! ... udating nose-hoover friction variables - ! - ! - IF (tnosep) THEN - ! - ! below one really should have atoms0%ekint and NOT ekin2nhp - CALL ions_noseupd(xnhpp, xnhp0, xnhpm, delt, qnp, ekin2nhp, gkbt2nhp, vnhp, kbt, nhpcl, nhpdim, nhpbeg, nhpend) - ! - END IF - ! - IF (tnoseh) THEN - CALL cell_noseupd(xnhhp, xnhh0, xnhhm, delt, qnh, temphh, temph, vnhh) - END IF - ! - IF (tnosee) THEN - CALL electrons_noseupd(xnhep, xnhe0, xnhem, delt, qne, ekinc, ekincw, vnhe) - END IF - ! - - call stop_clock('main_loop') - - ! ... Here find Empty states eigenfunctions and eigenvalues - ! - IF (ttempst) THEN - CALL empty_cp(nfi, c0, vpot) - END IF - - ! ... dipole - ! - IF (ttdipole) THEN - - IF (wfill%nspin > 1) & - CALL errore(' main ', ' dipole with spin not yet implemented ', 0) - ! - CALL ddipole(nfi, c0, ngw, atoms0%taus, tfor, ngw, wfill%nbl(1), ht0%a) - - END IF - - IF (self_interaction /= 0) THEN - IF (nat_localisation > 0 .AND. ttprint) THEN - CALL localisation(cp(:, nupdwn(1)), atoms0, ht0) - END IF - END IF - - ! ... if we are going to check convergence, then compute the - ! ... maximum value of the ionic forces - - tconv = .FALSE. - ! - IF (ttconvchk) THEN - ! - IF (ttforce) THEN - maxfion = max_ion_forces(atoms0) - ELSE - maxfion = 0.0d0 - END IF - ! - derho = (erhoold - edft%etot) - tconv = (derho < tconvthrs%derho) - tconv = tconv .AND. (ekinc < tconvthrs%ekin) - ! - IF (.NOT. lneb) THEN - tconv = tconv .AND. (maxfion < tconvthrs%force) - END IF - ! - IF (ionode) THEN - ! - IF (tstdout .OR. tconv) THEN - ! - WRITE (stdout, fmt= & - "(/,3X,'MAIN:',10X,'EKINC (thr)',10X,'DETOT (thr)',7X,'MAXFORCE (thr)')") - ! - WRITE (stdout, fmt="(3X,'MAIN: ',3(D14.6,1X,D8.1))") & - ekinc, tconvthrs%ekin, derho, tconvthrs%derho, maxfion, tconvthrs%force - ! - IF (tconv) THEN - WRITE (stdout, fmt="(3X,'MAIN: convergence achieved for system relaxation',/)") - ELSE - WRITE (stdout, fmt="(3X,'MAIN: convergence NOT achieved for system relaxation',/)") - END IF - ! - END IF - ! - END IF - ! - erhoold = edft%etot - ! - END IF - - ! ... printout - ! - - CALL printout(nfi, atoms0, ekinc, ekcell, ttprint, ht0, edft) - - ! ... Update variables - - ! - CALL electrons_shiftval(cm, c0, cp) - ! - IF (tnosee) THEN - CALL electrons_nose_shiftvar(xnhep, xnhe0, xnhem) - END IF - - IF (doions) THEN - - IF (tfor) THEN - ! - CALL ions_shiftval(atomsm, atoms0, atomsp) - ! - IF (tnosep) THEN - CALL ions_nose_shiftvar(xnhpp, xnhp0, xnhpm) - END IF - ! - END IF - - IF (thdyn) THEN - ! - CALL cell_shiftval(htm, ht0, htp) - ! - IF (tnoseh) THEN - CALL cell_nose_shiftvar(xnhhp, xnhh0, xnhhm) - END IF - ! - END IF - - END IF - - frich = frich*greash - - ! ... stop the code if either the file .cp_stop is present or if - ! ... the cpu time exceeds the limit set in input (max_seconds) - - tstop = check_stop_now() - - tstop = tstop .OR. tconv .OR. (nfi >= nomore) - ! - ! - tstop = tstop .OR. ttexit - ! - - IF (tstop) THEN - ! - ! ... all condition to stop the code are satisfied - ! - IF (ttprint) THEN - ! - ! ... we are in a step where printing is active, - ! ... exit immediately - ! - ttexit = .TRUE. - ! - ELSE IF (.NOT. ttexit) THEN - ! - ! ... perform an additional step, in order to compute - ! ... quantity to print out - ! - ttexit = .TRUE. - ! - CYCLE MAIN_LOOP - ! - END IF - ! - END IF - ! - ! ... write the restart file - ! - IF (ttsave .OR. ttexit) THEN - CALL writefile(nfi, tps, c0, cm, f, atoms0, atomsm, acc, & - taui, cdmi, htm, ht0, rhor, lambda_dumb, ttexit) !modified:giovanni - END IF - - ! ... loop back - ! - IF (ttexit) EXIT MAIN_LOOP - - END DO MAIN_LOOP - - conv_elec = tconv .OR. ttexit - etot = edft%etot - ! - CALL resort_position(tau, fion, atoms0, ind_srt, ht0) - ! - IF (lneb) THEN - DO i = 1, nat - fion(:, i) = fion(:, i)*DBLE(if_pos(:, i)) - END DO - END IF - ! - IF (tprnsfac) THEN - CALL print_sfac(rhor, sfac) - END IF - - DO iunit = 10, 99 - IF (iunit == stdout) CYCLE - INQUIRE (UNIT=iunit, OPENED=topen) - IF (topen) THEN - WRITE (stdout, *) ' main: Closing unit :', iunit - CLOSE (iunit) - END IF - END DO - - RETURN - -CONTAINS - - SUBROUTINE cell_shiftval(box_tm1, box_t0, box_tp1) - type(boxdimensions) :: box_tm1, box_t0, box_tp1 - box_tm1 = box_t0 - box_t0 = box_tp1 - RETURN - END SUBROUTINE cell_shiftval - - SUBROUTINE electrons_shiftval(cm, c0, cp) - USE kinds, ONLY: DP - IMPLICIT NONE - COMPLEX(DP), INTENT(IN) :: cp(:, :) - COMPLEX(DP), INTENT(INOUT) :: c0(:, :) - COMPLEX(DP), INTENT(OUT) :: cm(:, :) - cm(:, :) = c0(:, :) - c0(:, :) = cp(:, :) - RETURN - END SUBROUTINE electrons_shiftval - -END SUBROUTINE cpmain_x diff --git a/quantum_espresso/kcp/CPV/main_loops.f90 b/quantum_espresso/kcp/CPV/main_loops.f90 deleted file mode 100644 index 5e5f4c4e3..000000000 --- a/quantum_espresso/kcp/CPV/main_loops.f90 +++ /dev/null @@ -1,103 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! ... This file contains "sub-main" subroutines that drive the different -! ... kinds of "meta"/"non-meta" dynamics -! -! ... set ion_positions = 'from_input' and rd_pos = +your_positions+ -! ... to force cprmain to compute forces for +your_position+ configuration -! -!---------------------------------------------------------------------------- -SUBROUTINE neb_loop( ) - !---------------------------------------------------------------------------- - ! - USE path_base, ONLY : initialize_path, search_mep - USE path_routines, ONLY : iosys_path - USE path_io_routines, ONLY : io_path_start, io_path_stop, path_summary - ! - IMPLICIT NONE - ! - CALL iosys_path() - ! - CALL io_path_start() - ! - CALL initialize_path() - ! - CALL path_summary() - ! - CALL search_mep() - ! - CALL io_path_stop() - ! - RETURN - ! -END SUBROUTINE neb_loop -! -!---------------------------------------------------------------------------- -SUBROUTINE cpr_loop( nloop ) - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE ions_base, ONLY : nat - USE control_flags, ONLY : lmetadyn, program_name - USE metadyn_base, ONLY : metadyn_init - USE cp_interfaces, ONLY : main_fpmd - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nloop - ! - INTEGER :: iloop - REAL(DP), ALLOCATABLE :: tau(:,:) - REAL(DP), ALLOCATABLE :: fion(:,:) - REAL(DP) :: etot - ! - ! - IF ( nat > 0 ) THEN - ! - ALLOCATE( tau( 3, nat ) ) - ALLOCATE( fion( 3, nat ) ) - ! - ELSE - ! - CALL errore( ' cpr_loop ', ' nat less or equal 0 ', 1 ) - ! - END IF - ! - IF ( lmetadyn ) THEN - ! - CALL metadyn_init( 'CP', tau ) - ! - CALL metadyn() - ! - ELSE - ! - CALL init_run() - ! - DO iloop = 1, nloop - ! - IF( program_name == 'CP90' ) THEN - ! - CALL cprmain( tau(1,1), fion(1,1), etot ) - ! - ELSE - ! - CALL main_fpmd( tau, fion, etot ) - ! - END IF - ! - END DO - ! - END IF - ! - CALL terminate_run() - ! - DEALLOCATE( tau, fion ) - ! - RETURN - ! -END SUBROUTINE cpr_loop diff --git a/quantum_espresso/kcp/CPV/mainvar.f90 b/quantum_espresso/kcp/CPV/mainvar.f90 deleted file mode 100644 index e990fa4cc..000000000 --- a/quantum_espresso/kcp/CPV/mainvar.f90 +++ /dev/null @@ -1,753 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!---------------------------------------------------------------------------- -MODULE cp_main_variables - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY: DP - USE control_flags, ONLY: program_name - USE funct, ONLY: dft_is_meta - USE metagga, ONLY: kedtaur, kedtaus, kedtaug - USE cell_base, ONLY: boxdimensions - USE wave_types, ONLY: wave_descriptor, wave_descriptor_init - USE energies, ONLY: dft_energy_type - USE pres_ai_mod, ONLY: abivol, abisur, jellium, t_gauss, rho_gaus, & - v_vol, posv, f_vol - USE input_parameters, ONLY: do_bare_eigs, odd_nkscalfact - USE twin_types - ! - IMPLICIT NONE - SAVE - ! - ! ... structure factors e^{-ig*R} - ! - ! ... G = reciprocal lattice vectors - ! ... R_I = ionic positions - ! - COMPLEX(DP), ALLOCATABLE :: eigr(:, :) ! exp (i G dot R_I) - COMPLEX(DP), ALLOCATABLE :: ei1(:, :) ! exp (i G_x dot x_I) - COMPLEX(DP), ALLOCATABLE :: ei2(:, :) ! exp (i G_y dot y_I) - COMPLEX(DP), ALLOCATABLE :: ei3(:, :) ! exp (i G_z dot z_I) - ! - ! ... structure factors (summed over atoms of the same kind) - ! - - ! S( s, G ) = sum_(I in s) exp( i G dot R_(s,I) ) - ! s = index of the atomic specie - ! R_(s,I) = position of the I-th atom of the "s" specie - ! - COMPLEX(DP), ALLOCATABLE:: sfac(:, :) - ! - ! ... indexes, positions, and structure factors for the box grid - ! - REAL(DP), ALLOCATABLE :: taub(:, :) - COMPLEX(DP), ALLOCATABLE :: eigrb(:, :) - INTEGER, ALLOCATABLE :: irb(:, :) - ! - ! ... nonlocal projectors: - ! ... bec = scalar product of projectors and wave functions - ! ... betae = nonlocal projectors in g space = beta x e^(-ig.R) - ! ... becdr = used in force calculation - ! ... rhovan= \sum_i f(i) - ! ... deeq = \int V_eff(r) q_lm(r) dr - ! - type(twin_tensor) :: becdr!(:,:,:)!,bec(:,:) !modified:giovanni -! REAL(DP), ALLOCATABLE :: bephi(:,:)!, becp(:,:) !removed:giovanni - TYPE(twin_matrix) :: bec, becp, bephi, becdual, becmdual, becstart !added:giovanni - TYPE(twin_matrix) :: bec_emp - TYPE(twin_matrix), ALLOCATABLE :: lambda(:) - TYPE(twin_matrix), ALLOCATABLE :: lambdam(:) - TYPE(twin_matrix), ALLOCATABLE :: lambdap(:) - TYPE(twin_matrix), ALLOCATABLE :: lambda_bare(:) - ! - ! For non-orthogonal SIC, naive implementation :giovanni - ! - COMPLEX(DP), ALLOCATABLE :: overlap(:, :, :) - COMPLEX(DP), ALLOCATABLE :: ioverlap(:, :, :) - COMPLEX(DP), ALLOCATABLE :: kinetic_mat(:, :, :) - COMPLEX(DP), ALLOCATABLE :: pseudopot_mat(:, :, :) - ! - ! ... mass preconditioning - ! - REAL(DP), ALLOCATABLE :: ema0bg(:) - ! - ! ... constraints (lambda at t, lambdam at t-dt, lambdap at t+dt) - ! - type(twin_matrix), dimension(:), allocatable :: hamilt(:) - ! - INTEGER, ALLOCATABLE :: descla(:, :) ! descriptor of the lambda distribution - ! see descriptors_module - INTEGER :: nlax = 0 ! leading dimension of the distribute (by block) lambda matrix - INTEGER :: nlam = 1 ! dimension of lambda matrix, can be 1 or nlax depending on la_proc - INTEGER :: nrlx = 0 ! leading dimension of the distribute (by row ) lambda matrix - LOGICAL :: la_proc = .FALSE. ! indicate if a proc own a block of lambda - ! - INTEGER, PARAMETER :: nacx = 10 ! max number of averaged - ! quantities saved to the restart - REAL(DP) :: acc(nacx) - REAL(DP) :: acc_this_run(nacx) - ! - ! cell geometry - ! - TYPE(boxdimensions) :: htm, ht0, htp ! cell metrics - ! - ! charge densities and potentials - ! - ! rhog = charge density in g space - ! rhor = charge density in r space (dense grid) - ! rhos = charge density in r space (smooth grid) - ! vpot = potential in r space (dense grid) - ! - COMPLEX(DP), ALLOCATABLE :: rhog(:, :) - REAL(DP), ALLOCATABLE :: rhor(:, :), rhos(:, :) - REAL(DP), ALLOCATABLE :: vpot(:, :) - ! - ! derivative wrt cell - ! - COMPLEX(DP), ALLOCATABLE :: drhog(:, :, :, :) - REAL(DP), ALLOCATABLE :: drhor(:, :, :, :) - ! - TYPE(twin_matrix) :: becwfc_fixed, swfc_fixed - ! - TYPE(wave_descriptor) :: wfill ! wave function descriptor for filled - ! - TYPE(dft_energy_type) :: edft - ! - INTEGER :: nfi ! counter on the electronic iterations - INTEGER :: nprint_nfi = -1 ! counter indicating the last time data have been - ! printed on file ( prefix.pos, ... ) - INTEGER :: nfi_run = 0 ! counter on the electronic iterations, - ! for the present run - INTEGER :: iprint_stdout = 1 ! define how often CP writes verbose information to stdout - ! - INTERFACE distribute_bec - module procedure distribute_bec_cmplx, distribute_bec_real - END INTERFACE - - INTERFACE collect_lambda - module procedure collect_lambda_real, collect_lambda_cmplx - END INTERFACE - - INTERFACE collect_zmat - module procedure collect_zmat_real, collect_zmat_cmplx - END INTERFACE - - INTERFACE distribute_lambda - module procedure distribute_lambda_real, distribute_lambda_cmplx - END INTERFACE - - INTERFACE distribute_zmat - module procedure distribute_zmat_real, distribute_zmat_cmplx - END INTERFACE - - INTERFACE setval_lambda - module procedure setval_lambda_real, setval_lambda_cmplx - END INTERFACE - -CONTAINS - ! - !------------------------------------------------------------------------ - SUBROUTINE allocate_mainvar(ngw, ngwt, ngb, ngs, ng, nr1, nr2, nr3, & - nr1x, nr2x, npl, nnr, nnrsx, nat, nax, & - nsp, nspin, n, nx, nupdwn, nhsa, & - gzero, nudx, tpre) - !------------------------------------------------------------------------ - ! - USE mp_global, ONLY: np_ortho, me_ortho, ortho_comm, & - ortho_comm_id - USE mp, ONLY: mp_max, mp_min - USE descriptors, ONLY: descla_siz_, descla_init, nlax_, la_nrlx_, lambda_node_ - USE control_flags, ONLY: do_wf_cmplx, gamma_only, non_ortho, & - iprint_manifold_overlap ! added:giovanni - USE twin_types - ! - INTEGER, INTENT(IN) :: ngw, ngwt, ngb, ngs, ng, nr1, nr2, nr3, & - nnr, nnrsx, nat, nax, nsp, nspin, & - n, nx, nhsa, nr1x, nr2x, npl - INTEGER, INTENT(IN) :: nupdwn(:) - LOGICAL, INTENT(IN) :: gzero - INTEGER, INTENT(IN) :: nudx - LOGICAL, INTENT(IN) :: tpre - ! - INTEGER :: iss, nhsa_l - LOGICAL :: lgam !added:giovanni - - lgam = gamma_only .and. .not. do_wf_cmplx !added:giovanni - ! - ! ... allocation of all arrays not already allocated in init and nlinit - ! - ALLOCATE (eigr(ngw, nat)) - ALLOCATE (sfac(ngs, nsp)) - ALLOCATE (ei1(-nr1:nr1, nat)) - ALLOCATE (ei2(-nr2:nr2, nat)) - ALLOCATE (ei3(-nr3:nr3, nat)) - ALLOCATE (eigrb(ngb, nat)) - ALLOCATE (irb(3, nat)) - ! - IF (dft_is_meta()) THEN - ! - ! ... METAGGA - ! - ALLOCATE (kedtaur(nnr, nspin)) - ALLOCATE (kedtaus(nnrsx, nspin)) - ALLOCATE (kedtaug(ng, nspin)) - ! - ELSE - ! - ! ... dummy allocation required because this array appears in the - ! ... list of arguments of some routines - ! - ALLOCATE (kedtaur(1, nspin)) - ALLOCATE (kedtaus(1, nspin)) - ALLOCATE (kedtaug(1, nspin)) - ! - END IF - ! - ALLOCATE (ema0bg(ngw)) - ! - ALLOCATE (rhor(nnr, nspin)) - ALLOCATE (vpot(nnr, nspin)) - ALLOCATE (rhos(nnrsx, nspin)) - ALLOCATE (rhog(ng, nspin)) - IF (program_name == 'CP90' .AND. tpre) THEN - IF (tpre) THEN - ALLOCATE (drhog(ng, nspin, 3, 3)) - ALLOCATE (drhor(nnr, nspin, 3, 3)) - END IF - END IF - ! - ! Compute local dimensions for lambda matrixes - ! - - ALLOCATE (descla(descla_siz_, nspin)) - ! - nlax = 0 - nrlx = 0 - DO iss = 1, nspin - CALL descla_init(descla(:, iss), nupdwn(iss), nudx, np_ortho, me_ortho, ortho_comm, ortho_comm_id) - nlax = MAX(nlax, descla(nlax_, iss)) - nrlx = MAX(nrlx, descla(la_nrlx_, iss)) - IF (descla(lambda_node_, iss) > 0) la_proc = .TRUE. - END DO - ! - nlam = 1 - IF (la_proc) nlam = nlax - ! - ! ... End with lambda dimensions - ! - ! - IF (program_name == 'CP90') THEN - ! - if (abivol .or. abisur) then - ! - allocate (rho_gaus(nnr)) - allocate (v_vol(nnr)) - if (jellium .or. t_gauss) allocate (posv(3, nr1*nr2*nr3)) - if (t_gauss) allocate (f_vol(3, nax, nsp)) - ! - end if - ! - END IF - ! -!!!! begin_modified:giovanni - ALLOCATE (lambda(nspin)) - ALLOCATE (lambdam(nspin)) - ALLOCATE (lambdap(nspin)) - DO iss = 1, nspin - lambda(iss)%iscmplx = .not. lgam - call init_twin(lambda(iss), lgam) - call allocate_twin(lambda(iss), nlam, nlam, lgam) - call init_twin(lambdap(iss), lgam) - call allocate_twin(lambdap(iss), nlam, nlam, lgam) - call init_twin(lambdam(iss), lgam) - call allocate_twin(lambdam(iss), nlam, nlam, lgam) - END DO - ! - ! - ALLOCATE (lambda_bare(nspin)) - ! - IF (do_bare_eigs) THEN - ! - do iss = 1, nspin - call init_twin(lambda_bare(iss), lgam) - call allocate_twin(lambda_bare(iss), nlam, nlam, lgam) - end do - ! - END IF - ! - IF (non_ortho) THEN - allocate (ioverlap(nudx, nudx, nspin), & - overlap(nudx, nudx, nspin), kinetic_mat(nudx, nudx, nspin), & - pseudopot_mat(nudx, nudx, nspin)) - END IF -!!!! end_modified:giovanni - ! - ! becdr, distributed over row processors of the ortho group - ! - ! AF: this avoids problems when nhsa, i.e. nkb, is zero - !nhsa_l = MAX( nhsa, 1) - nhsa_l = nhsa - ! - call init_twin(becdr, lgam) - call allocate_twin(becdr, nhsa_l, nspin*nlax, 3, lgam) !added:giovanni - ! - call init_twin(bec, lgam) - call allocate_twin(bec, nhsa_l, n, lgam)!added:giovanni - call init_twin(becp, lgam) - call allocate_twin(becp, nhsa_l, n, lgam)!added:giovanni - call init_twin(bephi, lgam) - call allocate_twin(bephi, nhsa_l, nspin*nlax, lgam)!added:giovanni - - IF (non_ortho) THEN - call init_twin(becdual, lgam) - call allocate_twin(becdual, nhsa_l, n, lgam)!added:giovanni - call init_twin(becmdual, lgam) - call allocate_twin(becmdual, nhsa_l, n, lgam)!added:giovanni - END IF - ! - IF (iprint_manifold_overlap > 0) THEN - call init_twin(becstart, lgam) - call allocate_twin(becstart, nhsa_l, n, lgam)!added:giovanni - END IF -! ALLOCATE( bec( nhsa_l,n ) )!removed:giovanni - ! -! ALLOCATE( bephi( nhsa_l, nspin*nlax ) ) !removed:giovanni -! ALLOCATE( becp( nhsa_l, n ) ) !removed:giovanni - ! - CALL wave_descriptor_init(wfill, ngw, ngwt, nupdwn, nupdwn, & - 1, 1, nspin, 'gamma', gzero) - ! - RETURN - ! - END SUBROUTINE allocate_mainvar - ! - !------------------------------------------------------------------------ - SUBROUTINE deallocate_mainvar() - use io_global, only: ionode - IMPLICIT NONE - - INTEGER :: iss - !------------------------------------------------------------------------ - ! - IF (ALLOCATED(ei1)) DEALLOCATE (ei1) - IF (ALLOCATED(ei2)) DEALLOCATE (ei2) - IF (ALLOCATED(ei3)) DEALLOCATE (ei3) - IF (ALLOCATED(eigr)) DEALLOCATE (eigr) - IF (ALLOCATED(sfac)) DEALLOCATE (sfac) - IF (ALLOCATED(eigrb)) DEALLOCATE (eigrb) - IF (ALLOCATED(irb)) DEALLOCATE (irb) - IF (ALLOCATED(rhor)) DEALLOCATE (rhor) - IF (ALLOCATED(rhos)) DEALLOCATE (rhos) - IF (ALLOCATED(rhog)) DEALLOCATE (rhog) - IF (ALLOCATED(drhog)) DEALLOCATE (drhog) - IF (ALLOCATED(drhor)) DEALLOCATE (drhor) - IF (ALLOCATED(ema0bg)) DEALLOCATE (ema0bg) - IF (ALLOCATED(kedtaur)) DEALLOCATE (kedtaur) - IF (ALLOCATED(kedtaus)) DEALLOCATE (kedtaus) - IF (ALLOCATED(kedtaug)) DEALLOCATE (kedtaug) - IF (ALLOCATED(vpot)) DEALLOCATE (vpot) - IF (ALLOCATED(taub)) DEALLOCATE (taub) - IF (ALLOCATED(descla)) DEALLOCATE (descla) - !added:giovanni -- deallocation of structured types -- the check is inside deallocate - return - if (ionode) then -! write(0,*) "debug1" - end if - CALL deallocate_twin(bec) - CALL deallocate_twin(becp) - CALL deallocate_twin(becdr) - CALL deallocate_twin(bephi) - ! for non orthogonal case - CALL deallocate_twin(becdual) - CALL deallocate_twin(becmdual) - CALL deallocate_twin(becstart) - - if (ionode) then -! write(0,*) "debug2" - end if - IF (allocated(hamilt)) THEN - DO iss = 1, size(hamilt) - CALL deallocate_twin(hamilt(iss)) - END DO - DEALLOCATE (hamilt) - END IF - if (ionode) then -! write(0,*) "debug3" - end if - IF (allocated(lambda)) THEN - DO iss = 1, size(lambda) - CALL deallocate_twin(lambda(iss)) - END DO - DEALLOCATE (lambda) - END IF -! if(ionode) then -! write(0,*) "debug4" -! endif - IF (allocated(lambdam)) THEN - DO iss = 1, size(lambdam) - CALL deallocate_twin(lambdam(iss)) - END DO - DEALLOCATE (lambdam) - END IF - ! - IF (allocated(lambdap)) THEN - DO iss = 1, size(lambdap) - CALL deallocate_twin(lambdap(iss)) - END DO - DEALLOCATE (lambdap) - END IF - ! - IF (allocated(lambda_bare)) THEN - IF (do_bare_eigs) THEN - DO iss = 1, size(lambda_bare) - CALL deallocate_twin(lambda_bare(iss)) - END DO - END IF - DEALLOCATE (lambda_bare) - END IF - ! -- deallocation of structured types ------------------------------------------------------------- - - IF (allocated(overlap)) THEN - deallocate (overlap) - END IF - - IF (allocated(ioverlap)) THEN - deallocate (ioverlap) - END IF - - IF (allocated(kinetic_mat)) THEN - deallocate (kinetic_mat) - END IF - - IF (allocated(pseudopot_mat)) THEN - deallocate (pseudopot_mat) - END IF - - RETURN - ! - END SUBROUTINE deallocate_mainvar - ! - ! - !------------------------------------------------------------------------ - SUBROUTINE distribute_lambda_real(lambda_repl, lambda_dist, desc) - USE descriptors, ONLY: lambda_node_, ilar_, ilac_, nlac_, nlar_ - REAL(DP), INTENT(IN) :: lambda_repl(:, :) - REAL(DP), INTENT(OUT) :: lambda_dist(:, :) - INTEGER, INTENT(IN) :: desc(:) - INTEGER :: i, j, ic, ir - IF (desc(lambda_node_) > 0) THEN - ir = desc(ilar_) - ic = desc(ilac_) - DO j = 1, desc(nlac_) - DO i = 1, desc(nlar_) - lambda_dist(i, j) = lambda_repl(i + ir - 1, j + ic - 1) - END DO - END DO - END IF - RETURN - END SUBROUTINE distribute_lambda_real - - SUBROUTINE distribute_lambda_cmplx(lambda_repl, lambda_dist, desc) - USE descriptors, ONLY: lambda_node_, ilar_, ilac_, nlac_, nlar_ - COMPLEX(DP), INTENT(IN) :: lambda_repl(:, :) - COMPLEX(DP), INTENT(OUT) :: lambda_dist(:, :) - INTEGER, INTENT(IN) :: desc(:) - INTEGER :: i, j, ic, ir - IF (desc(lambda_node_) > 0) THEN - ir = desc(ilar_) - ic = desc(ilac_) - DO j = 1, desc(nlac_) - DO i = 1, desc(nlar_) - lambda_dist(i, j) = lambda_repl(i + ir - 1, j + ic - 1) - END DO - END DO - END IF - RETURN - END SUBROUTINE distribute_lambda_cmplx - ! - !------------------------------------------------------------------------ - SUBROUTINE distribute_bec_cmplx(bec_repl, bec_dist, desc, nspin) - USE descriptors, ONLY: lambda_node_, ilar_, nlar_, la_n_, nlax_ - COMPLEX(DP), INTENT(IN) :: bec_repl(:, :) - COMPLEX(DP) :: bec_dist(:, :) !modified:giovanni - INTEGER, INTENT(IN) :: desc(:, :) - INTEGER, INTENT(IN) :: nspin - INTEGER :: i, ir, n, nlax - ! -! IF(.not.bec_dist%iscmplx) THEN -! call errore(subname, "incompatible types", 1) -! ENDIF - - IF (desc(lambda_node_, 1) > 0) THEN - ! - bec_dist = CMPLX(0.0d0, 0.d0) - ! - ir = desc(ilar_, 1) - DO i = 1, desc(nlar_, 1) - bec_dist(:, i) = bec_repl(:, i + ir - 1) - END DO - ! - IF (nspin == 2) THEN - n = desc(la_n_, 1) ! number of states with spin 1 ( nupdw(1) ) - nlax = desc(nlax_, 1) ! array elements reserved for each spin ( bec(:,2*nlax) ) - ir = desc(ilar_, 2) - DO i = 1, desc(nlar_, 2) - bec_dist(:, i + nlax) = bec_repl(:, i + ir - 1 + n) - END DO - END IF - ! - END IF - RETURN - END SUBROUTINE distribute_bec_cmplx - ! - !----------------------------------------------------------------------------------------------- - SUBROUTINE distribute_bec_real(bec_repl, bec_dist, desc, nspin) - USE descriptors, ONLY: lambda_node_, ilar_, nlar_, la_n_, nlax_ - REAL(DP), INTENT(IN) :: bec_repl(:, :) - REAL(DP) :: bec_dist(:, :) !modified:giovanni - INTEGER, INTENT(IN) :: desc(:, :) - INTEGER, INTENT(IN) :: nspin - INTEGER :: i, ir, n, nlax - ! -! IF(bec_dist%iscmplx) THEN -! call errore(subname, "incompatible types", 1) -! ENDIF - - IF (desc(lambda_node_, 1) > 0) THEN - ! - bec_dist = 0.0d0 - ! - ir = desc(ilar_, 1) - DO i = 1, desc(nlar_, 1) - bec_dist(:, i) = bec_repl(:, i + ir - 1) - END DO - ! - IF (nspin == 2) THEN - n = desc(la_n_, 1) ! number of states with spin 1 ( nupdw(1) ) - nlax = desc(nlax_, 1) ! array elements reserved for each spin ( bec(:,2*nlax) ) - ir = desc(ilar_, 2) - DO i = 1, desc(nlar_, 2) - bec_dist(:, i + nlax) = bec_repl(:, i + ir - 1 + n) - END DO - END IF - ! - END IF - RETURN - END SUBROUTINE distribute_bec_real - ! - !------------------------------------------------------------------------ - SUBROUTINE distribute_zmat_real(zmat_repl, zmat_dist, desc) - USE descriptors, ONLY: lambda_node_, la_nrl_, la_me_, la_npr_, la_npc_, la_n_ - REAL(DP), INTENT(IN) :: zmat_repl(:, :) - REAL(DP), INTENT(OUT) :: zmat_dist(:, :) - INTEGER, INTENT(IN) :: desc(:) - INTEGER :: i, ii, j, me, np - me = desc(la_me_) - np = desc(la_npc_)*desc(la_npr_) - IF (desc(lambda_node_) > 0) THEN - DO j = 1, desc(la_n_) - ii = me + 1 - DO i = 1, desc(la_nrl_) - zmat_dist(i, j) = zmat_repl(ii, j) - ii = ii + np - END DO - END DO - END IF - RETURN - END SUBROUTINE distribute_zmat_real - - SUBROUTINE distribute_zmat_cmplx(zmat_repl, zmat_dist, desc) - USE descriptors, ONLY: lambda_node_, la_nrl_, la_me_, la_npr_, la_npc_, la_n_ - COMPLEX(DP), INTENT(IN) :: zmat_repl(:, :) - COMPLEX(DP), INTENT(OUT) :: zmat_dist(:, :) - INTEGER, INTENT(IN) :: desc(:) - INTEGER :: i, ii, j, me, np - me = desc(la_me_) - np = desc(la_npc_)*desc(la_npr_) - IF (desc(lambda_node_) > 0) THEN - DO j = 1, desc(la_n_) - ii = me + 1 - DO i = 1, desc(la_nrl_) - zmat_dist(i, j) = zmat_repl(ii, j) - ii = ii + np - END DO - END DO - END IF - RETURN - END SUBROUTINE distribute_zmat_cmplx - ! - !------------------------------------------------------------------------ - SUBROUTINE collect_lambda_real(lambda_repl, lambda_dist, desc) - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - USE descriptors, ONLY: lambda_node_, ilar_, ilac_, nlac_, nlar_ - REAL(DP), INTENT(OUT) :: lambda_repl(:, :) - REAL(DP), INTENT(IN) :: lambda_dist(:, :) - INTEGER, INTENT(IN) :: desc(:) - INTEGER :: i, j, ic, ir - lambda_repl = 0.0d0 - IF (desc(lambda_node_) > 0) THEN - ir = desc(ilar_) - ic = desc(ilac_) - DO j = 1, desc(nlac_) - DO i = 1, desc(nlar_) - lambda_repl(i + ir - 1, j + ic - 1) = lambda_dist(i, j) - END DO - END DO - END IF - CALL mp_sum(lambda_repl, intra_image_comm) - RETURN - END SUBROUTINE collect_lambda_real - - SUBROUTINE collect_lambda_cmplx(lambda_repl, lambda_dist, desc) - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - USE descriptors, ONLY: lambda_node_, ilar_, ilac_, nlac_, nlar_ - COMPLEX(DP), INTENT(OUT) :: lambda_repl(:, :) - COMPLEX(DP), INTENT(IN) :: lambda_dist(:, :) - INTEGER, INTENT(IN) :: desc(:) - INTEGER :: i, j, ic, ir - - lambda_repl = CMPLX(0.0d0, 0.d0) - IF (desc(lambda_node_) > 0) THEN - ir = desc(ilar_) - ic = desc(ilac_) - DO j = 1, desc(nlac_) - DO i = 1, desc(nlar_) - lambda_repl(i + ir - 1, j + ic - 1) = lambda_dist(i, j) - END DO - END DO - END IF - CALL mp_sum(lambda_repl, intra_image_comm) - RETURN - END SUBROUTINE collect_lambda_cmplx - ! - !------------------------------------------------------------------------ - SUBROUTINE collect_bec(bec_repl, bec_dist, desc, nspin) - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - USE descriptors, ONLY: lambda_node_, ilar_, nlar_, la_myc_, nlax_, la_n_ - REAL(DP), INTENT(OUT) :: bec_repl(:, :) - REAL(DP), INTENT(IN) :: bec_dist(:, :) - INTEGER, INTENT(IN) :: desc(:, :) - INTEGER, INTENT(IN) :: nspin - INTEGER :: i, ir, n, nlax - ! - bec_repl = 0.0d0 - ! - ! bec is distributed across row processor, the first column is enough - ! - IF ((desc(lambda_node_, 1) > 0) .AND. (desc(la_myc_, 1) == 1)) THEN - ir = desc(ilar_, 1) - DO i = 1, desc(nlar_, 1) - bec_repl(:, i + ir - 1) = bec_dist(:, i) - END DO - IF (nspin == 2) THEN - n = desc(la_n_, 1) ! number of states with spin==1 ( nupdw(1) ) - nlax = desc(nlax_, 1) ! array elements reserved for each spin ( bec(:,2*nlax) ) - ir = desc(ilar_, 2) - DO i = 1, desc(nlar_, 2) - bec_repl(:, i + ir - 1 + n) = bec_dist(:, i + nlax) - END DO - END IF - END IF - ! - CALL mp_sum(bec_repl, intra_image_comm) - ! - RETURN - END SUBROUTINE collect_bec - ! - !------------------------------------------------------------------------ - SUBROUTINE collect_zmat_real(zmat_repl, zmat_dist, desc) - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - USE descriptors, ONLY: lambda_node_, la_nrl_, la_me_, la_npr_, la_npc_, la_n_ - REAL(DP), INTENT(OUT) :: zmat_repl(:, :) - REAL(DP), INTENT(IN) :: zmat_dist(:, :) - INTEGER, INTENT(IN) :: desc(:) - INTEGER :: i, ii, j, me, np, nrl - zmat_repl = 0.0d0 - me = desc(la_me_) - np = desc(la_npc_)*desc(la_npr_) - nrl = desc(la_nrl_) - IF (desc(lambda_node_) > 0) THEN - DO j = 1, desc(la_n_) - ii = me + 1 - DO i = 1, nrl - zmat_repl(ii, j) = zmat_dist(i, j) - ii = ii + np - END DO - END DO - END IF - CALL mp_sum(zmat_repl, intra_image_comm) - RETURN - END SUBROUTINE collect_zmat_real - ! - !------------------------------------------------------------------------ - SUBROUTINE collect_zmat_cmplx(zmat_repl, zmat_dist, desc) - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - USE descriptors, ONLY: lambda_node_, la_nrl_, la_me_, la_npr_, la_npc_, la_n_ - COMPLEX(DP), INTENT(OUT) :: zmat_repl(:, :) - COMPLEX(DP), INTENT(IN) :: zmat_dist(:, :) - INTEGER, INTENT(IN) :: desc(:) - INTEGER :: i, ii, j, me, np, nrl - zmat_repl = CMPLX(0.0d0, 0.d0) - me = desc(la_me_) - np = desc(la_npc_)*desc(la_npr_) - nrl = desc(la_nrl_) - IF (desc(lambda_node_) > 0) THEN - DO j = 1, desc(la_n_) - ii = me + 1 - DO i = 1, nrl - zmat_repl(ii, j) = zmat_dist(i, j) - ii = ii + np - END DO - END DO - END IF - CALL mp_sum(zmat_repl, intra_image_comm) - RETURN - END SUBROUTINE collect_zmat_cmplx - ! - !------------------------------------------------------------------------ - SUBROUTINE setval_lambda_real(lambda_dist, i, j, val, desc) - USE descriptors, ONLY: lambda_node_, ilar_, ilac_, nlac_, nlar_ - REAL(DP), INTENT(OUT) :: lambda_dist(:, :) - INTEGER, INTENT(IN) :: i, j - REAL(DP), INTENT(IN) :: val - INTEGER, INTENT(IN) :: desc(:) - IF (desc(lambda_node_) > 0) THEN - IF ((i >= desc(ilar_)) .AND. (i - desc(ilar_) + 1 <= desc(nlar_))) THEN - IF ((j >= desc(ilac_)) .AND. (j - desc(ilac_) + 1 <= desc(nlac_))) THEN - lambda_dist(i - desc(ilar_) + 1, j - desc(ilac_) + 1) = val - END IF - END IF - END IF - RETURN - END SUBROUTINE setval_lambda_real - - SUBROUTINE setval_lambda_cmplx(lambda_dist, i, j, val, desc) - USE descriptors, ONLY: lambda_node_, ilar_, ilac_, nlac_, nlar_ - COMPLEX(DP), INTENT(OUT) :: lambda_dist(:, :) - INTEGER, INTENT(IN) :: i, j - COMPLEX(DP), INTENT(IN) :: val - INTEGER, INTENT(IN) :: desc(:) - IF (desc(lambda_node_) > 0) THEN - IF ((i >= desc(ilar_)) .AND. (i - desc(ilar_) + 1 <= desc(nlar_))) THEN - IF ((j >= desc(ilac_)) .AND. (j - desc(ilac_) + 1 <= desc(nlac_))) THEN - lambda_dist(i - desc(ilar_) + 1, j - desc(ilac_) + 1) = val - END IF - END IF - END IF - RETURN - END SUBROUTINE setval_lambda_cmplx - ! - ! -END MODULE cp_main_variables diff --git a/quantum_espresso/kcp/CPV/make.depend b/quantum_espresso/kcp/CPV/make.depend deleted file mode 100644 index 70d5f3376..000000000 --- a/quantum_espresso/kcp/CPV/make.depend +++ /dev/null @@ -1,1553 +0,0 @@ -adjef.o : ../Modules/io_global.o -adjef.o : ../Modules/kind.o -atoms_type.o : ../Modules/cell_base.o -atoms_type.o : ../Modules/kind.o -atoms_type.o : ../Modules/parameters.o -berryion.o : ../Modules/cell_base.o -berryion.o : ../Modules/constants.o -berryion.o : ../Modules/ions_base.o -bessel.o : ../Modules/constants.o -bessel.o : ../Modules/kind.o -bessel.o : cp_interfaces.o -bforceion.o : ../Modules/cell_base.o -bforceion.o : ../Modules/constants.o -bforceion.o : ../Modules/electrons_base.o -bforceion.o : ../Modules/ions_base.o -bforceion.o : ../Modules/parameters.o -bforceion.o : ../Modules/uspp.o -bforceion.o : mainvar.o -bforceion.o : modules.o -brillouin.o : ../Modules/kind.o -centers_and_spreads.o : ../Modules/cell_base.o -centers_and_spreads.o : ../Modules/constants.o -centers_and_spreads.o : ../Modules/electrons_base.o -centers_and_spreads.o : ../Modules/io_files.o -centers_and_spreads.o : ../Modules/io_global.o -centers_and_spreads.o : ../Modules/kind.o -centers_and_spreads.o : ../Modules/recvec.o -cg.o : ../Modules/electrons_base.o -cg.o : ../Modules/io_global.o -cg.o : ../Modules/kind.o -cg.o : ../Modules/recvec.o -cg_empty_sub.o : ../Modules/cell_base.o -cg_empty_sub.o : ../Modules/constants.o -cg_empty_sub.o : ../Modules/control_flags.o -cg_empty_sub.o : ../Modules/descriptors.o -cg_empty_sub.o : ../Modules/electrons_base.o -cg_empty_sub.o : ../Modules/energies.o -cg_empty_sub.o : ../Modules/griddim.o -cg_empty_sub.o : ../Modules/input_parameters.o -cg_empty_sub.o : ../Modules/io_files.o -cg_empty_sub.o : ../Modules/io_global.o -cg_empty_sub.o : ../Modules/ions_base.o -cg_empty_sub.o : ../Modules/kind.o -cg_empty_sub.o : ../Modules/mp.o -cg_empty_sub.o : ../Modules/mp_global.o -cg_empty_sub.o : ../Modules/printout_base.o -cg_empty_sub.o : ../Modules/recvec.o -cg_empty_sub.o : ../Modules/twin_types.o -cg_empty_sub.o : ../Modules/uspp.o -cg_empty_sub.o : ../Modules/wavefunctions.o -cg_empty_sub.o : cg.o -cg_empty_sub.o : cp_emass.o -cg_empty_sub.o : cp_interfaces.o -cg_empty_sub.o : electrons.o -cg_empty_sub.o : ensemble_dft.o -cg_empty_sub.o : ions_positions.o -cg_empty_sub.o : mainvar.o -cg_empty_sub.o : modules.o -cg_empty_sub.o : ortho_base.o -cg_sub.o : ../Modules/cell_base.o -cg_sub.o : ../Modules/constants.o -cg_sub.o : ../Modules/control_flags.o -cg_sub.o : ../Modules/descriptors.o -cg_sub.o : ../Modules/electrons_base.o -cg_sub.o : ../Modules/energies.o -cg_sub.o : ../Modules/griddim.o -cg_sub.o : ../Modules/input_parameters.o -cg_sub.o : ../Modules/io_files.o -cg_sub.o : ../Modules/io_global.o -cg_sub.o : ../Modules/ions_base.o -cg_sub.o : ../Modules/kind.o -cg_sub.o : ../Modules/mp.o -cg_sub.o : ../Modules/mp_global.o -cg_sub.o : ../Modules/printout_base.o -cg_sub.o : ../Modules/recvec.o -cg_sub.o : ../Modules/twin_types.o -cg_sub.o : ../Modules/uspp.o -cg_sub.o : ../Modules/wavefunctions.o -cg_sub.o : cg.o -cg_sub.o : cp_emass.o -cg_sub.o : cp_interfaces.o -cg_sub.o : efield.o -cg_sub.o : electrons.o -cg_sub.o : ensemble_dft.o -cg_sub.o : exx_divergence.o -cg_sub.o : ions_positions.o -cg_sub.o : mainvar.o -cg_sub.o : modules.o -cg_sub.o : ortho_base.o -cglib.o : ../Modules/cell_base.o -cglib.o : ../Modules/constants.o -cglib.o : ../Modules/control_flags.o -cglib.o : ../Modules/descriptors.o -cglib.o : ../Modules/dspev_drv.o -cglib.o : ../Modules/electrons_base.o -cglib.o : ../Modules/io_global.o -cglib.o : ../Modules/ions_base.o -cglib.o : ../Modules/kind.o -cglib.o : ../Modules/mp.o -cglib.o : ../Modules/mp_global.o -cglib.o : ../Modules/ptoolkit.o -cglib.o : ../Modules/recvec.o -cglib.o : ../Modules/twin_types.o -cglib.o : ../Modules/uspp.o -cglib.o : ../Modules/zhpev_drv.o -cglib.o : cp_interfaces.o -cglib.o : mainvar.o -cglib.o : modules.o -chargedensity.o : ../Modules/cell_base.o -chargedensity.o : ../Modules/constants.o -chargedensity.o : ../Modules/control_flags.o -chargedensity.o : ../Modules/electrons_base.o -chargedensity.o : ../Modules/fft_base.o -chargedensity.o : ../Modules/functionals.o -chargedensity.o : ../Modules/griddim.o -chargedensity.o : ../Modules/io_global.o -chargedensity.o : ../Modules/ions_base.o -chargedensity.o : ../Modules/kind.o -chargedensity.o : ../Modules/mp.o -chargedensity.o : ../Modules/mp_global.o -chargedensity.o : ../Modules/parallel_include.o -chargedensity.o : ../Modules/recvec.o -chargedensity.o : ../Modules/smallbox.o -chargedensity.o : ../Modules/twin_types.o -chargedensity.o : ../Modules/uspp.o -chargedensity.o : ../Modules/wave_base.o -chargedensity.o : cg.o -chargedensity.o : chargemix.o -chargedensity.o : cp_interfaces.o -chargedensity.o : mainvar.o -chargedensity.o : modules.o -chargedensity.o : wannier_base.o -chargemix.o : ../Modules/kind.o -chi2.o : ../Modules/cell_base.o -chi2.o : ../Modules/io_files.o -chi2.o : ../Modules/io_global.o -chi2.o : ../Modules/kind.o -chi2.o : ../Modules/mp.o -chi2.o : ../Modules/mp_global.o -chi2.o : ../Modules/recvec.o -compute_fes_grads.o : ../Modules/basic_algebra_routines.o -compute_fes_grads.o : ../Modules/cell_base.o -compute_fes_grads.o : ../Modules/check_stop.o -compute_fes_grads.o : ../Modules/constants.o -compute_fes_grads.o : ../Modules/constraints_module.o -compute_fes_grads.o : ../Modules/control_flags.o -compute_fes_grads.o : ../Modules/input_parameters.o -compute_fes_grads.o : ../Modules/io_files.o -compute_fes_grads.o : ../Modules/io_global.o -compute_fes_grads.o : ../Modules/ions_base.o -compute_fes_grads.o : ../Modules/kind.o -compute_fes_grads.o : ../Modules/metadyn_base.o -compute_fes_grads.o : ../Modules/metadyn_io.o -compute_fes_grads.o : ../Modules/metadyn_vars.o -compute_fes_grads.o : ../Modules/mp.o -compute_fes_grads.o : ../Modules/mp_global.o -compute_fes_grads.o : ../Modules/path_formats.o -compute_fes_grads.o : ../Modules/path_io_routines.o -compute_fes_grads.o : ../Modules/path_variables.o -compute_fes_grads.o : ../Modules/timestep.o -compute_fes_grads.o : ../Modules/wave_base.o -compute_fes_grads.o : ../Modules/xml_io_base.o -compute_fes_grads.o : input.o -compute_fes_grads.o : ions_positions.o -compute_fes_grads.o : mainvar.o -compute_scf.o : ../Modules/check_stop.o -compute_scf.o : ../Modules/control_flags.o -compute_scf.o : ../Modules/io_files.o -compute_scf.o : ../Modules/io_global.o -compute_scf.o : ../Modules/ions_base.o -compute_scf.o : ../Modules/kind.o -compute_scf.o : ../Modules/path_formats.o -compute_scf.o : ../Modules/path_variables.o -compute_scf.o : ../Modules/xml_io_base.o -compute_scf.o : cp_interfaces.o -compute_scf.o : input.o -compute_scf.o : mainvar.o -cp_autopilot.o : ../Modules/autopilot.o -cp_autopilot.o : ../Modules/control_flags.o -cp_autopilot.o : ../Modules/input_parameters.o -cp_autopilot.o : ../Modules/io_global.o -cp_autopilot.o : ../Modules/ions_base.o -cp_autopilot.o : ../Modules/ions_nose.o -cp_autopilot.o : ../Modules/kind.o -cp_autopilot.o : ../Modules/mp.o -cp_autopilot.o : ../Modules/parser.o -cp_autopilot.o : ../Modules/timestep.o -cp_autopilot.o : ../Modules/wave_base.o -cp_autopilot.o : cp_emass.o -cp_emass.o : ../Modules/control_flags.o -cp_emass.o : ../Modules/kind.o -cp_fpmd.o : ../Modules/cell_base.o -cp_fpmd.o : ../Modules/constants.o -cp_fpmd.o : ../Modules/constraints_module.o -cp_fpmd.o : ../Modules/control_flags.o -cp_fpmd.o : ../Modules/electrons_base.o -cp_fpmd.o : ../Modules/fft_base.o -cp_fpmd.o : ../Modules/functionals.o -cp_fpmd.o : ../Modules/griddim.o -cp_fpmd.o : ../Modules/io_global.o -cp_fpmd.o : ../Modules/ions_base.o -cp_fpmd.o : ../Modules/ions_nose.o -cp_fpmd.o : ../Modules/kind.o -cp_fpmd.o : ../Modules/mp.o -cp_fpmd.o : ../Modules/mp_global.o -cp_fpmd.o : ../Modules/recvec.o -cp_fpmd.o : ../Modules/smallbox.o -cp_fpmd.o : cpr_mod.o -cp_fpmd.o : pseudopot.o -cp_interfaces.o : ../Modules/cell_base.o -cp_interfaces.o : ../Modules/descriptors.o -cp_interfaces.o : ../Modules/electrons_base.o -cp_interfaces.o : ../Modules/energies.o -cp_interfaces.o : ../Modules/fft_types.o -cp_interfaces.o : ../Modules/griddim.o -cp_interfaces.o : ../Modules/io_global.o -cp_interfaces.o : ../Modules/ions_base.o -cp_interfaces.o : ../Modules/kind.o -cp_interfaces.o : ../Modules/recvec.o -cp_interfaces.o : ../Modules/twin_types.o -cp_interfaces.o : ../Modules/uspp.o -cp_interfaces.o : atoms_type.o -cp_interfaces.o : modules.o -cp_interfaces.o : ortho_check.o -cp_interfaces.o : wave_types.o -cp_interfaces.o : write_hamiltonian.o -cp_restart.o : ../Modules/cell_base.o -cp_restart.o : ../Modules/constants.o -cp_restart.o : ../Modules/control_flags.o -cp_restart.o : ../Modules/electrons_base.o -cp_restart.o : ../Modules/energies.o -cp_restart.o : ../Modules/fft_base.o -cp_restart.o : ../Modules/functionals.o -cp_restart.o : ../Modules/griddim.o -cp_restart.o : ../Modules/input_parameters.o -cp_restart.o : ../Modules/io_files.o -cp_restart.o : ../Modules/io_global.o -cp_restart.o : ../Modules/ions_base.o -cp_restart.o : ../Modules/kind.o -cp_restart.o : ../Modules/mp.o -cp_restart.o : ../Modules/mp_global.o -cp_restart.o : ../Modules/parameters.o -cp_restart.o : ../Modules/parser.o -cp_restart.o : ../Modules/printout_base.o -cp_restart.o : ../Modules/recvec.o -cp_restart.o : ../Modules/twin_types.o -cp_restart.o : ../Modules/version.o -cp_restart.o : ../Modules/wavefunctions.o -cp_restart.o : ../Modules/xml_io_base.o -cp_restart.o : ../iotk/src/iotk_module.o -cp_restart.o : cp_interfaces.o -cp_restart.o : electrons.o -cp_restart.o : mainvar.o -cp_restart.o : modules.o -cp_restart_backup.o : ../Modules/cell_base.o -cp_restart_backup.o : ../Modules/constants.o -cp_restart_backup.o : ../Modules/control_flags.o -cp_restart_backup.o : ../Modules/electrons_base.o -cp_restart_backup.o : ../Modules/energies.o -cp_restart_backup.o : ../Modules/fft_base.o -cp_restart_backup.o : ../Modules/functionals.o -cp_restart_backup.o : ../Modules/griddim.o -cp_restart_backup.o : ../Modules/input_parameters.o -cp_restart_backup.o : ../Modules/io_files.o -cp_restart_backup.o : ../Modules/io_global.o -cp_restart_backup.o : ../Modules/ions_base.o -cp_restart_backup.o : ../Modules/kind.o -cp_restart_backup.o : ../Modules/mp.o -cp_restart_backup.o : ../Modules/mp_global.o -cp_restart_backup.o : ../Modules/parameters.o -cp_restart_backup.o : ../Modules/parser.o -cp_restart_backup.o : ../Modules/printout_base.o -cp_restart_backup.o : ../Modules/recvec.o -cp_restart_backup.o : ../Modules/twin_types.o -cp_restart_backup.o : ../Modules/version.o -cp_restart_backup.o : ../Modules/wavefunctions.o -cp_restart_backup.o : ../Modules/xml_io_base.o -cp_restart_backup.o : ../iotk/src/iotk_module.o -cp_restart_backup.o : cp_interfaces.o -cp_restart_backup.o : mainvar.o -cp_restart_backup.o : modules.o -cp_version.o : ../Modules/version.o -cplib.o : ../Modules/atom.o -cplib.o : ../Modules/cell_base.o -cplib.o : ../Modules/constants.o -cplib.o : ../Modules/control_flags.o -cplib.o : ../Modules/descriptors.o -cplib.o : ../Modules/dspev_drv.o -cplib.o : ../Modules/electrons_base.o -cplib.o : ../Modules/energies.o -cplib.o : ../Modules/fft_base.o -cplib.o : ../Modules/fft_types.o -cplib.o : ../Modules/functionals.o -cplib.o : ../Modules/griddim.o -cplib.o : ../Modules/input_parameters.o -cplib.o : ../Modules/io_global.o -cplib.o : ../Modules/ions_base.o -cplib.o : ../Modules/kind.o -cplib.o : ../Modules/mp.o -cplib.o : ../Modules/mp_global.o -cplib.o : ../Modules/recvec.o -cplib.o : ../Modules/sic.o -cplib.o : ../Modules/smallbox.o -cplib.o : ../Modules/twin_types.o -cplib.o : ../Modules/uspp.o -cplib.o : cp_interfaces.o -cplib.o : mainvar.o -cplib.o : modules.o -cplib.o : pres_ai_mod.o -cplib_meta.o : ../Modules/cell_base.o -cplib_meta.o : ../Modules/constants.o -cplib_meta.o : ../Modules/control_flags.o -cplib_meta.o : ../Modules/electrons_base.o -cplib_meta.o : ../Modules/energies.o -cplib_meta.o : ../Modules/fft_base.o -cplib_meta.o : ../Modules/griddim.o -cplib_meta.o : ../Modules/io_global.o -cplib_meta.o : ../Modules/ions_base.o -cplib_meta.o : ../Modules/kind.o -cplib_meta.o : ../Modules/mp.o -cplib_meta.o : ../Modules/mp_global.o -cplib_meta.o : ../Modules/recvec.o -cplib_meta.o : cp_interfaces.o -cplib_meta.o : modules.o -cpr.o : ../Modules/autopilot.o -cpr.o : ../Modules/cell_base.o -cpr.o : ../Modules/check_stop.o -cpr.o : ../Modules/constants.o -cpr.o : ../Modules/constraints_module.o -cpr.o : ../Modules/control_flags.o -cpr.o : ../Modules/descriptors.o -cpr.o : ../Modules/electrons_base.o -cpr.o : ../Modules/energies.o -cpr.o : ../Modules/griddim.o -cpr.o : ../Modules/input_parameters.o -cpr.o : ../Modules/io_files.o -cpr.o : ../Modules/io_global.o -cpr.o : ../Modules/ions_base.o -cpr.o : ../Modules/ions_nose.o -cpr.o : ../Modules/kind.o -cpr.o : ../Modules/metadyn_base.o -cpr.o : ../Modules/mp.o -cpr.o : ../Modules/mp_global.o -cpr.o : ../Modules/printout_base.o -cpr.o : ../Modules/recvec.o -cpr.o : ../Modules/smallbox.o -cpr.o : ../Modules/timestep.o -cpr.o : ../Modules/twin_types.o -cpr.o : ../Modules/uspp.o -cpr.o : ../Modules/wave_base.o -cpr.o : ../Modules/wavefunctions.o -cpr.o : cg.o -cpr.o : cp_autopilot.o -cpr.o : cp_emass.o -cpr.o : cp_interfaces.o -cpr.o : efield.o -cpr.o : electrons.o -cpr.o : ensemble_dft.o -cpr.o : ions_positions.o -cpr.o : mainvar.o -cpr.o : modules.o -cpr.o : ortho_base.o -cpr.o : pres_ai_mod.o -cpr.o : wannier.o -cpr_mod.o : ../Modules/kind.o -cprstart.o : ../Modules/check_stop.o -cprstart.o : ../Modules/control_flags.o -cprstart.o : ../Modules/io_global.o -cprstart.o : ../Modules/mp.o -cprstart.o : ../Modules/mp_global.o -cprstart.o : environment.o -cprstart.o : input.o -cprsub.o : ../Modules/atom.o -cprsub.o : ../Modules/cell_base.o -cprsub.o : ../Modules/constants.o -cprsub.o : ../Modules/control_flags.o -cprsub.o : ../Modules/descriptors.o -cprsub.o : ../Modules/electrons_base.o -cprsub.o : ../Modules/griddim.o -cprsub.o : ../Modules/input_parameters.o -cprsub.o : ../Modules/io_global.o -cprsub.o : ../Modules/ions_base.o -cprsub.o : ../Modules/kind.o -cprsub.o : ../Modules/mp.o -cprsub.o : ../Modules/mp_global.o -cprsub.o : ../Modules/recvec.o -cprsub.o : ../Modules/twin_types.o -cprsub.o : ../Modules/uspp.o -cprsub.o : cp_interfaces.o -cprsub.o : cpr_mod.o -cprsub.o : mainvar.o -cprsub.o : modules.o -cprsub.o : pseudo_base.o -cprsub.o : pseudopot.o -cprsub.o : spline.o -dealloc.o : ../Modules/electrons_base.o -dealloc.o : ../Modules/fft_base.o -dealloc.o : ../Modules/fft_types.o -dealloc.o : ../Modules/io_global.o -dealloc.o : ../Modules/ions_base.o -dealloc.o : ../Modules/ions_nose.o -dealloc.o : ../Modules/recvec.o -dealloc.o : ../Modules/sic.o -dealloc.o : ../Modules/stick_base.o -dealloc.o : ../Modules/uspp.o -dealloc.o : ../Modules/wavefunctions.o -dealloc.o : cg.o -dealloc.o : chargemix.o -dealloc.o : chi2.o -dealloc.o : cpr_mod.o -dealloc.o : efield.o -dealloc.o : electrons.o -dealloc.o : ensemble_dft.o -dealloc.o : ions_positions.o -dealloc.o : ksstates.o -dealloc.o : mainvar.o -dealloc.o : modules.o -dealloc.o : polarization.o -dealloc.o : pseudopot.o -dealloc.o : turbo.o -dealloc.o : wannier.o -dforceb.o : ../Modules/cell_base.o -dforceb.o : ../Modules/constants.o -dforceb.o : ../Modules/electrons_base.o -dforceb.o : ../Modules/ions_base.o -dforceb.o : ../Modules/kind.o -dforceb.o : ../Modules/mp.o -dforceb.o : ../Modules/mp_global.o -dforceb.o : ../Modules/parallel_include.o -dforceb.o : ../Modules/parameters.o -dforceb.o : ../Modules/recvec.o -dforceb.o : ../Modules/uspp.o -dforceb.o : efield.o -dforceb.o : ensemble_dft.o -dforceb.o : modules.o -eelib.o : ../Modules/cell_base.o -eelib.o : ../Modules/constants.o -eelib.o : ../Modules/control_flags.o -eelib.o : ../Modules/electrons_base.o -eelib.o : ../Modules/fft_base.o -eelib.o : ../Modules/fft_types.o -eelib.o : ../Modules/griddim.o -eelib.o : ../Modules/io_global.o -eelib.o : ../Modules/ions_base.o -eelib.o : ../Modules/kind.o -eelib.o : ../Modules/mp.o -eelib.o : ../Modules/mp_global.o -eelib.o : ../Modules/recvec.o -eelib.o : cp_interfaces.o -eelib.o : modules.o -efermi.o : ../Modules/kind.o -efield.o : ../Modules/control_flags.o -efield.o : ../Modules/io_global.o -efield.o : ../Modules/kind.o -efield.o : ../Modules/recvec.o -efield.o : ../Modules/twin_types.o -efield.o : ../Modules/uspp.o -efield.o : ions_positions.o -eigs0.o : ../Modules/constants.o -eigs0.o : ../Modules/descriptors.o -eigs0.o : ../Modules/dspev_drv.o -eigs0.o : ../Modules/electrons_base.o -eigs0.o : ../Modules/io_global.o -eigs0.o : ../Modules/kind.o -eigs0.o : ../Modules/mp.o -eigs0.o : ../Modules/mp_global.o -eigs0.o : ../Modules/sic.o -eigs0.o : ../Modules/twin_types.o -eigs0.o : ../Modules/zhpev_drv.o -eigs0.o : electrons.o -eigs0.o : ensemble_dft.o -eigs0.o : mainvar.o -eigs0.o : modules.o -electrons.o : ../Modules/constants.o -electrons.o : ../Modules/dspev_drv.o -electrons.o : ../Modules/electrons_base.o -electrons.o : ../Modules/io_global.o -electrons.o : ../Modules/kind.o -electrons.o : ../Modules/mp_global.o -electrons.o : cp_emass.o -electrons.o : ensemble_dft.o -electrons.o : modules.o -empty_koopmans_pp.o : ../Modules/constants.o -empty_koopmans_pp.o : ../Modules/control_flags.o -empty_koopmans_pp.o : ../Modules/electrons_base.o -empty_koopmans_pp.o : ../Modules/griddim.o -empty_koopmans_pp.o : ../Modules/input_parameters.o -empty_koopmans_pp.o : ../Modules/io_global.o -empty_koopmans_pp.o : ../Modules/ions_base.o -empty_koopmans_pp.o : ../Modules/kind.o -empty_koopmans_pp.o : ../Modules/mp.o -empty_koopmans_pp.o : ../Modules/mp_global.o -empty_koopmans_pp.o : ../Modules/recvec.o -empty_koopmans_pp.o : ../Modules/twin_types.o -empty_koopmans_pp.o : ../Modules/uspp.o -empty_koopmans_pp.o : cp_interfaces.o -empty_koopmans_pp.o : electrons.o -empty_koopmans_pp.o : mainvar.o -empty_koopmans_pp.o : modules.o -emptystates.o : ../Modules/cell_base.o -emptystates.o : ../Modules/check_stop.o -emptystates.o : ../Modules/constants.o -emptystates.o : ../Modules/control_flags.o -emptystates.o : ../Modules/descriptors.o -emptystates.o : ../Modules/electrons_base.o -emptystates.o : ../Modules/griddim.o -emptystates.o : ../Modules/input_parameters.o -emptystates.o : ../Modules/io_files.o -emptystates.o : ../Modules/io_global.o -emptystates.o : ../Modules/ions_base.o -emptystates.o : ../Modules/kind.o -emptystates.o : ../Modules/mp.o -emptystates.o : ../Modules/mp_global.o -emptystates.o : ../Modules/mp_wave.o -emptystates.o : ../Modules/recvec.o -emptystates.o : ../Modules/timestep.o -emptystates.o : ../Modules/twin_types.o -emptystates.o : ../Modules/uspp.o -emptystates.o : ../Modules/wave_base.o -emptystates.o : ../Modules/wavefunctions.o -emptystates.o : ../Modules/wrappers.o -emptystates.o : ../Modules/xml_io_base.o -emptystates.o : centers_and_spreads.o -emptystates.o : cp_emass.o -emptystates.o : cp_interfaces.o -emptystates.o : electrons.o -emptystates.o : mainvar.o -emptystates.o : modules.o -emptystates.o : ortho_base.o -emptystates_tocg.o : ../Modules/cell_base.o -emptystates_tocg.o : ../Modules/check_stop.o -emptystates_tocg.o : ../Modules/control_flags.o -emptystates_tocg.o : ../Modules/descriptors.o -emptystates_tocg.o : ../Modules/electrons_base.o -emptystates_tocg.o : ../Modules/griddim.o -emptystates_tocg.o : ../Modules/input_parameters.o -emptystates_tocg.o : ../Modules/io_files.o -emptystates_tocg.o : ../Modules/io_global.o -emptystates_tocg.o : ../Modules/ions_base.o -emptystates_tocg.o : ../Modules/kind.o -emptystates_tocg.o : ../Modules/mp.o -emptystates_tocg.o : ../Modules/mp_global.o -emptystates_tocg.o : ../Modules/mp_wave.o -emptystates_tocg.o : ../Modules/recvec.o -emptystates_tocg.o : ../Modules/timestep.o -emptystates_tocg.o : ../Modules/twin_types.o -emptystates_tocg.o : ../Modules/uspp.o -emptystates_tocg.o : ../Modules/wave_base.o -emptystates_tocg.o : ../Modules/wavefunctions.o -emptystates_tocg.o : ../Modules/wrappers.o -emptystates_tocg.o : ../Modules/xml_io_base.o -emptystates_tocg.o : cp_emass.o -emptystates_tocg.o : cp_interfaces.o -emptystates_tocg.o : electrons.o -emptystates_tocg.o : mainvar.o -emptystates_tocg.o : modules.o -emptystates_tocg.o : ortho_base.o -ensemble_dft.o : ../Modules/descriptors.o -ensemble_dft.o : ../Modules/io_global.o -ensemble_dft.o : ../Modules/kind.o -ensemble_dft.o : ../Modules/twin_types.o -entropy.o : ../Modules/kind.o -environment.o : ../Modules/io_files.o -environment.o : ../Modules/io_global.o -environment.o : ../Modules/kind.o -environment.o : ../Modules/mp_global.o -environment.o : cp_version.o -exch_corr.o : ../Modules/cell_base.o -exch_corr.o : ../Modules/constants.o -exch_corr.o : ../Modules/control_flags.o -exch_corr.o : ../Modules/fft_base.o -exch_corr.o : ../Modules/functionals.o -exch_corr.o : ../Modules/griddim.o -exch_corr.o : ../Modules/io_global.o -exch_corr.o : ../Modules/ions_base.o -exch_corr.o : ../Modules/kind.o -exch_corr.o : ../Modules/mp.o -exch_corr.o : ../Modules/mp_global.o -exch_corr.o : ../Modules/recvec.o -exch_corr.o : ../Modules/sic.o -exch_corr.o : cp_interfaces.o -exch_corr.o : mainvar.o -exch_corr.o : modules.o -exx_divergence.o : ../Modules/cell_base.o -exx_divergence.o : ../Modules/constants.o -exx_divergence.o : ../Modules/control_flags.o -exx_divergence.o : ../Modules/io_global.o -exx_divergence.o : ../Modules/mp_global.o -exx_divergence.o : ../Modules/mp.o -exx_divergence.o : ../Modules/kind.o -exx_divergence.o : ../Modules/recvec.o -fft.o : ../Modules/control_flags.o -fft.o : ../Modules/fft_base.o -fft.o : ../Modules/fft_parallel.o -fft.o : ../Modules/fft_scalar.o -fft.o : ../Modules/fft_types.o -fft.o : ../Modules/griddim.o -fft.o : ../Modules/kind.o -fft.o : ../Modules/mp_global.o -fft.o : ../Modules/recvec.o -forceconv.o : ../Modules/kind.o -forces.o : ../Modules/cell_base.o -forces.o : ../Modules/constants.o -forces.o : ../Modules/control_flags.o -forces.o : ../Modules/fft_base.o -forces.o : ../Modules/functionals.o -forces.o : ../Modules/griddim.o -forces.o : ../Modules/ions_base.o -forces.o : ../Modules/kind.o -forces.o : ../Modules/mp_global.o -forces.o : ../Modules/parallel_include.o -forces.o : ../Modules/recvec.o -forces.o : ../Modules/twin_types.o -forces.o : ../Modules/uspp.o -forces.o : cp_interfaces.o -forces.o : ensemble_dft.o -forces.o : modules.o -fpmdpp.o : ../Modules/constants.o -fpmdpp.o : ../Modules/io_files.o -fpmdpp.o : ../Modules/io_global.o -fpmdpp.o : ../Modules/kind.o -fpmdpp.o : ../Modules/mp.o -fpmdpp.o : ../Modules/mp_global.o -fpmdpp.o : ../Modules/xml_io_base.o -fpmdpp.o : ../iotk/src/iotk_module.o -fromscra.o : ../Modules/cell_base.o -fromscra.o : ../Modules/control_flags.o -fromscra.o : ../Modules/descriptors.o -fromscra.o : ../Modules/electrons_base.o -fromscra.o : ../Modules/energies.o -fromscra.o : ../Modules/griddim.o -fromscra.o : ../Modules/io_global.o -fromscra.o : ../Modules/ions_base.o -fromscra.o : ../Modules/ions_nose.o -fromscra.o : ../Modules/kind.o -fromscra.o : ../Modules/mp_global.o -fromscra.o : ../Modules/printout_base.o -fromscra.o : ../Modules/recvec.o -fromscra.o : ../Modules/smallbox.o -fromscra.o : ../Modules/timestep.o -fromscra.o : ../Modules/uspp.o -fromscra.o : ../Modules/wave_base.o -fromscra.o : ../Modules/wavefunctions.o -fromscra.o : atoms_type.o -fromscra.o : cg.o -fromscra.o : cp_emass.o -fromscra.o : cp_interfaces.o -fromscra.o : efield.o -fromscra.o : electrons.o -fromscra.o : ensemble_dft.o -fromscra.o : ions_positions.o -fromscra.o : mainvar.o -fromscra.o : modules.o -fromscra.o : ortho_base.o -geninv.o : ../Modules/kind.o -gradrho.o : ../Modules/cell_base.o -gradrho.o : ../Modules/fft_base.o -gradrho.o : ../Modules/griddim.o -gradrho.o : ../Modules/recvec.o -gradrho.o : cp_interfaces.o -gram_swap.o : ../Modules/control_flags.o -gram_swap.o : ../Modules/electrons_base.o -gram_swap.o : ../Modules/kind.o -gram_swap.o : ../Modules/recvec.o -gram_swap.o : ../Modules/twin_types.o -gram_swap.o : ../Modules/uspp.o -gtable.o : ../Modules/io_global.o -gtable.o : ../Modules/mp.o -gtable.o : ../Modules/mp_global.o -gtable.o : ../Modules/parallel_include.o -gtable.o : ../Modules/recvec.o -gtable.o : efield.o -hflib.o : ../Modules/cell_base.o -hflib.o : ../Modules/constants.o -hflib.o : ../Modules/electrons_base.o -hflib.o : ../Modules/fft_base.o -hflib.o : ../Modules/functionals.o -hflib.o : ../Modules/griddim.o -hflib.o : ../Modules/io_global.o -hflib.o : ../Modules/kind.o -hflib.o : ../Modules/mp.o -hflib.o : ../Modules/mp_global.o -hflib.o : ../Modules/recvec.o -hflib.o : cp_interfaces.o -hflib.o : modules.o -indices.o : ../Modules/kind.o -init.o : ../Modules/berry_phase.o -init.o : ../Modules/cell_base.o -init.o : ../Modules/control_flags.o -init.o : ../Modules/fft_base.o -init.o : ../Modules/fft_types.o -init.o : ../Modules/griddim.o -init.o : ../Modules/io_files.o -init.o : ../Modules/io_global.o -init.o : ../Modules/ions_base.o -init.o : ../Modules/kind.o -init.o : ../Modules/mp_global.o -init.o : ../Modules/recvec.o -init.o : ../Modules/smallbox.o -init.o : ../Modules/stick_base.o -init.o : ../Modules/task_groups.o -init.o : ../Modules/uspp.o -init.o : atoms_type.o -init.o : cp_restart.o -init.o : electrons.o -init.o : ions_positions.o -init.o : mainvar.o -init.o : modules.o -init.o : problem_size.o -init_run.o : ../Modules/cell_base.o -init_run.o : ../Modules/control_flags.o -init_run.o : ../Modules/electrons_base.o -init_run.o : ../Modules/energies.o -init_run.o : ../Modules/fft_base.o -init_run.o : ../Modules/functionals.o -init_run.o : ../Modules/griddim.o -init_run.o : ../Modules/input_parameters.o -init_run.o : ../Modules/io_files.o -init_run.o : ../Modules/io_global.o -init_run.o : ../Modules/ions_base.o -init_run.o : ../Modules/ions_nose.o -init_run.o : ../Modules/kind.o -init_run.o : ../Modules/printout_base.o -init_run.o : ../Modules/recvec.o -init_run.o : ../Modules/timestep.o -init_run.o : ../Modules/twin_types.o -init_run.o : ../Modules/uspp.o -init_run.o : ../Modules/wavefunctions.o -init_run.o : ../Modules/xml_io_base.o -init_run.o : cg.o -init_run.o : cp_emass.o -init_run.o : cp_interfaces.o -init_run.o : efield.o -init_run.o : electrons.o -init_run.o : ensemble_dft.o -init_run.o : ions_positions.o -init_run.o : mainvar.o -init_run.o : modules.o -init_run.o : ortho_base.o -init_run.o : pseudopot.o -init_run.o : wannier.o -init_run.o : wave_types.o -inner_loop.o : ../Modules/cell_base.o -inner_loop.o : ../Modules/control_flags.o -inner_loop.o : ../Modules/electrons_base.o -inner_loop.o : ../Modules/energies.o -inner_loop.o : ../Modules/griddim.o -inner_loop.o : ../Modules/io_files.o -inner_loop.o : ../Modules/io_global.o -inner_loop.o : ../Modules/ions_base.o -inner_loop.o : ../Modules/kind.o -inner_loop.o : ../Modules/mp.o -inner_loop.o : ../Modules/mp_global.o -inner_loop.o : ../Modules/recvec.o -inner_loop.o : ../Modules/twin_types.o -inner_loop.o : ../Modules/uspp.o -inner_loop.o : cg.o -inner_loop.o : cp_interfaces.o -inner_loop.o : ensemble_dft.o -inner_loop.o : ions_positions.o -inner_loop.o : modules.o -inner_loop_cold.o : ../Modules/cell_base.o -inner_loop_cold.o : ../Modules/control_flags.o -inner_loop_cold.o : ../Modules/descriptors.o -inner_loop_cold.o : ../Modules/dspev_drv.o -inner_loop_cold.o : ../Modules/electrons_base.o -inner_loop_cold.o : ../Modules/energies.o -inner_loop_cold.o : ../Modules/griddim.o -inner_loop_cold.o : ../Modules/io_files.o -inner_loop_cold.o : ../Modules/io_global.o -inner_loop_cold.o : ../Modules/ions_base.o -inner_loop_cold.o : ../Modules/kind.o -inner_loop_cold.o : ../Modules/mp.o -inner_loop_cold.o : ../Modules/mp_global.o -inner_loop_cold.o : ../Modules/recvec.o -inner_loop_cold.o : ../Modules/twin_types.o -inner_loop_cold.o : ../Modules/uspp.o -inner_loop_cold.o : cg.o -inner_loop_cold.o : cp_interfaces.o -inner_loop_cold.o : ensemble_dft.o -inner_loop_cold.o : ions_positions.o -inner_loop_cold.o : mainvar.o -inner_loop_cold.o : modules.o -inner_loop_generalize.o : ../Modules/constants.o -inner_loop_generalize.o : ../Modules/control_flags.o -inner_loop_generalize.o : ../Modules/electrons_base.o -inner_loop_generalize.o : ../Modules/fft_base.o -inner_loop_generalize.o : ../Modules/griddim.o -inner_loop_generalize.o : ../Modules/io_global.o -inner_loop_generalize.o : ../Modules/ions_base.o -inner_loop_generalize.o : ../Modules/kind.o -inner_loop_generalize.o : ../Modules/mp.o -inner_loop_generalize.o : ../Modules/mp_global.o -inner_loop_generalize.o : ../Modules/recvec.o -inner_loop_generalize.o : ../Modules/twin_types.o -inner_loop_generalize.o : ../Modules/uspp.o -inner_loop_generalize.o : cg.o -inner_loop_generalize.o : cp_interfaces.o -inner_loop_generalize.o : electrons.o -inner_loop_generalize.o : mainvar.o -inner_loop_generalize.o : modules.o -inner_loop_smear.o : ../Modules/cell_base.o -inner_loop_smear.o : ../Modules/control_flags.o -inner_loop_smear.o : ../Modules/descriptors.o -inner_loop_smear.o : ../Modules/electrons_base.o -inner_loop_smear.o : ../Modules/energies.o -inner_loop_smear.o : ../Modules/griddim.o -inner_loop_smear.o : ../Modules/io_files.o -inner_loop_smear.o : ../Modules/io_global.o -inner_loop_smear.o : ../Modules/ions_base.o -inner_loop_smear.o : ../Modules/kind.o -inner_loop_smear.o : ../Modules/mp.o -inner_loop_smear.o : ../Modules/mp_global.o -inner_loop_smear.o : ../Modules/recvec.o -inner_loop_smear.o : ../Modules/uspp.o -inner_loop_smear.o : cp_interfaces.o -inner_loop_smear.o : ions_positions.o -inner_loop_smear.o : mainvar.o -inner_loop_smear.o : modules.o -input.o : ../Modules/autopilot.o -input.o : ../Modules/cell_base.o -input.o : ../Modules/constants.o -input.o : ../Modules/constraints_module.o -input.o : ../Modules/control_flags.o -input.o : ../Modules/electrons_base.o -input.o : ../Modules/griddim.o -input.o : ../Modules/input_parameters.o -input.o : ../Modules/io_files.o -input.o : ../Modules/io_global.o -input.o : ../Modules/ions_base.o -input.o : ../Modules/ions_nose.o -input.o : ../Modules/kind.o -input.o : ../Modules/metadyn_vars.o -input.o : ../Modules/printout_base.o -input.o : ../Modules/read_cards.o -input.o : ../Modules/read_namelists.o -input.o : ../Modules/sic.o -input.o : ../Modules/timestep.o -input.o : ../Modules/wave_base.o -input.o : ../Modules/xml_input.o -input.o : ../Modules/xml_io_base.o -input.o : cg.o -input.o : chargemix.o -input.o : cp_emass.o -input.o : efield.o -input.o : electrons.o -input.o : ensemble_dft.o -input.o : ksstates.o -input.o : mainvar.o -input.o : modules.o -input.o : pres_ai_mod.o -input.o : read_pseudo.o -input.o : turbo.o -input.o : wannier_base.o -io_pot_sic_xml.o : ../Modules/control_flags.o -io_pot_sic_xml.o : ../Modules/fft_base.o -io_pot_sic_xml.o : ../Modules/io_files.o -io_pot_sic_xml.o : ../Modules/io_global.o -io_pot_sic_xml.o : ../Modules/kind.o -io_pot_sic_xml.o : ../Modules/mp_global.o -io_pot_sic_xml.o : ../Modules/xml_io_base.o -ions_positions.o : ../Modules/cell_base.o -ions_positions.o : ../Modules/io_global.o -ions_positions.o : ../Modules/kind.o -ions_positions.o : ../Modules/printout_base.o -ions_positions.o : atoms_type.o -ksstates.o : ../Modules/electrons_base.o -ksstates.o : ../Modules/fft_base.o -ksstates.o : ../Modules/griddim.o -ksstates.o : ../Modules/io_files.o -ksstates.o : ../Modules/io_global.o -ksstates.o : ../Modules/kind.o -ksstates.o : ../Modules/mp.o -ksstates.o : ../Modules/mp_global.o -ksstates.o : ../Modules/recvec.o -ksstates.o : ../Modules/xml_io_base.o -ksstates.o : cp_interfaces.o -ksstates.o : electrons.o -main.o : ../Modules/cell_base.o -main.o : ../Modules/check_stop.o -main.o : ../Modules/constants.o -main.o : ../Modules/control_flags.o -main.o : ../Modules/electrons_base.o -main.o : ../Modules/energies.o -main.o : ../Modules/fft_base.o -main.o : ../Modules/griddim.o -main.o : ../Modules/io_files.o -main.o : ../Modules/io_global.o -main.o : ../Modules/ions_base.o -main.o : ../Modules/ions_nose.o -main.o : ../Modules/kind.o -main.o : ../Modules/printout_base.o -main.o : ../Modules/recvec.o -main.o : ../Modules/sic.o -main.o : ../Modules/stick_base.o -main.o : ../Modules/timestep.o -main.o : ../Modules/uspp.o -main.o : ../Modules/wave_base.o -main.o : ../Modules/wavefunctions.o -main.o : atoms_type.o -main.o : cg.o -main.o : cp_emass.o -main.o : cp_interfaces.o -main.o : electrons.o -main.o : input.o -main.o : ions_positions.o -main.o : mainvar.o -main.o : modules.o -main.o : polarization.o -main.o : turbo.o -main.o : wave_types.o -main_loops.o : ../Modules/control_flags.o -main_loops.o : ../Modules/ions_base.o -main_loops.o : ../Modules/kind.o -main_loops.o : ../Modules/metadyn_base.o -main_loops.o : ../Modules/path_base.o -main_loops.o : ../Modules/path_io_routines.o -main_loops.o : cp_interfaces.o -main_loops.o : path_routines.o -mainvar.o : ../Modules/cell_base.o -mainvar.o : ../Modules/control_flags.o -mainvar.o : ../Modules/descriptors.o -mainvar.o : ../Modules/energies.o -mainvar.o : ../Modules/functionals.o -mainvar.o : ../Modules/input_parameters.o -mainvar.o : ../Modules/io_global.o -mainvar.o : ../Modules/kind.o -mainvar.o : ../Modules/mp.o -mainvar.o : ../Modules/mp_global.o -mainvar.o : ../Modules/twin_types.o -mainvar.o : modules.o -mainvar.o : pres_ai_mod.o -mainvar.o : wave_types.o -makov_payne.o : ../Modules/cell_base.o -makov_payne.o : ../Modules/constants.o -makov_payne.o : ../Modules/electrons_base.o -makov_payne.o : ../Modules/fft_base.o -makov_payne.o : ../Modules/griddim.o -makov_payne.o : ../Modules/io_global.o -makov_payne.o : ../Modules/ions_base.o -makov_payne.o : ../Modules/kind.o -makov_payne.o : ../Modules/mp.o -makov_payne.o : ../Modules/mp_global.o -makov_payne.o : ../Modules/parallel_include.o -makov_payne.o : ../Modules/recvec.o -makov_payne.o : ions_positions.o -makov_payne.o : mainvar.o -metaxc.o : ../Modules/recvec.o -modules.o : ../Modules/functionals.o -modules.o : ../Modules/input_parameters.o -modules.o : ../Modules/kind.o -modules.o : ../Modules/parameters.o -modules.o : ../Modules/twin_types.o -modules.o : ../Modules/uspp.o -move_electrons.o : ../Modules/cell_base.o -move_electrons.o : ../Modules/control_flags.o -move_electrons.o : ../Modules/electrons_base.o -move_electrons.o : ../Modules/energies.o -move_electrons.o : ../Modules/fft_base.o -move_electrons.o : ../Modules/griddim.o -move_electrons.o : ../Modules/input_parameters.o -move_electrons.o : ../Modules/io_global.o -move_electrons.o : ../Modules/ions_base.o -move_electrons.o : ../Modules/kind.o -move_electrons.o : ../Modules/mp.o -move_electrons.o : ../Modules/mp_global.o -move_electrons.o : ../Modules/recvec.o -move_electrons.o : ../Modules/uspp.o -move_electrons.o : ../Modules/wavefunctions.o -move_electrons.o : cg.o -move_electrons.o : cp_interfaces.o -move_electrons.o : efield.o -move_electrons.o : electrons.o -move_electrons.o : ensemble_dft.o -move_electrons.o : ions_positions.o -move_electrons.o : mainvar.o -move_electrons.o : modules.o -move_electrons.o : ortho_base.o -move_electrons.o : wannier.o -nksiclib.o : ../Modules/cell_base.o -nksiclib.o : ../Modules/constants.o -nksiclib.o : ../Modules/control_flags.o -nksiclib.o : ../Modules/electrons_base.o -nksiclib.o : ../Modules/fft_base.o -nksiclib.o : ../Modules/functionals.o -nksiclib.o : ../Modules/griddim.o -nksiclib.o : ../Modules/input_parameters.o -nksiclib.o : ../Modules/io_global.o -nksiclib.o : ../Modules/ions_base.o -nksiclib.o : ../Modules/kind.o -nksiclib.o : ../Modules/mp.o -nksiclib.o : ../Modules/mp_global.o -nksiclib.o : ../Modules/recvec.o -nksiclib.o : ../Modules/twin_types.o -nksiclib.o : ../Modules/uspp.o -nksiclib.o : ../Modules/wavefunctions.o -nksiclib.o : cg.o -nksiclib.o : cp_interfaces.o -nksiclib.o : electrons.o -nksiclib.o : io_pot_sic_xml.o -nksiclib.o : ions_positions.o -nksiclib.o : mainvar.o -nksiclib.o : modules.o -nl_base.o : ../Modules/cell_base.o -nl_base.o : ../Modules/constants.o -nl_base.o : ../Modules/control_flags.o -nl_base.o : ../Modules/descriptors.o -nl_base.o : ../Modules/electrons_base.o -nl_base.o : ../Modules/io_global.o -nl_base.o : ../Modules/ions_base.o -nl_base.o : ../Modules/kind.o -nl_base.o : ../Modules/mp.o -nl_base.o : ../Modules/mp_global.o -nl_base.o : ../Modules/recvec.o -nl_base.o : ../Modules/twin_types.o -nl_base.o : ../Modules/uspp.o -nl_base.o : ../Modules/wavefunctions.o -nl_base.o : mainvar.o -nl_base.o : modules.o -nlcc.o : ../Modules/atom.o -nlcc.o : ../Modules/cell_base.o -nlcc.o : ../Modules/control_flags.o -nlcc.o : ../Modules/electrons_base.o -nlcc.o : ../Modules/fft_base.o -nlcc.o : ../Modules/griddim.o -nlcc.o : ../Modules/io_global.o -nlcc.o : ../Modules/ions_base.o -nlcc.o : ../Modules/kind.o -nlcc.o : ../Modules/mp.o -nlcc.o : ../Modules/mp_global.o -nlcc.o : ../Modules/recvec.o -nlcc.o : ../Modules/smallbox.o -nlcc.o : ../Modules/uspp.o -nlcc.o : atoms_type.o -nlcc.o : cp_interfaces.o -nlcc.o : modules.o -nlcc.o : pseudo_base.o -nlcc.o : pseudopot.o -nlcc.o : spline.o -odd_alpha.o : ../Modules/electrons_base.o -odd_alpha.o : ../Modules/io_global.o -odd_alpha.o : ../Modules/ions_base.o -odd_alpha.o : ../Modules/kind.o -odd_alpha.o : ../Modules/mp.o -odd_alpha.o : ../Modules/mp_global.o -odd_alpha.o : ../Modules/recvec.o -odd_alpha.o : ../Modules/twin_types.o -odd_alpha.o : ../Modules/uspp.o -odd_alpha.o : mainvar.o -odd_alpha.o : modules.o -odd_alpha.o : ortho_base.o -ortho.o : ../Modules/control_flags.o -ortho.o : ../Modules/descriptors.o -ortho.o : ../Modules/electrons_base.o -ortho.o : ../Modules/io_global.o -ortho.o : ../Modules/ions_base.o -ortho.o : ../Modules/kind.o -ortho.o : ../Modules/mp.o -ortho.o : ../Modules/mp_global.o -ortho.o : ../Modules/ptoolkit.o -ortho.o : ../Modules/recvec.o -ortho.o : ../Modules/twin_types.o -ortho.o : ../Modules/uspp.o -ortho.o : cp_interfaces.o -ortho.o : mainvar.o -ortho.o : modules.o -ortho.o : ortho_base.o -ortho_base.o : ../Modules/constants.o -ortho_base.o : ../Modules/control_flags.o -ortho_base.o : ../Modules/descriptors.o -ortho_base.o : ../Modules/dspev_drv.o -ortho_base.o : ../Modules/io_global.o -ortho_base.o : ../Modules/ions_base.o -ortho_base.o : ../Modules/kind.o -ortho_base.o : ../Modules/mp.o -ortho_base.o : ../Modules/mp_global.o -ortho_base.o : ../Modules/ptoolkit.o -ortho_base.o : ../Modules/recvec.o -ortho_base.o : ../Modules/twin_types.o -ortho_base.o : ../Modules/uspp.o -ortho_base.o : ../Modules/zhpev_drv.o -ortho_base.o : modules.o -ortho_check.o : ../Modules/electrons_base.o -ortho_check.o : ../Modules/io_global.o -ortho_check.o : ../Modules/kind.o -ortho_check.o : ../Modules/mp.o -ortho_check.o : ../Modules/mp_global.o -ortho_check.o : ../Modules/recvec.o -ortho_check.o : ../Modules/wavefunctions.o -ortho_check.o : electrons.o -para.o : ../Modules/constants.o -para.o : ../Modules/control_flags.o -para.o : ../Modules/fft_base.o -para.o : ../Modules/griddim.o -para.o : ../Modules/io_files.o -para.o : ../Modules/io_global.o -para.o : ../Modules/kind.o -para.o : ../Modules/mp.o -para.o : ../Modules/mp_global.o -para.o : ../Modules/parallel_include.o -para.o : ../Modules/recvec.o -para.o : ../Modules/xml_io_base.o -path_routines.o : ../Modules/cell_base.o -path_routines.o : ../Modules/constants.o -path_routines.o : ../Modules/control_flags.o -path_routines.o : ../Modules/input_parameters.o -path_routines.o : ../Modules/io_files.o -path_routines.o : ../Modules/io_global.o -path_routines.o : ../Modules/ions_base.o -path_routines.o : ../Modules/kind.o -path_routines.o : ../Modules/metadyn_vars.o -path_routines.o : ../Modules/mp.o -path_routines.o : ../Modules/mp_global.o -path_routines.o : ../Modules/path_variables.o -path_routines.o : ../Modules/wrappers.o -pc3nc_fixed.o : ../Modules/electrons_base.o -pc3nc_fixed.o : ../Modules/input_parameters.o -pc3nc_fixed.o : ../Modules/io_global.o -pc3nc_fixed.o : ../Modules/kind.o -pc3nc_fixed.o : ../Modules/mp.o -pc3nc_fixed.o : ../Modules/mp_global.o -pc3nc_fixed.o : ../Modules/recvec.o -perturbing_pot.o : ../Modules/cell_base.o -perturbing_pot.o : ../Modules/constants.o -perturbing_pot.o : ../Modules/control_flags.o -perturbing_pot.o : ../Modules/electrons_base.o -perturbing_pot.o : ../Modules/fft_base.o -perturbing_pot.o : ../Modules/functionals.o -perturbing_pot.o : ../Modules/griddim.o -perturbing_pot.o : ../Modules/io_global.o -perturbing_pot.o : ../Modules/kind.o -perturbing_pot.o : ../Modules/mp.o -perturbing_pot.o : ../Modules/mp_global.o -perturbing_pot.o : ../Modules/recvec.o -perturbing_pot.o : ../Modules/twin_types.o -perturbing_pot.o : ../Modules/uspp.o -perturbing_pot.o : ../Modules/wavefunctions.o -perturbing_pot.o : cp_interfaces.o -perturbing_pot.o : modules.o -phasefactor.o : ../Modules/cell_base.o -phasefactor.o : ../Modules/constants.o -phasefactor.o : ../Modules/control_flags.o -phasefactor.o : ../Modules/griddim.o -phasefactor.o : ../Modules/io_global.o -phasefactor.o : ../Modules/ions_base.o -phasefactor.o : ../Modules/kind.o -phasefactor.o : ../Modules/recvec.o -phasefactor.o : cp_interfaces.o -polarization.o : ../Modules/berry_phase.o -polarization.o : ../Modules/cell_base.o -polarization.o : ../Modules/constants.o -polarization.o : ../Modules/io_global.o -polarization.o : ../Modules/ions_base.o -polarization.o : ../Modules/kind.o -polarization.o : ../Modules/mp.o -polarization.o : ../Modules/mp_global.o -polarization.o : ../Modules/mp_wave.o -potentials.o : ../Modules/cell_base.o -potentials.o : ../Modules/constants.o -potentials.o : ../Modules/control_flags.o -potentials.o : ../Modules/electrons_base.o -potentials.o : ../Modules/energies.o -potentials.o : ../Modules/fft_base.o -potentials.o : ../Modules/functionals.o -potentials.o : ../Modules/griddim.o -potentials.o : ../Modules/io_files.o -potentials.o : ../Modules/io_global.o -potentials.o : ../Modules/ions_base.o -potentials.o : ../Modules/kind.o -potentials.o : ../Modules/mp.o -potentials.o : ../Modules/mp_global.o -potentials.o : ../Modules/recvec.o -potentials.o : ../Modules/sic.o -potentials.o : ../Modules/uspp.o -potentials.o : atoms_type.o -potentials.o : cp_interfaces.o -potentials.o : mainvar.o -potentials.o : modules.o -potentials.o : vanderwaals.o -potentials.o : wave_types.o -pres_ai_mod.o : ../Modules/constants.o -pres_ai_mod.o : ../Modules/kind.o -pres_ai_mod.o : ../Modules/parameters.o -print_out.o : ../Modules/cell_base.o -print_out.o : ../Modules/constants.o -print_out.o : ../Modules/control_flags.o -print_out.o : ../Modules/electrons_base.o -print_out.o : ../Modules/energies.o -print_out.o : ../Modules/fft_base.o -print_out.o : ../Modules/io_files.o -print_out.o : ../Modules/io_global.o -print_out.o : ../Modules/ions_base.o -print_out.o : ../Modules/ions_nose.o -print_out.o : ../Modules/kind.o -print_out.o : ../Modules/mp.o -print_out.o : ../Modules/mp_global.o -print_out.o : ../Modules/printout_base.o -print_out.o : ../Modules/recvec.o -print_out.o : ../Modules/sic.o -print_out.o : ../Modules/timestep.o -print_out.o : ../Modules/twin_types.o -print_out.o : ../Modules/xml_io_base.o -print_out.o : atoms_type.o -print_out.o : cg.o -print_out.o : cp_interfaces.o -print_out.o : efield.o -print_out.o : electrons.o -print_out.o : environment.o -print_out.o : mainvar.o -print_out.o : modules.o -print_out.o : polarization.o -print_out.o : pres_ai_mod.o -problem_size.o : ../Modules/electrons_base.o -problem_size.o : ../Modules/fft_base.o -problem_size.o : ../Modules/io_global.o -problem_size.o : ../Modules/ions_base.o -problem_size.o : ../Modules/kind.o -problem_size.o : ../Modules/recvec.o -problem_size.o : ../Modules/uspp.o -problem_size.o : electrons.o -pseudo_base.o : ../Modules/cell_base.o -pseudo_base.o : ../Modules/constants.o -pseudo_base.o : ../Modules/control_flags.o -pseudo_base.o : ../Modules/io_global.o -pseudo_base.o : ../Modules/kind.o -pseudo_base.o : cp_interfaces.o -pseudopot.o : ../Modules/kind.o -pseudopot.o : ../Modules/uspp.o -pseudopot.o : modules.o -pseudopot.o : spline.o -pseudopot_sub.o : ../Modules/atom.o -pseudopot_sub.o : ../Modules/cell_base.o -pseudopot_sub.o : ../Modules/constants.o -pseudopot_sub.o : ../Modules/control_flags.o -pseudopot_sub.o : ../Modules/io_global.o -pseudopot_sub.o : ../Modules/ions_base.o -pseudopot_sub.o : ../Modules/kind.o -pseudopot_sub.o : ../Modules/mp.o -pseudopot_sub.o : ../Modules/mp_global.o -pseudopot_sub.o : ../Modules/parameters.o -pseudopot_sub.o : ../Modules/recvec.o -pseudopot_sub.o : ../Modules/smallbox.o -pseudopot_sub.o : ../Modules/uspp.o -pseudopot_sub.o : cp_interfaces.o -pseudopot_sub.o : cpr_mod.o -pseudopot_sub.o : modules.o -pseudopot_sub.o : pseudo_base.o -pseudopot_sub.o : pseudopot.o -pseudopot_sub.o : read_pseudo.o -pseudopot_sub.o : spline.o -qmatrixd.o : ../Modules/cell_base.o -qmatrixd.o : ../Modules/electrons_base.o -qmatrixd.o : ../Modules/io_global.o -qmatrixd.o : ../Modules/ions_base.o -qmatrixd.o : ../Modules/kind.o -qmatrixd.o : ../Modules/mp.o -qmatrixd.o : ../Modules/mp_global.o -qmatrixd.o : ../Modules/recvec.o -qmatrixd.o : ../Modules/twin_types.o -qmatrixd.o : ../Modules/uspp.o -qmatrixd.o : efield.o -qmatrixd.o : modules.o -qqberry.o : ../Modules/atom.o -qqberry.o : ../Modules/cell_base.o -qqberry.o : ../Modules/constants.o -qqberry.o : ../Modules/ions_base.o -qqberry.o : ../Modules/mp.o -qqberry.o : ../Modules/mp_global.o -qqberry.o : ../Modules/recvec.o -qqberry.o : ../Modules/uspp.o -qqberry.o : cp_interfaces.o -qqberry.o : modules.o -read_pseudo.o : ../Modules/atom.o -read_pseudo.o : ../Modules/constants.o -read_pseudo.o : ../Modules/control_flags.o -read_pseudo.o : ../Modules/functionals.o -read_pseudo.o : ../Modules/io_files.o -read_pseudo.o : ../Modules/io_global.o -read_pseudo.o : ../Modules/ions_base.o -read_pseudo.o : ../Modules/kind.o -read_pseudo.o : ../Modules/mp.o -read_pseudo.o : ../Modules/pseudo_types.o -read_pseudo.o : ../Modules/radial_grids.o -read_pseudo.o : ../Modules/read_uspp.o -read_pseudo.o : ../Modules/upf.o -read_pseudo.o : ../Modules/upf_to_internal.o -read_pseudo.o : ../Modules/uspp.o -read_pseudo.o : modules.o -restart.o : ../Modules/autopilot.o -restart.o : ../Modules/cell_base.o -restart.o : ../Modules/control_flags.o -restart.o : ../Modules/electrons_base.o -restart.o : ../Modules/griddim.o -restart.o : ../Modules/input_parameters.o -restart.o : ../Modules/io_files.o -restart.o : ../Modules/io_global.o -restart.o : ../Modules/ions_base.o -restart.o : ../Modules/ions_nose.o -restart.o : ../Modules/kind.o -restart.o : ../Modules/mp.o -restart.o : ../Modules/mp_global.o -restart.o : ../Modules/recvec.o -restart.o : ../Modules/twin_types.o -restart.o : ../Modules/wavefunctions.o -restart.o : atoms_type.o -restart.o : cp_autopilot.o -restart.o : cp_interfaces.o -restart.o : cp_restart.o -restart.o : electrons.o -restart.o : ensemble_dft.o -restart.o : ksstates.o -restart.o : mainvar.o -restart.o : modules.o -restart_sub.o : ../Modules/cell_base.o -restart_sub.o : ../Modules/control_flags.o -restart_sub.o : ../Modules/electrons_base.o -restart_sub.o : ../Modules/energies.o -restart_sub.o : ../Modules/griddim.o -restart_sub.o : ../Modules/io_global.o -restart_sub.o : ../Modules/ions_base.o -restart_sub.o : ../Modules/ions_nose.o -restart_sub.o : ../Modules/kind.o -restart_sub.o : ../Modules/mp_global.o -restart_sub.o : ../Modules/printout_base.o -restart_sub.o : ../Modules/recvec.o -restart_sub.o : ../Modules/smallbox.o -restart_sub.o : ../Modules/timestep.o -restart_sub.o : ../Modules/twin_types.o -restart_sub.o : ../Modules/uspp.o -restart_sub.o : ../Modules/wave_base.o -restart_sub.o : ../Modules/wavefunctions.o -restart_sub.o : atoms_type.o -restart_sub.o : cp_interfaces.o -restart_sub.o : efield.o -restart_sub.o : electrons.o -restart_sub.o : ions_positions.o -restart_sub.o : mainvar.o -restart_sub.o : modules.o -runcp.o : ../Modules/control_flags.o -runcp.o : ../Modules/electrons_base.o -runcp.o : ../Modules/fft_base.o -runcp.o : ../Modules/input_parameters.o -runcp.o : ../Modules/kind.o -runcp.o : ../Modules/mp.o -runcp.o : ../Modules/mp_global.o -runcp.o : ../Modules/parallel_include.o -runcp.o : ../Modules/recvec.o -runcp.o : ../Modules/task_groups.o -runcp.o : ../Modules/twin_types.o -runcp.o : ../Modules/uspp.o -runcp.o : ../Modules/wave_base.o -runcp.o : cp_interfaces.o -runcp.o : efield.o -runcp.o : ensemble_dft.o -runcp.o : mainvar.o -runcp.o : modules.o -runcp.o : wannier.o -spharmonic.o : ../Modules/constants.o -spharmonic.o : ../Modules/kind.o -spline.o : ../Modules/kind.o -start_c0_wan.o : ../Modules/kind.o -stop_run.o : ../Modules/constraints_module.o -stop_run.o : ../Modules/control_flags.o -stop_run.o : ../Modules/io_files.o -stop_run.o : ../Modules/io_global.o -stop_run.o : ../Modules/metadyn_vars.o -stop_run.o : ../Modules/mp.o -stop_run.o : ../Modules/path_io_routines.o -stop_run.o : ../Modules/path_variables.o -stop_run.o : ../Modules/recvec.o -stop_run.o : environment.o -stress.o : ../Modules/cell_base.o -stress.o : ../Modules/constants.o -stress.o : ../Modules/electrons_base.o -stress.o : ../Modules/io_global.o -stress.o : ../Modules/ions_base.o -stress.o : ../Modules/kind.o -stress.o : ../Modules/mp.o -stress.o : ../Modules/mp_global.o -stress.o : ../Modules/recvec.o -stress.o : cp_interfaces.o -stress.o : modules.o -symm_wannier.o : ../Modules/cell_base.o -symm_wannier.o : ../Modules/constants.o -symm_wannier.o : ../Modules/electrons_base.o -symm_wannier.o : ../Modules/input_parameters.o -symm_wannier.o : ../Modules/io_global.o -symm_wannier.o : ../Modules/kind.o -symm_wannier.o : ../Modules/mp.o -symm_wannier.o : ../Modules/mp_global.o -symm_wannier.o : ../Modules/recvec.o -symm_wannier.o : centers_and_spreads.o -turbo.o : ../Modules/io_global.o -turbo.o : ../Modules/kind.o -turbo.o : ../Modules/mp.o -turbo.o : ../Modules/mp_global.o -util.o : ../Modules/kind.o -vanderwaals.o : ../Modules/cell_base.o -vanderwaals.o : ../Modules/constants.o -vanderwaals.o : ../Modules/kind.o -vanderwaals.o : ../Modules/mp_global.o -vol_clu.o : ../Modules/cell_base.o -vol_clu.o : ../Modules/constants.o -vol_clu.o : ../Modules/control_flags.o -vol_clu.o : ../Modules/electrons_base.o -vol_clu.o : ../Modules/fft_base.o -vol_clu.o : ../Modules/griddim.o -vol_clu.o : ../Modules/io_global.o -vol_clu.o : ../Modules/ions_base.o -vol_clu.o : ../Modules/mp.o -vol_clu.o : ../Modules/mp_global.o -vol_clu.o : ../Modules/parameters.o -vol_clu.o : ../Modules/recvec.o -vol_clu.o : cp_interfaces.o -vol_clu.o : ions_positions.o -vol_clu.o : mainvar.o -vol_clu.o : modules.o -vol_clu.o : pres_ai_mod.o -wannier.o : ../Modules/cell_base.o -wannier.o : ../Modules/control_flags.o -wannier.o : ../Modules/electrons_base.o -wannier.o : ../Modules/griddim.o -wannier.o : ../Modules/io_global.o -wannier.o : ../Modules/ions_base.o -wannier.o : ../Modules/kind.o -wannier.o : ../Modules/printout_base.o -wannier.o : ../Modules/recvec.o -wannier.o : ../Modules/twin_types.o -wannier.o : ../Modules/uspp.o -wannier.o : ../Modules/wave_base.o -wannier.o : cp_interfaces.o -wannier.o : modules.o -wannier.o : wannier_base.o -wannier_base.o : ../Modules/kind.o -wave.o : ../Modules/constants.o -wave.o : ../Modules/control_flags.o -wave.o : ../Modules/dspev_drv.o -wave.o : ../Modules/electrons_base.o -wave.o : ../Modules/io_global.o -wave.o : ../Modules/ions_base.o -wave.o : ../Modules/kind.o -wave.o : ../Modules/mp.o -wave.o : ../Modules/mp_global.o -wave.o : ../Modules/mp_wave.o -wave.o : ../Modules/random_numbers.o -wave.o : ../Modules/recvec.o -wave.o : ../Modules/twin_types.o -wave.o : ../Modules/uspp.o -wave.o : ../Modules/wave_base.o -wave.o : ../Modules/zhpev_drv.o -wave.o : electrons.o -wave.o : mainvar.o -wave_init_wannier.o : ../Modules/control_flags.o -wave_init_wannier.o : ../Modules/dspev_drv.o -wave_init_wannier.o : ../Modules/electrons_base.o -wave_init_wannier.o : ../Modules/input_parameters.o -wave_init_wannier.o : ../Modules/io_files.o -wave_init_wannier.o : ../Modules/io_global.o -wave_init_wannier.o : ../Modules/kind.o -wave_init_wannier.o : ../Modules/mp.o -wave_init_wannier.o : ../Modules/mp_global.o -wave_init_wannier.o : ../Modules/mp_wave.o -wave_init_wannier.o : ../Modules/recvec.o -wave_init_wannier.o : ../Modules/wavefunctions.o -wave_init_wannier.o : ../Modules/xml_io_base.o -wave_init_wannier.o : cp_interfaces.o -wave_init_wannier.o : electrons.o -wave_init_wannier.o : mainvar.o -wave_types.o : ../Modules/kind.o -waveinit.o : ../Modules/kind.o -wf.o : ../Modules/cell_base.o -wf.o : ../Modules/constants.o -wf.o : ../Modules/control_flags.o -wf.o : ../Modules/electrons_base.o -wf.o : ../Modules/fft_base.o -wf.o : ../Modules/griddim.o -wf.o : ../Modules/io_global.o -wf.o : ../Modules/ions_base.o -wf.o : ../Modules/kind.o -wf.o : ../Modules/mp.o -wf.o : ../Modules/mp_global.o -wf.o : ../Modules/mp_wave.o -wf.o : ../Modules/parallel_include.o -wf.o : ../Modules/printout_base.o -wf.o : ../Modules/recvec.o -wf.o : ../Modules/twin_types.o -wf.o : ../Modules/uspp.o -wf.o : cp_interfaces.o -wf.o : modules.o -wf.o : wannier.o -wf.o : wannier_base.o -write_hamiltonian.o : ../Modules/constants.o -write_hamiltonian.o : ../Modules/io_global.o -write_hamiltonian.o : ../Modules/kind.o -write_hamiltonian.o : mainvar.o -writetofile.o : ../Modules/cell_base.o -writetofile.o : ../Modules/control_flags.o -writetofile.o : ../Modules/fft_types.o -writetofile.o : ../Modules/io_global.o -writetofile.o : ../Modules/kind.o -writetofile.o : ../Modules/mp.o -writetofile.o : ../Modules/mp_global.o -cg_empty_sub.o : ../include/f_defs.h -cg_sub.o : ../include/f_defs.h -cglib.o : ../include/f_defs.h -chargedensity.o : ../include/f_defs.h -chargemix.o : ../include/f_defs.h -chi2.o : ../include/f_defs.h -compute_fes_grads.o : ../include/f_defs.h -compute_scf.o : ../include/f_defs.h -cplib.o : ../include/f_defs.h -cplib_meta.o : ../include/f_defs.h -cpr.o : ../include/f_defs.h -cprstart.o : ../include/f_defs.h -dealloc.o : ../include/f_defs.h -electrons.o : ../include/f_defs.h -empty_koopmans_pp.o : ../include/f_defs.h -emptystates.o : ../include/f_defs.h -emptystates_tocg.o : ../include/f_defs.h -exch_corr.o : ../include/f_defs.h -fft.o : ../include/f_defs.h -forceconv.o : ../include/f_defs.h -forces.o : ../include/f_defs.h -fromscra.o : ../include/f_defs.h -geninv.o : ../include/f_defs.h -gradrho.o : ../include/f_defs.h -init_run.o : ../include/f_defs.h -inner_loop.o : ../include/f_defs.h -inner_loop_cold.o : ../include/f_defs.h -inner_loop_smear.o : ../include/f_defs.h -ksstates.o : ../include/f_defs.h -mainvar.o : ../include/f_defs.h -move_electrons.o : ../include/f_defs.h -nksiclib.o : ../include/f_defs.h -nl_base.o : ../include/f_defs.h -nlcc.o : ../include/f_defs.h -ortho.o : ../include/f_defs.h -ortho_base.o : ../include/f_defs.h -para.o : ../include/f_defs.h -perturbing_pot.o : ../include/f_defs.h -phasefactor.o : ../include/f_defs.h -polarization.o : ../include/f_defs.h -potentials.o : ../include/f_defs.h -pseudo_base.o : ../include/f_defs.h -pseudopot.o : ../include/f_defs.h -pseudopot_sub.o : ../include/f_defs.h -read_pseudo.o : ../include/f_defs.h -restart_sub.o : ../include/f_defs.h -stress.o : ../include/f_defs.h -vol_clu.o : ../include/f_defs.h -wannier.o : ../include/f_defs.h -wave.o : ../include/f_defs.h -wf.o : ../include/f_defs.h diff --git a/quantum_espresso/kcp/CPV/makov_payne.f90 b/quantum_espresso/kcp/CPV/makov_payne.f90 deleted file mode 100644 index 7a0c2f39f..000000000 --- a/quantum_espresso/kcp/CPV/makov_payne.f90 +++ /dev/null @@ -1,282 +0,0 @@ -! -! Copyright (C) 2010 Quantum ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! ... original code written by Giovanni Cantele and Paolo Cazzato; adapted to -! ... work in the parallel case by Carlo Sbraccia -! ... code for the calculation of the vacuum level written by Carlo Sbraccia -! ... code ported from PW to CP by Federico Zipoli -! -SUBROUTINE makov_payne(etot) -! -! CP Modules - USE kinds, ONLY : DP - USE ions_base, ONLY : nat, zv - USE ions_positions, ONLY : tau0, ityp - USE io_global, ONLY : io_global_start, & - stdout, ionode, ionode_id - USE constants, ONLY : pi,AUTOEV - USE cp_main_variables, ONLY : rhor - USE electrons_base, ONLY : nspin - USE cell_base, ONLY : alat, ibrav - USE parallel_include - USE grid_dimensions, ONLY : nr1x, nr2x, nr3x - USE fft_base, ONLY : dfftp -#if defined __PARA - USE mp_global, ONLY : me_image, nproc_image, intra_image_comm - USE mp, ONLY : mp_barrier -#endif -! -IMPLICIT NONE -INTEGER :: i,j,k,ip -INTEGER, ALLOCATABLE, DIMENSION(:) :: zvv -REAL(DP), ALLOCATABLE, DIMENSION(:,:,:) :: rhof -REAL(DP), ALLOCATABLE, DIMENSION(:,:) :: r -REAL(DP) :: usunx,usuny,usunz,R0(3),aa,bb,debye -REAL(DP) :: charge, charge_ion, charge_el -REAL(DP) :: dipole(3), dipole_ion(3), dipole_el(3) -REAL(DP) :: quadrupole, quadrupole_ion, quadrupole_el -REAL(DP) :: corr1, corr2, etot -REAL(DP), ALLOCATABLE, DIMENSION(:) :: rgx,rgy,rgz -INTEGER :: ierr -#if defined __PARA -INTEGER :: proc -INTEGER, ALLOCATABLE:: displs(:), recvcount(:) -#endif -REAL(KIND=DP), ALLOCATABLE:: rhodist1(:) -REAL(KIND=DP), ALLOCATABLE:: rhodist2(:) -! - IF(ibrav.NE.1)THEN - WRITE(*,*)" WARNING Makov-Payne implemented in CP only when ibrav=1 " - RETURN - ENDIF -! - usunx=1.0D0/DBLE(nr1x) - usuny=1.0D0/DBLE(nr2x) - usunz=1.0D0/DBLE(nr3x) - ALLOCATE ( r(nat,3),rhof(nr1x,nr2x,nr3x),& - & rgx(nr1x),rgy(nr2x),rgz(nr3x),zvv(nat) ) - ! - DO i=1,nat - zvv(i)=zv(ityp(i)) - DO j=1,3 - r(i,j)=tau0(j,i) - ENDDO - ENDDO - ! - ip=0 - rhof=0.0D0 -! -!-------------------------------------------------------------------- -ALLOCATE(rhodist1(nr1x*nr2x*nr3x)) -IF (nspin.EQ.2) ALLOCATE(rhodist2(nr1x*nr2x*nr3x)) -#if defined __PARA -ALLOCATE( displs( nproc_image ), recvcount( nproc_image ) ) -! - do proc=1,nproc_image - recvcount(proc) = dfftp%nnp * ( dfftp%npp(proc) ) - if (proc.eq.1) then - displs(proc)=0 - else - displs(proc)=displs(proc-1) + recvcount(proc-1) - end if - end do -! -! gather the charge density on the first node -! - call mp_barrier() - call mpi_gatherv( rhor(1,1), recvcount(me_image+1), MPI_DOUBLE_PRECISION,& - & rhodist1,recvcount, displs, MPI_DOUBLE_PRECISION,& - & ionode_id, intra_image_comm, ierr) - call errore('mpi_gatherv','ierr<>0',ierr) -! -IF(nspin .eq. 2)THEN - call mp_barrier() - call mpi_gatherv( rhor(1,2), recvcount(me_image+1), MPI_DOUBLE_PRECISION, & - & rhodist2,recvcount, displs, MPI_DOUBLE_PRECISION, & - & ionode_id, intra_image_comm, ierr) - call errore('mpi_gatherv','ierr<>0',ierr) -ENDIF -#else - rhodist1=rhor(:,1) - IF(nspin .eq. 2) rhodist2=rhor(:,2) -#endif -! -#if defined __PARA -IF ( ionode ) THEN -#endif - DO k = 1, nr3x - DO j = 1, nr2x - DO i = 1, nr1x - ip=ip+1 - IF (nspin == 1 )rhof(i,j,k)=rhodist1(ip) - IF (nspin == 2 )rhof(i,j,k)=rhodist1(ip)+rhodist2(ip) - ENDDO - ENDDO - ENDDO - ip=0 - DO i=1,nr1x - rgx(i)=DBLE(i-1)*usunx*alat - ENDDO - DO i=1,nr2x - rgy(i)=DBLE(i-1)*usuny*alat - ENDDO - DO i=1,nr3x - rgz(i)=DBLE(i-1)*usunz*alat - ENDDO - ! - !---------------------------------------------------------- - ! - ! center of charge of the ions - ! - R0=0.0D0 - DO i=1,nat - R0(1)=R0(1)+zvv(i)*r(i,1) - R0(2)=R0(2)+zvv(i)*r(i,2) - R0(3)=R0(3)+zvv(i)*r(i,3) - ENDDO - R0=R0/SUM(zvv(1:nat)) - ! - ! shift of the ions (no PBC) - ! - DO i=1,nat - r(i,1)=(r(i,1)-R0(1)) - r(i,2)=(r(i,2)-R0(2)) - r(i,3)=(r(i,3)-R0(3)) - ENDDO - ! - ! shift of the electon density - ! - DO i=1,nr1x - rgx(i)=(rgx(i)-R0(1))-alat*anint( (rgx(i)-R0(1))/alat ) - ENDDO - DO i=1,nr2x - rgy(i)=(rgy(i)-R0(2))-alat*anint( (rgy(i)-R0(2))/alat ) - ENDDO - DO i=1,nr3x - rgz(i)=(rgz(i)-R0(3))-alat*anint( (rgz(i)-R0(3))/alat ) - ENDDO - - ! - ! ions - ! - charge_ion = SUM(zvv(1:nat)) - dipole_ion = 0.D0 - quadrupole_ion = 0.D0 - - DO i = 1, nat - DO j = 1, 3 - dipole_ion(j) = dipole_ion(j) + zvv(i)*r(i,j) - quadrupole_ion = quadrupole_ion + zvv(i)*(r(i,j))**2 - ENDDO - ENDDO - - ! - ! electrons - ! - charge_el = 0.0D0 - dipole_el = 0.0D0 - quadrupole_el = 0.0D0 - - DO i = 1, nr1x - DO j = 1, nr2x - DO k = 1, nr3x - - charge_el = charge_el + rhof(i,j,k) - dipole_el(1) = dipole_el(1) + rgx(i)*rhof(i,j,k) - dipole_el(2) = dipole_el(2) + rgy(j)*rhof(i,j,k) - dipole_el(3) = dipole_el(3) + rgz(k)*rhof(i,j,k) - - quadrupole_el = quadrupole_el + rhof(i,j,k) * & - & ( (rgx(i))**2 + (rgy(j))**2 + (rgz(k))**2 ) - - ENDDO - ENDDO - ENDDO - charge_el=charge_el*alat**3/DBLE(nr1x*nr2x*nr3x) - dipole_el=dipole_el*alat**3/DBLE(nr1x*nr2x*nr3x) - quadrupole_el=quadrupole_el*alat**3/DBLE(nr1x*nr2x*nr3x) - - ! ... compute ionic+electronic total charge, dipole and quadrupole moments - ! - charge = -charge_el + charge_ion - dipole = -dipole_el + dipole_ion - quadrupole = -quadrupole_el + quadrupole_ion - ! - ! - WRITE( stdout, * )"total charge of the system ",charge - WRITE( stdout, '(/5X,"charge density inside the ", & - & "Wigner-Seitz cell:",3F14.8," el.")' ) charge_el - ! - debye = 2.54176D0 - ! - WRITE( stdout, & - '(/5X,"reference position (R0):",5X,3F14.8," bohr")' ) R0(:) - ! - ! ... A positive dipole goes from the - charge to the + charge. - ! - WRITE( stdout, '(/5X,"Dipole moments (with respect to x0):")' ) - WRITE( stdout, '( 5X,"Elect",3F10.4," au, ", 3F10.4," Debye")' ) & - (-dipole_el(ip), ip = 1, 3), (-dipole_el(ip)*debye, ip = 1, 3 ) - WRITE( stdout, '( 5X,"Ionic",3F10.4," au, ", 3F10.4," Debye")' ) & - ( dipole_ion(ip),ip = 1, 3), ( dipole_ion(ip)*debye,ip = 1, 3 ) - WRITE( stdout, '( 5X,"Total",3F10.4," au, ", 3F10.4," Debye")' ) & - ( dipole(ip), ip = 1, 3), ( dipole(ip)*debye, ip = 1, 3 ) - ! - ! ... print the electronic, ionic and total quadrupole moments - ! - WRITE( stdout, '(/5X,"Electrons quadrupole moment",F20.8," a.u.")' ) & - -quadrupole_el - WRITE( stdout, '( 5X," Ions quadrupole moment",F20.8," a.u.")' ) & - quadrupole_ion - WRITE( stdout, '( 5X," Total quadrupole moment",F20.8," a.u.")' ) & - quadrupole - ! - ! ... Makov-Payne correction, PRB 51, 43014 (1995) - ! ... Note that Eq. 15 has the wrong sign for the quadrupole term - ! - ! 1 / 2 Ry -> a.u. - corr1 = - 2.8373D0 / alat * charge**2 / 2.0D0 - ! - aa = quadrupole - bb = dipole(1)**2 + dipole(2)**2 + dipole(3)**2 - ! - ! 4 / 3 -> 2 / 3 Ry -> a.u. - corr2 = ( 2.D0 / 3.D0 * pi )*( charge*aa - bb ) / alat**3 - ! - ! ... print the Makov-Payne correction - ! - WRITE( stdout, '(/,5X,"********* MAKOV-PAYNE CORRECTION *********")' ) - ! - WRITE( stdout,'(/5X,"Makov-Payne correction ",F14.8," a.u. = ",F6.3, & - & " eV (1st order, 1/a0)")' ) -corr1, -corr1*AUTOEV - WRITE( stdout,'( 5X," ",F14.8," a.u. = ",F6.3, & - & " eV (2nd order, 1/a0^3)")' ) -corr2, -corr2*AUTOEV - WRITE( stdout,'( 5X," ",F14.8," a.u. = ",F6.3, & - & " eV (total)")' ) -corr1-corr2, (-corr1-corr2)*AUTOEV - ! - WRITE( stdout,'(/5X,"corrected Total energy = ",F14.8," a.u.")' ) & - etot - corr1 - corr2 -! -#if defined __PARA -ENDIF ! ionode -#endif -! -IF ( ALLOCATED( rhodist1 ) ) DEALLOCATE( rhodist1 ) -IF ( ALLOCATED( rhodist2 ) ) DEALLOCATE( rhodist2 ) -#if defined __PARA -IF ( ALLOCATED( displs ) ) DEALLOCATE( displs ) -IF ( ALLOCATED( recvcount ) ) DEALLOCATE( recvcount ) -#endif -IF ( ALLOCATED( r ) ) DEALLOCATE( r ) -IF ( ALLOCATED( rgx ) ) DEALLOCATE( rgx ) -IF ( ALLOCATED( rgy ) ) DEALLOCATE( rgy ) -IF ( ALLOCATED( rgz ) ) DEALLOCATE( rgz ) -IF ( ALLOCATED( zvv ) ) DEALLOCATE( zvv ) -IF ( ALLOCATED( rhof ) ) DEALLOCATE( rhof ) -! -RETURN -END diff --git a/quantum_espresso/kcp/CPV/metaxc.f90 b/quantum_espresso/kcp/CPV/metaxc.f90 deleted file mode 100644 index 296e3099f..000000000 --- a/quantum_espresso/kcp/CPV/metaxc.f90 +++ /dev/null @@ -1,102 +0,0 @@ -! -! Copyright (C) 2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -SUBROUTINE tpssmeta(nnr, nspin,grho,rho,kedtau,etxc) - ! =================== - !-------------------------------------------------------------------- - IMPLICIT NONE - ! - ! input - integer nspin , nnr - real(8) grho(nnr,3,nspin), rho(nnr,nspin),kedtau(nnr,nspin) - ! output: excrho: exc * rho ; E_xc = \int excrho(r) d_r - ! output: rhor: contains the exchange-correlation potential - real(8) etxc - REAL(8) :: zeta, rh - INTEGER :: k, ipol, is - REAL(8) :: grho2 (2), sx, sc, v1x, v2x, v3x,v1c, v2c, v3c, & - v1xup, v1xdw, v2xup, v2xdw, v1cup, v1cdw ,v2cup(3),v2cdw(3), & - v3xup, v3xdw,grhoup(3),grhodw(3),& - segno, arho, atau - REAL(8), PARAMETER :: epsr = 1.0d-6, epsg = 1.0d-10 - etxc = 0.d0 - ! calculate the gradient of rho+rho_core in real space - DO k = 1, nnr - DO is = 1, nspin - grho2 (is) = grho(k,1, is)**2 + grho(k,2,is)**2 + grho(k,3, is)**2 - ENDDO - IF (nspin == 1) THEN - ! - ! This is the spin-unpolarised case - ! - arho = ABS (rho (k, 1) ) - segno = SIGN (1.d0, rho (k, 1) ) - atau = kedtau(k,1) - IF (arho.GT.epsr.AND.grho2 (1) .GT.epsg.AND.ABS(atau).GT.epsr) THEN - CALL tpsscxc (arho, grho2(1),atau,sx, sc, & - v1x, v2x,v3x,v1c, v2c,v3c) - rho (k, 1) = (v1x + v1c ) - kedtau(k,1)= (v3x + v3c) *0.5d0 - ! h contains D(rho*Exc)/D(|grad rho|) * (grad rho) / |grad rho| - DO ipol = 1, 3 - grho(k,ipol,1) = (v2x + v2c)*grho (k,ipol,1) - ENDDO - etxc = etxc + (sx + sc) * segno - ELSE - DO ipol = 1, 3 - grho (k, ipol, 1) = 0.d0 - ENDDO - kedtau(k,1)=0.d0 - ENDIF - ELSE - ! - ! spin-polarised case - ! - CALL tpsscx_spin(rho (k, 1), rho (k, 2), grho2 (1), grho2 (2), & - kedtau(k,1),kedtau(k,2),sx, & - v1xup,v1xdw,v2xup,v2xdw,v3xup,v3xdw) - rh = rho (k, 1) + rho (k, 2) - IF (rh.GT.epsr) THEN - zeta = (rho (k, 1) - rho (k, 2) ) / rh - DO ipol=1,3 - grhoup(ipol)=grho(k,ipol,1) - grhodw(ipol)=grho(k,ipol,2) - END DO - atau=kedtau(k,1)+kedtau(k,2) - CALL tpsscc_spin(rh,zeta,grhoup,grhodw, & - atau,sc,v1cup,v1cdw,v2cup,v2cdw,v3c) - ELSE - sc = 0.d0 - v1cup = 0.d0 - v1cdw = 0.d0 - v2cup=0.d0 - v2cdw=0.d0 - v3c=0.d0 - ! - ENDIF - ! - ! first term of the gradient correction : D(rho*Exc)/D(rho) - ! - rho(k, 1) = (v1xup + v1cup) - rho(k, 2) = (v1xdw + v1cdw) - ! - ! h contains D(rho*Exc)/D(|grad rho|) * (grad rho) / |grad rho| - ! - DO ipol = 1, 3 - grho(k,ipol,1) = (v2xup*grho(k,ipol,1) + v2cup(ipol)) - grho(k,ipol,2) = (v2xdw*grho(k,ipol,2) + v2cdw(ipol)) - ENDDO - kedtau(k,1)= (v3xup + v3c) *0.5d0 - kedtau(k,2)= (v3xdw + v3c) *0.5d0 - etxc = etxc + (sx + sc) - ENDIF - ENDDO - RETURN -END SUBROUTINE tpssmeta - -!----------------------------------------------------------------------- diff --git a/quantum_espresso/kcp/CPV/modules.f90 b/quantum_espresso/kcp/CPV/modules.f90 deleted file mode 100644 index fe1025f60..000000000 --- a/quantum_espresso/kcp/CPV/modules.f90 +++ /dev/null @@ -1,679 +0,0 @@ -! -! Copyright (C) 2002-2007 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! n = total number of electronic states -! nx = if n is even, nx=n ; if it is odd, nx=n+1 -! nx is used only to dimension arrays - -! tpiba = 2*pi/alat -! tpiba2 = (2*pi/alat)**2 -! ng = number of G vectors for density and potential -! ngl = number of shells of G - -! G-vector quantities for the thick grid - see also doc in ggen -! g = G^2 in increasing order (in units of tpiba2=(2pi/a)^2) -! gl = shells of G^2 ( " " " " " ) -! gx = G-vectors ( " " " tpiba =(2pi/a) ) -! -! g2_g = all G^2 in increasing order, replicated on all procs -! mill_g = miller index of G vecs (increasing order), replicated on all procs -! mill_l = miller index of G vecs local to the processors -! ig_l2g = "l2g" means local to global, this array convert a local -! G-vector index into the global index, in other words -! the index of the G-v. in the overall array of G-vectors -! bi? = base vector used to generate the reciprocal space -! -! np = fft index for G> -! nm = fft index for G< -! mill_l = G components in crystal axis -! - - -! -! lqmax: maximum angular momentum of Q (Vanderbilt augmentation charges) -! - -! nbeta number of beta functions (sum over all l) -! kkbeta last radial mesh point used to describe functions -! which vanish outside core -! nqf coefficients in Q smoothing -! nqlc angular momenta present in Q smoothing -! lll lll(j) is l quantum number of j'th beta function -! lmaxq highest angular momentum that is present in Q functions -! lmaxkb highest angular momentum that is present in beta functions -! dion bare pseudopotential D_{\mu,\nu} parameters -! (ionic and screening parts subtracted out) -! betar the beta function on a r grid (actually, r*beta) -! qqq Q_ij matrix -! qfunc Q_ij(r) function (for r>rinner) -! rinner radius at which to cut off partial core or Q_ij -! -! qfcoef coefficients to pseudize qfunc for different total -! angular momentum (for r 0 ) then - allocate( deeq_sic(nhm, nhm, nat, nx) ) - else - allocate( deeq_sic(1, 1, nat, nx) ) - endif - ! - if ( do_nk .or. do_nkpz ) then - allocate( wxdsic(nnrx,2) ) - allocate( wrefsic(nnrx) ) - else if ( do_nki .or. do_nkipz) then - allocate( wxdsic(nnrx,2) ) - endif - if ( do_nk .or. do_nkpz .or. do_nki .or. do_nkipz) then - allocate(wtot(nnrx,2)) - sizwtot=nnrx - else - allocate(wtot(1,2)) - sizwtot=1 - endif - wtot=0.0_dp - ! - if ( dft_is_gradient() ) then - allocate( grhobar(nnrx,3,2) ) - else - allocate( grhobar(1,1,1) ) - endif - ! - allocate( odd_alpha(nx) ) - odd_alpha(:)= 0.d0 - ! - if (odd_nkscalfact) allocate(valpsi(nx,ngw) ) - ! - IF( do_pz_renorm) THEN - allocate(taukin(nnrx,nspin)) - allocate(tauw(nnrx,nspin)) - allocate(edens(nnrx,nspin)) - allocate(upsilonkin(nnrx,3,nspin)) - allocate(upsilonw(nnrx,3,nspin)) - ENDIF - ! - ! - fsic = 0.0d0 - pink = 0.0d0 - vsic = 0.0d0 - deeq_sic = 0.0d0 - vsicpsi = 0.0d0 - ! - !vxc_sic = 0.0d0 - !wxdsic = 0.0d0 - !wrefsic = 0.0d0 - !orb_rhor = 0.0d0 - !rhobar = 0.0d0 - !rhoref = 0.0d0 - ! - end subroutine allocate_nksic - ! - real(dp) function nksic_memusage( ) - ! output in MB (according to 4B integers and 8B reals) - real(dp) :: cost - ! - cost = 0.0_dp - if ( allocated(fsic) ) cost = cost + real( size(fsic) ) * 8.0_dp - if ( allocated(vsic) ) cost = cost + real( size(vsic) ) * 8.0_dp - if ( allocated(fion_sic) ) cost = cost + real( size(fion_sic) ) * 8.0_dp - if ( allocated(deeq_sic) ) cost = cost + real( size(deeq_sic) ) * 8.0_dp - if ( allocated(pink) ) cost = cost + real( size(pink) ) * 8.0_dp - if ( allocated(vsicpsi) ) cost = cost + real( size(vsicpsi) ) * 16.0_dp - if ( allocated(vxc_sic) ) cost = cost + real( size(vxc_sic) ) * 8.0_dp - if ( allocated(wxdsic) ) cost = cost + real( size(wxdsic) ) * 8.0_dp - if ( allocated(orb_rhor)) cost = cost + real( size(orb_rhor)) * 8.0_dp - if ( allocated(rhoref) ) cost = cost + real( size(rhoref) ) * 8.0_dp - if ( allocated(rhobar) ) cost = cost + real( size(rhobar) ) * 8.0_dp - if ( allocated(grhobar) ) cost = cost + real( size(grhobar) ) * 8.0_dp - if ( allocated(wrefsic) ) cost = cost + real( size(wrefsic) ) * 8.0_dp - if ( allocated(wtot) ) cost = cost + real( size(wtot) ) * 8.0_dp - ! - nksic_memusage = cost / 1000000.0_dp - ! - end function nksic_memusage - ! - subroutine deallocate_nksic - ! - use input_parameters, only: odd_nkscalfact - if(allocated(vsic)) deallocate(vsic) - if(allocated(fion_sic)) deallocate(fion_sic) - if(allocated(deeq_sic)) deallocate(deeq_sic) - if(allocated(pink)) deallocate(pink) - if(allocated(odd_alpha)) deallocate(odd_alpha) - if(allocated(taukin)) deallocate(taukin) - if(allocated(tauw)) deallocate(tauw) - if(allocated(edens)) deallocate(edens) - if(allocated(upsilonkin)) deallocate(upsilonkin) - if(allocated(upsilonw)) deallocate(upsilonw) - if(allocated(wxdsic)) deallocate(wxdsic) - if(allocated(vxc_sic)) deallocate(vxc_sic) - if(allocated(vsicpsi)) deallocate(vsicpsi) - if(allocated(wrefsic)) deallocate(wrefsic) - if(allocated(wtot)) deallocate(wtot) - if(allocated(orb_rhor)) deallocate(orb_rhor) - if(allocated(grhobar)) deallocate(grhobar) - if(allocated(rhobar)) deallocate(rhobar) - if(allocated(rhoref)) deallocate(rhoref) - if(allocated(pink_emp)) deallocate(pink_emp) - if(allocated(odd_alpha_emp)) deallocate(odd_alpha_emp) - if (odd_nkscalfact) then - if (allocated(valpsi)) deallocate(valpsi) - if (allocated(alpha0_ref)) deallocate(alpha0_ref) - if (allocated(alpha0_ref_emp)) deallocate(alpha0_ref_emp) - if (allocated(swfc_fixed)) deallocate(swfc_fixed) - call deallocate_twin(becwfc_fixed) - endif - ! - end subroutine deallocate_nksic - ! -end module nksic - - -module hfmod - ! - use kinds - implicit none - complex(dp), allocatable :: vxxpsi(:,:) - real(dp), allocatable :: exx(:) - !real(dp), allocatable :: dvxc_hf(:,:) - !real(dp) :: dexc_hf = 0.d0 - real(dp) :: hfscalfact = 1.d0 - logical :: do_hf -contains - ! - subroutine allocate_hf(ngw,nnrx,nspin,nx) - implicit none - integer, intent(in):: ngw, nnrx, nspin, nx - ! - allocate(exx(nx)) - allocate(vxxpsi(ngw,nx)) - !allocate(dvxc_hf(nnrx,nspin)) - ! - !dvxc_hf(:,:) = 0.0d0 - exx(:) = 0.0 - ! - end subroutine - ! - subroutine deallocate_hf - if(allocated(exx)) deallocate(exx) - if(allocated(vxxpsi)) deallocate(vxxpsi) - !if(allocated(dvxc_hf)) deallocate(dvxc_hf) - end subroutine - ! -end module hfmod - -module eecp_mod - USE kinds - implicit none - real(dp), allocatable :: gcorr(:) - complex(dp), allocatable :: gcorr_fft(:) - real(dp), allocatable :: gcorr1d(:) - complex(dp), allocatable :: gcorr1d_fft(:) - real(dp), allocatable :: gcorr2d(:) - complex(dp), allocatable :: gcorr2d_fft(:) - real(dp), allocatable :: vcorr(:) - complex(dp), allocatable :: vcorr_fft(:) - character (len=256) :: which_compensation - logical :: do_comp - logical :: tcc_odd - real(dp) :: ecomp -contains - ! - subroutine allocate_ee(nnrx,ngm) - implicit none - integer, intent(in):: nnrx - integer, intent(in):: ngm - allocate(gcorr(nnrx)) - allocate(gcorr_fft(nnrx)) - allocate(gcorr1d(nnrx)) - allocate(gcorr1d_fft(nnrx)) - allocate(gcorr2d(nnrx)) - allocate(gcorr2d_fft(nnrx)) - allocate(vcorr(nnrx)) - allocate(vcorr_fft(ngm)) - end subroutine - ! - subroutine deallocate_ee - if(allocated(gcorr)) deallocate(gcorr) - if(allocated(gcorr_fft)) deallocate(gcorr_fft) - if(allocated(gcorr1d)) deallocate(gcorr1d) - if(allocated(gcorr1d_fft)) deallocate(gcorr1d_fft) - if(allocated(gcorr2d)) deallocate(gcorr2d) - if(allocated(gcorr2d_fft)) deallocate(gcorr2d_fft) - if(allocated(vcorr)) deallocate(vcorr) - if(allocated(vcorr_fft)) deallocate(vcorr_fft) - end subroutine - ! -end module eecp_mod - -module efield_mod - USE kinds - implicit none - real(dp) :: ampfield(3) - logical :: do_efield - real(dp), allocatable :: efieldpot(:) - complex(dp), allocatable :: efieldpotg(:) -contains - ! - subroutine allocate_efield(nnrx,ngm) - implicit none - integer, intent(in):: nnrx - integer, intent(in):: ngm - allocate(efieldpot(nnrx)) - allocate(efieldpotg(ngm)) - end subroutine - ! - subroutine deallocate_efield - if(allocated(efieldpot)) deallocate(efieldpot) - if(allocated(efieldpotg)) deallocate(efieldpotg) - end subroutine - ! -end module efield_mod -! -! Occupation constraint ...to be implemented... -! -module step_constraint - USE kinds - implicit none - integer, parameter :: natx_ = 5000 - real(DP) :: E_con - real(DP) :: A_con(natx_,2), sigma_con(natx_), alpha_con(natx_) - logical :: step_con - ! complex(DP), allocatable:: vpsi_con(:,:) - complex(DP) :: vpsi_con(1,1) -end module step_constraint diff --git a/quantum_espresso/kcp/CPV/move_electrons.f90 b/quantum_espresso/kcp/CPV/move_electrons.f90 deleted file mode 100644 index 769370574..000000000 --- a/quantum_espresso/kcp/CPV/move_electrons.f90 +++ /dev/null @@ -1,415 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!---------------------------------------------------------------------------- -SUBROUTINE move_electrons_x( nfi, tfirst, tlast, b1, b2, b3, fion, & - enthal, enb, enbi, fccc, ccc, dt2bye, stress, tprint_ham ) - !---------------------------------------------------------------------------- - ! - ! ... this routine updates the electronic degrees of freedom - ! -!$$ -!$$ CHP (August 10 / 2011) -!$$ -!$$ An optimal unitary rotation among occupied states is calculated by setting -!$$ 'do_innerloop=.true.' in the namelist SYSTEM of the input file. -!$$ Also, either CG or SD with parabolic minimization or steepest-descent method without -!$$ parabolic minimization can be chosen: 'do_innerloop_cg' being .true. or .false. -!$$ (Default: do_innerloop_cg=.false.) -!$$ Convergence for this inner loop minimization and (conventional) outer loop minimization -!$$ can be found in the files convg_inner.dat and convg_outer.dat, respectively. -!$$ esic_conv_thr is the threshold of convergence for the inner loop minimization. -!$$ -!$$ When do_innerloop_cg=.true., one could also set innerloop_cg_nsd (the number of -!$$ initial steepest-descent steps) and innerloop_cg_nreset (the number of CG step running -!$$ before resetting the CG direction, i.e., when this variable is set to 1, the calculation -!$$ becomes SD). Initially, SD is better than CG but when near the energy minimum, CG -!$$ works better. -!$$ -!$$ When the OUTERLOOP dynamics is damped dynamics, we should set innerloop_dd_nstep, -!$$ which is the number of outerloop steps between each inner loop minimization. When it is -!$$ set to 1, we do inner loop minimization at every outer loop step. -!$$ -!$$ Nota Bene: -!$$ 1. When using methods without energy functional such as nk0, do_innerloop_cg -!$$ should be set to .false. In general, it is faster to set this one to .false. -!$$ 2. Fractional occupation is not supported yet. This is the case for the outer loop's -!$$ CG routine as well - even without SIC. -!$$ - - USE kinds, ONLY : DP - USE control_flags, ONLY : lwf, tfor, tprnfor, thdyn - USE cg_module, ONLY : tcg - USE cp_main_variables, ONLY : eigr, bec, irb, eigrb, rhog, rhos, rhor, & - ei1, ei2, ei3, sfac, ema0bg, becdr, & - taub, lambda, lambdam, lambdap, lambda_bare, vpot,& - iprint_stdout !added:giovanni iprint_stdout - USE wavefunctions_module, ONLY : c0, cm, phi => cp, cdual - USE cell_base, ONLY : omega, ibrav, h, press - USE uspp, ONLY : becsum, vkb, nkb - USE energies, ONLY : ekin, enl, etot, eodd - USE electrons_base, ONLY : nbsp, nbspx, nspin, f, nudx - USE core, ONLY : nlcc_any, rhoc - USE ions_positions, ONLY : tau0 - USE dener, ONLY : detot, denl, dekin6 - USE efield_module, ONLY : tefield, ipolp, qmat, gqq, evalue, & - tefield2, ipolp2, qmat2, gqq2, evalue2 - ! - USE wannier_subroutines, ONLY : get_wannier_center, wf_options, & - write_charge_and_exit, ef_tune - USE ensemble_dft, ONLY : compute_entropy2, z0t, c0diag, becdiag, tens, tsmear, fmat0_diag - USE efield_module, ONLY : berry_energy, berry_energy2 - USE cp_interfaces, ONLY : runcp_uspp, runcp_uspp_force_pairing, & - interpolate_lambda, nlfl - USE gvecw, ONLY : ngw - USE orthogonalize_base, ONLY : calphi - USE control_flags, ONLY : force_pairing, gamma_only, do_wf_cmplx !added:giovanni - USE cp_interfaces, ONLY : rhoofr, compute_stress, invfft - USE electrons_base, ONLY : ispin, iupdwn, nupdwn - USE mp, ONLY : mp_sum, mp_bcast - USE efield_mod, ONLY : do_efield - USE hfmod, ONLY : do_hf, vxxpsi, exx - USE nksic, ONLY : do_orbdep, vsic, wtot, fsic, fion_sic, deeq_sic, pink, do_wxd, sizwtot, & - valpsi, odd_alpha - ! - USE nksic, ONLY : do_innerloop,do_innerloop_cg, innerloop_dd_nstep, & - innerloop_init_n - use ions_base, only : nsp - use electrons_module, ONLY : icompute_spread, wfc_centers, wfc_spreads - use cp_main_variables, ONLY : becdual - use control_flags, ONLY : non_ortho, esic_conv_thr - use input_parameters, ONLY : odd_nkscalfact - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nfi - LOGICAL, INTENT(IN) :: tfirst, tlast - REAL(DP), INTENT(IN) :: b1(3), b2(3), b3(3) - REAL(DP) :: fion(:,:) - REAL(DP), INTENT(IN) :: dt2bye - REAL(DP) :: fccc, ccc - REAL(DP) :: enb, enbi - REAL(DP) :: enthal - REAL(DP) :: ei_unp - REAL(DP) :: stress(3,3) - LOGICAL, OPTIONAL, INTENT(IN) :: tprint_ham - ! -!$$ The following local variables are for the inner-loop, i.e., unitary rotation - INTEGER :: ninner - REAL(DP) :: Omattot(nbspx,nbspx) - INTEGER , save :: nouter = 0 - LOGICAL :: lgam !added:giovanni - INTEGER :: iss !added:giovanni - COMPLEX(DP), DIMENSION(nbsp, nbsp) :: csc !added:giovanni:debug - ! - ! - lgam=gamma_only.and..not. do_wf_cmplx - - electron_dynamic: IF ( tcg ) THEN - ! - !WRITE(*,*) mpime, 'call to runcg_uspp in move_electrons.f90' - CALL runcg_uspp( nfi, tfirst, tlast, eigr, bec, irb, eigrb, & - rhor, rhog, rhos, rhoc, ei1, ei2, ei3, sfac, & - fion, ema0bg, becdr, lambdap, lambda, lambda_bare, vpot ) - ! - CALL compute_stress( stress, detot, h, omega ) - ! - ELSE - ! - IF ( lwf ) & - CALL get_wannier_center( tfirst, cm, bec%rvec, eigr, & - eigrb, taub, irb, ibrav, b1, b2, b3 ) - ! - IF ( .NOT. tsmear ) THEN - ! - ! standard implementation - ! - csc=CMPLX(0.d0,0.d0) - ! - IF(non_ortho) THEN - call compute_duals(c0,cdual,nbsp,1) - call calbec(1,nsp,eigr,cdual,becdual) - ENDIF - ! - CALL rhoofr( nfi, c0, irb, eigrb, bec, & - becsum, rhor, rhog, rhos, enl, denl, ekin, dekin6 ) - ! - ELSE - ! - ! take into account of the proper density matrix - ! and rotate orbitals back to theie diagonal representation - ! to compute rho and other physical quantities, like the kinetic energy - ! - ! rotates the wavefunctions c0 and the overlaps bec - ! (the occupation matrix f_ij becomes diagonal f_i) - ! - CALL rotate( z0t, c0, bec, c0diag, becdiag, .false. ) - ! - IF(non_ortho) THEN - call compute_duals(c0diag,cdual,nbsp,1) - call calbec(1,nsp,eigr,cdual,becdual) - ENDIF - ! - CALL rhoofr( nfi, c0diag, irb, eigrb, becdiag, & - becsum, rhor, rhog, rhos, enl, denl, ekin, dekin6 ) - ! - ENDIF - ! - ! ... put core charge (if present) in rhoc(r) - ! - IF ( nlcc_any ) CALL set_cc( irb, eigrb, rhoc ) - ! - IF ( lwf ) THEN - ! - CALL write_charge_and_exit( rhog ) - CALL ef_tune( rhog, tau0 ) - ! - END IF - ! - vpot = rhor - ! - CALL vofrho( nfi, vpot, rhog, rhos, rhoc, tfirst, tlast, & - ei1, ei2, ei3, irb, eigrb, sfac, tau0, fion ) - ! - ! compute auxiliary potentials - ! - if( do_orbdep ) then - ! - ! - ! - if (odd_nkscalfact) then - ! - valpsi(:,:) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - call odd_alpha_routine(nbspx,.false.) - ! - endif - ! - ! - ! - if ( tens .or. tsmear) then - fsic = fmat0_diag - else - fsic = f - endif - ! - IF(MOD(nfi,iprint_stdout)==0.or.tlast) THEN - ! - icompute_spread=.true. - ! - ENDIF - ! - call nksic_potential( nbsp, nbspx, c0, fsic, bec, becsum, deeq_sic, & - ispin, iupdwn, nupdwn, rhor, rhoc, wtot, sizwtot, vsic, do_wxd, pink, nudx, & - wfc_centers, wfc_spreads, icompute_spread, .false.) - ! -!$$ We should update etot only once at the end of this do_orbdep routine - - eodd = sum(pink(1:nbsp)) - ! - - nouter = nouter + 1 - ! -#ifdef __DEBUG - if( ionode .and.( nouter == 1) ) then - ! - open(1032,file='convg_outer.dat',status='unknown') - write(1032,'("# ninner nouter non-sic energy (Ha) sic energy (Ha)")') - - if(do_innerloop) then - open(1031,file='convg_inner.dat',status='unknown') - write(1031,'("# ninner nouter non-sic energy (Ha) sic energy (Ha) RMS force eigenvalue")') - - if(do_innerloop_cg) then - open(1037,file='cg_convg.dat',status='unknown')!for debug and tuning purposes - endif - - endif - endif -#endif - -!$$ Inner loop convergence is performed only once at the first iteration: -!$$ therefore it is better to start from LDA wavefunctions which are good -!$$ except for the unitary rotation. - - ninner = 0 -!$$ -!$$ For Benzene, it has been checked that pz and nk both need only one -!$$ inner loop optimization. -!$$ - - if( do_innerloop .and. ( nouter == 1 .or. mod(nouter,innerloop_dd_nstep) == 0 ) ) then - ! - ! if( do_innerloop .and. ( nouter.eq.1) ) then - ! if( do_innerloop ) then - ! if(do_innerloop .and. nouter.eq.1) then - ! if(.false.) then - ! - if(.not.do_innerloop_cg) then - call nksic_rot_emin(nouter,ninner,etot,Omattot) - else - call nksic_rot_emin_cg(nouter, innerloop_init_n, ninner, etot, Omattot, & - esic_conv_thr, lgam) - endif - ! - eodd = sum(pink(:)) - ! - endif - - ! -#ifdef __DEBUG_EXTRA -!$$ ! to see the outer loop energy convergence - if(ionode) write(1032,'(2I10,2F24.13)') ninner, nouter,etot,sum(pink(:)) - ! -#endif -!$$ - ! - etot = etot + eodd - ! -!$$ -! if(nouter.eq.1.and.ionode) then -! write(1033,*) 'fsic',fsic -! write(1033,*) 'nupdwn',nupdwn -! write(1033,*) 'iupdwn',iupdwn -! write(1033,*) 'nbsp,nbspx',nbsp,nbspx -! endif - endif !if( do_orbdep ) - ! - if( do_hf ) then - ! - call hf_potential( nbsp, nbspx, c0, f, ispin, iupdwn, nupdwn, & - nbsp, nbspx, c0, f, ispin, iupdwn, nupdwn, & - rhor, rhog, vxxpsi, exx) - ! - etot = etot + sum(exx(1:nbsp)) - ! - endif - ! - if( do_efield ) then - ! - call calc_dipole(c0, h) - ! - endif - ! - IF ( lwf ) CALL wf_options( tfirst, nfi, cm, becsum, bec%rvec, & - eigr, eigrb, taub, irb, ibrav, b1, & - b2, b3, vpot, rhog, rhos, enl, ekin ) - ! - CALL compute_stress( stress, detot, h, omega ) - ! - enthal = etot + press * omega - ! - IF( tefield ) THEN - ! - CALL berry_energy( enb, enbi, bec%rvec, c0, fion ) - ! - etot = etot + enb + enbi - ! - END IF - ! - IF( tefield2 ) THEN - ! - CALL berry_energy2( enb, enbi, bec%rvec, c0, fion ) - ! - etot = etot + enb + enbi - ! - END IF - - ! - !======================================================================= - ! - ! verlet algorithm - ! - ! loop which updates electronic degrees of freedom - ! cm=c(t+dt) is obtained from cm=c(t-dt) and c0=c(t) - ! the electron mass rises with g**2 - ! - !======================================================================= - ! - ! This call must be done after the call to nksic_potential - ! or nksic_inner_loop - ! - CALL newd( vpot, irb, eigrb, becsum, fion ) - ! - if( do_orbdep ) then - ! - fion = fion + fion_sic - ! - endif - ! - CALL prefor( eigr, vkb ) - ! - IF( force_pairing ) THEN - ! - CALL runcp_uspp_force_pairing( fccc, ccc, ema0bg, dt2bye, & - rhos, bec%rvec, c0, cm, ei_unp ) - ! - ELSE - ! - CALL runcp_uspp( nfi, fccc, ccc, ema0bg, dt2bye, rhos, bec, c0, cm, & - tprint_ham = tprint_ham ) - ! - ENDIF - ! - !---------------------------------------------------------------------- - ! contribution to fion due to lambda - !---------------------------------------------------------------------- - ! - ! ... nlfq needs deeq bec - ! - IF ( tfor .OR. tprnfor ) CALL nlfq( c0, eigr, bec, becdr, fion, lgam ) - ! - IF ( (tfor.or.tprnfor) .AND. tefield ) & - CALL bforceion( fion, .TRUE. , ipolp, qmat, bec%rvec, becdr%rvec, gqq, evalue ) - IF ( (tfor.or.tprnfor) .AND. tefield2 ) & - CALL bforceion( fion, .TRUE. , ipolp2, qmat2, bec%rvec, becdr%rvec, gqq2, evalue2 ) - ! - IF( force_pairing ) THEN - IF(.not. lambda(2)%iscmplx) THEN - lambda(2)%rvec(:,:) = lambda(1)%rvec(:,:) - lambdam(2)%rvec(:,:) = lambdam(1)%rvec(:,:) - ELSE - lambda(2)%cvec(:,:) = lambda(1)%cvec(:,:) - lambdam(2)%cvec(:,:) = lambdam(1)%cvec(:,:) - ENDIF - ENDIF - ! - IF ( tfor .OR. thdyn ) then - CALL interpolate_lambda( lambdap, lambda, lambdam ) - ELSE - ! - ! take care of the otherwise uninitialized lambdam - ! - DO iss=1,nspin - IF(.not.lambda(iss)%iscmplx) THEN - lambdam(iss)%rvec = lambda(iss)%rvec - ELSE - lambdam(iss)%cvec = lambda(iss)%cvec - ENDIF - ENDDO - ! - END IF - ! - ! ... calphi calculates phi - ! ... the electron mass rises with g**2 - ! - CALL calphi( c0, ngw, bec, nkb, vkb, phi, nbsp, lgam, ema0bg ) - ! - ! ... begin try and error loop (only one step!) - ! - ! ... nlfl and nlfh need: lambda (guessed) becdr - ! - IF ( tfor .OR. tprnfor ) CALL nlfl_twin( bec, becdr, lambda, fion, lgam ) - ! - END IF electron_dynamic - ! - RETURN - ! -END SUBROUTINE move_electrons_x diff --git a/quantum_espresso/kcp/CPV/nksiclib.f90 b/quantum_espresso/kcp/CPV/nksiclib.f90 deleted file mode 100644 index e651d58fb..000000000 --- a/quantum_espresso/kcp/CPV/nksiclib.f90 +++ /dev/null @@ -1,8260 +0,0 @@ -! -! Copyright (C) 2007-2008 Quantum ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! Non-Koopmans method -! Developed and implemented by I. Dabo -! (Universite Paris-Est, Ecole des Ponts, ParisTech) -! Further developed and optimized by Andrea Ferretti -! (MIT, University of Oxford) -! -#include "f_defs.h" - -!----------------------------------------------------------------------- - subroutine nksic_potential( nbsp, nx, c, f_diag, bec, becsum, & - deeq_sic, ispin, iupdwn, nupdwn, & - rhor, rhoc, wtot, sizwtot, vsic, do_wxd_, pink, nudx, & - wfc_centers, wfc_spreads, & - icompute_spread, is_empty) -!----------------------------------------------------------------------- -! -! ....calculate orbital dependent potentials, -! following the Non-Koopmans' (NK) scheme, -! but also Perdew-Zunger (PZ), -! Non-Koopmans' integral definition (NKI), -! Non-Joopmans on Perdew Zunger (PZNK) -! - use kinds, only: dp - use gvecp, only: ngm - use gvecw, only: ngw - use grid_dimensions, only: nnrx - USE electrons_base, ONLY: nspin - use funct, only: dft_is_gradient - use nksic, only: orb_rhor, wxdsic, & - wrefsic, rhoref, rhobar, & - do_nk, do_nki, do_pz, do_nkpz, & - do_nkipz, do_pz_renorm, & - grhobar, fion_sic, pzalpha => odd_alpha, & - kfact, upsilonkin, upsilonw, edens,& - taukin, tauw, valpsi, odd_alpha, nkscalfact - use nksic, only: epsi2=> epsi2_cutoff_renorm - use ions_base, only: nat - use control_flags, only: gamma_only, do_wf_cmplx - use uspp_param, only: nhm - use cp_interfaces, only: nksic_get_orbitalrho - use input_parameters, only: draw_pot, pot_number, odd_nkscalfact !added:linh draw vsic potentials - use io_pot_sic_xml, only: write_pot_sic !added:linh draw vsic potentials - USE io_global, ONLY: stdout - use core, ONLY: nlcc_any - use twin_types - ! - implicit none - ! - ! -- add N. Poilvert, define explicit interface to - ! nksic_correction_nkipz - ! - INTERFACE - subroutine nksic_correction_nkipz( f, ispin, orb_rhor, & - vsic, pink, ibnd, shart, is_empty) - - use kinds, only : dp - use constants, only : e2, fpi, hartree_si, electronvolt_si - use grid_dimensions, only : nnrx - use cp_interfaces, only : fwfft, invfft, fillgrad - use funct, only : dft_is_gradient - use mp, only : mp_sum - - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(out) :: vsic(nnrx) - real(dp), intent(out) :: pink, shart - logical, optional, intent(in) :: is_empty - end subroutine nksic_correction_nkipz - END INTERFACE - ! -- add N. Poilvert, define explicit interface to - ! nksic_correction_nki - INTERFACE - subroutine nksic_correction_nki( f, ispin, orb_rhor, rhor, & - rhoref, rhobar, rhobarg, grhobar,& - vsic, wxdsic, do_wxd_, pink, ibnd, shart, is_empty ) - - use kinds, only : dp - use constants, only : e2, fpi - use nksic, only : vxc => vxc_sic - use gvecp, only : ngm - use grid_dimensions, only : nnrx - use cp_interfaces, only : fwfft, invfft, fillgrad - use funct, only : dmxc_spin, dft_is_gradient - use mp, only : mp_sum - use electrons_base, only : nspin - - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(in) :: rhor(nnrx,nspin) - real(dp), intent(in) :: rhoref(nnrx,2) - real(dp), intent(in) :: rhobar(nnrx,2) - complex(dp), intent(in) :: rhobarg(ngm,2) - real(dp), intent(in) :: grhobar(nnrx,3,2) - real(dp), intent(out) :: vsic(nnrx) - real(dp), intent(out) :: wxdsic(nnrx,2) - logical, intent(in) :: do_wxd_ - real(dp), intent(out) :: pink, shart - logical, optional, intent(in) :: is_empty - end subroutine nksic_correction_nki - END INTERFACE - - ! in/out vars - ! - integer, intent(in) :: nbsp, nx, nudx, sizwtot - complex(dp), intent(in) :: c(ngw,nx) - type(twin_matrix), intent(in) :: bec!(nkb,nbsp) !modified:giovanni - real(dp), intent(in) :: becsum( nhm*(nhm+1)/2, nat, nspin) - integer, intent(in) :: ispin(nx) - integer, intent(in) :: iupdwn(nspin), nupdwn(nspin) - real(dp), intent(in) :: f_diag(nx) - real(dp) :: rhor(nnrx,nspin) - real(dp), intent(in) :: rhoc(nnrx) - real(dp), intent(out) :: vsic(nnrx,nx), wtot(sizwtot,2) - real(dp), intent(out) :: deeq_sic(nhm,nhm,nat,nx) - logical, intent(in) :: do_wxd_ - real(dp), intent(out) :: pink(nx) - logical :: icompute_spread - real(DP) :: wfc_centers(4,nudx,nspin) - real(DP) :: wfc_spreads(nudx,nspin,2) - logical :: is_empty - ! - ! local variables - ! - integer :: i,j,jj,ibnd,ir - real(dp) :: focc,pinkpz, shart - real(dp), allocatable :: vsicpz(:), rhor_nocc(:,:) - complex(dp), allocatable :: rhobarg(:,:) - logical :: lgam, is_empty_ - ! - ! main body - ! - CALL start_clock( 'nksic_drv' ) - lgam = gamma_only.and..not.do_wf_cmplx - ! - is_empty_=is_empty - ! - ! compute potentials - ! - if (dft_is_gradient()) then - allocate(rhobarg(ngm,2)) - !write(6,*) "allocated rhobarg" - else - allocate(rhobarg(1,1)) - endif - ! - if (nlcc_any) then - ! - allocate(rhor_nocc(nnrx,nspin)) - rhor_nocc(:,:) = rhor(:,:) - ! - ! add core charge - ! - call add_cc_rspace(rhoc, rhor) - ! - endif - ! - if ( do_nk .or. do_nkpz .or. do_nki .or. do_nkipz ) then - wtot=0.0_dp - endif - ! - if ( do_nkpz .or. do_nkipz) then - allocate(vsicpz(nnrx)) - vsicpz=0.0_dp - endif - ! - pink=0.0_dp - vsic=0.0_dp - ! - ! - ! if using pz_renorm factors, compute here tauw and upsilonw - ! - if(do_pz_renorm) THEN - ! - edens=0.d0 - taukin=0.d0 - tauw=0.d0 - ! - ENDIF - ! - ! loop over bands (2 ffts at the same time) - ! - ! - do j=1,nbsp,2 - ! - ! compute orbital densities - ! n odd => c(:,n+1) is already set to zero - ! - call nksic_get_orbitalrho( ngw, nnrx, bec, ispin, nbsp, & - c(:,j), c(:,j+1), orb_rhor, j, j+1, lgam) !warning:giovanni need modification - ! - ! compute centers and spreads of nksic or pz - ! minimizing orbitals - ! - if (icompute_spread) then - ! - call compute_nksic_centers(nnrx, nx, nudx, nbsp, nspin, iupdwn, & - nupdwn, ispin, orb_rhor, wfc_centers, wfc_spreads, j, j+1) - ! - endif - ! - shart=0.d0 - ! - ! compute orbital potentials - ! - inner_loop: do jj=1,2 - ! - i=j+jj-1 - ! - ! this condition is important when n is odd - ! - if ( i > nbsp ) exit inner_loop - ! - ibnd=i - ! - if ( nspin==2 ) then - ! - if ( i >= iupdwn(2) ) ibnd=i-iupdwn(2)+1 - ! - endif - ! - ! note: iupdwn(2) is set to zero if nspin = 1 - ! - focc=f_diag(i)*DBLE(nspin)/2.0d0 - ! - ! compute parameters needed for PZ-renormalization - ! - IF(do_pz_renorm) THEN - ! - !call nksic_get_taukin_pz( focc, nspin, ispin(i), orb_rhor(:,jj), & - !taukin, ibnd, 1) - ! - IF(ibnd==1) THEN - ! - IF(nspin==1) THEN - ! - !call nksic_get_taukin_pz( 0.5d0, nspin, ispin(i), & - ! rhor(:,1), tauw, ibnd, nupdwn(ispin(i))) - ! - ELSE IF(nspin==2) THEN - ! - !call nksic_get_taukin_pz( 1.d0, nspin, ispin(i), & - ! rhor(:,ispin(i)), tauw, ibnd, nupdwn(ispin(i))) - ! - ENDIF - ! - ENDIF - ! - ENDIF - ! - ! define rhoref and rhobar - ! - call nksic_get_rhoref( i, nnrx, ispin(i), nspin, & - focc, rhor, orb_rhor(:,jj), & - rhoref, rhobar, rhobarg, grhobar ) - - ! - ! compute nk pieces to build the potentials and the energy - ! - if ( do_nk .or. do_nkpz ) then - ! - call nksic_correction_nk( focc, ispin(i), orb_rhor(:,jj), & - rhor, rhoref, rhobar, rhobarg, grhobar, & - vsic(:,i), wxdsic, wrefsic, do_wxd_, & - pink(i), ibnd, shart) - ! - wfc_spreads(ibnd, ispin(i), 2) = shart - ! - ! here information is accumulated over states - ! (wtot is added in the next loop) - ! - wtot(1:nnrx,1:2) = wtot(1:nnrx,1:2) + wxdsic(1:nnrx,1:2) - ! - ! ths sic potential is partly updated here to save some memory - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + wrefsic(1:nnrx) & - - wxdsic( 1:nnrx, ispin(i) ) - ! - endif - ! - ! compute nkpz pieces to build the potential and the energy - ! - if ( do_nkpz ) then - ! - call nksic_correction_nkpz( focc, orb_rhor(:,jj), vsicpz, & - wrefsic, pinkpz, ibnd, ispin(i)) - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + vsicpz(1:nnrx) & - + wrefsic(1:nnrx) - ! - pink(i) = pink(i) +pinkpz - ! - endif - ! - ! compute pz potentials and energy - ! - if ( do_pz ) then - ! - call nksic_correction_pz ( focc, ispin(i), orb_rhor(:,jj), & - vsic(:,i), pink(i), pzalpha(i), ibnd, shart ) - ! - wfc_spreads(ibnd, ispin(i), 2) = shart - ! - if (do_pz_renorm) then - ! - do ir=1,nnrx - ! - edens(ir,ispin(i)) = edens(ir,ispin(i)) + pink(i)*(orb_rhor(ir,jj)+epsi2)**(kfact+1.) - ! - enddo - ! - endif - ! - endif - ! - ! compute nki pieces to build the potentials and the energy - ! - if ( do_nki .or. do_nkipz) then - ! - call nksic_correction_nki( focc, ispin(i), orb_rhor(:,jj), & - rhor, rhoref, rhobar, rhobarg, grhobar, & - vsic(:,i), wxdsic, do_wxd_, pink(i), ibnd, shart, is_empty_) - ! - ! here information is accumulated over states - ! (wtot is added in the next loop) - ! - wtot(1:nnrx,1:2) = wtot(1:nnrx,1:2) + wxdsic(1:nnrx,1:2) - ! - ! ths sic potential is partly updated here to save some memory - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) - wxdsic( 1:nnrx, ispin(i) ) - ! - wfc_spreads(ibnd, ispin(i), 2) = shart - ! - endif - - if ( do_nkipz ) then - ! - call nksic_correction_nkipz( focc, ispin(i), orb_rhor(:,jj), vsicpz, & - pinkpz, ibnd, shart, is_empty_ ) - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + vsicpz(1:nnrx) - ! - pink(i) = pink(i) + pinkpz - ! - wfc_spreads(ibnd, ispin(i), 2) = shart - ! - endif - ! - ! take care of spin symmetry - ! - if (.not.do_pz_renorm) then - ! - if (.not.is_empty_) then - ! - pink(i) = 2.d0 * pink(i)/nspin - ! - else - ! - pink(i) = 2.d0 * pink(i)/nspin - ! - endif - ! - endif - ! - if ( do_nk .or. do_nkpz .or. do_nki .or. do_nkipz) then - ! - if ( nspin== 1 ) then - ! - wtot(1:nnrx,1) = wtot(1:nnrx,1) + wxdsic(1:nnrx,2) - ! - wtot(1:nnrx,2) = wtot(1:nnrx,2) + wxdsic(1:nnrx,1) - ! - endif - ! - endif - ! - enddo inner_loop - ! - enddo - ! - ! Switch off the icompute_spread flag if present - ! - IF(icompute_spread) THEN - ! - icompute_spread=.false. - ! - ENDIF - ! - ! now wtot is completely built and can be added to vsic - ! - if ( do_nk .or. do_nkpz .or. do_nki .or. do_nkipz ) then - ! - do i = 1, nbsp - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + wtot( 1:nnrx, ispin(i) ) - ! - enddo - ! - endif - ! - ! computing orbital dependent alpha - ! - if ( odd_nkscalfact ) then - ! - do j=1,nbsp,2 - ! - inner_loop_odd_alpha: do jj=1,2 - ! - i=j+jj-1 - ! - if ( i > nbsp ) exit inner_loop_odd_alpha - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i)*odd_alpha(i)/nkscalfact - ! - valpsi(i,:) = valpsi(i,:) * pink(i)/nkscalfact - ! - pink(i) = pink(i)*odd_alpha(i)/nkscalfact - ! - enddo inner_loop_odd_alpha - ! - enddo - ! - endif - ! - if ( do_pz_renorm ) then - ! - do j=1,nbsp,2 - ! - call nksic_get_orbitalrho( ngw, nnrx, bec, ispin, nbsp, & - c(:,j), c(:,j+1), orb_rhor, j, j+1, lgam) - ! - inner_loop_renorm: do jj=1,2 - ! - i=j+jj-1 - ! - if ( i > nbsp ) exit inner_loop_renorm - ! - ibnd=i - ! - focc=f_diag(i)*DBLE(nspin)/2.0d0 - ! - if ( nspin==2 ) then - ! - if ( i >= iupdwn(2) ) ibnd=i-iupdwn(2)+1 - ! - endif - ! - call nksic_get_pz_factor( nspin, ispin(i), orb_rhor(:,jj), rhor,& - taukin, tauw, pzalpha(i), ibnd, kfact) - ! - ! - ! update vsic with factor here: it works for pz, will it work for - ! nk-type functionals? - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i)*pzalpha(i) - ! - call nksic_get_pzfactor_potential(focc, nspin, ispin(i), rhor, orb_rhor(:,jj), & - pink(i), taukin, tauw, edens, upsilonkin, upsilonw, vsic(:,i), pzalpha(i), ibnd, kfact) - ! - pink(i) = pink(i)*pzalpha(i) - ! - if (.not.is_empty_) then - ! - pink(i) = f_diag(i) * pink(i) - ! - else - ! - pink(i) = 2.d0* pink(i)/nspin - ! - endif - ! - enddo inner_loop_renorm - ! - enddo - ! - endif - ! - if (draw_pot) then !added:linh draw vsic potentials - ! - write(stdout,*) "I am writing out vsic", nbsp - ! - do i =1, nbsp - ! - if (i == pot_number) call write_pot_sic ( vsic(:, i) ) - ! - enddo - ! - endif !added:linh draw vsic potentials - ! - if ( allocated(vsicpz) ) deallocate(vsicpz) - ! - ! USPP: - ! compute corrections to the D coefficients of the pseudopots - ! due to vsic(r, i) in the case of orbital dependent functionals. - ! The corresponding contributions to the forces are computed. - ! - ! IMPORTANT: the following call makes use of newd. - ! It must be done before we call newd for the - ! total potentials, because deeq is overwritten at every call - ! - fion_sic(:,:) = 0.0d0 - ! - IF ( nhm > 0 ) then - ! - deeq_sic(:,:,:,:) = 0.0d0 - ! - DO i = 1, nbsp - ! - CALL nksic_newd( i, nnrx, ispin(i), nspin, vsic(:,i), nat, nhm, & - becsum, fion_sic, deeq_sic(:,:,:,i) ) !this is for ultrasoft! watch out! warning:giovanni this has to be modified in order to run ultrasoft - ! - ENDDO - ! - ENDIF - ! - deallocate(rhobarg) - ! - if (nlcc_any) then - ! - rhor(:,:)=rhor_nocc(:,:) - deallocate(rhor_nocc) - ! - endif - ! - CALL stop_clock( 'nksic_drv' ) - return - ! -!----------------------------------------------------------------------- - end subroutine nksic_potential -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_get_orbitalrho_real( ngw, nnrx, bec, ispin, nbsp, & - c1, c2, orb_rhor, i1, i2 ) -!----------------------------------------------------------------------- -! -! Computes orbital densities on the real (not smooth) grid -! - use kinds, only: dp - use constants, only: ci - use cp_interfaces, only: fwfft, invfft, calrhovan - use fft_base, only: dffts, dfftp - use cell_base, only: omega - use gvecp, only: ngm - use gvecs, only: ngs, nps, nms - use recvecs_indexes, only: np, nm - use smooth_grid_dimensions, only: nnrsx - use cp_main_variables, only: irb,eigrb - use uspp_param, only: nhm - use electrons_base, only: nspin - use ions_base, only: nat - use uspp, only: okvan, nkb - ! - implicit none - - ! - ! input/output vars - ! - integer, intent(in) :: ngw,nnrx,i1,i2 - integer, intent(in) :: nbsp, ispin(nbsp) - real(dp), intent(in) :: bec(nkb, nbsp) - complex(dp), intent(in) :: c1(ngw),c2(ngw) - real(dp), intent(out) :: orb_rhor(nnrx,2) - - ! - ! local vars - ! - character(20) :: subname='nksic_get_orbitalrho' - integer :: ir, ig, ierr - real(dp) :: sa1 - complex(dp) :: fm, fp - complex(dp), allocatable :: psis(:), psi(:) - complex(dp), allocatable :: orb_rhog(:,:) - real(dp), allocatable :: orb_rhos(:) - real(dp), allocatable :: rhovan(:,:,:) - real(dp), allocatable :: rhovanaux(:,:,:) - ! - !==================== - ! main body - !==================== - ! - call start_clock( 'nk_orbrho' ) - - ! - if ( okvan ) then - ! - allocate(rhovan(nhm*(nhm+1)/2,nat,nspin), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating rhovan',abs(ierr)) - allocate(rhovanaux(nhm*(nhm+1)/2,nat,nspin), stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating rhovanaux',abs(ierr)) - ! - endif - ! - allocate(psi(nnrx),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating psi',abs(ierr)) - ! - allocate(orb_rhog(ngm,2),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating orb_rhog',abs(ierr)) - - sa1 = 1.0d0 / omega - - - ! - ! check whether it is necessary to - ! deal with the smooth and dense grids separately - ! - if ( nnrsx == nnrx ) then - ! - ! This case should be the case when using NCPP - ! - CALL c2psi( psi, nnrx, c1, c2, ngw, 2 ) - ! - !CALL invfft('Wave', psi, dffts ) - CALL invfft('Dense', psi, dfftp ) - ! - ! computing the orbital charge in real space on the full grid - ! - do ir = 1, nnrx - ! - orb_rhor(ir,1) = sa1 * ( DBLE(psi(ir)) )**2 - orb_rhor(ir,2) = sa1 * ( AIMAG(psi(ir)) )**2 - ! - enddo - ! - else - ! - ! this is the general case, - ! normally used with USPP - ! - allocate( psis(nnrsx), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating psis',abs(ierr)) - allocate( orb_rhos(2), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating orb_rhos',abs(ierr)) - ! - CALL c2psi( psis, nnrsx, c1, c2, ngw, 2 ) - ! - CALL invfft('Wave',psis, dffts ) - ! - ! computing the orbital charge - ! in real space on the smooth grid - ! - do ir = 1, nnrsx - ! - orb_rhos(1) = sa1 * ( DBLE(psis(ir)) )**2 - orb_rhos(2) = sa1 * ( AIMAG(psis(ir)) )**2 - ! - psis( ir ) = CMPLX( orb_rhos(1), orb_rhos(2) ) - enddo - ! - ! orbital charges are taken to the G space - ! - CALL fwfft('Smooth',psis, dffts ) - ! - do ig = 1, ngs - ! - fp=psis(nps(ig))+psis(nms(ig)) - fm=psis(nps(ig))-psis(nms(ig)) - orb_rhog(ig,1)=0.5d0*CMPLX(DBLE(fp),AIMAG(fm)) - orb_rhog(ig,2)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - ! - enddo - ! - psi (:) = (0.d0, 0.d0) - do ig=1,ngs - ! - psi(nm(ig)) = CONJG(orb_rhog(ig,1)) +ci*CONJG(orb_rhog(ig,2)) - psi(np(ig)) = orb_rhog(ig,1) +ci*orb_rhog(ig,2) - ! - enddo - ! - call invfft('Dense',psi,dfftp) - ! - do ir=1,nnrx - ! - orb_rhor(ir,1) = DBLE(psi(ir)) - orb_rhor(ir,2) = AIMAG(psi(ir)) - enddo - - deallocate( psis ) - deallocate( orb_rhos ) - - endif - - ! - ! add Vanderbilt contribution to orbital density - ! - if( okvan ) then - ! - rhovan(:,:,:) = 0.0d0 - ! - if ( nspin == 2 ) then - ! - if ( i1 <= nbsp ) then - call calrhovan(rhovanaux,bec,i1) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i1)) - endif - ! - if ( i2 <= nbsp ) then - call calrhovan(rhovanaux,bec,i2) - rhovan(:,:,2)=rhovanaux(:,:,ispin(i2)) - endif - ! - call rhov(irb,eigrb,rhovan,orb_rhog,orb_rhor, .true.) - else - ! - if ( i1 <= nbsp ) then - call calrhovan(rhovanaux,bec,i1) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i1))*0.5d0 ! 1/2 factor since rhovanaux is counted twice in the case nspin=2 - ! - call rhov(irb,eigrb,rhovan,orb_rhog(:,1),orb_rhor(:,1), .true.) - ! - endif - ! - if ( i2 <= nbsp ) then - call calrhovan(rhovanaux,bec,i2) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i2))*0.5d0 ! 1/2 factor since rhovanaux is counted twice in the case nspin=2 - ! - call rhov(irb,eigrb,rhovan,orb_rhog(:,2),orb_rhor(:,2), .true.) - ! - endif - ! - endif - ! - endif - ! - deallocate(psi) - deallocate(orb_rhog) - ! - if ( okvan ) then - deallocate(rhovan) - deallocate(rhovanaux) - endif - ! - call stop_clock('nk_orbrho') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_get_orbitalrho_real -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_get_orbitalrho_twin_non_ortho( ngw, nnrx, bec, becdual, ispin, nbsp, & - c1, c2, c1dual, c2dual,orb_rhor, i1, i2, lgam) -!----------------------------------------------------------------------- -! -! Computes orbital densities on the real (not smooth) grid -! - use kinds, only: dp - use constants, only: ci - use cp_interfaces, only: fwfft, invfft, calrhovan - use fft_base, only: dffts, dfftp - use cell_base, only: omega - use gvecp, only: ngm - use gvecs, only: ngs, nps, nms - use recvecs_indexes, only: np, nm - use smooth_grid_dimensions, only: nnrsx - use cp_main_variables, only: irb,eigrb - use uspp_param, only: nhm - use electrons_base, only: nspin - use ions_base, only: nat - use uspp, only: okvan - use twin_types - ! - implicit none - - ! - ! input/output vars - ! - integer, intent(in) :: ngw,nnrx,i1,i2 - integer, intent(in) :: nbsp, ispin(nbsp) - type(twin_matrix) :: bec, becdual !(nkb, nbsp) - complex(dp), intent(in) :: c1(ngw),c2(ngw), c1dual(ngw), c2dual(ngw) - real(dp), intent(out) :: orb_rhor(nnrx,2) - logical :: lgam - ! - ! local vars - ! - character(20) :: subname='nksic_get_orbitalrho' - integer :: ir, ig, ierr - real(dp) :: sa1 - complex(dp) :: fm, fp - complex(dp), allocatable :: psis1(:), psis2(:), psi1(:), psi2(:), & - psi1d(:), psi2d(:) - complex(dp), allocatable :: orb_rhog(:,:) - real(dp), allocatable :: orb_rhos(:) - real(dp), allocatable :: rhovan(:,:,:) - real(dp), allocatable :: rhovanaux(:,:,:) - ! - !==================== - ! main body - !==================== - ! - call start_clock( 'nksic_orbrho' ) - - ! - if ( okvan ) then - ! - allocate(rhovan(nhm*(nhm+1)/2,nat,nspin), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating rhovan',abs(ierr)) - allocate(rhovanaux(nhm*(nhm+1)/2,nat,nspin), stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating rhovanaux',abs(ierr)) - ! - endif - ! - allocate(psi1(nnrx),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating psi1',abs(ierr)) - - allocate(psi1d(nnrx),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating psi1d',abs(ierr)) - - ! - if(.not.lgam) then - allocate(psi2(nnrx),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating psi2',abs(ierr)) - allocate(psi2d(nnrx),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating psi2d',abs(ierr)) - endif - ! - allocate(orb_rhog(ngm,2),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating orb_rhog',abs(ierr)) - sa1 = 1.0d0 / omega - ! - ! check whether it is necessary to - ! deal with the smooth and dense grids separately - ! - if ( nnrsx == nnrx ) then - ! - ! This case should be the one when using NCPP - ! - if(lgam) then - CALL c2psi( psi1, nnrx, c1, c2, ngw, 2 ) - CALL c2psi(psi1d, nnrx, c1dual, c2dual, ngw, 2) - else - CALL c2psi( psi1, nnrx, c1, c2, ngw, 0 ) - CALL c2psi( psi2, nnrx, c2, c1, ngw, 0 ) - CALL c2psi(psi1d, nnrx, c1dual, c2dual, ngw, 0) - CALL c2psi(psi2d, nnrx, c2dual, c1dual, ngw, 0) - endif - ! - CALL invfft('Dense', psi1, dfftp ) - CALL invfft('Dense', psi1d, dfftp ) - ! - ! - if(.not.lgam) then - CALL invfft('Dense', psi2, dfftp ) - CALL invfft('Dense', psi2d, dfftp ) - endif - ! - ! computing the orbital charge in real space on the full grid - ! - if(lgam) then - do ir = 1, nnrx - ! - orb_rhor(ir,1) = sa1*DBLE(psi1(ir))*DBLE(psi1d(ir)) - orb_rhor(ir,2) = sa1*AIMAG(psi1(ir))*AIMAG(psi1d(ir)) - ! - enddo - else - do ir = 1, nnrx - ! - orb_rhor(ir,1) = sa1*DBLE(CONJG(psi1d(ir))*psi1(ir)) - orb_rhor(ir,2) = sa1*DBLE(CONJG(psi2d(ir))*psi2(ir)) - ! - enddo - endif - ! - else - ! - ! this is the general case, - ! normally used with USPP - ! - - allocate( psis1(nnrsx), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating psis1',abs(ierr)) - if(.not.lgam) then - allocate( psis2(nnrsx), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating psis2',abs(ierr)) - endif - - allocate( orb_rhos(2), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating orb_rhos',abs(ierr)) - ! - if(lgam) then - CALL c2psi( psis1, nnrsx, c1, c2, ngw, 2 ) - else - CALL c2psi( psis1, nnrsx, c1, c2, ngw, 0 ) - CALL c2psi( psis2, nnrsx, c2, c1, ngw, 0 ) - endif - ! - - CALL invfft('Wave',psis1, dffts ) - ! - if(.not. lgam) then - CALL invfft('Wave',psis2, dffts ) - endif - ! - ! computing the orbital charge - ! in real space on the smooth grid - ! - if(lgam) then - do ir = 1, nnrsx - ! - orb_rhos(1) = sa1 * (( DBLE(psis1(ir)) )**2 ) - orb_rhos(2) = sa1 * (( AIMAG(psis1(ir)) )**2 ) - ! - psis1( ir ) = CMPLX( orb_rhos(1), orb_rhos(2) ) - enddo - else - do ir = 1, nnrsx - ! - orb_rhos(1) = sa1 * (( DBLE(psis1(ir)) )**2 +( AIMAG(psis1(ir)) )**2) - orb_rhos(2) = sa1 * (( DBLE(psis2(ir)) )**2 +( AIMAG(psis2(ir)) )**2) - ! - psis1( ir ) = CMPLX(orb_rhos(1), orb_rhos(2)) !!!### comment for k points -! psis1( ir ) = cmplx( orb_rhos(1), 0.d0) !!!### uncomment for k points -! psis2( ir ) = cmplx( orb_rhos(2), 0.d0) !!!### uncomment for k points - enddo - endif -! write(6,*) "psis", psis1 !added:giovanni:debug - ! - ! orbital charges are taken to the G space - ! - - CALL fwfft('Smooth',psis1, dffts ) -! IF(.not.lgam) THEN ! !!!### uncomment for k points -! CALL fwfft('Smooth',psis2, dffts ) !!!### uncomment for k points -! ENDIF !!!### uncomment for k points - ! -! IF(lgam) then !!!### uncomment for k points - do ig = 1, ngs - ! - fp=psis1(nps(ig))+psis1(nms(ig)) - fm=psis1(nps(ig))-psis1(nms(ig)) - orb_rhog(ig,1)=0.5d0*CMPLX(DBLE(fp),AIMAG(fm)) - orb_rhog(ig,2)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - ! - enddo -! else !!!### uncomment for k points -! do ig = 1, ngs !!!### uncomment for k points - ! -! fp=psis1(nps(ig)) !!!### uncomment for k points -! fm=psis2(nps(ig)) !!!### uncomment for k points -! orb_rhog(ig,1)=fp !!!### uncomment for k points -! orb_rhog(ig,2)=fm !!!### uncomment for k points - ! -! enddo !!!### uncomment for k points -! endif !!!### uncomment for k points - ! - psi1 (:) = CMPLX(0.d0, 0.d0) -! if(lgam) then !!!### uncomment for k points - do ig=1,ngs - ! - psi1(nm(ig)) = CONJG( orb_rhog(ig,1) ) & - +ci*CONJG( orb_rhog(ig,2) ) - psi1(np(ig)) = orb_rhog(ig,1) +ci*orb_rhog(ig,2) - ! - enddo -! else !!!### uncomment for k points -! do ig=1,ngs !!!### uncomment for k points - ! -! psi1(nm(ig)) = conjg( orb_rhog(ig,1) ) & -! +ci*conjg( orb_rhog(ig,2) ) -! psi1(np(ig)) = orb_rhog(ig,1) +ci*orb_rhog(ig,2) !!!### uncomment for k points - ! -! enddo !!!### uncomment for k points -! endif !!!### uncomment for k points - ! - call invfft('Dense',psi1,dfftp) - ! - do ir=1,nnrx - ! - orb_rhor(ir,1) = DBLE(psi1(ir)) - orb_rhor(ir,2) = AIMAG(psi1(ir)) - enddo - - deallocate( psis1 ) - if(.not.lgam) then - deallocate(psis2) - endif - - deallocate( orb_rhos ) - - endif -! write(6,*) "orb_rhog", orb_rhog !added:giovanni:debug - ! - ! add Vanderbilt contribution to orbital density - ! - if( okvan ) then - ! - rhovan(:,:,:) = 0.0d0 - ! - if ( nspin == 2 ) then - ! - if ( i1 <= nbsp ) then - call calrhovan(rhovanaux,bec,i1) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i1)) - endif - ! - if ( i2 <= nbsp ) then - call calrhovan(rhovanaux,bec,i2) - rhovan(:,:,2)=rhovanaux(:,:,ispin(i2)) - endif - ! - call rhov(irb,eigrb,rhovan,orb_rhog,orb_rhor, lgam) - else - ! - if ( i1 <= nbsp ) then - call calrhovan(rhovanaux,bec,i1) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i1)) - ! - call rhov(irb,eigrb,rhovan,orb_rhog(:,1),orb_rhor(:,1), lgam) - endif - ! - if ( i2 <= nbsp ) then - call calrhovan(rhovanaux,bec,i2) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i2)) - ! - call rhov(irb,eigrb,rhovan,orb_rhog(:,2),orb_rhor(:,2), lgam) - endif - ! - endif - ! - endif - ! -! write(6,*) "rhovan", rhovan(:,:,1) !added:giovanni:debug -! stop - deallocate(psi1) - if(allocated(psi2)) then - deallocate(psi2) - endif - if(allocated(psi1d)) then - deallocate(psi1d) - endif - if(allocated(psi2d)) then - deallocate(psi2d) - endif - - deallocate(orb_rhog) - ! - if ( okvan ) then - deallocate(rhovan) - deallocate(rhovanaux) - endif - ! - do ir=1,nnrx - if(orb_rhor(ir,1).lt.-1.d-3.or. orb_rhor(ir,2).lt.-1.d-3) then - write(6,*) "warning, negative density", orb_rhor(ir,1), orb_rhor(ir,2) - endif - enddo - ! - call stop_clock('nksic_orbrho') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_get_orbitalrho_twin_non_ortho -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_get_orbitalrho_twin( ngw, nnrx, bec, ispin, nbsp, & - c1, c2, orb_rhor, i1, i2, lgam) -!----------------------------------------------------------------------- -! -! Computes orbital densities on the real (not smooth) grid -! - use kinds, only: dp - use constants, only: ci - use cp_interfaces, only: fwfft, invfft, calrhovan - use fft_base, only: dffts, dfftp - use cell_base, only: omega - use gvecp, only: ngm - use gvecs, only: ngs, nps, nms - use recvecs_indexes, only: np, nm - use smooth_grid_dimensions, only: nnrsx - use cp_main_variables, only: irb,eigrb - use uspp_param, only: nhm - use electrons_base, only: nspin - use ions_base, only: nat - use uspp, only: okvan - use twin_types - ! - implicit none - ! - ! input/output vars - ! - integer, intent(in) :: ngw,nnrx,i1,i2 - integer, intent(in) :: nbsp, ispin(nbsp) - type(twin_matrix) :: bec !(nkb, nbsp) - complex(dp), intent(in) :: c1(ngw),c2(ngw) - real(dp), intent(out) :: orb_rhor(nnrx,2) - logical :: lgam - ! - ! local vars - ! - character(20) :: subname='nksic_get_orbitalrho' - integer :: ir, ig, ierr - real(dp) :: sa1 - complex(dp) :: fm, fp - complex(dp), allocatable :: psis1(:), psis2(:), psi1(:), psi2(:) - complex(dp), allocatable :: orb_rhog(:,:) - real(dp), allocatable :: orb_rhos(:) - real(dp), allocatable :: rhovan(:,:,:) - real(dp), allocatable :: rhovanaux(:,:,:) - ! - !==================== - ! main body - !==================== - ! - call start_clock( 'nksic_orbrho' ) - - ! - if ( okvan ) then - ! - allocate(rhovan(nhm*(nhm+1)/2,nat,nspin), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating rhovan',abs(ierr)) - allocate(rhovanaux(nhm*(nhm+1)/2,nat,nspin), stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating rhovanaux',abs(ierr)) - ! - endif - ! - allocate(psi1(nnrx),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating psi1',abs(ierr)) - ! - if(.not.lgam) then - allocate(psi2(nnrx),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating psi2',abs(ierr)) - endif - ! - allocate(orb_rhog(ngm,2),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating orb_rhog',abs(ierr)) - - sa1 = 1.0d0 / omega - ! - ! check whether it is necessary to - ! deal with the smooth and dense grids separately - ! - if ( nnrsx == nnrx ) then - ! - ! This case should be the one when using NCPP - ! - if(lgam) then - CALL c2psi( psi1, nnrx, c1, c2, ngw, 2 ) - else - CALL c2psi( psi1, nnrx, c1, c2, ngw, 0 ) - CALL c2psi( psi2, nnrx, c2, c1, ngw, 0 ) - endif - ! - CALL invfft('Dense', psi1, dfftp ) - ! - if(.not.lgam) then - CALL invfft('Dense', psi2, dfftp ) - endif - ! - ! computing the orbital charge in real space on the full grid - ! - if(lgam) then - ! - do ir = 1, nnrx - ! - orb_rhor(ir,1) = sa1 * (( DBLE(psi1(ir)) )**2 ) - orb_rhor(ir,2) = sa1 * (( AIMAG(psi1(ir)) )**2 ) - ! - enddo - ! - else - ! - do ir = 1, nnrx - ! - orb_rhor(ir,1) = sa1 * (( abs(psi1(ir)) ))**2 - orb_rhor(ir,2) = sa1 * (( abs(psi2(ir)) ))**2 - ! - enddo - ! - endif - ! - else - ! - ! this is the general case, - ! normally used with USPP - ! - - allocate( psis1(nnrsx), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating psis1',abs(ierr)) - if(.not.lgam) then - ! - allocate( psis2(nnrsx), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating psis2',abs(ierr)) - ! - endif - ! - allocate( orb_rhos(2), stat=ierr ) - ! - if ( ierr/=0 ) call errore(subname,'allocating orb_rhos',abs(ierr)) - ! - if(lgam) then - ! - CALL c2psi( psis1, nnrsx, c1, c2, ngw, 2 ) - ! - else - ! - CALL c2psi( psis1, nnrsx, c1, c2, ngw, 0 ) - CALL c2psi( psis2, nnrsx, c2, c1, ngw, 0 ) - ! - endif - ! - CALL invfft('Wave',psis1, dffts ) - ! - if(.not. lgam) then - ! - CALL invfft('Wave',psis2, dffts ) - ! - endif - ! - ! computing the orbital charge - ! in real space on the smooth grid - ! - if(lgam) then - ! - do ir = 1, nnrsx - ! - orb_rhos(1) = sa1 * (( DBLE(psis1(ir)) )**2 ) - orb_rhos(2) = sa1 * (( AIMAG(psis1(ir)) )**2 ) - ! - psis1( ir ) = CMPLX( orb_rhos(1), orb_rhos(2) ) - ! - enddo - ! - else - ! - do ir = 1, nnrsx - ! - orb_rhos(1) = sa1 * ( abs(psis1(ir)))**2 - orb_rhos(2) = sa1 * ( abs(psis2(ir)))**2 - ! - psis1( ir ) = CMPLX(orb_rhos(1), orb_rhos(2)) !!!### comment for k points - !psis1( ir ) = cmplx( orb_rhos(1), 0.d0) !!!### uncomment for k points - !psis2( ir ) = cmplx( orb_rhos(2), 0.d0) !!!### uncomment for k points - enddo - ! - endif -! write(6,*) "psis", psis1 !added:giovanni:debug - ! - ! orbital charges are taken to the G space - ! - - CALL fwfft('Smooth',psis1, dffts ) -! IF(.not.lgam) THEN ! !!!### uncomment for k points -! CALL fwfft('Smooth',psis2, dffts ) !!!### uncomment for k points -! ENDIF !!!### uncomment for k points - ! -! IF(lgam) then !!!### uncomment for k points - do ig = 1, ngs - ! - fp=psis1(nps(ig))+psis1(nms(ig)) - fm=psis1(nps(ig))-psis1(nms(ig)) - orb_rhog(ig,1)=0.5d0*CMPLX(DBLE(fp),AIMAG(fm)) - orb_rhog(ig,2)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - ! - enddo -! else !!!### uncomment for k points -! do ig = 1, ngs !!!### uncomment for k points - ! -! fp=psis1(nps(ig)) !!!### uncomment for k points -! fm=psis2(nps(ig)) !!!### uncomment for k points -! orb_rhog(ig,1)=fp !!!### uncomment for k points -! orb_rhog(ig,2)=fm !!!### uncomment for k points - ! -! enddo !!!### uncomment for k points -! endif !!!### uncomment for k points - ! - psi1 = CMPLX(0.d0, 0.d0) -! if(lgam) then !!!### uncomment for k points - do ig=1,ngs - ! - psi1(nm(ig)) = CONJG( orb_rhog(ig,1) ) & - +ci*CONJG( orb_rhog(ig,2) ) - psi1(np(ig)) = orb_rhog(ig,1) +ci*orb_rhog(ig,2) - ! - enddo -! else !!!### uncomment for k points -! do ig=1,ngs !!!### uncomment for k points - ! -! psi1(nm(ig)) = conjg( orb_rhog(ig,1) ) & -! +ci*conjg( orb_rhog(ig,2) ) -! psi1(np(ig)) = orb_rhog(ig,1) +ci*orb_rhog(ig,2) !!!### uncomment for k points - ! -! enddo !!!### uncomment for k points -! endif !!!### uncomment for k points - ! - call invfft('Dense',psi1,dfftp) - ! - do ir=1,nnrx - ! - orb_rhor(ir,1) = DBLE(psi1(ir)) - orb_rhor(ir,2) = AIMAG(psi1(ir)) - ! - enddo - - deallocate( psis1 ) - - if(.not.lgam) then - ! - deallocate(psis2) - ! - endif - - deallocate( orb_rhos ) - - endif -! write(6,*) "orb_rhog", orb_rhog !added:giovanni:debug - ! - ! add Vanderbilt contribution to orbital density - ! - if( okvan ) then - ! - rhovan(:,:,:) = 0.0d0 - ! - if ( nspin == 2 ) then - ! - if ( i1 <= nbsp ) then - ! - call calrhovan(rhovanaux,bec,i1) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i1)) - ! - endif - ! - if ( i2 <= nbsp ) then - ! - call calrhovan(rhovanaux,bec,i2) - rhovan(:,:,2)=rhovanaux(:,:,ispin(i2)) - ! - endif - ! - call rhov(irb,eigrb,rhovan,orb_rhog,orb_rhor, lgam) - ! - else - ! - if ( i1 <= nbsp ) then - ! - call calrhovan(rhovanaux,bec,i1) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i1)) ! 0.5 to divide the factor f=2 which accounts for spin multiplicity inside calrhovan - ! - write(6,*) "calling rhov inside nksic_get_orbitalrho" - call rhov(irb,eigrb,rhovan,orb_rhog(:,1),orb_rhor(:,1), lgam) !JUST-FOR-NOW ... do we need a factor of 0.5? - ! - endif - ! - if ( i2 <= nbsp ) then - ! - call calrhovan(rhovanaux,bec,i2) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i2)) ! 0.5 to divide the factor f=2 which accounts for spin multiplicity inside calrhovan - ! - call rhov(irb,eigrb,rhovan,orb_rhog(:,2),orb_rhor(:,2), lgam) !JUST-FOR-NOW ... do we need a factor of 0.5? - ! - endif - ! - endif - ! - endif - ! -! if(okvan) write(131,*) "rhovan-calrhovan", rhovan(:,:,1) !added:giovanni:debug -! stop - deallocate(psi1) - ! - if(allocated(psi2)) then - ! - deallocate(psi2) - ! - endif - - deallocate(orb_rhog) - ! - if ( okvan ) then - ! - deallocate(rhovan) - deallocate(rhovanaux) - ! - endif - ! - call stop_clock('nksic_orbrho') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_get_orbitalrho_twin -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_get_rhoref( i, nnrx, ispin, nspin, f, & - rhor, orb_rhor, & - rhoref_, rhobar_,rhobarg, grhobar_) -!----------------------------------------------------------------------- -! -! Computes rhoref and rhobar -! - use kinds, only : dp - use gvecp, only : ngm - use funct, only : dft_is_gradient - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use recvecs_indexes, only : np, nm - use nksic, only : fref, rhobarfact - use control_flags, only : gamma_only, do_wf_cmplx - ! - implicit none - - ! - ! input/output vars - ! - integer, intent(in) :: i, nnrx - integer, intent(in) :: ispin, nspin - real(dp), intent(in) :: f - real(dp), intent(in) :: rhor(nnrx,nspin) - real(dp), intent(in) :: orb_rhor(nnrx) - real(dp), intent(out) :: rhoref_(nnrx,2) - real(dp), intent(out) :: rhobar_(nnrx,2) - complex(dp) :: rhobarg(ngm,2) - real(dp), intent(out) :: grhobar_(nnrx,3,2) - ! - integer :: ig - complex(dp) :: fp, fm - complex(dp), allocatable :: psi(:) - logical :: lgam - - ! - ! main body - ! - call start_clock( 'nksic_get_rhoref' ) - - lgam=gamma_only.and..not.do_wf_cmplx - !write(6,*) ubound(rhobarg) - !write(6,*) ubound(grhobar_) - - ! - ! define rhobar_i = rho - f_i * rho_i - ! - if ( nspin == 1 ) then - rhobar_(:,1) = rhor(:,1) * 0.5_dp - rhobar_(:,2) = rhor(:,1) * 0.5_dp - else - rhobar_(:,1:2) = rhor(:,1:2) - endif - ! - rhobar_(:,ispin) = rhobar_(:,ispin) -f * orb_rhor(:) - ! - ! probably obsolete - if ( rhobarfact < 1.0d0 ) then - rhobar_ = rhobar_ * rhobarfact - endif - - ! - ! define rhoref = rho + (f_ref -f_i) rho_i = rhobar_i + f_ref * rho_i - ! build rhoref from scratch - ! - rhoref_(:,1:2) = rhobar_(:,1:2) - rhoref_(:,ispin) = rhoref_(:,ispin) + fref * orb_rhor(:) - ! - - ! - ! compute the gradient of rhobar if needed - ! - if ( dft_is_gradient() ) then - ! - ! allocate( rhobarg(ngm,2) ) modified:giovanni rhobarg became an argument of the subroutine - allocate( psi(nnrx) ) - ! - psi(:) = CMPLX ( rhobar_(:,1), rhobar_(:,2) ) - ! - call fwfft('Dense',psi,dfftp ) - ! - do ig=1,ngm - fp = psi( np(ig) ) +psi( nm(ig) ) - fm = psi( np(ig) ) -psi( nm(ig) ) - ! - rhobarg(ig,1) = 0.5d0 *CMPLX( DBLE(fp),AIMAG(fm)) - rhobarg(ig,2) = 0.5d0 *CMPLX(AIMAG(fp),-DBLE(fm)) - enddo - ! - call fillgrad( 2, rhobarg, grhobar_, lgam ) - ! - deallocate( psi ) - ! - endif - ! - call stop_clock( 'nksic_get_rhoref' ) - return - ! -!--------------------------------------------------------------- -end subroutine nksic_get_rhoref -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_newd( i, nnrx, ispin, nspin, vsic, nat, nhm, & - becsum, fion, deeq_sic ) -!----------------------------------------------------------------------- -! -! computes the deeq coefficients (contributions to the D coeff of USPP) -! for the given orbital i. Coefficients are sotred in deeq_sic -! - use kinds, only : dp - use uspp, only : okvan, deeq - use cp_main_variables, only : irb, eigrb - ! - implicit none - - ! - ! input/output vars - ! - integer, intent(in) :: i, nnrx, nat, nhm - integer, intent(in) :: ispin, nspin - real(dp), intent(in) :: vsic(nnrx) - real(dp), intent(in) :: becsum(nhm*(nhm+1)/2,nat,nspin) - real(dp), intent(inout) :: fion(3,nat) - real(dp), intent(out) :: deeq_sic(nhm,nhm,nat) - ! - ! local vars - ! - real(dp), allocatable :: vsic_aux(:,:) - - ! - ! main body - ! - if ( .not. okvan ) then - deeq_sic(:,:,:) = 0.0d0 - return - endif - ! - call start_clock( 'nk_newd' ) - ! - allocate( vsic_aux(nnrx,nspin) ) - - ! - ! fion are updated - ! deeq coefficients are overwritten - ! - vsic_aux = 0.0d0 - vsic_aux(:, ispin ) = vsic(:) - ! - call newd( vsic_aux, irb, eigrb, becsum, fion ) - ! - deeq_sic(:,:,:) = deeq(:,:,:,ispin) - - deallocate( vsic_aux ) - ! - call stop_clock( 'nk_newd' ) - return - ! -!--------------------------------------------------------------- -end subroutine nksic_newd -!--------------------------------------------------------------- - -!--------------------------------------------------------------- - subroutine nksic_correction_nk( f, ispin, orb_rhor, rhor, & - rhoref, rhobar, rhobarg, grhobar,& - vsic, wxdsic, wrefsic, do_wxd_,& - pink, ibnd, shart) -!--------------------------------------------------------------- -! -! ... calculate the non-Koopmans potential from the orbital density -! - use kinds, only : dp - use constants, only : e2, fpi, hartree_si, electronvolt_si - use cell_base, only : tpiba2,omega - use nksic, only : fref, rhobarfact, nknmax, & - vanishing_rho_w, & - nkscalfact, do_wref, & - etxc => etxc_sic, vxc => vxc_sic - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use eecp_mod, only : do_comp - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dmxc_spin, dft_is_gradient - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use electrons_base, only : nspin - use control_flags, only : gamma_only, do_wf_cmplx - ! - implicit none - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(in) :: rhor(nnrx,nspin) - real(dp), intent(in) :: rhoref(nnrx,2) - real(dp), intent(in) :: rhobar(nnrx,2) - complex(dp), intent(in) :: rhobarg(ngm,2) - real(dp), intent(in) :: grhobar(nnrx,3,2) - real(dp), intent(out) :: vsic(nnrx), wrefsic(nnrx) - real(dp), intent(out) :: wxdsic(nnrx,2) - logical, intent(in) :: do_wxd_ - real(dp), intent(out) :: pink - ! - !character(19) :: subname='nksic_correction_nk' - integer :: ig, ir - real(dp) :: fact, ehele, etmp - real(dp) :: etxcref, etxc0, w2cst - ! - real(dp), allocatable :: rhoele(:,:) - real(dp), allocatable :: rhoraux(:,:) - real(dp), allocatable :: vxc0(:,:) - real(dp), allocatable :: vxcref(:,:) - complex(dp), allocatable :: vhaux(:) - complex(dp), allocatable :: vcorr(:) - complex(dp), allocatable :: rhogaux(:,:) - complex(dp), allocatable :: vtmp(:) - ! - real(dp), allocatable :: grhoraux(:,:,:) - real(dp), allocatable :: orb_grhor(:,:,:) - complex(dp), allocatable :: orb_rhog(:,:) - real(dp), allocatable :: haux(:,:,:) - logical :: lgam !!added:giovanni - real(dp) :: icoeff - real(dp) :: dexc_dummy(3,3) - real(dp) :: shart - ! - !================== - ! main body - !================== - ! - lgam=gamma_only.and..not.do_wf_cmplx !added:giovanni - if(lgam) then - icoeff=2.d0 - else - icoeff=1.d0 - endif - - if( ibnd > nknmax .and. nknmax .ge. 0 ) return - ! - CALL start_clock( 'nk_corr' ) - CALL start_clock( 'nk_corr_h' ) - - ! - fact=omega/DBLE(nr1*nr2*nr3) - ! - allocate(rhoele(nnrx,2)) - allocate(rhogaux(ngm,2)) - allocate(orb_rhog(ngm,1)) - allocate(vtmp(ngm)) - allocate(vcorr(ngm)) - allocate(vhaux(nnrx)) - ! - rhoele=0.0d0 - rhoele(:,ispin) = orb_rhor(:) - ! - vsic=0.0_dp - wrefsic=0.0_dp - wxdsic=0.0_dp - pink=0.0_dp - - ! - ! Compute self-hartree contributions - ! - orb_rhog=0.0_dp - ! - ! rhoele has no occupation - ! - ! f-fref is NOT included here in vhaux - ! (will be added afterwards) - ! - vhaux=0.d0 - vhaux(:) = rhoele(:,ispin) - ! - call fwfft('Dense',vhaux,dfftp ) - ! - do ig=1,ngm - orb_rhog(ig,1) = vhaux( np(ig) ) - enddo - - ! - ! compute hartree-like potential - ! - if( gstart == 2 ) vtmp(1)=(0.d0,0.d0) - do ig=gstart,ngm - vtmp(ig) = orb_rhog(ig,1) * fpi/( tpiba2*g(ig) ) - enddo - ! - ! compute periodic corrections - ! - if( do_comp ) then - ! - call calc_compensation_potential( vcorr, orb_rhog(:,1),.true.) - vtmp(:) = vtmp(:) + vcorr(:) - ! - endif - - vhaux=0.0_dp -! IF(lgam) THEN !!!### uncomment for k points - do ig=1,ngm - ! - vhaux(np(ig)) = vtmp(ig) - vhaux(nm(ig)) = CONJG(vtmp(ig)) - ! - enddo -! ELSE !!!### uncomment for k points -! do ig=1,ngm !!!### uncomment for k points - ! -! vhaux(np(ig)) = vtmp(ig) !!!### uncomment for k points -! vhaux(nm(ig)) = conjg(vtmp(ig)) - ! -! enddo !!!### uncomment for k points -! ENDIF !!!### uncomment for k points - - call invfft('Dense',vhaux,dfftp) - ! - ! init here wref sic to save some memory - ! - ! this is just the self-hartree potential - ! (to be multiplied by fref later on) - ! - wrefsic(1:nnrx) = DBLE( vhaux(1:nnrx) ) - ! - ! self-hartree contrib to pink - ! and init vsic - ! - !ehele=0.5_dp * sum(dble(vhaux(1:nnrx))*rhoele(1:nnrx,ispin)) - ! - ehele = icoeff * DBLE ( DOT_PRODUCT( vtmp(1:ngm), orb_rhog(1:ngm,1))) - if ( gstart == 2 ) ehele = ehele + (1.d0-icoeff)*DBLE ( CONJG( vtmp(1) ) * orb_rhog(1,1) ) - ! - shart = 0.5_dp * ehele * omega * hartree_si/electronvolt_si - call mp_sum(shart, intra_image_comm) - - ! the f * (2.0d0 * fref-f) term is added here - ehele = 0.5_dp * f * (2.0_dp * fref-f) * ehele * omega / fact - !shart = 0.5_dp * ehele * omega / fact - - ! - ! fref-f has to be included explicitly in rhoele - ! - vsic(1:nnrx)=(fref-f)*DBLE(vhaux(1:nnrx)) - - deallocate(vtmp) - deallocate(vcorr) - deallocate(vhaux) - ! - CALL stop_clock( 'nk_corr_h' ) - - CALL start_clock( 'nk_corr_vxc' ) - ! - ! add self-xc contributions - ! - if ( dft_is_gradient() ) then - ! - allocate(grhoraux(nnrx,3,2)) - allocate(orb_grhor(nnrx,3,1)) - allocate(haux(nnrx,2,2)) - ! - ! compute the gradient of n_i(r) - call fillgrad( 1, orb_rhog, orb_grhor(:,:,1:1), lgam ) - ! - else - allocate(grhoraux(1,1,1)) - allocate(haux(1,1,1)) - grhoraux=0.0_dp - ! - endif - ! - ! - allocate(vxc0(nnrx,2)) - allocate(vxcref(nnrx,2)) - ! - etxcref=0.0_dp - vxcref=0.0_dp - ! - !rhoraux = rhoref - ! - if ( dft_is_gradient() ) then - ! - grhoraux(:,:,1:2) = grhobar(:,:,1:2) - grhoraux(:,:,ispin) = grhobar(:,:,ispin) & - + fref * orb_grhor(:,:,1) - ! - rhogaux(:,1:2) = rhobarg(:,1:2) - rhogaux(:,ispin) = rhobarg(:,ispin) + fref * orb_rhog(:,1) - - endif - ! - !call exch_corr_wrapper(nnrx,2,grhoraux,rhoref,etxcref,vxcref,haux) - vxcref=rhoref - CALL exch_corr_cp(nnrx, 2, grhoraux, vxcref, etxcref) !proposed:giovanni fixing PBE, warning, rhoref overwritten with vxcref, check array dimensions - !NB grhoaux(nnr,3,nspin)? yes; rhoref(nnr,nspin)? yes -!begin_added:giovanni fixing PBE potential - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc should be dexc(3,3), is lgam a variable here? - call gradh( 2, grhoraux, rhogaux, vxcref, dexc_dummy, lgam) - ! grhoraux(nnr,3,nspin)?yes; rhogaux(ng,nspin)? rhoref(nnr, nspin) - ! - end if - ! - -!end_added:giovanni fixing PBE potential - - ! - ! this term is computed for ibnd, ispin == 1 and stored - ! or if rhobarfact < 1 - ! - if ( ( ibnd == 1 .and. ispin == 1) .OR. rhobarfact < 1.0_dp ) then - ! - etxc=0.0_dp - vxc=0.0_dp - ! - ! some meory can be same in the nspin-2 case, - ! considering that rhobar + f*rhoele is identical to rho - ! when rhobarfact == 1 - ! - ! call exch_corr_wrapper(nnrx,2,grhoraux,rhor,etxc,vxc,haux) - ! - allocate( rhoraux(nnrx, 2) ) - ! - rhoraux = rhobar + f*rhoele - ! - if ( dft_is_gradient() ) then - ! - grhoraux(:,:,1:2) = grhobar(:,:,1:2) - grhoraux(:,:,ispin) = grhobar(:,:,ispin) & - + f * orb_grhor(:,:,1) - ! - rhogaux(:,1:2) = rhobarg(:,1:2) - rhogaux(:,ispin) = rhobarg(:,ispin) + f * orb_rhog(:,1) - - endif - ! - !call exch_corr_wrapper(nnrx,2,grhoraux,rhoraux,etxc,vxc,haux) - vxc=rhoraux - CALL exch_corr_cp(nnrx, 2, grhoraux, vxc, etxc) !proposed:giovanni warning rhoraix is overwritten with vxc, check array dimensions - !NB grhoraux(nnr,3,nspin)? rhoraux(nnr,nspin)? - !begin_added:giovanni fixing PBE potential - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc should be dexc(3,3), is lgam a variable here? - call gradh( 2, grhoraux, rhogaux, vxc, dexc_dummy, lgam) - ! grhoraux(nnr,3,nspin)? rhogaux(ng,nspin)? rhoraux(nnr, nspin) - ! - end if - !end_added:giovanni fixing PBE potential - ! - deallocate( rhoraux ) - ! - endif - ! - deallocate(rhogaux) - deallocate(orb_rhog) - ! - etxc0=0.0_dp - vxc0=0.0_dp - ! - !rhoraux = rhobar - ! - !call exch_corr_wrapper(nnrx,2,grhobar,rhobar,etxc0,vxc0,haux) - vxc0=rhobar - CALL exch_corr_cp(nnrx, 2, grhobar, vxc0, etxc0) !proposed:giovanni warning rhobar is overwritten with vxc0, check array dimensions - !NB grhobar(nnr,3,nspin)? rhobar(nnr,nspin)? -!begin_added:giovanni fixing PBE potential - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc should be dexc(3,3), is lgam a variable here? - call gradh(2, grhobar, rhobarg, vxc0, dexc_dummy, lgam) - ! grhobar(nnr,3,nspin)? rhogbar(ng,nspin)? rhor(nnr, nspin) - ! - end if -!end_added:giovanni fixing PBE potential - ! - ! update vsic pot - ! - vsic(1:nnrx) = vsic(1:nnrx) & - + vxcref(1:nnrx,ispin)-vxc(1:nnrx,ispin) - ! - ! define pink - ! - etmp = f*sum( vxcref(1:nnrx,ispin) * rhoele(1:nnrx,ispin) ) - ! - pink = ( etxc0-etxc ) + etmp + ehele - pink = pink*fact - ! - call mp_sum(pink,intra_image_comm) - ! - call stop_clock( 'nk_corr_vxc' ) - - ! - ! calculate wref and wxd - ! - CALL start_clock( 'nk_corr_fxc' ) - ! - wxdsic(:,:) = 0.0d0 - ! - if( do_wref .or. do_wxd_ ) then - ! - ! note that vxd and wref are updated - ! (and not overwritten) by the next call - ! - call nksic_dmxc_spin_cp_update( nnrx, rhoref, f, ispin, rhoele, & - vanishing_rho_w, wrefsic, wxdsic ) !modified:linh - ! - ! - if ( do_wref ) then - ! - w2cst = sum( wrefsic(1:nnrx) * rhoele(1:nnrx,ispin) ) * fact - ! - call mp_sum(w2cst,intra_image_comm) - ! - do ir=1,nnrx - wrefsic(ir)=fref*(wrefsic(ir)-w2cst) - enddo - ! - endif - ! - if ( do_wxd_ ) then - ! - wxdsic(:,1:2)= rhobarfact *( wxdsic(:,1:2) & - + vxc0(:,1:2) -vxc(:,1:2) ) - ! - endif - ! - endif - ! - CALL stop_clock( 'nk_corr_fxc' ) - - ! - ! rescale contributions with the nkscalfact parameter - ! take care of non-variational formulations - ! - pink = pink * nkscalfact - vsic = vsic * nkscalfact - ! - if( do_wxd_ ) then - wxdsic = wxdsic * nkscalfact - else - wxdsic = 0.d0 - endif - ! - if( do_wref ) then - wrefsic = wrefsic * nkscalfact - else - wrefsic = 0.d0 - endif - - ! - deallocate(vxc0) - deallocate(vxcref) - deallocate(rhoele) - ! - deallocate(grhoraux) - deallocate(haux) - ! - if ( allocated(orb_grhor) ) deallocate(orb_grhor) - ! - CALL stop_clock( 'nk_corr' ) - return - ! -!--------------------------------------------------------------- - end subroutine nksic_correction_nk -!--------------------------------------------------------------- - -!--------------------------------------------------------------- - subroutine nksic_get_pz_factor( nspin, ispin, orb_rhor, rhor, & - taukin, tauw, alpha, ibnd, kfact) -!--------------------------------------------------------------- -! -! ... sum up the kinetic energy-density taukin ... this works both for summing -! the orbital-resolved kinetic energy densities, and for the Weizsacker kinetic -! energy density (involving the total density). -! - use kinds, only : dp - use cell_base, only : omega - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use cp_interfaces, only : fwfft, invfft, fillgrad - use funct, only : dft_is_gradient - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use control_flags, only : gamma_only, do_wf_cmplx - use nksic, only : epsi2=> epsi2_cutoff_renorm - ! - implicit none - ! - integer, intent(in) :: ispin, ibnd, nspin - real(dp), intent(in) :: orb_rhor(nnrx), taukin(nnrx,nspin), tauw(nnrx,nspin), rhor(nnrx,nspin) - real(dp), intent(out) :: alpha - real(dp), intent(in) :: kfact - ! - INTEGER :: ir - LOGICAL :: lgam - real(dp) :: fact, temp, aidfract, norm, aidspin -! real(dp), parameter :: epsi=1.d-3 - ! - lgam=gamma_only.and..not.do_wf_cmplx - fact=omega/DBLE(nr1*nr2*nr3) - ! - temp=0.d0 - norm=0.d0 - ! - IF(nspin==1) THEN - aidspin=0.5d0 - ELSE - aidspin=1.d0 - ENDIF - ! - do ir=1,nnrx - ! -! ! ! IF((tauw(ir,ispin)**2+taukin(ir,ispin)**2.gt.epsi2**4)) THEN ! - IF(aidspin*rhor(ir,ispin).gt.epsi2) THEN ! - ! -! ! ! aidfract=((tauw(ir,ispin)+epsi2)/(taukin(ir,ispin)+epsi2))**kfact - aidfract=((orb_rhor(ir)+epsi2)/(aidspin*rhor(ir,ispin)+epsi2))**kfact - ! - IF(1.d0-abs(aidfract).lt.epsi2) THEN - ! - aidfract=1.d0 - ! - ENDIF - ! - temp = temp+orb_rhor(ir)*aidfract - ! - ELSE - ! - temp = temp+orb_rhor(ir) - ! - ENDIF - ! -! norm=norm+orb_rhor(ir) - ! - enddo - ! - call mp_sum(temp,intra_image_comm) -! call mp_sum(norm,intra_image_comm) - ! - temp=temp*fact -! norm=norm*fact -! write(6,*) "checknorm", norm - ! - alpha=temp - ! - end subroutine nksic_get_pz_factor - -!--------------------------------------------------------------- - subroutine nksic_get_pzfactor_potential(f, nspin, ispin, rhor, orb_rhor, & - pink, taukin, tauw, edens, upsilonkin, upsilonw, vsic, alpha, ibnd, kfact) -!--------------------------------------------------------------- -! -! ... sum up the kinetic energy-density taukin ... this works both for summing -! the orbital-resolved kinetic energy densities, and for the Weizsacker kinetic -! energy density (involving the total density). -! - use kinds, only : dp - use cell_base, only : omega - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use cp_interfaces, only : fwfft, invfft, fillgrad - use funct, only : dft_is_gradient - use mp, only : mp_sum - use control_flags, only : gamma_only, do_wf_cmplx - use nksic, only : epsi2=> epsi2_cutoff_renorm - - ! - implicit none - ! - integer, intent(in) :: ispin, ibnd, nspin - real(dp), intent(in) :: kfact, f, orb_rhor(nnrx), taukin(nnrx,nspin) - real(dp), intent(in) :: tauw(nnrx,nspin), edens(nnrx,nspin), rhor(nnrx,nspin) - real(dp), intent(inout) :: upsilonkin(nnrx,3,nspin), upsilonw(nnrx,3,nspin) - real(dp), intent(in) :: alpha - real(dp), intent(inout) :: pink - real(dp), intent(out) :: vsic(nnrx) - ! - INTEGER :: ir,j - LOGICAL :: lgam - real(dp) :: fact, temp, tempw, aidtau, aidfrac, aidspin - complex(dp), allocatable :: rhog_dummy(:,:) - real(dp), allocatable :: upsilonh(:,:,:), vsicaux(:,:) -! real(dp), parameter :: epsi=1.d-3 - ! - lgam=gamma_only.and..not.do_wf_cmplx - fact=omega/DBLE(nr1*nr2*nr3) - ! - allocate(upsilonh(nnrx,3,nspin)) - allocate(vsicaux(nnrx,nspin)) - allocate(rhog_dummy(1,1)) - ! - upsilonh=0.d0 - ! - vsicaux=0.d0 - ! - IF(nspin==1) THEN - aidspin=0.5d0 - ELSE - aidspin=1.d0 - ENDIF -! write(6,*) "checkall", ibnd, ispin - ! -! ! ! call nksic_get_upsilon_pz( f, nspin, ispin, orb_rhor, & -! ! ! upsilonkin, ibnd) - if(ibnd==1) THEN !compute also upsilonw - ! -! ! call nksic_get_upsilon_pz( 1.d0, nspin, ispin, rhor(:,ispin), & -! upsilonw, ibnd) - ! - ENDIF - ! - ! - upsilonh=0.d0 - ! -! vsicaux(:,ispin)=vsicaux(:,ispin) - ! - do ir=1,nnrx - ! - temp=0.d0 - tempw=0.d0 - ! - do j=1,3 - ! - temp=temp+upsilonkin(ir,j,ispin)**2. - tempw=tempw+upsilonw(ir,j,ispin)**2. - ! - enddo - ! - ! -! temp=sqrt(abs(temp)) -! tempw=sqrt(abs(tempw)) -! write(6,*) "checktau", taukin(ir,ispin),tauw(ir,ispin),ispin - ! -! ! ! IF((tauw(ir,ispin)**2+taukin(ir,ispin)**2.gt.epsi2**4)) THEN - IF((aidspin*rhor(ir,ispin).gt.epsi2)) THEN ! ! THEN - ! -! ! ! aidtau=0.5d0*(temp/(taukin(ir,ispin)+epsi2)-tempw/(tauw(ir,ispin)+epsi2)) - aidtau=-edens(ir,ispin)/(aidspin*rhor(ir,ispin)+epsi2)**(kfact+1.d0) - ! -! ! ! aidfrac=((tauw(ir,ispin)+epsi2)/(taukin(ir,ispin)+epsi2))**kfact - aidfrac=((orb_rhor(ir)+epsi2)/(aidspin*rhor(ir,ispin)+epsi2))**kfact - - ! - IF(1.d0-abs(aidfrac).lt.epsi2) THEN -! ! - aidfrac=1.d0 - aidtau=0.d0 - ! - ENDIF -! ! ! - IF(abs(aidtau).lt.epsi2) THEN - ! - aidtau=0.d0 - ! - ENDIF - ! - vsicaux(ir,ispin) = vsicaux(ir,ispin) & - +pink/f*(-alpha+aidfrac) - ! -! ! ! vsicaux(ir,ispin) = vsicaux(ir,ispin)+kfact*edens(ir,ispin)*aidfrac*aidtau - vsicaux(ir,ispin) = vsicaux(ir,ispin)+kfact*aidfrac*pink/f+aidtau*kfact - ! - do j=1,3 - ! - !aidtau=0.5d0*(upsilonkin(ir,j,ispin)/(taukin(ir,ispin)+epsi2)-upsilonw(ir,j,ispin)/(tauw(ir,ispin)+epsi2)) - ! - IF(abs(aidfrac-1.d0).lt.epsi2) THEN !abs(aidtau).lt.epsi2**2 - ! - !aidtau=0.d0 - ! - ENDIF - ! - !upsilonh(ir,j,ispin) = upsilonh(ir,j,ispin) - kfact*edens(ir,ispin)*aidfrac*aidtau - ! - enddo - ! - ELSE IF(abs(1.d0-alpha).gt.epsi2**2) THEN - ! - vsicaux(ir,ispin) = vsicaux(ir,ispin) & - +pink/f*(-alpha+1.d0) - ! - ENDIF - ! - enddo - ! - ! Now we need to use fft's to add the gradient part to vsic... check the sign of this expression - ! -! call gradh( 1, upsilonh(:,:,ispin:ispin), rhog_dummy, vsicaux(:,ispin:ispin), dexc_dummy, lgam ) - ! - do ir=1,nnrx - ! - vsic(ir) = vsic(ir) + vsicaux(ir,ispin) - ! - enddo - ! - deallocate(upsilonh, vsicaux, rhog_dummy) - ! - end subroutine nksic_get_pzfactor_potential - -!--------------------------------------------------------------- - subroutine add_up_taukin(nnrx, taukin, grhoraux, orb_rhor, f) -!--------------------------------------------------------------- - ! - USE kinds, only: DP - use nksic, only : epsi=> epsi_cutoff_renorm - - ! - INTEGER, INTENT(IN) :: nnrx - REAL(DP) :: taukin(nnrx), orb_rhor(nnrx), f, grhoraux(nnrx,3) - ! - REAL(DP) :: temp_gradient, temp_rho -! REAL(DP), PARAMETER :: epsi2=1.e-11 - INTEGER :: ir - ! - - do ir=1,nnrx - ! - temp_gradient = grhoraux(ir,1)**2+grhoraux(ir,2)**2+grhoraux(ir,3)**2 - temp_rho=orb_rhor(ir) - - IF ((temp_gradient.lt.epsi**2)) THEN!(temp_rho.lt.epsi.or.temp_gradient.lt.epsi**2) THEN - temp_gradient=0.d0 - temp_rho=1.d0 - ELSE - taukin(ir) = taukin(ir)+f/(2.) * temp_gradient - ENDIF - ! - enddo - - end subroutine add_up_taukin - -!--------------------------------------------------------------- - subroutine nksic_get_taukin_pz( f, nspin, ispin, orb_rhor, & - taukin, ibnd, mult) -!--------------------------------------------------------------- -! -! ... sum up the kinetic energy-density taukin ... this works both for summing -! the orbital-resolved kinetic energy densities, and for the Weizsacker kinetic -! energy density (involving the total density). -! - use kinds, only : dp -! use nksic, only : add_up_taukin - use grid_dimensions, only : nnrx - use gvecp, only : ngm - use recvecs_indexes, only : np - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dft_is_gradient - use control_flags, only : gamma_only, do_wf_cmplx - use nksic, only : epsi=> epsi_cutoff_renorm - - ! - implicit none - ! - integer, intent(in) :: ispin, ibnd, nspin, mult - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(inout) :: taukin(nnrx,nspin) - ! - INTEGER :: ig,ir - complex(dp), allocatable :: rhogaux(:,:) - real(dp), allocatable :: grhoraux(:,:,:) - complex(dp), allocatable :: vhaux(:) - LOGICAL :: lgam - ! - lgam=gamma_only.and..not.do_wf_cmplx - ! - allocate(rhogaux(ngm,2)) - allocate(vhaux(nnrx)) - ! - IF(ibnd==1) THEN !first band: initialize taukin for this spin_loop - ! - taukin(1:nnrx,ispin)=0.d0 - ! - ENDIF - ! - rhogaux=0.0_dp - ! - do ir=1,nnrx - ! - vhaux(ir) = sqrt(abs(orb_rhor(ir)+mult*epsi)) - ! - enddo - ! - call fwfft('Dense',vhaux,dfftp ) - ! - do ig=1,ngm - rhogaux(ig,ispin) = vhaux( np(ig) ) - enddo - ! -! call enkin_dens( rhogaux(:,ispin), ngm, f) - ! - allocate(grhoraux(nnrx,3,2)) - - grhoraux=0.0_dp - - call fillgrad( 1, rhogaux(:,ispin:ispin), grhoraux(:,:,ispin:ispin), lgam ) - - call add_up_taukin(nnrx, taukin(:,ispin), grhoraux(:,:,ispin), orb_rhor(:), f) -! vhaux=0.d0 -! do ig=1,ngm -! vhaux( np(ig) )= rhogaux(ig,ispin) -! vhaux( nm(ig) )= CONJG(rhogaux(ig,ispin)) -! enddo -! ! -! call invfft('Dense',vhaux,dfftp ) -! ! -! do ir=1,nnrx -! ! -! taukin(ir,ispin) = DBLE(vhaux(ir)) -! ! -! enddo - ! - deallocate(vhaux,rhogaux,grhoraux) - ! - end subroutine nksic_get_taukin_pz - -!--------------------------------------------------------------- - subroutine nksic_get_upsilon_pz( f, nspin, ispin, orb_rhor, & - upsilon, ibnd) -!--------------------------------------------------------------- -! -! ... sum up the kinetic energy-density taukin ... this works both for summing -! the orbital-resolved kinetic energy densities, and for the Weizsacker kinetic -! energy density (involving the total density). -! - use kinds, only : dp - use grid_dimensions, only : nnrx - use gvecp, only : ngm - use recvecs_indexes, only : np - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dft_is_gradient - use control_flags, only : gamma_only, do_wf_cmplx - use nksic, only : epsi=> epsi_cutoff_renorm - ! - implicit none - ! - integer, intent(in) :: ispin, ibnd, nspin - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(out) :: upsilon(nnrx,3,nspin) - ! - INTEGER :: ig,ir,j - complex(dp), allocatable :: rhogaux(:,:) - real(dp), allocatable :: grhoraux(:,:,:) - complex(dp), allocatable :: vhaux(:) - real(dp) :: temp(3), tempnorm -! real(dp), parameter :: epsi=1.d-3 - LOGICAL :: lgam - ! - lgam=gamma_only.and..not.do_wf_cmplx - ! - allocate(rhogaux(ngm,2)) - allocate(vhaux(nnrx)) - ! - rhogaux=0.0_dp - ! - do ir=1,nnrx - ! - vhaux(ir) = log(abs(orb_rhor(ir))) - ! - enddo - ! - call fwfft('Dense',vhaux,dfftp ) - ! - do ig=1,ngm - rhogaux(ig,ispin) = vhaux( np(ig) ) - enddo - ! - allocate(grhoraux(nnrx,3,2)) - ! - grhoraux=0.0_dp - ! - call fillgrad( 1, rhogaux(:,ispin:ispin), grhoraux(:,:,ispin:ispin), lgam ) - ! - upsilon(1:nnrx,1:3,ispin)=0.d0 - ! - do ir=1,nnrx - ! - IF(.true.) THEN - ! - tempnorm=0.d0 - ! - do j=1,3 - ! - temp(j) = grhoraux(ir,j,ispin)!/(2.*(orb_rhor(ir)+epsi)) - tempnorm=tempnorm+temp(j)**2 - ! - enddo - ! - IF(tempnorm.gt.epsi) THEN - ! - upsilon(ir,:,ispin)=temp(:) - ! - ENDIF - ! - ENDIF - ! - enddo - ! - deallocate(vhaux,rhogaux,grhoraux) - ! - end subroutine nksic_get_upsilon_pz - -!--------------------------------------------------------------- - subroutine nksic_correction_pz( f, ispin, orb_rhor, & - vsic, pink, pzalpha, ibnd, shart) -!--------------------------------------------------------------- -! -! ... calculate the non-Koopmans potential from the orbital density -! - use kinds, only : dp - use constants, only : e2, fpi, hartree_si, electronvolt_si - use cell_base, only : tpiba2,omega - use nksic, only : etxc => etxc_sic, vxc => vxc_sic, nknmax, & - nkscalfact, do_pz_renorm - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use eecp_mod, only : do_comp - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dft_is_gradient - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use control_flags, only : gamma_only, do_wf_cmplx - use control_flags, only : hartree_only_sic - ! - implicit none - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx), pzalpha - real(dp), intent(out) :: vsic(nnrx) - real(dp), intent(out) :: pink, shart - ! - !character(19) :: subname='nksic_correction_pz' - integer :: ig - real(dp) :: ehele, fact - ! - complex(dp), allocatable :: rhogaux(:,:) - complex(dp), allocatable :: vhaux(:) - complex(dp), allocatable :: vcorr(:) - complex(dp), allocatable :: vtmp(:) - ! - real(dp), allocatable :: grhoraux(:,:,:) - real(dp), allocatable :: haux(:,:,:) - logical :: lgam - real(dp) :: dexc_dummy(3,3) - ! - !================== - ! main body - !================== - ! - lgam=gamma_only.and..not.do_wf_cmplx - vsic=0.0_dp - pink=0.0_dp - ! - if ( ibnd > nknmax .and. nknmax .ge. 0 ) return - if ( f < 1.0d-6 ) return - ! - CALL start_clock( 'nk_corr' ) - CALL start_clock( 'nk_corr_h' ) - ! - fact=omega/DBLE(nr1*nr2*nr3) - ! - !allocate(rhoelef(nnrx,2)) - allocate(rhogaux(ngm,2)) - allocate(vtmp(ngm)) - allocate(vcorr(ngm)) - allocate(vhaux(nnrx)) - ! - !rhoelef=0.0d0 - !rhoelef(:,ispin) = f * orb_rhor(:) - ! - ! Compute self-hartree contributions - ! - rhogaux=0.0_dp - ! - ! rhoelef contains occupations - ! - !vhaux(:) = rhoelef(:,ispin) - vhaux(:) = f*orb_rhor(:) - ! - call fwfft('Dense',vhaux,dfftp ) - ! - do ig=1,ngm - rhogaux(ig,ispin) = vhaux( np(ig) ) - enddo - - ! - ! compute hartree-like potential - ! - if( gstart == 2 ) vtmp(1)=(0.d0,0.d0) - do ig=gstart,ngm - vtmp(ig) = rhogaux(ig,ispin) * fpi/( tpiba2*g(ig) ) - enddo - ! - ! compute periodic corrections - ! - if( do_comp ) then - ! - call calc_compensation_potential( vcorr, rhogaux(:,ispin), .true.) - vtmp(:) = vtmp(:) + vcorr(:) - ! - endif - ! - vhaux=0.0_dp -! if(lgam) then !!!### uncomment for k points - do ig=1,ngm - ! - vhaux(np(ig)) = vtmp(ig) - vhaux(nm(ig)) = CONJG(vtmp(ig)) - ! - enddo -! else !!!### uncomment for k points -! do ig=1,ngm !!!### uncomment for k points - ! -! vhaux(np(ig)) = vtmp(ig) !!!### uncomment for k points -! vhaux(nm(ig)) = conjg(vtmp(ig)) - ! -! enddo !!!### uncomment for k points -! endif !!!### uncomment for k points - call invfft('Dense',vhaux,dfftp) - ! - ! init vsic - ! - vsic(1:nnrx) = -DBLE( vhaux(1:nnrx) ) - ehele = 0.5_dp * sum( DBLE( vhaux(1:nnrx) ) & - * orb_rhor(1:nnrx) ) - ! - ! set ehele as measure of spread - ! - !IF(icompute_spread) THEN - shart=abs(ehele)*fact*hartree_si/electronvolt_si - call mp_sum(shart, intra_image_comm) - !ENDIF - ! - ehele=ehele*f !this is to make ehele quadratic in f (check this) - ! - ! partial cleanup - ! - deallocate( vtmp ) - deallocate( vcorr ) - deallocate( vhaux ) - ! - CALL stop_clock( 'nk_corr_h' ) - ! - ! Compute xc-contributions - ! - if (.not.hartree_only_sic) then - ! - if ( dft_is_gradient()) then - ! - allocate(grhoraux(nnrx,3,2)) - ! - allocate(haux(nnrx,2,2)) - ! - ! note: rhogaux contains the occupation - ! - grhoraux=0.0_dp - call fillgrad( 1, rhogaux(:,ispin:ispin), grhoraux(:,:,ispin:ispin), lgam ) - ! - ! - else - allocate(grhoraux(1,1,1)) - allocate(haux(1,1,1)) - ! - grhoraux=0.0_dp - endif - ! - ! - vxc=0.0_dp - haux=0.0_dp - etxc=0.0_dp - ! - vxc(:,ispin)=f*orb_rhor(:) - ! call exch_corr_wrapper(nnrx,2,grhoraux,rhoelef,etxc,vxc,haux) - CALL exch_corr_cp(nnrx, 2, grhoraux, vxc, etxc) !proposed:giovanni fixing PBE, warning, check array dimensions - ! - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc should be dexc(3,3), is lgam a variable here? - call gradh( 2, grhoraux, rhogaux, vxc, dexc_dummy, lgam) - ! grhoraux(nnr,3,nspin)?yes; rhogaux(ng,nspin)? rhoref(nnr, nspin) - ! - end if -!$$ - vsic(1:nnrx) = vsic(1:nnrx) -vxc(1:nnrx,ispin) - - else - ! - etxc=0. - ! - endif -! vsic(1:nnrx) = -vxc(1:nnrx,ispin) -!$$ - ! - ! energy correction terms - ! -!$$ - pink = fact * ( -etxc -ehele ) -!$$ -! pink = fact * ( -ehele ) -! pink = fact * ( -etxc ) -!$$ - -!$$ This is for screened pz functional; apparently, I should have used a different variable name. - ! - ! rescale contributions with the nkscalfact parameter - ! take care of non-variational formulations - ! - IF(.not.do_pz_renorm) THEN - ! - pink = pink * nkscalfact - vsic = vsic * nkscalfact - ! - ELSE - !I do not renormalize here, I will do it outside the subroutine - !pink = pink * pzalpha - !vsic = vsic * pzalpha - ! - ENDIF - ! - call mp_sum(pink,intra_image_comm) - ! - if (.not.hartree_only_sic) then - deallocate( grhoraux ) - deallocate( haux ) - endif - deallocate( rhogaux ) - ! - CALL stop_clock( 'nk_corr' ) - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_correction_pz -!--------------------------------------------------------------- - - -!--------------------------------------------------------------- - subroutine nksic_correction_nkpz( f, orb_rhor, vsic, wrefsic, pink, ibnd, ispin ) -!--------------------------------------------------------------- -! -! ... calculate the non-Koopmans potential on top of Perdew-Zunger, -! from the orbital densities -! - use kinds, only : dp - use constants, only : e2, fpi - use cell_base, only : tpiba2,omega - use nksic, only : fref, nkscalfact, & - do_wref, vanishing_rho_w - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use eecp_mod, only : do_comp - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dmxc_spin, dft_is_gradient - use mp_global, only : intra_image_comm - use mp, only : mp_sum - use control_flags, only : gamma_only, do_wf_cmplx - - ! - implicit none - real(dp), intent(in) :: f, orb_rhor(nnrx) - integer, intent(in) :: ispin, ibnd - real(dp), intent(out) :: vsic(nnrx), wrefsic(nnrx) - real(dp), intent(out) :: pink - ! - integer :: ig, ir - real(dp) :: fact, etxcref - real(dp) :: w2cst - ! - real(dp), allocatable :: rhoele(:,:) - real(dp), allocatable :: rhoref(:,:) - real(dp), allocatable :: vxcref(:,:) - real(dp), allocatable :: wxdsic(:,:) - real(dp), allocatable :: grhoraux(:,:,:) - real(dp), allocatable :: haux(:,:,:) - complex(dp), allocatable :: vhaux(:) - complex(dp), allocatable :: vcorr(:) - complex(dp), allocatable :: rhogaux(:,:) - complex(dp), allocatable :: vtmp(:) - logical :: lgam - real(dp) :: dexc_dummy(3,3) - ! - CALL start_clock( 'nk_corr' ) - CALL start_clock( 'nk_corr_h' ) - ! - lgam = gamma_only.and..not.do_wf_cmplx - fact=omega/DBLE(nr1*nr2*nr3) - ! - allocate(wxdsic(nnrx,2)) - allocate(rhoele(nnrx,2)) - allocate(rhoref(nnrx,2)) - allocate(rhogaux(ngm,2)) - allocate(vtmp(ngm)) - allocate(vcorr(ngm)) - allocate(vhaux(nnrx)) - ! - rhoele=0.0d0 - rhoele(:,ispin)=orb_rhor(:) - ! - vsic=0.0_dp - wrefsic=0.0_dp - wxdsic=0.0_dp - pink=0.0_dp - ! - ! compute self-hartree contributions - ! - rhogaux=0.0_dp - ! - ! rhoele has no occupation - ! - vhaux(:) = rhoele(:,ispin) - ! - call fwfft('Dense',vhaux,dfftp ) - ! - do ig=1,ngm - rhogaux(ig,ispin) = vhaux( np(ig) ) - enddo - ! - ! compute hartree-like potential - ! - if( gstart == 2 ) vtmp(1)=(0.d0,0.d0) - do ig=gstart,ngm - vtmp(ig)=rhogaux(ig,ispin)*fpi/(tpiba2*g(ig)) - enddo - ! - ! compute periodic corrections - ! - if( do_comp ) then - ! - call calc_compensation_potential( vcorr, rhogaux(:,ispin),.true.) - vtmp(:) = vtmp(:) + vcorr(:) - ! - endif - ! - vhaux=0.0_dp -! IF(lgam) THEN !!!### uncomment for k points - do ig=1,ngm - ! - vhaux(np(ig)) = vtmp(ig) - vhaux(nm(ig)) = CONJG(vtmp(ig)) - ! - enddo -! ELSE !!!### uncomment for k points -! do ig=1,ngm !!!### uncomment for k points - ! -! vhaux(np(ig)) = vtmp(ig) !!!### uncomment for k points -! vhaux(nm(ig)) = conjg(vtmp(ig)) - ! -! enddo !!!### uncomment for k points -! ENDIF !!!### uncomment for k points - ! - call invfft('Dense',vhaux,dfftp) - ! - ! init here wref sic to save some memory - ! - ! this is just the self-hartree potential - ! (to be multiplied by fref later on) - ! - wrefsic(1:nnrx)=DBLE(vhaux(1:nnrx)) - ! - ! the term - fref has to be included explicitly in rhoele - ! - vsic(1:nnrx)=-fref*DBLE(vhaux(1:nnrx)) - ! - deallocate(vtmp) - deallocate(vcorr) - deallocate(vhaux) - ! - call stop_clock( 'nk_corr_h' ) - call start_clock( 'nk_corr_vxc' ) - ! - ! add self-xc contributions - ! - rhoref=fref*rhoele - ! - if ( dft_is_gradient() ) then - allocate(grhoraux(nnrx,3,2)) - allocate(haux(nnrx,2,2)) - ! - grhoraux=0.0_dp - call fillgrad( 1, rhogaux, grhoraux(:,:,ispin:ispin), lgam ) - ! - grhoraux(:,:,ispin) = grhoraux(:,:,ispin) * fref - else - allocate(grhoraux(1,1,1)) - allocate(haux(1,1,1)) - grhoraux=0.0_dp - endif - ! - - - allocate(vxcref(nnrx,2)) - ! - etxcref=0.0_dp - vxcref=0.0_dp - ! - vxcref=rhoref - ! - CALL exch_corr_cp(nnrx, 2, grhoraux, vxcref, etxcref) !proposed:giovanni fixing PBE, warning, rhoref overwritten with vxcref, check array dimensions - ! - !begin_added:giovanni fixing PBE potential - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc should be dexc(3,3), is lgam a variable here? - call gradh( 2, grhoraux, rhogaux, vxcref, dexc_dummy, lgam) - ! grhoraux(nnr,3,nspin)?yes; rhogaux(ng,nspin)? rhoref(nnr, nspin) - ! - end if -!end_added:giovanni fixing PBE potential - deallocate(rhogaux) -! call exch_corr_wrapper(nnrx,2,grhoraux,rhoref,etxcref,vxcref,haux) - ! - ! update vsic pot - ! - vsic(1:nnrx)=vsic(1:nnrx)-vxcref(1:nnrx,ispin) - ! - ! define pink - ! - pink=f*sum(vsic(1:nnrx)*rhoele(1:nnrx,ispin))*fact - call mp_sum(pink,intra_image_comm) - ! - call stop_clock( 'nk_corr_vxc' ) - ! - ! calculate wref - ! - CALL start_clock( 'nk_corr_fxc' ) - ! - if( do_wref ) then - ! - ! note that wxd and wref are updated - ! (and not overwritten) by the next call - ! - call nksic_dmxc_spin_cp_update(nnrx,rhoref,f,ispin,rhoele, & - vanishing_rho_w,wrefsic,wxdsic)!modified:linh - ! - w2cst=sum(wrefsic(1:nnrx)*rhoele(1:nnrx,ispin))*fact - ! - call mp_sum(w2cst,intra_image_comm) - ! - do ir=1,nnrx - wrefsic(ir)=-fref*(wrefsic(ir)-w2cst) - enddo - ! - endif - ! - CALL stop_clock( 'nk_corr_fxc' ) - ! - ! rescale contributions with the nkscalfact parameter - ! take care of non-variational formulations - ! - pink = pink * nkscalfact - vsic = vsic * nkscalfact - ! - if( do_wref ) then - wrefsic = wrefsic * nkscalfact - else - wrefsic = 0.d0 - endif - ! - deallocate(wxdsic) - deallocate(vxcref) - deallocate(rhoele) - deallocate(rhoref) - deallocate(grhoraux) - deallocate(haux) - ! - CALL stop_clock( 'nk_corr' ) - return - ! -!--------------------------------------------------------------- - end subroutine nksic_correction_nkpz -!--------------------------------------------------------------- - -!--------------------------------------------------------------- - subroutine nksic_correction_nkipz( f, ispin, orb_rhor, & - vsic, pink, ibnd, shart, is_empty) -!--------------------------------------------------------------- -! -! ... calculate the non-Koopmans potential from the orbital density -! - use kinds, only : dp - use constants, only : e2, fpi, hartree_si, electronvolt_si - use cell_base, only : tpiba2,omega - use nksic, only : nknmax, nkscalfact - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use eecp_mod, only : do_comp - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dft_is_gradient - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use control_flags, only : gamma_only, do_wf_cmplx, hartree_only_sic - ! - implicit none - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(out) :: vsic(nnrx) - real(dp), intent(out) :: pink, shart - logical, optional, intent(in) :: is_empty - ! - !character(19) :: subname='nksic_correction_pz' - integer :: ig - real(dp) :: ehele, fact, w2cst, etmp, etxc_ - ! - real(dp), allocatable :: vxc_(:,:) - complex(dp), allocatable :: rhogaux(:,:) - complex(dp), allocatable :: vhaux(:) - complex(dp), allocatable :: vcorr(:) - complex(dp), allocatable :: vtmp(:) - ! - real(dp), allocatable :: grhoraux(:,:,:) - logical :: lgam - real(dp) :: icoeff - real(dp) :: dexc_dummy(3,3) - logical :: is_empty_ - ! - !================== - ! main body - !================== - ! - lgam=gamma_only.and..not.do_wf_cmplx - if(lgam) then - icoeff=2.d0 - else - icoeff=1.d0 - endif - ! - IF(present(is_empty)) THEN - ! - is_empty_ = is_empty - ! - ELSE - ! - is_empty_ = .false. - ! - ENDIF - ! - vsic=0.0_dp - pink=0.0_dp - ! - if ( ibnd > nknmax .and. nknmax .ge. 0 ) return - ! - CALL start_clock( 'nk_corr' ) - CALL start_clock( 'nk_corr_h' ) - ! - fact=omega/DBLE(nr1*nr2*nr3) - ! - allocate(rhogaux(ngm,2)) - allocate(vtmp(ngm)) - allocate(vcorr(ngm)) - allocate(vxc_(nnrx,2)) - allocate(vhaux(nnrx)) - ! - ! Compute self-hartree contributions - ! - rhogaux=0.0_dp - ! - ! vhaux does not contain occupations - ! - vhaux(:) = orb_rhor(:) - ! - call fwfft('Dense',vhaux,dfftp ) - ! - do ig=1,ngm - rhogaux(ig,ispin) = vhaux( np(ig) ) - enddo - ! - ! compute hartree-like potential - ! - if( gstart == 2 ) vtmp(1)=(0.d0,0.d0) - do ig=gstart,ngm - vtmp(ig) = rhogaux(ig,ispin) * fpi/( tpiba2*g(ig) ) - enddo - ! - ! compute periodic corrections - ! - if( do_comp ) then - ! - call calc_compensation_potential( vcorr, rhogaux(:,ispin),.true. ) - vtmp(:) = vtmp(:) + vcorr(:) - ! - endif - ! - vhaux=0.0_dp - do ig=1,ngm - ! - vhaux(np(ig)) = vtmp(ig) - vhaux(nm(ig)) = CONJG(vtmp(ig)) - ! - enddo - ! - call invfft('Dense',vhaux,dfftp) - ! - ! init vsic - ! - vsic(1:nnrx) = -DBLE( vhaux(1:nnrx) ) ! -v_hartree[n_i](r) - ! - ehele = icoeff * DBLE ( DOT_PRODUCT( vtmp(1:ngm), rhogaux(1:ngm,ispin))) - if ( gstart == 2 ) ehele = ehele + (1.d0-icoeff)*DBLE ( CONJG( vtmp(1) ) * rhogaux(1,ispin) ) - ! - w2cst = 0.0_dp - ! - w2cst = 0.5_dp * ehele * omega ! -E_H[n_i] + \int( v_H[n_i](r) n_i(r) )dr --> -E_H[n_i] + 2E_H[n_i] = E_H[n_i] - ! - call mp_sum(w2cst,intra_image_comm) - ! - vsic = vsic + w2cst ! Hartree part of first and third terms in eq. (A15) Borghi PRB - ! - ehele = 0.5d0 * ehele * omega / fact - ! - shart=abs(ehele)*fact*hartree_si/electronvolt_si - ! - call mp_sum(shart, intra_image_comm) - ! - ! NsC >>> - etmp=0.D0 - etmp= sum ( vsic(1:nnrx) * orb_rhor(1:nnrx) ) - etmp = etmp * fact *hartree_si/electronvolt_si - call mp_sum(etmp,intra_image_comm) - ! NsC <<< - ! partial cleanup - ! - deallocate( vtmp ) - deallocate( vcorr ) - deallocate( vhaux ) - ! - CALL stop_clock( 'nk_corr_h' ) - ! - IF (.NOT. hartree_only_sic ) THEN - ! Compute xc-contributions - ! - if ( dft_is_gradient() ) then - allocate(grhoraux(nnrx,3,2)) - ! - ! note: rhogaux does not contain the occupation - ! - grhoraux=0.0_dp - call fillgrad( 1, rhogaux(:,ispin:ispin), grhoraux(:,:,ispin:ispin), lgam ) - else - allocate(grhoraux(1,1,1)) - ! - grhoraux=0.0_dp - endif - ! - ! - vxc_=0.0_dp - etxc_=0.0_dp - ! - vxc_(:,ispin)=orb_rhor(:) - CALL exch_corr_cp(nnrx, 2, grhoraux, vxc_, etxc_) - !proposed:giovanni fixing PBE, warning, check array dimensions - ! - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc - ! should be dexc(3,3), is lgam a variable here? - call gradh( 2, grhoraux, rhogaux, vxc_, dexc_dummy, lgam) - ! - end if - ! - ELSE - ! - vxc_ = 0.D0 - etxc_ = 0.D0 - ! - ENDIF - ! - IF (.not.is_empty_) THEN - ! - etmp = sum( vxc_(1:nnrx,ispin) * orb_rhor(1:nnrx) ) - ! - w2cst = -etxc_ + etmp - w2cst = w2cst * fact - ! - call mp_sum(w2cst,intra_image_comm) - ! - pink = -f*(etxc_ + ehele) - ! - ELSE - ! - etmp = sum( vxc_(1:nnrx,ispin) * orb_rhor(1:nnrx) ) - ! - w2cst = -etxc_ + etmp - w2cst = w2cst * fact - ! - call mp_sum(w2cst,intra_image_comm) - ! - pink = -(etxc_ + ehele) - ! - ENDIF - ! - pink = pink*fact - ! - call mp_sum(pink,intra_image_comm) - ! - vsic(1:nnrx) = vsic(1:nnrx) - vxc_(1:nnrx,ispin) + w2cst - ! - ! NsC >>> - etmp=0.D0 - etmp= sum ( vsic(1:nnrx) * orb_rhor(1:nnrx) ) - etmp = etmp * fact *hartree_si/electronvolt_si - call mp_sum(etmp,intra_image_comm) - ! NsC <<< - ! - pink = pink * nkscalfact - vsic = vsic * nkscalfact - ! - IF (.not. hartree_only_sic) deallocate( grhoraux ) - deallocate( rhogaux ) - deallocate( vxc_ ) - ! - CALL stop_clock( 'nk_corr' ) - - return - ! -!--------------------------------------------------------------- -end subroutine nksic_correction_nkipz -!--------------------------------------------------------------- - -!--------------------------------------------------------------- - subroutine nksic_correction_nki( f, ispin, orb_rhor, rhor, & - rhoref, rhobar, rhobarg, grhobar,& - vsic, wxdsic, do_wxd_, pink, ibnd, shart, is_empty ) -!--------------------------------------------------------------- -! -! ... calculate the non-Koopmans (integrated, NKI) -! potential from the orbital density -! -! note that fref=1.0 when performing NKI (i.e. it has a diff -! meaning) -! then rho_ref = rho - rho_i + n_i -! rho_bar = rho - rho_i -! - use kinds, only : dp - use constants, only : e2, fpi, hartree_si, electronvolt_si - use cell_base, only : tpiba2,omega - use nksic, only : fref, rhobarfact, nknmax, & - nkscalfact, & - etxc => etxc_sic, vxc => vxc_sic - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use eecp_mod, only : do_comp - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dmxc_spin, dft_is_gradient - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use electrons_base, only : nspin - use control_flags, only : gamma_only, do_wf_cmplx - ! - implicit none - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(in) :: rhor(nnrx,nspin) - real(dp), intent(in) :: rhoref(nnrx,2) - real(dp), intent(in) :: rhobar(nnrx,2) - complex(dp), intent(in) :: rhobarg(ngm,2) - real(dp), intent(in) :: grhobar(nnrx,3,2) - real(dp), intent(out) :: vsic(nnrx) - real(dp), intent(out) :: wxdsic(nnrx,2) - logical, intent(in) :: do_wxd_ - real(dp), intent(out) :: pink, shart - logical, optional, intent(in) :: is_empty - ! - integer :: ig - real(dp) :: fact, ehele, etmp - real(dp) :: etxcref, etxc0, w2cst - ! - real(dp), allocatable :: rhoele(:,:) - real(dp), allocatable :: rhoraux(:,:) - real(dp), allocatable :: vxc0(:,:) - real(dp), allocatable :: vxcref(:,:) - complex(dp), allocatable :: vhaux(:) - complex(dp), allocatable :: vcorr(:) - complex(dp), allocatable :: rhogaux(:,:) - complex(dp), allocatable :: vtmp(:) - ! - real(dp), allocatable :: grhoraux(:,:,:) - real(dp), allocatable :: orb_grhor(:,:,:) - complex(dp), allocatable :: orb_rhog(:,:) - real(dp), allocatable :: haux(:,:,:) - logical :: lgam, is_empty_ - real(dp) :: icoeff - real(dp) :: dexc_dummy(3,3) - ! - !================== - ! main body - !================== - ! - lgam = gamma_only.and..not.do_wf_cmplx - ! - if(lgam) then - icoeff=2.d0 - else - icoeff=1.d0 - endif - ! - IF(present(is_empty)) THEN - ! - is_empty_=is_empty - ! - ELSE - ! - is_empty_=.false. - ! - ENDIF - ! - if( ibnd > nknmax .and. nknmax .ge. 0 ) return - ! - CALL start_clock( 'nk_corr' ) - CALL start_clock( 'nk_corr_h' ) - ! - fact=omega/DBLE(nr1*nr2*nr3) - ! - allocate(rhoele(nnrx,2)) - allocate(rhogaux(ngm,2)) - allocate(vtmp(ngm)) - allocate(orb_rhog(ngm,1)) - allocate(vcorr(ngm)) - allocate(vhaux(nnrx)) - ! - rhoele=0.0d0 - rhoele(:,ispin) = orb_rhor(:) - ! - vsic=0.0_dp - wxdsic=0.0_dp - pink=0.0_dp - ! - ! Compute self-hartree contributions - ! - orb_rhog=0.0_dp - ! - ! rhoele has no occupation - ! - vhaux(:) = rhoele(:,ispin) - ! - call fwfft('Dense',vhaux,dfftp ) - ! - do ig=1,ngm - orb_rhog(ig,1) = vhaux( np(ig) ) - enddo - ! - ! compute hartree-like potential - ! - if( gstart == 2 ) vtmp(1)=(0.d0,0.d0) - do ig=gstart,ngm - vtmp(ig) = orb_rhog(ig,1) * fpi/( tpiba2*g(ig) ) - enddo - ! - ! compute periodic corrections - ! - if( do_comp ) then - ! - call calc_compensation_potential( vcorr, orb_rhog(:,1),.true.) - vtmp(:) = vtmp(:) + vcorr(:) - ! - endif - ! - vhaux=0.0_dp - do ig=1,ngm - ! - vhaux(np(ig)) = vtmp(ig) - vhaux(nm(ig)) = CONJG(vtmp(ig)) - ! - enddo - ! - call invfft('Dense',vhaux,dfftp) - ! - ! init here vsic to save some memory - ! - ! this is just the self-hartree potential - ! - vsic(1:nnrx) = (1.0_dp-f) * DBLE( vhaux(1:nnrx) ) - ! - ! self-hartree contrib to pink - ! and w2cst for vsic - ! - ehele = icoeff * DBLE ( DOT_PRODUCT( vtmp(1:ngm), orb_rhog(1:ngm,1))) - if ( gstart == 2 ) ehele = ehele +(1.d0-icoeff)*DBLE ( CONJG( vtmp(1) ) * orb_rhog(1,1) ) - ! - shart=abs(ehele)*omega*0.5d0*hartree_si/electronvolt_si - ! - call mp_sum(shart, intra_image_comm) - ! -self-hartree energy to be added to the vsic potential - ! - ! the scalar Hatree term of both empty and occupied states is - ! in the same form: -E_H[n_i] - ! - w2cst = 0.0_dp - ! - w2cst = -0.5_dp * ehele * omega - ! - call mp_sum(w2cst,intra_image_comm) - ! - vsic = vsic + w2cst - ! - ! the f * (1-f) term is added here - ! - IF(.not.is_empty_) THEN - ! - ehele = 0.5_dp * f * (1.0_dp-f) * ehele * omega / fact - ! - ELSE !this is for the fake functional for empty states - ! - ehele = 0.5_dp * ehele * omega / fact - ! - ENDIF - ! - ! NsC >>> - etmp=0.D0 - etmp= sum ( vsic(1:nnrx) * orb_rhor(1:nnrx) ) - etmp = etmp * fact *hartree_si/electronvolt_si - call mp_sum(etmp,intra_image_comm) - ! NsC <<< - ! - deallocate(vtmp) - deallocate(vcorr) - deallocate(vhaux) - ! - CALL stop_clock( 'nk_corr_h' ) - ! - CALL start_clock( 'nk_corr_vxc' ) - ! - ! - ! add self-xc contributions - ! - if ( dft_is_gradient() ) then - ! - allocate(grhoraux(nnrx,3,2)) - allocate(orb_grhor(nnrx,3,1)) - allocate(haux(nnrx,2,2)) - ! - ! compute the gradient of n_i(r) - call fillgrad( 1, orb_rhog, orb_grhor(:,:,1:1), lgam ) - ! - else - ! - allocate(grhoraux(1,1,1)) - allocate(haux(1,1,1)) - grhoraux=0.0_dp - ! - endif - ! - allocate(vxc0(nnrx,2)) - allocate(vxcref(nnrx,2)) - ! - ! this term is computed for ibnd, ispin == 1 and stored - ! or if rhobarfact < 1 - ! - if ( ( ibnd == 1 .and. ispin == 1) .OR. rhobarfact < 1.0_dp ) then - ! - etxc=0.0_dp - vxc=0.0_dp - ! - ! some meory can be same in the nspin-2 case, - ! considering that rhobar + f*rhoele is identical to rho - ! when rhobarfact == 1 - ! - ! call exch_corr_wrapper(nnrx,2,grhoraux,rhor,etxc,vxc,haux) - ! - if ( dft_is_gradient() ) then - ! - grhoraux(:,:,1:2) = grhobar(:,:,1:2) - grhoraux(:,:,ispin) = grhobar(:,:,ispin) & - + f * orb_grhor(:,:,1) - ! - rhogaux(:,1:2) = rhobarg(:,1:2) - rhogaux(:,ispin) = rhobarg(:,ispin) + f * orb_rhog(:,1) - ! - endif - ! - allocate( rhoraux(nnrx, 2) ) - ! - rhoraux = rhobar + f*rhoele - vxc=rhoraux - ! - CALL exch_corr_cp(nnrx, 2, grhoraux, vxc, etxc) - !proposed:giovanni warning rhoraux is overwritten with vxc, - !check array dimensions - ! - !begin_added:giovanni fixing PBE potential - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc - ! should be dexc(3,3), is lgam a variable here? - ! - call gradh( 2, grhoraux, rhogaux, vxc, dexc_dummy, lgam) - ! - end if - !end_added:giovanni fixing PBE potential - deallocate( rhoraux ) - ! - endif - ! - etxcref=0.0_dp - vxcref=0.0_dp - ! - if ( f == 1.0_dp ) then - ! - vxcref=vxc - etxcref=etxc - ! - else - ! - if ( dft_is_gradient() ) then - ! - grhoraux(:,:,1:2) = grhobar(:,:,1:2) - grhoraux(:,:,ispin) = grhobar(:,:,ispin) & - + fref * orb_grhor(:,:,1) - ! - rhogaux(:,1:2) = rhobarg(:,1:2) - rhogaux(:,ispin) = rhobarg(:,ispin) + fref * orb_rhog(:,1) - ! - endif - ! - vxcref=rhoref - CALL exch_corr_cp(nnrx, 2, grhoraux, vxcref, etxcref) - ! - !proposed:giovanni warning rhoraux is overwritten with vxc, - !check array dimensions - ! - !begin_added:giovanni fixing PBE potential - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc - ! should be dexc(3,3), is lgam a variable here? - call gradh(2, grhoraux, rhogaux, vxcref, dexc_dummy, lgam) - ! grhobar(nnr,3,nspin)? rhogbar(ng,nspin)? rhor(nnr, nspin) - ! - endif - !end_added:giovanni fixing PBE potential - ! - endif - ! - !rhoraux = rhobar - ! - etxc0=0.0_dp - vxc0=0.0_dp - ! - vxc0=rhobar - CALL exch_corr_cp(nnrx, 2, grhobar, vxc0, etxc0) - !proposed:giovanni - ! - !begin_added:giovanni fixing PBE potential - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc - ! should be dexc(3,3), is lgam a variable here? - call gradh(2, grhobar, rhobarg, vxc0, dexc_dummy, lgam) - ! grhobar(nnr,3,nspin)? rhogbar(ng,nspin)? rhor(nnr, nspin) - ! - end if - !end_added:giovanni fixing PBE potential - ! - ! update potential (including other constant terms) - ! and define pink - ! - IF(.not.is_empty_) THEN - ! - etmp = sum( vxcref(1:nnrx,ispin) * rhoele(1:nnrx,ispin) ) - w2cst = ( etxcref-etxc0 ) -etmp - w2cst = w2cst * fact - ! - call mp_sum(w2cst,intra_image_comm) - ! - pink = (1.0_dp - f) * etxc0 - etxc + f * etxcref + ehele - ! - ELSE - ! - etmp = sum( vxcref(1:nnrx,ispin) * rhoele(1:nnrx,ispin) ) - w2cst = ( etxcref - etxc0 ) -etmp - w2cst = w2cst * fact - ! - call mp_sum(w2cst,intra_image_comm) - ! - etmp = sum( vxc(1:nnrx,ispin) * rhoele(1:nnrx,ispin) ) - ! - pink = etxcref - etxc0 - etmp + ehele - ! - ENDIF - ! - pink = pink*fact - ! - call mp_sum(pink,intra_image_comm) - ! - vsic(1:nnrx) = vsic(1:nnrx) & - + vxcref(1:nnrx,ispin) - vxc(1:nnrx,ispin) + w2cst - ! - ! calculate wxd - ! - wxdsic(:,:) = 0.0d0 - ! - if( do_wxd_ ) then - ! - wxdsic(:,1:2)= (1.0_dp-f)*vxc0(:,1:2) - vxc(:,1:2) + f*vxcref(:,1:2) - ! - endif - ! - call stop_clock( 'nk_corr_vxc' ) - ! - ! rescale contributions with the nkscalfact parameter - ! take care of non-variational formulations - ! - pink = pink * nkscalfact - vsic = vsic * nkscalfact - ! - if( do_wxd_ ) then - ! - wxdsic = wxdsic * nkscalfact - ! - else - ! - wxdsic = 0.d0 - ! - endif - ! - deallocate(vxc0) - deallocate(vxcref) - deallocate(rhoele) - ! - deallocate(grhoraux) - deallocate(haux) - deallocate(rhogaux) - ! - if ( allocated(orb_grhor) ) deallocate(orb_grhor) - ! - CALL stop_clock( 'nk_corr' ) - return - ! -!--------------------------------------------------------------- - end subroutine nksic_correction_nki -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_eforce( i, nbsp, nx, vsic, deeq_sic, bec, ngw, c1, c2, vsicpsi, lgam ) -!----------------------------------------------------------------------- -! -! Compute vsic potential for orbitals i and i+1 (c1 and c2) -! - use kinds, only : dp - use cp_interfaces, only : fwfft, invfft - use fft_base, only : dffts, dfftp - use gvecs, only : ngs, nps, nms - use grid_dimensions, only : nnrx - use smooth_grid_dimensions, only : nnrsx - use uspp, only : nkb, vkb - use uspp_param, only : nhm, nh - use cvan, only : ish - use ions_base, only : nsp, na, nat - use twin_types - ! - implicit none - - ! - ! input/output vars - ! - integer, intent(in) :: i, nbsp, nx, ngw - real(dp), intent(in) :: vsic(nnrx,nx) - real(dp), intent(in) :: deeq_sic(nhm,nhm,nat,nx) - type(twin_matrix), intent(in) :: bec!(nkb,nbsp) !modified:giovanni - complex(dp), intent(in) :: c1(ngw), c2(ngw) - complex(dp), intent(out) :: vsicpsi(ngw, 2) - logical, intent(in) :: lgam !added:giovanni - - ! - ! local vars - ! - character(12) :: subname='nksic_eforce' - integer :: ir, ig, ierr, j - integer :: is, iv, jv, isa, ism - integer :: ivoff, jvoff, ia, inl, jnl - real(dp) :: wfc(2), dd - complex(dp) :: wfc_c(2) - complex(dp) :: fm, fp - complex(dp), allocatable :: psi1(:), psi2(:) - real(dp), allocatable :: aa(:,:) - complex(dp), allocatable :: aa_c(:,:) - complex(dp), parameter :: c_one= CMPLX(1.d0,0.d0) - - ! - !==================== - ! main body - !==================== - ! - call start_clock( 'nk_eforce' ) - ! - allocate( psi1(nnrx), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating psi1',abs(ierr)) - if(.not.lgam) then - allocate( psi2(nnrx), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating psi2',abs(ierr)) - endif - - ! - ! init - ! - vsicpsi(:,:) = 0.0d0 - ! - ! take advantage of the smooth and the dense grids - ! being equal (NCPP case) - ! - if ( nnrsx == nnrx ) then !waring:giovanni we are not using ultrasoft - ! - ! no need to take care of the double grid. - ! typically, NCPP case - - ! - if(lgam) then - CALL c2psi( psi1, nnrx, c1, c2, ngw, 2 ) !warning:giovanni need to change this - else - CALL c2psi( psi1, nnrx, c1, c2, ngw, 0 ) !warning:giovanni need to change this - CALL c2psi( psi2, nnrx, c2, c1, ngw, 0 ) !warning:giovanni need to change this - endif - ! - CALL invfft('Dense', psi1, dfftp ) - if(.not. lgam) then - CALL invfft('Dense', psi2, dfftp ) - endif - - ! - ! computing the orbital wfcs - ! and the potentials in real space on the full grid - ! - if(lgam) then - do ir = 1, nnrx - ! - wfc(1) = DBLE( psi1(ir) ) - wfc(2) = AIMAG( psi1(ir) ) - ! - psi1( ir ) = CMPLX( wfc(1) * vsic(ir,i), wfc(2) * vsic(ir,i+1)) - ! - enddo - else - do ir = 1, nnrx - ! - wfc_c(1) = psi1(ir) - wfc_c(2) = psi2(ir) - ! - psi1( ir ) = wfc_c(1) * vsic(ir,i) - psi2(ir) = wfc_c(2) * vsic(ir,i+1) - ! - enddo - endif - ! - - CALL fwfft('Dense', psi1, dfftp ) - if(.not. lgam) then - CALL fwfft('Dense', psi2, dfftp ) - endif - ! - vsicpsi(:,:)=0.0_dp - ! - if(lgam) then - do ig=1,ngw - ! - fp = psi1(nps(ig))+psi1(nms(ig)) - fm = psi1(nps(ig))-psi1(nms(ig)) - ! - vsicpsi(ig,1)=0.5d0*CMPLX(DBLE(fp),AIMAG(fm)) - vsicpsi(ig,2)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - ! - enddo - else - do ig=1,ngw - ! - fp = psi1(nps(ig)) - fm = psi2(nps(ig)) - ! - vsicpsi(ig,1)=fp - vsicpsi(ig,2)=fm - ! - enddo - endif - - else - write(6,*) "WARNING, WE ARE USING USPP" - ! - ! here we take properly into account the - ! smooth and the dense grids - ! typically, USPP case - ! - CALL nksic_eforce_std(lgam) !warning:giovanni this makes fourier transforms - ! - endif - ! - deallocate( psi1 ) - if(.not.lgam) then - deallocate( psi2 ) - endif - - ! - ! add USPP non-local contribution - ! to the potantial - ! (this comes from the orbital-dependent piece of - ! the potential) - ! - if( nkb > 0 ) then -! write(6,*) "WE ARE USING USPP --- WARNING" - ! - ! aa_i,i,n = sum_j d_i,ij - ! - if(.not.bec%iscmplx) then - allocate( aa( nkb, 2 ) ) - ! - aa = 0.0d0 - ! - ! - do is = 1, nsp - ! - do iv = 1, nh(is) - do jv = 1, nh(is) - ! - isa = 0 - do ism = 1, is-1 - isa = isa + na( ism ) - enddo - ! - ivoff = ish(is)+(iv-1)*na(is) - jvoff = ish(is)+(jv-1)*na(is) - ! - if( i /= nbsp ) then - ! - do ia=1,na(is) - inl = ivoff + ia - jnl = jvoff + ia - isa = isa + 1 - ! - dd = deeq_sic(iv,jv,isa,i) - aa(inl,1) = aa(inl,1) + dd * bec%rvec(jnl,i) - ! - dd = deeq_sic(iv,jv,isa,i+1) - aa(inl,2) = aa(inl,2) + dd * bec%rvec(jnl,i+1) - ! - enddo - ! - else - ! - do ia=1,na(is) - inl = ivoff + ia - jnl = jvoff + ia - isa = isa + 1 - ! - dd = deeq_sic(iv,jv,isa,i) - aa(inl,1) = aa(inl,1) + dd * bec%rvec(jnl,i) - ! - enddo - ! - endif - ! - enddo - enddo - ! - enddo - ! -! write(6,*) "deeq_sic" -! write(6,*) deeq_sic - ! - call DGEMM ( 'N', 'N', 2*ngw, 2, nkb, 1.0d0, & - vkb, 2*ngw, aa, nkb, 1.0d0, vsicpsi(:,:), 2*ngw) - ! - deallocate( aa ) - ! - else - allocate( aa_c( nkb, 2 ) ) - ! - aa_c = CMPLX(0.0d0, 0.d0) - ! - ! - do is = 1, nsp - ! - do iv = 1, nh(is) - do jv = 1, nh(is) - ! - isa = 0 - do ism = 1, is-1 - isa = isa + na( ism ) - enddo - ! - ivoff = ish(is)+(iv-1)*na(is) - jvoff = ish(is)+(jv-1)*na(is) - ! - if( i /= nbsp ) then - ! - do ia=1,na(is) - inl = ivoff + ia - jnl = jvoff + ia - isa = isa + 1 - ! - dd = deeq_sic(iv,jv,isa,i) - aa_c(inl,1) = aa_c(inl,1) + dd * bec%cvec(jnl,i) !warning:giovanni or conjg? - ! - dd = deeq_sic(iv,jv,isa,i+1) - aa_c(inl,2) = aa_c(inl,2) + dd * bec%cvec(jnl,i+1) !warning:giovanni or conjg? - ! - enddo - ! - else - ! - do ia=1,na(is) - inl = ivoff + ia - jnl = jvoff + ia - isa = isa + 1 - ! - dd = deeq_sic(iv,jv,isa,i) - aa_c(inl,1) = aa_c(inl,1) + dd * bec%cvec(jnl,i) !warning:giovanni or conjg? - ! - enddo - ! - endif - ! - enddo - enddo - ! - enddo - ! - call ZGEMM ( 'N', 'N', ngw, 2, nkb, c_one, & - vkb, ngw, aa_c, nkb, c_one, vsicpsi(:,:), ngw) - ! - deallocate( aa_c ) - ! - endif - endif - - - call stop_clock( 'nk_eforce' ) - return - -! -! implementation to deal with both -! the smooth and the dense grids -! -CONTAINS - ! - subroutine nksic_eforce_std(lgam) - ! - use smooth_grid_dimensions, only : nnrsx - use recvecs_indexes, only : np - implicit none - - logical, intent(IN) :: lgam - ! - complex(dp) :: c(ngw,2) - complex(dp) :: psis(nnrsx) - complex(dp) :: vsicg(nnrx) - complex(dp) :: vsics(nnrsx) - complex(dp) :: vsicpsis(nnrsx) - - c(:,1) = c1 - c(:,2) = c2 - - do j = 1, 2 - ! - psis=0.d0 - if(lgam) then - do ig=1,ngw - psis(nms(ig))=CONJG(c(ig,j)) - psis(nps(ig))=c(ig,j) - end do - else - do ig=1,ngw - psis(nps(ig))=c(ig,j) - end do - endif - call invfft('Wave',psis,dffts) - ! - vsicg(1:nnrx)=vsic(1:nnrx,i+j-1) - call fwfft('Dense',vsicg,dfftp) - ! - vsics=0.0_dp - if(lgam) then - do ig=1,ngs - vsics(nps(ig))=vsicg(np(ig)) - vsics(nms(ig))=CONJG(vsicg(np(ig))) - end do - else - do ig=1,ngs - vsics(nps(ig))=vsicg(np(ig)) - vsics(nms(ig))=CONJG(vsicg(np(ig))) - end do - endif - ! - call invfft('Smooth',vsics,dffts) - ! - vsicpsis=0.0_dp - if(lgam) then - do ir = 1, nnrsx - vsicpsis(ir)=CMPLX(DBLE(vsics(ir))*DBLE(psis(ir)),0.0_dp) - enddo - else - do ir = 1, nnrsx - vsicpsis(ir)=CMPLX(DBLE(vsics(ir))*DBLE(psis(ir)), DBLE(vsics(ir))*AIMAG(psis(ir))) - enddo - endif - ! - call fwfft('Wave',vsicpsis,dffts) - ! - do ig=1,ngw - vsicpsi(ig,j)=vsicpsis(nps(ig)) - enddo - ! - enddo - ! - end subroutine nksic_eforce_std - ! -!--------------------------------------------------------------- -end subroutine nksic_eforce -!--------------------------------------------------------------- - - -!--------------------------------------------------------------- - subroutine nksic_dmxc_spin_cp( nnrx, rhoref, f, ispin, rhoele, & - small, wref, wxd ) -!--------------------------------------------------------------- -! -! the derivative of the xc potential with respect to the local density -! is computed. -! In order to save time, the loop over space coordinates is performed -! inside this routine (inlining). -! -! NOTE: wref and wsic are UPDATED and NOT OVERWRITTEN by this subroutine -! - USE kinds, ONLY : dp - USE funct, ONLY : xc_spin, get_iexch, get_icorr - implicit none - ! - integer, intent(in) :: nnrx, ispin - real(dp), intent(in) :: rhoref(nnrx,2), rhoele(nnrx,2) - real(dp), intent(in) :: f, small - real(dp), intent(inout) :: wref(nnrx), wxd(nnrx,2) - ! - character(18) :: subname='nksic_dmxc_spin_cp' - real(dp) :: rhoup, rhodw, rhotot, zeta - real(dp) :: dmuxc(2,2) - real(dp) :: rs, ex, vx, dr, dz, ec, & - vcupm, vcdwm, vcupp, vcdwp, dzm, dzp, fact - !real(dp) :: vxupp, vxdwp, vxupm, vxdwm - real(dp), external :: dpz, dpz_polarized - integer :: ir - !logical :: do_exch, do_corr - ! - real(dp), parameter :: e2 = 2.0_dp, & - pi34 = 0.6203504908994_DP, & ! redefined to pi34=(3/4pi)^(1/3) - pi34_old= 0.75_dp/3.141592653589793_dp, third=1.0_dp/3.0_dp, & - p43=4.0_dp/3.0_dp, p49=4.0_dp/ 9.0_dp, m23=-2.0_dp/3.0_dp - - ! - ! mian body - ! - !CALL start_clock( 'nk_dmxc_spin_cp' ) - ! - ! the current implementation works only on top - ! of LSD and LDA. Other functionals have to - ! be implemented explicitly. To do that, we need to - ! call the proper xc-routine (at the moment we call - ! slater and pz_corr) - ! - if ( get_iexch() /= 1 .or. get_icorr() /= 1 ) & - call errore(subname,'only LDA/LSD PZ functionals implemented',10) - ! - !do_exch = ( get_iexch() == 1 ) - !do_corr = ( get_icorr() == 1 ) - ! - ! - ! main loop - ! - do ir = 1, nnrx - ! - dmuxc(:,:)=0.0_dp - ! - rhoup = rhoref(ir,1) - rhodw = rhoref(ir,2) - rhotot = rhoup + rhodw - ! - if( rhotot < small) cycle - ! - zeta = (rhoup-rhodw)/rhotot - if(abs(zeta)>1.0_dp) zeta=sign(1.0_dp,zeta) - - ! - ! calculate exchange contribution (analytical) - ! - if ( rhoup > small) then - rs = pi34 / (2.0_dp*rhoup)**third - call slater(rs,ex,vx) - dmuxc(1,1)=vx/(3.0_dp*rhoup) - endif - ! - if( rhodw > small) then - rs = pi34 / (2.0_dp*rhodw)**third - call slater(rs,ex,vx) - dmuxc(2,2)=vx/(3.0_dp*rhodw) - endif - - ! - ! calculate correlation contribution (numerical) - ! - dr = min(1.e-6_dp,1.e-4_dp*rhotot) - fact = 0.5d0 / dr - ! - ! the explicit call to the correlation part only - ! are performed instead of calling xc_spin. - ! this saves some CPU time. - ! unfortunately, different functionals have then - ! to be treated explicitly - ! - !call xc_spin(rhotot-dr,zeta,ex,ec,vxupm,vxdwm,vcupm,vcdwm) - !call xc_spin(rhotot+dr,zeta,ex,ec,vxupp,vxdwp,vcupp,vcdwp) - ! - rs = pi34 / (rhotot-dr)**third - call pz_spin (rs, zeta, ec, vcupm, vcdwm) - rs = pi34 / (rhotot+dr)**third - call pz_spin (rs, zeta, ec, vcupp, vcdwp) - ! - dmuxc(1,1) = dmuxc(1,1) +(vcupp-vcupm) * fact - dmuxc(1,2) = dmuxc(1,2) +(vcupp-vcupm) * fact - dmuxc(2,1) = dmuxc(2,1) +(vcdwp-vcdwm) * fact - dmuxc(2,2) = dmuxc(2,2) +(vcdwp-vcdwm) * fact - - dz=1.e-6_dp - dzp=min(1.0,zeta+dz)-zeta - dzm=-max(-1.0,zeta-dz)+zeta - ! - fact = 1.0d0 / ( rhotot * (dzp+dzm) ) - ! - !call xc_spin(rhotot,zeta-dzm,ex,ec,vxupm,vxdwm,vcupm,vcdwm) - !call xc_spin(rhotot,zeta+dzp,ex,ec,vxupp,vxdwp,vcupp,vcdwp) - ! - rs = pi34 / (rhotot)**third - call pz_spin (rs, zeta-dzm, ec, vcupm, vcdwm) - call pz_spin (rs, zeta+dzp, ec, vcupp, vcdwp) - - dmuxc(1,1) = dmuxc(1,1) +(vcupp-vcupm)*(1.0_dp-zeta)*fact - dmuxc(1,2) = dmuxc(1,2) -(vcupp-vcupm)*(1.0_dp+zeta)*fact - dmuxc(2,1) = dmuxc(2,1) +(vcdwp-vcdwm)*(1.0_dp-zeta)*fact - dmuxc(2,2) = dmuxc(2,2) -(vcdwp-vcdwm)*(1.0_dp+zeta)*fact - - ! - ! add corrections to the nksic potentials - ! - wxd(ir,1) = wxd(ir,1) + dmuxc(1,ispin) * rhoele(ir,ispin)*f - wxd(ir,2) = wxd(ir,2) + dmuxc(2,ispin) * rhoele(ir,ispin)*f - ! - wref(ir) = wref(ir) + dmuxc(ispin,ispin)*rhoele(ir,ispin) - ! - enddo - - return - ! -!--------------------------------------------------------------- -end subroutine nksic_dmxc_spin_cp -!--------------------------------------------------------------- - - -!----------------------------------------------------------------------- - subroutine nksic_rot_emin(nouter,ninner,etot,Omattot, lgam) -!----------------------------------------------------------------------- -! -! ... Finds the orthogonal rotation matrix Omattot that minimizes -! the orbital-dependent and hence the total energy, and then -! rotate the wavefunction c0 accordingly. -! We may need Omattot for further rotation of the gradient for outer loop CG. -! Right now we do not do that because we set resetcg=.true. after inner loop -! minimization routine, i.e., setting the search direction to be gradient direction. -! (Ultrasoft pseudopotential case is not implemented.) -! - use kinds, only : dp - use constants, only : PI - use grid_dimensions, only : nnrx - use gvecw, only : ngw - use io_global, only : stdout, ionode - use electrons_base, only : nbsp, nbspx, nspin, & - iupdwn,nupdwn - use cp_interfaces, only : invfft - use nksic, only : vsic, pink, & - do_nk, do_wref, do_wxd, & - innerloop_nmax - use uspp, only : nkb - use cp_main_variables, only : bec - use wavefunctions_module, only : c0, cm - use control_flags, only : esic_conv_thr - use cg_module, only : tcg - use twin_types - ! - implicit none - ! - ! in/out vars - ! - integer :: ninner - integer, intent(in) :: nouter - real(dp), intent(in) :: etot - complex(dp) :: Omattot(nbspx,nbspx) - logical :: lgam - - ! - ! local variables - ! - real(dp) :: esic,esic_old - integer :: nbnd1,nbnd2 - integer :: npassofailmax - real(dp) :: dtmp,dalpha - integer :: isp - real(dp) :: vsicah2sum,deigrms,dmaxeig - logical :: do_nonvar,lstopinner - ! - complex(dp), allocatable :: Omat1tot(:,:) - complex(dp), allocatable :: Umatbig(:,:) - real(dp), allocatable :: Heigbig(:) - complex(dp), allocatable :: wfc_ctmp(:,:) - complex(dp), allocatable :: Umat(:,:) - real(dp), allocatable :: Heig(:) - complex(dp), allocatable :: vsicah(:,:) - real(dp), allocatable :: vsic1(:,:) - type(twin_matrix) :: bec1 -! real(dp), allocatable :: bec1(:,:) - real(dp), allocatable :: pink1(:) - ! - integer, save :: npassofail=0 - real(dp), save :: passoprod=0.3d0 - - ! - ! variables for test calculations - along gradient line direction - ! - logical :: ldotest - - ! - ! main body - ! - CALL start_clock( 'nk_rot_emin' ) - - ! - npassofailmax = 5 ! when to stop dividing passoprod by 2 - esic_old=0.d0 - - allocate( Omat1tot(nbspx,nbspx) ) - allocate( Umatbig(nbspx,nbspx) ) - allocate( Heigbig(nbspx) ) - allocate( wfc_ctmp(ngw,nbspx) ) - allocate( vsic1(nnrx,nbspx) ) - allocate( pink1(nbspx) ) - - call init_twin(bec1,lgam) - call allocate_twin(bec1,nkb,nbsp,lgam) -! allocate( bec1(nkb,nbsp) ) - ! - Umatbig(:,:)=(0.d0,0.d0) - Heigbig(:)=0.d0 - deigrms = 0.d0 - - Omattot(:,:)=0.d0 - do nbnd1=1,nbspx - Omattot(nbnd1,nbnd1)=1.d0 - enddo - - ninner = 0 - ldotest=.false. - - ! - ! init IO - if (ionode) write(stdout, "(14x,'# iter',6x,'etot',17x,'esic',& - & 17x,'deigrms')") - - ! - ! main loop - ! - inner_loop: & - do while (.true.) - - call start_clock( "nk_innerloop" ) - ! - ninner = ninner + 1 - - if( ninner > innerloop_nmax ) then - ! -#ifdef __DEBUG - if(ionode) write(1031,*) '# innerloop_nmax reached.' - if(ionode) write(1031,*) -#endif - if(ionode) then - write(stdout,"(14x,'# innerloop_nmax reached.',/)") - endif - ! - call stop_clock( "nk_innerloop" ) - exit inner_loop - ! - endif - -#ifdef __DEBUG - ! -!$$ ! Now do the test - ! - if( mod(ninner,10) == 1 .or. ninner <= 5) ldotest=.true. - !ldotest=.true. - if(ldotest) then - ! - dtmp = 4.d0*PI - !call nksic_rot_test(dtmp,201,nouter,ninner,etot) - ldotest=.false. - ! - endif -#endif - - ! - ! This part calculates the anti-hermitian part of the hamiltonian - ! vsicah and see whether a convergence has been achieved - ! - wfc_ctmp(:,:) = (0.d0,0.d0) - deigrms = 0.d0 - - spin_loop: & - do isp=1,nspin - ! - allocate( Umat(nupdwn(isp),nupdwn(isp)) ) - allocate( Heig(nupdwn(isp)) ) - allocate( vsicah(nupdwn(isp), nupdwn(isp)) ) - ! - call nksic_getvsicah_new2( isp, vsicah, vsicah2sum, lgam) - ! - call nksic_getHeigU( isp, vsicah, Heig, Umat) - - Umatbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = Umat(:,:) - Heigbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = Heig(:) - - !! - !! CHP: The following file prints out - !! the eigenvalues of the force matrix for debugging - ! - !if (ionode) then - ! nfile=10000+isp - ! write(nfile,'(2I10,100F10.6)') ninner,nouter,sum(Heig(:)**2),Heig(:) - !endif - ! - deigrms = deigrms + sum(Heig(:)**2) - - deallocate(Umat) - deallocate(Heig) - deallocate(vsicah) - ! - enddo spin_loop - - - dmaxeig = max( abs(Heigbig(iupdwn(1))), abs(Heigbig(iupdwn(1)+nupdwn(1)-1)) ) - do isp=2,nspin - ! - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)))) - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)+nupdwn(isp)-1))) - ! - enddo - - ! how severe the transform is - deigrms = sqrt(deigrms/nbsp) - - ! - ! print out ESIC part & other total energy - ! - esic=sum(pink(:)) - ! -#ifdef __DEBUG - if(ionode) write(1031,'(2I10,3F24.13)') ninner, nouter,etot,esic,deigrms -#endif - if(ionode) write(stdout,'(10x,2i5,3F21.13)') ninner, nouter, etot, esic, deigrms - - - dalpha = passoprod/dmaxeig - ! - call nksic_getOmattot(dalpha,Heigbig,Umatbig,c0,wfc_ctmp,Omat1tot,bec1,vsic1,pink1,dtmp, lgam) - - ! - ! deal with non-variational functionals, - ! such as NK0 - ! - do_nonvar = ( do_nk .and. ( .not. do_wref .or. .not. do_wxd) ) - ! - if( do_nonvar ) then - lstopinner = ( ninner >= 2 .and. & - ( (esic-dtmp)*(esic-esic_old) > 0.d0) ) - else - lstopinner = ( dtmp >= esic ) - endif - ! - lstopinner = ( lstopinner .or. ( abs(esic-dtmp) < esic_conv_thr ) ) - - - if ( lstopinner ) then - ! - npassofail = npassofail+1 - ! -#ifdef __DEBUG - if(ionode) write(1031,'("# procedure ",I4," / ",I4, & - & " is finished.",/)') npassofail,npassofailmax -#endif - if(ionode) write(stdout,'(14x, "# procedure ",I4," / ",I4, & - & " is finished.",/)') npassofail,npassofailmax - ! - ! if we reach at the maximum allowed npassofail number, - ! we exit without further update - ! - if( npassofail >= npassofailmax ) then - ! - ninner = ninner + 1 - call stop_clock( "nk_innerloop" ) - exit inner_loop - ! - endif - ! - passoprod = passoprod * 0.5d0 - ! ldotest=.true. - cycle - ! - endif - - ! - ! we keep track of all the rotations to rotate cm later - ! - Omattot = MATMUL(Omattot,Omat1tot) - ! - pink(:) = pink1(:) - vsic(:,:) = vsic1(:,:) - call copy_twin(bec, bec1) -! bec%rvec(:,:) = bec1(:,:) - c0(:,:) = wfc_ctmp(:,:) - esic_old = esic - - call stop_clock( "nk_innerloop" ) - ! - enddo inner_loop - - ! - ! Wavefunction cm rotation according to Omattot - ! cm is relevant only for damped dynamics - ! - call start_clock( "nk_rot_cm" ) - if ( .not. tcg ) then - ! - if( ninner >= 2 ) then - ! - wfc_ctmp(:,:) = (0.d0,0.d0) - ! - do nbnd1=1,nbspx - do nbnd2=1,nbspx - wfc_ctmp(:,nbnd1)=wfc_ctmp(:,nbnd1) + cm(:,nbnd2) * Omattot(nbnd2,nbnd1) - ! XXX (we can think to use a blas, here, and split over spins) - enddo - enddo - ! - cm(:,1:nbspx) = wfc_ctmp(:,1:nbspx) - ! - endif - ! - endif - ! - deallocate( Omat1tot ) - deallocate( Umatbig ) - deallocate( Heigbig ) - deallocate( wfc_ctmp ) - deallocate( vsic1 ) - call deallocate_twin(bec1) - deallocate( pink1 ) - ! - call stop_clock( "nk_rot_cm" ) - call stop_clock( 'nk_rot_emin' ) - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_rot_emin -!--------------------------------------------------------------- - - -!----------------------------------------------------------------------- - subroutine nksic_rot_test(passoprod,nsteps,nouter,ninner,etot) -!----------------------------------------------------------------------- -! -! ... prints out esic by varying the wavefunction along a search direction. -! (Ultrasoft pseudopotential case is not implemented.) -! - use kinds, only : dp - use grid_dimensions, only : nnrx - use gvecw, only : ngw - use io_global, only : ionode - use electrons_base, only : nbsp, nbspx, nspin, & - iupdwn, nupdwn - use uspp, only : nkb - use wavefunctions_module, only : c0 - ! - implicit none - ! - ! in/out vars - ! - real(dp), intent(in) :: passoprod - integer, intent(in) :: nsteps, ninner, nouter - real(dp), intent(in) :: etot - - - ! - ! local variables - ! - real(dp) :: esic - real(dp) :: bec1(nkb,nbsp) - real(dp) :: Omat1tot(nbspx,nbspx) - real(dp) :: vsic1(nnrx,nbspx) - complex(dp), allocatable :: Umat(:,:) - complex(dp) :: Umatbig(nbspx,nbspx) - real(dp), allocatable :: Heig(:) - real(dp) :: Heigbig(nbspx) - complex(dp) :: wfc_ctmp(ngw,nbspx) - real(dp) :: dalpha,dmaxeig - real(dp) :: pink1(nbspx) - integer :: isp,istep - real(dp), allocatable :: vsicah(:,:) - real(dp) :: vsicah2sum,deigrms - integer :: nfile - - ! - ! variables for test calculations - along gradient line direction - ! - - ! - ! main body - ! - CALL start_clock( 'nk_rot_test' ) - - - Umatbig(:,:) = (0.d0,0.d0) - Heigbig(:) = 0.d0 - deigrms = 0.d0 - - do isp=1,nspin - - allocate(Umat(nupdwn(isp),nupdwn(isp))) - allocate(Heig(nupdwn(isp))) - allocate(vsicah(nupdwn(isp),nupdwn(isp))) - - call nksic_getvsicah(isp,vsicah,vsicah2sum) - call nksic_getHeigU(isp,vsicah,Heig,Umat) - - Umatbig(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp),iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = Umat(:,:) - Heigbig(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = Heig(:) - - deigrms = deigrms + sum(Heig(:)**2) - - deallocate(Umat) - deallocate(Heig) - deallocate(vsicah) - - enddo ! do isp=1,nspin - - ! how severe the transform is - deigrms = sqrt(deigrms/nbsp) - - dmaxeig = max( abs(Heigbig(iupdwn(1))), abs(Heigbig(iupdwn(1)+nupdwn(1)-1)) ) - do isp=2,nspin - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)))) - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)+nupdwn(isp)-1))) - enddo - - nfile = 10000+100*nouter+ninner - if(ionode) write(nfile,*) '# passoprod',passoprod - - do istep=1,nsteps - if(nsteps.ne.1) then - dalpha = passoprod*(2.d0*istep-nsteps-1.d0)/(nsteps-1.d0) / dmaxeig - else - dalpha = 0.d0 - endif - - call nksic_getOmattot(dalpha,Heigbig,Umatbig,c0,wfc_ctmp,Omat1tot,bec1,vsic1,pink1,esic) - - if(ionode) write(nfile,'(5F24.13,2I10)') dalpha/3.141592*dmaxeig, dmaxeig, etot, esic, deigrms,ninner, nouter - - enddo !$$ do istep=1,nsteps - - if(ionode) write(nfile,*) - - CALL stop_clock( 'nk_rot_test' ) - return - ! -!--------------------------------------------------------------- -end subroutine nksic_rot_test -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_rot_emin_cg_new(c0, cm, vsic, ngw, nnrx, bec, & - nouter, init_n, ninner,etot,Omattot, & - rot_threshold, nbsp, nbspx, nudx, nspin, iupdwn, & - nupdwn, pink, wfc_centers, wfc_spreads, lgam) -!----------------------------------------------------------------------- -! -! ... Finds the orthogonal rotation matrix Omattot that minimizes -! the orbital-dependent and hence the total energy, and then -! rotate the wavefunction c0 accordingly using cg minimization. -! We may need Omattot for further rotation of the gradient for outer loop CG. -! Right now we do not do that because we set resetcg=.true. after inner loop -! minimization routine, i.e., setting the search direction to be gradient direction. -! (Ultrasoft pseudopotential case is not implemented.) -! - use kinds, only : dp - use io_global, only : stdout, ionode - use cp_interfaces, only : invfft - use nksic, only : innerloop_cg_nsd, & - innerloop_cg_nreset,& - innerloop_nmax, & - innerloop_atleast - use uspp, only : nkb - use control_flags, only : esic_conv_thr - use cg_module, only : tcg - use twin_types - ! - implicit none - ! - ! in/out vars - ! - integer :: ninner,nbsp,nbspx,nspin, nudx, nnrx - integer :: init_n, ngw, ispin(nbspx) - integer, intent(in) :: nouter - integer, intent(in) :: iupdwn(nspin), nupdwn(nspin) - real(dp), intent(in) :: etot - complex(dp) :: Omattot(nbspx,nbspx), c0(ngw,nbsp), cm(ngw,nbsp) - real(dp), intent(in) :: rot_threshold - real(dp), intent(inout) :: pink(nbsp), vsic(nnrx, nbspx), & - wfc_centers(4,nudx,nspin), wfc_spreads(nudx, nspin, 2) - logical :: lgam - type(twin_matrix) :: bec - - ! - ! local variables for cg routine - ! - integer :: nbnd1,nbnd2 - integer :: isp - logical :: ldotest - real(dp) :: dtmp - real(dp) :: ene0,ene1,enesti,enever,dene0 - real(dp) :: passo,passov,passof,passomax,spasso - real(dp) :: vsicah2sum,vsicah2sum_prev - integer :: nidx1,nidx2 - real(dp) :: dPI,dalpha,dmaxeig,deigrms - real(dp) :: pinksumprev,passoprod - ! - complex(dp), allocatable :: Omat1tot(:,:), Omat2tot(:,:) - real(dp), allocatable :: Heigbig(:) - complex(dp), allocatable :: Umatbig(:,:) - complex(dp), allocatable :: wfc_ctmp(:,:), wfc_ctmp2(:,:) - complex(dp), allocatable :: gi(:,:), hi(:,:) - ! - complex(dp), allocatable :: Umat(:,:) - real(dp), allocatable :: Heig(:) - complex(dp), allocatable :: vsicah(:,:) - real(dp), allocatable :: vsic1(:,:), vsic2(:,:) - type(twin_matrix) :: bec1,bec2 - real(dp), allocatable :: pink1(:), pink2(:) - logical :: restartcg_innerloop, ene_ok_innerloop, ltresh, setpassomax - integer :: iter3, nfail - integer :: maxiter3, numok, minsteps - real(dp) :: signalpha - character(len=4) :: marker - real(dp) :: conv_thr - - ! - ! main body - ! - CALL start_clock( 'nk_rot_emin' ) - ! - ! - marker=" " - maxiter3=4 - minsteps=2 - restartcg_innerloop = .true. - ene_ok_innerloop = .false. - ltresh=.false. - setpassomax=.false. - nfail=0 - if(nouter innerloop_nmax ) then - ! -#ifdef __DEBUG - if(ionode) write(1031,*) '# innerloop_nmax reached.' - if(ionode) write(1031,*) -#endif - if(ionode) then - write(stdout,"(14x,'# innerloop_nmax reached.',/)") - endif - ! - call stop_clock( "nk_innerloop" ) - exit inner_loop - ! - endif - -#ifdef __DEBUG - ! - ! call nksic_printoverlap(ninner,nouter) - -! if(mod(ninner,10).eq.1.or.ninner.le.5) ldotest=.true. - if(ninner.eq.31.or.ninner.eq.61.or.ninner.eq.91) ldotest=.true. -! if(ninner.le.10.and.nouter.eq.1) ldotest=.true. -! ldotest=.true. -! if(ninner.ge.25) ldotest=.true. - ! Now do the test - if(ldotest) then -! dtmp = 1.0d0*3.141592d0 - dtmp = 4.d0*3.141592d0 -! call nksic_rot_test(dtmp,201,nouter,ninner,etot) - ldotest=.false. - endif -#endif - - ! - !print out ESIC part & other total energy - ! - ene0 = sum( pink(1:nbsp) ) - - ! - ! test convergence - ! - if( abs(ene0-pinksumprev) < conv_thr ) then - numok=numok+1 - else - numok=0 - endif - ! - if( numok >= minsteps .and. ninner>=innerloop_atleast) ltresh=.true. - ! - if( ltresh ) then - ! -#ifdef __DEBUG - if(ionode) then - write(1037,"(a,/)") '# inner-loop converged.' - write(1031,"(a,/)") '# inner-loop converged.' - endif -#endif - if(ionode .and. numok twice passomax' -!$$$$ endif - -! if(ionode) then -! write(1037,*)'# deigrms = ',deigrms -! write(1037,*)'# vsicah2sum = ',vsicah2sum -! if(ninner.ne.1) write(1037,*)'# vsicah2sum/vsicah2sum_prev = ',dtmp -! endif - - - vsicah2sum_prev = vsicah2sum - ! - dene0 = 0.d0 - ! - do isp = 1, nspin - ! - do nbnd1 = 1, nupdwn(isp) - do nbnd2 = 1, nupdwn(isp) - ! - nidx1 = nbnd1-1+iupdwn(isp) - nidx2 = nbnd2-1+iupdwn(isp) - IF(nidx1.ne.nidx2) THEN - dene0 = dene0 - DBLE(CONJG(gi(nidx1,nidx2))*hi(nidx1,nidx2)) - ELSE !warning:giovanni: do we need this condition - !dene0 = dene0 -DBLE(CONJG(gi(nidx1,nidx2))*hi(nidx1,nidx2)) - ENDIF - ! - enddo - enddo - ! - enddo - - !$$ - !$$ dene0 = dene0 * 2.d0/nspin - ! - ! Be careful, the following is correct because A_ji = - A_ij, i.e., the number of - ! linearly independent variables is half the number of total variables! - ! - dene0 = dene0 * 1.d0/nspin - ! - spasso = 1.d0 - if( dene0 > 0.d0) spasso = -1.d0 - ! - dalpha = spasso*passof - ! - call nksic_getOmattot_new( nbsp, nbspx,nudx,nspin,ispin, & - iupdwn, nupdwn, wfc_centers, wfc_spreads, & - dalpha, Heigbig, Umatbig, c0, wfc_ctmp, & - Omat1tot, bec1, vsic1, pink1, ene1, lgam) - call minparabola( ene0, spasso*dene0, ene1, passof, passo, enesti) - ! - ! We neglect this step for paper writing purposes - ! - if( passo > passomax ) then - passo = passomax -#ifdef __DEBUG - if(ionode) write(1031,*) '# passo > passomax' -#endif - ! - endif - - passov = passof - passof = 2.d0*passo - - dalpha = spasso*passo - ! -!$$ The following line is for dene0 test -! if(ninner.ge.15) dalpha = spasso*passo*0.00001 -!$$ - call nksic_getOmattot( dalpha, Heigbig, Umatbig, c0, wfc_ctmp2, & - Omat2tot, bec2, vsic2, pink2, enever, lgam) -#ifdef __DEBUG - if(ionode) then - ! - write(1037,*) ninner, nouter - write(1037,'("ene0,ene1,enesti,enever")') - write(1037,'(a3,4f20.10)') 'CG1',ene0,ene1,enesti,enever - write(1037,'("spasso,passov,passo,passomax,dene0,& - & (enever-ene0)/passo/dene0")') - write(1037,'(a3,4f12.7,e20.10,f12.7)') & - 'CG2',spasso,passov,passo,passomax,dene0,(enever-ene0)/passo/dene0 - write(1037,*) - ! - endif -#endif - if(ene0 < ene1 .and. ene0 < enever) then !missed minimum case 3 - !write(6,'("# WARNING: innerloop missed minimum, case 3",/)') - ! - iter3=0 - signalpha=1.d0 - restartcg_innerloop=.true. - ! - do while(enever.ge.ene0 .and. iter3.lt.maxiter3) - ! - iter3=iter3+1 - ! - signalpha=signalpha*(-0.717d0) - dalpha = spasso*passo*signalpha - ! - call nksic_getOmattot( dalpha, Heigbig, Umatbig, c0, wfc_ctmp2, Omat2tot, bec2, vsic2, pink2, enever, lgam) - ! - enddo - - IF(enever.lt.ene0) THEN - ! - pink(:) = pink2(:) - vsic(:,:) = vsic2(:,:) - c0(:,:) = wfc_ctmp2(:,:) - call copy_twin(bec,bec2) - ! bec%rvec(:,:) = bec2(:,:) - Omattot = MATMUL( Omattot, Omat2tot) - !write(6,'("# WARNING: innerloop case 3 interations",3I/)') iter3 - write(marker,'(i1)') iter3 - marker = '*'//marker - passof=passo*abs(signalpha) - nfail=0 - ! - ELSE - ! - marker = '***' - ninner = ninner + 1 - nfail=nfail+1 - numok=0 - passof=passo*abs(signalpha) - ! - IF(nfail>2) THEN - write(6,'("# WARNING: innerloop not converged, exit",/)') - call stop_clock( "nk_innerloop" ) - exit - ENDIF -! ELSE -! nfail=0 -! ENDIF - ! - ENDIF -#ifdef __DEBUG - if(ionode) then - write(1037,'("# ene0= enever ) then !found minimum - ! - pink(:) = pink2(:) - vsic(:,:) = vsic2(:,:) - c0(:,:) = wfc_ctmp2(:,:) - call copy_twin(bec,bec2) -! bec%rvec(:,:) = bec2(:,:) - Omattot = MATMUL( Omattot, Omat2tot) - marker=" " - nfail=0 - ! - else !missed minimum, case 1 or 2 - ! - pink(:) = pink1(:) - vsic(:,:) = vsic1(:,:) - c0(:,:) = wfc_ctmp(:,:) - call copy_twin(bec,bec1) - Omattot = MATMUL( Omattot, Omat1tot) - restartcg_innerloop = .true. - IF(enever= 2 ) then - ! - wfc_ctmp(:,:) = CMPLX(0.d0,0.d0) - ! - do nbnd1=1,nbspx - do nbnd2=1,nbspx - wfc_ctmp(:,nbnd1)=wfc_ctmp(:,nbnd1) + cm(:,nbnd2) * Omattot(nbnd2,nbnd1) !warning:giovanni CONJUGATE? - ! XXX (we can think to use a blas, here, and split over spins) - !does not seem we need to make it conjugate - enddo - enddo - ! - cm(:,1:nbspx) = wfc_ctmp(:,1:nbspx) - ! - endif - ! - endif - ! - ! clean local workspace - ! - deallocate( Omat1tot, Omat2tot ) - deallocate( Umatbig ) - deallocate( Heigbig ) - deallocate( wfc_ctmp, wfc_ctmp2 ) - deallocate( hi ) - deallocate( gi ) - deallocate( pink1, pink2 ) - deallocate( vsic1, vsic2 ) - call deallocate_twin(bec1) - call deallocate_twin(bec2) - - CALL stop_clock( 'nk_rot_emin' ) - return - ! -!--------------------------------------------------------------- -end subroutine nksic_rot_emin_cg_new -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_rot_emin_cg(nouter,init_n, ninner,etot,Omattot, & - rot_threshold, lgam) -!----------------------------------------------------------------------- -! -! ... Finds the orthogonal rotation matrix Omattot that minimizes -! the orbital-dependent and hence the total energy, and then -! rotate the wavefunction c0 accordingly using cg minimization. -! We may need Omattot for further rotation of the gradient for outer loop CG. -! Right now we do not do that because we set resetcg=.true. after inner loop -! minimization routine, i.e., setting the search direction to be gradient direction. -! (Ultrasoft pseudopotential case is not implemented.) -! - use kinds, only : dp - use grid_dimensions, only : nnrx - use gvecw, only : ngw - use io_global, only : stdout, ionode - use electrons_base, only : nbsp, nbspx, nspin, & - iupdwn,nupdwn - use cp_interfaces, only : invfft - use nksic, only : vsic, pink, & - innerloop_cg_nsd, innerloop_cg_nreset,& - innerloop_nmax, & - innerloop_atleast - use uspp, only : nkb - use cp_main_variables, only : bec - use wavefunctions_module, only : c0, cm - use control_flags, only : esic_conv_thr - use cg_module, only : tcg - use twin_types - ! - implicit none - ! - ! in/out vars - ! - integer :: ninner - integer :: init_n - integer, intent(in) :: nouter - real(dp), intent(in) :: etot - complex(dp) :: Omattot(nbspx,nbspx) - real(dp), intent(in) :: rot_threshold - logical :: lgam - - ! - ! local variables for cg routine - ! - integer :: nbnd1,nbnd2 - integer :: isp - logical :: ldotest - real(dp) :: dtmp - real(dp) :: ene0,ene1,enesti,enever,dene0 - real(dp) :: passo,passov,passof,passomax,spasso - real(dp) :: vsicah2sum,vsicah2sum_prev - integer :: nidx1,nidx2 - real(dp) :: dPI,dalpha,dmaxeig,deigrms - real(dp) :: pinksumprev,passoprod - ! - complex(dp), allocatable :: Omat1tot(:,:), Omat2tot(:,:) - real(dp), allocatable :: Heigbig(:) - complex(dp), allocatable :: Umatbig(:,:) - complex(dp), allocatable :: wfc_ctmp(:,:), wfc_ctmp2(:,:) - complex(dp), allocatable :: gi(:,:), hi(:,:) - ! - complex(dp), allocatable :: Umat(:,:) - real(dp), allocatable :: Heig(:) - complex(dp), allocatable :: vsicah(:,:) - real(dp), allocatable :: vsic1(:,:), vsic2(:,:) - type(twin_matrix) :: bec1,bec2 - real(dp), allocatable :: pink1(:), pink2(:) - logical :: restartcg_innerloop, ene_ok_innerloop, ltresh, setpassomax - integer :: iter3, nfail - integer :: maxiter3,numok - real(dp) :: signalpha - character(len=4) :: marker - real(dp) :: conv_thr - - ! - ! main body - ! - CALL start_clock( 'nk_rot_emin' ) - ! - ! - marker=" " - maxiter3=4 - restartcg_innerloop = .true. - ene_ok_innerloop = .false. - ltresh=.false. - setpassomax=.false. - nfail=0 - if(nouter innerloop_nmax ) then - ! -#ifdef __DEBUG - if(ionode) write(1031,*) '# innerloop_nmax reached.' - if(ionode) write(1031,*) -#endif - if(ionode) then - write(stdout,"(14x,'# innerloop_nmax reached.',/)") - endif - ! - call stop_clock( "nk_innerloop" ) - exit inner_loop - ! - endif - -#ifdef __DEBUG - ! - ! call nksic_printoverlap(ninner,nouter) - -! if(mod(ninner,10).eq.1.or.ninner.le.5) ldotest=.true. - if(ninner.eq.31.or.ninner.eq.61.or.ninner.eq.91) ldotest=.true. -! if(ninner.le.10.and.nouter.eq.1) ldotest=.true. -! ldotest=.true. -! if(ninner.ge.25) ldotest=.true. - ! Now do the test - if(ldotest) then -! dtmp = 1.0d0*3.141592d0 - dtmp = 4.d0*3.141592d0 -! call nksic_rot_test(dtmp,201,nouter,ninner,etot) - ldotest=.false. - endif -#endif - - ! - !print out ESIC part & other total energy - ! - ene0 = sum( pink(1:nbsp) ) - - ! - ! test convergence - ! - if( abs(ene0-pinksumprev) < conv_thr ) then - numok=numok+1 - else - numok=0 - endif - ! - if( numok >= 2 .and. ninner>=innerloop_atleast) ltresh=.true. - ! - if( ltresh ) then - ! -#ifdef __DEBUG - if(ionode) then - write(1037,"(a,/)") '# inner-loop converged.' - write(1031,"(a,/)") '# inner-loop converged.' - endif -#endif - if(ionode) write(stdout,"(14x,'# innerloop converged',/)") - ! - call stop_clock( "nk_innerloop" ) - exit inner_loop - ! - endif - ! - pinksumprev=ene0 - - ! - ! This part calculates the anti-hermitian part of the Hamiltonian vsicah - ! and see whether a convergence has been achieved - ! - ! For this run, we obtain the gradient - ! - vsicah2sum = 0.0d0 - ! - do isp=1,nspin - ! - allocate(vsicah(nupdwn(isp),nupdwn(isp))) - ! - call nksic_getvsicah_new2(isp,vsicah,dtmp, lgam) - ! - gi( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = vsicah(:,:) - ! - vsicah2sum = vsicah2sum + dtmp - ! - deallocate(vsicah) - ! - enddo - ! - if( ninner /= 1 ) dtmp = vsicah2sum/vsicah2sum_prev - ! - if( ninner <= innerloop_cg_nsd .or. & - mod(ninner,innerloop_cg_nreset) ==0 .or. & - restartcg_innerloop ) then - ! - restartcg_innerloop=.false. - setpassomax=.false. - ! - hi(:,:) = gi(:,:) - else - hi(:,:) = gi(:,:) + dtmp*hi(:,:) - endif - ! - spin_loop: & - do isp=1,nspin - ! - IF(nupdwn(isp).gt.0) THEN - allocate( vsicah(nupdwn(isp),nupdwn(isp)) ) - allocate( Umat(nupdwn(isp),nupdwn(isp)) ) - allocate( Heig(nupdwn(isp)) ) - - vsicah(:,:) = hi( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) - - call nksic_getHeigU(isp,vsicah,Heig,Umat) - ! - deigrms = deigrms + sum(Heig(:)**2) - ! - Umatbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) = Umat(:,:) - Heigbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) = Heig(:) - ! - deallocate(vsicah) - deallocate(Umat) - deallocate(Heig) - ELSE - Umatbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) = 1.d0 - Heigbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) = 0.d0 - ENDIF - ! - enddo spin_loop - - ! how severe the transform is - deigrms = sqrt(deigrms/nbsp) -#ifdef __DEBUG - if(ionode) write(1031,'(2I10,3F24.13)') ninner, nouter,etot,ene0,deigrms -#endif - if(ionode) write(stdout,'(10x,A3,2i5,3F21.13)') marker, ninner, nouter, etot, ene0, deigrms - ! - ! - dmaxeig = max( dabs(Heigbig(iupdwn(1))), dabs(Heigbig(iupdwn(1)+nupdwn(1)-1)) ) - ! - do isp = 2, nspin - dmaxeig = max(dmaxeig,dabs(Heigbig(iupdwn(isp)))) - dmaxeig = max(dmaxeig,dabs(Heigbig(iupdwn(isp)+nupdwn(isp)-1))) - enddo - ! - passomax=passoprod/dmaxeig - ! - if( ninner == 1 .or. setpassomax) then - passof = passomax - setpassomax=.false. -#ifdef __DEBUG - if(ionode) write(1031,*) '# passof set to passomax' -#endif - endif - -!$$$$ if(passof .gt. passomax*2.d0) then -!$$$$ passof = passomax*2.d0 -!$$$$ if(ionode) write(1031,*) '# passof > twice passomax' -!$$$$ endif - -! if(ionode) then -! write(1037,*)'# deigrms = ',deigrms -! write(1037,*)'# vsicah2sum = ',vsicah2sum -! if(ninner.ne.1) write(1037,*)'# vsicah2sum/vsicah2sum_prev = ',dtmp -! endif - - - vsicah2sum_prev = vsicah2sum - ! - dene0 = 0.d0 - ! - do isp = 1, nspin - ! - do nbnd1 = 1, nupdwn(isp) - do nbnd2 = 1, nupdwn(isp) - ! - nidx1 = nbnd1-1+iupdwn(isp) - nidx2 = nbnd2-1+iupdwn(isp) - IF(nidx1.ne.nidx2) THEN - dene0 = dene0 - DBLE(CONJG(gi(nidx1,nidx2))*hi(nidx1,nidx2)) - ELSE !warning:giovanni: do we need this condition - !dene0 = dene0 -DBLE(CONJG(gi(nidx1,nidx2))*hi(nidx1,nidx2)) - ENDIF - ! - enddo - enddo - ! - enddo - - !$$ - !$$ dene0 = dene0 * 2.d0/nspin - ! - ! Be careful, the following is correct because A_ji = - A_ij, i.e., the number of - ! linearly independent variables is half the number of total variables! - ! - dene0 = dene0 * 1.d0/nspin - ! - spasso = 1.d0 - if( dene0 > 0.d0) spasso = -1.d0 - ! - dalpha = spasso*passof - ! - call nksic_getOmattot( dalpha, Heigbig, Umatbig, c0, wfc_ctmp, & - Omat1tot, bec1, vsic1, pink1, ene1, lgam) - call minparabola( ene0, spasso*dene0, ene1, passof, passo, enesti) - - ! - ! We neglect this step for paper writing purposes - ! - if( passo > passomax ) then - passo = passomax -#ifdef __DEBUG - if(ionode) write(1031,*) '# passo > passomax' -#endif - ! - endif - - passov = passof - passof = 2.d0*passo - - dalpha = spasso*passo - ! -!$$ The following line is for dene0 test -! if(ninner.ge.15) dalpha = spasso*passo*0.00001 -!$$ - call nksic_getOmattot( dalpha, Heigbig, Umatbig, c0, wfc_ctmp2, & - Omat2tot, bec2, vsic2, pink2, enever, lgam) - -#ifdef __DEBUG - if(ionode) then - ! - write(1037,*) ninner, nouter - write(1037,'("ene0,ene1,enesti,enever")') - write(1037,'(a3,4f20.10)') 'CG1',ene0,ene1,enesti,enever - write(1037,'("spasso,passov,passo,passomax,dene0,& - & (enever-ene0)/passo/dene0")') - write(1037,'(a3,4f12.7,e20.10,f12.7)') & - 'CG2',spasso,passov,passo,passomax,dene0,(enever-ene0)/passo/dene0 - write(1037,*) - ! - endif -#endif - - if(ene0 < ene1 .and. ene0 < enever) then !missed minimum case 3 - !write(6,'("# WARNING: innerloop missed minimum, case 3",/)') - ! - iter3=0 - signalpha=1.d0 - restartcg_innerloop=.true. - ! - do while(enever.ge.ene0 .and. iter3.lt.maxiter3) - ! - iter3=iter3+1 - ! - signalpha=signalpha*(-0.717d0) - dalpha = spasso*passo*signalpha - ! - call nksic_getOmattot( dalpha, Heigbig, Umatbig, c0, wfc_ctmp2, Omat2tot, bec2, vsic2, pink2, enever, lgam) - ! - enddo - - IF(enever.lt.ene0) THEN - ! - pink(:) = pink2(:) - vsic(:,:) = vsic2(:,:) - c0(:,:) = wfc_ctmp2(:,:) - call copy_twin(bec,bec2) - ! bec%rvec(:,:) = bec2(:,:) - Omattot = MATMUL( Omattot, Omat2tot) - !write(6,'("# WARNING: innerloop case 3 interations",3I/)') iter3 - write(marker,'(i1)') iter3 - marker = '*'//marker - passof=passo*abs(signalpha) - nfail=0 - ! - ELSE - ! - marker = '***' - ninner = ninner + 1 - nfail=nfail+1 - numok=0 - passof=passo*abs(signalpha) - ! - IF(nfail>2) THEN - write(6,'("# WARNING: innerloop not converged, exit",/)') - call stop_clock( "nk_innerloop" ) - exit - ENDIF -! ELSE -! nfail=0 -! ENDIF - ! - ENDIF -#ifdef __DEBUG - if(ionode) then - write(1037,'("# ene0= enever ) then !found minimum - ! - pink(:) = pink2(:) - vsic(:,:) = vsic2(:,:) - c0(:,:) = wfc_ctmp2(:,:) - call copy_twin(bec,bec2) -! bec%rvec(:,:) = bec2(:,:) - Omattot = MATMUL( Omattot, Omat2tot) - marker=" " - nfail=0 - ! - else !missed minimum, case 1 or 2 - ! - pink(:) = pink1(:) - vsic(:,:) = vsic1(:,:) - c0(:,:) = wfc_ctmp(:,:) - call copy_twin(bec,bec1) - Omattot = MATMUL( Omattot, Omat1tot) - restartcg_innerloop = .true. - IF(enever= 2 ) then - ! - wfc_ctmp(:,:) = CMPLX(0.d0,0.d0) - ! - do nbnd1=1,nbspx - do nbnd2=1,nbspx - wfc_ctmp(:,nbnd1)=wfc_ctmp(:,nbnd1) + cm(:,nbnd2) * Omattot(nbnd2,nbnd1) !warning:giovanni CONJUGATE? - ! XXX (we can think to use a blas, here, and split over spins) - !does not seem we need to make it conjugate - enddo - enddo - ! - cm(:,1:nbspx) = wfc_ctmp(:,1:nbspx) - ! - endif - ! - endif - - ! - ! clean local workspace - ! - deallocate( Omat1tot, Omat2tot ) - deallocate( Umatbig ) - deallocate( Heigbig ) - deallocate( wfc_ctmp, wfc_ctmp2 ) - deallocate( hi ) - deallocate( gi ) - deallocate( pink1, pink2 ) - deallocate( vsic1, vsic2 ) - call deallocate_twin(bec1) - call deallocate_twin(bec2) -! deallocate( bec1, bec2 ) - - - CALL stop_clock( 'nk_rot_emin' ) - return - ! -!--------------------------------------------------------------- -end subroutine nksic_rot_emin_cg -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_rot_emin_cg_descla(nouter,ninner,etot,Omattot, lgam) -!----------------------------------------------------------------------- -! !warning:giovanni why not passing wavefunctions as variables??? - -! ... Finds the orthogonal rotation matrix Omattot that minimizes -! the orbital-dependent and hence the total energy, and then -! rotate the wavefunction c0 accordingly using cg minimization. -! We may need Omattot for further rotation of the gradient for outer loop CG. -! Right now we do not do that because we set resetcg=.true. after inner loop -! minimization routine, i.e., setting the search direction to be gradient direction. -! (Ultrasoft pseudopotential case is not implemented.) -! - use kinds, only : dp - use grid_dimensions, only : nnrx - use gvecw, only : ngw - use io_global, only : stdout, ionode - use electrons_base, only : nbsp, nbspx, nspin, & - iupdwn,nupdwn - use cp_interfaces, only : invfft - use nksic, only : vsic, pink, & - innerloop_cg_nsd, innerloop_cg_nreset,& - innerloop_nmax - use uspp, only : nkb - use cp_main_variables, only : bec - use wavefunctions_module, only : c0, cm - use control_flags, only : esic_conv_thr - use cg_module, only : tcg - use twin_types - ! - implicit none - ! - ! in/out vars - ! - integer :: ninner - integer, intent(in) :: nouter - real(dp), intent(in) :: etot - complex(dp) :: Omattot(nbspx,nbspx) - logical :: lgam - - ! - ! local variables for cg routine - ! - integer :: nbnd1,nbnd2 - integer :: isp - logical :: ldotest - real(dp) :: dtmp - real(dp) :: ene0,ene1,enesti,enever,dene0 - real(dp) :: passo,passov,passof,passomax,spasso - real(dp) :: vsicah2sum,vsicah2sum_prev - integer :: nidx1,nidx2 - real(dp) :: dPI,dalpha,dmaxeig,deigrms - real(dp) :: pinksumprev,passoprod - ! - complex(dp), allocatable :: Omat1tot(:,:), Omat2tot(:,:) - real(dp), allocatable :: Heigbig(:) - complex(dp), allocatable :: Umatbig(:,:) - complex(dp), allocatable :: wfc_ctmp(:,:), wfc_ctmp2(:,:) - complex(dp), allocatable :: gi(:,:), hi(:,:) - ! - complex(dp), allocatable :: Umat(:,:) - real(dp), allocatable :: Heig(:) - complex(dp), allocatable :: vsicah(:,:) - real(dp), allocatable :: vsic1(:,:), vsic2(:,:) - type(twin_matrix) :: bec1,bec2 - real(dp), allocatable :: pink1(:), pink2(:) - - ! - ! main body - ! - CALL start_clock( 'nk_rot_emin' ) - ! - ! - pinksumprev=1.d8 - dPI = 2.0_DP * asin(1.0_DP) - passoprod = (0.3d0/dPI)*dPI - - ! - ! local workspace - ! - allocate( Omat1tot(nbspx,nbspx), Omat2tot(nbspx,nbspx) ) - allocate( Umatbig(nbspx,nbspx) ) - allocate( Heigbig(nbspx) ) - allocate( wfc_ctmp(ngw,nbspx), wfc_ctmp2(ngw,nbspx) ) - allocate( hi(nbsp,nbsp) ) - allocate( gi(nbsp,nbsp) ) - allocate( pink1(nbspx), pink2(nbspx) ) - allocate( vsic1(nnrx,nbspx), vsic2(nnrx,nbspx) ) - call init_twin(bec1, lgam) - call allocate_twin(bec1,nkb,nbsp,lgam) - call init_twin(bec2,lgam) - call allocate_twin(bec2,nkb,nbsp,lgam) - ! - Umatbig(:,:)=(0.d0,0.d0) - Heigbig(:)=0.d0 - deigrms = 0.d0 - hi(:,:) = 0.d0 - gi(:,:) = 0.d0 - - Omattot(:,:)=0.d0 - do nbnd1=1,nbspx - Omattot(nbnd1,nbnd1)=CMPLX(1.d0,0.d0) - enddo - - ninner = 0 - ldotest=.false. - - if (ionode) write(stdout, "(14x,'# iter',6x,'etot',17x,'esic',& - & 17x,'deigrms')") - - ! - ! main loop - ! - inner_loop: & - do while (.true.) - - call start_clock( "nk_innerloop" ) - ! - ninner = ninner + 1 - - if( ninner > innerloop_nmax ) then - ! -#ifdef __DEBUG - if(ionode) write(1031,*) '# innerloop_nmax reached.' - if(ionode) write(1031,*) -#endif - if(ionode) then - write(stdout,"(14x,'# innerloop_nmax reached.',/)") - endif - ! - call stop_clock( "nk_innerloop" ) - exit inner_loop - ! - endif - -#ifdef __DEBUG - ! - ! call nksic_printoverlap(ninner,nouter) - -! if(mod(ninner,10).eq.1.or.ninner.le.5) ldotest=.true. - if(ninner.eq.31.or.ninner.eq.61.or.ninner.eq.91) ldotest=.true. -! if(ninner.le.10.and.nouter.eq.1) ldotest=.true. -! ldotest=.true. -! if(ninner.ge.25) ldotest=.true. - ! Now do the test - if(ldotest) then -! dtmp = 1.0d0*3.141592d0 - dtmp = 4.d0*3.141592d0 -! call nksic_rot_test(dtmp,201,nouter,ninner,etot) - ldotest=.false. - endif -#endif - - ! - !print out ESIC part & other total energy - ! - ene0 = sum( pink(1:nbsp) ) - - ! - ! test convergence - ! - if( abs(ene0-pinksumprev) < esic_conv_thr) then - ! -#ifdef __DEBUG - if(ionode) then - write(1037,"(a,/)") '# inner-loop converged.' - write(1031,"(a,/)") '# inner-loop converged.' - endif -#endif - if(ionode) write(stdout,"(14x,'# innerloop converged',/)") - ! - call stop_clock( "nk_innerloop" ) - exit inner_loop - ! - endif - ! - pinksumprev=ene0 - - ! - ! This part calculates the anti-hermitian part of the Hamiltonian vsicah - ! and see whether a convergence has been achieved - ! - ! For this run, we obtain the gradient - ! - vsicah2sum = 0.0d0 - ! - do isp=1,nspin - ! - allocate(vsicah(nupdwn(isp),nupdwn(isp))) - ! - call nksic_getvsicah_new2(isp,vsicah,dtmp, lgam) - ! - gi( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = vsicah(:,:) - ! - vsicah2sum = vsicah2sum + dtmp - ! - deallocate(vsicah) - ! - enddo - ! - if( ninner /= 1 ) dtmp = vsicah2sum/vsicah2sum_prev - ! - if( ninner <= innerloop_cg_nsd .or. & - mod(ninner,innerloop_cg_nreset) ==0 ) then - ! - hi(:,:) = gi(:,:) - else - hi(:,:) = gi(:,:) + dtmp*hi(:,:) - endif - ! - spin_loop: & - do isp=1,nspin - ! - allocate( vsicah(nupdwn(isp),nupdwn(isp)) ) - allocate( Umat(nupdwn(isp),nupdwn(isp)) ) - allocate( Heig(nupdwn(isp)) ) - - vsicah(:,:) = hi( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) - - call nksic_getHeigU(isp,vsicah,Heig,Umat) - ! - deigrms = deigrms + sum(Heig(:)**2) - ! - Umatbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) = Umat(:,:) - Heigbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) = Heig(:) - ! - deallocate(vsicah) - deallocate(Umat) - deallocate(Heig) - ! - enddo spin_loop - - ! how severe the transform is - deigrms = sqrt(deigrms/nbsp) -#ifdef __DEBUG - if(ionode) write(1031,'(2I10,3F24.13)') ninner, nouter,etot,ene0,deigrms -#endif - if(ionode) write(stdout,'(10x,2i5,3F21.13)') ninner, nouter, etot, ene0, deigrms - ! - ! - dmaxeig = max( abs(Heigbig(iupdwn(1))), abs(Heigbig(iupdwn(1)+nupdwn(1)-1)) ) - ! - do isp = 2, nspin - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)))) - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)+nupdwn(isp)-1))) - enddo - ! - passomax=passoprod/dmaxeig - ! - if( ninner == 1 ) then - passof = passomax -#ifdef __DEBUG - if(ionode) write(1031,*) '# passof set to passomax' -#endif - endif - -!$$$$ if(passof .gt. passomax*2.d0) then -!$$$$ passof = passomax*2.d0 -!$$$$ if(ionode) write(1031,*) '# passof > twice passomax' -!$$$$ endif - -! if(ionode) then -! write(1037,*)'# deigrms = ',deigrms -! write(1037,*)'# vsicah2sum = ',vsicah2sum -! if(ninner.ne.1) write(1037,*)'# vsicah2sum/vsicah2sum_prev = ',dtmp -! endif - - - vsicah2sum_prev = vsicah2sum - ! - dene0 = 0.d0 - ! - do isp = 1, nspin - ! - do nbnd1 = 1, nupdwn(isp) - do nbnd2 = 1, nupdwn(isp) - ! - nidx1 = nbnd1-1+iupdwn(isp) - nidx2 = nbnd2-1+iupdwn(isp) - IF(nidx1.eq.nidx2) THEN - dene0 = dene0 -DBLE(CONJG(gi(nidx1,nidx2))*hi(nidx1,nidx2)) - ELSE - dene0 = dene0 -0.5d0*DBLE(CONJG(gi(nidx1,nidx2))*hi(nidx1,nidx2)) - ENDIF - ! - enddo - enddo - ! - enddo - - !$$ - !$$ dene0 = dene0 * 2.d0/nspin - ! - ! Be careful, the following is correct because A_ji = - A_ij, i.e., the number of - ! linearly independent variables is half the number of total variables! - ! - dene0 = dene0 * 2.d0/nspin - ! - spasso = 1.d0 - if( dene0 > 0.d0) spasso = -1.d0 - ! - dalpha = spasso*passof - ! - call nksic_getOmattot( dalpha, Heigbig, Umatbig, c0, wfc_ctmp, & - Omat1tot, bec1, vsic1, pink1, ene1, lgam) - call minparabola( ene0, spasso*dene0, ene1, passof, passo, enesti) - - ! - ! We neglect this step for paper writing purposes - ! - if( passo > passomax ) then - passo = passomax -#ifdef __DEBUG - if(ionode) write(1031,*) '# passo > passomax' -#endif - ! - endif - - passov = passof - passof = 2.d0*passo - - dalpha = spasso*passo - ! -!$$ The following line is for dene0 test -! if(ninner.ge.15) dalpha = spasso*passo*0.00001 -!$$ - call nksic_getOmattot( dalpha, Heigbig, Umatbig, c0, wfc_ctmp2, & - Omat2tot, bec2, vsic2, pink2, enever, lgam) - -#ifdef __DEBUG - if(ionode) then - ! - write(1037,*) ninner, nouter - write(1037,'("ene0,ene1,enesti,enever")') - write(1037,'(a3,4f20.10)') 'CG1',ene0,ene1,enesti,enever - write(1037,'("spasso,passov,passo,passomax,dene0,& - & (enever-ene0)/passo/dene0")') - write(1037,'(a3,4f12.7,e20.10,f12.7)') & - 'CG2',spasso,passov,passo,passomax,dene0,(enever-ene0)/passo/dene0 - write(1037,*) - ! - endif -#endif - - if(ene0 < ene1 .and. ene0 < enever) then - ! -#ifdef __DEBUG - if(ionode) then - write(1037,'("# ene0= enever ) then - ! - pink(:) = pink2(:) - vsic(:,:) = vsic2(:,:) - c0(:,:) = wfc_ctmp2(:,:) - call copy_twin(bec,bec2) -! bec%rvec(:,:) = bec2(:,:) - Omattot = MATMUL( Omattot, Omat2tot) - ! - else - ! - pink(:) = pink1(:) - vsic(:,:) = vsic1(:,:) - c0(:,:) = wfc_ctmp(:,:) - call copy_twin(bec,bec1) - Omattot = MATMUL( Omattot, Omat1tot) - ! -#ifdef __DEBUG - if(ionode) then - write(1037,'("# It happened that ene1 < enever!!")') - write(1037,*) - endif -#endif - ! -! ======= -! pink(:) = pink1(:) -! vsic(:,:) = vsic1(:,:) -! c0(:,:) = wfn_ctmp(:,:) -! bec%rvec(:,:) = bec1(:,:) -! Omattot = MATMUL(Omattot,Omat1tot) -! if(ionode) then -! write(1037,'("# It happened that ene1 < enever!!")') -! write(1037,*) -! endif -! 1.28.2.14 - endif - ! - call stop_clock( "nk_innerloop" ) - ! - enddo inner_loop - - ! - ! Wavefunction cm rotation according to Omattot - ! We need this because outer loop could be damped dynamics. - ! - if ( .not. tcg ) then - ! - if( ninner >= 2 ) then - ! - wfc_ctmp(:,:) = (0.d0,0.d0) - ! - do nbnd1=1,nbspx - do nbnd2=1,nbspx - wfc_ctmp(:,nbnd1)=wfc_ctmp(:,nbnd1) + cm(:,nbnd2) * Omattot(nbnd2,nbnd1) !warning:giovanni CONJUGATE? - ! XXX (we can think to use a blas, here, and split over spins) - enddo - enddo - ! - cm(:,1:nbspx) = wfc_ctmp(:,1:nbspx) - ! - endif - ! - endif - - ! - ! clean local workspace - ! - deallocate( Omat1tot, Omat2tot ) - deallocate( Umatbig ) - deallocate( Heigbig ) - deallocate( wfc_ctmp, wfc_ctmp2 ) - deallocate( hi ) - deallocate( gi ) - deallocate( pink1, pink2 ) - deallocate( vsic1, vsic2 ) - call deallocate_twin(bec1) - call deallocate_twin(bec2) -! deallocate( bec1, bec2 ) - - - CALL stop_clock( 'nk_rot_emin' ) - return - ! -!--------------------------------------------------------------- -end subroutine nksic_rot_emin_cg_descla -!--------------------------------------------------------------- - -!--------------------------------------------------------------- - subroutine nksic_getOmattot_new(nbsp,nbspx,nudx,nspin,ispin, & - iupdwn,nupdwn,wfc_centers,wfc_spreads, & - dalpha,Heigbig,Umatbig,wfc0, & - wfc1,Omat1tot,bec1,vsic1,pink1,ene1,lgam, is_empty)!warning:giovanni bec1 here needs to be a twin! -!--------------------------------------------------------------- -! -! ... This routine rotates the wavefunction wfc0 into wfc1 according to -! the force matrix (Heigbig, Umatbig) and the step of size dalpha. -! Other quantities such as bec, vsic, pink are also calculated for wfc1. - - use kinds, only : dp - use grid_dimensions, only : nnrx - use gvecw, only : ngw - use ions_base, only : nsp - use uspp, only : becsum - use cp_main_variables, only : eigr, rhor - use nksic, only : deeq_sic, wtot, fsic, sizwtot - use control_flags, only : gamma_only, do_wf_cmplx - use twin_types - use electrons_module, only : icompute_spread - use core, only : rhoc - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: nbsp, nbspx, nudx, nspin - integer, intent(in) :: ispin(nbspx), nupdwn(nspin), & - iupdwn(nspin) - real(dp), intent(in) :: dalpha - complex(dp), intent(in) :: Umatbig(nbspx,nbspx) - real(dp), intent(in) :: Heigbig(nbspx), wfc_centers(4,nudx,nspin),& - wfc_spreads(nudx,nspin,2) - complex(dp), intent(in) :: wfc0(ngw,nbspx) - ! - complex(dp) :: wfc1(ngw,nbspx) - complex(dp) :: Omat1tot(nbspx,nbspx) - type(twin_matrix) :: bec1 !(nkb,nbsp) !modified:giovanni - real(dp) :: vsic1(nnrx,nbspx) - real(dp) :: pink1(nbspx) - real(dp) :: ene1 - logical :: lgam, is_empty - - ! - ! local variables for cg routine - ! - integer :: isp, nbnd1 - real(dp) :: dmaxeig - complex(dp), allocatable :: Omat1(:,:) - complex(dp), allocatable :: Umat(:,:) - real(dp), allocatable :: Heig(:) - - ! - call start_clock( "nk_getOmattot" ) - ! - -! call init_twin(bec1,lgam) -! call allocate_twin(bec1,nkb,nbsp, lgam) - - Omat1tot(:,:) = 0.d0 - do nbnd1=1,nbspx - Omat1tot(nbnd1,nbnd1)=1.d0 - enddo - - wfc1(:,:) = CMPLX(0.d0,0.d0) - - dmaxeig = max( abs(Heigbig(iupdwn(1))), abs(Heigbig(iupdwn(1)+nupdwn(1)-1)) ) - do isp=2,nspin - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)))) - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)+nupdwn(isp)-1))) - enddo - - spin_loop: & - do isp=1,nspin - ! - IF(nupdwn(isp).gt.0) THEN - ! - allocate(Umat(nupdwn(isp),nupdwn(isp))) - allocate(Heig(nupdwn(isp))) - allocate(Omat1(nupdwn(isp),nupdwn(isp))) - - Umat(:,:) = Umatbig(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp),iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) - Heig(:) = Heigbig(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) - - call nksic_getOmat1(isp,Heig,Umat,dalpha,Omat1, lgam) - -!$$ Wavefunction wfc0 is rotated into wfc0 using Omat1 - call nksic_rotwfn(isp,Omat1,wfc0,wfc1) - -! Assigning the rotation matrix for a specific spin isp - Omat1tot(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp),iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = Omat1(:,:) - - deallocate(Umat) - deallocate(Heig) - deallocate(Omat1) - ! - ELSE - Omat1tot(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp),iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = 1.d0 - ENDIF - ! - enddo spin_loop - - ! - ! recalculate bec & vsic according to the new wavefunction - ! - call calbec(1,nsp,eigr,wfc1,bec1) - - vsic1(:,:) = 0.d0 - pink1(:) = 0.d0 - ! - call nksic_potential( nbsp, nbspx, wfc1, fsic, bec1, becsum, deeq_sic, & - ispin, iupdwn, nupdwn, rhor, rhoc, wtot, sizwtot, vsic1, pink1, nudx, wfc_centers, & - wfc_spreads, icompute_spread, is_empty ) - ! - ene1=sum(pink1(:)) - -! call deallocate_twin(bec1) - - ! - call stop_clock( "nk_getOmattot" ) - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getOmattot_new -!--------------------------------------------------------------- - -!--------------------------------------------------------------- - subroutine nksic_getOmattot(dalpha,Heigbig,Umatbig,wfc0,wfc1,Omat1tot,bec1,vsic1,pink1,ene1, lgam)!warning:giovanni bec1 here needs to be a twin! -!--------------------------------------------------------------- -! -! ... This routine rotates the wavefunction wfc0 into wfc1 according to -! the force matrix (Heigbig, Umatbig) and the step of size dalpha. -! Other quantities such as bec, vsic, pink are also calculated for wfc1. -! - - use kinds, only : dp - use grid_dimensions, only : nnrx - use gvecw, only : ngw - use electrons_base, only : nbsp, nbspx, nspin, ispin, & - iupdwn, nupdwn, nudx - use ions_base, only : nsp - use uspp, only : becsum - use cp_main_variables, only : eigr, rhor - use nksic, only : deeq_sic, wtot, fsic, sizwtot, do_wxd, & - valpsi, odd_alpha - use control_flags, only : gamma_only, do_wf_cmplx - use twin_types - use electrons_module, only : wfc_centers, wfc_spreads, & - icompute_spread - use core, only : rhoc - use input_parameters, only : odd_nkscalfact - ! - implicit none - ! - ! in/out vars - ! - real(dp), intent(in) :: dalpha - complex(dp), intent(in) :: Umatbig(nbspx,nbspx) - real(dp), intent(in) :: Heigbig(nbspx) - complex(dp), intent(in) :: wfc0(ngw,nbspx) - ! - complex(dp) :: wfc1(ngw,nbspx) - complex(dp) :: Omat1tot(nbspx,nbspx) - type(twin_matrix) :: bec1 !(nkb,nbsp) !modified:giovanni - real(dp) :: vsic1(nnrx,nbspx) - real(dp) :: pink1(nbspx) - real(dp) :: ene1 - logical :: lgam - - ! - ! local variables for cg routine - ! - integer :: isp, nbnd1 - real(dp) :: dmaxeig - complex(dp), allocatable :: Omat1(:,:) - complex(dp), allocatable :: Umat(:,:) - real(dp), allocatable :: Heig(:) - - ! - call start_clock( "nk_getOmattot" ) - ! - -! call init_twin(bec1,lgam) -! call allocate_twin(bec1,nkb,nbsp, lgam) - - Omat1tot(:,:) = 0.d0 - do nbnd1=1,nbspx - Omat1tot(nbnd1,nbnd1)=1.d0 - enddo - - wfc1(:,:) = CMPLX(0.d0,0.d0) - - dmaxeig = max( abs(Heigbig(iupdwn(1))), abs(Heigbig(iupdwn(1)+nupdwn(1)-1)) ) - do isp=2,nspin - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)))) - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)+nupdwn(isp)-1))) - enddo - - spin_loop: & - do isp=1,nspin - ! - IF(nupdwn(isp).gt.0) THEN - ! - allocate(Umat(nupdwn(isp),nupdwn(isp))) - allocate(Heig(nupdwn(isp))) - allocate(Omat1(nupdwn(isp),nupdwn(isp))) - - Umat(:,:) = Umatbig(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp),iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) - Heig(:) = Heigbig(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) - - call nksic_getOmat1(isp,Heig,Umat,dalpha,Omat1, lgam) - -!$$ Wavefunction wfc0 is rotated into wfc0 using Omat1 - call nksic_rotwfn(isp,Omat1,wfc0,wfc1) - -! Assigning the rotation matrix for a specific spin isp - Omat1tot(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp),iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = Omat1(:,:) - - deallocate(Umat) - deallocate(Heig) - deallocate(Omat1) - ! - ELSE - Omat1tot(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp),iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = 1.d0 - ENDIF - ! - enddo spin_loop - ! - ! recalculate bec & vsic according to the new wavefunction - ! - call calbec(1,nsp,eigr,wfc1,bec1) - ! - if (odd_nkscalfact) then - ! - valpsi(:,:) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - call odd_alpha_routine(nbspx, .false.) - ! - endif - ! - vsic1(:,:) = 0.d0 - pink1(:) = 0.d0 - ! - ! - call nksic_potential( nbsp, nbspx, wfc1, fsic, bec1, becsum, deeq_sic, & - ispin, iupdwn, nupdwn, rhor, rhoc, wtot, sizwtot, vsic1, do_wxd, pink1, nudx, wfc_centers, & - wfc_spreads, icompute_spread, .false. ) - ! - ene1=sum(pink1(:)) - -! call deallocate_twin(bec1) - - ! - call stop_clock( "nk_getOmattot" ) - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getOmattot -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_rotwfn(isp,Omat1,wfc1,wfc2) -!----------------------------------------------------------------------- -! -! ... Simple rotation of wfc1 into wfc2 by Omat1. -! wfc2(n) = sum_m wfc1(m) Omat1(m,n) -! - use electrons_base, only : iupdwn,nupdwn,nbspx - use gvecw, only : ngw - use kinds, only : dp - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp - complex(dp), intent(in) :: Omat1(nupdwn(isp),nupdwn(isp)) - complex(dp), intent(in) :: wfc1(ngw,nbspx) - complex(dp) :: wfc2(ngw,nbspx) - - ! - ! local variables for cg routine - ! - integer :: nbnd1,nbnd2 - - CALL start_clock('nk_rotwfn') - ! - wfc2(:,iupdwn(isp):iupdwn(isp)-1+nupdwn(isp))=CMPLX(0.d0,0.d0) - - ! - ! a blas could be used here XXX - ! - do nbnd1=1,nupdwn(isp) - do nbnd2=1,nupdwn(isp) - ! - wfc2(:,iupdwn(isp)-1 + nbnd1)=wfc2(:,iupdwn(isp)-1 + nbnd1) & - + wfc1(:,iupdwn(isp)-1 + nbnd2) * Omat1(nbnd2,nbnd1) - ! - enddo - enddo - - CALL stop_clock('nk_rotwfn') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_rotwfn -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_getHeigU_new(nspin, isp, nupdwn, vsicah, Heig, Umat) -!----------------------------------------------------------------------- -! -! ... solves the eigenvalues (Heig) and eigenvectors (Umat) of the force -! matrix vsicah. -! (Ultrasoft pseudopotential case is not implemented.) -! - use kinds, only : dp - use mp, only : mp_bcast - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp, nspin, nupdwn(nspin) - real(dp) :: Heig(nupdwn(isp)) - complex(dp) :: Umat(nupdwn(isp),nupdwn(isp)) - complex(dp) :: vsicah(nupdwn(isp),nupdwn(isp)) - - - ! - ! local variables - ! - complex(dp) :: Hmat(nupdwn(isp),nupdwn(isp)) - complex(dp) :: ci - - ci = CMPLX(0.d0,1.d0) - -!$$ Now this part diagonalizes Hmat = iWmat - Hmat(:,:) = ci * vsicah(:,:) -!$$ diagonalize Hmat -! if(ionode) then - CALL zdiag(nupdwn(isp),nupdwn(isp),Hmat(1,1),Heig(1),Umat(1,1),1) -! endif - -! CALL mp_bcast(Umat, ionode_id, intra_image_comm) -! CALL mp_bcast(Heig, ionode_id, intra_image_comm) - - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getHeigU_new -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_getHeigU(isp,vsicah,Heig,Umat) -!----------------------------------------------------------------------- -! -! ... solves the eigenvalues (Heig) and eigenvectors (Umat) of the force -! matrix vsicah. -! (Ultrasoft pseudopotential case is not implemented.) -! - use kinds, only : dp - use mp, only : mp_bcast - use electrons_base, only : nupdwn - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp - real(dp) :: Heig(nupdwn(isp)) - complex(dp) :: Umat(nupdwn(isp),nupdwn(isp)) - complex(dp) :: vsicah(nupdwn(isp),nupdwn(isp)) - - - ! - ! local variables - ! - complex(dp) :: Hmat(nupdwn(isp),nupdwn(isp)) - complex(dp) :: ci - - ci = CMPLX(0.d0,1.d0) - -!$$ Now this part diagonalizes Hmat = iWmat - Hmat(:,:) = ci * vsicah(:,:) -!$$ diagonalize Hmat -! if(ionode) then - CALL zdiag(nupdwn(isp),nupdwn(isp),Hmat(1,1),Heig(1),Umat(1,1),1) -! endif - -! CALL mp_bcast(Umat, ionode_id, intra_image_comm) -! CALL mp_bcast(Heig, ionode_id, intra_image_comm) - - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getHeigU -!--------------------------------------------------------------- - - -!----------------------------------------------------------------------- - subroutine nksic_printoverlap(ninner,nouter) -!----------------------------------------------------------------------- -! -! ... Calculates the anti-hermitian part of the SIC hamiltonian, vsicah. -! - use kinds, only : dp - use grid_dimensions, only : nr1x, nr2x, nr3x, nnrx - use gvecw, only : ngw - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use io_global, only : ionode - use electrons_base, only : nbspx - use cp_interfaces, only : invfft - use fft_base, only : dfftp - use nksic, only : vsic - use wavefunctions_module, only : c0 - ! - implicit none - ! - ! in/out vars - ! - integer :: ninner, nouter - real(dp) :: overlap(nbspx,nbspx),vsicah(nbspx,nbspx) - - ! - ! local variables - ! - complex(dp) :: psi1(nnrx), psi2(nnrx) - real(dp) :: overlaptmp,vsicahtmp - integer :: i,nbnd1,nbnd2 - real(dp) :: dwfnnorm - - dwfnnorm = 1.0/(DBLE(nr1x)*DBLE(nr2x)*DBLE(nr3x)) - - vsicah(:,:) = 0.d0 - overlap(:,:) = 0.d0 - - do nbnd1=1,nbspx - CALL c2psi( psi1, nnrx, c0(:,nbnd1), (0.d0,0.d0), ngw, 1) - CALL invfft('Dense', psi1, dfftp ) - - do nbnd2=1,nbspx - if(nbnd2.lt.nbnd1) then - vsicahtmp = -vsicah(nbnd2,nbnd1) - overlaptmp = overlap(nbnd2,nbnd1) - else - CALL c2psi( psi2, nnrx, c0(:,nbnd2), (0.d0,0.d0), ngw, 1) - CALL invfft('Dense', psi2, dfftp ) - - vsicahtmp = 0.d0 - overlaptmp = 0.d0 - - do i=1,nnrx -!$$ Imposing Pederson condition - vsicahtmp = vsicahtmp & - + 2.d0 * DBLE( CONJG(psi1(i)) * (vsic(i,nbnd2) & - - vsic(i,nbnd1) ) * psi2(i) ) * dwfnnorm -!$$ The following two lines give exactly the same results: checked - overlaptmp = overlaptmp + DBLE( CONJG(psi1(i)) * psi2(i) ) * dwfnnorm -! overlaptmp = overlaptmp + dble(psi1(i)) * dble(psi2(i)) * dwfnnorm - enddo - - CALL mp_sum(vsicahtmp,intra_image_comm) - CALL mp_sum(overlaptmp,intra_image_comm) - endif ! if(nbnd2.lt.nbnd1) - - vsicah(nbnd1,nbnd2) = vsicahtmp - overlap(nbnd1,nbnd2) = overlaptmp - - enddo ! nbnd2=1,nbspx - - enddo ! nbspx - - if(ionode) then - write(1021,*) ninner,nouter - write(1022,*) ninner,nouter - do nbnd1=1,nbspx - write(1021,'(100F12.7)') (overlap(nbnd1,nbnd2),nbnd2=1,nbspx) - write(1022,'(100F12.7)') (vsicah(nbnd1,nbnd2),nbnd2=1,nbspx) - enddo - write(1021,*) - write(1022,*) - endif - - return - ! -!--------------------------------------------------------------- -end subroutine nksic_printoverlap -!--------------------------------------------------------------- - - -!----------------------------------------------------------------------- - subroutine nksic_getvsicah( isp, vsicah, vsicah2sum) -!----------------------------------------------------------------------- -! -! ... Calculates the anti-hermitian part of the SIC hamiltonian, vsicah. -! - use kinds, only : dp - use grid_dimensions, only : nr1x, nr2x, nr3x, nnrx - use gvecw, only : ngw - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use electrons_base, only : nspin, iupdwn,nupdwn - use cp_interfaces, only : invfft - use fft_base, only : dfftp - use nksic, only : vsic,fsic - use wavefunctions_module, only : c0 - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp - real(dp) :: vsicah( nupdwn(isp),nupdwn(isp)) - real(dp) :: vsicah2sum - - ! - ! local variables - ! - complex(dp) :: psi1(nnrx), psi2(nnrx) - real(dp) :: vsicahtmp, cost - real(dp) :: dwfnnorm - integer :: nbnd1,nbnd2 - integer :: i, j1, j2 - - - CALL start_clock('nk_get_vsicah') - ! - dwfnnorm = 1.0d0/(DBLE(nr1x)*DBLE(nr2x)*DBLE(nr3x)) - cost = 2.0d0 * DBLE( nspin ) * 0.5d0 * dwfnnorm - ! - vsicah(:,:) = 0.d0 - vsicah2sum = 0.d0 - - ! - ! Imposing Pederson condition - ! - do nbnd1=1,nupdwn(isp) - ! - j1 = iupdwn(isp)-1 + nbnd1 - ! - CALL c2psi( psi1, nnrx, c0(:,j1), (0.d0,0.d0), ngw, 1) - CALL invfft('Dense', psi1, dfftp ) - - do nbnd2 = 1, nbnd1-1 - ! - j2 = iupdwn(isp)-1 + nbnd2 - ! - CALL c2psi( psi2, nnrx, c0(:,j2), (0.0d0,0.0d0), ngw, 1 ) - CALL invfft('Dense', psi2, dfftp ) - ! - vsicahtmp = 0.d0 - ! - do i=1,nnrx - ! - vsicahtmp = vsicahtmp + & - DBLE( CONJG(psi1(i)) * psi2(i) & - * ( vsic(i, j2 ) * fsic( j2 ) & - - vsic(i, j1 ) * fsic( j1 ) ) ) - ! - enddo - vsicahtmp = vsicahtmp * cost - ! - vsicah(nbnd1,nbnd2) = vsicahtmp - vsicah(nbnd2,nbnd1) = -vsicahtmp - ! - enddo - ! - enddo - ! - call mp_sum( vsicah, intra_image_comm) - ! - vsicah2sum = 0.0d0 - do nbnd1 = 1, nupdwn(isp) - do nbnd2 = 1, nbnd1-1 - vsicah2sum = vsicah2sum + 2.0d0*vsicah(nbnd2,nbnd1)*vsicah(nbnd2,nbnd1) - enddo - enddo - ! - call stop_clock('nk_get_vsicah') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getvsicah -!--------------------------------------------------------------- - - -!----------------------------------------------------------------------- - subroutine nksic_getvsicah_new1( isp, vsicah, vsicah2sum) -!----------------------------------------------------------------------- -! -! ... Calculates the anti-hermitian part of the SIC hamiltonian, vsicah. -! Exploit fft of wfc pairs. -! - use kinds, only : dp - use grid_dimensions, only : nr1x, nr2x, nr3x, nnrx - use gvecw, only : ngw - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use electrons_base, only : nspin, iupdwn,nupdwn - use cp_interfaces, only : invfft - use fft_base, only : dfftp - use nksic, only : vsic,fsic - use wavefunctions_module, only : c0 - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp - real(dp) :: vsicah( nupdwn(isp),nupdwn(isp)) - real(dp) :: vsicah2sum - - ! - ! local variables - ! - real(dp) :: vsicahtmp, cost - real(dp) :: dwfnnorm - integer :: nbnd1,nbnd2 - integer :: i, j1, jj1, j2, jj2 - ! - complex(dp), allocatable :: psi1(:), psi2(:) - real(dp), allocatable :: wfc1(:,:), wfc2(:,:) - - - CALL start_clock('nk_get_vsicah') - ! - dwfnnorm = 1.0d0/(DBLE(nr1x)*DBLE(nr2x)*DBLE(nr3x)) - cost = 2.0d0 * DBLE( nspin ) * 0.5d0 * dwfnnorm - ! - allocate( wfc1(nnrx, 2) ) - allocate( wfc2(nnrx, 2) ) - allocate( psi1(nnrx) ) - allocate( psi2(nnrx) ) - - ! - ! Imposing Pederson condition - ! - vsicah(:,:) = 0.d0 - ! - do nbnd1=1,nupdwn(isp),2 - ! - j1 = iupdwn(isp)-1 + nbnd1 - ! - CALL c2psi( psi1, nnrx, c0(:,j1), c0(:,j1+1), ngw, 2) - CALL invfft('Dense', psi1, dfftp ) - ! - wfc1(:,1) = DBLE ( psi1(:) ) - wfc1(:,2) = AIMAG ( psi1(:) ) - ! - do jj1 = 1, 2 - ! - if ( nbnd1+jj1-1 > nupdwn(isp) ) cycle - ! - ! - do nbnd2 = 1, nbnd1-1+jj1-1, 2 - ! - j2 = iupdwn(isp)-1 + nbnd2 - ! - CALL c2psi( psi2, nnrx, c0(:,j2), c0(:,j2+1), ngw, 2 ) - CALL invfft('Dense', psi2, dfftp ) - ! - wfc2(:,1) = DBLE ( psi2(:) ) - wfc2(:,2) = AIMAG ( psi2(:) ) - ! - do jj2 = 1, 2 - ! - if ( nbnd2+jj2-1 > nbnd1-1+jj1-1 ) cycle - ! - vsicahtmp = 0.d0 - ! - do i=1,nnrx - ! - vsicahtmp = vsicahtmp + & - cost * DBLE( wfc1(i,jj1) * wfc2(i,jj2) & - * ( vsic(i, j2+jj2-1 ) * fsic( j2+jj2-1 ) & - - vsic(i, j1+jj1-1 ) * fsic( j1+jj1-1 ) ) ) - ! - enddo - ! - vsicah(nbnd1+jj1-1,nbnd2+jj2-1) = vsicahtmp - vsicah(nbnd2+jj2-1,nbnd1+jj1-1) = -vsicahtmp - ! - enddo - enddo - ! - enddo - enddo - ! - call mp_sum( vsicah, intra_image_comm) - ! - vsicah2sum = 0.0d0 - ! - do nbnd1 = 1, nupdwn(isp) - do nbnd2 = 1, nbnd1-1 - vsicah2sum = vsicah2sum + 2.0d0*vsicah(nbnd2,nbnd1)*vsicah(nbnd2,nbnd1) - enddo - enddo - ! - ! - deallocate( wfc1, wfc2 ) - deallocate( psi1, psi2 ) - ! - call stop_clock('nk_get_vsicah') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getvsicah_new1 -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_getvsicah_new3(ngw, nbsp, nbspx, nspin, c0, bec, & - isp, nupdwn, iupdwn, vsicah, vsicah2sum, lgam) -!----------------------------------------------------------------------- -! -! ... Calculates the anti-hermitian part of the SIC hamiltonian, vsicah. -! makes use of nksic_eforce to compute h_i | phi_i > -! and then computes < phi_j | h_i | phi_i > in reciprocal space. -! - use kinds, only : dp - use reciprocal_vectors, only : gstart - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use cp_interfaces, only : invfft - use nksic, only : vsic, vsicpsi, & - deeq_sic ! to be passed directly - use twin_types - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp, nspin, ngw, nbsp, nbspx, & - nupdwn(nspin), iupdwn(nspin) - complex(dp) :: vsicah( nupdwn(isp),nupdwn(isp)), c0(ngw, nbsp) - real(dp) :: vsicah2sum - logical :: lgam - type(twin_matrix) :: bec - - ! - ! local variables - ! - real(dp) :: cost - integer :: nbnd1,nbnd2 - integer :: j1, jj1, j2 - ! - !complex(dp), allocatable :: vsicpsi(:,:) - complex(dp), allocatable :: hmat(:,:) - - - CALL start_clock('nk_get_vsicah') - ! - cost = DBLE( nspin ) * 2.0d0 - ! - !allocate( vsicpsi(npw,2) ) - allocate( hmat(nupdwn(isp),nupdwn(isp)) ) - - ! - ! compute < phi_j | Delta h_i | phi_i > - ! - do nbnd1 = 1, nupdwn(isp), 2 - ! - ! NOTE: USPP not implemented - ! - j1 = nbnd1+iupdwn(isp)-1 - CALL nksic_eforce( j1, nbsp, nbspx, vsic, & - deeq_sic, bec, ngw, c0(:,j1), c0(:,j1+1), vsicpsi, lgam ) - ! - do jj1 = 1, 2 - ! - if ( nbnd1+jj1-1 > nupdwn(isp) ) cycle - ! - do nbnd2 = 1, nupdwn(isp) - ! - j2 = nbnd2+iupdwn(isp)-1 - IF(lgam) THEN - hmat(nbnd2,nbnd1+jj1-1) = 2.d0*DBLE(DOT_PRODUCT( c0(:,j2), vsicpsi(:,jj1))) - ! - if ( gstart == 2 ) then - hmat(nbnd2,nbnd1+jj1-1) = hmat(nbnd2,nbnd1+jj1-1) - & - DBLE( c0(1,j2) * vsicpsi(1,jj1) ) - endif - ELSE - hmat(nbnd2,nbnd1+jj1-1) = DOT_PRODUCT( c0(:,j2), vsicpsi(:,jj1)) - ENDIF - ! - enddo - ! - enddo - enddo - ! - call mp_sum( hmat, intra_image_comm ) - hmat = hmat * cost - - - ! - ! Imposing Pederson condition - ! - vsicah(:,:) = 0.d0 - vsicah2sum = 0.0d0 - ! - do nbnd1 = 1, nupdwn(isp) - do nbnd2 = 1, nbnd1-1 - ! - IF(lgam) THEN - vsicah( nbnd2, nbnd1) = DBLE(hmat(nbnd2,nbnd1) -CONJG(hmat(nbnd1,nbnd2))) - vsicah( nbnd1, nbnd2) = DBLE(hmat(nbnd1,nbnd2) -CONJG(hmat(nbnd2,nbnd1))) - ELSE - vsicah( nbnd2, nbnd1) = hmat(nbnd2,nbnd1) -CONJG(hmat(nbnd1,nbnd2)) - vsicah( nbnd1, nbnd2) = hmat(nbnd1,nbnd2) -CONJG(hmat(nbnd2,nbnd1)) - ENDIF - vsicah2sum = vsicah2sum + DBLE(CONJG(vsicah(nbnd2,nbnd1))*vsicah(nbnd2,nbnd1)) - ! - enddo - !IF(.not.lgam) THEN - ! vsicah( nbnd1, nbnd1) = hmat(nbnd1,nbnd1) -CONJG(hmat(nbnd1,nbnd1)) - ! vsicah2sum = vsicah2sum + 2.d0*DBLE(CONJG(vsicah(nbnd1,nbnd1))*vsicah(nbnd1,nbnd1)) - !ENDIF - enddo - ! - deallocate( hmat ) - ! - call stop_clock('nk_get_vsicah') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getvsicah_new3 -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_getvsicah_new2( isp, vsicah, vsicah2sum, lgam) -!----------------------------------------------------------------------- -! -! ... Calculates the anti-hermitian part of the SIC hamiltonian, vsicah. -! makes use of nksic_eforce to compute h_i | phi_i > -! and then computes < phi_j | h_i | phi_i > in reciprocal space. -! - use kinds, only : dp - use gvecw, only : ngw - use reciprocal_vectors, only : gstart - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use electrons_base, only : nspin, iupdwn, nupdwn, nbsp,nbspx - use cp_interfaces, only : invfft - use nksic, only : vsic, vsicpsi, & - valpsi, deeq_sic ! to be passed directly - use wavefunctions_module, only : c0 - use cp_main_variables, only : bec ! to be passed directly - use input_parameters, only : odd_nkscalfact - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp - complex(dp) :: vsicah( nupdwn(isp),nupdwn(isp)) - real(dp) :: vsicah2sum - logical :: lgam - - ! - ! local variables - ! - real(dp) :: cost - integer :: nbnd1,nbnd2 - integer :: j1, jj1, j2 - ! - !complex(dp), allocatable :: vsicpsi(:,:) - complex(dp), allocatable :: hmat(:,:) - - - CALL start_clock('nk_get_vsicah') - ! - cost = DBLE( nspin ) * 2.0d0 - ! - !allocate( vsicpsi(npw,2) ) - allocate( hmat(nupdwn(isp),nupdwn(isp)) ) - - ! - ! compute < phi_j | Delta h_i | phi_i > - ! - do nbnd1 = 1, nupdwn(isp), 2 - ! - ! NOTE: USPP not implemented - ! - j1 = nbnd1+iupdwn(isp)-1 - CALL nksic_eforce( j1, nbsp, nbspx, vsic, & - deeq_sic, bec, ngw, c0(:,j1), c0(:,j1+1), vsicpsi, lgam ) - ! - do jj1 = 1, 2 - ! - if ( nbnd1+jj1-1 > nupdwn(isp) ) cycle - ! - do nbnd2 = 1, nupdwn(isp) - ! - j2 = nbnd2+iupdwn(isp)-1 - ! - IF (odd_nkscalfact) THEN - ! - vsicpsi(:,jj1) = vsicpsi(:,jj1) + valpsi(nbnd1+jj1-1,:) - ! - ENDIF - ! - IF(lgam) THEN - hmat(nbnd2,nbnd1+jj1-1) = 2.d0*DBLE(DOT_PRODUCT( c0(:,j2), vsicpsi(:,jj1))) - ! - if ( gstart == 2 ) then - hmat(nbnd2,nbnd1+jj1-1) = hmat(nbnd2,nbnd1+jj1-1) - & - DBLE( c0(1,j2) * vsicpsi(1,jj1) ) - endif - ELSE - hmat(nbnd2,nbnd1+jj1-1) = DOT_PRODUCT( c0(:,j2), vsicpsi(:,jj1)) - ENDIF - ! - enddo - ! - enddo - enddo - ! - call mp_sum( hmat, intra_image_comm ) - hmat = hmat * cost - - - ! - ! Imposing Pederson condition - ! - vsicah(:,:) = 0.d0 - vsicah2sum = 0.0d0 - ! - do nbnd1 = 1, nupdwn(isp) - do nbnd2 = 1, nbnd1-1 - ! - IF(lgam) THEN - vsicah( nbnd2, nbnd1) = DBLE(hmat(nbnd2,nbnd1) -CONJG(hmat(nbnd1,nbnd2))) - vsicah( nbnd1, nbnd2) = DBLE(hmat(nbnd1,nbnd2) -CONJG(hmat(nbnd2,nbnd1))) - ELSE - vsicah( nbnd2, nbnd1) = hmat(nbnd2,nbnd1) -CONJG(hmat(nbnd1,nbnd2)) - vsicah( nbnd1, nbnd2) = hmat(nbnd1,nbnd2) -CONJG(hmat(nbnd2,nbnd1)) - ENDIF - vsicah2sum = vsicah2sum + DBLE(CONJG(vsicah(nbnd2,nbnd1))*vsicah(nbnd2,nbnd1)) - ! - enddo - !IF(.not.lgam) THEN - ! vsicah( nbnd1, nbnd1) = hmat(nbnd1,nbnd1) -CONJG(hmat(nbnd1,nbnd1)) - ! vsicah2sum = vsicah2sum + 2.d0*DBLE(CONJG(vsicah(nbnd1,nbnd1))*vsicah(nbnd1,nbnd1)) - !ENDIF - enddo - ! - deallocate( hmat ) - ! - call stop_clock('nk_get_vsicah') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getvsicah_new2 -!--------------------------------------------------------------- - -! !----------------------------------------------------------------------- -! subroutine nksic_getvsicah_twin( vsicah, vsicah2sum, nlam, descla, lgam) -! !----------------------------------------------------------------------- -! ! warning:giovanni IMPLEMENT without spin, call spin-by-spin initialize vsicah outside -! !IT IS JUST LIKE LAMBDA MATRIX, NEED NO FURTHER DESCLA INITIALIZATION!!.. DO AS -! ! IN ORTHO_GAMMA... PASS DESCLA MATRIX -! ! ... Calculates the anti-hermitian part of the SIC hamiltonian, vsicah. -! ! makes use of nksic_eforce to compute h_i | phi_i > -! ! and then computes < phi_j | h_i | phi_i > in reciprocal space. -! ! -! use kinds, only : dp -! use grid_dimensions, only : nr1x, nr2x, nr3x, nnrx -! use gvecw, only : ngw -! use reciprocal_vectors, only : gstart -! USE mp, ONLY: mp_sum,mp_bcast, mp_root_sum -! use mp_global, only : intra_image_comm, leg_ortho -! use electrons_base, only : nspin, iupdwn, nupdwn, nbsp,nbspx -! use cp_interfaces, only : invfft -! use fft_base, only : dfftp -! use nksic, only : vsic, fsic, vsicpsi, & -! deeq_sic ! to be passed directly -! use wavefunctions_module, only : c0 -! use cp_main_variables, only : bec ! to be passed directly -! use twin_types -! ! USE cp_main_variables, ONLY : collect_lambda, distribute_lambda, descla, nrlx -! USE descriptors, ONLY: lambda_node_ , la_npc_ , la_npr_ , descla_siz_ , & -! descla_init , la_comm_ , ilar_ , ilac_ , nlar_ , & -! nlac_ , la_myr_ , la_myc_ , la_nx_ , la_n_ , la_me_ , la_nrl_, nlax_ -! ! -! implicit none -! ! -! ! in/out vars -! ! -! ! integer, intent(in) :: nspin -! type(twin_matrix), dimension(nspin) :: vsicah!( nupdwn(isp),nupdwn(isp)) -! real(dp) :: vsicah2sum -! logical :: lgam -! INTEGER :: descla( descla_siz_ ) -! INTEGER :: np_rot, me_rot, comm_rot, nrl -! ! -! ! local variables -! ! -! real(dp) :: cost -! integer :: nbnd1,nbnd2,isp -! integer :: i, j1, jj1, j2, jj2, nss, istart, is -! INTEGER :: np(2), coor_ip(2), ipr, ipc, nr, nc, ir, ic, ii, jj, root, j, nlam, nlax -! INTEGER :: desc_ip( descla_siz_ ) -! LOGICAL :: la_proc -! ! -! !complex(dp), allocatable :: vsicpsi(:,:) -! real(dp), allocatable :: mtmp(:,:) -! complex(dp), allocatable :: h0c0(:,:), mtmp_c(:,:) -! ! type(twin_matrix) :: c0hc0(nspin)!modified:giovanni -! -! CALL start_clock('nk_get_vsicah') -! -! nlax = descla( nlax_ ) -! la_proc = ( descla( lambda_node_ ) > 0 ) -! nlam = 1 -! if ( la_proc ) nlam = nlax_ -! ! -! ! -! ! warning:giovanni:put a check on dimensions here?? (like in ortho_base/ortho) -! ! this check should be on dimensionality of vsicah -! ! -! cost = dble( nspin ) * 2.0d0 -! ! -! !allocate( vsicpsi(npw,2) ) -! ! allocate(c0hc0(nspin)) -! allocate(h0c0(ngw,nbspx)) -! -! ! do is=1,nspin -! ! call init_twin(c0hc0(is),lgam) -! ! call allocate_twin(c0hc0(is),nlam,nlam,lgam) -! ! enddo -! -! ! -! ! compute < phi_j | Delta h_i | phi_i > -! ! -! ! -! do j1 = 1, nbsp, 2 -! ! -! ! NOTE: USPP not implemented -! ! -! CALL nksic_eforce( j1, nbsp, nbspx, vsic, & -! deeq_sic, bec, ngw, c0(:,j1), c0(:,j1+1), h0c0(:,j1:j1+1), lgam ) -! ! -! enddo -! -! DO is= 1, nspin -! -! nss= nupdwn( is ) -! istart= iupdwn( is ) -! -! np(1) = descla( la_npr_ , is ) -! np(2) = descla( la_npc_ , is ) -! -! DO ipc = 1, np(2) -! DO ipr = 1, np(1) -! -! coor_ip(1) = ipr - 1 -! coor_ip(2) = ipc - 1 -! CALL descla_init( desc_ip, descla( la_n_ , is ), descla( la_nx_ , is ), np, coor_ip, descla( la_comm_ , is ), 1 ) -! -! nr = desc_ip( nlar_ ) -! nc = desc_ip( nlac_ ) -! ir = desc_ip( ilar_ ) -! ic = desc_ip( ilac_ ) -! -! CALL GRID2D_RANK( 'R', desc_ip( la_npr_ ), desc_ip( la_npc_ ), & -! desc_ip( la_myr_ ), desc_ip( la_myc_ ), root ) -! ! -! root = root * leg_ortho -! -! IF(.not.c0hc0(is)%iscmplx) THEN -! ALLOCATE( mtmp( nr, nc ) ) -! mtmp = 0.0d0 -! CALL DGEMM( 'T', 'N', nr, nc, 2*ngw, - 2.0d0, c0( 1, istart + ir - 1 ), 2*ngw, & -! h0c0( 1, istart + ic - 1 ), 2*ngw, 0.0d0, mtmp, nr ) -! IF (gstart == 2) THEN -! DO jj = 1, nc -! DO ii = 1, nr -! i = ii + ir - 1 -! j = jj + ic - 1 -! mtmp(ii,jj) = mtmp(ii,jj) + DBLE( c0( 1, i + istart - 1 ) ) * DBLE( h0c0( 1, j + istart - 1 ) ) -! END DO -! END DO -! END IF -! mtmp=mtmp*cost -! ELSE -! ALLOCATE( mtmp_c( nr, nc ) ) -! mtmp_c = CMPLX(0.0d0,0.d0) -! CALL ZGEMM( 'C', 'N', nr, nc, ngw, CMPLX(- 1.0d0,0.d0), c0( 1, istart + ir - 1 ),ngw, & -! h0c0( 1, istart + ic - 1 ), ngw, CMPLX(0.0d0,0.d0), mtmp_c, nr ) -! ENDIF -! mtmp_c=mtmp_c*cost -! IF(.not.c0hc0(is)%iscmplx) THEN -! CALL mp_root_sum( mtmp, vsicah(is)%rvec(1:nr,1:nc), root, intra_image_comm ) -! DEALLOCATE( mtmp ) -! ELSE -! CALL mp_root_sum( mtmp_c, vsicah(is)%cvec(1:nr,1:nc), root, intra_image_comm ) -! DEALLOCATE( mtmp_c ) -! ENDIF -! ! IF( coor_ip(1) == descla( la_myr_ , is ) .AND. & -! ! coor_ip(2) == descla( la_myc_ , is ) .AND. descla( lambda_node_ , is ) > 0 ) THEN -! ! c0hc0(1:nr,1:nc,is) = mtmp -! ! END IF -! END DO -! END DO -! ! -! ! fill mtmp or mtmp_c with hermitian conjugate of vsicah -! ! and -! ! antisymmetrize vsicah -! IF(lgam) THEN -! allocate(mtmp(nlam,nlam)) -! mtmp=0.d0 -! CALL sqr_tr_cannon( nupdw(is), vsicah(is)%rvec, nlam, mtmp, nlam, descla ) -! DO i=1,nr -! DO j=1,nc -! vsicah(is)%rvec(i,j) = vsicah(is)%rvec(i,j)-mtmp(i,j) -! END DO -! END DO -! deallocate(mtmp) -! ELSE -! allocate(mtmp_c(nlam,nlam)) -! mtmp_c=0.d0 -! CALL sqr_tr_cannon( nupdw(is), vsicah(is)%cvec, nlam, mtmp_c, nlam, descla ) -! DO i=1,nr -! DO j=1,nc -! vsicah(is)%cvec(i,j) = vsicah(is)%cvec(i,j)-mtmp(i,j) -! END DO -! END DO -! deallocate(mtmp_c) -! ENDIF -! -! END DO -! -! ! -! ! Imposing Pederson condition -! ! -! -! ! vsicah(:,:) = 0.d0 -! ! vsicah2sum = 0.0d0 -! ! ! -! ! do nbnd1 = 1, nupdwn(isp) -! ! do nbnd2 = 1, nbnd1-1 -! ! ! -! ! IF(lgam) THEN -! ! vsicah( nbnd2, nbnd1) = DBLE(hmat(nbnd2,nbnd1) -CONJG(hmat(nbnd1,nbnd2))) -! ! vsicah( nbnd1, nbnd2) = DBLE(hmat(nbnd1,nbnd2) -CONJG(hmat(nbnd2,nbnd1))) -! ! ELSE -! ! vsicah( nbnd2, nbnd1) = hmat(nbnd2,nbnd1) -CONJG(hmat(nbnd1,nbnd2)) -! ! vsicah( nbnd1, nbnd2) = hmat(nbnd1,nbnd2) -CONJG(hmat(nbnd2,nbnd1)) -! ! ENDIF -! ! vsicah2sum = vsicah2sum + 2.0d0*CONJG(vsicah(nbnd2,nbnd1))*vsicah(nbnd2,nbnd1) -! ! ! -! ! enddo -! ! enddo -! ! -! deallocate( h0c0 ) -! -! ! -! call stop_clock('nk_get_vsicah') -! ! -! return -! ! -! !--------------------------------------------------------------- -! end subroutine nksic_getvsicah_twin -! !--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_getOmat1(isp,Heig,Umat,passof,Omat1,lgam) -!----------------------------------------------------------------------- -! -! ... Obtains the rotation matrix from the force-related matrices Heig and Umat -! and also from the step size (passof). -! - use kinds, only : dp - use constants, only : ci - use electrons_base, only : nupdwn - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp - real(dp), intent(in) :: Heig(nupdwn(isp)) - complex(dp), intent(in) :: Umat(nupdwn(isp),nupdwn(isp)) - real(dp), intent(in) :: passof - complex(dp) :: Omat1(nupdwn(isp),nupdwn(isp)) - logical :: lgam - ! - ! local variables - ! - complex(dp) :: Cmattmp(nupdwn(isp),nupdwn(isp)) - complex(dp) :: exp_iHeig(nupdwn(isp)) - - integer :: nbnd1 - real(dp) :: dtmp - - - call start_clock ( "nk_getOmat1" ) - -!$$ We set the step size in such a way that the phase change -!$$ of the wavevector with largest eigenvalue upon rotation is fixed -! passof = passoprod/max(abs(Heig(1)),abs(Heig(nupdwn(isp)))) -!$$ Now the above step is done outside. - - do nbnd1=1,nupdwn(isp) - dtmp = passof * Heig(nbnd1) - exp_iHeig(nbnd1) = DCOS(dtmp) + ci*DSIN(dtmp) - enddo - -!$$ Cmattmp = exp(i * passof * Heig) * Umat^dagger ; Omat = Umat * Cmattmp - do nbnd1=1,nupdwn(isp) - Cmattmp(nbnd1,:) = exp_iHeig(nbnd1)*CONJG(Umat(:,nbnd1)) - enddo - -! Omat1 = MATMUL( CONJG(TRANSPOSE(Umat)), Cmattmp) !modified:giovanni - IF(lgam) THEN - Omat1 = DBLE(MATMUL( Umat, Cmattmp)) !modified:giovanni - ELSE - Omat1 = MATMUL( Umat, Cmattmp) !modified:giovanni - ENDIF - - call stop_clock ( "nk_getOmat1" ) - - return -!--------------------------------------------------------------- -end subroutine nksic_getOmat1 -!--------------------------------------------------------------- - -!$$ -!--------------------------------------------------------------- - subroutine nksic_dmxc_spin_cp_update( nnrx, rhoref, f, ispin, rhoele, & - small, wref, wxd ) -!--------------------------------------------------------------- - -! the derivative of the xc potential with respect to the local density -! is computed. -! In order to save time, the loop over space coordinates is performed -! inside this routine (inlining). -! -! NOTE: wref and wsic are UPDATED and NOT OVERWRITTEN by this subroutine -! - USE kinds, ONLY : dp - USE funct, ONLY : xc_spin, get_iexch, get_icorr - implicit none - ! - integer, intent(in) :: nnrx, ispin - real(dp), intent(in) :: rhoref(nnrx,2), rhoele(nnrx,2) - real(dp), intent(in) :: f, small - real(dp), intent(inout) :: wref(nnrx), wxd(nnrx,2) - ! - real(dp) :: rhoup, rhodw, rhotot, zeta - real(dp) :: dmuxc(2,2) - real(dp) :: rs, ex, vx, dr, dz, ec, & - vcupm, vcdwm, vcupp, vcdwp, & - vxupm, vxdwm, vxupp, vxdwp, & - dzm, dzp, fact - ! - real(dp), external :: dpz, dpz_polarized - integer :: ir - !logical :: do_exch, do_corr - ! - real(dp), parameter :: e2 = 2.0_dp, & - pi34 = 0.6203504908994_DP, & ! redefined to pi34=(3/4pi)^(1/3) - pi34_old= 0.75_dp/3.141592653589793_dp, third=1.0_dp/3.0_dp, & - p43=4.0_dp/3.0_dp, p49=4.0_dp/ 9.0_dp, m23=-2.0_dp/3.0_dp - ! - if ( get_iexch() == 1 .and. get_icorr() == 1 ) THEN - ! - do ir = 1, nnrx - ! - dmuxc(:,:)=0.0_dp - ! - rhoup = rhoref(ir,1) - rhodw = rhoref(ir,2) - rhotot = rhoup + rhodw - ! - if( rhotot < small) cycle - ! - zeta = (rhoup-rhodw)/rhotot - if(abs(zeta)>1.0_dp) zeta=sign(1.0_dp,zeta) - ! - ! calculate exchange contribution (analytical) - ! - if ( rhoup > small) then - rs = pi34 / (2.0_dp*rhoup)**third - call slater(rs,ex,vx) - dmuxc(1,1)=vx/(3.0_dp*rhoup) - endif - ! - if( rhodw > small) then - rs = pi34 / (2.0_dp*rhodw)**third - call slater(rs,ex,vx) - dmuxc(2,2)=vx/(3.0_dp*rhodw) - endif - ! - ! calculate correlation contribution (numerical) - ! - dr = min(1.e-6_dp,1.e-4_dp*rhotot) - fact = 0.5d0 / dr - ! - ! the explicit call to the correlation part only - ! are performed instead of calling xc_spin. - ! this saves some CPU time. - ! unfortunately, different functionals have then - ! to be treated explicitly - ! - !call xc_spin(rhotot-dr,zeta,ex,ec,vxupm,vxdwm,vcupm,vcdwm) - !call xc_spin(rhotot+dr,zeta,ex,ec,vxupp,vxdwp,vcupp,vcdwp) - ! - rs = pi34 / (rhotot-dr)**third - call pz_spin (rs, zeta, ec, vcupm, vcdwm) - rs = pi34 / (rhotot+dr)**third - call pz_spin (rs, zeta, ec, vcupp, vcdwp) - ! - - dmuxc(1,1) = dmuxc(1,1) +(vcupp-vcupm) * fact - dmuxc(1,2) = dmuxc(1,2) +(vcupp-vcupm) * fact - dmuxc(2,1) = dmuxc(2,1) +(vcdwp-vcdwm) * fact - dmuxc(2,2) = dmuxc(2,2) +(vcdwp-vcdwm) * fact - - dz=1.e-6_dp - dzp=min(1.0,zeta+dz)-zeta - dzm=-max(-1.0,zeta-dz)+zeta - ! - fact = 1.0d0 / ( rhotot * (dzp+dzm) ) - ! - !call xc_spin(rhotot,zeta-dzm,ex,ec,vxupm,vxdwm,vcupm,vcdwm) - !call xc_spin(rhotot,zeta+dzp,ex,ec,vxupp,vxdwp,vcupp,vcdwp) - ! - rs = pi34 / (rhotot)**third - call pz_spin (rs, zeta-dzm, ec, vcupm, vcdwm) - call pz_spin (rs, zeta+dzp, ec, vcupp, vcdwp) - - dmuxc(1,1) = dmuxc(1,1) +(vcupp-vcupm)*(1.0_dp-zeta)*fact - dmuxc(1,2) = dmuxc(1,2) -(vcupp-vcupm)*(1.0_dp+zeta)*fact - dmuxc(2,1) = dmuxc(2,1) +(vcdwp-vcdwm)*(1.0_dp-zeta)*fact - dmuxc(2,2) = dmuxc(2,2) -(vcdwp-vcdwm)*(1.0_dp+zeta)*fact - - ! - ! add corrections to the nksic potentials - ! - wxd(ir,1) = wxd(ir,1) + dmuxc(1,ispin) * rhoele(ir,ispin)*f - wxd(ir,2) = wxd(ir,2) + dmuxc(2,ispin) * rhoele(ir,ispin)*f - ! - wref(ir) = wref(ir) + dmuxc(ispin,ispin)*rhoele(ir,ispin) - ! - enddo - ! - else - ! - do ir = 1, nnrx - ! - dmuxc(:,:)=0.0_dp - ! - rhoup = rhoref(ir,1) - rhodw = rhoref(ir,2) - rhotot = rhoup + rhodw - ! - if( rhotot < small) cycle - ! - zeta = (rhoup-rhodw)/rhotot - if(abs(zeta)>1.0_dp) zeta=sign(1.0_dp,zeta) - - dr = min(1.e-6_dp,1.e-4_dp*rhotot) - fact = 0.5d0 / dr - - call xc_spin (rhotot - dr, zeta, ex, ec, vxupm, vxdwm, vcupm, vcdwm) - call xc_spin (rhotot + dr, zeta, ex, ec, vxupp, vxdwp, vcupp, vcdwp) - ! - dmuxc(1,1) = dmuxc(1,1) + (vxupp + vcupp - vxupm - vcupm)*fact - dmuxc(1,2) = dmuxc(1,2) + (vxupp + vcupp - vxupm - vcupm)*fact - dmuxc(2,1) = dmuxc(2,1) + (vxdwp + vcdwp - vxdwm - vcdwm)*fact - dmuxc(2,2) = dmuxc(2,2) + (vxdwp + vcdwp - vxdwm - vcdwm)*fact - ! - dz = 1.E-6_DP - dzp= min( 1.0,zeta+dz)-zeta - dzm=-max(-1.0,zeta-dz)+zeta - ! - fact = 1.0d0 / ( rhotot * (dzp+dzm) ) - ! - call xc_spin (rhotot, zeta - dzm, ex, ec, vxupm, vxdwm, vcupm, vcdwm) - call xc_spin (rhotot, zeta + dzp, ex, ec, vxupp, vxdwp, vcupp, vcdwp) - ! - dmuxc(1,1) = dmuxc(1,1) + (vxupp + vcupp - vxupm - vcupm) * (1.0_DP - zeta)*fact - dmuxc(1,2) = dmuxc(1,2) - (vxupp + vcupp - vxupm - vcupm) * (1.0_DP + zeta)*fact - dmuxc(2,1) = dmuxc(2,1) + (vxdwp + vcdwp - vxdwm - vcdwm) * (1.0_DP - zeta)*fact - dmuxc(2,2) = dmuxc(2,2) - (vxdwp + vcdwp - vxdwm - vcdwm) * (1.0_DP + zeta)*fact - ! - ! add corrections to the nksic potentials - ! - wxd(ir,1) = wxd(ir,1) + dmuxc(1,ispin) * rhoele(ir,ispin)*f - wxd(ir,2) = wxd(ir,2) + dmuxc(2,ispin) * rhoele(ir,ispin)*f - ! - wref(ir) = wref(ir) + dmuxc(ispin,ispin)*rhoele(ir,ispin) - ! - enddo - ! - endif - - return - -!--------------------------------------------------------------- -end subroutine nksic_dmxc_spin_cp_update -!--------------------------------------------------------------- - -SUBROUTINE compute_nksic_centers(nnrx, nx, nudx, nbsp, nspin, iupdwn, & - nupdwn, ispin, orb_rhor, wfc_centers, wfc_spreads, j,k) - - USE kinds, ONLY: DP - USE ions_positions, ONLY: taus - USE ions_base, ONLY: ions_cofmass, pmass, na, nsp - USE cell_base, ONLY: s_to_r - USE mp, ONLY: mp_bcast - ! - ! INPUT VARIABLES - ! - INTEGER, INTENT(IN) :: nx, nnrx, nudx - INTEGER, INTENT(IN) :: ispin(nx),j,k,nspin, nbsp, & - nupdwn(nspin), iupdwn(nspin) - !ispin is 1 or 2 for each band (listed as in c0), - !nx is nudx, j and k the two bands involved in the - !spread calculation - REAL(DP), INTENT(in) :: orb_rhor(nnrx,2) - REAL(DP) :: wfc_centers(4,nudx,nspin) - REAL(DP) :: wfc_spreads(nudx,nspin,2) - !orbital spreads: both wannier(1) and self-hartree(2) - !self-hartree is stored separately, within nksic subroutines - ! - !INTERNAL VARIABLES - ! - INTEGER :: myspin1, myspin2, mybnd1, mybnd2 - REAL(DP):: r0(3) - REAL(DP), external :: ddot - - ! - myspin1=ispin(j) - ! - mybnd1=j-iupdwn(myspin1)+1 - ! - ! compute ionic center of mass - ! - CALL ions_cofmass(taus, pmass, na, nsp, r0) - ! and use it as reference position - ! - call compute_dipole( nnrx, 1, orb_rhor(1,1), r0, wfc_centers(1:4, mybnd1, myspin1), & - wfc_spreads(mybnd1, myspin1, 1)) -!!! NB: NLN: I modify the wfc_spread to quadrupole form, it does not equal to wannier definition - wfc_spreads(mybnd1,myspin1,1) = wfc_spreads(mybnd1,myspin1,1) - & - ddot(3, wfc_centers(2:4,mybnd1,myspin1), 1, wfc_centers(2:4,mybnd1,myspin1), 1) - ! - ! now shift wavefunction centers by r0 - ! - wfc_centers(2:4, mybnd1, myspin1) = wfc_centers(2:4, mybnd1, myspin1) + r0(1:3) - ! - IF(k.le.nbsp) THEN - ! - myspin2=ispin(k) - mybnd2=k-iupdwn(myspin2)+1 - ! - call compute_dipole( nnrx, 1, orb_rhor(1,2), r0, wfc_centers(1:4, mybnd2, myspin2), & - wfc_spreads(mybnd2, myspin2,1)) -!!! NB: NLN: I modify the wfc_spread to quadrupole form, it does not equal to wannier definition - wfc_spreads(mybnd2,myspin2,1) = wfc_spreads(mybnd2,myspin2,1) - & - ddot(3, wfc_centers(2:4,mybnd2,myspin2), 1, wfc_centers(2:4,mybnd2,myspin2), 1) - ! - ! now shift wavefunction centers by r0 - ! - wfc_centers(2:4, mybnd2, myspin2) = wfc_centers(2:4, mybnd2, myspin2) + r0(1:3) - ! - ENDIF - ! - RETURN - -END SUBROUTINE compute_nksic_centers -! -SUBROUTINE spread_sort(ngw, nspin, nbsp, nudx, nupdwn, iupdwn, tempspreads, wfc_centers, sort_spreads) - - USE kinds, ONLY: DP - USE input_parameters, only: draw_pot, sortwfc_spread !added:linh draw vsic potentials - USE wavefunctions_module, only: c0,cm - USE mp, only: mp_bcast - - IMPLICIT NONE - - !COMPLEX(DP) :: c0(ngw, nbsp), cm(ngw,nbsp) - INTEGER :: ngw, nspin, nbsp, nudx, nupdwn(nspin), iupdwn(nspin) - REAL(DP) :: tempspreads(nudx, nspin, 2) - REAL(DP) :: wfc_centers(4,nudx,nspin) - INTEGER :: sort_spreads(nudx,nspin) - ! - INTEGER :: isp,j,k,refnum,i, ig - INTEGER, ALLOCATABLE :: aidarray(:,:) - !REAL(DP), ALLOCATABLE :: tempspreads(:,:,:) - COMPLEX(DP), ALLOCATABLE :: tempwfc(:,:) - - ! do nothing if one is drawing the potential: to avoid mismatch between potential and orbital - IF(draw_pot) THEN - return - ENDIF - ! - !allocate(tempspreads(nudx,nspin,2)) - allocate(aidarray(nudx,2), tempwfc(ngw,2)) - ! - !tempspreads(:,:,:) = wfc_spreads(:,:,:) - ! - !write(*,*) mpime, "spreads", tempspreads(:,2,2) - ! - do isp=1,nspin - ! - !if(ionode) then - do j=1,nupdwn(isp) !initialize sort-decodification array - ! - aidarray(j,1) = j - aidarray(j,2) = 0 - ! - enddo - ! - do j=1,nupdwn(isp)-1 !bubble-sort the decodification array - ! - do k=nupdwn(isp),j+1,-1 - ! - IF(tempspreads(k,isp,2).lt.tempspreads(k-1,isp,2)) THEN - ! - call swap_real(tempspreads(k,isp,2),tempspreads(k-1,isp,2)) - call swap_real(tempspreads(k,isp,1),tempspreads(k-1,isp,1)) - do i=1,4 - call swap_real(wfc_centers(i,k,isp),wfc_centers(i,k-1,isp)) - enddo - call swap_integer(aidarray(k,1),aidarray(k-1,1)) - ! - ENDIF - ! - enddo - ! - enddo - !write(*,*) mpime, "aidarray", aidarray(:,1) - j=1 - k=1 - refnum=0 - !write(*,*) mpime, "before", c0(2,:) - ! - if(sortwfc_spread) then - ! - do while(k.le.nupdwn(isp)) - ! - write(6,*) j,aidarray(j,2), aidarray(j,1), refnum - IF(aidarray(j,2)==0.and.j/=aidarray(j,1)) THEN - ! - IF(aidarray(j,1)/=refnum) THEN - ! - IF(refnum==0) THEN - ! - do ig=1,ngw - ! - tempwfc(ig,1) = c0(ig,iupdwn(isp)+j-1) - tempwfc(ig,2) = cm(ig,iupdwn(isp)+j-1) - ! - enddo - refnum=j - ! - ENDIF - ! - do ig=1,ngw - ! - c0(ig,iupdwn(isp)+j-1) = c0(ig,iupdwn(isp)+aidarray(j,1)-1) - cm(ig,iupdwn(isp)+j-1) = cm(ig,iupdwn(isp)+aidarray(j,1)-1) - ! - enddo - ! - aidarray(j,2)=1 - j=aidarray(j,1) - ! - ELSE - ! - do ig=1,ngw - ! - c0(ig,iupdwn(isp)+j-1) = tempwfc(ig,1) - cm(ig,iupdwn(isp)+j-1) = tempwfc(ig,2) - ! - enddo - ! - aidarray(j,2)=1 - j=refnum+1 - refnum=0 - ! - ENDIF - k=k+1 - ! - ELSE - ! - IF(j==aidarray(j,1)) THEN - ! - k=k+1 - ! - ENDIF - ! - j=j+1 - ! - if(j.gt.nupdwn(isp)) THEN - exit - ELSE - cycle - ENDIF - ! - ENDIF - ! - enddo - endif - ! - sort_spreads(:,isp) = aidarray(:,1) - ! - enddo - - ! - if(allocated(tempwfc)) deallocate(tempwfc) - deallocate(aidarray) - ! - return - -contains - - subroutine swap_integer(a,b) - - use kinds, ONLY: DP - - implicit none - - INTEGER :: a,b - INTEGER :: c - - c=a - a=b - b=c - - return - - end subroutine swap_integer - - subroutine swap_real(a,b) - - use kinds, ONLY: DP - - implicit none - - REAL(DP) :: a,b - REAL(DP) :: c - - c=a - a=b - b=c - - return - - end subroutine swap_real - -END SUBROUTINE spread_sort - - -SUBROUTINE compute_complexification_index(ngw, nnrx, nnrsx, nbsp, nbspx, nspin, ispin, iupdwn, nupdwn, c0, bec,& - complexification_index) - ! - ! Here the overlap between the wavefunction manifold and its conjugate is calculated - ! - ! As it is now, this routine works only with Norm Conserving Pseudopotentials - ! - USE kinds, ONLY : DP - USE twin_types - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - use cell_base, only: omega - use cp_interfaces, only: fwfft, invfft - use fft_base, only: dfftp - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: ngw, nnrx, nnrsx, nbsp, nbspx, nspin, & - iupdwn(nspin), nupdwn(nspin), ispin(nbspx) - type(twin_matrix) :: bec - COMPLEX(DP) :: c0(ngw, nbspx), complexification_index - - INTEGER :: i,j, ir - COMPLEX(DP), allocatable :: temp_array(:, :), psi1(:), psi2(:) - REAL(DP) :: sa1 - - sa1 = 1.0d0 / omega - ! - allocate(temp_array(nbsp, nbsp)) - ! - temp_array=CMPLX(0.d0,0.d0) - ! - if ( nnrsx == nnrx ) then ! warning this is a bad way to say we are using ultrasoft - ! - allocate( psi1(nnrx), psi2(nnrx) ) - ! - do i=1,nbsp - ! - do j=1,i - ! - IF(ispin(i) == ispin(j)) THEN - ! - call c2psi(psi1,nnrx,c0(:,i), c0(:,j), ngw, 0) - call c2psi(psi2,nnrx,c0(:,j), c0(:,i), ngw, 0) - ! - CALL invfft('Dense', psi1, dfftp ) - CALL invfft('Dense', psi2, dfftp ) - ! - do ir=1, nnrx - ! - temp_array(i,j) = temp_array(i,j) + psi1(ir)*psi2(ir) - ! - enddo - ! - ENDIF - ! - enddo - ! - enddo - ! - else !if using uspp - ! - allocate( psi1(nnrx), psi2(nnrx) ) - ! - ! for the moment: do nothing - ! - endif - ! - call mp_sum(temp_array, intra_image_comm) - ! - temp_array = temp_array / DBLE( dfftp%nr1*dfftp%nr2*dfftp%nr3 ) - complexification_index=0.d0 - ! - do i=1,nbsp - ! - do j=1,i-1 - ! - IF(ispin(j) == ispin(i)) THEN - ! - complexification_index=complexification_index+2.d0*abs(temp_array(i,j))**2 - ! - ENDIF - ! - enddo - ! - complexification_index=complexification_index+abs(temp_array(i,i))**2 - ! - enddo - ! - complexification_index=(1.d0-complexification_index/nbsp)*100.d0 ! the index is in percentage - ! - deallocate(temp_array) - deallocate(psi1) - deallocate(psi2) - ! - return - -END subroutine compute_complexification_index - -!----------------------------------------------------------------------- - subroutine nksic_potential_non_ortho( nbsp, nx, c, cdual, f_diag, & - bec, becdual, becsum, & - deeq_sic, ispin, iupdwn, nupdwn, & - rhor, rhoc, wtot, sizwtot, vsic, do_wxd_, pink, nudx, & - wfc_centers, wfc_spreads, & - icompute_spread) -!----------------------------------------------------------------------- -! -! ....calculate orbital dependent potentials, -! following the Non-Koopmans' (NK) scheme, -! but also Perdew-Zunger (PZ), -! Non-Koopmans' integral definition (NKI), -! Non-Joopmans on Perdew Zunger (PZNK) -! -! subroutine writte for non-orthogonal functions -! note that non-linear core correction is not working -! in this particular subroutine -! -! - use kinds, only: dp - use gvecp, only: ngm - use gvecw, only: ngw - use grid_dimensions, only: nnrx - use electrons_base, only: nspin - use funct, only : dft_is_gradient - use nksic, only: orb_rhor, wxdsic, & - wrefsic, rhoref, rhobar, & - do_nk, do_nki, do_pz, do_nkpz, & - do_nkipz, grhobar, fion_sic, & - pzalpha=>odd_alpha, do_pz_renorm, edens, & - tauw,taukin, kfact - use ions_base, only: nat - use control_flags, only: gamma_only, do_wf_cmplx !added:giovanni - use uspp_param, only: nhm - use cp_interfaces, only: nksic_get_orbitalrho !added:giovanni - use twin_types !added:giovanni - use input_parameters, only: draw_pot, pot_number !added:linh draw vsic potentials - use io_pot_sic_xml, only: write_pot_sic !added:linh draw vsic potentials - USE io_global, ONLY: stdout - - ! - implicit none - ! - - ! -- add N. Poilvert, define explicit interface to - ! nksic_correction_nkipz - INTERFACE - subroutine nksic_correction_nkipz( f, ispin, orb_rhor, & - vsic, pink, ibnd, shart, is_empty) - - use kinds, only : dp - use constants, only : e2, fpi, hartree_si, electronvolt_si - use grid_dimensions, only : nnrx - use cp_interfaces, only : fwfft, invfft, fillgrad - use funct, only : dft_is_gradient - use mp, only : mp_sum - - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(out) :: vsic(nnrx) - real(dp), intent(out) :: pink, shart - logical, optional, intent(in) :: is_empty - end subroutine nksic_correction_nkipz - END INTERFACE - ! -- add N. Poilvert, define explicit interface to - ! nksic_correction_nki - INTERFACE - subroutine nksic_correction_nki( f, ispin, orb_rhor, rhor, & - rhoref, rhobar, rhobarg, grhobar,& - vsic, wxdsic, do_wxd_, pink, ibnd, is_empty ) - - use kinds, only : dp - use constants, only : e2, fpi - use grid_dimensions, only : nnrx - use gvecp, only : ngm - use cp_interfaces, only : fwfft, invfft, fillgrad - use funct, only : dmxc_spin, dft_is_gradient - use mp, only : mp_sum - use electrons_base, only : nspin - - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(in) :: rhor(nnrx,nspin) - real(dp), intent(in) :: rhoref(nnrx,2) - real(dp), intent(in) :: rhobar(nnrx,2) - complex(dp), intent(in) :: rhobarg(ngm,2) - real(dp), intent(in) :: grhobar(nnrx,3,2) - real(dp), intent(out) :: vsic(nnrx) - real(dp), intent(out) :: wxdsic(nnrx,2) - logical, intent(in) :: do_wxd_ - real(dp), intent(out) :: pink - logical, optional, intent(in) :: is_empty - end subroutine nksic_correction_nki - END INTERFACE - - ! - ! in/out vars - ! - integer, intent(in) :: nbsp, nx, nudx, sizwtot - complex(dp), intent(in) :: c(ngw,nx), cdual(ngw,nx) - type(twin_matrix), intent(in) :: bec, becdual!(nkb,nbsp) !modified:giovanni - real(dp), intent(in) :: becsum( nhm*(nhm+1)/2, nat, nspin) - integer, intent(in) :: ispin(nx) - integer, intent(in) :: iupdwn(nspin), nupdwn(nspin) - real(dp), intent(in) :: f_diag(nx) - real(dp), intent(in) :: rhor(nnrx,nspin) - real(dp), intent(in) :: rhoc(nnrx) - real(dp), intent(out) :: vsic(nnrx,nx), wtot(sizwtot,2) - real(dp), intent(out) :: deeq_sic(nhm,nhm,nat,nx) - logical, intent(in) :: do_wxd_ - real(dp), intent(out) :: pink(nx) - logical :: icompute_spread - real(DP) :: wfc_centers(4,nudx,nspin) - real(DP) :: wfc_spreads(nudx,nspin,2) - - ! - ! local variables - ! - integer :: i,j,jj,ibnd,isp - real(dp) :: focc,pinkpz,shart - real(dp), allocatable :: vsicpz(:) - complex(dp), allocatable :: rhobarg(:,:) - logical :: lgam - ! - ! main body - ! - CALL start_clock( 'nksic_drv' ) - lgam = gamma_only.and..not.do_wf_cmplx - ! - ! compute potentials - ! - if (dft_is_gradient()) then - allocate(rhobarg(ngm,2)) - !write(6,*) "allocated rhobarg" - else - allocate(rhobarg(1,1)) - endif - - if ( do_nk .or. do_nkpz .or. do_nki .or. do_nkipz ) then - wtot=0.0_dp - endif - ! - if ( do_nkpz .or. do_nkipz) then - allocate(vsicpz(nnrx)) - vsicpz=0.0_dp - endif - ! - pink=0.0_dp - vsic=0.0_dp - ! - ! if using pz_renorm factors, compute here tauw and upsilonw - ! - if(do_pz_renorm) THEN - ! - edens=0.d0 - ! - do isp=1,nspin - ! - call nksic_get_taukin_pz( 1.d0, nspin, isp, rhor(1,isp), tauw, 1) - ! - enddo - ! - ENDIF - ! - ! loop over bands (2 ffts at the same time) - ! -! call compute_overlap(c, ngw, nbsp, overlap_) - ! - do j=1,nbsp,2 - ! - ! compute orbital densities - ! n odd => c(:,n+1) is already set to zero - ! - call nksic_get_orbitalrho( ngw, nnrx, bec, becdual, ispin, nbsp, & - c(:,j), c(:,j+1), cdual(:,j), cdual(:,j+1), orb_rhor, & - j, j+1, lgam) !note:giovanni change here for non-orthogonality flavour -!begin_added:giovanni -! orb_rhor(:,1) = orb_rhor(:,1)/overlap_(j+1-iupdwn(ispin(j)),j+1-iupdwn(ispin(j)),ispin(j)) -! orb_rhor(:,2) = orb_rhor(:,2)/overlap_(j+2-iupdwn(ispin(j+1)),j+2-iupdwn(ispin(j+1)),ispin(j+1)) - !compute centers and spreads of nksic or pz minimizing orbitals - IF(icompute_spread) THEN - ! - call compute_nksic_centers(nnrx, nx, nudx, nbsp, nspin, iupdwn, & - nupdwn, ispin, orb_rhor, wfc_centers, wfc_spreads, j, j+1) - ! - ENDIF - ! -!end_added:giovanni - ! - shart=0.d0 - ! - ! compute orbital potentials - ! - inner_loop: do jj=1,2 - ! - i=j+jj-1 - ! - ! this condition is important when n is odd - ! - if ( i > nbsp ) exit inner_loop - ! - ibnd=i - if( nspin==2 ) then - if ( i >= iupdwn(2) ) ibnd=i-iupdwn(2)+1 - endif - ! - ! note: iupdwn(2) is set to zero if nspin = 1 - ! - focc=f_diag(i)*DBLE(nspin)/2.0d0 - ! - ! compute parameters needed for PZ-renormalization - ! - IF(do_pz_renorm) THEN - ! - call nksic_get_taukin_pz( focc, nspin, ispin(i), orb_rhor(:,jj), & - taukin, ibnd) - ! - ENDIF - ! - ! - ! define rhoref and rhobar - ! - call nksic_get_rhoref( i, nnrx, ispin(i), nspin, & - focc, rhor, orb_rhor(:,jj), & - rhoref, rhobar, rhobarg, grhobar ) - - ! - ! compute nk pieces to build the potentials and the energy - ! - if ( do_nk .or. do_nkpz ) then - ! - call nksic_correction_nk( focc, ispin(i), orb_rhor(:,jj), & - rhor, rhoref, rhobar, rhobarg, grhobar, & - vsic(:,i), wxdsic, wrefsic, do_wxd_, & - pink(i), ibnd, shart) - ! - wfc_spreads(ibnd, ispin(i), 2) = shart - ! - ! here information is accumulated over states - ! (wtot is added in the next loop) - ! - wtot(1:nnrx,1:2) = wtot(1:nnrx,1:2) + wxdsic(1:nnrx,1:2) - ! - ! ths sic potential is partly updated here to save some memory - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + wrefsic(1:nnrx) & - - wxdsic( 1:nnrx, ispin(i) ) - ! - endif - - ! - ! compute nkpz pieces to build the potential and the energy - ! - if( do_nkpz ) then - ! - call nksic_correction_nkpz( focc, orb_rhor(:,jj), vsicpz, & - wrefsic, pinkpz, ibnd, ispin(i)) - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + vsicpz(1:nnrx) & - + wrefsic(1:nnrx) - ! - pink(i) = pink(i) +pinkpz - ! - endif - - - ! - ! compute pz potentials and energy - ! - if ( do_pz ) then - ! - call nksic_correction_pz ( focc, ispin(i), orb_rhor(:,jj), & - vsic(:,i), pink(i), pzalpha(i), ibnd, shart) - ! - wfc_spreads(ibnd, ispin(i), 2) = shart - ! - if(do_pz_renorm) then - ! - edens(:,ispin(i)) = edens(:,ispin(i)) + pink(i)*orb_rhor(:,jj) - ! - endif - ! - endif - - ! - ! compute nki pieces to build the potentials and the energy - ! - if ( do_nki .or. do_nkipz) then - ! - call nksic_correction_nki( focc, ispin(i), orb_rhor(:,jj), & - rhor, rhoref, rhobar, rhobarg, grhobar, & - vsic(:,i), wxdsic, do_wxd_, pink(i), ibnd) - ! - ! here information is accumulated over states - ! (wtot is added in the next loop) - ! - wtot(1:nnrx,1:2) = wtot(1:nnrx,1:2) + wxdsic(1:nnrx,1:2) - ! - ! ths sic potential is partly updated here to save some memory - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) - wxdsic( 1:nnrx, ispin(i) ) - ! - endif - - if( do_nkipz ) then - ! - call nksic_correction_nkipz( focc, ispin(i), orb_rhor(:,jj), vsicpz, & - pinkpz, ibnd, shart) - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + vsicpz(1:nnrx) - ! - pink(i) = pink(i) +pinkpz - ! - wfc_spreads(ibnd, ispin(i), 2) = shart - ! - endif - ! - ! take care of spin symmetry - ! - pink(i) = f_diag(i) * pink(i) - ! - if ( do_nk .or. do_nkpz .or. do_nki .or. do_nkipz) then - ! - if( nspin== 1 ) then - ! - wtot(1:nnrx,1) = wtot(1:nnrx,1) + wxdsic(1:nnrx,2) - wtot(1:nnrx,2) = wtot(1:nnrx,2) + wxdsic(1:nnrx,1) - ! - endif - ! - endif - ! - enddo inner_loop - ! - enddo - - ! - ! Switch off the icompute_spread flag if present - ! - IF(icompute_spread) THEN - ! - icompute_spread=.false. - ! - ENDIF - ! - ! now wtot is completely built and can be added to vsic - ! - if ( do_nk .or. do_nkpz .or. do_nki .or. do_nkipz ) then - ! - do i = 1, nbsp - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + wtot( 1:nnrx, ispin(i) ) - ! - enddo - ! - endif - ! - ! if pz is renormalized, here we compute the potential, and multiply here pink by renormalization factor - ! - if ( do_pz_renorm ) then - ! - do j=1,nbsp,2 - ! - call nksic_get_orbitalrho( ngw, nnrx, bec, ispin, nbsp, & - c(:,j), c(:,j+1), orb_rhor, j, j+1, lgam) - ! - inner_loop_renorm: do jj=1,2 - ! - i=j+jj-1 - if ( i > nbsp ) exit inner_loop_renorm - ! - ibnd=i - focc=f_diag(i)*DBLE(nspin)/2.0d0 - ! - if( nspin==2 ) then - if ( i >= iupdwn(2) ) ibnd=i-iupdwn(2)+1 - endif - ! - call nksic_get_pz_factor( nspin, ispin(i), orb_rhor(:,jj), rhor,& - taukin, tauw, pzalpha(i), ibnd, kfact) - ! - ! update vsic with factor here: it works for pz, will it work for - ! nk-type functionals? - ! -! vsic(:,i) = vsic(:,i)*pzalpha(i) -! pink(i) = pink(i)*pzalpha(i) - ! - ! -! call nksic_get_pzfactor_potential(focc, nspin, ispin(i), rhor, orb_rhor(:,jj), & -! pink(i), taukin, tauw, edens, upsilonkin, upsilonw, vsic(:,i), pzalpha(i), ibnd, kfact) - ! - enddo inner_loop_renorm - ! - enddo - ! - endif - ! - ! - if (draw_pot) then !added:linh draw vsic potentials - ! - write(stdout,*) "I am writing out vsic", nbsp - do i =1, nbsp - ! - if (i == pot_number) call write_pot_sic ( vsic(:, i) ) - ! - enddo - ! - endif !added:linh draw vsic potentials - ! - if ( allocated(vsicpz) ) deallocate(vsicpz) - - ! - ! USPP: - ! compute corrections to the D coefficients of the pseudopots - ! due to vsic(r, i) in the case of orbital dependent functionals. - ! The corresponding contributions to the forces are computed. - ! - ! IMPORTANT: the following call makes use of newd. - ! It must be done before we call newd for the - ! total potentials, because deeq is overwritten at every call - ! - fion_sic(:,:) = 0.0d0 - ! - IF ( nhm > 0 ) then - ! - deeq_sic(:,:,:,:) = 0.0d0 - ! - DO i = 1, nbsp - ! - CALL nksic_newd( i, nnrx, ispin(i), nspin, vsic(:,i), nat, nhm, & - becsum, fion_sic, deeq_sic(:,:,:,i) ) - ! - ENDDO - ! - ENDIF - ! - deallocate(rhobarg) - ! - CALL stop_clock( 'nksic_drv' ) - return - ! -!----------------------------------------------------------------------- - end subroutine nksic_potential_non_ortho -!----------------------------------------------------------------------- diff --git a/quantum_espresso/kcp/CPV/nksiclib.f90_bk b/quantum_espresso/kcp/CPV/nksiclib.f90_bk deleted file mode 100644 index 472e2ceef..000000000 --- a/quantum_espresso/kcp/CPV/nksiclib.f90_bk +++ /dev/null @@ -1,8335 +0,0 @@ -! -! Copyright (C) 2007-2008 Quantum ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! Non-Koopmans method -! Developed and implemented by I. Dabo -! (Universite Paris-Est, Ecole des Ponts, ParisTech) -! Further developed and optimized by Andrea Ferretti -! (MIT, University of Oxford) -! -#include "f_defs.h" - -!----------------------------------------------------------------------- - subroutine nksic_potential( nbsp, nx, c, f_diag, bec, becsum, & - deeq_sic, ispin, iupdwn, nupdwn, & - rhor, rhoc, wtot, sizwtot, vsic, do_wxd_, pink, nudx, & - wfc_centers, wfc_spreads, & - icompute_spread, is_empty) -!----------------------------------------------------------------------- -! -! ....calculate orbital dependent potentials, -! following the Non-Koopmans' (NK) scheme, -! but also Perdew-Zunger (PZ), -! Non-Koopmans' integral definition (NKI), -! Non-Joopmans on Perdew Zunger (PZNK) -! - use kinds, only: dp - use gvecp, only: ngm - use gvecw, only: ngw - use grid_dimensions, only: nnrx - USE electrons_base, ONLY: nspin - use funct, only: dft_is_gradient - use nksic, only: orb_rhor, wxdsic, & - wrefsic, rhoref, rhobar, & - do_nk, do_nki, do_pz, do_nkpz, & - do_nkipz, do_pz_renorm, & - grhobar, fion_sic, pzalpha => odd_alpha, & - kfact, upsilonkin, upsilonw, edens,& - taukin, tauw, valpsi, odd_alpha, nkscalfact - use nksic, only: epsi3=> epsi_cutoff_renorm, epsi2=> epsi2_cutoff_renorm - use ions_base, only: nat - use control_flags, only: gamma_only, do_wf_cmplx - use uspp, only: nkb - use uspp_param, only: nhm - use cp_interfaces, only: nksic_get_orbitalrho - use input_parameters, only: draw_pot, pot_number, odd_nkscalfact !added:linh draw vsic potentials - use io_pot_sic_xml, only: write_pot_sic !added:linh draw vsic potentials - USE io_global, ONLY: stdout - use core, ONLY: nlcc_any - use twin_types - ! - implicit none - ! - ! -- add N. Poilvert, define explicit interface to - ! nksic_correction_nkipz - ! - INTERFACE - subroutine nksic_correction_nkipz( f, ispin, orb_rhor, & - vsic, pink, ibnd, shart, is_empty) - - use kinds, only : dp - use constants, only : e2, fpi, hartree_si, electronvolt_si - use cell_base, only : tpiba2,omega - use nksic, only : nknmax, nkscalfact - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use eecp_mod, only : do_comp - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dft_is_gradient - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use control_flags, only : gamma_only, do_wf_cmplx - - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(out) :: vsic(nnrx) - real(dp), intent(out) :: pink, shart - logical, optional, intent(in) :: is_empty - end subroutine nksic_correction_nkipz - END INTERFACE - ! -- add N. Poilvert, define explicit interface to - ! nksic_correction_nki - INTERFACE - subroutine nksic_correction_nki( f, ispin, orb_rhor, rhor, & - rhoref, rhobar, rhobarg, grhobar,& - vsic, wxdsic, do_wxd_, pink, ibnd, shart, is_empty ) - - use kinds, only : dp - use constants, only : e2, fpi - use cell_base, only : tpiba2,omega - use nksic, only : fref, rhobarfact, nknmax, & - nkscalfact, & - etxc => etxc_sic, vxc => vxc_sic - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use eecp_mod, only : do_comp - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dmxc_spin, dft_is_gradient - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use electrons_base, only : nspin - use control_flags, only : gamma_only, do_wf_cmplx - - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(in) :: rhor(nnrx,nspin) - real(dp), intent(in) :: rhoref(nnrx,2) - real(dp), intent(in) :: rhobar(nnrx,2) - complex(dp), intent(in) :: rhobarg(ngm,2) - real(dp), intent(in) :: grhobar(nnrx,3,2) - real(dp), intent(out) :: vsic(nnrx) - real(dp), intent(out) :: wxdsic(nnrx,2) - logical, intent(in) :: do_wxd_ - real(dp), intent(out) :: pink, shart - logical, optional, intent(in) :: is_empty - end subroutine nksic_correction_nki - END INTERFACE - - ! in/out vars - ! - integer, intent(in) :: nbsp, nx, nudx, sizwtot - complex(dp), intent(in) :: c(ngw,nx) - type(twin_matrix), intent(in) :: bec!(nkb,nbsp) !modified:giovanni - real(dp), intent(in) :: becsum( nhm*(nhm+1)/2, nat, nspin) - integer, intent(in) :: ispin(nx) - integer, intent(in) :: iupdwn(nspin), nupdwn(nspin) - real(dp), intent(in) :: f_diag(nx) - real(dp) :: rhor(nnrx,nspin) - real(dp), intent(in) :: rhoc(nnrx) - real(dp), intent(out) :: vsic(nnrx,nx), wtot(sizwtot,2) - real(dp), intent(out) :: deeq_sic(nhm,nhm,nat,nx) - logical, intent(in) :: do_wxd_ - real(dp), intent(out) :: pink(nx) - logical :: icompute_spread - real(DP) :: wfc_centers(4,nudx,nspin) - real(DP) :: wfc_spreads(nudx,nspin,2) - logical :: is_empty - ! - ! local variables - ! - integer :: i,j,jj,ibnd,isp,ir - real(dp) :: focc,pinkpz, shart - real(dp), allocatable :: vsicpz(:), rhor_nocc(:,:) - complex(dp), allocatable :: rhobarg(:,:) - logical :: lgam, is_empty_ - ! - ! main body - ! - CALL start_clock( 'nksic_drv' ) - lgam = gamma_only.and..not.do_wf_cmplx - ! - is_empty_=is_empty - ! - ! compute potentials - ! - if (dft_is_gradient()) then - allocate(rhobarg(ngm,2)) - !write(6,*) "allocated rhobarg" - else - allocate(rhobarg(1,1)) - endif - ! - if (nlcc_any) then - ! - allocate(rhor_nocc(nnrx,nspin)) - rhor_nocc(:,:) = rhor(:,:) - ! - ! add core charge - ! - call add_cc_rspace(rhoc, rhor) - ! - endif - ! - if ( do_nk .or. do_nkpz .or. do_nki .or. do_nkipz ) then - wtot=0.0_dp - endif - ! - if ( do_nkpz .or. do_nkipz) then - allocate(vsicpz(nnrx)) - vsicpz=0.0_dp - endif - ! - pink=0.0_dp - vsic=0.0_dp - ! - ! - ! if using pz_renorm factors, compute here tauw and upsilonw - ! - if(do_pz_renorm) THEN - ! - edens=0.d0 - taukin=0.d0 - tauw=0.d0 - ! - ENDIF - ! - ! loop over bands (2 ffts at the same time) - ! - ! - do j=1,nbsp,2 - ! - ! compute orbital densities - ! n odd => c(:,n+1) is already set to zero - ! - call nksic_get_orbitalrho( ngw, nnrx, bec, ispin, nbsp, & - c(:,j), c(:,j+1), orb_rhor, j, j+1, lgam) !warning:giovanni need modification - ! - ! compute centers and spreads of nksic or pz - ! minimizing orbitals - ! - if (icompute_spread) then - ! - call compute_nksic_centers(nnrx, nx, nudx, nbsp, nspin, iupdwn, & - nupdwn, ispin, orb_rhor, wfc_centers, wfc_spreads, j, j+1) - ! - endif - ! - shart=0.d0 - ! - ! compute orbital potentials - ! - inner_loop: do jj=1,2 - ! - i=j+jj-1 - ! - ! this condition is important when n is odd - ! - if ( i > nbsp ) exit inner_loop - ! - ibnd=i - ! - if ( nspin==2 ) then - ! - if ( i >= iupdwn(2) ) ibnd=i-iupdwn(2)+1 - ! - endif - ! - ! note: iupdwn(2) is set to zero if nspin = 1 - ! - focc=f_diag(i)*DBLE(nspin)/2.0d0 - ! - ! compute parameters needed for PZ-renormalization - ! - IF(do_pz_renorm) THEN - ! - !call nksic_get_taukin_pz( focc, nspin, ispin(i), orb_rhor(:,jj), & - !taukin, ibnd, 1) - ! - IF(ibnd==1) THEN - ! - IF(nspin==1) THEN - ! - !call nksic_get_taukin_pz( 0.5d0, nspin, ispin(i), & - ! rhor(:,1), tauw, ibnd, nupdwn(ispin(i))) - ! - ELSE IF(nspin==2) THEN - ! - !call nksic_get_taukin_pz( 1.d0, nspin, ispin(i), & - ! rhor(:,ispin(i)), tauw, ibnd, nupdwn(ispin(i))) - ! - ENDIF - ! - ENDIF - ! - ENDIF - ! - ! define rhoref and rhobar - ! - call nksic_get_rhoref( i, nnrx, ispin(i), nspin, & - focc, rhor, orb_rhor(:,jj), & - rhoref, rhobar, rhobarg, grhobar ) - - ! - ! compute nk pieces to build the potentials and the energy - ! - if ( do_nk .or. do_nkpz ) then - ! - call nksic_correction_nk( focc, ispin(i), orb_rhor(:,jj), & - rhor, rhoref, rhobar, rhobarg, grhobar, & - vsic(:,i), wxdsic, wrefsic, do_wxd_, & - pink(i), ibnd, shart) - ! - wfc_spreads(ibnd, ispin(i), 2) = shart - ! - ! here information is accumulated over states - ! (wtot is added in the next loop) - ! - wtot(1:nnrx,1:2) = wtot(1:nnrx,1:2) + wxdsic(1:nnrx,1:2) - ! - ! ths sic potential is partly updated here to save some memory - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + wrefsic(1:nnrx) & - - wxdsic( 1:nnrx, ispin(i) ) - ! - endif - ! - ! compute nkpz pieces to build the potential and the energy - ! - if ( do_nkpz ) then - ! - call nksic_correction_nkpz( focc, orb_rhor(:,jj), vsicpz, & - wrefsic, pinkpz, ibnd, ispin(i)) - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + vsicpz(1:nnrx) & - + wrefsic(1:nnrx) - ! - pink(i) = pink(i) +pinkpz - ! - endif - ! - ! compute pz potentials and energy - ! - if ( do_pz ) then - ! - call nksic_correction_pz ( focc, ispin(i), orb_rhor(:,jj), & - vsic(:,i), pink(i), pzalpha(i), ibnd, shart ) - ! - wfc_spreads(ibnd, ispin(i), 2) = shart - ! - if (do_pz_renorm) then - ! - do ir=1,nnrx - ! - edens(ir,ispin(i)) = edens(ir,ispin(i)) + pink(i)*(orb_rhor(ir,jj)+epsi2)**(kfact+1.) - ! - enddo - ! - endif - ! - endif - ! - ! compute nki pieces to build the potentials and the energy - ! - if ( do_nki .or. do_nkipz) then - ! - call nksic_correction_nki( focc, ispin(i), orb_rhor(:,jj), & - rhor, rhoref, rhobar, rhobarg, grhobar, & - vsic(:,i), wxdsic, do_wxd_, pink(i), ibnd, shart, is_empty_) - ! - ! here information is accumulated over states - ! (wtot is added in the next loop) - ! - wtot(1:nnrx,1:2) = wtot(1:nnrx,1:2) + wxdsic(1:nnrx,1:2) - ! - ! ths sic potential is partly updated here to save some memory - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) - wxdsic( 1:nnrx, ispin(i) ) - ! - wfc_spreads(ibnd, ispin(i), 2) = shart - ! - endif - - if ( do_nkipz ) then - ! - call nksic_correction_nkipz( focc, ispin(i), orb_rhor(:,jj), vsicpz, & - pinkpz, ibnd, shart, is_empty_ ) - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + vsicpz(1:nnrx) - ! - pink(i) = pink(i) + pinkpz - ! - wfc_spreads(ibnd, ispin(i), 2) = shart - ! - endif - ! - ! take care of spin symmetry - ! - if (.not.do_pz_renorm) then - ! - if (.not.is_empty_) then - ! - pink(i) = 2.d0 * pink(i)/nspin - ! - else - ! - pink(i) = 2.d0 * pink(i)/nspin - ! - endif - ! - endif - ! - if ( do_nk .or. do_nkpz .or. do_nki .or. do_nkipz) then - ! - if ( nspin== 1 ) then - ! - wtot(1:nnrx,1) = wtot(1:nnrx,1) + wxdsic(1:nnrx,2) - ! - wtot(1:nnrx,2) = wtot(1:nnrx,2) + wxdsic(1:nnrx,1) - ! - endif - ! - endif - ! - enddo inner_loop - ! - enddo - ! - ! Switch off the icompute_spread flag if present - ! - IF(icompute_spread) THEN - ! - icompute_spread=.false. - ! - ENDIF - ! - ! now wtot is completely built and can be added to vsic - ! - if ( do_nk .or. do_nkpz .or. do_nki .or. do_nkipz ) then - ! - do i = 1, nbsp - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + wtot( 1:nnrx, ispin(i) ) - ! - enddo - ! - endif - ! - ! computing orbital dependent alpha - ! - if ( odd_nkscalfact ) then - ! - do j=1,nbsp,2 - ! - inner_loop_odd_alpha: do jj=1,2 - ! - i=j+jj-1 - ! - if ( i > nbsp ) exit inner_loop_odd_alpha - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i)*odd_alpha(i)/nkscalfact - ! - valpsi(i,:) = valpsi(i,:) * pink(i)/nkscalfact - ! - pink(i) = pink(i)*odd_alpha(i)/nkscalfact - ! - enddo inner_loop_odd_alpha - ! - enddo - ! - endif - ! - if ( do_pz_renorm ) then - ! - do j=1,nbsp,2 - ! - call nksic_get_orbitalrho( ngw, nnrx, bec, ispin, nbsp, & - c(:,j), c(:,j+1), orb_rhor, j, j+1, lgam) - ! - inner_loop_renorm: do jj=1,2 - ! - i=j+jj-1 - ! - if ( i > nbsp ) exit inner_loop_renorm - ! - ibnd=i - ! - focc=f_diag(i)*DBLE(nspin)/2.0d0 - ! - if ( nspin==2 ) then - ! - if ( i >= iupdwn(2) ) ibnd=i-iupdwn(2)+1 - ! - endif - ! - call nksic_get_pz_factor( nspin, ispin(i), orb_rhor(:,jj), rhor,& - taukin, tauw, pzalpha(i), ibnd, kfact) - ! - ! - ! update vsic with factor here: it works for pz, will it work for - ! nk-type functionals? - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i)*pzalpha(i) - ! - call nksic_get_pzfactor_potential(focc, nspin, ispin(i), rhor, orb_rhor(:,jj), & - pink(i), taukin, tauw, edens, upsilonkin, upsilonw, vsic(:,i), pzalpha(i), ibnd, kfact) - ! - pink(i) = pink(i)*pzalpha(i) - ! - if (.not.is_empty_) then - ! - pink(i) = f_diag(i) * pink(i) - ! - else - ! - pink(i) = 2.d0* pink(i)/nspin - ! - endif - ! - enddo inner_loop_renorm - ! - enddo - ! - endif - ! - if (draw_pot) then !added:linh draw vsic potentials - ! - write(stdout,*) "I am writing out vsic", nbsp - ! - do i =1, nbsp - ! - if (i == pot_number) call write_pot_sic ( vsic(:, i) ) - ! - enddo - ! - endif !added:linh draw vsic potentials - ! - if ( allocated(vsicpz) ) deallocate(vsicpz) - ! - ! USPP: - ! compute corrections to the D coefficients of the pseudopots - ! due to vsic(r, i) in the case of orbital dependent functionals. - ! The corresponding contributions to the forces are computed. - ! - ! IMPORTANT: the following call makes use of newd. - ! It must be done before we call newd for the - ! total potentials, because deeq is overwritten at every call - ! - fion_sic(:,:) = 0.0d0 - ! - IF ( nhm > 0 ) then - ! - deeq_sic(:,:,:,:) = 0.0d0 - ! - DO i = 1, nbsp - ! - CALL nksic_newd( i, nnrx, ispin(i), nspin, vsic(:,i), nat, nhm, & - becsum, fion_sic, deeq_sic(:,:,:,i) ) !this is for ultrasoft! watch out! warning:giovanni this has to be modified in order to run ultrasoft - ! - ENDDO - ! - ENDIF - ! - deallocate(rhobarg) - ! - if (nlcc_any) then - ! - rhor(:,:)=rhor_nocc(:,:) - deallocate(rhor_nocc) - ! - endif - ! - CALL stop_clock( 'nksic_drv' ) - return - ! -!----------------------------------------------------------------------- - end subroutine nksic_potential -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_get_orbitalrho_real( ngw, nnrx, bec, ispin, nbsp, & - c1, c2, orb_rhor, i1, i2 ) -!----------------------------------------------------------------------- -! -! Computes orbital densities on the real (not smooth) grid -! - use kinds, only: dp - use constants, only: ci - use cp_interfaces, only: fwfft, invfft, calrhovan - use fft_base, only: dffts, dfftp - use cell_base, only: omega - use gvecp, only: ngm - use gvecs, only: ngs, nps, nms - use recvecs_indexes, only: np, nm - use smooth_grid_dimensions, only: nnrsx - use cp_main_variables, only: irb,eigrb - use uspp_param, only: nhm - use electrons_base, only: nspin - use ions_base, only: nat - use uspp, only: okvan, nkb - ! - implicit none - - ! - ! input/output vars - ! - integer, intent(in) :: ngw,nnrx,i1,i2 - integer, intent(in) :: nbsp, ispin(nbsp) - real(dp), intent(in) :: bec(nkb, nbsp) - complex(dp), intent(in) :: c1(ngw),c2(ngw) - real(dp), intent(out) :: orb_rhor(nnrx,2) - - ! - ! local vars - ! - character(20) :: subname='nksic_get_orbitalrho' - integer :: ir, ig, ierr - real(dp) :: sa1 - complex(dp) :: fm, fp - complex(dp), allocatable :: psis(:), psi(:) - complex(dp), allocatable :: orb_rhog(:,:) - real(dp), allocatable :: orb_rhos(:) - real(dp), allocatable :: rhovan(:,:,:) - real(dp), allocatable :: rhovanaux(:,:,:) - ! - !==================== - ! main body - !==================== - ! - call start_clock( 'nk_orbrho' ) - - ! - if ( okvan ) then - ! - allocate(rhovan(nhm*(nhm+1)/2,nat,nspin), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating rhovan',abs(ierr)) - allocate(rhovanaux(nhm*(nhm+1)/2,nat,nspin), stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating rhovanaux',abs(ierr)) - ! - endif - ! - allocate(psi(nnrx),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating psi',abs(ierr)) - ! - allocate(orb_rhog(ngm,2),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating orb_rhog',abs(ierr)) - - sa1 = 1.0d0 / omega - - - ! - ! check whether it is necessary to - ! deal with the smooth and dense grids separately - ! - if ( nnrsx == nnrx ) then - ! - ! This case should be the case when using NCPP - ! - CALL c2psi( psi, nnrx, c1, c2, ngw, 2 ) - ! - !CALL invfft('Wave', psi, dffts ) - CALL invfft('Dense', psi, dfftp ) - ! - ! computing the orbital charge in real space on the full grid - ! - do ir = 1, nnrx - ! - orb_rhor(ir,1) = sa1 * ( DBLE(psi(ir)) )**2 - orb_rhor(ir,2) = sa1 * ( AIMAG(psi(ir)) )**2 - ! - enddo - ! - else - ! - ! this is the general case, - ! normally used with USPP - ! - allocate( psis(nnrsx), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating psis',abs(ierr)) - allocate( orb_rhos(2), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating orb_rhos',abs(ierr)) - ! - CALL c2psi( psis, nnrsx, c1, c2, ngw, 2 ) - ! - CALL invfft('Wave',psis, dffts ) - ! - ! computing the orbital charge - ! in real space on the smooth grid - ! - do ir = 1, nnrsx - ! - orb_rhos(1) = sa1 * ( DBLE(psis(ir)) )**2 - orb_rhos(2) = sa1 * ( AIMAG(psis(ir)) )**2 - ! - psis( ir ) = CMPLX( orb_rhos(1), orb_rhos(2) ) - enddo - ! - ! orbital charges are taken to the G space - ! - CALL fwfft('Smooth',psis, dffts ) - ! - do ig = 1, ngs - ! - fp=psis(nps(ig))+psis(nms(ig)) - fm=psis(nps(ig))-psis(nms(ig)) - orb_rhog(ig,1)=0.5d0*CMPLX(DBLE(fp),AIMAG(fm)) - orb_rhog(ig,2)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - ! - enddo - ! - psi (:) = (0.d0, 0.d0) - do ig=1,ngs - ! - psi(nm(ig)) = CONJG(orb_rhog(ig,1)) +ci*CONJG(orb_rhog(ig,2)) - psi(np(ig)) = orb_rhog(ig,1) +ci*orb_rhog(ig,2) - ! - enddo - ! - call invfft('Dense',psi,dfftp) - ! - do ir=1,nnrx - ! - orb_rhor(ir,1) = DBLE(psi(ir)) - orb_rhor(ir,2) = AIMAG(psi(ir)) - enddo - - deallocate( psis ) - deallocate( orb_rhos ) - - endif - - ! - ! add Vanderbilt contribution to orbital density - ! - if( okvan ) then - ! - rhovan(:,:,:) = 0.0d0 - ! - if ( nspin == 2 ) then - ! - if ( i1 <= nbsp ) then - call calrhovan(rhovanaux,bec,i1) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i1)) - endif - ! - if ( i2 <= nbsp ) then - call calrhovan(rhovanaux,bec,i2) - rhovan(:,:,2)=rhovanaux(:,:,ispin(i2)) - endif - ! - call rhov(irb,eigrb,rhovan,orb_rhog,orb_rhor, .true.) - else - ! - if ( i1 <= nbsp ) then - call calrhovan(rhovanaux,bec,i1) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i1))*0.5d0 ! 1/2 factor since rhovanaux is counted twice in the case nspin=2 - ! - call rhov(irb,eigrb,rhovan,orb_rhog(:,1),orb_rhor(:,1), .true.) - ! - endif - ! - if ( i2 <= nbsp ) then - call calrhovan(rhovanaux,bec,i2) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i2))*0.5d0 ! 1/2 factor since rhovanaux is counted twice in the case nspin=2 - ! - call rhov(irb,eigrb,rhovan,orb_rhog(:,2),orb_rhor(:,2), .true.) - ! - endif - ! - endif - ! - endif - ! - deallocate(psi) - deallocate(orb_rhog) - ! - if ( okvan ) then - deallocate(rhovan) - deallocate(rhovanaux) - endif - ! - call stop_clock('nk_orbrho') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_get_orbitalrho_real -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_get_orbitalrho_twin_non_ortho( ngw, nnrx, bec, becdual, ispin, nbsp, & - c1, c2, c1dual, c2dual,orb_rhor, i1, i2, lgam) -!----------------------------------------------------------------------- -! -! Computes orbital densities on the real (not smooth) grid -! - use kinds, only: dp - use constants, only: ci - use cp_interfaces, only: fwfft, invfft, calrhovan - use fft_base, only: dffts, dfftp - use cell_base, only: omega - use gvecp, only: ngm - use gvecs, only: ngs, nps, nms - use recvecs_indexes, only: np, nm - use smooth_grid_dimensions, only: nnrsx - use cp_main_variables, only: irb,eigrb - use uspp_param, only: nhm - use electrons_base, only: nspin - use ions_base, only: nat - use uspp, only: okvan, nkb - use twin_types - ! - implicit none - - ! - ! input/output vars - ! - integer, intent(in) :: ngw,nnrx,i1,i2 - integer, intent(in) :: nbsp, ispin(nbsp) - type(twin_matrix) :: bec, becdual !(nkb, nbsp) - complex(dp), intent(in) :: c1(ngw),c2(ngw), c1dual(ngw), c2dual(ngw) - real(dp), intent(out) :: orb_rhor(nnrx,2) - logical :: lgam - ! - ! local vars - ! - character(20) :: subname='nksic_get_orbitalrho' - integer :: ir, ig, ierr - real(dp) :: sa1 - complex(dp) :: fm, fp - complex(dp), allocatable :: psis1(:), psis2(:), psi1(:), psi2(:), & - psi1d(:), psi2d(:) - complex(dp), allocatable :: orb_rhog(:,:) - real(dp), allocatable :: orb_rhos(:) - real(dp), allocatable :: rhovan(:,:,:) - real(dp), allocatable :: rhovanaux(:,:,:) - ! - !==================== - ! main body - !==================== - ! - call start_clock( 'nksic_orbrho' ) - - ! - if ( okvan ) then - ! - allocate(rhovan(nhm*(nhm+1)/2,nat,nspin), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating rhovan',abs(ierr)) - allocate(rhovanaux(nhm*(nhm+1)/2,nat,nspin), stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating rhovanaux',abs(ierr)) - ! - endif - ! - allocate(psi1(nnrx),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating psi1',abs(ierr)) - - allocate(psi1d(nnrx),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating psi1d',abs(ierr)) - - ! - if(.not.lgam) then - allocate(psi2(nnrx),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating psi2',abs(ierr)) - allocate(psi2d(nnrx),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating psi2d',abs(ierr)) - endif - ! - allocate(orb_rhog(ngm,2),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating orb_rhog',abs(ierr)) - sa1 = 1.0d0 / omega - ! - ! check whether it is necessary to - ! deal with the smooth and dense grids separately - ! - if ( nnrsx == nnrx ) then - ! - ! This case should be the one when using NCPP - ! - if(lgam) then - CALL c2psi( psi1, nnrx, c1, c2, ngw, 2 ) - CALL c2psi(psi1d, nnrx, c1dual, c2dual, ngw, 2) - else - CALL c2psi( psi1, nnrx, c1, c2, ngw, 0 ) - CALL c2psi( psi2, nnrx, c2, c1, ngw, 0 ) - CALL c2psi(psi1d, nnrx, c1dual, c2dual, ngw, 0) - CALL c2psi(psi2d, nnrx, c2dual, c1dual, ngw, 0) - endif - ! - CALL invfft('Dense', psi1, dfftp ) - CALL invfft('Dense', psi1d, dfftp ) - ! - ! - if(.not.lgam) then - CALL invfft('Dense', psi2, dfftp ) - CALL invfft('Dense', psi2d, dfftp ) - endif - ! - ! computing the orbital charge in real space on the full grid - ! - if(lgam) then - do ir = 1, nnrx - ! - orb_rhor(ir,1) = sa1*DBLE(psi1(ir))*DBLE(psi1d(ir)) - orb_rhor(ir,2) = sa1*AIMAG(psi1(ir))*AIMAG(psi1d(ir)) - ! - enddo - else - do ir = 1, nnrx - ! - orb_rhor(ir,1) = sa1*DBLE(CONJG(psi1d(ir))*psi1(ir)) - orb_rhor(ir,2) = sa1*DBLE(CONJG(psi2d(ir))*psi2(ir)) - ! - enddo - endif - ! - else - ! - ! this is the general case, - ! normally used with USPP - ! - - allocate( psis1(nnrsx), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating psis1',abs(ierr)) - if(.not.lgam) then - allocate( psis2(nnrsx), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating psis2',abs(ierr)) - endif - - allocate( orb_rhos(2), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating orb_rhos',abs(ierr)) - ! - if(lgam) then - CALL c2psi( psis1, nnrsx, c1, c2, ngw, 2 ) - else - CALL c2psi( psis1, nnrsx, c1, c2, ngw, 0 ) - CALL c2psi( psis2, nnrsx, c2, c1, ngw, 0 ) - endif - ! - - CALL invfft('Wave',psis1, dffts ) - ! - if(.not. lgam) then - CALL invfft('Wave',psis2, dffts ) - endif - ! - ! computing the orbital charge - ! in real space on the smooth grid - ! - if(lgam) then - do ir = 1, nnrsx - ! - orb_rhos(1) = sa1 * (( DBLE(psis1(ir)) )**2 ) - orb_rhos(2) = sa1 * (( AIMAG(psis1(ir)) )**2 ) - ! - psis1( ir ) = CMPLX( orb_rhos(1), orb_rhos(2) ) - enddo - else - do ir = 1, nnrsx - ! - orb_rhos(1) = sa1 * (( DBLE(psis1(ir)) )**2 +( AIMAG(psis1(ir)) )**2) - orb_rhos(2) = sa1 * (( DBLE(psis2(ir)) )**2 +( AIMAG(psis2(ir)) )**2) - ! - psis1( ir ) = CMPLX(orb_rhos(1), orb_rhos(2)) !!!### comment for k points -! psis1( ir ) = cmplx( orb_rhos(1), 0.d0) !!!### uncomment for k points -! psis2( ir ) = cmplx( orb_rhos(2), 0.d0) !!!### uncomment for k points - enddo - endif -! write(6,*) "psis", psis1 !added:giovanni:debug - ! - ! orbital charges are taken to the G space - ! - - CALL fwfft('Smooth',psis1, dffts ) -! IF(.not.lgam) THEN ! !!!### uncomment for k points -! CALL fwfft('Smooth',psis2, dffts ) !!!### uncomment for k points -! ENDIF !!!### uncomment for k points - ! -! IF(lgam) then !!!### uncomment for k points - do ig = 1, ngs - ! - fp=psis1(nps(ig))+psis1(nms(ig)) - fm=psis1(nps(ig))-psis1(nms(ig)) - orb_rhog(ig,1)=0.5d0*CMPLX(DBLE(fp),AIMAG(fm)) - orb_rhog(ig,2)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - ! - enddo -! else !!!### uncomment for k points -! do ig = 1, ngs !!!### uncomment for k points - ! -! fp=psis1(nps(ig)) !!!### uncomment for k points -! fm=psis2(nps(ig)) !!!### uncomment for k points -! orb_rhog(ig,1)=fp !!!### uncomment for k points -! orb_rhog(ig,2)=fm !!!### uncomment for k points - ! -! enddo !!!### uncomment for k points -! endif !!!### uncomment for k points - ! - psi1 (:) = CMPLX(0.d0, 0.d0) -! if(lgam) then !!!### uncomment for k points - do ig=1,ngs - ! - psi1(nm(ig)) = CONJG( orb_rhog(ig,1) ) & - +ci*CONJG( orb_rhog(ig,2) ) - psi1(np(ig)) = orb_rhog(ig,1) +ci*orb_rhog(ig,2) - ! - enddo -! else !!!### uncomment for k points -! do ig=1,ngs !!!### uncomment for k points - ! -! psi1(nm(ig)) = conjg( orb_rhog(ig,1) ) & -! +ci*conjg( orb_rhog(ig,2) ) -! psi1(np(ig)) = orb_rhog(ig,1) +ci*orb_rhog(ig,2) !!!### uncomment for k points - ! -! enddo !!!### uncomment for k points -! endif !!!### uncomment for k points - ! - call invfft('Dense',psi1,dfftp) - ! - do ir=1,nnrx - ! - orb_rhor(ir,1) = DBLE(psi1(ir)) - orb_rhor(ir,2) = AIMAG(psi1(ir)) - enddo - - deallocate( psis1 ) - if(.not.lgam) then - deallocate(psis2) - endif - - deallocate( orb_rhos ) - - endif -! write(6,*) "orb_rhog", orb_rhog !added:giovanni:debug - ! - ! add Vanderbilt contribution to orbital density - ! - if( okvan ) then - ! - rhovan(:,:,:) = 0.0d0 - ! - if ( nspin == 2 ) then - ! - if ( i1 <= nbsp ) then - call calrhovan(rhovanaux,bec,i1) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i1)) - endif - ! - if ( i2 <= nbsp ) then - call calrhovan(rhovanaux,bec,i2) - rhovan(:,:,2)=rhovanaux(:,:,ispin(i2)) - endif - ! - call rhov(irb,eigrb,rhovan,orb_rhog,orb_rhor, lgam) - else - ! - if ( i1 <= nbsp ) then - call calrhovan(rhovanaux,bec,i1) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i1)) - ! - call rhov(irb,eigrb,rhovan,orb_rhog(:,1),orb_rhor(:,1), lgam) - endif - ! - if ( i2 <= nbsp ) then - call calrhovan(rhovanaux,bec,i2) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i2)) - ! - call rhov(irb,eigrb,rhovan,orb_rhog(:,2),orb_rhor(:,2), lgam) - endif - ! - endif - ! - endif - ! -! write(6,*) "rhovan", rhovan(:,:,1) !added:giovanni:debug -! stop - deallocate(psi1) - if(allocated(psi2)) then - deallocate(psi2) - endif - if(allocated(psi1d)) then - deallocate(psi1d) - endif - if(allocated(psi2d)) then - deallocate(psi2d) - endif - - deallocate(orb_rhog) - ! - if ( okvan ) then - deallocate(rhovan) - deallocate(rhovanaux) - endif - ! - do ir=1,nnrx - if(orb_rhor(ir,1).lt.-1.d-3.or. orb_rhor(ir,2).lt.-1.d-3) then - write(6,*) "warning, negative density", orb_rhor(ir,1), orb_rhor(ir,2) - endif - enddo - ! - call stop_clock('nksic_orbrho') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_get_orbitalrho_twin_non_ortho -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_get_orbitalrho_twin( ngw, nnrx, bec, ispin, nbsp, & - c1, c2, orb_rhor, i1, i2, lgam) -!----------------------------------------------------------------------- -! -! Computes orbital densities on the real (not smooth) grid -! - use kinds, only: dp - use constants, only: ci - use cp_interfaces, only: fwfft, invfft, calrhovan - use fft_base, only: dffts, dfftp - use cell_base, only: omega - use gvecp, only: ngm - use gvecs, only: ngs, nps, nms - use recvecs_indexes, only: np, nm - use smooth_grid_dimensions, only: nnrsx - use cp_main_variables, only: irb,eigrb - use uspp_param, only: nhm - use electrons_base, only: nspin - use ions_base, only: nat - use uspp, only: okvan, nkb - use twin_types - ! - implicit none - ! - ! input/output vars - ! - integer, intent(in) :: ngw,nnrx,i1,i2 - integer, intent(in) :: nbsp, ispin(nbsp) - type(twin_matrix) :: bec !(nkb, nbsp) - complex(dp), intent(in) :: c1(ngw),c2(ngw) - real(dp), intent(out) :: orb_rhor(nnrx,2) - logical :: lgam - ! - ! local vars - ! - character(20) :: subname='nksic_get_orbitalrho' - integer :: ir, ig, ierr - real(dp) :: sa1 - complex(dp) :: fm, fp - complex(dp), allocatable :: psis1(:), psis2(:), psi1(:), psi2(:), & - psi1d(:), psi2d(:) - complex(dp), allocatable :: orb_rhog(:,:) - real(dp), allocatable :: orb_rhos(:) - real(dp), allocatable :: rhovan(:,:,:) - real(dp), allocatable :: rhovanaux(:,:,:) - ! - !==================== - ! main body - !==================== - ! - call start_clock( 'nksic_orbrho' ) - - ! - if ( okvan ) then - ! - allocate(rhovan(nhm*(nhm+1)/2,nat,nspin), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating rhovan',abs(ierr)) - allocate(rhovanaux(nhm*(nhm+1)/2,nat,nspin), stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating rhovanaux',abs(ierr)) - ! - endif - ! - allocate(psi1(nnrx),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating psi1',abs(ierr)) - ! - if(.not.lgam) then - allocate(psi2(nnrx),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating psi2',abs(ierr)) - endif - ! - allocate(orb_rhog(ngm,2),stat=ierr) - if ( ierr/=0 ) call errore(subname,'allocating orb_rhog',abs(ierr)) - - sa1 = 1.0d0 / omega - ! - ! check whether it is necessary to - ! deal with the smooth and dense grids separately - ! - if ( nnrsx == nnrx ) then - ! - ! This case should be the one when using NCPP - ! - if(lgam) then - CALL c2psi( psi1, nnrx, c1, c2, ngw, 2 ) - else - CALL c2psi( psi1, nnrx, c1, c2, ngw, 0 ) - CALL c2psi( psi2, nnrx, c2, c1, ngw, 0 ) - endif - ! - CALL invfft('Dense', psi1, dfftp ) - ! - if(.not.lgam) then - CALL invfft('Dense', psi2, dfftp ) - endif - ! - ! computing the orbital charge in real space on the full grid - ! - if(lgam) then - ! - do ir = 1, nnrx - ! - orb_rhor(ir,1) = sa1 * (( DBLE(psi1(ir)) )**2 ) - orb_rhor(ir,2) = sa1 * (( AIMAG(psi1(ir)) )**2 ) - ! - enddo - ! - else - ! - do ir = 1, nnrx - ! - orb_rhor(ir,1) = sa1 * (( abs(psi1(ir)) ))**2 - orb_rhor(ir,2) = sa1 * (( abs(psi2(ir)) ))**2 - ! - enddo - ! - endif - ! - else - ! - ! this is the general case, - ! normally used with USPP - ! - - allocate( psis1(nnrsx), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating psis1',abs(ierr)) - if(.not.lgam) then - ! - allocate( psis2(nnrsx), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating psis2',abs(ierr)) - ! - endif - ! - allocate( orb_rhos(2), stat=ierr ) - ! - if ( ierr/=0 ) call errore(subname,'allocating orb_rhos',abs(ierr)) - ! - if(lgam) then - ! - CALL c2psi( psis1, nnrsx, c1, c2, ngw, 2 ) - ! - else - ! - CALL c2psi( psis1, nnrsx, c1, c2, ngw, 0 ) - CALL c2psi( psis2, nnrsx, c2, c1, ngw, 0 ) - ! - endif - ! - CALL invfft('Wave',psis1, dffts ) - ! - if(.not. lgam) then - ! - CALL invfft('Wave',psis2, dffts ) - ! - endif - ! - ! computing the orbital charge - ! in real space on the smooth grid - ! - if(lgam) then - ! - do ir = 1, nnrsx - ! - orb_rhos(1) = sa1 * (( DBLE(psis1(ir)) )**2 ) - orb_rhos(2) = sa1 * (( AIMAG(psis1(ir)) )**2 ) - ! - psis1( ir ) = CMPLX( orb_rhos(1), orb_rhos(2) ) - ! - enddo - ! - else - ! - do ir = 1, nnrsx - ! - orb_rhos(1) = sa1 * ( abs(psis1(ir)))**2 - orb_rhos(2) = sa1 * ( abs(psis2(ir)))**2 - ! - psis1( ir ) = CMPLX(orb_rhos(1), orb_rhos(2)) !!!### comment for k points - !psis1( ir ) = cmplx( orb_rhos(1), 0.d0) !!!### uncomment for k points - !psis2( ir ) = cmplx( orb_rhos(2), 0.d0) !!!### uncomment for k points - enddo - ! - endif -! write(6,*) "psis", psis1 !added:giovanni:debug - ! - ! orbital charges are taken to the G space - ! - - CALL fwfft('Smooth',psis1, dffts ) -! IF(.not.lgam) THEN ! !!!### uncomment for k points -! CALL fwfft('Smooth',psis2, dffts ) !!!### uncomment for k points -! ENDIF !!!### uncomment for k points - ! -! IF(lgam) then !!!### uncomment for k points - do ig = 1, ngs - ! - fp=psis1(nps(ig))+psis1(nms(ig)) - fm=psis1(nps(ig))-psis1(nms(ig)) - orb_rhog(ig,1)=0.5d0*CMPLX(DBLE(fp),AIMAG(fm)) - orb_rhog(ig,2)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - ! - enddo -! else !!!### uncomment for k points -! do ig = 1, ngs !!!### uncomment for k points - ! -! fp=psis1(nps(ig)) !!!### uncomment for k points -! fm=psis2(nps(ig)) !!!### uncomment for k points -! orb_rhog(ig,1)=fp !!!### uncomment for k points -! orb_rhog(ig,2)=fm !!!### uncomment for k points - ! -! enddo !!!### uncomment for k points -! endif !!!### uncomment for k points - ! - psi1 = CMPLX(0.d0, 0.d0) -! if(lgam) then !!!### uncomment for k points - do ig=1,ngs - ! - psi1(nm(ig)) = CONJG( orb_rhog(ig,1) ) & - +ci*CONJG( orb_rhog(ig,2) ) - psi1(np(ig)) = orb_rhog(ig,1) +ci*orb_rhog(ig,2) - ! - enddo -! else !!!### uncomment for k points -! do ig=1,ngs !!!### uncomment for k points - ! -! psi1(nm(ig)) = conjg( orb_rhog(ig,1) ) & -! +ci*conjg( orb_rhog(ig,2) ) -! psi1(np(ig)) = orb_rhog(ig,1) +ci*orb_rhog(ig,2) !!!### uncomment for k points - ! -! enddo !!!### uncomment for k points -! endif !!!### uncomment for k points - ! - call invfft('Dense',psi1,dfftp) - ! - do ir=1,nnrx - ! - orb_rhor(ir,1) = DBLE(psi1(ir)) - orb_rhor(ir,2) = AIMAG(psi1(ir)) - ! - enddo - - deallocate( psis1 ) - - if(.not.lgam) then - ! - deallocate(psis2) - ! - endif - - deallocate( orb_rhos ) - - endif -! write(6,*) "orb_rhog", orb_rhog !added:giovanni:debug - ! - ! add Vanderbilt contribution to orbital density - ! - if( okvan ) then - ! - rhovan(:,:,:) = 0.0d0 - ! - if ( nspin == 2 ) then - ! - if ( i1 <= nbsp ) then - ! - call calrhovan(rhovanaux,bec,i1) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i1)) - ! - endif - ! - if ( i2 <= nbsp ) then - ! - call calrhovan(rhovanaux,bec,i2) - rhovan(:,:,2)=rhovanaux(:,:,ispin(i2)) - ! - endif - ! - call rhov(irb,eigrb,rhovan,orb_rhog,orb_rhor, lgam) - ! - else - ! - if ( i1 <= nbsp ) then - ! - call calrhovan(rhovanaux,bec,i1) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i1)) ! 0.5 to divide the factor f=2 which accounts for spin multiplicity inside calrhovan - ! - write(6,*) "calling rhov inside nksic_get_orbitalrho" - call rhov(irb,eigrb,rhovan,orb_rhog(:,1),orb_rhor(:,1), lgam) !JUST-FOR-NOW ... do we need a factor of 0.5? - ! - endif - ! - if ( i2 <= nbsp ) then - ! - call calrhovan(rhovanaux,bec,i2) - rhovan(:,:,1)=rhovanaux(:,:,ispin(i2)) ! 0.5 to divide the factor f=2 which accounts for spin multiplicity inside calrhovan - ! - call rhov(irb,eigrb,rhovan,orb_rhog(:,2),orb_rhor(:,2), lgam) !JUST-FOR-NOW ... do we need a factor of 0.5? - ! - endif - ! - endif - ! - endif - ! -! if(okvan) write(131,*) "rhovan-calrhovan", rhovan(:,:,1) !added:giovanni:debug -! stop - deallocate(psi1) - ! - if(allocated(psi2)) then - ! - deallocate(psi2) - ! - endif - - deallocate(orb_rhog) - ! - if ( okvan ) then - ! - deallocate(rhovan) - deallocate(rhovanaux) - ! - endif - ! - call stop_clock('nksic_orbrho') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_get_orbitalrho_twin -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_get_rhoref( i, nnrx, ispin, nspin, f, & - rhor, orb_rhor, & - rhoref_, rhobar_,rhobarg, grhobar_) -!----------------------------------------------------------------------- -! -! Computes rhoref and rhobar -! - use kinds, only : dp - use gvecp, only : ngm - use funct, only : dft_is_gradient - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use recvecs_indexes, only : np, nm - use nksic, only : fref, rhobarfact - use control_flags, only : gamma_only, do_wf_cmplx - ! - implicit none - - ! - ! input/output vars - ! - integer, intent(in) :: i, nnrx - integer, intent(in) :: ispin, nspin - real(dp), intent(in) :: f - real(dp), intent(in) :: rhor(nnrx,nspin) - real(dp), intent(in) :: orb_rhor(nnrx) - real(dp), intent(out) :: rhoref_(nnrx,2) - real(dp), intent(out) :: rhobar_(nnrx,2) - complex(dp) :: rhobarg(ngm,2) - real(dp), intent(out) :: grhobar_(nnrx,3,2) - ! - integer :: ig - complex(dp) :: fp, fm - complex(dp), allocatable :: psi(:) - logical :: lgam - - ! - ! main body - ! - call start_clock( 'nksic_get_rhoref' ) - - lgam=gamma_only.and..not.do_wf_cmplx - !write(6,*) ubound(rhobarg) - !write(6,*) ubound(grhobar_) - - ! - ! define rhobar_i = rho - f_i * rho_i - ! - if ( nspin == 1 ) then - rhobar_(:,1) = rhor(:,1) * 0.5_dp - rhobar_(:,2) = rhor(:,1) * 0.5_dp - else - rhobar_(:,1:2) = rhor(:,1:2) - endif - ! - rhobar_(:,ispin) = rhobar_(:,ispin) -f * orb_rhor(:) - ! - ! probably obsolete - if ( rhobarfact < 1.0d0 ) then - rhobar_ = rhobar_ * rhobarfact - endif - - ! - ! define rhoref = rho + (f_ref -f_i) rho_i = rhobar_i + f_ref * rho_i - ! build rhoref from scratch - ! - rhoref_(:,1:2) = rhobar_(:,1:2) - rhoref_(:,ispin) = rhoref_(:,ispin) + fref * orb_rhor(:) - ! - - ! - ! compute the gradient of rhobar if needed - ! - if ( dft_is_gradient() ) then - ! - ! allocate( rhobarg(ngm,2) ) modified:giovanni rhobarg became an argument of the subroutine - allocate( psi(nnrx) ) - ! - psi(:) = CMPLX ( rhobar_(:,1), rhobar_(:,2) ) - ! - call fwfft('Dense',psi,dfftp ) - ! - do ig=1,ngm - fp = psi( np(ig) ) +psi( nm(ig) ) - fm = psi( np(ig) ) -psi( nm(ig) ) - ! - rhobarg(ig,1) = 0.5d0 *CMPLX( DBLE(fp),AIMAG(fm)) - rhobarg(ig,2) = 0.5d0 *CMPLX(AIMAG(fp),-DBLE(fm)) - enddo - ! - call fillgrad( 2, rhobarg, grhobar_, lgam ) - ! - deallocate( psi ) - ! - endif - ! - call stop_clock( 'nksic_get_rhoref' ) - return - ! -!--------------------------------------------------------------- -end subroutine nksic_get_rhoref -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_newd( i, nnrx, ispin, nspin, vsic, nat, nhm, & - becsum, fion, deeq_sic ) -!----------------------------------------------------------------------- -! -! computes the deeq coefficients (contributions to the D coeff of USPP) -! for the given orbital i. Coefficients are sotred in deeq_sic -! - use kinds, only : dp - use uspp, only : okvan, deeq - use cp_main_variables, only : irb, eigrb - ! - implicit none - - ! - ! input/output vars - ! - integer, intent(in) :: i, nnrx, nat, nhm - integer, intent(in) :: ispin, nspin - real(dp), intent(in) :: vsic(nnrx) - real(dp), intent(in) :: becsum(nhm*(nhm+1)/2,nat,nspin) - real(dp), intent(inout) :: fion(3,nat) - real(dp), intent(out) :: deeq_sic(nhm,nhm,nat) - ! - ! local vars - ! - real(dp), allocatable :: vsic_aux(:,:) - - ! - ! main body - ! - if ( .not. okvan ) then - deeq_sic(:,:,:) = 0.0d0 - return - endif - ! - call start_clock( 'nk_newd' ) - ! - allocate( vsic_aux(nnrx,nspin) ) - - ! - ! fion are updated - ! deeq coefficients are overwritten - ! - vsic_aux = 0.0d0 - vsic_aux(:, ispin ) = vsic(:) - ! - call newd( vsic_aux, irb, eigrb, becsum, fion ) - ! - deeq_sic(:,:,:) = deeq(:,:,:,ispin) - - deallocate( vsic_aux ) - ! - call stop_clock( 'nk_newd' ) - return - ! -!--------------------------------------------------------------- -end subroutine nksic_newd -!--------------------------------------------------------------- - -!--------------------------------------------------------------- - subroutine nksic_correction_nk( f, ispin, orb_rhor, rhor, & - rhoref, rhobar, rhobarg, grhobar,& - vsic, wxdsic, wrefsic, do_wxd_,& - pink, ibnd, shart) -!--------------------------------------------------------------- -! -! ... calculate the non-Koopmans potential from the orbital density -! - use kinds, only : dp - use constants, only : e2, fpi, hartree_si, electronvolt_si - use cell_base, only : tpiba2,omega - use nksic, only : fref, rhobarfact, nknmax, & - vanishing_rho_w, & - nkscalfact, do_wref, & - etxc => etxc_sic, vxc => vxc_sic - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use eecp_mod, only : do_comp - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dmxc_spin, dft_is_gradient - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use electrons_base, only : nspin - use control_flags, only : gamma_only, do_wf_cmplx - ! - implicit none - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(in) :: rhor(nnrx,nspin) - real(dp), intent(in) :: rhoref(nnrx,2) - real(dp), intent(in) :: rhobar(nnrx,2) - complex(dp), intent(in) :: rhobarg(ngm,2) - real(dp), intent(in) :: grhobar(nnrx,3,2) - real(dp), intent(out) :: vsic(nnrx), wrefsic(nnrx) - real(dp), intent(out) :: wxdsic(nnrx,2) - logical, intent(in) :: do_wxd_ - real(dp), intent(out) :: pink - ! - !character(19) :: subname='nksic_correction_nk' - integer :: ig, ir - real(dp) :: fact, ehele, etmp - real(dp) :: etxcref, etxc0, w2cst - ! - real(dp), allocatable :: rhoele(:,:) - real(dp), allocatable :: rhoraux(:,:) - real(dp), allocatable :: vxc0(:,:) - real(dp), allocatable :: vxcref(:,:) - complex(dp), allocatable :: vhaux(:) - complex(dp), allocatable :: vcorr(:) - complex(dp), allocatable :: rhogaux(:,:) - complex(dp), allocatable :: vtmp(:) - ! - real(dp), allocatable :: grhoraux(:,:,:) - real(dp), allocatable :: orb_grhor(:,:,:) - complex(dp), allocatable :: orb_rhog(:,:) - real(dp), allocatable :: haux(:,:,:) - logical :: lgam !!added:giovanni - real(dp) :: icoeff - real(dp) :: dexc_dummy(3,3) - real(dp) :: shart - ! - !================== - ! main body - !================== - ! - lgam=gamma_only.and..not.do_wf_cmplx !added:giovanni - if(lgam) then - icoeff=2.d0 - else - icoeff=1.d0 - endif - - if( ibnd > nknmax .and. nknmax .ge. 0 ) return - ! - CALL start_clock( 'nk_corr' ) - CALL start_clock( 'nk_corr_h' ) - - ! - fact=omega/DBLE(nr1*nr2*nr3) - ! - allocate(rhoele(nnrx,2)) - allocate(rhogaux(ngm,2)) - allocate(orb_rhog(ngm,1)) - allocate(vtmp(ngm)) - allocate(vcorr(ngm)) - allocate(vhaux(nnrx)) - ! - rhoele=0.0d0 - rhoele(:,ispin) = orb_rhor(:) - ! - vsic=0.0_dp - wrefsic=0.0_dp - wxdsic=0.0_dp - pink=0.0_dp - - ! - ! Compute self-hartree contributions - ! - orb_rhog=0.0_dp - ! - ! rhoele has no occupation - ! - ! f-fref is NOT included here in vhaux - ! (will be added afterwards) - ! - vhaux=0.d0 - vhaux(:) = rhoele(:,ispin) - ! - call fwfft('Dense',vhaux,dfftp ) - ! - do ig=1,ngm - orb_rhog(ig,1) = vhaux( np(ig) ) - enddo - - ! - ! compute hartree-like potential - ! - if( gstart == 2 ) vtmp(1)=(0.d0,0.d0) - do ig=gstart,ngm - vtmp(ig) = orb_rhog(ig,1) * fpi/( tpiba2*g(ig) ) - enddo - ! - ! compute periodic corrections - ! - if( do_comp ) then - ! - call calc_compensation_potential( vcorr, orb_rhog(:,1),.true.) - vtmp(:) = vtmp(:) + vcorr(:) - ! - endif - - vhaux=0.0_dp -! IF(lgam) THEN !!!### uncomment for k points - do ig=1,ngm - ! - vhaux(np(ig)) = vtmp(ig) - vhaux(nm(ig)) = CONJG(vtmp(ig)) - ! - enddo -! ELSE !!!### uncomment for k points -! do ig=1,ngm !!!### uncomment for k points - ! -! vhaux(np(ig)) = vtmp(ig) !!!### uncomment for k points -! vhaux(nm(ig)) = conjg(vtmp(ig)) - ! -! enddo !!!### uncomment for k points -! ENDIF !!!### uncomment for k points - - call invfft('Dense',vhaux,dfftp) - ! - ! init here wref sic to save some memory - ! - ! this is just the self-hartree potential - ! (to be multiplied by fref later on) - ! - wrefsic(1:nnrx) = DBLE( vhaux(1:nnrx) ) - ! - ! self-hartree contrib to pink - ! and init vsic - ! - !ehele=0.5_dp * sum(dble(vhaux(1:nnrx))*rhoele(1:nnrx,ispin)) - ! - ehele = icoeff * DBLE ( DOT_PRODUCT( vtmp(1:ngm), orb_rhog(1:ngm,1))) - if ( gstart == 2 ) ehele = ehele + (1.d0-icoeff)*DBLE ( CONJG( vtmp(1) ) * orb_rhog(1,1) ) - ! - shart = 0.5_dp * ehele * omega * hartree_si/electronvolt_si - call mp_sum(shart, intra_image_comm) - - ! the f * (2.0d0 * fref-f) term is added here - ehele = 0.5_dp * f * (2.0_dp * fref-f) * ehele * omega / fact - !shart = 0.5_dp * ehele * omega / fact - - ! - ! fref-f has to be included explicitly in rhoele - ! - vsic(1:nnrx)=(fref-f)*DBLE(vhaux(1:nnrx)) - - deallocate(vtmp) - deallocate(vcorr) - deallocate(vhaux) - ! - CALL stop_clock( 'nk_corr_h' ) - - CALL start_clock( 'nk_corr_vxc' ) - ! - ! add self-xc contributions - ! - if ( dft_is_gradient() ) then - ! - allocate(grhoraux(nnrx,3,2)) - allocate(orb_grhor(nnrx,3,1)) - allocate(haux(nnrx,2,2)) - ! - ! compute the gradient of n_i(r) - call fillgrad( 1, orb_rhog, orb_grhor(:,:,1:1), lgam ) - ! - else - allocate(grhoraux(1,1,1)) - allocate(haux(1,1,1)) - grhoraux=0.0_dp - ! - endif - ! - ! - allocate(vxc0(nnrx,2)) - allocate(vxcref(nnrx,2)) - ! - etxcref=0.0_dp - vxcref=0.0_dp - ! - !rhoraux = rhoref - ! - if ( dft_is_gradient() ) then - ! - grhoraux(:,:,1:2) = grhobar(:,:,1:2) - grhoraux(:,:,ispin) = grhobar(:,:,ispin) & - + fref * orb_grhor(:,:,1) - ! - rhogaux(:,1:2) = rhobarg(:,1:2) - rhogaux(:,ispin) = rhobarg(:,ispin) + fref * orb_rhog(:,1) - - endif - ! - !call exch_corr_wrapper(nnrx,2,grhoraux,rhoref,etxcref,vxcref,haux) - vxcref=rhoref - CALL exch_corr_cp(nnrx, 2, grhoraux, vxcref, etxcref) !proposed:giovanni fixing PBE, warning, rhoref overwritten with vxcref, check array dimensions - !NB grhoaux(nnr,3,nspin)? yes; rhoref(nnr,nspin)? yes -!begin_added:giovanni fixing PBE potential - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc should be dexc(3,3), is lgam a variable here? - call gradh( 2, grhoraux, rhogaux, vxcref, dexc_dummy, lgam) - ! grhoraux(nnr,3,nspin)?yes; rhogaux(ng,nspin)? rhoref(nnr, nspin) - ! - end if - ! - -!end_added:giovanni fixing PBE potential - - ! - ! this term is computed for ibnd, ispin == 1 and stored - ! or if rhobarfact < 1 - ! - if ( ( ibnd == 1 .and. ispin == 1) .OR. rhobarfact < 1.0_dp ) then - ! - etxc=0.0_dp - vxc=0.0_dp - ! - ! some meory can be same in the nspin-2 case, - ! considering that rhobar + f*rhoele is identical to rho - ! when rhobarfact == 1 - ! - ! call exch_corr_wrapper(nnrx,2,grhoraux,rhor,etxc,vxc,haux) - ! - allocate( rhoraux(nnrx, 2) ) - ! - rhoraux = rhobar + f*rhoele - ! - if ( dft_is_gradient() ) then - ! - grhoraux(:,:,1:2) = grhobar(:,:,1:2) - grhoraux(:,:,ispin) = grhobar(:,:,ispin) & - + f * orb_grhor(:,:,1) - ! - rhogaux(:,1:2) = rhobarg(:,1:2) - rhogaux(:,ispin) = rhobarg(:,ispin) + f * orb_rhog(:,1) - - endif - ! - !call exch_corr_wrapper(nnrx,2,grhoraux,rhoraux,etxc,vxc,haux) - vxc=rhoraux - CALL exch_corr_cp(nnrx, 2, grhoraux, vxc, etxc) !proposed:giovanni warning rhoraix is overwritten with vxc, check array dimensions - !NB grhoraux(nnr,3,nspin)? rhoraux(nnr,nspin)? - !begin_added:giovanni fixing PBE potential - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc should be dexc(3,3), is lgam a variable here? - call gradh( 2, grhoraux, rhogaux, vxc, dexc_dummy, lgam) - ! grhoraux(nnr,3,nspin)? rhogaux(ng,nspin)? rhoraux(nnr, nspin) - ! - end if - !end_added:giovanni fixing PBE potential - ! - deallocate( rhoraux ) - ! - endif - ! - deallocate(rhogaux) - deallocate(orb_rhog) - ! - etxc0=0.0_dp - vxc0=0.0_dp - ! - !rhoraux = rhobar - ! - !call exch_corr_wrapper(nnrx,2,grhobar,rhobar,etxc0,vxc0,haux) - vxc0=rhobar - CALL exch_corr_cp(nnrx, 2, grhobar, vxc0, etxc0) !proposed:giovanni warning rhobar is overwritten with vxc0, check array dimensions - !NB grhobar(nnr,3,nspin)? rhobar(nnr,nspin)? -!begin_added:giovanni fixing PBE potential - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc should be dexc(3,3), is lgam a variable here? - call gradh(2, grhobar, rhobarg, vxc0, dexc_dummy, lgam) - ! grhobar(nnr,3,nspin)? rhogbar(ng,nspin)? rhor(nnr, nspin) - ! - end if -!end_added:giovanni fixing PBE potential - ! - ! update vsic pot - ! - vsic(1:nnrx) = vsic(1:nnrx) & - + vxcref(1:nnrx,ispin)-vxc(1:nnrx,ispin) - ! - ! define pink - ! - etmp = f*sum( vxcref(1:nnrx,ispin) * rhoele(1:nnrx,ispin) ) - ! - pink = ( etxc0-etxc ) + etmp + ehele - pink = pink*fact - ! - call mp_sum(pink,intra_image_comm) - ! - call stop_clock( 'nk_corr_vxc' ) - - ! - ! calculate wref and wxd - ! - CALL start_clock( 'nk_corr_fxc' ) - ! - wxdsic(:,:) = 0.0d0 - ! - if( do_wref .or. do_wxd_ ) then - ! - ! note that vxd and wref are updated - ! (and not overwritten) by the next call - ! - call nksic_dmxc_spin_cp_update( nnrx, rhoref, f, ispin, rhoele, & - vanishing_rho_w, wrefsic, wxdsic ) !modified:linh - ! - ! - if ( do_wref ) then - ! - w2cst = sum( wrefsic(1:nnrx) * rhoele(1:nnrx,ispin) ) * fact - ! - call mp_sum(w2cst,intra_image_comm) - ! - do ir=1,nnrx - wrefsic(ir)=fref*(wrefsic(ir)-w2cst) - enddo - ! - endif - ! - if ( do_wxd_ ) then - ! - wxdsic(:,1:2)= rhobarfact *( wxdsic(:,1:2) & - + vxc0(:,1:2) -vxc(:,1:2) ) - ! - endif - ! - endif - ! - CALL stop_clock( 'nk_corr_fxc' ) - - ! - ! rescale contributions with the nkscalfact parameter - ! take care of non-variational formulations - ! - pink = pink * nkscalfact - vsic = vsic * nkscalfact - ! - if( do_wxd_ ) then - wxdsic = wxdsic * nkscalfact - else - wxdsic = 0.d0 - endif - ! - if( do_wref ) then - wrefsic = wrefsic * nkscalfact - else - wrefsic = 0.d0 - endif - - ! - deallocate(vxc0) - deallocate(vxcref) - deallocate(rhoele) - ! - deallocate(grhoraux) - deallocate(haux) - ! - if ( allocated(orb_grhor) ) deallocate(orb_grhor) - ! - CALL stop_clock( 'nk_corr' ) - return - ! -!--------------------------------------------------------------- - end subroutine nksic_correction_nk -!--------------------------------------------------------------- - -!--------------------------------------------------------------- - subroutine nksic_get_pz_factor( nspin, ispin, orb_rhor, rhor, & - taukin, tauw, alpha, ibnd, kfact) -!--------------------------------------------------------------- -! -! ... sum up the kinetic energy-density taukin ... this works both for summing -! the orbital-resolved kinetic energy densities, and for the Weizsacker kinetic -! energy density (involving the total density). -! - use kinds, only : dp - use cell_base, only : tpiba2,omega - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dft_is_gradient - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use control_flags, only : gamma_only, do_wf_cmplx - use nksic, only : epsi3=> epsi_cutoff_renorm, epsi2=> epsi2_cutoff_renorm - ! - implicit none - ! - integer, intent(in) :: ispin, ibnd, nspin - real(dp), intent(in) :: orb_rhor(nnrx), taukin(nnrx,nspin), tauw(nnrx,nspin), rhor(nnrx,nspin) - real(dp), intent(out) :: alpha - real(dp), intent(in) :: kfact - ! - INTEGER :: ir - LOGICAL :: lgam - real(dp) :: fact, temp, aidfract, norm, aidspin -! real(dp), parameter :: epsi=1.d-3 - ! - lgam=gamma_only.and..not.do_wf_cmplx - fact=omega/DBLE(nr1*nr2*nr3) - ! - temp=0.d0 - norm=0.d0 - ! - IF(nspin==1) THEN - aidspin=0.5d0 - ELSE - aidspin=1.d0 - ENDIF - ! - do ir=1,nnrx - ! -! ! ! IF((tauw(ir,ispin)**2+taukin(ir,ispin)**2.gt.epsi2**4)) THEN ! - IF(aidspin*rhor(ir,ispin).gt.epsi2) THEN ! - ! -! ! ! aidfract=((tauw(ir,ispin)+epsi2)/(taukin(ir,ispin)+epsi2))**kfact - aidfract=((orb_rhor(ir)+epsi2)/(aidspin*rhor(ir,ispin)+epsi2))**kfact - ! - IF(1.d0-abs(aidfract).lt.epsi2) THEN - ! - aidfract=1.d0 - ! - ENDIF - ! - temp = temp+orb_rhor(ir)*aidfract - ! - ELSE - ! - temp = temp+orb_rhor(ir) - ! - ENDIF - ! -! norm=norm+orb_rhor(ir) - ! - enddo - ! - call mp_sum(temp,intra_image_comm) -! call mp_sum(norm,intra_image_comm) - ! - temp=temp*fact -! norm=norm*fact -! write(6,*) "checknorm", norm - ! - alpha=temp - ! - end subroutine nksic_get_pz_factor - -!--------------------------------------------------------------- - subroutine nksic_get_pzfactor_potential(f, nspin, ispin, rhor, orb_rhor, & - pink, taukin, tauw, edens, upsilonkin, upsilonw, vsic, alpha, ibnd, kfact) -!--------------------------------------------------------------- -! -! ... sum up the kinetic energy-density taukin ... this works both for summing -! the orbital-resolved kinetic energy densities, and for the Weizsacker kinetic -! energy density (involving the total density). -! - use kinds, only : dp - use cell_base, only : tpiba2,omega - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dft_is_gradient - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use control_flags, only : gamma_only, do_wf_cmplx - use nksic, only : epsi3=> epsi_cutoff_renorm, epsi2=> epsi2_cutoff_renorm - - ! - implicit none - ! - integer, intent(in) :: ispin, ibnd, nspin - real(dp), intent(in) :: kfact, f, orb_rhor(nnrx), taukin(nnrx,nspin), tauw(nnrx,nspin), edens(nnrx,nspin), rhor(nnrx,nspin) - real(dp), intent(inout) :: upsilonkin(nnrx,3,nspin), upsilonw(nnrx,3,nspin) - real(dp), intent(in) :: alpha - real(dp), intent(inout) :: pink - real(dp), intent(out) :: vsic(nnrx) - ! - INTEGER :: ir,j - LOGICAL :: lgam - real(dp) :: fact, temp, tempw, dexc_dummy(3,3), aidtau, aidfrac, aidspin - complex(dp), allocatable :: rhog_dummy(:,:) - real(dp), allocatable :: upsilonh(:,:,:), vsicaux(:,:) -! real(dp), parameter :: epsi=1.d-3 - ! - lgam=gamma_only.and..not.do_wf_cmplx - fact=omega/DBLE(nr1*nr2*nr3) - ! - allocate(upsilonh(nnrx,3,nspin)) - allocate(vsicaux(nnrx,nspin)) - allocate(rhog_dummy(1,1)) - ! - upsilonh=0.d0 - ! - vsicaux=0.d0 - ! - IF(nspin==1) THEN - aidspin=0.5d0 - ELSE - aidspin=1.d0 - ENDIF -! write(6,*) "checkall", ibnd, ispin - ! -! ! ! call nksic_get_upsilon_pz( f, nspin, ispin, orb_rhor, & -! ! ! upsilonkin, ibnd) - if(ibnd==1) THEN !compute also upsilonw - ! -! ! call nksic_get_upsilon_pz( 1.d0, nspin, ispin, rhor(:,ispin), & -! upsilonw, ibnd) - ! - ENDIF - ! - ! - upsilonh=0.d0 - ! -! vsicaux(:,ispin)=vsicaux(:,ispin) - ! - do ir=1,nnrx - ! - temp=0.d0 - tempw=0.d0 - ! - do j=1,3 - ! - temp=temp+upsilonkin(ir,j,ispin)**2. - tempw=tempw+upsilonw(ir,j,ispin)**2. - ! - enddo - ! - ! -! temp=sqrt(abs(temp)) -! tempw=sqrt(abs(tempw)) -! write(6,*) "checktau", taukin(ir,ispin),tauw(ir,ispin),ispin - ! -! ! ! IF((tauw(ir,ispin)**2+taukin(ir,ispin)**2.gt.epsi2**4)) THEN - IF((aidspin*rhor(ir,ispin).gt.epsi2)) THEN ! ! THEN - ! -! ! ! aidtau=0.5d0*(temp/(taukin(ir,ispin)+epsi2)-tempw/(tauw(ir,ispin)+epsi2)) - aidtau=-edens(ir,ispin)/(aidspin*rhor(ir,ispin)+epsi2)**(kfact+1.d0) - ! -! ! ! aidfrac=((tauw(ir,ispin)+epsi2)/(taukin(ir,ispin)+epsi2))**kfact - aidfrac=((orb_rhor(ir)+epsi2)/(aidspin*rhor(ir,ispin)+epsi2))**kfact - - ! - IF(1.d0-abs(aidfrac).lt.epsi2) THEN -! ! - aidfrac=1.d0 - aidtau=0.d0 - ! - ENDIF -! ! ! - IF(abs(aidtau).lt.epsi2) THEN - ! - aidtau=0.d0 - ! - ENDIF - ! - vsicaux(ir,ispin) = vsicaux(ir,ispin) & - +pink/f*(-alpha+aidfrac) - ! -! ! ! vsicaux(ir,ispin) = vsicaux(ir,ispin)+kfact*edens(ir,ispin)*aidfrac*aidtau - vsicaux(ir,ispin) = vsicaux(ir,ispin)+kfact*aidfrac*pink/f+aidtau*kfact - ! - do j=1,3 - ! - !aidtau=0.5d0*(upsilonkin(ir,j,ispin)/(taukin(ir,ispin)+epsi2)-upsilonw(ir,j,ispin)/(tauw(ir,ispin)+epsi2)) - ! - IF(abs(aidfrac-1.d0).lt.epsi2) THEN !abs(aidtau).lt.epsi2**2 - ! - !aidtau=0.d0 - ! - ENDIF - ! - !upsilonh(ir,j,ispin) = upsilonh(ir,j,ispin) - kfact*edens(ir,ispin)*aidfrac*aidtau - ! - enddo - ! - ELSE IF(abs(1.d0-alpha).gt.epsi2**2) THEN - ! - vsicaux(ir,ispin) = vsicaux(ir,ispin) & - +pink/f*(-alpha+1.d0) - ! - ENDIF - ! - enddo - ! - ! Now we need to use fft's to add the gradient part to vsic... check the sign of this expression - ! -! call gradh( 1, upsilonh(:,:,ispin:ispin), rhog_dummy, vsicaux(:,ispin:ispin), dexc_dummy, lgam ) - ! - do ir=1,nnrx - ! - vsic(ir) = vsic(ir) + vsicaux(ir,ispin) - ! - enddo - ! - deallocate(upsilonh, vsicaux, rhog_dummy) - ! - end subroutine nksic_get_pzfactor_potential - -!--------------------------------------------------------------- - subroutine add_up_taukin(nnrx, taukin, grhoraux, orb_rhor, f) -!--------------------------------------------------------------- - ! - USE kinds, only: DP - use nksic, only : epsi=> epsi_cutoff_renorm, epsi2_cutoff_renorm - - ! - INTEGER, INTENT(IN) :: nnrx - REAL(DP) :: taukin(nnrx), orb_rhor(nnrx), f, grhoraux(nnrx,3) - ! - REAL(DP) :: temp_gradient, temp_rho -! REAL(DP), PARAMETER :: epsi2=1.e-11 - INTEGER :: ir - ! - - do ir=1,nnrx - ! - temp_gradient = grhoraux(ir,1)**2+grhoraux(ir,2)**2+grhoraux(ir,3)**2 - temp_rho=orb_rhor(ir) - - IF ((temp_gradient.lt.epsi**2)) THEN!(temp_rho.lt.epsi.or.temp_gradient.lt.epsi**2) THEN - temp_gradient=0.d0 - temp_rho=1.d0 - ELSE - taukin(ir) = taukin(ir)+f/(2.) * temp_gradient - ENDIF - ! - enddo - - end subroutine add_up_taukin - -!--------------------------------------------------------------- - subroutine nksic_get_taukin_pz( f, nspin, ispin, orb_rhor, & - taukin, ibnd, mult) -!--------------------------------------------------------------- -! -! ... sum up the kinetic energy-density taukin ... this works both for summing -! the orbital-resolved kinetic energy densities, and for the Weizsacker kinetic -! energy density (involving the total density). -! - use kinds, only : dp -! use nksic, only : add_up_taukin - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dft_is_gradient - use control_flags, only : gamma_only, do_wf_cmplx - use nksic, only : epsi=> epsi_cutoff_renorm, epsi2_cutoff_renorm - - ! - implicit none - ! - integer, intent(in) :: ispin, ibnd, nspin, mult - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(inout) :: taukin(nnrx,nspin) - ! - INTEGER :: ig,ir - complex(dp), allocatable :: rhogaux(:,:) - real(dp), allocatable :: grhoraux(:,:,:) - complex(dp), allocatable :: vhaux(:) - LOGICAL :: lgam - ! - lgam=gamma_only.and..not.do_wf_cmplx - ! - allocate(rhogaux(ngm,2)) - allocate(vhaux(nnrx)) - ! - IF(ibnd==1) THEN !first band: initialize taukin for this spin_loop - ! - taukin(1:nnrx,ispin)=0.d0 - ! - ENDIF - ! - rhogaux=0.0_dp - ! - do ir=1,nnrx - ! - vhaux(ir) = sqrt(abs(orb_rhor(ir)+mult*epsi)) - ! - enddo - ! - call fwfft('Dense',vhaux,dfftp ) - ! - do ig=1,ngm - rhogaux(ig,ispin) = vhaux( np(ig) ) - enddo - ! -! call enkin_dens( rhogaux(:,ispin), ngm, f) - ! - allocate(grhoraux(nnrx,3,2)) - - grhoraux=0.0_dp - - call fillgrad( 1, rhogaux(:,ispin:ispin), grhoraux(:,:,ispin:ispin), lgam ) - - call add_up_taukin(nnrx, taukin(:,ispin), grhoraux(:,:,ispin), orb_rhor(:), f) -! vhaux=0.d0 -! do ig=1,ngm -! vhaux( np(ig) )= rhogaux(ig,ispin) -! vhaux( nm(ig) )= CONJG(rhogaux(ig,ispin)) -! enddo -! ! -! call invfft('Dense',vhaux,dfftp ) -! ! -! do ir=1,nnrx -! ! -! taukin(ir,ispin) = DBLE(vhaux(ir)) -! ! -! enddo - ! - deallocate(vhaux,rhogaux,grhoraux) - ! - end subroutine nksic_get_taukin_pz - -!--------------------------------------------------------------- - subroutine nksic_get_upsilon_pz( f, nspin, ispin, orb_rhor, & - upsilon, ibnd) -!--------------------------------------------------------------- -! -! ... sum up the kinetic energy-density taukin ... this works both for summing -! the orbital-resolved kinetic energy densities, and for the Weizsacker kinetic -! energy density (involving the total density). -! - use kinds, only : dp - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dft_is_gradient - use control_flags, only : gamma_only, do_wf_cmplx - use nksic, only : epsi=> epsi_cutoff_renorm, epsi2_cutoff_renorm - ! - implicit none - ! - integer, intent(in) :: ispin, ibnd, nspin - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(out) :: upsilon(nnrx,3,nspin) - ! - INTEGER :: ig,ir,j - complex(dp), allocatable :: rhogaux(:,:) - real(dp), allocatable :: grhoraux(:,:,:) - complex(dp), allocatable :: vhaux(:) - real(dp) :: temp(3), tempnorm -! real(dp), parameter :: epsi=1.d-3 - LOGICAL :: lgam - ! - lgam=gamma_only.and..not.do_wf_cmplx - ! - allocate(rhogaux(ngm,2)) - allocate(vhaux(nnrx)) - ! - rhogaux=0.0_dp - ! - do ir=1,nnrx - ! - vhaux(ir) = log(abs(orb_rhor(ir))) - ! - enddo - ! - call fwfft('Dense',vhaux,dfftp ) - ! - do ig=1,ngm - rhogaux(ig,ispin) = vhaux( np(ig) ) - enddo - ! - allocate(grhoraux(nnrx,3,2)) - ! - grhoraux=0.0_dp - ! - call fillgrad( 1, rhogaux(:,ispin:ispin), grhoraux(:,:,ispin:ispin), lgam ) - ! - upsilon(1:nnrx,1:3,ispin)=0.d0 - ! - do ir=1,nnrx - ! - IF(.true.) THEN - ! - tempnorm=0.d0 - ! - do j=1,3 - ! - temp(j) = grhoraux(ir,j,ispin)!/(2.*(orb_rhor(ir)+epsi)) - tempnorm=tempnorm+temp(j)**2 - ! - enddo - ! - IF(tempnorm.gt.epsi) THEN - ! - upsilon(ir,:,ispin)=temp(:) - ! - ENDIF - ! - ENDIF - ! - enddo - ! - deallocate(vhaux,rhogaux,grhoraux) - ! - end subroutine nksic_get_upsilon_pz - -!--------------------------------------------------------------- - subroutine nksic_correction_pz( f, ispin, orb_rhor, & - vsic, pink, pzalpha, ibnd, shart) -!--------------------------------------------------------------- -! -! ... calculate the non-Koopmans potential from the orbital density -! - use kinds, only : dp - use constants, only : e2, fpi, hartree_si, electronvolt_si - use cell_base, only : tpiba2,omega - use nksic, only : etxc => etxc_sic, vxc => vxc_sic, nknmax, & - nkscalfact, do_pz_renorm - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use eecp_mod, only : do_comp - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dft_is_gradient - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use control_flags, only : gamma_only, do_wf_cmplx - use control_flags, only : hartree_only_sic - ! - implicit none - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx), pzalpha - real(dp), intent(out) :: vsic(nnrx) - real(dp), intent(out) :: pink, shart - ! - !character(19) :: subname='nksic_correction_pz' - integer :: ig - real(dp) :: ehele, fact - ! - real(dp), allocatable :: rhoelef(:,:) - complex(dp), allocatable :: rhogaux(:,:) - complex(dp), allocatable :: vhaux(:) - complex(dp), allocatable :: vcorr(:) - complex(dp), allocatable :: vtmp(:) - ! - real(dp), allocatable :: grhoraux(:,:,:) - real(dp), allocatable :: haux(:,:,:) - logical :: lgam - real(dp) :: dexc_dummy(3,3) - ! - !================== - ! main body - !================== - ! - lgam=gamma_only.and..not.do_wf_cmplx - vsic=0.0_dp - pink=0.0_dp - ! - if ( ibnd > nknmax .and. nknmax .ge. 0 ) return - if ( f < 1.0d-6 ) return - ! - CALL start_clock( 'nk_corr' ) - CALL start_clock( 'nk_corr_h' ) - ! - fact=omega/DBLE(nr1*nr2*nr3) - ! - !allocate(rhoelef(nnrx,2)) - allocate(rhogaux(ngm,2)) - allocate(vtmp(ngm)) - allocate(vcorr(ngm)) - allocate(vhaux(nnrx)) - ! - !rhoelef=0.0d0 - !rhoelef(:,ispin) = f * orb_rhor(:) - ! - ! Compute self-hartree contributions - ! - rhogaux=0.0_dp - ! - ! rhoelef contains occupations - ! - !vhaux(:) = rhoelef(:,ispin) - vhaux(:) = f*orb_rhor(:) - ! - call fwfft('Dense',vhaux,dfftp ) - ! - do ig=1,ngm - rhogaux(ig,ispin) = vhaux( np(ig) ) - enddo - - ! - ! compute hartree-like potential - ! - if( gstart == 2 ) vtmp(1)=(0.d0,0.d0) - do ig=gstart,ngm - vtmp(ig) = rhogaux(ig,ispin) * fpi/( tpiba2*g(ig) ) - enddo - ! - ! compute periodic corrections - ! - if( do_comp ) then - ! - call calc_compensation_potential( vcorr, rhogaux(:,ispin), .true.) - vtmp(:) = vtmp(:) + vcorr(:) - ! - endif - ! - vhaux=0.0_dp -! if(lgam) then !!!### uncomment for k points - do ig=1,ngm - ! - vhaux(np(ig)) = vtmp(ig) - vhaux(nm(ig)) = CONJG(vtmp(ig)) - ! - enddo -! else !!!### uncomment for k points -! do ig=1,ngm !!!### uncomment for k points - ! -! vhaux(np(ig)) = vtmp(ig) !!!### uncomment for k points -! vhaux(nm(ig)) = conjg(vtmp(ig)) - ! -! enddo !!!### uncomment for k points -! endif !!!### uncomment for k points - call invfft('Dense',vhaux,dfftp) - ! - ! init vsic - ! - vsic(1:nnrx) = -DBLE( vhaux(1:nnrx) ) - ehele = 0.5_dp * sum( DBLE( vhaux(1:nnrx) ) & - * orb_rhor(1:nnrx) ) - ! - ! set ehele as measure of spread - ! - !IF(icompute_spread) THEN - shart=abs(ehele)*fact*hartree_si/electronvolt_si - call mp_sum(shart, intra_image_comm) - !ENDIF - ! - ehele=ehele*f !this is to make ehele quadratic in f (check this) - ! - ! partial cleanup - ! - deallocate( vtmp ) - deallocate( vcorr ) - deallocate( vhaux ) - ! - CALL stop_clock( 'nk_corr_h' ) - ! - ! Compute xc-contributions - ! - if (.not.hartree_only_sic) then - ! - if ( dft_is_gradient()) then - ! - allocate(grhoraux(nnrx,3,2)) - ! - allocate(haux(nnrx,2,2)) - ! - ! note: rhogaux contains the occupation - ! - grhoraux=0.0_dp - call fillgrad( 1, rhogaux(:,ispin:ispin), grhoraux(:,:,ispin:ispin), lgam ) - ! - ! - else - allocate(grhoraux(1,1,1)) - allocate(haux(1,1,1)) - ! - grhoraux=0.0_dp - endif - ! - ! - vxc=0.0_dp - haux=0.0_dp - etxc=0.0_dp - ! - vxc(:,ispin)=f*orb_rhor(:) - ! call exch_corr_wrapper(nnrx,2,grhoraux,rhoelef,etxc,vxc,haux) - CALL exch_corr_cp(nnrx, 2, grhoraux, vxc, etxc) !proposed:giovanni fixing PBE, warning, check array dimensions - ! - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc should be dexc(3,3), is lgam a variable here? - call gradh( 2, grhoraux, rhogaux, vxc, dexc_dummy, lgam) - ! grhoraux(nnr,3,nspin)?yes; rhogaux(ng,nspin)? rhoref(nnr, nspin) - ! - end if -!$$ - vsic(1:nnrx) = vsic(1:nnrx) -vxc(1:nnrx,ispin) - - else - ! - etxc=0. - ! - endif -! vsic(1:nnrx) = -vxc(1:nnrx,ispin) -!$$ - ! - ! energy correction terms - ! -!$$ - pink = fact * ( -etxc -ehele ) -!$$ -! pink = fact * ( -ehele ) -! pink = fact * ( -etxc ) -!$$ - -!$$ This is for screened pz functional; apparently, I should have used a different variable name. - ! - ! rescale contributions with the nkscalfact parameter - ! take care of non-variational formulations - ! - IF(.not.do_pz_renorm) THEN - ! - pink = pink * nkscalfact - vsic = vsic * nkscalfact - ! - ELSE - !I do not renormalize here, I will do it outside the subroutine - !pink = pink * pzalpha - !vsic = vsic * pzalpha - ! - ENDIF - ! - call mp_sum(pink,intra_image_comm) - ! - deallocate( grhoraux ) - deallocate( rhogaux ) - deallocate( haux ) - ! - CALL stop_clock( 'nk_corr' ) - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_correction_pz -!--------------------------------------------------------------- - - -!--------------------------------------------------------------- - subroutine nksic_correction_nkpz( f, orb_rhor, vsic, wrefsic, pink, ibnd, ispin ) -!--------------------------------------------------------------- -! -! ... calculate the non-Koopmans potential on top of Perdew-Zunger, -! from the orbital densities -! - use kinds, only : dp - use constants, only : e2, fpi - use cell_base, only : tpiba2,omega - use nksic, only : fref, nkscalfact, & - do_wref, vanishing_rho_w - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use eecp_mod, only : do_comp - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dmxc_spin, dft_is_gradient - use mp_global, only : intra_image_comm - use mp, only : mp_sum - use control_flags, only : gamma_only, do_wf_cmplx - - ! - implicit none - real(dp), intent(in) :: f, orb_rhor(nnrx) - integer, intent(in) :: ispin, ibnd - real(dp), intent(out) :: vsic(nnrx), wrefsic(nnrx) - real(dp), intent(out) :: pink - ! - integer :: ig, ir - real(dp) :: fact, etxcref - real(dp) :: w2cst - ! - real(dp), allocatable :: rhoele(:,:) - real(dp), allocatable :: rhoref(:,:) - real(dp), allocatable :: vxcref(:,:) - real(dp), allocatable :: wxdsic(:,:) - real(dp), allocatable :: grhoraux(:,:,:) - real(dp), allocatable :: haux(:,:,:) - complex(dp), allocatable :: vhaux(:) - complex(dp), allocatable :: vcorr(:) - complex(dp), allocatable :: rhogaux(:,:) - complex(dp), allocatable :: vtmp(:) - logical :: lgam - real(dp) :: dexc_dummy(3,3) - ! - CALL start_clock( 'nk_corr' ) - CALL start_clock( 'nk_corr_h' ) - ! - lgam = gamma_only.and..not.do_wf_cmplx - fact=omega/DBLE(nr1*nr2*nr3) - ! - allocate(wxdsic(nnrx,2)) - allocate(rhoele(nnrx,2)) - allocate(rhoref(nnrx,2)) - allocate(rhogaux(ngm,2)) - allocate(vtmp(ngm)) - allocate(vcorr(ngm)) - allocate(vhaux(nnrx)) - ! - rhoele=0.0d0 - rhoele(:,ispin)=orb_rhor(:) - ! - vsic=0.0_dp - wrefsic=0.0_dp - wxdsic=0.0_dp - pink=0.0_dp - ! - ! compute self-hartree contributions - ! - rhogaux=0.0_dp - ! - ! rhoele has no occupation - ! - vhaux(:) = rhoele(:,ispin) - ! - call fwfft('Dense',vhaux,dfftp ) - ! - do ig=1,ngm - rhogaux(ig,ispin) = vhaux( np(ig) ) - enddo - ! - ! compute hartree-like potential - ! - if( gstart == 2 ) vtmp(1)=(0.d0,0.d0) - do ig=gstart,ngm - vtmp(ig)=rhogaux(ig,ispin)*fpi/(tpiba2*g(ig)) - enddo - ! - ! compute periodic corrections - ! - if( do_comp ) then - ! - call calc_compensation_potential( vcorr, rhogaux(:,ispin),.true.) - vtmp(:) = vtmp(:) + vcorr(:) - ! - endif - ! - vhaux=0.0_dp -! IF(lgam) THEN !!!### uncomment for k points - do ig=1,ngm - ! - vhaux(np(ig)) = vtmp(ig) - vhaux(nm(ig)) = CONJG(vtmp(ig)) - ! - enddo -! ELSE !!!### uncomment for k points -! do ig=1,ngm !!!### uncomment for k points - ! -! vhaux(np(ig)) = vtmp(ig) !!!### uncomment for k points -! vhaux(nm(ig)) = conjg(vtmp(ig)) - ! -! enddo !!!### uncomment for k points -! ENDIF !!!### uncomment for k points - ! - call invfft('Dense',vhaux,dfftp) - ! - ! init here wref sic to save some memory - ! - ! this is just the self-hartree potential - ! (to be multiplied by fref later on) - ! - wrefsic(1:nnrx)=DBLE(vhaux(1:nnrx)) - ! - ! the term - fref has to be included explicitly in rhoele - ! - vsic(1:nnrx)=-fref*DBLE(vhaux(1:nnrx)) - ! - deallocate(vtmp) - deallocate(vcorr) - deallocate(vhaux) - ! - call stop_clock( 'nk_corr_h' ) - call start_clock( 'nk_corr_vxc' ) - ! - ! add self-xc contributions - ! - rhoref=fref*rhoele - ! - if ( dft_is_gradient() ) then - allocate(grhoraux(nnrx,3,2)) - allocate(haux(nnrx,2,2)) - ! - grhoraux=0.0_dp - call fillgrad( 1, rhogaux, grhoraux(:,:,ispin:ispin), lgam ) - ! - grhoraux(:,:,ispin) = grhoraux(:,:,ispin) * fref - else - allocate(grhoraux(1,1,1)) - allocate(haux(1,1,1)) - grhoraux=0.0_dp - endif - ! - - - allocate(vxcref(nnrx,2)) - ! - etxcref=0.0_dp - vxcref=0.0_dp - ! - vxcref=rhoref - ! - CALL exch_corr_cp(nnrx, 2, grhoraux, vxcref, etxcref) !proposed:giovanni fixing PBE, warning, rhoref overwritten with vxcref, check array dimensions - ! - !begin_added:giovanni fixing PBE potential - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc should be dexc(3,3), is lgam a variable here? - call gradh( 2, grhoraux, rhogaux, vxcref, dexc_dummy, lgam) - ! grhoraux(nnr,3,nspin)?yes; rhogaux(ng,nspin)? rhoref(nnr, nspin) - ! - end if -!end_added:giovanni fixing PBE potential - deallocate(rhogaux) -! call exch_corr_wrapper(nnrx,2,grhoraux,rhoref,etxcref,vxcref,haux) - ! - ! update vsic pot - ! - vsic(1:nnrx)=vsic(1:nnrx)-vxcref(1:nnrx,ispin) - ! - ! define pink - ! - pink=f*sum(vsic(1:nnrx)*rhoele(1:nnrx,ispin))*fact - call mp_sum(pink,intra_image_comm) - ! - call stop_clock( 'nk_corr_vxc' ) - ! - ! calculate wref - ! - CALL start_clock( 'nk_corr_fxc' ) - ! - if( do_wref ) then - ! - ! note that wxd and wref are updated - ! (and not overwritten) by the next call - ! - call nksic_dmxc_spin_cp_update(nnrx,rhoref,f,ispin,rhoele, & - vanishing_rho_w,wrefsic,wxdsic)!modified:linh - ! - w2cst=sum(wrefsic(1:nnrx)*rhoele(1:nnrx,ispin))*fact - ! - call mp_sum(w2cst,intra_image_comm) - ! - do ir=1,nnrx - wrefsic(ir)=-fref*(wrefsic(ir)-w2cst) - enddo - ! - endif - ! - CALL stop_clock( 'nk_corr_fxc' ) - ! - ! rescale contributions with the nkscalfact parameter - ! take care of non-variational formulations - ! - pink = pink * nkscalfact - vsic = vsic * nkscalfact - ! - if( do_wref ) then - wrefsic = wrefsic * nkscalfact - else - wrefsic = 0.d0 - endif - ! - deallocate(wxdsic) - deallocate(vxcref) - deallocate(rhoele) - deallocate(rhoref) - deallocate(grhoraux) - deallocate(haux) - ! - CALL stop_clock( 'nk_corr' ) - return - ! -!--------------------------------------------------------------- - end subroutine nksic_correction_nkpz -!--------------------------------------------------------------- - -!--------------------------------------------------------------- - subroutine nksic_correction_nkipz( f, ispin, orb_rhor, & - vsic, pink, ibnd, shart, is_empty) -!--------------------------------------------------------------- -! -! ... calculate the non-Koopmans potential from the orbital density -! - use kinds, only : dp - use constants, only : e2, fpi, hartree_si, electronvolt_si - use cell_base, only : tpiba2,omega - use nksic, only : nknmax, nkscalfact - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use eecp_mod, only : do_comp - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dft_is_gradient - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use control_flags, only : gamma_only, do_wf_cmplx - use io_global, only: stdout - - ! - implicit none - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(out) :: vsic(nnrx) - real(dp), intent(out) :: pink, shart - logical, optional, intent(in) :: is_empty - ! - !character(19) :: subname='nksic_correction_pz' - integer :: ig - real(dp) :: ehele, fact, w2cst, etmp, etxc_ - ! - real(dp), allocatable :: rhoele(:,:) - real(dp), allocatable :: vxc_(:,:) - complex(dp), allocatable :: rhogaux(:,:) - complex(dp), allocatable :: vhaux(:) - complex(dp), allocatable :: vcorr(:) - complex(dp), allocatable :: vtmp(:) - ! - real(dp), allocatable :: grhoraux(:,:,:) - real(dp), allocatable :: haux(:,:,:) - logical :: lgam - real(dp) :: icoeff - real(dp) :: dexc_dummy(3,3) - logical :: is_empty_ - ! - !================== - ! main body - !================== - ! - lgam=gamma_only.and..not.do_wf_cmplx - if(lgam) then - icoeff=2.d0 - else - icoeff=1.d0 - endif - ! - IF(present(is_empty)) THEN - ! - is_empty_ = is_empty - ! - ELSE - ! - is_empty_ = .false. - ! - ENDIF - ! - vsic=0.0_dp - pink=0.0_dp - ! - if ( ibnd > nknmax .and. nknmax .ge. 0 ) return - ! - CALL start_clock( 'nk_corr' ) - CALL start_clock( 'nk_corr_h' ) - ! - fact=omega/DBLE(nr1*nr2*nr3) - ! - allocate(rhogaux(ngm,2)) - allocate(vtmp(ngm)) - allocate(vcorr(ngm)) - allocate(vxc_(nnrx,2)) - allocate(vhaux(nnrx)) - ! - ! Compute self-hartree contributions - ! - rhogaux=0.0_dp - ! - ! vhaux does not contain occupations - ! - vhaux(:) = orb_rhor(:) - ! - call fwfft('Dense',vhaux,dfftp ) - ! - do ig=1,ngm - rhogaux(ig,ispin) = vhaux( np(ig) ) - enddo - ! - ! compute hartree-like potential - ! - if( gstart == 2 ) vtmp(1)=(0.d0,0.d0) - do ig=gstart,ngm - vtmp(ig) = rhogaux(ig,ispin) * fpi/( tpiba2*g(ig) ) - enddo - ! - ! compute periodic corrections - ! - if( do_comp ) then - ! - call calc_compensation_potential( vcorr, rhogaux(:,ispin),.true. ) - vtmp(:) = vtmp(:) + vcorr(:) - ! - endif - ! - vhaux=0.0_dp - do ig=1,ngm - ! - vhaux(np(ig)) = vtmp(ig) - vhaux(nm(ig)) = CONJG(vtmp(ig)) - ! - enddo - call invfft('Dense',vhaux,dfftp) - ! - ! init vsic - ! - vsic(1:nnrx) = -DBLE( vhaux(1:nnrx) ) - ! - ehele = icoeff * DBLE ( DOT_PRODUCT( vtmp(1:ngm), rhogaux(1:ngm,ispin))) - if ( gstart == 2 ) ehele = ehele + (1.d0-icoeff)*DBLE ( CONJG( vtmp(1) ) * rhogaux(1,ispin) ) - ! - w2cst = 0.5_dp * ehele * omega - call mp_sum(w2cst,intra_image_comm) - vsic = vsic + w2cst - ! - ehele = 0.5d0 * ehele * omega / fact - ! - shart=abs(ehele)*fact*hartree_si/electronvolt_si - ! - call mp_sum(shart, intra_image_comm) - ! - ! partial cleanup - ! - deallocate( vtmp ) - deallocate( vcorr ) - deallocate( vhaux ) - ! - CALL stop_clock( 'nk_corr_h' ) - ! - ! Compute xc-contributions - ! - if ( dft_is_gradient() ) then - allocate(grhoraux(nnrx,3,2)) - ! - ! note: rhogaux does not contain the occupation - ! - grhoraux=0.0_dp - call fillgrad( 1, rhogaux(:,ispin:ispin), grhoraux(:,:,ispin:ispin), lgam ) - else - allocate(grhoraux(1,1,1)) - ! - grhoraux=0.0_dp - endif - ! - ! - vxc_=0.0_dp - etxc_=0.0_dp - ! - vxc_(:,ispin)=orb_rhor(:) - CALL exch_corr_cp(nnrx, 2, grhoraux, vxc_, etxc_) !proposed:giovanni fixing PBE, warning, check array dimensions - ! - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc should be dexc(3,3), is lgam a variable here? - call gradh( 2, grhoraux, rhogaux, vxc_, dexc_dummy, lgam) - ! - end if - - IF(.not.is_empty_) THEN - ! - etmp = sum( vxc_(1:nnrx,ispin) * orb_rhor(1:nnrx) ) - ! - w2cst = -etxc_ + etmp - w2cst = w2cst * fact - ! - call mp_sum(w2cst,intra_image_comm) - ! - pink = -f*(etxc_ + ehele) - ! - ELSE - ! - etmp = sum( vxc_(1:nnrx,ispin) * orb_rhor(1:nnrx) ) - ! - w2cst = -etxc_ + etmp - w2cst = w2cst * fact - ! - call mp_sum(w2cst,intra_image_comm) - ! - pink = -(etxc_ + ehele) - ! - ENDIF - ! - pink = pink*fact - ! - call mp_sum(pink,intra_image_comm) - ! - vsic(1:nnrx) = vsic(1:nnrx) - vxc_(1:nnrx,ispin) + w2cst - ! - pink = pink * nkscalfact - vsic = vsic * nkscalfact - ! - deallocate( grhoraux ) - deallocate( rhogaux ) - deallocate( vxc_ ) - ! - CALL stop_clock( 'nk_corr' ) - - return - ! -!--------------------------------------------------------------- -end subroutine nksic_correction_nkipz -!--------------------------------------------------------------- - -!--------------------------------------------------------------- - subroutine nksic_correction_nki( f, ispin, orb_rhor, rhor, & - rhoref, rhobar, rhobarg, grhobar,& - vsic, wxdsic, do_wxd_, pink, ibnd, shart, is_empty ) -!--------------------------------------------------------------- -! -! ... calculate the non-Koopmans (integrated, NKI) -! potential from the orbital density -! -! note that fref=1.0 when performing NKI (i.e. it has a diff meaning) -! then rho_ref = rho - rho_i + n_i -! rho_bar = rho - rho_i -! - use kinds, only : dp - use constants, only : e2, fpi, hartree_si, electronvolt_si - use cell_base, only : tpiba2,omega - use nksic, only : fref, rhobarfact, nknmax, & - nkscalfact, & - etxc => etxc_sic, vxc => vxc_sic - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use eecp_mod, only : do_comp - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dmxc_spin, dft_is_gradient - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use electrons_base, only : nspin - use control_flags, only : gamma_only, do_wf_cmplx - use io_global, only: stdout - ! - implicit none - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(in) :: rhor(nnrx,nspin) - real(dp), intent(in) :: rhoref(nnrx,2) - real(dp), intent(in) :: rhobar(nnrx,2) - complex(dp), intent(in) :: rhobarg(ngm,2) - real(dp), intent(in) :: grhobar(nnrx,3,2) - real(dp), intent(out) :: vsic(nnrx) - real(dp), intent(out) :: wxdsic(nnrx,2) - logical, intent(in) :: do_wxd_ - real(dp), intent(out) :: pink, shart - logical, optional, intent(in) :: is_empty - ! - !character(20) :: subname='nksic_correction_nki' - integer :: ig - real(dp) :: fact, ehele, etmp - real(dp) :: etxcref, etxc0, w2cst - ! - real(dp), allocatable :: rhoele(:,:) - real(dp), allocatable :: rhoraux(:,:) - real(dp), allocatable :: vxc0(:,:) - real(dp), allocatable :: vxcref(:,:) - complex(dp), allocatable :: vhaux(:) - complex(dp), allocatable :: vcorr(:) - complex(dp), allocatable :: rhogaux(:,:) - complex(dp), allocatable :: vtmp(:) - ! - real(dp), allocatable :: grhoraux(:,:,:) - real(dp), allocatable :: orb_grhor(:,:,:) - complex(dp), allocatable :: orb_rhog(:,:) - real(dp), allocatable :: haux(:,:,:) - logical :: lgam, is_empty_ - real(dp) :: icoeff - real(dp) :: dexc_dummy(3,3) - ! - !================== - ! main body - !================== - ! - lgam = gamma_only.and..not.do_wf_cmplx - ! - if (lgam) then - ! - icoeff=2.d0 - ! - else - ! - icoeff=1.d0 - ! - endif - ! - if (present(is_empty)) then - ! - is_empty_=is_empty - ! - else - ! - is_empty_=.false. - ! - endif - ! - if( ibnd > nknmax .and. nknmax .ge. 0 ) return - ! - call start_clock( 'nk_corr' ) - call start_clock( 'nk_corr_h' ) - ! - fact=omega/DBLE(nr1*nr2*nr3) - ! - allocate(rhoele(nnrx,2)) - allocate(rhogaux(ngm,2)) - allocate(vtmp(ngm)) - allocate(orb_rhog(ngm,1)) - allocate(vcorr(ngm)) - allocate(vhaux(nnrx)) - ! - rhoele=0.0d0 - rhoele(:,ispin) = orb_rhor(:) - ! - vsic=0.0_dp - wxdsic=0.0_dp - pink=0.0_dp - ! - ! Compute self-hartree contributions - ! - orb_rhog=0.0_dp - ! - ! rhoele has no occupation - ! - vhaux(:) = rhoele(:,ispin) - ! - call fwfft('Dense',vhaux,dfftp ) - ! - do ig=1,ngm - ! - orb_rhog(ig,1) = vhaux( np(ig) ) - ! - enddo - ! - ! compute hartree-like potential - ! - if ( gstart == 2 ) vtmp(1)=(0.d0,0.d0) - ! - do ig=gstart,ngm - ! - vtmp(ig) = orb_rhog(ig,1) * fpi/( tpiba2*g(ig) ) - ! - enddo - ! - ! compute periodic corrections - ! - if ( do_comp ) then - ! - call calc_compensation_potential( vcorr, orb_rhog(:,1),.true.) - vtmp(:) = vtmp(:) + vcorr(:) - ! - endif - ! - vhaux=0.0_dp - ! - do ig=1,ngm - ! - vhaux(np(ig)) = vtmp(ig) - vhaux(nm(ig)) = CONJG(vtmp(ig)) - ! - enddo - ! - call invfft('Dense',vhaux,dfftp) - ! - ! init here vsic to save some memory - ! - ! this is just the self-hartree potential - ! - vsic(1:nnrx) = (1.0_dp-f) * DBLE( vhaux(1:nnrx) ) - ! - ! self-hartree contrib to pink - ! and w2cst for vsic - ! - ehele = icoeff * DBLE ( DOT_PRODUCT( vtmp(1:ngm), orb_rhog(1:ngm,1))) - if ( gstart == 2 ) ehele = ehele +(1.d0-icoeff)*DBLE ( CONJG( vtmp(1) ) * orb_rhog(1,1) ) - ! - shart=abs(ehele)*omega*0.5d0*hartree_si/electronvolt_si - ! - call mp_sum(shart, intra_image_comm) - ! - ! -self-hartree energy to be added to the vsic potential - ! - w2cst = -0.5_dp * ehele * omega - ! - call mp_sum(w2cst,intra_image_comm) - ! - vsic = vsic + w2cst - ! - ! the f * (1-f) term is added here - ! - if (.not.is_empty_) then - ! - ehele = 0.5_dp * f * (1.0_dp-f) * ehele * omega / fact - ! - else !this is for the fake functional for empty states - ! - ehele = 0.5_dp * ehele * omega / fact - ! - endif - ! - deallocate(vtmp) - deallocate(vcorr) - deallocate(vhaux) - ! - CALL stop_clock( 'nk_corr_h' ) - ! - CALL start_clock( 'nk_corr_vxc' ) - ! - ! add self-xc contributions - ! - if ( dft_is_gradient() ) then - ! - allocate(grhoraux(nnrx,3,2)) - allocate(orb_grhor(nnrx,3,1)) - allocate(haux(nnrx,2,2)) - ! - ! compute the gradient of n_i(r) - ! - call fillgrad( 1, orb_rhog, orb_grhor(:,:,1:1), lgam ) - ! - else - ! - allocate(grhoraux(1,1,1)) - allocate(haux(1,1,1)) - grhoraux=0.0_dp - ! - endif - ! - allocate(vxc0(nnrx,2)) - allocate(vxcref(nnrx,2)) - ! - ! this term is computed for ibnd, ispin == 1 and stored - ! or if rhobarfact < 1 - ! - if ( ( ibnd == 1 .and. ispin == 1) .OR. rhobarfact < 1.0_dp ) then - ! - etxc=0.0_dp - vxc=0.0_dp - ! - ! some meory can be same in the nspin-2 case, - ! considering that rhobar + f*rhoele is identical to rho - ! when rhobarfact == 1 - ! - ! call exch_corr_wrapper(nnrx,2,grhoraux,rhor,etxc,vxc,haux) - ! - if ( dft_is_gradient() ) then - ! - grhoraux(:,:,1:2) = grhobar(:,:,1:2) - grhoraux(:,:,ispin) = grhobar(:,:,ispin) & - + f * orb_grhor(:,:,1) - ! - rhogaux(:,1:2) = rhobarg(:,1:2) - rhogaux(:,ispin) = rhobarg(:,ispin) + f * orb_rhog(:,1) - ! - endif - ! - allocate( rhoraux(nnrx, 2) ) - ! - rhoraux = rhobar + f*rhoele - vxc=rhoraux - ! - CALL exch_corr_cp(nnrx, 2, grhoraux, vxc, etxc) !proposed:giovanni warning rhoraux is overwritten with vxc, check array dimensions - ! - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc should be dexc(3,3), is lgam a variable here? - call gradh( 2, grhoraux, rhogaux, vxc, dexc_dummy, lgam) - ! - end if - ! - deallocate( rhoraux ) - ! - endif - ! - etxcref=0.0_dp - vxcref=0.0_dp - ! - if ( f == 1.0_dp ) then - ! - vxcref=vxc - etxcref=etxc - ! - else - ! - if ( dft_is_gradient() ) then - ! - grhoraux(:,:,1:2) = grhobar(:,:,1:2) - grhoraux(:,:,ispin) = grhobar(:,:,ispin) & - + fref * orb_grhor(:,:,1) - ! - rhogaux(:,1:2) = rhobarg(:,1:2) - rhogaux(:,ispin) = rhobarg(:,ispin) + fref * orb_rhog(:,1) - ! - endif - ! - vxcref=rhoref - CALL exch_corr_cp(nnrx, 2, grhoraux, vxcref, etxcref) !proposed:giovanni warning rhoraux is overwritten with vxc, check array dimensions - ! - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc should be dexc(3,3), is lgam a variable here? - call gradh(2, grhoraux, rhogaux, vxcref, dexc_dummy, lgam) - ! - end if - ! - endif - ! - !rhoraux = rhobar - ! - etxc0=0.0_dp - vxc0=0.0_dp - ! - vxc0=rhobar - CALL exch_corr_cp(nnrx, 2, grhobar, vxc0, etxc0) !proposed:giovanni - ! - if (dft_is_gradient()) then - ! - ! Add second part of the xc-potential to rhor - ! Compute contribution to the stress dexc - ! Need a dummy dexc here, need to cross-check gradh! dexc should be dexc(3,3), is lgam a variable here? - call gradh(2, grhobar, rhobarg, vxc0, dexc_dummy, lgam) - ! - end if - ! - ! update potential (including other constant terms) - ! and define pink - ! - IF(.not.is_empty_) THEN - ! - etmp = sum( vxcref(1:nnrx,ispin) * rhoele(1:nnrx,ispin) ) - w2cst = ( etxcref-etxc0 ) -etmp - w2cst = w2cst * fact - ! - call mp_sum(w2cst,intra_image_comm) - ! - pink = (1.0_dp-f)*etxc0 -etxc + f*etxcref + ehele - pink = pink*fact - ! - ELSE - ! - etmp = sum( vxcref(1:nnrx,ispin) * rhoele(1:nnrx,ispin) ) - w2cst = ( etxcref-etxc0 ) -etmp - w2cst = w2cst * fact - ! - call mp_sum(w2cst,intra_image_comm) - ! - etmp = sum( vxc(1:nnrx,ispin) * rhoele(1:nnrx,ispin) ) - ! - pink = etxcref-etxc0-etmp+ehele - pink = pink*fact - ! - ENDIF - ! - call mp_sum(pink,intra_image_comm) - ! - ! - vsic(1:nnrx) = vsic(1:nnrx) & - + vxcref(1:nnrx,ispin) -vxc(1:nnrx,ispin) + w2cst - ! - ! calculate wxd - ! - wxdsic(:,:) = 0.0d0 - ! - if( do_wxd_ ) then - ! - wxdsic(:,1:2)= (1.0_dp-f)*vxc0(:,1:2) -vxc(:,1:2) +f*vxcref(:,1:2) - ! - endif - ! - call stop_clock( 'nk_corr_vxc' ) - ! - ! rescale contributions with the nkscalfact parameter - ! take care of non-variational formulations - ! - pink = pink * nkscalfact - vsic = vsic * nkscalfact - ! - if( do_wxd_ ) then - ! - wxdsic = wxdsic * nkscalfact - ! - else - ! - wxdsic = 0.d0 - ! - endif - ! - deallocate(vxc0) - deallocate(vxcref) - deallocate(rhoele) - ! - deallocate(grhoraux) - deallocate(haux) - deallocate(rhogaux) - ! - if ( allocated(orb_grhor) ) deallocate(orb_grhor) - ! - CALL stop_clock( 'nk_corr' ) - return - ! -!--------------------------------------------------------------- - end subroutine nksic_correction_nki -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_eforce( i, nbsp, nx, vsic, deeq_sic, bec, ngw, c1, c2, vsicpsi, lgam ) -!----------------------------------------------------------------------- -! -! Compute vsic potential for orbitals i and i+1 (c1 and c2) -! - use kinds, only : dp - use cp_interfaces, only : fwfft, invfft - use fft_base, only : dffts, dfftp - use gvecs, only : ngs, nps, nms - use grid_dimensions, only : nnrx - use smooth_grid_dimensions, only : nnrsx - use uspp, only : nkb, vkb - use uspp_param, only : nhm, nh - use cvan, only : ish - use ions_base, only : nsp, na, nat - use twin_types - ! - implicit none - - ! - ! input/output vars - ! - integer, intent(in) :: i, nbsp, nx, ngw - real(dp), intent(in) :: vsic(nnrx,nx) - real(dp), intent(in) :: deeq_sic(nhm,nhm,nat,nx) - type(twin_matrix), intent(in) :: bec!(nkb,nbsp) !modified:giovanni - complex(dp), intent(in) :: c1(ngw), c2(ngw) - complex(dp), intent(out) :: vsicpsi(ngw, 2) - logical, intent(in) :: lgam !added:giovanni - - ! - ! local vars - ! - character(12) :: subname='nksic_eforce' - integer :: ir, ig, ierr, j - integer :: is, iv, jv, isa, ism - integer :: ivoff, jvoff, ia, inl, jnl - real(dp) :: wfc(2), dd - complex(dp) :: wfc_c(2) - complex(dp) :: fm, fp - complex(dp), allocatable :: psi1(:), psi2(:) - real(dp), allocatable :: aa(:,:) - complex(dp), allocatable :: aa_c(:,:) - complex(dp), parameter :: c_one= CMPLX(1.d0,0.d0) - - ! - !==================== - ! main body - !==================== - ! - call start_clock( 'nk_eforce' ) - ! - allocate( psi1(nnrx), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating psi1',abs(ierr)) - if(.not.lgam) then - allocate( psi2(nnrx), stat=ierr ) - if ( ierr/=0 ) call errore(subname,'allocating psi2',abs(ierr)) - endif - - ! - ! init - ! - vsicpsi(:,:) = 0.0d0 - ! - ! take advantage of the smooth and the dense grids - ! being equal (NCPP case) - ! - if ( nnrsx == nnrx ) then !waring:giovanni we are not using ultrasoft - ! - ! no need to take care of the double grid. - ! typically, NCPP case - - ! - if(lgam) then - CALL c2psi( psi1, nnrx, c1, c2, ngw, 2 ) !warning:giovanni need to change this - else - CALL c2psi( psi1, nnrx, c1, c2, ngw, 0 ) !warning:giovanni need to change this - CALL c2psi( psi2, nnrx, c2, c1, ngw, 0 ) !warning:giovanni need to change this - endif - ! - CALL invfft('Dense', psi1, dfftp ) - if(.not. lgam) then - CALL invfft('Dense', psi2, dfftp ) - endif - - ! - ! computing the orbital wfcs - ! and the potentials in real space on the full grid - ! - if(lgam) then - do ir = 1, nnrx - ! - wfc(1) = DBLE( psi1(ir) ) - wfc(2) = AIMAG( psi1(ir) ) - ! - psi1( ir ) = CMPLX( wfc(1) * vsic(ir,i), & - wfc(2) * vsic(ir,i+1)) - ! - enddo - else - do ir = 1, nnrx - ! - wfc_c(1) = psi1(ir) - wfc_c(2) = psi2(ir) - ! - psi1( ir ) = wfc_c(1) * vsic(ir,i) - psi2(ir) = wfc_c(2) * vsic(ir,i+1) - ! - enddo - endif - ! - - CALL fwfft('Dense', psi1, dfftp ) - if(.not. lgam) then - CALL fwfft('Dense', psi2, dfftp ) - endif - ! - vsicpsi(:,:)=0.0_dp - ! - if(lgam) then - do ig=1,ngw - ! - fp = psi1(nps(ig))+psi1(nms(ig)) - fm = psi1(nps(ig))-psi1(nms(ig)) - ! - vsicpsi(ig,1)=0.5d0*CMPLX(DBLE(fp),AIMAG(fm)) - vsicpsi(ig,2)=0.5d0*CMPLX(AIMAG(fp),-DBLE(fm)) - ! - enddo - else - do ig=1,ngw - ! - fp = psi1(nps(ig)) - fm = psi2(nps(ig)) - ! - vsicpsi(ig,1)=fp - vsicpsi(ig,2)=fm - ! - enddo - endif - - else - write(6,*) "WARNING, WE ARE USING USPP" - ! - ! here we take properly into account the - ! smooth and the dense grids - ! typically, USPP case - ! - CALL nksic_eforce_std(lgam) !warning:giovanni this makes fourier transforms - ! - endif - ! - deallocate( psi1 ) - if(.not.lgam) then - deallocate( psi2 ) - endif - - ! - ! add USPP non-local contribution - ! to the potantial - ! (this comes from the orbital-dependent piece of - ! the potential) - ! - if( nkb > 0 ) then -! write(6,*) "WE ARE USING USPP --- WARNING" - ! - ! aa_i,i,n = sum_j d_i,ij - ! - if(.not.bec%iscmplx) then - allocate( aa( nkb, 2 ) ) - ! - aa = 0.0d0 - ! - ! - do is = 1, nsp - ! - do iv = 1, nh(is) - do jv = 1, nh(is) - ! - isa = 0 - do ism = 1, is-1 - isa = isa + na( ism ) - enddo - ! - ivoff = ish(is)+(iv-1)*na(is) - jvoff = ish(is)+(jv-1)*na(is) - ! - if( i /= nbsp ) then - ! - do ia=1,na(is) - inl = ivoff + ia - jnl = jvoff + ia - isa = isa + 1 - ! - dd = deeq_sic(iv,jv,isa,i) - aa(inl,1) = aa(inl,1) + dd * bec%rvec(jnl,i) - ! - dd = deeq_sic(iv,jv,isa,i+1) - aa(inl,2) = aa(inl,2) + dd * bec%rvec(jnl,i+1) - ! - enddo - ! - else - ! - do ia=1,na(is) - inl = ivoff + ia - jnl = jvoff + ia - isa = isa + 1 - ! - dd = deeq_sic(iv,jv,isa,i) - aa(inl,1) = aa(inl,1) + dd * bec%rvec(jnl,i) - ! - enddo - ! - endif - ! - enddo - enddo - ! - enddo - ! -! write(6,*) "deeq_sic" -! write(6,*) deeq_sic - ! - call DGEMM ( 'N', 'N', 2*ngw, 2, nkb, 1.0d0, & - vkb, 2*ngw, aa, nkb, 1.0d0, vsicpsi(:,:), 2*ngw) - ! - deallocate( aa ) - ! - else - allocate( aa_c( nkb, 2 ) ) - ! - aa_c = CMPLX(0.0d0, 0.d0) - ! - ! - do is = 1, nsp - ! - do iv = 1, nh(is) - do jv = 1, nh(is) - ! - isa = 0 - do ism = 1, is-1 - isa = isa + na( ism ) - enddo - ! - ivoff = ish(is)+(iv-1)*na(is) - jvoff = ish(is)+(jv-1)*na(is) - ! - if( i /= nbsp ) then - ! - do ia=1,na(is) - inl = ivoff + ia - jnl = jvoff + ia - isa = isa + 1 - ! - dd = deeq_sic(iv,jv,isa,i) - aa_c(inl,1) = aa_c(inl,1) + dd * bec%cvec(jnl,i) !warning:giovanni or conjg? - ! - dd = deeq_sic(iv,jv,isa,i+1) - aa_c(inl,2) = aa_c(inl,2) + dd * bec%cvec(jnl,i+1) !warning:giovanni or conjg? - ! - enddo - ! - else - ! - do ia=1,na(is) - inl = ivoff + ia - jnl = jvoff + ia - isa = isa + 1 - ! - dd = deeq_sic(iv,jv,isa,i) - aa_c(inl,1) = aa_c(inl,1) + dd * bec%cvec(jnl,i) !warning:giovanni or conjg? - ! - enddo - ! - endif - ! - enddo - enddo - ! - enddo - ! - call ZGEMM ( 'N', 'N', ngw, 2, nkb, c_one, & - vkb, ngw, aa_c, nkb, c_one, vsicpsi(:,:), ngw) - ! - deallocate( aa_c ) - ! - endif - endif - - - call stop_clock( 'nk_eforce' ) - return - -! -! implementation to deal with both -! the smooth and the dense grids -! -CONTAINS - ! - subroutine nksic_eforce_std(lgam) - ! - use smooth_grid_dimensions, only : nnrsx - use recvecs_indexes, only : np - implicit none - - logical, intent(IN) :: lgam - ! - complex(dp) :: c(ngw,2) - complex(dp) :: psis(nnrsx), psis2(nnrsx) - complex(dp) :: vsicg(nnrx) - complex(dp) :: vsics(nnrsx) - complex(dp) :: vsicpsis(nnrsx) - - c(:,1) = c1 - c(:,2) = c2 - - do j = 1, 2 - ! - psis=0.d0 - if(lgam) then - do ig=1,ngw - psis(nms(ig))=CONJG(c(ig,j)) - psis(nps(ig))=c(ig,j) - end do - else - do ig=1,ngw - psis(nps(ig))=c(ig,j) - end do - endif - call invfft('Wave',psis,dffts) - ! - vsicg(1:nnrx)=vsic(1:nnrx,i+j-1) - call fwfft('Dense',vsicg,dfftp) - ! - vsics=0.0_dp - if(lgam) then - do ig=1,ngs - vsics(nps(ig))=vsicg(np(ig)) - vsics(nms(ig))=CONJG(vsicg(np(ig))) - end do - else - do ig=1,ngs - vsics(nps(ig))=vsicg(np(ig)) - vsics(nms(ig))=CONJG(vsicg(np(ig))) - end do - endif - ! - call invfft('Smooth',vsics,dffts) - ! - vsicpsis=0.0_dp - if(lgam) then - do ir = 1, nnrsx - vsicpsis(ir)=CMPLX(DBLE(vsics(ir))*DBLE(psis(ir)),0.0_dp) - enddo - else - do ir = 1, nnrsx - vsicpsis(ir)=CMPLX(DBLE(vsics(ir))*DBLE(psis(ir)), & - DBLE(vsics(ir))*AIMAG(psis(ir))) - enddo - endif - ! - call fwfft('Wave',vsicpsis,dffts) - ! - do ig=1,ngw - vsicpsi(ig,j)=vsicpsis(nps(ig)) - enddo - ! - enddo - ! - end subroutine nksic_eforce_std - ! -!--------------------------------------------------------------- -end subroutine nksic_eforce -!--------------------------------------------------------------- - - -!--------------------------------------------------------------- - subroutine nksic_dmxc_spin_cp( nnrx, rhoref, f, ispin, rhoele, & - small, wref, wxd ) -!--------------------------------------------------------------- -! -! the derivative of the xc potential with respect to the local density -! is computed. -! In order to save time, the loop over space coordinates is performed -! inside this routine (inlining). -! -! NOTE: wref and wsic are UPDATED and NOT OVERWRITTEN by this subroutine -! - USE kinds, ONLY : dp - USE funct, ONLY : xc_spin, get_iexch, get_icorr - implicit none - ! - integer, intent(in) :: nnrx, ispin - real(dp), intent(in) :: rhoref(nnrx,2), rhoele(nnrx,2) - real(dp), intent(in) :: f, small - real(dp), intent(inout) :: wref(nnrx), wxd(nnrx,2) - ! - character(18) :: subname='nksic_dmxc_spin_cp' - real(dp) :: rhoup, rhodw, rhotot, zeta - real(dp) :: dmuxc(2,2) - real(dp) :: rs, ex, vx, dr, dz, ec, & - vcupm, vcdwm, vcupp, vcdwp, dzm, dzp, fact - !real(dp) :: vxupp, vxdwp, vxupm, vxdwm - real(dp), external :: dpz, dpz_polarized - integer :: ir - !logical :: do_exch, do_corr - ! - real(dp), parameter :: e2 = 2.0_dp, & - pi34 = 0.6203504908994_DP, & ! redefined to pi34=(3/4pi)^(1/3) - pi34_old= 0.75_dp/3.141592653589793_dp, third=1.0_dp/3.0_dp, & - p43=4.0_dp/3.0_dp, p49=4.0_dp/ 9.0_dp, m23=-2.0_dp/3.0_dp - - ! - ! mian body - ! - !CALL start_clock( 'nk_dmxc_spin_cp' ) - ! - ! the current implementation works only on top - ! of LSD and LDA. Other functionals have to - ! be implemented explicitly. To do that, we need to - ! call the proper xc-routine (at the moment we call - ! slater and pz_corr) - ! - if ( get_iexch() /= 1 .or. get_icorr() /= 1 ) & - call errore(subname,'only LDA/LSD PZ functionals implemented',10) - ! - !do_exch = ( get_iexch() == 1 ) - !do_corr = ( get_icorr() == 1 ) - ! - ! - ! main loop - ! - do ir = 1, nnrx - ! - dmuxc(:,:)=0.0_dp - ! - rhoup = rhoref(ir,1) - rhodw = rhoref(ir,2) - rhotot = rhoup + rhodw - ! - if( rhotot < small) cycle - ! - zeta = (rhoup-rhodw)/rhotot - if(abs(zeta)>1.0_dp) zeta=sign(1.0_dp,zeta) - - ! - ! calculate exchange contribution (analytical) - ! - if ( rhoup > small) then - rs = pi34 / (2.0_dp*rhoup)**third - call slater(rs,ex,vx) - dmuxc(1,1)=vx/(3.0_dp*rhoup) - endif - ! - if( rhodw > small) then - rs = pi34 / (2.0_dp*rhodw)**third - call slater(rs,ex,vx) - dmuxc(2,2)=vx/(3.0_dp*rhodw) - endif - - ! - ! calculate correlation contribution (numerical) - ! - dr = min(1.e-6_dp,1.e-4_dp*rhotot) - fact = 0.5d0 / dr - ! - ! the explicit call to the correlation part only - ! are performed instead of calling xc_spin. - ! this saves some CPU time. - ! unfortunately, different functionals have then - ! to be treated explicitly - ! - !call xc_spin(rhotot-dr,zeta,ex,ec,vxupm,vxdwm,vcupm,vcdwm) - !call xc_spin(rhotot+dr,zeta,ex,ec,vxupp,vxdwp,vcupp,vcdwp) - ! - rs = pi34 / (rhotot-dr)**third - call pz_spin (rs, zeta, ec, vcupm, vcdwm) - rs = pi34 / (rhotot+dr)**third - call pz_spin (rs, zeta, ec, vcupp, vcdwp) - ! - dmuxc(1,1) = dmuxc(1,1) +(vcupp-vcupm) * fact - dmuxc(1,2) = dmuxc(1,2) +(vcupp-vcupm) * fact - dmuxc(2,1) = dmuxc(2,1) +(vcdwp-vcdwm) * fact - dmuxc(2,2) = dmuxc(2,2) +(vcdwp-vcdwm) * fact - - dz=1.e-6_dp - dzp=min(1.0,zeta+dz)-zeta - dzm=-max(-1.0,zeta-dz)+zeta - ! - fact = 1.0d0 / ( rhotot * (dzp+dzm) ) - ! - !call xc_spin(rhotot,zeta-dzm,ex,ec,vxupm,vxdwm,vcupm,vcdwm) - !call xc_spin(rhotot,zeta+dzp,ex,ec,vxupp,vxdwp,vcupp,vcdwp) - ! - rs = pi34 / (rhotot)**third - call pz_spin (rs, zeta-dzm, ec, vcupm, vcdwm) - call pz_spin (rs, zeta+dzp, ec, vcupp, vcdwp) - - dmuxc(1,1) = dmuxc(1,1) +(vcupp-vcupm)*(1.0_dp-zeta)*fact - dmuxc(1,2) = dmuxc(1,2) -(vcupp-vcupm)*(1.0_dp+zeta)*fact - dmuxc(2,1) = dmuxc(2,1) +(vcdwp-vcdwm)*(1.0_dp-zeta)*fact - dmuxc(2,2) = dmuxc(2,2) -(vcdwp-vcdwm)*(1.0_dp+zeta)*fact - - ! - ! add corrections to the nksic potentials - ! - wxd(ir,1) = wxd(ir,1) + dmuxc(1,ispin) * rhoele(ir,ispin)*f - wxd(ir,2) = wxd(ir,2) + dmuxc(2,ispin) * rhoele(ir,ispin)*f - ! - wref(ir) = wref(ir) + dmuxc(ispin,ispin)*rhoele(ir,ispin) - ! - enddo - - return - ! -!--------------------------------------------------------------- -end subroutine nksic_dmxc_spin_cp -!--------------------------------------------------------------- - - -!----------------------------------------------------------------------- - subroutine nksic_rot_emin(nouter,ninner,etot,Omattot, lgam) -!----------------------------------------------------------------------- -! -! ... Finds the orthogonal rotation matrix Omattot that minimizes -! the orbital-dependent and hence the total energy, and then -! rotate the wavefunction c0 accordingly. -! We may need Omattot for further rotation of the gradient for outer loop CG. -! Right now we do not do that because we set resetcg=.true. after inner loop -! minimization routine, i.e., setting the search direction to be gradient direction. -! (Ultrasoft pseudopotential case is not implemented.) -! - use kinds, only : dp - use constants, only : PI - use grid_dimensions, only : nnrx - use gvecw, only : ngw - use io_global, only : stdout, ionode - use electrons_base, only : nbsp, nbspx, nspin, & - iupdwn,nupdwn - use cp_interfaces, only : invfft - use fft_base, only : dfftp - use ions_base, only : nsp, nat - use uspp_param, only : nhm - use nksic, only : vsic, pink, & - do_nk, do_wref, do_wxd, & - innerloop_nmax - use uspp, only : nkb - use cp_main_variables, only : bec - use wavefunctions_module, only : c0, cm - use control_flags, only : esic_conv_thr - use cg_module, only : tcg - use twin_types - ! - implicit none - ! - ! in/out vars - ! - integer :: ninner - integer, intent(in) :: nouter - real(dp), intent(in) :: etot - complex(dp) :: Omattot(nbspx,nbspx) - logical :: lgam - - ! - ! local variables - ! - real(dp) :: esic,esic_old - integer :: i, nbnd1,nbnd2 - integer :: npassofailmax - real(dp) :: dtmp,dalpha - integer :: isp - real(dp) :: vsicah2sum,deigrms,dmaxeig - integer :: nfile - logical :: do_nonvar,lstopinner - ! - complex(dp), allocatable :: Omat1tot(:,:) - complex(dp), allocatable :: Umatbig(:,:) - real(dp), allocatable :: Heigbig(:) - complex(dp), allocatable :: wfc_ctmp(:,:) - complex(dp), allocatable :: Umat(:,:) - real(dp), allocatable :: Heig(:) - complex(dp), allocatable :: vsicah(:,:) - real(dp), allocatable :: vsic1(:,:) - type(twin_matrix) :: bec1 -! real(dp), allocatable :: bec1(:,:) - real(dp), allocatable :: pink1(:) - ! - integer, save :: npassofail=0 - real(dp), save :: passoprod=0.3d0 - - ! - ! variables for test calculations - along gradient line direction - ! - logical :: ldotest - - ! - ! main body - ! - CALL start_clock( 'nk_rot_emin' ) - - ! - npassofailmax = 5 ! when to stop dividing passoprod by 2 - esic_old=0.d0 - - allocate( Omat1tot(nbspx,nbspx) ) - allocate( Umatbig(nbspx,nbspx) ) - allocate( Heigbig(nbspx) ) - allocate( wfc_ctmp(ngw,nbspx) ) - allocate( vsic1(nnrx,nbspx) ) - allocate( pink1(nbspx) ) - - call init_twin(bec1,lgam) - call allocate_twin(bec1,nkb,nbsp,lgam) -! allocate( bec1(nkb,nbsp) ) - ! - Umatbig(:,:)=(0.d0,0.d0) - Heigbig(:)=0.d0 - deigrms = 0.d0 - - Omattot(:,:)=0.d0 - do nbnd1=1,nbspx - Omattot(nbnd1,nbnd1)=1.d0 - enddo - - ninner = 0 - ldotest=.false. - - ! - ! init IO - if (ionode) write(stdout, "(14x,'# iter',6x,'etot',17x,'esic',& - & 17x,'deigrms')") - - ! - ! main loop - ! - inner_loop: & - do while (.true.) - - call start_clock( "nk_innerloop" ) - ! - ninner = ninner + 1 - - if( ninner > innerloop_nmax ) then - ! -#ifdef __DEBUG - if(ionode) write(1031,*) '# innerloop_nmax reached.' - if(ionode) write(1031,*) -#endif - if(ionode) then - write(stdout,"(14x,'# innerloop_nmax reached.',/)") - endif - ! - call stop_clock( "nk_innerloop" ) - exit inner_loop - ! - endif - -#ifdef __DEBUG - ! -!$$ ! Now do the test - ! - if( mod(ninner,10) == 1 .or. ninner <= 5) ldotest=.true. - !ldotest=.true. - if(ldotest) then - ! - dtmp = 4.d0*PI - !call nksic_rot_test(dtmp,201,nouter,ninner,etot) - ldotest=.false. - ! - endif -#endif - - ! - ! This part calculates the anti-hermitian part of the hamiltonian - ! vsicah and see whether a convergence has been achieved - ! - wfc_ctmp(:,:) = (0.d0,0.d0) - deigrms = 0.d0 - - spin_loop: & - do isp=1,nspin - ! - allocate( Umat(nupdwn(isp),nupdwn(isp)) ) - allocate( Heig(nupdwn(isp)) ) - allocate( vsicah(nupdwn(isp), nupdwn(isp)) ) - ! - call nksic_getvsicah_new2( isp, vsicah, vsicah2sum, lgam) - ! - call nksic_getHeigU( isp, vsicah, Heig, Umat) - - Umatbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = Umat(:,:) - Heigbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = Heig(:) - - !! - !! CHP: The following file prints out - !! the eigenvalues of the force matrix for debugging - ! - !if (ionode) then - ! nfile=10000+isp - ! write(nfile,'(2I10,100F10.6)') ninner,nouter,sum(Heig(:)**2),Heig(:) - !endif - ! - deigrms = deigrms + sum(Heig(:)**2) - - deallocate(Umat) - deallocate(Heig) - deallocate(vsicah) - ! - enddo spin_loop - - - dmaxeig = max( abs(Heigbig(iupdwn(1))), abs(Heigbig(iupdwn(1)+nupdwn(1)-1)) ) - do isp=2,nspin - ! - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)))) - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)+nupdwn(isp)-1))) - ! - enddo - - ! how severe the transform is - deigrms = sqrt(deigrms/nbsp) - - ! - ! print out ESIC part & other total energy - ! - esic=sum(pink(:)) - ! -#ifdef __DEBUG - if(ionode) write(1031,'(2I10,3F24.13)') ninner, nouter,etot,esic,deigrms -#endif - if(ionode) write(stdout,'(10x,2i5,3F21.13)') ninner, nouter, etot, esic, deigrms - - - dalpha = passoprod/dmaxeig - ! - call nksic_getOmattot(dalpha,Heigbig,Umatbig,c0,wfc_ctmp,Omat1tot,bec1,vsic1,pink1,dtmp, lgam) - - ! - ! deal with non-variational functionals, - ! such as NK0 - ! - do_nonvar = ( do_nk .and. ( .not. do_wref .or. .not. do_wxd) ) - ! - if( do_nonvar ) then - lstopinner = ( ninner >= 2 .and. & - ( (esic-dtmp)*(esic-esic_old) > 0.d0) ) - else - lstopinner = ( dtmp >= esic ) - endif - ! - lstopinner = ( lstopinner .or. ( abs(esic-dtmp) < esic_conv_thr ) ) - - - if ( lstopinner ) then - ! - npassofail = npassofail+1 - ! -#ifdef __DEBUG - if(ionode) write(1031,'("# procedure ",I4," / ",I4, & - & " is finished.",/)') npassofail,npassofailmax -#endif - if(ionode) write(stdout,'(14x, "# procedure ",I4," / ",I4, & - & " is finished.",/)') npassofail,npassofailmax - ! - ! if we reach at the maximum allowed npassofail number, - ! we exit without further update - ! - if( npassofail >= npassofailmax ) then - ! - ninner = ninner + 1 - call stop_clock( "nk_innerloop" ) - exit inner_loop - ! - endif - ! - passoprod = passoprod * 0.5d0 - ! ldotest=.true. - cycle - ! - endif - - ! - ! we keep track of all the rotations to rotate cm later - ! - Omattot = MATMUL(Omattot,Omat1tot) - ! - pink(:) = pink1(:) - vsic(:,:) = vsic1(:,:) - call copy_twin(bec, bec1) -! bec%rvec(:,:) = bec1(:,:) - c0(:,:) = wfc_ctmp(:,:) - esic_old = esic - - call stop_clock( "nk_innerloop" ) - ! - enddo inner_loop - - ! - ! Wavefunction cm rotation according to Omattot - ! cm is relevant only for damped dynamics - ! - call start_clock( "nk_rot_cm" ) - if ( .not. tcg ) then - ! - if( ninner >= 2 ) then - ! - wfc_ctmp(:,:) = (0.d0,0.d0) - ! - do nbnd1=1,nbspx - do nbnd2=1,nbspx - wfc_ctmp(:,nbnd1)=wfc_ctmp(:,nbnd1) + cm(:,nbnd2) * Omattot(nbnd2,nbnd1) - ! XXX (we can think to use a blas, here, and split over spins) - enddo - enddo - ! - cm(:,1:nbspx) = wfc_ctmp(:,1:nbspx) - ! - endif - ! - endif - ! - deallocate( Omat1tot ) - deallocate( Umatbig ) - deallocate( Heigbig ) - deallocate( wfc_ctmp ) - deallocate( vsic1 ) - call deallocate_twin(bec1) - deallocate( pink1 ) - ! - call stop_clock( "nk_rot_cm" ) - call stop_clock( 'nk_rot_emin' ) - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_rot_emin -!--------------------------------------------------------------- - - -!----------------------------------------------------------------------- - subroutine nksic_rot_test(passoprod,nsteps,nouter,ninner,etot) -!----------------------------------------------------------------------- -! -! ... prints out esic by varying the wavefunction along a search direction. -! (Ultrasoft pseudopotential case is not implemented.) -! - use kinds, only : dp - use grid_dimensions, only : nnrx - use gvecw, only : ngw - use io_global, only : ionode - use electrons_base, only : nbsp, nbspx, nspin, & - iupdwn, nupdwn - use uspp, only : nkb - use wavefunctions_module, only : c0 - use cg_module, only : tcg - ! - implicit none - ! - ! in/out vars - ! - real(dp), intent(in) :: passoprod - integer, intent(in) :: nsteps, ninner, nouter - real(dp), intent(in) :: etot - - - ! - ! local variables - ! - real(dp) :: esic - real(dp) :: bec1(nkb,nbsp) - real(dp) :: Omat1tot(nbspx,nbspx) - real(dp) :: vsic1(nnrx,nbspx) - complex(dp), allocatable :: Umat(:,:) - complex(dp) :: Umatbig(nbspx,nbspx) - real(dp), allocatable :: Heig(:) - real(dp) :: Heigbig(nbspx) - complex(dp) :: wfc_ctmp(ngw,nbspx) - real(dp) :: dalpha,dmaxeig - real(dp) :: pink1(nbspx) - integer :: isp,istep - real(dp), allocatable :: vsicah(:,:) - real(dp) :: vsicah2sum,deigrms - integer :: nfile - - ! - ! variables for test calculations - along gradient line direction - ! - - ! - ! main body - ! - CALL start_clock( 'nk_rot_test' ) - - - Umatbig(:,:) = (0.d0,0.d0) - Heigbig(:) = 0.d0 - deigrms = 0.d0 - - do isp=1,nspin - - allocate(Umat(nupdwn(isp),nupdwn(isp))) - allocate(Heig(nupdwn(isp))) - allocate(vsicah(nupdwn(isp),nupdwn(isp))) - - call nksic_getvsicah(isp,vsicah,vsicah2sum) - call nksic_getHeigU(isp,vsicah,Heig,Umat) - - Umatbig(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp),iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = Umat(:,:) - Heigbig(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = Heig(:) - - deigrms = deigrms + sum(Heig(:)**2) - - deallocate(Umat) - deallocate(Heig) - deallocate(vsicah) - - enddo ! do isp=1,nspin - - ! how severe the transform is - deigrms = sqrt(deigrms/nbsp) - - dmaxeig = max( abs(Heigbig(iupdwn(1))), abs(Heigbig(iupdwn(1)+nupdwn(1)-1)) ) - do isp=2,nspin - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)))) - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)+nupdwn(isp)-1))) - enddo - - nfile = 10000+100*nouter+ninner - if(ionode) write(nfile,*) '# passoprod',passoprod - - do istep=1,nsteps - if(nsteps.ne.1) then - dalpha = passoprod*(2.d0*istep-nsteps-1.d0)/(nsteps-1.d0) / dmaxeig - else - dalpha = 0.d0 - endif - - call nksic_getOmattot(dalpha,Heigbig,Umatbig,c0,wfc_ctmp,Omat1tot,bec1,vsic1,pink1,esic) - - if(ionode) write(nfile,'(5F24.13,2I10)') dalpha/3.141592*dmaxeig, dmaxeig, etot, esic, deigrms,ninner, nouter - - enddo !$$ do istep=1,nsteps - - if(ionode) write(nfile,*) - - CALL stop_clock( 'nk_rot_test' ) - return - ! -!--------------------------------------------------------------- -end subroutine nksic_rot_test -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_rot_emin_cg_new(c0, cm, vsic, ngw, nnrx, bec, & - nouter, init_n, ninner,etot,Omattot, & - rot_threshold, nbsp, nbspx, nudx, nspin, iupdwn, & - nupdwn, pink, wfc_centers, wfc_spreads, lgam) -!----------------------------------------------------------------------- -! -! ... Finds the orthogonal rotation matrix Omattot that minimizes -! the orbital-dependent and hence the total energy, and then -! rotate the wavefunction c0 accordingly using cg minimization. -! We may need Omattot for further rotation of the gradient for outer loop CG. -! Right now we do not do that because we set resetcg=.true. after inner loop -! minimization routine, i.e., setting the search direction to be gradient direction. -! (Ultrasoft pseudopotential case is not implemented.) -! - use kinds, only : dp - use io_global, only : stdout, ionode - use cp_interfaces, only : invfft - use fft_base, only : dfftp - use ions_base, only : nsp, nat - use uspp_param, only : nhm - use nksic, only : innerloop_cg_nsd, & - innerloop_cg_nreset,& - innerloop_nmax, & - innerloop_atleast - use uspp, only : nkb - use control_flags, only : esic_conv_thr - use cg_module, only : tcg - use twin_types - ! - implicit none - ! - ! in/out vars - ! - integer :: ninner,nbsp,nbspx,nspin, nudx, nnrx - integer :: init_n, ngw, ispin(nbspx) - integer, intent(in) :: nouter - integer, intent(in) :: iupdwn(nspin), nupdwn(nspin) - real(dp), intent(in) :: etot - complex(dp) :: Omattot(nbspx,nbspx), c0(ngw,nbsp), cm(ngw,nbsp) - real(dp), intent(in) :: rot_threshold - real(dp), intent(inout) :: pink(nbsp), vsic(nnrx, nbspx), & - wfc_centers(4,nudx,nspin), wfc_spreads(nudx, nspin, 2) - logical :: lgam - type(twin_matrix) :: bec - - ! - ! local variables for cg routine - ! - integer :: nbnd1,nbnd2 - integer :: isp - logical :: ldotest - integer :: nfile - real(dp) :: dtmp - real(dp) :: ene0,ene1,enesti,enever,dene0 - real(dp) :: passo,passov,passof,passomax,spasso - real(dp) :: vsicah2sum,vsicah2sum_prev - integer :: nidx1,nidx2 - real(dp) :: dPI,dalpha,dmaxeig,deigrms - real(dp) :: pinksumprev,passoprod - ! - complex(dp), allocatable :: Omat1tot(:,:), Omat2tot(:,:) - real(dp), allocatable :: Heigbig(:) - complex(dp), allocatable :: Umatbig(:,:) - complex(dp), allocatable :: wfc_ctmp(:,:), wfc_ctmp2(:,:) - complex(dp), allocatable :: gi(:,:), hi(:,:) - ! - complex(dp), allocatable :: Umat(:,:) - real(dp), allocatable :: Heig(:) - complex(dp), allocatable :: vsicah(:,:) - real(dp), allocatable :: vsic1(:,:), vsic2(:,:) - type(twin_matrix) :: bec1,bec2 - real(dp), allocatable :: pink1(:), pink2(:) - logical :: restartcg_innerloop, ene_ok_innerloop, ltresh, setpassomax - integer :: iter3, nfail - integer :: maxiter3, numok, minsteps - real(dp) :: signalpha - character(len=4) :: marker - real(dp) :: conv_thr - - ! - ! main body - ! - CALL start_clock( 'nk_rot_emin' ) - ! - ! - marker=" " - maxiter3=4 - minsteps=2 - restartcg_innerloop = .true. - ene_ok_innerloop = .false. - ltresh=.false. - setpassomax=.false. - nfail=0 - if(nouter innerloop_nmax ) then - ! -#ifdef __DEBUG - if(ionode) write(1031,*) '# innerloop_nmax reached.' - if(ionode) write(1031,*) -#endif - if(ionode) then - write(stdout,"(14x,'# innerloop_nmax reached.',/)") - endif - ! - call stop_clock( "nk_innerloop" ) - exit inner_loop - ! - endif - -#ifdef __DEBUG - ! - ! call nksic_printoverlap(ninner,nouter) - -! if(mod(ninner,10).eq.1.or.ninner.le.5) ldotest=.true. - if(ninner.eq.31.or.ninner.eq.61.or.ninner.eq.91) ldotest=.true. -! if(ninner.le.10.and.nouter.eq.1) ldotest=.true. -! ldotest=.true. -! if(ninner.ge.25) ldotest=.true. - ! Now do the test - if(ldotest) then -! dtmp = 1.0d0*3.141592d0 - dtmp = 4.d0*3.141592d0 -! call nksic_rot_test(dtmp,201,nouter,ninner,etot) - ldotest=.false. - endif -#endif - - ! - !print out ESIC part & other total energy - ! - ene0 = sum( pink(1:nbsp) ) - - ! - ! test convergence - ! - if( abs(ene0-pinksumprev) < conv_thr ) then - numok=numok+1 - else - numok=0 - endif - ! - if( numok >= minsteps .and. ninner>=innerloop_atleast) ltresh=.true. - ! - if( ltresh ) then - ! -#ifdef __DEBUG - if(ionode) then - write(1037,"(a,/)") '# inner-loop converged.' - write(1031,"(a,/)") '# inner-loop converged.' - endif -#endif - if(ionode .and. numok twice passomax' -!$$$$ endif - -! if(ionode) then -! write(1037,*)'# deigrms = ',deigrms -! write(1037,*)'# vsicah2sum = ',vsicah2sum -! if(ninner.ne.1) write(1037,*)'# vsicah2sum/vsicah2sum_prev = ',dtmp -! endif - - - vsicah2sum_prev = vsicah2sum - ! - dene0 = 0.d0 - ! - do isp = 1, nspin - ! - do nbnd1 = 1, nupdwn(isp) - do nbnd2 = 1, nupdwn(isp) - ! - nidx1 = nbnd1-1+iupdwn(isp) - nidx2 = nbnd2-1+iupdwn(isp) - IF(nidx1.ne.nidx2) THEN - dene0 = dene0 - DBLE(CONJG(gi(nidx1,nidx2))*hi(nidx1,nidx2)) - ELSE !warning:giovanni: do we need this condition - !dene0 = dene0 -DBLE(CONJG(gi(nidx1,nidx2))*hi(nidx1,nidx2)) - ENDIF - ! - enddo - enddo - ! - enddo - - !$$ - !$$ dene0 = dene0 * 2.d0/nspin - ! - ! Be careful, the following is correct because A_ji = - A_ij, i.e., the number of - ! linearly independent variables is half the number of total variables! - ! - dene0 = dene0 * 1.d0/nspin - ! - spasso = 1.d0 - if( dene0 > 0.d0) spasso = -1.d0 - ! - dalpha = spasso*passof - ! - call nksic_getOmattot_new( nbsp, nbspx,nudx,nspin,ispin, & - iupdwn, nupdwn, wfc_centers, wfc_spreads, & - dalpha, Heigbig, Umatbig, c0, wfc_ctmp, & - Omat1tot, bec1, vsic1, pink1, ene1, lgam) - call minparabola( ene0, spasso*dene0, ene1, passof, passo, enesti) - ! - ! We neglect this step for paper writing purposes - ! - if( passo > passomax ) then - passo = passomax -#ifdef __DEBUG - if(ionode) write(1031,*) '# passo > passomax' -#endif - ! - endif - - passov = passof - passof = 2.d0*passo - - dalpha = spasso*passo - ! -!$$ The following line is for dene0 test -! if(ninner.ge.15) dalpha = spasso*passo*0.00001 -!$$ - call nksic_getOmattot( dalpha, Heigbig, Umatbig, c0, wfc_ctmp2, & - Omat2tot, bec2, vsic2, pink2, enever, lgam) -#ifdef __DEBUG - if(ionode) then - ! - write(1037,*) ninner, nouter - write(1037,'("ene0,ene1,enesti,enever")') - write(1037,'(a3,4f20.10)') 'CG1',ene0,ene1,enesti,enever - write(1037,'("spasso,passov,passo,passomax,dene0,& - & (enever-ene0)/passo/dene0")') - write(1037,'(a3,4f12.7,e20.10,f12.7)') & - 'CG2',spasso,passov,passo,passomax,dene0,(enever-ene0)/passo/dene0 - write(1037,*) - ! - endif -#endif - if(ene0 < ene1 .and. ene0 < enever) then !missed minimum case 3 - !write(6,'("# WARNING: innerloop missed minimum, case 3",/)') - ! - iter3=0 - signalpha=1.d0 - restartcg_innerloop=.true. - ! - do while(enever.ge.ene0 .and. iter3.lt.maxiter3) - ! - iter3=iter3+1 - ! - signalpha=signalpha*(-0.717d0) - dalpha = spasso*passo*signalpha - ! - call nksic_getOmattot( dalpha, Heigbig, Umatbig, c0, wfc_ctmp2, Omat2tot, bec2, vsic2, pink2, enever, lgam) - ! - enddo - - IF(enever.lt.ene0) THEN - ! - pink(:) = pink2(:) - vsic(:,:) = vsic2(:,:) - c0(:,:) = wfc_ctmp2(:,:) - call copy_twin(bec,bec2) - ! bec%rvec(:,:) = bec2(:,:) - Omattot = MATMUL( Omattot, Omat2tot) - !write(6,'("# WARNING: innerloop case 3 interations",3I/)') iter3 - write(marker,'(i1)') iter3 - marker = '*'//marker - passof=passo*abs(signalpha) - nfail=0 - ! - ELSE - ! - marker = '***' - ninner = ninner + 1 - nfail=nfail+1 - numok=0 - passof=passo*abs(signalpha) - ! - IF(nfail>2) THEN - write(6,'("# WARNING: innerloop not converged, exit",/)') - call stop_clock( "nk_innerloop" ) - exit - ENDIF -! ELSE -! nfail=0 -! ENDIF - ! - ENDIF -#ifdef __DEBUG - if(ionode) then - write(1037,'("# ene0= enever ) then !found minimum - ! - pink(:) = pink2(:) - vsic(:,:) = vsic2(:,:) - c0(:,:) = wfc_ctmp2(:,:) - call copy_twin(bec,bec2) -! bec%rvec(:,:) = bec2(:,:) - Omattot = MATMUL( Omattot, Omat2tot) - marker=" " - nfail=0 - ! - else !missed minimum, case 1 or 2 - ! - pink(:) = pink1(:) - vsic(:,:) = vsic1(:,:) - c0(:,:) = wfc_ctmp(:,:) - call copy_twin(bec,bec1) - Omattot = MATMUL( Omattot, Omat1tot) - restartcg_innerloop = .true. - IF(enever= 2 ) then - ! - wfc_ctmp(:,:) = CMPLX(0.d0,0.d0) - ! - do nbnd1=1,nbspx - do nbnd2=1,nbspx - wfc_ctmp(:,nbnd1)=wfc_ctmp(:,nbnd1) + cm(:,nbnd2) * Omattot(nbnd2,nbnd1) !warning:giovanni CONJUGATE? - ! XXX (we can think to use a blas, here, and split over spins) - !does not seem we need to make it conjugate - enddo - enddo - ! - cm(:,1:nbspx) = wfc_ctmp(:,1:nbspx) - ! - endif - ! - endif - ! - ! clean local workspace - ! - deallocate( Omat1tot, Omat2tot ) - deallocate( Umatbig ) - deallocate( Heigbig ) - deallocate( wfc_ctmp, wfc_ctmp2 ) - deallocate( hi ) - deallocate( gi ) - deallocate( pink1, pink2 ) - deallocate( vsic1, vsic2 ) - call deallocate_twin(bec1) - call deallocate_twin(bec2) - - CALL stop_clock( 'nk_rot_emin' ) - return - ! -!--------------------------------------------------------------- -end subroutine nksic_rot_emin_cg_new -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_rot_emin_cg(nouter,init_n, ninner,etot,Omattot, & - rot_threshold, lgam) -!----------------------------------------------------------------------- -! -! ... Finds the orthogonal rotation matrix Omattot that minimizes -! the orbital-dependent and hence the total energy, and then -! rotate the wavefunction c0 accordingly using cg minimization. -! We may need Omattot for further rotation of the gradient for outer loop CG. -! Right now we do not do that because we set resetcg=.true. after inner loop -! minimization routine, i.e., setting the search direction to be gradient direction. -! (Ultrasoft pseudopotential case is not implemented.) -! - use kinds, only : dp - use grid_dimensions, only : nnrx - use gvecw, only : ngw - use io_global, only : stdout, ionode - use electrons_base, only : nbsp, nbspx, nspin, & - iupdwn,nupdwn - use cp_interfaces, only : invfft - use fft_base, only : dfftp - use ions_base, only : nsp, nat - use uspp_param, only : nhm - use nksic, only : vsic, pink, & - innerloop_cg_nsd, innerloop_cg_nreset,& - innerloop_nmax, & - innerloop_atleast - use uspp, only : nkb - use cp_main_variables, only : bec - use wavefunctions_module, only : c0, cm - use control_flags, only : esic_conv_thr - use cg_module, only : tcg - use twin_types - ! - implicit none - ! - ! in/out vars - ! - integer :: ninner - integer :: init_n - integer, intent(in) :: nouter - real(dp), intent(in) :: etot - complex(dp) :: Omattot(nbspx,nbspx) - real(dp), intent(in) :: rot_threshold - logical :: lgam - - ! - ! local variables for cg routine - ! - integer :: nbnd1,nbnd2 - integer :: isp - logical :: ldotest - integer :: nfile - real(dp) :: dtmp - real(dp) :: ene0,ene1,enesti,enever,dene0 - real(dp) :: passo,passov,passof,passomax,spasso - real(dp) :: vsicah2sum,vsicah2sum_prev - integer :: nidx1,nidx2 - real(dp) :: dPI,dalpha,dmaxeig,deigrms - real(dp) :: pinksumprev,passoprod - ! - complex(dp), allocatable :: Omat1tot(:,:), Omat2tot(:,:) - real(dp), allocatable :: Heigbig(:) - complex(dp), allocatable :: Umatbig(:,:) - complex(dp), allocatable :: wfc_ctmp(:,:), wfc_ctmp2(:,:) - complex(dp), allocatable :: gi(:,:), hi(:,:) - ! - complex(dp), allocatable :: Umat(:,:) - real(dp), allocatable :: Heig(:) - complex(dp), allocatable :: vsicah(:,:) - real(dp), allocatable :: vsic1(:,:), vsic2(:,:) - type(twin_matrix) :: bec1,bec2 - real(dp), allocatable :: pink1(:), pink2(:) - logical :: restartcg_innerloop, ene_ok_innerloop, ltresh, setpassomax - integer :: iter3, nfail - integer :: maxiter3,numok - real(dp) :: signalpha - character(len=4) :: marker - real(dp) :: conv_thr - ! - ! for numerial derivative testing - integer :: i - real(dp) :: odd_test1, odd_test2, tmppasso - ! - ! main body - ! - CALL start_clock( 'nk_rot_emin' ) - ! - ! - marker=" " - maxiter3=4 - restartcg_innerloop = .true. - ene_ok_innerloop = .false. - ltresh=.false. - setpassomax=.false. - nfail=0 - if(nouter innerloop_nmax ) then - ! -#ifdef __DEBUG - if(ionode) write(1031,*) '# innerloop_nmax reached.' - if(ionode) write(1031,*) -#endif - if(ionode) then - write(stdout,"(14x,'# innerloop_nmax reached.',/)") - endif - ! - call stop_clock( "nk_innerloop" ) - exit inner_loop - ! - endif - -#ifdef __DEBUG - ! - ! call nksic_printoverlap(ninner,nouter) - -! if(mod(ninner,10).eq.1.or.ninner.le.5) ldotest=.true. - if(ninner.eq.31.or.ninner.eq.61.or.ninner.eq.91) ldotest=.true. -! if(ninner.le.10.and.nouter.eq.1) ldotest=.true. -! ldotest=.true. -! if(ninner.ge.25) ldotest=.true. - ! Now do the test - if(ldotest) then -! dtmp = 1.0d0*3.141592d0 - dtmp = 4.d0*3.141592d0 -! call nksic_rot_test(dtmp,201,nouter,ninner,etot) - ldotest=.false. - endif -#endif - - ! - !print out ESIC part & other total energy - ! - ene0 = sum( pink(1:nbsp) ) - - ! - ! test convergence - ! - if( abs(ene0-pinksumprev) < conv_thr ) then - numok=numok+1 - else - numok=0 - endif - ! - if( numok >= 2 .and. ninner>=innerloop_atleast) ltresh=.true. - ! - if( ltresh ) then - ! -#ifdef __DEBUG - if(ionode) then - write(1037,"(a,/)") '# inner-loop converged.' - write(1031,"(a,/)") '# inner-loop converged.' - endif -#endif - if(ionode) write(stdout,"(14x,'# innerloop converged',/)") - ! - call stop_clock( "nk_innerloop" ) - exit inner_loop - ! - endif - ! - pinksumprev=ene0 - - ! - ! This part calculates the anti-hermitian part of the Hamiltonian vsicah - ! and see whether a convergence has been achieved - ! - ! For this run, we obtain the gradient - ! - vsicah2sum = 0.0d0 - ! - do isp=1,nspin - ! - allocate(vsicah(nupdwn(isp),nupdwn(isp))) - ! - call nksic_getvsicah_new2(isp,vsicah,dtmp, lgam) - ! - gi( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = vsicah(:,:) - ! - vsicah2sum = vsicah2sum + dtmp - ! - deallocate(vsicah) - ! - enddo - ! - if( ninner /= 1 ) dtmp = vsicah2sum/vsicah2sum_prev - ! - if( ninner <= innerloop_cg_nsd .or. & - mod(ninner,innerloop_cg_nreset) ==0 .or. & - restartcg_innerloop ) then - ! - restartcg_innerloop=.false. - setpassomax=.false. - ! - hi(:,:) = gi(:,:) - write(stdout, *) "I am doing steepest de" - else - if (ninner==18) then - write(stdout, *) "I am doing conjgradient check" - hi(:,:) = gi(:,:) !+ dtmp*hi(:,:) - else - write(stdout, *) "I am doing conjgradient" - hi(:,:) = gi(:,:) + dtmp*hi(:,:) - endif - endif - ! - spin_loop: & - do isp=1,nspin - ! - IF(nupdwn(isp).gt.0) THEN - allocate( vsicah(nupdwn(isp),nupdwn(isp)) ) - allocate( Umat(nupdwn(isp),nupdwn(isp)) ) - allocate( Heig(nupdwn(isp)) ) - - vsicah(:,:) = hi( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) - - call nksic_getHeigU(isp,vsicah,Heig,Umat) - ! - deigrms = deigrms + sum(Heig(:)**2) - ! - Umatbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) = Umat(:,:) - Heigbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) = Heig(:) - ! - deallocate(vsicah) - deallocate(Umat) - deallocate(Heig) - ELSE - Umatbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) = 1.d0 - Heigbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) = 0.d0 - ENDIF - ! - enddo spin_loop - - ! how severe the transform is - deigrms = sqrt(deigrms/nbsp) -#ifdef __DEBUG - if(ionode) write(1031,'(2I10,3F24.13)') ninner, nouter,etot,ene0,deigrms -#endif - if(ionode) write(stdout,'(10x,A3,2i5,3F21.13)') marker, ninner, nouter, etot, ene0, deigrms - ! - ! - dmaxeig = max( dabs(Heigbig(iupdwn(1))), dabs(Heigbig(iupdwn(1)+nupdwn(1)-1)) ) - ! - do isp = 2, nspin - dmaxeig = max(dmaxeig,dabs(Heigbig(iupdwn(isp)))) - dmaxeig = max(dmaxeig,dabs(Heigbig(iupdwn(isp)+nupdwn(isp)-1))) - enddo - ! - passomax=passoprod/dmaxeig - ! - if( ninner == 1 .or. setpassomax) then - passof = passomax - setpassomax=.false. -#ifdef __DEBUG - if(ionode) write(1031,*) '# passof set to passomax' -#endif - endif - -!$$$$ if(passof .gt. passomax*2.d0) then -!$$$$ passof = passomax*2.d0 -!$$$$ if(ionode) write(1031,*) '# passof > twice passomax' -!$$$$ endif - -! if(ionode) then -! write(1037,*)'# deigrms = ',deigrms -! write(1037,*)'# vsicah2sum = ',vsicah2sum -! if(ninner.ne.1) write(1037,*)'# vsicah2sum/vsicah2sum_prev = ',dtmp -! endif - - - vsicah2sum_prev = vsicah2sum - ! - dene0 = 0.d0 - ! - do isp = 1, nspin - ! - do nbnd1 = 1, nupdwn(isp) - do nbnd2 = 1, nupdwn(isp) - ! - nidx1 = nbnd1-1+iupdwn(isp) - nidx2 = nbnd2-1+iupdwn(isp) - IF(nidx1.ne.nidx2) THEN - dene0 = dene0 - DBLE(CONJG(gi(nidx1,nidx2))*hi(nidx1,nidx2)) - ELSE !warning:giovanni: do we need this condition - !dene0 = dene0 -DBLE(CONJG(gi(nidx1,nidx2))*hi(nidx1,nidx2)) - ENDIF - ! - enddo - enddo - ! - enddo - ! - !$$ - !$$ dene0 = dene0 * 2.d0/nspin - ! - ! Be careful, the following is correct because A_ji = - A_ij, i.e., the number of - ! linearly independent variables is half the number of total variables! - ! - dene0 = dene0 * 1.d0/nspin - ! - spasso = 1.d0 - if( dene0 > 0.d0) spasso = -1.d0 - ! - if (.true.) then - ! - write(stdout, *) "Hello, I am computing numerical derivative" - ! - odd_test1 = 0.0 - odd_test2 = 0.0 - ! - do i=1,2 - ! - if (i==1) tmppasso=1.d-3 - if (i==2) tmppasso=-1.d-3 - ! - dalpha = spasso*tmppasso - ! - call nksic_getOmattot( dalpha, Heigbig, Umatbig, c0, wfc_ctmp, & - Omat1tot, bec1, vsic1, pink1, ene1, lgam) - ! - if (i==1) odd_test1 = ene1 - if (i==2) odd_test2 = ene1 - ! - enddo - ! - write(stdout, *) " odd_test1 odd_test2 ", odd_test1, odd_test2 - write(stdout, *) "ratio bw numerial and analytic derivative = ", & - ((odd_test1-odd_test2)/(tmppasso*2.0))/dene0 - write(stdout, *) "ratio bw numerial and analytic derivative = ", ((odd_test1-ene0)/(tmppasso))/dene0 - ! - endif - ! - dalpha = spasso*passof - ! - call nksic_getOmattot( dalpha, Heigbig, Umatbig, c0, wfc_ctmp, & - Omat1tot, bec1, vsic1, pink1, ene1, lgam) - call minparabola( ene0, spasso*dene0, ene1, passof, passo, enesti) - - ! - ! We neglect this step for paper writing purposes - ! - if( passo > passomax ) then - passo = passomax -#ifdef __DEBUG - if(ionode) write(1031,*) '# passo > passomax' -#endif - ! - endif - - passov = passof - passof = 2.d0*passo - - dalpha = spasso*passo - ! -!$$ The following line is for dene0 test -! if(ninner.ge.15) dalpha = spasso*passo*0.00001 -!$$ - call nksic_getOmattot( dalpha, Heigbig, Umatbig, c0, wfc_ctmp2, & - Omat2tot, bec2, vsic2, pink2, enever, lgam) - -#ifdef __DEBUG - if(ionode) then - ! - write(1037,*) ninner, nouter - write(1037,'("ene0,ene1,enesti,enever")') - write(1037,'(a3,4f20.10)') 'CG1',ene0,ene1,enesti,enever - write(1037,'("spasso,passov,passo,passomax,dene0,& - & (enever-ene0)/passo/dene0")') - write(1037,'(a3,4f12.7,e20.10,f12.7)') & - 'CG2',spasso,passov,passo,passomax,dene0,(enever-ene0)/passo/dene0 - write(1037,*) - ! - endif -#endif - - if(ene0 < ene1 .and. ene0 < enever) then !missed minimum case 3 - !write(6,'("# WARNING: innerloop missed minimum, case 3",/)') - ! - iter3=0 - signalpha=1.d0 - restartcg_innerloop=.true. - ! - do while(enever.ge.ene0 .and. iter3.lt.maxiter3) - ! - iter3=iter3+1 - ! - signalpha=signalpha*(-0.717d0) - dalpha = spasso*passo*signalpha - ! - call nksic_getOmattot( dalpha, Heigbig, Umatbig, c0, wfc_ctmp2, Omat2tot, bec2, vsic2, pink2, enever, lgam) - ! - enddo - - IF(enever.lt.ene0) THEN - ! - pink(:) = pink2(:) - vsic(:,:) = vsic2(:,:) - c0(:,:) = wfc_ctmp2(:,:) - call copy_twin(bec,bec2) - ! bec%rvec(:,:) = bec2(:,:) - Omattot = MATMUL( Omattot, Omat2tot) - !write(6,'("# WARNING: innerloop case 3 interations",3I/)') iter3 - write(marker,'(i1)') iter3 - marker = '*'//marker - passof=passo*abs(signalpha) - nfail=0 - ! - ELSE - ! - marker = '***' - ninner = ninner + 1 - nfail=nfail+1 - numok=0 - passof=passo*abs(signalpha) - ! - IF(nfail>2) THEN - write(6,'("# WARNING: innerloop not converged, exit",/)') - call stop_clock( "nk_innerloop" ) - exit - ENDIF -! ELSE -! nfail=0 -! ENDIF - ! - ENDIF -#ifdef __DEBUG - if(ionode) then - write(1037,'("# ene0= enever ) then !found minimum - ! - pink(:) = pink2(:) - vsic(:,:) = vsic2(:,:) - c0(:,:) = wfc_ctmp2(:,:) - call copy_twin(bec,bec2) -! bec%rvec(:,:) = bec2(:,:) - Omattot = MATMUL( Omattot, Omat2tot) - marker=" " - nfail=0 - ! - else !missed minimum, case 1 or 2 - ! - pink(:) = pink1(:) - vsic(:,:) = vsic1(:,:) - c0(:,:) = wfc_ctmp(:,:) - call copy_twin(bec,bec1) - Omattot = MATMUL( Omattot, Omat1tot) - restartcg_innerloop = .true. - IF(enever= 2 ) then - ! - wfc_ctmp(:,:) = CMPLX(0.d0,0.d0) - ! - do nbnd1=1,nbspx - do nbnd2=1,nbspx - wfc_ctmp(:,nbnd1)=wfc_ctmp(:,nbnd1) + cm(:,nbnd2) * Omattot(nbnd2,nbnd1) !warning:giovanni CONJUGATE? - ! XXX (we can think to use a blas, here, and split over spins) - !does not seem we need to make it conjugate - enddo - enddo - ! - cm(:,1:nbspx) = wfc_ctmp(:,1:nbspx) - ! - endif - ! - endif - - ! - ! clean local workspace - ! - deallocate( Omat1tot, Omat2tot ) - deallocate( Umatbig ) - deallocate( Heigbig ) - deallocate( wfc_ctmp, wfc_ctmp2 ) - deallocate( hi ) - deallocate( gi ) - deallocate( pink1, pink2 ) - deallocate( vsic1, vsic2 ) - call deallocate_twin(bec1) - call deallocate_twin(bec2) -! deallocate( bec1, bec2 ) - - - CALL stop_clock( 'nk_rot_emin' ) - return - ! -!--------------------------------------------------------------- -end subroutine nksic_rot_emin_cg -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_rot_emin_cg_descla(nouter,ninner,etot,Omattot, lgam) -!----------------------------------------------------------------------- -! !warning:giovanni why not passing wavefunctions as variables??? - -! ... Finds the orthogonal rotation matrix Omattot that minimizes -! the orbital-dependent and hence the total energy, and then -! rotate the wavefunction c0 accordingly using cg minimization. -! We may need Omattot for further rotation of the gradient for outer loop CG. -! Right now we do not do that because we set resetcg=.true. after inner loop -! minimization routine, i.e., setting the search direction to be gradient direction. -! (Ultrasoft pseudopotential case is not implemented.) -! - use kinds, only : dp - use grid_dimensions, only : nnrx - use gvecw, only : ngw - use io_global, only : stdout, ionode - use electrons_base, only : nbsp, nbspx, nspin, & - iupdwn,nupdwn - use cp_interfaces, only : invfft - use fft_base, only : dfftp - use ions_base, only : nsp, nat - use uspp_param, only : nhm - use nksic, only : vsic, pink, & - innerloop_cg_nsd, innerloop_cg_nreset,& - innerloop_nmax - use uspp, only : nkb - use cp_main_variables, only : bec - use wavefunctions_module, only : c0, cm - use control_flags, only : esic_conv_thr - use cg_module, only : tcg - use twin_types - ! - implicit none - ! - ! in/out vars - ! - integer :: ninner - integer, intent(in) :: nouter - real(dp), intent(in) :: etot - complex(dp) :: Omattot(nbspx,nbspx) - logical :: lgam - - ! - ! local variables for cg routine - ! - integer :: nbnd1,nbnd2 - integer :: isp - logical :: ldotest - integer :: nfile - real(dp) :: dtmp - real(dp) :: ene0,ene1,enesti,enever,dene0 - real(dp) :: passo,passov,passof,passomax,spasso - real(dp) :: vsicah2sum,vsicah2sum_prev - integer :: nidx1,nidx2 - real(dp) :: dPI,dalpha,dmaxeig,deigrms - real(dp) :: pinksumprev,passoprod - ! - complex(dp), allocatable :: Omat1tot(:,:), Omat2tot(:,:) - real(dp), allocatable :: Heigbig(:) - complex(dp), allocatable :: Umatbig(:,:) - complex(dp), allocatable :: wfc_ctmp(:,:), wfc_ctmp2(:,:) - complex(dp), allocatable :: gi(:,:), hi(:,:) - ! - complex(dp), allocatable :: Umat(:,:) - real(dp), allocatable :: Heig(:) - complex(dp), allocatable :: vsicah(:,:) - real(dp), allocatable :: vsic1(:,:), vsic2(:,:) - type(twin_matrix) :: bec1,bec2 - real(dp), allocatable :: pink1(:), pink2(:) - - ! - ! main body - ! - CALL start_clock( 'nk_rot_emin' ) - ! - ! - pinksumprev=1.d8 - dPI = 2.0_DP * asin(1.0_DP) - passoprod = (0.3d0/dPI)*dPI - - ! - ! local workspace - ! - allocate( Omat1tot(nbspx,nbspx), Omat2tot(nbspx,nbspx) ) - allocate( Umatbig(nbspx,nbspx) ) - allocate( Heigbig(nbspx) ) - allocate( wfc_ctmp(ngw,nbspx), wfc_ctmp2(ngw,nbspx) ) - allocate( hi(nbsp,nbsp) ) - allocate( gi(nbsp,nbsp) ) - allocate( pink1(nbspx), pink2(nbspx) ) - allocate( vsic1(nnrx,nbspx), vsic2(nnrx,nbspx) ) - call init_twin(bec1, lgam) - call allocate_twin(bec1,nkb,nbsp,lgam) - call init_twin(bec2,lgam) - call allocate_twin(bec2,nkb,nbsp,lgam) - ! - Umatbig(:,:)=(0.d0,0.d0) - Heigbig(:)=0.d0 - deigrms = 0.d0 - hi(:,:) = 0.d0 - gi(:,:) = 0.d0 - - Omattot(:,:)=0.d0 - do nbnd1=1,nbspx - Omattot(nbnd1,nbnd1)=CMPLX(1.d0,0.d0) - enddo - - ninner = 0 - ldotest=.false. - - if (ionode) write(stdout, "(14x,'# iter',6x,'etot',17x,'esic',& - & 17x,'deigrms')") - - ! - ! main loop - ! - inner_loop: & - do while (.true.) - - call start_clock( "nk_innerloop" ) - ! - ninner = ninner + 1 - - if( ninner > innerloop_nmax ) then - ! -#ifdef __DEBUG - if(ionode) write(1031,*) '# innerloop_nmax reached.' - if(ionode) write(1031,*) -#endif - if(ionode) then - write(stdout,"(14x,'# innerloop_nmax reached.',/)") - endif - ! - call stop_clock( "nk_innerloop" ) - exit inner_loop - ! - endif - -#ifdef __DEBUG - ! - ! call nksic_printoverlap(ninner,nouter) - -! if(mod(ninner,10).eq.1.or.ninner.le.5) ldotest=.true. - if(ninner.eq.31.or.ninner.eq.61.or.ninner.eq.91) ldotest=.true. -! if(ninner.le.10.and.nouter.eq.1) ldotest=.true. -! ldotest=.true. -! if(ninner.ge.25) ldotest=.true. - ! Now do the test - if(ldotest) then -! dtmp = 1.0d0*3.141592d0 - dtmp = 4.d0*3.141592d0 -! call nksic_rot_test(dtmp,201,nouter,ninner,etot) - ldotest=.false. - endif -#endif - - ! - !print out ESIC part & other total energy - ! - ene0 = sum( pink(1:nbsp) ) - - ! - ! test convergence - ! - if( abs(ene0-pinksumprev) < esic_conv_thr) then - ! -#ifdef __DEBUG - if(ionode) then - write(1037,"(a,/)") '# inner-loop converged.' - write(1031,"(a,/)") '# inner-loop converged.' - endif -#endif - if(ionode) write(stdout,"(14x,'# innerloop converged',/)") - ! - call stop_clock( "nk_innerloop" ) - exit inner_loop - ! - endif - ! - pinksumprev=ene0 - - ! - ! This part calculates the anti-hermitian part of the Hamiltonian vsicah - ! and see whether a convergence has been achieved - ! - ! For this run, we obtain the gradient - ! - vsicah2sum = 0.0d0 - ! - do isp=1,nspin - ! - allocate(vsicah(nupdwn(isp),nupdwn(isp))) - ! - call nksic_getvsicah_new2(isp,vsicah,dtmp, lgam) - ! - gi( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = vsicah(:,:) - ! - vsicah2sum = vsicah2sum + dtmp - ! - deallocate(vsicah) - ! - enddo - ! - if( ninner /= 1 ) dtmp = vsicah2sum/vsicah2sum_prev - ! - if( ninner <= innerloop_cg_nsd .or. & - mod(ninner,innerloop_cg_nreset) ==0 ) then - ! - hi(:,:) = gi(:,:) - else - hi(:,:) = gi(:,:) + dtmp*hi(:,:) - endif - ! - spin_loop: & - do isp=1,nspin - ! - allocate( vsicah(nupdwn(isp),nupdwn(isp)) ) - allocate( Umat(nupdwn(isp),nupdwn(isp)) ) - allocate( Heig(nupdwn(isp)) ) - - vsicah(:,:) = hi( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) - - call nksic_getHeigU(isp,vsicah,Heig,Umat) - ! - deigrms = deigrms + sum(Heig(:)**2) - ! - Umatbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp), & - iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) = Umat(:,:) - Heigbig( iupdwn(isp):iupdwn(isp)-1+nupdwn(isp) ) = Heig(:) - ! - deallocate(vsicah) - deallocate(Umat) - deallocate(Heig) - ! - enddo spin_loop - - ! how severe the transform is - deigrms = sqrt(deigrms/nbsp) -#ifdef __DEBUG - if(ionode) write(1031,'(2I10,3F24.13)') ninner, nouter,etot,ene0,deigrms -#endif - if(ionode) write(stdout,'(10x,2i5,3F21.13)') ninner, nouter, etot, ene0, deigrms - ! - ! - dmaxeig = max( abs(Heigbig(iupdwn(1))), abs(Heigbig(iupdwn(1)+nupdwn(1)-1)) ) - ! - do isp = 2, nspin - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)))) - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)+nupdwn(isp)-1))) - enddo - ! - passomax=passoprod/dmaxeig - ! - if( ninner == 1 ) then - passof = passomax -#ifdef __DEBUG - if(ionode) write(1031,*) '# passof set to passomax' -#endif - endif - -!$$$$ if(passof .gt. passomax*2.d0) then -!$$$$ passof = passomax*2.d0 -!$$$$ if(ionode) write(1031,*) '# passof > twice passomax' -!$$$$ endif - -! if(ionode) then -! write(1037,*)'# deigrms = ',deigrms -! write(1037,*)'# vsicah2sum = ',vsicah2sum -! if(ninner.ne.1) write(1037,*)'# vsicah2sum/vsicah2sum_prev = ',dtmp -! endif - - - vsicah2sum_prev = vsicah2sum - ! - dene0 = 0.d0 - ! - do isp = 1, nspin - ! - do nbnd1 = 1, nupdwn(isp) - do nbnd2 = 1, nupdwn(isp) - ! - nidx1 = nbnd1-1+iupdwn(isp) - nidx2 = nbnd2-1+iupdwn(isp) - IF(nidx1.eq.nidx2) THEN - dene0 = dene0 -DBLE(CONJG(gi(nidx1,nidx2))*hi(nidx1,nidx2)) - ELSE - dene0 = dene0 -0.5d0*DBLE(CONJG(gi(nidx1,nidx2))*hi(nidx1,nidx2)) - ENDIF - ! - enddo - enddo - ! - enddo - - !$$ - !$$ dene0 = dene0 * 2.d0/nspin - ! - ! Be careful, the following is correct because A_ji = - A_ij, i.e., the number of - ! linearly independent variables is half the number of total variables! - ! - dene0 = dene0 * 2.d0/nspin - ! - spasso = 1.d0 - if( dene0 > 0.d0) spasso = -1.d0 - ! - dalpha = spasso*passof - ! - call nksic_getOmattot( dalpha, Heigbig, Umatbig, c0, wfc_ctmp, & - Omat1tot, bec1, vsic1, pink1, ene1, lgam) - call minparabola( ene0, spasso*dene0, ene1, passof, passo, enesti) - - ! - ! We neglect this step for paper writing purposes - ! - if( passo > passomax ) then - passo = passomax -#ifdef __DEBUG - if(ionode) write(1031,*) '# passo > passomax' -#endif - ! - endif - - passov = passof - passof = 2.d0*passo - - dalpha = spasso*passo - ! -!$$ The following line is for dene0 test -! if(ninner.ge.15) dalpha = spasso*passo*0.00001 -!$$ - call nksic_getOmattot( dalpha, Heigbig, Umatbig, c0, wfc_ctmp2, & - Omat2tot, bec2, vsic2, pink2, enever, lgam) - -#ifdef __DEBUG - if(ionode) then - ! - write(1037,*) ninner, nouter - write(1037,'("ene0,ene1,enesti,enever")') - write(1037,'(a3,4f20.10)') 'CG1',ene0,ene1,enesti,enever - write(1037,'("spasso,passov,passo,passomax,dene0,& - & (enever-ene0)/passo/dene0")') - write(1037,'(a3,4f12.7,e20.10,f12.7)') & - 'CG2',spasso,passov,passo,passomax,dene0,(enever-ene0)/passo/dene0 - write(1037,*) - ! - endif -#endif - - if(ene0 < ene1 .and. ene0 < enever) then - ! -#ifdef __DEBUG - if(ionode) then - write(1037,'("# ene0= enever ) then - ! - pink(:) = pink2(:) - vsic(:,:) = vsic2(:,:) - c0(:,:) = wfc_ctmp2(:,:) - call copy_twin(bec,bec2) -! bec%rvec(:,:) = bec2(:,:) - Omattot = MATMUL( Omattot, Omat2tot) - ! - else - ! - pink(:) = pink1(:) - vsic(:,:) = vsic1(:,:) - c0(:,:) = wfc_ctmp(:,:) - call copy_twin(bec,bec1) - Omattot = MATMUL( Omattot, Omat1tot) - ! -#ifdef __DEBUG - if(ionode) then - write(1037,'("# It happened that ene1 < enever!!")') - write(1037,*) - endif -#endif - ! -! ======= -! pink(:) = pink1(:) -! vsic(:,:) = vsic1(:,:) -! c0(:,:) = wfn_ctmp(:,:) -! bec%rvec(:,:) = bec1(:,:) -! Omattot = MATMUL(Omattot,Omat1tot) -! if(ionode) then -! write(1037,'("# It happened that ene1 < enever!!")') -! write(1037,*) -! endif -! 1.28.2.14 - endif - ! - call stop_clock( "nk_innerloop" ) - ! - enddo inner_loop - - ! - ! Wavefunction cm rotation according to Omattot - ! We need this because outer loop could be damped dynamics. - ! - if ( .not. tcg ) then - ! - if( ninner >= 2 ) then - ! - wfc_ctmp(:,:) = (0.d0,0.d0) - ! - do nbnd1=1,nbspx - do nbnd2=1,nbspx - wfc_ctmp(:,nbnd1)=wfc_ctmp(:,nbnd1) + cm(:,nbnd2) * Omattot(nbnd2,nbnd1) !warning:giovanni CONJUGATE? - ! XXX (we can think to use a blas, here, and split over spins) - enddo - enddo - ! - cm(:,1:nbspx) = wfc_ctmp(:,1:nbspx) - ! - endif - ! - endif - - ! - ! clean local workspace - ! - deallocate( Omat1tot, Omat2tot ) - deallocate( Umatbig ) - deallocate( Heigbig ) - deallocate( wfc_ctmp, wfc_ctmp2 ) - deallocate( hi ) - deallocate( gi ) - deallocate( pink1, pink2 ) - deallocate( vsic1, vsic2 ) - call deallocate_twin(bec1) - call deallocate_twin(bec2) -! deallocate( bec1, bec2 ) - - - CALL stop_clock( 'nk_rot_emin' ) - return - ! -!--------------------------------------------------------------- -end subroutine nksic_rot_emin_cg_descla -!--------------------------------------------------------------- - -!--------------------------------------------------------------- - subroutine nksic_getOmattot_new(nbsp,nbspx,nudx,nspin,ispin, & - iupdwn,nupdwn,wfc_centers,wfc_spreads, & - dalpha,Heigbig,Umatbig,wfc0, & - wfc1,Omat1tot,bec1,vsic1,pink1,ene1,lgam, is_empty)!warning:giovanni bec1 here needs to be a twin! -!--------------------------------------------------------------- -! -! ... This routine rotates the wavefunction wfc0 into wfc1 according to -! the force matrix (Heigbig, Umatbig) and the step of size dalpha. -! Other quantities such as bec, vsic, pink are also calculated for wfc1. - - use kinds, only : dp - use grid_dimensions, only : nnrx - use gvecw, only : ngw - use ions_base, only : nsp - use uspp, only : becsum,nkb - use cp_main_variables, only : eigr, rhor - use nksic, only : deeq_sic, wtot, fsic, sizwtot - use control_flags, only : gamma_only, do_wf_cmplx - use twin_types - use electrons_module, only : icompute_spread - use core, only : rhoc - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: nbsp, nbspx, nudx, nspin - integer, intent(in) :: ispin(nbspx), nupdwn(nspin), & - iupdwn(nspin) - real(dp), intent(in) :: dalpha - complex(dp), intent(in) :: Umatbig(nbspx,nbspx) - real(dp), intent(in) :: Heigbig(nbspx), wfc_centers(4,nudx,nspin),& - wfc_spreads(nudx,nspin,2) - complex(dp), intent(in) :: wfc0(ngw,nbspx) - ! - complex(dp) :: wfc1(ngw,nbspx) - complex(dp) :: Omat1tot(nbspx,nbspx) - type(twin_matrix) :: bec1 !(nkb,nbsp) !modified:giovanni - real(dp) :: vsic1(nnrx,nbspx) - real(dp) :: pink1(nbspx) - real(dp) :: ene1 - logical :: lgam, is_empty - - ! - ! local variables for cg routine - ! - integer :: isp, nbnd1 - real(dp) :: dmaxeig - complex(dp), allocatable :: Omat1(:,:) - complex(dp), allocatable :: Umat(:,:) - real(dp), allocatable :: Heig(:) - - ! - call start_clock( "nk_getOmattot" ) - ! - -! call init_twin(bec1,lgam) -! call allocate_twin(bec1,nkb,nbsp, lgam) - - Omat1tot(:,:) = 0.d0 - do nbnd1=1,nbspx - Omat1tot(nbnd1,nbnd1)=1.d0 - enddo - - wfc1(:,:) = CMPLX(0.d0,0.d0) - - dmaxeig = max( abs(Heigbig(iupdwn(1))), abs(Heigbig(iupdwn(1)+nupdwn(1)-1)) ) - do isp=2,nspin - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)))) - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)+nupdwn(isp)-1))) - enddo - - spin_loop: & - do isp=1,nspin - ! - IF(nupdwn(isp).gt.0) THEN - ! - allocate(Umat(nupdwn(isp),nupdwn(isp))) - allocate(Heig(nupdwn(isp))) - allocate(Omat1(nupdwn(isp),nupdwn(isp))) - - Umat(:,:) = Umatbig(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp),iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) - Heig(:) = Heigbig(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) - - call nksic_getOmat1(isp,Heig,Umat,dalpha,Omat1, lgam) - -!$$ Wavefunction wfc0 is rotated into wfc0 using Omat1 - call nksic_rotwfn(isp,Omat1,wfc0,wfc1) - -! Assigning the rotation matrix for a specific spin isp - Omat1tot(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp),iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = Omat1(:,:) - - deallocate(Umat) - deallocate(Heig) - deallocate(Omat1) - ! - ELSE - Omat1tot(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp),iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = 1.d0 - ENDIF - ! - enddo spin_loop - - ! - ! recalculate bec & vsic according to the new wavefunction - ! - call calbec(1,nsp,eigr,wfc1,bec1) - - vsic1(:,:) = 0.d0 - pink1(:) = 0.d0 - ! - call nksic_potential( nbsp, nbspx, wfc1, fsic, bec1, becsum, deeq_sic, & - ispin, iupdwn, nupdwn, rhor, rhoc, wtot, sizwtot, vsic1, pink1, nudx, wfc_centers, & - wfc_spreads, icompute_spread, is_empty ) - ! - ene1=sum(pink1(:)) - -! call deallocate_twin(bec1) - - ! - call stop_clock( "nk_getOmattot" ) - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getOmattot_new -!--------------------------------------------------------------- - -!--------------------------------------------------------------- - subroutine nksic_getOmattot(dalpha,Heigbig,Umatbig,wfc0,wfc1,Omat1tot,bec1,vsic1,pink1,ene1, lgam)!warning:giovanni bec1 here needs to be a twin! -!--------------------------------------------------------------- -! -! ... This routine rotates the wavefunction wfc0 into wfc1 according to -! the force matrix (Heigbig, Umatbig) and the step of size dalpha. -! Other quantities such as bec, vsic, pink are also calculated for wfc1. -! - - use kinds, only : dp - use grid_dimensions, only : nnrx - use gvecw, only : ngw - use electrons_base, only : nbsp, nbspx, nspin, ispin, & - iupdwn, nupdwn, nudx - use ions_base, only : nsp - use uspp, only : becsum,nkb - use cp_main_variables, only : eigr, rhor - use nksic, only : deeq_sic, wtot, fsic, sizwtot, do_wxd, & - valpsi, odd_alpha - use control_flags, only : gamma_only, do_wf_cmplx - use twin_types - use electrons_module, only : wfc_centers, wfc_spreads, & - icompute_spread - use core, only : rhoc - use input_parameters, only : odd_nkscalfact - ! - implicit none - ! - ! in/out vars - ! - real(dp), intent(in) :: dalpha - complex(dp), intent(in) :: Umatbig(nbspx,nbspx) - real(dp), intent(in) :: Heigbig(nbspx) - complex(dp), intent(in) :: wfc0(ngw,nbspx) - ! - complex(dp) :: wfc1(ngw,nbspx) - complex(dp) :: Omat1tot(nbspx,nbspx) - type(twin_matrix) :: bec1 !(nkb,nbsp) !modified:giovanni - real(dp) :: vsic1(nnrx,nbspx) - real(dp) :: pink1(nbspx) - real(dp) :: ene1 - logical :: lgam - - ! - ! local variables for cg routine - ! - integer :: isp, nbnd1 - real(dp) :: dmaxeig - complex(dp), allocatable :: Omat1(:,:) - complex(dp), allocatable :: Umat(:,:) - real(dp), allocatable :: Heig(:) - - ! - call start_clock( "nk_getOmattot" ) - ! - -! call init_twin(bec1,lgam) -! call allocate_twin(bec1,nkb,nbsp, lgam) - - Omat1tot(:,:) = 0.d0 - do nbnd1=1,nbspx - Omat1tot(nbnd1,nbnd1)=1.d0 - enddo - - wfc1(:,:) = CMPLX(0.d0,0.d0) - - dmaxeig = max( abs(Heigbig(iupdwn(1))), abs(Heigbig(iupdwn(1)+nupdwn(1)-1)) ) - do isp=2,nspin - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)))) - dmaxeig = max(dmaxeig,abs(Heigbig(iupdwn(isp)+nupdwn(isp)-1))) - enddo - - spin_loop: & - do isp=1,nspin - ! - IF(nupdwn(isp).gt.0) THEN - ! - allocate(Umat(nupdwn(isp),nupdwn(isp))) - allocate(Heig(nupdwn(isp))) - allocate(Omat1(nupdwn(isp),nupdwn(isp))) - - Umat(:,:) = Umatbig(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp),iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) - Heig(:) = Heigbig(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) - - call nksic_getOmat1(isp,Heig,Umat,dalpha,Omat1, lgam) - -!$$ Wavefunction wfc0 is rotated into wfc0 using Omat1 - call nksic_rotwfn(isp,Omat1,wfc0,wfc1) - -! Assigning the rotation matrix for a specific spin isp - Omat1tot(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp),iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = Omat1(:,:) - - deallocate(Umat) - deallocate(Heig) - deallocate(Omat1) - ! - ELSE - Omat1tot(iupdwn(isp):iupdwn(isp)-1+nupdwn(isp),iupdwn(isp):iupdwn(isp)-1+nupdwn(isp)) = 1.d0 - ENDIF - ! - enddo spin_loop - ! - ! recalculate bec & vsic according to the new wavefunction - ! - call calbec(1,nsp,eigr,wfc1,bec1) - ! - if (odd_nkscalfact) then - ! - valpsi(:,:) = (0.0_DP, 0.0_DP) - odd_alpha(:) = 0.0_DP - ! - call odd_alpha_routine(wfc1, nbsp, nbspx, lgam, .false.) - ! - endif - ! - vsic1(:,:) = 0.d0 - pink1(:) = 0.d0 - ! - ! - call nksic_potential( nbsp, nbspx, wfc1, fsic, bec1, becsum, deeq_sic, & - ispin, iupdwn, nupdwn, rhor, rhoc, wtot, sizwtot, vsic1, do_wxd, pink1, nudx, wfc_centers, & - wfc_spreads, icompute_spread, .false. ) - ! - ene1=sum(pink1(:)) - -! call deallocate_twin(bec1) - - ! - call stop_clock( "nk_getOmattot" ) - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getOmattot -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_rotwfn(isp,Omat1,wfc1,wfc2) -!----------------------------------------------------------------------- -! -! ... Simple rotation of wfc1 into wfc2 by Omat1. -! wfc2(n) = sum_m wfc1(m) Omat1(m,n) -! - use electrons_base, only : iupdwn,nupdwn,nbspx - use gvecw, only : ngw - use kinds, only : dp - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp - complex(dp), intent(in) :: Omat1(nupdwn(isp),nupdwn(isp)) - complex(dp), intent(in) :: wfc1(ngw,nbspx) - complex(dp) :: wfc2(ngw,nbspx) - - ! - ! local variables for cg routine - ! - integer :: nbnd1,nbnd2 - - CALL start_clock('nk_rotwfn') - ! - wfc2(:,iupdwn(isp):iupdwn(isp)-1+nupdwn(isp))=CMPLX(0.d0,0.d0) - - ! - ! a blas could be used here XXX - ! - do nbnd1=1,nupdwn(isp) - do nbnd2=1,nupdwn(isp) - ! - wfc2(:,iupdwn(isp)-1 + nbnd1)=wfc2(:,iupdwn(isp)-1 + nbnd1) & - + wfc1(:,iupdwn(isp)-1 + nbnd2) * Omat1(nbnd2,nbnd1) - ! - enddo - enddo - - CALL stop_clock('nk_rotwfn') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_rotwfn -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_getHeigU_new(nspin, isp, nupdwn, vsicah, Heig, Umat) -!----------------------------------------------------------------------- -! -! ... solves the eigenvalues (Heig) and eigenvectors (Umat) of the force -! matrix vsicah. -! (Ultrasoft pseudopotential case is not implemented.) -! - use kinds, only : dp - use mp, only : mp_bcast - use mp_global, only : intra_image_comm - use io_global, only : ionode, ionode_id - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp, nspin, nupdwn(nspin) - real(dp) :: Heig(nupdwn(isp)) - complex(dp) :: Umat(nupdwn(isp),nupdwn(isp)) - complex(dp) :: vsicah(nupdwn(isp),nupdwn(isp)) - - - ! - ! local variables - ! - complex(dp) :: Hmat(nupdwn(isp),nupdwn(isp)) - complex(dp) :: ci - - ci = CMPLX(0.d0,1.d0) - -!$$ Now this part diagonalizes Hmat = iWmat - Hmat(:,:) = ci * vsicah(:,:) -!$$ diagonalize Hmat -! if(ionode) then - CALL zdiag(nupdwn(isp),nupdwn(isp),Hmat(1,1),Heig(1),Umat(1,1),1) -! endif - -! CALL mp_bcast(Umat, ionode_id, intra_image_comm) -! CALL mp_bcast(Heig, ionode_id, intra_image_comm) - - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getHeigU_new -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_getHeigU(isp,vsicah,Heig,Umat) -!----------------------------------------------------------------------- -! -! ... solves the eigenvalues (Heig) and eigenvectors (Umat) of the force -! matrix vsicah. -! (Ultrasoft pseudopotential case is not implemented.) -! - use kinds, only : dp - use mp, only : mp_bcast - use mp_global, only : intra_image_comm - use io_global, only : ionode, ionode_id - use electrons_base, only : nupdwn - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp - real(dp) :: Heig(nupdwn(isp)) - complex(dp) :: Umat(nupdwn(isp),nupdwn(isp)) - complex(dp) :: vsicah(nupdwn(isp),nupdwn(isp)) - - - ! - ! local variables - ! - complex(dp) :: Hmat(nupdwn(isp),nupdwn(isp)) - complex(dp) :: ci - - ci = CMPLX(0.d0,1.d0) - -!$$ Now this part diagonalizes Hmat = iWmat - Hmat(:,:) = ci * vsicah(:,:) -!$$ diagonalize Hmat -! if(ionode) then - CALL zdiag(nupdwn(isp),nupdwn(isp),Hmat(1,1),Heig(1),Umat(1,1),1) -! endif - -! CALL mp_bcast(Umat, ionode_id, intra_image_comm) -! CALL mp_bcast(Heig, ionode_id, intra_image_comm) - - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getHeigU -!--------------------------------------------------------------- - - -!----------------------------------------------------------------------- - subroutine nksic_printoverlap(ninner,nouter) -!----------------------------------------------------------------------- -! -! ... Calculates the anti-hermitian part of the SIC hamiltonian, vsicah. -! - use kinds, only : dp - use grid_dimensions, only : nr1x, nr2x, nr3x, nnrx - use gvecw, only : ngw - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use io_global, only : ionode - use electrons_base, only : nbspx - use cp_interfaces, only : invfft - use fft_base, only : dfftp - use nksic, only : vsic - use wavefunctions_module, only : c0 - ! - implicit none - ! - ! in/out vars - ! - integer :: ninner, nouter - real(dp) :: overlap(nbspx,nbspx),vsicah(nbspx,nbspx) - - ! - ! local variables - ! - complex(dp) :: psi1(nnrx), psi2(nnrx) - real(dp) :: overlaptmp,vsicahtmp - integer :: i,nbnd1,nbnd2 - real(dp) :: dwfnnorm - - dwfnnorm = 1.0/(DBLE(nr1x)*DBLE(nr2x)*DBLE(nr3x)) - - vsicah(:,:) = 0.d0 - overlap(:,:) = 0.d0 - - do nbnd1=1,nbspx - CALL c2psi( psi1, nnrx, c0(:,nbnd1), (0.d0,0.d0), ngw, 1) - CALL invfft('Dense', psi1, dfftp ) - - do nbnd2=1,nbspx - if(nbnd2.lt.nbnd1) then - vsicahtmp = -vsicah(nbnd2,nbnd1) - overlaptmp = overlap(nbnd2,nbnd1) - else - CALL c2psi( psi2, nnrx, c0(:,nbnd2), (0.d0,0.d0), ngw, 1) - CALL invfft('Dense', psi2, dfftp ) - - vsicahtmp = 0.d0 - overlaptmp = 0.d0 - - do i=1,nnrx -!$$ Imposing Pederson condition - vsicahtmp = vsicahtmp & - + 2.d0 * DBLE( CONJG(psi1(i)) * (vsic(i,nbnd2) & - - vsic(i,nbnd1) ) * psi2(i) ) * dwfnnorm -!$$ The following two lines give exactly the same results: checked - overlaptmp = overlaptmp + DBLE( CONJG(psi1(i)) * psi2(i) ) * dwfnnorm -! overlaptmp = overlaptmp + dble(psi1(i)) * dble(psi2(i)) * dwfnnorm - enddo - - CALL mp_sum(vsicahtmp,intra_image_comm) - CALL mp_sum(overlaptmp,intra_image_comm) - endif ! if(nbnd2.lt.nbnd1) - - vsicah(nbnd1,nbnd2) = vsicahtmp - overlap(nbnd1,nbnd2) = overlaptmp - - enddo ! nbnd2=1,nbspx - - enddo ! nbspx - - if(ionode) then - write(1021,*) ninner,nouter - write(1022,*) ninner,nouter - do nbnd1=1,nbspx - write(1021,'(100F12.7)') (overlap(nbnd1,nbnd2),nbnd2=1,nbspx) - write(1022,'(100F12.7)') (vsicah(nbnd1,nbnd2),nbnd2=1,nbspx) - enddo - write(1021,*) - write(1022,*) - endif - - return - ! -!--------------------------------------------------------------- -end subroutine nksic_printoverlap -!--------------------------------------------------------------- - - -!----------------------------------------------------------------------- - subroutine nksic_getvsicah( isp, vsicah, vsicah2sum) -!----------------------------------------------------------------------- -! -! ... Calculates the anti-hermitian part of the SIC hamiltonian, vsicah. -! - use kinds, only : dp - use grid_dimensions, only : nr1x, nr2x, nr3x, nnrx - use gvecw, only : ngw - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use electrons_base, only : nspin, iupdwn,nupdwn - use cp_interfaces, only : invfft - use fft_base, only : dfftp - use nksic, only : vsic,fsic - use wavefunctions_module, only : c0 - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp - real(dp) :: vsicah( nupdwn(isp),nupdwn(isp)) - real(dp) :: vsicah2sum - - ! - ! local variables - ! - complex(dp) :: psi1(nnrx), psi2(nnrx) - real(dp) :: vsicahtmp, cost - real(dp) :: dwfnnorm - integer :: nbnd1,nbnd2 - integer :: i, j1, j2 - - - CALL start_clock('nk_get_vsicah') - ! - dwfnnorm = 1.0d0/(DBLE(nr1x)*DBLE(nr2x)*DBLE(nr3x)) - cost = 2.0d0 * DBLE( nspin ) * 0.5d0 * dwfnnorm - ! - vsicah(:,:) = 0.d0 - vsicah2sum = 0.d0 - - ! - ! Imposing Pederson condition - ! - do nbnd1=1,nupdwn(isp) - ! - j1 = iupdwn(isp)-1 + nbnd1 - ! - CALL c2psi( psi1, nnrx, c0(:,j1), (0.d0,0.d0), ngw, 1) - CALL invfft('Dense', psi1, dfftp ) - - do nbnd2 = 1, nbnd1-1 - ! - j2 = iupdwn(isp)-1 + nbnd2 - ! - CALL c2psi( psi2, nnrx, c0(:,j2), (0.0d0,0.0d0), ngw, 1 ) - CALL invfft('Dense', psi2, dfftp ) - ! - vsicahtmp = 0.d0 - ! - do i=1,nnrx - ! - vsicahtmp = vsicahtmp + & - DBLE( CONJG(psi1(i)) * psi2(i) & - * ( vsic(i, j2 ) * fsic( j2 ) & - - vsic(i, j1 ) * fsic( j1 ) ) ) - ! - enddo - vsicahtmp = vsicahtmp * cost - ! - vsicah(nbnd1,nbnd2) = vsicahtmp - vsicah(nbnd2,nbnd1) = -vsicahtmp - ! - enddo - ! - enddo - ! - call mp_sum( vsicah, intra_image_comm) - ! - vsicah2sum = 0.0d0 - do nbnd1 = 1, nupdwn(isp) - do nbnd2 = 1, nbnd1-1 - vsicah2sum = vsicah2sum + 2.0d0*vsicah(nbnd2,nbnd1)*vsicah(nbnd2,nbnd1) - enddo - enddo - ! - call stop_clock('nk_get_vsicah') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getvsicah -!--------------------------------------------------------------- - - -!----------------------------------------------------------------------- - subroutine nksic_getvsicah_new1( isp, vsicah, vsicah2sum) -!----------------------------------------------------------------------- -! -! ... Calculates the anti-hermitian part of the SIC hamiltonian, vsicah. -! Exploit fft of wfc pairs. -! - use kinds, only : dp - use grid_dimensions, only : nr1x, nr2x, nr3x, nnrx - use gvecw, only : ngw - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use electrons_base, only : nspin, iupdwn,nupdwn - use cp_interfaces, only : invfft - use fft_base, only : dfftp - use nksic, only : vsic,fsic - use wavefunctions_module, only : c0 - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp - real(dp) :: vsicah( nupdwn(isp),nupdwn(isp)) - real(dp) :: vsicah2sum - - ! - ! local variables - ! - real(dp) :: vsicahtmp, cost - real(dp) :: dwfnnorm - integer :: nbnd1,nbnd2 - integer :: i, j1, jj1, j2, jj2 - ! - complex(dp), allocatable :: psi1(:), psi2(:) - real(dp), allocatable :: wfc1(:,:), wfc2(:,:) - - - CALL start_clock('nk_get_vsicah') - ! - dwfnnorm = 1.0d0/(DBLE(nr1x)*DBLE(nr2x)*DBLE(nr3x)) - cost = 2.0d0 * DBLE( nspin ) * 0.5d0 * dwfnnorm - ! - allocate( wfc1(nnrx, 2) ) - allocate( wfc2(nnrx, 2) ) - allocate( psi1(nnrx) ) - allocate( psi2(nnrx) ) - - ! - ! Imposing Pederson condition - ! - vsicah(:,:) = 0.d0 - ! - do nbnd1=1,nupdwn(isp),2 - ! - j1 = iupdwn(isp)-1 + nbnd1 - ! - CALL c2psi( psi1, nnrx, c0(:,j1), c0(:,j1+1), ngw, 2) - CALL invfft('Dense', psi1, dfftp ) - ! - wfc1(:,1) = DBLE ( psi1(:) ) - wfc1(:,2) = AIMAG ( psi1(:) ) - ! - do jj1 = 1, 2 - ! - if ( nbnd1+jj1-1 > nupdwn(isp) ) cycle - ! - ! - do nbnd2 = 1, nbnd1-1+jj1-1, 2 - ! - j2 = iupdwn(isp)-1 + nbnd2 - ! - CALL c2psi( psi2, nnrx, c0(:,j2), c0(:,j2+1), ngw, 2 ) - CALL invfft('Dense', psi2, dfftp ) - ! - wfc2(:,1) = DBLE ( psi2(:) ) - wfc2(:,2) = AIMAG ( psi2(:) ) - ! - do jj2 = 1, 2 - ! - if ( nbnd2+jj2-1 > nbnd1-1+jj1-1 ) cycle - ! - vsicahtmp = 0.d0 - ! - do i=1,nnrx - ! - vsicahtmp = vsicahtmp + & - cost * DBLE( wfc1(i,jj1) * wfc2(i,jj2) & - * ( vsic(i, j2+jj2-1 ) * fsic( j2+jj2-1 ) & - - vsic(i, j1+jj1-1 ) * fsic( j1+jj1-1 ) ) ) - ! - enddo - ! - vsicah(nbnd1+jj1-1,nbnd2+jj2-1) = vsicahtmp - vsicah(nbnd2+jj2-1,nbnd1+jj1-1) = -vsicahtmp - ! - enddo - enddo - ! - enddo - enddo - ! - call mp_sum( vsicah, intra_image_comm) - ! - vsicah2sum = 0.0d0 - ! - do nbnd1 = 1, nupdwn(isp) - do nbnd2 = 1, nbnd1-1 - vsicah2sum = vsicah2sum + 2.0d0*vsicah(nbnd2,nbnd1)*vsicah(nbnd2,nbnd1) - enddo - enddo - ! - ! - deallocate( wfc1, wfc2 ) - deallocate( psi1, psi2 ) - ! - call stop_clock('nk_get_vsicah') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getvsicah_new1 -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_getvsicah_new3(ngw, nbsp, nbspx, nspin, c0, bec, & - isp, nupdwn, iupdwn, vsicah, vsicah2sum, lgam) -!----------------------------------------------------------------------- -! -! ... Calculates the anti-hermitian part of the SIC hamiltonian, vsicah. -! makes use of nksic_eforce to compute h_i | phi_i > -! and then computes < phi_j | h_i | phi_i > in reciprocal space. -! - use kinds, only : dp - use grid_dimensions, only : nr1x, nr2x, nr3x, nnrx - use reciprocal_vectors, only : gstart - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use cp_interfaces, only : invfft - use fft_base, only : dfftp - use nksic, only : vsic, fsic, vsicpsi, & - deeq_sic ! to be passed directly - use twin_types - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp, nspin, ngw, nbsp, nbspx, & - nupdwn(nspin), iupdwn(nspin) - complex(dp) :: vsicah( nupdwn(isp),nupdwn(isp)), c0(ngw, nbsp) - real(dp) :: vsicah2sum - logical :: lgam - type(twin_matrix) :: bec - - ! - ! local variables - ! - real(dp) :: vsicahtmp, cost - integer :: nbnd1,nbnd2 - integer :: i, j1, jj1, j2, jj2 - ! - !complex(dp), allocatable :: vsicpsi(:,:) - complex(dp), allocatable :: hmat(:,:) - - - CALL start_clock('nk_get_vsicah') - ! - cost = DBLE( nspin ) * 2.0d0 - ! - !allocate( vsicpsi(npw,2) ) - allocate( hmat(nupdwn(isp),nupdwn(isp)) ) - - ! - ! compute < phi_j | Delta h_i | phi_i > - ! - do nbnd1 = 1, nupdwn(isp), 2 - ! - ! NOTE: USPP not implemented - ! - j1 = nbnd1+iupdwn(isp)-1 - CALL nksic_eforce( j1, nbsp, nbspx, vsic, & - deeq_sic, bec, ngw, c0(:,j1), c0(:,j1+1), vsicpsi, lgam ) - ! - do jj1 = 1, 2 - ! - if ( nbnd1+jj1-1 > nupdwn(isp) ) cycle - ! - do nbnd2 = 1, nupdwn(isp) - ! - j2 = nbnd2+iupdwn(isp)-1 - IF(lgam) THEN - hmat(nbnd2,nbnd1+jj1-1) = 2.d0*DBLE(DOT_PRODUCT( c0(:,j2), vsicpsi(:,jj1))) - ! - if ( gstart == 2 ) then - hmat(nbnd2,nbnd1+jj1-1) = hmat(nbnd2,nbnd1+jj1-1) - & - DBLE( c0(1,j2) * vsicpsi(1,jj1) ) - endif - ELSE - hmat(nbnd2,nbnd1+jj1-1) = DOT_PRODUCT( c0(:,j2), vsicpsi(:,jj1)) - ENDIF - ! - enddo - ! - enddo - enddo - ! - call mp_sum( hmat, intra_image_comm ) - hmat = hmat * cost - - - ! - ! Imposing Pederson condition - ! - vsicah(:,:) = 0.d0 - vsicah2sum = 0.0d0 - ! - do nbnd1 = 1, nupdwn(isp) - do nbnd2 = 1, nbnd1-1 - ! - IF(lgam) THEN - vsicah( nbnd2, nbnd1) = DBLE(hmat(nbnd2,nbnd1) -CONJG(hmat(nbnd1,nbnd2))) - vsicah( nbnd1, nbnd2) = DBLE(hmat(nbnd1,nbnd2) -CONJG(hmat(nbnd2,nbnd1))) - ELSE - vsicah( nbnd2, nbnd1) = hmat(nbnd2,nbnd1) -CONJG(hmat(nbnd1,nbnd2)) - vsicah( nbnd1, nbnd2) = hmat(nbnd1,nbnd2) -CONJG(hmat(nbnd2,nbnd1)) - ENDIF - vsicah2sum = vsicah2sum + DBLE(CONJG(vsicah(nbnd2,nbnd1))*vsicah(nbnd2,nbnd1)) - ! - enddo - !IF(.not.lgam) THEN - ! vsicah( nbnd1, nbnd1) = hmat(nbnd1,nbnd1) -CONJG(hmat(nbnd1,nbnd1)) - ! vsicah2sum = vsicah2sum + 2.d0*DBLE(CONJG(vsicah(nbnd1,nbnd1))*vsicah(nbnd1,nbnd1)) - !ENDIF - enddo - ! - deallocate( hmat ) - ! - call stop_clock('nk_get_vsicah') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getvsicah_new3 -!--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_getvsicah_new2( isp, vsicah, vsicah2sum, lgam) -!----------------------------------------------------------------------- -! -! ... Calculates the anti-hermitian part of the SIC hamiltonian, vsicah. -! makes use of nksic_eforce to compute h_i | phi_i > -! and then computes < phi_j | h_i | phi_i > in reciprocal space. -! - use kinds, only : dp - use grid_dimensions, only : nr1x, nr2x, nr3x, nnrx - use gvecw, only : ngw - use reciprocal_vectors, only : gstart - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use electrons_base, only : nspin, iupdwn, nupdwn, nbsp,nbspx - use cp_interfaces, only : invfft - use fft_base, only : dfftp - use nksic, only : vsic, fsic, vsicpsi, & - valpsi, deeq_sic ! to be passed directly - use wavefunctions_module, only : c0 - use cp_main_variables, only : bec ! to be passed directly - use input_parameters, only : odd_nkscalfact - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp - complex(dp) :: vsicah( nupdwn(isp),nupdwn(isp)) - real(dp) :: vsicah2sum - logical :: lgam - - ! - ! local variables - ! - real(dp) :: vsicahtmp, cost - integer :: nbnd1,nbnd2 - integer :: i, j1, jj1, j2, jj2 - ! - !complex(dp), allocatable :: vsicpsi(:,:) - complex(dp), allocatable :: hmat(:,:) - - - CALL start_clock('nk_get_vsicah') - ! - cost = DBLE( nspin ) * 2.0d0 - ! - !allocate( vsicpsi(npw,2) ) - allocate( hmat(nupdwn(isp),nupdwn(isp)) ) - - ! - ! compute < phi_j | Delta h_i | phi_i > - ! - do nbnd1 = 1, nupdwn(isp), 2 - ! - ! NOTE: USPP not implemented - ! - j1 = nbnd1+iupdwn(isp)-1 - CALL nksic_eforce( j1, nbsp, nbspx, vsic, & - deeq_sic, bec, ngw, c0(:,j1), c0(:,j1+1), vsicpsi, lgam ) - ! - do jj1 = 1, 2 - ! - if ( nbnd1+jj1-1 > nupdwn(isp) ) cycle - ! - do nbnd2 = 1, nupdwn(isp) - ! - j2 = nbnd2+iupdwn(isp)-1 - ! - IF (odd_nkscalfact) THEN - ! - vsicpsi(:,jj1) = vsicpsi(:,jj1) + valpsi(nbnd1+jj1-1,:) - ! - ENDIF - ! - IF(lgam) THEN - hmat(nbnd2,nbnd1+jj1-1) = 2.d0*DBLE(DOT_PRODUCT( c0(:,j2), vsicpsi(:,jj1))) - ! - if ( gstart == 2 ) then - hmat(nbnd2,nbnd1+jj1-1) = hmat(nbnd2,nbnd1+jj1-1) - & - DBLE( c0(1,j2) * vsicpsi(1,jj1) ) - endif - ELSE - hmat(nbnd2,nbnd1+jj1-1) = DOT_PRODUCT( c0(:,j2), vsicpsi(:,jj1)) - ENDIF - ! - enddo - ! - enddo - enddo - ! - call mp_sum( hmat, intra_image_comm ) - hmat = hmat * cost - - - ! - ! Imposing Pederson condition - ! - vsicah(:,:) = 0.d0 - vsicah2sum = 0.0d0 - ! - do nbnd1 = 1, nupdwn(isp) - do nbnd2 = 1, nbnd1-1 - ! - IF(lgam) THEN - vsicah( nbnd2, nbnd1) = DBLE(hmat(nbnd2,nbnd1) -CONJG(hmat(nbnd1,nbnd2))) - vsicah( nbnd1, nbnd2) = DBLE(hmat(nbnd1,nbnd2) -CONJG(hmat(nbnd2,nbnd1))) - ELSE - vsicah( nbnd2, nbnd1) = hmat(nbnd2,nbnd1) -CONJG(hmat(nbnd1,nbnd2)) - vsicah( nbnd1, nbnd2) = hmat(nbnd1,nbnd2) -CONJG(hmat(nbnd2,nbnd1)) - ENDIF - vsicah2sum = vsicah2sum + DBLE(CONJG(vsicah(nbnd2,nbnd1))*vsicah(nbnd2,nbnd1)) - ! - enddo - !IF(.not.lgam) THEN - ! vsicah( nbnd1, nbnd1) = hmat(nbnd1,nbnd1) -CONJG(hmat(nbnd1,nbnd1)) - ! vsicah2sum = vsicah2sum + 2.d0*DBLE(CONJG(vsicah(nbnd1,nbnd1))*vsicah(nbnd1,nbnd1)) - !ENDIF - enddo - ! - deallocate( hmat ) - ! - call stop_clock('nk_get_vsicah') - ! - return - ! -!--------------------------------------------------------------- -end subroutine nksic_getvsicah_new2 -!--------------------------------------------------------------- - -! !----------------------------------------------------------------------- -! subroutine nksic_getvsicah_twin( vsicah, vsicah2sum, nlam, descla, lgam) -! !----------------------------------------------------------------------- -! ! warning:giovanni IMPLEMENT without spin, call spin-by-spin initialize vsicah outside -! !IT IS JUST LIKE LAMBDA MATRIX, NEED NO FURTHER DESCLA INITIALIZATION!!.. DO AS -! ! IN ORTHO_GAMMA... PASS DESCLA MATRIX -! ! ... Calculates the anti-hermitian part of the SIC hamiltonian, vsicah. -! ! makes use of nksic_eforce to compute h_i | phi_i > -! ! and then computes < phi_j | h_i | phi_i > in reciprocal space. -! ! -! use kinds, only : dp -! use grid_dimensions, only : nr1x, nr2x, nr3x, nnrx -! use gvecw, only : ngw -! use reciprocal_vectors, only : gstart -! USE mp, ONLY: mp_sum,mp_bcast, mp_root_sum -! use mp_global, only : intra_image_comm, leg_ortho -! use electrons_base, only : nspin, iupdwn, nupdwn, nbsp,nbspx -! use cp_interfaces, only : invfft -! use fft_base, only : dfftp -! use nksic, only : vsic, fsic, vsicpsi, & -! deeq_sic ! to be passed directly -! use wavefunctions_module, only : c0 -! use cp_main_variables, only : bec ! to be passed directly -! use twin_types -! ! USE cp_main_variables, ONLY : collect_lambda, distribute_lambda, descla, nrlx -! USE descriptors, ONLY: lambda_node_ , la_npc_ , la_npr_ , descla_siz_ , & -! descla_init , la_comm_ , ilar_ , ilac_ , nlar_ , & -! nlac_ , la_myr_ , la_myc_ , la_nx_ , la_n_ , la_me_ , la_nrl_, nlax_ -! ! -! implicit none -! ! -! ! in/out vars -! ! -! ! integer, intent(in) :: nspin -! type(twin_matrix), dimension(nspin) :: vsicah!( nupdwn(isp),nupdwn(isp)) -! real(dp) :: vsicah2sum -! logical :: lgam -! INTEGER :: descla( descla_siz_ ) -! INTEGER :: np_rot, me_rot, comm_rot, nrl -! ! -! ! local variables -! ! -! real(dp) :: cost -! integer :: nbnd1,nbnd2,isp -! integer :: i, j1, jj1, j2, jj2, nss, istart, is -! INTEGER :: np(2), coor_ip(2), ipr, ipc, nr, nc, ir, ic, ii, jj, root, j, nlam, nlax -! INTEGER :: desc_ip( descla_siz_ ) -! LOGICAL :: la_proc -! ! -! !complex(dp), allocatable :: vsicpsi(:,:) -! real(dp), allocatable :: mtmp(:,:) -! complex(dp), allocatable :: h0c0(:,:), mtmp_c(:,:) -! ! type(twin_matrix) :: c0hc0(nspin)!modified:giovanni -! -! CALL start_clock('nk_get_vsicah') -! -! nlax = descla( nlax_ ) -! la_proc = ( descla( lambda_node_ ) > 0 ) -! nlam = 1 -! if ( la_proc ) nlam = nlax_ -! ! -! ! -! ! warning:giovanni:put a check on dimensions here?? (like in ortho_base/ortho) -! ! this check should be on dimensionality of vsicah -! ! -! cost = dble( nspin ) * 2.0d0 -! ! -! !allocate( vsicpsi(npw,2) ) -! ! allocate(c0hc0(nspin)) -! allocate(h0c0(ngw,nbspx)) -! -! ! do is=1,nspin -! ! call init_twin(c0hc0(is),lgam) -! ! call allocate_twin(c0hc0(is),nlam,nlam,lgam) -! ! enddo -! -! ! -! ! compute < phi_j | Delta h_i | phi_i > -! ! -! ! -! do j1 = 1, nbsp, 2 -! ! -! ! NOTE: USPP not implemented -! ! -! CALL nksic_eforce( j1, nbsp, nbspx, vsic, & -! deeq_sic, bec, ngw, c0(:,j1), c0(:,j1+1), h0c0(:,j1:j1+1), lgam ) -! ! -! enddo -! -! DO is= 1, nspin -! -! nss= nupdwn( is ) -! istart= iupdwn( is ) -! -! np(1) = descla( la_npr_ , is ) -! np(2) = descla( la_npc_ , is ) -! -! DO ipc = 1, np(2) -! DO ipr = 1, np(1) -! -! coor_ip(1) = ipr - 1 -! coor_ip(2) = ipc - 1 -! CALL descla_init( desc_ip, descla( la_n_ , is ), descla( la_nx_ , is ), np, coor_ip, descla( la_comm_ , is ), 1 ) -! -! nr = desc_ip( nlar_ ) -! nc = desc_ip( nlac_ ) -! ir = desc_ip( ilar_ ) -! ic = desc_ip( ilac_ ) -! -! CALL GRID2D_RANK( 'R', desc_ip( la_npr_ ), desc_ip( la_npc_ ), & -! desc_ip( la_myr_ ), desc_ip( la_myc_ ), root ) -! ! -! root = root * leg_ortho -! -! IF(.not.c0hc0(is)%iscmplx) THEN -! ALLOCATE( mtmp( nr, nc ) ) -! mtmp = 0.0d0 -! CALL DGEMM( 'T', 'N', nr, nc, 2*ngw, - 2.0d0, c0( 1, istart + ir - 1 ), 2*ngw, & -! h0c0( 1, istart + ic - 1 ), 2*ngw, 0.0d0, mtmp, nr ) -! IF (gstart == 2) THEN -! DO jj = 1, nc -! DO ii = 1, nr -! i = ii + ir - 1 -! j = jj + ic - 1 -! mtmp(ii,jj) = mtmp(ii,jj) + DBLE( c0( 1, i + istart - 1 ) ) * DBLE( h0c0( 1, j + istart - 1 ) ) -! END DO -! END DO -! END IF -! mtmp=mtmp*cost -! ELSE -! ALLOCATE( mtmp_c( nr, nc ) ) -! mtmp_c = CMPLX(0.0d0,0.d0) -! CALL ZGEMM( 'C', 'N', nr, nc, ngw, CMPLX(- 1.0d0,0.d0), c0( 1, istart + ir - 1 ),ngw, & -! h0c0( 1, istart + ic - 1 ), ngw, CMPLX(0.0d0,0.d0), mtmp_c, nr ) -! ENDIF -! mtmp_c=mtmp_c*cost -! IF(.not.c0hc0(is)%iscmplx) THEN -! CALL mp_root_sum( mtmp, vsicah(is)%rvec(1:nr,1:nc), root, intra_image_comm ) -! DEALLOCATE( mtmp ) -! ELSE -! CALL mp_root_sum( mtmp_c, vsicah(is)%cvec(1:nr,1:nc), root, intra_image_comm ) -! DEALLOCATE( mtmp_c ) -! ENDIF -! ! IF( coor_ip(1) == descla( la_myr_ , is ) .AND. & -! ! coor_ip(2) == descla( la_myc_ , is ) .AND. descla( lambda_node_ , is ) > 0 ) THEN -! ! c0hc0(1:nr,1:nc,is) = mtmp -! ! END IF -! END DO -! END DO -! ! -! ! fill mtmp or mtmp_c with hermitian conjugate of vsicah -! ! and -! ! antisymmetrize vsicah -! IF(lgam) THEN -! allocate(mtmp(nlam,nlam)) -! mtmp=0.d0 -! CALL sqr_tr_cannon( nupdw(is), vsicah(is)%rvec, nlam, mtmp, nlam, descla ) -! DO i=1,nr -! DO j=1,nc -! vsicah(is)%rvec(i,j) = vsicah(is)%rvec(i,j)-mtmp(i,j) -! END DO -! END DO -! deallocate(mtmp) -! ELSE -! allocate(mtmp_c(nlam,nlam)) -! mtmp_c=0.d0 -! CALL sqr_tr_cannon( nupdw(is), vsicah(is)%cvec, nlam, mtmp_c, nlam, descla ) -! DO i=1,nr -! DO j=1,nc -! vsicah(is)%cvec(i,j) = vsicah(is)%cvec(i,j)-mtmp(i,j) -! END DO -! END DO -! deallocate(mtmp_c) -! ENDIF -! -! END DO -! -! ! -! ! Imposing Pederson condition -! ! -! -! ! vsicah(:,:) = 0.d0 -! ! vsicah2sum = 0.0d0 -! ! ! -! ! do nbnd1 = 1, nupdwn(isp) -! ! do nbnd2 = 1, nbnd1-1 -! ! ! -! ! IF(lgam) THEN -! ! vsicah( nbnd2, nbnd1) = DBLE(hmat(nbnd2,nbnd1) -CONJG(hmat(nbnd1,nbnd2))) -! ! vsicah( nbnd1, nbnd2) = DBLE(hmat(nbnd1,nbnd2) -CONJG(hmat(nbnd2,nbnd1))) -! ! ELSE -! ! vsicah( nbnd2, nbnd1) = hmat(nbnd2,nbnd1) -CONJG(hmat(nbnd1,nbnd2)) -! ! vsicah( nbnd1, nbnd2) = hmat(nbnd1,nbnd2) -CONJG(hmat(nbnd2,nbnd1)) -! ! ENDIF -! ! vsicah2sum = vsicah2sum + 2.0d0*CONJG(vsicah(nbnd2,nbnd1))*vsicah(nbnd2,nbnd1) -! ! ! -! ! enddo -! ! enddo -! ! -! deallocate( h0c0 ) -! -! ! -! call stop_clock('nk_get_vsicah') -! ! -! return -! ! -! !--------------------------------------------------------------- -! end subroutine nksic_getvsicah_twin -! !--------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine nksic_getOmat1(isp,Heig,Umat,passof,Omat1,lgam) -!----------------------------------------------------------------------- -! -! ... Obtains the rotation matrix from the force-related matrices Heig and Umat -! and also from the step size (passof). -! - use kinds, only : dp - use constants, only : ci - use electrons_base, only : nupdwn - ! - implicit none - ! - ! in/out vars - ! - integer, intent(in) :: isp - real(dp), intent(in) :: Heig(nupdwn(isp)) - complex(dp), intent(in) :: Umat(nupdwn(isp),nupdwn(isp)) - real(dp), intent(in) :: passof - complex(dp) :: Omat1(nupdwn(isp),nupdwn(isp)) - logical :: lgam - ! - ! local variables - ! - complex(dp) :: Cmattmp(nupdwn(isp),nupdwn(isp)) - complex(dp) :: exp_iHeig(nupdwn(isp)) - - integer :: nbnd1 - real(dp) :: dtmp - - - call start_clock ( "nk_getOmat1" ) - -!$$ We set the step size in such a way that the phase change -!$$ of the wavevector with largest eigenvalue upon rotation is fixed -! passof = passoprod/max(abs(Heig(1)),abs(Heig(nupdwn(isp)))) -!$$ Now the above step is done outside. - - do nbnd1=1,nupdwn(isp) - dtmp = passof * Heig(nbnd1) - exp_iHeig(nbnd1) = DCOS(dtmp) + ci*DSIN(dtmp) - enddo - -!$$ Cmattmp = exp(i * passof * Heig) * Umat^dagger ; Omat = Umat * Cmattmp - do nbnd1=1,nupdwn(isp) - Cmattmp(nbnd1,:) = exp_iHeig(nbnd1)*CONJG(Umat(:,nbnd1)) - enddo - -! Omat1 = MATMUL( CONJG(TRANSPOSE(Umat)), Cmattmp) !modified:giovanni - IF(lgam) THEN - Omat1 = DBLE(MATMUL( Umat, Cmattmp)) !modified:giovanni - ELSE - Omat1 = MATMUL( Umat, Cmattmp) !modified:giovanni - ENDIF - - call stop_clock ( "nk_getOmat1" ) - - return -!--------------------------------------------------------------- -end subroutine nksic_getOmat1 -!--------------------------------------------------------------- - -!$$ -!--------------------------------------------------------------- - subroutine nksic_dmxc_spin_cp_update( nnrx, rhoref, f, ispin, rhoele, & - small, wref, wxd ) -!--------------------------------------------------------------- - -! the derivative of the xc potential with respect to the local density -! is computed. -! In order to save time, the loop over space coordinates is performed -! inside this routine (inlining). -! -! NOTE: wref and wsic are UPDATED and NOT OVERWRITTEN by this subroutine -! - USE kinds, ONLY : dp - USE funct, ONLY : xc_spin, get_iexch, get_icorr - implicit none - ! - integer, intent(in) :: nnrx, ispin - real(dp), intent(in) :: rhoref(nnrx,2), rhoele(nnrx,2) - real(dp), intent(in) :: f, small - real(dp), intent(inout) :: wref(nnrx), wxd(nnrx,2) - ! - character(18) :: subname='nksic_dmxc_spin_cp' - real(dp) :: rhoup, rhodw, rhotot, zeta - real(dp) :: dmuxc(2,2) - real(dp) :: rs, ex, vx, dr, dz, ec, & - vcupm, vcdwm, vcupp, vcdwp, & - vxupm, vxdwm, vxupp, vxdwp, & - dzm, dzp, fact - ! - real(dp), external :: dpz, dpz_polarized - integer :: ir - !logical :: do_exch, do_corr - ! - real(dp), parameter :: e2 = 2.0_dp, & - pi34 = 0.6203504908994_DP, & ! redefined to pi34=(3/4pi)^(1/3) - pi34_old= 0.75_dp/3.141592653589793_dp, third=1.0_dp/3.0_dp, & - p43=4.0_dp/3.0_dp, p49=4.0_dp/ 9.0_dp, m23=-2.0_dp/3.0_dp - ! - if ( get_iexch() == 1 .and. get_icorr() == 1 ) THEN - ! - do ir = 1, nnrx - ! - dmuxc(:,:)=0.0_dp - ! - rhoup = rhoref(ir,1) - rhodw = rhoref(ir,2) - rhotot = rhoup + rhodw - ! - if( rhotot < small) cycle - ! - zeta = (rhoup-rhodw)/rhotot - if(abs(zeta)>1.0_dp) zeta=sign(1.0_dp,zeta) - ! - ! calculate exchange contribution (analytical) - ! - if ( rhoup > small) then - rs = pi34 / (2.0_dp*rhoup)**third - call slater(rs,ex,vx) - dmuxc(1,1)=vx/(3.0_dp*rhoup) - endif - ! - if( rhodw > small) then - rs = pi34 / (2.0_dp*rhodw)**third - call slater(rs,ex,vx) - dmuxc(2,2)=vx/(3.0_dp*rhodw) - endif - ! - ! calculate correlation contribution (numerical) - ! - dr = min(1.e-6_dp,1.e-4_dp*rhotot) - fact = 0.5d0 / dr - ! - ! the explicit call to the correlation part only - ! are performed instead of calling xc_spin. - ! this saves some CPU time. - ! unfortunately, different functionals have then - ! to be treated explicitly - ! - !call xc_spin(rhotot-dr,zeta,ex,ec,vxupm,vxdwm,vcupm,vcdwm) - !call xc_spin(rhotot+dr,zeta,ex,ec,vxupp,vxdwp,vcupp,vcdwp) - ! - rs = pi34 / (rhotot-dr)**third - call pz_spin (rs, zeta, ec, vcupm, vcdwm) - rs = pi34 / (rhotot+dr)**third - call pz_spin (rs, zeta, ec, vcupp, vcdwp) - ! - - dmuxc(1,1) = dmuxc(1,1) +(vcupp-vcupm) * fact - dmuxc(1,2) = dmuxc(1,2) +(vcupp-vcupm) * fact - dmuxc(2,1) = dmuxc(2,1) +(vcdwp-vcdwm) * fact - dmuxc(2,2) = dmuxc(2,2) +(vcdwp-vcdwm) * fact - - dz=1.e-6_dp - dzp=min(1.0,zeta+dz)-zeta - dzm=-max(-1.0,zeta-dz)+zeta - ! - fact = 1.0d0 / ( rhotot * (dzp+dzm) ) - ! - !call xc_spin(rhotot,zeta-dzm,ex,ec,vxupm,vxdwm,vcupm,vcdwm) - !call xc_spin(rhotot,zeta+dzp,ex,ec,vxupp,vxdwp,vcupp,vcdwp) - ! - rs = pi34 / (rhotot)**third - call pz_spin (rs, zeta-dzm, ec, vcupm, vcdwm) - call pz_spin (rs, zeta+dzp, ec, vcupp, vcdwp) - - dmuxc(1,1) = dmuxc(1,1) +(vcupp-vcupm)*(1.0_dp-zeta)*fact - dmuxc(1,2) = dmuxc(1,2) -(vcupp-vcupm)*(1.0_dp+zeta)*fact - dmuxc(2,1) = dmuxc(2,1) +(vcdwp-vcdwm)*(1.0_dp-zeta)*fact - dmuxc(2,2) = dmuxc(2,2) -(vcdwp-vcdwm)*(1.0_dp+zeta)*fact - - ! - ! add corrections to the nksic potentials - ! - wxd(ir,1) = wxd(ir,1) + dmuxc(1,ispin) * rhoele(ir,ispin)*f - wxd(ir,2) = wxd(ir,2) + dmuxc(2,ispin) * rhoele(ir,ispin)*f - ! - wref(ir) = wref(ir) + dmuxc(ispin,ispin)*rhoele(ir,ispin) - ! - enddo - ! - else - ! - do ir = 1, nnrx - ! - dmuxc(:,:)=0.0_dp - ! - rhoup = rhoref(ir,1) - rhodw = rhoref(ir,2) - rhotot = rhoup + rhodw - ! - if( rhotot < small) cycle - ! - zeta = (rhoup-rhodw)/rhotot - if(abs(zeta)>1.0_dp) zeta=sign(1.0_dp,zeta) - - dr = min(1.e-6_dp,1.e-4_dp*rhotot) - fact = 0.5d0 / dr - - call xc_spin (rhotot - dr, zeta, ex, ec, vxupm, vxdwm, vcupm, vcdwm) - call xc_spin (rhotot + dr, zeta, ex, ec, vxupp, vxdwp, vcupp, vcdwp) - ! - dmuxc(1,1) = dmuxc(1,1) + (vxupp + vcupp - vxupm - vcupm)*fact - dmuxc(1,2) = dmuxc(1,2) + (vxupp + vcupp - vxupm - vcupm)*fact - dmuxc(2,1) = dmuxc(2,1) + (vxdwp + vcdwp - vxdwm - vcdwm)*fact - dmuxc(2,2) = dmuxc(2,2) + (vxdwp + vcdwp - vxdwm - vcdwm)*fact - ! - dz = 1.E-6_DP - dzp= min( 1.0,zeta+dz)-zeta - dzm=-max(-1.0,zeta-dz)+zeta - ! - fact = 1.0d0 / ( rhotot * (dzp+dzm) ) - ! - call xc_spin (rhotot, zeta - dzm, ex, ec, vxupm, vxdwm, vcupm, vcdwm) - call xc_spin (rhotot, zeta + dzp, ex, ec, vxupp, vxdwp, vcupp, vcdwp) - ! - dmuxc(1,1) = dmuxc(1,1) + (vxupp + vcupp - vxupm - vcupm) * (1.0_DP - zeta)*fact - dmuxc(1,2) = dmuxc(1,2) - (vxupp + vcupp - vxupm - vcupm) * (1.0_DP + zeta)*fact - dmuxc(2,1) = dmuxc(2,1) + (vxdwp + vcdwp - vxdwm - vcdwm) * (1.0_DP - zeta)*fact - dmuxc(2,2) = dmuxc(2,2) - (vxdwp + vcdwp - vxdwm - vcdwm) * (1.0_DP + zeta)*fact - ! - ! add corrections to the nksic potentials - ! - wxd(ir,1) = wxd(ir,1) + dmuxc(1,ispin) * rhoele(ir,ispin)*f - wxd(ir,2) = wxd(ir,2) + dmuxc(2,ispin) * rhoele(ir,ispin)*f - ! - wref(ir) = wref(ir) + dmuxc(ispin,ispin)*rhoele(ir,ispin) - ! - enddo - ! - endif - - return - -!--------------------------------------------------------------- -end subroutine nksic_dmxc_spin_cp_update -!--------------------------------------------------------------- - -SUBROUTINE compute_nksic_centers(nnrx, nx, nudx, nbsp, nspin, iupdwn, & - nupdwn, ispin, orb_rhor, wfc_centers, wfc_spreads, j,k) - - USE kinds, ONLY: DP - USE ions_positions, ONLY: taus - USE ions_base, ONLY: ions_cofmass, pmass, na, nsp - USE cell_base, ONLY: h, s_to_r - USE cell_base, ONLY : at, bg, alat, omega - USE mp_global, ONLY : intra_image_comm, mpime - USE io_global, ONLY : ionode_id - USE mp, ONLY : mp_bcast - ! - ! INPUT VARIABLES - ! - INTEGER, INTENT(IN) :: ispin(nx),nx,j,k,nspin, nbsp, & - nupdwn(nspin), iupdwn(nspin) - !ispin is 1 or 2 for each band (listed as in c0), - !nx is nudx, j and k the two bands involved in the - !spread calculation - REAL(DP), INTENT(in) :: orb_rhor(nnrx,2) - REAL(DP) :: wfc_centers(4,nudx,nspin) !in position 1 we & - !have the integrated charge - REAL(DP) :: wfc_spreads(nudx,nspin,2) - !orbital spreads: both wannier(1) and self-hartree(2) - !self-hartree is stored separately, within nksic subroutines - ! - !INTERNAL VARIABLES - ! - INTEGER :: myspin1, myspin2, mybnd1, mybnd2 - REAL(DP):: r0(3), rs(3) - REAL(DP), external :: ddot - - ! - myspin1=ispin(j) - ! - mybnd1=j-iupdwn(myspin1)+1 - ! - ! compute ionic center of mass - ! - CALL ions_cofmass(taus, pmass, na, nsp, rs) - ! and use it as reference position - !r0=0.d0 - ! - call compute_dipole( nnrx, 1, orb_rhor(1,1), r0, wfc_centers(1:4, mybnd1, myspin1), wfc_spreads(mybnd1, myspin1, 1)) - wfc_spreads(mybnd1,myspin1,1) = wfc_spreads(mybnd1,myspin1,1) - ddot(3, wfc_centers(2:4,mybnd1,myspin1), 1, wfc_centers(2:4,mybnd1,myspin1), 1) - ! - ! now shift wavefunction centers by r0 - ! - wfc_centers(2:4, mybnd1, myspin1) = wfc_centers(2:4, mybnd1, myspin1) + r0(1:3) - ! - IF(k.le.nbsp) THEN - ! - myspin2=ispin(k) - mybnd2=k-iupdwn(myspin2)+1 - ! - call compute_dipole( nnrx, 1, orb_rhor(1,2), r0, wfc_centers(1:4, mybnd2, myspin2), wfc_spreads(mybnd2, myspin2,1)) - wfc_spreads(mybnd2,myspin2,1) = wfc_spreads(mybnd2,myspin2,1) - ddot(3, wfc_centers(2:4,mybnd2,myspin2), 1, wfc_centers(2:4,mybnd2,myspin2), 1) - ! - ! now shift wavefunction centers by r0 - ! - wfc_centers(2:4, mybnd2, myspin2) = wfc_centers(2:4, mybnd2, myspin2) + r0(1:3) - ! - ENDIF - ! - RETURN - -END SUBROUTINE compute_nksic_centers -! -SUBROUTINE spread_sort(ngw, nspin, nbsp, nudx, nupdwn, iupdwn, tempspreads, wfc_centers, sort_spreads) - - USE kinds, ONLY: DP - USE input_parameters, only: draw_pot, sortwfc_spread !added:linh draw vsic potentials - USE wavefunctions_module, only: c0,cm - USE mp_global, only: mpime, intra_image_comm - USE mp, only: mp_bcast - USE io_global, only: ionode, ionode_id - - IMPLICIT NONE - - !COMPLEX(DP) :: c0(ngw, nbsp), cm(ngw,nbsp) - INTEGER :: ngw, nspin, nbsp, nudx, nupdwn(nspin), iupdwn(nspin) - REAL(DP) :: tempspreads(nudx, nspin, 2) - REAL(DP) :: wfc_centers(4,nudx,nspin) - INTEGER :: sort_spreads(nudx,nspin) - ! - INTEGER :: isp,j,k,refnum,i, ig - INTEGER, ALLOCATABLE :: aidarray(:,:) - !REAL(DP), ALLOCATABLE :: tempspreads(:,:,:) - COMPLEX(DP), ALLOCATABLE :: tempwfc(:,:) - - ! do nothing if one is drawing the potential: to avoid mismatch between potential and orbital - IF(draw_pot) THEN - return - ENDIF - ! - !allocate(tempspreads(nudx,nspin,2)) - allocate(aidarray(nudx,2), tempwfc(ngw,2)) - ! - !tempspreads(:,:,:) = wfc_spreads(:,:,:) - ! - !write(*,*) mpime, "spreads", tempspreads(:,2,2) - ! - do isp=1,nspin - ! - !if(ionode) then - do j=1,nupdwn(isp) !initialize sort-decodification array - ! - aidarray(j,1) = j - aidarray(j,2) = 0 - ! - enddo - ! - do j=1,nupdwn(isp)-1 !bubble-sort the decodification array - ! - do k=nupdwn(isp),j+1,-1 - ! - IF(tempspreads(k,isp,2).lt.tempspreads(k-1,isp,2)) THEN - ! - call swap_real(tempspreads(k,isp,2),tempspreads(k-1,isp,2)) - call swap_real(tempspreads(k,isp,1),tempspreads(k-1,isp,1)) - do i=1,4 - call swap_real(wfc_centers(i,k,isp),wfc_centers(i,k-1,isp)) - enddo - call swap_integer(aidarray(k,1),aidarray(k-1,1)) - ! - ENDIF - ! - enddo - ! - enddo - !write(*,*) mpime, "aidarray", aidarray(:,1) - j=1 - k=1 - refnum=0 - !write(*,*) mpime, "before", c0(2,:) - ! - if(sortwfc_spread) then - ! - do while(k.le.nupdwn(isp)) - ! - write(6,*) j,aidarray(j,2), aidarray(j,1), refnum - IF(aidarray(j,2)==0.and.j/=aidarray(j,1)) THEN - ! - IF(aidarray(j,1)/=refnum) THEN - ! - IF(refnum==0) THEN - ! - do ig=1,ngw - ! - tempwfc(ig,1) = c0(ig,iupdwn(isp)+j-1) - tempwfc(ig,2) = cm(ig,iupdwn(isp)+j-1) - ! - enddo - refnum=j - ! - ENDIF - ! - do ig=1,ngw - ! - c0(ig,iupdwn(isp)+j-1) = c0(ig,iupdwn(isp)+aidarray(j,1)-1) - cm(ig,iupdwn(isp)+j-1) = cm(ig,iupdwn(isp)+aidarray(j,1)-1) - ! - enddo - ! - aidarray(j,2)=1 - j=aidarray(j,1) - ! - ELSE - ! - do ig=1,ngw - ! - c0(ig,iupdwn(isp)+j-1) = tempwfc(ig,1) - cm(ig,iupdwn(isp)+j-1) = tempwfc(ig,2) - ! - enddo - ! - aidarray(j,2)=1 - j=refnum+1 - refnum=0 - ! - ENDIF - k=k+1 - ! - ELSE - ! - IF(j==aidarray(j,1)) THEN - ! - k=k+1 - ! - ENDIF - ! - j=j+1 - ! - if(j.gt.nupdwn(isp)) THEN - exit - ELSE - cycle - ENDIF - ! - ENDIF - ! - enddo - endif - ! - sort_spreads(:,isp) = aidarray(:,1) - ! - enddo - - ! - if(allocated(tempwfc)) deallocate(tempwfc) - deallocate(aidarray) - ! - return - -contains - - subroutine swap_integer(a,b) - - use kinds, ONLY: DP - - implicit none - - INTEGER :: a,b - INTEGER :: c - - c=a - a=b - b=c - - return - - end subroutine swap_integer - - subroutine swap_real(a,b) - - use kinds, ONLY: DP - - implicit none - - REAL(DP) :: a,b - REAL(DP) :: c - - c=a - a=b - b=c - - return - - end subroutine swap_real - -END SUBROUTINE spread_sort - - -SUBROUTINE compute_complexification_index(ngw, nnrx, nnrsx, nbsp, nbspx, nspin, ispin, iupdwn, nupdwn, c0, bec,& - complexification_index) - ! - ! Here the overlap between the wavefunction manifold and its conjugate is calculated - ! - ! As it is now, this routine works only with Norm Conserving Pseudopotentials - ! - USE kinds, ONLY : DP - USE twin_types - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm - use cell_base, only: omega - use cp_interfaces, only: fwfft, invfft - use fft_base, only: dffts, dfftp - use uspp, ONLY: okvan, nkb - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: ngw, nnrx, nnrsx, nbsp, nbspx, nspin, & - iupdwn(nspin), nupdwn(nspin), ispin(nbspx) - type(twin_matrix) :: bec - COMPLEX(DP) :: c0(ngw, nbspx), complexification_index - - INTEGER :: i,j,k, ir - COMPLEX(DP), allocatable :: temp_array(:, :), psi1(:), psi2(:) - REAL(DP) :: sa1 - - sa1 = 1.0d0 / omega - ! - allocate(temp_array(nbsp, nbsp)) - ! - temp_array=CMPLX(0.d0,0.d0) - ! - if ( nnrsx == nnrx ) then ! warning this is a bad way to say we are using ultrasoft - ! - allocate( psi1(nnrx), psi2(nnrx) ) - ! - do i=1,nbsp - ! - do j=1,i - ! - IF(ispin(i) == ispin(j)) THEN - ! - call c2psi(psi1,nnrx,c0(:,i), c0(:,j), ngw, 0) - call c2psi(psi2,nnrx,c0(:,j), c0(:,i), ngw, 0) - ! - CALL invfft('Dense', psi1, dfftp ) - CALL invfft('Dense', psi2, dfftp ) - ! - do ir=1, nnrx - ! - temp_array(i,j) = temp_array(i,j) + psi1(ir)*psi2(ir) - ! - enddo - ! - ENDIF - ! - enddo - ! - enddo - ! - else !if using uspp - ! - allocate( psi1(nnrx), psi2(nnrx) ) - ! - ! for the moment: do nothing - ! - endif - ! - call mp_sum(temp_array, intra_image_comm) - ! - temp_array = temp_array / DBLE( dfftp%nr1*dfftp%nr2*dfftp%nr3 ) - complexification_index=0.d0 - ! - do i=1,nbsp - ! - do j=1,i-1 - ! - IF(ispin(j) == ispin(i)) THEN - ! - complexification_index=complexification_index+2.d0*abs(temp_array(i,j))**2 - ! - ENDIF - ! - enddo - ! - complexification_index=complexification_index+abs(temp_array(i,i))**2 - ! - enddo - ! - complexification_index=(1.d0-complexification_index/nbsp)*100.d0 ! the index is in percentage - ! - deallocate(temp_array) - deallocate(psi1) - deallocate(psi2) - ! - return - -END subroutine compute_complexification_index - -!----------------------------------------------------------------------- - subroutine nksic_potential_non_ortho( nbsp, nx, c, cdual, f_diag, & - bec, becdual, becsum, & - deeq_sic, ispin, iupdwn, nupdwn, & - rhor, rhoc, wtot, sizwtot, vsic, do_wxd_, pink, nudx, & - wfc_centers, wfc_spreads, & - icompute_spread) -!----------------------------------------------------------------------- -! -! ....calculate orbital dependent potentials, -! following the Non-Koopmans' (NK) scheme, -! but also Perdew-Zunger (PZ), -! Non-Koopmans' integral definition (NKI), -! Non-Joopmans on Perdew Zunger (PZNK) -! -! subroutine writte for non-orthogonal functions -! note that non-linear core correction is not working -! in this particular subroutine -! -! - use kinds, only: dp - use gvecp, only: ngm - use gvecw, only: ngw - use grid_dimensions, only: nnrx - use electrons_base, only: nspin - use funct, only : dft_is_gradient - use nksic, only: orb_rhor, wxdsic, & - wrefsic, rhoref, rhobar, & - do_nk, do_nki, do_pz, do_nkpz, & - do_nkipz, grhobar, fion_sic, & - pzalpha=>odd_alpha, do_pz_renorm, edens, & - tauw,taukin, upsilonkin, upsilonw, kfact - use ions_base, only: nat - use control_flags, only: gamma_only, do_wf_cmplx !added:giovanni - use uspp, only: nkb - use uspp_param, only: nhm - use cp_interfaces, only: nksic_get_orbitalrho !added:giovanni - use twin_types !added:giovanni - use input_parameters, only: draw_pot, pot_number !added:linh draw vsic potentials - use io_pot_sic_xml, only: write_pot_sic !added:linh draw vsic potentials - USE io_global, ONLY: stdout - - ! - implicit none - ! - - ! -- add N. Poilvert, define explicit interface to - ! nksic_correction_nkipz - INTERFACE - subroutine nksic_correction_nkipz( f, ispin, orb_rhor, & - vsic, pink, ibnd, shart, is_empty) - - use kinds, only : dp - use constants, only : e2, fpi, hartree_si, electronvolt_si - use cell_base, only : tpiba2,omega - use nksic, only : nknmax, nkscalfact - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use eecp_mod, only : do_comp - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dft_is_gradient - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use control_flags, only : gamma_only, do_wf_cmplx - - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(out) :: vsic(nnrx) - real(dp), intent(out) :: pink, shart - logical, optional, intent(in) :: is_empty - end subroutine nksic_correction_nkipz - END INTERFACE - ! -- add N. Poilvert, define explicit interface to - ! nksic_correction_nki - INTERFACE - subroutine nksic_correction_nki( f, ispin, orb_rhor, rhor, & - rhoref, rhobar, rhobarg, grhobar,& - vsic, wxdsic, do_wxd_, pink, ibnd, is_empty ) - - use kinds, only : dp - use constants, only : e2, fpi - use cell_base, only : tpiba2,omega - use nksic, only : fref, rhobarfact, nknmax, & - nkscalfact, & - etxc => etxc_sic, vxc => vxc_sic - use grid_dimensions, only : nnrx, nr1, nr2, nr3 - use gvecp, only : ngm - use recvecs_indexes, only : np, nm - use reciprocal_vectors, only : gstart, g - use eecp_mod, only : do_comp - use cp_interfaces, only : fwfft, invfft, fillgrad - use fft_base, only : dfftp - use funct, only : dmxc_spin, dft_is_gradient - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use electrons_base, only : nspin - use control_flags, only : gamma_only, do_wf_cmplx - - integer, intent(in) :: ispin, ibnd - real(dp), intent(in) :: f, orb_rhor(nnrx) - real(dp), intent(in) :: rhor(nnrx,nspin) - real(dp), intent(in) :: rhoref(nnrx,2) - real(dp), intent(in) :: rhobar(nnrx,2) - complex(dp), intent(in) :: rhobarg(ngm,2) - real(dp), intent(in) :: grhobar(nnrx,3,2) - real(dp), intent(out) :: vsic(nnrx) - real(dp), intent(out) :: wxdsic(nnrx,2) - logical, intent(in) :: do_wxd_ - real(dp), intent(out) :: pink - logical, optional, intent(in) :: is_empty - end subroutine nksic_correction_nki - END INTERFACE - - ! - ! in/out vars - ! - integer, intent(in) :: nbsp, nx, nudx, sizwtot - complex(dp), intent(in) :: c(ngw,nx), cdual(ngw,nx) - type(twin_matrix), intent(in) :: bec, becdual!(nkb,nbsp) !modified:giovanni - real(dp), intent(in) :: becsum( nhm*(nhm+1)/2, nat, nspin) - integer, intent(in) :: ispin(nx) - integer, intent(in) :: iupdwn(nspin), nupdwn(nspin) - real(dp), intent(in) :: f_diag(nx) - real(dp), intent(in) :: rhor(nnrx,nspin) - real(dp), intent(in) :: rhoc(nnrx) - real(dp), intent(out) :: vsic(nnrx,nx), wtot(sizwtot,2) - real(dp), intent(out) :: deeq_sic(nhm,nhm,nat,nx) - logical, intent(in) :: do_wxd_ - real(dp), intent(out) :: pink(nx) - logical :: icompute_spread - real(DP) :: wfc_centers(4,nudx,nspin) - real(DP) :: wfc_spreads(nudx,nspin,2) - - ! - ! local variables - ! - integer :: i,j,jj,ibnd,isp - real(dp) :: focc,pinkpz,shart - real(dp), allocatable :: vsicpz(:) - complex(dp), allocatable :: rhobarg(:,:) - logical :: lgam - complex(dp), dimension(nudx,nudx,nspin) :: overlap_ - ! - ! main body - ! - CALL start_clock( 'nksic_drv' ) - lgam = gamma_only.and..not.do_wf_cmplx - ! - ! compute potentials - ! - if (dft_is_gradient()) then - allocate(rhobarg(ngm,2)) - !write(6,*) "allocated rhobarg" - else - allocate(rhobarg(1,1)) - endif - - if ( do_nk .or. do_nkpz .or. do_nki .or. do_nkipz ) then - wtot=0.0_dp - endif - ! - if ( do_nkpz .or. do_nkipz) then - allocate(vsicpz(nnrx)) - vsicpz=0.0_dp - endif - ! - pink=0.0_dp - vsic=0.0_dp - ! - ! if using pz_renorm factors, compute here tauw and upsilonw - ! - if(do_pz_renorm) THEN - ! - edens=0.d0 - ! - do isp=1,nspin - ! - call nksic_get_taukin_pz( 1.d0, nspin, isp, rhor(1,isp), tauw, 1) - ! - enddo - ! - ENDIF - ! - ! loop over bands (2 ffts at the same time) - ! -! call compute_overlap(c, ngw, nbsp, overlap_) - ! - do j=1,nbsp,2 - ! - ! compute orbital densities - ! n odd => c(:,n+1) is already set to zero - ! - call nksic_get_orbitalrho( ngw, nnrx, bec, becdual, ispin, nbsp, & - c(:,j), c(:,j+1), cdual(:,j), cdual(:,j+1), orb_rhor, & - j, j+1, lgam) !note:giovanni change here for non-orthogonality flavour -!begin_added:giovanni -! orb_rhor(:,1) = orb_rhor(:,1)/overlap_(j+1-iupdwn(ispin(j)),j+1-iupdwn(ispin(j)),ispin(j)) -! orb_rhor(:,2) = orb_rhor(:,2)/overlap_(j+2-iupdwn(ispin(j+1)),j+2-iupdwn(ispin(j+1)),ispin(j+1)) - !compute centers and spreads of nksic or pz minimizing orbitals - IF(icompute_spread) THEN - ! - call compute_nksic_centers(nnrx, nx, nudx, nbsp, nspin, iupdwn, & - nupdwn, ispin, orb_rhor, wfc_centers, wfc_spreads, j, j+1) - ! - ENDIF - ! -!end_added:giovanni - ! - shart=0.d0 - ! - ! compute orbital potentials - ! - inner_loop: do jj=1,2 - ! - i=j+jj-1 - ! - ! this condition is important when n is odd - ! - if ( i > nbsp ) exit inner_loop - ! - ibnd=i - if( nspin==2 ) then - if ( i >= iupdwn(2) ) ibnd=i-iupdwn(2)+1 - endif - ! - ! note: iupdwn(2) is set to zero if nspin = 1 - ! - focc=f_diag(i)*DBLE(nspin)/2.0d0 - ! - ! compute parameters needed for PZ-renormalization - ! - IF(do_pz_renorm) THEN - ! - call nksic_get_taukin_pz( focc, nspin, ispin(i), orb_rhor(:,jj), & - taukin, ibnd) - ! - ENDIF - ! - ! - ! define rhoref and rhobar - ! - !write(6,*) ubound(rhobarg) - call nksic_get_rhoref( i, nnrx, ispin(i), nspin, & - focc, rhor, orb_rhor(:,jj), & - rhoref, rhobar, rhobarg, grhobar ) - - ! - ! compute nk pieces to build the potentials and the energy - ! - if ( do_nk .or. do_nkpz ) then - ! - call nksic_correction_nk( focc, ispin(i), orb_rhor(:,jj), & - rhor, rhoref, rhobar, rhobarg, grhobar, & - vsic(:,i), wxdsic, wrefsic, do_wxd_, & - pink(i), ibnd, shart) - ! - wfc_spreads(ibnd, ispin(i), 2) = shart - ! - ! here information is accumulated over states - ! (wtot is added in the next loop) - ! - wtot(1:nnrx,1:2) = wtot(1:nnrx,1:2) + wxdsic(1:nnrx,1:2) - ! - ! ths sic potential is partly updated here to save some memory - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + wrefsic(1:nnrx) & - - wxdsic( 1:nnrx, ispin(i) ) - ! - endif - - ! - ! compute nkpz pieces to build the potential and the energy - ! - if( do_nkpz ) then - ! - call nksic_correction_nkpz( focc, orb_rhor(:,jj), vsicpz, & - wrefsic, pinkpz, ibnd, ispin(i)) - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + vsicpz(1:nnrx) & - + wrefsic(1:nnrx) - ! - pink(i) = pink(i) +pinkpz - ! - endif - - - ! - ! compute pz potentials and energy - ! - if ( do_pz ) then - ! - call nksic_correction_pz ( focc, ispin(i), orb_rhor(:,jj), & - vsic(:,i), pink(i), pzalpha(i), ibnd, shart) - ! - wfc_spreads(ibnd, ispin(i), 2) = shart - ! - if(do_pz_renorm) then - ! - edens(:,ispin(i)) = edens(:,ispin(i)) + pink(i)*orb_rhor(:,jj) - ! - endif - ! - endif - - ! - ! compute nki pieces to build the potentials and the energy - ! - if ( do_nki .or. do_nkipz) then - ! - call nksic_correction_nki( focc, ispin(i), orb_rhor(:,jj), & - rhor, rhoref, rhobar, rhobarg, grhobar, & - vsic(:,i), wxdsic, do_wxd_, pink(i), ibnd) - ! - ! here information is accumulated over states - ! (wtot is added in the next loop) - ! - wtot(1:nnrx,1:2) = wtot(1:nnrx,1:2) + wxdsic(1:nnrx,1:2) - ! - ! ths sic potential is partly updated here to save some memory - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) - wxdsic( 1:nnrx, ispin(i) ) - ! - endif - - if( do_nkipz ) then - ! - call nksic_correction_nkipz( focc, ispin(i), orb_rhor(:,jj), vsicpz, & - pinkpz, ibnd, shart) - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + vsicpz(1:nnrx) - ! - pink(i) = pink(i) + pinkpz - ! - wfc_spreads(ibnd, ispin(i), 2) = shart - ! - endif - ! - ! take care of spin symmetry - ! - pink(i) = f_diag(i) * pink(i) - ! - if ( do_nk .or. do_nkpz .or. do_nki .or. do_nkipz) then - ! - if( nspin== 1 ) then - ! - wtot(1:nnrx,1) = wtot(1:nnrx,1) + wxdsic(1:nnrx,2) - wtot(1:nnrx,2) = wtot(1:nnrx,2) + wxdsic(1:nnrx,1) - ! - endif - ! - endif - ! - enddo inner_loop - ! - enddo - - ! - ! Switch off the icompute_spread flag if present - ! - IF(icompute_spread) THEN - ! - icompute_spread=.false. - ! - ENDIF - ! - ! now wtot is completely built and can be added to vsic - ! - if ( do_nk .or. do_nkpz .or. do_nki .or. do_nkipz ) then - ! - do i = 1, nbsp - ! - vsic(1:nnrx,i) = vsic(1:nnrx,i) + wtot( 1:nnrx, ispin(i) ) - ! - enddo - ! - endif - ! - ! if pz is renormalized, here we compute the potential, and multiply here pink by renormalization factor - ! - if ( do_pz_renorm ) then - ! - do j=1,nbsp,2 - ! - call nksic_get_orbitalrho( ngw, nnrx, bec, ispin, nbsp, & - c(:,j), c(:,j+1), orb_rhor, j, j+1, lgam) - ! - inner_loop_renorm: do jj=1,2 - ! - i=j+jj-1 - if ( i > nbsp ) exit inner_loop_renorm - ! - ibnd=i - focc=f_diag(i)*DBLE(nspin)/2.0d0 - ! - if( nspin==2 ) then - if ( i >= iupdwn(2) ) ibnd=i-iupdwn(2)+1 - endif - ! - call nksic_get_pz_factor( nspin, ispin(i), orb_rhor(:,jj), & - taukin, tauw, pzalpha(i), ibnd, kfact) - ! - ! update vsic with factor here: it works for pz, will it work for - ! nk-type functionals? - ! -! vsic(:,i) = vsic(:,i)*pzalpha(i) -! pink(i) = pink(i)*pzalpha(i) - ! - ! -! call nksic_get_pzfactor_potential(focc, nspin, ispin(i), rhor, orb_rhor(:,jj), & -! pink(i), taukin, tauw, edens, upsilonkin, upsilonw, vsic(:,i), pzalpha(i), ibnd, kfact) - ! - enddo inner_loop_renorm - ! - enddo - ! - endif - ! - ! - if (draw_pot) then !added:linh draw vsic potentials - ! - write(stdout,*) "I am writing out vsic", nbsp - do i =1, nbsp - ! - if (i == pot_number) call write_pot_sic ( vsic(:, i) ) - ! - enddo - ! - endif !added:linh draw vsic potentials - ! - if ( allocated(vsicpz) ) deallocate(vsicpz) - - ! - ! USPP: - ! compute corrections to the D coefficients of the pseudopots - ! due to vsic(r, i) in the case of orbital dependent functionals. - ! The corresponding contributions to the forces are computed. - ! - ! IMPORTANT: the following call makes use of newd. - ! It must be done before we call newd for the - ! total potentials, because deeq is overwritten at every call - ! - fion_sic(:,:) = 0.0d0 - ! - IF ( nhm > 0 ) then - ! - deeq_sic(:,:,:,:) = 0.0d0 - ! - DO i = 1, nbsp - ! - CALL nksic_newd( i, nnrx, ispin(i), nspin, vsic(:,i), nat, nhm, & - becsum, fion_sic, deeq_sic(:,:,:,i) ) - ! - ENDDO - ! - ENDIF - ! - deallocate(rhobarg) - ! - CALL stop_clock( 'nksic_drv' ) - return - ! -!----------------------------------------------------------------------- - end subroutine nksic_potential_non_ortho -!----------------------------------------------------------------------- diff --git a/quantum_espresso/kcp/CPV/nl_base.f90 b/quantum_espresso/kcp/CPV/nl_base.f90 deleted file mode 100644 index 81e8326a0..000000000 --- a/quantum_espresso/kcp/CPV/nl_base.f90 +++ /dev/null @@ -1,2006 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -!----------------------------------------------------------------------- - subroutine nlsm1_real ( n, nspmn, nspmx, eigr, c, becp ) -!----------------------------------------------------------------------- - - ! computes: the array becp - ! becp(ia,n,iv,is)= - ! = sum_g [(-i)**l beta(g,iv,is) e^(-ig.r_ia)]^* c(g,n) - ! = delta_l0 beta(g=0,iv,is) c(g=0,n) - ! +sum_g> beta(g,iv,is) 2 re[(i)**l e^(ig.r_ia) c(g,n)] - ! - ! routine makes use of c*(g)=c(-g) (g> see routine ggen) - ! input : beta(ig,l,is), eigr, c - ! output: becp as parameter - ! - USE kinds, ONLY : DP - USE mp, ONLY : mp_sum - USE mp_global, ONLY : nproc_image, intra_image_comm - USE ions_base, only : na, nat - USE gvecw, only : ngw - USE uspp, only : nkb, nhtol, beta - USE cvan, only : ish - USE uspp_param, only : nh - ! - USE reciprocal_vectors, ONLY : gstart -! - implicit none - - integer, intent(in) :: n, nspmn, nspmx - complex(DP), intent(in) :: eigr( ngw, nat ), c( ngw, n ) - real(DP), intent(out) :: becp( nkb, n ) - ! - integer :: isa, ig, is, iv, ia, l, inl, i, nhx - real(DP), allocatable :: becps( :, : ) - complex(DP), allocatable :: wrk2( :, : ) - complex(DP), parameter :: c_one=CMPLX(1.d0,0.d0), c_zero=CMPLX(0.d0,0.d0) - complex(DP), parameter :: ci=CMPLX(0.d0,1.d0) - complex(DP) :: cl, arg_c - ! - call start_clock( 'nlsm1' ) - - isa = 0 - do is = 1, nspmn - 1 - isa = isa + na(is) - end do - - do is = nspmn, nspmx - ! - IF( nh( is ) < 1 ) THEN - isa = isa + na(is) - CYCLE - END IF - ! - allocate( wrk2( ngw, na( is ) ) ) - ! - IF( nproc_image > 1 ) THEN - nhx = nh( is ) * na( is ) - IF( MOD( nhx, 2 ) /= 0 ) nhx = nhx + 1 - ALLOCATE( becps( nhx, n ) ) - becps = 0.0d0 - END IF - ! - do iv = 1, nh( is ) - ! -!$omp parallel default(shared), private(l,ixr,ixi,signre,signim,ig,arg,ia) - l = nhtol( iv, is ) - cl = (-ci)**l -! ! -! if (l == 0) then -! ixr = 1 -! ixi = 2 -! signre = 1.0d0 -! signim = 1.0d0 -! else if (l == 1) then -! ixr = 2 -! ixi = 1 -! signre = 1.0d0 -! signim = -1.0d0 -! else if (l == 2) then -! ixr = 1 -! ixi = 2 -! signre = -1.0d0 -! signim = -1.0d0 -! else if (l == 3) then -! ixr = 2 -! ixi = 1 -! signre = -1.0d0 -! signim = 1.0d0 -! endif -! -!$omp do - do ia=1,na(is) - ! - ! q = 0 component (with weight 1.0) - ! - if (gstart == 2) then - wrk2(1, ia ) = cl*beta(1,iv,is)*eigr(1,ia+isa) -! wrk2( 2, 1, ia ) = signim*beta(1,iv,is)*eigr(ixi,1,ia+isa) - end if - ! - ! q > 0 components (with weight 2.0) - ! - do ig = gstart, ngw - arg_c = CMPLX(2.0d0 * beta(ig,iv,is), 0.d0)*cl - wrk2( ig, ia ) = arg_c*eigr(ig,ia+isa) -! wrk2( 2, ig, ia ) = signim*arg*eigr(ixi,ig,ia+isa) - end do - ! - end do -!$omp end do - -!$omp end parallel - ! - IF( nproc_image > 1 ) THEN - inl=(iv-1)*na(is)+1 - CALL DGEMM( 'T', 'N', na(is), n, 2*ngw, 1.0d0, wrk2, 2*ngw, c, 2*ngw, 0.0d0, becps( inl, 1 ), nhx ) - ELSE - inl=ish(is)+(iv-1)*na(is)+1 - CALL DGEMM( 'T', 'N', na(is), n, 2*ngw, 1.0d0, wrk2, 2*ngw, c, 2*ngw, 0.0d0, becp( inl, 1 ), nkb ) - END IF - - end do - - deallocate( wrk2 ) - - - IF( nproc_image > 1 ) THEN - ! - inl = ish(is) + 1 - ! - CALL mp_sum( becps, intra_image_comm ) - - do i = 1, n - do iv = inl , ( inl + na(is) * nh(is) - 1 ) - becp( iv, i ) = becps( iv - inl + 1, i ) - end do - end do - - DEALLOCATE( becps ) - - END IF - - isa = isa + na(is) - - end do - - call stop_clock( 'nlsm1' ) - - return - end subroutine nlsm1_real -!--------------------------------------------------------l--------------- - -!----------------------------------------------------------------------- - subroutine nlsm1_twin(n, nspmn, nspmx, eigr, c, becp, lbound_bec, lgam2)!added:giovanni lgam -!----------------------------------------------------------------------- - - ! computes: the array becp - ! becp(ia,n,iv,is)= - ! = sum_g [(-i)**l beta(g,iv,is) e^(-ig.r_ia)]^* c(g,n) - ! = delta_l0 beta(g=0,iv,is) c(g=0,n) - ! +sum_g> beta(g,iv,is) 2 re[(i)**l e^(ig.r_ia) c(g,n)] - ! - ! routine makes use of c*(g)=c(-g) (g> see routine ggen) - ! input : beta(ig,l,is), eigr, c - ! output: becp as parameter - ! - USE kinds, ONLY : DP - USE mp, ONLY : mp_sum - USE mp_global, ONLY : nproc_image, intra_image_comm - USE ions_base, only : na, nat - USE gvecw, only : ngw - USE uspp, only : nkb, nhtol, beta - USE cvan, only : ish - USE uspp_param, only : nh - USE twin_types !added:giovanni - ! - USE reciprocal_vectors, ONLY : gstart -! - implicit none - - integer, intent(in) :: n, nspmn, nspmx, lbound_bec - complex(DP), intent(in) :: eigr(ngw,nat),c(ngw, n )!modified:giovanni - type(twin_matrix) :: becp ! modified:giovanni - logical :: lgam2 ! added:giovanni - ! - integer :: isa, ig, is, iv, ia, l, inl, nhx, i - real(DP), allocatable :: becps( :, : ) - complex(DP), allocatable :: becps_c( :, : ) - complex(DP), allocatable :: wrk2_c( :, : ) - complex(DP), parameter :: c_one=CMPLX(1.d0,0.d0), c_zero=CMPLX(0.d0,0.d0) - complex(DP), parameter :: ci=CMPLX(0.d0,1.d0) - complex(DP) :: cl, arg_c - logical :: lgam!added:giovanni - ! - lgam=lgam2 - call start_clock( 'nlsm1' ) - ! isa - isa = 0 - do is = 1, nspmn - 1 - isa = isa + na(is) - end do - - IF ((.not.lgam).and.nproc_image==1) THEN - ALLOCATE( becps_c( nkb, n )) - becps_c = CMPLX(0.0d0,0.d0) - ENDIF - - do is = nspmn, nspmx - ! - IF( nh( is ) < 1 ) THEN - isa = isa + na(is) - CYCLE - END IF - ! - allocate( wrk2_c( ngw, na( is ) ) ) - wrk2_c=CMPLX(0.d0,0.d0) - ! - IF( nproc_image > 1 ) THEN - nhx = nh( is ) * na( is ) - IF( MOD( nhx, 2 ) /= 0 ) nhx = nhx + 1 - IF(lgam) THEN - ALLOCATE( becps( nhx, n ) ) - becps = 0.0d0 - ELSE - ALLOCATE( becps_c( nhx, n ) ) - becps_c = CMPLX(0.0d0,0.d0) - ENDIF - END IF - - - ! - IF(lgam) THEN !added:giovanni - do iv = 1, nh( is ) - ! - !$omp parallel default(shared), private(l,ixr,ixi,signre,signim,ig,arg,ia) - l = nhtol( iv, is ) -! write(6,*) "check_l_giovanni", l, iv, is - cl =(-ci)**l -! write(6,'(2((F20.13)(3x)))') cl - ! - ! - !$omp do - do ia=1,na(is) - ! - ! q = 0 component (with weight 1.0) - ! - if (gstart == 2) then - wrk2_c( 1, ia ) = CMPLX(beta(1,iv,is),0.d0)*cl*eigr(1,ia+isa) - end if - ! - ! q > 0 components (with weight 2.0) - ! - do ig = gstart, ngw - arg_c = CMPLX(2.0d0*beta(ig,iv,is), 0.d0)*cl - wrk2_c( ig, ia ) = arg_c*eigr(ig,ia+isa) - end do - ! - end do - !$omp end do - !$omp end parallel - ! - IF( nproc_image > 1 ) THEN - inl=(iv-1)*na(is)+1 - CALL DGEMM( 'T', 'N', na(is), n, 2*ngw, 1.0d0, wrk2_c, 2*ngw, c, 2*ngw, 0.0d0, becps( inl, 1 ), nhx ) - ELSE - inl=ish(is)+(iv-1)*na(is)+1 - CALL DGEMM( 'T', 'N', na(is), n, 2*ngw, 1.0d0, wrk2_c, 2*ngw, c, 2*ngw, 0.0d0, becp%rvec( inl, lbound_bec ), nkb ) - ENDIF - - end do - - ELSE -!begin_added:giovanni - do iv = 1, nh( is ) - ! - !$omp parallel default(shared), private(l,ixr,ixi,signre,signim,ig,arg,ia) - l = nhtol( iv, is ) - cl=(-ci)**l - ! - !$omp do - do ia=1,na(is) - ! - do ig = 1, ngw - arg_c = cl*CMPLX(beta(ig,iv,is),0.d0) - wrk2_c( ig, ia ) = (arg_c*eigr(ig,ia+isa)) - end do - ! - end do - !$omp end do - - !$omp end parallel - ! - IF( nproc_image > 1 ) THEN - inl=(iv-1)*na(is)+1 - CALL ZGEMM( 'C', 'N', na(is), n, ngw, c_one, wrk2_c, ngw, c, ngw, c_zero, becps_c( inl, 1 ), nhx ) - ELSE - inl=ish(is)+(iv-1)*na(is)+1 - CALL ZGEMM( 'C', 'N', na(is), n, ngw, c_one, wrk2_c, ngw, c, ngw,c_zero, becps_c( inl, lbound_bec ), nkb) - END IF - - end do -!end_added:giovanni - ENDIF - - deallocate( wrk2_c ) - - IF(nproc_image>1) THEN - - inl = ish(is) + 1 - - IF(lgam) THEN - ! - CALL mp_sum( becps, intra_image_comm ) - - do i = 1, n - do iv = inl , ( inl + na(is) * nh(is) - 1 ) - becp%rvec( iv, i +lbound_bec -1) = becps( iv - inl + 1, i ) - end do - end do - - DEALLOCATE( becps ) - ! - ELSE IF(.not.lgam) THEN - - CALL mp_sum( becps_c, intra_image_comm ) - - do i = 1, n - do iv = inl , ( inl + na(is) * nh(is) - 1 ) - becp%cvec( iv, i +lbound_bec -1) = (becps_c( iv - inl + 1, i )) - end do - end do - - DEALLOCATE( becps_c ) - - ENDIF - - END IF - - isa = isa + na(is) - - end do -!begin_added:giovanni - IF(nproc_image==1.and.(.not.lgam)) THEN - becp%cvec(:,:) = becps_c(:,:) - deallocate(becps_c) - endif -!end_added:giovanni - call stop_clock( 'nlsm1' ) - - return - end subroutine nlsm1_twin -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - subroutine nlsm1_dist_real ( n, nspmn, nspmx, eigr, c, becp, nlax, nspin, desc ) -!----------------------------------------------------------------------- - ! - ! This version is for becp distributed over procs - ! - ! computes: the array becp - ! becp(ia,n,iv,is)= - ! = sum_g [(-i)**l beta(g,iv,is) e^(-ig.r_ia)]^* c(g,n) - ! = delta_l0 beta(g=0,iv,is) c(g=0,n) - ! +sum_g> beta(g,iv,is) 2 re[(i)**l e^(ig.r_ia) c(g,n)] - ! - ! routine makes use of c*(g)=c(-g) (g> see routine ggen) - ! input : beta(ig,l,is), eigr, c - ! output: becp as parameter - ! - USE kinds, ONLY : DP - USE mp, ONLY : mp_sum - USE mp_global, ONLY : nproc_image, intra_image_comm - USE ions_base, only : na, nat - USE gvecw, only : ngw - USE uspp, only : nkb, nhtol, beta - USE cvan, only : ish - USE uspp_param, only : nh - ! - USE reciprocal_vectors, ONLY : gstart - USE descriptors, ONLY : descla_siz_ , lambda_node_ , nlar_ , ilar_ , la_n_ -! - implicit none - - integer, intent(in) :: n, nspmn, nspmx, nlax, nspin - integer, intent(in) :: desc( descla_siz_ , nspin ) - real(DP), intent(in) :: eigr( 2, ngw, nat ), c( 2, ngw, n ) - real(DP), intent(out) :: becp( nkb, nlax*nspin ) - ! - integer :: isa, ig, is, iv, ia, l, ixr, ixi, inl, i, nhx - integer :: nr, ir, nup - real(DP) :: signre, signim, arg - real(DP), allocatable :: becps( :, : ) - real(DP), allocatable :: wrk2( :, :, : ) - ! - call start_clock( 'nlsm1' ) - - isa = 0 - do is = 1, nspmn - 1 - isa = isa + na(is) - end do - - do is = nspmn, nspmx - ! - IF( nh( is ) < 1 ) THEN - isa = isa + na(is) - CYCLE - END IF - ! - allocate( wrk2( 2, ngw, na( is ) ) ) - ! - IF( nproc_image > 1 ) THEN - nhx = nh( is ) * na( is ) - IF( MOD( nhx, 2 ) /= 0 ) nhx = nhx + 1 - ALLOCATE( becps( nhx, n ) ) - becps = 0.0d0 - END IF - ! - do iv = 1, nh( is ) - ! -!$omp parallel default(shared), private(l,ixr,ixi,signre,signim,ig,arg,ia) - l = nhtol( iv, is ) - ! - if (l == 0) then - ixr = 1 - ixi = 2 - signre = 1.0d0 - signim = 1.0d0 - else if (l == 1) then - ixr = 2 - ixi = 1 - signre = 1.0d0 - signim = -1.0d0 - else if (l == 2) then - ixr = 1 - ixi = 2 - signre = -1.0d0 - signim = -1.0d0 - else if (l == 3) then - ixr = 2 - ixi = 1 - signre = -1.0d0 - signim = 1.0d0 - endif -! -!$omp do - do ia=1,na(is) - ! - ! q = 0 component (with weight 1.0) - ! - if (gstart == 2) then - wrk2( 1, 1, ia ) = signre*beta(1,iv,is)*eigr(ixr,1,ia+isa) - wrk2( 2, 1, ia ) = signim*beta(1,iv,is)*eigr(ixi,1,ia+isa) - end if - ! - ! q > 0 components (with weight 2.0) - ! - do ig = gstart, ngw - arg = 2.0d0 * beta(ig,iv,is) - wrk2( 1, ig, ia ) = signre*arg*eigr(ixr,ig,ia+isa) - wrk2( 2, ig, ia ) = signim*arg*eigr(ixi,ig,ia+isa) - end do - ! - end do -!$omp end do - -!$omp end parallel - - ! - IF( nproc_image > 1 ) THEN - inl=(iv-1)*na(is)+1 - CALL DGEMM( 'T', 'N', na(is), n, 2*ngw, 1.0d0, wrk2, 2*ngw, c, 2*ngw, 0.0d0, becps( inl, 1 ), nhx ) - ELSE - inl=ish(is)+(iv-1)*na(is)+1 - CALL DGEMM( 'T', 'N', na(is), n, 2*ngw, 1.0d0, wrk2, 2*ngw, c, 2*ngw, 0.0d0, becp( inl, 1 ), nkb ) - END IF - - end do - - deallocate( wrk2 ) - - - IF( nproc_image > 1 ) THEN - ! - inl = ish(is) + 1 - ! - CALL mp_sum( becps, intra_image_comm ) - - IF( desc( lambda_node_ , 1 ) > 0 ) THEN - ir = desc( ilar_ , 1 ) - nr = desc( nlar_ , 1 ) - do i = 1, nr - do iv = inl , ( inl + na(is) * nh(is) - 1 ) - becp( iv, i ) = becps( iv - inl + 1, i + ir - 1 ) - end do - end do - END IF - ! - IF( nspin == 2 ) THEN - IF( desc( lambda_node_ , 2 ) > 0 ) THEN - nup = desc( la_n_ , 1 ) - ir = desc( ilar_ , 2 ) - nr = desc( nlar_ , 2 ) - do i = 1, nr - do iv = inl , ( inl + na(is) * nh(is) - 1 ) - becp( iv, i + nlax ) = becps( iv - inl + 1, i + ir - 1 + nup ) - end do - end do - END IF - END IF - - DEALLOCATE( becps ) - - END IF - - isa = isa + na(is) - - end do - - call stop_clock( 'nlsm1' ) - - return - end subroutine nlsm1_dist_real -!----------------------------------------------------------------------- - -! -!----------------------------------------------------------------------- - subroutine nlsm1_dist_twin ( n, nspmn, nspmx, eigr, c, becp, nlax, nspin, desc, lgam2 ) -!----------------------------------------------------------------------- - ! - ! This version is for becp distributed over procs - ! - ! computes: the array becp - ! becp(ia,n,iv,is)= - ! = sum_g [(-i)**l beta(g,iv,is) e^(-ig.r_ia)]^* c(g,n) - ! = delta_l0 beta(g=0,iv,is) c(g=0,n) - ! +sum_g> beta(g,iv,is) 2 re[(i)**l e^(ig.r_ia) c(g,n)] - ! - ! routine makes use of c*(g)=c(-g) (g> see routine ggen) - ! input : beta(ig,l,is), eigr, c - ! output: becp as parameter - ! - USE kinds, ONLY : DP - USE mp, ONLY : mp_sum - USE mp_global, ONLY : nproc_image, intra_image_comm - USE ions_base, only : na, nat - USE gvecw, only : ngw - USE uspp, only : nkb, nhtol, beta - USE cvan, only : ish - USE uspp_param, only : nh - ! - USE reciprocal_vectors, ONLY : gstart - USE descriptors, ONLY : descla_siz_ , lambda_node_ , nlar_ , ilar_ , la_n_ - USE twin_types -! - implicit none - - integer, intent(in) :: n, nspmn, nspmx, nlax, nspin - integer, intent(in) :: desc( descla_siz_ , nspin ) - complex(DP), intent(in) :: eigr( ngw, nat ), c( ngw, n ) - type(twin_matrix), intent(out) :: becp !( nkb, nlax*nspin ) - logical, intent(IN) :: lgam2 - ! - integer :: isa, ig, is, iv, ia, l, inl, i, nhx - integer :: nr, ir, nup - real(DP), allocatable :: becps( :, : ) - complex(DP), allocatable :: becps_c( :, : ) - complex(DP), allocatable :: wrk2_c( :, : ) - complex(DP), parameter :: c_one=CMPLX(1.d0,0.d0), c_zero=CMPLX(0.d0,0.d0) - complex(DP), parameter :: ci=CMPLX(0.d0,1.d0) - complex(DP) :: cl, arg_c - logical :: lgam !added:giovanni - ! - lgam=lgam2 - call start_clock( 'nlsm1' ) - ! isa - isa = 0 - do is = 1, nspmn - 1 - isa = isa + na(is) - end do - - IF(nproc_image==1.and.(.not.lgam)) THEN - ALLOCATE( becps_c( max(1,nkb), n )) - becps_c = CMPLX(0.0d0,0.d0) - ENDIF - - do is = nspmn, nspmx - ! - IF( nh( is ) < 1 ) THEN - isa = isa + na(is) - CYCLE - END IF - ! - allocate( wrk2_c( ngw, na( is ) ) ) - wrk2_c=CMPLX(0.d0,0.d0) - ! - IF( nproc_image > 1 ) THEN - nhx = nh( is ) * na( is ) - IF( MOD( nhx, 2 ) /= 0 ) nhx = nhx + 1 - IF(lgam) THEN - ALLOCATE( becps( nhx, n ) ) - becps = 0.0d0 - ELSE - ALLOCATE( becps_c( nhx, n ) ) - becps_c = CMPLX(0.0d0,0.d0) - ENDIF - END IF - ! - IF(lgam) THEN !added:giovanni - do iv = 1, nh( is ) - ! - !$omp parallel default(shared), private(l,ixr,ixi,signre,signim,ig,arg,ia) - l = nhtol( iv, is ) - cl =(-ci)**l - ! - ! - !$omp do - do ia=1,na(is) - ! - ! q = 0 component (with weight 1.0) - ! - if (gstart == 2) then - wrk2_c( 1, ia ) =CMPLX(beta(1,iv,is),0.d0)*cl*eigr(1,ia+isa) - end if - ! - ! q > 0 components (with weight 2.0) - ! - do ig = gstart, ngw - arg_c = CMPLX(2.0d0*beta(ig,iv,is), 0.d0)*cl - wrk2_c( ig, ia ) = arg_c*eigr(ig,ia+isa) - end do - ! - end do - !$omp end do - - !$omp end parallel - ! - IF( nproc_image > 1 ) THEN - inl=(iv-1)*na(is)+1 - CALL DGEMM( 'T', 'N', na(is), n, 2*ngw, 1.0d0, wrk2_c, 2*ngw, c, 2*ngw, 0.0d0, becps( inl, 1 ), nhx ) - ELSE - inl=ish(is)+(iv-1)*na(is)+1 - CALL DGEMM( 'T', 'N', na(is), n, 2*ngw, 1.0d0, wrk2_c, 2*ngw, c, 2*ngw, 0.0d0, becp%rvec( inl, 1 ), nkb ) - END IF - end do - - ELSE -!begin_added:giovanni - do iv = 1, nh( is ) - ! - !$omp parallel default(shared), private(l,ixr,ixi,signre,signim,ig,arg,ia) - l = nhtol( iv, is ) - cl=(-ci)**l - ! - !$omp do - do ia=1,na(is) - ! - do ig = 1, ngw - arg_c = cl*CMPLX(beta(ig,iv,is),0.d0) - wrk2_c( ig, ia ) = arg_c*eigr(ig,ia+isa) - end do - ! - end do - !$omp end do - - !$omp end parallel - ! - IF( nproc_image > 1 ) THEN - inl=(iv-1)*na(is)+1 - CALL ZGEMM( 'C', 'N', na(is), n, ngw, c_one, wrk2_c, ngw, c, ngw, c_zero, becps_c( inl, 1 ), nhx ) - ELSE - inl=ish(is)+(iv-1)*na(is)+1 - CALL ZGEMM( 'C', 'N', na(is), n, ngw, c_one, wrk2_c, ngw, c, ngw,c_zero, becps_c( inl, 1 ), nkb) - END IF - end do -!end_added:giovanni - ENDIF - - deallocate( wrk2_c ) - - IF( nproc_image > 1 ) THEN - ! - inl = ish(is) + 1 - ! - IF(lgam) THEN - - CALL mp_sum( becps, intra_image_comm ) - - IF( desc( lambda_node_ , 1 ) > 0 ) THEN - ir = desc( ilar_ , 1 ) - nr = desc( nlar_ , 1 ) - do i = 1, nr - do iv = inl , ( inl + na(is) * nh(is) - 1 ) - becp%rvec( iv, i ) = becps( iv - inl + 1, i + ir - 1 ) - end do - end do - END IF - - IF( nspin == 2 ) THEN - IF( desc( lambda_node_ , 2 ) > 0 ) THEN - nup = desc( la_n_ , 1 ) - ir = desc( ilar_ , 2 ) - nr = desc( nlar_ , 2 ) - do i = 1, nr - do iv = inl , ( inl + na(is) * nh(is) - 1 ) - becp%rvec( iv, i + nlax ) = becps( iv - inl + 1, i + ir - 1+ nup ) - end do - end do - END IF - END IF - - DEALLOCATE( becps ) - - ELSE !if not lgam - - CALL mp_sum( becps_c, intra_image_comm ) - IF( desc( lambda_node_ , 1 ) > 0 ) THEN - ir = desc( ilar_ , 1 ) - nr = desc( nlar_ , 1 ) - do i = 1, nr - do iv = inl , ( inl + na(is) * nh(is) - 1 ) - becp%cvec( iv, i ) = (becps_c( iv - inl + 1, i + ir - 1 )) - end do - end do - END IF - - IF( nspin == 2 ) THEN - IF( desc( lambda_node_ , 2 ) > 0 ) THEN - nup = desc( la_n_ , 1 ) - ir = desc( ilar_ , 2 ) - nr = desc( nlar_ , 2 ) - do i = 1, nr - do iv = inl , ( inl + na(is) * nh(is) - 1 ) - becp%cvec( iv, i + nlax ) = (becps_c( iv - inl + 1, i +ir - 1+ nup )) - end do - end do - END IF - END IF - - DEALLOCATE( becps_c ) - ENDIF - END IF - - isa = isa + na(is) - - end do -! write(0,*) "inloop_giovanni", nproc_image==1.and.(.not.lgam).and.(.not.becp%iscmplx) -!begin_added:giovanni - IF(nproc_image==1.and.(.not.lgam)) THEN - becp%cvec(:,:)=(becps_c(:,:)) - DEALLOCATE(becps_c) - ENDIF - - call stop_clock( 'nlsm1' ) - - return - end subroutine nlsm1_dist_twin -!----------------------------------------------------------------------- - - -!------------------------------------------------------------------------- - subroutine nlsm2( ngw, nkb, n, nspin, eigr, c, becdr, lgam2 ) -!----------------------------------------------------------------------- - - ! computes: the array becdr - ! becdr(ia,n,iv,is,k) - ! =2.0 sum_g> g_k beta(g,iv,is) re[ (i)**(l+1) e^(ig.r_ia) c(g,n)] - ! - ! routine makes use of c*(g)=c(-g) (g> see routine ggen) - ! input : eigr, c - ! output: becdr - ! - - USE kinds, ONLY : DP - use ions_base, only : nsp, na, nat - use uspp, only : nhtol, beta !, nkb - use cvan, only : ish - use uspp_param, only : nh - use cell_base, only : tpiba - use mp, only : mp_sum - use mp_global, only : nproc_image, intra_image_comm - use cp_main_variables, only : descla, distribute_bec_real, distribute_bec_cmplx - use reciprocal_vectors, only : gx, gstart - use twin_types !added:giovanni -! - implicit none - - integer, intent(in) :: ngw, nkb, n, nspin - complex(DP), intent(in) :: eigr(ngw,nat), c(ngw,n) - type(twin_tensor), intent(out) :: becdr!(nkb,nspin*nlax,3) !modified:giovanni - logical :: lgam2 - ! - real(DP), allocatable :: gk(:) - complex(DP), allocatable :: wrk2_c(:,:) - real(DP), allocatable :: becdr_repl(:,:) - complex(DP), allocatable :: becdr_repl_c(:,:) - ! - integer :: ig, is, iv, ia, k, l, inl, isa - logical :: lgam ! added:giovanni - complex(DP), parameter :: c_one=CMPLX(1.d0,0.d0), c_zero=CMPLX(0.d0,0.d0) - complex(DP), parameter :: ci=CMPLX(0.d0,1.d0) !added:giovanni - complex(DP) :: cl, arg_c !added:giovanni - real(DP) :: fact -! - lgam=lgam2 - - call start_clock( 'nlsm2' ) - - allocate( gk( ngw ) ) - - IF(lgam) THEN - becdr%rvec = 0.d0 - allocate( becdr_repl( max(nkb,1), n ) ) - ELSE - becdr%cvec = c_zero - allocate( becdr_repl_c( max(nkb,1), n ) ) - ENDIF -! - do k = 1, 3 - - IF(lgam) then - becdr_repl = 0.d0 - ELSE - becdr_repl_c = CMPLX(0.d0,0.d0) - ENDIF - - do ig=1,ngw - gk(ig)=gx(k,ig)*tpiba - end do -! - isa = 0 - - do is=1,nsp - - allocate( wrk2_c( ngw, na( is ) ) ) - wrk2_c=CMPLX(0.d0,0.d0) - - IF(lgam) THEN - fact=2.d0 - ELSE - fact=1.d0 - ENDIF - - do iv=1,nh(is) - ! - ! order of states: s_1 p_x1 p_z1 p_y1 s_2 p_x2 p_z2 p_y2 - ! -!$omp parallel default(shared), private(l,ixr,ixi,signre,signim,ig,arg,ia) - l=nhtol(iv,is) - cl=(-ci)**(l+1) -! -!$omp do - do ia=1,na(is) - ! q = 0 component (with weight 1.0) - if (gstart == 2) then - wrk2_c(1,ia) = cl*CMPLX(gk(1)*beta(1,iv,is),0.d0)*eigr(1,ia+isa) - end if - ! q > 0 components (with weight 2.0) - do ig=gstart,ngw - arg_c = CMPLX(fact*gk(ig)*beta(ig,iv,is),0.d0) - wrk2_c(ig,ia) = cl*arg_c*eigr(ig,ia+isa) - end do - end do -!$omp end do -!$omp end parallel - inl=ish(is)+(iv-1)*na(is)+1 - IF(lgam) THEN - CALL DGEMM( 'T', 'N', na(is), n, 2*ngw, 1.0d0, wrk2_c, 2*ngw, c, 2*ngw, 0.0d0, becdr_repl( inl, 1 ), max(nkb,1) ) - ELSE - CALL ZGEMM( 'C', 'N', na(is), n, ngw, c_one, wrk2_c, ngw, c, ngw, c_zero, becdr_repl_c( inl, 1 ), max(nkb,1) ) - ENDIF - end do - - deallocate( wrk2_c ) - - isa = isa + na(is) - - end do - - IF( nproc_image > 1 ) THEN - IF(lgam) THEN - CALL mp_sum( becdr_repl(:,:), intra_image_comm ) - ELSE - CALL mp_sum( becdr_repl_c(:,:), intra_image_comm ) - ENDIF - END IF - - IF(lgam) THEN - CALL distribute_bec_real( becdr_repl(:,:), becdr%rvec(:,:,k), descla, nspin ) - ELSE - write(6,*) ubound(becdr_repl_c), ubound(becdr%cvec) - CALL distribute_bec_cmplx((becdr_repl_c(:,:)), becdr%cvec(:,:,k), descla, nspin ) - ENDIF - - end do - - deallocate( gk ) - IF(lgam) THEN - deallocate( becdr_repl ) - ELSE - deallocate( becdr_repl_c ) - ENDIF - - call stop_clock( 'nlsm2' ) -! - return - end subroutine nlsm2 -!----------------------------------------------------------------------- - -!------------------------------------------------------------------------- - subroutine nlsm2_repl( ngw, nkb, n, eigr, c, becdr, lgam ) -!----------------------------------------------------------------------- - - ! computes: the array becdr - ! becdr(ia,n,iv,is,k) - ! =2.0 sum_g> g_k beta(g,iv,is) re[ (i)**(l+1) e^(ig.r_ia) c(g,n)] - ! - ! routine makes use of c*(g)=c(-g) (g> see routine ggen) - ! input : eigr, c - ! output: becdr - ! - - USE kinds, ONLY : DP - use ions_base, only : nsp, na, nat - use uspp, only : nhtol, beta !, nkb - use cvan, only : ish - use uspp_param, only : nh - use cell_base, only : tpiba - use mp, only : mp_sum - use mp_global, only : nproc_image, intra_image_comm - use reciprocal_vectors, only : gx, gstart - use twin_types !added:giovanni -! - implicit none - - integer, intent(in) :: ngw, nkb, n - complex(DP), intent(in) :: eigr(ngw,nat), c(ngw,n) - type(twin_tensor) :: becdr -! real(DP), intent(out) :: becdr(nkb,n,3) - logical :: lgam - ! - real(DP), allocatable :: gk(:) - complex(DP), allocatable :: wrk2_c(:,:) - ! - integer :: ig, is, iv, ia, k, l, inl, isa - real(DP) :: fact - complex(DP), parameter :: c_one=CMPLX(1.d0,0.d0), c_zero=CMPLX(0.d0,0.d0) - complex(DP), parameter :: ci=CMPLX(0.d0,1.d0) !added:giovanni - complex(DP) :: cl, arg_c !added:giovanni - ! - call start_clock( 'nlsm2' ) - - allocate( gk( ngw ) ) - - IF(lgam) THEN - becdr%rvec = 0.d0 - ELSE - becdr%cvec = c_zero - ENDIF -! - do k = 1, 3 - - do ig=1,ngw - gk(ig)=gx(k,ig)*tpiba - end do -! - isa = 0 - - do is=1,nsp - - allocate( wrk2_c( ngw, na( is ) ) ) - ! - IF(lgam) THEN - fact=2.d0 - ELSE - fact=1.d0 - ENDIF - ! - do iv=1,nh(is) - ! - ! order of states: s_1 p_x1 p_z1 p_y1 s_2 p_x2 p_z2 p_y2 - ! -!$omp parallel default(shared), private(l,ixr,ixi,signre,signim,ig,arg,ia) - l=nhtol(iv,is) - cl=(-ci)**(l+1) -! -!$omp do - do ia=1,na(is) - ! q = 0 component (with weight 1.0) - if (gstart == 2) then - wrk2_c(1,ia) = cl*CMPLX(gk(1)*beta(1,iv,is),0.d0)*eigr(1,ia+isa) - end if - ! q > 0 components (with weight 2.0) - do ig=gstart,ngw - arg_c = CMPLX(fact*gk(ig)*beta(ig,iv,is),0.d0) - wrk2_c(ig,ia) = cl*arg_c*eigr(ig,ia+isa) - end do - end do -!$omp end do -!$omp end parallel - inl=ish(is)+(iv-1)*na(is)+1 - IF(lgam) THEN - CALL DGEMM( 'T', 'N', na(is), n, 2*ngw, 1.0d0, wrk2_c, 2*ngw, c, 2*ngw, 0.0d0, becdr%rvec( inl, 1, k ), nkb ) - ELSE - CALL ZGEMM( 'C', 'N', na(is), n, ngw, c_one, wrk2_c, ngw, c, ngw, c_zero, becdr%cvec( inl, 1, k ), nkb ) - ENDIF - end do - - deallocate( wrk2_c ) - - isa = isa + na(is) - - end do - - IF( nproc_image > 1 ) THEN - IF(lgam) THEN - CALL mp_sum( becdr%rvec(:,:,k), intra_image_comm ) - ELSE - CALL mp_sum( becdr%cvec(:,:,k), intra_image_comm ) - ENDIF - END IF - end do - - deallocate( gk ) - - call stop_clock( 'nlsm2' ) -! - return - end subroutine nlsm2_repl -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- - real(8) function ennl_non_ortho( rhovan, bec, becdual )!added:giovanni lgam -!----------------------------------------------------------------------- - ! - ! calculation of nonlocal potential energy term and array rhovan - ! - use kinds, only : DP - use cvan, only : ish - use uspp_param, only : nhm, nh - use uspp, only : dvan - use electrons_base, only : n => nbsp, nspin, ispin, f - use ions_base, only : nsp, nat, na - use twin_types - use control_flags, only : gamma_only, do_wf_cmplx - ! - implicit none - ! - ! input - ! - type(twin_matrix) :: bec, becdual!( nkb, n )!modified:giovanni - real(DP) :: rhovan( nhm*(nhm+1)/2, nat, nspin ) - ! - ! local - ! - real(DP) :: sumt, sums(2), ennl_t - complex(DP) :: sumt_c, sums_c(2), ennl_tc - integer :: is, iv, jv, ijv, inl, jnl, isa, isat, ism, ia, iss, i - logical :: lgam!added:giovanni lgam - ! - lgam=gamma_only.and..not.do_wf_cmplx - ! - ennl_t = 0.d0 - ennl_tc = CMPLX(0.d0,0.d0) - ! - ! xlf does not like name of function used for OpenMP reduction - ! -!$omp parallel default(shared), & -!$omp private(is,iv,jv,ijv,isa,isat,ism,ia,inl,jnl,sums,i,iss,sumt), reduction(+:ennl_t) - if(.not.bec%iscmplx) then - do is = 1, nsp - do iv = 1, nh(is) - do jv = iv, nh(is) - ijv = (jv-1)*jv/2 + iv - isa = 0 - do ism = 1, is - 1 - isa = isa + na(ism) - end do -!$omp do - do ia = 1, na(is) - inl = ish(is)+(iv-1)*na(is)+ia - jnl = ish(is)+(jv-1)*na(is)+ia - isat = isa+ia - sums = 0.d0 - do i = 1, n - iss = ispin(i) - sums(iss) = sums(iss) + 0.5d0*f(i) * (becdual%rvec(inl,i) * bec%rvec(jnl,i) & - +becdual%rvec(jnl,i) * bec%rvec(inl,i)) - end do - sumt = 0.d0 - do iss = 1, nspin - rhovan( ijv, isat, iss ) = sums( iss ) - sumt = sumt + sums( iss ) - end do - if( iv .ne. jv ) sumt = 2.d0 * sumt - ennl_t = ennl_t + sumt * dvan( jv, iv, is) - end do -!$omp end do - end do - end do - end do - else - do is = 1, nsp - do iv = 1, nh(is) - do jv = iv, nh(is) - ijv = (jv-1)*jv/2 + iv - isa = 0 - do ism = 1, is - 1 - isa = isa + na(ism) - end do -!$omp do - do ia = 1, na(is) - inl = ish(is)+(iv-1)*na(is)+ia - jnl = ish(is)+(jv-1)*na(is)+ia - isat = isa+ia - sums_c = CMPLX(0.d0,0.d0) - do i = 1, n - iss = ispin(i) - sums_c(iss) = sums_c(iss) + CMPLX(0.5d0*f(i),0.d0) & - & * (bec%cvec(inl,i) * CONJG(becdual%cvec(jnl,i))+bec%cvec(jnl,i) * CONJG(becdual%cvec(inl,i))) - end do - sumt_c = CMPLX(0.d0,0.d0) - do iss = 1, nspin - rhovan( ijv, isat, iss ) = DBLE(sums_c( iss )) - sumt_c = sumt_c + sums_c( iss ) - end do - if( iv .ne. jv ) sumt_c = CMPLX(2.d0,0.d0) * sumt_c - ennl_tc = ennl_tc + sumt_c * CMPLX(dvan( jv, iv, is),0.d0) - end do -!$omp end do - end do - end do - end do - endif -!$omp end parallel - ! - if(.not.bec%iscmplx) then - ennl_non_ortho = ennl_t - else - ennl_non_ortho = DBLE(ennl_tc) - endif - ! - return - end function ennl_non_ortho -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- - real(8) function ennl( rhovan, bec )!added:giovanni lgam -!----------------------------------------------------------------------- - ! - ! calculation of nonlocal potential energy term and array rhovan - ! - use kinds, only : DP - use cvan, only : ish - use uspp_param, only : nhm, nh - use uspp, only : dvan - use electrons_base, only : n => nbsp, nspin, ispin, f - use ions_base, only : nsp, nat, na - use twin_types - use control_flags, only : gamma_only, do_wf_cmplx - ! - implicit none - ! - ! input - ! - type(twin_matrix) :: bec!( nkb, n )!modified:giovanni - real(DP) :: rhovan( nhm*(nhm+1)/2, nat, nspin ) - ! - ! local - ! - real(DP) :: sumt, sums(2), ennl_t - complex(DP) :: sumt_c, sums_c(2), ennl_tc - integer :: is, iv, jv, ijv, inl, jnl, isa, isat, ism, ia, iss, i - logical :: lgam!added:giovanni lgam - ! - lgam=gamma_only.and..not.do_wf_cmplx - ! - ennl_t = 0.d0 - ennl_tc = CMPLX(0.d0,0.d0) - ! - ! xlf does not like name of function used for OpenMP reduction - ! -!$omp parallel default(shared), & -!$omp private(is,iv,jv,ijv,isa,isat,ism,ia,inl,jnl,sums,i,iss,sumt), reduction(+:ennl_t) - if(.not.bec%iscmplx) then - do is = 1, nsp - do iv = 1, nh(is) - do jv = iv, nh(is) - ijv = (jv-1)*jv/2 + iv - isa = 0 - do ism = 1, is - 1 - isa = isa + na(ism) - end do -!$omp do - do ia = 1, na(is) - inl = ish(is)+(iv-1)*na(is)+ia - jnl = ish(is)+(jv-1)*na(is)+ia - isat = isa+ia - sums = 0.d0 - do i = 1, n - iss = ispin(i) - sums(iss) = sums(iss) + f(i) * bec%rvec(inl,i) * bec%rvec(jnl,i) - end do - sumt = 0.d0 - do iss = 1, nspin - rhovan( ijv, isat, iss ) = sums( iss ) - sumt = sumt + sums( iss ) - end do - if( iv .ne. jv ) sumt = 2.d0 * sumt - ennl_t = ennl_t + sumt * dvan( jv, iv, is) - end do -!$omp end do - end do - end do - end do - else ! if bec%iscmplx - do is = 1, nsp - do iv = 1, nh(is) - do jv = iv, nh(is) - ijv = (jv-1)*jv/2 + iv - isa = 0 - do ism = 1, is - 1 - isa = isa + na(ism) - end do -!$omp do - do ia = 1, na(is) - inl = ish(is)+(iv-1)*na(is)+ia - jnl = ish(is)+(jv-1)*na(is)+ia - isat = isa+ia - sums_c = CMPLX(0.d0,0.d0) - do i = 1, n - iss = ispin(i) - sums_c(iss) = sums_c(iss) + CMPLX(f(i),0.d0) & - * ((bec%cvec(inl,i)) * CONJG(bec%cvec(jnl,i))) - end do - sumt_c = CMPLX(0.d0,0.d0) - do iss = 1, nspin - rhovan( ijv, isat, iss ) = DBLE(sums_c( iss )) - sumt_c = sumt_c + sums_c( iss ) - end do - if( iv .ne. jv ) sumt_c = CMPLX(2.d0,0.d0) * sumt_c - ennl_tc = ennl_tc + sumt_c * CMPLX(dvan( jv, iv, is),0.d0) - end do -!$omp end do - end do - end do - end do - endif -!$omp end parallel - ! - if(.not.bec%iscmplx) then - ennl = ennl_t - else - ennl = DBLE(ennl_tc) - endif - ! - return - end function ennl -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- - real(8) function ennl_new( n, nspin, ispin, f, rhovan, bec )!added:giovanni lgam -!----------------------------------------------------------------------- - ! - ! calculation of nonlocal potential energy term and array rhovan - ! - use kinds, only : DP - use cvan, only : ish - use uspp_param, only : nhm, nh - use uspp, only : dvan - use ions_base, only : nsp, nat, na - use twin_types - use control_flags, only : gamma_only, do_wf_cmplx - ! - implicit none - ! - ! input - ! - integer, intent(in) :: n, nspin, ispin(n) - real(DP) :: f(n) - type(twin_matrix) :: bec!( nkb, n )!modified:giovanni - real(DP) :: rhovan( nhm*(nhm+1)/2, nat, nspin ) - ! - ! local - ! - real(DP) :: sumt, sums(2), ennl_t - complex(DP) :: sumt_c, sums_c(2), ennl_tc - integer :: is, iv, jv, ijv, inl, jnl, isa, isat, ism, ia, iss, i - logical :: lgam!added:giovanni lgam - ! - lgam=gamma_only.and..not.do_wf_cmplx - ! - ennl_t = 0.d0 - ennl_tc = CMPLX(0.d0,0.d0) - ! - ! xlf does not like name of function used for OpenMP reduction - ! -!$omp parallel default(shared), & -!$omp private(is,iv,jv,ijv,isa,isat,ism,ia,inl,jnl,sums,i,iss,sumt), reduction(+:ennl_t) - if(.not.bec%iscmplx) then - do is = 1, nsp - do iv = 1, nh(is) - do jv = iv, nh(is) - ijv = (jv-1)*jv/2 + iv - isa = 0 - do ism = 1, is - 1 - isa = isa + na(ism) - end do -!$omp do - do ia = 1, na(is) - inl = ish(is)+(iv-1)*na(is)+ia - jnl = ish(is)+(jv-1)*na(is)+ia - isat = isa+ia - sums = 0.d0 - do i = 1, n - iss = ispin(i) - sums(iss) = sums(iss) + f(i) * bec%rvec(inl,i) * bec%rvec(jnl,i) - end do - sumt = 0.d0 - do iss = 1, nspin - rhovan( ijv, isat, iss ) = sums( iss ) - sumt = sumt + sums( iss ) - end do - if( iv .ne. jv ) sumt = 2.d0 * sumt - ennl_t = ennl_t + sumt * dvan( jv, iv, is) - end do -!$omp end do - end do - end do - end do - else - do is = 1, nsp - do iv = 1, nh(is) - do jv = iv, nh(is) - ijv = (jv-1)*jv/2 + iv - isa = 0 - do ism = 1, is - 1 - isa = isa + na(ism) - end do -!$omp do - do ia = 1, na(is) - inl = ish(is)+(iv-1)*na(is)+ia - jnl = ish(is)+(jv-1)*na(is)+ia - isat = isa+ia - sums_c = CMPLX(0.d0,0.d0) - do i = 1, n - iss = ispin(i) - sums_c(iss) = sums_c(iss) + CMPLX(f(i),0.d0) & - * ((bec%cvec(inl,i)) * CONJG(bec%cvec(jnl,i))) - end do - sumt_c = CMPLX(0.d0,0.d0) - do iss = 1, nspin - rhovan( ijv, isat, iss ) = DBLE(sums_c( iss )) - sumt_c = sumt_c + sums_c( iss ) - end do - if( iv .ne. jv ) sumt_c = CMPLX(2.d0,0.d0) * sumt_c - ennl_tc = ennl_tc + sumt_c * CMPLX(dvan( jv, iv, is),0.d0) - end do -!$omp end do - end do - end do - end do - endif -!$omp end parallel - ! - if(.not.bec%iscmplx) then - ennl_new = ennl_t - else - ennl_new = DBLE(ennl_tc) - endif - ! - return - end function ennl_new -!----------------------------------------------------------------------- - - -!----------------------------------------------------------------------- - subroutine calrhovan_real( rhovan, bec, iwf ) -!----------------------------------------------------------------------- - ! - ! calculation of rhovan relative to state iwf - ! - use kinds, only : DP - use cvan, only : ish - use uspp_param, only : nhm, nh - use uspp, only : nkb - use electrons_base, only : n => nbsp, nspin, ispin, f - use ions_base, only : nsp, nat, na - ! - implicit none - ! - ! input - ! - real(DP) :: bec( nkb, n ) - real(DP) :: rhovan( nhm*(nhm+1)/2, nat, nspin ) - integer, intent(in) :: iwf - ! - ! local - ! - integer :: is, iv, jv, ijv, inl, jnl, isa, ism, ia, iss - ! - do is = 1, nsp - do iv = 1, nh(is) - do jv = iv, nh(is) - ijv = (jv-1)*jv/2 + iv - isa = 0 - do ism = 1, is - 1 - isa = isa + na(ism) - end do - do ia = 1, na(is) - inl = ish(is)+(iv-1)*na(is)+ia - jnl = ish(is)+(jv-1)*na(is)+ia - isa = isa+1 - iss = ispin(iwf) - rhovan( ijv, isa, iss ) = f(iwf) * bec(inl,iwf) * bec(jnl,iwf) - end do - end do - end do - end do - ! - return - end subroutine calrhovan_real -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine calrhovan_twin( rhovan, bec, iwf ) -!----------------------------------------------------------------------- - ! - ! calculation of rhovan relative to state iwf - ! - use kinds, only : DP - use cvan, only : ish - use uspp_param, only : nhm, nh - use electrons_base, only : nspin, ispin, f - use ions_base, only : nsp, nat, na - use twin_types - use cp_main_variables, only : becdual - use control_flags, only : non_ortho - ! - implicit none - ! - ! input - ! - type(twin_matrix) :: bec !( nkb, n ) - real(DP) :: rhovan( nhm*(nhm+1)/2, nat, nspin ) - integer, intent(in) :: iwf - ! - ! local - ! - integer :: is, iv, jv, ijv, inl, jnl, isa, ism, ia, iss - ! - if(.not.bec%iscmplx) then - do is = 1, nsp - do iv = 1, nh(is) - do jv = iv, nh(is) - ijv = (jv-1)*jv/2 + iv - isa = 0 - do ism = 1, is - 1 - isa = isa + na(ism) - end do - do ia = 1, na(is) - inl = ish(is)+(iv-1)*na(is)+ia - jnl = ish(is)+(jv-1)*na(is)+ia - isa = isa+1 - iss = ispin(iwf) - IF(non_ortho) THEN - rhovan( ijv, isa, iss ) = f(iwf) * becdual%rvec(inl,iwf) * bec%rvec(jnl,iwf) - ELSE - rhovan( ijv, isa, iss ) = f(iwf) * bec%rvec(inl,iwf) * bec%rvec(jnl,iwf) - ENDIF - end do - end do - end do - end do - else - do is = 1, nsp - do iv = 1, nh(is) - do jv = iv, nh(is) - ijv = (jv-1)*jv/2 + iv - isa = 0 - do ism = 1, is - 1 - isa = isa + na(ism) - end do - do ia = 1, na(is) - inl = ish(is)+(iv-1)*na(is)+ia - jnl = ish(is)+(jv-1)*na(is)+ia - isa = isa+1 - iss = ispin(iwf) - IF(non_ortho) THEN - rhovan( ijv, isa, iss ) = f(iwf) * DBLE(CONJG(becdual%cvec(inl,iwf)) * & - (bec%cvec(jnl,iwf))) - ELSE - rhovan( ijv, isa, iss ) = f(iwf) * DBLE(CONJG(bec%cvec(inl,iwf)) * & - (bec%cvec(jnl,iwf))) - ENDIF - end do - end do - end do - end do - endif - ! - return - end subroutine calrhovan_twin -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine calbec ( nspmn, nspmx, eigr, c, bec) -!----------------------------------------------------------------------- - - ! this routine calculates array bec - ! - ! < psi_n | beta_i,i > = c_n(0) beta_i,i(0) + - ! 2 sum_g> re(c_n*(g) (-i)**l beta_i,i(g) e^-ig.r_i) - ! - ! routine makes use of c(-g)=c*(g) and beta(-g)=beta*(g) - ! - - USE kinds, ONLY : DP - use ions_base, only : na, nat - use io_global, only : stdout - use cvan, only : ish - use electrons_base, only : n => nbsp - use gvecw, only : ngw - use control_flags, only : iprsta, gamma_only, do_wf_cmplx - use uspp_param, only : nh - use twin_types -! - implicit none - ! - integer, intent(in) :: nspmn, nspmx - type(twin_matrix) :: bec!( nkb, n ) - complex(DP), intent(in) :: c( ngw, n ), eigr( ngw,nat ) - - ! local variables - - integer :: is, ia, i , iv - logical :: lgam -! - lgam=gamma_only.and..not.do_wf_cmplx - - call start_clock( 'calbec' ) - call nlsm1_twin( n, nspmn, nspmx, eigr, c, bec, 1, lgam ) -! - if ( iprsta > 2 ) then - WRITE( stdout,*) - do is=1,nspmx - if(nspmx.gt.1) then - WRITE( stdout,'(33x,a,i4)') ' calbec: bec (is)',is - if(.not.bec%iscmplx) then - WRITE( stdout,'(8f9.4)') & - & ((bec%rvec(ish(is)+(iv-1)*na(is)+1,i),iv=1,nh(is)),i=1,n) - else - WRITE( stdout,'(8(2((f9.4),(f9.4))))') & - & ((bec%cvec(ish(is)+(iv-1)*na(is)+1,i),iv=1,nh(is)),i=1,n) - endif - else - do ia=1,na(is) - WRITE( stdout,'(33x,a,i4)') ' calbec: bec (ia)',ia - if(lgam) then - WRITE( stdout,'(8f9.4)') & - & ((bec%rvec(ish(is)+(iv-1)*na(is)+ia,i),iv=1,nh(is)),i=1,n) - else - WRITE( stdout,'(8(2((f9.4),(f9.4))))') & - & ((bec%cvec(ish(is)+(iv-1)*na(is)+ia,i),iv=1,nh(is)),i=1,n) - endif - end do - end if - end do - endif - call stop_clock( 'calbec' ) -! - return - end subroutine calbec -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -SUBROUTINE caldbec( ngw, nkb, n, nspmn, nspmx, eigr, c, dbec ) !warning:giovanni this still does not work with complex wavefunctions - !----------------------------------------------------------------------- - ! - ! this routine calculates array dbec, derivative of bec: - ! - ! < psi_n | beta_i,i > = c_n(0) beta_i,i(0) + - ! 2 sum_g> re(c_n*(g) (-i)**l beta_i,i(g) e^-ig.r_i) - ! - ! with respect to cell parameters h - ! - ! routine makes use of c(-g)=c*(g) and beta(-g)=beta*(g) - ! - USE kinds, ONLY : DP - use mp, only : mp_sum - use mp_global, only : nproc_image, intra_image_comm - use ions_base, only : na, nat - use cvan, only : ish - use cdvan, only : dbeta - use uspp, only : nhtol - use uspp_param, only : nh - use reciprocal_vectors, only : gstart - USE cp_main_variables, ONLY : descla, la_proc, nlam - USE descriptors, ONLY : nlar_ , nlac_ , ilar_ , ilac_ , nlax_ , la_myr_ , la_myc_ - use electrons_base, only : nspin, iupdwn, nupdwn - ! - implicit none - ! - integer, intent(in) :: ngw, nkb, n - integer, intent(in) :: nspmn, nspmx - complex(DP), intent(in) :: c(ngw,n) - real(DP), intent(in) :: eigr(2,ngw,nat) - real(DP), intent(out) :: dbec( nkb, 2*nlam, 3, 3 ) - ! - real(DP), allocatable :: wrk2(:,:,:), dwrk(:,:) - ! - integer :: ig, is, iv, ia, l, ixr, ixi, inl, i, j, ii, isa, nanh, iw, iss, nr, ir, istart, nss - real(DP) :: signre, signim, arg - ! - ! - ! - do j=1,3 - do i=1,3 - - isa = 0 - do is = 1, nspmn - 1 - isa = isa + na(is) - end do - - do is=nspmn,nspmx - allocate( wrk2( 2, ngw, na(is) ) ) - nanh = na(is)*nh(is) - allocate( dwrk( nanh, n ) ) - do iv=1,nh(is) - l=nhtol(iv,is) - if (l == 0) then - ixr = 1 - ixi = 2 - signre = 1.0d0 - signim = 1.0d0 - else if (l == 1) then - ixr = 2 - ixi = 1 - signre = 1.0d0 - signim = -1.0d0 - else if (l == 2) then - ixr = 1 - ixi = 2 - signre = -1.0d0 - signim = -1.0d0 - else if (l == 3) then - ixr = 2 - ixi = 1 - signre = -1.0d0 - signim = 1.0d0 - else - CALL errore(' caldbec ', ' l not implemented ', ABS( l ) ) - endif - ! - do ia=1,na(is) - if (gstart == 2) then - ! q = 0 component (with weight 1.0) - wrk2(1,1,ia)= signre*dbeta(1,iv,is,i,j)*eigr(ixr,1,ia+isa) - wrk2(2,1,ia)= signim*dbeta(1,iv,is,i,j)*eigr(ixi,1,ia+isa) - end if - ! q > 0 components (with weight 2.0) - do ig = gstart, ngw - arg = 2.0d0*dbeta(ig,iv,is,i,j) - wrk2(1,ig,ia) = signre*arg*eigr(ixr,ig,ia+isa) - wrk2(2,ig,ia) = signim*arg*eigr(ixi,ig,ia+isa) - end do - end do - inl=(iv-1)*na(is)+1 - CALL DGEMM( 'T', 'N', na(is), n, 2*ngw, 1.0d0, wrk2, 2*ngw, c, 2*ngw, 0.0d0, dwrk(inl,1), nanh ) - end do - deallocate( wrk2 ) - if( nproc_image > 1 ) then - call mp_sum( dwrk, intra_image_comm ) - end if - inl=ish(is)+1 - do iss=1,nspin - IF( la_proc ) THEN - nr = descla( nlar_ , iss ) - ir = descla( ilar_ , iss ) - istart = iupdwn( iss ) - nss = nupdwn( iss ) - do ii = 1, nr - do iw = 1, nanh - dbec( iw + inl - 1, ii + (iss-1)*nspin, i, j ) = dwrk( iw, ii + ir - 1 + istart - 1 ) - end do - end do - END IF - end do - deallocate( dwrk ) - isa = isa + na(is) - end do - end do - end do - - ! - return -end subroutine caldbec -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -subroutine dennl( bec, dbec, drhovan, denl ) - !----------------------------------------------------------------------- - ! - ! compute the contribution of the non local part of the - ! pseudopotentials to the derivative of E with respect to h - ! - USE kinds, ONLY : DP - use cvan, only : ish - use uspp_param, only : nh, nhm - use uspp, only : nkb, dvan - use ions_base, only : nsp, na, nat - use mp, only : mp_sum - use mp_global, only : intra_image_comm - USE cp_main_variables, ONLY : descla, la_proc, nlam - USE descriptors, ONLY : nlar_ , nlac_ , ilar_ , ilac_ , nlax_ , la_myr_ , la_myc_ - use electrons_base, only : n => nbsp, f, nspin, iupdwn, nupdwn - - implicit none - - real(DP), intent(in) :: dbec( nkb, 2*nlam, 3, 3 ) - real(DP), intent(in) :: bec( nkb, n ) - real(DP), intent(out) :: drhovan( nhm*(nhm+1)/2, nat, nspin, 3, 3 ) - real(DP), intent(out) :: denl( 3, 3 ) - - real(DP) :: dsum(3,3),dsums(2,3,3) - integer :: is, iv, jv, ijv, inl, jnl, isa, ism, ia, iss, i,j,k - integer :: istart, nss, ii, ir, nr - ! - denl=0.d0 - drhovan=0.0d0 - - IF( la_proc ) THEN - - - do is=1,nsp - do iv=1,nh(is) - do jv=iv,nh(is) - ijv = (jv-1)*jv/2 + iv - isa=0 - do ism=1,is-1 - isa=isa+na(ism) - end do - do ia=1,na(is) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - isa=isa+1 - dsums=0.d0 - do iss=1,nspin - IF( descla( la_myr_ , iss ) == descla( la_myc_ , iss ) ) THEN - nr = descla( nlar_ , iss ) - ir = descla( ilar_ , iss ) - istart = iupdwn( iss ) - nss = nupdwn( iss ) - do i=1,nr - ii = i+istart-1+ir-1 - do k=1,3 - do j=1,3 - dsums(iss,k,j)=dsums(iss,k,j)+f(ii)* & - & (dbec(inl,i+(iss-1)*nlam,k,j)*bec(jnl,ii) & - & + bec(inl,ii)*dbec(jnl,i+(iss-1)*nlam,k,j)) - enddo - enddo - end do - END IF - end do - ! - do iss=1,nspin - IF( descla( la_myr_ , iss ) == descla( la_myc_ , iss ) ) THEN - dsum=0.d0 - do k=1,3 - do j=1,3 - drhovan(ijv,isa,iss,j,k)=dsums(iss,j,k) - dsum(j,k)=dsum(j,k)+dsums(iss,j,k) - enddo - enddo - if(iv.ne.jv) dsum=2.d0*dsum - denl = denl + dsum * dvan(jv,iv,is) - END IF - end do - end do - end do - end do - end do - - END IF - - CALL mp_sum( denl, intra_image_comm ) - do k=1,3 - do j=1,3 - CALL mp_sum( drhovan(:,:,:,j,k), intra_image_comm ) - end do - end do - -! WRITE(6,*) 'DEBUG enl (CP) = ' -! detmp = denl -! detmp = MATMUL( detmp(:,:), TRANSPOSE( h ) ) -! WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3) -5555 format(1x,f12.5,1x,f12.5,1x,f12.5/ & - & 1x,f12.5,1x,f12.5,1x,f12.5/ & - & 1x,f12.5,1x,f12.5,1x,f12.5//) - - ! - return -end subroutine dennl -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -subroutine nlfq( c, eigr, bec, becdr, fion, lgam2) - !----------------------------------------------------------------------- - ! - ! contribution to fion due to nonlocal part - ! - USE kinds, ONLY : DP - use uspp, only : nkb, dvan, deeq - use uspp_param, only : nhm, nh - use cvan, only : ish - use ions_base, only : nat, nsp, na - use electrons_base, only : n => nbsp, f, nspin, iupdwn, nupdwn - use gvecw, only : ngw - use constants, only : pi, fpi - use mp_global, only : intra_image_comm - use mp, only : mp_sum - USE cp_main_variables, ONLY: nlax, descla, la_proc - USE descriptors, ONLY: nlar_ , nlac_ , ilar_ , ilac_ , lambda_node_ , & - la_myr_ , la_myc_ - USE twin_types !added:giovanni - ! - implicit none - ! - type(twin_matrix) :: bec!(nkb,n) !modified:giovanni - complex(DP) :: c(ngw, n) !modified:giovanni - type(twin_tensor) :: becdr!( nkb, nspin*nlax, 3 ) !modified:giovanni - complex(DP), intent(in) :: eigr( ngw, nat ) - real(DP), intent(out) :: fion( 3, nat ) - logical, intent(IN) :: lgam2 - ! - integer :: k, is, ia, isa, iss, inl, iv, jv, i, ir, nr, nss, istart, ioff - real(DP) :: temp - ! - real(DP), allocatable :: tmpbec(:,:), tmpdr(:,:) - complex(DP), allocatable :: tmpbec_c(:,:), tmpdr_c(:,:) - real(DP), allocatable :: fion_loc(:,:) - logical :: lgam !added:giovanni:debug - character(len=5) :: subname = "nlfq" -#ifdef __OPENMP - INTEGER :: mytid, ntids, omp_get_thread_num, omp_get_num_threads -#endif - ! - call start_clock( 'nlfq' ) - ! - lgam=lgam2.or..not.becdr%iscmplx !added:giovanni - ! - IF(becdr%iscmplx.neqv.bec%iscmplx) THEN !added:giovanni:debug - call errore(subname, "incompatible twin types", 1) - stop - ENDIF - ! - ! nlsm2 fills becdr - ! - call nlsm2( ngw, nkb, n, nspin, eigr, c, becdr, lgam2 ) - ! - allocate ( fion_loc( 3, nat ) ) - ! - fion_loc = 0.0d0 - ! - DO k = 1, 3 - -!$omp parallel default(shared), & -!$omp private(tmpbec,tmpdr,isa,is,ia,iss,nss,istart,ir,nr,ioff,iv,jv,inl,temp,i,mytid,ntids) -#ifdef __OPENMP - mytid = omp_get_thread_num() ! take the thread ID - ntids = omp_get_num_threads() ! take the number of threads -#endif - - IF(lgam) THEN - allocate ( tmpbec( nhm, nlax ), tmpdr( nhm, nlax ) ) - ELSE - allocate ( tmpbec_c( nhm, nlax ), tmpdr_c( nhm, nlax ) ) - ENDIF - - isa = 0 - ! - DO is=1,nsp - DO ia=1,na(is) - - isa=isa+1 - -#ifdef __OPENMP - ! distribute atoms round robin to threads - ! - IF( MOD( isa, ntids ) /= mytid ) CYCLE -#endif - DO iss = 1, nspin - - nss = nupdwn( iss ) - istart = iupdwn( iss ) - - IF( la_proc .AND. & - ( descla( la_myr_ , iss ) == descla( la_myc_ , iss ) ) ) THEN - - ! only processors on the diagonal of the square proc grid enter here. - ! This is to distribute the load among different multi-core nodes, - ! and maximize the memory bandwith per core. - IF(lgam) THEN - tmpbec = 0.d0 - tmpdr = 0.d0 - ELSE - tmpbec_c = CMPLX(0.d0, 0.d0) - tmpdr_c = CMPLX(0.d0, 0.d0) - ENDIF - - ir = descla( ilar_ , iss ) - nr = descla( nlar_ , iss ) - - ioff = istart-1+ir-1 - - IF(lgam) THEN - do iv=1,nh(is) - do jv=1,nh(is) - inl=ish(is)+(jv-1)*na(is)+ia - temp=dvan(iv,jv,is)+deeq(jv,iv,isa,iss) - do i=1,nr - tmpbec(iv,i)=tmpbec(iv,i)+temp*bec%rvec(inl,i+ioff) - end do - end do - end do - ELSE - do iv=1,nh(is) - do jv=1,nh(is) - inl=ish(is)+(jv-1)*na(is)+ia - temp=dvan(iv,jv,is)+deeq(jv,iv,isa,iss) - do i=1,nr - tmpbec_c(iv,i)=tmpbec_c(iv,i)+temp*bec%cvec(inl,i+ioff) - end do - end do - end do - ENDIF - - IF(lgam) THEN - do iv=1,nh(is) - inl=ish(is)+(iv-1)*na(is)+ia - do i=1,nr - tmpdr(iv,i)=f(i+ioff)*becdr%rvec( inl, i+(iss-1)*nlax, k ) - end do - end do - ELSE - do iv=1,nh(is) - inl=ish(is)+(iv-1)*na(is)+ia - do i=1,nr - tmpdr_c(iv,i)=f(i+ioff)*becdr%cvec( inl, i+(iss-1)*nlax, k ) - end do - end do - ENDIF - - IF(lgam) THEN - do i=1,nr - do iv=1,nh(is) - tmpdr(iv,i)=tmpdr(iv,i)*tmpbec(iv,i) - end do - end do - ELSE - do i=1,nr - do iv=1,nh(is) - tmpdr_c(iv,i)=tmpdr_c(iv,i)*CONJG(tmpbec_c(iv,i)) - end do - end do - ENDIF - - IF(lgam) THEN - fion_loc(k,isa) = fion_loc(k,isa)-2.d0*SUM(tmpdr) - ELSE - fion_loc(k,isa) = fion_loc(k,isa)-2.d0*DBLE(SUM(tmpdr_c)) - ENDIF - - END IF - END DO - END DO - END DO - - IF(lgam) THEN - deallocate (tmpbec, tmpdr) - ELSE - deallocate (tmpbec_c, tmpdr_c) - ENDIF -!$omp end parallel - END DO - ! - CALL mp_sum( fion_loc, intra_image_comm ) - ! - fion = fion + fion_loc - ! - ! end of x/y/z loop - ! - deallocate ( fion_loc ) - ! - call stop_clock( 'nlfq' ) - ! - return -end subroutine nlfq - diff --git a/quantum_espresso/kcp/CPV/nlcc.f90 b/quantum_espresso/kcp/CPV/nlcc.f90 deleted file mode 100644 index f195a84a2..000000000 --- a/quantum_espresso/kcp/CPV/nlcc.f90 +++ /dev/null @@ -1,578 +0,0 @@ -! -! Copyright (C) 2002-2007 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - - -!=----------------------------------------------------------------------------=! - subroutine core_charge_ftr( tpre ) -!=----------------------------------------------------------------------------=! - ! - ! Compute the fourier trasform of the core charge, from the radial - ! mesh to the reciprocal space - ! - use kinds, ONLY : DP - use control_flags, ONLY : program_name - use ions_base, ONLY : nsp - use atom, ONLY : rgrid - use uspp_param, ONLY : upf - use gvecb, ONLY : ngb, gb - use small_box, ONLY : omegab, tpibab - use pseudo_base, ONLY : compute_rhocg - use cp_interfaces, ONLY : build_cctab, chkpstab - use pseudopotential, ONLY : tpstab, rhoc1_sp, rhocp_sp - use cell_base, ONLY : omega, tpiba2, tpiba - USE splines, ONLY : spline - use reciprocal_vectors, ONLY : ngm, g, gstart - USE core, ONLY : rhocb, rhocg, drhocg, nlcc_any - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(IN) :: tpre - ! - INTEGER :: is, ig - REAL(DP) :: xg, cost1 - ! - ! - IF( .NOT. nlcc_any ) RETURN - ! - IF( .NOT. ALLOCATED( rgrid ) ) & - CALL errore( ' core_charge_ftr ', ' rgrid not allocated ', 1 ) - IF( .NOT. ALLOCATED( upf ) ) & - CALL errore( ' core_charge_ftr ', ' upf not allocated ', 1 ) - ! - IF( tpstab ) THEN - ! - CALL build_cctab( ) - ! - END IF - ! - do is = 1, nsp - ! - if( upf(is)%nlcc ) then - ! - IF( program_name == 'CP90' ) THEN - ! - CALL compute_rhocg( rhocb(:,is), rhocb(:,is), rgrid(is)%r, & - rgrid(is)%rab, upf(is)%rho_atc(:), gb, omegab, tpibab**2, & - rgrid(is)%mesh, ngb, 0 ) - ! - END IF - ! - IF( ( program_name == 'FPMD' ) .OR. tpre ) THEN - ! - IF( tpstab ) THEN - ! - cost1 = 1.0d0/omega - ! - IF( gstart == 2 ) THEN - rhocg (1,is) = rhoc1_sp(is)%y( 1 ) * cost1 - drhocg(1,is) = 0.0d0 - END IF - DO ig = gstart, SIZE( rhocg, 1 ) - xg = SQRT( g(ig) ) * tpiba - rhocg (ig,is) = spline( rhoc1_sp(is), xg ) * cost1 - drhocg(ig,is) = spline( rhocp_sp(is), xg ) * cost1 - END DO - ! - ELSE - - CALL compute_rhocg( rhocg(:,is), drhocg(:,is), rgrid(is)%r, & - rgrid(is)%rab, upf(is)%rho_atc(:), g, & - omega, tpiba2, rgrid(is)%mesh, ngm, 1 ) - - END IF - ! - END IF - ! - endif - ! - end do - - return - end subroutine core_charge_ftr - - -!=----------------------------------------------------------------------------=! - subroutine add_core_charge_x( rhoetg, rhoetr, sfac, rhoc, nsp) -!=----------------------------------------------------------------------------=! - USE kinds, ONLY: DP - USE fft_base, ONLY: dfftp - use electrons_base, only: nspin - use gvecp, only: ngm - use uspp_param, only: upf - USE cp_interfaces, ONLY: invfft - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm - USE cell_base, ONLY: omega - USE mp, ONLY: mp_sum - USE control_flags, ONLY: iprsta - - implicit none - - integer :: nsp - COMPLEX(DP) :: rhoetg(:) - REAL(DP) :: rhoetr(:) - REAL(DP) :: rhoc(:,:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - - COMPLEX(DP), ALLOCATABLE :: vtemp(:), psi(:) - REAL(DP) :: fac - REAL(DP) :: rsum - integer :: is, ig - - ALLOCATE( vtemp( ngm ), psi( dfftp%nnr ) ) - - vtemp = CMPLX( 0.0d0, 0.0d0 ) - - fac = 1.0d0 / DBLE( nspin ) - DO is = 1, nsp - if( upf(is)%nlcc ) then - do ig = 1, ngm - vtemp(ig) = vtemp(ig) + fac * sfac( ig, is ) * CMPLX(rhoc(ig,is),0.0d0) - end do - endif - end do - - rhoetg( 1:ngm ) = rhoetg( 1:ngm ) + vtemp( 1:ngm ) - - CALL rho2psi( 'Dense', psi, dfftp%nnr, vtemp, ngm ) - CALL invfft( 'Dense', psi, dfftp ) - - IF( SIZE( rhoetr ) /= SIZE( psi ) ) & - CALL errore( " add_core_charge ", " inconsistent sizes ", 1 ) - - IF( iprsta > 2 ) THEN - rsum = DBLE( SUM( psi ) ) * omega / DBLE( dfftp%nr1 * dfftp%nr2 * dfftp%nr3 ) - CALL mp_sum( rsum, intra_image_comm ) - WRITE( stdout, 10 ) rsum -10 FORMAT( 3X, 'Core Charge = ', D14.6 ) - END IF - - - rhoetr(:) = rhoetr(:) + DBLE( psi ) - - - DEALLOCATE( vtemp, psi ) - - RETURN - end subroutine add_core_charge_x - - - -!=----------------------------------------------------------------------------=! - subroutine core_charge_forces_x & - ( fion, vxc, rhoc1, tnlcc, atoms, ht, ei1, ei2, ei3 ) -!=----------------------------------------------------------------------------=! - - ! This subroutine computes the non local core correction - ! contribution to the atomic forces - - USE kinds, ONLY: DP - USE cell_base, ONLY: tpiba, boxdimensions - USE atoms_type_module, ONLY: atoms_type - USE grid_dimensions, ONLY: nr1, nr2, nr3 - USE reciprocal_vectors, ONLY: mill_l, gstart, gx, ngm - USE ions_base, ONLY: nat - - IMPLICIT NONE - - TYPE (atoms_type), INTENT(IN) :: atoms ! atomic positions - TYPE (boxdimensions), INTENT(IN) :: ht ! cell parameters - COMPLEX(DP) :: ei1( -nr1:nr1, nat) ! - COMPLEX(DP) :: ei2( -nr2:nr2, nat) ! - COMPLEX(DP) :: ei3( -nr3:nr3, nat) ! - LOGICAL :: tnlcc(:) ! NLCC flags - REAL(DP) :: fion(:,:) ! ionic forces - REAL(DP) :: rhoc1(:,:) ! derivative of the core charge - COMPLEX(DP) :: vxc(:,:) ! XC potential - - INTEGER :: ig, ig1, ig2, ig3, isa, ia, is, ispin, nspin - COMPLEX(DP) :: gxc, gyc, gzc, tx, ty, tz, teigr, cxc - COMPLEX(DP), ALLOCATABLE :: ftmp(:,:) - REAL(DP) :: cost - - IF( ANY( tnlcc ) ) then - - nspin = SIZE( vxc, 2) - ALLOCATE( ftmp( 3, atoms%nat ) ) - ftmp = CMPLX( 0.0d0, 0.0d0 ) - - DO ig = gstart, ngm - ig1 = mill_l(1,ig) - ig2 = mill_l(2,ig) - ig3 = mill_l(3,ig) - GXC = CMPLX(0.D0, gx(1,ig)) - GYC = CMPLX(0.D0, gx(2,ig)) - GZC = CMPLX(0.D0, gx(3,ig)) - isa = 1 - DO is = 1, atoms%nsp - IF ( tnlcc(is) ) THEN - CXC = 0.0_DP - DO ispin = 1, nspin - CXC = CXC + rhoc1( ig, is ) * CONJG( vxc( ig, ispin ) ) - END DO - TX = CXC * GXC / DBLE( nspin ) - TY = CXC * GYC / DBLE( nspin ) - TZ = CXC * GZC / DBLE( nspin ) - DO IA = 1, atoms%na(is) - teigr = ei1( ig1, isa ) * ei2( ig2, isa ) * ei3( ig3, isa ) - ftmp( 1, isa ) = ftmp( 1, isa ) + TEIGR * TX - ftmp( 2, isa ) = ftmp( 2, isa ) + TEIGR * TY - ftmp( 3, isa ) = ftmp( 3, isa ) + TEIGR * TZ - isa = isa + 1 - END DO - ELSE - isa = isa + atoms%na(is) - END IF - END DO - END DO - - ! ... each processor add its own contribution to the array FION - cost = 2.D0 * ht%deth * tpiba - - DO isa = 1, atoms%nat - FION(1,ISA) = FION(1,ISA) + DBLE(ftmp(1,ISA)) * cost - FION(2,ISA) = FION(2,ISA) + DBLE(ftmp(2,ISA)) * cost - FION(3,ISA) = FION(3,ISA) + DBLE(ftmp(3,ISA)) * cost - END DO - - DEALLOCATE( ftmp ) - - END IF - - RETURN - END SUBROUTINE core_charge_forces_x -!=----------------------------------------------------------------------------=! - -!----------------------------------------------------------------------- - subroutine add_cc_rspace( rhoc, rhor ) -!----------------------------------------------------------------------- -! -! add core correction to the charge density for exch-corr calculation -! this subroutine performs the addition in r-space only -! - USE kinds, ONLY: DP - use electrons_base, only: nspin - use control_flags, only: iprsta - use io_global, only: stdout - use mp_global, only: intra_image_comm - use cell_base, only: omega - USE mp, ONLY: mp_sum - - ! this isn't really needed, but if I remove it, ifc 7.1 - ! gives an "internal compiler error" - use grid_dimensions, only: nr1, nr2, nr3, nnrx - USE cp_interfaces, ONLY: fwfft -! - implicit none - ! - REAL(DP), INTENT(IN) :: rhoc( nnrx ) - REAL(DP), INTENT(INOUT):: rhor( nnrx, nspin ) - ! -! - integer :: iss, isup, isdw - REAL(DP) :: rsum - ! - IF( iprsta > 2 ) THEN - rsum = SUM( rhoc ) * omega / DBLE(nr1*nr2*nr3) - CALL mp_sum( rsum, intra_image_comm ) - WRITE( stdout, 10 ) rsum -10 FORMAT( 3X, 'Core Charge = ', D14.6 ) - END IF - ! - ! In r-space: - ! - if ( nspin .eq. 1 ) then - iss=1 - call DAXPY(nnrx,1.d0,rhoc,1,rhor(1,iss),1) - else - isup=1 - isdw=2 - call DAXPY(nnrx,0.5d0,rhoc,1,rhor(1,isup),1) - call DAXPY(nnrx,0.5d0,rhoc,1,rhor(1,isdw),1) - end if -! - return - end subroutine add_cc_rspace - - - - -!----------------------------------------------------------------------- - subroutine add_cc( rhoc, rhog, rhor ) -!----------------------------------------------------------------------- -! -! add core correction to the charge density for exch-corr calculation -! - USE kinds, ONLY: DP - use electrons_base, only: nspin - use control_flags, only: iprsta - use io_global, only: stdout - use mp_global, only: intra_image_comm - use cell_base, only: omega - use recvecs_indexes, only: np - USE mp, ONLY: mp_sum - - ! this isn't really needed, but if I remove it, ifc 7.1 - ! gives an "internal compiler error" - use gvecp, only: ngm - use grid_dimensions, only: nr1, nr2, nr3, nnrx - USE cp_interfaces, ONLY: fwfft - USE fft_base, ONLY: dfftp -! - implicit none - ! - REAL(DP), INTENT(IN) :: rhoc( nnrx ) - REAL(DP), INTENT(INOUT):: rhor( nnrx, nspin ) - COMPLEX(DP), INTENT(INOUT):: rhog( ngm, nspin ) - ! - COMPLEX(DP), ALLOCATABLE :: wrk1( : ) -! - integer :: ig, iss, isup, isdw - REAL(DP) :: rsum - ! - IF( iprsta > 2 ) THEN - rsum = SUM( rhoc ) * omega / DBLE(nr1*nr2*nr3) - CALL mp_sum( rsum, intra_image_comm ) - WRITE( stdout, 10 ) rsum -10 FORMAT( 3X, 'Core Charge = ', D14.6 ) - END IF - ! - ! In r-space: - ! - if ( nspin .eq. 1 ) then - iss=1 - call DAXPY(nnrx,1.d0,rhoc,1,rhor(1,iss),1) - else - isup=1 - isdw=2 - call DAXPY(nnrx,0.5d0,rhoc,1,rhor(1,isup),1) - call DAXPY(nnrx,0.5d0,rhoc,1,rhor(1,isdw),1) - end if - ! - ! rhoc(r) -> rhoc(g) (wrk1 is used as work space) - ! - allocate( wrk1( nnrx ) ) - - wrk1(:) = rhoc(:) - - call fwfft('Dense',wrk1, dfftp ) - ! - ! In g-space: - ! - if (nspin.eq.1) then - do ig=1,ngm - rhog(ig,iss)=rhog(ig,iss)+wrk1(np(ig)) - end do - else - do ig=1,ngm - rhog(ig,isup)=rhog(ig,isup)+0.5d0*wrk1(np(ig)) - rhog(ig,isdw)=rhog(ig,isdw)+0.5d0*wrk1(np(ig)) - end do - end if - - deallocate( wrk1 ) -! - return - end subroutine add_cc - - -! -!----------------------------------------------------------------------- - subroutine force_cc(irb,eigrb,vxc,fion1) -!----------------------------------------------------------------------- -! -! core correction force: f = \int V_xc(r) (d rhoc(r)/d R_i) dr -! same logic as in newd - uses box grid. For parallel execution: -! the sum over node contributions is done in the calling routine -! - USE kinds, ONLY: DP - use electrons_base, only: nspin - use gvecb, only: gxb, ngb, npb, nmb - use grid_dimensions, only: nr1, nr2, nr3, nnr => nnrx - use cell_base, only: omega - use ions_base, only: nsp, na, nat - use small_box, only: tpibab - use uspp_param, only: upf - use core, only: rhocb - use cp_interfaces, only: invfft - use fft_base, only: dfftb - use smallbox_grid_dimensions, only: nnrb => nnrbx - - implicit none - -! input - integer, intent(in) :: irb(3,nat) - complex(8), intent(in):: eigrb(ngb,nat) - real(8), intent(in) :: vxc(nnr,nspin) -! output - real(8), intent(inout):: fion1(3,nat) -! local - integer iss, ix, ig, is, ia, nfft, isa - real(8) fcc(3,nat), fac, boxdotgrid - complex(8) ci, facg - complex(8), allocatable :: qv(:) - external boxdotgrid -! - call start_clock( 'forcecc' ) - ci = (0.d0,1.d0) - fac = omega/DBLE(nr1*nr2*nr3*nspin) - fcc = 0.d0 - - allocate( qv( nnrb ) ) - - isa = 0 - - do is=1,nsp - if( .not. upf(is)%nlcc ) go to 10 -#ifdef __PARA - do ia=1,na(is) - nfft=1 - if ( dfftb%np3( ia + isa ) <= 0 ) go to 15 -#else - do ia=1,na(is),2 -! -! two fft's on two atoms at the same time (when possible) -! - nfft=2 - if(ia.eq.na(is)) nfft=1 -#endif - do ix=1,3 - qv(:) = (0.d0, 0.d0) - if (nfft.eq.2) then - do ig=1,ngb - facg = tpibab*CMPLX(0.d0,gxb(ix,ig))*rhocb(ig,is) - qv(npb(ig)) = eigrb(ig,ia+isa )*facg & - & + ci * eigrb(ig,ia+isa+1)*facg - qv(nmb(ig)) = CONJG(eigrb(ig,ia+isa )*facg) & - & + ci * CONJG(eigrb(ig,ia+isa+1)*facg) - end do - else - do ig=1,ngb - facg = tpibab*CMPLX(0.d0,gxb(ix,ig))*rhocb(ig,is) - qv(npb(ig)) = eigrb(ig,ia+isa)*facg - qv(nmb(ig)) = CONJG(eigrb(ig,ia+isa)*facg) - end do - end if -! - call invfft('Box',qv,dfftb,ia+isa) - ! - ! note that a factor 1/2 is hidden in fac if nspin=2 - ! - do iss=1,nspin - fcc(ix,ia+isa) = fcc(ix,ia+isa) + fac * & - & boxdotgrid(irb(1,ia +isa),1,qv,vxc(1,iss)) - if (nfft.eq.2) & - & fcc(ix,ia+1+isa) = fcc(ix,ia+1+isa) + fac * & - & boxdotgrid(irb(1,ia+1+isa),2,qv,vxc(1,iss)) - end do - end do -15 continue - end do -10 continue - isa = isa + na(is) - end do -! - do ia = 1, nat - fion1(:,ia) = fion1(:,ia) + fcc(:,ia) - end do - - deallocate( qv ) -! - call stop_clock( 'forcecc' ) - return - end subroutine force_cc - - -! -!----------------------------------------------------------------------- - subroutine set_cc( irb, eigrb, rhoc ) -!----------------------------------------------------------------------- -! -! Calculate core charge contribution in real space, rhoc(r) -! Same logic as for rhov: use box grid for core charges -! - use ions_base, only: nsp, na, nat - use uspp_param, only: upf - use grid_dimensions, only: nnr => nnrx - use gvecb, only: ngb, npb, nmb - use core, only: rhocb - use cp_interfaces, only: invfft - use fft_base, only: dfftb - use smallbox_grid_dimensions, only: nnrb => nnrbx - - implicit none -! input - integer, intent(in) :: irb(3,nat) - complex(8), intent(in):: eigrb(ngb,nat) -! output - real(8), intent(out) :: rhoc(nnr) -! local - integer nfft, ig, is, ia, isa - complex(8) ci - complex(8), allocatable :: wrk1(:) - complex(8), allocatable :: qv(:) -! - call start_clock( 'set_cc' ) - ci=(0.d0,1.d0) -! - allocate( qv ( nnrb ) ) - allocate( wrk1 ( nnr ) ) - wrk1 (:) = (0.d0, 0.d0) -! - isa = 0 - do is=1,nsp - if (.not.upf(is)%nlcc) go to 10 -#ifdef __PARA - do ia=1,na(is) - nfft=1 - if ( dfftb%np3( ia + isa ) <= 0 ) go to 15 -#else - do ia=1,na(is),2 - nfft=2 - if( ia.eq.na(is) ) nfft=1 -! -! two ffts at the same time, on two atoms (if possible: nfft=2) -! -#endif - qv(:) = (0.d0, 0.d0) - if(nfft.eq.2)then - do ig=1,ngb - qv(npb(ig))= eigrb(ig,ia +isa)*rhocb(ig,is) & - & + ci*eigrb(ig,ia+1+isa)*rhocb(ig,is) - qv(nmb(ig))= CONJG(eigrb(ig,ia +isa)*rhocb(ig,is)) & - & + ci*CONJG(eigrb(ig,ia+1+isa)*rhocb(ig,is)) - end do - else - do ig=1,ngb - qv(npb(ig)) = eigrb(ig,ia+isa)*rhocb(ig,is) - qv(nmb(ig)) = CONJG(eigrb(ig,ia+isa)*rhocb(ig,is)) - end do - endif -! - call invfft('Box',qv,dfftb,isa+ia) -! - call box2grid(irb(1,ia+isa),1,qv,wrk1) - if (nfft.eq.2) call box2grid(irb(1,ia+1+isa),2,qv,wrk1) -! -15 continue - end do -10 continue - isa = isa + na(is) - end do -! - call DCOPY(nnr,wrk1,2,rhoc,1) - - deallocate( qv ) - deallocate( wrk1 ) -! - call stop_clock( 'set_cc' ) -! - return - end subroutine set_cc - diff --git a/quantum_espresso/kcp/CPV/odd_alpha.f90 b/quantum_espresso/kcp/CPV/odd_alpha.f90 deleted file mode 100644 index 5d6c74033..000000000 --- a/quantum_espresso/kcp/CPV/odd_alpha.f90 +++ /dev/null @@ -1,158 +0,0 @@ -!-------------------------------------------------------------- -subroutine odd_alpha_routine( nbndx, is_empty) -!-------------------------------------------------------------- - ! - ! alpha_v = (\sum (I,l) {alpha0_I }) / (\sum (I,l) {}), - ! where chi(I,l) is orthornormal pseudo atomic wfc - ! input: evc_wfc - ! out: odd_alpha, valpsi >>> pass to sharing variable - ! full valpsi will be complete in nksiclib routine - ! - ! - use kinds, ONLY: DP - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_bcast, mp_sum - USE io_global, ONLY: ionode, ionode_id - use orthogonalize_base, ONLY: calphi - USE nksic, ONLY: odd_alpha, valpsi, & - call_index_emp, call_index, & - alpha0_ref_emp, alpha0_ref - USE twin_types - ! - implicit none - ! -#ifdef __PARA - include 'mpif.h' -#endif - ! - integer, intent(in) :: nbndx - logical :: is_empty - ! - ! local variables - ! - integer :: n_ref_nkscal0 - integer, allocatable :: index_ref_nkscal0(:) - real(DP), allocatable :: ref_nkscal0(:) - real(DP), allocatable :: spead_ref_nkscal0(:) - ! - integer :: i, iv - ! - ! this part is computed only one at starting calculation - ! - ! - if (is_empty) then - ! - call_index_emp = call_index_emp + 1 - ! - else - ! - call_index = call_index + 1 - ! - endif - ! - if ( ((.not. is_empty).and.(call_index .eq. 1)) .or. (is_empty .and. (call_index_emp .eq. 1)) ) then - ! - if (is_empty .and. (call_index_emp .eq. 1) ) then - ! - ! alpha0_ref_emp first is allocated here, then will be deallocated - ! in the end of cp run in deallocate_nksic module.f90 - ! - allocate (alpha0_ref_emp(nbndx)) - alpha0_ref_emp = 0.d0 - ! - endif - ! - if ((.not. is_empty) .and. (call_index .eq. 1)) then - ! - ! alpha0_ref_emp first is allocated here, then will be deallocated - ! in the end of cp run in deallocate_nksic module.f90 - ! - allocate (alpha0_ref(nbndx)) - alpha0_ref = 0.d0 - ! - endif - ! - ! read from file ref. alpha - ! - if (ionode) then - ! - if (is_empty .and. (call_index_emp .eq. 1) ) then - ! - open (unit = 99, file = 'file_alpharef_empty.txt', form = 'formatted', status = 'old' ) - ! - read(99, *), n_ref_nkscal0 - ! - endif - ! - if ((.not. is_empty) .and. (call_index .eq. 1)) then - ! - open (unit = 99, file = 'file_alpharef.txt', form = 'formatted', status = 'old' ) - ! - read(99, *), n_ref_nkscal0 - ! - endif - ! - endif - ! - call mp_bcast( n_ref_nkscal0, ionode_id, intra_image_comm ) - ! - allocate(index_ref_nkscal0(n_ref_nkscal0)) - allocate(ref_nkscal0(n_ref_nkscal0)) - allocate(spead_ref_nkscal0(n_ref_nkscal0)) - ! - if (ionode) then - ! - do i = 1, n_ref_nkscal0 - ! - read (99, * ) index_ref_nkscal0(i), ref_nkscal0(i), spead_ref_nkscal0(i) - ! - enddo - ! - close (99) - ! - endif - ! - call mp_bcast( index_ref_nkscal0, ionode_id, intra_image_comm ) - call mp_bcast( ref_nkscal0, ionode_id, intra_image_comm ) - call mp_bcast( spead_ref_nkscal0, ionode_id, intra_image_comm ) - ! - ! first, we assign the refalpha to all fixed orbitals, - ! - do iv = 1, n_ref_nkscal0 - ! - if (is_empty) then - ! - alpha0_ref_emp(iv) = ref_nkscal0(iv) - ! - else - ! - alpha0_ref(iv) = ref_nkscal0(iv) - ! - endif - ! - enddo - ! - deallocate(index_ref_nkscal0) - deallocate(ref_nkscal0) - deallocate(spead_ref_nkscal0) - ! - endif - ! - ! if the calculation does not update alpha wrt minimization wfc - ! we return from here - ! - if (is_empty) then - ! - odd_alpha(:) = alpha0_ref_emp(:) - ! - else - ! - odd_alpha(:) = alpha0_ref(:) - ! - endif - ! - valpsi(:,:) = (0.0_DP, 0.0_DP) - ! - return - ! -end subroutine odd_alpha_routine diff --git a/quantum_espresso/kcp/CPV/odd_alpha.f90_bk b/quantum_espresso/kcp/CPV/odd_alpha.f90_bk deleted file mode 100644 index 610617b38..000000000 --- a/quantum_espresso/kcp/CPV/odd_alpha.f90_bk +++ /dev/null @@ -1,371 +0,0 @@ -!-------------------------------------------------------------- -subroutine odd_alpha_routine( evc, nbsp, nbndx, lgam, is_empty) -!-------------------------------------------------------------- - ! - ! alpha_v = (\sum (I,l) {alpha0_I }) / (\sum (I,l) {}), - ! where chi(I,l) is orthornormal pseudo atomic wfc - ! input: evc_wfc - ! out: odd_alpha, valpsi >>> pass to sharing variable - ! full valpsi will be complete in nksiclib routine - ! - ! - use kinds, ONLY: DP - USE ions_base, ONLY: nsp - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_bcast, mp_sum - USE io_global, ONLY: ionode, ionode_id, stdout - use gvecw, only: ngw - use reciprocal_vectors, only: gstart - USE uspp, ONLY: nhsa=>nkb, betae => vkb - use electrons_base, only: nspin, ispin, f - USE cp_main_variables, ONLY: eigr - use orthogonalize_base, ONLY: calphi - USE nksic, ONLY: odd_alpha, valpsi, swfc_fixed, & - becwfc_fixed, alpha0_ref, call_index, & - call_index_emp, alpha0_ref_emp - - USE wavefunctions_module, ONLY : c0_fixed, c0fixed_emp - USE twin_types - ! - implicit none - ! -#ifdef __PARA - include 'mpif.h' -#endif - ! - integer, intent(in) :: nbsp, nbndx - complex(DP), intent(in) :: evc(ngw,nbndx) - logical :: lgam, is_empty - ! - ! local variables - ! - logical :: odd_alpha_is_fixed = .true. - real(DP), allocatable :: norm(:), alpha_mean(:), temp(:) - complex(DP), allocatable :: hpsi(:,:), tempc(:) - complex(DP), allocatable :: wfc(:,:) - type(twin_matrix) :: proj - ! - integer :: n_ref_nkscal0 - integer, allocatable :: index_ref_nkscal0(:) - real(DP), allocatable :: ref_nkscal0(:) - real(DP), allocatable :: spead_ref_nkscal0(:) - ! - integer :: i, iv, jv, n_evc0_fixed - complex(DP) :: tempsi - ! - ! this part is computed only one at starting calculation - ! - ! - if (is_empty) then - ! - call_index_emp = call_index_emp + 1 - ! - else - ! - call_index = call_index + 1 - ! - endif - ! - write(stdout, *) call_index_emp - if ( (call_index .eq. 1) .or. (call_index_emp .eq. 1) ) then - ! - if (is_empty) then - ! - ! alpha0_ref_emp first is allocated here, then will be deallocated - ! in the end of cp run in deallocate_nksic module.f90 - ! - write(stdout, *) 'hello1' - allocate (alpha0_ref_emp(nbndx)) - alpha0_ref_emp = 0.d0 - ! - else - ! - ! alpha0_ref_emp first is allocated here, then will be deallocated - ! in the end of cp run in deallocate_nksic module.f90 - ! - allocate (alpha0_ref(nbndx)) - alpha0_ref = 0.d0 - ! - endif - ! - ! read from file ref. alpha - ! - if (ionode) then - ! - if (is_empty) then - ! - open (unit = 99, file = 'file_alpharef_empty.txt', form = 'formatted', status = 'old' ) - ! - else - ! - open (unit = 99, file = 'file_alpharef.txt', form = 'formatted', status = 'old' ) - ! - endif - ! - read(99, *), n_ref_nkscal0 - ! - endif - ! - write(stdout, *) 'hello2' - call mp_bcast( n_ref_nkscal0, ionode_id, intra_image_comm ) - ! - allocate(index_ref_nkscal0(n_ref_nkscal0)) - allocate(ref_nkscal0(n_ref_nkscal0)) - allocate(spead_ref_nkscal0(n_ref_nkscal0)) - ! - write(stdout, *) 'hello3' - if (ionode) then - ! - do i = 1, n_ref_nkscal0 - ! - read (99, * ) index_ref_nkscal0(i), ref_nkscal0(i), spead_ref_nkscal0(i) - ! - enddo - ! - close (99) - ! - endif - ! - write(stdout, *) 'hello4' - call mp_bcast( index_ref_nkscal0, ionode_id, intra_image_comm ) - call mp_bcast( ref_nkscal0, ionode_id, intra_image_comm ) - call mp_bcast( spead_ref_nkscal0, ionode_id, intra_image_comm ) - ! - ! first, we assign the refalpha to all fixed orbitals, - ! - do iv = 1, n_ref_nkscal0 - ! - if (is_empty) then - ! - alpha0_ref_emp(iv) = ref_nkscal0(iv) - ! - else - ! - alpha0_ref(iv) = ref_nkscal0(iv) - ! - endif - ! - enddo - ! - write(stdout, *) 'hello5' - deallocate(index_ref_nkscal0) - deallocate(ref_nkscal0) - deallocate(spead_ref_nkscal0) - ! - ! Here, I allocate the global variables. This step is done at - ! the first time to call of this routine, or when the program restarted. - ! These allocated variable will be deallocated inside the - ! module deallocate_nksic - ! - write(stdout, *) 'hello6' - ! - ! pass the evc0_fixed to wfc - ! - allocate(wfc(ngw, nbndx)) - ! - if (is_empty) then - ! - wfc(:,:) = c0fixed_emp(:,:) - ! - else - ! - wfc(:,:) = c0_fixed(:,:) - ! - allocate(swfc_fixed(ngw, nbndx)) - ! - call init_twin(becwfc_fixed, lgam) - ! - call allocate_twin(becwfc_fixed, nhsa, nbndx, lgam) - ! - ! calculate becwfc = - ! - call nlsm1_twin( nbndx, 1, nsp, eigr, wfc, becwfc_fixed, 1, lgam ) - ! - ! calculate swfc = S|wfc> - ! - call calphi( wfc, size(wfc,1), becwfc_fixed, nhsa, betae, swfc_fixed, nbndx, lgam) - ! - endif - ! - deallocate(wfc) - ! - endif - ! - write(stdout, *) 'hello' - ! if the calculation does not update alpha wrt minimization wfc - ! we return from here - ! - if (odd_alpha_is_fixed) then - ! - if (is_empty) then - ! - odd_alpha(:) = alpha0_ref_emp(:) - ! - else - ! - odd_alpha(:) = alpha0_ref(:) - ! - endif - ! - valpsi(:,:) = (0.0_DP, 0.0_DP) - ! - return - ! - endif - ! - ! else we want to update alpha wrt minimization wfc - ! the below averaging scheme is performed. - ! - allocate(hpsi(nbndx,ngw), norm(nbndx), alpha_mean(nbndx)) - ! - n_evc0_fixed = nbndx - call init_twin(proj, lgam) - call allocate_twin(proj, nbndx, n_evc0_fixed, lgam) - ! - ! calculate proj = , updated at every wfc minimizing steps - ! - IF(lgam) THEN - ALLOCATE(temp(ngw)) - ELSE - ALLOCATE(tempc(ngw)) - ENDIF - ! - DO iv = 1, nbndx - ! - IF(lgam) THEN - ! - DO jv = 1, n_evc0_fixed - ! - temp(:) = DBLE(CONJG( evc(:,iv)) * swfc_fixed(:,jv)) - ! - proj%rvec(iv,jv) = 2.d0*DBLE(SUM(temp)) - ! - IF (gstart == 2) proj%rvec(iv,jv)=proj%rvec(iv,jv)-temp(1) - ! - ENDDO - ! - ELSE - ! - DO jv = 1, n_evc0_fixed - ! - tempc(:) = CONJG(evc(:,iv)) * swfc_fixed(:,jv) - ! - proj%cvec(iv,jv) = SUM(tempc) - ! - ENDDO - ! - ENDIF - ! - ENDDO - ! - IF(lgam) THEN - ! - DEALLOCATE(temp) - ! - CALL mp_sum( proj%rvec, intra_image_comm ) - ! - ELSE - ! - DEALLOCATE(tempc) - ! - CALL mp_sum( proj%cvec, intra_image_comm ) - ! - ENDIF - ! - alpha_mean(:) = 0.0_DP - norm(:) = 0.0_DP - ! - do iv = 1, nbndx - ! - do jv = 1, n_evc0_fixed - ! - if (lgam) then - ! - if (is_empty) then - ! - alpha_mean(iv) = alpha_mean(iv) + alpha0_ref_emp(jv) * (proj%rvec(iv, jv) * proj%rvec(iv, jv)) - ! - else - ! - alpha_mean(iv) = alpha_mean(iv) + alpha0_ref(jv) * (proj%rvec(iv, jv) * proj%rvec(iv, jv)) - ! - endif - ! - norm(iv) = norm(iv) + proj%rvec(iv, jv) * proj%rvec(iv, jv) - ! - else - ! - if (is_empty) then - ! - alpha_mean(iv) = alpha_mean(iv) + alpha0_ref_emp(jv) * proj%cvec(iv, jv) * conjg(proj%cvec(iv, jv)) - ! - else - ! - alpha_mean(iv) = alpha_mean(iv) + alpha0_ref(jv) * proj%cvec(iv, jv) * conjg(proj%cvec(iv, jv)) - ! - endif - ! - norm(iv) = norm(iv) + proj%cvec(iv, jv) * conjg(proj%cvec(iv, jv)) - ! - endif - ! - enddo - ! - enddo - ! - ! compute alpha - ! - alpha_mean(:) = alpha_mean(:)/norm(:) - ! - ! compute hpsi - ! - hpsi(:,:) = (0.0_DP, 0.0_DP) - tempsi = (0.0_DP, 0.0_DP) - ! - do iv = 1, nbndx - ! - do jv = 1, n_evc0_fixed - ! - if (lgam) then - ! - if (is_empty) then - ! - tempsi = proj%rvec(iv, jv)*( alpha0_ref_emp(jv) - alpha_mean(iv) ) - ! - else - ! - tempsi = proj%rvec(iv, jv)*( alpha0_ref(jv) - alpha_mean(iv) ) - ! - endif - ! - else - ! - if (is_empty) then - ! - tempsi = proj%cvec(iv, jv)*( alpha0_ref_emp(jv) - alpha_mean(iv) ) - ! - else - ! - tempsi = proj%cvec(iv, jv)*( alpha0_ref(jv) - alpha_mean(iv) ) - ! - endif - ! - endif - ! - call ZAXPY (ngw, tempsi, swfc_fixed(:, jv), 1, hpsi(iv, :), 1) - ! - enddo - ! - enddo - ! - ! passing the variables to commont variables - ! - odd_alpha(:) = alpha_mean(:) - valpsi(:,:) = hpsi(:,:) - ! - deallocate( hpsi, norm, alpha_mean ) - call deallocate_twin(proj) - ! - return - ! -end subroutine odd_alpha_routine diff --git a/quantum_espresso/kcp/CPV/ortho.f90 b/quantum_espresso/kcp/CPV/ortho.f90 deleted file mode 100644 index c4ef76b68..000000000 --- a/quantum_espresso/kcp/CPV/ortho.f90 +++ /dev/null @@ -1,1161 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - -!=----------------------------------------------------------------------------=! - SUBROUTINE ortho_m( c0, cp, lambda, descla, ccc, nupdwn, iupdwn, nspin ) - ! - USE kinds, ONLY: DP - USE control_flags, ONLY: force_pairing - USE cp_main_variables, ONLY: ema0bg - USE descriptors, ONLY: lambda_node_ , nlar_ , nlac_ - USE control_flags, ONLY: ortho_max - USE orthogonalize_base, ONLY: calphi, updatc - USE cp_interfaces, ONLY: ortho_gamma - ! - IMPLICIT NONE - - INTEGER, INTENT(IN) :: descla(:,:) - INTEGER, INTENT(IN) :: nupdwn(:), iupdwn(:), nspin - COMPLEX(DP), INTENT(INOUT) :: c0(:,:), cp(:,:) - REAL(DP), INTENT(INOUT) :: lambda(:,:,:) - REAL(DP), INTENT(IN) :: ccc - ! - COMPLEX(DP), ALLOCATABLE :: phi(:,:) - INTEGER :: iss, nsc, iwfc, nwfc, info - INTEGER :: iter, i, j - INTEGER :: ngwx, n, nx - REAL(DP) :: diff - REAL(DP), ALLOCATABLE :: dum(:,:) - REAL(DP), ALLOCATABLE :: ddum(:,:) - COMPLEX(DP), ALLOCATABLE :: cdum(:,:) - ! - CALL start_clock( 'ortho' ) - - n = SIZE( c0, 2 ) - ngwx = SIZE( c0, 1 ) - nx = SIZE( lambda, 1 ) - - ALLOCATE( dum( 1, n ) ) - ALLOCATE( ddum( 1, nx ) ) - ALLOCATE( cdum( ngwx, 1 ) ) - - ALLOCATE( phi( ngwx, n ), STAT = info ) - IF( info /= 0 ) CALL errore( ' ortho ', ' allocating phi ', 3 ) - - CALL calphi( c0, ngwx, dum, 1, cdum, phi, n, ema0bg ) - ! - nsc = nspin - IF( force_pairing ) nsc = 1 - ! - DO iss = 1, nsc - ! - nwfc = nupdwn(iss) - iwfc = iupdwn(iss) - ! - CALL ortho_gamma( 1, cp, ngwx, phi, dum, ddum, 1, dum, ddum, lambda(:,:,iss), nx, & - descla(:,iss), diff, iter, n, nwfc, iwfc ) - ! - IF ( iter > ortho_max ) THEN - call errore(' ortho ',' itermax ',iter) - END IF - ! - CALL updatc( 1.0d0, n, lambda(:,:,iss), nx, phi, ngwx, dum, 1, dum, dum, cp, & - nwfc, iwfc, descla(:,iss) ) - ! - ! lagrange multipliers - ! - IF( descla( lambda_node_ , iss ) > 0 ) THEN - DO j = 1, descla( nlac_ , iss ) - DO i = 1, descla( nlar_ , iss ) - lambda( i, j, iss ) = lambda( i, j, iss ) / ccc - END DO - END DO - END IF - ! - END DO - ! - IF( force_pairing ) cp(:, iupdwn(2):iupdwn(2)+nupdwn(2)-1 ) = cp(:,1:nupdwn(2)) - ! - DEALLOCATE( phi ) - DEALLOCATE( dum ) - DEALLOCATE( ddum ) - DEALLOCATE( cdum ) - ! - CALL stop_clock( 'ortho' ) - ! - RETURN - END SUBROUTINE ortho_m - -SUBROUTINE ortho_m_twin(c0, cp, lambda, descla, ccc, nupdwn, iupdwn, nspin) - ! - USE kinds, ONLY: DP - USE control_flags, ONLY: force_pairing - USE cp_main_variables, ONLY: ema0bg - USE descriptors, ONLY: lambda_node_ , nlar_ , nlac_ - USE control_flags, ONLY: ortho_max - USE orthogonalize_base, ONLY: calphi, updatc - USE cp_interfaces, ONLY: ortho_gamma - USE twin_types - ! - IMPLICIT NONE - - INTEGER, INTENT(IN) :: descla(:,:) - INTEGER, INTENT(IN) :: nupdwn(:), iupdwn(:), nspin - COMPLEX(DP), INTENT(INOUT) :: c0(:,:), cp(:,:) - TYPE(twin_matrix), DIMENSION(:), INTENT(INOUT) :: lambda - REAL(DP), INTENT(IN) :: ccc - ! - COMPLEX(DP), ALLOCATABLE :: phi(:,:) - INTEGER :: iss, nsc, iwfc, nwfc, info - INTEGER :: iter, i, j - INTEGER :: ngwx, n, nx - REAL(DP) :: diff - REAL(DP), ALLOCATABLE :: dum(:,:) - REAL(DP), ALLOCATABLE :: ddum(:,:) - COMPLEX(DP), ALLOCATABLE :: cdum(:,:) - COMPLEX(DP), ALLOCATABLE :: dum_c(:,:) - COMPLEX(DP), ALLOCATABLE :: ddum_c(:,:) - ! - CALL start_clock( 'ortho' ) - - n = SIZE( c0, 2 ) - ngwx = SIZE( c0, 1 ) - nx = SIZE( lambda, 1 ) - - ALLOCATE( dum( 1, n ) ) - ALLOCATE( ddum( 1, nx ) ) - ALLOCATE( cdum( ngwx, 1 ) ) - ALLOCATE( dum_c( 1, n ) ) - ALLOCATE( ddum_c( 1, nx ) ) - - ALLOCATE( phi( ngwx, n ), STAT = info ) - IF( info /= 0 ) CALL errore( ' ortho ', ' allocating phi ', 3 ) - - CALL calphi( c0, ngwx, dum, 1, cdum, phi, n, ema0bg ) - ! - nsc = nspin - IF( force_pairing ) nsc = 1 - ! - DO iss = 1, nsc - ! - nwfc = nupdwn(iss) - iwfc = iupdwn(iss) - ! - IF(.not.lambda(iss)%iscmplx) THEN - CALL ortho_gamma( 1, cp, ngwx, phi, dum, ddum, 1, dum, ddum, lambda(iss)%rvec(:,:), nx, & - descla(:,iss), diff, iter, n, nwfc, iwfc ) - ELSE - !write(313+mpime,*) "lambda_ref", lambda(iss)%cvec - CALL ortho_gamma( 1, cp, ngwx, phi, dum_c, ddum_c, 1, dum_c, ddum_c, lambda(iss)%cvec(:,:), nx, & - descla(:,iss), diff, iter, n, nwfc, iwfc ) - ENDIF - ! - IF ( iter > ortho_max ) THEN - call errore(' ortho ',' itermax ',iter) - END IF - ! - IF(.not.lambda(iss)%iscmplx) THEN - CALL updatc( 1.0d0, n, lambda(iss)%rvec(:,:), nx, phi, ngwx, dum, 1, dum, dum, cp, & - nwfc, iwfc, descla(:,iss) ) - ELSE - CALL updatc( 1.0d0, n, lambda(iss)%cvec(:,:), nx, phi, ngwx, cdum, 1, cdum, cdum, cp, & - nwfc, iwfc, descla(:,iss)) - ENDIF - ! - ! lagrange multipliers - ! - IF( descla( lambda_node_ , iss ) > 0 ) THEN - IF(.not.lambda(iss)%iscmplx) THEN - DO j = 1, descla( nlac_ , iss ) - DO i = 1, descla( nlar_ , iss ) - lambda(iss)%rvec( i, j ) = lambda(iss)%rvec( i, j ) / ccc - END DO - END DO - ELSE - DO j = 1, descla( nlac_ , iss ) - DO i = 1, descla( nlar_ , iss ) - lambda(iss)%cvec( i, j) = lambda(iss)%cvec( i, j) / ccc - END DO - END DO - ENDIF - END IF - ! - END DO - ! - IF( force_pairing ) cp(:, iupdwn(2):iupdwn(2)+nupdwn(2)-1 ) = cp(:,1:nupdwn(2)) - ! - DEALLOCATE( phi ) - DEALLOCATE( dum ) - DEALLOCATE( ddum ) - DEALLOCATE( cdum ) - ! - CALL stop_clock( 'ortho' ) - ! - RETURN - END SUBROUTINE ortho_m_twin - -!=----------------------------------------------------------------------------=! - SUBROUTINE ortho_gamma_real_x( iopt, cp, ngwx, phi, becp, qbecp, nkbx, bephi, qbephi, & - x0, nx0, descla, diff, iter, n, nss, istart ) -!=----------------------------------------------------------------------------=! - ! - USE kinds, ONLY: DP - USE orthogonalize_base, ONLY: rhoset, sigset, tauset, ortho_iterate, & - ortho_alt_iterate, diagonalize_serial, & - use_parallel_diag, diagonalize_parallel - USE descriptors, ONLY: lambda_node_ , nlar_ , nlac_ , ilar_ , ilac_ , & - nlax_ , la_comm_ , descla_siz_ - USE mp, ONLY: mp_sum - USE parallel_toolkit, ONLY: sqr_tr_cannon - - IMPLICIT NONE - - ! ... Arguments - - INTEGER, INTENT(IN) :: iopt - INTEGER, INTENT(IN) :: ngwx, nkbx, nx0 - INTEGER, INTENT(IN) :: n, nss, istart - COMPLEX(DP) :: phi( ngwx, n ), cp( ngwx, n ) - REAL(DP) :: bephi( :, : ), becp( :, : ) - REAL(DP) :: qbephi( :, : ), qbecp( :, : ) - REAL(DP) :: x0( nx0, nx0 ) - INTEGER, INTENT(IN) :: descla( descla_siz_ ) - INTEGER, INTENT(OUT) :: iter - REAL(DP), INTENT(OUT) :: diff - - ! ... Locals - - REAL(DP), ALLOCATABLE :: s(:,:), sig(:,:), tau(:,:), rhot(:,:) - REAL(DP), ALLOCATABLE :: wrk(:,:), rhoa(:,:), rhos(:,:), rhod(:) - INTEGER :: i, j, info, nr, nc, ir, ic - INTEGER :: nlam, nlax - LOGICAL :: la_proc - - ! - ! ... Subroutine body - ! - nlax = descla( nlax_ ) - la_proc = ( descla( lambda_node_ ) > 0 ) - nlam = 1 - if ( la_proc ) nlam = nlax - - IF( la_proc ) THEN - ! - IF( nx0 /= descla( nlax_ ) ) & - CALL errore( ' ortho_gamma ', ' inconsistent dimensions nx0 ' , nx0 ) - IF( nlam /= descla( nlax_ ) ) & - CALL errore( ' ortho_gamma ', ' inconsistent dimensions nlam ' , nlam ) - ! - nr = descla( nlar_ ) - nc = descla( nlac_ ) - ! - ir = descla( ilar_ ) - ic = descla( ilac_ ) - ! - ELSE - ! - nr = 1 - nc = 1 - ! - IF( nlam /= 1 ) & - CALL errore( ' ortho_gamma ', ' inconsistent dimensions nlam, should be 1 ' , nlam ) - IF( nx0 /= 1 ) & - CALL errore( ' ortho_gamma ', ' inconsistent dimensions nx0, should be 1 ' , nx0 ) - ! - END IF - ! - ALLOCATE( rhos( nlam, nlam ) ) - ALLOCATE( rhoa( nlam, nlam ) ) ! antisymmetric part of rho - ALLOCATE( s( nlam, nlam ) ) - ALLOCATE( sig( nlam, nlam ) ) - ALLOCATE( tau( nlam, nlam ) ) - ! - ALLOCATE( rhod( nss ) ) - ! - ! rho = - ! - CALL start_clock( 'rhoset' ) - ! - CALL rhoset( cp, ngwx, phi, bephi, nkbx, qbecp, n, nss, istart, rhos, nlam, descla ) - ! - IF( la_proc ) THEN - ! - ALLOCATE( rhot( nlam, nlam ) ) ! transpose of rho - ! - ! distributed array rhos contains "rho", - ! now transpose rhos and store the result in distributed array rhot - ! - CALL sqr_tr_cannon( nss, rhos, nlam, rhot, nlam, descla ) !modified:giovanni - ! - ! Compute the symmetric part of rho - ! - DO j = 1, nc - DO i = 1, nr - rhos( i, j ) = 0.5d0 * ( rhos( i, j ) + rhot( i, j ) ) - END DO - END DO - ! - ! distributed array rhos now contains symmetric part of "rho", - ! - CALL consistency_check( rhos ) - ! - ! Antisymmetric part of rho, alredy distributed across ortho procs. - ! - DO j = 1, nc - DO i = 1, nr - rhoa( i, j ) = rhos( i, j ) - rhot( i, j ) - END DO - END DO - ! - DEALLOCATE( rhot ) - ! - END IF - - CALL stop_clock( 'rhoset' ) - - - CALL start_clock( 'rsg' ) - ! - ! ... Diagonalize symmetric part of rho (rhos) - ! ... "s" is the matrix of eigenvectors, "rhod" is the array of eigenvalues - ! - IF( use_parallel_diag ) THEN - ! - CALL diagonalize_parallel( nss, rhos, rhod, s, descla ) - ! - ELSE - ! - IF( la_proc ) THEN - ! - ALLOCATE( wrk( nss, nss ), STAT = info ) - IF( info /= 0 ) CALL errore( ' ortho ', ' allocating matrixes ', 1 ) - ! - CALL collect_matrix( wrk, rhos ) - ! - CALL diagonalize_serial( nss, wrk, rhod ) - ! - CALL distribute_matrix( wrk, s ) - ! - DEALLOCATE( wrk ) - ! - END IF - ! - END IF - ! - CALL stop_clock( 'rsg' ) - ! - ! sig = 1- - ! - CALL sigset( cp, ngwx, becp, nkbx, qbecp, n, nss, istart, sig, nlam, descla ) - ! - ! tau = - ! - CALL tauset( phi, ngwx, bephi, nkbx, qbephi, n, nss, istart, tau, nlam, descla ) - ! - CALL start_clock( 'ortho_iter' ) - ! - IF( iopt == 0 ) THEN - ! - CALL ortho_iterate( iter, diff, s, nlam, rhod, x0, nx0, sig, rhoa, rhos, tau, nss, descla) - ! - ELSE - ! - CALL ortho_alt_iterate( iter, diff, s, nlam, rhod, x0, nx0, sig, rhoa, tau, nss, descla) - ! - END IF - ! - CALL stop_clock( 'ortho_iter' ) - ! - DEALLOCATE( rhoa, rhos, rhod, s, sig, tau ) - ! - IF( la_proc ) CALL consistency_check( x0 ) - - RETURN - - CONTAINS - - SUBROUTINE distribute_matrix( a, b ) - REAL(DP) :: a(:,:), b(:,:) - INTEGER :: i, j - IF( la_proc ) THEN - DO j = 1, nc - DO i = 1, nr - b( i, j ) = a( i + ir - 1, j + ic - 1 ) - END DO - END DO - END IF - RETURN - END SUBROUTINE - - SUBROUTINE collect_matrix( a, b ) - REAL(DP) :: a(:,:), b(:,:) - INTEGER :: i, j - a = 0.0d0 - IF( la_proc ) THEN - DO j = 1, nc - DO i = 1, nr - a( ir + i - 1, ic + j - 1 ) = b( i, j ) - END DO - END DO - END IF - CALL mp_sum( a, descla( la_comm_ ) ) - RETURN - END SUBROUTINE - - SUBROUTINE consistency_check( a ) - REAL(DP) :: a(:,:) - INTEGER :: i, j - ! - ! on some machines (IBM RS/6000 for instance) the following test allows - ! to distinguish between Numbers and Sodium Nitride (NaN, Not a Number). - ! If a matrix of Not-Numbers is passed to rs, the most likely outcome is - ! that the program goes on forever doing nothing and writing nothing. - ! - DO j = 1, nc - DO i = 1, nr - IF (a(i,j) /= a(i,j)) CALL errore(' ortho ',' ortho went bananas ',1) - END DO - END DO - RETURN - END SUBROUTINE - - END SUBROUTINE ortho_gamma_real_x - -!=----------------------------------------------------------------------------=! - SUBROUTINE ortho_gamma_cmplx_x( iopt, cp, ngwx, phi, becp, qbecp, nkbx, bephi, qbephi, & - x0, nx0, descla, diff, iter, n, nss, istart ) -!=----------------------------------------------------------------------------=! - ! - USE kinds, ONLY: DP - USE orthogonalize_base, ONLY: rhoset, sigset, tauset, ortho_iterate, & - ortho_alt_iterate, diagonalize_serial, & - use_parallel_diag, diagonalize_parallel - USE descriptors, ONLY: lambda_node_ , nlar_ , nlac_ , ilar_ , ilac_ , & - nlax_ , la_comm_ , descla_siz_ - USE mp, ONLY: mp_sum - USE parallel_toolkit, ONLY: sqr_tr_cannon - - IMPLICIT NONE - - ! ... Arguments - - INTEGER, INTENT(IN) :: iopt - INTEGER, INTENT(IN) :: ngwx, nkbx, nx0 - INTEGER, INTENT(IN) :: n, nss, istart - COMPLEX(DP) :: phi( ngwx, n ), cp( ngwx, n ) - COMPLEX(DP) :: bephi( :, : ), becp( :, : ) - COMPLEX(DP) :: qbephi( :, : ), qbecp( :, : ) - COMPLEX(DP) :: x0( nx0, nx0 ) - INTEGER, INTENT(IN) :: descla( descla_siz_ ) - INTEGER, INTENT(OUT) :: iter - REAL(DP), INTENT(OUT) :: diff - - ! ... Locals - - COMPLEX(DP), ALLOCATABLE :: s(:,:), sig(:,:), tau(:,:), rhot(:,:) - COMPLEX(DP), ALLOCATABLE :: wrk(:,:), rhoa(:,:), rhos(:,:) - REAL(DP), ALLOCATABLE :: rhod(:) - INTEGER :: i, j, info, nr, nc, ir, ic - INTEGER :: nlam, nlax - LOGICAL :: la_proc - -! write(6,*) "calling ortho_gamma"!added:giovanni:debug -! do i=1, size(x0,1) -! do j=1, size(x0,2) -! write(6,*) i,j,x0(i,j) -! enddo -! enddo - ! - ! ... Subroutine body - ! - nlax = descla( nlax_ ) - la_proc = ( descla( lambda_node_ ) > 0 ) - nlam = 1 - if ( la_proc ) nlam = nlax - - IF( la_proc ) THEN - ! - IF( nx0 /= descla( nlax_ ) ) & - CALL errore( ' ortho_gamma ', ' inconsistent dimensions nx0 ' , nx0 ) - IF( nlam /= descla( nlax_ ) ) & - CALL errore( ' ortho_gamma ', ' inconsistent dimensions nlam ' , nlam ) - ! - nr = descla( nlar_ ) - nc = descla( nlac_ ) - ! - ir = descla( ilar_ ) - ic = descla( ilac_ ) - ! - ELSE - ! - nr = 1 - nc = 1 - ! - IF( nlam /= 1 ) & - CALL errore( ' ortho_gamma ', ' inconsistent dimensions nlam, should be 1 ' , nlam ) - IF( nx0 /= 1 ) & - CALL errore( ' ortho_gamma ', ' inconsistent dimensions nx0, should be 1 ' , nx0 ) - ! - END IF - ! - ALLOCATE( rhos( nlam, nlam ) ) - ALLOCATE( rhoa( nlam, nlam ) ) ! antisymmetric part of rho - ALLOCATE( s( nlam, nlam ) ) - ALLOCATE( sig( nlam, nlam ) ) - ALLOCATE( tau( nlam, nlam ) ) - ! - ALLOCATE( rhod( nss ) ) - ! - ! rho = - ! - CALL start_clock( 'rhoset' ) - ! -! write(6,*) "becp", becp !added:giovanni:debug -! write(6,*) "bephi", bephi, "qbecp", qbecp !added:giovanni:debug - CALL rhoset( cp, ngwx, phi, bephi, nkbx, qbecp, n, nss, istart, rhos, nlam, descla ) -! write(6,*) "rhos", rhos !added:giovanni:debug - ! - IF( la_proc ) THEN - ! - ALLOCATE( rhot( nlam, nlam ) ) ! transpose of rho - ! - ! distributed array rhos contains "rho", - ! now transpose rhos and store the result in distributed array rhot - ! - CALL sqr_tr_cannon( nss, rhos, nlam, rhot, nlam, descla ) - ! - ! Compute the symmetric part of rho - ! - DO j = 1, nc - DO i = 1, nr - rhos( i, j ) = 0.5d0 * ( rhos( i, j ) + rhot( i, j ) ) - END DO - END DO - ! - ! distributed array rhos now contains symmetric part of "rho", - ! - CALL consistency_check( rhos ) - ! - ! Antisymmetric part of rho, alredy distributed across ortho procs. - ! - DO j = 1, nc - DO i = 1, nr - rhoa( i, j ) = rhos( i, j ) - rhot( i, j ) - END DO - END DO - ! - DEALLOCATE( rhot ) - ! - END IF -! write(6,*) "rhoss", rhos !added:giovanni:debug -! write(6,*) "rhoa", rhoa !added:giovanni:debug - - CALL stop_clock( 'rhoset' ) - - - CALL start_clock( 'rsg' ) - ! - ! ... Diagonalize symmetric part of rho (rhos) - ! ... "s" is the matrix of eigenvectors, "rhod" is the array of eigenvalues - ! - IF( use_parallel_diag ) THEN - ! -! write(6,*) "calling diagonalize_parallel" ! added:giovanni:debug - CALL diagonalize_parallel( nss, rhos, rhod, s, descla ) -! write(6,*) "rhod", rhod !added:giovanni:debug - ! - ELSE - ! - IF( la_proc ) THEN - ! - ALLOCATE( wrk( nss, nss ), STAT = info ) - IF( info /= 0 ) CALL errore( ' ortho ', ' allocating matrixes ', 1 ) - ! - CALL collect_matrix( wrk, rhos ) - ! - CALL diagonalize_serial( nss, wrk, rhod ) - ! - CALL distribute_matrix( wrk, s ) - ! - DEALLOCATE( wrk ) - ! - END IF - ! - END IF - ! - CALL stop_clock( 'rsg' ) - ! - ! sig = 1- - ! - CALL sigset( cp, ngwx, becp, nkbx, qbecp, n, nss, istart, sig, nlam, descla ) -! write(6,*) "sig", sig !added:giovanni:debug - ! - ! tau = - ! - CALL tauset( phi, ngwx, bephi, nkbx, qbephi, n, nss, istart, tau, nlam, descla ) -! write(6,*)"tau", tau!, "qbephi2", qbephi !added:giovanni:debug - ! -! write(6,*) "calling ortho_iterate", x0!added:giovanni:debug - !stop - CALL start_clock( 'ortho_iter' ) - ! - IF( iopt == 0 ) THEN - ! - CALL ortho_iterate( iter, diff, s, nlam, rhod, x0, nx0, sig, rhoa, rhos, tau, nss, descla) - ! - ELSE - ! - CALL ortho_alt_iterate( iter, diff, s, nlam, rhod, x0, nx0, sig, rhoa, tau, nss, descla) - ! - END IF - ! - CALL stop_clock( 'ortho_iter' ) - ! - DEALLOCATE( rhoa, rhos, rhod, s, sig, tau ) - ! - IF( la_proc ) CALL consistency_check( x0 ) - - RETURN - - CONTAINS - - SUBROUTINE distribute_matrix( a, b ) - COMPLEX(DP) :: a(:,:), b(:,:) - INTEGER :: i, j - IF( la_proc ) THEN - DO j = 1, nc - DO i = 1, nr - b( i, j ) = a( i + ir - 1, j + ic - 1 ) - END DO - END DO - END IF - RETURN - END SUBROUTINE - - SUBROUTINE collect_matrix( a, b ) - COMPLEX(DP) :: a(:,:), b(:,:) - INTEGER :: i, j - a = CMPLX(0.0d0, 0.d0) - IF( la_proc ) THEN - DO j = 1, nc - DO i = 1, nr - a( ir + i - 1, ic + j - 1 ) = b( i, j ) - END DO - END DO - END IF - CALL mp_sum( a, descla( la_comm_ ) ) - RETURN - END SUBROUTINE - - SUBROUTINE consistency_check( a ) - COMPLEX(DP) :: a(:,:) - INTEGER :: i, j - ! - ! on some machines (IBM RS/6000 for instance) the following test allows - ! to distinguish between Numbers and Sodium Nitride (NaN, Not a Number). - ! If a matrix of Not-Numbers is passed to rs, the most likely outcome is - ! that the program goes on forever doing nothing and writing nothing. - ! - DO j = 1, nc - DO i = 1, nr - IF (a(i,j) /= a(i,j)) CALL errore(' ortho ',' ortho went bananas ',1) - END DO - END DO - RETURN - END SUBROUTINE - - END SUBROUTINE ortho_gamma_cmplx_x - - -!=----------------------------------------------------------------------------=! - SUBROUTINE ortho_cp_real( eigr, cp, phi, ngwx, x0, descla, diff, iter, ccc, & - bephi, becp, nbsp, nspin, nupdwn, iupdwn ) -!=----------------------------------------------------------------------------=! - ! - ! input = cp (non-orthonormal), beta - ! input = phi |phi>=s'|c0> - ! output= cp (orthonormal with s( r(t+dt) ) ) - ! output= bephi, becp - ! the method used is similar to the version in les houches 1988 - ! 'simple molecular systems at..' p. 462-463 (18-22) - ! xcx + b x + b^t x^t + a = 1 - ! where c = b = a = - ! where s=s(r(t+dt)) and s'=s(r(t)) - ! for vanderbilt pseudo pot - kl & ap - ! - USE kinds, ONLY: DP - USE ions_base, ONLY: na, nat - USE cvan, ONLY: ish, nvb - USE uspp, ONLY: nkb, qq - USE uspp_param, ONLY: nh - USE control_flags, ONLY: iprsta, ortho_max - USE control_flags, ONLY: force_pairing - USE io_global, ONLY: stdout - USE cp_interfaces, ONLY: ortho_gamma, nlsm1, nlsm1_dist - USE descriptors, ONLY: nlac_ , ilac_ , descla_siz_ , nlar_ , ilar_, lambda_node_, nlax_ - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ngwx, nbsp, nspin - INTEGER, INTENT(IN) :: nupdwn( nspin ), iupdwn( nspin ) - INTEGER, INTENT(IN) :: descla(descla_siz_,nspin) - COMPLEX(DP) :: cp(ngwx,nbsp), phi(ngwx,nbsp), eigr(ngwx,nat) - REAL(DP) :: x0(:,:,:), diff, ccc - INTEGER :: iter - REAL(DP) :: bephi(:,:), becp(:,:) - ! - REAL(DP), ALLOCATABLE :: xloc(:,:) - REAL(DP), ALLOCATABLE :: qbephi(:,:,:), qbecp(:,:,:), bephi_c(:,:) - ! - INTEGER :: nlam, nlax - LOGICAL :: la_proc - ! - INTEGER :: nkbx - INTEGER :: istart, nss, i, iss, iv, jv, is, inl, jnl - INTEGER :: nspin_sub, nx0, nc, ic, icc - REAL(DP) :: qqf - ! -! write(6,*) "inside ortho-cp-real" !added:giovanni:debug - nkbx = nkb - ! - nx0 = SIZE( x0, 1 ) - ! - nlax = descla( nlax_ , 1) - la_proc = ( descla( lambda_node_ , 1) > 0 ) - nlam = 1 - if ( la_proc ) nlam = nlax - - IF( nx0 /= nlam ) & - CALL errore( " ortho_cp_real ", " inconsistent dimensions for x0 ", nx0 ) - - ! - ! - ! calculation of becp and bephi - ! - CALL start_clock( 'ortho' ) - - CALL nlsm1( nbsp, 1, nvb, eigr, cp, becp) - - CALL nlsm1_dist ( nbsp, 1, nvb, eigr, phi, bephi, nlax, nspin, descla ) - ! - ! calculation of qbephi and qbecp - ! - ALLOCATE( qbephi( nkbx, nx0, nspin ) ) - ! - IF( nvb > 0 ) THEN - ALLOCATE( bephi_c ( nkbx, nlax*nspin ) ) - CALL redist_row2col_real(nupdwn(1), bephi, bephi_c, nkbx, nlax, descla(1,1) ) !modified:giovanni - IF( nspin == 2 ) THEN - CALL redist_row2col_cmplx( nupdwn(2), bephi(1,nlax+1), bephi_c(1,nlax+1), nkbx, nlax, descla(1,2) ) !modified:giovanni - END IF - END IF - ! - qbephi = 0.d0 - ! - DO is=1,nvb - DO iv=1,nh(is) - inl = ish(is)+(iv-1)*na(is) - DO jv=1,nh(is) - jnl = ish(is)+(jv-1)*na(is) - qqf = qq(iv,jv,is) - IF( ABS( qqf ) > 1.D-5 ) THEN - DO iss = 1, nspin - istart = iupdwn(iss) - nc = descla( nlac_ , iss ) - ic = descla( ilac_ , iss ) + istart - 1 - IF( la_proc ) THEN - DO i = 1, nc - icc=i+ic-1 - CALL daxpy( na(is), qqf, bephi_c(jnl+1,i+(iss-1)*nlax),1,qbephi(inl+1,i,iss), 1 ) - END DO - END IF - END DO - ENDIF - END DO - END DO - END DO - - IF( nvb > 0 ) DEALLOCATE( bephi_c ) - ! - ALLOCATE( qbecp ( nkbx, nx0, nspin ) ) - - qbecp = 0.d0 - - DO is=1,nvb - DO iv=1,nh(is) - inl = ish(is)+(iv-1)*na(is) - DO jv=1,nh(is) - jnl = ish(is)+(jv-1)*na(is) - qqf = qq(iv,jv,is) - IF( ABS( qqf ) > 1.D-5 ) THEN - DO iss = 1, nspin - istart = iupdwn(iss) - nc = descla( nlac_ , iss ) - ic = descla( ilac_ , iss ) + istart - 1 - IF( la_proc ) THEN - DO i = 1, nc - icc=i+ic-1 - CALL daxpy( na(is), qqf, becp (jnl+1,icc),1, qbecp(inl+1,i,iss), 1 ) - END DO - END IF - END DO - ENDIF - END DO - END DO - END DO - ! - ALLOCATE( xloc( nx0, nx0 ) ) - ! - nspin_sub = nspin - if( force_pairing ) nspin_sub = 1 - ! - DO iss = 1, nspin_sub - - nss = nupdwn(iss) - istart = iupdwn(iss) - - IF( la_proc ) xloc = x0(:,:,iss) * ccc - - CALL ortho_gamma( 0, cp, ngwx, phi, becp, qbecp(:,:,iss), nkbx, bephi(:,((iss-1)*nlax+1):iss*nlax), & - qbephi(:,:,iss), xloc, nx0, descla(:,iss), diff, iter, nbsp, nss, istart ) - - IF( iter > ortho_max ) THEN - WRITE( stdout, 100 ) diff, iter - CALL errore('ortho','max number of iterations exceeded',iter) - END IF - - IF( iprsta > 2 ) THEN - WRITE( stdout, 100 ) diff, iter - ENDIF - ! - IF( la_proc ) x0( :, :, iss ) = xloc / ccc - ! - END DO - ! - IF( force_pairing ) cp(:, iupdwn(2):iupdwn(2)+nupdwn(2)-1 ) = cp(:,1:nupdwn(2)) - ! - DEALLOCATE( xloc ) - DEALLOCATE( qbecp ) - DEALLOCATE( qbephi ) - ! - CALL stop_clock( 'ortho' ) - ! - RETURN - ! -100 FORMAT(3X,'diff = ',D18.10,' iter = ', I5 ) - ! - END SUBROUTINE ortho_cp_real - -!=----------------------------------------------------------------------------=! - SUBROUTINE ortho_cp_twin( eigr, cp, phi, ngwx, x0, descla, diff, iter, ccc, & - bephi, becp, nbsp, nspin, nupdwn, iupdwn ) -!=----------------------------------------------------------------------------=! - ! - ! input = cp (non-orthonormal), beta - ! input = phi |phi>=s'|c0> - ! output= cp (orthonormal with s( r(t+dt) ) ) - ! output= bephi, becp - ! the method used is similar to the version in les houches 1988 - ! 'simple molecular systems at..' p. 462-463 (18-22) - ! xcx + b x + b^t x^t + a = 1 - ! where c = b = a = - ! where s=s(r(t+dt)) and s'=s(r(t)) - ! for vanderbilt pseudo pot - kl & ap - ! - USE kinds, ONLY: DP - USE ions_base, ONLY: na, nat - USE cvan, ONLY: ish, nvb - USE uspp, ONLY: nkb, qq - USE uspp_param, ONLY: nh - USE control_flags, ONLY: iprsta, ortho_max - USE control_flags, ONLY: force_pairing, gamma_only, do_wf_cmplx - USE io_global, ONLY: stdout - USE cp_interfaces, ONLY: ortho_gamma, nlsm1, nlsm1_dist - USE descriptors, ONLY: nlac_ , ilac_ , descla_siz_ , nlar_ , ilar_, lambda_node_, nlax_ - USE twin_types !added:giovanni - USE parallel_toolkit, ONLY: redist_row2col - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ngwx, nbsp, nspin - INTEGER, INTENT(IN) :: nupdwn( nspin ), iupdwn( nspin ) - INTEGER, INTENT(IN) :: descla(descla_siz_, nspin) - COMPLEX(DP) :: cp(ngwx,nbsp), phi(ngwx,nbsp), eigr(ngwx,nat) - type(twin_matrix), dimension(nspin) :: x0 - REAL(DP) :: diff, ccc - INTEGER :: iter - type(twin_matrix) :: bephi, becp !modified:giovanni - ! - REAL(DP), ALLOCATABLE :: xloc(:,:) - COMPLEX(DP), ALLOCATABLE :: xloc_c(:,:) - REAL(DP), ALLOCATABLE :: qbephi(:,:,:), qbecp(:,:,:), bephi_c(:,:) - COMPLEX(DP), ALLOCATABLE :: qbephi_c(:,:,:), qbecp_c(:,:,:), bephi_c_c(:,:) - ! - INTEGER :: nlam, nlax - LOGICAL :: la_proc - ! - INTEGER :: nkbx - INTEGER :: istart, nss, i, iss, iv, jv, is, inl, jnl - INTEGER :: nspin_sub, nx0, nc, ic, icc - REAL(DP) :: qqf - COMPLEX(DP) :: qqf_c - LOGICAL :: lgam !added:giovanni - COMPLEX(DP), PARAMETER :: c_one = CMPLX(1.d0, 0.d0) - - ! -! write(6,*) "inside ortho-cp-twin", bephi%cvec !added:giovanni:debug - lgam=gamma_only.and..not.do_wf_cmplx - nkbx = nkb - ! - IF(.not.x0(1)%iscmplx) THEN - nx0 = SIZE( x0(1)%rvec, 1 ) - ELSE - nx0 = SIZE( x0(1)%cvec, 1 ) - ENDIF - ! - nlax = descla( nlax_ , 1) - la_proc = ( descla( lambda_node_ , 1) > 0 ) - nlam = 1 - if ( la_proc ) nlam = nlax - write(6,*) "nx0", nx0, nlam, x0(1)%iscmplx - IF( nx0 /= nlam ) THEN - CALL errore( " ortho_cp_twin ", " inconsistent dimensions for x0 ", nx0 ) - ENDIF - ! - ! calculation of becp and bephi - ! - CALL start_clock( 'ortho' ) -! write(6,*) "starting nlsm1", cp !added:giovanni:debug - CALL nlsm1( nbsp, 1, nvb, eigr, cp, becp, 1, lgam) !modified:giovanni -! write(6,*) "finished becp", phi !added:giovanni:debug - CALL nlsm1_dist( nbsp, 1, nvb, eigr, phi, bephi, nlax, nspin, descla, lgam ) -! write(6,*) "finished bephi", bephi%cvec !modified:giovanni - ! - ! calculation of qbephi and qbecp - ! - IF(.not.becp%iscmplx) THEN - ALLOCATE( qbephi( nkbx, nx0, nspin ) ) - ELSE - ALLOCATE( qbephi_c( nkbx, nx0, nspin ) ) - ENDIF - ! - IF( nvb > 0 ) THEN - !begin_modified:giovanni - ! - IF(.not.becp%iscmplx) THEN - ALLOCATE( bephi_c ( nkbx, nlax*nspin ) ) - CALL redist_row2col_real( nupdwn(1), bephi%rvec(1:nkbx,1:nlax), bephi_c, nkbx, nlax, descla(1,1) ) - ELSE - ALLOCATE( bephi_c_c ( nkbx, nlax*nspin ) ) - CALL redist_row2col_cmplx( nupdwn(1), bephi%cvec(1:nkbx,1:nlax), bephi_c_c, nkbx, nlax, descla(1,1) ) - ENDIF - ! - IF( nspin == 2 ) THEN - IF(.not.becp%iscmplx) THEN - CALL redist_row2col_real( nupdwn(2), bephi%rvec(1:nkbx, &!warning:giovanni ... need to conform to interface - nlax+1:nlax+nlax), bephi_c(1:nkbx, & - nlax+1:nlax+nlax), nkbx, nlax, descla(1,2) ) -! CALL redist_row2col( nupdwn(2), bephi%rvec(1:ubound(bephi%rvec,1), & -! nlax+1:ubound(bephi%rvec,2)), bephi_c(1:ubound(bephi_c,1), & -! nlax+1:ubound(bephi_c,2)), nkbx, nlax, descla(1,2) ) - ELSE - CALL redist_row2col_cmplx(nupdwn(2), bephi%cvec(1, & !warning:giovanni ... need to conform to interface - nlax+1), bephi_c_c(1, & - nlax+1), nkbx, nlax, descla(1,2)) -! CALL redist_row2col( nupdwn(2), bephi%cvec(1:ubound(bephi%cvec,1), & -! nlax+1:ubound(bephi%cvec,2)), bephi_c_c(1:ubound(bephi_c_c,1), & -! nlax+1:ubound(bephi_c_c,2)), nkbx, nlax, descla(1,2) ) - ENDIF - END IF - ! - END IF -!end_modified:giovanni - ! write(6,*) "bephi_cc", bephi_c_c !added:giovanni:debug - ! - IF(.not.becp%iscmplx) THEN - qbephi = 0.d0 - ! - DO is=1,nvb - DO iv=1,nh(is) - inl = ish(is)+(iv-1)*na(is) - DO jv=1,nh(is) - jnl = ish(is)+(jv-1)*na(is) - qqf = qq(iv,jv,is) - IF( ABS( qqf ) > 1.D-5 ) THEN - DO iss = 1, nspin - istart = iupdwn(iss) - nc = descla( nlac_ , iss ) - ic = descla( ilac_ , iss ) + istart - 1 - IF( la_proc ) THEN - DO i = 1, nc - icc=i+ic-1 - CALL daxpy( na(is), qqf, bephi_c(jnl+1,i+(iss-1)*nlax),1,qbephi(inl+1,i,iss), 1 ) - END DO - END IF - END DO - ENDIF - END DO - END DO - END DO - - IF( nvb > 0 ) DEALLOCATE( bephi_c ) - ELSE - qbephi_c = CMPLX(0.d0, 0.d0) - ! - DO is=1,nvb - DO iv=1,nh(is) - inl = ish(is)+(iv-1)*na(is) - DO jv=1,nh(is) - jnl = ish(is)+(jv-1)*na(is) - qqf_c = CMPLX(qq(iv,jv,is),0.d0) - IF( ABS( qqf_c ) > 1.D-5 ) THEN - DO iss = 1, nspin - istart = iupdwn(iss) - nc = descla( nlac_ , iss ) - ic = descla( ilac_ , iss ) + istart - 1 - IF( la_proc ) THEN - DO i = 1, nc - icc=i+ic-1 - CALL ZAXPY ( na(is), qqf_c, bephi_c_c(jnl+1,i+(iss-1)*nlax), 1, qbephi_c(inl+1,i,iss), 1 ) - END DO - END IF - END DO - ENDIF - END DO - END DO - END DO - - IF( nvb > 0 ) DEALLOCATE( bephi_c_c ) - ENDIF - ! - IF(.not.becp%iscmplx) THEN - ALLOCATE( qbecp ( nkbx, nx0, nspin ) ) - - qbecp = 0.d0 - - DO is=1,nvb - DO iv=1,nh(is) - inl = ish(is)+(iv-1)*na(is) - DO jv=1,nh(is) - jnl = ish(is)+(jv-1)*na(is) - qqf = qq(iv,jv,is) - IF( ABS( qqf ) > 1.D-5 ) THEN - DO iss = 1, nspin - istart = iupdwn(iss) - nc = descla( nlac_ , iss ) - ic = descla( ilac_ , iss ) + istart - 1 - IF( la_proc ) THEN - DO i = 1, nc - icc=i+ic-1 - CALL daxpy( na(is), qqf, becp%rvec (jnl+1,icc),1, qbecp(inl+1,i,iss), 1 ) - END DO - END IF - END DO - ENDIF - END DO - END DO - END DO - ELSE - - ALLOCATE( qbecp_c ( nkbx, nx0, nspin ) ) - - qbecp_c(:,:,:) = CMPLX(0.d0,0.d0) - - DO is=1,nvb - DO iv=1,nh(is) - inl = ish(is)+(iv-1)*na(is) - DO jv=1,nh(is) - jnl = ish(is)+(jv-1)*na(is) - qqf_c = CMPLX(qq(iv,jv,is), 0.d0) - IF( ABS( qqf_c ) > 1.D-5 ) THEN - DO iss = 1, nspin - istart = iupdwn(iss) - nc = descla( nlac_ , iss ) - ic = descla( ilac_ , iss ) + istart - 1 - IF( la_proc ) THEN - DO i = 1, nc - icc=i+ic-1 - CALL ZAXPY(na(is), qqf_c, becp%cvec(jnl+1,icc),1, qbecp_c(inl+1,i,iss), 1) - END DO - END IF - END DO - ENDIF - END DO - END DO - END DO - ENDIF - ! - IF(.not.becp%iscmplx) THEN - ALLOCATE( xloc( nx0, nx0 ) ) - ELSE - ALLOCATE( xloc_c( nx0, nx0 ) ) - ENDIF - ! - nspin_sub = nspin - if( force_pairing ) nspin_sub = 1 - ! -! csc=CMPLX(0.d0,0.d0) !added:giovanni:debug -! call scalar_us(becp, nkbx, vkb, cp, ngwx, 15, csc, nbsp, lgam) -! write(6,*) nbsp, "csc-ortho-before", csc - DO iss = 1, nspin_sub -! write(6,*) "calling ortho_gamma in ortho_cp_twin", phi, "qbecp_c", qbecp_c(:,:,iss), "bephi", bephi%cvec!, "qbephi", qbephi_c !added:giovanni:debug - nss = nupdwn(iss) - istart = iupdwn(iss) - IF(.not.x0(iss)%iscmplx) THEN - IF( la_proc ) xloc = x0(iss)%rvec(:,:) * ccc - CALL ortho_gamma( 0, cp, ngwx, phi, becp%rvec, qbecp(:,:,iss), nkbx, bephi%rvec(:,((iss-1)*nlax+1):iss*nlax), & - qbephi(:,:,iss), xloc, nx0, descla(:,iss), diff, iter, nbsp, nss, istart ) - ELSE - IF( la_proc ) xloc_c = x0(iss)%cvec(:,:) * ccc - CALL ortho_gamma( 0, cp, ngwx, phi, becp%cvec, (qbecp_c(:,:,iss)), nkbx, bephi%cvec(:,((iss-1)*nlax+1):iss*nlax), & - (qbephi_c(:,:,iss)), xloc_c, nx0, descla(:,iss), diff, iter, nbsp, nss, istart ) - ENDIF - ! -! csc=CMPLX(0.d0,0.d0) !added:giovanni:debug -! call scalar_us(becp, nkbx, vkb, cp, ngwx, 15, csc, nbsp, lgam) -! write(6,*) nbsp, "csc-ortho-after", csc - ! - IF( iter > ortho_max ) THEN - WRITE( stdout, 100 ) diff, iter - CALL errore('ortho','max number of iterations exceeded',iter) - END IF - - IF( iprsta > 2 ) THEN - WRITE( stdout, 100 ) diff, iter - ENDIF - ! - IF(.not.x0(iss)%iscmplx) THEN - IF( la_proc ) x0(iss)%rvec(:,:) = xloc/ccc - ELSE - IF( la_proc ) x0(iss)%cvec(:,:) = xloc_c/ccc - ENDIF - ! - - END DO - ! - IF( force_pairing ) cp(:, iupdwn(2):iupdwn(2)+nupdwn(2)-1 ) = cp(:,1:nupdwn(2)) - ! - IF(.not.becp%iscmplx) THEN - DEALLOCATE( xloc ) - DEALLOCATE( qbecp ) - DEALLOCATE( qbephi ) - ELSE - DEALLOCATE( xloc_c ) - DEALLOCATE( qbecp_c ) - DEALLOCATE( qbephi_c ) - ENDIF - - ! - CALL stop_clock( 'ortho' ) - ! - RETURN - ! -100 FORMAT(3X,'diff = ',D18.10,' iter = ', I5 ) - ! - END SUBROUTINE ortho_cp_twin diff --git a/quantum_espresso/kcp/CPV/ortho_base.f90 b/quantum_espresso/kcp/CPV/ortho_base.f90 deleted file mode 100644 index 720a03011..000000000 --- a/quantum_espresso/kcp/CPV/ortho_base.f90 +++ /dev/null @@ -1,2557 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - - -MODULE orthogonalize_base - - USE kinds - USE dspev_module, ONLY: pdspev_drv, dspev_drv - USE zhpev_module, ONLY: pzhpev_drv, zhpev_drv - - IMPLICIT NONE - - SAVE - - PRIVATE - - REAL(DP) :: one, zero, two, minus_one, minus_two - PARAMETER ( one = 1.0d0, zero = 0.0d0, two = 2.0d0, minus_one = -1.0d0 ) - PARAMETER ( minus_two = -2.0d0 ) - COMPLEX(DP) :: cone, czero, mcone - PARAMETER ( cone = (1.0d0, 0.0d0), czero = (0.0d0, 0.0d0) ) - PARAMETER ( mcone = (-1.0d0, 0.0d0) ) - REAL(DP) :: small = 1.0d-14 - LOGICAL :: use_parallel_diag - - PUBLIC :: sigset - PUBLIC :: tauset - PUBLIC :: rhoset - PUBLIC :: ortho_iterate - PUBLIC :: ortho_alt_iterate - PUBLIC :: updatc, calphi - PUBLIC :: mesure_diag_perf - PUBLIC :: mesure_mmul_perf - PUBLIC :: diagonalize_parallel - PUBLIC :: diagonalize_serial - PUBLIC :: use_parallel_diag - - INTERFACE calphi - module procedure calphi_new, calphi_old - END INTERFACE - - INTERFACE rhoset - module procedure rhoset_real, rhoset_cmplx - END INTERFACE - - INTERFACE diagonalize_parallel - module procedure diagonalize_parallel_real, diagonalize_parallel_cmplx - END INTERFACE - - INTERFACE diagonalize_serial - module procedure diagonalize_serial_real, diagonalize_serial_cmplx - END INTERFACE - - INTERFACE sigset - module procedure sigset_real, sigset_cmplx - END INTERFACE - - INTERFACE tauset - module procedure tauset_real, tauset_cmplx - END INTERFACE - - INTERFACE ortho_iterate - module procedure ortho_iterate_real, ortho_iterate_cmplx - END INTERFACE - - INTERFACE ortho_alt_iterate - module procedure ortho_alt_iterate_real, ortho_alt_iterate_cmplx - END INTERFACE - - INTERFACE updatc - module procedure updatc_real, updatc_cmplx - END INTERFACE - -CONTAINS - - -! ---------------------------------------------- - - - SUBROUTINE diagonalize_serial_real( n, rhos, rhod ) - IMPLICIT NONE - INTEGER, INTENT(IN) :: n - REAL(DP) :: rhos(:,:) - REAL(DP) :: rhod(:) - ! - ! inputs: - ! n size of the eigenproblem - ! rhos the symmetric matrix - ! outputs: - ! rhos eigenvectors - ! rhod eigenvalues - ! - REAL(DP), ALLOCATABLE :: aux(:) - INTEGER :: i, j, k - - IF( n < 1 ) RETURN - - ALLOCATE( aux( n * ( n + 1 ) / 2 ) ) - - ! pack lower triangle of rho into aux - ! - k = 0 - DO j = 1, n - DO i = j, n - k = k + 1 - aux( k ) = rhos( i, j ) - END DO - END DO - - CALL dspev_drv( 'V', 'L', n, aux, rhod, rhos, SIZE(rhos,1) ) - - DEALLOCATE( aux ) - - RETURN - - END SUBROUTINE diagonalize_serial_real - - SUBROUTINE diagonalize_serial_cmplx( n, rhos, rhod ) - IMPLICIT NONE - INTEGER, INTENT(IN) :: n - COMPLEX(DP) :: rhos(:,:) - REAL(DP) :: rhod(:) - ! - ! inputs: - ! n size of the eigenproblem - ! rhos the symmetric matrix - ! outputs: - ! rhos eigenvectors - ! rhod eigenvalues - ! - COMPLEX(DP), ALLOCATABLE :: aux(:) - INTEGER :: i, j, k - - IF( n < 1 ) RETURN - - ALLOCATE( aux( n * ( n + 1 ) / 2 ) ) - - ! pack lower triangle of rho into aux - ! - k = 0 - DO j = 1, n - DO i = j, n - k = k + 1 - aux( k ) = rhos( i, j ) - END DO - END DO - - CALL zhpev_drv( 'V', 'L', n, aux, rhod, rhos, SIZE(rhos,1) ) - - DEALLOCATE( aux ) - - RETURN - - END SUBROUTINE diagonalize_serial_cmplx - -! ---------------------------------------------- - -SUBROUTINE diagonalize_parallel_real( n, rhos, rhod, s, desc ) - - USE descriptors, ONLY: lambda_node_ , nlax_ -#ifdef __SCALAPACK - USE mp_global, ONLY: ortho_cntx - USE dspev_module, ONLY: pdsyevd_drv -#endif - - IMPLICIT NONE - REAL(DP), INTENT(IN) :: rhos(:,:) ! input symmetric matrix - REAL(DP) :: rhod(:) ! output eigenvalues - REAL(DP) :: s(:,:) ! output eigenvectors - INTEGER, INTENT(IN) :: n ! size of the global matrix - INTEGER, INTENT(IN) :: desc(:) - - IF( n < 1 ) RETURN - - ! Matrix is distributed on the same processors group - ! used for parallel matrix multiplication - ! - IF( SIZE(s,1) /= SIZE(rhos,1) .OR. SIZE(s,2) /= SIZE(rhos,2) ) & - CALL errore( " diagonalize_parallel ", " inconsistent dimension for s and rhos ", 1 ) - - IF ( desc( lambda_node_ ) > 0 ) THEN - ! - IF( SIZE(s,1) /= desc( nlax_ ) ) & - CALL errore( " diagonalize_parallel ", " inconsistent dimension ", 1 ) - ! - ! Compute local dimension of the cyclically distributed matrix - ! - s = rhos - ! -#ifdef __SCALAPACK - CALL pdsyevd_drv( .true. , n, desc( nlax_ ), s, SIZE(s,1), rhod, ortho_cntx ) -#else - CALL qe_pdsyevd( .true., n, desc, s, SIZE(s,1), rhod ) -#endif - ! - END IF - - RETURN - -END SUBROUTINE diagonalize_parallel_real - -SUBROUTINE diagonalize_parallel_cmplx( n, rhos, rhod, s, desc ) - - USE descriptors, ONLY: lambda_node_ , nlax_ -#ifdef __SCALAPACK - USE mp_global, ONLY: ortho_cntx - USE dspev_module, ONLY: pdsyevd_drv -#endif - - IMPLICIT NONE - COMPLEX(DP), INTENT(IN) :: rhos(:,:) ! input symmetric matrix - REAL(DP) :: rhod(:) ! output eigenvalues - COMPLEX(DP) :: s(:,:) ! output eigenvectors - INTEGER, INTENT(IN) :: n ! size of the global matrix - INTEGER, INTENT(IN) :: desc(:) - - IF( n < 1 ) RETURN - - ! Matrix is distributed on the same processors group - ! used for parallel matrix multiplication - ! - IF( SIZE(s,1) /= SIZE(rhos,1) .OR. SIZE(s,2) /= SIZE(rhos,2) ) & - CALL errore( " diagonalize_parallel ", " inconsistent dimension for s and rhos ", 1 ) - - IF ( desc( lambda_node_ ) > 0 ) THEN - ! - IF( SIZE(s,1) /= desc( nlax_ ) ) & - CALL errore( " diagonalize_parallel ", " inconsistent dimension ", 1 ) - ! - ! Compute local dimension of the cyclically distributed matrix - ! - s = rhos - ! -#ifdef __SCALAPACK - CALL pzheevd_drv( .true. , n, desc( nlax_ ), s, SIZE(s,1), rhod, ortho_cntx ) -#else - CALL qe_pzheevd( .true., n, desc, s, SIZE(s,1), rhod ) -#endif - ! - END IF - - RETURN - -END SUBROUTINE diagonalize_parallel_cmplx - -! ---------------------------------------------- - - - SUBROUTINE mesure_diag_perf( n ) - ! - USE mp_global, ONLY: intra_image_comm, root_image - USE mp_global, ONLY: np_ortho, me_ortho, ortho_comm, ortho_comm_id - USE io_global, ONLY: ionode, stdout - USE mp, ONLY: mp_sum, mp_bcast, mp_barrier - USE mp, ONLY: mp_max - USE descriptors, ONLY: descla_siz_ , descla_init , nlar_ , nlac_ , & - ilar_ , ilac_ , nlax_ , lambda_node_ , la_myc_ , la_myr_ - USE control_flags, ONLY: ortho_para - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: n - REAL(DP), ALLOCATABLE :: s(:,:), a(:,:), d(:) - REAL(DP) :: t1, tpar, tser - INTEGER :: nr, nc, ir, ic, nx - INTEGER :: desc( descla_siz_ ) - REAL(DP) :: cclock - EXTERNAL :: cclock - INTEGER, PARAMETER :: paradim = 1000 - ! - ! Check if number of PEs for orthogonalization/diagonalization is given from the input - ! - IF( ortho_para > 0 ) THEN - use_parallel_diag = .TRUE. - RETURN - END IF - - ALLOCATE( d( n ) ) - ! - CALL descla_init( desc, n, n, np_ortho, me_ortho, ortho_comm, ortho_comm_id ) - - nx = 1 - IF( desc( lambda_node_ ) > 0 ) nx = desc( nlax_ ) - - nr = desc( nlar_ ) - nc = desc( nlac_ ) - ir = desc( ilar_ ) - ic = desc( ilac_ ) - - ALLOCATE( s( nx, nx ) ) - ALLOCATE( a( nx, nx ) ) - ! - CALL set_a() - ! - ! some MPIs (OpenMPI) the first time they call a collective routine take too much - ! time to perform initializations, then perform a dummy call to get meaningful time - ! - CALL diagonalize_parallel( n, a, d, s, desc ) - ! - CALL set_a() - ! - CALL mp_barrier( intra_image_comm ) - t1 = cclock() - ! - CALL diagonalize_parallel( n, a, d, s, desc ) - ! - tpar = cclock() - t1 - CALL mp_max( tpar, intra_image_comm ) - - DEALLOCATE( s, a ) - ! - IF( desc( la_myc_ ) == 0 .AND. desc( la_myr_ ) == 0 .AND. & - desc( lambda_node_ ) > 0 .AND. n < paradim ) THEN - - ! when n >= paradim do not mesure serial perf, go parallel - - ALLOCATE( a( n, n ) ) - nr = n - nc = n - ir = 1 - ic = 1 - - CALL set_a() - - t1 = cclock() - - CALL diagonalize_serial( n, a, d ) - - tser = cclock() - t1 - - DEALLOCATE( a ) - - ELSE - - tser = 0_DP - - END IF - - CALL mp_max( tser, intra_image_comm ) - -#if defined __PARA - - IF( ionode ) THEN - use_parallel_diag = .FALSE. - WRITE( stdout, 90 ) - IF( n < paradim ) WRITE( stdout, 100 ) tser - WRITE( stdout, 110 ) tpar, np_ortho(1) * np_ortho(2) - 90 FORMAT(/,3X,'Diagonalization Performances') -100 FORMAT(3X,'ortho diag, time for serial driver = ', 1F9.5) -110 FORMAT(3X,'ortho diag, time for parallel driver = ', 1F9.5, ' with ', I4, ' procs' ) - IF( n < paradim ) THEN - IF( tpar < tser ) use_parallel_diag = .TRUE. - ELSE - use_parallel_diag = .TRUE. - END IF - END IF - -#else - - use_parallel_diag = .FALSE. - -#endif - - CALL mp_bcast( use_parallel_diag, root_image, intra_image_comm ) - - DEALLOCATE( d ) - - RETURN - - CONTAINS - - SUBROUTINE set_a() - INTEGER :: i, j, ii, jj - IF( desc( lambda_node_ ) < 0 ) RETURN - DO j = 1, nc - DO i = 1, nr - ii = i + ir - 1 - jj = j + ic - 1 - IF( ii == jj ) THEN - a(i,j) = ( DBLE( n-ii+1 ) ) / DBLE( n ) + 1.0d0 / ( DBLE( ii+jj ) - 1.0d0 ) - ELSE - a(i,j) = 1.0d0 / ( DBLE( ii+jj ) - 1.0d0 ) - END IF - END DO - END DO - RETURN - END SUBROUTINE set_a - - END SUBROUTINE mesure_diag_perf - - -! ---------------------------------------------- - - - SUBROUTINE mesure_mmul_perf( n ) - ! - USE mp_global, ONLY: nproc_image, intra_image_comm, & - ortho_comm, np_ortho, me_ortho, init_ortho_group, ortho_comm_id - USE io_global, ONLY: ionode, stdout - USE mp, ONLY: mp_sum, mp_bcast, mp_barrier - USE mp, ONLY: mp_max - USE descriptors, ONLY: descla_siz_ , descla_init , nlar_ , nlac_ , la_comm_ , lambda_node_ - USE control_flags, ONLY: ortho_para - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: n - ! - REAL(DP), ALLOCATABLE :: c(:,:), a(:,:), b(:,:) - REAL(DP) :: t1, tcan - INTEGER :: nr, nc, np - INTEGER :: desc( descla_siz_ ) - ! - REAL(DP) :: cclock - EXTERNAL :: cclock - ! - IF( ortho_para > 0 ) THEN - ! - ! Here the number of processors is suggested on input - ! - np = ortho_para - if( np > MIN( n, nproc_image ) ) np = MIN( n, nproc_image ) - np = MAX( INT( SQRT( DBLE( np ) + 0.1d0 ) ), 1 ) - ! - ELSE - ! - ! Take the maximum number of processors - ! - np = MIN( n, nproc_image ) - np = MAX( INT( SQRT( DBLE( np ) + 0.1d0 ) ), 1 ) - ! - END IF - - ! - ! Now test the allowed processors mesh sizes - ! - - CALL init_ortho_group( np * np, intra_image_comm ) - - CALL descla_init( desc, n, n, np_ortho, me_ortho, ortho_comm, ortho_comm_id ) - - nr = desc( nlar_ ) - nc = desc( nlac_ ) - - ALLOCATE( a( nr, nc ), c( nr, nc ), b( nr, nc ) ) - - a = 1.0d0 / DBLE( n ) - b = 1.0d0 / DBLE( n ) - - ! some MPIs (OpenMPI) the first time they call a collective routine take too much - ! time to perform initializations, then perform a dummy call to get meaningful time - CALL sqr_mm_cannon( 'N', 'N', n, 1.0d0, a, nr, b, nr, 0.0d0, c, nr, desc) - - CALL mp_barrier( intra_image_comm ) - t1 = cclock() - - CALL sqr_mm_cannon( 'N', 'N', n, 1.0d0, a, nr, b, nr, 0.0d0, c, nr, desc) - - tcan = cclock() - t1 - CALL mp_max( tcan, intra_image_comm ) - - DEALLOCATE( a, c, b ) - - -#if defined __PARA - - IF( ionode ) THEN - ! - WRITE( stdout, 90 ) - WRITE( stdout, 120 ) tcan, np*np - 90 FORMAT(/,3X,'Matrix Multiplication Performances') -120 FORMAT(3X,'ortho mmul, time for parallel driver = ', 1F9.5, ' with ', I4, ' procs') - ! - END IF - -#else - - np = 1 - -#endif - - CALL init_ortho_group( np*np, intra_image_comm ) - -#if defined __PARA - IF( ionode ) THEN - WRITE( stdout, '(/,3X,"Constraints matrixes will be distributed block like on")' ) - WRITE( stdout, '(3X,"ortho sub-group = ", I4, "*", I4, " procs",/)' ) np_ortho(1), np_ortho(2) - END IF -#endif - - RETURN - - END SUBROUTINE mesure_mmul_perf - - - - -!=----------------------------------------------------------------------------=! - - SUBROUTINE ortho_iterate_real( iter, diff, u, ldx, diag, xloc, nx0, sig, rhor, rhos, tau, nss, desc ) - - ! this iterative loop uses Cannon's parallel matrix multiplication - ! matrix are distributed over a square processor grid: 1x1 2x2 3x3 ... - ! But the subroutine work with any number of processors, when - ! nproc is not a square, some procs are left idle - - USE kinds, ONLY: DP - USE control_flags, ONLY: ortho_eps, ortho_max - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum, mp_max - USE descriptors, ONLY: nlar_ , nlac_ , ilar_ , ilac_ , lambda_node_ , & - la_myr_ , la_myc_ , la_comm_ , descla_siz_ , nlax_ - USE parallel_toolkit, ONLY: sqr_tr_cannon !added:giovanni - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nss, ldx, nx0 - INTEGER, INTENT(IN) :: desc( descla_siz_ ) - REAL(DP) :: u ( ldx, ldx ) - REAL(DP) :: diag( nss ) - REAL(DP) :: xloc( nx0, nx0 ) - REAL(DP) :: rhor( ldx, ldx ) - REAL(DP) :: rhos( ldx, ldx ) - REAL(DP) :: tau ( ldx, ldx ) - REAL(DP) :: sig ( ldx, ldx ) - INTEGER, INTENT(OUT) :: iter - REAL(DP), INTENT(OUT) :: diff - - INTEGER :: i, j - INTEGER :: nr, nc, ir, ic - REAL(DP), ALLOCATABLE :: tmp1(:,:), tmp2(:,:), dd(:,:), tr1(:,:), tr2(:,:) - REAL(DP), ALLOCATABLE :: con(:,:), x1(:,:) - ! - IF( nss < 1 ) RETURN - - ! - ! all processors not involved in the parallel orthogonalization - ! jump at the end of the subroutine - ! - - IF( ldx/= nx0 ) & - CALL errore( " ortho_iterate ", " inconsistent dimensions ldx, nx0 ", nx0 ) - - IF( desc( lambda_node_ ) < 0 ) then - xloc = 0.0d0 - iter = 0 - go to 100 - endif - ! - ! Compute the size of the local block - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - ir = desc( ilar_ ) - ic = desc( ilac_ ) - - IF( ldx/= desc( nlax_ ) ) & - CALL errore( " ortho_iterate ", " inconsistent dimensions ldx ", ldx ) - - ALLOCATE( tr1(ldx,ldx), tr2(ldx,ldx) ) - ALLOCATE( tmp1(ldx,ldx), tmp2(ldx,ldx), dd(ldx,ldx), x1(ldx,ldx), con(ldx,ldx) ) - - ! Clear elements not involved in the orthogonalization - ! - do j = nc + 1, nx0 - do i = 1, nx0 - xloc( i, j ) = 0.0d0 - end do - end do - do j = 1, nx0 - do i = nr + 1, nx0 - xloc( i, j ) = 0.0d0 - end do - end do - - - ITERATIVE_LOOP: DO iter = 1, ortho_max - ! - ! the following calls do the following matrix multiplications: - ! tmp1 = x0*rhor (1st call) - ! dd = x0*tau*x0 (2nd and 3rd call) - ! tmp2 = x0*rhos (4th call) - ! - CALL sqr_mm_cannon( 'N', 'N', nss, 1.0d0, xloc, nx0, rhor, ldx, 0.0d0, tmp1, ldx, desc) - CALL sqr_mm_cannon( 'N', 'N', nss, 1.0d0, tau, ldx, xloc, nx0, 0.0d0, tmp2, ldx, desc) - CALL sqr_mm_cannon( 'N', 'N', nss, 1.0d0, xloc, nx0, tmp2, ldx, 0.0d0, dd, ldx, desc) - CALL sqr_mm_cannon( 'N', 'N', nss, 1.0d0, xloc, nx0, rhos, ldx, 0.0d0, tmp2, ldx, desc) - ! - CALL sqr_tr_cannon( nss, tmp1, ldx, tr1, ldx, desc ) - CALL sqr_tr_cannon( nss, tmp2, ldx, tr2, ldx, desc ) - ! -!$omp parallel do default(shared), private(j) - DO i=1,nr - DO j=1,nc - x1(i,j) = sig(i,j)-tmp1(i,j)-tr1(i,j)-dd(i,j) - con(i,j)= x1(i,j)-tmp2(i,j)-tr2(i,j) - END DO - END DO - ! - ! x1 = sig -x0*rho -x0*rho^t -x0*tau*x0 - ! - diff = 0.d0 - DO i=1,nr - DO j=1,nc - IF(ABS(con(i,j)).GT.diff) diff=ABS(con(i,j)) - END DO - END DO - - CALL mp_max( diff, desc( la_comm_ ) ) - - IF( diff < ortho_eps ) EXIT ITERATIVE_LOOP - - ! - ! the following calls do: - ! tmp1 = x1*u - ! tmp2 = ut*x1*u - ! - CALL sqr_mm_cannon( 'N', 'N', nss, 1.0d0, x1, ldx, u, ldx, 0.0d0, tmp1, ldx, desc ) - CALL sqr_mm_cannon( 'T', 'N', nss, 1.0d0, u, ldx, tmp1, ldx, 0.0d0, tmp2, ldx, desc ) - ! - ! g=ut*x1*u/d (g is stored in tmp1) - ! -!$omp parallel do default(shared), private(j) - DO i=1,nr - DO j=1,nc - tmp1(i,j)=tmp2(i,j)/(diag(i+ir-1)+diag(j+ic-1)) - END DO - END DO - ! - ! the following calls do: - ! tmp2 = g*ut - ! x0 = u*g*ut - ! - CALL sqr_mm_cannon( 'N', 'T', nss, 1.0d0, tmp1, ldx, u, ldx, 0.0d0, tmp2, ldx, desc ) - CALL sqr_mm_cannon( 'N', 'N', nss, 1.0d0, u, ldx, tmp2, ldx, 0.0d0, xloc, nx0, desc) - ! - END DO ITERATIVE_LOOP - - DEALLOCATE( tmp1, tmp2, dd, x1, con, tr1, tr2 ) - -100 CONTINUE - - CALL mp_max( iter, intra_image_comm ) - - RETURN - END SUBROUTINE ortho_iterate_real - - SUBROUTINE ortho_iterate_cmplx( iter, diff, u, ldx, diag, xloc, nx0, sig, rhor, rhos, tau, nss, desc ) - - ! this iterative loop uses Cannon's parallel matrix multiplication - ! matrix are distributed over a square processor grid: 1x1 2x2 3x3 ... - ! But the subroutine work with any number of processors, when - ! nproc is not a square, some procs are left idle - - USE kinds, ONLY: DP - USE control_flags, ONLY: ortho_eps, ortho_max - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum, mp_max - USE descriptors, ONLY: nlar_ , nlac_ , ilar_ , ilac_ , lambda_node_ , & - la_myr_ , la_myc_ , la_comm_ , descla_siz_ , nlax_ - USE parallel_toolkit, ONLY: sqr_tr_cannon !added:giovanni - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nss, ldx, nx0 - INTEGER, INTENT(IN) :: desc( descla_siz_ ) - COMPLEX(DP) :: u ( ldx, ldx ) - REAL(DP) :: diag( nss ) - COMPLEX(DP) :: xloc( nx0, nx0 ) - COMPLEX(DP) :: rhor( ldx, ldx ) - COMPLEX(DP) :: rhos( ldx, ldx ) - COMPLEX(DP) :: tau ( ldx, ldx ) - COMPLEX(DP) :: sig ( ldx, ldx ) - INTEGER, INTENT(OUT) :: iter - REAL(DP), INTENT(OUT) :: diff - - INTEGER :: i, j - INTEGER :: nr, nc, ir, ic - COMPLEX(DP), ALLOCATABLE :: tmp1(:,:), tmp2(:,:), dd(:,:), tr1(:,:), tr2(:,:) - COMPLEX(DP), ALLOCATABLE :: con(:,:), x1(:,:) - COMPLEX(DP), PARAMETER :: c_zero=CMPLX(0.d0,0.d0), c_one=CMPLX(1.d0,0.d0) - ! - IF( nss < 1 ) RETURN - - ! - ! all processors not involved in the parallel orthogonalization - ! jump at the end of the subroutine - ! - - IF( ldx/= nx0 ) & - CALL errore( " ortho_iterate ", " inconsistent dimensions ldx, nx0 ", nx0 ) - - IF( desc( lambda_node_ ) < 0 ) then - xloc = CMPLX(0.0d0, 0.d0) - iter = 0 - go to 100 - endif - ! - ! Compute the size of the local block - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - ir = desc( ilar_ ) - ic = desc( ilac_ ) - - IF( ldx/= desc( nlax_ ) ) & - CALL errore( " ortho_iterate ", " inconsistent dimensions ldx ", ldx ) - - ALLOCATE( tr1(ldx,ldx), tr2(ldx,ldx) ) - ALLOCATE( tmp1(ldx,ldx), tmp2(ldx,ldx), dd(ldx,ldx), x1(ldx,ldx), con(ldx,ldx) ) - - ! Clear elements not involved in the orthogonalization - ! - do j = nc + 1, nx0 - do i = 1, nx0 - xloc( i, j ) = CMPLX(0.0d0, 0.d0) - end do - end do - do j = 1, nx0 - do i = nr + 1, nx0 - xloc( i, j ) = CMPLX(0.0d0, 0.d0) - end do - end do - - ITERATIVE_LOOP: DO iter = 1, ortho_max - ! - ! the following calls do the following matrix multiplications: - ! tmp1 = x0*rhor (1st call) - ! dd = x0*tau*x0 (2nd and 3rd call) - ! tmp2 = x0*rhos (4th call) - ! - CALL sqr_zmm_cannon( 'N', 'N', nss, c_one, xloc, nx0, rhor, ldx, c_zero, tmp1, ldx, desc) - - CALL sqr_zmm_cannon( 'N', 'N', nss, c_one, tau, ldx, xloc, nx0, c_zero, tmp2, ldx, desc) - - CALL sqr_zmm_cannon( 'N', 'N', nss, c_one, xloc, nx0, tmp2, ldx, c_zero, dd, ldx, desc) - - CALL sqr_zmm_cannon( 'N', 'N', nss, c_one, xloc, nx0, rhos, ldx, c_zero, tmp2, ldx, desc) - ! - CALL sqr_tr_cannon( nss, tmp1, ldx, tr1, ldx, desc ) - CALL sqr_tr_cannon( nss, tmp2, ldx, tr2, ldx, desc ) - ! -!$omp parallel do default(shared), private(j) - DO i=1,nr - DO j=1,nc - x1(i,j) = sig(i,j)-tmp1(i,j)-tr1(i,j)-dd(i,j) - con(i,j)= x1(i,j)-tmp2(i,j)-tr2(i,j) - END DO - END DO - ! - ! x1 = sig -x0*rho -x0*rho^t -x0*tau*x0 - ! - diff = 0.d0 - DO i=1,nr - DO j=1,nc - IF(ABS(con(i,j)).GT.diff) diff=ABS(con(i,j)) - END DO - END DO - - CALL mp_max( diff, desc( la_comm_ ) ) - - IF( diff < ortho_eps ) EXIT ITERATIVE_LOOP - - ! - ! the following calls do: - ! tmp1 = x1*u - ! tmp2 = ut*x1*u - ! - CALL sqr_zmm_cannon( 'N', 'N', nss, c_one, x1, ldx, u, ldx, c_zero, tmp1, ldx, desc ) - CALL sqr_zmm_cannon( 'C', 'N', nss, c_one, u, ldx, tmp1, ldx, c_zero, tmp2, ldx, desc ) - ! - ! g=ut*x1*u/d (g is stored in tmp1) - ! -!$omp parallel do default(shared), private(j) - DO i=1,nr - DO j=1,nc - tmp1(i,j)=tmp2(i,j)/(diag(i+ir-1)+diag(j+ic-1)) - END DO - END DO - ! - ! the following calls do: - ! tmp2 = g*ut - ! x0 = u*g*ut - ! - CALL sqr_zmm_cannon( 'N', 'C', nss, c_one, tmp1, ldx, u, ldx, c_zero, tmp2, ldx, desc ) - CALL sqr_zmm_cannon( 'N', 'N', nss, c_one, u, ldx, tmp2, ldx, c_zero, xloc, nx0, desc) - ! - END DO ITERATIVE_LOOP - DEALLOCATE( tmp1, tmp2, dd, x1, con, tr1, tr2 ) - -100 CONTINUE - - CALL mp_max( iter, intra_image_comm ) - - RETURN - END SUBROUTINE ortho_iterate_cmplx - -!=----------------------------------------------------------------------------=! -! -! Alternative iterative cycle -! -!=----------------------------------------------------------------------------=! -! - - - SUBROUTINE ortho_alt_iterate_real( iter, diff, u, ldx, diag, xloc, nx0, sig, & - rhor, tau, nss, desc ) - - USE kinds, ONLY: DP - USE control_flags, ONLY: ortho_eps, ortho_max - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum, mp_max - USE parallel_toolkit, ONLY: sqr_tr_cannon - USE descriptors, ONLY: nlar_ , nlac_ , ilar_ , ilac_ , lambda_node_ , & - la_myr_ , la_myc_ , la_comm_ , descla_siz_ , nlax_ - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nss, ldx, nx0 - INTEGER, INTENT(IN) :: desc( descla_siz_ ) - REAL(DP) :: u ( ldx, ldx ) - REAL(DP) :: diag( nss ) - REAL(DP) :: xloc( nx0, nx0 ) - REAL(DP) :: rhor( ldx, ldx ) - REAL(DP) :: tau ( ldx, ldx ) - REAL(DP) :: sig ( ldx, ldx ) - INTEGER, INTENT(OUT) :: iter - REAL(DP), INTENT(OUT) :: diff - - INTEGER :: i, j - INTEGER :: nr, nc, ir, ic - REAL(DP), ALLOCATABLE :: tmp1(:,:), tmp2(:,:) - REAL(DP), ALLOCATABLE :: x1(:,:) - REAL(DP), ALLOCATABLE :: sigd(:) - REAL(DP) :: den - ! - IF( nss < 1 ) RETURN - - IF( ldx/= nx0 ) & - CALL errore( " ortho_alt_iterate ", " inconsistent dimensions ldx, nx0 ", nx0 ) - - if( desc( lambda_node_ ) < 0 ) then - xloc = 0.0d0 - iter = 0 - go to 100 - endif - ! - ! Compute the size of the local block - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - ir = desc( ilar_ ) - ic = desc( ilac_ ) - - IF( ldx/= desc( nlax_ ) ) & - CALL errore( " ortho_alt_iterate ", " inconsistent dimensions ldx ", ldx ) - - ALLOCATE( tmp1(ldx,ldx), tmp2(ldx,ldx), x1(ldx,ldx), sigd(nss) ) - - ! Clear elements not involved in the orthogonalization - ! - do j = nc + 1, nx0 - do i = 1, nx0 - xloc( i, j ) = 0.0d0 - end do - end do - do j = 1, nx0 - do i = nr + 1, nx0 - xloc( i, j ) = 0.0d0 - end do - end do - ! - ! ... Transform "sig", "rhoa" and "tau" in the new basis through matrix "s" - ! - CALL sqr_mm_cannon( 'N', 'N', nss, 1.0d0, sig, ldx, u, ldx, 0.0d0, tmp1, ldx, desc) - CALL sqr_mm_cannon( 'T', 'N', nss, 1.0d0, u, ldx, tmp1, ldx, 0.0d0, sig, ldx, desc) - ! - CALL sqr_mm_cannon( 'N', 'N', nss, 1.0d0, rhor, ldx, u, ldx, 0.0d0, tmp1, ldx, desc) - CALL sqr_mm_cannon( 'T', 'N', nss, 1.0d0, u, ldx, tmp1, ldx, 0.0d0, rhor, ldx, desc) - ! - CALL sqr_mm_cannon( 'N', 'N', nss, 1.0d0, tau, ldx, u, ldx, 0.0d0, tmp1, ldx, desc) - CALL sqr_mm_cannon( 'T', 'N', nss, 1.0d0, u, ldx, tmp1, ldx, 0.0d0, tau, ldx, desc) - ! - ! ... Initialize x0 with preconditioning - ! - DO J = 1, nc - DO I = 1, nr - den = ( diag( i + ir - 1 ) + diag( j + ic - 1 ) ) - IF( ABS( den ) <= small ) den = SIGN( small, den ) - xloc( i, j ) = sig( i, j ) / den - ENDDO - ENDDO - - ! - ! ... Starting iteration - ! - - ITERATIVE_LOOP: DO iter = 0, ortho_max - - CALL sqr_mm_cannon( 'N', 'N', nss, 1.0d0, xloc, nx0, rhor, ldx, 0.0d0, tmp2, ldx, desc) - - CALL sqr_tr_cannon( nss, tmp2, ldx, tmp1, ldx, desc ) - - DO J=1,nc - DO I=1,nr - tmp2(I,J) = tmp2(I,J) + tmp1(I,J) - ENDDO - ENDDO -! - CALL sqr_mm_cannon( 'T', 'N', nss, 1.0d0, tau, ldx, xloc, nx0, 0.0d0, tmp1, ldx, desc) - ! - sigd = 0.0d0 - IF( desc( la_myr_ ) == desc( la_myc_ ) ) THEN - DO i = 1, nr - SIGD( i + ir - 1 ) = tmp1(i,i) - tmp1(i,i) = -SIGD( i + ir - 1 ) - ENDDO - END IF - CALL mp_sum( sigd, desc( la_comm_ ) ) - - CALL sqr_mm_cannon( 'T', 'N', nss, 1.0d0, xloc, nx0, tmp1, ldx, 0.0d0, x1, ldx, desc) - ! - CALL sqr_tr_cannon_real( nss, x1, ldx, tmp1, ldx, desc ) - - ! ... X1 = SIG - tmp2 - 0.5d0 * ( X1 + X1^t ) - - diff = 0.0d0 - ! - DO j = 1, nc - DO i = 1, nr - ! - den = ( diag(i+ir-1) + sigd(i+ir-1) + diag(j+ic-1) + sigd(j+ic-1) ) - IF( ABS( den ) <= small ) den = SIGN( small, den ) - x1(i,j) = sig(i,j) - tmp2(i,j) - 0.5d0 * (x1(i,j)+tmp1(i,j)) - x1(i,j) = x1(i,j) / den - diff = MAX( ABS( x1(i,j) - xloc(i,j) ), diff ) - xloc(i,j) = x1(i,j) - ! - END DO - END DO - - CALL mp_max( diff, desc( la_comm_ ) ) - - IF( diff < ortho_eps ) EXIT ITERATIVE_LOOP - - END DO ITERATIVE_LOOP - ! - ! ... Transform x0 back to the original basis - - CALL sqr_mm_cannon( 'N', 'N', nss, 1.0d0, u, ldx, xloc, nx0, 0.0d0, tmp1, ldx, desc) - CALL sqr_mm_cannon( 'N', 'T', nss, 1.0d0, u, ldx, tmp1, ldx, 0.0d0, xloc, nx0, desc) - - DEALLOCATE( tmp1, tmp2, x1, sigd ) - -100 CONTINUE - - CALL mp_max( iter, intra_image_comm ) - - RETURN - END SUBROUTINE ortho_alt_iterate_real - - SUBROUTINE ortho_alt_iterate_cmplx( iter, diff, u, ldx, diag, xloc, nx0, sig, rhor, tau, nss, desc ) - - USE kinds, ONLY: DP - USE control_flags, ONLY: ortho_eps, ortho_max - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum, mp_max - USE descriptors, ONLY: nlar_ , nlac_ , ilar_ , ilac_ , lambda_node_ , & - la_myr_ , la_myc_ , la_comm_ , descla_siz_ , nlax_ - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nss, ldx, nx0 - INTEGER, INTENT(IN) :: desc( descla_siz_ ) - COMPLEX(DP) :: u ( ldx, ldx ) - REAL(DP) :: diag( nss ) - COMPLEX(DP) :: xloc( nx0, nx0 ) - COMPLEX(DP) :: rhor( ldx, ldx ) - COMPLEX(DP) :: tau ( ldx, ldx ) - COMPLEX(DP) :: sig ( ldx, ldx ) - INTEGER, INTENT(OUT) :: iter - REAL(DP), INTENT(OUT) :: diff - - INTEGER :: i, j - INTEGER :: nr, nc, ir, ic - COMPLEX(DP), ALLOCATABLE :: tmp1(:,:), tmp2(:,:) - COMPLEX(DP), ALLOCATABLE :: x1(:,:) - REAL(DP), ALLOCATABLE :: sigd(:) - REAL(DP) :: den - COMPLEX(DP), PARAMETER :: c_zero = CMPLX(0.d0, 0.d0), c_one = CMPLX(1.d0,0.d0) - ! - IF( nss < 1 ) RETURN - - IF( ldx/= nx0 ) & - CALL errore( " ortho_alt_iterate ", " inconsistent dimensions ldx, nx0 ", nx0 ) - - if( desc( lambda_node_ ) < 0 ) then - xloc = CMPLX(0.0d0,0.d0) - iter = 0 - go to 100 - endif - ! - ! Compute the size of the local block - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - ir = desc( ilar_ ) - ic = desc( ilac_ ) - - IF( ldx/= desc( nlax_ ) ) & - CALL errore( " ortho_alt_iterate ", " inconsistent dimensions ldx ", ldx ) - - ALLOCATE( tmp1(ldx,ldx), tmp2(ldx,ldx), x1(ldx,ldx), sigd(nss) ) - - ! Clear elements not involved in the orthogonalization - ! - do j = nc + 1, nx0 - do i = 1, nx0 - xloc( i, j ) = CMPLX(0.0d0, 0.d0) - end do - end do - do j = 1, nx0 - do i = nr + 1, nx0 - xloc( i, j ) = CMPLX(0.0d0, 0.d0) - end do - end do - ! - ! ... Transform "sig", "rhoa" and "tau" in the new basis through matrix "s" - ! - CALL sqr_zmm_cannon( 'N', 'N', nss, c_one, sig, ldx, u, ldx, c_zero, tmp1, ldx, desc) - CALL sqr_zmm_cannon( 'C', 'N', nss, c_one, u, ldx, tmp1, ldx, c_zero, sig, ldx, desc) - ! - CALL sqr_zmm_cannon( 'N', 'N', nss, c_one, rhor, ldx, u, ldx, c_zero, tmp1, ldx, desc) - CALL sqr_zmm_cannon( 'C', 'N', nss, c_one, u, ldx, tmp1, ldx, c_zero, rhor, ldx, desc) - ! - CALL sqr_zmm_cannon( 'N', 'N', nss, c_one, tau, ldx, u, ldx, c_zero, tmp1, ldx, desc) - CALL sqr_zmm_cannon( 'C', 'N', nss, c_one, u, ldx, tmp1, ldx, c_zero, tau, ldx, desc) - ! - ! ... Initialize x0 with preconditioning - ! - DO J = 1, nc - DO I = 1, nr - den = ( diag( i + ir - 1 ) + diag( j + ic - 1 ) ) - IF( ABS( den ) <= small ) den = SIGN( small, den ) - xloc( i, j ) = sig( i, j ) / den - ENDDO - ENDDO - - ! - ! ... Starting iteration - ! - - ITERATIVE_LOOP: DO iter = 0, ortho_max - - CALL sqr_zmm_cannon( 'N', 'N', nss, c_one, xloc, nx0, rhor, ldx, c_zero, tmp2, ldx, desc) - - CALL sqr_tr_cannon_cmplx( nss, tmp2, ldx, tmp1, ldx, desc ) - - DO J=1,nc - DO I=1,nr - tmp2(I,J) = tmp2(I,J) + tmp1(I,J) - ENDDO - ENDDO -! - CALL sqr_zmm_cannon( 'C', 'N', nss, c_one, tau, ldx, xloc, nx0, c_zero, tmp1, ldx, desc) - ! - sigd = 0.0d0 - IF( desc( la_myr_ ) == desc( la_myc_ ) ) THEN - DO i = 1, nr - SIGD( i + ir - 1 ) = DBLE(tmp1(i,i)) - tmp1(i,i) = CMPLX(-SIGD( i + ir - 1 ), 0.d0) - ENDDO - END IF - CALL mp_sum( sigd, desc( la_comm_ ) ) - - CALL sqr_zmm_cannon( 'C', 'N', nss, c_one, xloc, nx0, tmp1, ldx, c_zero, x1, ldx, desc) - ! - CALL sqr_tr_cannon_cmplx( nss, x1, ldx, tmp1, ldx, desc ) - - ! ... X1 = SIG - tmp2 - 0.5d0 * ( X1 + X1^t ) - - diff = 0.0d0 - ! - DO j = 1, nc - DO i = 1, nr - ! - den = ( diag(i+ir-1) + sigd(i+ir-1) + diag(j+ic-1) + sigd(j+ic-1) ) - IF( ABS( den ) <= small ) den = SIGN( small, den ) - x1(i,j) = sig(i,j) - tmp2(i,j) - 0.5d0 * (x1(i,j)+tmp1(i,j)) - x1(i,j) = x1(i,j) / den - diff = MAX( ABS( x1(i,j) - xloc(i,j) ), diff ) - xloc(i,j) = x1(i,j) - ! - END DO - END DO - - CALL mp_max( diff, desc( la_comm_ ) ) - - IF( diff < ortho_eps ) EXIT ITERATIVE_LOOP - - END DO ITERATIVE_LOOP - ! - ! ... Transform x0 back to the original basis - - CALL sqr_zmm_cannon( 'N', 'N', nss, c_one, u, ldx, xloc, nx0, c_zero, tmp1, ldx, desc) - CALL sqr_mm_cannon( 'N', 'C', nss, c_one, u, ldx, tmp1, ldx, c_zero, xloc, nx0, desc) - - DEALLOCATE( tmp1, tmp2, x1, sigd ) - -100 CONTINUE - - CALL mp_max( iter, intra_image_comm ) - - RETURN - END SUBROUTINE ortho_alt_iterate_cmplx - -!------------------------------------------------------------------------- - SUBROUTINE sigset_real( cp, ngwx, becp, nkbx, qbecp, n, nss, ist, sig, ldx, desc ) -!----------------------------------------------------------------------- -! input: cp (non-orthonormal), becp, qbecp -! computes the matrix -! sig = 1 - a , a = = + sum q_ij -! where s=s(r(t+dt)) -! routine makes use of c(-q)=c*(q) -! - USE kinds, ONLY: DP - USE uspp, ONLY: nkbus - USE cvan, ONLY: nvb - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gstart - USE mp, ONLY: mp_root_sum - USE control_flags, ONLY: iprsta - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm, leg_ortho - USE descriptors, ONLY: lambda_node_ , la_npc_ , la_npr_ , descla_siz_ , & - descla_init , la_comm_ , ilar_ , ilac_ , nlar_ , & - nlac_ , la_myr_ , la_myc_ , la_nx_ , la_n_ , nlax_ - USE parallel_toolkit, ONLY: dsqmsym -! - IMPLICIT NONE -! - INTEGER :: nss, ist, ngwx, nkbx, n, ldx, nx - COMPLEX(DP) :: cp( ngwx, n ) - REAL(DP) :: becp( nkbx, n ), qbecp( nkbx, ldx ) - REAL(DP) :: sig( ldx, ldx ) - INTEGER :: desc( descla_siz_ ) -! - INTEGER :: i, j, ipr, ipc, nr, nc, ir, ic - INTEGER :: root - INTEGER :: desc_ip( descla_siz_ ) - INTEGER :: np( 2 ), coor_ip( 2 ) - ! - REAL(DP), ALLOCATABLE :: sigp(:,:) -! - IF( nss < 1 ) RETURN - - np(1) = desc( la_npr_ ) - np(2) = desc( la_npc_ ) - - nx = desc( nlax_ ) - - ALLOCATE( sigp( nx, nx ) ) - - IF( desc( lambda_node_ ) > 0 ) THEN - IF( desc( nlax_ ) /= ldx ) & - CALL errore( " sigset ", " inconsistent dimension ldx ", ldx ) - IF( nx /= ldx ) & - CALL errore( " sigset ", " inconsistent dimension nx ", nx ) - END IF - - DO ipc = 1, np(2) - DO ipr = 1, ipc ! np(1) use symmetry - - coor_ip(1) = ipr - 1 - coor_ip(2) = ipc - 1 - - CALL descla_init( desc_ip, desc( la_n_ ), desc( la_nx_ ), np, coor_ip, desc( la_comm_ ), 1 ) - - nr = desc_ip( nlar_ ) - nc = desc_ip( nlac_ ) - ir = desc_ip( ilar_ ) - ic = desc_ip( ilac_ ) - ! - CALL GRID2D_RANK( 'R', desc_ip( la_npr_ ), desc_ip( la_npc_ ), & - desc_ip( la_myr_ ), desc_ip( la_myc_ ), root ) - - root = root * leg_ortho - - CALL DGEMM( 'T', 'N', nr, nc, 2*ngw, -2.0d0, cp( 1, ist + ir - 1), 2*ngwx, & - cp( 1, ist + ic - 1 ), 2*ngwx, 0.0d0, sigp, nx ) - ! - ! q = 0 components has weight 1.0 - ! - IF ( gstart == 2 ) THEN - CALL DGER( nr, nc, 1.D0, cp(1,ist+ir-1), 2*ngwx, cp(1,ist+ic-1), 2*ngwx, sigp, nx ) - END IF - ! - CALL mp_root_sum( sigp, sig, root, intra_image_comm ) - ! - END DO - ! - END DO - ! - DEALLOCATE( sigp ) - ! - CALL dsqmsym( nss, sig, nx, desc ) - ! - IF( desc( lambda_node_ ) > 0 ) THEN - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - ir = desc( ilar_ ) - ic = desc( ilac_ ) - ! - IF( desc( la_myr_ ) == desc( la_myc_ ) ) THEN - DO i = 1, nr - sig(i,i) = sig(i,i) + 1.0d0 - END DO - END IF - ! - IF( nvb > 0 ) THEN - CALL DGEMM( 'T', 'N', nr, nc, nkbus, -1.0d0, becp( 1, ist+ir-1 ), & - nkbx, qbecp( 1:, 1: ), nkbx, 1.0d0, sig, ldx ) - ENDIF - ! - IF( iprsta > 4 ) THEN - WRITE( stdout,*) - WRITE( stdout,'(26x,a)') ' sig ' - DO i = 1, nr - WRITE( stdout,'(7f11.6)' ) ( sig(i,j), j=1, nc ) - END DO - ENDIF - ! - END IF - ! - RETURN - END SUBROUTINE sigset_real - -!------------------------------------------------------------------------- - SUBROUTINE sigset_cmplx( cp, ngwx, becp, nkbx, qbecp, n, nss, ist, sig, ldx, desc ) !warning:giovanni***check_what_happens_here -!----------------------------------------------------------------------- -! input: cp (non-orthonormal), becp, qbecp -! computes the matrix -! sig = 1 - a , a = = + sum q_ij -! where s=s(r(t+dt)) -! routine makes use of c(-q)=c*(q) -! - USE kinds, ONLY: DP - USE uspp, ONLY: nkbus - USE cvan, ONLY: nvb - USE gvecw, ONLY: ngw - USE mp, ONLY: mp_root_sum - USE control_flags, ONLY: iprsta - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm, leg_ortho - USE descriptors, ONLY: lambda_node_ , la_npc_ , la_npr_ , descla_siz_ , & - descla_init , la_comm_ , ilar_ , ilac_ , nlar_ , & - nlac_ , la_myr_ , la_myc_ , la_nx_ , la_n_ , nlax_ - USE parallel_toolkit, ONLY: zsqmher -! - IMPLICIT NONE -! - INTEGER :: nss, ist, ngwx, nkbx, n, ldx, nx - COMPLEX(DP) :: cp( ngwx, n ) - COMPLEX(DP) :: becp( nkbx, n ), qbecp( nkbx, ldx ) - COMPLEX(DP) :: sig( ldx, ldx ) - INTEGER :: desc( descla_siz_ ) -! - INTEGER :: i, j, ipr, ipc, nr, nc, ir, ic - INTEGER :: root - INTEGER :: desc_ip( descla_siz_ ) - INTEGER :: np( 2 ), coor_ip( 2 ) - ! - COMPLEX(DP), ALLOCATABLE :: sigp(:,:) - COMPLEX(DP), PARAMETER :: c_zero=CMPLX(0.d0,0.d0), & - c_mone=CMPLX(-1.d0,0.d0), c_one=CMPLX(1.d0,0.d0) -! - IF( nss < 1 ) RETURN - - np(1) = desc( la_npr_ ) - np(2) = desc( la_npc_ ) - - nx = desc( nlax_ ) - - ALLOCATE( sigp( nx, nx ) ) - - IF( desc( lambda_node_ ) > 0 ) THEN - IF( desc( nlax_ ) /= ldx ) & - CALL errore( " sigset ", " inconsistent dimension ldx ", ldx ) - IF( nx /= ldx ) & - CALL errore( " sigset ", " inconsistent dimension nx ", nx ) - END IF - - DO ipc = 1, np(2) - DO ipr = 1, np(1) !use symmetry - - coor_ip(1) = ipr - 1 - coor_ip(2) = ipc - 1 - - CALL descla_init( desc_ip, desc( la_n_ ), desc( la_nx_ ), np, coor_ip, desc( la_comm_ ), 1 ) - - nr = desc_ip( nlar_ ) - nc = desc_ip( nlac_ ) - ir = desc_ip( ilar_ ) - ic = desc_ip( ilac_ ) - ! - CALL GRID2D_RANK( 'R', desc_ip( la_npr_ ), desc_ip( la_npc_ ), & - desc_ip( la_myr_ ), desc_ip( la_myc_ ), root ) - - root = root * leg_ortho - - CALL ZGEMM( 'C', 'N', nr, nc, ngw, c_mone, cp( 1, ist + ir - 1), ngwx, & - cp( 1, ist + ic - 1 ), ngwx, c_zero, sigp, nx ) !warning:giovanni -! ! -! ! q = 0 components has weight 1.0 -! ! -! IF ( gstart == 2 ) THEN -! CALL DGER( nr, nc, 1.D0, cp(1,ist+ir-1), 2*ngwx, cp(1,ist+ic-1), 2*ngwx, sigp, nx ) -! END IF - ! - CALL mp_root_sum( sigp, sig, root, intra_image_comm ) - ! - END DO - ! - END DO - ! - DEALLOCATE( sigp ) - ! - CALL zsqmher( nss, sig, nx, desc ) -! CALL dsqmsym - ! - IF( desc( lambda_node_ ) > 0 ) THEN - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - ir = desc( ilar_ ) - ic = desc( ilac_ ) - ! - IF( desc( la_myr_ ) == desc( la_myc_ ) ) THEN - DO i = 1, nr - sig(i,i) = sig(i,i) + CMPLX(1.0d0,0.d0) - END DO - END IF - ! - IF( nvb > 0 ) THEN - CALL ZGEMM( 'C', 'N', nr, nc, nkbus, c_mone, becp( 1, ist+ir-1 ), & - nkbx, (qbecp( 1:, 1: )), nkbx, c_one, sig, ldx ) - ENDIF - ! - IF( iprsta > 4 ) THEN - WRITE( stdout,*) - WRITE( stdout,'(26x,a)') ' sig ' - DO i = 1, nr - WRITE( stdout,'(2((7f11.6)(4x)))' ) ( sig(i,j), j=1, nc ) - END DO - ENDIF - ! - END IF - ! - RETURN - END SUBROUTINE sigset_cmplx - -! -!----------------------------------------------------------------------- - SUBROUTINE rhoset_real( cp, ngwx, phi, bephi, nkbx, qbecp, n, nss, ist, rho, ldx, desc ) -!----------------------------------------------------------------------- -! input: cp (non-orthonormal), phi, bephi, qbecp -! computes the matrix -! rho = = -! where |phi> = s'|c0> = |c0> + sum q_ij |i> -! where s=s(r(t+dt)) and s'=s(r(t)) -! routine makes use of c(-q)=c*(q) -! - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gstart - USE uspp, ONLY: nkbus - USE cvan, ONLY: nvb - USE kinds, ONLY: DP - USE mp, ONLY: mp_root_sum - USE mp_global, ONLY: intra_image_comm, leg_ortho - USE control_flags, ONLY: iprsta - USE io_global, ONLY: stdout - USE descriptors, ONLY: lambda_node_ , la_npc_ , la_npr_ , descla_siz_ , & - descla_init , la_comm_ , ilar_ , ilac_ , nlar_ , & - nlac_ , la_myr_ , la_myc_ , la_nx_ , la_n_ , nlax_ - -! - IMPLICIT NONE -! - INTEGER :: nss, ist, ngwx, nkbx, ldx, n - COMPLEX(DP) :: cp( ngwx, n ), phi( ngwx, n ) - REAL(DP) :: bephi( nkbx, ldx ), qbecp( nkbx, ldx ) - REAL(DP) :: rho( ldx, ldx ) - INTEGER :: desc( descla_siz_ ) - ! - INTEGER :: i, j, ipr, ipc, nr, nc, ir, ic - INTEGER :: root, nx - INTEGER :: desc_ip( descla_siz_ ) - INTEGER :: np( 2 ), coor_ip( 2 ) - - REAL(DP), ALLOCATABLE :: rhop(:,:) - ! - ! - ! - ! - - IF( nss < 1 ) RETURN - - np(1) = desc( la_npr_ ) - np(2) = desc( la_npc_ ) - - nx = desc( nlax_ ) - - IF( desc( lambda_node_ ) > 0 ) THEN - IF( desc( nlax_ ) /= ldx ) & - CALL errore( " rhoset ", " inconsistent dimension ldx ", ldx ) - IF( nx /= ldx ) & - CALL errore( " rhoset ", " inconsistent dimension nx ", nx ) - END IF - - ALLOCATE( rhop( nx, nx ) ) - - rhop = 0.0d0 - - DO ipc = 1, np(2) - DO ipr = 1, np(1) - - coor_ip(1) = ipr - 1 - coor_ip(2) = ipc - 1 - - CALL descla_init( desc_ip, desc( la_n_ ), desc( la_nx_ ), np, coor_ip, desc( la_comm_ ), 1 ) - - nr = desc_ip( nlar_ ) - nc = desc_ip( nlac_ ) - ir = desc_ip( ilar_ ) - ic = desc_ip( ilac_ ) - ! - CALL GRID2D_RANK( 'R', desc_ip( la_npr_ ), desc_ip( la_npc_ ), & - desc_ip( la_myr_ ), desc_ip( la_myc_ ), root ) - ! - root = root * leg_ortho - - CALL DGEMM( 'T', 'N', nr, nc, 2*ngw, 2.0d0, phi( 1, ist + ir - 1 ), 2*ngwx, & - cp( 1, ist + ic - 1 ), 2*ngwx, 0.0d0, rhop, nx ) - ! - ! q = 0 components has weight 1.0 - ! - IF (gstart == 2) THEN - CALL DGER( nr, nc, -1.D0, phi(1,ist+ir-1), 2*ngwx, cp(1,ist+ic-1), 2*ngwx, rhop, nx ) - END IF - - CALL mp_root_sum( rhop, rho, root, intra_image_comm ) - - END DO - END DO - - DEALLOCATE( rhop ) - - IF( desc( lambda_node_ ) > 0 ) THEN - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - ! - ! bephi is distributed among processor rows - ! qbephi is distributed among processor columns - ! tau is block distributed among the whole processor 2D grid - ! - ! - IF( nvb > 0 ) THEN - ! - ! rho(i,j) = rho(i,j) + SUM_b bephi( b, i ) * qbecp( b, j ) - ! - CALL DGEMM( 'T', 'N', nr, nc, nkbus, 1.0d0, bephi, nkbx, qbecp, nkbx, 1.0d0, rho, ldx ) - - END IF - - IF ( iprsta > 4 ) THEN - WRITE( stdout,*) - WRITE( stdout,'(26x,a)') ' rho ' - DO i=1,nr - WRITE( stdout,'(7f11.6)') (rho(i,j),j=1,nc) - END DO - END IF - - END IF - ! - RETURN - END SUBROUTINE rhoset_real - -! -!----------------------------------------------------------------------- - SUBROUTINE rhoset_cmplx( cp, ngwx, phi, bephi, nkbx, qbecp, n, nss, ist, rho, ldx, desc ) -!----------------------------------------------------------------------- -! input: cp (non-orthonormal), phi, bephi, qbecp -! computes the matrix -! rho = = -! where |phi> = s'|c0> = |c0> + sum q_ij |i> -! where s=s(r(t+dt)) and s'=s(r(t)) -! routine makes use of c(-q)=c*(q) -! - USE gvecw, ONLY: ngw - USE uspp, ONLY: nkbus - USE cvan, ONLY: nvb - USE kinds, ONLY: DP - USE mp, ONLY: mp_root_sum - USE mp_global, ONLY: intra_image_comm, leg_ortho - USE control_flags, ONLY: iprsta - USE io_global, ONLY: stdout - USE descriptors, ONLY: lambda_node_ , la_npc_ , la_npr_ , descla_siz_ , & - descla_init , la_comm_ , ilar_ , ilac_ , nlar_ , & - nlac_ , la_myr_ , la_myc_ , la_nx_ , la_n_ , nlax_ - -! - IMPLICIT NONE -! - INTEGER :: nss, ist, ngwx, nkbx, ldx, n - COMPLEX(DP) :: cp( ngwx, n ), phi( ngwx, n ) - COMPLEX(DP) :: bephi( nkbx, ldx ), qbecp( nkbx, ldx ) - COMPLEX(DP) :: rho( ldx, ldx ) - INTEGER :: desc( descla_siz_ ) - ! - INTEGER :: i, j, ipr, ipc, nr, nc, ir, ic - INTEGER :: root, nx - INTEGER :: desc_ip( descla_siz_ ) - INTEGER :: np( 2 ), coor_ip( 2 ) - - COMPLEX(DP), ALLOCATABLE :: rhop(:,:) - COMPLEX(DP), PARAMETER :: c_zero= CMPLX(0.d0,0.d0), c_one=CMPLX(1.d0,0.d0) - ! - ! - ! - ! - - IF( nss < 1 ) RETURN - - np(1) = desc( la_npr_ ) - np(2) = desc( la_npc_ ) - - nx = desc( nlax_ ) - - IF( desc( lambda_node_ ) > 0 ) THEN - IF( desc( nlax_ ) /= ldx ) & - CALL errore( " rhoset ", " inconsistent dimension ldx ", ldx ) - IF( nx /= ldx ) & - CALL errore( " rhoset ", " inconsistent dimension nx ", nx ) - END IF - - ALLOCATE( rhop( nx, nx ) ) - - rhop = CMPLX(0.d0,0.d0) - - DO ipc = 1, np(2) - DO ipr = 1, np(1) - - coor_ip(1) = ipr - 1 - coor_ip(2) = ipc - 1 - - CALL descla_init( desc_ip, desc( la_n_ ), desc( la_nx_ ), np, coor_ip, desc( la_comm_ ), 1 ) - - nr = desc_ip( nlar_ ) - nc = desc_ip( nlac_ ) - ir = desc_ip( ilar_ ) - ic = desc_ip( ilac_ ) - ! - CALL GRID2D_RANK( 'R', desc_ip( la_npr_ ), desc_ip( la_npc_ ), & - desc_ip( la_myr_ ), desc_ip( la_myc_ ), root ) - ! - root = root * leg_ortho - - CALL ZGEMM( 'C', 'N', nr, nc, ngw, c_one, phi( 1, ist + ir - 1 ), ngwx, & - cp( 1, ist + ic - 1 ), ngwx, c_zero, rhop, nx ) - ! - ! q = 0 components has weight 1.0 - ! -! IF (gstart == 2) THEN -! CALL DGER( nr, nc, -1.D0, phi(1,ist+ir-1), 2*ngwx, cp(1,ist+ic-1), 2*ngwx, rhop, nx ) -! END IF - - CALL mp_root_sum( rhop, rho, root, intra_image_comm ) - - END DO - END DO - - DEALLOCATE( rhop ) - - IF( desc( lambda_node_ ) > 0 ) THEN - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - ! - ! bephi is distributed among processor rows - ! qbephi is distributed among processor columns - ! tau is block distributed among the whole processor 2D grid - ! - ! - IF( nvb > 0 ) THEN - ! - ! rho(i,j) = rho(i,j) + SUM_b bephi( b, i ) * qbecp( b, j ) - ! - CALL ZGEMM( 'C', 'N', nr, nc, nkbus, c_one, bephi, nkbx, (qbecp), nkbx, c_one, rho, ldx ) - - END IF - - IF ( iprsta > 4 ) THEN - WRITE( stdout,*) - WRITE( stdout,'(26x,a)') ' rho ' - DO i=1,nr - WRITE( stdout,'(2((7f11.6)(4x)))') (rho(i,j),j=1,nc) - END DO - END IF - - END IF - ! - RETURN - END SUBROUTINE rhoset_cmplx - -!------------------------------------------------------------------------- - SUBROUTINE tauset_real( phi, ngwx, bephi, nkbx, qbephi, n, nss, ist, tau, ldx, desc ) -!----------------------------------------------------------------------- -! input: phi -! computes the matrix -! tau = = , where |phi> = s'|c0> -! where s=s(r(t+dt)) and s'=s(r(t)) -! routine makes use of c(-q)=c*(q) -! - USE kinds, ONLY: DP - USE cvan, ONLY: nvb - USE uspp, ONLY: nkbus - USE gvecw, ONLY: ngw - USE reciprocal_vectors, ONLY: gstart - USE mp, ONLY: mp_root_sum - USE control_flags, ONLY: iprsta - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm, leg_ortho - USE descriptors, ONLY: lambda_node_ , la_npc_ , la_npr_ , descla_siz_ , & - descla_init , la_comm_ , ilar_ , ilac_ , nlar_ , & - nlac_ , la_myr_ , la_myc_ , la_nx_ , la_n_ , nlax_ - USE parallel_toolkit, ONLY: dsqmsym -! - IMPLICIT NONE - ! - INTEGER :: nss, ist, ngwx, nkbx, n, ldx, nx - COMPLEX(DP) :: phi( ngwx, n ) - REAL(DP) :: bephi( nkbx, ldx ), qbephi( nkbx, ldx ) - REAL(DP) :: tau( ldx, ldx ) - INTEGER :: desc( descla_siz_ ) - ! - INTEGER :: i, j, ipr, ipc, nr, nc, ir, ic - INTEGER :: root - INTEGER :: desc_ip( descla_siz_ ) - INTEGER :: np( 2 ), coor_ip( 2 ) - - REAL(DP), ALLOCATABLE :: taup( :, : ) - ! - IF( nss < 1 ) RETURN - ! - ! get dimensions of the square processor grid - ! - np(1) = desc( la_npr_ ) - np(2) = desc( la_npc_ ) - ! - nx = desc( nlax_ ) - ! - IF( desc( lambda_node_ ) > 0 ) THEN - IF( desc( nlax_ ) /= ldx ) & - CALL errore( " tauset ", " inconsistent dimension ldx ", ldx ) - IF( nx /= ldx ) & - CALL errore( " tauset ", " inconsistent dimension nx ", nx ) - END IF - ! - ALLOCATE( taup( nx, nx ) ) - ! - taup = 0.0d0 - ! - ! loop on processors coordinates - ! - DO ipc = 1, np(2) - ! - DO ipr = 1, ipc ! np(1) use symmetry - - coor_ip(1) = ipr - 1 - coor_ip(2) = ipc - 1 - - CALL descla_init( desc_ip, desc( la_n_ ), desc( la_nx_ ), np, coor_ip, desc( la_comm_ ), 1 ) - - nr = desc_ip( nlar_ ) - nc = desc_ip( nlac_ ) - ir = desc_ip( ilar_ ) - ic = desc_ip( ilac_ ) - ! - CALL GRID2D_RANK( 'R', desc_ip( la_npr_ ), desc_ip( la_npc_ ), & - desc_ip( la_myr_ ), desc_ip( la_myc_ ), root ) - ! - root = root * leg_ortho - ! - ! All processors contribute to the tau block of processor (ipr,ipc) - ! with their own part of wavefunctions - ! - CALL DGEMM( 'T', 'N', nr, nc, 2*ngw, 2.0d0, phi( 1, ist + ir - 1 ), 2*ngwx, & - phi( 1, ist + ic - 1 ), 2*ngwx, 0.0d0, taup, nx ) - ! - ! q = 0 components has weight 1.0 - ! - IF (gstart == 2) THEN - CALL DGER( nr, nc, -1.D0, phi(1,ist+ir-1), 2*ngwx, phi(1,ist+ic-1), 2*ngwx, taup, nx ) - END IF - ! - CALL mp_root_sum( taup, tau, root, intra_image_comm ) - ! - END DO - ! - END DO - ! - DEALLOCATE( taup ) - ! - CALL dsqmsym( nss, tau, nx, desc ) - ! - IF( desc( lambda_node_ ) > 0 ) THEN - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - ! - ! bephi is distributed among processor rows - ! qbephi is distributed among processor columns - ! tau is block distributed among the whole processor 2D grid - ! - IF( nvb > 0 ) THEN - ! - CALL DGEMM( 'T', 'N', nr, nc, nkbus, 1.0d0, bephi, nkbx, qbephi, nkbx, 1.0d0, tau, ldx ) - ! - END IF - - IF( iprsta > 4 ) THEN - WRITE( stdout,*) - WRITE( stdout,'(26x,a)') ' tau ' - DO i=1,nr - WRITE( stdout,'(7f11.6)') (tau(i,j),j=1,nc) - END DO - ENDIF - ! - ENDIF - ! - RETURN - END SUBROUTINE tauset_real - -!------------------------------------------------------------------------- - SUBROUTINE tauset_cmplx( phi, ngwx, bephi, nkbx, qbephi, n, nss, ist, tau, ldx, desc ) -!----------------------------------------------------------------------- -! input: phi -! computes the matrix -! tau = = , where |phi> = s'|c0> -! where s=s(r(t+dt)) and s'=s(r(t)) -! routine makes use of c(-q)=c*(q) -! - USE kinds, ONLY: DP - USE cvan, ONLY: nvb - USE uspp, ONLY: nkbus - USE gvecw, ONLY: ngw - USE mp, ONLY: mp_root_sum - USE control_flags, ONLY: iprsta - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm, leg_ortho - USE descriptors, ONLY: lambda_node_ , la_npc_ , la_npr_ , descla_siz_ , & - descla_init , la_comm_ , ilar_ , ilac_ , nlar_ , & - nlac_ , la_myr_ , la_myc_ , la_nx_ , la_n_ , nlax_ - USE parallel_toolkit, ONLY: zsqmher -! - IMPLICIT NONE - ! - INTEGER :: nss, ist, ngwx, nkbx, n, ldx, nx - COMPLEX(DP) :: phi( ngwx, n ) - COMPLEX(DP) :: bephi( nkbx, ldx ), qbephi( nkbx, ldx ) - COMPLEX(DP) :: tau( ldx, ldx ) - INTEGER :: desc( descla_siz_ ) - ! - INTEGER :: i, j, ipr, ipc, nr, nc, ir, ic - INTEGER :: root - INTEGER :: desc_ip( descla_siz_ ) - INTEGER :: np( 2 ), coor_ip( 2 ) - - COMPLEX(DP), ALLOCATABLE :: taup( :, : ) - COMPLEX(DP), PARAMETER :: c_one=CMPLX(1.d0,0.d0), c_zero=CMPLX(0.d0,0.d0) - ! - IF( nss < 1 ) RETURN - ! - ! get dimensions of the square processor grid - ! - np(1) = desc( la_npr_ ) - np(2) = desc( la_npc_ ) - ! - nx = desc( nlax_ ) - ! - IF( desc( lambda_node_ ) > 0 ) THEN - IF( desc( nlax_ ) /= ldx ) & - CALL errore( " tauset ", " inconsistent dimension ldx ", ldx ) - IF( nx /= ldx ) & - CALL errore( " tauset ", " inconsistent dimension nx ", nx ) - END IF - ! - ALLOCATE( taup( nx, nx ) ) - ! - taup = CMPLX(0.0d0, 0.d0) - ! - ! loop on processors coordinates - ! - DO ipc = 1, np(2) - ! - DO ipr = 1, ipc ! np(1) use symmetry - - coor_ip(1) = ipr - 1 - coor_ip(2) = ipc - 1 - - CALL descla_init( desc_ip, desc( la_n_ ), desc( la_nx_ ), np, coor_ip, desc( la_comm_ ), 1 ) - - nr = desc_ip( nlar_ ) - nc = desc_ip( nlac_ ) - ir = desc_ip( ilar_ ) - ic = desc_ip( ilac_ ) - ! - CALL GRID2D_RANK( 'R', desc_ip( la_npr_ ), desc_ip( la_npc_ ), & - desc_ip( la_myr_ ), desc_ip( la_myc_ ), root ) - ! - root = root * leg_ortho - ! - ! All processors contribute to the tau block of processor (ipr,ipc) - ! with their own part of wavefunctions - ! - CALL ZGEMM( 'C', 'N', nr, nc, ngw, c_one, phi( 1, ist + ir - 1 ), ngwx, & - phi( 1, ist + ic - 1 ), ngwx, c_zero, taup, nx ) - ! - ! q = 0 components has weight 1.0 - ! -! IF (gstart == 2) THEN -! CALL DGER( nr, nc, -1.D0, phi(1,ist+ir-1), 2*ngwx, phi(1,ist+ic-1), 2*ngwx, taup, nx ) -! END IF - ! - CALL mp_root_sum( taup, tau, root, intra_image_comm ) - ! - END DO - ! - END DO - ! - DEALLOCATE( taup ) - ! - CALL zsqmher( nss, tau, nx, desc ) -! CALL dsqmsym( nss, tau, nx, desc ) - ! - IF( desc( lambda_node_ ) > 0 ) THEN - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - ! - ! bephi is distributed among processor rows - ! qbephi is distributed among processor columns - ! tau is block distributed among the whole processor 2D grid - ! - IF( nvb > 0 ) THEN - ! - CALL ZGEMM( 'C', 'N', nr, nc, nkbus, c_one, bephi, nkbx, qbephi, nkbx, c_one, tau, ldx ) - ! - END IF - - IF( iprsta > 4 ) THEN - WRITE( stdout,*) - WRITE( stdout,'(26x,a)') ' tau ' - DO i=1,nr - WRITE( stdout,'(7(2((f11.6)(4x))))') (tau(i,j),j=1,nc) - END DO - ENDIF - ! - ENDIF - ! - RETURN - END SUBROUTINE tauset_cmplx - -! -!------------------------------------------------------------------------- - SUBROUTINE updatc_real( ccc, n, x0, nx0, phi, ngwx, bephi, nkbx, becp, bec, cp, nss, istart, desc ) -!----------------------------------------------------------------------- -! - ! input ccc : dt**2/emass OR 1.0d0 demending on ortho - ! input x0 : converged lambdas from ortho-loop (unchanged in output) - ! input cp : non-orthonormal cp=c0+dh/dc*ccc - ! input bec : - ! input phi - ! output cp : orthonormal cp=cp+lambda*phi - ! output bec: bec=becp+lambda*bephi - ! - USE kinds, ONLY: DP - USE ions_base, ONLY: na - USE io_global, ONLY: stdout - USE cvan, ONLY: nvb, ish - USE uspp, ONLY: nkb, nkbus - USE uspp_param, ONLY: nh - USE gvecw, ONLY: ngw - USE control_flags, ONLY: iprsta - USE mp, ONLY: mp_sum, mp_bcast - USE mp_global, ONLY: intra_image_comm, leg_ortho, me_image - USE descriptors, ONLY: nlar_ , nlac_ , ilar_ , ilac_ , lambda_node_ , descla_siz_ , la_comm_ , & - la_npc_ , la_npr_ , nlax_ , la_n_ , la_nx_ , la_myr_ , la_myc_ , & - descla_init -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: n, nx0, ngwx, nkbx, istart, nss - INTEGER, INTENT(IN) :: desc( descla_siz_ ) - COMPLEX(DP) :: cp( ngwx, n ), phi( ngwx, n ) - REAL(DP), INTENT(IN) :: ccc - REAL(DP) :: bec( nkbx, n ), x0( nx0, nx0 ) - REAL(DP) :: bephi( :, : ), becp( nkbx, n ) - - ! local variables - - INTEGER :: i, is, iv, ia, inl, nr, nc, ir, ic - REAL(DP), ALLOCATABLE :: wtemp(:,:) - REAL(DP), ALLOCATABLE :: xd(:,:) - REAL(DP), ALLOCATABLE :: bephi_tmp(:,:) - INTEGER :: ipr, ipc, nx, root - INTEGER :: np( 2 ), coor_ip( 2 ) - INTEGER :: desc_ip( descla_siz_ ) - ! - ! lagrange multipliers - ! - IF( nss < 1 ) RETURN - ! - IF( desc( lambda_node_ ) > 0 ) THEN - IF( nx0 /= desc( nlax_ ) ) & - CALL errore( " updatc ", " inconsistent dimension nx0 ", nx0 ) - END IF - ! - ! size of the local block - ! - nx = desc( nlax_ ) - ! - np(1) = desc( la_npr_ ) - np(2) = desc( la_npc_ ) - ! - CALL start_clock( 'updatc' ) - - ALLOCATE( xd( nx, nx ) ) - - IF( nvb > 0 )THEN - ALLOCATE( wtemp( nx, nkb ) ) - ALLOCATE( bephi_tmp( nkbx, nx ) ) - DO i = 1, nss - DO inl = 1, nkbus - bec( inl, i + istart - 1 ) = 0.0d0 - END DO - END DO - END IF - - - DO ipc = 1, np(2) - ! - IF( nvb > 0 )THEN - ! - ! For the inner loop we need the block of bebhi( :, ic : ic + nc - 1 ) - ! this is the same of block bephi( :, ir : ir + nr - 1 ) on processor - ! with coords ipr == ipc - ! - ! get the right processor owning the block of bephi - ! - CALL GRID2D_RANK( 'R', np(1), np(2), ipc-1, ipc-1, root ) - root = root * leg_ortho - ! - ! broadcast the block to all processors - ! - IF( me_image == root ) bephi_tmp = bephi - CALL mp_bcast( bephi_tmp, root, intra_image_comm ) - ! - END IF - - DO ipr = 1, np(1) - ! - coor_ip(1) = ipr - 1 - coor_ip(2) = ipc - 1 - - CALL descla_init( desc_ip, desc( la_n_ ), desc( la_nx_ ), np, coor_ip, desc( la_comm_ ), 1 ) - - nr = desc_ip( nlar_ ) - nc = desc_ip( nlac_ ) - ir = desc_ip( ilar_ ) - ic = desc_ip( ilac_ ) - ! - CALL GRID2D_RANK( 'R', desc_ip( la_npr_ ), desc_ip( la_npc_ ), & - desc_ip( la_myr_ ), desc_ip( la_myc_ ), root ) - - root = root * leg_ortho - - IF( desc( la_myr_ ) == ipr - 1 .AND. desc( la_myc_ ) == ipc - 1 .AND. desc( lambda_node_ ) > 0 ) THEN - xd = x0 * ccc - END IF - - CALL mp_bcast( xd, root, intra_image_comm ) - ! - CALL DGEMM( 'N', 'N', 2*ngw, nc, nr, 1.0d0, phi(1,istart+ir-1), 2*ngwx, & - xd, nx, 1.0d0, cp(1,istart+ic-1), 2*ngwx ) - - IF( nvb > 0 )THEN - - ! updating of the - ! - ! bec of vanderbilt species are updated - ! - CALL DGEMM( 'N', 'T', nr, nkbus, nc, 1.0d0, xd, nx, bephi_tmp, nkbx, 0.0d0, wtemp, nx ) - ! - ! here nr and ir are still valid, since they are the same for all procs in the same row - ! - DO i = 1, nr - DO inl = 1, nkbus - bec( inl, i + istart + ir - 2 ) = bec( inl, i + istart + ir - 2 ) + wtemp( i, inl ) - END DO - END DO - ! - END IF - - END DO - ! - END DO - - IF( nvb > 0 )THEN - DEALLOCATE( wtemp ) - DEALLOCATE( bephi_tmp ) - DO i = istart, istart + nss - 1 - DO inl = 1, nkbus - bec( inl, i ) = bec( inl, i ) + becp( inl, i ) - END DO - END DO - END IF -! - IF ( iprsta > 2 ) THEN - WRITE( stdout,*) - DO is = 1, nvb - IF( nvb > 1 ) THEN - WRITE( stdout,'(33x,a,i4)') ' updatc: bec (is)',is - WRITE( stdout,'(8f9.4)') & - & ((bec(ish(is)+(iv-1)*na(is)+1,i+istart-1),iv=1,nh(is)),i=1,nss) - ELSE - DO ia=1,na(is) - WRITE( stdout,'(33x,a,i4)') ' updatc: bec (ia)',ia - WRITE( stdout,'(8f9.4)') & - & ((bec(ish(is)+(iv-1)*na(is)+ia,i+istart-1),iv=1,nh(is)),i=1,nss) - END DO - END IF - WRITE( stdout,*) - END DO - ENDIF - ! - DEALLOCATE( xd ) - ! - CALL stop_clock( 'updatc' ) - ! - RETURN - END SUBROUTINE updatc_real - -!------------------------------------------------------------------------- - SUBROUTINE updatc_cmplx( ccc, n, x0, nx0, phi, ngwx, bephi, nkbx, becp, bec, cp, nss, istart, desc ) -!----------------------------------------------------------------------- -! - ! input ccc : dt**2/emass OR 1.0d0 demending on ortho - ! input x0 : converged lambdas from ortho-loop (unchanged in output) - ! input cp : non-orthonormal cp=c0+dh/dc*ccc - ! input bec : - ! input phi - ! output cp : orthonormal cp=cp+lambda*phi - ! output bec: bec=becp+lambda*bephi - ! - USE kinds, ONLY: DP - USE ions_base, ONLY: na - USE io_global, ONLY: stdout - USE cvan, ONLY: nvb, ish - USE uspp, ONLY: nkb, nkbus - USE uspp_param, ONLY: nh - USE gvecw, ONLY: ngw - USE control_flags, ONLY: iprsta - USE mp, ONLY: mp_sum, mp_bcast - USE mp_global, ONLY: intra_image_comm, leg_ortho, me_image - USE descriptors, ONLY: nlar_ , nlac_ , ilar_ , ilac_ , lambda_node_ , descla_siz_ , la_comm_ , & - la_npc_ , la_npr_ , nlax_ , la_n_ , la_nx_ , la_myr_ , la_myc_ , & - descla_init -! - IMPLICIT NONE -! - INTEGER, INTENT(IN) :: n, nx0, ngwx, nkbx, istart, nss - INTEGER, INTENT(IN) :: desc( descla_siz_ ) - COMPLEX(DP) :: cp( ngwx, n ), phi( ngwx, n ) - REAL(DP), INTENT(IN) :: ccc - COMPLEX(DP) :: bec( nkbx, n ), x0( nx0, nx0 ) - COMPLEX(DP) :: bephi( :, : ), becp( nkbx, n ) - - ! local variables - - INTEGER :: i, is, iv, ia, inl, nr, nc, ir, ic - COMPLEX(DP), ALLOCATABLE :: wtemp(:,:) - COMPLEX(DP), ALLOCATABLE :: xd(:,:) - COMPLEX(DP), ALLOCATABLE :: bephi_tmp(:,:) - INTEGER :: ipr, ipc, nx, root - INTEGER :: np( 2 ), coor_ip( 2 ) - INTEGER :: desc_ip( descla_siz_ ) - COMPLEX(DP), PARAMETER :: c_one=CMPLX(1.d0,0.d0), c_zero=CMPLX(0.d0,0.d0) - ! - ! lagrange multipliers - ! - IF( nss < 1 ) RETURN - ! - IF( desc( lambda_node_ ) > 0 ) THEN - IF( nx0 /= desc( nlax_ ) ) & - CALL errore( " updatc ", " inconsistent dimension nx0 ", nx0 ) - END IF - ! - ! size of the local block - ! - nx = desc( nlax_ ) - ! - np(1) = desc( la_npr_ ) - np(2) = desc( la_npc_ ) - ! - CALL start_clock( 'updatc' ) - - ALLOCATE( xd( nx, nx ) ) - - IF( nvb > 0 )THEN - ALLOCATE( wtemp( nx, nkb ) ) - ALLOCATE( bephi_tmp( nkbx, nx ) ) - DO i = 1, nss - DO inl = 1, nkbus - bec( inl, i + istart - 1 ) = 0.0d0 - END DO - END DO - END IF - - - DO ipc = 1, np(2) - ! - IF( nvb > 0 )THEN - ! - ! For the inner loop we need the block of bebhi( :, ic : ic + nc - 1 ) - ! this is the same of block bephi( :, ir : ir + nr - 1 ) on processor - ! with coords ipr == ipc - ! - ! get the right processor owning the block of bephi - ! - CALL GRID2D_RANK( 'R', np(1), np(2), ipc-1, ipc-1, root ) - root = root * leg_ortho - ! - ! broadcast the block to all processors - ! - IF( me_image == root ) bephi_tmp = bephi - CALL mp_bcast( bephi_tmp, root, intra_image_comm ) - ! - END IF - - DO ipr = 1, np(1) - ! - coor_ip(1) = ipr - 1 - coor_ip(2) = ipc - 1 - - CALL descla_init( desc_ip, desc( la_n_ ), desc( la_nx_ ), np, coor_ip, desc( la_comm_ ), 1 ) - - nr = desc_ip( nlar_ ) - nc = desc_ip( nlac_ ) - ir = desc_ip( ilar_ ) - ic = desc_ip( ilac_ ) - ! - CALL GRID2D_RANK( 'R', desc_ip( la_npr_ ), desc_ip( la_npc_ ), & - desc_ip( la_myr_ ), desc_ip( la_myc_ ), root ) - - root = root * leg_ortho - - IF( desc( la_myr_ ) == ipr - 1 .AND. desc( la_myc_ ) == ipc - 1 .AND. desc( lambda_node_ ) > 0 ) THEN - xd = x0 * ccc - END IF - - CALL mp_bcast( xd, root, intra_image_comm ) - ! - CALL ZGEMM( 'N', 'N', ngw, nc, nr, c_one, phi(1,istart+ir-1), ngwx, & - xd, nx, c_one, cp(1,istart+ic-1), ngwx ) - - IF( nvb > 0 )THEN - - ! updating of the - ! - ! bec of vanderbilt species are updated - ! - CALL ZGEMM( 'N', 'C', nr, nkbus, nc, c_one, xd, nx, bephi_tmp, nkbx, c_zero, wtemp, nx ) - ! - ! here nr and ir are still valid, since they are the same for all procs in the same row - ! - DO i = 1, nr - DO inl = 1, nkbus - bec( inl, i + istart + ir - 2 ) = bec( inl, i + istart + ir - 2 ) + CONJG(wtemp( i, inl )) - END DO - END DO - ! - END IF - - END DO - ! - END DO - - IF( nvb > 0 )THEN - DEALLOCATE( wtemp ) - DEALLOCATE( bephi_tmp ) - DO i = istart, istart + nss - 1 - DO inl = 1, nkbus - bec( inl, i ) = bec( inl, i ) + becp( inl, i ) - END DO - END DO - END IF -! - IF ( iprsta > 2 ) THEN - WRITE( stdout,*) - DO is = 1, nvb - IF( nvb > 1 ) THEN - WRITE( stdout,'(33x,a,i4)') ' updatc: bec (is)',is - WRITE( stdout,'(8(2((f9.4)(4x))))') & - & ((bec(ish(is)+(iv-1)*na(is)+1,i+istart-1),iv=1,nh(is)),i=1,nss) - ELSE - DO ia=1,na(is) - WRITE( stdout,'(33x,a,i4)') ' updatc: bec (ia)',ia - WRITE( stdout,'(8(2((f9.4)(4x))))') & - & ((bec(ish(is)+(iv-1)*na(is)+ia,i+istart-1),iv=1,nh(is)),i=1,nss) - END DO - END IF - WRITE( stdout,*) - END DO - ENDIF - ! - DEALLOCATE( xd ) - ! - CALL stop_clock( 'updatc' ) - ! - RETURN - END SUBROUTINE updatc_cmplx - -!------------------------------------------------------------------------- - SUBROUTINE calphi_new( c0, ngwx, bec, nkbx, betae, phi, n, lgam2, ema0bg) -!----------------------------------------------------------------------- -! input: c0 (orthonormal with s(r(t)), bec=, betae=|beta> -! computes the matrix phi (with the old positions) -! where |phi> = s'|c0> = |c0> + sum q_ij |i> -! where s'=s(r(t)) -! - USE kinds, ONLY: DP - USE ions_base, ONLY: na - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm - USE cvan, ONLY: ish, nvb - USE uspp_param, ONLY: nh - USE uspp, ONLY: nkbus, qq - USE gvecw, ONLY: ngw - USE constants, ONLY: pi, fpi - USE control_flags, ONLY: iprsta - USE mp, ONLY: mp_sum - USE twin_types !added:giovanni -! - IMPLICIT NONE - - INTEGER, INTENT(IN) :: ngwx, nkbx, n - COMPLEX(DP) :: c0( ngwx, n ), phi( ngwx, n ), betae( ngwx, nkbx ) - REAL(DP) :: emtot!, bec( nkbx, n ), emtot - type(twin_matrix) :: bec !added:giovanni:debug - REAL(DP), OPTIONAL :: ema0bg( ngwx ) - LOGICAL :: lgam2 - ! local variables - ! - INTEGER :: is, iv, jv, ia, inl, jnl, i, j - REAL(DP), ALLOCATABLE :: qtemp( : , : ) - COMPLEX(DP), ALLOCATABLE :: qtemp_c( : , : ) - COMPLEX(DP), parameter :: c_one=CMPLX(1.d0,0.d0), c_zero=CMPLX(0.d0,0.d0) - REAL(DP) :: qqf - COMPLEX(DP) :: qqf_c - LOGICAL :: lgam - ! - lgam=lgam2!.and..not.bec%iscmplx - ! -! write(6,*) "debug_betae", betae -! write(6,*) "debug_bec", bec%cvec - IF( n < 1 ) RETURN - ! - CALL start_clock( 'calphi' ) - - ! - IF ( nvb > 0 ) THEN - - IF(lgam) THEN - ALLOCATE(qtemp( nkbus, n )) - qtemp(:,:) = 0.d0 - ELSE - ALLOCATE(qtemp_c( nkbus, n )) - qtemp_c(:,:) = CMPLX(0.d0, 0.d0) - ENDIF - - IF(lgam) THEN - DO is=1,nvb - DO iv=1,nh(is) - inl = ish(is)+(iv-1)*na(is) - DO jv=1,nh(is) - jnl = ish(is)+(jv-1)*na(is) - IF(ABS(qq(iv,jv,is)) > 1.d-5) THEN - qqf = qq(iv,jv,is) - DO i=1,n - CALL daxpy(na(is), qqf, bec%rvec(jnl+1,i),1,qtemp(inl+1,i),1) - END DO - ENDIF - END DO - END DO - END DO - ! - CALL DGEMM ( 'N', 'N', 2*ngw, n, nkbus, 1.0d0, betae, & - 2*ngwx, qtemp, nkbus, 0.0d0, phi, 2*ngwx ) - DEALLOCATE(qtemp) - - ELSE !IF(bec%iscmplx) THEN - DO is=1,nvb - DO iv=1,nh(is) - inl = ish(is)+(iv-1)*na(is) - DO jv=1,nh(is) - jnl = ish(is)+(jv-1)*na(is) - IF(ABS(qq(iv,jv,is)) > 1.d-5) THEN - qqf_c = CMPLX(qq(iv,jv,is), 0.d0) - DO i=1,n - CALL ZAXPY (na(is), qqf_c, bec%cvec(jnl+1,i),1,qtemp_c(inl+1,i),1) - END DO - ENDIF - END DO - END DO - END DO - ! -! write(6,*) "debug_qtemp", lbound(qtemp_c), ubound(qtemp_c), qtemp_c - CALL ZGEMM ( 'N', 'N', ngw, n, nkbus, c_one, betae, & - ngwx, qtemp_c, nkbus, c_zero, phi, ngwx) - - DEALLOCATE(qtemp_c) - - ENDIF - - ELSE - - phi = CMPLX(0.d0, 0.d0) - - END IF -! - IF( PRESENT( ema0bg ) ) THEN -!$omp parallel do default(shared), private(i) - DO j=1,n - DO i=1,ngw - phi(i,j)=(phi(i,j)+c0(i,j))*ema0bg(i) - END DO - END DO -!$omp end parallel do - ELSE -!$omp parallel do default(shared), private(i) - DO j=1,n - DO i=1,ngw - phi(i,j)=phi(i,j)+c0(i,j) - END DO - END DO -!$omp end parallel do - END IF - - ! - - IF(iprsta > 2) THEN - emtot=0.0d0 - IF( PRESENT( ema0bg ) ) THEN - DO j=1,n - DO i=1,ngw - emtot=emtot +2.0d0*DBLE(phi(i,j)*CONJG(c0(i,j)))*ema0bg(i)**(-2.0d0) - END DO - END DO - ELSE - DO j=1,n - DO i=1,ngw - emtot=emtot +2.0d0*DBLE(phi(i,j)*CONJG(c0(i,j))) - END DO - END DO - END IF - emtot=emtot/n - - CALL mp_sum( emtot, intra_image_comm ) - - WRITE( stdout,*) 'in calphi sqrt(emtot)=',SQRT(emtot) - WRITE( stdout,*) - DO is = 1, nvb - IF( nvb > 1 ) THEN - WRITE( stdout,'(33x,a,i4)') ' calphi: bec (is)',is - IF(.not.bec%iscmplx) THEN - WRITE( stdout,'(8f9.4)') & - & ((bec%rvec(ish(is)+(iv-1)*na(is)+1,i),iv=1,nh(is)),i=1,n) - ELSE - WRITE( stdout,'(8(2((f9.4)(3x))))') & - & ((bec%cvec(ish(is)+(iv-1)*na(is)+1,i),iv=1,nh(is)),i=1,n) - ENDIF - ELSE - IF(.not.bec%iscmplx) THEN - DO ia=1,na(is) - WRITE( stdout,'(33x,a,i4)') ' calphi: bec (ia)',ia - WRITE( stdout,'(8f9.4)') & - & ((bec%rvec(ish(is)+(iv-1)*na(is)+ia,i),iv=1,nh(is)),i=1,n) - END DO - ELSE - DO ia=1,na(is) - WRITE( stdout,'(33x,a,i4)') ' calphi: bec (ia)',ia - WRITE( stdout,'(8(2((f9.4)(3x))))') & - & ((bec%cvec(ish(is)+(iv-1)*na(is)+ia,i),iv=1,nh(is)),i=1,n) - END DO - ENDIF - END IF - END DO - ENDIF - - CALL stop_clock( 'calphi' ) -! -! write(6,*) "debug phi", phi -! stop - RETURN - END SUBROUTINE calphi_new - -!------------------------------------------------------------------------- - SUBROUTINE calphi_old( c0, ngwx, bec, nkbx, betae, phi, n, ema0bg ) -!----------------------------------------------------------------------- -! input: c0 (orthonormal with s(r(t)), bec=, betae=|beta> -! computes the matrix phi (with the old positions) -! where |phi> = s'|c0> = |c0> + sum q_ij |i> -! where s'=s(r(t)) -! - USE kinds, ONLY: DP - USE ions_base, ONLY: na - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm - USE cvan, ONLY: ish, nvb - USE uspp_param, ONLY: nh - USE uspp, ONLY: nkbus, qq - USE gvecw, ONLY: ngw - USE constants, ONLY: pi, fpi - USE control_flags, ONLY: iprsta - USE mp, ONLY: mp_sum -! - IMPLICIT NONE - - INTEGER, INTENT(IN) :: ngwx, nkbx, n - COMPLEX(DP) :: c0( ngwx, n ), phi( ngwx, n ), betae( ngwx, nkbx ) - REAL(DP) :: bec( nkbx, n ), emtot - REAL(DP), OPTIONAL :: ema0bg( ngwx ) - - ! local variables - ! - INTEGER :: is, iv, jv, ia, inl, jnl, i, j - REAL(DP), ALLOCATABLE :: qtemp( : , : ) - REAL(DP) :: qqf -! - IF( n < 1 ) RETURN - ! - CALL start_clock( 'calphi' ) - - ! - IF ( nvb > 0 ) THEN - - ALLOCATE( qtemp( nkbus, n ) ) - - qtemp (:,:) = 0.d0 - DO is=1,nvb - DO iv=1,nh(is) - inl = ish(is)+(iv-1)*na(is) - DO jv=1,nh(is) - jnl = ish(is)+(jv-1)*na(is) - IF(ABS(qq(iv,jv,is)) > 1.d-5) THEN - qqf = qq(iv,jv,is) - DO i=1,n - CALL daxpy( na(is), qqf, bec(jnl+1,i),1,qtemp(inl+1,i), 1 ) - END DO - ENDIF - END DO - END DO - END DO -! - CALL DGEMM ( 'N', 'N', 2*ngw, n, nkbus, 1.0d0, betae, & - 2*ngwx, qtemp, nkbus, 0.0d0, phi, 2*ngwx ) - - DEALLOCATE( qtemp ) - - ELSE - - phi = (0.d0, 0.d0) - - END IF -! - IF( PRESENT( ema0bg ) ) THEN -!$omp parallel do default(shared), private(i) - DO j=1,n - DO i=1,ngw - phi(i,j)=(phi(i,j)+c0(i,j))*ema0bg(i) - END DO - END DO -!$omp end parallel do - ELSE -!$omp parallel do default(shared), private(i) - DO j=1,n - DO i=1,ngw - phi(i,j)=phi(i,j)+c0(i,j) - END DO - END DO -!$omp end parallel do - END IF - - ! - - IF(iprsta > 2) THEN - emtot=0.0d0 - IF( PRESENT( ema0bg ) ) THEN - DO j=1,n - DO i=1,ngw - emtot=emtot +2.0d0*DBLE(phi(i,j)*CONJG(c0(i,j)))*ema0bg(i)**(-2.0d0) - END DO - END DO - ELSE - DO j=1,n - DO i=1,ngw - emtot=emtot +2.0d0*DBLE(phi(i,j)*CONJG(c0(i,j))) - END DO - END DO - END IF - emtot=emtot/n - - CALL mp_sum( emtot, intra_image_comm ) - - WRITE( stdout,*) 'in calphi sqrt(emtot)=',SQRT(emtot) - WRITE( stdout,*) - DO is = 1, nvb - IF( nvb > 1 ) THEN - WRITE( stdout,'(33x,a,i4)') ' calphi: bec (is)',is - WRITE( stdout,'(8f9.4)') & - & ((bec(ish(is)+(iv-1)*na(is)+1,i),iv=1,nh(is)),i=1,n) - ELSE - DO ia=1,na(is) - WRITE( stdout,'(33x,a,i4)') ' calphi: bec (ia)',ia - WRITE( stdout,'(8f9.4)') & - & ((bec(ish(is)+(iv-1)*na(is)+ia,i),iv=1,nh(is)),i=1,n) - END DO - END IF - END DO - ENDIF - - - CALL stop_clock( 'calphi' ) -! - RETURN - END SUBROUTINE calphi_old - - END MODULE orthogonalize_base diff --git a/quantum_espresso/kcp/CPV/ortho_check.f90 b/quantum_espresso/kcp/CPV/ortho_check.f90 deleted file mode 100644 index 8e1eb39e6..000000000 --- a/quantum_espresso/kcp/CPV/ortho_check.f90 +++ /dev/null @@ -1,94 +0,0 @@ -! -! Copyright (C) 2005 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!------------------------------------------------------------------------- -SUBROUTINE ortho_check_cmplx(c0_emp, lgam) - !----------------------------------------------------------------------- - ! - ! ... This subroutine checks the projectability of each empty - ! ... wavefunction on the occupied manifold (for complex wfc) - ! - USE io_global, ONLY: stdout - USE kinds, ONLY: DP - USE wavefunctions_module, ONLY: c0 - USE gvecw, ONLY: ngw - USE electrons_base, ONLY: nbspx, nspin - USE electrons_module, ONLY: nbsp_emp - USE mp_global, ONLY: intra_pool_comm - USE mp, ONLY: mp_sum - USE reciprocal_vectors, ONLY: gstart - ! - ! - IMPLICIT NONE - ! - COMPLEX(DP), INTENT(IN) :: c0_emp(:, :) - LOGICAL, INTENT(IN) :: lgam - ! - INTEGER :: m, n - REAL(DP) :: proj, proj_tot - COMPLEX(DP) :: g0comp(nbspx) - ! - COMPLEX(DP), EXTERNAL :: ZDOTC - ! - ! - WRITE (stdout, '(/, A)') " -----------------------------------------" - WRITE (stdout, '(A)') " Projectability EMP states on OCC manifold" - WRITE (stdout, '(A, /)') " -----------------------------------------" - ! - ! - proj_tot = 0.D0 - ! - ! - DO m = 1, nbsp_emp - ! - proj = 0.D0 - ! - DO n = 1, nbspx - ! - proj = proj + ZDOTC(ngw, c0(:, n), 1, c0_emp(:, m), 1) - ! - END DO - ! - ! when gamma-trick is used ... - ! - IF (lgam) THEN - ! - ! ... account for G<0 vectors - ! - proj = proj*2 - ! - IF (gstart == 2) THEN - ! - ! ... and remove double counting for G=0 component - ! - g0comp(:) = CONJG(c0(1, :))*c0_emp(1, m) - proj = proj - SUM(g0comp(:)) - ! - END IF - ! - END IF - ! - CALL mp_sum(proj, intra_pool_comm) - WRITE (stdout, 100) m, proj - proj_tot = proj_tot + proj - ! - END DO - ! - ! - ! ... normalize proj_tot to 1 - ! - proj_tot = proj_tot/nbsp_emp - WRITE (stdout, 101) proj_tot - ! - ! -100 FORMAT(4X, "orbital # ", I4, " : ", F12.8) -101 FORMAT(/, 6X, "Total projectability = ", F12.8,/) - ! - ! -END SUBROUTINE ortho_check_cmplx - diff --git a/quantum_espresso/kcp/CPV/para.f90 b/quantum_espresso/kcp/CPV/para.f90 deleted file mode 100644 index f977728e0..000000000 --- a/quantum_espresso/kcp/CPV/para.f90 +++ /dev/null @@ -1,238 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - -! nproc: number of processors -! me: number of this processor ( starting from one ) -! -! parallel fft information for the dense grid -! -! npp: number of plane per processor -! n3: n3(me)+1 = first plane on proc. me -! ncp: number of (density) columns per proc -! ncp0: starting column for each processor -! ncplane: number of columns in a plane -! nct: total number of non-zero columns -! nnr_: local fft data size -! ipc: index saying which proc owns columns in a plane -! icpl: index relating columns and pos. in the plane -! -! n3 -> dfftp%ipp -! ncplane -> dfftp%nnp -! ncp -> dfftp%nsp -! ncp0 -> dfftp%iss -! npp -> dfftp%npp -! ipc -> dfftp%isind -! icpl -> dfftp%ismap -! nnr_ -> dfftp%nnr -! -! integer maxproc, ncplanex -! parameter (maxproc=64, ncplanex=37000) -! -! integer npp(maxproc), n3(maxproc), ncp(maxproc), ncp0(maxproc), & -! ncplane, nct, nnr_, ipc(ncplanex), icpl(ncplanex) -! -! parallel fft information for the smooth mesh -! -! npps: number of plane per processor -! ncps: number of (density) columns per proc -! ncpw: number of (wfs) columns per processor -! ncps0: starting column for each processor -! ncplanes:number of columns in a plane (smooth) -! ncts: total number of non-zero columns -! nnrs_: local fft data size -! ipcs: saying which proc owns columns in a plane -! icpls: index relating columns and pos. in the plane -! -! ncpw -> dffts%ncpw -! n3s -> dffts%ipp -! ncplanes -> dffts%nnp -! ncps -> dffts%nsp -! ncps0 -> dffts%iss -! npps -> dffts%npp -! ipcs -> dffts%isind -! icpls -> dffts%ismap -! nnrs_ -> dffts%nnr -! -! -! -!---------------------------------------------------------------------- - SUBROUTINE read_rho( nspin, rhor ) -!---------------------------------------------------------------------- - ! - ! read rhor(nnr,nspin) from file - ! - use kinds, ONLY: DP - USE fft_base, ONLY: dfftp - use grid_dimensions, ONLY: nr1, nr2, nr3, nr1x, nr2x, nnrx - use xml_io_base, ONLY: read_rho_xml, restart_dir - use control_flags, ONLY: ndr - USE io_files, ONLY: outdir - ! - implicit none - ! - integer :: nspin - real(DP) :: rhor( nnrx, nspin ) - ! - CHARACTER(LEN=256) :: filename - ! - filename = restart_dir( outdir, ndr ) - ! - filename = TRIM(filename) // '/' // 'charge-density' - ! - CALL read_rho_xml( filename, rhor(:,1), nr1, nr2, nr3, nr1x, nr2x, dfftp%ipp, dfftp%npp ) - ! - IF( nspin == 2 ) THEN - ! - filename = TRIM(filename) // '/' // 'spin-polarization' - ! - CALL read_rho_xml( filename, rhor(:,2), nr1, nr2, nr3, nr1x, nr2x, dfftp%ipp, dfftp%npp ) - ! - ! Convert rho_tot, spin_pol back to rho_up, rho_down - ! - rhor(:,2) = 0.5d0 * ( rhor(:,1) - rhor(:,2) ) - rhor(:,1) = rhor(:,1) - rhor(:,2) - ! - END IF - - RETURN - END SUBROUTINE read_rho -! -!---------------------------------------------------------------------- - subroutine old_write_rho( rhounit, nspin, rhor, a1, a2, a3 ) -!---------------------------------------------------------------------- -! -! collect rhor(nnrx,nspin) on first node and write to file -! - use parallel_include - use grid_dimensions, only : nr1x, nr2x, nr3x, nnrx - USE mp_global, ONLY : nproc_image, intra_image_comm - USE io_global, ONLY : ionode, ionode_id - USE fft_base, ONLY : dfftp - USE mp, ONLY : mp_barrier, mp_gather - USE constants, ONLY : bohr_radius_angs - ! - implicit none - ! - integer, INTENT(IN) :: rhounit, nspin - real(kind=DP), INTENT(IN) :: rhor( nnrx, nspin ) - real(kind=DP), INTENT(IN) :: a1(3), a2(3), a3(3) - ! - integer :: ir, is - - integer :: proc - integer, allocatable:: displs(:), recvcount(:) - real(kind=DP), allocatable:: rhodist(:) - ! - IF ( ionode ) THEN - ! - OPEN( unit = rhounit, form = 'UNFORMATTED', status = 'UNKNOWN' ) - ! - WRITE( rhounit, '("3 2")' ) - ! - WRITE( rhounit, '(3(2X,I3))' ) nr1x, nr2x, nr3x - ! - WRITE( rhounit, '(3(2X,"0",2X,F16.10))' ) & - ( DBLE( nr1x - 1 ) / DBLE( nr1x ) ) * a1(1) * bohr_radius_angs, & - ( DBLE( nr2x - 1 ) / DBLE( nr2x ) ) * a2(2) * bohr_radius_angs, & - ( DBLE( nr3x - 1 ) / DBLE( nr3x ) ) * a3(3) * bohr_radius_angs - ! - END IF - ! - COLLECT_CHARGE: IF( nproc_image > 1 ) THEN - ! - ALLOCATE( displs( nproc_image ), recvcount( nproc_image ) ) - ! - if (ionode) allocate(rhodist(nr1x*nr2x*nr3x)) - ! - do proc=1,nproc_image - recvcount(proc) = dfftp%nnp * ( dfftp%npp(proc) ) - if (proc.eq.1) then - displs(proc)=0 - else - displs(proc)=displs(proc-1) + recvcount(proc-1) - end if - end do - ! - do is=1,nspin - ! - ! gather the charge density on the first node - ! - call mp_barrier() - call mp_gather( rhor(:,is), rhodist, recvcount, displs, ionode_id, intra_image_comm ) - ! - ! write the charge density to unit "rhounit" from first node only - ! - if ( ionode ) & - write( rhounit, '(F12.7)' ) (rhodist(ir),ir=1,nr1x*nr2x*nr3x) - ! - end do - - DEALLOCATE( displs, recvcount ) - if (ionode) deallocate(rhodist) - - ELSE - - IF ( ionode ) THEN - WRITE( rhounit, '(F12.7)' ) ( ( rhor(ir,is), ir = 1, nnrx ), is = 1, nspin ) - END IF - - END IF COLLECT_CHARGE - - IF ( ionode ) THEN - CLOSE( unit = rhounit ) - END IF - ! - return - end subroutine old_write_rho -! -!---------------------------------------------------------------------- - subroutine nrbounds(ngw,nr1s,nr2s,nr3s,mill,nmin,nmax) -!---------------------------------------------------------------------- -! -! find the bounds for (i,j,k) indexes of all wavefunction G-vectors -! The (i,j,k) indexes are defined as: G=i*g(1)+j*g(2)+k*g(3) -! where g(1), g(2), g(3) are basis vectors of the reciprocal lattice -! - use parallel_include - use mp, only: mp_min, mp_max - use mp_global, only: intra_image_comm - implicit none -! input - integer ngw,nr1s,nr2s,nr3s,mill(3,*) -! output - integer nmin(3), nmax(3) -! local - integer nmin0(3), nmax0(3), ig -! -! - nmin0(1)= nr1s - nmax0(1)= -nr1s - nmin0(2)= nr2s - nmax0(2)= -nr2s - nmin0(3)= nr3s - nmax0(3)= -nr3s -! - do ig=1,ngw - nmin0(1) = min(nmin0(1),mill(1,ig)) - nmin0(2) = min(nmin0(2),mill(2,ig)) - nmin0(3) = min(nmin0(3),mill(3,ig)) - nmax0(1) = max(nmax0(1),mill(1,ig)) - nmax0(2) = max(nmax0(2),mill(2,ig)) - nmax0(3) = max(nmax0(3),mill(3,ig)) - end do -! -! find minima and maxima for the FFT box across all nodes -! - CALL mp_min( nmin0, intra_image_comm ) - CALL mp_max( nmax0, intra_image_comm ) - nmin = nmin0 - nmax = nmax0 - - return - end subroutine nrbounds diff --git a/quantum_espresso/kcp/CPV/path_routines.f90 b/quantum_espresso/kcp/CPV/path_routines.f90 deleted file mode 100644 index 93b7d6699..000000000 --- a/quantum_espresso/kcp/CPV/path_routines.f90 +++ /dev/null @@ -1,282 +0,0 @@ -! -! Copyright (C) 2002-2006 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!----------------------------------------------------------------------- -MODULE path_routines - !----------------------------------------------------------------------- - ! - ! ... This module contains some interface subroutines needed for - ! ... the NEB implementation into the FPMD code - ! - ! ... Written by Carlo Sbraccia ( 2003-2006 ) - ! - USE io_global, ONLY : stdout - USE kinds, ONLY : DP - USE constants, ONLY : bohr_radius_angs, eV_to_kelvin - ! - PRIVATE - ! - PUBLIC :: iosys_path - ! - CONTAINS - ! - !------------------------------------------------------------------------ - SUBROUTINE iosys_path() - !------------------------------------------------------------------------ - ! - USE input_parameters, ONLY : full_phs_path_flag, atomic_positions - USE input_parameters, ONLY : pos, CI_scheme, opt_scheme, num_of_images, & - first_last_opt, temp_req, ds, k_max, & - k_min, path_thr, restart_mode, nstep, & - calculation, use_freezing, & - phase_space, ion_dynamics - ! - USE path_variables, ONLY : lsteep_des, lquick_min, lbroyden, nstep_path, & - num_of_images_ => num_of_images, & - CI_scheme_ => CI_scheme, & - first_last_opt_ => first_last_opt, & - temp_req_ => temp_req, & - ds_ => ds, & - k_max_ => k_max, & - k_min_ => k_min, & - path_thr_ => path_thr, & - use_freezing_ => use_freezing - ! - USE io_files, ONLY : prefix, outdir, tmp_dir - USE io_global, ONLY : ionode - USE ions_base, ONLY : nat - USE cell_base, ONLY : alat, a1, a2, a3 - USE mp_global, ONLY : mpime - USE mp, ONLY : mp_bcast, mp_barrier, mp_sum - USE control_flags, ONLY : lpath, lneb, lcoarsegrained, lconstrain, & - lmd, tprnfor - USE metadyn_vars, ONLY : init_metadyn_vars - USE wrappers, ONLY : f_mkdir - ! - IMPLICIT NONE - ! - INTEGER :: image, i, ia - INTEGER :: ios - REAL(DP), ALLOCATABLE :: tau(:,:) - CHARACTER(LEN=256) :: outdir_saved - CHARACTER(LEN=256) :: filename - CHARACTER (LEN=6), EXTERNAL :: int_to_char - ! - tmp_dir = TRIM( outdir ) - ! - tprnfor = .TRUE. - nstep_path = nstep - ! - SELECT CASE( TRIM( phase_space ) ) - CASE( 'full' ) - ! - lcoarsegrained = .FALSE. - ! - CASE ( 'coarse-grained' ) - ! - lcoarsegrained = .TRUE. - ! - END SELECT - ! - IF ( lcoarsegrained ) THEN - ! - CALL init_metadyn_vars() - ! - lmd = .TRUE. - lconstrain = .TRUE. - ! - SELECT CASE( TRIM( ion_dynamics ) ) - CASE( 'verlet', 'damp' ) - ! - CONTINUE - ! - CASE DEFAULT - ! - CALL errore( 'iosys_path ', 'calculation=' // TRIM( calculation ) // & - & ': ion_dynamics=' // TRIM( ion_dynamics ) // & - & ' not supported', 1 ) - ! - END SELECT - ! - END IF - ! - IF ( num_of_images < 2 ) & - CALL errore( ' iosys ', 'calculation=' // TRIM( calculation ) // & - & ': num_of_images must be at least 2', 1 ) - ! - IF ( ( CI_scheme /= "no-CI" ) .AND. & - ( CI_scheme /= "auto" ) .AND. & - ( CI_scheme /= "manual" ) ) THEN - ! - CALL errore( ' iosys ', 'calculation=' // TRIM( calculation ) // & - & ': unknown CI_scheme', 1 ) - ! - END IF - ! - ! ... initialization of logical variables - ! - lsteep_des = .FALSE. - lquick_min = .FALSE. - lbroyden = .FALSE. - ! - SELECT CASE ( opt_scheme ) - CASE ( "sd" ) - ! - lsteep_des = .TRUE. - ! - CASE ( "quick-min" ) - ! - lquick_min = .TRUE. - ! - CASE( "broyden" ) - ! - lbroyden = .TRUE. - ! - CASE default - ! - CALL errore( 'iosys', 'calculation = ' // TRIM( calculation ) // & - & ': unknown opt_scheme', 1 ) - ! - END SELECT - ! - num_of_images_ = num_of_images - CI_scheme_ = CI_scheme - first_last_opt_ = first_last_opt - temp_req_ = temp_req - ds_ = ds - k_max_ = k_max - k_min_ = k_min - path_thr_ = path_thr - use_freezing_ = use_freezing - ! - lpath = .TRUE. - lneb = .TRUE. - nstep_path = nstep - ! - outdir_saved = outdir - ! - IF ( full_phs_path_flag ) THEN - ! - ALLOCATE( tau( 3, nat ) ) - ! - DO image = 1, num_of_images - ! - tau = RESHAPE( pos(1:3*nat,image), SHAPE( tau ) ) - ! - ! ... convert input atomic positions to internally used format: - ! - SELECT CASE ( TRIM( atomic_positions ) ) - CASE( 'alat' ) - ! - ! ... input atomic positions are divided by a0 - ! - tau(:,1:nat) = tau(:,1:nat) * alat - ! - CASE( 'bohr' ) - ! - ! ... input atomic positions are in a.u.: do nothing - ! - tau(:,1:nat) = tau(:,1:nat) - ! - CASE( 'crystal' ) - ! - ! ... input atomic positions are in crystal axis ("scaled") - ! - DO ia = 1, nat - ! - DO i = 1, 3 - ! - tau(i,ia) = a1(i) * tau(1,ia) + & - a2(i) * tau(2,ia) + & - a3(i) * tau(3,ia) - ! - END DO - ! - END DO - ! - CASE( 'angstrom' ) - ! - ! ... atomic positions in Angstrom - ! - tau(:,1:nat) = tau(:,1:nat) / bohr_radius_angs - ! - CASE DEFAULT - ! - CALL errore( 'iosys_path', ' tau_units = ' // & - & TRIM( atomic_positions ) // ' not implemented ', 1 ) - ! - END SELECT - ! - pos(1:3*nat,image) = RESHAPE( tau, (/ 3 * nat /) ) - ! - END DO - ! - DEALLOCATE( tau ) - ! - END IF - ! - DO image = 1, num_of_images - ! - ios = 0 - ! - outdir = TRIM( outdir_saved ) // "/" // TRIM( prefix ) // "_" // & - TRIM( int_to_char( image ) ) // '/' - ! - IF ( ionode ) THEN - ! - ! ... a scratch directory for this image of the elastic band is - ! ... created ( only by the master node ) - ! - ios = f_mkdir( TRIM( outdir ) ) - ! - END IF - ! - ! ... all jobs are syncronized - ! - CALL mp_barrier() - ! - ! ... each job checks whether the scratch directory is accessible - ! ... or not - ! - filename = TRIM( outdir ) // 'cp' // TRIM( int_to_char( mpime ) ) - ! - OPEN( UNIT = 4, FILE = TRIM( filename ) , & - STATUS = 'UNKNOWN', FORM = 'UNFORMATTED', IOSTAT = ios ) - CLOSE( UNIT = 4, STATUS = 'DELETE' ) - ! - CALL mp_sum( ios ) - ! - IF ( ios /= 0 ) & - CALL errore( 'outdir:', TRIM( outdir ) // & - & ' non existent or non writable', 1 ) - ! - ! ... if starting from scratch all temporary files are removed - ! ... from outdir ( only by the master node ) - ! - IF ( restart_mode == 'from_scratch' ) THEN - ! - IF ( ionode ) THEN - ! - ! ... standard output of the self consistency is removed - ! - OPEN( UNIT = 4, FILE = TRIM( outdir ) // 'CP.out', & - STATUS = 'UNKNOWN' ) - CLOSE( UNIT = 4, STATUS = 'DELETE' ) - ! - END IF - ! - END IF - ! - END DO - ! - outdir = outdir_saved - ! - RETURN - ! - END SUBROUTINE iosys_path - ! -END MODULE path_routines diff --git a/quantum_espresso/kcp/CPV/pc3nc_fixed.f90 b/quantum_espresso/kcp/CPV/pc3nc_fixed.f90 deleted file mode 100644 index 47d665166..000000000 --- a/quantum_espresso/kcp/CPV/pc3nc_fixed.f90 +++ /dev/null @@ -1,173 +0,0 @@ - -subroutine pc3nc_fixed(phi, grad, lgam) - ! - use kinds - use io_global, only: stdout - use mp_global, only: intra_image_comm - use gvecw, only: ngw - use reciprocal_vectors, only: ng0 => gstart - use mp, only: mp_sum - use electrons_base, only: n => nbsp, ispin - use input_parameters,only : fixed_band - ! - implicit none - ! - complex(dp), intent(in):: phi(ngw,n) - complex(dp), intent(inout):: grad(ngw, n) - logical :: lgam - ! - ! local variables - ! - integer :: nb,ig, iter - real(dp):: norm_dgrad, norm_thr - complex(dp) :: sca_c - complex(dp) :: d1(ngw), c1(ngw), grad0(ngw), dgrad(ngw) - ! - call start_clock('pc3nc_fixed') - ! - norm_thr = 1.0E-12 - grad0(:) = grad(:, fixed_band) - ! - ! compute c1 = \sum_i |phi_i> - ! - c1(:) = cmplx(0.0d0, 0.0d0) - do nb=1, n - ! - sca_c=cmplx(0.0d0, 0.0d0) - ! - if (ispin(nb) == ispin(fixed_band)) then - ! - if (lgam) then - ! - if (ng0.eq.2) grad(1,nb) = cmplx(dble(grad(1,nb)),0.0d0) - ! - do ig=1,ngw !loop on g vectors - sca_c = sca_c + conjg(grad(ig,nb))*phi(ig,fixed_band) - enddo - ! - sca_c = sca_c*2.0d0 !2. for real weavefunctions - ! - if (ng0.eq.2) then - sca_c = cmplx(dble(sca_c), 0.d0) & - - cmplx(dble(conjg(grad(1,nb))*phi(1,fixed_band)),0.d0) - else - sca_c = cmplx(dble(sca_c), 0.d0) - endif - ! - else - ! - do ig=1,ngw !loop on g vectors - ! - sca_c = sca_c + conjg(grad(ig,nb)) * phi(ig,fixed_band) - ! - enddo - ! - endif - ! - endif - ! - call mp_sum( sca_c, intra_image_comm ) - ! - c1(:) = c1(:) + sca_c*phi(:, nb) - ! - if (lgam) then - ! - if (ng0.eq.2) c1(1) = cmplx(dble(c1(1)),0.0d0) - ! - endif - ! - enddo - ! - ! main iteration - ! - do iter = 1, 100 - ! - ! compute d1 = [\sum_i |phi_i><\phi_i|grad0> ] - ! - d1(:)=cmplx(0.0d0, 0.0d0) - do nb=1, n - ! - sca_c=cmplx(0.0d0, 0.0d0) - ! - if (ispin(nb) == ispin(fixed_band)) then - ! - if (lgam) then - ! - if (ng0.eq.2) grad0(1) = cmplx(dble(grad0(1)),0.0d0) - ! - do ig=1,ngw !loop on g vectors - sca_c = sca_c + conjg(phi(ig,nb))*grad0(ig) - enddo - ! - sca_c = sca_c*2.0d0 !2. for real weavefunctions - ! - if (ng0.eq.2) then - sca_c = cmplx(dble(sca_c), 0.d0) & - - cmplx(dble(conjg(phi(1,nb))* grad0(1)),0.d0) - else - sca_c = cmplx(dble(sca_c), 0.d0) - endif - ! - else - ! - do ig=1,ngw !loop on g vectors - ! - sca_c = sca_c + conjg(phi(ig,nb))*grad0(ig) - ! - enddo - ! - endif - ! - endif - ! - call mp_sum( sca_c, intra_image_comm ) - ! - d1(:) = d1(:) + sca_c*phi(:, nb) - ! - if (lgam) then - ! - if (ng0.eq.2) d1(1) = cmplx(dble(d1(1)),0.0d0) - ! - endif - ! - enddo - ! - ! compute the gradient - ! - dgrad(:) = grad0(:) - (1.d0/2.d0)*(d1(:) + c1(:)) - ! - ! compute norm |dgrad| - ! - norm_dgrad = 0.0d0 - do ig=1,ngw - norm_dgrad = norm_dgrad + conjg(dgrad(ig))*dgrad(ig) - enddo - ! - if (lgam) then - norm_dgrad = 2.0d0*norm_dgrad - if (ng0.eq.2) norm_dgrad = norm_dgrad - conjg(dgrad(1))*dgrad(1) - endif - ! - call mp_sum (norm_dgrad, intra_image_comm) - ! - write(stdout,*) 'norm dgrad', iter, norm_dgrad - ! - if (norm_dgrad <= norm_thr) then - ! - goto 100 - ! - else - ! - grad0(:) = grad0(:) - dgrad(:) - ! - endif - ! - enddo - ! - 100 continue - ! - grad(:, fixed_band) = grad0(:) - ! - return - ! - end subroutine pc3nc_fixed diff --git a/quantum_espresso/kcp/CPV/perturbing_pot.f90 b/quantum_espresso/kcp/CPV/perturbing_pot.f90 deleted file mode 100644 index b55d808bb..000000000 --- a/quantum_espresso/kcp/CPV/perturbing_pot.f90 +++ /dev/null @@ -1,180 +0,0 @@ -! -! Copyright (C) 2007-2008 Quantum ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -!#define DEBUG -! -!----------------------------------------------------------------------- - SUBROUTINE perturbing_pot(current_bnd, current_spin, rhor, pot) -!----------------------------------------------------------------------- -! ... Calculate pot(r) = \int dr' f_Hxr(r,r')n_i(r') ... -! take as an input: -! 1) the band and spin index of the chosen orbital -! 2) the total charge density (to compute the xc kernel) -! give as OUTPUT: -! the perturbing potential in pot -! -! - USE kinds, ONLY : DP - USE constants, ONLY : fpi, hartree_si, electronvolt_si - USE cell_base, ONLY : tpiba2, omega - USE gvecw, ONLY : ngw - USE gvecp, ONLY : ngm - USE recvecs_indexes, ONLY : np, nm - USE grid_dimensions, ONLY : nnrx - USE electrons_base, ONLY : nspin - USE control_flags, ONLY : gamma_only, do_wf_cmplx - USE reciprocal_vectors, ONLY : gstart, g - USE cp_interfaces, ONLY : fwfft, invfft - USE fft_base, ONLY : dfftp - USE mp, ONLY : mp_sum - USE cp_interfaces, ONLY : nksic_get_orbitalrho - USE eecp_mod, ONLY : do_comp - USE wavefunctions_module, ONLY : c0 - USE funct, ONLY : dmxc, dmxc_spin - USE uspp, ONLY : okvan - USE twin_types - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN):: current_spin, current_bnd - ! band and spin index of the orbital - REAL(DP), INTENT(IN):: rhor(nnrx,nspin) - ! INPUT: total charge density to compute the xc kernel - REAL(DP) :: orb_rhor(nnrx), dmuxc_r(nnrx, nspin, nspin) - ! orbital density as an input - REAL(DP), INTENT(OUT):: pot(nnrx) - ! OUTPUT: potential \int f_Hxc(r,r')*orb_rho_r(r') - COMPLEX(DP), ALLOCATABLE :: orb_rhog(:,:), vhaux(:), vtmp(:), vcorr(:) - ! ... orbital density in G space, auxiliary potential in real and G space - COMPLEX(DP) :: c1(ngw), psi1(nnrx) - ! ... auxiliary variable for the wavefunction ... - INTEGER ig, ir - ! ... counter - ! - ! - ! - ALLOCATE ( orb_rhog(ngm,1) ) - ALLOCATE ( vhaux(nnrx) ) - ALLOCATE ( vtmp(ngm) ) - ALLOCATE ( vcorr(ngm) ) - ! - IF (okvan) call errore('perturbing_pot','USPP not implemented yet',1) - ! - ! ... xc kernel initialization ... - ! - dmuxc_r = 0.D0 - DO ir =1 , nnrx - ! - IF (nspin == 2) THEN - CALL dmxc_spin (rhor(ir,1), rhor(ir,2), dmuxc_r(ir,1,1), dmuxc_r(ir,1,2), dmuxc_r(ir,2,1), dmuxc_r(ir,2,2) ) - dmuxc_r(ir,:,:)=dmuxc_r(ir,:,:)*0.5D0 ! From Rydberg to Hartree -#ifdef DEBUG - IF (MOD(ir,200) == 0) WRITE(stdout,'(I8, 6F15.6)') ir, rhor(ir,1), rhor(ir,2), dmuxc_r(ir,1,1), dmuxc_r(ir,1,2), dmuxc_r(ir,2,1), dmuxc_r(ir,2,2) -#endif - ELSE - dmuxc_r(ir,1,1) = 0.5D0*dmxc(rhor(ir,1)) ! factor 0.5 from Ry to Ha - ENDIF - ! - ENDDO - ! - pot=0.D0 - orb_rhog = (0.D0,0.D0) - ! - ! ... Orbital density ... - ! - c1=c0(:, current_bnd) - CALL c2psi ( psi1, nnrx, c1, c1, ngw, 0 ) - CALL invfft('Dense', psi1, dfftp ) - ! - orb_rhor= 0.D0 - DO ir = 1, nnrx - ! - orb_rhor(ir) = (( abs(psi1(ir)) ))**2/omega - ! - ENDDO - ! -#ifdef DEBUG - sum=0.D0 - DO ir = 1, nnrx - sum =sum + orb_rhor(ir) - ENDDO - CALL mp_sum (sum, intra_image_comm) - WRITE(stdout,'(2x, "orbital charge", 2F18.12)') sum/( nr1*nr2*nr3 )*omega -#endif - ! ... Hartree potential ... - ! - ! orbital density in G spce - vhaux(:) = (0.D0, 0.D0) - vhaux=CMPLX(orb_rhor(:),0.D0) - CALL fwfft('Dense',vhaux,dfftp ) - DO ig = 1,ngm; orb_rhog(ig,1) = vhaux( np(ig) ); ENDDO - ! - ! compute hartree like potential - IF ( gstart == 2 ) vtmp(1)=(0.d0,0.d0) - DO ig=gstart,ngm - vtmp(ig) = orb_rhog(ig,1) * fpi/( tpiba2*g(ig) ) - ENDDO - ! - ! compute periodic corrections - IF ( do_comp ) THEN - ! - call calc_compensation_potential( vcorr, orb_rhog(:,1),.true.) - vtmp(:) = vtmp(:) + vcorr(:) - ! - ENDIF - ! - ! Go back to real space - vhaux = (0.D0,0.D0) - DO ig = 1, ngm - vhaux(np(ig)) = vtmp(ig) - vhaux(nm(ig)) = CONJG( vtmp(ig) ) - ENDDO - ! - CALL invfft('Dense', vhaux, dfftp) - ! - ! update the potential - pot(1:nnrx) = DBLE(vhaux(1:nnrx)) - ! -#ifdef DEBUG - sum=0.D0 - DO ir = 1, nnrx - sum = sum + orb_rhor(ir)*pot(ir) - ENDDO - CALL mp_sum (sum, intra_image_comm) - sum = sum *0.5D0*omega/(nr1*nr2*nr3) - WRITE(stdout,*) "hartree energy", sum, "Ha" - ! - DO is = 1 ,nspin - DO is1 =1, nspin - WRITE(6,'(i3,i3,3F18.6,/)') is,is1,dmuxc_r(1:3,is,is1) - ENDDO - ENDDO -#endif - ! - ! ... Add xc contribution - DO ir = 1, nnrx - pot(ir) = pot(ir) + dmuxc_r(ir,current_spin,current_spin) * orb_rhor(ir) - ENDDO - ! -#ifdef DEBUG - uPi=0.D0 - DO ir = 1, nnrx - uPi = uPi + ( orb_rhor(ir) * pot(ir) ) - ENDDO - CALL mp_sum( uPi , intra_image_comm ) - uPi = uPi / ( nr1*nr2*nr3 )*omega - WRITE(stdout,*) "unrelaxed Koopmans uPi=", uPi -#endif - ! - DEALLOCATE ( orb_rhog ) - DEALLOCATE ( vhaux ) - DEALLOCATE ( vtmp ) - ! -!--------------------------------------------------------------- - END SUBROUTINE perturbing_pot -!--------------------------------------------------------------- diff --git a/quantum_espresso/kcp/CPV/phasefactor.f90 b/quantum_espresso/kcp/CPV/phasefactor.f90 deleted file mode 100644 index 246b40ecc..000000000 --- a/quantum_espresso/kcp/CPV/phasefactor.f90 +++ /dev/null @@ -1,309 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - - -!=----------------------------------------------------------------------------=! - SUBROUTINE phfacs_x( ei1, ei2, ei3, eigr, mill, taus, nr1, nr2, nr3, nat ) -!=----------------------------------------------------------------------------=! - - ! this routine computes the phase factors - ! - ! ei1(ix,ia) = exp ( -i ix G_1 dot R(ia)) - ! ei2(iy,ia) = exp ( -i iy G_2 dot R(ia)) - ! ei3(iz,ia) = exp ( -i iz G_3 dot R(ia)) - ! - ! eigr(ig,ia) = exp( -i G dot R(ia)) = - ! = ei1(ix,ia) * ei2(iy,ia) * ei3(iz,ia) - ! - ! G_1,G_2,G_3 = reciprocal lattice generators - ! - ! ia = index of ion - ! ig = index of G vector - ! ix,iy,iz = Miller indices - ! ---------------------------------------------- - - USE kinds, ONLY: DP - USE constants, ONLY: tpi - - IMPLICIT NONE - - ! ... declare subroutine arguments - - INTEGER, INTENT(IN) :: nat - INTEGER, INTENT(IN) :: nr1, nr2, nr3 - COMPLEX(DP) :: ei1( -nr1 : nr1, nat ) - COMPLEX(DP) :: ei2( -nr2 : nr2, nat ) - COMPLEX(DP) :: ei3( -nr3 : nr3, nat ) - COMPLEX(DP) :: eigr( :, : ) - REAL(DP) :: taus( 3, nat ) - INTEGER :: mill( :, : ) - - ! ... declare other variables - - COMPLEX(DP) :: ctep1, ctep2, ctep3, ctem1, ctem2, ctem3 - REAL(DP) :: ar1, ar2, ar3 - INTEGER :: i, j, k, isa - INTEGER :: ig, ig1, ig2, ig3, ngw - - ! ... --+ end of declarations +-- - - if(nr1 < 3) call errore(' phfacs ',' nr1 too small ',1) - if(nr2 < 3) call errore(' phfacs ',' nr2 too small ',1) - if(nr3 < 3) call errore(' phfacs ',' nr3 too small ',1) - - DO isa = 1, nat - - ! ... Miller index = 0: exp(i 0 dot R(ia)) = 1 - - ei1( 0, isa ) = CMPLX( 1.d0, 0.d0 ) - ei2( 0, isa ) = CMPLX( 1.d0, 0.d0 ) - ei3( 0, isa ) = CMPLX( 1.d0, 0.d0 ) - - ! ... let R_1,R_2,R_3 be the direct lattice generators, - ! ... G_1,G_2,G_3 the reciprocal lattice generators - ! ... by definition G_i dot R_j = 2 pi delta_{ij} - ! ... ionic coordinates are in units of R_1,R_2,R_3 - ! ... then G_i dot R(ia) = 2 pi R(ia)_i - - ar1 = tpi * taus(1,isa) ! G_1 dot R(ia) - ar2 = tpi * taus(2,isa) ! G_2 dot R(ia) - ar3 = tpi * taus(3,isa) ! G_3 dot R(ia) - - ! ... Miller index = 1: exp(-i G_i dot R(ia)) - - ctep1 = CMPLX( cos( ar1 ), -sin( ar1 ) ) - ctep2 = CMPLX( cos( ar2 ), -sin( ar2 ) ) - ctep3 = CMPLX( cos( ar3 ), -sin( ar3 ) ) - - ! ... Miller index = -1: exp(-i G_im dot R(ia)) = exp(i G_i dot R(ia)) - - ctem1 = CONJG(ctep1) - ctem2 = CONJG(ctep2) - ctem3 = CONJG(ctep3) - - ! ... Miller index > 0: exp(i N G_i dot R(ia)) = - ! ... = exp(i G_i dot R(ia)) exp(i (N-1) G_i dot R(ia)) - ! ... Miller index < 0: exp(-i N G_i dot R(ia)) = - ! ... = exp(-i G_i dot R(ia)) exp(-i (N-1) G_i dot R(ia)) - - DO i = 1, nr1 - ei1( i, isa ) = ei1( i - 1, isa ) * ctep1 - ei1( -i, isa ) = ei1( -i + 1, isa ) * ctem1 - END DO - DO j = 1, nr2 - ei2( j, isa ) = ei2( j - 1, isa ) * ctep2 - ei2( -j, isa ) = ei2( -j + 1, isa ) * ctem2 - END DO - DO k = 1, nr3 - ei3( k, isa ) = ei3( k - 1, isa ) * ctep3 - ei3( -k, isa ) = ei3( -k + 1, isa ) * ctem3 - END DO - - END DO - - ngw = SIZE( eigr, 1 ) - IF( ngw > SIZE( mill, 2 ) ) THEN - CALL errore(' phfacs ',' eigr inconsisten size ',ngw) - END IF - - DO ig = 1, ngw - ig1 = mill( 1, ig ) - ig2 = mill( 2, ig ) - ig3 = mill( 3, ig ) - DO i = 1, nat - eigr( ig, i ) = ei1( ig1, i ) * ei2( ig2, i ) * ei3( ig3, i ) - END DO - END DO - - RETURN - END SUBROUTINE phfacs_x - - -!=----------------------------------------------------------------------------=! - SUBROUTINE strucf_x( sfac, ei1, ei2, ei3, mill, ngm ) -!=----------------------------------------------------------------------------=! - -! this routine computes the structure factors -! -! sfac(ig,is) = (sum over ia) exp(i G dot R(ia)) = -! (sum over ia) ei1(ix,ia) * ei2(iy,ia) * ei3(iz,ia) -! -! ei1(ix,ia) = exp (i ix G_1 dot R(ia)) -! ei2(iy,ia) = exp (i iy G_2 dot R(ia)) -! ei3(iz,ia) = exp (i iz G_3 dot R(ia)) -! -! G_1,G_2,G_3 = reciprocal lattice generators -! -! ia = index of ion (running over ions of species is) -! ig = index of G vector -! is = index of atomic species -! ix,iy,iz = Miller indices of G vector - - - USE kinds, ONLY: DP - USE ions_base, ONLY: nat, na, nsp - use grid_dimensions, only: nr1, nr2, nr3 - - IMPLICIT NONE - - ! ... declare subroutine arguments - ! - COMPLEX(DP) :: ei1( -nr1 : nr1, nat ) - COMPLEX(DP) :: ei2( -nr2 : nr2, nat ) - COMPLEX(DP) :: ei3( -nr3 : nr3, nat ) - INTEGER :: mill( :, : ) - INTEGER :: ngm - COMPLEX(DP), INTENT(OUT) :: sfac(:,:) - - ! ... declare other variables - ! - INTEGER :: is, ig, ia, ig1, ig2, ig3, isa - - call start_clock( 'strucf' ) - -!$omp parallel do default(shared), private(ig1,ig2,ig3,isa,is,ia) - DO ig = 1, ngm - ig1 = mill( 1, ig ) - ig2 = mill( 2, ig ) - ig3 = mill( 3, ig ) - isa = 1 - DO is = 1, nsp - sfac( ig, is ) = CMPLX (0.0d0, 0.0d0) - DO ia = 1, na(is) - sfac( ig, is ) = sfac( ig, is ) + & - ei1( ig1, isa ) * ei2( ig2, isa ) * ei3( ig3, isa ) - isa = isa + 1 - END DO - END DO - END DO - - call stop_clock( 'strucf' ) - - RETURN - END SUBROUTINE strucf_x - - - -!----------------------------------------------------------------------- - - subroutine phfac_x( tau0, ei1, ei2, ei3, eigr) - - !----------------------------------------------------------------------- - ! this subroutine generates the complex matrices ei1, ei2, and ei3 - ! used to compute the structure factor and forces on atoms : - ! ei1(n1,ia,is) = exp(-i*n1*b1*tau(ia,is)) -nr1 1 ) rhog( 1:ngm ) = rhog( 1:ngm ) + rhoeg( 1:ngm, 2 ) - - IF( tstress ) THEN - ! - ! add drho_e / dh - ! - DO k = 1, 6 - drhog( 1:ngm, k ) = - rhog( 1:ngm ) * dalbe( k ) - END DO - ! - END IF - - ! ... Calculate local part of the pseudopotential and its energy contribution (eps) - CALL vofps( eps, vloc, rhog, vps, sfac, box%deth, lgam ) - - edft%epseu = DBLE(eps) - - IF( tstress ) THEN - ! - CALL stress_local( deps, gagb, sfac, rhog, drhog, box%deth ) - ! - END IF - - ! ... Calculate hartree potential and energy (eh) - ! - CALL vofloc( tscreen, edft%ehte, edft%ehti, ehp, vloc, rhog, & - rhops, vps, sfac, box%deth, screen_coul ) - ! - ! - IF( tforce ) THEN - ! - CALL force_loc( tscreen, rhog, fion, rhops, vps, & - ei1, ei2, ei3, sfac, box%deth, screen_coul, lgam ) - ! - END IF - - edft%self_ehte = 0.d0 - - IF( ttsic ) THEN - ! - ! ... Calculate Self-interaction correction --- Hartree part - ! - ALLOCATE ( self_vloc( ngm ) ) - CALL self_vofhar( ttscreen, edft%self_ehte, self_vloc, rhoeg, omega, box%hmat ) - ! - END IF - - edft%eh = DBLE( ehp ) - edft%self_ehte - edft%eht = edft%eh + edft%esr - edft%eself - - IF( tprint .AND. tvhmean ) THEN - ! - CALL vofmean( sfac, rhops, rhog ) - ! - END IF - - IF( tstress ) THEN - ! - ! add Ionic pseudo charges rho_I - ! - DO is = 1, nsp - DO ig = gstart, ngm - rhog( ig ) = rhog( ig ) + sfac( ig, is ) * rhops( ig, is ) - END DO - END DO - ! - ! add drho_I / dh - ! - CALL add_drhoph( drhog, sfac, gagb ) - ! - CALL stress_hartree( deht, edft%eh, rhog, drhog, gagb, box%deth ) - - DEALLOCATE( drhog ) - ! - END IF - - DEALLOCATE( rhog ) - - ALLOCATE( rhoetr( nnrx, nspin ) ) - ! - rhoetr = 0.0d0 - - DO iss = 1, nspin - - ! ... add core contribution to the charge - - CALL DCOPY( nnrx, rhoe(1,iss), 1, rhoetr(1,iss), 1 ) - - IF( nlcc_any ) THEN - - ! ... add core correction: rhoeg = rhoeg + cc; rhoetr = rhoe + cc - - CALL add_core_charge( rhoeg(:,iss), rhoetr(:,iss), sfac, rhocg, atoms%nsp ) - - END IF - - END DO - - ! - ! - ! exchange and correlation potential - ! - ! - - IF(tgc) THEN - ALLOCATE( grho( nnrx, 3, nspin ) ) - ALLOCATE( v2xc( nnrx, nspin, nspin ) ) - ELSE - ALLOCATE( grho( 1, 1, 1 ) ) - ALLOCATE( v2xc( 1, 1, 1 ) ) - END IF - - grho = 0.0d0 - v2xc = 0.0d0 - - IF( tgc ) THEN - ! - CALL fillgrad( nspin, rhoeg, grho, lgam) - ! - END IF - - CALL exch_corr_energy( rhoetr, grho, vpot, exc, vxc, v2xc ) - - - self_exc = 0.d0 - self_vxc = 0.d0 - ! - IF ( ttsic ) THEN - - ALLOCATE (self_rho( nnrx, 2), STAT = ierr) - IF( ierr /= 0 ) CALL errore(' vofrhos ', ' allocating self_rho ', ierr) - ! - self_rho(:,1) = rhoetr(:,2) - self_rho(:,2) = rhoetr(:,2) - - IF ( tgc ) THEN - ! - ALLOCATE(self_grho( nnrx, 3, nspin ), STAT = ierr) - IF( ierr /= 0 ) CALL errore(' vofrhos ', ' allocating self_grho ', ierr) - ! - self_grho(:,:,1) = grho(:,:,2) - self_grho(:,:,2) = grho(:,:,2) - ! - ALLOCATE(self_v2xc( nnrx, nspin, nspin ), STAT = ierr) - IF( ierr /= 0 ) CALL errore(' vofrhos ', ' allocating self_v2xc ', ierr) - ! - ENDIF - - ALLOCATE ( self_vpot( nnrx, 2 ), STAT = ierr ) - IF( ierr /= 0 ) CALL errore(' vofrhos ', ' allocating self_vpot ', ierr) - - self_vpot = 0.D0 - - CALL exch_corr_energy( self_rho, self_grho, self_vpot, self_exc, self_vxc, self_v2xc ) - - vpot (:,1) = ( 1.0d0 - sic_alpha ) * vpot(:,1) - vpot (:,2) = ( 1.0d0 - sic_alpha ) * vpot(:,2) + sic_alpha * ( self_vpot(:,2) + self_vpot(:,1) ) - - IF (tgc) THEN - ! - v2xc(:,1,1) = ( 1.0d0 - sic_alpha ) * v2xc(:,1,1) - v2xc(:,2,2) = ( 1.0d0 - sic_alpha ) * v2xc(:,2,2) + sic_alpha * ( self_v2xc(:,2,2) + self_v2xc(:,1,1) ) - ! - END IF - - self_exc = sic_alpha * ( exc - self_exc ) - ! - exc = exc - self_exc - ! - self_vxc = sic_alpha * ( vxc - self_vxc ) - ! - vxc = vxc - self_vxc - ! - END IF - - IF ( tstress ) THEN - ! - strvxc = ( exc - vxc ) * omega / DBLE( nr1 * nr2 * nr3 ) - ! - END IF - - edft%exc = exc * omega / DBLE( nr1 * nr2 * nr3 ) - edft%vxc = vxc * omega / DBLE( nr1 * nr2 * nr3 ) - edft%self_exc = self_exc * omega / DBLE( nr1 * nr2 * nr3 ) - edft%self_vxc = self_vxc * omega / DBLE( nr1 * nr2 * nr3 ) - - CALL mp_sum( edft%vxc, intra_image_comm ) - CALL mp_sum( edft%exc, intra_image_comm ) - CALL mp_sum( edft%self_exc, intra_image_comm ) - CALL mp_sum( edft%self_vxc, intra_image_comm ) - - - IF( nlcc_any ) THEN - ! - ! ... xc potential (vpot) from real to G space, to compute nlcc forces - ! ... rhoeg = fwfft(vpot) - ! - DO iss = 1, nspin - ! - psi = vpot(:,iss) - ! - CALL fwfft( 'Dense', psi, dfftp ) - CALL psi2rho( 'Dense', psi, dfftp%nnr, rhoeg(:,iss), ngm ) - ! - END DO - ! - ! ... now rhoeg contains the xc potential - ! - IF (tforce) THEN - ! - nlcc (1:nsp) = upf(1:nsp)%nlcc - CALL core_charge_forces( fion, rhoeg, rhocg, nlcc, atoms, box, ei1, ei2, ei3 ) - ! - END IF - ! - END IF - - ! - ! ... vloc(g): hartree and local part of the pseudo potentials (in - ! ... reciprocal space) - ! - - IF ( ttsic ) THEN - - CALL rho2psi( 'Dense', psi, dfftp%nnr, self_vloc, ngm ) - CALL invfft( 'Dense', psi, dfftp ) - ! - vpot(:,1) = vpot(:,1) - DBLE( psi(:) ) - vpot(:,2) = vpot(:,2) + DBLE( psi(:) ) - - END IF - - ! ... add hartree end local pseudo potentials ( invfft(vloc) ) - ! ... to xc potential (vpot). - ! ... vpot = vpot + invfft(vloc) - - CALL rho2psi( 'Dense', psi, dfftp%nnr, vloc, ngm ) - CALL invfft( 'Dense', psi, dfftp ) - - ! ... now potentials are in real space - ! ... vpot(r) = hartree + xc + local - - DO iss = 1, nspin - vpot(:,iss) = vpot(:,iss) + DBLE( psi ) - END DO - - IF( ttsic ) THEN - IF( tgc ) THEN - DEALLOCATE( self_grho ) - DEALLOCATE( self_v2xc ) - END IF - DEALLOCATE( self_vpot ) - DEALLOCATE( self_rho ) - DEALLOCATE( self_vloc ) - END IF - - IF( tstress ) THEN - ! - ! ... compute exchange & correlation energy contribution - ! - nlcc (1:nsp) = upf(1:nsp)%nlcc - CALL stress_xc( dexc, strvxc, sfac, rhoeg, grho, v2xc, gagb, nlcc, drhocg, box ) - ! - END IF - - ! ... sum up forces - ! - IF (tforce) THEN - CALL mp_sum(fion, intra_image_comm) - END IF - - ! - ! ... process external forces on ions - ! - IF( textfor ) THEN - ! - fion( :, 1:atoms%nat ) = fion( :, 1:atoms%nat ) + extfor( :, 1:atoms%nat ) - fion( :, 1:atoms%nat ) = fion( :, 1:atoms%nat ) + atoms%for( :, 1:atoms%nat ) - ! - DO i = 1, atoms%nat - CALL s_to_r( atoms%taus(:,i), atoms%taur(:,i), box ) - END DO - ! - edft%eextfor =compute_eextfor( atoms%taur ) - ! - ENDIF - - ! ... sum up energy contributions - ! - CALL total_energy( edft ) - - - ! ... sum up stress tensor - ! - IF( tstress ) THEN - IF( iprsta >= 2 ) THEN - CALL stress_debug( dekin6, deht, dexc, desr, deps, denl6, box%m1 ) - END IF - CALL pstress( box%paiu, desr, dekin6, denl, deps, deht, dexc, box%a ) - END IF - - - ! ... Copy new atomic forces on for type member - ! - atoms%for( 1:3, 1:atoms%nat ) = fion - - DEALLOCATE( rhoetr, grho, v2xc, fion ) - DEALLOCATE( vloc, psi ) - - ! - IF( tscreen ) THEN - DEALLOCATE( screen_coul ) - END IF - ! - IF( tstress ) THEN - DEALLOCATE( gagb ) - END IF - - CALL stop_clock( 'vofrho' ) - - ! ... Flush stdout - - CALL flush_unit( stdout ) - - RETURN - END SUBROUTINE vofrhos_x - -!=----------------------------------------------------------------------------=! - - SUBROUTINE cluster_bc( screen_coul, hg, omega, hmat ) - - USE kinds, ONLY: DP - USE mp_global, ONLY: me_image - USE fft_base, ONLY: dfftp - USE cp_interfaces, ONLY: fwfft - USE gvecp, ONLY: ngm - USE constants, ONLY: gsmall, pi - USE cell_base, ONLY: tpiba2, s_to_r, alat - use grid_dimensions, only: nr1, nr2, nr3, nr1l, nr2l, nr3l, nnrx - - IMPLICIT NONE - - REAL(DP), INTENT(IN) :: hg( ngm ) - REAL(DP), INTENT(IN) :: omega, hmat( 3, 3 ) - COMPLEX(DP) :: screen_coul( ngm ) - - REAL(DP), EXTERNAL :: qe_erf - - ! ... Locals - ! - COMPLEX(DP), ALLOCATABLE :: grr(:) - COMPLEX(DP), ALLOCATABLE :: grg(:) - REAL(DP) :: rc, r(3), s(3), rmod, g2, rc2, arg, fact - INTEGER :: ig, i, j, k, ir - INTEGER :: ir1, ir2, ir3 - - ir1 = 1 - ir2 = 1 - ir3 = 1 - DO k = 1, me_image - ir3 = ir3 + dfftp%npp( k ) - END DO - - ALLOCATE( grr( nnrx ) ) - ALLOCATE( grg( SIZE( screen_coul ) ) ) - - grr = 0.0d0 - - ! ... Martyna and Tuckerman convergence criterium - ! - rc = 7.0d0 / alat - rc2 = rc**2 - fact = omega / ( nr1 * nr2 * nr3 ) - IF( MOD(nr1 * nr2 * nr3, 2) /= 0 ) fact = -fact - - DO k = 1, nr3l - s(3) = DBLE ( (k-1) + (ir3 - 1) ) / nr3 - 0.5d0 - DO j = 1, nr2l - s(2) = DBLE ( (j-1) + (ir2 - 1) ) / nr2 - 0.5d0 - DO i = 1, nr1l - s(1) = DBLE ( (i-1) + (ir1 - 1) ) / nr1 - 0.5d0 - CALL S_TO_R( S, R, hmat ) - rmod = SQRT( r(1)**2 + r(2)**2 + r(3)**2 ) - ir = i + (j-1)*dfftp%nr1x + (k-1)*dfftp%nr1x*dfftp%nr2x - IF( rmod < gsmall ) THEN - grr( ir ) = fact * 2.0d0 * rc / SQRT( pi ) - ELSE - grr( ir ) = fact * qe_erf( rc * rmod ) / rmod - END IF - END DO - END DO - END DO - - ! grg = FFT( grr ) - - CALL fwfft( 'Dense', grr, dfftp ) - CALL psi2rho( 'Dense', grr, dfftp%nnr, grg, ngm ) - - DO ig = 1, SIZE( screen_coul ) - IF( hg(ig) < gsmall ) THEN - screen_coul(ig) = grg(1) - ( - pi / rc2 ) - ELSE - g2 = tpiba2 * hg(ig) - arg = - g2 / ( 4.0d0 * rc2 ) - screen_coul(ig) = grg(ig) - ( 4.0d0 * pi * EXP( arg ) / g2 ) - END IF - END DO - - DEALLOCATE( grr, grg ) - - RETURN - END SUBROUTINE cluster_bc - - -!=----------------------------------------------------------------------------=! - - - SUBROUTINE vofps_x_new( eps, vloc, rhoeg, vps, sfac, omega, lgam) - - ! this routine computes: - ! omega = ht%deth - ! vloc_ps(ig) = (sum over is) sfac(is,ig) * vps(ig,is) - ! - ! Eps = Fact * omega * (sum over ig) cmplx ( rho_e(ig) ) * vloc_ps(ig) - ! if Gamma symmetry Fact = 2 else Fact = 1 - ! - - USE kinds, ONLY: DP - USE ions_base, ONLY: nsp - USE gvecp, ONLY: ngm - USE reciprocal_vectors, ONLY: gstart - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - - IMPLICIT NONE - - ! ... Arguments - - REAL(DP), INTENT(IN) :: vps(:,:) - REAL(DP), INTENT(IN) :: omega - COMPLEX(DP), INTENT(OUT) :: vloc(:) - COMPLEX(DP), INTENT(IN) :: rhoeg(:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - COMPLEX(DP), INTENT(OUT) :: eps - LOGICAL :: lgam - - ! ... Locals - - INTEGER :: is, ig - COMPLEX(DP) :: vp - - ! ... Subroutine body ... - ! - eps = CMPLX(0.D0,0.D0) - ! - DO ig = gstart, ngm - - vp = CMPLX(0.D0,0.D0) - DO is = 1, nsp - vp = vp + sfac( ig, is ) * vps( ig, is ) - END DO - - vloc(ig) = vp - eps = eps + vp * CONJG( rhoeg( ig ) ) - - END DO - ! ... - ! ... G = 0 element - ! - - IF ( gstart == 2 ) THEN - vp = (0.D0,0.D0) - DO is = 1, nsp - vp = vp + sfac( 1, is) * vps(1, is) - END DO - vloc(1) = VP - IF(lgam) THEN - eps = eps + vp * CONJG( rhoeg(1) ) * 0.5d0 - ELSE - eps = eps + vp * CONJG( rhoeg(1) ) - ENDIF - END IF - ! - IF(lgam) THEN - eps = 2.D0 * eps * omega - ELSE - eps = eps * omega - ENDIF - ! - CALL mp_sum( eps, intra_image_comm ) - - RETURN - END SUBROUTINE vofps_x_new - -!=----------------------------------------------------------------------------=! - - SUBROUTINE vofps_x( eps, vloc, rhoeg, vps, sfac, omega ) - - ! this routine computes: - ! omega = ht%deth - ! vloc_ps(ig) = (sum over is) sfac(is,ig) * vps(ig,is) - ! - ! Eps = Fact * omega * (sum over ig) cmplx ( rho_e(ig) ) * vloc_ps(ig) - ! if Gamma symmetry Fact = 2 else Fact = 1 - ! - - USE kinds, ONLY: DP - USE ions_base, ONLY: nsp - USE gvecp, ONLY: ngm - USE reciprocal_vectors, ONLY: gstart - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - - IMPLICIT NONE - - ! ... Arguments - - REAL(DP), INTENT(IN) :: vps(:,:) - REAL(DP), INTENT(IN) :: omega - COMPLEX(DP), INTENT(OUT) :: vloc(:) - COMPLEX(DP), INTENT(IN) :: rhoeg(:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - COMPLEX(DP), INTENT(OUT) :: eps - - ! ... Locals - - INTEGER :: is, ig - COMPLEX(DP) :: vp - - ! ... Subroutine body ... - ! - eps = (0.D0,0.D0) - ! - DO ig = gstart, ngm - - vp = (0.D0,0.D0) - DO is = 1, nsp - vp = vp + sfac( ig, is ) * vps( ig, is ) - END DO - - vloc(ig) = vp - eps = eps + vp * CONJG( rhoeg( ig ) ) - - END DO - ! ... - ! ... G = 0 element - ! - IF ( gstart == 2 ) THEN - vp = (0.D0,0.D0) - DO is = 1, nsp - vp = vp + sfac( 1, is) * vps(1, is) - END DO - vloc(1) = VP - eps = eps + vp * CONJG( rhoeg(1) ) * 0.5d0 - END IF - ! - eps = 2.D0 * eps * omega - ! - CALL mp_sum( eps, intra_image_comm ) - - RETURN - END SUBROUTINE vofps_x - -!=----------------------------------------------------------------------------=! - - SUBROUTINE vofloc_x( tscreen, ehte, ehti, eh, vloc, rhoeg, & - rhops, vps, sfac, omega, screen_coul ) - - ! this routine computes: - ! omega = ht%deth - ! rho_e(ig) = (sum over iss) rhoeg(ig,iss) - ! rho_I(ig) = (sum over is) sfac(is,ig) * rhops(ig,is) - ! vloc_h(ig) = fpi / ( g(ig) * tpiba2 ) * { rho_e(ig) + rho_I(ig) } - ! - ! Eh = Fact * omega * (sum over ig) * fpi / ( g(ig) * tpiba2 ) * - ! { rho_e(ig) + rho_I(ig) } * conjugate { rho_e(ig) + rho_I(ig) } - ! if Gamma symmetry Fact = 1 else Fact = 1/2 - ! - ! Hatree potential and local pseudopotential - ! vloc(ig) = vloc_h(ig) + vloc_ps(ig) - ! - - USE kinds, ONLY: DP - USE constants, ONLY: fpi - USE cell_base, ONLY: tpiba2 - USE reciprocal_vectors, ONLY: gstart, g - USE ions_base, ONLY: nsp - USE gvecp, ONLY: ngm - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - - IMPLICIT NONE - - ! ... Arguments - - LOGICAL, INTENT(IN) :: tscreen - REAL(DP), INTENT(IN) :: rhops(:,:), vps(:,:) - COMPLEX(DP), INTENT(INOUT) :: vloc(:) - COMPLEX(DP), INTENT(IN) :: rhoeg(:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - REAL(DP), INTENT(OUT) :: ehte, ehti - REAL(DP), INTENT(IN) :: omega - COMPLEX(DP), INTENT(OUT) :: eh - COMPLEX(DP), INTENT(IN) :: screen_coul(:) - - ! ... Locals - - INTEGER :: is, ig - REAL(DP) :: fpibg - COMPLEX(DP) :: rhet, rhog, rp, vscreen - - ! ... Subroutine body ... - - eh = 0.0d0 - ehte = 0.0d0 - ehti = 0.0d0 - -!$omp parallel do default(shared), private(rp,is,rhet,rhog,fpibg), reduction(+:eh,ehte,ehti) - DO ig = gstart, ngm - - rp = (0.D0,0.D0) - DO is = 1, nsp - rp = rp + sfac( ig, is ) * rhops( ig, is ) - END DO - - rhet = rhoeg( ig ) - rhog = rhet + rp - - IF( tscreen ) THEN - fpibg = fpi / ( g(ig) * tpiba2 ) + screen_coul(ig) - ELSE - fpibg = fpi / ( g(ig) * tpiba2 ) - END IF - - vloc(ig) = vloc(ig) + fpibg * rhog - eh = eh + fpibg * rhog * CONJG(rhog) - ehte = ehte + fpibg * DBLE(rhet * CONJG(rhet)) - ehti = ehti + fpibg * DBLE( rp * CONJG(rp)) - - END DO - ! ... - ! ... G = 0 element - ! - IF ( gstart == 2 ) THEN - rp = (0.D0,0.D0) - IF( tscreen ) THEN - vscreen = screen_coul(1) - ELSE - vscreen = 0.0d0 - END IF - DO IS = 1, nsp - rp = rp + sfac( 1, is) * rhops(1, is) - END DO - rhet = rhoeg(1) - rhog = rhet + rp - vloc(1) = vloc(1) + vscreen * rhog - eh = eh + vscreen * rhog * CONJG(rhog) - ehte = ehte + vscreen * DBLE(rhet * CONJG(rhet)) - ehti = ehti + vscreen * DBLE( rp * CONJG(rp)) - END IF - ! ... - eh = eh * omega - ehte = ehte * omega - ehti = ehti * omega - ! ... - CALL mp_sum(eh , intra_image_comm) - CALL mp_sum(ehte, intra_image_comm) - CALL mp_sum(ehti, intra_image_comm) - ! - RETURN - END SUBROUTINE vofloc_x - - - SUBROUTINE force_loc_x( tscreen, rhoeg, fion, rhops, vps, ei1, ei2, ei3, & - sfac, omega, screen_coul, lgam ) - - ! this routine computes: - ! - ! Local contribution to the forces on the ions - ! eigrx(ig,isa) = ei1( mill(1,ig), isa) - ! eigry(ig,isa) = ei2( mill(2,ig), isa) - ! eigrz(ig,isa) = ei3( mill(3,ig), isa) - ! fpibg = fpi / ( g(ig) * tpiba2 ) - ! tx_h(ig,is) = fpibg * rhops(ig, is) * CONJG( rho_e(ig) + rho_I(ig) ) - ! tx_ps(ig,is) = vps(ig,is) * CONJG( rho_e(ig) ) - ! gx(ig) = CMPLX(0.D0, gx(1,ig)) * tpiba - ! fion(x,isa) = fion(x,isa) + - ! Fact * omega * ( sum over ig, iss) (tx_h(ig,is) + tx_ps(ig,is)) * - ! gx(ig) * eigrx(ig,isa) * eigry(ig,isa) * eigrz(ig,isa) - ! if Gamma symmetry Fact = 2.0 else Fact = 1 - ! - - USE kinds, ONLY: DP - USE constants, ONLY: fpi - USE cell_base, ONLY: tpiba2, tpiba - USE grid_dimensions, ONLY: nr1, nr2, nr3 - USE reciprocal_vectors, ONLY: mill_l, gstart, gx, g - USE ions_base, ONLY: nat, nsp, na - USE gvecs, ONLY: ngs - - IMPLICIT NONE - - ! ... Arguments - - LOGICAL :: tscreen - REAL(DP) :: fion(:,:) - REAL(DP) :: rhops(:,:), vps(:,:) - COMPLEX(DP) :: rhoeg(:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - COMPLEX(DP) :: ei1(-nr1:nr1,nat) - COMPLEX(DP) :: ei2(-nr2:nr2,nat) - COMPLEX(DP) :: ei3(-nr3:nr3,nat) - REAL(DP) :: omega - COMPLEX(DP) :: screen_coul(:) - LOGICAL :: lgam - - ! ... Locals - - INTEGER :: is, ia, isa, ig, ig1, ig2, ig3 - REAL(DP) :: fpibg, fact - COMPLEX(DP) :: rhet, rhog, rp, gxc, gyc, gzc - COMPLEX(DP) :: teigr, cnvg, cvn, tx, ty, tz - COMPLEX(DP), ALLOCATABLE :: ftmp(:,:) - - ! ... Subroutine body ... - - IF(lgam) THEN - ! - fact=2.d0 - ! - ELSE - ! - fact=1.d0 - ! - ENDIF - - ALLOCATE( ftmp( 3, SIZE( fion, 2 ) ) ) - - ftmp = 0.0d0 - - DO ig = gstart, ngs - - RP = (0.D0,0.D0) - DO IS = 1, nsp - RP = RP + sfac( ig, is ) * rhops( ig, is ) - END DO - - RHET = RHOEG( ig ) - RHOG = RHET + RP - - IF( tscreen ) THEN - FPIBG = fpi / ( g(ig) * tpiba2 ) + screen_coul(ig) - ELSE - FPIBG = fpi / ( g(ig) * tpiba2 ) - END IF - - ig1 = mill_l(1,IG) - ig2 = mill_l(2,IG) - ig3 = mill_l(3,IG) - GXC = CMPLX(0.D0,gx(1,IG)) - GYC = CMPLX(0.D0,gx(2,IG)) - GZC = CMPLX(0.D0,gx(3,IG)) - isa = 1 - DO IS = 1, nsp - CNVG = RHOPS(IG,is) * FPIBG * CONJG(rhog) - CVN = VPS(ig, is) * CONJG(rhet) - TX = (CNVG+CVN) * GXC - TY = (CNVG+CVN) * GYC - TZ = (CNVG+CVN) * GZC - DO IA = 1, na(is) - TEIGR = ei1(IG1,ISA) * ei2(IG2,ISA) * ei3(IG3,ISA) - ftmp(1,ISA) = ftmp(1,ISA) + TEIGR*TX - ftmp(2,ISA) = ftmp(2,ISA) + TEIGR*TY - ftmp(3,ISA) = ftmp(3,ISA) + TEIGR*TZ - isa = isa + 1 - END DO - END DO - - END DO - ! - fion = fion + DBLE(ftmp) * fact * omega * tpiba - - DEALLOCATE( ftmp ) - - RETURN - END SUBROUTINE force_loc_x - - -! -!=----------------------------------------------------------------------------=! - SUBROUTINE vofesr( iesr, esr, desr, fion, taus, tstress, hmat ) -!=----------------------------------------------------------------------------=! - - USE kinds, ONLY : DP - USE constants, ONLY : sqrtpm1 - USE cell_base, ONLY : s_to_r, pbcs - USE mp_global, ONLY : nproc_image, me_image, intra_image_comm - USE mp, ONLY : mp_sum - USE ions_base, ONLY : rcmax, zv, nsp, na, nat - - IMPLICIT NONE - -! ... ARGUMENTS - - INTEGER, INTENT(IN) :: iesr - REAL(DP), INTENT(IN) :: taus(3,nat) - REAL(DP) :: ESR - REAL(DP) :: DESR(6) - REAL(DP) :: FION(3,nat) - LOGICAL, INTENT(IN) :: TSTRESS - REAL(DP), INTENT(in) :: hmat( 3, 3 ) - - REAL(DP), EXTERNAL :: qe_erfc - - INTEGER :: ldim_block, gind_block - EXTERNAL ldim_block, gind_block - - -! ... LOCALS - - INTEGER :: na_loc, ia_s, ia_e - INTEGER :: k, i, j, l, m, is, ia, infm, ix, iy, iz - INTEGER :: npt, isa, me - INTEGER :: iakl, iajm - LOGICAL :: tzero, tshift - INTEGER, ALLOCATABLE :: iatom(:,:) - REAL(DP), ALLOCATABLE :: zv2(:,:) - REAL(DP), ALLOCATABLE :: rc(:,:) - REAL(DP), ALLOCATABLE :: fionloc(:,:) - REAL(DP) :: rxlm(3), sxlm(3) - REAL(DP) :: xlm, ylm, zlm, erre2, rlm, arg, esrtzero - REAL(DP) :: addesr, addpre, repand, fxx - REAL(DP) :: rckj_m1 - REAL(DP) :: zv2_kj - REAL(DP) :: fact_pre - REAL(DP) :: iasp( nsp ) - - INTEGER, DIMENSION(6), PARAMETER :: ALPHA = (/ 1,2,3,2,3,3 /) - INTEGER, DIMENSION(6), PARAMETER :: BETA = (/ 1,1,1,2,2,3 /) - -! ... SUBROUTINE BODY - - me = me_image + 1 - - ! get the index of the first atom of each specie - - isa = 1 - DO is = 1, nsp - iasp( is ) = isa - isa = isa + na( is ) - END DO - - ! Here count the pairs of atoms - - npt = 0 - DO k = 1, nsp - DO j = k, nsp - DO l = 1, na(k) - IF ( k == j ) THEN - infm = l ! If the specie is the same avoid - ELSE ! atoms double counting - infm = 1 - END IF - DO m = infm, na(j) - npt = npt + 1 - END DO - END DO - END DO - END DO - - ALLOCATE( iatom( 4, npt ) ) - ALLOCATE( rc( nsp, nsp ) ) - ALLOCATE( zv2( nsp, nsp ) ) - ALLOCATE( fionloc( 3, nat ) ) - rc = 0.0_DP - zv2 = 0.0_DP - fionloc = 0.0_DP - - ! Here pre-compute some factors - - DO k = 1, nsp - DO j = k, nsp - zv2( k, j ) = zv( k ) * zv( j ) - rc ( k, j ) = SQRT( rcmax(k)**2 + rcmax(j)**2 ) - END DO - END DO - - ! Here store the indexes of all pairs of atoms - - npt = 0 - DO k = 1, nsp - DO j = k, nsp - DO l = 1, na(k) - IF (k.EQ.j) THEN - infm = l - ELSE - infm = 1 - END IF - DO m = infm, na(j) - npt = npt + 1 - iatom(1,npt) = k - iatom(2,npt) = j - iatom(3,npt) = l - iatom(4,npt) = m - END DO - END DO - END DO - END DO - - xlm = 1.0_DP - ylm = 1.0_DP - zlm = 1.0_DP - ESR = 0.0_DP - DESR = 0.0_DP - - ! Distribute the atoms pairs to processors - - NA_LOC = ldim_block( npt, nproc_image, me_image) - IA_S = gind_block( 1, npt, nproc_image, me_image ) - IA_E = IA_S + NA_LOC - 1 - - DO ia = ia_s, ia_e - - k = iatom(1,ia) - j = iatom(2,ia) - l = iatom(3,ia) - m = iatom(4,ia) - - zv2_kj = zv2(k,j) - rckj_m1 = 1.0_DP / rc(k,j) - fact_pre = (2.0_DP * zv2_kj * sqrtpm1) * rckj_m1 - - iakl = iasp(k) + l - 1 - iajm = iasp(j) + m - 1 - - IF( (l.EQ.m) .AND. (k.EQ.j)) THEN - ! ... same atoms - xlm=0.0_DP; ylm=0.0_DP; zlm=0.0_DP; - tzero=.TRUE. - ELSE - ! ... different atoms - xlm = taus(1,iakl) - taus(1,iajm) - ylm = taus(2,iakl) - taus(2,iajm) - zlm = taus(3,iakl) - taus(3,iajm) - CALL pbcs(xlm,ylm,zlm,xlm,ylm,zlm,1) - TZERO=.FALSE. - END IF - - DO IX=-IESR,IESR - sxlm(1) = XLM + DBLE(IX) - DO IY=-IESR,IESR - sxlm(2) = YLM + DBLE(IY) - DO IZ=-IESR,IESR - TSHIFT= IX.EQ.0 .AND. IY.EQ.0 .AND. IZ.EQ.0 - IF( .NOT. ( TZERO .AND. TSHIFT ) ) THEN - sxlm(3) = ZLM + DBLE(IZ) - CALL S_TO_R( sxlm, rxlm, hmat ) - ERRE2 = rxlm(1)**2 + rxlm(2)**2 + rxlm(3)**2 - RLM = SQRT(ERRE2) - ARG = RLM * rckj_m1 - IF (TZERO) THEN - ESRTZERO=0.5D0 - ELSE - ESRTZERO=1.D0 - END IF - ADDESR = ZV2_KJ * qe_erfc(ARG) / RLM - ESR = ESR + ESRTZERO*ADDESR - ADDPRE = FACT_PRE * EXP(-ARG*ARG) - REPAND = ESRTZERO*(ADDESR + ADDPRE)/ERRE2 - ! - DO i = 1, 3 - fxx = repand * rxlm( i ) - fionloc( i, iakl ) = fionloc( i, iakl ) + fxx - fionloc( i, iajm ) = fionloc( i, iajm ) - fxx - END DO - ! - IF( tstress ) THEN - DO i = 1, 6 - fxx = repand * rxlm( alpha( i ) ) * rxlm( beta( i ) ) - desr( i ) = desr( i ) - fxx - END DO - END IF - ! - END IF - END DO ! IZ - END DO ! IY - END DO ! IX - END DO - -! -! each processor add its own contribution to the array FION -! - isa = 0 - DO IS = 1, nsp - DO IA = 1, na(is) - isa = isa + 1 - FION(1,ISA) = FION(1,ISA)+FIONLOC(1,ISA) - FION(2,ISA) = FION(2,ISA)+FIONLOC(2,ISA) - FION(3,ISA) = FION(3,ISA)+FIONLOC(3,ISA) - END DO - END DO - - CALL mp_sum(esr, intra_image_comm) - - DEALLOCATE(iatom) - DEALLOCATE(rc) - DEALLOCATE(zv2) - DEALLOCATE(fionloc) - - RETURN -!=----------------------------------------------------------------------------=! - END SUBROUTINE vofesr -!=----------------------------------------------------------------------------=! - -!=----------------------------------------------------------------------------=! - SUBROUTINE self_vofhar_x( tscreen, self_ehte, vloc, rhoeg, omega, hmat ) -!=----------------------------------------------------------------------------=! - - ! adds the hartree part of the self interaction - - USE kinds, ONLY: DP - USE constants, ONLY: fpi - USE control_flags, ONLY: gamma_only !added:giovanni do_wf_cmplx - USE cell_base, ONLY: tpiba2, boxdimensions - USE gvecp, ONLY: ngm - USE reciprocal_vectors, ONLY: gstart, g - USE sic_module, ONLY: sic_epsilon - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - - IMPLICIT NONE - - ! ... Arguments - LOGICAL :: tscreen - COMPLEX(DP) :: vloc(:) - COMPLEX(DP) :: rhoeg(:,:) - REAL(DP) :: self_ehte - REAL(DP), INTENT(IN) :: omega - REAL(DP), INTENT(IN) :: hmat( 3, 3 ) - - ! ... Locals - - INTEGER :: ig - REAL(DP) :: fpibg - COMPLEX(DP) :: rhog - COMPLEX(DP) :: ehte - COMPLEX(DP) :: vscreen - COMPLEX(DP), ALLOCATABLE :: screen_coul(:) - - ! ... Subroutine body ... - - IF( tscreen ) THEN - ALLOCATE( screen_coul( ngm ) ) - CALL cluster_bc( screen_coul, g, omega, hmat ) - END IF - - !== HARTREE == - - ehte = 0.D0 - - DO IG = gstart, ngm - - rhog = rhoeg(ig,1) - rhoeg(ig,2) - - IF( tscreen ) THEN - FPIBG = fpi / ( g(ig) * tpiba2 ) + screen_coul(ig) - ELSE - FPIBG = fpi / ( g(ig) * tpiba2 ) - END IF - - vloc(ig) = fpibg * rhog - ehte = ehte + fpibg * rhog * CONJG(rhog) - - END DO - - ! ... G = 0 element - ! - IF ( gstart == 2 ) THEN - rhog = rhoeg(1,1) - rhoeg(1,2) - IF( tscreen ) THEN - vscreen = screen_coul(1) - ELSE - vscreen = 0.0d0 - END IF - vloc(1) = vscreen * rhog - ehte = ehte + vscreen * rhog * CONJG(rhog) - END IF - - ! ... - - IF( .NOT. gamma_only ) THEN - ehte = ehte * 0.5d0 - END IF - ! - self_ehte = DBLE(ehte) * omega * sic_epsilon - vloc = vloc * sic_epsilon - - CALL mp_sum( self_ehte, intra_image_comm ) - - IF( ALLOCATED( screen_coul ) ) DEALLOCATE( screen_coul ) - - RETURN -!=----------------------------------------------------------------------------=! - END SUBROUTINE self_vofhar_x -!=----------------------------------------------------------------------------=! - - - -!=----------------------------------------------------------------------------=! - SUBROUTINE localisation_x( wfc, atoms_m, ht) -!=----------------------------------------------------------------------------=! - - - USE kinds, ONLY: DP - USE constants, ONLY: fpi - USE control_flags, ONLY: gamma_only !added:giovanni do_wf_cmplx - USE atoms_type_module, ONLY: atoms_type - USE sic_module, ONLY: ind_localisation - USE sic_module, ONLY: sic_rloc, pos_localisation - USE ions_base, ONLY: ind_srt - USE fft_base, ONLY: dfftp, dffts - USE cell_base, ONLY: tpiba2, boxdimensions, s_to_r - USE reciprocal_vectors, ONLY: gstart, g - USE gvecp, ONLY: ngm - USE gvecw, ONLY: ngw - use grid_dimensions, only: nr1l, nr2l, nr3l, nnrx - USE cp_interfaces, ONLY: fwfft, invfft - - IMPLICIT NONE - -! ... Arguments - - COMPLEX(DP), INTENT(IN) :: wfc(:) - TYPE (atoms_type), INTENT(in) :: atoms_m - TYPE (boxdimensions), INTENT(in) :: ht - - -! ... Locals - - REAL(DP) :: ehte - INTEGER :: ig, ia, is, isa_input, isa_sorted, isa_loc - REAL(DP) :: fpibg, omega, R(3) - INTEGER :: Xmin, Ymin, Zmin, Xmax, Ymax, Zmax, i,j,k, ir - REAL(DP) :: work, work2 - COMPLEX(DP) :: rhog - COMPLEX(DP), ALLOCATABLE :: density(:), psi(:) - COMPLEX(DP), ALLOCATABLE :: k_density(:) - COMPLEX(DP) :: vscreen - COMPLEX(DP), ALLOCATABLE :: screen_coul(:) - -! ... Subroutine body ... - - - IF( .FALSE. ) THEN - ALLOCATE( screen_coul( ngm ) ) - CALL cluster_bc( screen_coul, g, ht%deth, ht%hmat ) - END IF - - - omega = ht%deth - - ALLOCATE( density( nnrx ) ) - ALLOCATE( psi( nnrx ) ) - ALLOCATE( k_density( ngm ) ) - - CALL c2psi( psi, dffts%nnr, wfc, wfc, ngw, 1 ) - CALL invfft( 'Wave', psi, dffts ) - - psi = DBLE( psi ) - - isa_sorted = 0 - isa_loc = 0 - - DO is = 1, atoms_m%nsp - - DO ia = 1, atoms_m%na( is ) - - isa_sorted = isa_sorted + 1 ! index of the atom as is in the sorted %tau atom_type component - isa_input = ind_srt( isa_sorted ) ! index of the atom as is in the input card ATOMIC_POSITIONS - - IF( ind_localisation( isa_input ) > 0 ) THEN - - isa_loc = isa_loc + 1 ! index of the localised atom ( 1 ... nat_localisation ) - - IF( isa_loc > SIZE( pos_localisation, 2 ) ) & - CALL errore( ' localisation ', ' too many localization ', isa_loc ) - - ehte = 0.D0 - R( : ) = atoms_m%taus( :, isa_sorted ) - CALL s_to_r ( R, pos_localisation( 1:3 , isa_loc ), ht ) - - !WRITE(6,*) 'ATOM ', ind_localisation( isa_input ) - !WRITE(6,*) 'POS ', atoms_m%taus( :, isa_sorted ) - - work = nr1l - work2 = sic_rloc * work - work = work * R(1) - work2 - Xmin = FLOOR(work) - work = work + 2*work2 - Xmax = FLOOR(work) - IF ( Xmax > nr1l ) Xmax = nr1l - IF ( Xmin < 1 ) Xmin = 1 - - work = nr2l - work2 = sic_rloc * work - work = work * R(2) - work2 - Ymin = FLOOR(work) - work = work + 2*work2 - Ymax = FLOOR(work) - IF ( Ymax > nr2l ) Ymax = nr2l - IF ( Ymin < 1 ) Ymin = 1 - - work = nr3l - work2 = sic_rloc * work - work = work * R(3) - work2 - Zmin = FLOOR(work) - work = work + 2*work2 - Zmax = FLOOR(work) - IF ( Zmax > nr3l ) Zmax = nr3l - IF ( Zmin < 1 ) Zmin = 1 - - density = 0.D0 - - DO k = Zmin, Zmax - DO j = Ymin, Ymax - DO i = Xmin, Xmax - ir = i + (j-1)*dfftp%nr1x + (k-1)*dfftp%nr1x*dfftp%nr2x - density( ir ) = psi( ir ) * psi( ir ) - END DO - END DO - END DO - - CALL fwfft( 'Dense', density, dfftp ) - CALL psi2rho( 'Dense', density, dfftp%nnr, k_density, ngm ) - -! ... G /= 0 elements - - DO IG = gstart, ngm - - rhog = k_density(ig) - IF( .FALSE. ) THEN - FPIBG = fpi / ( g(ig) * tpiba2 ) + screen_coul(ig) - ELSE - FPIBG = fpi / ( g(ig) * tpiba2 ) - END IF - - ehte = ehte + fpibg * DBLE(rhog * CONJG(rhog)) - - END DO - -! ... G = 0 element - - IF ( gstart == 2 ) THEN - IF( .FALSE. ) THEN - vscreen = screen_coul(1) - ELSE - vscreen = 0.0d0 - END IF - rhog = k_density(1) - ehte = ehte + vscreen * DBLE(rhog * CONJG(rhog)) - END IF -! ... - IF( .NOT. gamma_only ) THEN - ehte = ehte * 0.5d0 - END IF - ehte = ehte * omega - pos_localisation( 4, isa_loc ) = ehte - - END IF ! ind_localisation - - END DO ! ia - - END DO ! is - - ! CALL errore( 'DEBUG', ' qui ', 1 ) - -! ... - IF( ALLOCATED(screen_coul) ) DEALLOCATE( screen_coul ) - DEALLOCATE( k_density, density, psi ) - - RETURN - END SUBROUTINE localisation_x - diff --git a/quantum_espresso/kcp/CPV/pres_ai_mod.f90 b/quantum_espresso/kcp/CPV/pres_ai_mod.f90 deleted file mode 100644 index 990374bc4..000000000 --- a/quantum_espresso/kcp/CPV/pres_ai_mod.f90 +++ /dev/null @@ -1,81 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -!=----------------------------------------------------------------------------=! - MODULE pres_ai_mod -!=----------------------------------------------------------------------------=! - - use kinds, only: dp - use parameters, only: nsx - IMPLICIT NONE -! - SAVE -! - logical :: abivol, abisur, pvar, fill_vac, scale_at, t_gauss, jellium - logical :: cntr(nsx) - real(dp), allocatable:: rho_gaus(:), posv(:,:), v_vol(:), f_vol(:,:,:) - real(dp) :: P_ext, P_in, P_fin, rho_thr, step_rad(nsx) - real(dp) :: Surf_t, dthr, volclu, surfclu, n_ele, nelect - real(dp) :: R_j, e_j, h_j - real(dp) :: stress_vol(3,3) - real(dp) :: delta_eps, delta_sigma - real(dp) :: xc0(500), weight(500) - integer :: n_cntr, axis - -CONTAINS - - !---------------------------------------------------------------------- - SUBROUTINE pres_ai_init (abivol_, abisur_, pvar_, fill_vac_, & - scale_at_, t_gauss_, jellium_, cntr_, & - P_ext_, P_in_, P_fin_, rho_thr_, & - step_rad_, Surf_t_, dthr_, R_j_, h_j_, & - delta_eps_, delta_sigma_, n_cntr_, axis_) - !---------------------------------------------------------------------- - ! - USE constants, ONLY : au_gpa - ! - IMPLICIT NONE - ! - LOGICAL :: abivol_, abisur_, pvar_, fill_vac_, scale_at_, & - t_gauss_, jellium_, cntr_(nsx) - REAL(dp) :: P_ext_, P_in_, P_fin_, rho_thr_, step_rad_(nsx), & - Surf_t_, dthr_, R_j_, h_j_, delta_eps_, delta_sigma_ - INTEGER :: n_cntr_, axis_ - ! - ! Copy variables read from input into module - ! - abivol = abivol_ - abisur = abisur_ - pvar = pvar_ - fill_vac = fill_vac_ - scale_at = scale_at_ - t_gauss = t_gauss_ - cntr_(:) = cntr_(:) - jellium = .false. ! provvisorio - rho_thr = rho_thr_ - step_rad(:) = step_rad_(:) - Surf_t = Surf_t_ - dthr = dthr_ - R_j = R_j_ - h_j = h_j_ - delta_eps = delta_eps_ - delta_sigma = delta_sigma_ - n_cntr = n_cntr_ - axis = axis_ - ! - ! Correct (a.u.) units to pressure - ! - P_ext = P_ext_ / au_gpa - P_in = P_in_ / au_gpa - P_fin = P_fin_ / au_gpa - if (pvar) P_ext = P_in - ! - END SUBROUTINE pres_ai_init -!=----------------------------------------------------------------------------=! - END MODULE pres_ai_mod -!=----------------------------------------------------------------------------=! diff --git a/quantum_espresso/kcp/CPV/print_out.f90 b/quantum_espresso/kcp/CPV/print_out.f90 deleted file mode 100644 index d47bed96f..000000000 --- a/quantum_espresso/kcp/CPV/print_out.f90 +++ /dev/null @@ -1,1190 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!=----------------------------------------------------------------------------=! - SUBROUTINE printout_new_real_x & - ( nfi, tfirst, tfilei, tstdouti, tprint, tps, h, stress, tau0, vels, & - fion, ekinc, temphc, tempp, temps, etot, enthal, econs, econt, & - vnhh, xnhh0, vnhp, xnhp0, atot, ekin, epot, print_forces, print_stress, & - hamilt, print_hamilt_norm ) -!=----------------------------------------------------------------------------=! - - ! - USE kinds, ONLY : DP - USE control_flags, ONLY : iprint, textfor, do_makov_payne - USE energies, ONLY : print_energies, dft_energy_type - USE printout_base, ONLY : printout_base_open, printout_base_close, & - printout_pos, printout_cell, printout_stress, & - printout_matrix_norm - USE constants, ONLY : au_gpa, amu_si, bohr_radius_cm, & - amu_au, BOHR_RADIUS_ANGS, pi - USE ions_base, ONLY : na, nsp, nat, ind_bck, pmass, cdmi, & - ions_cofmass, ions_displacement, label_srt - USE cell_base, ONLY : s_to_r, get_volume - USE efield_module, ONLY : tefield, pberryel, pberryion, & - tefield2, pberryel2, pberryion2 - USE cg_module, ONLY : tcg, itercg - USE sic_module, ONLY : self_interaction, sic_alpha, sic_epsilon - USE electrons_module, ONLY : print_eigenvalues, print_centers_spreads !added:giovanni print_centers_spreads - USE electrons_base, ONLY : nspin - USE pres_ai_mod, ONLY : P_ext, Surf_t, volclu, surfclu, abivol, & - abisur, pvar, n_ele - - USE xml_io_base, ONLY : save_print_counter - USE cp_main_variables, ONLY : nprint_nfi, iprint_stdout - USE io_files, ONLY : outdir - USE control_flags, ONLY : ndw, tdipole - USE polarization, ONLY : print_dipole - USE io_global, ONLY : ionode, stdout - use eecp_mod, only : do_comp, ecomp - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nfi - LOGICAL, INTENT(IN) :: tfirst, tfilei, tprint, tstdouti - REAL(DP), INTENT(IN) :: tps - REAL(DP), INTENT(IN) :: h( 3, 3 ) - REAL(DP), INTENT(IN) :: stress( 3, 3 ) - REAL(DP), INTENT(IN) :: tau0( :, : ) ! real positions - REAL(DP), INTENT(IN) :: vels( :, : ) ! scaled velocities - REAL(DP), INTENT(IN) :: fion( :, : ) ! real forces - REAL(DP), INTENT(IN) :: ekinc, temphc, tempp, etot, enthal, econs, econt - REAL(DP), INTENT(IN) :: temps( : ) ! partial temperature for different ionic species - REAL(DP), INTENT(IN) :: vnhh( 3, 3 ), xnhh0( 3, 3 ), vnhp( 1 ), xnhp0( 1 ) - REAL(DP), INTENT(IN) :: atot! enthalpy of system for c.g. case - REAL(DP), INTENT(IN) :: ekin - REAL(DP), INTENT(IN) :: epot ! ( epseu + eht + exc ) - LOGICAL, INTENT(IN) :: print_forces, print_stress - REAL(DP), OPTIONAL, INTENT(IN) :: hamilt(:, :, :) - LOGICAL, OPTIONAL, INTENT(IN) :: print_hamilt_norm - ! - REAL(DP) :: stress_gpa( 3, 3 ) - REAL(DP) :: cdm0( 3 ) - REAL(DP) :: dis( nsp ) - REAL(DP) :: out_press, volume - REAL(DP) :: totalmass - REAL(DP) :: hamn_h, hamn_ah - REAL(DP) :: ham_h, ham_ah - INTEGER :: i, j, isp, isa, is, ia, kilobytes - REAL(DP), ALLOCATABLE :: tauw( :, : ) - LOGICAL :: tsic, tfile, tstdout - LOGICAL, PARAMETER :: nice_output_files=.false. - ! - ! avoid double printing to files by refering to nprint_nfi - ! - tfile = tfilei .and. ( nfi .gt. nprint_nfi ) - tstdout = tstdouti .or. ( MOD( nfi, iprint_stdout ) == 0 ) - ! - CALL memstat( kilobytes ) - ! - IF( ionode .AND. tfile .AND. tprint ) THEN - CALL printout_base_open() - END IF - ! - IF( tprint ) THEN - IF ( tfile ) THEN - ! we're writing files, let's save nfi - CALL save_print_counter( nfi, outdir, ndw ) - ELSE IF ( tfilei ) then - ! not there yet, save the old nprint_nfi - CALL save_print_counter( nprint_nfi, outdir, ndw ) - END IF - END IF - ! - volume = get_volume( h ) - ! - stress_gpa = stress * au_gpa - ! - out_press = ( stress_gpa(1,1) + stress_gpa(2,2) + stress_gpa(3,3) ) / 3.0d0 - ! - IF( nfi > 0 ) THEN - CALL update_accomulators & - ( ekinc, ekin, epot, etot, tempp, enthal, econs, out_press, volume ) - END IF - ! - ! Makov-Payne correction to the total energy (isolated systems only) - ! - IF( do_makov_payne ) CALL makov_payne( etot ) - ! - IF( ionode ) THEN - ! - IF( tprint ) THEN - ! - tsic = ( self_interaction /= 0 ) - ! - IF(tstdout) & - CALL print_energies( tsic, sic_alpha = sic_alpha, sic_epsilon = sic_epsilon, textfor = textfor ) - ! - CALL print_eigenvalues( 31, tfile, tstdout, nfi, tps ) - ! - CALL print_centers_spreads( 31, tfile, tstdout, nfi, tps ) - ! - ! - IF(tstdout) WRITE( stdout, * ) - ! - IF( kilobytes > 0 .AND. tstdout ) & - WRITE( stdout, fmt="(3X,'Allocated memory (kb) = ', I9 )" ) kilobytes - ! - IF(tstdout) WRITE( stdout, * ) - ! - IF( tdipole ) CALL print_dipole( 32, tfile, nfi, tps ) - ! - IF(tstdout) CALL printout_cell( stdout, h ) - ! - IF( tfile ) CALL printout_cell( 36, h, nfi, tps ) - ! - ! - IF ( PRESENT(hamilt) .AND. PRESENT(print_hamilt_norm) ) THEN - ! - hamn_h=0.0d0 - hamn_ah=0.0d0 - ! - IF( tfile .AND. print_hamilt_norm ) THEN - ! - DO isp = 1, nspin - ! - DO j = 1, SIZE( hamilt, 2) - DO i = 1, SIZE( hamilt, 1) - ! - ham_h = 0.5d0 * ( hamilt(i,j,isp) + hamilt(j,i,isp) ) - ham_ah = 0.5d0 * ( hamilt(i,j,isp) - hamilt(j,i,isp) ) - ! - hamn_h = hamn_h + DBLE( ham_h * ham_h ) - hamn_ah = hamn_ah + DBLE( ham_ah * ham_ah ) - ! - ENDDO - ENDDO - ENDDO - ! - CALL printout_matrix_norm( 43, hamn_h, hamn_ah, nfi ) - ! - ENDIF - ! - ENDIF - ! - ! System density: - ! - totalmass = 0.0d0 - DO is = 1, nsp - totalmass = totalmass + pmass(is) * na(is) / amu_au - END DO - totalmass = totalmass / volume * 11.2061d0 ! AMU_SI * 1000.0 / BOHR_RADIUS_CM**3 - IF(tstdout) & - WRITE( stdout, fmt='(/,3X,"System Density [g/cm^3] : ",F10.4,/)' ) totalmass - ! - ! Compute Center of mass displacement since the initialization of step counter - ! - CALL ions_cofmass( tau0, pmass, na, nsp, cdm0 ) - ! - IF(tstdout) & - WRITE( stdout,1000) SUM( ( cdm0(:)-cdmi(:) )**2 ) - ! - CALL ions_displacement( dis, tau0 ) - ! - IF( print_stress ) THEN - ! - IF(tstdout) & - CALL printout_stress( stdout, stress_gpa ) - ! - IF( tfile ) CALL printout_stress( 38, stress_gpa, nfi, tps ) - ! - END IF - ! - ! ... write out a standard XYZ file in angstroms - ! - IF(tstdout) & - CALL printout_pos( stdout, tau0, nat, what = 'pos', & - label = label_srt, sort = ind_bck ) - ! - IF( tfile ) then - if (.not.nice_output_files) then - CALL printout_pos( 35, tau0, nat, nfi = nfi, tps = tps ) - else - CALL printout_pos( 35, tau0, nat, what = 'xyz', & - nfi = nfi, tps = tps, label = label_srt, & - fact= BOHR_RADIUS_ANGS ,sort = ind_bck ) - endif - END IF - ! - ALLOCATE( tauw( 3, nat ) ) - ! - isa = 0 - ! - DO is = 1, nsp - ! - DO ia = 1, na(is) - ! - isa = isa + 1 - ! - CALL s_to_r( vels(:,isa), tauw(:,isa), h ) - ! - END DO - ! - END DO - ! - IF(tstdout) WRITE( stdout, * ) - ! - IF(tstdout) & - CALL printout_pos( stdout, tauw, nat, & - what = 'vel', label = label_srt, sort = ind_bck ) - ! - IF( tfile ) then - if (.not.nice_output_files) then - CALL printout_pos( 34, tauw, nat, nfi = nfi, tps = tps ) - else - CALL printout_pos( 34, tauw, nat, nfi = nfi, tps = tps, & - what = 'vel', label = label_srt, sort = ind_bck ) - endif - END IF - ! - IF( print_forces ) THEN - ! - IF(tstdout) WRITE( stdout, * ) - ! - IF(tstdout) & - CALL printout_pos( stdout, fion, nat, & - what = 'for', label = label_srt, sort = ind_bck ) - ! - IF( tfile ) then - if (.not.nice_output_files) then - CALL printout_pos( 37, fion, nat, nfi = nfi, tps = tps ) - else - CALL printout_pos( 37, fion, nat, nfi = nfi, tps = tps, & - what = 'for', label = label_srt, sort = ind_bck ) - endif - END IF - ! - END IF - ! - DEALLOCATE( tauw ) - ! - ! ... Write partial temperature and MSD for each atomic specie tu stdout - ! - IF(tstdout) WRITE( stdout, * ) - IF(tstdout) WRITE( stdout, 1944 ) - ! - DO is = 1, nsp - IF( tstdout ) WRITE( stdout, 1945 ) is, temps(is), dis(is) - END DO - ! - IF( tfile ) WRITE( 33, 2948 ) nfi, ekinc, temphc, tempp, etot, enthal, & - econs, econt, volume, out_press, tps - IF( tfile ) WRITE( 39, 2949 ) nfi, vnhh(3,3), xnhh0(3,3), vnhp(1), & - xnhp0(1), tps - ! - END IF - ! - END IF - ! - - IF( ionode .AND. tfile .AND. tprint ) THEN - ! - ! ... Close and flush unit 30, ... 40 - ! - CALL printout_base_close() - ! - END IF - ! - IF( ( MOD( nfi, iprint_stdout ) == 0 ) .OR. tfirst ) THEN - ! - WRITE( stdout, * ) - WRITE( stdout, 1947 ) - IF ( abivol .AND. pvar ) write(stdout,*) 'P = ', P_ext*au_gpa - ! - END IF - ! - if (abivol) then - write(stdout,*) nfi, 'ab-initio volume = ', volclu, ' a.u.^3' - write(stdout,*) nfi, 'PV = ', P_ext*volclu, ' ha' - end if - if (abisur) then - write(stdout,*) nfi, 'ab-initio surface = ', surfclu, ' a.u.^2' - if (abivol) write(stdout,*) nfi, 'spherical surface = ', & - 4.d0*pi*(0.75d0*volclu/pi)**(2.d0/3.d0), ' a.u.^2' - write(stdout,*) nfi, 't*S = ', Surf_t*surfclu, ' ha' - end if - if (abivol.or.abisur) write(stdout,*) nfi, & - ' # of electrons within the isosurface = ', n_ele - - IF( .not. tcg ) THEN - ! - if( .not. do_comp ) then - WRITE( stdout, 1948 ) nfi, ekinc, temphc, tempp, etot, enthal, econs, & - econt, vnhh(3,3), xnhh0(3,3), vnhp(1), xnhp0(1) - else - WRITE( stdout, 1960 ) nfi, ekinc, temphc, tempp, etot, enthal, econs, & - econt, vnhh(3,3), xnhh0(3,3), vnhp(1), xnhp0(1), & - ecomp - end if - ELSE - IF ( MOD( nfi, iprint ) == 0 .OR. tfirst ) THEN - ! - WRITE( stdout, * ) - WRITE( stdout, 255 ) 'nfi','tempp','E','-T.S-mu.nbsp','+K_p','#Iter' - ! - END IF - ! - WRITE( stdout, 256 ) nfi, INT( tempp ), etot, atot, econs, itercg - ! - END IF - - IF( tefield) THEN - IF(ionode) write(stdout,'( A14,F12.6,2X,A14,F12.6)') 'Elct. dipole 1',-pberryel,'Ionic dipole 1',-pberryion - ENDIF - IF( tefield2) THEN - IF(ionode) write(stdout,'( A14,F12.6,2X,A14,F12.6)') 'Elct. dipole 2',-pberryel2,'Ionic dipole 2',-pberryion2 - ENDIF - ! - ! -255 FORMAT( ' ',A5,A8,3(1X,A12),A6 ) -256 FORMAT( 'Step ',I5,1X,I7,1X,F12.5,1X,F12.5,1X,F12.5,1X,I5 ) -1000 FORMAT(/,3X,'Center of mass square displacement (a.u.): ',F10.6,/) -1944 FORMAT(//' Partial temperatures (for each ionic specie) ', & - /,' Species Temp (K) Mean Square Displacement (a.u.)') -1945 FORMAT(3X,I6,1X,F10.2,1X,F10.4) -1947 FORMAT( 2X,'nfi',4X,'ekinc',2X,'temph',2X,'tempp',8X,'etot',6X,'enthal', & - & 7X,'econs',7X,'econt',4X,'vnhh',3X,'xnhh0',4X,'vnhp',3X,'xnhp0' ) -1948 FORMAT( I5,1X,F12.2,1X,F6.1,1X,F6.1,4(1X,F11.5),4(1X,F7.4) ) -1960 FORMAT( I5,1X,F18.10,1X,F11.1,1X,F6.1,4(1X,F11.5),4(1X,F7.4),1X,F11.5) -2948 FORMAT( I6,1X,ES18.10,1X,ES18.10,1X,ES18.10,4(1X,ES18.10),ES18.10, ES18.10, ES18.10 ) -2949 FORMAT( I6,1X,4(1X,ES18.10), ES18.10 ) - ! - RETURN - END SUBROUTINE printout_new_real_x - ! -!=----------------------------------------------------------------------------=! - SUBROUTINE printout_new_twin_x & - ( nfi, tfirst, tfilei, tstdouti, tprint, tps, h, stress, tau0, vels, & - fion, ekinc, temphc, tempp, temps, etot, enthal, econs, econt, & - vnhh, xnhh0, vnhp, xnhp0, atot, ekin, epot, print_forces, print_stress, & - hamilt, print_hamilt_norm, lgam ) -!=----------------------------------------------------------------------------=! - - ! - USE kinds, ONLY : DP - USE control_flags, ONLY : iprint, textfor, do_makov_payne - USE energies, ONLY : print_energies, dft_energy_type - USE printout_base, ONLY : printout_base_open, printout_base_close, & - printout_pos, printout_cell, printout_stress, & - printout_matrix_norm - USE constants, ONLY : au_gpa, amu_si, bohr_radius_cm, & - amu_au, BOHR_RADIUS_ANGS, pi - USE ions_base, ONLY : na, nsp, nat, ind_bck, pmass, cdmi, & - ions_cofmass, ions_displacement, label_srt - USE cell_base, ONLY : s_to_r, get_volume - USE efield_module, ONLY : tefield, pberryel, pberryion, & - tefield2, pberryel2, pberryion2 - USE cg_module, ONLY : tcg, itercg - USE sic_module, ONLY : self_interaction, sic_alpha, sic_epsilon - USE electrons_module, ONLY : print_eigenvalues, print_centers_spreads !added:giovanni print_centers_spreads - USE electrons_base, ONLY : nspin - USE pres_ai_mod, ONLY : P_ext, Surf_t, volclu, surfclu, abivol, & - abisur, pvar, n_ele - - USE xml_io_base, ONLY : save_print_counter - USE cp_main_variables, ONLY : nprint_nfi, iprint_stdout - USE io_files, ONLY : outdir - USE control_flags, ONLY : ndw, tdipole - USE polarization, ONLY : print_dipole - USE io_global, ONLY : ionode, stdout - use eecp_mod, only : do_comp, ecomp - use twin_types - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nfi - LOGICAL, INTENT(IN) :: tfirst, tfilei, tprint, tstdouti - REAL(DP), INTENT(IN) :: tps - REAL(DP), INTENT(IN) :: h( 3, 3 ) - REAL(DP), INTENT(IN) :: stress( 3, 3 ) - REAL(DP), INTENT(IN) :: tau0( :, : ) ! real positions - REAL(DP), INTENT(IN) :: vels( :, : ) ! scaled velocities - REAL(DP), INTENT(IN) :: fion( :, : ) ! real forces - REAL(DP), INTENT(IN) :: ekinc, temphc, tempp, etot, enthal, econs, econt - REAL(DP), INTENT(IN) :: temps( : ) ! partial temperature for different ionic species - REAL(DP), INTENT(IN) :: vnhh( 3, 3 ), xnhh0( 3, 3 ), vnhp( 1 ), xnhp0( 1 ) - REAL(DP), INTENT(IN) :: atot! enthalpy of system for c.g. case - REAL(DP), INTENT(IN) :: ekin - REAL(DP), INTENT(IN) :: epot ! ( epseu + eht + exc ) - LOGICAL, INTENT(IN) :: print_forces, print_stress - type(twin_matrix), dimension(:), OPTIONAL, INTENT(IN) :: hamilt - LOGICAL, OPTIONAL, INTENT(IN) :: print_hamilt_norm - ! - REAL(DP) :: stress_gpa( 3, 3 ) - REAL(DP) :: cdm0( 3 ) - REAL(DP) :: dis( nsp ) - REAL(DP) :: out_press, volume - REAL(DP) :: totalmass - REAL(DP) :: hamn_h, hamn_ah - REAL(DP) :: ham_h, ham_ah -! COMPLEX(DP) :: hamn_h, hamn_ah - COMPLEX(DP) :: ham_h_c, ham_ah_c - INTEGER :: i, j, isp, isa, is, ia, kilobytes - REAL(DP), ALLOCATABLE :: tauw( :, : ) - LOGICAL :: tsic, tfile, tstdout - LOGICAL, PARAMETER :: nice_output_files=.false. - LOGICAL, INTENT(IN) :: lgam - ! - ! avoid double printing to files by refering to nprint_nfi - ! - tfile = tfilei .and. ( nfi .gt. nprint_nfi ) - tstdout = tstdouti .or. ( MOD( nfi, iprint_stdout ) == 0 ) - ! - CALL memstat( kilobytes ) - ! - IF( ionode .AND. tfile .AND. tprint ) THEN - CALL printout_base_open() - END IF - ! - IF( tprint ) THEN - IF ( tfile ) THEN - ! we're writing files, let's save nfi - CALL save_print_counter( nfi, outdir, ndw ) - ELSE IF ( tfilei ) then - ! not there yet, save the old nprint_nfi - CALL save_print_counter( nprint_nfi, outdir, ndw ) - END IF - END IF - ! - volume = get_volume( h ) - ! - stress_gpa = stress * au_gpa - ! - out_press = ( stress_gpa(1,1) + stress_gpa(2,2) + stress_gpa(3,3) ) / 3.0d0 - ! - IF( nfi > 0 ) THEN - CALL update_accomulators & - ( ekinc, ekin, epot, etot, tempp, enthal, econs, out_press, volume ) - END IF - ! - ! Makov-Payne correction to the total energy (isolated systems only) - ! - IF( do_makov_payne ) CALL makov_payne( etot ) - ! - IF( ionode ) THEN - ! - IF( tprint ) THEN - ! - tsic = ( self_interaction /= 0 ) - ! - IF(tstdout) & - CALL print_energies( tsic, sic_alpha = sic_alpha, sic_epsilon = sic_epsilon, textfor = textfor ) - ! - CALL print_eigenvalues( 31, tfile, tstdout, nfi, tps ) - ! - CALL print_centers_spreads( 31, tfile, tstdout, nfi, tps ) - ! - IF(tstdout) WRITE( stdout, * ) - ! - IF( kilobytes > 0 .AND. tstdout ) & - WRITE( stdout, fmt="(3X,'Allocated memory (kb) = ', I9 )" ) kilobytes - ! - IF(tstdout) WRITE( stdout, * ) - ! - IF( tdipole ) CALL print_dipole( 32, tfile, nfi, tps ) - ! - IF(tstdout) CALL printout_cell( stdout, h ) - ! - IF( tfile ) CALL printout_cell( 36, h, nfi, tps ) - ! - ! - IF ( PRESENT(hamilt) .AND. PRESENT(print_hamilt_norm) ) THEN - ! - hamn_h=0.0d0 - hamn_ah=0.0d0 - ! - IF( tfile .AND. print_hamilt_norm ) THEN - ! - DO isp = 1, nspin - ! - IF(.not.hamilt(isp)%iscmplx) THEN - DO j = 1, hamilt(isp)%ydim - DO i = 1, hamilt(isp)%xdim - ! - ham_h = 0.5d0 * ( hamilt(isp)%rvec(i,j) + hamilt(isp)%rvec(j,i) ) - ham_ah = 0.5d0 * ( hamilt(isp)%rvec(i,j) - hamilt(isp)%rvec(j,i) ) - ! - hamn_h = hamn_h + DBLE( ham_h * ham_h ) - hamn_ah = hamn_ah + DBLE( ham_ah * ham_ah ) - ! - ENDDO - ENDDO - ELSE - DO j = 1, hamilt(isp)%ydim - DO i = 1, hamilt(isp)%xdim - ! - ham_h_c = 0.5d0 * ( hamilt(isp)%cvec(i,j) + CONJG(hamilt(isp)%cvec(j,i) )) - ham_ah_c = 0.5d0 * ( hamilt(isp)%cvec(i,j) - CONJG(hamilt(isp)%cvec(j,i)) ) - ! - hamn_h = hamn_h + ABS( ham_h_c * ham_h_c ) !warning:giovanni do not know what to put here - hamn_ah = hamn_ah + ABS( ham_ah_c * ham_ah_c )!warning:giovanni do not know what to put here - ! - ENDDO - ENDDO - ENDIF - ENDDO - ! - CALL printout_matrix_norm( 43, hamn_h, hamn_ah, nfi ) - ! - ENDIF - ! - ENDIF - - ! - ! System density: - ! - totalmass = 0.0d0 - DO is = 1, nsp - totalmass = totalmass + pmass(is) * na(is) / amu_au - END DO - totalmass = totalmass / volume * 11.2061d0 ! AMU_SI * 1000.0 / BOHR_RADIUS_CM**3 - IF(tstdout) & - WRITE( stdout, fmt='(/,3X,"System Density [g/cm^3] : ",F10.4,/)' ) totalmass - ! - ! Compute Center of mass displacement since the initialization of step counter - ! - CALL ions_cofmass( tau0, pmass, na, nsp, cdm0 ) - ! - IF(tstdout) & - WRITE( stdout,1000) SUM( ( cdm0(:)-cdmi(:) )**2 ) - ! - CALL ions_displacement( dis, tau0 ) - ! - IF( print_stress ) THEN - ! - IF(tstdout) & - CALL printout_stress( stdout, stress_gpa ) - ! - IF( tfile ) CALL printout_stress( 38, stress_gpa, nfi, tps ) - ! - END IF - ! - ! ... write out a standard XYZ file in angstroms - ! - IF(tstdout) & - CALL printout_pos( stdout, tau0, nat, what = 'pos', & - label = label_srt, sort = ind_bck ) - ! - IF( tfile ) then - if (.not.nice_output_files) then - CALL printout_pos( 35, tau0, nat, nfi = nfi, tps = tps ) - else - CALL printout_pos( 35, tau0, nat, what = 'xyz', & - nfi = nfi, tps = tps, label = label_srt, & - fact= BOHR_RADIUS_ANGS ,sort = ind_bck ) - endif - END IF - ! - ALLOCATE( tauw( 3, nat ) ) - ! - isa = 0 - ! - DO is = 1, nsp - ! - DO ia = 1, na(is) - ! - isa = isa + 1 - ! - CALL s_to_r( vels(:,isa), tauw(:,isa), h ) - ! - END DO - ! - END DO - ! - IF(tstdout) WRITE( stdout, * ) - ! - IF(tstdout) & - CALL printout_pos( stdout, tauw, nat, & - what = 'vel', label = label_srt, sort = ind_bck ) - ! - IF( tfile ) then - if (.not.nice_output_files) then - CALL printout_pos( 34, tauw, nat, nfi = nfi, tps = tps ) - else - CALL printout_pos( 34, tauw, nat, nfi = nfi, tps = tps, & - what = 'vel', label = label_srt, sort = ind_bck ) - endif - END IF - ! - IF( print_forces ) THEN - ! - IF(tstdout) WRITE( stdout, * ) - ! - IF(tstdout) & - CALL printout_pos( stdout, fion, nat, & - what = 'for', label = label_srt, sort = ind_bck ) - ! - IF( tfile ) then - if (.not.nice_output_files) then - CALL printout_pos( 37, fion, nat, nfi = nfi, tps = tps ) - else - CALL printout_pos( 37, fion, nat, nfi = nfi, tps = tps, & - what = 'for', label = label_srt, sort = ind_bck ) - endif - END IF - ! - END IF - ! - DEALLOCATE( tauw ) - ! - ! ... Write partial temperature and MSD for each atomic specie tu stdout - ! - IF(tstdout) WRITE( stdout, * ) - IF(tstdout) WRITE( stdout, 1944 ) - ! - DO is = 1, nsp - IF( tstdout ) WRITE( stdout, 1945 ) is, temps(is), dis(is) - END DO - ! - IF( tfile ) WRITE( 33, 2948 ) nfi, ekinc, temphc, tempp, etot, enthal, & - econs, econt, volume, out_press, tps - IF( tfile ) WRITE( 39, 2949 ) nfi, vnhh(3,3), xnhh0(3,3), vnhp(1), & - xnhp0(1), tps - ! - END IF - ! - END IF - ! - - IF( ionode .AND. tfile .AND. tprint ) THEN - ! - ! ... Close and flush unit 30, ... 40 - ! - CALL printout_base_close() - ! - END IF - ! - IF( ( MOD( nfi, iprint_stdout ) == 0 ) .OR. tfirst ) THEN - ! - WRITE( stdout, * ) - WRITE( stdout, 1947 ) - IF ( abivol .AND. pvar ) write(stdout,*) 'P = ', P_ext*au_gpa - ! - END IF - ! - if (abivol) then - write(stdout,*) nfi, 'ab-initio volume = ', volclu, ' a.u.^3' - write(stdout,*) nfi, 'PV = ', P_ext*volclu, ' ha' - end if - if (abisur) then - write(stdout,*) nfi, 'ab-initio surface = ', surfclu, ' a.u.^2' - if (abivol) write(stdout,*) nfi, 'spherical surface = ', & - 4.d0*pi*(0.75d0*volclu/pi)**(2.d0/3.d0), ' a.u.^2' - write(stdout,*) nfi, 't*S = ', Surf_t*surfclu, ' ha' - end if - if (abivol.or.abisur) write(stdout,*) nfi, & - ' # of electrons within the isosurface = ', n_ele - - IF( .not. tcg ) THEN - ! - if( .not. do_comp ) then - WRITE( stdout, 1948 ) nfi, ekinc, temphc, tempp, etot, enthal, econs, & - econt, vnhh(3,3), xnhh0(3,3), vnhp(1), xnhp0(1) - else - WRITE( stdout, 1960 ) nfi, ekinc, temphc, tempp, etot, enthal, econs, & - econt, vnhh(3,3), xnhh0(3,3), vnhp(1), xnhp0(1), & - ecomp - end if - ELSE - IF ( MOD( nfi, iprint ) == 0 .OR. tfirst ) THEN - ! - WRITE( stdout, * ) - WRITE( stdout, 255 ) 'nfi','tempp','E','-T.S-mu.nbsp','+K_p','#Iter' - ! - END IF - ! - WRITE( stdout, 256 ) nfi, INT( tempp ), etot, atot, econs, itercg - ! - END IF - - IF( tefield) THEN - IF(ionode) write(stdout,'( A14,F12.6,2X,A14,F12.6)') 'Elct. dipole 1',-pberryel,'Ionic dipole 1',-pberryion - ENDIF - IF( tefield2) THEN - IF(ionode) write(stdout,'( A14,F12.6,2X,A14,F12.6)') 'Elct. dipole 2',-pberryel2,'Ionic dipole 2',-pberryion2 - ENDIF - ! - ! -255 FORMAT( ' ',A5,A8,3(1X,A12),A6 ) -256 FORMAT( 'Step ',I5,1X,I7,1X,F12.5,1X,F12.5,1X,F12.5,1X,I5 ) -1000 FORMAT(/,3X,'Center of mass square displacement (a.u.): ',F10.6,/) -1944 FORMAT(//' Partial temperatures (for each ionic specie) ', & - /,' Species Temp (K) Mean Square Displacement (a.u.)') -1945 FORMAT(3X,I6,1X,F10.2,1X,F10.4) -1947 FORMAT( 2X,'nfi',4X,'ekinc',2X,'temph',2X,'tempp',8X,'etot',6X,'enthal', & - & 7X,'econs',7X,'econt',4X,'vnhh',3X,'xnhh0',4X,'vnhp',3X,'xnhp0' ) -1948 FORMAT( I5,1X,E12.2,1X,F6.1,1X,F6.1,4(1X,F11.5),4(1X,F7.4) ) -1960 FORMAT( I5,1X,ES12.2,1X,F6.1,1X,F6.1,4(1X,F11.5),4(1X,F7.4),1X,F11.5) -2948 FORMAT( I6,1X,ES15.5,1X,ES11.1,1X,ES11.1,4(1X,ES15.5),ES12.2, ES12.2, ES15.5 ) -2949 FORMAT( I6,1X,4(1X,ES14.4), ES15.5 ) - ! - RETURN - END SUBROUTINE printout_new_twin_x - ! - -!=----------------------------------------------------------------------------=! - SUBROUTINE printout_x(nfi, atoms, ekinc, ekcell, tprint, ht, edft) -!=----------------------------------------------------------------------------=! - - USE kinds, ONLY: DP - USE control_flags, ONLY: tnosee, tnosep, tnoseh, iprint - use constants, only: k_boltzmann_au, au_gpa, amu_si, bohr_radius_cm - use energies, only: dft_energy_type - use time_step, ONLY: tps - USE electrons_nose, ONLY: electrons_nose_nrg, xnhe0, vnhe, qne, ekincw - USE sic_module, ONLY: self_interaction - USE ions_base, ONLY: ions_temp - USE ions_nose, ONLY: ndega, ions_nose_nrg, xnhp0, vnhp, qnp, & - kbt, nhpcl, nhpdim, atm2nhp, ekin2nhp, gkbt2nhp - USE cell_nose, ONLY: cell_nose_nrg, qnh, temph, xnhh0, vnhh - USE cell_base, ONLY: iforceh, boxdimensions, s_to_r, press - USE printout_base, ONLY: printout_base_open, printout_base_close, & - printout_pos, printout_cell, printout_stress - USE atoms_type_module, ONLY: atoms_type - USE cp_interfaces, ONLY: printout_new - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nfi - TYPE (atoms_type) :: atoms - LOGICAL :: tprint - type (boxdimensions), intent(in) :: ht - TYPE (dft_energy_type) :: edft - REAL(DP) :: ekinc, ekcell -! -! ... - INTEGER :: is, ia - REAL(DP) :: stress_tensor(3,3), temps( atoms%nsp ) - REAL(DP) :: tempp, econs, ettt, out_press, ekinpr, enosee - REAL(DP) :: enthal, enoseh, temphc, enosep - REAL(DP) :: epot - !!REAL(DP) :: dis( nsp ) - LOGICAL :: tfile, tsic - LOGICAL :: tfirst = .TRUE. - REAL(DP), ALLOCATABLE :: tauw( :, : ) - INTEGER :: old_nfi = -1 - - ! ... Subroutine Body - - tfile = ( MOD( nfi, iprint ) == 0 ) ! print quantity to trajectory files - tsic = ( self_interaction /= 0 ) - - ! ... Calculate Ions temperature tempp (in Kelvin ) - - CALL ions_temp & - ( tempp, temps, ekinpr, atoms%vels, atoms%na, atoms%nsp, ht%hmat, & - atoms%m, ndega, nhpdim, atm2nhp, ekin2nhp ) - - ! ... Stress tensor (in GPa) and pressure (in GPa) - - stress_tensor = ht%paiu(:,:) * au_gpa / ht%deth - ! - out_press = ( stress_tensor(1,1) + stress_tensor(2,2) + stress_tensor(3,3) ) / 3.0d0 - - ! ... Enthalpy (in Hartree) - - enthal = edft%etot + press * ht%deth - - IF( tnoseh ) THEN - enoseh = cell_nose_nrg( qnh, xnhh0, vnhh, temph, iforceh ) - ELSE - enoseh = 0.0d0 - END IF - - if( COUNT( iforceh == 1 ) > 0 ) then - temphc = 2.0d0 / k_boltzmann_au * ekcell / DBLE( COUNT( iforceh == 1 ) ) - else - temphc = 0.0d0 - endif - - IF( tnosep ) THEN - enosep = ions_nose_nrg( xnhp0, vnhp, qnp, gkbt2nhp, kbt, nhpcl, nhpdim ) - ELSE - enosep = 0 - END IF - - IF( tnosee ) THEN - enosee = electrons_nose_nrg( xnhe0, vnhe, qne, ekincw ) - ELSE - enosee = 0 - END IF - - ! ... Energy expectation value for physical ions hamiltonian - ! ... in Born-Oppenheimer approximation - - econs = atoms%ekint + ekcell + enthal - - ! ... Car-Parrinello constant of motion - - ettt = econs + ekinc + enosee + enosep + enoseh - - epot = edft%eht + edft%exc + edft%epseu - - ! ... Print physical variables to fortran units - - stress_tensor = stress_tensor / au_gpa - - ALLOCATE( tauw( 3, atoms%nat ) ) - DO is = 1, atoms%nsp - DO ia = atoms%isa(is), atoms%isa(is) + atoms%na(is) - 1 - CALL s_to_r( atoms%taus(:,ia), tauw(:,ia), ht ) - END DO - END DO - - CALL printout_new & - ( nfi, tfirst, tfile, .FALSE., tprint, tps, ht%hmat, stress_tensor, tauw, atoms%vels, & - atoms%for, ekinc, temphc, tempp, temps, edft%etot, enthal, econs, ettt, & - vnhh, xnhh0, vnhp, xnhp0, 0.0d0, edft%ekin, epot, .true. , .true. ) - - DEALLOCATE( tauw ) - - old_nfi = nfi - - tfirst = .FALSE. - - 5 FORMAT(/,3X,'Simulated Time (ps): ',F12.6) - 10 FORMAT(/,3X,'Cell Variables (AU)',/) - 11 FORMAT(/,3X,'Atomic Positions (AU)',/) - 12 FORMAT(/,3X,'Atomic Velocities (AU)',/) - 13 FORMAT(/,3X,'Atomic Forces (AU)',/) - 17 FORMAT(/,3X,'Total Stress (GPa)',/) - 19 FORMAT(/,3X,'Dipole moment (AU)',/) - 20 FORMAT(6X,3(F18.8,2X)) - 30 FORMAT(2X,'STEP:',I7,1X,F10.2) - 50 FORMAT(6X,3(F18.8,2X)) - 293 FORMAT(/,3X,'Atomic Coordinates (AU):') - 253 FORMAT(3F12.5) - 252 FORMAT(3E14.6) - 254 FORMAT(3F14.8) - 255 FORMAT(3X,A3,3F10.4,3E12.4) - 100 FORMAT(3X,A3,3(1X,E14.6)) - 101 FORMAT(3X,3(1X,E14.6)) - 1944 FORMAT(//' Partial temperatures (for each ionic specie) ', & - /,' Species Temp (K) MSD (AU)') - 1945 FORMAT(3X,I6,1X,F10.2,1X,F10.4) - - - RETURN - END SUBROUTINE printout_x - - - -!=----------------------------------------------------------------------------=! - SUBROUTINE print_legend() -!=----------------------------------------------------------------------------=! - ! - USE io_global, ONLY : ionode, stdout - ! - IMPLICIT NONE - ! - IF ( .NOT. ionode ) RETURN - ! - WRITE( stdout, *) - WRITE( stdout, *) ' Short Legend and Physical Units in the Output' - WRITE( stdout, *) ' ---------------------------------------------' - WRITE( stdout, *) ' NFI [int] - step index' - WRITE( stdout, *) ' EKINC [HARTREE A.U.] - kinetic energy of the fictitious electronic dynamics' - WRITE( stdout, *) ' TEMPH [K] - Temperature of the fictitious cell dynamics' - WRITE( stdout, *) ' TEMP [K] - Ionic temperature' - WRITE( stdout, *) ' ETOT [HARTREE A.U.] - Scf total energy (Kohn-Sham hamiltonian)' - WRITE( stdout, *) ' ENTHAL [HARTREE A.U.] - Enthalpy ( ETOT + P * V )' - WRITE( stdout, *) ' ECONS [HARTREE A.U.] - Enthalpy + kinetic energy of ions and cell' - WRITE( stdout, *) ' ECONT [HARTREE A.U.] - Constant of motion for the CP lagrangian' - WRITE( stdout, *) - ! - RETURN - ! - END SUBROUTINE print_legend - - - - -!=----------------------------------------------------------------------------=! - SUBROUTINE print_sfac_x( rhoe, sfac ) -!=----------------------------------------------------------------------------=! - - USE kinds, ONLY : DP - USE mp_global, ONLY: me_image, nproc_image, intra_image_comm - USE mp, ONLY: mp_max, mp_get, mp_put - USE reciprocal_vectors, ONLY: ig_l2g, gx, g - USE gvecp, ONLY: ngm - USE fft_base, ONLY : dfftp - USE cp_interfaces, ONLY: fwfft - USE io_global, ONLY : ionode, ionode_id - USE io_files, ONLY: sfacunit, sfac_file - - IMPLICIT NONE - - REAL(DP), INTENT(IN) :: rhoe(:,:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - - INTEGER :: nspin, ispin, ip, nsp, ngx_l, ng, is, ig - COMPLEX(DP), ALLOCATABLE :: rhoeg(:,:) - COMPLEX(DP), ALLOCATABLE :: psi(:) - COMPLEX(DP), ALLOCATABLE :: rhoeg_rcv(:,:) - REAL (DP), ALLOCATABLE :: hg_rcv(:) - REAL (DP), ALLOCATABLE :: gx_rcv(:,:) - INTEGER , ALLOCATABLE :: ig_rcv(:) - COMPLEX(DP), ALLOCATABLE :: sfac_rcv(:,:) - - nspin = SIZE(rhoe,2) - nsp = SIZE(sfac,2) - ngx_l = ngm - CALL mp_max(ngx_l, intra_image_comm) - ALLOCATE(rhoeg(ngm,nspin)) - ALLOCATE(hg_rcv(ngx_l)) - ALLOCATE(gx_rcv(3,ngx_l)) - ALLOCATE(ig_rcv(ngx_l)) - ALLOCATE(rhoeg_rcv(ngx_l,nspin)) - ALLOCATE(sfac_rcv(ngx_l,nsp)) - - ! ... FFT: rho(r) --> rho(g) - ! - ALLOCATE( psi( SIZE( rhoe, 1 ) ) ) - ! - DO ispin = 1, nspin - psi = rhoe(:,ispin) - CALL fwfft( 'Dense', psi, dfftp ) - CALL psi2rho( 'Dense', psi, dfftp%nnr, rhoeg(:,ispin), ngm ) - END DO - - DEALLOCATE( psi ) - - IF( ionode ) THEN - OPEN(sfacunit, FILE=TRIM(sfac_file), STATUS='UNKNOWN') - END IF - - DO ip = 1, nproc_image - CALL mp_get(ng, ngm, me_image, ionode_id, ip-1, ip, intra_image_comm ) - CALL mp_get(hg_rcv(:), g(:), me_image, ionode_id, ip-1, ip, intra_image_comm ) - CALL mp_get(gx_rcv(:,:), gx(:,:), me_image, ionode_id, ip-1, ip, intra_image_comm ) - CALL mp_get(ig_rcv(:), ig_l2g(:), me_image, ionode_id, ip-1, ip, intra_image_comm ) - DO ispin = 1, nspin - CALL mp_get( rhoeg_rcv(:,ispin), rhoeg(:,ispin), me_image, ionode_id, ip-1, ip, intra_image_comm ) - END DO - DO is = 1, nsp - CALL mp_get( sfac_rcv(:,is), sfac(:,is), me_image, ionode_id, ip-1, ip, intra_image_comm ) - END DO - IF( ionode ) THEN - DO ig = 1, ng - WRITE(sfacunit,100) ig_rcv(ig), & - hg_rcv(ig), gx_rcv(1,ig), gx_rcv(2,ig), gx_rcv(3,ig), & - (sfac_rcv(ig,is),is=1,nsp), & - (rhoeg_rcv(ig,ispin),ispin=1,nspin) - END DO - END IF - 100 FORMAT(1X,I8,1X,4(1X,D13.6),1X,50(2X,2D14.6)) - END DO - - IF( ionode ) THEN - CLOSE(sfacunit) - END IF - - DEALLOCATE(rhoeg) - DEALLOCATE(hg_rcv) - DEALLOCATE(gx_rcv) - DEALLOCATE(ig_rcv) - DEALLOCATE(rhoeg_rcv) - DEALLOCATE(sfac_rcv) - - RETURN - END SUBROUTINE print_sfac_x - - - - -!=----------------------------------------------------------------------------=! - SUBROUTINE printacc( ) -!=----------------------------------------------------------------------------=! - - USE kinds, ONLY : DP - USE cp_main_variables, ONLY : acc, acc_this_run, nfi, nfi_run - USE io_global, ONLY : ionode, stdout - - IMPLICIT NONE - ! - REAL(DP) :: avgs(9) - REAL(DP) :: avgs_run(9) - - avgs = 0.0d0 - avgs_run = 0.0d0 - ! - IF ( nfi > 0 ) THEN - avgs = acc( 1:9 ) / DBLE( nfi ) - END IF - ! - IF ( nfi_run > 0 ) THEN - avgs_run = acc_this_run(1:9) / DBLE( nfi_run ) - END IF - - IF( ionode ) THEN - WRITE( stdout,1949) - WRITE( stdout,1951) avgs(1), avgs_run(1) - WRITE( stdout,1952) avgs(2), avgs_run(2) - WRITE( stdout,1953) avgs(3), avgs_run(3) - WRITE( stdout,1954) avgs(4), avgs_run(4) - WRITE( stdout,1955) avgs(5), avgs_run(5) - WRITE( stdout,1956) avgs(6), avgs_run(6) - WRITE( stdout,1957) avgs(7), avgs_run(7) - WRITE( stdout,1958) avgs(8), avgs_run(8) - WRITE( stdout,1959) avgs(9), avgs_run(9) - WRITE( stdout,1990) - 1949 FORMAT(//,3X,'Averaged Physical Quantities',/ & - ,3X,' ',' accomulated',' this run') - 1951 FORMAT(3X,'ekinc : ',F14.5,F14.5,' (AU)') - 1952 FORMAT(3X,'ekin : ',F14.5,F14.5,' (AU)') - 1953 FORMAT(3X,'epot : ',F14.5,F14.5,' (AU)') - 1954 FORMAT(3X,'total energy : ',F14.5,F14.5,' (AU)') - 1955 FORMAT(3X,'temperature : ',F14.5,F14.5,' (K )') - 1956 FORMAT(3X,'enthalpy : ',F14.5,F14.5,' (AU)') - 1957 FORMAT(3X,'econs : ',F14.5,F14.5,' (AU)') - 1958 FORMAT(3X,'pressure : ',F14.5,F14.5,' (Gpa)') - 1959 FORMAT(3X,'volume : ',F14.5,F14.5,' (AU)') - 1990 FORMAT(/) - END IF - - RETURN - END SUBROUTINE printacc - - - -!=----------------------------------------------------------------------------=! - SUBROUTINE open_and_append_x( iunit, file_name ) -!=----------------------------------------------------------------------------=! - USE io_global, ONLY: ionode - IMPLICIT NONE - INTEGER, INTENT(IN) :: iunit - CHARACTER(LEN = *), INTENT(IN) :: file_name - INTEGER :: ierr - IF( ionode ) THEN - OPEN( UNIT = iunit, FILE = trim( file_name ), & - STATUS = 'unknown', POSITION = 'append', IOSTAT = ierr) - IF( ierr /= 0 ) & - CALL errore( ' open_and_append ', ' opening file '//trim(file_name), 1 ) - END IF - RETURN - END SUBROUTINE open_and_append_x - - - - -!=----------------------------------------------------------------------------=! - SUBROUTINE print_projwfc_real_x ( c0, lambda, eigr, vkb ) -!=----------------------------------------------------------------------------=! - USE kinds, ONLY: DP - USE electrons_base, ONLY: nspin, iupdwn, nupdwn - USE electrons_module, ONLY: nupdwn_emp - USE cp_interfaces, ONLY: set_evtot, set_eitot - ! - IMPLICIT NONE - ! - COMPLEX(DP), INTENT(IN) :: c0(:,:), eigr(:,:), vkb(:,:) - REAL(DP), INTENT(IN) :: lambda(:,:,:) - ! - INTEGER :: nupdwn_tot( 2 ), iupdwn_tot( 2 ) - COMPLEX(DP), ALLOCATABLE :: ctmp(:,:) - REAL(DP), ALLOCATABLE :: eitot(:,:) - ! - nupdwn_tot = nupdwn + nupdwn_emp - iupdwn_tot(1) = iupdwn(1) - iupdwn_tot(2) = nupdwn(1) + 1 - ! - ALLOCATE( eitot( nupdwn_tot(1), nspin ) ) - ! - CALL set_eitot( eitot ) - ! - ALLOCATE( ctmp( SIZE( c0, 1 ), nupdwn_tot(1) * nspin ) ) - ! - CALL set_evtot( c0, ctmp, lambda, iupdwn_tot, nupdwn_tot ) - ! - CALL projwfc( ctmp, SIZE(ctmp,2), eigr, vkb, nupdwn_tot(1), eitot(1,1) ) - ! - DEALLOCATE( eitot ) - DEALLOCATE( ctmp ) - - RETURN - END SUBROUTINE - -!=----------------------------------------------------------------------------=! - SUBROUTINE print_projwfc_twin_x ( c0, lambda, eigr, vkb ) -!=----------------------------------------------------------------------------=! - USE kinds, ONLY: DP - USE electrons_base, ONLY: nspin, iupdwn, nupdwn - USE electrons_module, ONLY: nupdwn_emp - USE cp_interfaces, ONLY: set_evtot, set_eitot - USE twin_types - ! - IMPLICIT NONE - ! - COMPLEX(DP), INTENT(IN) :: c0(:,:), eigr(:,:), vkb(:,:) - TYPE(twin_matrix), DIMENSION(:), INTENT(IN) :: lambda(:) - ! - INTEGER :: nupdwn_tot( 2 ), iupdwn_tot( 2 ) - COMPLEX(DP), ALLOCATABLE :: ctmp(:,:) - REAL(DP), ALLOCATABLE :: eitot(:,:) - ! - nupdwn_tot = nupdwn + nupdwn_emp - iupdwn_tot(1) = iupdwn(1) - iupdwn_tot(2) = nupdwn(1) + 1 - ! - ALLOCATE(eitot( nupdwn_tot(1), nspin )) - ! - CALL set_eitot( eitot ) - ! - ALLOCATE( ctmp( SIZE( c0, 1 ), nupdwn_tot(1) * nspin ) ) - ! - CALL set_evtot( c0, ctmp, lambda, iupdwn_tot, nupdwn_tot ) - ! - CALL projwfc( ctmp, SIZE(ctmp,2), eigr, vkb, nupdwn_tot(1), eitot(1,1) ) - ! - DEALLOCATE( eitot ) - DEALLOCATE( ctmp ) - - RETURN - END SUBROUTINE - -!=----------------------------------------------------------------------------=! - SUBROUTINE update_accomulators & - ( ekinc, ekin, epot, etot, tempp, enthal, econs, press, volume ) -!=----------------------------------------------------------------------------=! - - USE kinds, ONLY : DP - USE cp_main_variables, ONLY : acc, acc_this_run, nfi_run - - IMPLICIT NONE - - REAL(DP), INTENT(IN) :: ekinc, ekin, epot, etot, tempp - REAL(DP), INTENT(IN) :: enthal, econs, press, volume - - nfi_run = nfi_run + 1 - - ! ... sum up values to be averaged - - acc(1) = acc(1) + ekinc - acc(2) = acc(2) + ekin - acc(3) = acc(3) + epot - acc(4) = acc(4) + etot - acc(5) = acc(5) + tempp - acc(6) = acc(6) + enthal - acc(7) = acc(7) + econs - acc(8) = acc(8) + press ! pressure in GPa - acc(9) = acc(9) + volume - - ! ... sum up values to be averaged - - acc_this_run(1) = acc_this_run(1) + ekinc - acc_this_run(2) = acc_this_run(2) + ekin - acc_this_run(3) = acc_this_run(3) + epot - acc_this_run(4) = acc_this_run(4) + etot - acc_this_run(5) = acc_this_run(5) + tempp - acc_this_run(6) = acc_this_run(6) + enthal - acc_this_run(7) = acc_this_run(7) + econs - acc_this_run(8) = acc_this_run(8) + press ! pressure in GPa - acc_this_run(9) = acc_this_run(9) + volume - - RETURN - END SUBROUTINE diff --git a/quantum_espresso/kcp/CPV/problem_size.f90 b/quantum_espresso/kcp/CPV/problem_size.f90 deleted file mode 100644 index 9e1a3283a..000000000 --- a/quantum_espresso/kcp/CPV/problem_size.f90 +++ /dev/null @@ -1,94 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -MODULE problem_size - - IMPLICIT NONE - SAVE - PRIVATE - PUBLIC :: cpsizes - -CONTAINS - - SUBROUTINE cpsizes() - - USE kinds - use ions_base, only: nat, nsp - use electrons_base, only: nx => nbnd, nspin - use electrons_module, only: nbspx_emp - use reciprocal_vectors, only: ngwx, ngmx - use gvecb, only: ngb - use uspp_param, only: nhm - use uspp, only: nkb - USE io_global, ONLY: ionode - USE io_global, ONLY: stdout - USE fft_base, ONLY: dfftp - - implicit none - - integer nr1x, nr2x, nr3x, nr1_l, nr2_l, nr3_l - integer nbyte - integer nbyte_alloc - integer itmp - - nr1_l = dfftp%nr1x - nr2_l = dfftp%nr2x - nr3_l = dfftp%npl - - nr1x = dfftp%nr1x - nr2x = dfftp%nr2x - nr3x = dfftp%nr3x - - nbyte = 0 - nbyte_alloc = 0 - -! ... Atoms type - nbyte = nbyte + 8*3*14*nat - -! ... GVEC - nbyte = nbyte + 8*10*ngb - nbyte = nbyte + 8*13*ngmx - -! ... Pseudo - nbyte = nbyte + 8*5*nkb*nx*nspin - -! ... C0 CM CP C_EMP - nbyte = nbyte + 3*16*ngwx*nx*nspin - nbyte = nbyte + 3*16*ngwx*nbspx_emp - -! ... ei1 ei2 ei3, eigr, sfac - nbyte = nbyte + 3*16*MAX(nr1x, nr2x, nr3x)*nat - nbyte = nbyte + 16*ngwx*nat - nbyte = nbyte + 16*ngmx*nsp - -! ... rhoe and vpot ( nr1_l, nr2_l, nr3_l, nspin ) - nbyte = nbyte + (8 + 16)*NR1_L*NR2_L*NR3_L*nspin - -! ... TEMPORARY ALLOCATED MEMORY - -! ... ortho - itmp = 8*8*NX*NX - if (itmp .gt. nbyte_alloc) nbyte_alloc = itmp - -! ... pvofrho & pstress - itmp = 8*(NR1_L*NR2_L*NR3_L*8 + & - & nat*NX*nhm*6 + 6*ngmx + 6*ngwx + & - & ngwx*nhm*nsp + 2*ngwx*nat) - if (itmp .gt. nbyte_alloc) nbyte_alloc = itmp - - IF (ionode) THEN - WRITE (stdout, 10) nbyte + nbyte_alloc - END IF - -10 FORMAT(//, 3X, 'Estimated Sizes of the problem', / & - & , 3X, '------------------------------', / & - & , 3X, 'dimension of the problem (byte/pe) : ', I12) - - RETURN - END SUBROUTINE cpsizes - -END MODULE problem_size diff --git a/quantum_espresso/kcp/CPV/pseudo_base.f90 b/quantum_espresso/kcp/CPV/pseudo_base.f90 deleted file mode 100644 index 034d76afa..000000000 --- a/quantum_espresso/kcp/CPV/pseudo_base.f90 +++ /dev/null @@ -1,430 +0,0 @@ -! -! Copyright (C) 2002-2008 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - -!=----------------------------------------------------------------------------=! - MODULE pseudo_base -!=----------------------------------------------------------------------------=! - - - USE kinds - USE cp_interfaces, ONLY: bessel2, bessel3 - USE constants, ONLY: gsmall, fpi, pi - USE cell_base, ONLY: tpiba - - IMPLICIT NONE - - SAVE - - PRIVATE - - PUBLIC :: compute_rhops, formfn, formfa - PUBLIC :: compute_eself, compute_rhocg - - - -!=----------------------------------------------------------------------------=! - CONTAINS -!=----------------------------------------------------------------------------=! - - - subroutine compute_rhocg( rhocb, drhocb, r, rab, rho_atc, gb, omegab, & - tpibab2, mesh, ngb, what ) - - - ! if what == 0 compute rhocb(G) - ! if what == 1 compute rhocb(G) and drhocb(G) - ! - ! rhocb(G) = (integral) rho_cc(r) j_0(r,G) r**2 dr - ! = (integral) rho_cc(r) j_0(r,G) r**2 dr/dx dx - ! drhocb(G) = (integral) rho_cc(r) dj_0(r,G)/dG r**2 dr - - use kinds, only: DP - use constants, only: fpi - use control_flags, only: iprsta - use io_global, only: stdout - - implicit none - - integer, intent(in) :: mesh - integer, intent(in) :: ngb - integer, intent(in) :: what - real(DP), intent(out) :: rhocb( ngb ) - real(DP), intent(out) :: drhocb( ngb ) - real(DP), intent(in) :: rho_atc( mesh ) - real(DP), intent(in) :: r( mesh ) - real(DP), intent(in) :: rab( mesh ) - real(DP), intent(in) :: gb( ngb ) - real(DP), intent(in) :: omegab - real(DP), intent(in) :: tpibab2 - - integer :: ig, ir - real(DP), allocatable :: fint(:), jl(:), djl(:) - real(DP) :: c, xg - - allocate(fint(mesh)) - allocate(jl(mesh)) - if( what == 1 ) then - allocate(djl(mesh)) - end if - - if( what < 0 .and. what > 1 ) & - call errore(" compute_rhocg ", " parameter what is out of range ", 1 ) - - c = fpi / omegab - do ig = 1, ngb - xg = sqrt( gb(ig) * tpibab2 ) - call sph_bes ( mesh, r(1), xg, 0, jl ) - do ir=1,mesh - fint(ir)=r(ir)**2*rho_atc(ir)*jl(ir) - end do - call simpson_cp90( mesh,fint,rab(1),rhocb(ig)) - if( what == 1 ) then - ! djl = - d j_0(x) /dx = + j_1(x) - call sph_bes ( mesh, r(1), xg, +1, djl ) - do ir=1,mesh - fint(ir)=r(ir)**3*rho_atc(ir)*djl(ir) - end do - call simpson_cp90( mesh, fint, rab(1), drhocb(ig) ) - end if - end do - do ig=1,ngb - rhocb(ig) = c * rhocb(ig) - end do - if( what == 1 ) then - do ig=1,ngb - drhocb(ig) = c * drhocb(ig) - end do - end if - - if(iprsta >= 4) & - WRITE( stdout,'(a,f12.8)') ' integrated core charge= ',omegab*rhocb(1) - - deallocate( jl, fint ) - if( what == 1 ) then - deallocate(djl) - end if - - return - end subroutine compute_rhocg - - - -!----------------------------------------------------------------------- - - - - subroutine compute_rhops( rhops, drhops, zv, rcmax, g, omega, tpiba2, ngs, tpre ) -! - use kinds, only: DP - ! - implicit none - integer, intent(in) :: ngs - logical, intent(in) :: tpre - real(DP), intent(in) :: g( ngs ) - real(DP), intent(out) :: rhops( ngs ) - real(DP), intent(out) :: drhops( ngs ) - real(DP), intent(in) :: zv, rcmax, omega, tpiba2 - ! - real(DP) :: r2new - integer :: ig - ! - r2new = 0.25d0 * tpiba2 * rcmax**2 - do ig = 1, ngs - rhops(ig) = - zv * exp( -r2new * g(ig) ) / omega - end do - if(tpre) then - drhops( 1:ngs ) = - rhops( 1:ngs ) * r2new / tpiba2 - endif - ! - return - end subroutine compute_rhops - - - -!----------------------------------------------------------------------- - FUNCTION compute_eself( na, zv, rcmax, nsp ) -!----------------------------------------------------------------------- - ! - ! calculation of gaussian selfinteraction - ! - USE constants, ONLY: pi - ! - IMPLICIT NONE - REAL (DP) :: compute_eself - ! - INTEGER, INTENT(IN) :: nsp - INTEGER, INTENT(IN) :: na( nsp ) - REAL (DP), INTENT(IN) :: zv( nsp ) - REAL (DP), INTENT(IN) :: rcmax( nsp ) - ! - REAL (DP) :: eself - INTEGER :: is - ! - eself = 0.0d0 - DO is = 1, nsp - eself = eself + DBLE( na( is ) ) * zv( is )**2 / rcmax( is ) - END DO - eself = eself / SQRT( 2.0d0 * pi ) - ! - compute_eself = eself - RETURN - END FUNCTION compute_eself - - - - -!----------------------------------------------------------------------- - subroutine formfn( r, rab, vloc_at, zv, rcmax, g, omega, & - tpiba2, mesh, ngs, oldvan, tpre, vps, dv0, dvps ) -!----------------------------------------------------------------------- -! - !computes the form factors of pseudopotential (vps), - ! also calculated the derivative of vps with respect to - ! g^2 (dvps) - ! - use kinds, only: DP - use constants, only: pi, fpi, gsmall - ! - implicit none - integer, intent(in) :: ngs - integer, intent(in) :: mesh - logical, intent(in) :: oldvan - logical, intent(in) :: tpre - real(DP), intent(in) :: g( ngs ) - real(DP), intent(in) :: r( mesh ) - real(DP), intent(in) :: rab( mesh ) - real(DP), intent(in) :: vloc_at( mesh ) - real(DP), intent(out) :: vps( ngs ) - real(DP), intent(out) :: dvps( ngs ) - real(DP), intent(out) :: dv0 - real(DP), intent(in) :: zv, rcmax, omega, tpiba2 - ! - real(DP) :: xg - integer :: ig, ir, irmax - real(DP), allocatable:: f(:),vscr(:), figl(:) - real(DP), allocatable:: df(:), dfigl(:) - real(DP), external :: qe_erf, qe_erfc -! - allocate( figl(ngs), f(mesh), vscr(mesh) ) - if (tpre) then - allocate( dfigl(ngs), df(mesh) ) - end if - ! - ! definition of irmax: gridpoint beyond which potential is zero - ! - irmax = 0 - do ir = 1, mesh - if( r( ir ) < 10.0d0 ) irmax = ir - end do - ! - do ir = 1, irmax - vscr(ir) = 0.5d0 * r(ir) * vloc_at(ir) + zv * qe_erf( r(ir) / rcmax ) - end do - do ir = irmax + 1, mesh - vscr(ir)=0.0d0 - end do - ! - ! ... In CP the G=0 value of the Hartree+local pseudopotential - ! ... is not set to its correct value, the "alpha Z" term, but - ! ... to a different value. This has no effect on the energy - ! ... of a neutral system as long as all terms are consistent - ! ... but it yields a different alignment of levels and, only - ! ... in charged system, a different energy. - ! ... dv0 is the correction to the G=0 term in CP needed to - ! ... reproduce the results from other PW codes - ! - DO ir = 1, irmax - f(ir) = fpi * ( zv * qe_erfc( r(ir)/rcmax ) ) * r(ir) - END DO - DO ir = irmax + 1, mesh - f(ir)=0.0d0 - END DO - IF ( oldvan ) THEN - CALL herman_skillman_int( mesh, f, rab, dv0 ) - ELSE - CALL simpson_cp90( mesh, f, rab, dv0 ) - END IF - ! - do ig = 1, ngs - xg = sqrt( g(ig) * tpiba2 ) - if( xg < gsmall ) then - ! - ! g=0 - ! - do ir = 1, irmax - f(ir) = vscr(ir) * r(ir) - if( tpre ) then - df(ir) = vscr(ir) * r(ir) ** 3 - endif - end do - do ir = irmax + 1, mesh - f(ir) = 0.0d0 - if( tpre ) then - df(ir) = 0.0d0 - end if - end do - ! - if ( oldvan ) then - call herman_skillman_int( mesh, f, rab, figl(ig) ) - if(tpre) call herman_skillman_int( mesh, df, rab, dfigl(ig) ) - else - call simpson_cp90( mesh, f, rab, figl(ig) ) - if(tpre) call simpson_cp90( mesh, df, rab, dfigl(ig) ) - end if - ! - else - ! - ! g>0 - ! - do ir = 1, mesh - f(ir) = vscr(ir) * sin( r(ir) * xg ) - if( tpre ) then - df(ir) = vscr(ir) * cos( r(ir) * xg ) * 0.5d0 * r(ir) / xg - endif - end do - ! - if ( oldvan ) then - call herman_skillman_int( mesh, f, rab(1), figl(ig) ) - if(tpre) call herman_skillman_int( mesh, df, rab(1), dfigl(ig) ) - else - call simpson_cp90(mesh,f,rab(1),figl(ig)) - if(tpre) call simpson_cp90(mesh,df,rab(1),dfigl(ig)) - end if - ! - end if - end do - ! - do ig = 1, ngs - xg = sqrt( g(ig) * tpiba2 ) - if( xg < gsmall ) then - ! - ! g=0 - ! - vps(ig) = fpi * figl(ig) / omega - if(tpre)then - dvps(ig) = - fpi * dfigl(ig) / omega / 6.0d0 ! limit ( xg -> 0 ) dvps( xgi ) - end if - ! - else - ! - ! g>0 - ! - vps(ig) = fpi * figl(ig) / ( omega * xg ) - if(tpre)then - dvps(ig) = fpi * dfigl(ig) / ( omega * xg ) - 0.5d0 * vps(ig) / (xg*xg) - endif - end if - end do - ! - deallocate( figl, f, vscr ) - if (tpre) then - deallocate( dfigl, df ) - end if - ! - return - end subroutine formfn - - - - -!----------------------------------------------------------------------- - subroutine formfa( vps, dvps, rc1, rc2, wrc1, wrc2, rcl, al, bl, & - zv, rcmax, g, omega, tpiba2, ngs, gstart, tpre ) -!----------------------------------------------------------------------- -! - !computes the form factors of pseudopotential (vps), - ! also calculated the derivative of vps with respect to - ! g^2 (dvps) - ! - ! BHS pseudopotentials (fourier transformed analytically) - - use kinds, only: DP - use constants, only: pi, fpi, gsmall - ! - implicit none - integer, intent(in) :: ngs, gstart - logical, intent(in) :: tpre - real(DP), intent(in) :: g( ngs ) - real(DP), intent(in) :: rc1, rc2 - real(DP), intent(in) :: wrc1, wrc2 - real(DP), intent(in) :: rcl( 3 ), al( 3 ), bl( 3 ) - real(DP), intent(out) :: vps( ngs ) - real(DP), intent(out) :: dvps( ngs ) - real(DP), intent(in) :: zv, rcmax, omega, tpiba2 - ! - real(DP) :: r2max, r21, r22, gps, sfp, r2l, ql, el, par, sp - real(DP) :: emax, e1, e2, fpibg, dgps, dsfp - integer :: ib, ig - - r2max = rcmax**2 - r21 = rc1**2 - r22 = rc2**2 - - ! - ! g = 0 - ! - if (gstart == 2) then - gps = - zv * pi * ( - wrc2 * r22 - wrc1 * r21 + r2max ) / omega - sfp = 0.0d0 - do ib = 1, 3 - r2l = rcl( ib )**2 - ql = 0.25d0 * r2l * g(1) * tpiba2 - el = exp( -ql ) - par = al( ib ) + bl( ib ) * r2l * ( 1.5d0 - ql ) - sp = ( pi * r2l )**1.5d0 * el / omega - sfp = sp * par + sfp - end do - vps(1) = gps + sfp - end if - ! - ! g > 0 - ! - do ig = gstart, ngs - ! - emax = exp ( -0.25d0 * r2max * g(ig) * tpiba2 ) - e1 = exp ( -0.25d0 * r21 * g(ig) * tpiba2 ) - e2 = exp ( -0.25d0 * r22 * g(ig) * tpiba2 ) - fpibg = fpi / ( g(ig) * tpiba2 ) - gps = - zv * ( wrc1 * e1 - emax + wrc2 * e2 ) / omega - gps = gps * fpibg - ! - if(tpre) then - dgps = - gps / ( tpiba2 * g(ig) ) + fpibg * zv * & - & ( wrc1 * r21 * e1 - r2max * emax + wrc2 * r22 * e2 ) * & - & 0.25d0 / omega - end if - ! - sfp = 0.0d0 - dsfp = 0.0d0 - ! - do ib = 1, 3 - r2l = rcl( ib )**2 - ql = 0.25d0 * r2l * g(ig) * tpiba2 - par = al( ib ) + bl( ib ) * r2l * ( 1.5d0 - ql ) - sp = ( pi * r2l )**1.5d0 * exp( -ql ) / omega - sfp = sp * par + sfp - if(tpre) then - dsfp = dsfp - sp * ( par + bl( ib ) * r2l ) * ql / ( tpiba2 * g(ig) ) - end if - end do - ! - vps(ig) = sfp + gps - if(tpre) dvps(ig) = dsfp + dgps - ! - end do -! - return - end subroutine formfa - - - -!=----------------------------------------------------------------------------=! - END MODULE pseudo_base -!=----------------------------------------------------------------------------=! - diff --git a/quantum_espresso/kcp/CPV/pseudopot.f90 b/quantum_espresso/kcp/CPV/pseudopot.f90 deleted file mode 100644 index 31557cc08..000000000 --- a/quantum_espresso/kcp/CPV/pseudopot.f90 +++ /dev/null @@ -1,95 +0,0 @@ -! -! Copyright (C) 2002-2007 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! AB INITIO COSTANT PRESSURE MOLECULAR DYNAMICS -! ---------------------------------------------- -! Car-Parrinello Parallel Program -! Carlo Cavazzoni - Gerardo Ballabio -! SISSA, Trieste, Italy - 1997-99 -! Last modified: Tue Nov 2 08:03:11 MET 1999 -! ---------------------------------------------- - -#include "f_defs.h" - -MODULE pseudopotential - - ! ... declare modules - - USE kinds, ONLY: DP - USE splines, ONLY: spline_data - - IMPLICIT NONE - SAVE - - ! declare module-scope variables - - INTEGER :: nsanl ! number of atoms of the non local species - - TYPE (spline_data), ALLOCATABLE :: vps_sp(:) - TYPE (spline_data), ALLOCATABLE :: dvps_sp(:) - ! - TYPE (spline_data), ALLOCATABLE :: rhoc1_sp(:) - TYPE (spline_data), ALLOCATABLE :: rhocp_sp(:) - ! - REAL(DP), ALLOCATABLE :: xgtab(:) - - LOGICAL :: tpstab = .TRUE. - -! ---------------------------------------------- - -CONTAINS - -! ---------------------------------------------- - - SUBROUTINE deallocate_pseudopotential - - USE splines, ONLY: kill_spline - USE local_pseudo, ONLY: deallocate_local_pseudo - USE uspp, ONLY: dvan - - INTEGER :: i - - CALL deallocate_local_pseudo() - ! - IF( ALLOCATED( dvan ) ) DEALLOCATE( dvan ) - IF( ALLOCATED( xgtab ) ) DEALLOCATE( xgtab ) - ! - IF( ALLOCATED( vps_sp ) ) THEN - DO i = 1, size(vps_sp) - CALL kill_spline(vps_sp(i),'a') - END DO - DEALLOCATE(vps_sp) - END IF - ! - IF( ALLOCATED(dvps_sp) ) THEN - DO i = 1, size(dvps_sp) - CALL kill_spline(dvps_sp(i),'a') - END DO - DEALLOCATE(dvps_sp) - END IF - ! - IF( ALLOCATED(rhoc1_sp) ) THEN - DO i = 1, size(rhoc1_sp) - CALL kill_spline(rhoc1_sp(i),'a') - END DO - DEALLOCATE(rhoc1_sp) - END IF - ! - IF( ALLOCATED(rhocp_sp) ) THEN - DO i = 1, size(rhocp_sp) - CALL kill_spline(rhocp_sp(i),'a') - END DO - DEALLOCATE(rhocp_sp) - END IF - ! - RETURN - END SUBROUTINE deallocate_pseudopotential - - -END MODULE pseudopotential - -! ---------------------------------------------- diff --git a/quantum_espresso/kcp/CPV/pseudopot_sub.f90 b/quantum_espresso/kcp/CPV/pseudopot_sub.f90 deleted file mode 100644 index 4334c860b..000000000 --- a/quantum_espresso/kcp/CPV/pseudopot_sub.f90 +++ /dev/null @@ -1,1440 +0,0 @@ -! -! Copyright (C) 2002-2007 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -#include "f_defs.h" - - - SUBROUTINE compute_dvan_x() - ! - ! calculate array dvan(iv,jv,is) - ! - ! rw**2 * vrps = [ ( Vpsnl(r) - Vpsloc(r) )* Rps(r) * r^2 ] - ! = [ DVpsnl(r) * Rps(r) * r^2 ] - ! dion = (2l+1) / < Rps(r) | DVpsnl(r) | Rps(r) > - - USE kinds, ONLY: DP - use uspp, only: dvan, nhtolm, indv - use uspp_param, only: upf, nhm, nh - use ions_base, only: nsp - ! - implicit none - ! - integer :: is, iv, jv - real(DP) :: fac - ! - if( allocated( dvan ) ) deallocate( dvan ) - allocate( dvan( nhm, nhm, nsp ) ) - dvan(:,:,:) =0.d0 - ! - do is = 1, nsp - ! fac converts ry to hartree - fac = 0.5d0 - do iv=1,nh(is) - do jv=1,nh(is) - if ( nhtolm(iv,is) == nhtolm(jv,is) ) then - dvan( iv, jv, is ) = fac * upf(is)%dion( indv(iv,is), indv(jv,is) ) - endif - end do - end do - end do - RETURN - END SUBROUTINE compute_dvan_x - - - -!------------------------------------------------------------------------------! - - - - SUBROUTINE pseudopotential_indexes_x( ) - - use parameters, only: lmaxx ! - use ions_base, only: nsp, & ! number of specie - na ! number of atoms for each specie - use cvan, only: ish ! - use uspp, only: nkb, & ! - nkbus ! - use uspp_param, only: upf, &! - lmaxkb, &! - nhm, &! - nbetam, &! - nh, &! - lmaxq ! - use uspp, only: nhtol, &! - nhtolm, &! - indv ! - - use pseudopotential, ONLY: nsanl - USE read_pseudo_module_fpmd, ONLY: nspnl - - IMPLICIT NONE - - ! - INTEGER :: is, iv, ind, il, lm - ! ------------------------------------------------------------------ - ! find number of beta functions per species, max dimensions, - ! total number of beta functions (all and Vanderbilt only) - ! ------------------------------------------------------------------ - lmaxkb = -1 - nkb = 0 - nkbus = 0 - ! - do is = 1, nsp - ind = 0 - do iv = 1, upf(is)%nbeta - lmaxkb = max( lmaxkb, upf(is)%lll( iv ) ) - ind = ind + 2 * upf(is)%lll( iv ) + 1 - end do - nh(is) = ind - ish(is)=nkb - nkb = nkb + na(is) * nh(is) - if( upf(is)%tvanp ) nkbus = nkbus + na(is) * nh(is) - end do - nhm = MAXVAL( nh(1:nsp) ) - nbetam = MAXVAL( upf(1:nsp)%nbeta ) - if (lmaxkb > lmaxx) call errore(' pseudopotential_indexes ',' l > lmax ',lmaxkb) - lmaxq = 2*lmaxkb + 1 - ! - ! the following prevents an out-of-bound error: nqlc(is)=2*lmax+1 - ! but in some versions of the PP files lmax is not set to the maximum - ! l of the beta functions but includes the l of the local potential - ! - do is=1,nsp - upf(is)%nqlc = MIN ( upf(is)%nqlc, lmaxq ) - end do - if (nkb <= 0) call errore(' pseudopotential_indexes ',' not implemented ?',nkb) - - if( allocated( nhtol ) ) deallocate( nhtol ) - if( allocated( indv ) ) deallocate( indv ) - if( allocated( nhtolm ) ) deallocate( nhtolm ) - ! - allocate(nhtol(nhm,nsp)) - allocate(indv (nhm,nsp)) - allocate(nhtolm(nhm,nsp)) - - ! ------------------------------------------------------------------ - ! definition of indices nhtol, indv, nhtolm - ! ------------------------------------------------------------------ - ! - do is = 1, nsp - ind = 0 - do iv = 1, upf(is)%nbeta - lm = upf(is)%lll(iv)**2 - do il = 1, 2* upf(is)%lll( iv ) + 1 - lm = lm + 1 - ind = ind + 1 - nhtolm( ind, is ) = lm - nhtol( ind, is ) = upf(is)%lll( iv ) - indv( ind, is ) = iv - end do - end do - end do - - ! ... Calculate the number of atoms with non local pseudopotentials - ! - nsanl = SUM( na(1:nspnl) ) - - RETURN - END SUBROUTINE pseudopotential_indexes_x - - -!------------------------------------------------------------------------------! - - - LOGICAL FUNCTION chkpstab_x(hg, xgtabmax) - ! - USE kinds, ONLY: DP - USE mp, ONLY: mp_max - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm - USE cell_base, ONLY: tpiba - USE control_flags, ONLY: iprsta - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: hg(:) - REAL(DP), INTENT(IN) :: xgtabmax - REAL(DP) :: xgmax - - chkpstab_x = .FALSE. - ! - xgmax = tpiba * SQRT( MAXVAL( hg ) ) - CALL mp_max( xgmax, intra_image_comm ) - ! - IF( xgmax > xgtabmax ) THEN - chkpstab_x = .TRUE. - IF( iprsta > 2 ) & - WRITE( stdout, fmt='( "CHKPSTAB: recalculate pseudopotential table" )' ) - END IF - ! - RETURN - END FUNCTION chkpstab_x - - -!------------------------------------------------------------------------------! - - - SUBROUTINE compute_xgtab_x( xgmin, xgmax, xgtabmax ) - ! - USE kinds, ONLY : DP - USE cell_base, ONLY : tpiba - USE mp, ONLY : mp_max - USE mp_global, ONLY : intra_image_comm - USE reciprocal_vectors, ONLY : g - USE pseudopotential, ONLY : xgtab - USE betax, ONLY : mmx - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(OUT) :: xgmax, xgmin, xgtabmax - ! - INTEGER :: ig, nval - REAL(DP) :: dxg - ! - IF( .NOT. ALLOCATED( xgtab ) ) ALLOCATE( xgtab( mmx ) ) - nval = mmx - ! - xgmin = 0.0d0 - xgmax = tpiba * SQRT( MAXVAL( g ) ) - CALL mp_max(xgmax, intra_image_comm) - xgmax = xgmax + (xgmax-xgmin) - dxg = (xgmax - xgmin) / DBLE(nval-1) - ! - DO ig = 1, SIZE( xgtab ) - xgtab(ig) = xgmin + DBLE(ig-1) * dxg - END DO - ! - xgtabmax = xgtab( SIZE( xgtab ) ) - xgtab = xgtab**2 / tpiba**2 - ! - RETURN - END SUBROUTINE compute_xgtab_x - - -!------------------------------------------------------------------------------! - - - SUBROUTINE build_pstab_x( ) - - USE kinds, ONLY : DP - USE atom, ONLY : rgrid - USE ions_base, ONLY : nsp, rcmax, zv - USE cell_base, ONLY : tpiba2 - USE splines, ONLY : init_spline, allocate_spline, kill_spline, nullify_spline - USE pseudo_base, ONLY : formfn, formfa - USE uspp_param, only : upf, oldvan - USE control_flags, only : tpre - use reciprocal_vectors, ONLY : g - USE cp_interfaces, ONLY : compute_xgtab, chkpstab - USE pseudopotential, ONLY : vps_sp, dvps_sp, xgtab - USE local_pseudo, ONLY : vps0 - USE betax, ONLY : mmx - - IMPLICIT NONE - - INTEGER :: is - REAL(DP) :: xgmax, xgmin - LOGICAL :: compute_tab - REAL(DP) :: xgtabmax = 0.0d0 - ! - IF( .NOT. ALLOCATED( rgrid ) ) & - CALL errore( ' build_pstab_x ', ' rgrid not allocated ', 1 ) - IF( .NOT. ALLOCATED( upf ) ) & - CALL errore( ' build_pstab_x ', ' upf not allocated ', 1 ) - ! - compute_tab = chkpstab( g, xgtabmax ) - ! - IF( ALLOCATED( vps_sp ) ) THEN - ! - IF( .NOT. compute_tab ) return - ! - DO is = 1, nsp - CALL kill_spline( vps_sp(is), 'a' ) - CALL kill_spline(dvps_sp(is),'a') - END DO - DEALLOCATE( vps_sp ) - DEALLOCATE(dvps_sp) - ! - END IF - ! - CALL compute_xgtab( xgmin, xgmax, xgtabmax ) - ! - ALLOCATE( vps_sp(nsp)) - ALLOCATE( dvps_sp(nsp)) - ! - DO is = 1, nsp - - CALL nullify_spline( vps_sp( is ) ) - CALL nullify_spline( dvps_sp( is ) ) - - CALL allocate_spline( vps_sp(is), mmx, xgmin, xgmax ) - CALL allocate_spline( dvps_sp(is), mmx, xgmin, xgmax ) - - call formfn( rgrid(is)%r, rgrid(is)%rab, & - upf(is)%vloc(1:rgrid(is)%mesh), zv(is), rcmax(is), & - xgtab, 1.0d0, tpiba2, rgrid(is)%mesh, mmx, oldvan(is),& - tpre, vps_sp(is)%y, vps0(is), dvps_sp(is)%y ) - ! obsolete BHS format - !call formfa( vps_sp(is)%y, dvps_sp(is)%y, rc1(is), rc2(is), & - ! wrc1(is), wrc2(is), rcl(:,is,lloc(is)), & - ! al(:,is,lloc(is)), bl(:,is,lloc(is)), zv(is), & - ! rcmax(is), xgtab, 1.0d0, tpiba2, mmx, 2 , tpre ) - - ! WRITE( 13, "(3D16.8)" ) ( xgtab(ig), vps_sp(is)%y(ig), dvps_sp(is)%y(ig), ig = 1, mmx ) - - CALL init_spline( vps_sp(is) ) - CALL init_spline( dvps_sp(is) ) - - END DO - - RETURN - END SUBROUTINE build_pstab_x - - -!------------------------------------------------------------------------------! - - - SUBROUTINE build_cctab_x( ) - - USE kinds, ONLY : DP - USE atom, ONLY : rgrid - USE uspp_param, ONLY : upf - USE ions_base, ONLY : nsp - USE cell_base, ONLY : tpiba2 - USE splines, ONLY : init_spline, allocate_spline, kill_spline, nullify_spline - USE pseudo_base, ONLY : compute_rhocg - USE reciprocal_vectors, ONLY : g - USE cp_interfaces, ONLY : compute_xgtab, chkpstab - USE pseudopotential, ONLY : rhoc1_sp, rhocp_sp, xgtab - USE betax, ONLY : mmx - - IMPLICIT NONE - - INTEGER :: is - REAL(DP) :: xgmax, xgmin - LOGICAL :: compute_tab - REAL(DP) :: xgtabmax = 0.0d0 - ! - IF( .NOT. ALLOCATED( rgrid ) ) & - CALL errore( ' build_cctab_x ', ' rgrid not allocated ', 1 ) - IF( .NOT. ALLOCATED( upf ) ) & - CALL errore( ' build_cctab_x ', ' upf not allocated ', 1 ) - ! - compute_tab = chkpstab( g, xgtabmax ) - ! - IF( ALLOCATED( rhoc1_sp ) ) THEN - ! - IF( .NOT. compute_tab ) return - ! - DO is = 1, nsp - CALL kill_spline(rhoc1_sp(is),'a') - CALL kill_spline(rhocp_sp(is),'a') - END DO - DEALLOCATE(rhoc1_sp) - DEALLOCATE(rhocp_sp) - ! - END IF - ! - CALL compute_xgtab( xgmin, xgmax, xgtabmax ) - ! - ALLOCATE( rhoc1_sp(nsp)) - ALLOCATE( rhocp_sp(nsp)) - ! - DO is = 1, nsp - - CALL nullify_spline( rhoc1_sp( is ) ) - CALL nullify_spline( rhocp_sp( is ) ) - - IF( upf(is)%nlcc ) THEN - ! - CALL allocate_spline( rhoc1_sp(is), mmx, xgmin, xgmax ) - CALL allocate_spline( rhocp_sp(is), mmx, xgmin, xgmax ) - ! - CALL compute_rhocg( rhoc1_sp(is)%y, rhocp_sp(is)%y, rgrid(is)%r, & - rgrid(is)%rab, upf(is)%rho_atc(:), xgtab, 1.0d0, tpiba2, & - rgrid(is)%mesh, mmx, 1 ) - ! - CALL init_spline( rhoc1_sp(is) ) - CALL init_spline( rhocp_sp(is) ) - ! - END IF - - END DO - - RETURN - END SUBROUTINE build_cctab_x - - -!------------------------------------------------------------------------------! - - - SUBROUTINE compute_betagx_x( tpre ) - ! - ! calculation of array betagx(ig,iv,is) - ! - USE kinds, ONLY : DP - USE ions_base, ONLY : nsp - USE uspp_param, ONLY : upf, nh, nhm, oldvan - USE atom, ONLY : rgrid - USE uspp, ONLY : nhtol, indv - USE betax, only : refg, betagx, mmx, dbetagx - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(IN) :: tpre - ! - INTEGER :: is, iv, l, il, ir, nr - REAL(DP), ALLOCATABLE :: dfint(:), djl(:), fint(:), jl(:) - REAL(DP) :: xg - ! - IF( .NOT. ALLOCATED( rgrid ) ) & - CALL errore( ' compute_betagx_x ', ' rgrid not allocated ', 1 ) - IF( .NOT. ALLOCATED( upf ) ) & - CALL errore( ' compute_betagx_x ', ' upf not allocated ', 1 ) - ! - IF( ALLOCATED( betagx ) ) DEALLOCATE( betagx ) - IF( ALLOCATED( dbetagx ) ) DEALLOCATE( dbetagx ) - ! - ALLOCATE( betagx ( mmx, nhm, nsp ) ) - IF ( tpre ) ALLOCATE( dbetagx( mmx, nhm, nsp ) ) - ! - do is = 1, nsp - ! - nr = upf(is)%kkbeta - ! - if ( tpre ) then - allocate( dfint( nr ) ) - allocate( djl ( nr ) ) - end if - ! - allocate( fint ( nr ) ) - allocate( jl ( nr ) ) - ! - do iv = 1, nh(is) - ! - l = nhtol(iv,is) - ! - do il = 1, mmx - ! - xg = sqrt( refg * (il-1) ) - call sph_bes ( nr, rgrid(is)%r, xg, l, jl ) -! - if( tpre )then - ! - call sph_dbes1 ( nr, rgrid(is)%r, xg, l, jl, djl) - ! - endif - ! - ! beta(ir)=r*beta(r) - ! - do ir = 1, nr - fint(ir) = rgrid(is)%r(ir) * jl(ir) * & - upf(is)%beta( ir, indv(iv,is) ) - end do - if (oldvan(is)) then - call herman_skillman_int(nr,fint,rgrid(is)%rab,betagx(il,iv,is)) - else - call simpson_cp90(nr,fint,rgrid(is)%rab,betagx(il,iv,is)) - endif - ! - if(tpre) then - do ir = 1, nr - dfint(ir) = rgrid(is)%r(ir) * djl(ir) * & - upf(is)%beta( ir, indv(iv,is) ) - end do - if (oldvan(is)) then - call herman_skillman_int(nr,dfint,rgrid(is)%rab,dbetagx(il,iv,is)) - else - call simpson_cp90(nr,dfint,rgrid(is)%rab,dbetagx(il,iv,is)) - end if - endif - ! - end do - end do -! - deallocate(jl) - deallocate(fint) - ! - if (tpre) then - deallocate(djl) - deallocate(dfint) - end if - ! - end do - RETURN - END SUBROUTINE compute_betagx_x - - -!------------------------------------------------------------------------------! - - - SUBROUTINE compute_qradx_x( tpre ) - ! - ! calculation of array qradx(igb,iv,jv,is) for interpolation table - ! (symmetric wrt exchange of iv and jv: a single index ijv is used) - ! - ! qradx(ig,l,k,is) = 4pi/omega int_0^r dr r^2 j_l(qr) q(r,l,k,is) - ! - ! - ! - USE kinds, ONLY : DP - use io_global, only : stdout - USE ions_base, ONLY : nsp - USE uspp_param, ONLY : upf, nh, nbetam, lmaxq, oldvan - USE atom, ONLY : rgrid - USE betax, only : refg, qradx, mmx, dqradx - USE cvan, only : nvb - use gvecb, only : ngb - USE cp_interfaces, ONLY : fill_qrl - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(IN) :: tpre - ! - INTEGER :: is, iv, l, il, ir, jv, ijv - INTEGER :: nr - REAL(DP), ALLOCATABLE :: dfint(:), djl(:), fint(:), jl(:), qrl(:,:,:) - REAL(DP) :: xg - - IF( .NOT. ALLOCATED( rgrid ) ) & - CALL errore( ' compute_qradx_x ', ' rgrid not allocated ', 1 ) - IF( .NOT. ALLOCATED( upf ) ) & - CALL errore( ' compute_qradx_x ', ' upf not allocated ', 1 ) - - IF( ALLOCATED( qradx ) ) DEALLOCATE( qradx ) - IF( ALLOCATED( dqradx ) ) DEALLOCATE( dqradx ) - ! - ALLOCATE( qradx( mmx, nbetam*(nbetam+1)/2, lmaxq, nsp ) ) - ! - IF ( tpre ) ALLOCATE( dqradx( mmx, nbetam*(nbetam+1)/2, lmaxq, nsp ) ) - - DO is = 1, nvb - ! - ! qqq and beta are now indexed and taken in the same order - ! as vanderbilts ppot-code prints them out - ! - WRITE( stdout,*) ' nlinit nh(is), ngb, is, kkbeta, lmaxq = ', & - & nh(is), ngb, is, upf(is)%kkbeta, upf(is)%nqlc - ! - nr = upf(is)%kkbeta - ! - IF ( tpre ) THEN - ALLOCATE( djl ( nr ) ) - ALLOCATE( dfint( nr ) ) - END IF - ! - ALLOCATE( fint( nr ) ) - ALLOCATE( jl ( nr ) ) - ALLOCATE( qrl( nr, upf(is)%nbeta*(upf(is)%nbeta+1)/2, upf(is)%nqlc) ) - ! - call fill_qrl ( is, qrl ) - ! - do l = 1, upf(is)%nqlc - ! - do il = 1, mmx - ! - xg = sqrt( refg * DBLE(il-1) ) - ! - call sph_bes ( nr, rgrid(is)%r, xg, l-1, jl(1) ) - ! - if( tpre ) then - ! - call sph_dbes1 ( nr, rgrid(is)%r, xg, l-1, jl, djl) - ! - endif - ! - ! - do iv = 1, upf(is)%nbeta - do jv = iv, upf(is)%nbeta - ijv = jv * ( jv - 1 ) / 2 + iv - ! - ! note qrl(r)=r^2*q(r) - ! - do ir = 1, nr - fint( ir ) = qrl( ir, ijv, l ) * jl( ir ) - end do - if (oldvan(is)) then - call herman_skillman_int & - (nr,fint(1),rgrid(is)%rab,qradx(il,ijv,l,is)) - else - call simpson_cp90 & - (nr,fint(1),rgrid(is)%rab,qradx(il,ijv,l,is)) - end if - ! - if( tpre ) then - do ir = 1, nr - dfint(ir) = qrl(ir,ijv,l) * djl(ir) - end do - if ( oldvan(is) ) then - call herman_skillman_int & - (nr,dfint(1),rgrid(is)%rab,dqradx(il,ijv,l,is)) - else - call simpson_cp90 & - (nr,dfint(1),rgrid(is)%rab,dqradx(il,ijv,l,is)) - end if - end if - ! - end do - end do - ! - ! - end do - end do - ! - DEALLOCATE ( jl ) - DEALLOCATE ( qrl ) - DEALLOCATE ( fint ) - ! - if ( tpre ) then - DEALLOCATE(djl) - DEALLOCATE ( dfint ) - end if - ! - WRITE( stdout,*) - WRITE( stdout,'(20x,a)') ' qqq ' - ! - do iv=1,upf(is)%nbeta - WRITE( stdout,'(8f9.4)') (upf(is)%qqq(iv,jv),jv=1,upf(is)%nbeta) - end do - WRITE( stdout,*) - ! - end do - - RETURN - END SUBROUTINE compute_qradx_x - -!------------------------------------------------------------------------------! - - SUBROUTINE exact_qradb_x( tpre ) - ! - USE kinds, ONLY : DP - use io_global, only: stdout - USE ions_base, ONLY: nsp - USE uspp_param, ONLY: upf, nh, nbetam, lmaxq, oldvan - USE atom, ONLY: rgrid - use uspp, only: qq - USE betax, only: qradx, dqradx - USE cvan, only: nvb - use gvecb, only: ngb - use control_flags, only: iprsta - use cell_base, only: ainv - use constants, only: pi, fpi - use qradb_mod, only: qradb - use qgb_mod, only: qgb - use gvecb, only: gb, gxb - use small_box, only: omegab, tpibab - use dqrad_mod, only: dqrad - use dqgb_mod, only: dqgb - USE cp_interfaces, ONLY: fill_qrl - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(IN) :: tpre - ! - INTEGER :: is, iv, l, il, ir, jv, ijv, ierr - INTEGER :: ig, i,j, nr - REAL(DP), ALLOCATABLE :: dfint(:), djl(:), fint(:), jl(:), qrl(:,:,:) - REAL(DP) :: xg, c - REAL(DP), ALLOCATABLE :: dqradb(:,:,:,:) - REAL(DP), ALLOCATABLE :: ylmb(:,:), dylmb(:,:,:,:) - COMPLEX(DP), ALLOCATABLE :: dqgbs(:,:,:) - - IF( .NOT. ALLOCATED( rgrid ) ) & - CALL errore( ' exact_qradb_x ', ' rgrid not allocated ', 1 ) - IF( .NOT. ALLOCATED( upf ) ) & - CALL errore( ' exact_qradb_x ', ' upf not allocated ', 1 ) - - IF( ALLOCATED( qradx ) ) DEALLOCATE( qradx ) - IF( ALLOCATED( dqradx ) ) DEALLOCATE( dqradx ) - ! - ALLOCATE( qradx( ngb, nbetam*(nbetam+1)/2, lmaxq, nsp ) ) - ! - IF ( tpre ) ALLOCATE( dqradx( ngb, nbetam*(nbetam+1)/2, lmaxq, nsp ) ) - - DO is = 1, nvb - ! - ! qqq and beta are now indexed and taken in the same order - ! as vanderbilts ppot-code prints them out - ! - WRITE( stdout,*) ' nlinit nh(is), ngb, is, kkbeta, lmaxq = ', & - & nh(is), ngb, is, upf(is)%kkbeta, upf(is)%nqlc - ! - nr = upf(is)%kkbeta - ! - IF ( tpre ) THEN - ALLOCATE( djl ( nr ) ) - ALLOCATE( dfint( nr ) ) - END IF - ! - ALLOCATE( fint( nr ) ) - ALLOCATE( jl ( nr ) ) - ALLOCATE( qrl( nr, upf(is)%nbeta*(upf(is)%nbeta+1)/2, upf(is)%nqlc) ) - ! - call fill_qrl ( is, qrl ) - ! qrl = 0.0d0 - ! - do l = 1, upf(is)%nqlc - ! - do il = 1, ngb - ! - xg = sqrt( gb( il ) * tpibab * tpibab ) - ! - call sph_bes ( nr, rgrid(is)%r, xg, l-1, jl(1) ) - ! - if( tpre ) then - ! - call sph_dbes1 ( nr, rgrid(is)%r, xg, l-1, jl, djl) - ! - endif - ! - ! - do iv = 1, upf(is)%nbeta - do jv = iv, upf(is)%nbeta - ijv = jv * ( jv - 1 ) / 2 + iv - ! - ! note qrl(r)=r^2*q(r) - ! - do ir = 1, nr - fint( ir ) = qrl( ir, ijv, l ) * jl( ir ) - end do - if (oldvan(is)) then - call herman_skillman_int & - (nr,fint(1),rgrid(is)%rab,qradx(il,ijv,l,is)) - else - call simpson_cp90 & - (nr,fint(1),rgrid(is)%rab,qradx(il,ijv,l,is)) - end if - ! - if( tpre ) then - do ir = 1, nr - dfint(ir) = qrl(ir,ijv,l) * djl(ir) - end do - if ( oldvan(is) ) then - call herman_skillman_int & - (nr,dfint(1),rgrid(is)%rab,dqradx(il,ijv,l,is)) - else - call simpson_cp90 & - (nr,dfint(1),rgrid(is)%rab,dqradx(il,ijv,l,is)) - end if - end if - ! - end do - end do - ! - ! - end do - end do - ! - DEALLOCATE ( jl ) - DEALLOCATE ( qrl ) - DEALLOCATE ( fint ) - ! - if ( tpre ) then - DEALLOCATE(djl) - DEALLOCATE ( dfint ) - end if - ! - WRITE( stdout,*) - WRITE( stdout,'(20x,a)') ' qqq ' - ! - do iv=1, upf(is)%nbeta - WRITE( stdout,'(8f9.4)') (upf(is)%qqq(iv,jv),jv=1, upf(is)%nbeta) - end do - WRITE( stdout,*) - ! - end do - - allocate( ylmb( ngb, lmaxq*lmaxq ), STAT=ierr ) - IF( ierr /= 0 ) & - CALL errore(' exact_qradb ', ' cannot allocate ylmb ', 1 ) -! - qradb(:,:,:,:) = 0.d0 - call ylmr2 (lmaxq*lmaxq, ngb, gxb, gb, ylmb) - - do is = 1, nvb - ! - ! calculation of array qradb(igb,iv,jv,is) - ! - if( iprsta .ge. 4 ) WRITE( stdout,*) ' qradb ' - ! - c = fpi / omegab - ! - do iv= 1, upf(is)%nbeta - do jv = iv, upf(is)%nbeta - ijv = jv*(jv-1)/2 + iv - do ig=1,ngb - do l=1,upf(is)%nqlc - qradb(ig,ijv,l,is)= c*qradx(ig,ijv,l,is) - enddo - enddo - enddo - enddo - ! - ! --------------------------------------------------------------- - ! stocking of qgb(igb,ijv,is) and of qq(iv,jv,is) - ! --------------------------------------------------------------- - ! - do iv= 1,nh(is) - do jv=iv,nh(is) - ! - ! compact indices because qgb is symmetric - ! - ijv = jv*(jv-1)/2 + iv - call qvan2b(ngb,iv,jv,is,ylmb,qgb(1,ijv,is) ) -! - qq(iv,jv,is)=omegab*DBLE(qgb(1,ijv,is)) - qq(jv,iv,is)=qq(iv,jv,is) -! - end do - end do - - end do -! - if (tpre) then -! --------------------------------------------------------------- -! arrays required for stress calculation, variable-cell dynamics -! --------------------------------------------------------------- - allocate(dqradb(ngb,nbetam*(nbetam+1)/2,lmaxq,nsp)) - allocate(dylmb(ngb,lmaxq*lmaxq,3,3)) - allocate(dqgbs(ngb,3,3)) - dqrad(:,:,:,:,:,:) = 0.d0 - ! - call dylmr2_(lmaxq*lmaxq, ngb, gxb, gb, ainv, dylmb) - ! - do is=1,nvb - ! - do iv= 1, upf(is)%nbeta - do jv=iv, upf(is)%nbeta - ijv = jv*(jv-1)/2 + iv - do l=1,upf(is)%nqlc - do ig=1,ngb - dqradb(ig,ijv,l,is) = dqradx(ig,ijv,l,is) - enddo - do i=1,3 - do j=1,3 - dqrad(1,ijv,l,is,i,j) = & - -qradb(1,ijv,l,is) * ainv(j,i) - do ig=2,ngb - dqrad(ig,ijv,l,is,i,j) = & - & -qradb(ig,ijv,l,is)*ainv(j,i) & - & -c*dqradb(ig,ijv,l,is)* & - & gxb(i,ig)/gb(ig)* & - & (gxb(1,ig)*ainv(j,1)+ & - & gxb(2,ig)*ainv(j,2)+ & - & gxb(3,ig)*ainv(j,3)) - enddo - enddo - enddo - end do - enddo - enddo - ! - do iv= 1,nh(is) - do jv=iv,nh(is) - ! - ! compact indices because qgb is symmetric - ! - ijv = jv*(jv-1)/2 + iv - call dqvan2b(ngb,iv,jv,is,ylmb,dylmb,dqgbs ) - do i=1,3 - do j=1,3 - do ig=1,ngb - dqgb(ig,ijv,is,i,j)=dqgbs(ig,i,j) - enddo - enddo - enddo - end do - end do - end do - deallocate(dqgbs) - deallocate(dylmb) - deallocate(dqradb) - end if - - deallocate( ylmb ) - - IF( ALLOCATED( qradx ) ) DEALLOCATE( qradx ) - IF( ALLOCATED( dqradx ) ) DEALLOCATE( dqradx ) - - RETURN - END SUBROUTINE exact_qradb_x - - -!------------------------------------------------------------------------------! - - - LOGICAL FUNCTION check_tables_x( ) - ! - ! check table size against cell variations - ! - ! - USE kinds, ONLY : DP - USE betax, ONLY : refg, mmx - USE mp, ONLY : mp_max - USE mp_global, ONLY : intra_image_comm - USE gvecw, ONLY : ngw - USE cell_base, ONLY : tpiba2 - USE small_box, ONLY : tpibab - USE gvecb, ONLY : gb, ngb - USE reciprocal_vectors, ONLY : g - ! - IMPLICIT NONE - ! - REAL(DP) :: gg, ggb, gmax - ! - gg = MAXVAL( g( 1:ngw ) ) - gg = gg * tpiba2 / refg - ! - IF( ALLOCATED( gb ) ) THEN - ! - ggb = MAXVAL( gb( 1:ngb ) ) - ggb = ggb * tpibab * tpibab / refg - gmax = MAX( gg, ggb ) - ! - ELSE - ! - gmax = gg - ! - END IF - ! - CALL mp_max( gmax, intra_image_comm ) - ! - check_tables_x = .FALSE. - IF( ( INT( gmax ) + 2 ) > mmx ) check_tables_x = .TRUE. - ! - RETURN - END FUNCTION check_tables_x - - -!------------------------------------------------------------------------------! - - - SUBROUTINE interpolate_beta_x( tpre ) - ! - ! interpolate array beta(ig,iv,is) - ! - ! - USE kinds, ONLY : DP - USE control_flags, only: iprsta - USE constants, only: pi, fpi - USE io_global, only: stdout - USE gvecw, only: ngw - USE ions_base, only: nsp - USE reciprocal_vectors, only: g, gx, gstart - USE uspp_param, only: lmaxkb, nh - USE uspp, only: nhtolm, beta - USE cell_base, only: ainv, omega, tpiba - USE betax, ONLY : refg, betagx, dbetagx - USE cdvan, ONLY : dbeta - - IMPLICIT NONE - - LOGICAL, INTENT(IN) :: tpre - - REAL(DP), ALLOCATABLE :: ylm(:,:), dylm(:,:,:,:) - REAL(DP) :: c, gg, betagl, dbetagl - INTEGER :: is, iv, lp, ig, jj, i, j - - ALLOCATE( ylm( ngw, (lmaxkb+1)**2 ) ) - CALL ylmr2 ( (lmaxkb+1)**2, ngw, gx, g, ylm) - ! - ! - do is = 1, nsp - ! - ! calculation of array beta(ig,iv,is) - ! - if( iprsta .ge. 4 ) WRITE( stdout,*) ' beta ' - c = fpi / sqrt(omega) - do iv = 1, nh(is) - lp = nhtolm( iv, is ) - do ig = gstart, ngw - gg = g( ig ) * tpiba * tpiba / refg - jj = int( gg ) + 1 - betagl = betagx( jj+1, iv, is ) * ( gg - DBLE(jj-1) ) + betagx( jj, iv, is ) * ( DBLE(jj) - gg ) - beta( ig, iv, is ) = c * ylm( ig, lp ) * betagl - end do - if( gstart == 2 ) then - beta( 1, iv, is ) = c * ylm( 1, lp ) * betagx( 1, iv, is ) - end if - end do - end do - - if (tpre) then - ! - ! calculation of array dbeta required for stress, variable-cell - ! - allocate( dylm( ngw, (lmaxkb+1)**2, 3, 3 ) ) - ! - call dylmr2_( (lmaxkb+1)**2, ngw, gx, g, ainv, dylm ) - ! - do is = 1, nsp - if( iprsta .ge. 4 ) WRITE( stdout,*) ' dbeta ' - c = fpi / sqrt(omega) - do iv = 1, nh(is) - lp = nhtolm(iv,is) - betagl = betagx(1,iv,is) - do i=1,3 - do j=1,3 - dbeta( 1, iv, is, i, j ) = -0.5d0 * beta( 1, iv, is ) * ainv( j, i ) & - & - c * dylm( 1, lp, i, j ) * betagl ! SEGNO - enddo - enddo - do ig = gstart, ngw - gg = g(ig) * tpiba * tpiba / refg - jj=int(gg)+1 - betagl = betagx( jj+1, iv, is ) * ( gg - DBLE(jj-1) ) + & - & betagx( jj , iv, is ) * ( DBLE(jj) - gg ) - dbetagl= dbetagx( jj+1, iv, is ) * ( gg - DBLE(jj-1) ) + & - & dbetagx( jj , iv, is ) * ( DBLE(jj) - gg ) - do i=1,3 - do j=1,3 - dbeta( ig, iv, is, i, j ) = & - & - 0.5d0 * beta( ig, iv, is ) * ainv( j, i ) & - & - c * dylm( ig, lp, i, j ) * betagl & ! SEGNO - & - c * ylm ( ig, lp ) * dbetagl * gx( i, ig ) / g( ig ) & - & * ( gx( 1, ig ) * ainv( j, 1 ) + gx( 2, ig ) * ainv( j, 2 ) + gx( 3, ig ) * ainv( j, 3 ) ) - end do - end do - end do - end do - end do - ! - deallocate(dylm) - ! - end if - ! - deallocate(ylm) - - RETURN - END SUBROUTINE interpolate_beta_x - - -!------------------------------------------------------------------------------! - - - SUBROUTINE interpolate_qradb_x( tpre ) - ! - ! interpolate array qradb(ig,iv,is) - ! - ! - USE kinds, ONLY : DP - use control_flags, only: iprsta - use io_global, only: stdout - use cell_base, only: ainv - use cvan, only: nvb - use uspp, only: qq - use constants, only: pi, fpi - use ions_base, only: nsp - use uspp_param, only: upf, lmaxq, nbetam, nh - use qradb_mod, only: qradb - use qgb_mod, only: qgb - use gvecb, only: gb, gxb, ngb - use small_box, only: omegab, tpibab - use dqrad_mod, only: dqrad - use dqgb_mod, only: dqgb - USE betax, ONLY: qradx, dqradx, refg, mmx -! - implicit none - - LOGICAL, INTENT(IN) :: tpre - - integer is, l, ig, iv, jv, ijv, i,j, jj, ierr - real(8), allocatable:: dqradb(:,:,:,:) - real(8), allocatable:: ylmb(:,:), dylmb(:,:,:,:) - complex(8), allocatable:: dqgbs(:,:,:) - real(8) c, gg -! -! - allocate( ylmb( ngb, lmaxq*lmaxq ), STAT=ierr ) - IF( ierr /= 0 ) & - CALL errore(' interpolate_qradb ', ' cannot allocate ylmb ', 1 ) - - qradb(:,:,:,:) = 0.d0 - if ( nvb > 0 ) call ylmr2 (lmaxq*lmaxq, ngb, gxb, gb, ylmb) - - do is = 1, nvb - ! - ! calculation of array qradb(igb,iv,jv,is) - ! - if( iprsta .ge. 4 ) WRITE( stdout,*) ' qradb ' - ! - c = fpi / omegab - ! - do iv= 1, upf(is)%nbeta - do jv = iv, upf(is)%nbeta - ijv = jv*(jv-1)/2 + iv - do l=1, upf(is)%nqlc - qradb(1,ijv,l,is) = c * qradx(1,ijv,l,is) - end do - do ig=2,ngb - gg=gb(ig)*tpibab*tpibab/refg - jj=int(gg)+1 - do l=1,upf(is)%nqlc - if(jj.ge.mmx) then - qradb(ig,ijv,l,is)=0.d0 - else - qradb(ig,ijv,l,is)= & - & c*qradx(jj+1,ijv,l,is)*(gg-DBLE(jj-1))+ & - & c*qradx(jj,ijv,l,is)*(DBLE(jj)-gg) - endif - enddo - enddo - enddo - enddo -! -! --------------------------------------------------------------- -! stocking of qgb(igb,ijv,is) and of qq(iv,jv,is) -! --------------------------------------------------------------- - do iv= 1,nh(is) - do jv=iv,nh(is) -! -! compact indices because qgb is symmetric -! - ijv = jv*(jv-1)/2 + iv - call qvan2b(ngb,iv,jv,is,ylmb,qgb(1,ijv,is) ) -! - qq(iv,jv,is)=omegab*DBLE(qgb(1,ijv,is)) - qq(jv,iv,is)=qq(iv,jv,is) -! - end do - end do - - end do -! - if (tpre) then -! --------------------------------------------------------------- -! arrays required for stress calculation, variable-cell dynamics -! --------------------------------------------------------------- - allocate(dqradb(ngb,nbetam*(nbetam+1)/2,lmaxq,nsp)) - allocate(dylmb(ngb,lmaxq*lmaxq,3,3)) - allocate(dqgbs(ngb,3,3)) - dqrad(:,:,:,:,:,:) = 0.d0 - ! - if ( nvb > 0 ) call dylmr2_( lmaxq*lmaxq, ngb, gxb, gb, ainv, dylmb ) - ! - do is=1,nvb - ! - do iv= 1, upf(is)%nbeta - do jv=iv, upf(is)%nbeta - ijv = jv*(jv-1)/2 + iv - do l=1,upf(is)%nqlc - dqradb(1,ijv,l,is) = dqradx(1,ijv,l,is) - do ig=2,ngb - gg=gb(ig)*tpibab*tpibab/refg - jj=int(gg)+1 - if(jj.ge.mmx) then - dqradb(ig,ijv,l,is) = 0.d0 - else - dqradb(ig,ijv,l,is) = & - dqradx(jj+1,ijv,l,is)*(gg-DBLE(jj-1)) + & - dqradx(jj,ijv,l,is)*(DBLE(jj)-gg) - endif - enddo - do i=1,3 - do j=1,3 - dqrad(1,ijv,l,is,i,j) = - qradb(1,ijv,l,is) * ainv(j,i) - do ig=2,ngb - dqrad(ig,ijv,l,is,i,j) = & - & - qradb(ig,ijv,l,is)*ainv(j,i) & - & - c * dqradb(ig,ijv,l,is)* & - & gxb(i,ig)/gb(ig)* & - & (gxb(1,ig)*ainv(j,1)+ & - & gxb(2,ig)*ainv(j,2)+ & - & gxb(3,ig)*ainv(j,3)) - enddo - enddo - enddo - end do - enddo - enddo - ! - do iv= 1,nh(is) - do jv=iv,nh(is) - ! - ! compact indices because qgb is symmetric - ! - ijv = jv*(jv-1)/2 + iv - call dqvan2b(ngb,iv,jv,is,ylmb,dylmb,dqgbs ) - do i=1,3 - do j=1,3 - do ig=1,ngb - dqgb(ig,ijv,is,i,j)=dqgbs(ig,i,j) - enddo - enddo - enddo - end do - end do - end do - deallocate(dqgbs) - deallocate(dylmb) - deallocate(dqradb) - end if - deallocate(ylmb) - - RETURN - END SUBROUTINE interpolate_qradb_x - - -!------------------------------------------------------------------------------! - - - SUBROUTINE exact_beta_x( tpre ) - ! - ! compute array beta without interpolation - ! - ! - USE control_flags, only : iprsta - USE kinds, ONLY : DP - USE constants, only : pi, fpi - USE io_global, only : stdout - USE gvecw, only : ngw - USE ions_base, only : nsp - USE uspp_param, only : upf, lmaxkb, nh, nhm, oldvan - USE uspp, only : nhtolm, beta, nhtol, indv - USE cell_base, only : ainv, omega, tpiba - USE cdvan, ONLY : dbeta - USE atom, ONLY : rgrid - USE reciprocal_vectors, only : g, gx, gstart - - IMPLICIT NONE - - LOGICAL, INTENT(IN) :: tpre - - REAL(DP), ALLOCATABLE :: ylm(:,:), dylm(:,:,:,:) - REAL(DP) :: c, betagl, dbetagl - INTEGER :: is, iv, lp, ig, i, j, nr - INTEGER :: l, il, ir - REAL(DP), ALLOCATABLE :: dfint(:), djl(:), fint(:), jl(:) - REAL(DP), ALLOCATABLE :: betagx ( :, :, : ), dbetagx( :, :, : ) - REAL(DP) :: xg - - IF( .NOT. ALLOCATED( rgrid ) ) & - CALL errore( ' exact_beta_x ', ' rgrid not allocated ', 1 ) - IF( .NOT. ALLOCATED( upf ) ) & - CALL errore( ' exact_beta_x ', ' upf not allocated ', 1 ) - - ALLOCATE( ylm( ngw, (lmaxkb+1)**2 ) ) - ALLOCATE( betagx ( ngw, nhm, nsp ) ) - IF (tpre) ALLOCATE( dbetagx( ngw, nhm, nsp ) ) - - CALL ylmr2 ( (lmaxkb+1)**2, ngw, gx, g, ylm) - - ! - do is = 1, nsp - ! - nr = upf(is)%kkbeta - ! - if ( tpre ) then - allocate( dfint( nr ) ) - allocate( djl ( nr ) ) - end if - ! - allocate( fint ( nr ) ) - allocate( jl ( nr ) ) - ! - do iv = 1, nh(is) - ! - l = nhtol(iv,is) - ! - do il = 1, ngw - ! - xg = sqrt( g( il ) * tpiba * tpiba ) - call sph_bes (nr, rgrid(is)%r, xg, l, jl ) - ! - if( tpre )then - ! - call sph_dbes1 ( nr, rgrid(is)%r, xg, l, jl, djl) - ! - endif - ! - ! beta(ir)=r*beta(r) - ! - do ir = 1, nr - fint(ir) = rgrid(is)%r(ir) * jl(ir) * & - upf(is)%beta( ir, indv(iv,is) ) - end do - if (oldvan(is)) then - call herman_skillman_int(nr,fint,rgrid(is)%rab,betagx(il,iv,is)) - else - call simpson_cp90(nr,fint,rgrid(is)%rab,betagx(il,iv,is)) - endif - ! - if(tpre) then - do ir = 1, nr - dfint(ir) = rgrid(is)%r(ir) * djl(ir) * & - upf(is)%beta( ir, indv(iv,is) ) - end do - if (oldvan(is)) then - call herman_skillman_int(nr,dfint,rgrid(ir)%rab,dbetagx(il,iv,is)) - else - call simpson_cp90(nr,dfint,rgrid(is)%rab,dbetagx(il,iv,is)) - end if - endif - ! - end do - end do -! - deallocate(jl) - deallocate(fint) - ! - if (tpre) then - deallocate(djl) - deallocate(dfint) - end if - ! - end do - ! - do is = 1, nsp - ! - ! calculation of array beta(ig,iv,is) - ! - if( iprsta .ge. 4 ) WRITE( stdout,*) ' beta ' - c = fpi / sqrt(omega) - do iv = 1, nh(is) - lp = nhtolm( iv, is ) - do ig = 1, ngw - betagl = betagx( ig, iv, is ) - beta( ig, iv, is ) = c * ylm( ig, lp ) * betagl - end do - end do - end do - - if (tpre) then - ! - ! calculation of array dbeta required for stress, variable-cell - ! - allocate( dylm( ngw, (lmaxkb+1)**2, 3, 3 ) ) - ! - call dylmr2_( (lmaxkb+1)**2, ngw, gx, g, ainv, dylm ) - ! - do is = 1, nsp - if( iprsta .ge. 4 ) WRITE( stdout,*) ' dbeta ' - c = fpi / sqrt(omega) - do iv = 1, nh(is) - lp = nhtolm(iv,is) - betagl = betagx(1,iv,is) - do i=1,3 - do j=1,3 - dbeta(1,iv,is,i,j)=-0.5d0*beta(1,iv,is)*ainv(j,i) & - & -c*dylm(1,lp,i,j)*betagl ! SEGNO - enddo - enddo - do ig=gstart,ngw - betagl = betagx(ig,iv,is) - dbetagl= dbetagx(ig,iv,is) - do i=1,3 - do j=1,3 - dbeta(ig,iv,is,i,j)= & - & -0.5d0*beta(ig,iv,is)*ainv(j,i) & - & -c*dylm(ig,lp,i,j)*betagl & ! SEGNO - & -c*ylm (ig,lp)*dbetagl*gx(i,ig)/g(ig) & - & *(gx(1,ig)*ainv(j,1)+ & - & gx(2,ig)*ainv(j,2)+ & - & gx(3,ig)*ainv(j,3)) - end do - end do - end do - end do - end do - ! - deallocate(dylm) - ! - end if - ! - deallocate(ylm) - IF( ALLOCATED( betagx ) ) DEALLOCATE( betagx ) - IF( ALLOCATED( dbetagx ) ) DEALLOCATE( dbetagx ) - - RETURN - END SUBROUTINE exact_beta_x -! -! -!------------------------------------------------------------------------------! -! -! - SUBROUTINE fill_qrl_x( is, qrl ) - ! - ! fill l-components of Q(r) as in Vanderbilt's approach - ! - USE uspp_param, ONLY: upf - USE atom, ONLY: rgrid - USE kinds, ONLY: DP - USE io_global, ONLY: stdout - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: is - REAL(DP), INTENT(OUT) :: qrl( :, :, : ) - ! - INTEGER :: iv, jv, ijv, lmin, lmax, l, ir, i - INTEGER :: dim1, dim2, dim3 - ! - IF( .NOT. ALLOCATED( rgrid ) ) & - CALL errore( ' fill_qrl_x ', ' rgrid not allocated ', 1 ) - IF( .NOT. ALLOCATED( upf ) ) & - CALL errore( ' fill_qrl_x ', ' upf not allocated ', 1 ) - - dim1 = SIZE( qrl, 1 ) - dim2 = SIZE( qrl, 2 ) - dim3 = SIZE( qrl, 3 ) - ! - IF ( upf(is)%kkbeta > dim1 ) & - CALL errore ('fill_qrl', 'bad 1st dimension for array qrl', 1) - ! - qrl = 0.0d0 - ! - do iv = 1, upf(is)%nbeta - ! - do jv = iv, upf(is)%nbeta - ! - ijv = (jv-1)*jv/2 + iv - ! - IF ( ijv > dim2) & - CALL errore ('fill_qrl', 'bad 2nd dimension for array qrl', 2) - - ! notice that L runs from 1 to Lmax+1 - - lmin = ABS (upf(is)%lll(jv) - upf(is)%lll(iv)) + 1 - lmax = upf(is)%lll(jv) + upf(is)%lll(iv) + 1 - - WRITE( stdout, * ) 'QRL is, jv, iv = ', is, jv, iv - WRITE( stdout, * ) 'QRL lll jv, iv = ', upf(is)%lll(jv), upf(is)%lll(iv) - WRITE( stdout, * ) 'QRL lmin, lmax = ', lmin, lmax - WRITE( stdout, * ) '---------------- ' - - IF ( lmin < 1 .OR. lmax > dim3) THEN - WRITE( stdout, * ) ' lmin, lmax = ', lmin, lmax - CALL errore ('fill_qrl', 'bad 3rd dimension for array qrl', 3) - END IF - - - do l = lmin, lmax - do ir = 1, upf(is)%kkbeta - IF( upf(is)%q_with_l ) THEN - ! BEWARE: index l in upf%qfuncl(l) runs from 0 to lmax, - ! not from 1 to lmax+1 - qrl(ir,ijv,l)=upf(is)%qfuncl(ir,ijv,l-1) - ELSE - ! - if ( rgrid(is)%r(ir) >= upf(is)%rinner(l) ) then - qrl(ir,ijv,l)=upf(is)%qfunc(ir,ijv) - else - qrl(ir,ijv,l)=upf(is)%qfcoef(1,l,iv,jv) - do i = 2, upf(is)%nqf - qrl(ir,ijv,l)=qrl(ir,ijv,l) + & - upf(is)%qfcoef(i,l,iv,jv)*rgrid(is)%r(ir)**(2*i-2) - end do - qrl(ir,ijv,l) = qrl(ir,ijv,l) * rgrid(is)%r(ir)**(l+1) - end if - ENDIF - end do - end do - end do - end do - RETURN - END SUBROUTINE fill_qrl_x diff --git a/quantum_espresso/kcp/CPV/qmatrixd.f90 b/quantum_espresso/kcp/CPV/qmatrixd.f90 deleted file mode 100644 index 73903867b..000000000 --- a/quantum_espresso/kcp/CPV/qmatrixd.f90 +++ /dev/null @@ -1,465 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -subroutine qmatrixd(c0, bec0,ctable, gqq, qmat, detq, ipol) - - ! this subroutine computes the inverse of the matrix Q - ! Q_ij= - ! and det Q - ! Matrix Q is symmetric, and we make us of it - - ! c0 input: the unperturbed wavefunctions - ! bec0 input: the coefficients - ! ctable input: the coorespondence array - ! gqq input: the intqq(r) exp(iG_ipol*r) array - ! qmat output: the inverse q matrix - ! detq output: det Q - ! ipol: electric field direction - - use kinds, only : DP - use gvecw, only: ngw - use cvan, only: nvb, ish - use ions_base, only : nax, nsp, na - use reciprocal_vectors, only: gstart - use uspp_param, only: nh, nhm - use electrons_base, only: nx => nbspx, n => nbsp, ispin - use mp, only: mp_sum, mp_alltoall - use mp_global, only: intra_image_comm, nproc_image - USE efield_module, ONLY : ctable_missing_1,ctable_missing_2, n_g_missing_p,& - & ctable_missing_rev_1,ctable_missing_rev_2 - use twin_types !added:giovanni - - implicit none - - type(twin_matrix) :: bec0 !modified:giovanni (nkb,n) - complex(DP) :: gqq(nhm,nhm,nax,nsp) - complex(DP) :: c0(ngw,nx), qmat(nx,nx), detq - integer :: ctable(ngw,2) - integer, intent(in) :: ipol - ! local variables - integer ig,ix,jx, iv,jv,is,ia, inl,jnl, ip - complex(DP) :: sca - integer :: info - integer, allocatable :: ipiv(:,:) - complex(DP), allocatable :: work(:) - complex(DP), allocatable :: sndbuf(:,:,:),rcvbuf(:,:,:) - - - qmat(:,:)=CMPLX(0.d0,0.d0) - - ALLOCATE( ipiv( nx, nx ), work( nx ) ) - - do ix=1,n - do jx=ix,n - -! first the local part - - sca=CMPLX(0.d0,0.d0) - if(ispin(ix) == ispin(jx) ) then - - do ig=1,ngw - if(ctable(ig,1).ne.(ngw+1))then - if(ctable(ig,1).ge.0) then - sca=sca+CONJG(c0(ctable(ig,1),ix))*c0(ig,jx) - endif - endif - enddo - - do ig=1,ngw - if(ctable(ig,1).ne.(ngw+1))then - if(ctable(ig,1).lt. 0) then - sca=sca+c0(-ctable(ig,1),ix)*c0(ig,jx) - endif - endif - enddo - - do ig=gstart,ngw - if(ctable(ig,2).ne.(ngw+1)) then - if(ctable(ig,2).lt.0) then - sca=sca+c0(-ctable(ig,2),ix)*CONJG(c0(ig,jx)) - endif - endif - enddo - - do ig=gstart,ngw - if(ctable(ig,2).ne.(ngw+1)) then - if(ctable(ig,2).ge.0) then - sca=sca+CONJG(c0(ctable(ig,2),ix))*conjg(c0(ig,jx)) - endif - endif - enddo - - - -#ifdef __PARA - - if(ipol /= 3) then - ! - allocate(sndbuf(n_g_missing_p(ipol),2,nproc_image)) - sndbuf(:,:,:)=(0.d0,0.d0) - allocate(rcvbuf(n_g_missing_p(ipol),2,nproc_image)) -!copy arrays to snd buf - do ip=1,nproc_image - do ig=1,n_g_missing_p(ipol) - if(ipol==1) then - if(ctable_missing_1(ig,1,ip)/=0) then - sndbuf(ig,1,ip)=c0(ctable_missing_1(ig,1,ip),jx) - endif - else - if(ctable_missing_2(ig,1,ip)/=0) then - sndbuf(ig,1,ip)=c0(ctable_missing_2(ig,1,ip),jx) - endif - endif - enddo - do ig=1,n_g_missing_p(ipol) - if(ipol==1) then - if(ctable_missing_1(ig,2,ip)/=0) then - sndbuf(ig,2,ip)=conjg(c0(ctable_missing_1(ig,2,ip),jx)) - endif - else - if(ctable_missing_2(ig,2,ip)/=0) then - sndbuf(ig,2,ip)=conjg(c0(ctable_missing_2(ig,2,ip),jx)) - endif - endif - enddo - enddo - - - CALL mp_alltoall( sndbuf, rcvbuf, intra_image_comm ) - -!update sca - do ip=1,nproc_image - do ig=1,n_g_missing_p(ipol) - if(ipol==1) then - if(ctable_missing_rev_1(ig,1,ip) >0) then - sca=sca+conjg(c0(ctable_missing_rev_1(ig,1,ip),ix))*rcvbuf(ig,1,ip) - else if(ctable_missing_rev_1(ig,1,ip)< 0) then - sca=sca+c0(-ctable_missing_rev_1(ig,1,ip),ix)*rcvbuf(ig,1,ip) - endif - else - if(ctable_missing_rev_2(ig,1,ip) >0) then - sca=sca+conjg(c0(ctable_missing_rev_2(ig,1,ip),ix))*rcvbuf(ig,1,ip) - else if(ctable_missing_rev_2(ig,1,ip)< 0) then - sca=sca+c0(-ctable_missing_rev_2(ig,1,ip),ix)*rcvbuf(ig,1,ip) - endif - endif - enddo - do ig=1,n_g_missing_p(ipol) - if(ipol==1) then - if(ctable_missing_rev_1(ig,2,ip) >0) then - sca=sca+conjg(c0(ctable_missing_rev_1(ig,2,ip),ix))*rcvbuf(ig,2,ip) - else if(ctable_missing_rev_1(ig,2,ip)< 0) then - sca=sca+c0(-ctable_missing_rev_1(ig,2,ip),ix)*rcvbuf(ig,2,ip) - endif - else - if(ctable_missing_rev_2(ig,2,ip) >0) then - sca=sca+conjg(c0(ctable_missing_rev_2(ig,2,ip),ix))*rcvbuf(ig,2,ip) - else if(ctable_missing_rev_2(ig,2,ip)< 0) then - sca=sca+c0(-ctable_missing_rev_2(ig,2,ip),ix)*rcvbuf(ig,2,ip) - endif - endif - enddo - - enddo - - deallocate(rcvbuf,sndbuf) - - endif - -#endif - - - call mp_sum( sca, intra_image_comm ) - endif - qmat(ix,jx)=sca - - ! now the non local vanderbilt part - - sca = CMPLX(0.d0,0.d0) - if(ispin(ix)==ispin(jx)) then - if(.not.bec0%iscmplx) then - do is=1,nvb!loop on vanderbilt species - do ia=1,na(is)!loop on atoms - do iv=1,nh(is)!loop on projectors - do jv=1,nh(is) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - sca=sca+gqq(iv,jv,ia,is)*bec0%rvec(inl,ix)*bec0%rvec(jnl,jx) - enddo - enddo - enddo - enddo - else - do is=1,nvb!loop on vanderbilt species - do ia=1,na(is)!loop on atoms - do iv=1,nh(is)!loop on projectors - do jv=1,nh(is) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - sca=sca+gqq(iv,jv,ia,is)*CONJG(bec0%cvec(inl,ix))*bec0%cvec(jnl,jx) - enddo - enddo - enddo - enddo - endif - - qmat(ix,jx)=qmat(ix,jx)+sca - endif - qmat(jx,ix)=qmat(ix,jx) - enddo - enddo - - !LAPACK - call zgetrf (n,n,qmat,nx,ipiv,info) - ! write(6,*) 'info trf', info - detq=(1.d0,0.d0) - - do ix=1,n - if(ix.ne.ipiv(ix,1)) detq=-detq - enddo - do ix=1,n - detq = detq*qmat(ix,ix) - enddo - - call zgetri (n,qmat,nx,ipiv,work,nx,info) - -! force qmat to be symmetric - - do ix=1,n - do jx=ix+1,n - qmat(jx,ix)=0.5d0*(qmat(ix,jx)+qmat(jx,ix)) - qmat(ix,jx)=qmat(jx,ix) - enddo - enddo - - deallocate( ipiv, work ) - - return -end subroutine qmatrixd - -subroutine qmatrixd_old(c0, bec0,ctable, gqq, qmat, detq, ipol) - - ! this subroutine computes the inverse of the matrix Q - ! Q_ij= - ! and det Q - ! Matrix Q is symmetric, and we make us of it - - ! c0 input: the unperturbed wavefunctions - ! bec0 input: the coefficients - ! ctable input: the coorespondence array - ! gqq input: the intqq(r) exp(iG_ipol*r) array - ! qmat output: the inverse q matrix - ! detq output: det Q - ! ipol: electric field direction - - use kinds, only : DP - use gvecw, only: ngw - use cvan, only: nvb, ish - use ions_base, only : nax, nsp, na - use reciprocal_vectors, only: gstart - use uspp_param, only: nh, nhm - use uspp, only : nkb - use electrons_base, only: nx => nbspx, n => nbsp, ispin - use mp, only: mp_sum, mp_alltoall - use mp_global, only: intra_image_comm, nproc_image - USE efield_module, ONLY : ctable_missing_1,ctable_missing_2,n_g_missing_p,& - & ctable_missing_rev_1,ctable_missing_rev_2 - - implicit none - - real(DP) :: bec0(nkb,n) - complex(DP) :: gqq(nhm,nhm,nax,nsp) - complex(DP) :: c0(ngw,nx), qmat(nx,nx), detq - integer :: ctable(ngw,2) - integer, intent(in) :: ipol - ! local variables - integer ig,ix,jx, iv,jv,is,ia, inl,jnl, ip - complex(DP) :: sca - integer :: info - integer, allocatable :: ipiv(:,:) - complex(DP), allocatable :: work(:) - complex(DP), allocatable :: sndbuf(:,:,:),rcvbuf(:,:,:) - - - qmat(:,:)=CMPLX(0.d0,0.d0) - - ALLOCATE( ipiv( nx, nx ), work( nx ) ) - - do ix=1,n - do jx=ix,n - -! first the local part - - sca=CMPLX(0.d0,0.d0) - if(ispin(ix) == ispin(jx) ) then - - do ig=1,ngw - if(ctable(ig,1).ne.(ngw+1))then - if(ctable(ig,1).ge.0) then - sca=sca+CONJG(c0(ctable(ig,1),ix))*c0(ig,jx) - endif - endif - enddo - - do ig=1,ngw - if(ctable(ig,1).ne.(ngw+1))then - if(ctable(ig,1).lt. 0) then - sca=sca+c0(-ctable(ig,1),ix)*c0(ig,jx) - endif - endif - enddo - - do ig=gstart,ngw - if(ctable(ig,2).ne.(ngw+1)) then - if(ctable(ig,2).lt.0) then - sca=sca+c0(-ctable(ig,2),ix)*CONJG(c0(ig,jx)) - endif - endif - enddo - - do ig=gstart,ngw - if(ctable(ig,2).ne.(ngw+1)) then - if(ctable(ig,2).ge.0) then - sca=sca+CONJG(c0(ctable(ig,2),ix))*conjg(c0(ig,jx)) - endif - endif - enddo - - - -#ifdef __PARA - - if(ipol /= 3) then - ! - allocate(sndbuf(n_g_missing_p(ipol),2,nproc_image)) - sndbuf(:,:,:)=(0.d0,0.d0) - allocate(rcvbuf(n_g_missing_p(ipol),2,nproc_image)) -!copy arrays to snd buf - do ip=1,nproc_image - do ig=1,n_g_missing_p(ipol) - if(ipol==1) then - if(ctable_missing_1(ig,1,ip)/=0) then - sndbuf(ig,1,ip)=c0(ctable_missing_1(ig,1,ip),jx) - endif - else - if(ctable_missing_2(ig,1,ip)/=0) then - sndbuf(ig,1,ip)=c0(ctable_missing_2(ig,1,ip),jx) - endif - endif - enddo - do ig=1,n_g_missing_p(ipol) - if(ipol==1) then - if(ctable_missing_1(ig,2,ip)/=0) then - sndbuf(ig,2,ip)=conjg(c0(ctable_missing_1(ig,2,ip),jx)) - endif - else - if(ctable_missing_2(ig,2,ip)/=0) then - sndbuf(ig,2,ip)=conjg(c0(ctable_missing_2(ig,2,ip),jx)) - endif - endif - enddo - enddo - - - CALL mp_alltoall( sndbuf, rcvbuf, intra_image_comm ) - -!update sca - do ip=1,nproc_image - do ig=1,n_g_missing_p(ipol) - if(ipol==1) then - if(ctable_missing_rev_1(ig,1,ip) >0) then - sca=sca+conjg(c0(ctable_missing_rev_1(ig,1,ip),ix))*rcvbuf(ig,1,ip) - else if(ctable_missing_rev_1(ig,1,ip)< 0) then - sca=sca+c0(-ctable_missing_rev_1(ig,1,ip),ix)*rcvbuf(ig,1,ip) - endif - else - if(ctable_missing_rev_2(ig,1,ip) >0) then - sca=sca+conjg(c0(ctable_missing_rev_2(ig,1,ip),ix))*rcvbuf(ig,1,ip) - else if(ctable_missing_rev_2(ig,1,ip)< 0) then - sca=sca+c0(-ctable_missing_rev_2(ig,1,ip),ix)*rcvbuf(ig,1,ip) - endif - endif - enddo - do ig=1,n_g_missing_p(ipol) - if(ipol==1) then - if(ctable_missing_rev_1(ig,2,ip) >0) then - sca=sca+conjg(c0(ctable_missing_rev_1(ig,2,ip),ix))*rcvbuf(ig,2,ip) - else if(ctable_missing_rev_1(ig,2,ip)< 0) then - sca=sca+c0(-ctable_missing_rev_1(ig,2,ip),ix)*rcvbuf(ig,2,ip) - endif - else - if(ctable_missing_rev_2(ig,2,ip) >0) then - sca=sca+conjg(c0(ctable_missing_rev_2(ig,2,ip),ix))*rcvbuf(ig,2,ip) - else if(ctable_missing_rev_2(ig,2,ip)< 0) then - sca=sca+c0(-ctable_missing_rev_2(ig,2,ip),ix)*rcvbuf(ig,2,ip) - endif - endif - enddo - - enddo - - deallocate(rcvbuf,sndbuf) - - endif - -#endif - - - call mp_sum( sca, intra_image_comm ) - endif - qmat(ix,jx)=sca - - ! now the non local vanderbilt part - - sca = CMPLX(0.d0,0.d0) - if(ispin(ix)==ispin(jx)) then - do is=1,nvb!loop on vanderbilt species - do ia=1,na(is)!loop on atoms - do iv=1,nh(is)!loop on projectors - do jv=1,nh(is) - inl=ish(is)+(iv-1)*na(is)+ia - jnl=ish(is)+(jv-1)*na(is)+ia - sca=sca+gqq(iv,jv,ia,is)*bec0(inl,ix)*bec0(jnl,jx) - enddo - enddo - enddo - enddo - - qmat(ix,jx)=qmat(ix,jx)+sca - endif - qmat(jx,ix)=qmat(ix,jx) - enddo - enddo - - !LAPACK - call zgetrf (n,n,qmat,nx,ipiv,info) - ! write(6,*) 'info trf', info - detq=(1.d0,0.d0) - - do ix=1,n - if(ix.ne.ipiv(ix,1)) detq=-detq - enddo - do ix=1,n - detq = detq*qmat(ix,ix) - enddo - - call zgetri (n,qmat,nx,ipiv,work,nx,info) - -! force qmat to be symmetric - - do ix=1,n - do jx=ix+1,n - qmat(jx,ix)=0.5d0*(qmat(ix,jx)+qmat(jx,ix)) - qmat(ix,jx)=qmat(jx,ix) - enddo - enddo - - deallocate( ipiv, work ) - - return -end subroutine qmatrixd_old diff --git a/quantum_espresso/kcp/CPV/qqberry.f90 b/quantum_espresso/kcp/CPV/qqberry.f90 deleted file mode 100644 index c8a7036a6..000000000 --- a/quantum_espresso/kcp/CPV/qqberry.f90 +++ /dev/null @@ -1,281 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -subroutine qqberry2( gqq,gqqm, ipol) - -! this subroutine computes the array gqq and gqqm -! gqq=int_dr qq(r)exp(iGr)= -! gqqm=int_dr qq(r)exp(-iGr)= - -! gqq output: as defined above - - use uspp_param, only: upf, lmaxq, nbetam, nh, nhm, oldvan - use uspp, only: indv, lpx, lpl, ap,nhtolm - use atom, only: rgrid - use core - use gvecw, only: ngw - use reciprocal_vectors, only: mill_l - use constants - use cvan, only: nvb - use ions_base - use ions_base, only: nas => nax - use cell_base, only: a1, a2, a3 - use reciprocal_vectors, only: gx, g - use mp, only: mp_sum - use mp_global, only: intra_image_comm - use cp_interfaces, only: fill_qrl - - implicit none - - complex(8) gqq(nhm,nhm,nas,nsp) - complex(8) gqqm(nhm,nhm,nas,nsp) - real(8) gmes - integer :: ipol - -! local variables - - integer :: ndm, ig, is, iv, jv, i,l,ir, igi,ia - real(8), allocatable:: fint(:),jl(:) - real(8), allocatable:: qrl(:,:,:), qradb2(:,:,:,:) - real(8) c, xg - complex(8) qgbs,sig - integer :: ivs, jvs, ivl, jvl, lp, ijv - real(8), allocatable:: ylm(:,:) - - IF( .NOT. ALLOCATED( rgrid ) ) & - CALL errore( ' qqberry2 ', ' rgrid not allocated ', 1 ) - IF( .NOT. ALLOCATED( upf ) ) & - CALL errore( ' qqberry2 ', ' upf not allocated ', 1 ) - - ndm = MAXVAL (upf(1:nsp)%kkbeta) - allocate( fint( ndm), jl(ndm)) - allocate( qradb2(nbetam,nbetam,lmaxq,nsp)) - allocate( ylm(ngw, lmaxq*lmaxq)) - - CALL ylmr2( lmaxq*lmaxq, ngw, gx, g, ylm ) - - qradb2 = 0.0d0 - - do is=1,nsp - do ia=1,nas - do jv=1,nhm - do iv=1,nhm - gqq(iv,jv,ia,is)=(0.d0,0.d0) - gqqm(iv,jv,ia,is)=(0.d0,0.d0) - enddo - enddo - enddo - enddo - - if(ipol.eq.1) then - gmes=a1(1)**2+a1(2)**2+a1(3)**2 - gmes=2*pi/SQRT(gmes) - endif - if(ipol.eq.2) then - gmes=a2(1)**2+a2(2)**2+a2(3)**2 - gmes=2*pi/SQRT(gmes) - endif - if(ipol.eq.3) then - gmes=a3(1)**2+a3(2)**2+a3(3)**2 - gmes=2*pi/SQRT(gmes) - endif - ! only for Vanderbilt species - do is=1,nvb - c=fpi !/omegab - ! - ALLOCATE ( qrl( upf(is)%kkbeta, upf(is)%nbeta*(upf(is)%nbeta+1)/2, & - upf(is)%nqlc ) ) - ! - call fill_qrl ( is, qrl ) - ! now the radial part - do l=1,upf(is)%nqlc - xg= gmes !only orthorombic cells - !!!call bess(xg,l,upf(is)%kkbeta,rgrid(is)%r,jl) - call sph_bes ( upf(is)%kkbeta, rgrid(is)%r, xg, l-1, jl ) - do iv= 1,upf(is)%nbeta - do jv=iv,upf(is)%nbeta - ijv = (jv-1)*jv/2 + iv -! -! note qrl(r)=r^2*q(r) -! - do ir=1,upf(is)%kkbeta - fint(ir)=qrl(ir,ijv,l)*jl(ir) - end do - if (oldvan(is)) then - call herman_skillman_int ( upf(is)%kkbeta,fint,rgrid(is)%rab,& - qradb2(iv,jv,l,is) ) - else - call simpson ( upf(is)%kkbeta,fint,rgrid(is)%rab,& - qradb2(iv,jv,l,is) ) - endif - qradb2(iv,jv,l,is)= c*qradb2(iv,jv,l,is) - if ( iv /= jv ) qradb2(jv,iv,l,is)= qradb2(iv,jv,l,is) - end do - end do - end do - DEALLOCATE ( qrl ) - enddo - - igi=-1 - do ig=1,ngw - if(ipol.eq.1 ) then - if(mill_l(1,ig).eq.1 .and. mill_l(2,ig).eq.0 .and. mill_l(3,ig).eq. 0) igi=ig - endif - if(ipol.eq.2 ) then - if(mill_l(1,ig).eq.0 .and. mill_l(2,ig).eq.1 .and. mill_l(3,ig).eq. 0) igi=ig - endif - if(ipol.eq.3 ) then - if(mill_l(1,ig).eq.0 .and. mill_l(2,ig).eq.0 .and. mill_l(3,ig).eq. 1) igi=ig - endif - enddo - if( igi.ne.-1) then - -!setting array beigr - - do is=1,nvb - do iv= 1,nh(is) - do jv=iv,nh(is) - ivs=indv(iv,is) - jvs=indv(jv,is) - ivl=nhtolm(iv,is) - jvl=nhtolm(jv,is) -! -! lpx = max number of allowed y_lm -! lp = composite lm to indentify them -! - qgbs=(0.d0,0.d0) - do i=1,lpx(ivl,jvl) - lp=lpl(ivl,jvl,i) -! -! extraction of angular momentum l from lp: -! - if (lp.eq.1) then - l=1 - else if ((lp.ge.2) .and. (lp.le.4)) then - l=2 - else if ((lp.ge.5) .and. (lp.le.9)) then - l=3 - else if ((lp.ge.10).and.(lp.le.16)) then - l=4 - else if ((lp.ge.17).and.(lp.le.25)) then - l=5 - else if (lp.ge.26) then - call errore(' qvanb ',' lp.ge.26 ',lp) - endif -! -! sig= (-i)^l -! - sig=(0.d0,-1.d0)**(l-1) - - sig=sig*ap(lp,ivl,jvl) - qgbs=qgbs+sig*ylm(igi,lp)*qradb2(ivs,jvs,l,is) - - end do - - do ia=1,na(is) - - gqqm(iv,jv,ia,is)=qgbs - gqqm(jv,iv,ia,is)=qgbs - gqq(iv,jv,ia,is)=CONJG(gqqm(iv,jv,ia,is)) - gqq(jv,iv,ia,is)=CONJG(gqqm(iv,jv,ia,is)) - end do - end do - enddo - enddo - endif - - call mp_sum(gqq(:,:,:,:),intra_image_comm) - call mp_sum(gqqm(:,:,:,:),intra_image_comm) - - deallocate( fint) - deallocate( jl) - deallocate(qradb2) - deallocate(ylm) - - return -end subroutine qqberry2 - - - - - - -! this subroutine updates gqq and gqqm to the -! (new) atomic position - - -subroutine qqupdate(eigr, gqqm0, gqq, gqqm, ipol) - -! gqq output: as defined above - - use cvan - use gvecw, only: ngw - use ions_base, only : nas => nax, nat, na, nsp - use reciprocal_vectors, only: mill_l - use uspp_param, only: nh, nhm - use mp, only: mp_sum - use mp_global, only: intra_image_comm - - implicit none - - - complex(8) eigr(ngw,nat) - complex(8) gqq(nhm,nhm,nas,nsp) - complex(8) gqqm(nhm,nhm,nas,nsp) - complex(8) gqqm0(nhm,nhm,nas,nsp) - - integer ipol - - integer igi,ig,is,iv,jv,ia,isa - - - do is=1,nsp - do ia=1,nas - do jv=1,nhm - do iv=1,nhm - gqq(iv,jv,ia,is)=(0.d0,0.d0) - gqqm(iv,jv,ia,is)=(0.d0,0.d0) - enddo - enddo - enddo - enddo - - igi=-1 - do ig=1,ngw - if(ipol.eq.1 ) then - if(mill_l(1,ig).eq.1 .and. mill_l(2,ig).eq.0 .and. mill_l(3,ig).eq. 0) igi=ig - endif - if(ipol.eq.2 ) then - if(mill_l(1,ig).eq.0 .and. mill_l(2,ig).eq.1 .and. mill_l(3,ig).eq. 0) igi=ig - endif - if(ipol.eq.3 ) then - if(mill_l(1,ig).eq.0 .and. mill_l(2,ig).eq.0 .and. mill_l(3,ig).eq. 1) igi=ig - endif - enddo - if( igi.ne.-1) then - - - isa = 1 - do is=1,nvb - do ia=1,na(is) - do iv= 1,nh(is) - do jv=iv,nh(is) - gqqm(iv,jv,ia,is)= gqqm0(iv,jv,ia,is)*eigr(igi,isa) - gqqm(jv,iv,ia,is)= gqqm0(iv,jv,ia,is)*eigr(igi,isa) - gqq(iv,jv,ia,is)=CONJG(gqqm(iv,jv,ia,is)) - gqq(jv,iv,ia,is)=CONJG(gqqm(iv,jv,ia,is)) - enddo - enddo - isa = isa + 1 - enddo - enddo - endif - call mp_sum(gqq(:,:,:,:),intra_image_comm) - call mp_sum(gqqm(:,:,:,:),intra_image_comm) - return -end subroutine qqupdate diff --git a/quantum_espresso/kcp/CPV/read_pseudo.f90 b/quantum_espresso/kcp/CPV/read_pseudo.f90 deleted file mode 100644 index 0dac5861d..000000000 --- a/quantum_espresso/kcp/CPV/read_pseudo.f90 +++ /dev/null @@ -1,554 +0,0 @@ - -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - -!=----------------------------------------------------------------------------=! - MODULE read_pseudo_module_fpmd -!=----------------------------------------------------------------------------=! - - USE kinds - USE io_files, ONLY: pseudounit - USE pseudo_types, ONLY: pseudo_upf - USE pseudo_types, ONLY: nullify_pseudo_upf, deallocate_pseudo_upf - USE uspp_param, ONLY: upf - - IMPLICIT NONE - - SAVE - - PRIVATE - - REAL(DP) :: TOLMESH = 1.d-5 - INTEGER :: nspnl = 0 ! number of non local species - - PUBLIC :: nspnl, readpp - PUBLIC :: pseudo_filename, check_file_type - -!=----------------------------------------------------------------------------=! - CONTAINS -!=----------------------------------------------------------------------------=! - -CHARACTER(LEN=256) FUNCTION pseudo_filename( is ) - USE io_files, ONLY: psfile, pseudo_dir - INTEGER, INTENT(IN) :: is - IF (TRIM(pseudo_dir) == ' ' ) then - pseudo_filename=TRIM(psfile(is)) - ELSE - pseudo_filename=TRIM(pseudo_dir)//TRIM(psfile(is)) - END IF - RETURN -END FUNCTION pseudo_filename - -!=----------------------------------------------------------------------------=! - -INTEGER FUNCTION check_file_type( is ) - ! - ! ... This subroutine guesses the pseudopotential type - ! on return: - ! -1 file is nonexistent - ! 0 file is unknown (guess: old CPV norm-conserving format) - ! 1 file is *.vdb or *.van Vanderbilt US pseudopotential - ! 2 file is *.RRKJ3 Andrea's US new code - ! 11 file is NUMERIC (FPMD only) no more supported use UPF - ! 12 file is ANALYTIC (FPMD only) no more supported use UPF - ! 20 file is UPF - ! - INTEGER, INTENT(IN) :: is - CHARACTER(LEN=256) :: filename - CHARACTER(LEN=80) :: dummy - LOGICAL, EXTERNAL :: matches - INTEGER :: ios, info, l - LOGICAL :: exst - ! - info = 0 - ios = 0 - filename = pseudo_filename( is ) - ! - INQUIRE ( FILE = TRIM(filename), EXIST=exst ) - IF ( .NOT. exst) THEN - check_file_type = -1 - return - END IF - OPEN( UNIT = pseudounit, FILE = TRIM(filename), STATUS = 'OLD' ) - header_loop: do while (ios == 0) - read ( pseudounit, *, iostat = ios, err = 200) dummy - if (matches (" 5) then - if (filename (l - 5:l) .eq.'.RRKJ3') info = 2 - end if - END IF - - check_file_type = info - - RETURN -END FUNCTION check_file_type - -!=----------------------------------------------------------------------------=! - -SUBROUTINE check_types_order( ) - USE ions_base, ONLY: nsp - IMPLICIT NONE - INTEGER :: is, il - ! - ! With Vanderbilt, only UPF are allowed - ! - IF( ANY( upf( 1:nsp )%tvanp ) ) THEN - CALL errore( ' check_types_order ', & - ' vanderbilt pseudo, not yet implemented in FPMD ', 1 ) - END IF - ! - ! non-local species must be ahead the local one, - ! - il = 0 - DO is = 1, nsp - IF ( upf( is )%nbeta == 0 ) THEN - il = 1 - ELSE IF ( il == 1 ) THEN - CALL errore( & - ' check_types_order ', ' Local pseudopotentials should follow non local ones ', 1 ) - END IF - END DO - RETURN -END SUBROUTINE check_types_order - -!=----------------------------------------------------------------------------=! - -REAL(DP) FUNCTION calculate_dx( a, m ) - USE constants, ONLY: eps14 - REAL(DP), INTENT(IN) :: a(:) - INTEGER, INTENT(IN) :: m - INTEGER :: n, nn - REAL(DP) :: ra, rb - n = MIN( SIZE( a ), m ) - nn = n - IF( a(1) < eps14 ) THEN - ra = a(2) - nn = n - 1 - ELSE - ra = a(1) - END IF - rb = a(n) - calculate_dx = LOG( rb / ra ) / DBLE( nn - 1 ) - RETURN -END FUNCTION calculate_dx - -!=----------------------------------------------------------------------------=! - - SUBROUTINE readpp( xc_type ) - - ! this subroutine reads pseudopotential parameters from file - ! - ! See check_file_type for Allowed format - ! - ! - ! ---------------------------------------------- - - USE mp, ONLY: mp_bcast, mp_sum - USE io_global, ONLY: stdout, ionode, ionode_id - USE uspp, ONLY : okvan - USE core, ONLY : nlcc_any - USE uspp_param, ONLY : oldvan - USE cvan, ONLY: nvb - use ions_base, only: zv, nsp - use upf_module, only: read_upf - use read_uspp_module, only: readvan, readrrkj - use control_flags, only: program_name - use funct, only: get_iexch, get_icorr, get_igcx, get_igcc, set_dft_from_name, dft_is_hybrid - USE upf_to_internal, ONLY: set_pseudo_upf - USE atom, ONLY : msh, rgrid - use radial_grids, ONLY : deallocate_radial_grid, nullify_radial_grid - - IMPLICIT NONE - - CHARACTER(LEN=*), INTENT(IN) :: xc_type - -! ... declare other variables - CHARACTER(LEN=20) :: dft_name - CHARACTER(LEN=80) :: error_msg - CHARACTER(LEN=256) :: filename - INTEGER :: is, ierr, info - INTEGER :: iexch_, icorr_, igcx_, igcc_ - -! end of declarations -! ---------------------------------------------- - - nspnl = 0 ! number of non local pseudo - nvb = 0 ! number of Vanderbilt pseudo - ! - nlcc_any = .false. ! core corrections - - IF( nsp < 1 ) THEN - CALL errore(' READPOT ',' nsp less than one! ', 1 ) - END IF - - IF( ALLOCATED( rgrid ) ) THEN - DO is = 1, SIZE( rgrid ) - CALL deallocate_radial_grid( rgrid( is ) ) - CALL nullify_radial_grid( rgrid( is ) ) - END DO - DEALLOCATE( rgrid ) - DEALLOCATE( msh ) - END IF - - ALLOCATE( rgrid( nsp ), msh(nsp ) ) - - DO is = 1, nsp - CALL nullify_radial_grid( rgrid( is ) ) - END DO - - IF( ALLOCATED( upf ) ) THEN - DO is = 1, SIZE( upf ) - CALL deallocate_pseudo_upf( upf( is ) ) - CALL nullify_pseudo_upf( upf( is ) ) - END DO - DEALLOCATE( upf ) - END IF - - ALLOCATE( upf( nsp ) ) - - ! nullify upf objects as soon as they are instantiated - - DO is = 1, nsp - CALL nullify_pseudo_upf( upf( is ) ) - END DO - - ierr = 0 - info = 0 - error_msg = 'none' - - IF( ionode ) THEN - WRITE( stdout,4) - 4 FORMAT(//,3X,'Atomic Pseudopotentials Parameters',/, & - 3X,'----------------------------------' ) - END IF - - DO is = 1, nsp - - filename = TRIM( pseudo_filename( is ) ) - ! - upf(is)%nlcc = .FALSE. - upf(is)%nbeta = 0 - upf(is)%tvanp = .FALSE. - ! - IF( ionode ) THEN - WRITE( stdout,6) is, TRIM(filename) - 6 FORMAT( /,3X,'Reading pseudopotential for specie # ',I2,' from file :',/,3X,A) - END IF - - IF( ionode ) THEN - info = check_file_type( is ) - SELECT CASE (info) - CASE (0) - WRITE( stdout,"(3X,'file type is ',I2,': Old CPV NC PP')") info - CASE (1) - WRITE( stdout,"(3X,'file type is ',I2,': Vanderbilt US PP')") info - CASE (2) - WRITE( stdout,"(3X,'file type is ',I2,': RRKJ3')") info - CASE (11) - WRITE( stdout,"(3X,'file type is ',I2,': Old FPMD Numeric')") info - CASE (12) - WRITE( stdout,"(3X,'file type is ',I2,': Old FPMD Analytic')") info - CASE (20) - WRITE( stdout, "(3X,'file type is ',I2,': UPF')") info - END SELECT - END IF - CALL mp_bcast( info, ionode_id ) - IF (info == -1) CALL errore ('readpp', & - 'file '//TRIM(filename)//' not found',is) - - ! Now each processor read the pseudopotential file - - ierr = 0 - - OPEN( UNIT = pseudounit, FILE = filename, STATUS = 'OLD' ) - - ! - ! used only by obsolete Vanderbilt format with Herman-Skillman grid - ! - oldvan(is) = .false. - ! - IF( info == 20 ) THEN - ! - ! ... Pseudopotential form is UPF - ! - call read_upf(upf(is), rgrid(is), ierr, unit=pseudounit) - ! - IF ( ierr /= 0 ) THEN - CALL deallocate_pseudo_upf( upf(is) ) - ELSE - call set_pseudo_upf( is, upf( is ) ) - END IF - - ELSE IF( info == 1 ) THEN - - CALL readvan( pseudounit, is, upf(is) ) - CALL set_pseudo_upf( is, upf( is ), rgrid( is ) ) - - ELSE IF( info == 2 ) THEN - - CALL readrrkj( pseudounit, is, upf(is) ) - CALL set_pseudo_upf( is, upf( is ), rgrid( is ) ) - - ELSE IF( info == 11 ) THEN - - error_msg = ' type no more supported, convert to UPF using fpmd2upf ' - ierr = info - - ELSE IF( info == 12 ) THEN - - error_msg = ' type no more supported, convert to UPF using fpmd2upf ' - ierr = info - - ELSE IF( info == 0 ) THEN - - IF( program_name == 'FPMD' ) THEN - CALL errore(' readpp ', ' file format not supported ', 1 ) - ELSE - CALL errore(' readpp ', ' file format no longer supported ', 2 ) - END IF - - END IF - - CLOSE( pseudounit ) - - CALL mp_sum( ierr ) - IF( ierr /= 0 ) THEN - CALL errore(' readpseudo ', error_msg, ABS(ierr) ) - END IF - - ! ... Zv = valence charge of the (pseudo-)atom, read from PP files, - ! ... is set equal to Zp = pseudo-charge of the pseudopotential - ! (should be moved out from here) - - zv(is) = upf(is)%zp - - IF( program_name == 'FPMD' ) THEN - ! - IF( upf(is)%nbeta > 0 ) nspnl = nspnl + 1 - IF( upf(is)%tvanp ) nvb = nvb + 1 - IF( ionode ) THEN - CALL upf_info( upf(is) ) - END IF - ! - ELSE IF( program_name == 'CP90' ) THEN - ! - ! Ultrasoft formats: UPF, AdC, Vanderbilt ("old" and new) - ! norm-conserving formats: UPF - ! - ! check on input ordering: US first, NC later - ! - if(is > 1) then - if ( (.NOT. upf(is-1)%tvanp) .AND. upf(is)%tvanp ) then - call errore ('readpp', & - 'ultrasoft PPs must precede norm-conserving',is) - endif - endif - ! - ! count u-s vanderbilt species - ! - if (upf(is)%tvanp) nvb=nvb+1 - ! - END IF - ! - ! check for core corrections - ! - nlcc_any = nlcc_any .OR. upf(is)%nlcc - ! - if ( xc_type /= 'none' ) then - ! - ! DFT xc functional, given from input - ! - dft_name = TRIM( xc_type ) - CALL set_dft_from_name( dft_name ) - - WRITE( stdout, fmt="(/,3X,'Warning XC functionals forced to be: ',A)" ) dft_name - ! - else - ! - ! check for consistency of DFT - ! - if (is == 1) then - iexch_ = get_iexch() - icorr_ = get_icorr() - igcx_ = get_igcx() - igcc_ = get_igcc() - else - if ( iexch_ /= get_iexch() .or. icorr_ /= get_icorr() .or. & - igcx_ /= get_igcx() .or. igcc_ /= get_igcc() ) then - CALL errore( 'readpp','inconsistent DFT read',is) - end if - end if - end if - - IF ( dft_is_hybrid() ) & - CALL errore( 'readpp', 'HYBRID XC not implemented in CPV', 1 ) - - END DO - - IF( program_name == 'FPMD' ) THEN - CALL check_types_order() - END IF - - okvan = ( nvb > 0 ) - ! - RETURN - END SUBROUTINE readpp - -!=----------------------------------------------------------------------------=! - - SUBROUTINE compute_lloc( upf, lloc ) - ! Calculate lloc - USE pseudo_types, ONLY: pseudo_upf - IMPLICIT NONE - TYPE (pseudo_upf), INTENT(IN) :: upf - INTEGER :: lloc - INTEGER :: which_lloc( 0 : upf%nbeta ) - INTEGER :: l - ! - lloc = upf%nbeta - which_lloc = 0 - DO l = 1, upf%nbeta - which_lloc( upf%lll( l ) ) = 1 - END DO - ! - ! the first "l" which is not non-local - ! is taken as the "l" of the local part of the pseudo - ! - loop_l: DO l = 0, upf%nbeta - IF( which_lloc( l ) == 0 ) THEN - lloc = l - exit loop_l - END IF - END DO loop_l - ! - RETURN - END SUBROUTINE - -!=----------------------------------------------------------------------------=! - - SUBROUTINE upf_info( upf ) - USE pseudo_types, ONLY: pseudo_upf - USE io_global, ONLY: stdout - - TYPE (pseudo_upf), INTENT(IN) :: upf - INTEGER :: in1, in2, in3, in4, m, l, i - INTEGER :: lloc - - WRITE( stdout, * ) - - CALL compute_lloc( upf, lloc ) - - IF (upf%nbeta > 0) THEN - WRITE( stdout,10) upf%typ - WRITE( stdout,50) lloc - WRITE( stdout,60) (upf%lll(l),l=1,upf%nbeta) - ELSE -! ... A local pseudopotential has been read. - WRITE( stdout,11) upf%typ - WRITE( stdout,50) lloc - END IF - IF( upf%nlcc ) THEN - WRITE( stdout,12) - END IF - - 10 FORMAT( 3X,'Type is ',A10,' and NONLOCAL. ') - 107 FORMAT( 3X,'Mixed reference potential:') - 106 FORMAT( 3X,' L :',3(9X,i1)) - 105 FORMAT( 3X,' Weight:',3(2X,F8.5)) - 50 FORMAT( 3X,'Local component is ..... : ',I3) - 60 FORMAT( 3X,'Non local components are : ',4I3) - 11 FORMAT( 3X,'Type is ',A10,' and LOCAL. ') - 12 FORMAT( 3X,'Using non local core corcorrections for this pseudo') - 20 FORMAT( 3X,'Pseudo charge : ',F8.3) - - WRITE( stdout,20) upf%zp - - WRITE( stdout,131) upf%nbeta + 1, upf%mesh - in1=1 - in2=upf%mesh/4 - in3=upf%mesh/2 - in4=upf%mesh - WRITE( stdout,132) - WRITE( stdout,120) in1,upf%r(in1),upf%vloc(in1)/2.0,(upf%beta(in1,m)/2.0,m=1,upf%nbeta) - WRITE( stdout,120) in2,upf%r(in2),upf%vloc(in2)/2.0,(upf%beta(in2,m)/2.0,m=1,upf%nbeta) - WRITE( stdout,120) in3,upf%r(in3),upf%vloc(in3)/2.0,(upf%beta(in3,m)/2.0,m=1,upf%nbeta) - WRITE( stdout,120) in4,upf%r(in4),upf%vloc(in4)/2.0,(upf%beta(in4,m)/2.0,m=1,upf%nbeta) - 131 FORMAT(/, 3X,'Pseudopotentials Grid : Channels = ',I2,& - ', Mesh = ',I5,/,30X) - 132 FORMAT( 3X,'point radius vloc ( vnl - vloc )') - 120 FORMAT(I8,E14.6,5E14.6) - - - IF( upf%nwfc > 0 .AND. upf%mesh > 0 ) THEN - WRITE( stdout,141) upf%nwfc, upf%mesh - in1=1 - in2=upf%mesh/4 - in3=upf%mesh/2 - in4=upf%mesh - WRITE( stdout,145) (upf%oc(i),i=1,upf%nwfc) - WRITE( stdout,142) - WRITE( stdout,120) in1,upf%r(in1),(upf%chi(in1,m),m=1,upf%nwfc) - WRITE( stdout,120) in2,upf%r(in2),(upf%chi(in2,m),m=1,upf%nwfc) - WRITE( stdout,120) in3,upf%r(in3),(upf%chi(in3,m),m=1,upf%nwfc) - WRITE( stdout,120) in4,upf%r(in4),(upf%chi(in4,m),m=1,upf%nwfc) - END IF - - 141 FORMAT(/, 3X,'Atomic wavefunction Grid : Channels = ',I2,& - ', Mesh = ',I5,/,30X) - 142 FORMAT( 3X,'point radius wavefunction') - 145 FORMAT( 3X,'Channels occupation number : ',5F10.4) - - IF( upf%nlcc ) THEN - WRITE( stdout,151) upf%mesh - in1 = 1 - in2 = upf%mesh / 4 - in3 = upf%mesh / 2 - in4 = upf%mesh - WRITE( stdout,152) - WRITE( stdout,120) in1,upf%r(in1),upf%rho_atc(in1) - WRITE( stdout,120) in2,upf%r(in2),upf%rho_atc(in2) - WRITE( stdout,120) in3,upf%r(in3),upf%rho_atc(in3) - WRITE( stdout,120) in4,upf%r(in4),upf%rho_atc(in4) - END IF - - 151 FORMAT(/, 3X,'Core correction Grid : Mesh = ',I5) - 152 FORMAT( 3X,'point radius rho core') - - RETURN - END SUBROUTINE upf_info - - -!=----------------------------------------------------------------------------=! - END MODULE read_pseudo_module_fpmd -!=----------------------------------------------------------------------------=! -! diff --git a/quantum_espresso/kcp/CPV/restart.f90 b/quantum_espresso/kcp/CPV/restart.f90 deleted file mode 100644 index c9b11dbc5..000000000 --- a/quantum_espresso/kcp/CPV/restart.f90 +++ /dev/null @@ -1,764 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! written by Carlo Cavazzoni - -!----------------------------------------------------------------------- - - SUBROUTINE writefile_cp_real & - & (h, hold, nfi, c0, cm, taus, tausm, vels, velsm, acc, & - & lambda, lambdam, xnhe0, xnhem, vnhe, xnhp0, xnhpm, vnhp, nhpcl, nhpdim, ekincm,& - & xnhh0, xnhhm, vnhh, velh, fion, tps, mat_z, occ_f, rho) -!----------------------------------------------------------------------- -! -! read from file and distribute data calculated in preceding iterations -! - USE kinds, ONLY: DP - USE ions_base, ONLY: cdmi, taui - USE cell_base, ONLY: s_to_r - USE cp_restart, ONLY: cp_writefile - USE cp_interfaces, ONLY: set_evtot, set_eitot - USE electrons_base, ONLY: nspin, iupdwn, nupdwn - USE electrons_module, ONLY: ei, nupdwn_emp - USE io_files, ONLY: outdir - USE ensemble_dft, ONLY: tens, tsmear - USE mp, ONLY: mp_bcast - USE control_flags, ONLY: tksw, ndw, evc_restart -! - implicit none - integer, INTENT(IN) :: nfi - REAL(DP), INTENT(IN) :: h(3, 3), hold(3, 3) - complex(DP), INTENT(IN) :: c0(:, :), cm(:, :) - REAL(DP), INTENT(IN) :: tausm(:, :), taus(:, :), fion(:, :) - REAL(DP), INTENT(IN) :: vels(:, :), velsm(:, :) - REAL(DP), INTENT(IN) :: acc(:), lambda(:, :, :), lambdam(:, :, :) - REAL(DP), INTENT(IN) :: xnhe0, xnhem, vnhe, ekincm - REAL(DP), INTENT(IN) :: xnhp0(:), xnhpm(:), vnhp(:) - integer, INTENT(in) :: nhpcl, nhpdim - REAL(DP), INTENT(IN) :: xnhh0(3, 3), xnhhm(3, 3), vnhh(3, 3), velh(3, 3) - REAL(DP), INTENT(in) :: tps - REAL(DP), INTENT(in) :: rho(:, :) - REAL(DP), INTENT(in) :: occ_f(:) - REAL(DP), INTENT(in) :: mat_z(:, :, :) - - REAL(DP) :: ht(3, 3), htm(3, 3), htvel(3, 3), gvel(3, 3) - INTEGER :: nk = 1 - REAL(DP) :: xk(3, 1) = 0.0d0, wk(1) = 2.0d0 - COMPLEX(DP), ALLOCATABLE :: ctot(:, :) - REAL(DP), ALLOCATABLE :: eitot(:, :) - INTEGER :: nupdwn_tot(2), iupdwn_tot(2) - - write (6, *) "writefile_cp_real: this subroutine is not working in this implementation" !added:giovanni:debug - stop - if (ndw < 1) then - ! - ! Do not write restart file if the unit number - ! is negative, this is used mainly for benchmarks and tests - ! - return - ! - end if - - ht = TRANSPOSE(h) - htm = TRANSPOSE(hold) - htvel = TRANSPOSE(velh) - gvel = 0.0d0 - - nupdwn_tot = nupdwn + nupdwn_emp - iupdwn_tot(1) = iupdwn(1) - iupdwn_tot(2) = nupdwn_tot(1) + 1 !! NlN check if it's correct through all the routine - ! - ALLOCATE (eitot(nupdwn_tot(1), nspin)) - ! - CALL set_eitot(eitot) - ! - IF (tksw .or. evc_restart) THEN - ! - ALLOCATE (ctot(SIZE(c0, 1), nupdwn_tot(1)*nspin)) - ! - CALL set_evtot(c0, ctot, lambda, iupdwn_tot, nupdwn_tot) - ! - END IF - ! - ! Sincronize lambdas, whose replicas could diverge on - ! different processors - ! - IF (tens) THEN - ! - CALL cp_writefile(ndw, outdir, .TRUE., nfi, tps, acc, nk, xk, wk, & - ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, taui, cdmi, taus, & - vels, tausm, velsm, fion, vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ_f, & - occ_f, lambda, lambdam, xnhe0, xnhem, vnhe, ekincm, ei, & - rho, c0, cm, ctot, iupdwn, nupdwn, iupdwn, nupdwn, mat_z=mat_z) - ! - ELSE IF (tsmear) THEN - ! - CALL cp_writefile(ndw, outdir, .TRUE., nfi, tps, acc, nk, xk, wk, & - ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, taui, cdmi, taus, & - vels, tausm, velsm, fion, vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ_f, & - occ_f, lambda, lambdam, xnhe0, xnhem, vnhe, ekincm, eitot, & - rho, c0, cm, ctot, iupdwn, nupdwn, iupdwn_tot, nupdwn_tot, mat_z=mat_z) - ! - ELSE - ! - CALL cp_writefile(ndw, outdir, .TRUE., nfi, tps, acc, nk, xk, wk, & - ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, taui, cdmi, taus, & - vels, tausm, velsm, fion, vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ_f, & - occ_f, lambda, lambdam, xnhe0, xnhem, vnhe, ekincm, eitot, & - rho, c0, cm, ctot, iupdwn, nupdwn, iupdwn_tot, nupdwn_tot) - ! - END IF - - DEALLOCATE (eitot) - ! - IF (tksw .or. evc_restart) DEALLOCATE (ctot) - - return - end subroutine writefile_cp_real - - SUBROUTINE writefile_cp_twin & - & (h, hold, nfi, c0, cm, taus, tausm, vels, velsm, acc, & - & lambda, lambdam, lambda_bare, xnhe0, xnhem, vnhe, xnhp0, xnhpm, vnhp,& - & nhpcl, nhpdim, ekincm,& - & xnhh0, xnhhm, vnhh, velh, fion, tps, mat_z, occ_f, rho) -!----------------------------------------------------------------------- -! -! read from file and distribute data calculated in preceding iterations -! - USE kinds, ONLY: DP - USE ions_base, ONLY: cdmi, taui - USE cell_base, ONLY: s_to_r - USE cp_restart, ONLY: cp_writefile - USE cp_interfaces, ONLY: set_evtot, set_eitot - USE electrons_base, ONLY: nspin, iupdwn, nupdwn - USE electrons_module, ONLY: ei, nupdwn_emp - USE io_files, ONLY: outdir - USE ensemble_dft, ONLY: tens, tsmear - USE mp, ONLY: mp_bcast - USE control_flags, ONLY: tksw, ndw, evc_restart - USE electrons_module, ONLY: wfc_spreads - USE nksic, ONLY: do_orbdep - USE twin_types -! - implicit none - integer, INTENT(IN) :: nfi - REAL(DP), INTENT(IN) :: h(3, 3), hold(3, 3) - complex(DP), INTENT(IN) :: c0(:, :), cm(:, :) - REAL(DP), INTENT(IN) :: tausm(:, :), taus(:, :), fion(:, :) - REAL(DP), INTENT(IN) :: vels(:, :), velsm(:, :) - REAL(DP), INTENT(IN) :: acc(:) - TYPE(twin_matrix), dimension(:), INTENT(IN) :: lambda, lambdam, lambda_bare - REAL(DP), INTENT(IN) :: xnhe0, xnhem, vnhe, ekincm - REAL(DP), INTENT(IN) :: xnhp0(:), xnhpm(:), vnhp(:) - integer, INTENT(in) :: nhpcl, nhpdim - REAL(DP), INTENT(IN) :: xnhh0(3, 3), xnhhm(3, 3), vnhh(3, 3), velh(3, 3) - REAL(DP), INTENT(in) :: tps - REAL(DP), INTENT(in) :: rho(:, :) - REAL(DP), INTENT(in) :: occ_f(:) - TYPE(twin_matrix), dimension(:), INTENT(IN) :: mat_z - - REAL(DP) :: ht(3, 3), htm(3, 3), htvel(3, 3), gvel(3, 3) - INTEGER :: nk = 1 - REAL(DP) :: xk(3, 1) = 0.0d0, wk(1) = 2.0d0 - COMPLEX(DP), ALLOCATABLE :: ctot(:, :) - REAL(DP), ALLOCATABLE :: eitot(:, :) - INTEGER :: nupdwn_tot(2), iupdwn_tot(2) - - if (ndw < 1) then - ! - ! Do not write restart file if the unit number - ! is negative, this is used mainly for benchmarks and tests - ! - return - ! - end if - - ht = TRANSPOSE(h) - htm = TRANSPOSE(hold) - htvel = TRANSPOSE(velh) - gvel = 0.0d0 - - nupdwn_tot = nupdwn + nupdwn_emp - iupdwn_tot(1) = iupdwn(1) - iupdwn_tot(2) = nupdwn_tot(1) + 1 !! NlN check if it's correct through all the routine - ! - ALLOCATE (eitot(nupdwn_tot(1), nspin)) - ! - CALL set_eitot(eitot) - ! - IF (tksw .or. evc_restart) THEN - ! - ALLOCATE (ctot(SIZE(c0, 1), nupdwn_tot(1)*nspin)) - ! - CALL set_evtot(c0, ctot, lambda, iupdwn_tot, nupdwn_tot) - ! - END IF - ! - ! Sincronize lambdas, whose replicas could diverge on - ! different processors - ! - IF (do_orbdep) THEN !Sort wavefunctions with respect to spread !!added:giovanni - ! - IF (allocated(wfc_spreads)) THEN - ! - !call spread_sort(c0, ngw, nspin, nbsp, nudx, nupdwn, iupdwn, wfc_spreads) - ! - END IF - ! - END IF - - IF (tens) THEN - ! - CALL cp_writefile(ndw, outdir, .TRUE., nfi, tps, acc, nk, xk, wk, & - ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, taui, cdmi, taus, & - vels, tausm, velsm, fion, vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ_f, & - occ_f, lambda, lambdam, lambda_bare, xnhe0, xnhem, vnhe, ekincm, ei, & - rho, c0, cm, ctot, iupdwn, nupdwn, iupdwn, nupdwn, mat_z=mat_z) - ! - ELSE IF (tsmear) THEN - ! - CALL cp_writefile(ndw, outdir, .TRUE., nfi, tps, acc, nk, xk, wk, & - ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, taui, cdmi, taus, & - vels, tausm, velsm, fion, vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ_f, & - occ_f, lambda, lambdam, lambda_bare, xnhe0, xnhem, vnhe, ekincm, eitot, & - rho, c0, cm, ctot, iupdwn, nupdwn, iupdwn_tot, nupdwn_tot, mat_z=mat_z) - ! - ELSE - ! - CALL cp_writefile(ndw, outdir, .TRUE., nfi, tps, acc, nk, xk, wk, & - ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, taui, cdmi, taus, & - vels, tausm, velsm, fion, vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ_f, & - occ_f, lambda, lambdam, lambda_bare, xnhe0, xnhem, vnhe, ekincm, eitot, & - rho, c0, cm, ctot, iupdwn, nupdwn, iupdwn_tot, nupdwn_tot) - ! - END IF - - DEALLOCATE (eitot) - ! - IF (tksw .or. evc_restart) DEALLOCATE (ctot) - - return - end subroutine writefile_cp_twin - -!----------------------------------------------------------------------- - subroutine readfile_cp_real & - & (flag, h, hold, nfi, c0, cm, taus, tausm, vels, velsm, acc, & - & lambda, lambdam, xnhe0, xnhem, vnhe, xnhp0, xnhpm, vnhp, nhpcl, nhpdim, ekincm,& - & xnhh0, xnhhm, vnhh, velh,& - & fion, tps, mat_z, occ_f) -!----------------------------------------------------------------------- -! -! read from file and distribute data calculated in preceding iterations -! - USE kinds, ONLY: DP - USE io_files, ONLY: outdir - USE electrons_base, ONLY: nspin, keep_occ - USE ions_base, ONLY: cdmi, taui - USE cp_restart, ONLY: cp_readfile, cp_read_cell, cp_read_wfc - USE ensemble_dft, ONLY: tens, tsmear - USE autopilot, ONLY: event_step, event_index, max_event_step - USE cp_autopilot, ONLY: employ_rules - USE control_flags, ONLY: ndr -! - implicit none - INTEGER, INTENT(in) :: flag - integer :: nfi - REAL(DP) :: h(3, 3), hold(3, 3) - complex(DP) :: c0(:, :), cm(:, :) - REAL(DP) :: tausm(:, :), taus(:, :), fion(:, :) - REAL(DP) :: vels(:, :), velsm(:, :) - REAL(DP) :: acc(:), lambda(:, :, :), lambdam(:, :, :) - REAL(DP) :: xnhe0, xnhem, vnhe - REAL(DP) :: xnhp0(:), xnhpm(:), vnhp(:) - integer, INTENT(inout) :: nhpcl, nhpdim - REAL(DP) :: ekincm - REAL(DP) :: xnhh0(3, 3), xnhhm(3, 3), vnhh(3, 3), velh(3, 3) - REAL(DP), INTENT(OUT) :: tps - REAL(DP), INTENT(INOUT) :: mat_z(:, :, :), occ_f(:) - ! - REAL(DP) :: ht(3, 3), htm(3, 3), htvel(3, 3), gvel(3, 3) - integer :: nk = 1, ispin - REAL(DP) :: xk(3, 1) = 0.0d0, wk(1) = 2.0d0 - REAL(DP), ALLOCATABLE :: occ_(:) - REAL(DP) :: b1(3), b2(3), b3(3) - - IF (flag == -1) THEN - CALL cp_read_cell(ndr, outdir, .TRUE., ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh) - h = TRANSPOSE(ht) - hold = TRANSPOSE(htm) - velh = TRANSPOSE(htvel) - RETURN - ELSE IF (flag == 0) THEN - DO ispin = 1, nspin - CALL cp_read_wfc(ndr, outdir, 1, 1, ispin, nspin, c2=cm(:, :), tag='m') - END DO - RETURN - END IF - - ALLOCATE (occ_(SIZE(occ_f))) - - IF (tens) THEN - CALL cp_readfile(ndr, outdir, .TRUE., nfi, tps, acc, nk, xk, wk, & - ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, taui, cdmi, taus, & - vels, tausm, velsm, fion, vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ_, & - occ_, lambda, lambdam, b1, b2, b3, & - xnhe0, xnhem, vnhe, ekincm, c0, cm, mat_z=mat_z) - ELSE IF (tsmear) THEN - CALL cp_readfile(ndr, outdir, .TRUE., nfi, tps, acc, nk, xk, wk, & - ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, taui, cdmi, taus, & - vels, tausm, velsm, fion, vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ_, & - occ_, lambda, lambdam, b1, b2, b3, & - xnhe0, xnhem, vnhe, ekincm, c0, cm, mat_z=mat_z) - ELSE - CALL cp_readfile(ndr, outdir, .TRUE., nfi, tps, acc, nk, xk, wk, & - ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, taui, cdmi, taus, & - vels, tausm, velsm, fion, vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ_, & - occ_, lambda, lambdam, b1, b2, b3, & - xnhe0, xnhem, vnhe, ekincm, c0, cm) - END IF - ! AutoPilot (Dynamic Rules) Implementation - event_index = 1 - - do while (event_step(event_index) <= nfi) - ! Assuming that the remaining dynamic parm values are set correctly by reading - ! the the restart file. - ! if this is not true, employ rules as events are updated right here as: - call employ_rules() - event_index = event_index + 1 - if (event_index > max_event_step) then - CALL errore(' readfile ', ' maximum events exceeded for dynamic rules ', 1) - end if - end do - - IF (.NOT. keep_occ) THEN - occ_f(:) = occ_(:) - END IF - - DEALLOCATE (occ_) - - return - end subroutine readfile_cp_real - -!----------------------------------------------------------------------- - subroutine readfile_cp_twin & - & (flag, h, hold, nfi, c0, cm, taus, tausm, vels, velsm, acc, & - & lambda, lambdam, xnhe0, xnhem, vnhe, xnhp0, xnhpm, vnhp, nhpcl, nhpdim, ekincm,& - & xnhh0, xnhhm, vnhh, velh,& - & fion, tps, mat_z, occ_f) -!----------------------------------------------------------------------- -! -! read from file and distribute data calculated in preceding iterations -! - USE kinds, ONLY: DP - USE io_files, ONLY: outdir - USE electrons_base, ONLY: nspin, keep_occ - USE ions_base, ONLY: cdmi, taui - USE cp_restart, ONLY: cp_readfile, cp_read_cell, cp_read_wfc - USE ensemble_dft, ONLY: tens, tsmear - USE autopilot, ONLY: event_step, event_index, max_event_step - USE cp_autopilot, ONLY: employ_rules - USE control_flags, ONLY: ndr - USE twin_types -! - implicit none - INTEGER, INTENT(in) :: flag - integer :: nfi - REAL(DP) :: h(3, 3), hold(3, 3) - complex(DP) :: c0(:, :), cm(:, :) - REAL(DP) :: tausm(:, :), taus(:, :), fion(:, :) - REAL(DP) :: vels(:, :), velsm(:, :) - REAL(DP) :: acc(:) - TYPE(twin_matrix), DIMENSION(:) :: lambda, lambdam - REAL(DP) :: xnhe0, xnhem, vnhe - REAL(DP) :: xnhp0(:), xnhpm(:), vnhp(:) - integer, INTENT(inout) :: nhpcl, nhpdim - REAL(DP) :: ekincm - REAL(DP) :: xnhh0(3, 3), xnhhm(3, 3), vnhh(3, 3), velh(3, 3) - REAL(DP), INTENT(OUT) :: tps - REAL(DP), INTENT(INOUT) :: occ_f(:) - TYPE(twin_matrix), DIMENSION(:) :: mat_z - ! - REAL(DP) :: ht(3, 3), htm(3, 3), htvel(3, 3), gvel(3, 3) - integer :: nk = 1, ispin - REAL(DP) :: xk(3, 1) = 0.0d0, wk(1) = 2.0d0 - REAL(DP), ALLOCATABLE :: occ_(:) - REAL(DP) :: b1(3), b2(3), b3(3) - - IF (flag == -1) THEN - CALL cp_read_cell(ndr, outdir, .TRUE., ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh) - h = TRANSPOSE(ht) - hold = TRANSPOSE(htm) - velh = TRANSPOSE(htvel) - RETURN - ELSE IF (flag == 0) THEN - DO ispin = 1, nspin - CALL cp_read_wfc(ndr, outdir, 1, 1, ispin, nspin, c2=cm(:, :), tag='m') - END DO - RETURN - END IF - - ALLOCATE (occ_(SIZE(occ_f))) - - IF (tens) THEN - CALL cp_readfile(ndr, outdir, .TRUE., nfi, tps, acc, nk, xk, wk, & - ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, taui, cdmi, taus, & - vels, tausm, velsm, fion, vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ_, & - occ_, lambda, lambdam, b1, b2, b3, & - xnhe0, xnhem, vnhe, ekincm, c0, cm, mat_z=mat_z) - ELSE IF (tsmear) THEN - CALL cp_readfile(ndr, outdir, .TRUE., nfi, tps, acc, nk, xk, wk, & - ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, taui, cdmi, taus, & - vels, tausm, velsm, fion, vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ_, & - occ_, lambda, lambdam, b1, b2, b3, & - xnhe0, xnhem, vnhe, ekincm, c0, cm, mat_z=mat_z) - ELSE - CALL cp_readfile(ndr, outdir, .TRUE., nfi, tps, acc, nk, xk, wk, & - ht, htm, htvel, gvel, xnhh0, xnhhm, vnhh, taui, cdmi, taus, & - vels, tausm, velsm, fion, vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ_, & - occ_, lambda, lambdam, b1, b2, b3, & - xnhe0, xnhem, vnhe, ekincm, c0, cm) - END IF - - ! AutoPilot (Dynamic Rules) Implementation - event_index = 1 - - do while (event_step(event_index) <= nfi) - ! Assuming that the remaining dynamic parm values are set correctly by reading - ! the the restart file. - ! if this is not true, employ rules as events are updated right here as: - call employ_rules() - event_index = event_index + 1 - if (event_index > max_event_step) then - CALL errore(' readfile ', ' maximum events exceeded for dynamic rules ', 1) - end if - end do - - IF (.NOT. keep_occ) THEN - occ_f(:) = occ_(:) - END IF - - DEALLOCATE (occ_) - - return - end subroutine readfile_cp_twin - -!=----------------------------------------------------------------------------=! - - SUBROUTINE writefile_fpmd & - (nfi, trutime, c0, cm, occ, atoms_0, atoms_m, acc, taui, cdmi, ht_m, & - ht_0, rho, lambda, tlast) - - USE kinds, ONLY: DP - USE cell_base, ONLY: boxdimensions, r_to_s - USE control_flags, ONLY: ndw - USE control_flags, ONLY: tksw, evc_restart - USE atoms_type_module, ONLY: atoms_type - USE electrons_nose, ONLY: xnhe0, xnhem, vnhe - USE electrons_base, ONLY: nspin, iupdwn, nupdwn - USE cell_nose, ONLY: xnhh0, xnhhm, vnhh - USE ions_nose, ONLY: vnhp, xnhp0, xnhpm, nhpcl, nhpdim - USE cp_restart, ONLY: cp_writefile - USE electrons_module, ONLY: nupdwn_emp - USE io_files, ONLY: outdir - USE cp_interfaces, ONLY: set_evtot, set_eitot - USE kohn_sham_states, ONLY: print_all_states - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nfi - COMPLEX(DP), INTENT(IN) :: c0(:, :), cm(:, :) - REAL(DP), INTENT(IN) :: occ(:) - TYPE(boxdimensions), INTENT(IN) :: ht_m, ht_0 - TYPE(atoms_type), INTENT(IN) :: atoms_0, atoms_m - REAL(DP), INTENT(IN) :: rho(:, :) - REAL(DP), INTENT(IN) :: taui(:, :) - REAL(DP), INTENT(IN) :: acc(:), cdmi(:) - REAL(DP), INTENT(IN) :: trutime - REAL(DP), INTENT(IN) :: lambda(:, :, :) - LOGICAL, INTENT(IN) :: tlast - - REAL(DP) :: ekincm - COMPLEX(DP), ALLOCATABLE :: ctot(:, :) - REAL(DP), ALLOCATABLE :: eitot(:, :) - INTEGER :: nupdwn_tot(2), iupdwn_tot(2) - - INTEGER :: nkpt = 1 - REAL(DP) :: xk(3, 1) = 0.0d0, wk(1) = 2.0d0 - - IF (ndw < 1) RETURN - ! - ! this is used for benchmarking and debug - ! if ndw < 1 Do not save wave functions and other system - ! properties on the writefile subroutine - - ekincm = 0.0d0 - ! - nupdwn_tot = nupdwn + nupdwn_emp - iupdwn_tot(1) = iupdwn(1) -! iupdwn_tot(2) = nupdwn(1) + 1 - iupdwn_tot(2) = nupdwn_tot(1) + 1 !! NlN check if it's correct through all the routine - ! - ALLOCATE (eitot(nupdwn_tot(1), nspin)) - ! - CALL set_eitot(eitot) - - IF (tksw .or. evc_restart) THEN - ! - ALLOCATE (ctot(SIZE(c0, 1), nupdwn_tot(1)*nspin)) - ! - CALL set_evtot(c0, ctot, lambda, iupdwn_tot, nupdwn_tot) - ! - IF (tlast) CALL print_all_states(ctot, iupdwn_tot, nupdwn_tot) - ! - END IF - ! - CALL cp_writefile(ndw, outdir, .TRUE., nfi, trutime, acc, nkpt, xk, wk, & - ht_0%a, ht_m%a, ht_0%hvel, ht_0%gvel, xnhh0, xnhhm, vnhh, taui, cdmi, & - atoms_0%taus, atoms_0%vels, atoms_m%taus, atoms_m%vels, atoms_0%for, & - vnhp, xnhp0, xnhpm, nhpcl, nhpdim, occ, occ, lambda, lambda, & - xnhe0, xnhem, vnhe, ekincm, eitot, rho, c0, cm, ctot, iupdwn, nupdwn, & - iupdwn_tot, nupdwn_tot) - - DEALLOCATE (eitot) - - IF (tksw .or. evc_restart) DEALLOCATE (ctot) - - RETURN - END SUBROUTINE writefile_fpmd - -!=----------------------------------------------------------------------------=! - -!------------------------------------------------------------------------------! - SUBROUTINE set_eitot_x(eitot) -!------------------------------------------------------------------------------! - USE kinds, ONLY: DP - USE electrons_base, ONLY: nupdwn, nspin - USE electrons_module, ONLY: nupdwn_emp, ei, ei_emp, nbsp_emp - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(OUT) :: eitot(:, :) - ! - INTEGER :: n - ! - eitot = 0.0d0 - ! - eitot(1:nupdwn(1), 1) = ei(1:nupdwn(1), 1) - IF (nspin == 2) eitot(1:nupdwn(2), 2) = ei(1:nupdwn(2), 2) - ! - IF (nbsp_emp > 0) THEN - ! - n = nupdwn(1) - eitot(n + 1:n + nupdwn_emp(1), 1) = ei_emp(1:nupdwn_emp(1), 1) - IF (nspin == 2) THEN - n = nupdwn(2) - eitot(n + 1:n + nupdwn_emp(2), 2) = ei_emp(1:nupdwn_emp(2), 2) - END IF - ! - END IF - ! - RETURN - END SUBROUTINE set_eitot_x - -!------------------------------------------------------------------------------! - SUBROUTINE set_evtot_real_x(c0, ctot, lambda, iupdwn_tot, nupdwn_tot) -!------------------------------------------------------------------------------! - USE kinds, ONLY: DP - USE electrons_base, ONLY: nupdwn, nspin, iupdwn, nudx - USE electrons_module, ONLY: nupdwn_emp, nbsp_emp, nbspx_emp, iupdwn_emp - USE cp_interfaces, ONLY: readempty, crot, readempty_twin - USE cp_main_variables, ONLY: collect_lambda, descla - USE control_flags, ONLY: ndw - USE input_parameters, ONLY: print_evc0_occ_empty - USE wavefunctions_module, ONLY: c0_occ_emp_aux - ! - IMPLICIT NONE - ! - COMPLEX(DP), INTENT(IN) :: c0(:, :) - COMPLEX(DP), INTENT(OUT) :: ctot(:, :) - REAL(DP), INTENT(IN) :: lambda(:, :, :) - INTEGER, INTENT(IN) :: iupdwn_tot(2), nupdwn_tot(2) - ! - COMPLEX(DP), ALLOCATABLE :: cemp(:, :) - REAL(DP), ALLOCATABLE :: eitmp(:) - REAL(DP), ALLOCATABLE :: lambda_repl(:, :) - LOGICAL :: t_emp - ! - ALLOCATE (eitmp(nudx)) - ALLOCATE (lambda_repl(nudx, nudx)) - ! - ctot = 0.0d0 - ! - CALL collect_lambda(lambda_repl, lambda(:, :, 1), descla(:, 1)) - ! - CALL crot(ctot, c0, SIZE(c0, 1), nupdwn(1), iupdwn_tot(1), iupdwn(1), lambda_repl, nudx, eitmp) - ! - IF (nspin == 2) THEN - CALL collect_lambda(lambda_repl, lambda(:, :, 2), descla(:, 2)) - CALL crot(ctot, c0, SIZE(c0, 1), nupdwn(2), iupdwn_tot(2), iupdwn(2), lambda_repl, nudx, eitmp) - END IF - ! - DEALLOCATE (lambda_repl) - ! - t_emp = .FALSE. - ! - IF (nbsp_emp > 0) THEN - ! - ALLOCATE (cemp(SIZE(c0, 1), nbspx_emp)) - cemp = 0.0d0 - t_emp = readempty(cemp, nbspx_emp, ndw) - ! - END IF - ! - IF (t_emp) THEN - ctot(:, nupdwn(1) + 1:nupdwn_tot(1)) = cemp(:, 1:nupdwn_emp(1)) - IF (nspin == 2) THEN - ctot(:, iupdwn_tot(2) + nupdwn(2):iupdwn_tot(2) + nupdwn_tot(1) - 1) = & - cemp(:, iupdwn_emp(2):iupdwn_emp(2) + nupdwn_emp(2) - 1) - END IF - END IF - ! - IF (nbsp_emp > 0) DEALLOCATE (cemp) - ! - ! print evc0 of occ and empty in xml_io format - ! - IF (print_evc0_occ_empty .and. (nbsp_emp > 0)) THEN - ! - ALLOCATE (c0_occ_emp_aux(SIZE(c0, 1), nupdwn_tot(1)*nspin)) - ! - t_emp = .FALSE. - ! - ALLOCATE (cemp(SIZE(c0, 1), nbspx_emp)) - cemp = 0.0d0 - t_emp = readempty_twin(cemp, nbspx_emp, ndw) - ! - IF (t_emp) THEN - c0_occ_emp_aux(:, iupdwn_tot(1):nupdwn(1)) = c0(:, iupdwn(1):nupdwn(1)) - c0_occ_emp_aux(:, nupdwn(1) + 1:nupdwn_tot(1)) = cemp(:, 1:nupdwn_emp(1)) - IF (nspin == 2) THEN - c0_occ_emp_aux(:, iupdwn_tot(2):iupdwn_tot(2) + nupdwn(2) - 1) = c0(:, iupdwn(2):iupdwn(2) + nupdwn(2) - 1) - c0_occ_emp_aux(:, iupdwn_tot(2) + nupdwn(2):iupdwn_tot(2) + nupdwn_tot(2) - 1) = & - cemp(:, iupdwn_emp(2):iupdwn_emp(2) + nupdwn_emp(2) - 1) - END IF - END IF - ! - DEALLOCATE (cemp) - END IF - ! - DEALLOCATE (eitmp) - ! - RETURN - - END SUBROUTINE set_evtot_real_x - -!------------------------------------------------------------------------------! - SUBROUTINE set_evtot_twin_x(c0, ctot, lambda, iupdwn_tot, nupdwn_tot) -!------------------------------------------------------------------------------! - USE kinds, ONLY: DP - USE electrons_base, ONLY: nupdwn, nspin, iupdwn, nudx - USE electrons_module, ONLY: nupdwn_emp, nbsp_emp, nbspx_emp, iupdwn_emp - USE cp_interfaces, ONLY: readempty, crot, readempty_twin - USE cp_main_variables, ONLY: collect_lambda, descla - USE control_flags, ONLY: ndw - USE input_parameters, ONLY: print_evc0_occ_empty - USE wavefunctions_module, ONLY: c0_occ_emp_aux - USE twin_types - ! - IMPLICIT NONE - ! - COMPLEX(DP), INTENT(IN) :: c0(:, :) - COMPLEX(DP), INTENT(OUT) :: ctot(:, :) - TYPE(twin_matrix), dimension(:) :: lambda - INTEGER, INTENT(IN) :: iupdwn_tot(2), nupdwn_tot(2) - ! - COMPLEX(DP), ALLOCATABLE :: cemp(:, :) - REAL(DP), ALLOCATABLE :: eitmp(:) - REAL(DP), ALLOCATABLE :: lambda_repl(:, :) - COMPLEX(DP), ALLOCATABLE :: lambda_repl_c(:, :) - LOGICAL :: t_emp - ! - ALLOCATE (eitmp(nudx)) - ! - ctot = 0.0d0 - ! - IF (.not. lambda(1)%iscmplx) THEN - ALLOCATE (lambda_repl(nudx, nudx)) - CALL collect_lambda(lambda_repl, lambda(1)%rvec(:, :), descla(:, 1)) - CALL crot(ctot, c0, SIZE(c0, 1), nupdwn(1), iupdwn_tot(1), iupdwn(1), lambda_repl, nudx, eitmp) - ELSE - ALLOCATE (lambda_repl_c(nudx, nudx)) - CALL collect_lambda(lambda_repl_c, lambda(1)%cvec(:, :), descla(:, 1)) - CALL crot(ctot, c0, SIZE(c0, 1), nupdwn(1), iupdwn_tot(1), iupdwn(1), lambda_repl_c, nudx, eitmp) - END IF - ! - IF (nspin == 2) THEN - IF (.not. lambda(1)%iscmplx) THEN - CALL collect_lambda(lambda_repl, lambda(2)%rvec(:, :), descla(:, 2)) - CALL crot(ctot, c0, SIZE(c0, 1), nupdwn(2), iupdwn_tot(2), iupdwn(2), lambda_repl, nudx, eitmp) - ELSE - CALL collect_lambda(lambda_repl_c, lambda(2)%cvec(:, :), descla(:, 2)) - CALL crot(ctot, c0, SIZE(c0, 1), nupdwn(2), iupdwn_tot(2), iupdwn(2), lambda_repl_c, nudx, eitmp) - END IF - END IF - ! - IF (.not. lambda(1)%iscmplx) THEN - DEALLOCATE (lambda_repl) - ELSE - DEALLOCATE (lambda_repl_c) - END IF - ! - t_emp = .FALSE. - ! - IF (nbsp_emp > 0) THEN - ! - ALLOCATE (cemp(SIZE(c0, 1), nbspx_emp)) - cemp = 0.0d0 - t_emp = readempty(cemp, nbspx_emp, ndw) - ! - END IF - ! - IF (t_emp) THEN - ctot(:, nupdwn(1) + 1:nupdwn_tot(1)) = cemp(:, 1:nupdwn_emp(1)) - IF (nspin == 2) THEN - ctot(:, iupdwn_tot(2) + nupdwn(2):iupdwn_tot(2) + nupdwn_tot(1) - 1) = & - cemp(:, iupdwn_emp(2):iupdwn_emp(2) + nupdwn_emp(2) - 1) - END IF - END IF - ! - IF (nbsp_emp > 0) DEALLOCATE (cemp) - ! - DEALLOCATE (eitmp) - ! - ! print evc0 of occ and empty in xml_io format - ! - IF (print_evc0_occ_empty .and. (nbsp_emp > 0)) THEN - ! - ALLOCATE (c0_occ_emp_aux(SIZE(c0, 1), nupdwn_tot(1)*nspin)) - ! - t_emp = .FALSE. - ! - ALLOCATE (cemp(SIZE(c0, 1), nbspx_emp)) - cemp = 0.0d0 - t_emp = readempty_twin(cemp, nbspx_emp, ndw) - ! - IF (t_emp) THEN - c0_occ_emp_aux(:, iupdwn_tot(1):nupdwn(1)) = c0(:, iupdwn(1):nupdwn(1)) - c0_occ_emp_aux(:, nupdwn(1) + 1:nupdwn_tot(1)) = cemp(:, 1:nupdwn_emp(1)) - IF (nspin == 2) THEN - c0_occ_emp_aux(:, iupdwn_tot(2):iupdwn_tot(2) + nupdwn(2) - 1) = c0(:, iupdwn(2):iupdwn(2) + nupdwn(2) - 1) - c0_occ_emp_aux(:, iupdwn_tot(2) + nupdwn(2):iupdwn_tot(2) + nupdwn_tot(2) - 1) = & - cemp(:, iupdwn_emp(2):iupdwn_emp(2) + nupdwn_emp(2) - 1) - END IF - END IF - ! - DEALLOCATE (cemp) - ! - END IF - ! - RETURN - - END SUBROUTINE set_evtot_twin_x diff --git a/quantum_espresso/kcp/CPV/restart_sub.f90 b/quantum_espresso/kcp/CPV/restart_sub.f90 deleted file mode 100644 index c8a229a69..000000000 --- a/quantum_espresso/kcp/CPV/restart_sub.f90 +++ /dev/null @@ -1,262 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -SUBROUTINE from_restart( ) - ! - USE kinds, ONLY : DP - USE control_flags, ONLY : program_name, tbeg, taurdr, tfor, tsdp, tv0rd, & - iprsta, tsde, tzeroe, tzerop, nbeg, tranp, amprp, & - tzeroc, force_pairing, ampre, trane, tpre, dt_old, & - iprint_manifold_overlap !added:giovanni iprint_manifold_overlap - USE wavefunctions_module, ONLY : c0, cm, cstart - USE electrons_module, ONLY : occn_info - USE electrons_base, ONLY : iupdwn, nupdwn, f, nbsp, nbspx - USE io_global, ONLY : ionode, stdout - USE cell_base, ONLY : ainv, h, hold, deth, r_to_s, s_to_r, boxdimensions, & - velh, a1, a2, a3 - USE ions_base, ONLY : na, nsp, iforce, vel_srt, nat, randpos - USE time_step, ONLY : tps, delt - USE ions_positions, ONLY : taus, tau0, tausm, taum, vels, fion, set_velocities - USE ions_nose, ONLY : xnhp0, xnhpm - USE grid_dimensions, ONLY : nr1, nr2, nr3 - USE reciprocal_vectors, ONLY : mill_l - USE printout_base, ONLY : printout_pos - USE gvecs, ONLY : ngs - USE gvecw, ONLY : ngw - USE cp_interfaces, ONLY : phfacs, strucf - USE energies, ONLY : eself, dft_energy_type - USE wave_base, ONLY : rande_base - USE efield_module, ONLY : efield_berry_setup, tefield, & - efield_berry_setup2, tefield2 - USE small_box, ONLY : ainvb - USE uspp, ONLY : okvan, vkb, nkb - USE core, ONLY : nlcc_any - USE cp_main_variables, ONLY : ht0, htm, lambdap, lambda, lambdam, ei1, ei2, ei3, eigr, & - sfac, bec, taub, irb, eigrb, edft, becstart - USE cdvan, ONLY : dbec - USE time_step, ONLY : delt - USE atoms_type_module, ONLY : atoms_type - USE twin_types - ! - IMPLICIT NONE - ! - ! ... We are restarting from file recompute ainv - ! - CALL invmat( 3, h, ainv, deth ) - ! - ! ... Reset total time counter if the run is not strictly 'restart' - ! - IF ( nbeg < 1 ) tps = 0.D0 - ! - IF ( taurdr ) THEN - ! - ! ... Input positions read from input file and stored in tau0 - ! ... in readfile, only scaled positions are read - ! - CALL r_to_s( tau0, taus, na, nsp, ainv ) - ! - END IF - ! - IF ( ANY( tranp(1:nsp) ) ) THEN - ! - ! ... Input positions are randomized - ! - CALL randpos( taus, na, nsp, tranp, amprp, ainv, iforce ) - ! - END IF - ! - IF ( tzerop .AND. tfor ) THEN - ! - CALL r_to_s( vel_srt, vels, na, nsp, ainv ) - ! - CALL set_velocities( tausm, taus, vels, iforce, nat, delt ) - ! - END IF - ! - CALL s_to_r( taus, tau0, na, nsp, h ) - ! - CALL s_to_r( tausm, taum, na, nsp, h ) - ! - IF ( tzeroc ) THEN - ! - hold = h - velh = 0.D0 - ! - htm = ht0 - ht0%hvel = 0.D0 - ! - END IF - ! - fion = 0.D0 - ! - IF( force_pairing ) THEN - cm(:,iupdwn(2):nbsp) = cm(:,1:nupdwn(2)) - c0(:,iupdwn(2):nbsp) = c0(:,1:nupdwn(2)) - IF(.not.lambda(1)%iscmplx) THEN - lambdap(2)%rvec( :, :) = lambdap(1)%rvec( :, :) - lambda(2)%rvec( :, :) = lambda(1)%rvec( :, :) - lambdam(2)%rvec( :, :) = lambdam(1)%rvec( :, :) - ELSE - lambdap(2)%cvec( :, :) = lambdap(1)%cvec( :, :) - lambda(2)%cvec( :, :) = lambda(1)%cvec( :, :) - lambdam(2)%cvec( :, :) = lambda(1)%cvec( :, :) - ENDIF - END IF - ! - IF ( tzeroe ) THEN - ! - lambdam = lambda - ! - cm = c0 - ! - WRITE( stdout, '(" Electronic velocities set to zero")' ) - ! - END IF - ! - IF( program_name == "FPMD" ) THEN - ! - CALL occn_info( f ) - ! - ! ... diagnostics - ! - IF ( ionode ) THEN - ! - WRITE( stdout, 100 ) - ! - IF ( .NOT. tbeg ) THEN - WRITE( stdout, 110 ) - ELSE - WRITE( stdout, 120 ) - END IF - ! - IF ( .NOT. taurdr ) THEN - WRITE( stdout, 130 ) - ELSE - WRITE( stdout, 140 ) - END IF - ! - IF ( tfor .AND. ( .NOT. tsdp ) ) THEN - ! - IF ( .NOT. tv0rd ) THEN - ! - IF ( .NOT. tzerop ) THEN - WRITE( stdout, 150 ) - ELSE - WRITE( stdout, 155 ) - END IF - ! - ELSE - ! - WRITE( stdout, 160 ) - ! - END IF - ! - END IF - ! - IF ( iprsta > 1 ) & - CALL printout_pos( stdout, taus, nat, head = 'Scaled positions from restart module' ) - ! - IF ( .NOT. tsde ) THEN - ! - IF ( .NOT. tzeroe ) THEN - WRITE( stdout, 170 ) - ELSE - WRITE( stdout, 180 ) - END IF - ! - END IF - ! - WRITE( stdout, * ) - ! - END IF - ! - END IF - ! - ! ... computes form factors and initializes nl-pseudop. according - ! ... to starting cell (from ndr or again standard input) - ! - IF ( okvan .or. nlcc_any ) THEN - CALL initbox( tau0, taub, irb, ainv, a1, a2, a3 ) - CALL phbox( taub, eigrb, ainvb ) - END IF - ! - CALL phfacs( ei1, ei2, ei3, eigr, mill_l, taus, nr1, nr2, nr3, nat ) - ! - CALL strucf( sfac, ei1, ei2, ei3, mill_l, ngs ) - ! - CALL prefor( eigr, vkb ) - ! - CALL formf( .TRUE. , eself ) - ! - IF ( trane ) THEN - ! - WRITE( stdout, 515 ) ampre - ! -515 FORMAT( 3X,'Initial random displacement of el. coordinates',/ & - 3X,'Amplitude = ',F10.6 ) - ! - CALL rande_base( c0, ampre ) - - CALL gram( vkb, bec, nkb, c0, ngw, nbsp ) - ! - IF( force_pairing ) c0(:,iupdwn(2):nbsp) = c0(:,1:nupdwn(2)) - ! - cm = c0 - ! - END IF - ! - CALL calbec( 1, nsp, eigr, c0, bec ) - ! - IF ( tpre ) CALL caldbec( ngw, nkb, nbsp, 1, nsp, eigr, c0, dbec ) - ! - IF ( tefield ) CALL efield_berry_setup( eigr, tau0 ) - IF ( tefield2 ) CALL efield_berry_setup2( eigr, tau0 ) - ! - edft%eself = eself - ! - IF( tzerop .or. tzeroe .or. tzeroc ) THEN - IF( .not. ( tzerop .and. tzeroe .and. tzeroc ) ) THEN - IF( ionode ) THEN - WRITE( stdout, * ) 'WARNING setting to ZERO ions, electrons and cell velocities without ' - WRITE( stdout, * ) 'setting to ZERO all velocities could generate meaningles trajectories ' - END IF - END IF - END IF - ! - ! - ! dt_old should be -1.0 here if untouched ... - ! - if ( dt_old > 0.0d0 ) then - tausm = taus - (taus-tausm)*delt/dt_old - xnhpm = xnhp0 - (xnhp0-xnhpm)*delt/dt_old - WRITE( stdout, '(" tausm & xnhpm were rescaled ")' ) - endif - ! - IF(iprint_manifold_overlap>0) THEN !added:giovanni - ! - cstart(1:ngw,1:nbspx) = c0(1:ngw,1:nbspx) - call copy_twin(becstart, bec) - ! - ENDIF - ! - RETURN - ! -100 FORMAT( /,3X,'MD PARAMETERS READ FROM RESTART FILE',/ & - ,3X,'------------------------------------' ) -110 FORMAT( 3X,'Cell variables From RESTART file' ) -120 FORMAT( 3X,'Cell variables From INPUT file' ) -130 FORMAT( 3X,'Ions positions From RESTART file' ) -140 FORMAT( 3X,'Ions positions From INPUT file' ) -150 FORMAT( 3X,'Ions Velocities From RESTART file' ) -155 FORMAT( 3X,'Ions Velocities set to ZERO' ) -160 FORMAT( 3X,'Ions Velocities From STANDARD INPUT' ) -170 FORMAT( 3X,'Electronic Velocities From RESTART file' ) -180 FORMAT( 3X,'Electronic Velocities set to ZERO' ) - ! -END SUBROUTINE from_restart diff --git a/quantum_espresso/kcp/CPV/runcp.f90 b/quantum_espresso/kcp/CPV/runcp.f90 deleted file mode 100644 index 64e7b7988..000000000 --- a/quantum_espresso/kcp/CPV/runcp.f90 +++ /dev/null @@ -1,627 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -! Written and Revised by Carlo Cavazzoni - -!=----------------------------------------------------------------------------------=! - - SUBROUTINE runcp_uspp_x & - ( nfi, fccc, ccc, ema0bg, dt2bye, rhos, bec, c0, cm, fromscra, restart, tprint_ham ) - ! - ! This subroutine performs a Car-Parrinello or Steepest-Descent step - ! on the electronic variables, computing forces on electrons - ! - ! on input: - ! c0 wave functions at time t - ! cm wave functions at time t - dt - ! - ! on output: - ! cm wave functions at time t + dt, not yet othogonalized - ! - USE parallel_include - USE kinds, ONLY : DP - USE mp_global, ONLY : nogrp - USE mp, ONLY : mp_sum - USE fft_base, ONLY : dffts - use wave_base, only : wave_steepest, wave_verlet - use control_flags, only : lwf, tsde, use_task_groups, & - gamma_only, do_wf_cmplx !added:giovanni do_wf_cmplx - use uspp, only : deeq, vkb - use reciprocal_vectors, only : gstart - use electrons_base, only : n=>nbsp, ispin, f, nspin, nupdwn, iupdwn - USE electrons_base, ONLY: nx=>nbspx - use wannier_subroutines, only : ef_potential - use efield_module, only : dforce_efield, tefield, dforce_efield2, tefield2 - use gvecw, only : ngw, ngwx - USE cp_main_variables, ONLY : hamilt - USE cp_interfaces, ONLY : dforce - USE task_groups, ONLY : tg_gather - USE ldaU, ONLY : vupsi, lda_plus_u - use hfmod, only : do_hf, vxxpsi - use nksic, only : do_orbdep, vsic, vsicpsi, deeq_sic, & - f_cutoff, valpsi - use ensemble_dft, only : tens, tsmear - use twin_types !added:giovanni - use input_parameters, only : odd_nkscalfact - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nfi - REAL(DP) :: fccc, ccc - REAL(DP) :: ema0bg(:), dt2bye - REAL(DP) :: rhos(:,:) - type(twin_matrix) :: bec!(:,:) !modified:giovanni - COMPLEX(DP) :: c0(:,:), cm(:,:) - LOGICAL, OPTIONAL, INTENT(IN) :: fromscra - LOGICAL, OPTIONAL, INTENT(IN) :: restart - LOGICAL, OPTIONAL, INTENT(IN) :: tprint_ham - ! - ! - real(DP) :: verl1, verl2, verl3 - real(DP), allocatable :: emadt2(:) - real(DP), allocatable :: emaver(:) - real(DP), allocatable :: faux(:) - complex(DP), allocatable :: c2(:), c3(:) - REAL(DP), ALLOCATABLE :: tg_rhos(:,:) - integer :: incr, idx, idx_in - integer :: tg_rhos_siz, c2_siz - integer :: isp, j, jj, j0, i, ii, i0 - integer :: iflag - logical :: ttsde - LOGICAL :: tprint_ham_ - LOGICAL :: lgam - integer :: iss - - lgam=gamma_only.and..not.do_wf_cmplx - - allocate(faux(nx)) - - iflag = 0 - ! - IF( PRESENT( fromscra ) ) THEN - IF( fromscra ) iflag = 1 - ENDIF - ! - IF( PRESENT( restart ) ) THEN - IF( restart ) iflag = 2 - ENDIF - ! - tprint_ham_ = .FALSE. - - DO iss=1,size(hamilt) - if(.not. hamilt(iss)%iscmplx) then - hamilt(iss)%rvec = 0.0d0 - else - hamilt(iss)%cvec = CMPLX(0.0d0,0.d0) - endif - END DO - - IF ( PRESENT( tprint_ham ) ) THEN - ! - tprint_ham_ = tprint_ham - ENDIF - ! - IF( use_task_groups ) THEN - tg_rhos_siz = nogrp * dffts%nnrx - c2_siz = nogrp * ngwx - ELSE - tg_rhos_siz = 1 - c2_siz = ngw - ENDIF - - ! - ! ... set verlet variables - ! - verl1 = 2.0d0 * fccc - verl2 = 1.0d0 - verl1 - verl3 = 1.0d0 * fccc - ALLOCATE( emadt2( ngw ) ) - ALLOCATE( emaver( ngw ) ) - - ccc = fccc * dt2bye - emadt2 = dt2bye * ema0bg - emaver = emadt2 * verl3 - - IF( iflag == 0 ) THEN - ttsde = tsde - ELSE IF( iflag == 1 ) THEN - ttsde = .TRUE. - ELSE IF( iflag == 2 ) THEN - ttsde = .FALSE. - END IF - - IF( lwf ) THEN - - call ef_potential( nfi, rhos, bec%rvec, deeq, vkb, c0, cm, emadt2, emaver, verl1, verl2 ) !warning:giovanni not yet modified - - ELSE - - allocate( c2( c2_siz ), c3( c2_siz ) ) - allocate( tg_rhos( tg_rhos_siz, nspin ) ) - ! - c2 = 0D0 - c3 = 0D0 - - ! size check - IF ( do_orbdep .AND. use_task_groups ) & - CALL errore('runcp_uspp','NKSIC and task_groups incompatible',10) - - IF( use_task_groups ) THEN - ! - ! The potential in rhos is distributed accros all processors - ! We need to redistribute it so that it is completely contained in the - ! processors of an orbital TASK-GROUP - ! - DO i = 1, nspin - CALL tg_gather( dffts, rhos(:,i), tg_rhos(:,i) ) - END DO - -! IF(lgam) THEN - incr = 2 * nogrp -! ELSE -! incr = nogrp -! ENDIF - - ELSE - -! IF(lgam) THEN - incr = 2 -! ELSE -! incr = 1 -! ENDIF - - END IF - - - ! - ! faux takes into account spin multiplicity. - ! - faux(:) = f(:) * DBLE( nspin ) / 2.0d0 - ! - DO j = 1, n - faux(j) = max( f_cutoff, faux(j) ) - ENDDO - - - DO i = 1, n, incr - ! - ! ... apply preconditioning on occupation - ! ... (this preconditioning must be taken into account when - ! ... calculating eigenvalues in eigs0.f90) - ! - - ! - IF( use_task_groups ) THEN - ! - !The input coefficients to dforce cover eigenstates i:i+2*NOGRP-1 - !Thus, in dforce the dummy arguments for c0(1,i) and - !c0(1,i+1) hold coefficients for eigenstates i,i+2*NOGRP-2,2 - !and i+1,i+2*NOGRP...for example if NOGRP is 4 then we would have - !1-3-5-7 and 2-4-6-8 - ! - - if( tefield .OR. tefield2 ) then - CALL errore( ' runcp_uspp ', ' electric field with task group not implemented yet ', 1 ) - end if - if( lda_plus_u ) then - CALL errore( ' runcp_uspp ', ' lda_plus_u with task group not implemented yet ', 1 ) - end if - - CALL dforce( i, bec, vkb, c0, c2, c3, tg_rhos, tg_rhos_siz, ispin, faux, n, nspin ) - - ELSE -!begin_added:giovanni:debug ------------ FORCES -! write(6,*) "c0, debug, before dforce", i -! write(6,*) c0(1,i), c0(2,i), c0(3,i), rhos(1,1) -! write(6,*) "c2, debug, before dforce" -! write(6,*) c2(1), c2(2), c2(3), rhos(2,1) -! write(6,*) "c3, debug, before dforce" -! write(6,*) c3(1), c3(2), c3(3), rhos(3,1) -!end_added:giovanni:debug ------------ FORCES - CALL dforce( i, bec, vkb, c0, c2, c3, rhos, SIZE(rhos,1), ispin, faux, n, nspin ) -!begin_added:giovanni:debug ------------ FORCES -! write(6,*) "c0, debug, after dforce" -! write(6,*) c0(1,i), c0(2,i), c0(3,i), rhos(1,1) -! write(6,*) "c2, debug, after dforce" -! write(6,*) c2(1), c2(2), c2(3), rhos(2,1) -! write(6,*) "c3, debug, after dforce" -! write(6,*) c3(1), c3(2), c3(3), rhos(3,1) -!end_added:giovanni:debug ------------ FORCES - END IF - - - IF ( lda_plus_u ) THEN - ! - IF ( tens .OR. tsmear ) THEN - ! - c2(:) = c2(:) - vupsi(:,i) - c3(:) = c3(:) - vupsi(:,i+1) - ! - ELSE - ! - c2(:) = c2(:) - vupsi(:,i) * faux(i) - c3(:) = c3(:) - vupsi(:,i+1) * faux(i+1) - ! - ENDIF - ! - ENDIF - ! - IF ( do_orbdep ) THEN - ! - IF ( odd_nkscalfact ) THEN - ! - IF ( tens .OR. tsmear ) THEN - ! - c2(:) = c2(:) - valpsi(i, :) - c3(:) = c3(:) - valpsi(i+1, :) - ! - ELSE - ! - c2(:) = c2(:) - valpsi(i,:) * faux(i) - c3(:) = c3(:) - valpsi(i+1, :) * faux(i+1) - ! - ENDIF - ! - ENDIF - ! - ! faux takes into account spin multiplicity. - ! - CALL nksic_eforce( i, n, nx, vsic, deeq_sic, bec, ngw, c0(:,i), c0(:,i+1), vsicpsi, lgam ) - ! - IF ( tens .OR. tsmear ) THEN - ! - c2(:) = c2(:) - vsicpsi(:,1) - c3(:) = c3(:) - vsicpsi(:,2) - ! - ELSE - ! - c2(:) = c2(:) - vsicpsi(:,1) * faux(i) - c3(:) = c3(:) - vsicpsi(:,2) * faux(i+1) - ! - ENDIF - - ! - ! build the matrix elements of - ! the Delta h^SIC hamiltonian - ! - ! (for the sake of plotting the evolution - ! of its imaginary part ) - ! - IF ( tprint_ham_ ) THEN - ! - DO ii = 0, 1 - ! - IF ( i+ii > n ) CYCLE - ! - isp = ispin( i+ii ) - i0 = i+ii - ! - IF ( nspin==2 ) i0 = i0 -iupdwn(isp) +1 - ! NOTE: iupdwn(isp) is set to zero if nspin=1 - ! - DO j0 = 1, nupdwn(isp) - ! - jj = j0 - IF ( nspin==2 ) jj = jj +iupdwn(isp) -1 - ! - IF(.not.hamilt(isp)%iscmplx) THEN - hamilt(isp)%rvec(j0, i0) = 2.0d0 * DOT_PRODUCT( c0(:,jj), vsicpsi(:,ii+1) ) - ! - IF ( gstart == 2 ) THEN - hamilt(isp)%rvec( j0, i0) = hamilt(isp)%rvec( j0, i0) -c0(1,jj)*vsicpsi(1,ii+1) - ENDIF - ELSE - hamilt(isp)%cvec(j0, i0) = DOT_PRODUCT( c0(:,jj), vsicpsi(:,ii+1) ) !warning:giovanni put conjugate?? - ENDIF - ! - ENDDO - ! - ENDDO - ! - ENDIF - ! - ENDIF - - ! - ! HF exchange - ! - IF ( do_hf ) THEN - ! - IF ( tens .OR. tsmear ) THEN - ! - c2(:) = c2(:) - vxxpsi(:,i) - c3(:) = c3(:) - vxxpsi(:,i+1) - ! - ELSE - ! - c2(:) = c2(:) - vxxpsi(:,i) * faux(i) - c3(:) = c3(:) - vxxpsi(:,i+1) * faux(i+1) - ! - ENDIF - ! - ENDIF - - ! - ! spin multiplicity and occupation factors - ! are taken into account inside the calls - ! - IF( tefield ) THEN - CALL dforce_efield ( bec%rvec, i, c0, c2, c3, rhos) - ENDIF - ! - IF( tefield2 ) THEN - CALL dforce_efield2 ( bec%rvec, i, c0, c2, c3, rhos) - ENDIF - - IF( iflag == 2 ) THEN - DO idx = 1, incr, 2 - IF( i + idx - 1 <= n ) THEN - cm( :, i+idx-1) = c0(:,i+idx-1) - cm( :, i+idx ) = c0(:,i+idx ) - END IF - ENDDO - END IF - ! - idx_in = 1 - DO idx = 1, incr, 2 - IF( i + idx - 1 <= n ) THEN - IF (tsde) THEN - CALL wave_steepest( cm(:, i+idx-1 ), c0(:, i+idx-1 ), emaver, c2, ngw, idx_in ) - CALL wave_steepest( cm(:, i+idx ), c0(:, i+idx ), emaver, c3, ngw, idx_in ) - ELSE - CALL wave_verlet( cm(:, i+idx-1 ), c0(:, i+idx-1 ), verl1, verl2, emaver, c2, ngw, idx_in ) - CALL wave_verlet( cm(:, i+idx ), c0(:, i+idx ), verl1, verl2, emaver, c3, ngw, idx_in ) - ENDIF - IF ( gstart == 2 ) THEN - IF(lgam) THEN - cm(1,i+idx-1) = CMPLX(DBLE(cm(1,i+idx-1)),0.0d0) - cm(1,i+idx ) = CMPLX(DBLE(cm(1,i+idx )),0.0d0) - ENDIF - END IF - END IF - ! - idx_in = idx_in + 1 - ! - END DO - ! - end do - - DEALLOCATE( c2 ) - DEALLOCATE( c3 ) - DEALLOCATE( tg_rhos ) - - END IF - ! - IF ( tprint_ham_ ) THEN - DO iss=1, size(hamilt) - IF(.not.hamilt(iss)%iscmplx) THEN - CALL mp_sum( hamilt(iss)%rvec ) - ELSE - CALL mp_sum( hamilt(iss)%cvec ) - ENDIF - END DO - ENDIF - ! - DEALLOCATE( emadt2 ) - DEALLOCATE( emaver ) -! - END SUBROUTINE runcp_uspp_x -! -! -!=----------------------------------------------------------------------------=! -! -! - -!=----------------------------------------------------------------------------=! - - SUBROUTINE runcp_uspp_force_pairing_x & !warning:giovanni still to be modified - ( fccc, ccc, ema0bg, dt2bye, rhos, bec, c0, cm, intermed, fromscra, & - restart ) - ! -! same as runcp, except that electrons are paired forcedly -! i.e. this handles a state dependant Hamiltonian for the paired and unpaired electrons -! unpaired is assumed to exist, to be unique, and located in highest index band - - USE kinds, ONLY : DP - USE wave_base, ONLY : wave_steepest, wave_verlet - USE control_flags, ONLY : lwf, tsde, use_task_groups - USE uspp, ONLY : vkb - USE reciprocal_vectors, ONLY : gstart - USE wannier_subroutines, ONLY : ef_potential - USE efield_module, ONLY : dforce_efield, tefield - USE electrons_base, ONLY : ispin, nspin, f, n=>nbsp - USE cp_interfaces, ONLY : dforce - ! - USE gvecw, ONLY: ngw - ! - ! - USE electrons_base, ONLY: nupdwn, iupdwn, nbspx, nbsp - USE mp, ONLY: mp_sum - USE mp_global, ONLY: intra_image_comm -!@@@@ - USE ldaU -!@@@@ - ! - IMPLICIT NONE - REAL(DP) :: fccc, ccc - REAL(DP) :: ema0bg(:), dt2bye - REAL(DP) :: rhos(:,:) - REAL(DP) :: bec(:,:) - COMPLEX(DP) :: c0(:,:), cm(:,:) - REAL(DP) :: intermed - LOGICAL, OPTIONAL, INTENT(in) :: fromscra - LOGICAL, OPTIONAL, INTENT(in) :: restart -! - REAL(DP) :: verl1, verl2, verl3 - REAL(DP), ALLOCATABLE:: emadt2(:) - REAL(DP), ALLOCATABLE:: emaver(:) - COMPLEX(DP), ALLOCATABLE:: c2(:), c3(:) - INTEGER :: i - INTEGER :: iflag - LOGICAL :: ttsde -! - INTEGER :: np_dw, is_dw, npair, n_unp, n_dwn - REAL(DP), ALLOCATABLE :: occ(:) - COMPLEX(DP), ALLOCATABLE :: c4(:), c5(:) -! -! ... Controlling on sic applicability -! - IF( lwf ) CALL errore('runcp_uspp_force_pairing', & - 'Wannier function and sic are not compatibile',1) - IF( tefield ) CALL errore('runcp_uspp_force_pairing', & - 'Electric field and sic are not implemented',2) - IF( nspin == 1 ) CALL errore(' runcp_force_pairing ',' inconsistent nspin ', 1) - - IF( use_task_groups ) CALL errore(' runcp_force_pairing ',' task_groups not implemented ', 1) -! - ALLOCATE( emadt2( ngw ) ) - ALLOCATE( emaver( ngw ) ) -! - iflag = 0 - IF( PRESENT( fromscra ) ) THEN - IF( fromscra ) iflag = 1 - END IF - IF( PRESENT( restart ) ) THEN - IF( restart ) iflag = 2 - END IF -! - IF( iflag == 0 ) THEN - ttsde = tsde - ELSE IF( iflag == 1 ) THEN - ttsde = .TRUE. - ELSE IF( iflag == 2 ) THEN - ttsde = .FALSE. - END IF -! - ALLOCATE( c2(ngw), c3(ngw), c4(ngw), c5(ngw) ) - ! - ! ... set verlet variables - ! - verl1 = 2.0d0 * fccc - verl2 = 1.0d0 - verl1 - verl3 = 1.0d0 * fccc -! - ccc = fccc * dt2bye - emadt2 = dt2bye * ema0bg - emaver = emadt2 * verl3 -! - IF( nupdwn(1) /= (nupdwn(2) + 1) ) & - CALL errore(' runcp_force_pairing ',' inconsistent number of states ', 1) - - n_unp = nupdwn(1) - n_dwn = nupdwn(2) - is_dw = iupdwn(2) - np_dw = nbsp -! - ALLOCATE( occ( nbspx ) ) -! - occ( 1:np_dw ) = 1.0d0 - occ( nbspx ) = 0.0d0 -! -! c0(dwn_paired) == c0(up_paired) -! cm(dwn_paired) == cm(up_paired) -! the nbspx dwn state has to be empty -! -! - c0(:, is_dw:np_dw ) = c0(:, 1:n_dwn ) - cm(:, is_dw:np_dw ) = cm(:, 1:n_dwn ) -! - c0(:, nbspx ) = (0.d0, 0.d0) - cm(:, nbspx ) = (0.d0, 0.d0) -! - IF( MOD(n_unp, 2) == 0 ) npair = n_unp - 2 - IF( MOD(n_unp, 2) /= 0 ) npair = n_unp - 1 - - DO i = 1, npair, 2 - ! - CALL dforce(i,bec,vkb,c0,c2,c3,rhos(:,1:1),SIZE(rhos,1),ispin,f,n,nspin) - CALL dforce(i,bec,vkb,c0,c4,c5,rhos(:,2:2),SIZE(rhos,1),ispin,f,n,nspin) - ! - c2 = occ( i )*(c2 + c4) - c3 = occ(i+1)*(c3 + c5) - ! - IF( iflag == 2 ) THEN - cm(:,i) = c0(:,i) - cm(:,i+1) = c0(:,i+1) - END IF - ! - IF( ttsde ) THEN - CALL wave_steepest( cm(:, i ), c0(:, i ), emaver, c2 ) - CALL wave_steepest( cm(:, i+1), c0(:, i+1), emaver, c3 ) - ELSE - CALL wave_verlet( cm(:, i ), c0(:, i ), verl1, verl2, emaver, c2 ) - CALL wave_verlet( cm(:, i+1), c0(:, i+1), verl1, verl2, emaver, c3 ) - END IF - ! - IF ( gstart == 2 ) THEN - cm(1, i) = CMPLX(DBLE(cm(1, i)),0.d0) - cm(1, i+1) = CMPLX(DBLE(cm(1, i+1)),0.d0) - END IF - ! - END DO - ! - IF( MOD(n_unp, 2) == 0 ) THEN - - npair = n_unp - 1 -! - CALL dforce(npair,bec,vkb,c0,c2,c3,rhos(:,1:1),SIZE(rhos,1),ispin,f,n,nspin) - CALL dforce(npair,bec,vkb,c0,c4,c5,rhos(:,2:2),SIZE(rhos,1),ispin,f,n,nspin) -! - c2 = c2 + c4 - ! - IF( iflag == 2 ) cm( :, npair ) = c0( :, npair ) -! - IF( ttsde ) THEN - CALL wave_steepest( cm(:, npair ), c0(:, npair ), emaver, c2 ) - ELSE - CALL wave_verlet( cm(:, npair), c0(:, npair), verl1, verl2, emaver, c2 ) - ENDIF -! - IF ( gstart == 2 ) cm(1, npair) = CMPLX(DBLE(cm(1, npair)),0.d0) - - ENDIF -! - c0(:, is_dw:np_dw ) = c0(:, 1:n_dwn ) - cm(:, is_dw:np_dw ) = cm(:, 1:n_dwn ) -! - c0(:, nbspx ) = (0.d0, 0.d0) - cm(:, nbspx ) = (0.d0, 0.d0) -! - -! -! The electron unpaired is signed by n_unp and spin up -! for the unpaired electron the ei_unp is the value of lambda -! "TRUE" ONLY WHEN THE POT is NORM_CONSERVING -! - - CALL dforce( n_unp, bec, vkb, c0, c2, c3, rhos, SIZE(rhos,1), ispin,f,n,nspin ) - ! - intermed = - 2.d0 * sum(c2 * conjg(c0(:,n_unp))) - IF ( gstart == 2 ) THEN - intermed = intermed + 1.d0 * c2(1) * conjg(c0(1,n_unp)) - END IF - CALL mp_sum ( intermed, intra_image_comm ) - ! - IF( iflag == 2 ) cm(:, n_unp) = c0(:, n_unp) - ! - IF( ttsde ) THEN - CALL wave_steepest( cm(:, n_unp), c0(:, n_unp), emaver, c2 ) - ELSE - CALL wave_verlet( cm(:, n_unp), c0(:, n_unp), verl1, verl2, emaver, c2 ) - ENDIF - ! - IF ( gstart == 2 ) cm(1, n_unp) = CMPLX(DBLE(cm(1, n_unp)),0.d0) - ! - DEALLOCATE( occ ) - DEALLOCATE( emadt2 ) - DEALLOCATE( emaver ) - DEALLOCATE(c2, c4) - DEALLOCATE(c3, c5) - - END SUBROUTINE runcp_uspp_force_pairing_x - diff --git a/quantum_espresso/kcp/CPV/spharmonic.f90 b/quantum_espresso/kcp/CPV/spharmonic.f90 deleted file mode 100644 index 5cb7410df..000000000 --- a/quantum_espresso/kcp/CPV/spharmonic.f90 +++ /dev/null @@ -1,430 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - MODULE spherical_harmonics - - USE kinds - IMPLICIT NONE - SAVE - - PRIVATE - - PUBLIC :: set_dmqm, set_fmrm, set_pmtm - - CONTAINS - - SUBROUTINE mspharm( lm1x, ngw, gx, gg, ylm) - INTEGER, INTENT(IN) :: lm1x, ngw - REAL(DP), INTENT(IN) :: gx(:,:), gg(:) - REAL(DP), INTENT(OUT) :: ylm(:,:) - INTEGER :: iy - iy = 0 -! DO l = 0, lm1x -! DO m = -l, l -! iy = iy + 1 -! CALL spharm( ylm(:,iy), gx, gg, ngw, l, m ) -! END DO -! END DO -! DO l = 0, lm1x -! DO m = 0, l -! iy = iy + 1 -! CALL spharm( ylm(:,iy), gx, gg, ngw, l, m ) -! IF( m > 0 ) THEN -! iy = iy + 1 -! CALL spharm( ylm(:,iy), gx, gg, ngw, l, -m ) -! END IF -! END DO -! END DO - CALL ylmr2( (lm1x+1)**2, ngw, gx, gg, ylm ) - RETURN - END SUBROUTINE mspharm - - - SUBROUTINE spharm(S,G,GSQM,NG,L,M) - - USE constants, only: fpi - -! ... L = 0, 1, 2 angular momentum -! ... M = -L, ..., L magnetic quantum number -! ... NG = number of plane wave -! ... G(:,:) = cartesian components of the reciprocal space vectors -! ... GSQM(:) = square modulus of the reciprocal space vectors -! ... S(:) = spherical harmonic components - - IMPLICIT NONE - INTEGER, INTENT(IN) :: NG, M, L - REAL(DP), INTENT(OUT) :: S(:) - REAL(DP), INTENT(IN) :: G(:,:), GSQM(:) - REAL(DP) :: x,y,z,r,r2 - INTEGER :: i, mm - - MM = M + L + 1 - SELECT CASE (L) - CASE (0) - S = 1.0d0 - CASE (1) - DO i = 1, ng - IF(GSQM(i).GE.1.0d-12) THEN - SELECT CASE ( m ) - CASE( 0 ) ! ok - S(i) = G(3,i) / sqrt(GSQM(i)) - CASE( 1 ) ! ok - S(i) = -G(1,i) / sqrt(GSQM(i)) - CASE( -1 ) ! ok - S(i) = -G(2,i) / sqrt(GSQM(i)) - CASE DEFAULT - CALL errore(' spharm ',' magnetic moment not implementent ',mm) - END SELECT - ELSE - S(i) = 0.0d0 - END IF - END DO - CASE (2) - DO i = 1, ng - IF(GSQM(i).GE.1.0d-12) THEN - x = G(1,i) - y = G(2,i) - z = G(3,i) - r2 = GSQM(i) - SELECT CASE (m) - CASE ( 0) - s(i) = 0.50d0 * (3.D0*Z*Z/r2-1.D0) - CASE ( 2) - s(i) = 0.50d0 * (X*X-Y*Y)/r2 * SQRT(3.D0) - CASE (-2) - s(i) = X*Y/r2 * SQRT(3.D0) - CASE (-1) - s(i) = -Y*Z/r2 * SQRT(3.D0) - CASE ( 1) - s(i) = -Z*X/r2 * SQRT(3.D0) - CASE DEFAULT - CALL errore(' spharm ',' magnetic moment not implementent ',mm) - END SELECT - ELSE - S(i) = 0.0d0 - END IF - END DO - CASE (3) - DO i = 1, ng - IF(GSQM(i).GE.1.0d-12) THEN - x = G(1,i) - y = G(2,i) - z = G(3,i) - r = SQRT(GSQM(i)) - SELECT CASE(M) - CASE( -3 ) - S(i) = -0.5d0 * SQRT(5.0d0/2.0d0) * y * ( 3.0d0 * x**2 - y**2 ) / r**3 - CASE( -2 ) - S(i) = SQRT(15.0d0) * x * y * z / r**3 - CASE( -1 ) - S(i) = -0.5d0 * SQRT(3.0d0/2.0d0) * ( 5.0d0 * z**2 / r**2 - 1.0d0 ) * y / r - CASE( 0 ) - S(i) = 0.5d0 * ( 5.0d0 * z**3 / r**3 - 3.0d0 * z / r ) - CASE( 1 ) - S(i) = -0.5d0 * SQRT(3.0d0/2.0d0) * ( 5.0d0 * z**2 / r**2 - 1.0d0 ) * x / r - CASE( 2 ) - S(i) = 0.5d0 * SQRT(15.0d0) * z * ( x**2 - y**2 ) / r**3 - CASE( 3 ) - S(i) = -0.5d0 * SQRT(5.0d0/2.0d0) * x * ( x**2 - 3.0d0 * y**2 ) / r**3 - END SELECT - ELSE - S(i) = 0.0d0 - END IF - END DO - CASE DEFAULT - CALL errore(' spharm ',' angular momuntum not implementent ',l) - END SELECT - - s( 1:ng ) = s( 1:ng ) * sqrt ( DBLE(2*l+1) / fpi) - - RETURN - END SUBROUTINE spharm - -!========================================================================= -!== PM is the matrix used to construct the spherical harmonics with L=P == -!== Y_M(G) = PM(A,M) * G_A [A=1,3] == -!==---------------------------------------------------------------------== -!== PMTM is the product of PM * TM , TM being the "inverse" of TM, i.e. == -!== G_A = TM(A,M) * Y_M(G) == -!========================================================================= -! - SUBROUTINE set_pmtm(pm,pmtm) - - IMPLICIT NONE - REAL(DP) P_M(3,3),T_M(3,3) - REAL(DP) PM(3,3),PMTM(6,3,3) - INTEGER M1,M2,KK - - INTEGER, dimension(6), parameter :: ALPHA = (/ 1,2,3,2,3,3 /) - INTEGER, dimension(6), parameter :: BETA = (/ 1,1,1,2,2,3 /) - - P_M = 0.0d0 - T_M = 0.0d0 - -!======== PM ================ -! M=1 - P_M(2,1)= -1.D0 -! M=2 - P_M(3,2)= 1.D0 -! M=3 - P_M(1,3)= -1.D0 - - PM = P_M - -!======== TM ================ -! M=1 - T_M(2,1)= -1.0d0 -! M=2 - T_M(3,2)= 1.0d0 -! M=3 - T_M(1,3)= -1.0d0 - -!======= PMTM ============= - - DO M1=1,3 - DO M2=1,3 - DO KK=1,6 - PMTM(KK,M1,M2)= P_M(BETA(KK),M1)*T_M(ALPHA(KK),M2) - END DO - END DO - END DO - - - RETURN - END SUBROUTINE set_pmtm - - -!========================================================================= -!== DM is the matrix used to construct the spherical harmonics with L=D == -!== Y_M(G) = DM(A,B,M) * G_A * G_B [A,B=1,3 => K=1,6] == -!==---------------------------------------------------------------------== -!== DMQM is the product of DM * QM , QM being the "inverse" of DM, i.e. == -!== G_A * G_B = QM(A,B,M) * Y_M(G) + DELTA_A,B / 3 == -!========================================================================= -! - SUBROUTINE set_dmqm(dm,dmqm) - - IMPLICIT NONE - REAL(DP) D_M(3,3,5),Q_M(3,3,5) - REAL(DP) DM(6,5),DMQM(6,5,5) - INTEGER A,M1,M2,KK - - INTEGER, dimension(6), parameter :: ALPHA = (/ 1,2,3,2,3,3 /) - INTEGER, dimension(6), parameter :: BETA = (/ 1,1,1,2,2,3 /) - - D_M = 0.0d0 - Q_M = 0.0d0 - -!======== DM ================ -! M=1 - D_M(1,1,3)=-1.D0/2.D0 - D_M(2,2,3)=-1.D0/2.D0 - D_M(3,3,3)= 1.D0 -! M=2 - D_M(1,1,5)= SQRT(3.D0)/2.D0 - D_M(2,2,5)=-SQRT(3.D0)/2.D0 -! M=3 - D_M(1,2,1)= SQRT(3.D0)/2.D0 - D_M(2,1,1)= SQRT(3.D0)/2.D0 -! M=4 - D_M(2,3,2)= -SQRT(3.D0)/2.D0 - D_M(3,2,2)= -SQRT(3.D0)/2.D0 -! M=5 - D_M(1,3,4)= -SQRT(3.D0)/2.D0 - D_M(3,1,4)= -SQRT(3.D0)/2.D0 - -!======== QM ================ -! M=1 - Q_M(1,1,3)=-1.D0/3.D0 - Q_M(2,2,3)=-1.D0/3.D0 - Q_M(3,3,3)= 2.D0/3.D0 -! M=2 - Q_M(1,1,5)= 1.D0/SQRT(3.D0) - Q_M(2,2,5)= -1.D0/SQRT(3.D0) -! M=3 - Q_M(1,2,1)= 1.D0/SQRT(3.D0) - Q_M(2,1,1)= 1.D0/SQRT(3.D0) -! M=4 - Q_M(2,3,2)= -1.D0/SQRT(3.D0) - Q_M(3,2,2)= -1.D0/SQRT(3.D0) -! M=5 - Q_M(1,3,4)= -1.D0/SQRT(3.D0) - Q_M(3,1,4)= -1.D0/SQRT(3.D0) - -!======= DMQM ============= - - DO M1=1,5 - DO M2=1,5 - DO KK=1,6 - DMQM(KK,M1,M2)=0.D0 - DO A=1,3 - DMQM(KK,M1,M2)=DMQM(KK,M1,M2)+ & - D_M(BETA(KK),A,M1)*Q_M(A,ALPHA(KK),M2) - END DO - END DO - END DO - END DO - - DO M1=1,5 - DO KK=1,6 - DM(KK,M1)=D_M(ALPHA(KK),BETA(KK),M1) - END DO - END DO - - RETURN - END SUBROUTINE set_dmqm - - - - -!========================================================================= -!== FM is the matrix used to construct the spherical harmonics with L=F == -!== Y_M(G) = FM(A,B,C,M) * G_A * G_B * G_C [A,B,C=1,3] == -!==---------------------------------------------------------------------== -!== RM is the "inverse" of FM, i.e. == -!== G_A * G_B * G_C = RM(A,B,C,M) * Y_M(G) + == -!== DELTA_A,B * G_C / 5.0 + == -!== DELTA_B,C * G_A / 5.0 + == -!== DELTA_A,C * G_B / 5.0 + == -!========================================================================= -! - SUBROUTINE set_fmrm(fm,fmrm) - - IMPLICIT NONE - REAL(DP) :: F_M(3,3,3,7), R_M(3,3,3,7) - REAL(DP) :: FM(3,3,3,7), FMRM(6,7,7) - INTEGER :: M1,M2,KK,s,k - - INTEGER, dimension(6), parameter :: ALPHA = (/ 1,2,3,2,3,3 /) - INTEGER, dimension(6), parameter :: BETA = (/ 1,1,1,2,2,3 /) - - F_M = 0.0d0 - R_M = 0.0d0 - -!======== FM ================ -! M=-3 - F_M(1,1,2,1)= -1.D0/2.D0 * SQRT(5.0d0/2.0d0) - F_M(1,2,1,1)= -1.D0/2.D0 * SQRT(5.0d0/2.0d0) - F_M(2,1,1,1)= -1.D0/2.D0 * SQRT(5.0d0/2.0d0) - F_M(2,2,2,1)= +1.D0/2.D0 * SQRT(5.0d0/2.0d0) -! M=-2 - F_M(1,2,3,2)= SQRT(15.0d0)/6.0d0 - F_M(1,3,2,2)= SQRT(15.0d0)/6.0d0 - F_M(2,1,3,2)= SQRT(15.0d0)/6.0d0 - F_M(2,3,1,2)= SQRT(15.0d0)/6.0d0 - F_M(3,1,2,2)= SQRT(15.0d0)/6.0d0 - F_M(3,2,1,2)= SQRT(15.0d0)/6.0d0 -! M=-1 - F_M(1,1,2,3)= +SQRT(3.0d0/2.0d0) / 6.0d0 - F_M(1,2,1,3)= +SQRT(3.0d0/2.0d0) / 6.0d0 - F_M(2,1,1,3)= +SQRT(3.0d0/2.0d0) / 6.0d0 - F_M(2,2,2,3)= +SQRT(3.0d0/2.0d0) / 2.0d0 - F_M(3,3,2,3)= -SQRT(3.0d0/2.0d0) * 2.0d0 / 3.0d0 - F_M(3,2,3,3)= -SQRT(3.0d0/2.0d0) * 2.0d0 / 3.0d0 - F_M(2,3,3,3)= -SQRT(3.0d0/2.0d0) * 2.0d0 / 3.0d0 -! M=0 - F_M(1,1,3,4)= -1.0d0/2.0d0 - F_M(1,3,1,4)= -1.0d0/2.0d0 - F_M(3,1,1,4)= -1.0d0/2.0d0 - F_M(2,2,3,4)= -1.0d0/2.0d0 - F_M(2,3,2,4)= -1.0d0/2.0d0 - F_M(3,2,2,4)= -1.0d0/2.0d0 - F_M(3,3,3,4)= 1.0d0 -! M=1 - F_M(1,1,1,5)= +SQRT(3.0d0/2.0d0) / 2.0d0 - F_M(2,2,1,5)= +SQRT(3.0d0/2.0d0) / 6.0d0 - F_M(2,1,2,5)= +SQRT(3.0d0/2.0d0) / 6.0d0 - F_M(1,2,2,5)= +SQRT(3.0d0/2.0d0) / 6.0d0 - F_M(3,3,1,5)= -SQRT(3.0d0/2.0d0) * 2.0d0 / 3.0d0 - F_M(3,1,3,5)= -SQRT(3.0d0/2.0d0) * 2.0d0 / 3.0d0 - F_M(1,3,3,5)= -SQRT(3.0d0/2.0d0) * 2.0d0 / 3.0d0 -! M=2 - F_M(3,1,1,6)= SQRT(15.0d0) / 6.0d0 - F_M(1,3,1,6)= SQRT(15.0d0) / 6.0d0 - F_M(1,1,3,6)= SQRT(15.0d0) / 6.0d0 - F_M(3,2,2,6)= -SQRT(15.0d0) / 6.0d0 - F_M(2,3,2,6)= -SQRT(15.0d0) / 6.0d0 - F_M(2,2,3,6)= -SQRT(15.0d0) / 6.0d0 -! M=3 - F_M(1,1,1,7)= -SQRT(5.0d0/2.0d0) / 2.0d0 - F_M(2,2,1,7)= +SQRT(5.0d0/2.0d0) / 2.0d0 - F_M(2,1,2,7)= +SQRT(5.0d0/2.0d0) / 2.0d0 - F_M(1,2,2,7)= +SQRT(5.0d0/2.0d0) / 2.0d0 - - - FM = F_M - - -!======== FM ================ -! M=-3 - R_M(1,1,2,1)= -1.D0 / SQRT(5.0d0/2.0d0) / 2.0d0 - R_M(1,2,1,1)= -1.D0 / SQRT(5.0d0/2.0d0) / 2.0d0 - R_M(2,1,1,1)= -1.D0 / SQRT(5.0d0/2.0d0) / 2.0d0 - R_M(2,2,2,1)= +1.D0 / SQRT(5.0d0/2.0d0) / 2.0d0 -! M=-2 - R_M(1,2,3,2)= 1.0d0 / SQRT(15.0d0) - R_M(1,3,2,2)= 1.0d0 / SQRT(15.0d0) - R_M(2,1,3,2)= 1.0d0 / SQRT(15.0d0) - R_M(2,3,1,2)= 1.0d0 / SQRT(15.0d0) - R_M(3,1,2,2)= 1.0d0 / SQRT(15.0d0) - R_M(3,2,1,2)= 1.0d0 / SQRT(15.0d0) -! M=-1 - R_M(1,1,2,3)= +1.0d0 / SQRT(3.0d0/2.0d0) / 10.0d0 - R_M(1,2,1,3)= +1.0d0 / SQRT(3.0d0/2.0d0) / 10.0d0 - R_M(2,1,1,3)= +1.0d0 / SQRT(3.0d0/2.0d0) / 10.0d0 - R_M(2,2,2,3)= +3.0d0 / SQRT(3.0d0/2.0d0) / 10.0d0 - R_M(3,3,2,3)= -2.0d0 / SQRT(3.0d0/2.0d0) / 5.0d0 - R_M(3,2,3,3)= -2.0d0 / SQRT(3.0d0/2.0d0) / 5.0d0 - R_M(2,3,3,3)= -2.0d0 / SQRT(3.0d0/2.0d0) / 5.0d0 -! M=0 - R_M(1,1,3,4)= -1.0d0/5.0d0 - R_M(1,3,1,4)= -1.0d0/5.0d0 - R_M(3,1,1,4)= -1.0d0/5.0d0 - R_M(2,2,3,4)= -1.0d0/5.0d0 - R_M(2,3,2,4)= -1.0d0/5.0d0 - R_M(3,2,2,4)= -1.0d0/5.0d0 - R_M(3,3,3,4)= 2.0d0/5.0d0 -! M=1 - R_M(1,1,1,5)= +3.0d0 / SQRT(3.0d0/2.0d0) / 10.0d0 - R_M(2,2,1,5)= +1.0d0 / SQRT(3.0d0/2.0d0) / 10.0d0 - R_M(2,1,2,5)= +1.0d0 / SQRT(3.0d0/2.0d0) / 10.0d0 - R_M(1,2,2,5)= +1.0d0 / SQRT(3.0d0/2.0d0) / 10.0d0 - R_M(3,3,1,5)= -2.0d0 / SQRT(3.0d0/2.0d0) / 5.0d0 - R_M(3,1,3,5)= -2.0d0 / SQRT(3.0d0/2.0d0) / 5.0d0 - R_M(1,3,3,5)= -2.0d0 / SQRT(3.0d0/2.0d0) / 5.0d0 -! M=2 - R_M(3,1,1,6)= 1.0d0 / SQRT(15.0d0) - R_M(1,3,1,6)= 1.0d0 / SQRT(15.0d0) - R_M(1,1,3,6)= 1.0d0 / SQRT(15.0d0) - R_M(3,2,2,6)= -1.0d0 / SQRT(15.0d0) - R_M(2,3,2,6)= -1.0d0 / SQRT(15.0d0) - R_M(2,2,3,6)= -1.0d0 / SQRT(15.0d0) -! M=3 - R_M(1,1,1,7)= -1.0d0 / SQRT(5.0d0/2.0d0) / 2.0d0 - R_M(2,2,1,7)= +1.0d0 / SQRT(5.0d0/2.0d0) / 2.0d0 - R_M(2,1,2,7)= +1.0d0 / SQRT(5.0d0/2.0d0) / 2.0d0 - R_M(1,2,2,7)= +1.0d0 / SQRT(5.0d0/2.0d0) / 2.0d0 - - DO M1=1,7 - DO M2=1,7 - DO KK=1,6 - FMRM(KK,M1,M2)=0.D0 - DO s=1,3 - DO k=1,3 - FMRM(KK,M1,M2) = FMRM(KK,M1,M2) + & - F_M(BETA(KK),s,k,M1) * R_M(s,k,ALPHA(KK),M2) - END DO - END DO - END DO - END DO - END DO - - - RETURN - END SUBROUTINE set_fmrm - - END MODULE spherical_harmonics diff --git a/quantum_espresso/kcp/CPV/spline.f90 b/quantum_espresso/kcp/CPV/spline.f90 deleted file mode 100644 index 5a1961b08..000000000 --- a/quantum_espresso/kcp/CPV/spline.f90 +++ /dev/null @@ -1,708 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!-----------------------------------------------------------------------------! -! This module is basad on a similar module from CP2K -!-----------------------------------------------------------------------------! - - MODULE splines - -! routines for handling splines -! allocate_spline: allocates x and y vectors for splines -! init_spline: generate table for spline (allocate spl%y2) -! spline: return value of spline for given abscissa (optional:also y1) -! spline_1: return value of 1. derivative of spline for given abscissa -! spline_int: return value of integral on given interval of spline -! kill_spline: destructor ( spl%x,y und/oder spl%y2) - -! NB: splines are always ``natural splines'', i.e. values of first -! derivative at the end-points cannot be specified -!-----------------------------------------------------------------------------! - USE kinds, ONLY : DP - - IMPLICIT NONE - - PRIVATE - PUBLIC :: spline_data, allocate_spline, init_spline, spline, spline_1, & - spline_int, kill_spline, splineh, splinedx, splintdx, nullify_spline - - TYPE spline_data - REAL (DP), POINTER :: x(:) ! array containing x values - REAL (DP), POINTER :: y(:) ! array containing y values - ! y(i) is the function value corresponding - ! to x(i) in the interpolation table - REAL (DP), POINTER :: y2(:) ! second derivative of interpolating function - INTEGER :: n ! number of element in the interpolation table - INTEGER :: pos - REAL (DP) :: h, invh, h26, h16 - REAL (DP) :: xmin, xmax ! ... added by Carlo Cavazzoni - END TYPE spline_data - -!-----------------------------------------------------------------------------! - - CONTAINS - -!-----------------------------------------------------------------------------! - - SUBROUTINE nullify_spline( spl ) - TYPE (spline_data), INTENT (INOUT) :: spl - NULLIFY( spl%x ) - NULLIFY( spl%y ) - NULLIFY( spl%y2 ) - spl%n = 0 - spl%pos = 0 - spl%h = 0.0d0 - spl%invh = 0.0d0 - spl%h26 = 0.0d0 - spl%h16 = 0.0d0 - spl%xmin = 0.0d0 - spl%xmax = 0.0d0 - RETURN - END SUBROUTINE nullify_spline - - SUBROUTINE allocate_spline( spl, nn, xmin, xmax ) - - IMPLICIT NONE - - TYPE (spline_data), INTENT (INOUT) :: spl - INTEGER, INTENT (IN) :: nn - REAL(DP), INTENT (IN), OPTIONAL :: xmin, xmax - - INTEGER err - - IF( PRESENT( xmin ) .AND. .NOT. PRESENT( xmax ) ) & - CALL errore(' allocate_spline ', ' wrong number of arguments ', 1 ) - - spl%n = nn - - IF ( associated(spl%x) ) THEN - DEALLOCATE (spl%x,STAT=err) - IF (err/=0) CALL errore(' allocate_spline ','could not deallocate spl%x',1) - NULLIFY (spl%x) - END IF - - ! note that spl%x is not allocated if we use a regular x grid - - IF( PRESENT( xmin ) .AND. PRESENT( xmax ) ) THEN - IF( xmin >= xmax ) & - CALL errore(' allocate_spline ', ' wrong interval ', 1) - spl%xmin = xmin - spl%xmax = xmax - spl%h = ( xmax - xmin ) / DBLE( nn - 1 ) - spl%invh = 1.0d0 / spl%h - ELSE - spl%xmin = 0 - spl%xmax = 0 - ALLOCATE (spl%x(1:nn),STAT=err) - IF (err/=0) CALL errore(' allocate_spline ','could not allocate spl%x',1) - END IF - - IF (associated(spl%y)) THEN - DEALLOCATE (spl%y,STAT=err) - IF (err/=0) CALL errore(' allocate_spline ','could not deallocate spl%y',1) - NULLIFY (spl%y) - END IF - - ALLOCATE (spl%y(1:nn),STAT=err) - IF (err/=0) CALL errore(' allocate_spline ','could not allocate spl%y',1) - - IF (associated(spl%y2)) THEN - DEALLOCATE (spl%y2,STAT=err) - IF (err/=0) CALL errore(' allocate_spline ','could not deallocate spl%y2',1) - NULLIFY (spl%y2) - END IF - - ALLOCATE (spl%y2(1:nn),STAT=err) - IF (err/=0) CALL errore(' allocate_spline ','could not allocate spl%y2',1) - - RETURN - END SUBROUTINE allocate_spline - - -!----------------------------------------------------------------------- - - SUBROUTINE init_spline( spl, endpt, y1a, y1b ) - -! endpt: 's': regular spacing -! 'l': left; 'r': right; 'b': both = specify 1-deriv for each endpoints - - IMPLICIT NONE - TYPE (spline_data), INTENT (INOUT) :: spl - CHARACTER (len=*), INTENT (IN), OPTIONAL :: endpt - REAL (DP), INTENT (IN), OPTIONAL :: y1a, y1b ! end point derivative - INTEGER :: err, i, k, n - REAL (DP) :: p, qn, sig, un, y1l, y1r, dyp, dym, dxp, dxm, dxpm - REAL (DP), POINTER :: ww(:) - CHARACTER (len=8) :: ep - LOGICAL :: reg, lep, rep - - ! shortcat for regular mesh without table of x values - - IF( .NOT. ASSOCIATED( spl%x ) ) THEN - CALL splinedx( spl%xmin, spl%xmax, spl%y(:), spl%n, 0.0d0, 0.0d0, spl%y2(:) ) - RETURN - END IF - - ! Find out if y first derivative is given at endpoints - - IF ( .NOT. present(endpt) ) THEN - ep = ' ' - ELSE - ep = endpt - END IF - reg = ( scan(ep,'sS') > 0 ) - lep = ( scan(ep,'lL') > 0 ) .OR. ( scan(ep,'bB') > 0 ) - rep = ( scan(ep,'rR') > 0 ) .OR. ( scan(ep,'bB') > 0 ) - - ! check input parameter consistency - - IF ( ( lep .OR. rep ) .AND. .NOT. present(y1a) ) & - CALL errore( 'init_spline', 'first deriv. at end-point missing', 1 ) - IF ( lep .AND. rep .AND. .NOT. present(y1b) ) & - CALL errore( 'init_spline', 'first deriv. at end-point missing', 1 ) - - ! define endpoints derivative - - IF ( lep ) y1l = y1a - IF ( rep .AND. .NOT. lep ) y1r = y1a - IF ( rep .AND. lep ) y1r = y1b - - spl%pos = 1 - ALLOCATE ( ww( 1 : spl%n ), STAT = err ) - IF (err/=0) CALL errore('init_spline','could not allocate ww',1) - - n = spl % n - - IF ( lep ) THEN - spl%y2(1) = -0.5d0 - dxp = spl%x(2) - spl%x(1) - dyp = spl%y(2) - spl%y(1) - ww(1) = ( 3.0d0 / dxp ) * ( dyp / dxp - y1l ) - ELSE - spl%y2(1) = 0 - ww(1) = 0.d0 - END IF - - DO i = 2, n - 1 - - dxp = spl%x(i+1) - spl%x(i) - dxm = spl%x(i) - spl%x(i-1) - dxpm = spl%x(i+1) - spl%x(i-1) - - sig = dxm / dxpm - p = sig * spl%y2(i-1) + 2.0d0 - spl%y2(i) = ( sig - 1.0d0 ) / p - - dyp = spl%y(i+1) - spl%y(i) - dym = spl%y(i) - spl%y(i-1) - - ww(i) = ( 6.0d0 * ( dyp / dxp - dym / dxm ) / dxpm - sig * ww(i-1) ) / p - - END DO - - IF ( rep ) THEN - qn = 0.5d0 - dxm = spl%x(n) - spl%x(n-1) - dym = spl%y(n) - spl%y(n-1) - un = ( 3.0d0 / dxm ) * ( y1r - dym / dxm ) - ELSE - qn = 0 - un = 0 - END IF - - spl % y2(n) = ( un - qn * ww(n-1) ) / ( qn * spl%y2(n-1) + 1.0d0 ) - - DO k = n - 1, 1, -1 - spl % y2(k) = spl%y2(k) * spl%y2(k+1) + ww(k) - END DO - - DEALLOCATE ( ww, STAT = err ) - IF (err/=0) CALL errore('init_spline','could not deallocate ww',1) - - IF ( reg ) THEN - spl%h = ( spl%x(n) - spl%x(1) ) / ( n - 1.0d0 ) - spl%h16 = spl%h / 6.0d0 - spl%h26 = spl%h**2 / 6.0d0 - spl%invh = 1 / spl%h - ELSE - spl%h = 0.0d0 - spl%invh = 0.0d0 - END IF - - RETURN - END SUBROUTINE init_spline - -!----------------------------------------------------------------------- - - FUNCTION interv( spl, xx ) - - IMPLICIT NONE - - TYPE (spline_data), INTENT (IN) :: spl - REAL (DP), INTENT (IN) :: xx - INTEGER :: interv - INTEGER :: khi, klo, i, p, n, k - - ! if we have a regular mesh use a quick position search - - IF ( spl%h /= 0 ) THEN - i = ( xx - spl%x(1) ) * spl%invh + 1 - IF ( i < 1 .OR. i > spl%n ) & - CALL errore('interv', 'illegal x-value passed to interv',1) - interv = i - RETURN - END IF - - p = spl%pos - IF ( p >= spl%n .OR. p <= 1 ) p = spl%n / 2 - i = 0 - n = spl%n - - ! check if interval is close to previous interval - - IF ( xx < spl%x(p+1) ) THEN - IF ( xx >= spl%x(p) ) THEN - i = spl%pos - ELSE IF ( p > 1 .AND. xx >= spl%x(p-1) ) THEN - i = p - 1 - ELSE - klo = 1 - khi = p + 1 - END IF - ELSE IF ( (p + 2) <= n .AND. xx < spl%x(p+2) ) THEN - i = p + 1 - ELSE - klo = p + 1 - khi = n - END IF - - ! perform binary search - - IF ( i == 0 ) THEN - IF ( xx < spl%x(1) .OR. xx > spl%x(n) ) & - CALL errore('interv', 'xx value out of spline-range',1) - DO WHILE ( (khi - klo) > 1 ) - k = ( khi + klo ) / 2 - IF ( spl%x(k) > xx ) THEN - khi = k - ELSE - klo = k - END IF - END DO - i = klo - END IF - - interv = i - RETURN - END FUNCTION interv - - -!----------------------------------------------------------------------- - FUNCTION spline( spl, xx, y1 ) - - IMPLICIT NONE - - TYPE (spline_data), INTENT (INOUT) :: spl - REAL (DP), INTENT (IN) :: xx - REAL (DP), INTENT (OUT), OPTIONAL :: y1 - REAL (DP) :: spline - - INTEGER :: khi, klo - REAL (DP) :: a, b, h, invh, ylo, yhi, y2lo, y2hi, a3ma, b3mb - - ! shortcat for regular mesh without table of x values - - IF( .NOT. ASSOCIATED( spl%x ) ) THEN - IF( PRESENT( y1 ) ) & - CALL errore(' spline ', ' y1 without x table not implemented ', 1 ) - CALL splintdx( spl%xmin, spl%xmax, spl%y, spl%y2, spl%n, xx, a ) - spline = a - RETURN - END IF - - spl%pos = interv( spl, xx ) - klo = spl%pos - khi = spl%pos + 1 - - IF ( spl%h /= 0 ) THEN - h = spl%h - invh = spl%invh - ELSE - h = spl%x( khi ) - spl%x( klo ) - invh = spl%invh - IF ( h == 0.0d0 ) & - CALL errore('spline','bad spl%x input',1) - END IF - - a = ( spl%x( khi ) - xx ) * invh - b = 1 - a - a3ma = a**3 - a - b3mb = b**3 - b - ylo = spl%y( klo ) - yhi = spl%y( khi ) - y2lo = spl%y2( klo ) - y2hi = spl%y2( khi ) - spline = a * ylo + b * yhi + ( a3ma * y2lo + b3mb * y2hi ) * ( h**2 ) / 6.0d0 - - IF ( present( y1 ) ) then - y1 = ( yhi - ylo ) * invh + & - ( ( 1.0d0 - 3 * a**2 ) * y2lo + ( 3 * b**2 - 1.0d0 ) * y2hi ) * h / 6.0d0 - END IF - - RETURN - END FUNCTION spline - -!----------------------------------------------------------------------- - - FUNCTION splineh(spl,xx,y1) - IMPLICIT NONE - TYPE (spline_data), INTENT (IN) :: spl - REAL (DP), INTENT (IN) :: xx - REAL (DP), INTENT (OUT) :: y1 - REAL (DP) :: splineh - - INTEGER :: i - REAL (DP) :: a, b, h, invh, t, ylo, yhi, y2lo, y2hi, d, d0 - -! fast spline for pair potentials without checks - h = spl%h - invh = spl%invh - d=xx-spl%x(1); i=INT(d*spl%invh); d0=DBLE(i)*h; i=i+1 - i = (xx-spl%x(1))*invh + 1 - - a = (spl%x(i+1)-xx)*invh - b = 1 - a - t = -a*b -! b=(d-d0)*invh; a=1-b; t=-a*b - ylo = spl%y(i) - yhi = spl%y(i+1) - y2lo = spl%y2(i) - y2hi = spl%y2(i+1) - splineh = a*ylo + b*yhi + ((a+1)*y2lo+(b+1)*y2hi)*t*spl%h26 - y1 = (yhi-ylo)*invh + ((1.d0-3*a*a)*y2lo+(3*b*b-1.d0)*y2hi)*spl%h16 - - END FUNCTION splineh -!----------------------------------------------------------------------- - FUNCTION spline_1(spl,xx) - IMPLICIT NONE - TYPE (spline_data), INTENT (INOUT) :: spl - REAL (DP), INTENT (IN) :: xx - REAL (DP) :: spline_1 - - INTEGER :: khi, klo - REAL (DP) :: a, b, h - - spl%pos = interv(spl,xx) - klo = spl%pos - khi = spl%pos + 1 - - h = spl%x(khi) - spl%x(klo) - IF (h==0.d0) CALL errore('spline','bad spl%x input',1) - a = (spl%x(khi)-xx)/h - b = 1 - a - spline_1 = (spl%y(khi)-spl%y(klo))/h + ((1.d0-3*a**2)*spl%y2(klo)+(3*b** & - 2-1.d0)*spl%y2(khi))*h/6.d0 - - RETURN - END FUNCTION spline_1 - - - -!----------------------------------------------------------------------- - FUNCTION stamm(spl,p,x) - IMPLICIT NONE - TYPE (spline_data), INTENT (IN) :: spl - INTEGER, INTENT (IN) :: p - REAL (DP), INTENT (IN) :: x - REAL (DP) :: stamm - REAL (DP) :: a, b, aa, bb, h - - h = spl%x(p+1) - spl%x(p) - b = (x-spl%x(p))/h - a = 1 - b - aa = a**2 - bb = b**2 - stamm = 0.5d0*h*(bb*spl%y(p+1)-aa*spl%y(p)) + h**3/12.d0*(aa*(1-0.5d0*aa)* & - spl%y2(p)-bb*(1-0.5d0*bb)*spl%y2(p+1)) - - RETURN - END FUNCTION stamm - - - -!----------------------------------------------------------------------- - FUNCTION spline_int(spl,x0,x1) - IMPLICIT NONE - TYPE (spline_data), INTENT (INOUT) :: spl - REAL (DP), INTENT (IN) :: x0, x1 - REAL (DP) :: spline_int - - INTEGER :: j, pa, pb - REAL (DP) :: h, vorz, xa, xb, i1, i2 - - vorz = 1 - xa = min(x0,x1) - xb = max(x0,x1) - IF (x0>x1) vorz = -1 - IF (xaspl%x(spl%n)) CALL errore('spline_int', & - 'illegal integration range',1) - - pa = interv(spl,xa) - pb = interv(spl,xb) - - IF (pa==pb) THEN - spline_int = vorz*(stamm(spl,pa,xb)-stamm(spl,pa,xa)) - RETURN - END IF - - i1 = 0 - i2 = 0 - DO j = pa + 1, pb - 1 - h = spl%x(j+1) - spl%x(j) - i1 = i1 + h*(spl%y(j)+spl%y(j+1)) - i2 = i2 + h**3*(spl%y2(j)+spl%y2(j+1)) - END DO - h = spl%x(pa+1) - spl%x(pa) - i1 = i1 + h*spl%y(pa+1) - i2 = i2 + h**3*spl%y2(pa+1) - h = spl%x(pb+1) - spl%x(pb) - i1 = i1 + h*spl%y(pb) - i2 = i2 + h**3*spl%y2(pb) - - spline_int = vorz*(i1/2.-i2/24.d0+stamm(spl,pb,xb)-stamm(spl,pa,xa)) - - RETURN - END FUNCTION spline_int - -!----------------------------------------------------------------------- - SUBROUTINE kill_spline(spl,what) -! deallocate splines -! what=='a' or not present: deallocate all (spl%x, spl%y, spl%y2) -! what=='d': deallocate only data (spl%x, spl%y) -! what=='2': deallocate only table of 2. derivatives (spl%y2) - IMPLICIT NONE - TYPE (spline_data), INTENT (INOUT) :: spl - CHARACTER, INTENT (IN), OPTIONAL :: what - CHARACTER :: w - INTEGER :: err - - w = 'a' - IF (present(what)) w = what - SELECT CASE (w) - CASE ('d','D') - IF (associated(spl%x)) THEN - DEALLOCATE (spl%x,STAT=err) - IF (err/=0) CALL errore('kill_spline', 'could not deallocate spl%x',1) - NULLIFY (spl%x) - END IF - IF (associated(spl%y)) THEN - DEALLOCATE (spl%y,STAT=err) - IF (err/=0) CALL errore('kill_spline', 'could not deallocate spl%y',1) - NULLIFY (spl%y) - END IF - CASE ('2') - IF (associated(spl%y2)) THEN - DEALLOCATE (spl%y2,STAT=err) - IF (err/=0) CALL errore('kill_spline', 'could not deallocate spl%y2',1) - NULLIFY (spl%y2) - END IF - CASE ('a','A') - IF (associated(spl%x)) THEN - DEALLOCATE (spl%x,STAT=err) - IF (err/=0) CALL errore('kill_spline', 'could not deallocate spl%x',1) - NULLIFY (spl%x) - END IF - IF (associated(spl%y)) THEN - DEALLOCATE (spl%y,STAT=err) - IF (err/=0) CALL errore('kill_spline', 'could not deallocate spl%y',1) - NULLIFY (spl%y) - END IF - IF (associated(spl%y2)) THEN - DEALLOCATE (spl%y2,STAT=err) - IF (err/=0) CALL errore('kill_spline', 'could not deallocate spl%y2',1) - NULLIFY (spl%y2) - END IF - END SELECT - - RETURN - END SUBROUTINE kill_spline - -!=-----------------------------------------------------------------------=! -! Subroutines: splinedx, splintdx -! added for compatibility with SISSA code -! Carlo Cavazzoni 15-03-2000 -!=-----------------------------------------------------------------------=! - - SUBROUTINE splinedx(xmin,xmax,y,n,yp1,ypn,y2) - USE kinds - IMPLICIT NONE - INTEGER, INTENT(IN) :: n - REAL(DP), INTENT(IN) :: yp1,ypn,xmin,xmax,y(:) - REAL(DP), INTENT(OUT) :: y2(:) - INTEGER :: i, k - REAL(DP) :: p, qn, sig, un, dx - REAL(DP) :: u(n) - - dx = (xmax-xmin)/DBLE(n-1) - if ( yp1 .gt. 0.99d30 ) then - y2(1)=0.d0 - u(1)=0.0d0 - else - y2(1)=-0.5d0 - u(1)=(3.d0/dx) * ( (y(2)-y(1)) / dx - yp1 ) - endif - do i=2,n-1 - sig=0.5d0 - p=sig*y2(i-1)+2.d0 - y2(i)=(sig-1.d0)/p - u(i) = (6.0d0 * ( (y(i+1)-y(i))/ dx - (y(i)-y(i-1))/ dx ) & - / (2.0d0*dx) - sig * u(i-1) ) / p - end do - if ( ypn .gt. 0.99d30 ) then - qn=0.d0 - un=0.d0 - else - qn=0.5d0 - un= ( 3.d0 / dx ) * ( ypn - (y(n)-y(n-1)) / dx ) - endif - y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.0d0) - do k=n-1,1,-1 - y2(k)=y2(k)*y2(k+1)+u(k) - end do - return - END SUBROUTINE splinedx - - - SUBROUTINE splintdx(xmin,xmax,ya,y2a,n,x,y) - USE kinds - IMPLICIT NONE - INTEGER, INTENT(IN) :: n - REAL(DP), INTENT(IN) :: x,xmin,xmax,ya(:),y2a(:) - REAL(DP), INTENT(OUT) :: y - INTEGER :: khi,klo - REAL(DP) :: a,b,dx,xhi,xlo - dx = (xmax-xmin)/DBLE(n-1) - klo = INT(x/dx) - khi = klo+1 - IF(klo.LT.1) THEN - CALL errore(' splintdx ',' klo less than one ',klo) - END IF - IF(khi.GT.n) THEN - CALL errore(' splintdx ',' khi grether than N ',khi) - END IF - xlo = xmin + DBLE(klo-1) * dx - xhi = xmin + DBLE(khi-1) * dx - - a = (xhi-x)/dx - b = (x-xlo)/dx - y = a*ya(klo) + b*ya(khi) + & - ( (a*a*a-a)*y2a(klo) + (b*b*b-b)*y2a(khi) ) * (dx*dx)/6.0d0 - RETURN - END SUBROUTINE splintdx - -!----------------------------------------------------------------------- - - SUBROUTINE nr_spline( x, y, n, yp1, ypn, y2 ) - INTEGER :: n - REAL(DP) :: yp1, ypn, x(n), y(n), y2(n) - INTEGER :: i, k - REAL(DP) :: p, qn, sig, un - REAL(DP) :: u( n ) - if ( yp1 .gt. 0.99d30 ) then - y2(1)=0.d0 - u(1)=0.d0 - else - y2(1)=-0.5d0 - u(1)=(3.d0/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) - endif - do i=2,n-1 - sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) - p=sig*y2(i-1)+2.d0 - y2(i)=(sig-1.d0)/p - u(i)=(6.d0*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) / & - (x(i)-x(i-1))) / (x(i+1)-x(i-1))-sig*u(i-1))/p - end do - if ( ypn .gt. 0.99d30 ) then - qn=0.d0 - un=0.d0 - else - qn=0.5d0 - un=(3.d0/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1))) - endif - y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.d0) - do k=n-1,1,-1 - y2(k)=y2(k)*y2(k+1)+u(k) - end do - return - END SUBROUTINE nr_spline - - - SUBROUTINE nr_splint( xa, ya, y2a, n, x, y ) - INTEGER :: n - REAL(DP) :: x,y,xa(n),y2a(n),ya(n) - INTEGER :: k,khi,klo - REAL(DP) :: a,b,h - klo=1 - khi=n -1 if (khi-klo.gt.1) then - k=(khi+klo)/2 - if(xa(k).gt.x)then - khi=k - else - klo=k - endif - goto 1 - endif - h=xa(khi)-xa(klo) - if (h.eq.0.) & - CALL errore(' nr_splint ', 'bad xa input in splint' , 1 ) - a=(xa(khi)-x)/h - b=(x-xa(klo))/h - y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))* & - (h**2)/6.d0 - return - END SUBROUTINE nr_splint - - - SUBROUTINE nr_splie2( x1a, x2a, ya, m, n, y2a ) - INTEGER :: m, n - REAL(DP) :: x1a(m), x2a(n), y2a(m,n), ya(m,n) - INTEGER :: j,k - REAL(DP) :: y2tmp(n), ytmp(n) - do j = 1, m - do k = 1, n - ytmp(k) = ya(j,k) - end do - call nr_spline( x2a, ytmp, n, 1.d30, 1.d30, y2tmp ) - do k = 1, n - y2a(j,k) = y2tmp(k) - end do - end do - return - END SUBROUTINE nr_splie2 - - - SUBROUTINE nr_splin2( x1a, x2a, ya, y2a, m, n, x1, x2, y ) - INTEGER :: m, n - REAL(DP) :: x1, x2, y, x1a(m), x2a(n), y2a(m,n), ya(m,n) - INTEGER :: j, k - REAL(DP) :: y2tmp( MAX(n,m) ), ytmp( n ), yytmp( MAX(n,m) ) - do j = 1, m - do k = 1, n - ytmp(k) = ya(j,k) - y2tmp(k) = y2a(j,k) - end do - call nr_splint( x2a, ytmp, y2tmp, n, x2, yytmp(j) ) - end do - call nr_spline( x1a, yytmp, m, 1.d30, 1.d30, y2tmp ) - call nr_splint( x1a, yytmp, y2tmp, m, x1, y ) - return - END SUBROUTINE nr_splin2 - -!----------------------------------------------------------------------- - - END MODULE splines diff --git a/quantum_espresso/kcp/CPV/start_c0_wan.f90 b/quantum_espresso/kcp/CPV/start_c0_wan.f90 deleted file mode 100644 index 399127687..000000000 --- a/quantum_espresso/kcp/CPV/start_c0_wan.f90 +++ /dev/null @@ -1,51 +0,0 @@ -!=----------------------------------------------------------------------------=! - SUBROUTINE start_c0_wan ( ctot, c0, ngw, n, u_matrix, nx ) -!=----------------------------------------------------------------------------=! - ! - ! this routine rotates the KS wave functions to very localize minimizing - ! wfc. That will be used as starting of KS - ! it works with a block-like distributed matrix - ! of the Lagrange multipliers ( lambda ). - ! - ! ... declare modules - ! - USE kinds, ONLY: DP - ! - IMPLICIT NONE - ! - ! ... declare subroutine arguments - ! - INTEGER, INTENT(IN) :: ngw, n, nx - COMPLEX, INTENT(IN) :: u_matrix(:,:,:) - COMPLEX(DP), INTENT(INOUT) :: ctot(:,:) - COMPLEX(DP), INTENT(IN) :: c0(:,:) - ! - ! ... declare other variables - ! - INTEGER :: i, j, k - ! - IF( nx < 1 ) THEN - RETURN - END IF - ! - c0(:,:) = (0.0, 0.0) - ! - DO ispin = 1, nspin - ! - istart = iupdwn (ispin) - ! - DO j = 1, nbnd - ! - DO i = 1, nbnd - ! - CALL DAXPY( 2*ngw, u_matrix(j,i,ispin), c0(1, istart:istart+nbnd-1), 1, ctot(1,istart:istart+nbnd-1), 1 ) - ! - ENDDO - ! - ENDDO - ! - ENDDO - ! - RETURN - ! - END SUBROUTINE start_c0_wan diff --git a/quantum_espresso/kcp/CPV/stop_run.f90 b/quantum_espresso/kcp/CPV/stop_run.f90 deleted file mode 100644 index 4f1d8635d..000000000 --- a/quantum_espresso/kcp/CPV/stop_run.f90 +++ /dev/null @@ -1,57 +0,0 @@ -! -! Copyright (C) 2001-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!---------------------------------------------------------------------------- -SUBROUTINE stop_run( flag ) - !---------------------------------------------------------------------------- - ! - ! ... Close all files and synchronize processes before stopping. - ! - USE control_flags, ONLY : lpath, lconstrain, lcoarsegrained - USE environment, ONLY : environment_end - USE path_variables, ONLY : path_deallocation - USE path_io_routines, ONLY : io_path_stop - USE constraints_module, ONLY : deallocate_constraint - USE metadyn_vars, ONLY : deallocate_metadyn_vars - USE mp, ONLY : mp_barrier, mp_end - USE reciprocal_vectors, ONLY : mill_g - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(IN) :: flag - ! - ! - CALL environment_end( ) - ! - IF ( lpath ) CALL io_path_stop() - ! - CALL deallocate_modules_var() - ! - IF ( lconstrain ) CALL deallocate_constraint() - ! - IF ( lcoarsegrained ) CALL deallocate_metadyn_vars() - ! - IF ( lpath ) CALL path_deallocation() - ! - if( allocated( mill_g ) ) deallocate( mill_g ) - - CALL mp_barrier() - ! - CALL mp_end() - ! - IF ( flag ) THEN - ! - STOP - ! - ELSE - ! - STOP 1 - ! - END IF - ! -END SUBROUTINE stop_run diff --git a/quantum_espresso/kcp/CPV/stress.f90 b/quantum_espresso/kcp/CPV/stress.f90 deleted file mode 100644 index 422c6ee95..000000000 --- a/quantum_espresso/kcp/CPV/stress.f90 +++ /dev/null @@ -1,568 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -#include "f_defs.h" - -!------------------------------------------------------------------------------! - SUBROUTINE pstress_x( paiu, desr, dekin, denl, deps, deht, dexc, ht ) -!------------------------------------------------------------------------------! - - ! this routine sum up stress tensor from partial contributions - - USE kinds, ONLY: DP - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - USE stress_param, ONLY: alpha, beta - - IMPLICIT NONE - - ! ... declare subroutine arguments - - REAL(DP) :: paiu(3,3) - REAL(DP) :: ht(3,3) - REAL(DP) :: denl(3,3) - REAL(DP) :: desr(6), dekin(6), deps(6), deht(6), dexc(6) - - INTEGER :: k - - ! ... total stress (pai-lowercase) - - DO k = 1, 6 - paiu( alpha(k), beta(k) ) = -( dekin(k) + deht(k) + dexc(k) + desr (k) + deps(k) ) - paiu( beta(k), alpha(k) ) = paiu(alpha(k),beta(k)) - END DO - - CALL mp_sum( paiu, intra_image_comm ) - - paiu = paiu - MATMUL( denl(:,:), ht(:,:) ) - - RETURN - END SUBROUTINE pstress_x - - -!------------------------------------------------------------------------------! - SUBROUTINE pstress_conv( de3x3, de6, ainv ) -!------------------------------------------------------------------------------! - - USE kinds, ONLY: DP - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - USE stress_param, ONLY: alpha, beta - - IMPLICIT NONE - - REAL(DP) :: de3x3(3,3) - REAL(DP), INTENT(IN) :: de6(6) - REAL(DP), INTENT(IN) :: ainv(3,3) - REAL(DP) :: tmp(3,3) - - INTEGER :: k - - DO k = 1, 6 - tmp( alpha(k), beta(k) ) = de6(k) - tmp( beta(k), alpha(k) ) = tmp(alpha(k),beta(k)) - END DO - - de3x3 = MATMUL( tmp(:,:), TRANSPOSE( ainv(:,:) ) ) - - CALL mp_sum( de3x3, intra_image_comm ) - - - RETURN - END SUBROUTINE - - - -!------------------------------------------------------------------------------! - SUBROUTINE pseudo_stress_x( deps, gagb, sfac, rhoeg, omega ) -!------------------------------------------------------------------------------! - ! - USE kinds, ONLY: DP - USE gvecs, ONLY: ngs - USE electrons_base, ONLY: nspin - USE stress_param, ONLY: dalbe - USE cp_interfaces, ONLY: stress_local - - IMPLICIT NONE - - REAL(DP), INTENT(IN) :: omega - REAL(DP), INTENT(OUT) :: deps(:) - REAL(DP), INTENT(IN) :: gagb(:,:) - COMPLEX(DP), INTENT(IN) :: rhoeg(:,:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - - INTEGER :: k - COMPLEX(DP), ALLOCATABLE :: rhoe( : ) - COMPLEX(DP), ALLOCATABLE :: drhoe( :, : ) - ! - ALLOCATE( drhoe( ngs, 6 ), rhoe( ngs ) ) - - rhoe( 1:ngs ) = rhoeg( 1:ngs, 1 ) - IF( nspin > 1 ) rhoe( 1:ngs ) = rhoe( 1:ngs ) + rhoeg( 1:ngs, 2 ) - - DO k = 1, 6 - drhoe( 1:ngs, k ) = - rhoe( 1:ngs ) * dalbe( k ) - END DO - - CALL stress_local( deps, gagb, sfac, rhoe, drhoe, omega ) - - DEALLOCATE( drhoe, rhoe ) - - RETURN - END SUBROUTINE pseudo_stress_x - - - -!------------------------------------------------------------------------------! - SUBROUTINE stress_local_x( deps, gagb, sfac, rhoe, drhoe, omega ) -!------------------------------------------------------------------------------! - ! - USE kinds, ONLY: DP - USE ions_base, ONLY: nsp - USE reciprocal_vectors, ONLY: gstart - USE gvecs, ONLY: ngs - USE local_pseudo, ONLY: vps, dvps - - IMPLICIT NONE - - REAL(DP), INTENT(IN) :: omega - REAL(DP), INTENT(OUT) :: deps(:) - REAL(DP), INTENT(IN) :: gagb(:,:) - COMPLEX(DP), INTENT(IN) :: rhoe(:) - COMPLEX(DP), INTENT(IN) :: drhoe(:,:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - - INTEGER :: ig,k,is - COMPLEX(DP) :: dsvp, svp, depst(6) - REAL(DP) :: wz - ! - depst = (0.d0,0.d0) - - wz = 2.0d0 - - DO ig = gstart, ngs - svp = 0.0d0 - DO is = 1, nsp - svp = svp + sfac( ig, is ) * vps( ig, is ) - END DO - depst = depst + wz * CONJG( drhoe( ig, : ) ) * svp - END DO - IF( gstart == 2 ) THEN - svp = 0.0d0 - DO is = 1, nsp - svp = svp + sfac( 1, is ) * vps( 1, is ) - END DO - depst = depst + CONJG( drhoe( 1, : ) ) * svp - END IF - - DO ig = gstart, ngs - dsvp = 0.0d0 - DO is = 1, nsp - dsvp = dsvp + sfac( ig, is ) * dvps( ig, is ) - END DO - DO k = 1, 6 - depst( k ) = depst( k ) - wz * 2.0d0 * CONJG( rhoe( ig ) ) * dsvp * gagb( k, ig ) - END DO - END DO - - deps = omega * DBLE( depst ) - - RETURN - END SUBROUTINE stress_local_x - - - - -!------------------------------------------------------------------------------! - SUBROUTINE stress_kin_x( dekin, c0, occ ) -!------------------------------------------------------------------------------! - -! this routine computes the kinetic energy contribution to the stress -! tensor -! -! dekin(:) = - 2 (sum over i) f(i) * -! ( (sum over g) gagb(:,g) CONJG( c0(g,i) ) c0(g,i) ) -! - - USE kinds, ONLY: DP - USE gvecw, ONLY: ecsig, ecfix, ecutz, ngw - USE constants, ONLY: pi - USE reciprocal_vectors, ONLY: gstart, g, gx - USE cell_base, ONLY: tpiba2 - USE electrons_base, ONLY: nspin, iupdwn, nupdwn - USE stress_param, ONLY: alpha, beta - - IMPLICIT NONE - -! ... declare subroutine arguments - REAL(DP), INTENT(OUT) :: dekin(:) - COMPLEX(DP), INTENT(IN) :: c0(:,:) - REAL(DP), INTENT(IN) :: occ(:) - -! ... declare other variables - REAL(DP) :: sk(6), scg, efac - REAL(DP), ALLOCATABLE :: arg(:) - INTEGER :: ib, ig, ispin, iwfc - -! ... end of declarations -! ---------------------------------------------- - - dekin = 0.0_DP - ALLOCATE( arg( ngw ) ) - - efac = 2.0d0 * ecutz / ecsig / SQRT(pi) - IF( efac > 0.0d0 ) THEN - DO ig = gstart, ngw - arg(ig) = 1.0d0 + efac * exp( -( ( tpiba2 * g(ig) - ecfix ) / ecsig )**2 ) - END DO - ELSE - arg = 1.0d0 - END IF - - ! ... compute kinetic energy contribution - - DO ispin = 1, nspin - DO ib = 1, nupdwn( ispin ) - sk = 0.0_DP - iwfc = ib + iupdwn( ispin ) - 1 - DO ig = gstart, ngw - scg = arg(ig) * CONJG( c0( ig, iwfc ) ) * c0( ig, iwfc ) - sk(1) = sk(1) + scg * gx( alpha( 1 ), ig ) * gx( beta( 1 ), ig ) - sk(2) = sk(2) + scg * gx( alpha( 2 ), ig ) * gx( beta( 2 ), ig ) - sk(3) = sk(3) + scg * gx( alpha( 3 ), ig ) * gx( beta( 3 ), ig ) - sk(4) = sk(4) + scg * gx( alpha( 4 ), ig ) * gx( beta( 4 ), ig ) - sk(5) = sk(5) + scg * gx( alpha( 5 ), ig ) * gx( beta( 5 ), ig ) - sk(6) = sk(6) + scg * gx( alpha( 6 ), ig ) * gx( beta( 6 ), ig ) - END DO - dekin = dekin + occ( iwfc ) * sk * tpiba2 - END DO - END DO - dekin = - 2.0_DP * dekin - DEALLOCATE(arg) - RETURN - END SUBROUTINE stress_kin_x - - - - -!------------------------------------------------------------------------------! - SUBROUTINE add_drhoph_x( drhot, sfac, gagb ) -!------------------------------------------------------------------------------! - ! - USE kinds, ONLY: DP - USE gvecs, ONLY: ngs - USE ions_base, ONLY: nsp, rcmax - USE local_pseudo, ONLY: rhops - USE stress_param, ONLY: dalbe - ! - IMPLICIT NONE - ! - COMPLEX(DP), INTENT(INOUT) :: drhot( :, : ) - COMPLEX(DP), INTENT(IN) :: sfac( :, : ) - REAL(DP), INTENT(IN) :: gagb( :, : ) - ! - INTEGER :: ij, is, ig - COMPLEX(DP) :: drhop - ! - DO ij = 1, 6 - IF( dalbe( ij ) > 0.0d0 ) THEN - DO is = 1, nsp - DO ig = 1, ngs - drhot(ig,ij) = drhot(ig,ij) - sfac(ig,is)*rhops(ig,is) - ENDDO - END DO - END IF - END DO - DO ig = 1, ngs - drhop = 0.0d0 - DO is = 1, nsp - drhop = drhop - sfac( ig, is ) * rhops(ig,is) * rcmax(is)**2 * 0.5D0 - END DO - DO ij = 1, 6 - drhot(ig,ij) = drhot(ig,ij) - drhop * gagb( ij, ig ) - END DO - END DO - RETURN - END SUBROUTINE add_drhoph_x - - - - -!------------------------------------------------------------------------------! - SUBROUTINE stress_har_x(deht, ehr, sfac, rhoeg, gagb, omega ) -!------------------------------------------------------------------------------! - - use kinds, only: DP - use ions_base, only: nsp - USE constants, ONLY: fpi - USE reciprocal_vectors, ONLY: gstart - USE gvecs, ONLY: ngs - USE gvecp, ONLY: ngm - USE local_pseudo, ONLY: rhops - USE electrons_base, ONLY: nspin - USE stress_param, ONLY: dalbe - USE cp_interfaces, ONLY: add_drhoph, stress_hartree - - IMPLICIT NONE - - REAL(DP), INTENT(OUT) :: DEHT(:) - REAL(DP), INTENT(IN) :: omega, EHR, gagb(:,:) - COMPLEX(DP), INTENT(IN) :: RHOEG(:,:) - COMPLEX(DP), INTENT(IN) :: sfac(:,:) - - COMPLEX(DP), ALLOCATABLE :: rhot(:), drhot(:,:) - - INTEGER ig, is, k - - - ALLOCATE( rhot( ngm ) ) - ALLOCATE( drhot( ngm, 6 ) ) - - ! sum up spin components - ! - DO ig = gstart, ngm - rhot( ig ) = rhoeg( ig, 1 ) - IF( nspin > 1 ) rhot( ig ) = rhot( ig ) + rhoeg( ig, 2 ) - END DO - ! - ! add Ionic pseudo charges rho_I - ! - DO is = 1, nsp - DO ig = gstart, ngs - rhot( ig ) = rhot( ig ) + sfac( ig, is ) * rhops( ig, is ) - END DO - END DO - - ! add drho_e / dh - ! - DO k = 1, 6 - IF( dalbe( k ) > 0.0d0 ) THEN - drhot( :, k ) = - rhoeg( :, 1 ) - IF( nspin > 1 ) drhot( :, k ) = drhot( :, k ) + rhoeg( :, 2 ) - ELSE - drhot( :, k ) = 0.0d0 - END IF - END DO - - ! add drho_I / dh - ! - CALL add_drhoph( drhot, sfac, gagb ) - - CALL stress_hartree(deht, ehr, rhot, drhot, gagb, omega ) - - DEALLOCATE( rhot, drhot ) - - RETURN - END SUBROUTINE stress_har_x - - - - -!------------------------------------------------------------------------------! - SUBROUTINE stress_hartree_x(deht, ehr, rhot, drhot, gagb, omega ) -!------------------------------------------------------------------------------! - - ! This subroutine computes: d E_hartree / dh = - ! E_hartree * h^t + - ! 4pi omega rho_t * CONJG( rho_t ) / G^2 / G^2 * G_alpha * G_beta + - ! 4pi omega Re{ CONJG( rho_t ) * drho_t / G^2 } - ! where: - ! rho_t = rho_e + rho_I - ! drho_t = d rho_t / dh = -rho_e + d rho_hard / dh + d rho_I / dh - - use kinds, only: DP - use mp_global, ONLY: me_image, root_image - USE constants, ONLY: fpi - USE cell_base, ONLY: tpiba2 - USE reciprocal_vectors, ONLY: gstart, g - USE gvecp, ONLY: ngm - USE stress_param, ONLY: dalbe - - IMPLICIT NONE - - REAL(DP), INTENT(OUT) :: DEHT(:) - REAL(DP), INTENT(IN) :: omega, EHR, gagb(:,:) - COMPLEX(DP) :: rhot(:) ! total charge: Sum_spin ( rho_e + rho_I ) - COMPLEX(DP) :: drhot(:,:) - - COMPLEX(DP) DEHC(6) - COMPLEX(DP) CFACT - REAL(DP), ALLOCATABLE :: hgm1( : ) - REAL(DP) :: wz - - INTEGER ig, k - - DEHC = (0.D0,0.D0) - DEHT = 0.D0 - - wz = 2.0d0 - - ALLOCATE( hgm1( ngm ) ) - - hgm1( 1 ) = 0.0d0 - DO ig = gstart, ngm - hgm1( ig ) = 1.D0 / g(ig) / tpiba2 - END DO - - ! Add term rho_t * CONJG( rho_t ) / G^2 * G_alpha * G_beta / G^2 - - DO ig = gstart, ngm - cfact = rhot( ig ) * CONJG( rhot( ig ) ) * hgm1( ig ) ** 2 - dehc = dehc + cfact * gagb(:,ig) - END DO - - ! Add term 2 * Re{ CONJG( rho_t ) * drho_t / G^2 } - - DO ig = gstart, ngm - DO k = 1, 6 - dehc( k ) = dehc( k ) + rhot( ig ) * CONJG( drhot( ig, k ) ) * hgm1( ig ) - END DO - END DO - - ! term: E_h * h^t - - if ( me_image == root_image ) then - deht = wz * fpi * omega * DBLE(dehc) + ehr * dalbe - else - deht = wz * fpi * omega * DBLE(dehc) - end if - - DEALLOCATE( hgm1 ) - - RETURN - END SUBROUTINE stress_hartree_x - - - -!------------------------------------------------------------------------------! - SUBROUTINE stress_debug(dekin, deht, dexc, desr, deps, denl, htm1) -!------------------------------------------------------------------------------! - - USE kinds, ONLY: DP - USE io_global, ONLY: stdout - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - USE stress_param, ONLY: alpha, beta - - IMPLICIT NONE - - REAL(DP) :: dekin(6), deht(6), dexc(6), desr(6), deps(6), denl(6) - REAL(DP) :: detot(6), htm1(3,3) - REAL(DP) :: detmp(3,3) - - INTEGER :: k, i, j - - detot = dekin + deht + dexc + desr + deps + denl - - DO k=1,6 - detmp(alpha(k),beta(k)) = detot(k) - detmp(beta(k),alpha(k)) = detmp(alpha(k),beta(k)) - END DO - CALL mp_sum( detmp, intra_image_comm ) - detmp = MATMUL( detmp(:,:), htm1(:,:) ) - WRITE( stdout,*) "derivative of e(tot)" - WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3) - - DO k=1,6 - detmp(alpha(k),beta(k)) = dekin(k) - detmp(beta(k),alpha(k)) = detmp(alpha(k),beta(k)) - END DO - CALL mp_sum( detmp, intra_image_comm ) - detmp = MATMUL( detmp(:,:), htm1(:,:) ) - WRITE( stdout,*) "derivative of e(kin)" - WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3) - - DO k=1,6 - detmp(alpha(k),beta(k)) = deht(k) + desr(k) - detmp(beta(k),alpha(k)) = detmp(alpha(k),beta(k)) - END DO - CALL mp_sum( detmp, intra_image_comm ) - detmp = MATMUL( detmp(:,:), htm1(:,:) ) - WRITE( stdout,*) "derivative of e(electrostatic)" - WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3) - - DO k=1,6 - detmp(alpha(k),beta(k)) = deht(k) - detmp(beta(k),alpha(k)) = detmp(alpha(k),beta(k)) - END DO - CALL mp_sum( detmp, intra_image_comm ) - detmp = MATMUL( detmp(:,:), htm1(:,:) ) - WRITE( stdout,*) "derivative of e(h)" - WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3) - - DO k=1,6 - detmp(alpha(k),beta(k)) = desr(k) - detmp(beta(k),alpha(k)) = detmp(alpha(k),beta(k)) - END DO - CALL mp_sum( detmp, intra_image_comm ) - detmp = MATMUL( detmp(:,:), htm1(:,:) ) - WRITE( stdout,*) "derivative of e(sr)" - WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3) - - DO k=1,6 - detmp(alpha(k),beta(k)) = deps(k) - detmp(beta(k),alpha(k)) = detmp(alpha(k),beta(k)) - END DO - CALL mp_sum( detmp, intra_image_comm ) - detmp = MATMUL( detmp(:,:), htm1(:,:) ) - WRITE( stdout,*) "derivative of e(ps)" - WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3) - - DO k=1,6 - detmp(alpha(k),beta(k)) = denl(k) - detmp(beta(k),alpha(k)) = detmp(alpha(k),beta(k)) - END DO - CALL mp_sum( detmp, intra_image_comm ) - detmp = MATMUL( detmp(:,:), htm1(:,:) ) - WRITE( stdout,*) "derivative of e(nl)" - WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3) - - DO k=1,6 - detmp(alpha(k),beta(k)) = dexc(k) - detmp(beta(k),alpha(k)) = detmp(alpha(k),beta(k)) - END DO - CALL mp_sum( detmp, intra_image_comm ) - detmp = MATMUL( detmp(:,:), htm1(:,:) ) - WRITE( stdout,*) "derivative of e(xc)" - WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3) - -5555 format(1x,f12.5,1x,f12.5,1x,f12.5/ & - & 1x,f12.5,1x,f12.5,1x,f12.5/ & - & 1x,f12.5,1x,f12.5,1x,f12.5//) - - RETURN - END SUBROUTINE stress_debug - - - - -!------------------------------------------------------------------------------! - SUBROUTINE compute_gagb_x( gagb, gx, ngm, tpiba2 ) -!------------------------------------------------------------------------------! - - ! ... compute G_alpha * G_beta - - USE kinds, ONLY: DP - USE stress_param, ONLY: alpha, beta - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: ngm - REAL(DP), INTENT(IN) :: gx(:,:) - REAL(DP), INTENT(OUT) :: gagb(:,:) - REAL(DP), INTENT(IN) :: tpiba2 - - INTEGER :: k, ig - - DO k = 1, 6 - DO ig = 1, ngm - gagb( k, ig ) = gx( alpha( k ), ig ) * gx( beta( k ), ig ) * tpiba2 - END DO - END DO - - END SUBROUTINE compute_gagb_x diff --git a/quantum_espresso/kcp/CPV/symm_wannier.f90 b/quantum_espresso/kcp/CPV/symm_wannier.f90 deleted file mode 100644 index dc0ecef2f..000000000 --- a/quantum_espresso/kcp/CPV/symm_wannier.f90 +++ /dev/null @@ -1,192 +0,0 @@ -! -! Copyright (C) 2002-2007 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!----------------------------------------------------------------------- -SUBROUTINE symm_wannier_x( wfc, num_states, emp ) - !--------------------------------------------------------------------- - ! - ! ... This routine imposes the Bloch symmetry on the variational - ! ... orbitals in two steps: - ! ... - ! ... 1) finds the orbitals inside a reference primitive cell; if - ! ... read_centers = .false. then the first N orbitals (where N is - ! ... the number of PC orbitals) are taken as reference - ! ... 2) builds the other orbitals by imposing w_R(r) = w_0(r-R), where - ! ... R are the lattice vectors of the corresponding primitive cell - ! - ! - USE kinds, ONLY : DP - USE electrons_base, ONLY : nspin - USE gvecw, ONLY : ngw - USE input_parameters, ONLY : mp1, mp2, mp3, read_centers, & - offset_centers_occ, offset_centers_emp - USE reciprocal_vectors, ONLY : gx - USE cell_base, ONLY : at, alat - USE constants, ONLY : tpi - USE io_global, ONLY : ionode, ionode_id, stdout - USE mp, ONLY : mp_bcast - USE mp_global, ONLY : intra_image_comm - USE constants, ONLY : BOHR_RADIUS_ANGS - USE centers_and_spreads, ONLY : read_wannier_centers, read_wannier_spreads - ! - ! - IMPLICIT NONE - ! - COMPLEX(DP), INTENT(INOUT) :: wfc(:,:) - INTEGER, INTENT(IN) :: num_states - LOGICAL, INTENT(IN) :: emp - ! - INTEGER :: norb - INTEGER :: norb_pc ! number of ref orbitals - REAL(DP), ALLOCATABLE :: centers(:,:), spreads(:) - REAL(DP), ALLOCATABLE :: centers_(:,:), spreads_(:) - COMPLEX(DP), ALLOCATABLE :: wfc_aux(:,:) - INTEGER :: n, ig - INTEGER :: i, j, k - INTEGER :: counter - REAL(DP) :: offset(3) - REAL(DP) :: rvect(3), Rvec(3) - CHARACTER(3) :: typ='occ' - COMPLEX(DP) :: imag = (0.D0,1.D0) - ! - ! - norb = num_states / nspin - norb_pc = norb / (mp1*mp2*mp3) - ! - IF ( emp ) typ = 'emp' - ! - WRITE( stdout, 101 ) typ - ! - IF ( read_centers ) THEN - ! - ALLOCATE( centers(3,norb) ) - ALLOCATE( centers_(3,norb) ) - ALLOCATE( spreads(norb), spreads_(norb) ) - ALLOCATE( wfc_aux(ngw,norb_pc) ) - ! - IF ( ionode ) CALL read_wannier_centers(centers, norb, emp) - IF ( ionode ) CALL read_wannier_spreads(spreads_, norb, emp) - CALL mp_bcast( centers, ionode_id, intra_image_comm ) - CALL mp_bcast( spreads_, ionode_id, intra_image_comm ) - spreads(:) = 0.D0 - ! - WRITE( stdout, * ) - WRITE( stdout, '( 3x, "Reference orbitals found (crystal units):" )' ) - ! - offset = (/0.,0.,0./) - IF ( emp ) THEN - IF ( offset_centers_emp ) offset = (/0.1,0.1,0.1/) - ELSE - IF ( offset_centers_occ ) offset = (/0.1,0.1,0.1/) - ENDIF - ! - counter = 0 - DO n = 1, norb - ! - ! shift the orbitals inside the supercell (0,1)x(0,1)x(0,1) - ! - centers(1,n) = centers(1,n) + offset(1) - floor(centers(1,n)) - centers(2,n) = centers(2,n) + offset(2) - floor(centers(2,n)) - centers(3,n) = centers(3,n) + offset(3) - floor(centers(3,n)) - ! - centers(:,n) = centers(:,n) - offset(:) - ! - ! identify the orbitals inside a ref primitive cell - ! - IF ( (centers(1,n) + offset(1)) * mp1 - 1 < 1.e-3 .and. & - (centers(2,n) + offset(2)) * mp2 - 1 < 1.e-3 .and. & - (centers(3,n) + offset(3)) * mp3 - 1 < 1.e-3 ) THEN - ! - counter = counter + 1 - wfc_aux(:,counter) = wfc(:,n) - centers_(:,counter) = centers(:,n) - spreads(counter) = spreads_(n) - ! - WRITE ( stdout, 201 ) n, centers(:,n) - ! - ENDIF - ! - ENDDO - ! - ! - IF ( counter .ne. norb_pc ) THEN - CALL errore( 'symm_wannier', 'Wrong number of ref orbitals', counter ) - ENDIF - ! - centers(:,:) = 0.D0 - centers(:,:norb_pc) = centers_(:,:norb_pc) - DEALLOCATE( centers_ ) - ! - wfc(:,1:norb_pc) = wfc_aux(:,:) - DEALLOCATE( wfc_aux ) - ! - ELSE - ! - counter = norb_pc - ! - WRITE( stdout, * ) - WRITE( stdout, 202 ) norb_pc - ! - ENDIF - ! - ! - ! Now we build all the other orbitals by imposing w_R(g) = e^(igR) w_0(g) - ! - WRITE( stdout, 301 ) - ! - DO i = 1, mp1 - DO j = 1, mp2 - DO k = 1, mp3 - ! - IF ( i == 1 .and. j == 1 .and. k == 1 ) CYCLE - ! - rvect = (/ float(i-1) / mp1, & - float(j-1) / mp2, & - float(k-1) / mp3 /) - Rvec(:) = rvect(:) - CALL cryst_to_cart( 1, Rvec, at, 1 ) - ! - DO n = 1, norb_pc - ! - counter = counter + 1 - ! - IF ( read_centers ) THEN - ! - centers(:,counter) = centers(:,n) + rvect(:) - spreads(counter) = spreads_(n) - ! - ENDIF - ! - DO ig = 1, ngw - ! - wfc(ig,counter) = wfc(ig,n) * EXP( imag * tpi * DOT_PRODUCT( gx(:,ig), Rvec ) ) - ! - ENDDO - ENDDO - ! - ENDDO - ENDDO - ENDDO - ! - IF ( nspin == 2 ) wfc(:,norb+1:) = wfc(:,1:norb) - ! - IF ( read_centers ) THEN - ! - CALL cryst_to_cart( norb, centers, at, 1 ) - centers = centers * alat * BOHR_RADIUS_ANGS - ! - ENDIF - ! - ! -101 FORMAT( //, 3x, 'Forcing Bloch symmetry on the ', a3, ' orbitals', / & - 3x, '------------------------------------------' ) -201 FORMAT( 5x, 'orbital # ', i3, ' :', 4x, '(', 3f10.6, ' )' ) -202 FORMAT( 3x, 'Taking the first ', i4, ' orbitals as reference' ) -301 FORMAT( /, 3x, 'Building the other orbitals ---> w_Rn(r) = w_0n(r-R)', / ) - ! - ! -END SUBROUTINE symm_wannier_x diff --git a/quantum_espresso/kcp/CPV/turbo.f90 b/quantum_espresso/kcp/CPV/turbo.f90 deleted file mode 100644 index 7d5f9908f..000000000 --- a/quantum_espresso/kcp/CPV/turbo.f90 +++ /dev/null @@ -1,71 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - MODULE turbo - - USE kinds - IMPLICIT NONE - SAVE - - PRIVATE - - LOGICAL :: TTURBO - INTEGER :: NTURBO - COMPLEX(DP), ALLOCATABLE :: turbo_states(:,:) - - PUBLIC :: tturbo, nturbo, turbo_states, turbo_init, allocate_turbo - PUBLIC :: deallocate_turbo - - CONTAINS - - SUBROUTINE turbo_init(tturbo_inp, nturbo_inp) - USE io_global, ONLY: ionode - USE io_global, ONLY: stdout - LOGICAL, INTENT(IN) :: tturbo_inp - INTEGER, INTENT(IN) :: nturbo_inp - tturbo = tturbo_inp - nturbo = nturbo_inp - IF( ionode .AND. tturbo ) THEN - WRITE( stdout,fmt='(/,3X,"TURBO setup, nturbo = ",I10)') nturbo - END IF - RETURN - END SUBROUTINE turbo_init - - SUBROUTINE allocate_turbo( nnr ) - USE io_global, ONLY: ionode, stdout - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - INTEGER :: nnr - INTEGER :: ierr - IF( ionode ) THEN - WRITE( stdout,fmt='(/,3X,"TURBO: allocating ",I10," bytes ")') & - 16*nnr*nturbo - END IF - IF( .NOT. ALLOCATED( turbo_states ) ) THEN - ALLOCATE( turbo_states( nnr, nturbo ), STAT = ierr) - CALL mp_sum( ierr, intra_image_comm ) - IF( ierr /= 0 ) THEN - IF( ionode ) THEN - WRITE( stdout,fmt='(3X,"TURBO: insufficient memory, turbo is switched off ")') - END IF - tturbo = .FALSE. - nturbo = 0 - END IF - END IF - RETURN - END SUBROUTINE allocate_turbo - - SUBROUTINE deallocate_turbo - INTEGER :: ierr - IF( ALLOCATED(turbo_states) ) THEN - DEALLOCATE(turbo_states, STAT=ierr) - IF( ierr /= 0 ) CALL errore(' deallocate_turbo ', ' deallocating turbo_states ', ierr) - END IF - RETURN - END SUBROUTINE deallocate_turbo - - END MODULE turbo diff --git a/quantum_espresso/kcp/CPV/util.f90 b/quantum_espresso/kcp/CPV/util.f90 deleted file mode 100644 index f3db0a231..000000000 --- a/quantum_espresso/kcp/CPV/util.f90 +++ /dev/null @@ -1,122 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - MODULE util - - USE kinds, ONLY : DP - IMPLICIT NONE - SAVE - - PRIVATE - - INTEGER, PARAMETER :: i4b = kind(0) - INTEGER, PARAMETER :: sp = kind(1._DP) - INTEGER, PARAMETER :: spc = kind((1._DP,1._DP)) - INTEGER, PARAMETER :: lgt = kind(.TRUE.) - - INTERFACE swap - MODULE PROCEDURE swap_i, swap_r, swap_rv, swap_c, swap_cv, swap_cm, & - masked_swap_rs, masked_swap_rv, masked_swap_rm - END INTERFACE - - PUBLIC :: swap - -!!***** - CONTAINS -!BL - SUBROUTINE swap_i(a,b) - INTEGER (i4b), INTENT (INOUT) :: a, b - INTEGER (i4b) :: dum - - dum = a - a = b - b = dum - END SUBROUTINE swap_i -!BL - SUBROUTINE swap_r(a,b) - REAL (sp), INTENT (INOUT) :: a, b - REAL (sp) :: dum - - dum = a - a = b - b = dum - END SUBROUTINE swap_r -!BL - SUBROUTINE swap_rv(a,b) - REAL (sp), DIMENSION (:), INTENT (INOUT) :: a, b - REAL (sp), DIMENSION (size(a)) :: dum - - dum = a - a = b - b = dum - END SUBROUTINE swap_rv -!BL - SUBROUTINE swap_c(a,b) - COMPLEX (spc), INTENT (INOUT) :: a, b - COMPLEX (spc) :: dum - - dum = a - a = b - b = dum - END SUBROUTINE swap_c -!BL - SUBROUTINE swap_cv(a,b) - COMPLEX (spc), DIMENSION (:), INTENT (INOUT) :: a, b - COMPLEX (spc), DIMENSION (size(a)) :: dum - - dum = a - a = b - b = dum - END SUBROUTINE swap_cv -!BL - SUBROUTINE swap_cm(a,b) - COMPLEX (spc), DIMENSION (:,:), INTENT (INOUT) :: a, b - COMPLEX (spc), DIMENSION (size(a,1),size(a,2)) :: dum - - dum = a - a = b - b = dum - END SUBROUTINE swap_cm -!BL - SUBROUTINE masked_swap_rs(a,b,mask) - REAL (sp), INTENT (INOUT) :: a, b - LOGICAL (lgt), INTENT (IN) :: mask - REAL (sp) :: swp - - IF (mask) THEN - swp = a - a = b - b = swp - END IF - END SUBROUTINE masked_swap_rs -!BL - SUBROUTINE masked_swap_rv(a,b,mask) - REAL (sp), DIMENSION (:), INTENT (INOUT) :: a, b - LOGICAL (lgt), DIMENSION (:), INTENT (IN) :: mask - REAL (sp), DIMENSION (size(a)) :: swp - - WHERE (mask) - swp = a - a = b - b = swp - END WHERE - END SUBROUTINE masked_swap_rv -!BL - SUBROUTINE masked_swap_rm(a,b,mask) - REAL (sp), DIMENSION (:,:), INTENT (INOUT) :: a, b - LOGICAL (lgt), DIMENSION (:,:), INTENT (IN) :: mask - REAL (sp), DIMENSION (size(a,1),size(a,2)) :: swp - - WHERE (mask) - swp = a - a = b - b = swp - END WHERE - END SUBROUTINE masked_swap_rm -!BL -!BL - END MODULE util diff --git a/quantum_espresso/kcp/CPV/vanderwaals.f90 b/quantum_espresso/kcp/CPV/vanderwaals.f90 deleted file mode 100644 index dbf9e7d35..000000000 --- a/quantum_espresso/kcp/CPV/vanderwaals.f90 +++ /dev/null @@ -1,454 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - module vanderwaals - - USE kinds - IMPLICIT NONE - SAVE - - PRIVATE - - logical :: tvdw = .false. - - PUBLIC :: vdw, tvdw - - contains - - -!--------------------------------- - subroutine VdW(evdw, taus, nat, na, nsp, fion, box) - - USE constants, ONLY: au => BOHR_RADIUS_ANGS - USE cell_base, ONLY: s_to_r, boxdimensions, pbcs - USE mp_global, ONLY: me_image, root_image - -! -! taus == atomic positions in scaled coordinates -! nat == numero atomi -! na(s) == numero atomi per la specie s -! nsp(1) == numero atomi specie 1 -! x,y,z == coordinate cartesiane -! force == forze -! evdw == energia di VdW -! csp() == coeffic. di VdW -! - implicit none - - REAL(DP), intent(in) :: taus(:,:) - INTEGER, intent(in) :: nat, na(:), nsp - type(boxdimensions), intent(in) :: box - REAL(DP), intent(out) :: evdw - REAL(DP), intent(out) :: fion(:,:) - - REAL(DP) alp,rcc,rcut,cutoff - parameter (alp=2.d0,rcc=6.5d0,rcut=3.0d0,cutoff=14.0d0) - - REAL(DP) csp11, csp12, csp22 - parameter (csp11=1.0191452D0, csp12=0.2239317D0, csp22=0.04364401D0) - - REAL(DP) sij(3),rij(3),sij_image(3) - REAL(DP) csp1, dist, ff,dist6,fun,fact - REAL(DP) force( 3, nat ) - integer i,j,is,js,ia,ja,ix,iy,iz,iesr - logical:: tzero,tshift - - force=0.d0 - evdw =0.d0 - iesr=1 - - if(nsp.ne.2 .or. .not.tvdw) then - return - endif - - do i=1,nat - - if(i.le.na(1)) then - ia = i - is = 1 - else - ia = i - na(1) - is = 2 - end if - - do j=1,nat - - if(j.le.na(1)) then - ja = j - js = 1 - else - ja = j - na(1) - js = 2 - end if - - if (i.eq.j) then - sij=0.d0 - tzero=.true. - else - tzero=.false. - sij = taus(:,i) - taus(:,j) - CALL PBCS(sij(1),sij(2),sij(3),sij(1),sij(2),sij(3),1) - end if - - do ix=-iesr,iesr - sij_image(1)= sij(1)+DBLE(ix) - do iy=-iesr,iesr - sij_image(2)= sij(2)+DBLE(iy) - do iz=-iesr,iesr - sij_image(3)= sij(3)+DBLE(iz) - tshift=ix.eq.0 .and. iy.eq.0 .and. iz.eq.0 - if(.not.(tzero.and.tshift)) then - call s_to_r(sij_image,rij,box) - dist = ( rij(1)**2 + rij(2)**2 + rij(3)**2 )**0.5d0 -! -! ... c-c vdw coefficient -! - CSP1 = csp11 -! -! ... c-h vdw coefficient -! - if ( (i.le.na(1).and.j.gt.na(1)) .or. & - (i.gt.na(1).and.j.le.na(1)) ) then - CSP1 = csp12 - end if -! -! ... h-h vdw coefficient -! - if (i.gt.na(1).and.j.gt.na(1)) then - CSP1 = csp22 - end if -! -! ... apply lower boundary cut-off -! - if(dist.lt.rcut) then - dist = rcut - end if - - ff = alp * (rcc - dist) - dist6 = dist**6 - fun = - CSP1 / dist6 * cutofun_vdw(ff) / (au)**6 - - if(dist.lt.rcut) then - fact = 0.d0 - else - fact = (6.d0 * CSP1/dist**7 * cutofun_vdw(ff) + & - alp * dcutofun_vdw(ff) * CSP1/dist6) / (au)**6 - endif - - evdw = evdw + fun - force(1,i) = force(1,i) - fact * rij(1) / dist - force(2,i) = force(2,i) - fact * rij(2) / dist - force(3,i) = force(3,i) - fact * rij(3) / dist - endif - enddo !iz - enddo !iy - enddo !ix - enddo !j - enddo !i - evdw=evdw/2.d0 - - IF( me_image == root_image ) THEN - fion( :, 1:nat ) = fion( :, 1:nat ) + force( :, 1:nat ) - END IF - - return - end subroutine vdw - -!================================================================== - - function cutofun_vdw(xin) - implicit none - - REAL(DP) cutofun_vdw - REAL(DP), intent(in) :: xin - REAL(DP) x - - if( xin .gt. 30.d0 ) then - x = 30.d0 - else - x = xin - endif - cutofun_vdw = 1.d0 / (exp(x) + 1.d0) - - return - end function cutofun_vdw -!================================================================== c -!================================================================== - function dcutofun_vdw(xin) - implicit none - - REAL(DP) dcutofun_vdw - REAL(DP), intent(in) :: xin - REAL(DP) x - - if( xin .gt. 30.d0 ) then - x = 30.d0 - else - x = xin - endif - dcutofun_vdw = - exp(x) / (exp(x) + 1.d0)**2 - - return - end function dcutofun_vdw -!================================================================== - - - - - subroutine baricentro(bar,vectors,nvec) - implicit none - integer, intent(in) :: nvec - REAL(DP), intent(out) :: bar(3) - REAL(DP), intent(in) :: vectors(3,nvec) - integer i,j - do i = 1,3 - bar(i) = 0.0d0 - do j = 1,nvec - bar(i) = bar(i) + vectors(i,j) - end do - bar(i) = bar(i) / DBLE(nvec) - end do - return - end subroutine baricentro - - REAL(DP) function distanza(u,v) - implicit none - REAL(DP) u(3),v(3) - distanza = (u(1)-v(1))**2 + (u(2)-v(2))**2 + (u(3)-v(3))**2 - distanza = sqrt(distanza) - return - end function distanza - - - -! REAL(DP) FUNCTION VDW_FORCES(C6,IESR,FION,STAU0,NA,NAX,NSP) -! -! USE cell_base, only: R_TO_S, S_TO_R -! -! implicit none -! -! REAL(DP) c6 -! integer iesr -! REAL(DP) fion(3,nax,nsp) -! REAL(DP) stau0(3,nax,nsp) -! integer na(nsp) -! integer nax,nsp -! -! REAL(DP) EVDW -! REAL(DP) distanza -! integer i,j,k,ix,iy,iz,infm,m,l,ishft,im -! REAL(DP) XLM, YLM, ZLM, ZERO -! REAL(DP) sxlm(3),rxlm(3),ERRE2,RLM,ADDEVDW,ADDPRE -! REAL(DP) FXX, REPAND -! REAL(DP) molbar(3,NAX) -! REAL(DP) molecola(3,NAX),tau(3),rdis -! REAL(DP) fmol(3,NAX) -! REAL(DP) bond_len_au -! integer iatmol(NAX,NSP),imol,nmol,natmol -! logical TZERO -! -! -! bond_len_au = 2.0d0 -! imol = 1 -! do i=1,na(1) -! im = 1 -! call S_TO_R(stau0(1,i,1),molecola(1,im)) -! iatmol(i,1) = im -! im = im + 1 -! do j = 1,na(2) -! call S_TO_R(stau0(1,j,2),tau) -! rdis = distanza(molecola(1,1),tau) -! if(rdis.lt.bond_len_au) then -! call S_TO_R(stau0(1,j,2),molecola(1,im)) -! iatmol(j,2) = im -! im = im + 1 -! end if -! end do -! natmol = im - 1 -! call baricentro(tau,molecola,natmol) -! call r_to_s(tau,molbar(1,imol)) -! imol = imol + 1 -! end do -! nmol = imol - 1 -! -! -! -! EVDW = 0.D0 -! -! call azzera(fmol,3*nax) -! DO L=1,nmol -! DO M= L,nmol -! IF(L.EQ.M) THEN -! XLM=0.D0 -! YLM=0.D0 -! ZLM=0.D0 -! TZERO=.TRUE. -! ELSE -! TZERO=.FALSE. -! XLM = molbar(1,l) - molbar(1,m) -! YLM = molbar(2,l) - molbar(2,m) -! ZLM = molbar(3,l) - molbar(3,m) -! CALL PBCS(XLM,YLM,ZLM,XLM,YLM,ZLM,1) -! END IF -! DO IX=-IESR,IESR -! DO IY=-IESR,IESR -! DO IZ=-IESR,IESR -! ISHFT=IX*IX+IY*IY+IZ*IZ -! IF(.NOT.(TZERO.AND.ISHFT.EQ.0)) THEN -! sxlm(1) = XLM + DBLE(IX) -! sxlm(2) = YLM + DBLE(IY) -! sxlm(3) = ZLM + DBLE(IZ) -! CALL S_TO_R(sxlm,rxlm) -! ERRE2 = rxlm(1)**2 + rxlm(2)**2 + rxlm(3)**2 -! RLM = SQRT(ERRE2) -! IF (TZERO) THEN -! ZERO=0.5D0 -! ELSE -! ZERO=1.D0 -! END IF -! ADDEVDW = - C6 / RLM**6 -! EVDW = EVDW + ZERO*ADDEVDW -! ADDPRE = - 6.0D0 * C6 /RLM**8 -! REPAND = ZERO*(ADDEVDW + ADDPRE) -! DO I=1,3 -! FXX = REPAND*rxlm(I) -! FMOL(I,L) = FMOL(I,L) + FXX -! FMOL(I,M) = FMOL(I,M) - FXX -! END DO -! END IF -! END DO ! IZ -! END DO ! IY -! END DO ! IX -! END DO ! M -! END DO ! L -! -! do i=1,nsp -! do j=1,na(i) -! do k=1,3 -! fion(k,j,i)=fion(k,j,i)+fmol(k,iatmol(j,i))/REAL(natmol) -! end do -! end do -! end do -! -! VDW_FORCES = EVDW -! return -! end FUNCTION VDW_FORCES -! -! -! subroutine VDW_STRESS(C6,IESR,STAU0,DVDW,NA,NAX,NSP) -! -! USE cell_base, only: R_TO_S, S_TO_R -! -! implicit none -! -! REAL(DP) c6 -! integer iesr -! REAL(DP) stau0(3,nax,nsp) -! REAL(DP) dvdw(6) -! integer na(nsp) -! integer nax,nsp -! -! REAL(DP) distanza -! integer i,j,k,ix,iy,iz,infm,m,l,ishft,im -! REAL(DP) XLM, YLM, ZLM, ZERO -! REAL(DP) sxlm(3),rxlm(3),ERRE2,RLM,ADDEVDW,ADDPRE -! REAL(DP) FXX, REPAND -! REAL(DP) molbar(3,NAX) -! REAL(DP) molecola(3,NAX),tau(3),rdis -! REAL(DP) bond_len_au -! integer iatmol(NAX,NSP),imol,nmol,natmol -! integer alpha(6),beta(6) -! logical TZERO -! -! ALPHA(1) = 1 -! ALPHA(2) = 2 -! ALPHA(3) = 3 -! ALPHA(4) = 2 -! ALPHA(5) = 3 -! ALPHA(6) = 3 -! BETA(1) = 1 -! BETA(2) = 1 -! BETA(3) = 1 -! BETA(4) = 2 -! BETA(5) = 2 -! BETA(6) = 3 -! -! do i=1,6 -! dvdw(i) = 0.0d0 -! end do -! -! bond_len_au = 2.0d0 -! imol = 1 -! do i=1,na(1) -! im = 1 -! call S_TO_R(stau0(1,i,1),molecola(1,im)) -! iatmol(i,1) = im -! im = im + 1 -! do j = 1,na(2) -! call S_TO_R(stau0(1,j,2),tau) -! rdis = distanza(molecola(1,1),tau) -! if(rdis.lt.bond_len_au) then -! call S_TO_R(stau0(1,j,2),molecola(1,im)) -! iatmol(j,2) = im -! im = im + 1 -! end if -! end do -! natmol = im - 1 -! call baricentro(tau,molecola,natmol) -! call r_to_s(tau,molbar(1,imol)) -! imol = imol + 1 -! end do -! nmol = imol - 1 -! -! -! DO L=1,nmol -! DO M= L,nmol -! IF(L.EQ.M) THEN -! XLM=0.D0 -! YLM=0.D0 -! ZLM=0.D0 -! TZERO=.TRUE. -! ELSE -! TZERO=.FALSE. -! XLM = molbar(1,l) - molbar(1,m) -! YLM = molbar(2,l) - molbar(2,m) -! ZLM = molbar(3,l) - molbar(3,m) -! CALL PBCS(XLM,YLM,ZLM,XLM,YLM,ZLM,1) -! END IF -! DO IX=-IESR,IESR -! DO IY=-IESR,IESR -! DO IZ=-IESR,IESR -! ISHFT=IX*IX+IY*IY+IZ*IZ -! IF(.NOT.(TZERO.AND.ISHFT.EQ.0)) THEN -! sxlm(1) = XLM + DBLE(IX) -! sxlm(2) = YLM + DBLE(IY) -! sxlm(3) = ZLM + DBLE(IZ) -! CALL S_TO_R(sxlm,rxlm) -! ERRE2 = rxlm(1)**2 + rxlm(2)**2 + rxlm(3)**2 -! RLM = SQRT(ERRE2) -! IF (TZERO) THEN -! ZERO=0.5D0 -! ELSE -! ZERO=1.D0 -! END IF -! ADDPRE = - 6.0D0 * C6 /RLM**8 -! REPAND = ZERO * ADDPRE -! DO I=1,6 -! FXX = REPAND*rxlm(ALPHA(I))*rxlm(BETA(I)) -! DVDW(I) = DVDW(I) - FXX -! END DO -! END IF -! END DO ! IZ -! END DO ! IY -! END DO ! IX -! END DO ! M -! END DO ! L -! -! return -! end SUBROUTINE VDW_STRESS - - end module vanderwaals diff --git a/quantum_espresso/kcp/CPV/vol_clu.f90 b/quantum_espresso/kcp/CPV/vol_clu.f90 deleted file mode 100644 index e309ff8b1..000000000 --- a/quantum_espresso/kcp/CPV/vol_clu.f90 +++ /dev/null @@ -1,420 +0,0 @@ -! -! Copyright (C) 2002-2007 Quantum-Espresso groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -#include "f_defs.h" - -!---------------------------------------------------------------------- - subroutine vol_clu(rho_real,rho_g,flag) -!---------------------------------------------------------------------- -! it computes the volume of the cluster (cluster calculations) starting -! from the measure of the region of space occupied by the electronic density -! above a given threshold - - use cell_base - use electrons_base - use ions_base - use ions_positions, only: tau0 - use constants, only: pi - use parameters - use reciprocal_vectors - use gvecs - use gvecp, only: ngm - use recvecs_indexes - use cp_main_variables, only: drhor - use control_flags, only: tpre - use local_pseudo - USE cp_interfaces, ONLY: fwfft, invfft - use grid_dimensions, only: nr1, nr2, nr3, nnr => nnrx - use pres_ai_mod, only: rho_thr, n_cntr, cntr, step_rad, fill_vac, & - & delta_eps, delta_sigma, axis, & - & abisur, dthr, Surf_t, rho_gaus, v_vol, & - & posv, xc0, weight, volclu, stress_vol, & - & surfclu, n_ele, jellium, R_j, h_j, e_j, & - & nelect, P_ext - use fft_base -#ifdef __PARA - use mp_global, only: nproc, mpime - USE mp, ONLY: mp_bcast, mp_sum - USE mp_global, ONLY: intra_image_comm -#endif - - implicit none - -#ifdef __PARA - include 'mpif.h' -#endif - - real(kind=8) dx, dxx, xcc(4500) - real(kind=8) weight0, wpiu, wmeno - real(kind=8) tau00(3), dist - real(kind=8) rho_real(nnr,nspin), rhoc - real(kind=8) alfa(nsx), alfa0, sigma, hgt - real(kind=8) pos_aux(3) - real(kind=8) dpvdh(3,3) - real(kind=8) mtot, rad0, cm(3) - real(kind=8) modr, lap - real(kind=8) prod, aux1 - real(kind=8) gxl, xyr, xzr, yzr - real(kind=8), allocatable:: drho(:,:), d2rho(:,:) - real(kind=8), allocatable:: dxdyrho(:), dxdzrho(:) - real(kind=8), allocatable:: dydzrho(:) - real(kind=8), allocatable:: tauv(:,:,:) - - complex(kind=8) ci - complex(kind=8) aux, fact, rho_g(ngm,nspin) - complex(kind=8), allocatable :: psi(:), rhofill(:), rhotmp(:,:) - - integer ir, ir1, ir2, ir3, is, iss, ia, flag - integer i, j, k, ig, cnt, n_at - -#ifdef __PARA - integer shift(nproc), ppp(nproc) - integer ip, me -#endif - if (abisur) allocate(drho(3,nnr)) - if (abisur) allocate(d2rho(3,nnr)) - if (abisur) allocate(dxdyrho(nnr)) - if (abisur) allocate(dxdzrho(nnr)) - if (abisur) allocate(dydzrho(nnr)) - allocate(psi(nnr)) - - call start_clock( 'vol_clu' ) - - ci = (0.d0,1.d0) - -#ifdef __PARA - me = mpime + 1 - do ip=1,nproc - ppp(ip) = dfftp%nnp * ( dfftp%npp(ip) ) - if (ip.eq.1) then - shift(ip)=0 - else - shift(ip)=shift(ip-1) + ppp(ip-1) - end if - end do -#endif - - sigma = rho_thr/3.d0 !3.d0 - hgt = 0.0050d0 !5000.d0*rho_thr -! We smear the step function defining the volume and approximate its derivative -! with a gaussian. Here we sample the integral of this gaussian. It has to -! be done once for ever - dx = 5.d0*sigma/60.d0 - if (flag.eq.1) then - dxx = dx/40.d0 - weight(1) = 0.d0 - xcc(1) = rho_thr - 5.d0*sigma - xc0(1) = xcc(1) - cnt = 1 - do i = 2,121 - weight(i) = weight(i-1) - do j = 1,40 - cnt = cnt + 1 - xcc(cnt) = xcc(cnt-1) + dxx - if (j.eq.40) then - xc0(i) = xcc(cnt) - end if - aux1 = xcc(cnt)-dxx/2.d0-rho_thr - weight(i) = weight(i) + 1.d0/(sigma*dsqrt(pi*2.d0)) * & - & dxx * dexp(-1.d0*aux1**2/(2.d0*sigma**2)) - end do - end do -! This doesn't work yet..... - if (jellium) then - do ir3 = 1,nr3 - do ir2 = 1,nr2 - do ir1 = 1,nr1 - ir = ir1 + (ir2-1)*nr1 + (ir3-1)*nr2*nr1 - dist = 0.d0 - do i = 1,3 - posv(i,ir) = (DBLE(ir1)-1.0d0)*a1(i)/DBLE(nr1) +& - & (DBLE(ir2)-1.0d0)*a2(i)/DBLE(nr2) +& - & (DBLE(ir3)-1.0d0)*a3(i)/DBLE(nr3) - end do - end do - end do - end do - end if - end if - - n_at = MAXVAL ( na(1:nsp) ) - allocate ( tauv(3,n_at,nsp) ) - n_at = 0 - do is = 1,nsp - alfa(is) = step_rad(is)/2.d0 - do ia = 1,na(is) - n_at = n_at + 1 - do k = 1,3 - tauv(k,ia,is) = tau0(k,n_at) - end do - end do - end do - - stress_vol = 0.d0 - dpvdh = 0.d0 - -! Now we compute the volume and other quantities - - volclu = 0.d0 - n_ele = 0.d0 - surfclu = 0.d0 - -! Let's add rhops to fill possible holes in the valence charge density on top -! of the ions - - allocate(rhotmp(ngm,nspin)) - rhotmp = CMPLX(0.d0,0.d0) - - if (nspin.eq.1) then - do ig = 1,ngm - rhotmp(ig,1)=rho_g(ig,1) - end do - else - do ig = 1,ngm - do iss = 1,2 - rhotmp(ig,iss) = rho_g(ig,iss) - end do - end do - end if - -! To fill the vacuum inside hollow structures - - if (fill_vac) then - allocate(rhofill(ngm)) - rhofill = 0.d0 - do k = 1,3 - cm(k) = 0.d0 - mtot = 0.d0 - do is = 1,nsp - do ia = 1,na(is) - cm(k) = cm(k) + tauv(k,ia,is)*pmass(is) - end do - mtot = mtot + pmass(is) - end do - cm(k) = cm(k)/mtot - end do - end if - - if (fill_vac) then - do i = 1,n_cntr - do is = 1,nsp - if (cntr(is)) then - rad0 = step_rad(is) + DBLE(i)*delta_sigma - alfa0 = rad0/2.d0 - do ia = 1,na(is) - do k = 1,3 - if (k.ne.axis) then - tau00(k) = (tauv(k,ia,is)-cm(k))* & - & (1.d0-delta_eps*DBLE(i))+cm(k) - else - tau00(k) = tauv(k,ia,is) - end if - end do - do ig = 1,ngm - prod = 0.d0 - do k = 1,3 - prod = prod + gx(k,ig)*tau00(k) - end do - prod = prod*tpiba - fact = CMPLX(dcos(prod),-1.d0*dsin(prod)) - aux = alfa0*hgt*dexp(-0.50d0*alfa0**2*g(ig)*tpiba2) - rhofill(ig) = rhofill(ig) + aux*fact - end do - end do - end if - end do - end do - if (nspin.eq.1) then - do ig=1,ngm - rhotmp(ig,1) = rhotmp(ig,1) + rhofill(ig) - end do - else - do ig = 1,ngm - do iss = 1,2 - rhotmp(ig,iss) = rhotmp(ig,iss) + 0.5d0*rhofill(ig) - end do - end do - end if - end if - - if (fill_vac) then - deallocate(rhofill) - end if - - if (abisur) & - & call gradrho(nspin,rhotmp,drho,d2rho,dxdyrho,dxdzrho,dydzrho) - - psi = CMPLX(0.d0,0.d0) - if (nspin.eq.1) then - do ig = 1,ngm - psi(np(ig)) = rhotmp(ig,1) - psi(nm(ig)) = conjg(rhotmp(ig,1)) - end do - call invfft('Dense',psi, dfftp ) - do ir = 1,nnr - rho_gaus(ir) = real(psi(ir)) - end do - else - do ig = 1,ngm - psi(np(ig)) = rhotmp(ig,1) + ci*rhotmp(ig,2) - psi(nm(ig)) = conjg(rhotmp(ig,1)) + ci*conjg(rhotmp(ig,2)) - end do - call invfft('Dense',psi, dfftp ) - do ir = 1,nnr - rho_gaus(ir) = real(psi(ir))+aimag(psi(ir)) - end do - end if - deallocate(psi) - deallocate(rhotmp) - - e_j = 0.d0 - - do ir = 1,nnr - - v_vol(ir) = 0.d0 - - if (jellium) then -#ifdef __PARA - do j = 1,3 - pos_aux(j) = posv(j,ir+shift(me)) - end do -#else - do j = 1,3 - pos_aux(j) = posv(j,ir) - end do -#endif - dist = 0.d0 - do j = 1,3 - dist = dist + (pos_aux(j) - 0.5d0*(a1(j)+a2(j)+a3(j)))**2 - end do - dist = dsqrt(dist) - if (dist.ge.R_j) then - v_vol(ir) = - nelect/dist - v_vol(ir) = 0.d0 - else -! The last term in the internal potential is for its continuity - v_vol(ir) = + 0.5d0*nelect*dist**2/R_j**3 & - - 1.5d0*nelect/R_j - v_vol(ir) = - h_j - end if - if (nspin.eq.1) then - e_j = e_j + v_vol(ir) * rho_real(ir,1) * omega / & - & DBLE(nr1*nr2*nr3) - else - e_j = e_j + v_vol(ir) * & - ( rho_real(ir,1) + rho_real(ir,2) ) * omega / & - & DBLE(nr1*nr2*nr3) - end if - end if - - rhoc = rho_gaus(ir) -! Volume and surface - if (rhoc.gt.rho_thr+5.d0*sigma) then - weight0 = 1.d0 - wpiu = 1.d0 - i = int((rhoc-rho_thr-dthr+5.d0*sigma)/dx) + 1 - if (i.gt.120) then - wmeno = 1.d0 - else - wmeno = weight(i) + (weight(i+1)-weight(i)) * & - & (rhoc-rho_thr-dthr-DBLE(i-1)*dx+5.d0*sigma)/dx - end if - go to 79 - end if -! Volume and surface - k = int((rhoc-rho_thr+5.d0*sigma)/dx) + 1 - weight0 = weight(k) + (weight(k+1)-weight(k)) * & - (rhoc-rho_thr+5.d0*sigma-DBLE(k-1)*dx)/dx - if (abisur) then - if (rhoc-rho_thr+dthr.gt.5.d0*sigma) then - wpiu = weight0 - i = int((rhoc-rho_thr-dthr+5.d0*sigma)/dx) + 1 - wmeno = weight(i)+(weight(i+1)-weight(i))* & - & (rhoc-rho_thr-dthr+5.d0*sigma-DBLE(i-1)*dx)/dx - else if (rho_thr+dthr-rhoc.gt.5.d0*sigma) then - wmeno = 0.d0 - i = int((rhoc-rho_thr+dthr+5.d0*sigma)/dx) + 1 - wpiu = weight0 - else - i = int((rhoc-rho_thr+dthr+5.d0*sigma)/dx) + 1 - wpiu = weight0 - i = int((rhoc-rho_thr-dthr+5.d0*sigma)/dx) + 1 - wmeno = weight(i)+(weight(i+1)-weight(i))* & - & (rhoc-rho_thr-dthr+5.d0*sigma-DBLE(i-1)*dx)/dx - end if - end if - 79 continue - if (nspin.eq.1) then - n_ele = n_ele + weight0 * rho_real(ir,1) - else - n_ele = n_ele + weight0 * (rho_real(ir,1) + rho_real(ir,2)) - end if - volclu = volclu + weight0 - v_vol(ir) = v_vol(ir) + P_ext /(sigma*dsqrt(pi*2.d0)) * & - & dexp(-1.d0*(rhoc-rho_thr)**2/(2.d0*sigma**2)) - if (tpre) then - do k = 1,3 - do j = 1,3 - do is = 1,nspin - dpvdh(k,j) = dpvdh(k,j) + & - & v_vol(ir)*drhor(ir,is,k,j)*omega/ & - & DBLE(nr1*nr2*nr3) - end do - end do - end do - end if - - if (abisur) then - modr = 0.d0 - lap = 0.d0 - gxl = 0.d0 - do j = 1,3 - modr = modr + drho(j,ir)**2 - lap = lap + d2rho(j,ir) - gxl = gxl + drho(j,ir)**2*d2rho(j,ir) - end do - xyr = 2.d0*dxdyrho(ir)*drho(1,ir)*drho(2,ir) - xzr = 2.d0*dxdzrho(ir)*drho(1,ir)*drho(3,ir) - yzr = 2.d0*dydzrho(ir)*drho(2,ir)*drho(3,ir) - modr = dsqrt(modr) - surfclu = surfclu + (wpiu-wmeno)*modr - v_vol(ir) = v_vol(ir) -1.d0*Surf_t/dthr * (wpiu-wmeno) * & - & (lap/modr - (gxl + xyr + xzr + yzr)/modr**3) - end if - - end do - -#ifdef __PARA - call mp_sum(volclu,intra_image_comm) - call mp_sum(n_ele,intra_image_comm) - if (jellium) call mp_sum(e_j,intra_image_comm) - call mp_sum(surfclu,intra_image_comm) - call mp_sum(dpvdh,intra_image_comm) -#endif - volclu = volclu * omega / DBLE(nr1*nr2*nr3) - n_ele = n_ele * omega / DBLE(nr1*nr2*nr3) - surfclu = surfclu * omega / DBLE(nr1*nr2*nr3) / dthr - do i = 1,3 - do j = 1,3 - stress_vol(i,j) = dpvdh(i,1)*h(j,1) + dpvdh(i,2)*h(j,2) + & - & dpvdh(i,3)*h(j,3) - end do - end do - - deallocate( tauv ) - if ( abisur ) deallocate( drho ) - if ( abisur ) deallocate( d2rho ) - if ( abisur ) deallocate( dxdyrho ) - if ( abisur ) deallocate( dxdzrho ) - if ( abisur ) deallocate( dydzrho ) - - call stop_clock( 'vol_clu' ) - - return - end - diff --git a/quantum_espresso/kcp/CPV/wannier.f90 b/quantum_espresso/kcp/CPV/wannier.f90 deleted file mode 100644 index 5273b64cd..000000000 --- a/quantum_espresso/kcp/CPV/wannier.f90 +++ /dev/null @@ -1,868 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! ... wannier function dynamics and electric field -! - M.S -#include "f_defs.h" -! -!---------------------------------------------------------------------------- -MODULE efcalc - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - USE wannier_base, ONLY : wf_efield, wf_switch - USE wannier_base, ONLY : efx0, efy0, efz0, efx1, efy1, efz1, sw_len - ! - IMPLICIT NONE - ! - REAL(DP) :: efx, efy, efz, sw_step - REAL(DP), ALLOCATABLE :: xdist(:), ydist(:), zdist(:) - ! - CONTAINS - ! - !-------------------------------------------------------------------------- - SUBROUTINE clear_nbeg( nbeg ) - !-------------------------------------------------------------------------- - ! - ! ... some more electric field stuff - ! - M.S - ! - INTEGER, INTENT(OUT) :: nbeg - ! - ! - IF ( wf_efield ) THEN - ! - IF ( wf_switch ) THEN - ! - WRITE( stdout, '(/,5X,"!----------------------------------!")' ) - WRITE( stdout, '( 5X,"! !")' ) - WRITE( stdout, '( 5X,"! ADIABATIC SWITCHING OF THE FIELD !")' ) - WRITE( stdout, '( 5X,"! !")' ) - WRITE( stdout, '( 5X,"!----------------------------------!",/)' ) - ! - nbeg=0 - ! - END IF - ! - END IF - ! - RETURN - ! - END SUBROUTINE clear_nbeg - ! - !-------------------------------------------------------------------------- - SUBROUTINE ef_force( fion, na, nsp, zv ) - !-------------------------------------------------------------------------- - ! - ! ... Electric Feild for ions here - ! - IMPLICIT NONE - ! - REAL(DP) :: fion(:,:), zv(:) - INTEGER :: na(:), nsp - INTEGER :: is, ia, isa - ! - IF ( wf_efield ) THEN - ! - isa = 0 - ! - DO is =1, nsp - ! - DO ia = 1, na(is) - ! - isa = isa + 1 - ! - fion(1,isa) = fion(1,isa) + efx * zv(is) - fion(2,isa) = fion(2,isa) + efy * zv(is) - fion(3,isa) = fion(3,isa) + efz * zv(is) - ! - END DO - ! - END DO - ! - END IF - ! - RETURN - ! - END SUBROUTINE ef_force - ! - ! - SUBROUTINE deallocate_efcalc() - IF( ALLOCATED( xdist ) ) DEALLOCATE( xdist ) - IF( ALLOCATED( ydist ) ) DEALLOCATE( ydist ) - IF( ALLOCATED( zdist ) ) DEALLOCATE( zdist ) - END SUBROUTINE deallocate_efcalc - ! -END MODULE efcalc -! -!-------------------------------------------------------------------------- -MODULE tune - !-------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - ! - LOGICAL :: shift - INTEGER :: npts, av0, av1, xdir, ydir, zdir, start - REAL(DP) :: alpha, b - ! -END MODULE tune -! -!-------------------------------------------------------------------------- -MODULE wannier_module - !-------------------------------------------------------------------------- - ! - ! ... In the presence of an electric field every wannier state feels a - ! ... different potantial, which depends on the position of its center. - ! ... RHOS is read in as the charge density in subrouting vofrho and - ! ... overwritten to be the potential. - ! ... -M.S - ! - USE kinds, ONLY : DP - ! - IMPLICIT NONE - ! - SAVE - ! - LOGICAL :: what1, wann_calc - REAL(DP) :: wfx, wfy, wfz, ionx, iony, ionz - REAL(DP), ALLOCATABLE :: utwf(:,:) - REAL(DP), ALLOCATABLE :: wfc(:,:) - REAL(DP), ALLOCATABLE :: rhos1(:,:), rhos2(:,:) - COMPLEX(DP), ALLOCATABLE :: rhogdum(:,:) - ! - CONTAINS - ! - !------------------------------------------------------------------------ - SUBROUTINE allocate_wannier( nbsp, nnrsx, nspin, ng ) - !------------------------------------------------------------------------ - ! - INTEGER, INTENT(in) :: nbsp, nnrsx, nspin, ng - ! - ALLOCATE( utwf( nbsp, nbsp ) ) - ALLOCATE( wfc( 3, nbsp ) ) - ALLOCATE( rhos1( nnrsx, nspin) ) - ALLOCATE( rhos2( nnrsx, nspin) ) - ALLOCATE( rhogdum( ng, nspin ) ) - ! - RETURN - ! - END SUBROUTINE allocate_wannier - ! - !------------------------------------------------------------------------ - SUBROUTINE deallocate_wannier() - !------------------------------------------------------------------------ - ! - IF ( ALLOCATED( utwf ) ) DEALLOCATE( utwf ) - IF ( ALLOCATED( wfc ) ) DEALLOCATE( wfc ) - IF ( ALLOCATED( rhos1 ) ) DEALLOCATE( rhos1 ) - IF ( ALLOCATED( rhos2 ) ) DEALLOCATE( rhos2 ) - IF ( ALLOCATED( rhogdum ) ) DEALLOCATE( rhogdum ) - ! - RETURN - ! - END SUBROUTINE deallocate_wannier - ! -END MODULE wannier_module -! -!-------------------------------------------------------------------------- -MODULE electric_field_module - !-------------------------------------------------------------------------- - ! - ! ... 1 Volt / meter = 1/(5.1412*1.e+11) a.u. - ! - USE kinds, ONLY : DP - ! - IMPLICIT NONE - ! - SAVE - ! - LOGICAL :: field_tune, ft - REAL(DP) :: efe_elec, efe_ion, prefactor, e_tuned(3) - REAL(DP) :: tt(3), cdmm(3), tt2(3) - REAL(DP) :: par, alen, blen, clen, rel1(3), rel2(3) - ! -END MODULE electric_field_module -! -!-------------------------------------------------------------------------- -MODULE wannier_subroutines - !-------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout, ionode - ! - IMPLICIT NONE - SAVE - ! - INTERFACE wf_closing_options - module procedure wf_closing_options_real, wf_closing_options_twin - END INTERFACE - - CONTAINS - ! - !------------------------------------------------------------------------ - SUBROUTINE wannier_startup( ibrav, alat, a1, a2, a3, b1, b2, b3 ) - !------------------------------------------------------------------------ - ! - USE wannier_module, ONLY : utwf - USE efcalc, ONLY : wf_efield, efx0, efy0, efz0, & - efx1, efy1, efz1, wf_switch, sw_len - USE wannier_base, ONLY : calwf, wfsd, wfdt, maxwfdt, nsd, nit, & - wf_q, wf_friction, nsteps - USE printout_base, ONLY : printout_base_name - ! - IMPLICIT NONE - ! - INTEGER :: ibrav - REAL(DP) :: a1(3), a2(3), a3(3) - REAL(DP) :: b1(3), b2(3), b3(3) - REAL(DP) :: alat - CHARACTER(LEN=256) :: fname - ! - INTEGER :: i - ! - ! ... More Wannier and Field Initialization - ! - IF (calwf.GT.1) THEN - IF (calwf.EQ.3 .AND. ionode ) THEN - WRITE( stdout, * ) "------------------------DYNAMICS IN THE WANNIER BASIS--------------------------" - WRITE( stdout, * ) " DYNAMICS PARAMETERS " - IF (wfsd == 1) THEN - WRITE( stdout, 12125) wf_q - WRITE( stdout, 12126) wfdt - WRITE( stdout, 12124) wf_friction - WRITE( stdout, * ) nsteps,"STEPS OF DAMPED MOLECULAR DYNAMICS FOR OPTIMIZATION OF THE SPREAD" - ELSE IF (wfsd == 2) THEN - WRITE( stdout, 12132) wfdt - WRITE( stdout, 12133) maxwfdt - WRITE( stdout, * ) nsd,"STEPS OF STEEPEST DESCENT FOR OPTIMIZATION OF THE SPREAD" - WRITE( stdout, * ) nit-nsd,"STEPS OF CONJUGATE GRADIENT FOR OPTIMIZATION OF THE SPREAD" - ELSE - WRITE( stdout, * ) "USING JACOBI ROTATIONS FOR OPTIMIZATION OF THE SPREAD" - END IF - WRITE( stdout, * ) "AVERAGE WANNIER FUNCTION SPREAD WRITTEN TO FORT.24" - fname = printout_base_name( "spr" ) - WRITE( stdout, * ) "INDIVIDUAL WANNIER FUNCTION SPREAD WRITTEN TO "//TRIM(fname) - fname = printout_base_name( "wfc" ) - WRITE( stdout, * ) "WANNIER CENTERS WRITTEN TO "//TRIM(fname) - WRITE( stdout, * ) "SOME PERTINENT RUN-TIME INFORMATION WRITTEN TO FORT.27" - WRITE( stdout, * ) "-------------------------------------------------------------------------------" - WRITE( stdout, * ) -12124 FORMAT(' DAMPING COEFFICIENT USED FOR WANNIER FUNCTION SPREAD OPTIMIZATION = ',f10.7) -12125 FORMAT(' FICTITIOUS MASS PARAMETER USED FOR SPREAD OPTIMIZATION = ',f7.1) -12126 FORMAT(' TIME STEP USED FOR DAMPED DYNAMICS = ',f10.7) - ! -12132 FORMAT(' SMALLEST TIMESTEP IN THE SD / CG DIRECTION FOR SPREAD OPTIMIZATION= ',f10.7) -12133 FORMAT(' LARGEST TIMESTEP IN THE SD / CG DIRECTION FOR SPREAD OPTIMIZATION = ',f10.7) - END IF - WRITE( stdout, * ) "IBRAV SELECTED:",ibrav - ! - CALL recips( a1, a2, a3, b1, b2, b3 ) - b1 = b1 * alat - b2 = b2 * alat - b3 = b3 * alat - ! - CALL wfunc_init( calwf, b1, b2, b3, ibrav) - ! - WRITE( stdout, * ) - utwf=0.d0 - DO i=1, SIZE( utwf, 1 ) - utwf(i, i)=1.d0 - END DO - END IF - IF(wf_efield) THEN - - CALL grid_map - - IF( ionode ) THEN - WRITE( stdout, * ) "GRID MAPPING DONE" - WRITE( stdout, * ) "DYNAMICS IN THE PRESENCE OF AN EXTERNAL ELECTRIC FIELD" - WRITE( stdout, * ) - WRITE( stdout, * ) "POLARIZATION CONTRIBUTION OUTPUT TO FORT.28 IN THE FOLLOWING FORMAT" - WRITE( stdout, * ) - WRITE( stdout, * ) "EFX, EFY, EFZ, ELECTRIC ENTHALPY(ELECTRONIC), ELECTRIC ENTHALPY(IONIC)" - WRITE( stdout, * ) - WRITE( stdout, '(" E0(x) = ",F10.7)' ) efx0 - WRITE( stdout, '(" E0(y) = ",F10.7)' ) efy0 - WRITE( stdout, '(" E0(z) = ",F10.7)' ) efz0 - WRITE( stdout, '(" E1(x) = ",F10.7)' ) efx1 - WRITE( stdout, '(" E1(y) = ",F10.7)' ) efy1 - WRITE( stdout, '(" E1(z) = ",F10.7)' ) efz1 - ! - IF ( wf_switch ) WRITE( stdout, 12127) sw_len - ! - WRITE( stdout, * ) - ! - END IF - ! -12127 FORMAT(' FIELD WILL BE TURNED ON ADIBATICALLY OVER ',i5,' STEPS') - END IF - ! - RETURN - ! - END SUBROUTINE wannier_startup - ! - !-------------------------------------------------------------------------- - SUBROUTINE get_wannier_center( tfirst, cm, bec, eigr, & - eigrb, taub, irb, ibrav, b1, b2, b3 ) - !-------------------------------------------------------------------------- - ! - USE efcalc, ONLY: wf_efield - USE wannier_base, ONLY: calwf, jwf - USE wannier_module, ONLY: what1, wfc, utwf - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(in) :: tfirst - COMPLEX(DP) :: cm(:,:) - REAL(DP) :: bec(:,:) - COMPLEX(DP) :: eigrb(:,:), eigr(:,:) - INTEGER :: irb(:,:) - REAL(DP) :: taub(:,:) - INTEGER :: ibrav - REAL(DP) :: b1(:), b2(:), b3(:) - ! - ! ... Get Wannier centers for the first step if wf_efield=true - ! - IF ( wf_efield ) THEN - ! - IF ( tfirst ) THEN - ! - what1 = .TRUE. - ! - jwf = 1 - ! - CALL wf( calwf,cm, bec, eigrb, irb, & - b1, b2, b3, utwf, what1, wfc, jwf, ibrav ) - ! - what1 = .FALSE. - ! - END IF - END IF - ! - RETURN - ! - END SUBROUTINE get_wannier_center - ! - !-------------------------------------------------------------------------- - SUBROUTINE ef_tune( rhog, tau0 ) - !-------------------------------------------------------------------------- - ! - USE electric_field_module, ONLY: field_tune, e_tuned - USE wannier_module, ONLY: rhogdum - ! - IMPLICIT NONE - ! - COMPLEX(DP) :: rhog(:,:) - REAL(DP) :: tau0(:,:) - ! - ! ... Tune the Electric field - ! - IF ( field_tune ) THEN - ! - rhogdum = rhog - ! - CALL macroscopic_average( rhogdum, tau0, e_tuned ) - ! - END IF - ! - RETURN - ! - END SUBROUTINE ef_tune - ! - !-------------------------------------------------------------------------- - SUBROUTINE write_charge_and_exit( rhog ) - !-------------------------------------------------------------------------- - ! - USE wannier_base, ONLY : writev - ! - IMPLICIT NONE - ! - COMPLEX(DP) :: rhog(:,:) - ! - ! ... Write chargedensity in g-space - ! - IF ( writev ) THEN - ! - CALL write_rho_g( rhog ) - ! - CALL stop_run( .TRUE. ) - ! - END IF - ! - RETURN - ! - END SUBROUTINE write_charge_and_exit - ! - !-------------------------------------------------------------------------- - SUBROUTINE wf_options( tfirst, nfi, cm, rhovan, bec, eigr, eigrb, & - taub, irb, ibrav, b1, b2, b3, rhor, rhog, rhos, & - enl, ekin ) - !-------------------------------------------------------------------------- - ! - USE wannier_base, ONLY : nwf, calwf, jwf, wffort, iplot, iwf - USE wannier_module, ONLY : what1, wfc, utwf - USE cp_interfaces, ONLY : rhoofr - USE dener, ONLY : denl, dekin6 - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(IN) :: tfirst - INTEGER :: nfi - COMPLEX(DP) :: cm(:,:) - REAL(DP) :: bec(:,:) - REAL(DP) :: rhovan(:,:,:) - COMPLEX(DP) :: eigrb(:,:), eigr(:,:) - INTEGER :: irb(:,:) - REAL(DP) :: taub(:,:) - INTEGER :: ibrav - REAL(DP) :: b1(:), b2(:), b3(:) - COMPLEX(DP) :: rhog(:,:) - REAL(DP) :: rhor(:,:), rhos(:,:) - REAL(DP) :: enl, ekin - ! - INTEGER :: i, j - ! - ! - ! ... Wannier Function options - M.S - ! - jwf=1 - IF (calwf.EQ.1) THEN - DO i=1, nwf - iwf=iplot(i) - j=wffort+i-1 - CALL rhoofr (nfi,cm, irb, eigrb,bec,rhovan,rhor,rhog,rhos,enl,denl,ekin,dekin6,.false.,j) - END DO - ! - CALL stop_run( .TRUE. ) - ! - END IF - ! - IF ( calwf == 2 ) THEN - ! - ! ... calculate the overlap matrix - ! - jwf=1 - ! - CALL wf (calwf,cm,bec,eigrb,irb,b1,b2,b3,utwf,what1,wfc,jwf,ibrav) - ! - CALL stop_run( .TRUE. ) - ! - END IF - ! - IF (calwf.EQ.5) THEN - ! - jwf=iplot(1) - CALL wf (calwf,cm,bec,eigrb,irb,b1,b2,b3,utwf,what1,wfc,jwf,ibrav) - ! - CALL stop_run( .TRUE. ) - ! - END IF - ! - ! ... End Wannier Function options - M.S - ! - RETURN - END SUBROUTINE wf_options - ! - !-------------------------------------------------------------------------- - SUBROUTINE ef_potential( nfi, rhos, bec, deeq, betae, c0, cm, emadt2, emaver, verl1, verl2 ) - !-------------------------------------------------------------------------- - ! - USE efcalc, ONLY : wf_efield, efx, efy, efz, & - efx0, efy0, efz0, efx1, efy1, efz1, & - wf_switch, sw_len, sw_step, xdist, & - ydist, zdist - USE electric_field_module, ONLY : field_tune, e_tuned, par, rel1, rel2 - USE wannier_module, ONLY : rhos1, rhos2, wfc - USE smooth_grid_dimensions, ONLY : nnrsx - USE electrons_base, ONLY : nbsp, nspin, nupdwn, f, ispin - USE cell_base, ONLY : ainv, a1, a2, a3 - USE reciprocal_vectors, ONLY : gstart - USE control_flags, ONLY : tsde - USE wave_base, ONLY : wave_steepest, wave_verlet - USE cp_interfaces, ONLY : dforce - ! - IMPLICIT NONE - ! - INTEGER :: nfi - REAL(DP) :: rhos(:,:) - REAL(DP) :: bec(:,:) - REAL(DP) :: deeq(:,:,:,:) - COMPLEX(DP) :: betae(:,:) - COMPLEX(DP) :: c0( :, : ) - COMPLEX(DP) :: cm( :, : ) - REAL(DP) :: emadt2(:) - REAL(DP) :: emaver(:) - REAL(DP) :: verl1, verl2 - COMPLEX(DP), ALLOCATABLE :: c2( : ), c3( : ) - INTEGER :: i, ir - ! - ! ... Potential for electric field - ! - ALLOCATE( c2( SIZE( c0, 1 ))) - ALLOCATE( c3( SIZE( c0, 1 ))) - - IF(wf_efield) THEN - IF(field_tune) THEN - efx=e_tuned(1) - efy=e_tuned(2) - efz=e_tuned(3) - WRITE( stdout, '(" wf_efield Now ",3(F12.8,1X))' ) efx, efy,efz - ! - ELSE - IF(wf_switch) THEN - par=0.d0 - IF(nfi.LE.sw_len) THEN - sw_step=1.0d0/DBLE(sw_len) - par=nfi*sw_step - IF(efx1.LT.efx0) THEN - efx=efx0-(efx0-efx1)*par**5*(70*par**4-315*par**3+540*par**2-420*par+126) - ELSE - efx=efx0+(efx1-efx0)*par**5*(70*par**4-315*par**3+540*par**2-420*par+126) - END IF - IF(efy1.LT.efy0) THEN - efy=efy0-(efy0-efy1)*par**5*(70*par**4-315*par**3+540*par**2-420*par+126) - ELSE - efy=efy0+(efy1-efy0)*par**5*(70*par**4-315*par**3+540*par**2-420*par+126) - END IF - IF(efz1.LT.efz0) THEN - efz=efz0-(efz0-efz1)*par**5*(70*par**4-315*par**3+540*par**2-420*par+126) - ELSE - efz=efz0+(efz1-efz0)*par**5*(70*par**4-315*par**3+540*par**2-420*par+126) - END IF - END IF - ELSE - efx=efx1 - efy=efy1 - efz=efz1 - END IF - END IF - END IF - DO i=1,nbsp,2 - IF(wf_efield) THEN - rhos1=0.d0 - rhos2=0.d0 - DO ir=1,nnrsx - rel1(1)=xdist(ir)*a1(1)+ydist(ir)*a2(1)+zdist(ir)*a3(1)-wfc(1,i) - rel1(2)=xdist(ir)*a1(2)+ydist(ir)*a2(2)+zdist(ir)*a3(2)-wfc(2,i) - rel1(3)=xdist(ir)*a1(3)+ydist(ir)*a2(3)+zdist(ir)*a3(3)-wfc(3,i) - ! minimum image convention - CALL pbc(rel1,a1,a2,a3,ainv,rel1) - IF(nspin.EQ.2) THEN - IF(i.LE.nupdwn(1)) THEN - rhos1(ir,1)=rhos(ir,1)+efx*rel1(1)+efy*rel1(2)+efz*rel1(3) - ELSE - rhos1(ir,2)=rhos(ir,2)+efx*rel1(1)+efy*rel1(2)+efz*rel1(3) - END IF - ELSE - rhos1(ir,1)=rhos(ir,1)+efx*rel1(1)+efy*rel1(2)+efz*rel1(3) - END IF - IF(i.NE.nbsp) THEN - rel2(1)=xdist(ir)*a1(1)+ydist(ir)*a2(1)+zdist(ir)*a3(1)-wfc(1,i+1) - rel2(2)=xdist(ir)*a1(2)+ydist(ir)*a2(2)+zdist(ir)*a3(2)-wfc(2,i+1) - rel2(3)=xdist(ir)*a1(3)+ydist(ir)*a2(3)+zdist(ir)*a3(3)-wfc(3,i+1) - ! minimum image convention - CALL pbc(rel2,a1,a2,a3,ainv,rel2) - IF(nspin.EQ.2) THEN - IF(i+1.LE.nupdwn(1)) THEN - rhos2(ir,1)=rhos(ir,1)+efx*rel2(1)+efy*rel2(2)+efz*rel2(3) - ELSE - rhos2(ir,2)=rhos(ir,2)+efx*rel2(1)+efy*rel2(2)+efz*rel2(3) - END IF - ELSE - rhos2(ir,1)=rhos(ir,1)+efx*rel2(1)+efy*rel2(2)+efz*rel2(3) - END IF - ELSE - rhos2(ir,:)=rhos1(ir,:) - END IF - END DO - CALL dforce(i,bec,betae,c0,c2,c3,rhos1,nnrsx,ispin,f,nbsp,nspin,rhos2) - ELSE - CALL dforce(i,bec,betae,c0,c2,c3,rhos,nnrsx,ispin,f,nbsp,nspin) - END IF - IF(tsde) THEN - CALL wave_steepest( cm(:, i ), c0(:, i ), emadt2, c2 ) - CALL wave_steepest( cm(:, i+1), c0(:, i+1), emadt2, c3 ) - ELSE - CALL wave_verlet( cm(:, i ), c0(:, i ), verl1, verl2, emaver, c2 ) - CALL wave_verlet( cm(:, i+1), c0(:, i+1), verl1, verl2, emaver, c3 ) - ENDIF - IF (gstart.EQ.2) THEN - cm(1, i)=CMPLX(DBLE(cm(1, i)),0.d0) - cm(1,i+1)=CMPLX(DBLE(cm(1,i+1)),0.d0) - END IF - END DO - - DEALLOCATE( c2 ) - DEALLOCATE( c3 ) - - RETURN - END SUBROUTINE ef_potential - ! - !-------------------------------------------------------------------- - ! ... Electric Field Implementation for Electric Enthalpy - ! ... - M.S - !-------------------------------------------------------------------- - ! - !-------------------------------------------------------------------------- - SUBROUTINE ef_enthalpy( enthal, tau0 ) - !-------------------------------------------------------------------------- - ! - USE efcalc, ONLY : wf_efield, efx, efy, efz - USE electric_field_module, ONLY : efe_elec, efe_ion, tt2, tt - USE wannier_module, ONLY : wfx, wfy, wfz, ionx, iony, ionz, wfc - USE electrons_base, ONLY : nbsp, f - USE cell_base, ONLY : ainv, a1, a2, a3 - USE ions_base, ONLY : na, nsp, zv - USE io_global, ONLY : ionode - ! - IMPLICIT NONE - ! - REAL(DP) :: enthal, tau0(:,:) - INTEGER :: i, is, ia, isa - ! - IF(wf_efield) THEN - ! Electronic Contribution First - wfx=0.d0 - wfy=0.d0 - wfz=0.d0 - efe_elec=0.d0 - DO i=1,nbsp - tt2(1)=wfc(1,i) - tt2(2)=wfc(2,i) - tt2(3)=wfc(3,i) - CALL pbc(tt2,a1,a2,a3,ainv,tt2) - wfx=wfx+f(i)*tt2(1) - wfy=wfy+f(i)*tt2(2) - wfz=wfz+f(i)*tt2(3) - END DO - efe_elec=efe_elec+efx*wfx+efy*wfy+efz*wfz - !Then Ionic Contribution - ionx=0.d0 - iony=0.d0 - ionz=0.d0 - efe_ion=0.d0 - isa = 0 - DO is=1,nsp - DO ia=1,na(is) - isa = isa + 1 - tt(1)=tau0(1,isa) - tt(2)=tau0(2,isa) - tt(3)=tau0(3,isa) - CALL pbc(tt,a1,a2,a3,ainv,tt) - ionx=ionx+zv(is)*tt(1) - iony=iony+zv(is)*tt(2) - ionz=ionz+zv(is)*tt(3) - END DO - END DO - efe_ion=efe_ion+efx*ionx+efy*iony+efz*ionz - IF( ionode ) THEN - WRITE(28,'(f12.9,1x,f12.9,1x,f12.9,1x,f20.15,1x,f20.15)') efx, efy, efz, efe_elec,-efe_ion - END IF - ELSE - efe_elec = 0.0_DP - efe_ion = 0.0_DP - END IF - enthal=enthal+efe_elec-efe_ion - - RETURN - END SUBROUTINE ef_enthalpy - ! - !-------------------------------------------------------------------------- - SUBROUTINE wf_closing_options_real( nfi, c0, cm, bec, eigr, eigrb, taub, & - irb, ibrav, b1, b2, b3, taus, tausm, vels, & - velsm, acc, lambda, lambdam, xnhe0, xnhem, & - vnhe, xnhp0, xnhpm, vnhp, nhpcl,nhpdim,ekincm,& - xnhh0, xnhhm, vnhh, velh, ecut, ecutw, delt, & - celldm, fion, tps, mat_z, occ_f, rho ) - !-------------------------------------------------------------------------- - ! - USE wannier_base, ONLY : calwf, jwf - USE wannier_module, ONLY : what1, wfc, utwf - USE cell_base, ONLY : h, hold - USE cvan, ONLY : nvb - USE cp_interfaces, ONLY : writefile - ! - IMPLICIT NONE - ! - INTEGER :: nfi - COMPLEX(DP) :: c0(:,:) - COMPLEX(DP) :: cm(:,:) - REAL(DP) :: bec(:,:) - COMPLEX(DP) :: eigrb(:,:), eigr(:,:) - INTEGER :: irb(:,:) - REAL(DP) :: taub(:,:) - INTEGER :: ibrav - REAL(DP) :: b1(:), b2(:), b3(:) - REAL(DP) :: taus(:,:), tausm(:,:), vels(:,:), velsm(:,:) - REAL(DP) :: acc(:) - REAL(DP) :: lambda(:,:,:), lambdam(:,:,:) - REAL(DP) :: xnhe0, xnhem, vnhe, xnhp0(:), xnhpm(:), vnhp(:), ekincm - INTEGER :: nhpcl, nhpdim - REAL(DP) :: velh(:,:) - REAL(DP) :: xnhh0(:,:), xnhhm(:,:), vnhh(:,:) - REAL(DP) :: ecut, ecutw, delt, celldm(:) - REAL(DP) :: fion(:,:), tps - REAL(DP) :: mat_z(:,:,:), occ_f(:), rho(:,:) - ! - CALL start_clock('wf_close_opt') - ! - ! ... More Wannier Function Options - ! - IF ( calwf == 4 ) THEN - ! - jwf = 1 - ! - CALL wf( calwf, c0, bec, eigrb, irb, & - b1, b2, b3, utwf, what1, wfc, jwf, ibrav ) - ! - IF ( nvb == 0 ) THEN - ! - CALL wf( calwf, cm, bec, eigrb, irb, & - b1, b2, b3, utwf, what1, wfc, jwf, ibrav ) - ! - ELSE - ! - cm = c0 - ! - END IF - ! - CALL writefile( h, hold, nfi, c0, cm, taus, & - tausm, vels, velsm,acc, lambda, lambdam, xnhe0, xnhem, & - vnhe, xnhp0, xnhpm, vnhp,nhpcl,nhpdim,ekincm, xnhh0, xnhhm,& - vnhh, velh, fion, tps, mat_z, occ_f, rho ) - ! - CALL stop_clock('wf_close_opt') - CALL stop_run( .TRUE. ) - ! - END IF - ! - IF ( calwf == 3 ) THEN - ! - ! ... construct overlap matrix and calculate spreads and do Localization - ! - jwf = 1 - ! - CALL wf( calwf, c0, bec, eigrb, irb, & - b1, b2, b3, utwf, what1, wfc, jwf, ibrav ) - ! - CALL stop_clock('wf_close_opt') - ! - END IF - ! - RETURN - ! - END SUBROUTINE wf_closing_options_real - - !-------------------------------------------------------------------------- - SUBROUTINE wf_closing_options_twin( nfi, c0, cm, bec, eigr, eigrb, taub, & - irb, ibrav, b1, b2, b3, taus, tausm, vels, & - velsm, acc, lambda, lambdam, lambda_bare, xnhe0, & - xnhem, & - vnhe, xnhp0, xnhpm, vnhp, nhpcl,nhpdim,ekincm,& - xnhh0, xnhhm, vnhh, velh, ecut, ecutw, delt, & - celldm, fion, tps, mat_z, occ_f, rho ) - !-------------------------------------------------------------------------- - ! - USE wannier_base, ONLY : calwf, jwf - USE wannier_module, ONLY : what1, wfc, utwf - USE electrons_base, ONLY : nbsp - USE cell_base, ONLY : h, hold - USE cvan, ONLY : nvb - USE cp_interfaces, ONLY : writefile - USE twin_types - ! - USE uspp, ONLY : nkb - ! - IMPLICIT NONE - ! - INTEGER :: nfi - COMPLEX(DP) :: c0(:,:) - COMPLEX(DP) :: cm(:,:) -! REAL(DP) :: bec(:,:) - TYPE(twin_matrix) :: bec - COMPLEX(DP) :: eigrb(:,:), eigr(:,:) - INTEGER :: irb(:,:) - REAL(DP) :: taub(:,:) - INTEGER :: ibrav - REAL(DP) :: b1(:), b2(:), b3(:) - REAL(DP) :: taus(:,:), tausm(:,:), vels(:,:), velsm(:,:) - REAL(DP) :: acc(:) -! REAL(DP) :: lambda(:,:,:), lambdam(:,:,:) - TYPE(twin_matrix), dimension(:) :: lambda, lambdam, lambda_bare - REAL(DP) :: xnhe0, xnhem, vnhe, xnhp0(:), xnhpm(:), vnhp(:), ekincm - INTEGER :: nhpcl, nhpdim - REAL(DP) :: velh(:,:) - REAL(DP) :: xnhh0(:,:), xnhhm(:,:), vnhh(:,:) - REAL(DP) :: ecut, ecutw, delt, celldm(:) - REAL(DP) :: fion(:,:), tps - REAL(DP) :: occ_f(:), rho(:,:) - TYPE(twin_matrix), dimension(:) :: mat_z - ! - ! ... workaround for wf to work (we do not have win type in there...) - ! - REAL(DP) bec_tmp(nkb, nbsp) - ! - CALL start_clock('wf_close_opt') - ! - ! ... More Wannier Function Options - ! - IF ( calwf == 4 ) THEN - ! - jwf = 1 - ! - ! ... workaround for wf to work (we do not have win type in there...) - ! - bec_tmp(:,:) = 0.0 - bec_tmp(:,:) = bec%rvec(:,:) - ! - !CALL wf( calwf, c0, bec, eigrb, irb, & - ! b1, b2, b3, utwf, what1, wfc, jwf, ibrav ) - CALL wf( calwf, c0, bec_tmp, eigrb, irb, & - b1, b2, b3, utwf, what1, wfc, jwf, ibrav ) - ! - IF ( nvb == 0 ) THEN - ! - !CALL wf( calwf, cm, bec, eigrb, irb, & - ! b1, b2, b3, utwf, what1, wfc, jwf, ibrav ) - CALL wf( calwf, cm, bec_tmp, eigrb, irb, & - b1, b2, b3, utwf, what1, wfc, jwf, ibrav ) - ! - ELSE - ! - cm = c0 - ! - END IF - ! - CALL writefile( h, hold, nfi, c0, cm, taus, & - tausm, vels, velsm,acc, lambda, lambdam, lambda_bare, xnhe0, xnhem, & - vnhe, xnhp0, xnhpm, vnhp,nhpcl,nhpdim,ekincm, xnhh0, xnhhm,& - vnhh, velh, fion, tps, mat_z, occ_f, rho ) - ! - CALL stop_clock('wf_close_opt') - CALL stop_run( .TRUE. ) - ! - END IF - ! - IF ( calwf == 3 ) THEN - ! - ! ... construct overlap matrix and calculate spreads and do Localization - ! - jwf = 1 - ! - CALL wf( calwf, c0, bec, eigrb, irb, & - b1, b2, b3, utwf, what1, wfc, jwf, ibrav ) - ! - CALL stop_clock('wf_close_opt') - ! - END IF - ! - RETURN - ! - END SUBROUTINE wf_closing_options_twin - ! -END MODULE wannier_subroutines diff --git a/quantum_espresso/kcp/CPV/wannier_base.f90 b/quantum_espresso/kcp/CPV/wannier_base.f90 deleted file mode 100644 index 2cffe73f9..000000000 --- a/quantum_espresso/kcp/CPV/wannier_base.f90 +++ /dev/null @@ -1,153 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE wannier_base - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - ! - IMPLICIT NONE - ! - ! ... input variables - ! - LOGICAL :: wf_efield - LOGICAL :: wf_switch - INTEGER :: sw_len - REAL(DP) :: efx0, efy0, efz0 - REAL(DP) :: efx1, efy1, efz1 - INTEGER :: wfsd - REAL(DP) :: wfdt - REAL(DP) :: maxwfdt - REAL(DP) :: wf_q - REAL(DP) :: wf_friction - INTEGER :: nit - INTEGER :: nsd - INTEGER :: nsteps - REAL(DP) :: tolw - LOGICAL :: adapt - INTEGER :: calwf - INTEGER :: nwf - INTEGER :: wffort - LOGICAL :: writev - INTEGER, ALLOCATABLE :: iplot(:) - ! - ! ... other internal variables - ! - INTEGER :: nw, nwrwf, iwf, jwf - INTEGER, ALLOCATABLE :: wfg1(:), wfg(:,:) - INTEGER, ALLOCATABLE :: indexplus(:,:), indexminus(:,:) - INTEGER, ALLOCATABLE :: indexplusz(:), indexminusz(:) - INTEGER, ALLOCATABLE :: tag(:,:), tagp(:,:) - REAL(DP), ALLOCATABLE :: weight(:) ! weights of G vectors - REAL(DP), ALLOCATABLE :: gnx(:,:) - INTEGER , ALLOCATABLE :: gnn(:,:) - COMPLEX(DP), ALLOCATABLE :: expo(:,:) - ! - CONTAINS - ! - !------------------------------------------------------------------------ - SUBROUTINE wannier_init( wf_efield_, wf_switch_, sw_len_, efx0_, efy0_, & - efz0_, efx1_, efy1_, efz1_, wfsd_, wfdt_, & - maxwfdt_, wf_q_, wf_friction_, nit_, nsd_, & - nsteps_, tolw_, adapt_, calwf_, nwf_, wffort_, & - writev_, iplot_, restart_mode_ ) - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(IN) :: wf_efield_ - LOGICAL, INTENT(IN) :: wf_switch_ - INTEGER, INTENT(IN) :: sw_len_ - REAL(DP), INTENT(IN) :: efx0_, efy0_, efz0_ - REAL(DP), INTENT(IN) :: efx1_, efy1_, efz1_ - INTEGER, INTENT(IN) :: wfsd_ - REAL(DP), INTENT(IN) :: wfdt_ - REAL(DP), INTENT(IN) :: maxwfdt_ - REAL(DP), INTENT(IN) :: wf_q_ - REAL(DP), INTENT(IN) :: wf_friction_ - INTEGER, INTENT(IN) :: nit_ - INTEGER, INTENT(IN) :: nsd_ - INTEGER, INTENT(IN) :: nsteps_ - REAL(DP), INTENT(IN) :: tolw_ - LOGICAL, INTENT(IN) :: adapt_ - INTEGER, INTENT(IN) :: calwf_ - INTEGER, INTENT(IN) :: nwf_ - INTEGER, INTENT(IN) :: wffort_ - INTEGER, INTENT(IN) :: iplot_(:) - LOGICAL, INTENT(IN) :: writev_ - CHARACTER(LEN=*), INTENT(IN) :: restart_mode_ - ! - ! - wf_efield = wf_efield_ - wf_switch = wf_switch_ - sw_len = sw_len_ - efx0 = efx0_ - efy0 = efy0_ - efz0 = efz0_ - efx1 = efx1_ - efy1 = efy1_ - efz1 = efz1_ - wfsd = wfsd_ - wfdt = wfdt_ - maxwfdt = maxwfdt_ - wf_q = wf_q_ - wf_friction = wf_friction_ - nit = nit_ - nsd = nsd_ - nsteps = nsteps_ - tolw = tolw_ - adapt = adapt_ - calwf = calwf_ - nwf = nwf_ - wffort = wffort_ - writev = writev_ - ! - IF ( calwf == 1 .AND. nwf == 0 ) & - CALL errore( 'wannier_init ', & - & 'when calwf = 1, nwf must be larger that 0', 1 ) - ! - IF ( nwf > 0 ) THEN - ! - ALLOCATE( iplot( nwf ) ) - ! - iplot(:) = iplot_(1:nwf) - ! - END IF - ! - IF ( TRIM( restart_mode_ ) == "from_scratch" ) THEN - ! - IF ( wf_efield ) & - CALL errore( 'wannier_init', 'electric field not ' // & - & 'allowed when starting from scratch', 1 ) - ! - END IF - ! - END SUBROUTINE wannier_init - ! - ! - ! - SUBROUTINE deallocate_wannier_base() - IF( ALLOCATED( iplot ) ) DEALLOCATE( iplot ) - IF( ALLOCATED( wfg1 ) ) DEALLOCATE( wfg1 ) - IF( ALLOCATED( wfg ) ) DEALLOCATE( wfg ) - IF( ALLOCATED( indexplus ) ) DEALLOCATE( indexplus ) - IF( ALLOCATED( indexminus ) ) DEALLOCATE( indexminus ) - IF( ALLOCATED( indexplusz ) ) DEALLOCATE( indexplusz ) - IF( ALLOCATED( indexminusz ) ) DEALLOCATE( indexminusz ) - IF( ALLOCATED( tag ) ) DEALLOCATE( tag ) - IF( ALLOCATED( tagp ) ) DEALLOCATE( tagp ) - IF( ALLOCATED( weight ) ) DEALLOCATE( weight ) - IF( ALLOCATED( gnx ) ) DEALLOCATE( gnx ) - IF( ALLOCATED( gnn ) ) DEALLOCATE( gnn ) - IF( ALLOCATED( expo ) ) DEALLOCATE( expo ) - RETURN - END SUBROUTINE deallocate_wannier_base - ! - ! - ! -END MODULE wannier_base diff --git a/quantum_espresso/kcp/CPV/wave.f90 b/quantum_espresso/kcp/CPV/wave.f90 deleted file mode 100644 index 123a55bc2..000000000 --- a/quantum_espresso/kcp/CPV/wave.f90 +++ /dev/null @@ -1,787 +0,0 @@ -! -! Copyright (C) 2002-2008 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - -!=----------------------------------------------------------------------------=! - SUBROUTINE interpolate_lambda_real_x( lambdap, lambda, lambdam ) -!=----------------------------------------------------------------------------=! - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP) :: lambdap(:,:,:), lambda(:,:,:), lambdam(:,:,:) - ! - ! interpolate new lambda at (t+dt) from lambda(t) and lambda(t-dt): - ! - lambdap= 2.d0*lambda - lambdam - lambdam=lambda - lambda =lambdap - RETURN - END SUBROUTINE interpolate_lambda_real_x -!=----------------------------------------------------------------------------=! - SUBROUTINE interpolate_lambda_twin_x( lambdap, lambda, lambdam ) -!=----------------------------------------------------------------------------=! - USE kinds, ONLY: DP - USE twin_types - - IMPLICIT NONE - TYPE(twin_matrix), dimension(:) :: lambdap, lambda, lambdam - ! - INTEGER :: i - ! - ! interpolate new lambda at (t+dt) from lambda(t) and lambda(t-dt): - ! - DO i=1,size(lambda) - IF(.not.lambda(i)%iscmplx) THEN - lambdap(i)%rvec= 2.d0*lambda(i)%rvec - lambdam(i)%rvec - lambdam(i)%rvec=lambda(i)%rvec - lambda(i)%rvec =lambdap(i)%rvec - ELSE - lambdap(i)%cvec= 2.d0*lambda(i)%cvec - lambdam(i)%cvec - lambdam(i)%cvec=lambda(i)%cvec - lambda(i)%cvec =lambdap(i)%cvec - ENDIF - ENDDO - RETURN - END SUBROUTINE interpolate_lambda_twin_x - -!=----------------------------------------------------------------------------=! - SUBROUTINE update_lambda_x( i, lambda, c0, c2, n, noff, tdist ) -!=----------------------------------------------------------------------------=! - USE kinds, ONLY: DP - USE electrons_module, ONLY: ib_owner, ib_local - USE mp_global, ONLY: me_image, intra_image_comm - USE mp, ONLY: mp_sum - USE wave_base, ONLY: hpsi - USE reciprocal_vectors, ONLY: gzero - IMPLICIT NONE - INTEGER, INTENT(IN) :: n, noff - REAL(DP) :: lambda(:,:) - COMPLEX(DP) :: c0(:,:), c2(:) - INTEGER, INTENT(IN) :: i - LOGICAL, INTENT(IN) :: tdist ! if .true. lambda is distributed - ! - REAL(DP), ALLOCATABLE :: prod(:) - INTEGER :: ibl - ! - ALLOCATE( prod( n ) ) - prod = hpsi( gzero, c0, SIZE( c0, 1 ), c2, n, noff ) - CALL mp_sum( prod, intra_image_comm ) - IF( tdist ) THEN - IF( me_image == ib_owner( i ) ) THEN - ibl = ib_local( i ) - lambda( ibl, : ) = prod( : ) - END IF - ELSE - lambda( i, : ) = prod( : ) - END IF - DEALLOCATE( prod ) - RETURN - END SUBROUTINE update_lambda_x - -!=----------------------------------------------------------------------------=! - subroutine elec_fakekine_x( ekincm, ema0bg, emass, c0, cm, ngw, n, noff, delt ) -!=----------------------------------------------------------------------------=! - ! - ! This subroutine computes the CP(fake) wave functions kinetic energy - - USE kinds, only : DP - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use reciprocal_vectors, only : gstart - use wave_base, only : wave_speed2 - use control_flags, only: gamma_only, do_wf_cmplx!added:giovanni - ! - IMPLICIT NONE - ! - integer, intent(in) :: ngw ! number of plane wave coeff. - integer, intent(in) :: n ! number of bands - integer, intent(in) :: noff ! offset for band index - real(DP), intent(out) :: ekincm - real(DP), intent(in) :: ema0bg( ngw ), delt, emass - complex(DP), intent(in) :: c0( ngw, n ), cm( ngw, n ) - ! - real(DP), allocatable :: emainv(:) - real(DP) :: ftmp - integer :: i - logical :: lgam!added:giovanni - - lgam=gamma_only.and..not.do_wf_cmplx!added:giovanni - ALLOCATE( emainv( ngw ) ) - emainv = 1.0d0 / ema0bg - ftmp = 1.0d0 - if( gstart == 2 ) ftmp = 0.5d0 - - ekincm=0.0d0 - do i = noff, n + noff - 1 - ekincm = ekincm + 2.0d0 * wave_speed2( c0(:,i), cm(:,i), emainv, ftmp, lgam )!added:giovanni lgam - end do - ekincm = ekincm * emass / ( delt * delt ) - - CALL mp_sum( ekincm, intra_image_comm ) - DEALLOCATE( emainv ) - - return - end subroutine elec_fakekine_x - -!=----------------------------------------------------------------------------=! - SUBROUTINE protate_real_x ( c0, bec, c0rot, becrot, ngwl, nss, noff, lambda, & - na, nsp, ish, nh, np_rot, me_rot ) -!=----------------------------------------------------------------------------=! - - ! this routine rotates the wave functions using the matrix lambda - ! it works with a block-like distributed matrix - ! of the Lagrange multipliers ( lambda ). - ! no replicated data are used, allowing scalability for large problems. - ! the layout of lambda is as follows : - ! - ! (PE 0) (PE 1) .. (PE NPE-1) - ! lambda(1 ,1:nx) lambda(2 ,1:nx) .. lambda(NPE ,1:nx) - ! lambda(1+ NPE,1:nx) lambda(2+ NPE,1:nx) .. lambda(NPE+ NPE,1:nx) - ! lambda(1+2*NPE,1:nx) lambda(2+2*NPE,1:nx) .. lambda(NPE+2*NPE,1:nx) - ! - ! distributes lambda's rows across processors with a blocking factor - ! of 1, ( row 1 to PE 1, row 2 to PE 2, .. row nproc_image+1 to PE 1 and - ! so on). - ! nrl = local number of rows - ! ---------------------------------------------- - - ! ... declare modules - - USE kinds, ONLY: DP - USE mp, ONLY: mp_bcast - USE mp_global, ONLY: intra_image_comm - USE dspev_module, ONLY: pdspev_drv, dspev_drv - - IMPLICIT NONE - - ! ... declare subroutine arguments - - INTEGER, INTENT(IN) :: ngwl, nss, noff - INTEGER, INTENT(IN) :: na(:), nsp, ish(:), nh(:) - INTEGER, INTENT(IN) :: np_rot, me_rot - COMPLEX(DP), INTENT(IN) :: c0(:,:) - COMPLEX(DP), INTENT(OUT) :: c0rot(:,:) - REAL(DP), INTENT(IN) :: lambda(:,:) - REAL(DP), INTENT(IN) :: bec(:,:) - REAL(DP), INTENT(OUT) :: becrot(:,:) - - ! ... declare other variables - INTEGER :: i, j, ip - INTEGER :: jl, nrl_ip, is, ia, jv, jnl - REAL(DP), ALLOCATABLE :: uu(:,:) - - IF( nss < 1 ) THEN - RETURN - END IF - - CALL start_clock('protate') - - DO i = 1, nss - c0rot( :, i+noff-1 ) = 0.0d0 - becrot(:,i+noff-1 ) = 0.0d0 - END DO - - - -! becrot = 0.0d0 -! c0rot = 0.0d0 - - DO ip = 1, np_rot - - nrl_ip = nss / np_rot - IF( (ip-1) < mod( nss, np_rot ) ) THEN - nrl_ip = nrl_ip + 1 - END IF - - ALLOCATE( uu( nrl_ip, nss ) ) - IF( me_rot .EQ. (ip-1) ) THEN - uu = lambda( 1:nrl_ip, 1:nss ) - END IF - CALL mp_bcast( uu, (ip-1), intra_image_comm) - - j = ip - DO jl = 1, nrl_ip - DO i = 1, nss - CALL DAXPY(2*ngwl,uu(jl,i),c0(1,j+noff-1),1,c0rot(1,i+noff-1),1) - END DO - - do is=1,nsp - do jv=1,nh(is) - do ia=1,na(is) - jnl=ish(is)+(jv-1)*na(is)+ia - do i = 1, nss - becrot(jnl,i+noff-1) = becrot(jnl,i+noff-1)+ uu(jl, i) * bec( jnl, j+noff-1 ) - end do - end do - end do - end do - - j = j + np_rot - END DO - - DEALLOCATE(uu) - - END DO - - CALL stop_clock('protate') - - RETURN - END SUBROUTINE protate_real_x - -!=----------------------------------------------------------------------------=! - SUBROUTINE protate_cmplx_x ( c0, bec, c0rot, becrot, ngwl, nss, noff, lambda, & - na, nsp, ish, nh, np_rot, me_rot ) -!=----------------------------------------------------------------------------=! - - ! this routine rotates the wave functions using the matrix lambda - ! it works with a block-like distributed matrix - ! of the Lagrange multipliers ( lambda ). - ! no replicated data are used, allowing scalability for large problems. - ! the layout of lambda is as follows : - ! - ! (PE 0) (PE 1) .. (PE NPE-1) - ! lambda(1 ,1:nx) lambda(2 ,1:nx) .. lambda(NPE ,1:nx) - ! lambda(1+ NPE,1:nx) lambda(2+ NPE,1:nx) .. lambda(NPE+ NPE,1:nx) - ! lambda(1+2*NPE,1:nx) lambda(2+2*NPE,1:nx) .. lambda(NPE+2*NPE,1:nx) - ! - ! distributes lambda's rows across processors with a blocking factor - ! of 1, ( row 1 to PE 1, row 2 to PE 2, .. row nproc_image+1 to PE 1 and - ! so on). - ! nrl = local number of rows - ! ---------------------------------------------- - - ! ... declare modules - - USE kinds, ONLY: DP - USE mp, ONLY: mp_bcast - USE mp_global, ONLY: intra_image_comm - USE dspev_module, ONLY: pdspev_drv, dspev_drv - - IMPLICIT NONE - - ! ... declare subroutine arguments - - INTEGER, INTENT(IN) :: ngwl, nss, noff - INTEGER, INTENT(IN) :: na(:), nsp, ish(:), nh(:) - INTEGER, INTENT(IN) :: np_rot, me_rot - COMPLEX(DP), INTENT(IN) :: c0(:,:) - COMPLEX(DP), INTENT(OUT) :: c0rot(:,:) - COMPLEX(DP), INTENT(IN) :: lambda(:,:) - COMPLEX(DP), INTENT(IN) :: bec(:,:) - COMPLEX(DP), INTENT(OUT) :: becrot(:,:) - - ! ... declare other variables - INTEGER :: i, j, ip - INTEGER :: jl, nrl_ip, is, ia, jv, jnl - COMPLEX(DP), ALLOCATABLE :: uu(:,:) - - IF( nss < 1 ) THEN - RETURN - END IF - - CALL start_clock('protate') - - DO i = 1, nss - c0rot( :, i+noff-1 ) = 0.0d0 - becrot(:,i+noff-1 ) = 0.0d0 - END DO - - - -! becrot = 0.0d0 -! c0rot = 0.0d0 - - DO ip = 1, np_rot - - nrl_ip = nss / np_rot - IF( (ip-1) < mod( nss, np_rot ) ) THEN - nrl_ip = nrl_ip + 1 - END IF - - ALLOCATE( uu( nrl_ip, nss ) ) - IF( me_rot .EQ. (ip-1) ) THEN - uu = lambda( 1:nrl_ip, 1:nss ) - END IF - CALL mp_bcast( uu, (ip-1), intra_image_comm) - - j = ip - DO jl = 1, nrl_ip - DO i = 1, nss - CALL ZAXPY(ngwl,CONJG(uu(jl,i)),c0(1,j+noff-1),1,c0rot(1,i+noff-1),1) - END DO - - do is=1,nsp - do jv=1,nh(is) - do ia=1,na(is) - jnl=ish(is)+(jv-1)*na(is)+ia - do i = 1, nss - becrot(jnl,i+noff-1) = becrot(jnl,i+noff-1)+ CONJG(uu(jl, i)) * bec( jnl, j+noff-1 ) - end do - end do - end do - end do - - j = j + np_rot - END DO - - DEALLOCATE(uu) - - END DO - - CALL stop_clock('protate') - - RETURN - END SUBROUTINE protate_cmplx_x - -!=----------------------------------------------------------------------------=! - SUBROUTINE crot_gamma2_real ( c0rot, c0, ngw, n, noffr, noff, lambda, nx, eig ) -!=----------------------------------------------------------------------------=! - - ! this routine rotates the wave functions to the Kohn-Sham base - ! it works with a block-like distributed matrix - ! of the Lagrange multipliers ( lambda ). - ! - ! ... declare modules - - USE kinds, ONLY: DP - USE mp, ONLY: mp_bcast - USE dspev_module, ONLY: dspev_drv - - IMPLICIT NONE - - ! ... declare subroutine arguments - - INTEGER, INTENT(IN) :: ngw, n, nx, noffr, noff - COMPLEX(DP), INTENT(INOUT) :: c0rot(:,:) - COMPLEX(DP), INTENT(IN) :: c0(:,:) - REAL(DP), INTENT(IN) :: lambda(:,:) - REAL(DP), INTENT(OUT) :: eig(:) - - ! ... declare other variables - ! - REAL(DP), ALLOCATABLE :: vv(:,:), ap(:) - INTEGER :: i, j, k - - IF( nx < 1 ) THEN - RETURN - END IF - - ALLOCATE( vv( nx, nx ) ) - - ! NON distributed lambda - - ALLOCATE( ap( nx * ( nx + 1 ) / 2 ) ) - - K = 0 - DO J = 1, n - DO I = J, n - K = K + 1 - ap( k ) = lambda( i, j ) - END DO - END DO - - CALL dspev_drv( 'V', 'L', n, ap, eig, vv, nx ) - - DEALLOCATE( ap ) - - DO i = 1, n - c0rot( :, i+noffr-1 ) = 0.0d0 - END DO - - DO j = 1, n - DO i = 1, n - CALL DAXPY( 2*ngw, vv(j,i), c0(1,j+noff-1), 1, c0rot(1,i+noffr-1), 1 ) - END DO - END DO - - DEALLOCATE( vv ) - - RETURN - END SUBROUTINE crot_gamma2_real - -!=----------------------------------------------------------------------------=! - SUBROUTINE crot_gamma2_cmplx ( c0rot, c0, ngw, n, noffr, noff, lambda, nx, eig ) -!=----------------------------------------------------------------------------=! - - ! this routine rotates the wave functions to the Kohn-Sham base - ! it works with a block-like distributed matrix - ! of the Lagrange multipliers ( lambda ). - ! - ! ... declare modules - - USE kinds, ONLY: DP - USE mp, ONLY: mp_bcast - USE zhpev_module, ONLY: zhpev_drv - - IMPLICIT NONE - - ! ... declare subroutine arguments - - INTEGER, INTENT(IN) :: ngw, n, nx, noffr, noff - COMPLEX(DP), INTENT(INOUT) :: c0rot(:,:) - COMPLEX(DP), INTENT(IN) :: c0(:,:) - COMPLEX(DP), INTENT(IN) :: lambda(:,:) - REAL(DP), INTENT(OUT) :: eig(:) - - ! ... declare other variables - ! - COMPLEX(DP), ALLOCATABLE :: vv(:,:), ap(:) - INTEGER :: i, j, k - - IF( nx < 1 ) THEN - RETURN - END IF - - ALLOCATE( vv( nx, nx ) ) - - ! NON distributed lambda - - ALLOCATE( ap( nx * ( nx + 1 ) / 2 ) ) - - K = 0 - DO J = 1, n - DO I = J, n - K = K + 1 - ap( k ) = lambda( i, j ) - END DO - END DO - - CALL zhpev_drv( 'V', 'L', n, ap, eig, vv, nx ) - - DEALLOCATE( ap ) - - DO i = 1, n - c0rot( :, i+noffr-1 ) = 0.0d0 - END DO - - DO j = 1, n - DO i = 1, n - CALL ZAXPY( ngw, vv(j,i), c0(1,j+noff-1), 1, c0rot(1,i+noffr-1), 1 ) - END DO - END DO - - DEALLOCATE( vv ) - - RETURN - END SUBROUTINE crot_gamma2_cmplx - - -!=----------------------------------------------------------------------------=! - SUBROUTINE proj_gamma( a, b, ngw, n, noff, lambda) -!=----------------------------------------------------------------------------=! - - ! projection A=A-SUM{B}B - ! no replicated data are used, allowing scalability for large problems. - ! The layout of lambda is as follows : - ! - ! (PE 0) (PE 1) .. (PE NPE-1) - ! lambda(1 ,1:nx) lambda(2 ,1:nx) .. lambda(NPE ,1:nx) - ! lambda(1+ NPE,1:nx) lambda(2+ NPE,1:nx) .. lambda(NPE+ NPE,1:nx) - ! lambda(1+2*NPE,1:nx) lambda(2+2*NPE,1:nx) .. lambda(NPE+2*NPE,1:nx) - ! - ! distribute lambda's rows across processors with a blocking factor - ! of 1, ( row 1 to PE 1, row 2 to PE 2, .. row nproc_image+1 to PE 1 and so on). - ! ---------------------------------------------- - -! ... declare modules - USE kinds, ONLY: DP - USE mp_global, ONLY: nproc_image, me_image - USE wave_base, ONLY: dotp - USE reciprocal_vectors, ONLY: gzero - - IMPLICIT NONE - -! ... declare subroutine arguments - INTEGER, INTENT( IN ) :: ngw, n, noff - COMPLEX(DP), INTENT(INOUT) :: a(:,:), b(:,:) - REAL(DP), OPTIONAL :: lambda(:,:) - -! ... declare other variables - REAL(DP), ALLOCATABLE :: ee(:) - INTEGER :: i, j - COMPLEX(DP) :: alp - -! ... end of declarations -! ---------------------------------------------- - - IF( n < 1 ) THEN - RETURN - END IF - - ALLOCATE( ee( n ) ) - DO i = 1, n - DO j = 1, n - ee(j) = -dotp( gzero, ngw, b(:,j+noff-1), a(:,i+noff-1) ) - END DO - IF( PRESENT(lambda) ) THEN - IF( MOD( (i-1), nproc_image ) == me_image ) THEN - DO j = 1, n - lambda( (i-1) / nproc_image + 1, j ) = ee(j) - END DO - END IF - END IF - DO j = 1, n - alp = CMPLX(ee(j),0.0d0) - CALL ZAXPY( ngw, alp, b(1,j+noff-1), 1, a(1,i+noff-1), 1 ) - END DO - END DO - DEALLOCATE(ee) - - RETURN - END SUBROUTINE proj_gamma - -!=----------------------------------------------------------------------------=! - SUBROUTINE wave_atom_init_x( cm, n, noff ) -!=----------------------------------------------------------------------------=! - - ! this routine sets the initial atomic wavefunctions - -! ... declare modules - USE kinds, ONLY: DP - USE mp, ONLY: mp_sum - USE mp_wave, ONLY: splitwf - USE reciprocal_vectors, ONLY: ngw - USE random_numbers, ONLY: randy - USE control_flags, ONLY: ampre, tatomicwfc, trane - USE uspp_param, ONLY: n_atom_wfc - USE ions_base, ONLY: nat, ityp - USE cp_main_variables, ONLY: eigr - USE reciprocal_vectors, ONLY: ngw, gx, ngwx - USE constants, ONLY: tpi - - IMPLICIT NONE - - ! ... declare subroutine arguments - INTEGER, INTENT(IN) :: n, noff - COMPLEX(DP), INTENT(INOUT) :: cm(:,:) - - ! ... declare other variables - INTEGER :: ig, natomwfc - REAL(DP) :: rr, arg - COMPLEX(DP), ALLOCATABLE :: wfcatom(:,:) ! atomic wfcs for initialization - INTEGER :: ibnd, n_starting_wfc, n_starting_atomic_wfc - CHARACTER(len=15) :: subname="wave_atom_init" - - ! ... Check array dimensions - IF( SIZE( cm, 1 ) < ngw ) THEN - CALL errore(' wave_atom_init ', ' wrong dimensions ', 3) - END IF - - ! ... Reset them to zero - - cm( :, noff : noff + n - 1 ) = 0.0d0 - - ! ... initialize the wave functions in such a way that the values - ! ... of the components are independent on the number of processors - - ampre = 0.01d0 - write(6,*) "computing n_atom_wfc" - natomwfc = n_atom_wfc(nat, ityp, .false.) ! third value is noncolin, which is not yet implemented - ! - IF ( tatomicwfc ) THEN - ! - n_starting_wfc = MAX( natomwfc, n ) - n_starting_atomic_wfc = natomwfc - ! - ENDIF - - ALLOCATE( wfcatom( ngwx, n_starting_wfc ) ) - - IF ( tatomicwfc ) THEN - ! - write(6,*) "calling atomic_wfc" - CALL atomic_wfc( eigr, n_starting_atomic_wfc, wfcatom(:,1:n_starting_atomic_wfc) ) - write(6,*) "called atomic_wfc" - ! - IF ( trane .AND. & - n_starting_wfc == n_starting_atomic_wfc ) THEN - ! - ! ... in this case, introduce a small randomization of wavefunctions - ! ... to prevent possible "loss of states" - ! - DO ibnd = 1, n_starting_atomic_wfc - ! -!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ig, rr, arg) - DO ig = 1, ngw - ! - rr = randy() - arg = tpi * randy() - ! - wfcatom(ig,ibnd) = wfcatom(ig,ibnd) * & - ( 1.0_DP + 0.05_DP * CMPLX( rr*COS(arg), rr*SIN(arg)) ) - ! - END DO -!$OMP END PARALLEL DO - ! - END DO - ! - END IF - ! - END IF - ! - ! ... if not enough atomic wfc are available, - ! ... fill missing wfcs with random numbers - ! - DO ibnd = n_starting_atomic_wfc + 1, n_starting_wfc - ! - ! - wfcatom(:,ibnd) = (0.0_dp, 0.0_dp) - ! -!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ig, rr, arg) - DO ig = 1, ngw - ! - rr = randy() - arg = tpi * randy() - ! - wfcatom(ig,ibnd) = & - CMPLX( rr*COS( arg ), rr*SIN( arg ) ) / & - ( ( gx(1,ig) )**2 + & - ( gx(2,ig) )**2 + & - ( gx(3,ig) )**2 + 1.0_DP ) - END DO -!$OMP END PARALLEL DO - ! - END DO - - IF(n_starting_wfc.lt.n) THEN - call errore(subname, "warning: wavefunction not fully initialized", 1) - ENDIF - cm( :, noff : noff + min(n,n_starting_wfc) - 1 ) = wfcatom(:,1:min(n,n_starting_wfc)) - deallocate(wfcatom) - - RETURN - - END SUBROUTINE wave_atom_init_x - -!=----------------------------------------------------------------------------=! - SUBROUTINE wave_rand_init_x( cm, n, noff ) -!=----------------------------------------------------------------------------=! - - ! this routine sets the initial wavefunctions at random - -! ... declare modules - USE kinds, ONLY: DP - USE mp, ONLY: mp_sum - USE mp_wave, ONLY: splitwf - USE reciprocal_vectors, ONLY: ig_l2g, ngw, gzero, ngwt - USE random_numbers, ONLY: randy - - IMPLICIT NONE - - ! ... declare subroutine arguments - INTEGER, INTENT(IN) :: n, noff - COMPLEX(DP), INTENT(OUT) :: cm(:,:) - - ! ... declare other variables - INTEGER :: ntest, ig, ib - REAL(DP) :: rranf1, rranf2, ampre - COMPLEX(DP), ALLOCATABLE :: pwt( : ) - - ! ... Check array dimensions - IF( SIZE( cm, 1 ) < ngw ) THEN - CALL errore(' wave_rand_init ', ' wrong dimensions ', 3) - END IF - - ! ... Reset them to zero - - cm( :, noff : noff + n - 1 ) = 0.0d0 - - ! ... initialize the wave functions in such a way that the values - ! ... of the components are independent on the number of processors - - ampre = 0.01d0 - ALLOCATE( pwt( ngwt ) ) - - ntest = ngwt / 4 - IF( ntest < SIZE( cm, 2 ) ) THEN - ntest = ngwt - END IF - ! - ! ... assign random values to wave functions - ! - DO ib = noff, noff + n - 1 - pwt( : ) = 0.0d0 - DO ig = 3, ntest - rranf1 = 0.5d0 - randy() - rranf2 = randy() - pwt( ig ) = ampre * CMPLX(rranf1, rranf2) - END DO - DO ig = 1, ngw - cm( ig, ib ) = pwt( ig_l2g( ig ) ) - END DO - END DO - IF ( gzero ) THEN - cm( 1, noff : noff + n - 1 ) = (0.0d0, 0.0d0) - END IF - - DEALLOCATE( pwt ) - - RETURN - END SUBROUTINE wave_rand_init_x - -!=----------------------------------------------------------------------------=! - SUBROUTINE wave_sine_init_x( cm, n, noff ) !added:giovanni -!=----------------------------------------------------------------------------=! - - ! this routine sets the initial wavefunctions at random - -! ... declare modules - USE kinds, ONLY: DP - USE mp, ONLY: mp_sum - USE mp_wave, ONLY: splitwf - USE reciprocal_vectors, ONLY: ngw, gx - USE random_numbers, ONLY: randy - - IMPLICIT NONE - - ! ... declare subroutine arguments - INTEGER, INTENT(IN) :: n, noff - COMPLEX(DP), INTENT(OUT) :: cm(:,:) - - ! ... declare other variables - INTEGER :: ntest, ig, ib - REAL(DP) :: rranf1, rranf2, ampre - COMPLEX(DP), ALLOCATABLE :: pwt( : ) - - ! ... Check array dimensions - IF( SIZE( cm, 1 ) < ngw ) THEN - CALL errore(' wave_rand_init ', ' wrong dimensions ', 3) - END IF - - ! ... Reset them to zero - - cm( :, noff : noff + n - 1 ) = 0.0d0 - - ! ... initialize the wave functions in such a way that the values - ! ... of the components are independent of the number of processors - - ampre = 0.01d0 - ALLOCATE( pwt( ngw ) ) - - ntest = ngw - IF( ntest < SIZE( cm, 2 ) ) THEN - ntest = ngw - END IF - ! - ! ... assign real values to wave functions - ! - DO ib = noff, noff + n - 1 - pwt( : ) = CMPLX(0.0d0,0.d0) - DO ig = 1, ntest - rranf1 = dcos(ib*(gx(1, ig )))+dcos(ib*(gx(2, ig )))+dcos(ib*(gx(3, ig ))) - rranf2 = (dsin(ib*(gx(1,ig)))+dsin(ib*(gx(2, ig)))+dsin(ib*(gx(3, ig)))) - pwt( ig ) = ampre * CMPLX(rranf1, rranf2) - END DO - DO ig = 1, ngw - cm( ig, ib ) = pwt( ig ) - END DO - END DO - - DEALLOCATE( pwt ) - - RETURN - END SUBROUTINE wave_sine_init_x diff --git a/quantum_espresso/kcp/CPV/wave.f90~ b/quantum_espresso/kcp/CPV/wave.f90~ deleted file mode 100644 index 36cff6c46..000000000 --- a/quantum_espresso/kcp/CPV/wave.f90~ +++ /dev/null @@ -1,795 +0,0 @@ -! -! Copyright (C) 2002-2008 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" - -!=----------------------------------------------------------------------------=! - SUBROUTINE interpolate_lambda_real_x( lambdap, lambda, lambdam ) -!=----------------------------------------------------------------------------=! - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP) :: lambdap(:,:,:), lambda(:,:,:), lambdam(:,:,:) - ! - ! interpolate new lambda at (t+dt) from lambda(t) and lambda(t-dt): - ! - lambdap= 2.d0*lambda - lambdam - lambdam=lambda - lambda =lambdap - RETURN - END SUBROUTINE interpolate_lambda_real_x -!=----------------------------------------------------------------------------=! - SUBROUTINE interpolate_lambda_twin_x( lambdap, lambda, lambdam ) -!=----------------------------------------------------------------------------=! - USE kinds, ONLY: DP - USE twin_types - IMPLICIT NONE - TYPE(twin_matrix), dimension(:) :: lambdap, lambda, lambdam - ! - INTEGER :: i - ! - ! interpolate new lambda at (t+dt) from lambda(t) and lambda(t-dt): - ! - DO i=1,size(lambda) - IF(.not.lambda(i)%iscmplx) THEN - lambdap(i)%rvec= 2.d0*lambda(i)%rvec - lambdam(i)%rvec - lambdam(i)%rvec=lambda(i)%rvec - lambda(i)%rvec =lambdap(i)%rvec - ELSE - lambdap(i)%cvec= 2.d0*lambda(i)%cvec - lambdam(i)%cvec - lambdam(i)%cvec=lambda(i)%cvec - lambda(i)%cvec =lambdap(i)%cvec - ENDIF - ENDDO - RETURN - END SUBROUTINE interpolate_lambda_twin_x - -!=----------------------------------------------------------------------------=! - SUBROUTINE update_lambda_x( i, lambda, c0, c2, n, noff, tdist ) -!=----------------------------------------------------------------------------=! - USE kinds, ONLY: DP - USE electrons_module, ONLY: ib_owner, ib_local - USE mp_global, ONLY: me_image, intra_image_comm - USE mp, ONLY: mp_sum - USE wave_base, ONLY: hpsi - USE reciprocal_vectors, ONLY: gzero - IMPLICIT NONE - INTEGER, INTENT(IN) :: n, noff - REAL(DP) :: lambda(:,:) - COMPLEX(DP) :: c0(:,:), c2(:) - INTEGER, INTENT(IN) :: i - LOGICAL, INTENT(IN) :: tdist ! if .true. lambda is distributed - ! - REAL(DP), ALLOCATABLE :: prod(:) - INTEGER :: ibl - ! - ALLOCATE( prod( n ) ) - prod = hpsi( gzero, c0, SIZE( c0, 1 ), c2, n, noff ) - CALL mp_sum( prod, intra_image_comm ) - IF( tdist ) THEN - IF( me_image == ib_owner( i ) ) THEN - ibl = ib_local( i ) - lambda( ibl, : ) = prod( : ) - END IF - ELSE - lambda( i, : ) = prod( : ) - END IF - DEALLOCATE( prod ) - RETURN - END SUBROUTINE update_lambda_x - -!=----------------------------------------------------------------------------=! - subroutine elec_fakekine_x( ekincm, ema0bg, emass, c0, cm, ngw, n, noff, delt ) -!=----------------------------------------------------------------------------=! - ! - ! This subroutine computes the CP(fake) wave functions kinetic energy - - USE kinds, only : DP - use mp, only : mp_sum - use mp_global, only : intra_image_comm - use reciprocal_vectors, only : gstart - use wave_base, only : wave_speed2 - use control_flags, only: gamma_only, do_wf_cmplx!added:giovanni - ! - IMPLICIT NONE - ! - integer, intent(in) :: ngw ! number of plane wave coeff. - integer, intent(in) :: n ! number of bands - integer, intent(in) :: noff ! offset for band index - real(DP), intent(out) :: ekincm - real(DP), intent(in) :: ema0bg( ngw ), delt, emass - complex(DP), intent(in) :: c0( ngw, n ), cm( ngw, n ) - ! - real(DP), allocatable :: emainv(:) - real(DP) :: ftmp - integer :: i - logical :: lgam!added:giovanni - - lgam=gamma_only.and..not.do_wf_cmplx!added:giovanni - ALLOCATE( emainv( ngw ) ) - emainv = 1.0d0 / ema0bg - ftmp = 1.0d0 - if( gstart == 2 ) ftmp = 0.5d0 - - ekincm=0.0d0 - do i = noff, n + noff - 1 - ekincm = ekincm + 2.0d0 * wave_speed2( c0(:,i), cm(:,i), emainv, ftmp, lgam )!added:giovanni lgam - end do - ekincm = ekincm * emass / ( delt * delt ) - - CALL mp_sum( ekincm, intra_image_comm ) - DEALLOCATE( emainv ) - - return - end subroutine elec_fakekine_x - -!=----------------------------------------------------------------------------=! - SUBROUTINE protate_real_x ( c0, bec, c0rot, becrot, ngwl, nss, noff, lambda, nrl, & - na, nsp, ish, nh, np_rot, me_rot, comm_rot ) -!=----------------------------------------------------------------------------=! - - ! this routine rotates the wave functions using the matrix lambda - ! it works with a block-like distributed matrix - ! of the Lagrange multipliers ( lambda ). - ! no replicated data are used, allowing scalability for large problems. - ! the layout of lambda is as follows : - ! - ! (PE 0) (PE 1) .. (PE NPE-1) - ! lambda(1 ,1:nx) lambda(2 ,1:nx) .. lambda(NPE ,1:nx) - ! lambda(1+ NPE,1:nx) lambda(2+ NPE,1:nx) .. lambda(NPE+ NPE,1:nx) - ! lambda(1+2*NPE,1:nx) lambda(2+2*NPE,1:nx) .. lambda(NPE+2*NPE,1:nx) - ! - ! distributes lambda's rows across processors with a blocking factor - ! of 1, ( row 1 to PE 1, row 2 to PE 2, .. row nproc_image+1 to PE 1 and - ! so on). - ! nrl = local number of rows - ! ---------------------------------------------- - - ! ... declare modules - - USE kinds, ONLY: DP - USE mp, ONLY: mp_bcast - USE mp_global, ONLY: nproc_image, me_image, intra_image_comm - USE dspev_module, ONLY: pdspev_drv, dspev_drv - - IMPLICIT NONE - - ! ... declare subroutine arguments - - INTEGER, INTENT(IN) :: ngwl, nss, nrl, noff - INTEGER, INTENT(IN) :: na(:), nsp, ish(:), nh(:) - INTEGER, INTENT(IN) :: np_rot, me_rot, comm_rot - COMPLEX(DP), INTENT(IN) :: c0(:,:) - COMPLEX(DP), INTENT(OUT) :: c0rot(:,:) - REAL(DP), INTENT(IN) :: lambda(:,:) - REAL(DP), INTENT(IN) :: bec(:,:) - REAL(DP), INTENT(OUT) :: becrot(:,:) - - ! ... declare other variables - INTEGER :: i, j, k, ip - INTEGER :: jl, nrl_ip, is, ia, jv, jnl, nj - REAL(DP), ALLOCATABLE :: uu(:,:) - - IF( nss < 1 ) THEN - RETURN - END IF - - CALL start_clock('protate') - - DO i = 1, nss - c0rot( :, i+noff-1 ) = 0.0d0 - becrot(:,i+noff-1 ) = 0.0d0 - END DO - - - -! becrot = 0.0d0 -! c0rot = 0.0d0 - - DO ip = 1, np_rot - - nrl_ip = nss / np_rot - IF( (ip-1) < mod( nss, np_rot ) ) THEN - nrl_ip = nrl_ip + 1 - END IF - - ALLOCATE( uu( nrl_ip, nss ) ) - IF( me_rot .EQ. (ip-1) ) THEN - uu = lambda( 1:nrl_ip, 1:nss ) - END IF - CALL mp_bcast( uu, (ip-1), intra_image_comm) - - j = ip - DO jl = 1, nrl_ip - DO i = 1, nss - CALL DAXPY(2*ngwl,uu(jl,i),c0(1,j+noff-1),1,c0rot(1,i+noff-1),1) - END DO - - do is=1,nsp - do jv=1,nh(is) - do ia=1,na(is) - jnl=ish(is)+(jv-1)*na(is)+ia - do i = 1, nss - becrot(jnl,i+noff-1) = becrot(jnl,i+noff-1)+ uu(jl, i) * bec( jnl, j+noff-1 ) - end do - end do - end do - end do - - j = j + np_rot - END DO - - DEALLOCATE(uu) - - END DO - - CALL stop_clock('protate') - - RETURN - END SUBROUTINE protate_real_x - -!=----------------------------------------------------------------------------=! - SUBROUTINE protate_cmplx_x ( c0, bec, c0rot, becrot, ngwl, nss, noff, lambda, nrl, & - na, nsp, ish, nh, np_rot, me_rot, comm_rot ) -!=----------------------------------------------------------------------------=! - - ! this routine rotates the wave functions using the matrix lambda - ! it works with a block-like distributed matrix - ! of the Lagrange multipliers ( lambda ). - ! no replicated data are used, allowing scalability for large problems. - ! the layout of lambda is as follows : - ! - ! (PE 0) (PE 1) .. (PE NPE-1) - ! lambda(1 ,1:nx) lambda(2 ,1:nx) .. lambda(NPE ,1:nx) - ! lambda(1+ NPE,1:nx) lambda(2+ NPE,1:nx) .. lambda(NPE+ NPE,1:nx) - ! lambda(1+2*NPE,1:nx) lambda(2+2*NPE,1:nx) .. lambda(NPE+2*NPE,1:nx) - ! - ! distributes lambda's rows across processors with a blocking factor - ! of 1, ( row 1 to PE 1, row 2 to PE 2, .. row nproc_image+1 to PE 1 and - ! so on). - ! nrl = local number of rows - ! ---------------------------------------------- - - ! ... declare modules - - USE kinds, ONLY: DP - USE mp, ONLY: mp_bcast - USE mp_global, ONLY: nproc_image, me_image, intra_image_comm - USE dspev_module, ONLY: pdspev_drv, dspev_drv - - IMPLICIT NONE - - ! ... declare subroutine arguments - - INTEGER, INTENT(IN) :: ngwl, nss, nrl, noff - INTEGER, INTENT(IN) :: na(:), nsp, ish(:), nh(:) - INTEGER, INTENT(IN) :: np_rot, me_rot, comm_rot - COMPLEX(DP), INTENT(IN) :: c0(:,:) - COMPLEX(DP), INTENT(OUT) :: c0rot(:,:) - COMPLEX(DP), INTENT(IN) :: lambda(:,:) - COMPLEX(DP), INTENT(IN) :: bec(:,:) - COMPLEX(DP), INTENT(OUT) :: becrot(:,:) - - ! ... declare other variables - INTEGER :: i, j, k, ip - INTEGER :: jl, nrl_ip, is, ia, jv, jnl, nj - COMPLEX(DP), ALLOCATABLE :: uu(:,:) - - IF( nss < 1 ) THEN - RETURN - END IF - - CALL start_clock('protate') - - DO i = 1, nss - c0rot( :, i+noff-1 ) = 0.0d0 - becrot(:,i+noff-1 ) = 0.0d0 - END DO - - - -! becrot = 0.0d0 -! c0rot = 0.0d0 - - DO ip = 1, np_rot - - nrl_ip = nss / np_rot - IF( (ip-1) < mod( nss, np_rot ) ) THEN - nrl_ip = nrl_ip + 1 - END IF - - ALLOCATE( uu( nrl_ip, nss ) ) - IF( me_rot .EQ. (ip-1) ) THEN - uu = lambda( 1:nrl_ip, 1:nss ) - END IF - CALL mp_bcast( uu, (ip-1), intra_image_comm) - - j = ip - DO jl = 1, nrl_ip - DO i = 1, nss - CALL ZAXPY(ngwl,CONJG(uu(jl,i)),c0(1,j+noff-1),1,c0rot(1,i+noff-1),1) - END DO - - do is=1,nsp - do jv=1,nh(is) - do ia=1,na(is) - jnl=ish(is)+(jv-1)*na(is)+ia - do i = 1, nss - becrot(jnl,i+noff-1) = becrot(jnl,i+noff-1)+ CONJG(uu(jl, i)) * bec( jnl, j+noff-1 ) - end do - end do - end do - end do - - j = j + np_rot - END DO - - DEALLOCATE(uu) - - END DO - - CALL stop_clock('protate') - - RETURN - END SUBROUTINE protate_cmplx_x - -!=----------------------------------------------------------------------------=! - SUBROUTINE crot_gamma2_real ( c0rot, c0, ngw, n, noffr, noff, lambda, nx, eig ) -!=----------------------------------------------------------------------------=! - - ! this routine rotates the wave functions to the Kohn-Sham base - ! it works with a block-like distributed matrix - ! of the Lagrange multipliers ( lambda ). - ! - ! ... declare modules - - USE kinds, ONLY: DP - USE mp, ONLY: mp_bcast - USE mp_global, ONLY: nproc_image, me_image, intra_image_comm - USE dspev_module, ONLY: dspev_drv - - IMPLICIT NONE - - ! ... declare subroutine arguments - - INTEGER, INTENT(IN) :: ngw, n, nx, noffr, noff - COMPLEX(DP), INTENT(INOUT) :: c0rot(:,:) - COMPLEX(DP), INTENT(IN) :: c0(:,:) - REAL(DP), INTENT(IN) :: lambda(:,:) - REAL(DP), INTENT(OUT) :: eig(:) - - ! ... declare other variables - ! - REAL(DP), ALLOCATABLE :: vv(:,:), ap(:) - INTEGER :: i, j, k - - IF( nx < 1 ) THEN - RETURN - END IF - - ALLOCATE( vv( nx, nx ) ) - - ! NON distributed lambda - - ALLOCATE( ap( nx * ( nx + 1 ) / 2 ) ) - - K = 0 - DO J = 1, n - DO I = J, n - K = K + 1 - ap( k ) = lambda( i, j ) - END DO - END DO - - CALL dspev_drv( 'V', 'L', n, ap, eig, vv, nx ) - - DEALLOCATE( ap ) - - DO i = 1, n - c0rot( :, i+noffr-1 ) = 0.0d0 - END DO - - DO j = 1, n - DO i = 1, n - CALL DAXPY( 2*ngw, vv(j,i), c0(1,j+noff-1), 1, c0rot(1,i+noffr-1), 1 ) - END DO - END DO - - DEALLOCATE( vv ) - - RETURN - END SUBROUTINE crot_gamma2_real - -!=----------------------------------------------------------------------------=! - SUBROUTINE crot_gamma2_cmplx ( c0rot, c0, ngw, n, noffr, noff, lambda, nx, eig ) -!=----------------------------------------------------------------------------=! - - ! this routine rotates the wave functions to the Kohn-Sham base - ! it works with a block-like distributed matrix - ! of the Lagrange multipliers ( lambda ). - ! - ! ... declare modules - - USE kinds, ONLY: DP - USE mp, ONLY: mp_bcast - USE mp_global, ONLY: nproc_image, me_image, intra_image_comm - USE zhpev_module, ONLY: zhpev_drv - - IMPLICIT NONE - - ! ... declare subroutine arguments - - INTEGER, INTENT(IN) :: ngw, n, nx, noffr, noff - COMPLEX(DP), INTENT(INOUT) :: c0rot(:,:) - COMPLEX(DP), INTENT(IN) :: c0(:,:) - COMPLEX(DP), INTENT(IN) :: lambda(:,:) - REAL(DP), INTENT(OUT) :: eig(:) - - ! ... declare other variables - ! - COMPLEX(DP), ALLOCATABLE :: vv(:,:), ap(:) - INTEGER :: i, j, k - - IF( nx < 1 ) THEN - RETURN - END IF - - ALLOCATE( vv( nx, nx ) ) - - ! NON distributed lambda - - ALLOCATE( ap( nx * ( nx + 1 ) / 2 ) ) - - K = 0 - DO J = 1, n - DO I = J, n - K = K + 1 - ap( k ) = lambda( i, j ) - END DO - END DO - - CALL zhpev_drv( 'V', 'L', n, ap, eig, vv, nx ) - - DEALLOCATE( ap ) - - DO i = 1, n - c0rot( :, i+noffr-1 ) = 0.0d0 - END DO - - DO j = 1, n - DO i = 1, n - CALL ZAXPY( ngw, vv(j,i), c0(1,j+noff-1), 1, c0rot(1,i+noffr-1), 1 ) - END DO - END DO - - DEALLOCATE( vv ) - - RETURN - END SUBROUTINE crot_gamma2_cmplx - - -!=----------------------------------------------------------------------------=! - SUBROUTINE proj_gamma( a, b, ngw, n, noff, lambda) -!=----------------------------------------------------------------------------=! - - ! projection A=A-SUM{B}B - ! no replicated data are used, allowing scalability for large problems. - ! The layout of lambda is as follows : - ! - ! (PE 0) (PE 1) .. (PE NPE-1) - ! lambda(1 ,1:nx) lambda(2 ,1:nx) .. lambda(NPE ,1:nx) - ! lambda(1+ NPE,1:nx) lambda(2+ NPE,1:nx) .. lambda(NPE+ NPE,1:nx) - ! lambda(1+2*NPE,1:nx) lambda(2+2*NPE,1:nx) .. lambda(NPE+2*NPE,1:nx) - ! - ! distribute lambda's rows across processors with a blocking factor - ! of 1, ( row 1 to PE 1, row 2 to PE 2, .. row nproc_image+1 to PE 1 and so on). - ! ---------------------------------------------- - -! ... declare modules - USE kinds, ONLY: DP - USE mp_global, ONLY: nproc_image, me_image, intra_image_comm - USE wave_base, ONLY: dotp - USE reciprocal_vectors, ONLY: gzero - - IMPLICIT NONE - -! ... declare subroutine arguments - INTEGER, INTENT( IN ) :: ngw, n, noff - COMPLEX(DP), INTENT(INOUT) :: a(:,:), b(:,:) - REAL(DP), OPTIONAL :: lambda(:,:) - -! ... declare other variables - REAL(DP), ALLOCATABLE :: ee(:) - INTEGER :: i, j, jl - COMPLEX(DP) :: alp - -! ... end of declarations -! ---------------------------------------------- - - IF( n < 1 ) THEN - RETURN - END IF - - ALLOCATE( ee( n ) ) - DO i = 1, n - DO j = 1, n - ee(j) = -dotp( gzero, ngw, b(:,j+noff-1), a(:,i+noff-1) ) - END DO - IF( PRESENT(lambda) ) THEN - IF( MOD( (i-1), nproc_image ) == me_image ) THEN - DO j = 1, n - lambda( (i-1) / nproc_image + 1, j ) = ee(j) - END DO - END IF - END IF - DO j = 1, n - alp = CMPLX(ee(j),0.0d0) - CALL ZAXPY( ngw, alp, b(1,j+noff-1), 1, a(1,i+noff-1), 1 ) - END DO - END DO - DEALLOCATE(ee) - - RETURN - END SUBROUTINE proj_gamma - -!=----------------------------------------------------------------------------=! - SUBROUTINE wave_atom_init_x( cm, n, noff ) -!=----------------------------------------------------------------------------=! - - ! this routine sets the initial atomic wavefunctions - -! ... declare modules - USE kinds, ONLY: DP - USE mp, ONLY: mp_sum - USE mp_wave, ONLY: splitwf - USE mp_global, ONLY: me_image, nproc_image, root_image, intra_image_comm - USE reciprocal_vectors, ONLY: ig_l2g, ngw, ngwt, gzero - USE io_global, ONLY: stdout - USE random_numbers, ONLY: randy - USE control_flags, ONLY: ampre, tatomicwfc, trane - USE uspp_param, ONLY: n_atom_wfc - USE electrons_base, ONLY: nbsp - USE ions_base, ONLY: nat, nsp, ityp - USE cp_main_variables, ONLY: eigr - USE reciprocal_vectors, ONLY: ig_l2g, ngw, ngwt, gzero, gx, ngwx - USE constants, ONLY: tpi - - IMPLICIT NONE - - ! ... declare subroutine arguments - INTEGER, INTENT(IN) :: n, noff - COMPLEX(DP), INTENT(INOUT) :: cm(:,:) - - ! ... declare other variables - INTEGER :: ntest, ig, ib, natomwfc, ik - REAL(DP) :: rranf1, rranf2, rr, arg - COMPLEX(DP), ALLOCATABLE :: wfcatom(:,:) ! atomic wfcs for initialization - INTEGER :: ibnd, n_starting_wfc, n_starting_atomic_wfc - CHARACTER(len=15) :: subname="wave_atom_init" - - ! ... Check array dimensions - IF( SIZE( cm, 1 ) < ngw ) THEN - CALL errore(' wave_atom_init ', ' wrong dimensions ', 3) - END IF - - ! ... Reset them to zero - - cm( :, noff : noff + n - 1 ) = 0.0d0 - - ! ... initialize the wave functions in such a way that the values - ! ... of the components are independent on the number of processors - - ampre = 0.01d0 - write(6,*) "computing n_atom_wfc" - natomwfc = n_atom_wfc(nat, ityp, .false.) ! third value is noncolin, which is not yet implemented - ! - IF ( tatomicwfc ) THEN - ! - n_starting_wfc = MAX( natomwfc, n ) - n_starting_atomic_wfc = natomwfc - ! - ENDIF - - ALLOCATE( wfcatom( ngwx, n_starting_wfc ) ) - - IF ( tatomicwfc ) THEN - ! - write(6,*) "calling atomic_wfc" - CALL atomic_wfc( eigr, n_starting_atomic_wfc, wfcatom(:,1:n_starting_atomic_wfc) ) - write(6,*) "called atomic_wfc" - ! - IF ( trane .AND. & - n_starting_wfc == n_starting_atomic_wfc ) THEN - ! - ! ... in this case, introduce a small randomization of wavefunctions - ! ... to prevent possible "loss of states" - ! - DO ibnd = 1, n_starting_atomic_wfc - ! -!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ig, rr, arg) - DO ig = 1, ngw - ! - rr = randy() - arg = tpi * randy() - ! - wfcatom(ig,ibnd) = wfcatom(ig,ibnd) * & - ( 1.0_DP + 0.05_DP * CMPLX( rr*COS(arg), rr*SIN(arg)) ) - ! - END DO -!$OMP END PARALLEL DO - ! - END DO - ! - END IF - ! - END IF - ! - ! ... if not enough atomic wfc are available, - ! ... fill missing wfcs with random numbers - ! - DO ibnd = n_starting_atomic_wfc + 1, n_starting_wfc - ! - ! - wfcatom(:,ibnd) = (0.0_dp, 0.0_dp) - ! -!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ig, rr, arg) - DO ig = 1, ngw - ! - rr = randy() - arg = tpi * randy() - ! - wfcatom(ig,ibnd) = & - CMPLX( rr*COS( arg ), rr*SIN( arg ) ) / & - ( ( gx(1,ig) )**2 + & - ( gx(2,ig) )**2 + & - ( gx(3,ig) )**2 + 1.0_DP ) - END DO -!$OMP END PARALLEL DO - ! - END DO - - IF(n_starting_wfc.lt.n) THEN - call errore(subname, "warning: wavefunction not fully initialized", 1) - ENDIF - cm( :, noff : noff + min(n,n_starting_wfc) - 1 ) = wfcatom(:,1:min(n,n_starting_wfc)) - deallocate(wfcatom) - - RETURN - - END SUBROUTINE wave_atom_init_x - -!=----------------------------------------------------------------------------=! - SUBROUTINE wave_rand_init_x( cm, n, noff ) -!=----------------------------------------------------------------------------=! - - ! this routine sets the initial wavefunctions at random - -! ... declare modules - USE kinds, ONLY: DP - USE mp, ONLY: mp_sum - USE mp_wave, ONLY: splitwf - USE mp_global, ONLY: me_image, nproc_image, root_image, intra_image_comm - USE reciprocal_vectors, ONLY: ig_l2g, ngw, ngwt, gzero - USE io_global, ONLY: stdout - USE random_numbers, ONLY: randy - - IMPLICIT NONE - - ! ... declare subroutine arguments - INTEGER, INTENT(IN) :: n, noff - COMPLEX(DP), INTENT(OUT) :: cm(:,:) - - ! ... declare other variables - INTEGER :: ntest, ig, ib - REAL(DP) :: rranf1, rranf2, ampre - COMPLEX(DP), ALLOCATABLE :: pwt( : ) - - ! ... Check array dimensions - IF( SIZE( cm, 1 ) < ngw ) THEN - CALL errore(' wave_rand_init ', ' wrong dimensions ', 3) - END IF - - ! ... Reset them to zero - - cm( :, noff : noff + n - 1 ) = 0.0d0 - - ! ... initialize the wave functions in such a way that the values - ! ... of the components are independent on the number of processors - - ampre = 0.01d0 - ALLOCATE( pwt( ngwt ) ) - - ntest = ngwt / 4 - IF( ntest < SIZE( cm, 2 ) ) THEN - ntest = ngwt - END IF - ! - ! ... assign random values to wave functions - ! - DO ib = noff, noff + n - 1 - pwt( : ) = 0.0d0 - DO ig = 3, ntest - rranf1 = 0.5d0 - randy() - rranf2 = randy() - pwt( ig ) = ampre * CMPLX(rranf1, rranf2) - END DO - DO ig = 1, ngw - cm( ig, ib ) = pwt( ig_l2g( ig ) ) - END DO - END DO - IF ( gzero ) THEN - cm( 1, noff : noff + n - 1 ) = (0.0d0, 0.0d0) - END IF - - DEALLOCATE( pwt ) - - RETURN - END SUBROUTINE wave_rand_init_x - -!=----------------------------------------------------------------------------=! - SUBROUTINE wave_sine_init_x( cm, n, noff ) !added:giovanni -!=----------------------------------------------------------------------------=! - - ! this routine sets the initial wavefunctions at random - -! ... declare modules - USE kinds, ONLY: DP - USE mp, ONLY: mp_sum - USE mp_wave, ONLY: splitwf - USE mp_global, ONLY: me_image, nproc_image, root_image, intra_image_comm - USE reciprocal_vectors, ONLY: ig_l2g, ngw, ngwt, gzero, gx - USE io_global, ONLY: stdout - USE random_numbers, ONLY: randy - - IMPLICIT NONE - - ! ... declare subroutine arguments - INTEGER, INTENT(IN) :: n, noff - COMPLEX(DP), INTENT(OUT) :: cm(:,:) - - ! ... declare other variables - INTEGER :: ntest, ig, ib - REAL(DP) :: rranf1, rranf2, ampre - COMPLEX(DP), ALLOCATABLE :: pwt( : ) - - ! ... Check array dimensions - IF( SIZE( cm, 1 ) < ngw ) THEN - CALL errore(' wave_rand_init ', ' wrong dimensions ', 3) - END IF - - ! ... Reset them to zero - - cm( :, noff : noff + n - 1 ) = 0.0d0 - - ! ... initialize the wave functions in such a way that the values - ! ... of the components are independent of the number of processors - - ampre = 0.01d0 - ALLOCATE( pwt( ngw ) ) - - ntest = ngw - IF( ntest < SIZE( cm, 2 ) ) THEN - ntest = ngw - END IF - ! - ! ... assign real values to wave functions - ! - DO ib = noff, noff + n - 1 - pwt( : ) = CMPLX(0.0d0,0.d0) - DO ig = 1, ntest - rranf1 = dcos(ib*(gx(1, ig )))+dcos(ib*(gx(2, ig )))+dcos(ib*(gx(3, ig ))) - rranf2 = (dsin(ib*(gx(1,ig)))+dsin(ib*(gx(2, ig)))+dsin(ib*(gx(3, ig)))) - pwt( ig ) = ampre * CMPLX(rranf1, rranf2) - END DO - DO ig = 1, ngw - cm( ig, ib ) = pwt( ig ) - END DO - END DO - - DEALLOCATE( pwt ) - - RETURN - END SUBROUTINE wave_sine_init_x diff --git a/quantum_espresso/kcp/CPV/wave_init_wannier.f90 b/quantum_espresso/kcp/CPV/wave_init_wannier.f90 deleted file mode 100644 index c09771193..000000000 --- a/quantum_espresso/kcp/CPV/wave_init_wannier.f90 +++ /dev/null @@ -1,583 +0,0 @@ -!=----------------------------------------------------------------------------=! -SUBROUTINE wave_init_wannier_pwscf ( c0, nbndx ) -!=----------------------------------------------------------------------------=! - ! - ! this routine read the occupied wannier wave functions from pw2wannier PP code - ! and the wfc will be used as starting wfc for ODD functional. This will use - ! readempty routine to do this job - ! The same for empty states, but it will be read in the empty.f90 - ! - USE kinds, ONLY: DP - USE mp_global, ONLY: me_image, nproc_image, intra_image_comm - USE io_global, ONLY: stdout, ionode, ionode_id - USE mp, ONLY: mp_bcast, mp_sum - USE mp_wave, ONLY: splitwf - USE io_files, ONLY: outdir - USE io_files, ONLY: emptyunitc0 - USE electrons_base, ONLY: nspin, nupdwn, iupdwn - USE reciprocal_vectors, ONLY: ig_l2g - USE gvecw, ONLY: ngw - USE xml_io_base, ONLY: restart_dir, wfc_filename - USE control_flags, ONLY: ndr - ! - IMPLICIT none - ! - INTEGER, INTENT(IN) :: nbndx - COMPLEX(DP), INTENT(OUT) :: c0(ngw,nbndx) - ! - LOGICAL :: exst - INTEGER :: ig, ibnd, iss - INTEGER :: ngw_rd, nbnd_rd, ngw_l, ngw_g - ! - CHARACTER(LEN=256) :: fileocc, dirname - ! - COMPLEX(DP), ALLOCATABLE :: ctmp(:) - ! - ! ... Subroutine Body - ! - ngw_g = ngw - ngw_l = ngw - ! - CALL mp_sum( ngw_g, intra_image_comm ) - ! - ALLOCATE( ctmp(ngw_g) ) - c0(:,:) = (0.0_DP, 0.0_DP) - ! - dirname = restart_dir( outdir, ndr ) - ! - DO iss = 1, nspin - ! - fileocc = TRIM( wfc_filename( dirname, 'evc_occupied', 1, iss ) ) - ! - IF ( ionode ) THEN - ! - INQUIRE( FILE = TRIM(fileocc), EXIST = exst ) - ! - IF ( exst ) THEN - ! - OPEN( UNIT=emptyunitc0, FILE=TRIM(fileocc), STATUS='OLD', FORM='UNFORMATTED' ) - ! - READ(emptyunitc0) ngw_rd, nbnd_rd - ! - IF ( ngw_g .ne. ngw_rd .or. nbnd_rd .ne. nupdwn(iss) ) THEN - ! - exst = .false. - WRITE( stdout,10) TRIM(fileocc) - WRITE( stdout,20) ngw_g, ngw_rd - WRITE( stdout,30) nupdwn(iss), nbnd_rd - ! - ENDIF - ! - ENDIF - ! - ENDIF - ! -10 FORMAT('*** OCCUPIED STATES : wavefunctions dimensions changed ', A ) -20 FORMAT('*** NGW_G = ', I8, ' NGW_RD = ', I8) -30 FORMAT('*** NBND = ', I4, ' NBND_RD = ', I4) - ! - CALL mp_bcast(exst, ionode_id, intra_image_comm) - CALL mp_bcast(nbnd_rd, ionode_id, intra_image_comm) - CALL mp_bcast(ngw_rd, ionode_id, intra_image_comm) - ! - IF ( exst ) THEN - ! - DO ibnd = 1, nupdwn(iss) - ! - IF ( ionode ) THEN - ! - READ(emptyunitc0) ( ctmp(ig), ig = 1, MIN( SIZE(ctmp), ngw_rd ) ) - ! - ENDIF - ! - CALL splitwf(c0(:,ibnd + iupdwn(iss) - 1), ctmp, ngw_l, ig_l2g, me_image, & - nproc_image, ionode_id, intra_image_comm) - - ! - ENDDO - ! - ELSE - ! - IF (.not. exst ) CALL errore( 'wave_init_wannier_pwscf', 'Something wrong with reading evc_occupied files', 1 ) - ! - ENDIF - ! - IF ( ionode .AND. exst ) THEN - ! - CLOSE(emptyunitc0) - ! - ENDIF - ! - ENDDO - ! - DEALLOCATE(ctmp) - ! - RETURN - ! -END SUBROUTINE wave_init_wannier_pwscf - -!=----------------------------------------------------------------------------=! -SUBROUTINE wave_init_wannier_cp ( c0, ngw, nbndx, occupied_only) -!=----------------------------------------------------------------------------=! - ! - ! this routine rotates the wave functions to the Kohn-Sham base - ! it works with a block-like distributed matrix - ! of the Lagrange multipliers ( lambda ). - ! - ! ... declare modules - ! - USE kinds, ONLY: DP - USE mp, ONLY: mp_bcast - USE dspev_module, ONLY: dspev_drv - USE cp_interfaces, ONLY: set_evtot, readempty - USE electrons_base, ONLY: nspin, iupdwn, nupdwn - USE electrons_module, ONLY: iupdwn_emp, nupdwn_emp - USE wavefunctions_module, ONLY: ctot_aux - ! - IMPLICIT NONE - ! - ! ... declare subroutine arguments - ! - INTEGER, INTENT(IN) :: ngw, nbndx - COMPLEX(DP), INTENT(INOUT) :: c0(ngw, nbndx) - LOGICAL, INTENT(IN) :: occupied_only - ! - ! ... declare other variables - ! - COMPLEX(DP), ALLOCATABLE :: vv(:,:) - COMPLEX(DP), ALLOCATABLE :: ctot(:,:), c0_tmp(:,:) - INTEGER :: i, j, k, nx, n_occs, npw - ! - IF (occupied_only) THEN - ! - ! if this routine is called in occupied calculation, - ! c0 is the variational orbitalsi, and ctot is tranformed - ! from c0. - ! - ALLOCATE( ctot( SIZE( c0, 1 ), nupdwn(1)*nspin ) ) - ctot = (0.0d0, 0.0d0) - ctot(:,1:nupdwn(1)*nspin ) = ctot_aux(:,1:nupdwn(1)*nspin ) - ! - if (allocated(ctot_aux)) deallocate (ctot_aux) - !write(stdout,*) "in restart kipz lambda up", lambda(1)%cvec(1:3,1) - !write(stdout,*) "in restart kipz lambda dwn", lambda(2)%cvec(1:3,1) - !CALL set_evtot( c0, ctot, lambda, iupdwn, nupdwn ) - ! - nx = nupdwn(1) - ! - n_occs = nupdwn(1) - IF( nspin == 2 ) n_occs = n_occs + nupdwn(2) - ! - ELSE - ! - ! if this routine is called in the empty calculation - ! ctot (canonical orbitals) are read from file, - ! - ALLOCATE( ctot( SIZE( c0, 1 ), nupdwn_emp(1) * nspin ) ) - ctot = (0.0d0, 0.0d0) - ctot(:,:) = c0(:,:) - ! - nx = nupdwn_emp(1) - ! - n_occs = nupdwn_emp(1) - IF( nspin == 2 ) n_occs = n_occs + nupdwn_emp(2) - ! - END IF - ! - !write(stdout,*) "ctot in restart kipz", ctot(1:3, 1) - !write(stdout,*) "c0 in restart kipz", c0(1:3, 1) - ALLOCATE( vv( nx, nx ) ) - ! - ! read the optimal unitary matrix - ! - CALL conv_read_chkpt(vv, nx) - ! - ! convert canonical to minimizing orbitals - ! - ALLOCATE( c0_tmp( SIZE( c0, 1 ), nx ) ) - c0_tmp(:,:) = (0.0d0, 0.0d0) - ! - npw=SIZE( c0, 1 ) - do k=1, nx - do i=1, nx - c0_tmp(:,i) = c0_tmp(:,i) + vv(k,i)*ctot(:,k) - enddo !ibnd - enddo !wannier - ! - ! Symmetry the up and down spin - ! - c0=(0.0d0, 0.0d0) - ! - IF (occupied_only) THEN - ! - DO i = 1, MIN(nupdwn(1), n_occs) - ! - c0(:,i) = c0_tmp(:, i) - ! - ENDDO - ! - IF (nspin==2) THEN - ! - DO i = 1, MIN(nupdwn(1),nupdwn(2)) - ! - j=i+iupdwn(2)-1 - c0(:,j) = c0_tmp(:,i) - ! - ENDDO - ! - ENDIF - ! - ELSE - ! - DO i = 1, MIN(nupdwn_emp(1), n_occs) - ! - c0(:,i) = c0_tmp(:, i) - ! - ENDDO - ! - IF (nspin==2) THEN - ! - DO i = 1, MIN(nupdwn_emp(1),nupdwn_emp(2)) - ! - j=i+iupdwn_emp(2)-1 - c0(:,j) = c0_tmp(:,i) - ! - ENDDO - ! - ENDIF - ! - ENDIF - - DEALLOCATE( vv ) - DEALLOCATE( ctot , c0_tmp) - ! - RETURN - ! -END SUBROUTINE wave_init_wannier_cp -! -! -subroutine conv_read_chkpt(u_matrix_pass, nx) - ! - !=======================================! - ! Read formatted checkpoint file ! - !=======================================! - use kinds, only : dp - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_bcast, mp_sum - USE io_global, ONLY: ionode, ionode_id, stdout - USE input_parameters, ONLY: which_file_wannier - ! - implicit none - ! - integer, intent (in) :: nx - complex(dp), intent(inout) :: u_matrix_pass(nx, nx) - ! - integer :: chk_unit,i,j,k,l,nkp,ierr - character(len=50) :: seedname - ! - character(len=33) :: header - character(len=20) :: checkpoint - ! - integer, allocatable :: exclude_bands(:) - real(kind=dp), allocatable :: kpt_latt(:,:) !kpoints in lattice vecs - integer, allocatable :: ndimwin(:) - logical, allocatable :: lwindow(:,:) - ! - ! u_matrix_opt gives the num_wann dimension optimal subspace from the - ! original bloch states - ! - complex(kind=dp), allocatable :: u_matrix_opt(:,:,:) - ! - ! u_matrix gives the unitary rotations from the optimal subspace to the - ! optimally smooth states. - ! m_matrix we store here, because it is needed for restart of wannierise - ! - complex(kind=dp), allocatable :: u_matrix(:,:,:) - complex(kind=dp), allocatable :: m_matrix(:,:,:,:) - ! Wannier centres and spreads - ! - real(kind=dp), allocatable :: wannier_centres(:,:) - real(kind=dp), allocatable :: wannier_spreads(:) - ! - real(kind=dp) :: real_lattice(3,3) - real(kind=dp) :: recip_lattice(3,3) - integer :: mp_grid(3) - logical :: have_disentangled - ! - ! - integer :: num_bands, num_exclude_bands - integer :: num_kpts, nntot, num_wann - real(dp) :: omega_invariant - ! - seedname=which_file_wannier - ! - write(stdout,'(1x,3a)') 'Reading information from file ',trim(seedname),'.chk :' - ! - chk_unit=100 ! io_file_unit() - ! - if(ionode) then - ! - open(unit=chk_unit,file=trim(seedname)//'.chk',status='old',form='unformatted') - ! - ! Read comment line - ! - read(chk_unit) header - ! - ! Consistency checks - ! - read(chk_unit) num_bands ! Number of bands - read(chk_unit) num_exclude_bands ! Number of excluded bands - ! - endif - ! - call mp_bcast( header, ionode_id, intra_image_comm ) - call mp_bcast( num_bands, ionode_id, intra_image_comm ) - call mp_bcast( num_exclude_bands, ionode_id, intra_image_comm ) - ! - write(stdout,'(1x,a)') trim(header) - ! - write(stdout,'(a,i0)') "Number of bands: ", num_bands - ! - if (num_exclude_bands < 0) then - ! - call errore('conv_read_chkpt', 'Invalid value for num_exclude_bands', num_exclude_bands) - ! - endif - ! - allocate(exclude_bands(num_exclude_bands),stat=ierr) - ! - if(ionode) then - ! - read(chk_unit) (exclude_bands(i),i=1,num_exclude_bands) ! Excluded bands - ! - endif - ! - call mp_bcast( exclude_bands, ionode_id, intra_image_comm ) - ! - write(stdout,'(a)',advance='no') "Excluded bands: " - ! - if (num_exclude_bands == 0) then - ! - write(stdout,'(a)') "none." - ! - else - ! - do i=1,num_exclude_bands-1 - ! - write(stdout,'(I0,a)',advance='no') exclude_bands(i), ',' - ! - end do - ! - write(stdout,'(I0,a)') exclude_bands(num_exclude_bands), '.' - ! - end if - ! - if(ionode) then - ! - read(chk_unit) ((real_lattice(i,j),i=1,3),j=1,3) ! Real lattice - read(chk_unit) ((recip_lattice(i,j),i=1,3),j=1,3) ! Reciprocal lattice - read(chk_unit) num_kpts ! K-points - read(chk_unit) (mp_grid(i),i=1,3) ! M-P grid - ! - endif - ! - call mp_bcast( real_lattice, ionode_id, intra_image_comm ) - call mp_bcast( recip_lattice, ionode_id, intra_image_comm ) - call mp_bcast( num_kpts, ionode_id, intra_image_comm ) - call mp_bcast( mp_grid, ionode_id, intra_image_comm ) - ! - write(stdout,'(a)') "Real lattice: read." - ! - write(stdout,'(a)') "Reciprocal lattice: read." - ! - write(stdout,'(a,I0)') "Num kpts:", num_kpts - ! - write(stdout,'(a)') "mp_grid: read." - ! - if (.not.allocated(kpt_latt)) allocate(kpt_latt(3,num_kpts),stat=ierr) - ! - if(ionode) then - ! - read(chk_unit) ((kpt_latt(i,nkp),i=1,3),nkp=1,num_kpts) - read(chk_unit) nntot ! nntot - read(chk_unit) num_wann ! num_wann - read(chk_unit) checkpoint ! checkpoint - read(chk_unit) have_disentangled ! whether a disentanglement has been performed - ! - endif - ! - call mp_bcast( kpt_latt, ionode_id, intra_image_comm ) - call mp_bcast( nntot, ionode_id, intra_image_comm ) - call mp_bcast( num_wann, ionode_id, intra_image_comm ) - call mp_bcast( checkpoint, ionode_id, intra_image_comm ) - call mp_bcast( have_disentangled, ionode_id, intra_image_comm ) - ! - write(stdout,'(a)') "kpt_latt: read." - ! - write(stdout,'(a,I0)') "nntot:", nntot - ! - write(stdout,'(a,I0)') "num_wann:", num_wann - ! - checkpoint=adjustl(trim(checkpoint)) - ! - write(stdout,'(a,I0)') "checkpoint: " // trim(checkpoint) - ! - if (have_disentangled) then - ! - write(stdout,'(a)') "have_disentangled: TRUE" - ! - if (ionode) then - read(chk_unit) omega_invariant ! omega invariant - endif - ! - call mp_bcast( omega_invariant, ionode_id, intra_image_comm ) - ! - write(stdout,'(a)') "omega_invariant: read." - ! - ! lwindow - if (.not.allocated(lwindow)) then - ! - allocate(lwindow(num_bands,num_kpts),stat=ierr) - ! - endif - ! - if (ionode) then - read(chk_unit) ((lwindow(i,nkp),i=1,num_bands),nkp=1,num_kpts) - endif - ! - call mp_bcast( lwindow, ionode_id, intra_image_comm ) - ! - write(stdout,'(a)') "lwindow: read." - ! - ! ndimwin - ! - if (.not.allocated(ndimwin)) then - ! - allocate(ndimwin(num_kpts),stat=ierr) - ! - endif - ! - if (ionode) then - read(chk_unit) (ndimwin(nkp),nkp=1,num_kpts) - endif - ! - call mp_bcast( ndimwin, ionode_id, intra_image_comm ) - ! - write(stdout,'(a)') "ndimwin: read." - ! - ! U_matrix_opt - ! - if (.not.allocated(u_matrix_opt)) then - ! - allocate(u_matrix_opt(num_bands,num_wann,num_kpts),stat=ierr) - ! - endif - ! - if (ionode) then - read(chk_unit) (((u_matrix_opt(i,j,nkp),i=1,num_bands),j=1,num_wann),nkp=1,num_kpts) - endif - ! - call mp_bcast( u_matrix_opt, ionode_id, intra_image_comm ) - ! - write(stdout,'(a)') "U_matrix_opt: read." - ! - else - ! - write(stdout,'(a)') "have_disentangled: FALSE" - ! - endif - ! - ! U_matrix - ! - if (.not.allocated(u_matrix)) then - ! - allocate(u_matrix(num_wann,num_wann,num_kpts),stat=ierr) - ! - endif - ! - if (ionode) then - read(chk_unit) (((u_matrix(i,j,k),i=1,num_wann),j=1,num_wann),k=1,num_kpts) - ! NLN - !DO i=1,num_wann - ! DO j=1,num_wann - ! WRITE(*,*) '========== U matrix ==========' - ! WRITE(*,*) i,j,1 - ! WRITE(*,*) u_matrix(i,j,1) - ! ENDDO - !ENDDO - endif - ! - call mp_bcast( u_matrix, ionode_id, intra_image_comm ) - ! - write(stdout,'(a)') "U_matrix: read." - ! - ! M_matrix - ! - if (.not.allocated(m_matrix)) then - ! - allocate(m_matrix(num_wann,num_wann,nntot,num_kpts),stat=ierr) - ! - endif - ! - if (ionode) then - read(chk_unit) ((((m_matrix(i,j,k,l),i=1,num_wann),j=1,num_wann),k=1,nntot),l=1,num_kpts) - endif - ! - call mp_bcast( m_matrix, ionode_id, intra_image_comm ) - ! - write(stdout,'(a)') "M_matrix: read." - ! - ! wannier_centres - ! - if (.not.allocated(wannier_centres)) then - ! - allocate(wannier_centres(3,num_wann),stat=ierr) - ! - end if - ! - if (ionode) then - read(chk_unit) ((wannier_centres(i,j),i=1,3),j=1,num_wann) - endif - ! - call mp_bcast( wannier_centres, ionode_id, intra_image_comm ) - ! - write(stdout,'(a)') "wannier_centres: read." - ! - ! wannier spreads - ! - if (.not.allocated(wannier_spreads)) then - ! - allocate(wannier_spreads(num_wann),stat=ierr) - ! - end if - ! - if (ionode) then - read(chk_unit) (wannier_spreads(i),i=1, num_wann) - endif - call mp_bcast( wannier_spreads, ionode_id, intra_image_comm ) - ! - write(stdout,'(a)') "wannier_spreads: read." - write(stdout,*) wannier_spreads(1) - ! - close(chk_unit) - ! - write(stdout,'(a/)') ' ... done' - ! - ! RETURN U_MATRIX - ! - if (nx/=num_wann) call errore('conv_read_chkpt', 'different number nx and num_wann', nx) - u_matrix_pass (:,:) = u_matrix(:,:, 1) - ! - if (allocated(exclude_bands)) deallocate (exclude_bands) - if (allocated(kpt_latt)) deallocate (kpt_latt) - if (allocated(lwindow)) deallocate (lwindow) - if (allocated(ndimwin)) deallocate (ndimwin) - if (allocated(u_matrix_opt)) deallocate(u_matrix_opt) - if (allocated(u_matrix)) deallocate(u_matrix) - if (allocated(m_matrix)) deallocate(m_matrix) - if (allocated(wannier_centres)) deallocate(wannier_centres) - if (allocated(wannier_spreads)) deallocate(wannier_spreads) - ! - return - ! -end subroutine conv_read_chkpt diff --git a/quantum_espresso/kcp/CPV/wave_types.f90 b/quantum_espresso/kcp/CPV/wave_types.f90 deleted file mode 100644 index fbe581a39..000000000 --- a/quantum_espresso/kcp/CPV/wave_types.f90 +++ /dev/null @@ -1,189 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! ---------------------------------------------- -! BEGIN manual - -! ---------------------------------------------- ! - MODULE wave_types -! ---------------------------------------------- ! - -! ---------------------------------------------- -! END manual - - - USE kinds - IMPLICIT NONE - PRIVATE - SAVE - -! BEGIN manual -! TYPE DEFINITIONS - - TYPE wave_descriptor - - INTEGER :: ldg ! leading dimension for pw array dimension - INTEGER :: ldb ! leading dimension for band array dimension - INTEGER :: lds ! leading dimension for spin array dimension - INTEGER :: ldk ! leading dimension for k-points array dimension - - INTEGER :: ngwl ! local number of pw - INTEGER :: ngwt ! global number of pw - INTEGER :: nbl( 2 ) ! local number of bands - INTEGER :: nbt( 2 ) ! global number of bands - INTEGER :: nkl ! local number of k-points - INTEGER :: nkt ! global number of k-points - - INTEGER :: nspin ! number of spin - - INTEGER :: isym ! symmetry of the wave function - ! ( gamma symmetry: isym == 0 ) - - LOGICAL :: gamma ! true if wave functions have gamma symmetry - - LOGICAL :: gzero ! true if the first plane wave is the one - ! with |G| == 0 - - END TYPE wave_descriptor - -! ---------------------------------------------- -! END manual - - PUBLIC :: wave_descriptor, wave_descriptor_init, wave_descriptor_info - -! end of module-scope declarations -! ---------------------------------------------- - - CONTAINS - -! ---------------------------------------------- ! -! subroutines - - - SUBROUTINE wave_descriptor_init( desc, ngwl, ngwt, nbl, nbt, nkl, nkt, & - nspin, scheme, lgz ) - - IMPLICIT NONE - - TYPE (wave_descriptor), INTENT(OUT) :: desc - INTEGER, INTENT(IN) :: ngwl - INTEGER, INTENT(IN) :: ngwt - INTEGER, INTENT(IN) :: nbl( : ) - INTEGER, INTENT(IN) :: nbt( : ) - INTEGER, INTENT(IN) :: nkl - INTEGER, INTENT(IN) :: nkt - INTEGER, INTENT(IN) :: nspin - CHARACTER(LEN=*), INTENT(IN) :: scheme - LOGICAL, INTENT(IN) :: lgz - - INTEGER :: is - - ! g vectors - - IF( ngwt < 0 ) & - CALL errore( ' wave_descriptor_init ', ' arg no. 3 out of range ', 1 ) - - desc % ngwt = ngwt - - IF( ngwl <= 0 ) THEN - desc % ngwl = ngwt - ELSE IF( ngwl > ngwt ) THEN - CALL errore( ' wave_descriptor_init ', ' arg no. 2 incompatible with arg no. 3 ', 1 ) - ELSE - desc % ngwl = ngwl - END IF - - ! bands - - desc % nbt = 0 - DO is = 1, nspin - IF( nbt( is ) < 0 ) & - CALL errore( ' wave_descriptor_init ', ' arg no. 5 out of range ', 1 ) - desc % nbt( is ) = nbt( is ) - END DO - - - desc % nbl = 0 - DO is = 1, nspin - IF( nbl( is ) <= 0 ) THEN - desc % nbl( is ) = nbt( is ) - ELSE IF( nbl( is ) > nbt( is ) ) THEN - CALL errore( ' wave_descriptor_init ', ' arg no. 4 incompatible with arg no. 5 ', 1 ) - ELSE - desc % nbl( is ) = nbl( is ) - END IF - END DO - ! k - points - - IF( nkt < 0 ) & - CALL errore( ' wave_descriptor_init ', ' arg no. 7 out of range ', 1 ) - - desc % nkt = nkt - - IF( nkl <= 0 ) THEN - desc % nkl = nkt - ELSE IF( nkl > nkt ) THEN - CALL errore( ' wave_descriptor_init ', ' arg no. 6 incompatible with arg no. 7 ', 1 ) - ELSE - desc % nkl = nkl - END IF - - ! spin - - IF( nspin < 0 .OR. nspin > 2 ) & - CALL errore( ' wave_descriptor_init ', ' arg no. 8 out of range ', 1 ) - - desc % nspin = nspin - - ! other - - IF( TRIM( scheme ) == 'gamma' ) THEN - desc % isym = 0 - desc % gamma = .TRUE. - ELSE - desc % isym = 1 - desc % gamma = .FALSE. - END IF - - desc % gzero = lgz - - desc % ldg = MAX( 1, desc % ngwl ) - desc % ldb = MAX( 1, MAXVAL( desc % nbl ) ) - desc % ldk = MAX( 1, desc % nkl ) - desc % lds = MAX( 1, desc % nspin ) - - RETURN - END SUBROUTINE wave_descriptor_init - - - SUBROUTINE wave_descriptor_info( desc, nam, iunit ) - - IMPLICIT NONE - - TYPE (wave_descriptor), INTENT(IN) :: desc - INTEGER, INTENT(IN) :: iunit - CHARACTER(LEN=*) :: nam - - WRITE( iunit, 10 ) nam, desc%ldg, desc%ldb, desc%ldk, desc%lds, & - desc%ngwl, desc%ngwt, desc%nbl, desc%nbt, desc%nkl, desc%nkt, & - desc%nspin, desc%isym, desc%gzero - -10 FORMAT( 3X, 'Wave function descriptor . . . . . : ',A20,/ & - ,3X, 'leading dimensions (g,b,k,s) . . . : ',4I8,/ & - ,3X, 'num. of plane wave (Local, Global) : ',2I8,/& - ,3X, 'num. of bands (Local, Global). . . : ',4I5,/& - ,3X, 'num. of k points (Local, Global) . : ',2I5,/& - ,3X, 'num. of spin . . . . . . . . . . . : ',I4,/& - ,3X, 'symmetry . . . . . . . . . . . . . : ',I4,/& - ,3X, 'has G == 0 vector. . . . . . . . . : ',L7) - - RETURN - END SUBROUTINE wave_descriptor_info - -! ---------------------------------------------- ! - END MODULE wave_types -! ---------------------------------------------- ! diff --git a/quantum_espresso/kcp/CPV/waveinit.f90 b/quantum_espresso/kcp/CPV/waveinit.f90 deleted file mode 100644 index fbdf1442b..000000000 --- a/quantum_espresso/kcp/CPV/waveinit.f90 +++ /dev/null @@ -1,15 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -MODULE wave_init - - USE kinds - - IMPLICIT NONE - SAVE - -END MODULE wave_init diff --git a/quantum_espresso/kcp/CPV/wf.f90 b/quantum_espresso/kcp/CPV/wf.f90 deleted file mode 100644 index 90ed45124..000000000 --- a/quantum_espresso/kcp/CPV/wf.f90 +++ /dev/null @@ -1,3855 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -#define ZERO ( 0.D0, 0.D0 ) -#define ONE ( 1.D0, 0.D0 ) -#define CI ( 0.D0, 1.D0 ) -! -! ... written by Manu Sharma ( 2001-2005 ) -! -!---------------------------------------------------------------------------- -SUBROUTINE wf( clwf, c, bec, eigrb, irb, & - b1, b2, b3, Uall, what1, wfc, jw, ibrav ) - !---------------------------------------------------------------------------- - ! - ! ... this routine calculates overlap matrices - ! - ! ... routine makes use of c(-g)=c*(g) and beta(-g)=beta*(g) - ! - USE kinds, ONLY : DP - USE constants, ONLY : pi, tpi - USE ions_base, ONLY : na, nat - USE cvan, ONLY : nvb, ish - USE cell_base, ONLY : omega, a1, a2, a3, alat, h, ainv - USE electrons_base, ONLY : nspin, nbspx, nbsp, nupdwn, iupdwn - USE gvecb, ONLY : npb, nmb, ngb - USE gvecw, ONLY : ngw - USE reciprocal_vectors, ONLY : gstart - USE control_flags, ONLY : iprsta, do_wf_cmplx, gamma_only - USE qgb_mod, ONLY : qgb - USE wannier_base, ONLY : wfg, nw, weight, indexplus, indexplusz, & - indexminus, indexminusz, tag, tagp, & - expo, wfsd - USE grid_dimensions, ONLY : nr1, nr2, nr3 - USE smallbox_grid_dimensions, ONLY : nnrbx - USE uspp_param, ONLY : nh - USE uspp, ONLY : nkb - USE io_global, ONLY : ionode, stdout - USE mp, ONLY : mp_barrier, mp_sum - USE mp_wave, ONLY : redistwf - USE mp_global, ONLY : nproc_image, me_image, intra_image_comm - USE cp_interfaces, ONLY : invfft - USE fft_base, ONLY : dfftp, dfftb - USE printout_base, ONLY : printout_base_open, printout_base_unit, & - printout_base_close - USE parallel_include - USE twin_types - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: irb(3,nat), jw, ibrav, clwf -! TYPE(twin_matrix) :: bec - REAL(DP), INTENT(INOUT) :: bec(nkb,nbsp) - REAL(DP), INTENT(IN) :: b1(3), b2(3), b3(3) - COMPLEX(DP), INTENT(INOUT) :: c(ngw,nbspx) - COMPLEX(DP), INTENT(IN) :: eigrb(ngb,nat) - REAL(DP), INTENT(INOUT) :: Uall(nbsp,nbsp) - LOGICAL, INTENT(IN) :: what1 - REAL(DP), INTENT(OUT) :: wfc(3,nbsp) -! INTEGER, INTENT(IN) :: nbspx, nbsp, nupdwn(nspin), iupdwn(nspin) - ! - REAL(DP), ALLOCATABLE :: becwf(:,:), temp3(:,:) - COMPLEX(DP), ALLOCATABLE :: cwf(:,:), bec2(:), bec3(:), bec2up(:) - COMPLEX(DP), ALLOCATABLE :: bec2dw(:), bec3up(:), bec3dw(:) - COMPLEX(DP), ALLOCATABLE :: c_m(:,:), c_p(:,:), c_psp(:,:) - COMPLEX(DP), ALLOCATABLE :: c_msp(:,:) - INTEGER, ALLOCATABLE :: tagz(:) - REAL(DP), ALLOCATABLE :: Uspin(:,:) - COMPLEX(DP), ALLOCATABLE :: X(:,:), Xsp(:,:), X2(:,:), X3(:,:) - COMPLEX(DP), ALLOCATABLE :: O(:,:,:), Ospin(:,:,:), Oa(:,:,:) - COMPLEX(DP), ALLOCATABLE :: qv(:) - REAL(DP), ALLOCATABLE :: gr(:,:), mt(:), mt0(:), wr(:), W(:,:), EW(:,:) - INTEGER, ALLOCATABLE :: f3(:), f4(:) - COMPLEX(DP), ALLOCATABLE :: U2(:,:) - ! - INTEGER :: inl, jnl, isa, is, ia, ijv, i, j, k, ig, & - tk, iv, jv, inw, iqv, total, nstat, irb3 - REAL(DP) :: t1 - REAL(DP) :: wrsq, wrsqmin - COMPLEX(DP) :: qvt - REAL (DP) :: temp_vec(3) - INTEGER :: me - REAL(DP) :: te(6) - INTEGER :: iunit - - COMPLEX(DP), EXTERNAL :: boxdotgridcplx - LOGICAL :: lgam - ! -#if defined (__PARA) - ! - INTEGER :: proc, ngpwpp(nproc_image) - ! - COMPLEX(DP), ALLOCATABLE :: psitot(:,:), psitot_pl(:,:) - COMPLEX(DP), ALLOCATABLE :: psitot_mi(:,:) - INTEGER, ALLOCATABLE :: ns(:) - ! -#endif - ! - CALL start_clock('wf_1') - ! - lgam=gamma_only.and..not.do_wf_cmplx - me = me_image + 1 - ! - ALLOCATE( becwf(nkb,nbsp), temp3(nkb,nbsp), U2(nbsp,nbsp) ) - ALLOCATE( cwf(ngw,nbspx), bec2(nbsp), bec3(nbsp), bec2up(nupdwn(1)) ) - ALLOCATE( bec3up( nupdwn(1) ) ) - IF( nspin == 2 ) THEN - ALLOCATE( bec2dw( nupdwn(2) ), bec3dw( nupdwn(2) ) ) - ENDIF - ! - te = 0.D0 - ! - ALLOCATE( tagz( nw )) - ! - tagz(:) = 1 - tagz(3) = 0 - ! - ! ... set up matrix O - ! - ALLOCATE( O( nw, nbsp, nbsp ), X( nbsp, nbsp ), Oa( nw, nbsp, nbsp ) ) - ! - IF ( nspin == 2 .AND. nvb > 0 ) THEN - ! - ALLOCATE( X2( nupdwn(1), nupdwn(1) ) ) - ALLOCATE( X3( nupdwn(2), nupdwn(2) ) ) - ! - END IF - ! -#if defined (__PARA) - ! - ! Compute the number of states to each processor - ! - ALLOCATE( ns( nproc_image ) ) - ns = nbsp / nproc_image - DO j = 1, nbsp - IF( (j-1) < MOD( nbsp, nproc_image ) ) ns( j ) = ns( j ) + 1 - END DO - IF(iprsta.GT.4) THEN - DO j=1,nproc_image - WRITE( stdout, * ) ns(j) - END DO - END IF - ! - nstat = ns( me ) - - total = 0 - DO proc=1,nproc_image - ngpwpp(proc)=(dfftp%nwl(proc)+1)/2 - total=total+ngpwpp(proc) - IF(iprsta.GT.4) THEN - WRITE( stdout, * ) "I am proceessor", proc, "and i have ",ns(me)," states." - END IF - END DO - ! - ALLOCATE(psitot(total,nstat)) - ALLOCATE(psitot_pl(total,nstat)) - ALLOCATE(psitot_mi(total,nstat)) - - ALLOCATE(c_p(ngw,nbspx)) - ALLOCATE(c_m(ngw,nbspx)) - IF(iprsta.GT.4) THEN - WRITE( stdout, * ) "All allocations done" - END IF - ! - ! ... Step 1. Communicate to all Procs so that each proc has all - ! ... G-vectors and some states instead of all states and some - ! ... G-vectors. This information is stored in the 1-d array - ! ... psitot1. - ! - ! Step 2. Convert the 1-d array psitot1 into a 2-d array consistent with the - ! original notation c(ngw,nbsp). Psitot contains ntot = SUM_Procs(ngw) G-vecs - ! and nstat states instead of all nbsp states - ! - ! - CALL redistwf( c, psitot, ngpwpp, ns, intra_image_comm, 1 ) - ! -#endif - - IF( clwf .EQ. 5 ) THEN - ! - CALL write_psi( c, jw ) - ! - END IF - ! - ! -#if defined (__PARA) - ! - ! Step 3. do the translation of the 2-d array to get the transtalted - ! arrays psitot_pl and psittot_mi, corresponding to G+G' and -G+G' - ! - DO inw=1,nw - ! - ! Intermediate Check. If the translation is only along the z-direction - ! no interprocessor communication and data rearrangement is required - ! because each processor contains all the G- components in the z-dir. - ! - IF(tagz(inw).EQ.0) THEN - DO i=1,nbsp - DO ig=1,ngw - IF(indexplusz(ig).EQ.-1) THEN - c_p(ig,i)=(0.D0,0.D0) - ELSE - c_p(ig,i)=c(indexplusz(ig),i) - END IF - IF(indexminusz(ig).EQ.-1) THEN - c_m(ig,i)=(0.D0,0.D0) - ELSE - c_m(ig,i)=CONJG(c(indexminusz(ig),i)) - END IF - END DO - END DO - ELSE - DO i=1,ns(me) - DO ig=1,total - IF(indexplus(ig,inw).EQ.-1) THEN - psitot_pl(ig,i)=(0.D0,0.D0) - ELSE - IF(tagp(ig,inw).EQ.1) THEN - psitot_pl(ig,i)=CONJG(psitot(indexplus(ig,inw),i)) - ELSE - psitot_pl(ig,i)=psitot(indexplus(ig,inw),i) - END IF - END IF - IF(indexminus(ig,inw).EQ.-1) THEN - psitot_mi(ig,i)=(0.D0,0.D0) - ELSE - IF(tag(ig,inw).EQ.1) THEN - psitot_mi(ig,i)=CONJG(psitot(indexminus(ig,inw),i)) - ELSE - psitot_mi(ig,i)=psitot(indexminus(ig,inw),i) - END IF - END IF - END DO - END DO - IF(iprsta.GT.4) THEN - WRITE( stdout, * ) "Step 3. do the translation of the 2-d array...Done, wf" - END IF - ! - ! Step 4. Convert the 2-d arrays psitot_p and psitot_m into 1-d - ! arrays - ! - ! Step 5. Redistribute among processors. The result is stored in 2-d - ! arrays c_p and c_m consistent with the notation c(ngw,nbsp), such that - ! c_p(j,i) contains the coeffiCIent for c(j,i) corresponding to G+G' - ! and c_m(j,i) contains the coeffiCIent for c(j,i) corresponding to -G+G' - ! - c_p = 0.D0 - CALL redistwf( c_p, psitot_pl, ngpwpp, ns, intra_image_comm, -1 ) - ! - c_m = 0.D0 - CALL redistwf( c_m, psitot_mi, ngpwpp, ns, intra_image_comm, -1 ) - ! - END IF - ! -#else - ! - ALLOCATE(c_p(ngw,nbspx)) - ALLOCATE(c_m(ngw,nbspx)) - DO inw=1,nw - IF(tagz(inw).EQ.0) THEN - DO i=1,nbsp - DO ig=1,ngw - IF(indexplusz(ig).EQ.-1) THEN - c_p(ig,i)=(0.D0,0.D0) - ELSE - c_p(ig,i)=c(indexplusz(ig),i) - END IF - IF(indexminusz(ig).EQ.-1) THEN - c_m(ig,i)=(0.D0,0.D0) - ELSE - c_m(ig,i)=CONJG(c(indexminusz(ig),i)) - END IF - END DO - END DO - ELSE - DO i=1,nbsp - DO ig=1,ngw - IF(indexplus(ig,inw).EQ.-1) THEN - c_p(ig,i)=(0.D0,0.D0) - ELSE - IF(tagp(ig,inw).EQ.1) THEN - c_p(ig,i)=CONJG(c(indexplus(ig,inw),i)) - ELSE - c_p(ig,i)=c(indexplus(ig,inw),i) - END IF - END IF - IF(indexminus(ig,inw).EQ.-1) THEN - c_m(ig,i)=(0.D0,0.D0) - ELSE - IF(tag(ig,inw).EQ.1) THEN - c_m(ig,i)=CONJG(c(indexminus(ig,inw),i)) - ELSE - c_m(ig,i)=c(indexminus(ig,inw),i) - END IF - END IF - END DO - END DO - END IF - ! -#endif - ! - ! ... Step 6. Calculate Overlaps - ! - ! ... Augmentation Part first - ! - ALLOCATE( qv( nnrbx ) ) - ! - X = ZERO - ! - isa = 1 - DO is = 1, nvb - DO ia =1, na(is) - DO iv = 1, nh(is) - inl = ish(is) + (iv-1)*na(is) + ia - jv = iv - ijv=(jv-1)*jv/2 + iv - qv( 1 : nnrbx ) = 0.D0 - DO ig=1,ngb - qv(npb(ig))=eigrb(ig,isa)*qgb(ig,ijv,is) - qv(nmb(ig))=CONJG(eigrb(ig,isa)*qgb(ig,ijv,is)) - END DO -#ifdef __PARA - irb3=irb(3,isa) -#endif - CALL invfft('Box',qv,dfftb,isa) - iqv=1 - qvt=(0.D0,0.D0) - qvt=boxdotgridcplx(irb(1,isa),qv,expo(1,inw)) - -#ifdef __PARA - CALL mp_sum( qvt, intra_image_comm ) -#endif - ! - IF (nspin.EQ.1) THEN - bec2(1:nbsp)=(0.D0,0.D0) - bec2(1:nbsp)=bec(inl,1:nbsp)*ONE - CALL ZSYRK('U','T',nbsp,1,qvt,bec2,1,ONE,X,nbsp) - ELSE - X2=(0.D0,0.D0) - X3=(0.D0,0.D0) - bec2up(1:nupdwn(1))=(0.D0,0.D0) - bec2up(1:nupdwn(1))=bec(inl,1:nupdwn(1)) - CALL ZSYRK('U','T',nupdwn(1),1,qvt,bec2up,1,ONE,X2,nupdwn(1)) - bec2dw(1:nupdwn(2))=(0.D0,0.D0) - bec2dw(1:nupdwn(2))=bec(inl,iupdwn(2):nbsp) - CALL ZSYRK('U','T',nupdwn(2),1,qvt,bec2dw,1,ONE,X3,nupdwn(2)) - DO i = 1, nupdwn(1) - DO j=i, nupdwn(1) - X(i,j)=X(i,j)+X2(i,j) - END DO - END DO - DO i = 1,nupdwn(2) - DO j=i,nupdwn(2) - X(i+nupdwn(1),j+nupdwn(1)) =X(i+nupdwn(1),j+nupdwn(1)) + X3(i,j) - END DO - END DO - END IF - DO jv = iv+1, nh(is) - jnl = ish(is) + (jv-1)*na(is) + ia - ijv = (jv-1)*jv/2 + iv - qv( 1:nnrbx ) = 0.D0 - DO ig=1,ngb - qv(npb(ig))=eigrb(ig,isa)*qgb(ig,ijv,is) - qv(nmb(ig))=CONJG(eigrb(ig,isa)*qgb(ig,ijv,is)) - END DO - CALL invfft('Box',qv,dfftb,isa) - iqv=1 - qvt=0.D0 - qvt=boxdotgridcplx(irb(1,isa),qv,expo(1,inw)) -#ifdef __PARA - CALL mp_sum( qvt, intra_image_comm ) -#endif - ! - IF (nspin.EQ.1) THEN - bec2(1:nbsp)=(0.D0,0.D0) - bec3(1:nbsp)=(0.D0,0.D0) - bec2(1:nbsp)=bec(inl,1:nbsp)*ONE - bec3(1:nbsp)=bec(jnl,1:nbsp)*ONE - CALL ZSYR2K('U','T',nbsp,1,qvt,bec2,1,bec3,1,ONE,X,nbsp) - ELSE - X2=(0.D0,0.D0) - X3=(0.D0,0.D0) - bec2up(1:nupdwn(1))=(0.D0,0.D0) - bec3up(1:nupdwn(1))=(0.D0,0.D0) - bec2up(1:nupdwn(1))=bec(inl,1:nupdwn(1))*ONE - bec3up(1:nupdwn(1))=bec(jnl,1:nupdwn(1))*ONE - CALL ZSYR2K('U','T',nupdwn(1),1,qvt,bec2up,1,bec3up,1,ONE,X2,nupdwn(1)) - bec2dw(1:nupdwn(2))=(0.D0,0.D0) - bec3dw(1:nupdwn(2))=(0.D0,0.D0) - bec2dw(1:nupdwn(2))=bec(inl,iupdwn(2):nbsp)*ONE - bec3dw(1:nupdwn(2))=bec(jnl,iupdwn(2):nbsp)*ONE - CALL ZSYR2K('U','T',nupdwn(2),1,qvt,bec2dw,1,bec3dw,1,ONE,X3,nupdwn(2)) - DO i = 1, nupdwn(1) - DO j=i, nupdwn(1) - X(i,j)=X(i,j)+X2(i,j) - END DO - END DO - DO i = 1,nupdwn(2) - DO j=i,nupdwn(2) - X(i+nupdwn(1),j+nupdwn(1)) =X(i+nupdwn(1),j+nupdwn(1)) + X3(i,j) - END DO - END DO - END IF - END DO - END DO - isa = isa + 1 - END DO - END DO - t1=omega/DBLE(nr1*nr2*nr3) - X=X*t1 - DO i=1, nbsp - DO j=i+1, nbsp - X(j, i)=X(i, j) - END DO - END DO - Oa(inw, :, :)=X(:, :) - IF(iprsta.GT.4) THEN - WRITE( stdout, * ) "Augmentation Part Done" - END IF - - DEALLOCATE( qv ) - - - ! Then Soft Part - IF( nspin == 1 ) THEN - ! Spin Unpolarized calculation - X=0.D0 - IF( gstart == 2 ) THEN - c_m(1,:)=0.D0 - END IF - ! cwf(:,:)=ZERO - ! cwf(:,:)=c(:,:) - CALL ZGEMM('C','N',nbsp,nbsp,ngw,ONE,c,ngw,c_p,ngw,ONE,X,nbsp) - CALL ZGEMM('T','N',nbsp,nbsp,ngw,ONE,c,ngw,c_m,ngw,ONE,X,nbsp) - - CALL mp_sum ( X, intra_image_comm ) - - O(inw,:,:)=Oa(inw,:,:)+X(:,:) - - IF(iprsta.GT.4) THEN - WRITE( stdout, * ) "Soft Part Done" - END IF - - ELSE - ! Spin Polarized case - ! Up Spin First - ALLOCATE(Xsp(nbsp,nupdwn(1))) - ALLOCATE(c_psp(ngw,nupdwn(1))) - ALLOCATE(c_msp(ngw,nupdwn(1))) - Xsp=0.D0 - c_psp=0.D0 - c_msp=0.D0 - DO i=1,nupdwn(1) - c_psp(:,i)=c_p(:,i) - c_msp(:,i)=c_m(:,i) - END DO - IF(gstart.EQ.2) THEN - c_msp(1,:)=0.D0 - END IF - ! cwf(:,:)=ZERO - ! cwf(:,:)=c(:,:,1,1) - CALL ZGEMM('C','N',nbsp,nupdwn(1),ngw,ONE,c,ngw,c_psp,ngw,ONE,Xsp,nbsp) - CALL ZGEMM('T','N',nbsp,nupdwn(1),ngw,ONE,c,ngw,c_msp,ngw,ONE,Xsp,nbsp) -#ifdef __PARA - CALL mp_sum ( Xsp, intra_image_comm ) -#endif - DO i=1,nupdwn(1) - DO j=1,nbsp - X(j,i)=Xsp(j,i) - END DO - END DO - DEALLOCATE(Xsp,c_psp,c_msp) - ! Then Down Spin - ALLOCATE(Xsp(nbsp,iupdwn(2):nbsp)) - ALLOCATE(c_psp(ngw,iupdwn(2):nbsp)) - ALLOCATE(c_msp(ngw,iupdwn(2):nbsp)) - Xsp=0.D0 - c_psp=0.D0 - c_msp=0.D0 - DO i=iupdwn(2),nbsp - c_psp(:,i)=c_p(:,i) - c_msp(:,i)=c_m(:,i) - END DO - IF(gstart.EQ.2) THEN - c_msp(1,:)=0.D0 - END IF - ! cwf(:,:)=ZERO - ! cwf(:,:)=c(:,:,1,1) - CALL ZGEMM('C','N',nbsp,nupdwn(2),ngw,ONE,c,ngw,c_psp,ngw,ONE,Xsp,nbsp) - CALL ZGEMM('T','N',nbsp,nupdwn(2),ngw,ONE,c,ngw,c_msp,ngw,ONE,Xsp,nbsp) -#ifdef __PARA - CALL mp_sum ( Xsp, intra_image_comm ) -#endif - DO i=iupdwn(2),nbsp - DO j=1,nbsp - X(j,i)=Xsp(j,i) - END DO - END DO - DEALLOCATE(Xsp,c_psp,c_msp) - O(inw,:,:)=Oa(inw,:,:)+X(:,:) - END IF - - - END DO - -#ifdef __PARA - DEALLOCATE(ns) -#endif - - CALL stop_clock('wf_1') - - DEALLOCATE( X ) - IF ( ALLOCATED( X2 ) ) DEALLOCATE( X2 ) - IF ( ALLOCATED( X3 ) ) DEALLOCATE( X3 ) - ! - - CALL start_clock('wf_2') - - - IF(clwf.EQ.2) THEN - ! output the overlap matrix to fort.38 - IF(me.EQ.1) THEN - REWIND 38 - WRITE(38, '(i5, 2i2, i3, f9.5)') nbsp, nw, nspin, ibrav, alat - IF (nspin.EQ.2) THEN - WRITE(38, '(i5)') nupdwn(1) - END IF - WRITE(38, *) a1 - WRITE(38, *) a2 - WRITE(38, *) a3 - WRITE(38, *) b1 - WRITE(38, *) b2 - WRITE(38, *) b3 - DO inw=1, nw - WRITE(38, *) wfg(inw, :), weight(inw) - END DO - DO inw=1, nw - DO i=1, nbsp - DO j=1, nbsp - WRITE(38, *) O(inw, i, j) - END DO - END DO - END DO - DO i=1, nbsp - DO j=1, nbsp - WRITE(38, *) Uall(i, j) - END DO - END DO - CLOSE(38) - END IF - CALL stop_run( .TRUE. ) - END IF - - IF(clwf.EQ.3.OR.clwf.EQ.4) THEN - IF(nspin.EQ.1) THEN - IF(.NOT.what1) THEN - IF(wfsd==1) THEN - CALL ddyn(nbsp,O,Uall) - ELSE IF(wfsd==2) THEN - CALL wfsteep(nbsp,O,Uall) - ELSE IF(wfsd==3) THEN - CALL jacobi_rotation(nbsp,O,Uall) - END IF - END IF - IF(iprsta.GT.4) THEN - WRITE( stdout, * ) "Out from DDYN" - END IF - ELSE - ALLOCATE(Uspin(nupdwn(1), nupdwn(1)), Ospin(nw, nupdwn(1), nupdwn(1))) - DO i=1, nupdwn(1) - DO j=1, nupdwn(1) - Uspin(i, j)=Uall(i, j) - Ospin(:, i, j)=O(:, i, j) - END DO - END DO - IF(.NOT.what1) THEN - IF(wfsd==1) THEN - CALL ddyn(nupdwn(1), Ospin, Uspin) - ELSE IF (wfsd==2) THEN - CALL wfsteep(nupdwn(1), Ospin, Uspin) - ELSE - CALL jacobi_rotation(nupdwn(1), Ospin, Uspin) - END IF - END IF - DO i=1, nupdwn(1) - DO j=1, nupdwn(1) - Uall(i, j)=Uspin(i, j) - O(:,i,j) =Ospin(:,i,j) - END DO - END DO - DEALLOCATE(Uspin, Ospin) - ALLOCATE(Uspin(nupdwn(2), nupdwn(2)), Ospin(nw, nupdwn(2), nupdwn(2))) - DO i=1, nupdwn(2) - DO j=1, nupdwn(2) - Uspin(i, j)=Uall(i+nupdwn(1), j+nupdwn(1)) - Ospin(:, i, j)=O(:, i+nupdwn(1), j+nupdwn(1)) - END DO - END DO - IF(.NOT.what1) THEN - IF(wfsd==1) THEN - CALL ddyn(nupdwn(2), Ospin, Uspin) - ELSE IF (wfsd==2) THEN - CALL wfsteep(nupdwn(2), Ospin, Uspin) - ELSE - CALL jacobi_rotation(nupdwn(2), Ospin, Uspin) - END IF - END IF - DO i=1, nupdwn(2) - DO j=1, nupdwn(2) - Uall(i+nupdwn(1), j+nupdwn(1))=Uspin(i, j) - O(:,i+nupdwn(1),j+nupdwn(1))=Ospin(:,i,j) - END DO - END DO - DEALLOCATE(Uspin, Ospin) - END IF - END IF - - ! Update C and bec - cwf=ZERO - ! cwf(:,:)=c(:,:,1,1) - becwf=0.0d0 - U2=Uall*ONE - CALL ZGEMM('N','N',ngw,nbsp,nbsp,ONE,c,ngw,U2,nbsp,ZERO,cwf,ngw) - ! call ZGEMM('nbsp','nbsp',ngw,nbsp,nbsp,ONE,cwf,ngw,U2,nbsp,ZERO,cwf,ngw) - CALL DGEMM('N','N',nkb,nbsp,nbsp,ONE,bec,nkb,Uall,nbsp,ZERO,becwf,nkb) - U2=ZERO - IF(iprsta.GT.4) THEN - WRITE( stdout, * ) "Updating Wafefunctions and Bec" - END IF - - c(:,:)=cwf(:,:) - bec(:,:)=becwf(:,:) - - IF(iprsta.GT.4) THEN - WRITE( stdout, * ) "Wafefunctions and Bec Updated" - END IF - ! - ! calculate wannier-function centers - ! - ALLOCATE( wr(nw), W(nw,nw), gr(nw,3), EW(nw,nw), f3(nw), f4(nw), mt0(nw), mt(nw) ) - ! - DO inw=1, nw - gr(inw, :)=wfg(inw,1)*b1(:)+wfg(inw,2)*b2(:)+wfg(inw,3)*b3(:) - END DO - ! - ! set up a matrix with the element (i,j) is G_i·G_j·weight(j) - ! to check the correctness of choices on G vectors - ! - DO i=1, nw - DO j=1, nw - W(i,j)=DOT_PRODUCT(gr(i,:),gr(j,:))*weight(j) - END DO - END DO - ! - EW = W - DO i=1,nw - EW(i,i) = EW(i,i)-1.D0 - END DO - ! - ! ... balance the phase factor if necessary - ! - ! adjust mt : very inefficient routine added by Young-Su -> must be improved - DO i=1, nbsp - mt0(:) = -AIMAG(LOG(O(:,i,i)))/tpi - wr = MATMUL(EW,mt0) - wrsq = SUM(wr(:)**2) - IF ( wrsq .lt. 1.D-6 ) THEN - mt = mt0 - ELSE - wrsqmin = 100.D0 -COMB: DO k=3**nw-1,0,-1 - tk=k - DO j=nw,1,-1 - f3(j)=tk/3**(j-1) - tk=tk-f3(j)*3**(j-1) - END DO - mt(:)=mt0(:)+f3(:)-1 - wr = MATMUL(EW,mt) - wrsq = SUM(wr(:)**2) - IF ( wrsq .lt. wrsqmin ) THEN - wrsqmin = wrsq - f4(:)=f3(:)-1 - END IF - END DO COMB - mt = mt0 + f4 - END IF - ! - wfc(1, i) = SUM(mt*weight(:)*gr(:,1))*alat - wfc(2, i) = SUM(mt*weight(:)*gr(:,2))*alat - wfc(3, i) = SUM(mt*weight(:)*gr(:,3))*alat - ! - END DO - ! - IF ( ionode ) THEN - ! - iunit = printout_base_unit( "wfc" ) - CALL printout_base_open( "wfc" ) - IF ( .NOT. what1 ) THEN - ! - ! ... pbc are imposed here in the range [0,1] - ! - DO i = 1, nbsp - ! - temp_vec(:) = MATMUL( ainv(:,:), wfc(:,i) ) - ! - temp_vec(:) = temp_vec(:) - floor (temp_vec(:)) - ! - temp_vec(:) = MATMUL( h(:,:), temp_vec(:) ) - ! - WRITE( iunit, '(3f20.14)' ) temp_vec(:) - ! - END DO - ! - END IF - CALL printout_base_close( "wfc" ) - ! - END IF - ! - ! - ! - DEALLOCATE( wr, W, gr, EW, f3, f4, mt0, mt ) - ! -#if defined (__PARA) - ! - DEALLOCATE( psitot ) - DEALLOCATE( psitot_pl ) - DEALLOCATE( psitot_mi ) - ! -#endif - ! - DEALLOCATE( c_p, c_m ) - ! - DEALLOCATE( O ) - DEALLOCATE( Oa ) - DEALLOCATE( tagz ) - DEALLOCATE( becwf, temp3, U2 ) - DEALLOCATE( cwf, bec2, bec3, bec2up, bec3up ) - IF( ALLOCATED( bec2dw ) ) DEALLOCATE( bec2dw ) - IF( ALLOCATED( bec3dw ) ) DEALLOCATE( bec3dw ) - - CALL stop_clock('wf_2') - ! - RETURN - ! -END SUBROUTINE wf -! -! !---------------------------------------------------------------------------- -! SUBROUTINE wf_new( clwf, c, bec, eigr, eigrb, taub, irb, & -! b1, b2, b3, Uall, what1, wfc, jw, ibrav, nbspx, nbsp, nupdwn, iupdwn ) -! !---------------------------------------------------------------------------- -! ! -! ! ... this routine calculates overlap matrices -! ! -! ! ... routine makes use of c(-g)=c*(g) and beta(-g)=beta*(g) -! ! -! USE kinds, ONLY : DP -! USE constants, ONLY : pi, tpi -! USE ions_base, ONLY : nsp, na, nax, nat -! USE cvan, ONLY : nvb, ish -! USE cell_base, ONLY : omega, a1, a2, a3, alat, h, ainv -! USE electrons_base, ONLY : nspin -! USE gvecb, ONLY : npb, nmb, ngb -! USE gvecw, ONLY : ngw -! USE reciprocal_vectors, ONLY : gstart -! USE smooth_grid_dimensions, ONLY : nnrsx -! USE control_flags, ONLY : iprsta, do_wf_cmplx, gamma_only -! USE qgb_mod, ONLY : qgb -! USE wannier_base, ONLY : wfg, nw, weight, indexplus, indexplusz, & -! indexminus, indexminusz, tag, tagp, & -! expo, wfsd -! USE grid_dimensions, ONLY : nr1, nr2, nr3 -! USE smallbox_grid_dimensions, ONLY : nnrbx -! USE uspp_param, ONLY : nh, nhm -! USE uspp, ONLY : nkb -! USE io_global, ONLY : ionode, stdout -! USE mp, ONLY : mp_barrier, mp_sum -! USE mp_wave, ONLY : redistwf -! USE mp_global, ONLY : nproc_image, me_image, root_image, intra_image_comm -! USE cp_interfaces, ONLY : invfft -! USE fft_base, ONLY : dfftp, dfftb -! USE printout_base, ONLY : printout_base_open, printout_base_unit, & -! printout_base_close -! USE parallel_include -! USE twin_types -! ! -! IMPLICIT NONE -! ! -! INTEGER, INTENT(IN) :: irb(3,nat), jw, ibrav, clwf -! TYPE(twin_matrix) :: bec -! ! REAL(DP), INTENT(INOUT) :: bec(nkb,nbsp) -! REAL(DP), INTENT(IN) :: b1(3), b2(3), b3(3), taub(3,nax) -! COMPLEX(DP), INTENT(INOUT) :: c(ngw,nbspx) -! COMPLEX(DP), INTENT(IN) :: eigr(ngw,nat), eigrb(ngb,nat) -! REAL(DP), INTENT(INOUT) :: Uall(nbsp,nbsp) -! LOGICAL, INTENT(IN) :: what1 -! REAL(DP), INTENT(OUT) :: wfc(3,nbsp) -! INTEGER, INTENT(IN) :: nbspx, nbsp, nupdwn(nspin), iupdwn(nspin) -! ! -! REAL(DP), ALLOCATABLE :: becwf(:,:), temp3(:,:) -! COMPLEX(DP), ALLOCATABLE :: cwf(:,:), bec2(:), bec3(:), bec2up(:) -! COMPLEX(DP), ALLOCATABLE :: bec2dw(:), bec3up(:), bec3dw(:) -! COMPLEX(DP), ALLOCATABLE :: c_m(:,:), c_p(:,:), c_psp(:,:) -! COMPLEX(DP), ALLOCATABLE :: c_msp(:,:) -! INTEGER, ALLOCATABLE :: tagz(:) -! REAL(DP), ALLOCATABLE :: Uspin(:,:) -! COMPLEX(DP), ALLOCATABLE :: X(:,:), Xsp(:,:), X2(:,:), X3(:,:) -! COMPLEX(DP), ALLOCATABLE :: O(:,:,:), Ospin(:,:,:), Oa(:,:,:) -! COMPLEX(DP), ALLOCATABLE :: qv(:) -! REAL(DP), ALLOCATABLE :: gr(:,:), mt(:), mt0(:), wr(:), W(:,:), EW(:,:) -! INTEGER, ALLOCATABLE :: f3(:), f4(:) -! COMPLEX(DP), ALLOCATABLE :: U2(:,:) -! ! -! INTEGER :: inl, jnl, iss, isa, is, ia, ijv, i, j, k, l, ig, & -! ierr, ti, tj, tk, iv, jv, inw, iqv, ibig1, ibig2, & -! ibig3, ir1, ir2, ir3, ir, m, & -! ib, jb, total, nstat, jj, ngpww, irb3 -! REAL(DP) :: t1, t2, t3, taup(3) -! REAL(DP) :: wrsq, wrsqmin -! COMPLEX(DP) :: qvt -! REAL (DP) :: temp_vec(3) -! INTEGER :: adjust,ini, ierr1,nnn, me -! INTEGER :: igx, igy, igz -! REAL(DP) :: wfcx, wfcy, wfcz -! REAL(DP) :: te(6) -! INTEGER :: iunit -! -! COMPLEX(DP), EXTERNAL :: boxdotgridcplx -! LOGICAL :: lgam -! ! -! #if defined (__PARA) -! ! -! INTEGER :: proc, ntot, ncol, mc, ngpwpp(nproc_image) -! INTEGER :: ncol1,nz1, nz_1 -! INTEGER :: nmin(3), nmax(3), n1,n2,nzx,nz,nz_ -! INTEGER :: nmin1(3), nmax1(3) -! ! -! COMPLEX(DP), ALLOCATABLE :: psitot(:,:), psitot_pl(:,:) -! COMPLEX(DP), ALLOCATABLE :: psitot_mi(:,:) -! INTEGER, ALLOCATABLE :: ns(:) -! ! -! #endif -! ! -! CALL start_clock('wf_1') -! ! -! lgam=gamma_only.and..not.do_wf_cmplx -! me = me_image + 1 -! ! -! ALLOCATE( becwf(nkb,nbsp), temp3(nkb,nbsp), U2(nbsp,nbsp) ) -! ALLOCATE( cwf(ngw,nbspx), bec2(nbsp), bec3(nbsp), bec2up(nupdwn(1)) ) -! ALLOCATE( bec3up( nupdwn(1) ) ) -! IF( nspin == 2 ) THEN -! ALLOCATE( bec2dw( nupdwn(2) ), bec3dw( nupdwn(2) ) ) -! ENDIF -! ! -! te = 0.D0 -! ! -! ALLOCATE( tagz( nw )) -! ! -! tagz(:) = 1 -! tagz(3) = 0 -! ! -! ! ... set up matrix O -! ! -! ALLOCATE( O( nw, nbsp, nbsp ), X( nbsp, nbsp ), Oa( nw, nbsp, nbsp ) ) -! ! -! IF ( nspin == 2 .AND. nvb > 0 ) THEN -! ! -! ALLOCATE( X2( nupdwn(1), nupdwn(1) ) ) -! ALLOCATE( X3( nupdwn(2), nupdwn(2) ) ) -! ! -! END IF -! ! -! #if defined (__PARA) -! ! -! ! Compute the number of states to each processor -! ! -! ALLOCATE( ns( nproc_image ) ) -! ns = nbsp / nproc_image -! DO j = 1, nbsp -! IF( (j-1) < MOD( nbsp, nproc_image ) ) ns( j ) = ns( j ) + 1 -! END DO -! IF(iprsta.GT.4) THEN -! DO j=1,nproc_image -! WRITE( stdout, * ) ns(j) -! END DO -! END IF -! ! -! nstat = ns( me ) -! -! total = 0 -! DO proc=1,nproc_image -! ngpwpp(proc)=(dfftp%nwl(proc)+1)/2 -! total=total+ngpwpp(proc) -! IF(iprsta.GT.4) THEN -! WRITE( stdout, * ) "I am proceessor", proc, "and i have ",ns(me)," states." -! END IF -! END DO -! ! -! ALLOCATE(psitot(total,nstat)) -! ALLOCATE(psitot_pl(total,nstat)) -! ALLOCATE(psitot_mi(total,nstat)) -! -! ALLOCATE(c_p(ngw,nbspx)) -! ALLOCATE(c_m(ngw,nbspx)) -! IF(iprsta.GT.4) THEN -! WRITE( stdout, * ) "All allocations done" -! END IF -! ! -! ! ... Step 1. Communicate to all Procs so that each proc has all -! ! ... G-vectors and some states instead of all states and some -! ! ... G-vectors. This information is stored in the 1-d array -! ! ... psitot1. -! ! -! ! Step 2. Convert the 1-d array psitot1 into a 2-d array consistent with the -! ! original notation c(ngw,nbsp). Psitot contains ntot = SUM_Procs(ngw) G-vecs -! ! and nstat states instead of all nbsp states -! ! -! ! -! CALL redistwf( c, psitot, ngpwpp, ns, intra_image_comm, 1 ) -! ! -! #endif -! -! IF( clwf .EQ. 5 ) THEN -! ! -! CALL write_psi( c, jw ) -! ! -! END IF -! ! -! ! -! #if defined (__PARA) -! ! -! ! Step 3. do the translation of the 2-d array to get the transtalted -! ! arrays psitot_pl and psittot_mi, corresponding to G+G' and -G+G' -! ! -! DO inw=1,nw -! ! -! ! Intermediate Check. If the translation is only along the z-direction -! ! no interprocessor communication and data rearrangement is required -! ! because each processor contains all the G- components in the z-dir. -! ! -! IF(tagz(inw).EQ.0) THEN -! DO i=1,nbsp -! DO ig=1,ngw -! IF(indexplusz(ig).EQ.-1) THEN -! c_p(ig,i)=(0.D0,0.D0) -! ELSE -! c_p(ig,i)=c(indexplusz(ig),i) -! END IF -! IF(indexminusz(ig).EQ.-1) THEN -! c_m(ig,i)=(0.D0,0.D0) -! ELSE -! c_m(ig,i)=CONJG(c(indexminusz(ig),i)) -! END IF -! END DO -! END DO -! ELSE -! DO i=1,ns(me) -! DO ig=1,total -! IF(indexplus(ig,inw).EQ.-1) THEN -! psitot_pl(ig,i)=(0.D0,0.D0) -! ELSE -! IF(tagp(ig,inw).EQ.1) THEN -! psitot_pl(ig,i)=CONJG(psitot(indexplus(ig,inw),i)) -! ELSE -! psitot_pl(ig,i)=psitot(indexplus(ig,inw),i) -! END IF -! END IF -! IF(indexminus(ig,inw).EQ.-1) THEN -! psitot_mi(ig,i)=(0.D0,0.D0) -! ELSE -! IF(tag(ig,inw).EQ.1) THEN -! psitot_mi(ig,i)=CONJG(psitot(indexminus(ig,inw),i)) -! ELSE -! psitot_mi(ig,i)=psitot(indexminus(ig,inw),i) -! END IF -! END IF -! END DO -! END DO -! IF(iprsta.GT.4) THEN -! WRITE( stdout, * ) "Step 3. do the translation of the 2-d array...Done, wf" -! END IF -! ! -! ! Step 4. Convert the 2-d arrays psitot_p and psitot_m into 1-d -! ! arrays -! ! -! ! Step 5. Redistribute among processors. The result is stored in 2-d -! ! arrays c_p and c_m consistent with the notation c(ngw,nbsp), such that -! ! c_p(j,i) contains the coeffiCIent for c(j,i) corresponding to G+G' -! ! and c_m(j,i) contains the coeffiCIent for c(j,i) corresponding to -G+G' -! ! -! c_p = 0.D0 -! CALL redistwf( c_p, psitot_pl, ngpwpp, ns, intra_image_comm, -1 ) -! ! -! c_m = 0.D0 -! CALL redistwf( c_m, psitot_mi, ngpwpp, ns, intra_image_comm, -1 ) -! ! -! END IF -! ! -! #else -! ! -! ALLOCATE(c_p(ngw,nbspx)) -! ALLOCATE(c_m(ngw,nbspx)) -! DO inw=1,nw -! IF(tagz(inw).EQ.0) THEN -! DO i=1,nbsp -! DO ig=1,ngw -! IF(indexplusz(ig).EQ.-1) THEN -! c_p(ig,i)=(0.D0,0.D0) -! ELSE -! c_p(ig,i)=c(indexplusz(ig),i) -! END IF -! IF(indexminusz(ig).EQ.-1) THEN -! c_m(ig,i)=(0.D0,0.D0) -! ELSE -! c_m(ig,i)=CONJG(c(indexminusz(ig),i)) -! END IF -! END DO -! END DO -! ELSE -! DO i=1,nbsp -! DO ig=1,ngw -! IF(indexplus(ig,inw).EQ.-1) THEN -! c_p(ig,i)=(0.D0,0.D0) -! ELSE -! IF(tagp(ig,inw).EQ.1) THEN -! c_p(ig,i)=CONJG(c(indexplus(ig,inw),i)) -! ELSE -! c_p(ig,i)=c(indexplus(ig,inw),i) -! END IF -! END IF -! IF(indexminus(ig,inw).EQ.-1) THEN -! c_m(ig,i)=(0.D0,0.D0) -! ELSE -! IF(tag(ig,inw).EQ.1) THEN -! c_m(ig,i)=CONJG(c(indexminus(ig,inw),i)) -! ELSE -! c_m(ig,i)=c(indexminus(ig,inw),i) -! END IF -! END IF -! END DO -! END DO -! END IF -! ! -! #endif -! ! -! ! ... Step 6. Calculate Overlaps -! ! -! ! ... Augmentation Part first -! ! -! ALLOCATE( qv( nnrbx ) ) -! ! -! X = ZERO -! ! -! isa = 1 -! DO is = 1, nvb -! DO ia =1, na(is) -! DO iv = 1, nh(is) -! inl = ish(is) + (iv-1)*na(is) + ia -! jv = iv -! ijv=(jv-1)*jv/2 + iv -! qv( 1 : nnrbx ) = 0.D0 -! DO ig=1,ngb -! qv(npb(ig))=eigrb(ig,isa)*qgb(ig,ijv,is) -! qv(nmb(ig))=CONJG(eigrb(ig,isa)*qgb(ig,ijv,is)) -! END DO -! #ifdef __PARA -! irb3=irb(3,isa) -! #endif -! CALL invfft('Box',qv,dfftb,isa) -! iqv=1 -! qvt=(0.D0,0.D0) -! qvt=boxdotgridcplx(irb(1,isa),qv,expo(1,inw)) -! -! #ifdef __PARA -! CALL mp_sum( qvt, intra_image_comm ) -! #endif -! ! -! IF (nspin.EQ.1) THEN -! bec2(1:nbsp)=(0.D0,0.D0) -! bec2(1:nbsp)=bec(inl,1:nbsp)*ONE -! CALL ZSYRK('U','T',nbsp,1,qvt,bec2,1,ONE,X,nbsp) -! ELSE -! X2=(0.D0,0.D0) -! X3=(0.D0,0.D0) -! bec2up(1:nupdwn(1))=(0.D0,0.D0) -! bec2up(1:nupdwn(1))=bec(inl,1:nupdwn(1)) -! CALL ZSYRK('U','T',nupdwn(1),1,qvt,bec2up,1,ONE,X2,nupdwn(1)) -! bec2dw(1:nupdwn(2))=(0.D0,0.D0) -! bec2dw(1:nupdwn(2))=bec(inl,iupdwn(2):nbsp) -! CALL ZSYRK('U','T',nupdwn(2),1,qvt,bec2dw,1,ONE,X3,nupdwn(2)) -! DO i = 1, nupdwn(1) -! DO j=i, nupdwn(1) -! X(i,j)=X(i,j)+X2(i,j) -! END DO -! END DO -! DO i = 1,nupdwn(2) -! DO j=i,nupdwn(2) -! X(i+nupdwn(1),j+nupdwn(1)) =X(i+nupdwn(1),j+nupdwn(1)) + X3(i,j) -! END DO -! END DO -! END IF -! DO jv = iv+1, nh(is) -! jnl = ish(is) + (jv-1)*na(is) + ia -! ijv = (jv-1)*jv/2 + iv -! qv( 1:nnrbx ) = 0.D0 -! DO ig=1,ngb -! qv(npb(ig))=eigrb(ig,isa)*qgb(ig,ijv,is) -! qv(nmb(ig))=CONJG(eigrb(ig,isa)*qgb(ig,ijv,is)) -! END DO -! CALL invfft('Box',qv,dfftb,isa) -! iqv=1 -! qvt=0.D0 -! qvt=boxdotgridcplx(irb(1,isa),qv,expo(1,inw)) -! #ifdef __PARA -! CALL mp_sum( qvt, intra_image_comm ) -! #endif -! ! -! IF (nspin.EQ.1) THEN -! bec2(1:nbsp)=(0.D0,0.D0) -! bec3(1:nbsp)=(0.D0,0.D0) -! bec2(1:nbsp)=bec(inl,1:nbsp)*ONE -! bec3(1:nbsp)=bec(jnl,1:nbsp)*ONE -! CALL ZSYR2K('U','T',nbsp,1,qvt,bec2,1,bec3,1,ONE,X,nbsp) -! ELSE -! X2=(0.D0,0.D0) -! X3=(0.D0,0.D0) -! bec2up(1:nupdwn(1))=(0.D0,0.D0) -! bec3up(1:nupdwn(1))=(0.D0,0.D0) -! bec2up(1:nupdwn(1))=bec(inl,1:nupdwn(1))*ONE -! bec3up(1:nupdwn(1))=bec(jnl,1:nupdwn(1))*ONE -! CALL ZSYR2K('U','T',nupdwn(1),1,qvt,bec2up,1,bec3up,1,ONE,X2,nupdwn(1)) -! bec2dw(1:nupdwn(2))=(0.D0,0.D0) -! bec3dw(1:nupdwn(2))=(0.D0,0.D0) -! bec2dw(1:nupdwn(2))=bec(inl,iupdwn(2):nbsp)*ONE -! bec3dw(1:nupdwn(2))=bec(jnl,iupdwn(2):nbsp)*ONE -! CALL ZSYR2K('U','T',nupdwn(2),1,qvt,bec2dw,1,bec3dw,1,ONE,X3,nupdwn(2)) -! DO i = 1, nupdwn(1) -! DO j=i, nupdwn(1) -! X(i,j)=X(i,j)+X2(i,j) -! END DO -! END DO -! DO i = 1,nupdwn(2) -! DO j=i,nupdwn(2) -! X(i+nupdwn(1),j+nupdwn(1)) =X(i+nupdwn(1),j+nupdwn(1)) + X3(i,j) -! END DO -! END DO -! END IF -! END DO -! END DO -! isa = isa + 1 -! END DO -! END DO -! t1=omega/DBLE(nr1*nr2*nr3) -! X=X*t1 -! DO i=1, nbsp -! DO j=i+1, nbsp -! X(j, i)=X(i, j) -! END DO -! END DO -! Oa(inw, :, :)=X(:, :) -! IF(iprsta.GT.4) THEN -! WRITE( stdout, * ) "Augmentation Part Done" -! END IF -! -! DEALLOCATE( qv ) -! -! -! ! Then Soft Part -! IF( nspin == 1 ) THEN -! ! Spin Unpolarized calculation -! X=0.D0 -! IF( gstart == 2 ) THEN -! c_m(1,:)=0.D0 -! END IF -! ! cwf(:,:)=ZERO -! ! cwf(:,:)=c(:,:) -! CALL ZGEMM('C','N',nbsp,nbsp,ngw,ONE,c,ngw,c_p,ngw,ONE,X,nbsp) -! CALL ZGEMM('T','N',nbsp,nbsp,ngw,ONE,c,ngw,c_m,ngw,ONE,X,nbsp) -! -! CALL mp_sum ( X, intra_image_comm ) -! -! O(inw,:,:)=Oa(inw,:,:)+X(:,:) -! -! IF(iprsta.GT.4) THEN -! WRITE( stdout, * ) "Soft Part Done" -! END IF -! -! ELSE -! ! Spin Polarized case -! ! Up Spin First -! ALLOCATE(Xsp(nbsp,nupdwn(1))) -! ALLOCATE(c_psp(ngw,nupdwn(1))) -! ALLOCATE(c_msp(ngw,nupdwn(1))) -! Xsp=0.D0 -! c_psp=0.D0 -! c_msp=0.D0 -! DO i=1,nupdwn(1) -! c_psp(:,i)=c_p(:,i) -! c_msp(:,i)=c_m(:,i) -! END DO -! IF(gstart.EQ.2) THEN -! c_msp(1,:)=0.D0 -! END IF -! ! cwf(:,:)=ZERO -! ! cwf(:,:)=c(:,:,1,1) -! CALL ZGEMM('C','N',nbsp,nupdwn(1),ngw,ONE,c,ngw,c_psp,ngw,ONE,Xsp,nbsp) -! CALL ZGEMM('T','N',nbsp,nupdwn(1),ngw,ONE,c,ngw,c_msp,ngw,ONE,Xsp,nbsp) -! #ifdef __PARA -! CALL mp_sum ( Xsp, intra_image_comm ) -! #endif -! DO i=1,nupdwn(1) -! DO j=1,nbsp -! X(j,i)=Xsp(j,i) -! END DO -! END DO -! DEALLOCATE(Xsp,c_psp,c_msp) -! ! Then Down Spin -! ALLOCATE(Xsp(nbsp,iupdwn(2):nbsp)) -! ALLOCATE(c_psp(ngw,iupdwn(2):nbsp)) -! ALLOCATE(c_msp(ngw,iupdwn(2):nbsp)) -! Xsp=0.D0 -! c_psp=0.D0 -! c_msp=0.D0 -! DO i=iupdwn(2),nbsp -! c_psp(:,i)=c_p(:,i) -! c_msp(:,i)=c_m(:,i) -! END DO -! IF(gstart.EQ.2) THEN -! c_msp(1,:)=0.D0 -! END IF -! ! cwf(:,:)=ZERO -! ! cwf(:,:)=c(:,:,1,1) -! CALL ZGEMM('C','N',nbsp,nupdwn(2),ngw,ONE,c,ngw,c_psp,ngw,ONE,Xsp,nbsp) -! CALL ZGEMM('T','N',nbsp,nupdwn(2),ngw,ONE,c,ngw,c_msp,ngw,ONE,Xsp,nbsp) -! #ifdef __PARA -! CALL mp_sum ( Xsp, intra_image_comm ) -! #endif -! DO i=iupdwn(2),nbsp -! DO j=1,nbsp -! X(j,i)=Xsp(j,i) -! END DO -! END DO -! DEALLOCATE(Xsp,c_psp,c_msp) -! O(inw,:,:)=Oa(inw,:,:)+X(:,:) -! END IF -! -! -! END DO -! -! #ifdef __PARA -! DEALLOCATE(ns) -! #endif -! -! CALL stop_clock('wf_1') -! -! DEALLOCATE( X ) -! IF ( ALLOCATED( X2 ) ) DEALLOCATE( X2 ) -! IF ( ALLOCATED( X3 ) ) DEALLOCATE( X3 ) -! ! -! -! CALL start_clock('wf_2') -! -! -! IF(clwf.EQ.2) THEN -! ! output the overlap matrix to fort.38 -! IF(me.EQ.1) THEN -! REWIND 38 -! WRITE(38, '(i5, 2i2, i3, f9.5)') nbsp, nw, nspin, ibrav, alat -! IF (nspin.EQ.2) THEN -! WRITE(38, '(i5)') nupdwn(1) -! END IF -! WRITE(38, *) a1 -! WRITE(38, *) a2 -! WRITE(38, *) a3 -! WRITE(38, *) b1 -! WRITE(38, *) b2 -! WRITE(38, *) b3 -! DO inw=1, nw -! WRITE(38, *) wfg(inw, :), weight(inw) -! END DO -! DO inw=1, nw -! DO i=1, nbsp -! DO j=1, nbsp -! WRITE(38, *) O(inw, i, j) -! END DO -! END DO -! END DO -! DO i=1, nbsp -! DO j=1, nbsp -! WRITE(38, *) Uall(i, j) -! END DO -! END DO -! CLOSE(38) -! END IF -! CALL stop_run( .TRUE. ) -! END IF -! -! IF(clwf.EQ.3.OR.clwf.EQ.4) THEN -! IF(nspin.EQ.1) THEN -! IF(.NOT.what1) THEN -! IF(wfsd==1) THEN -! CALL ddyn(nbsp,O,Uall) -! ELSE IF(wfsd==2) THEN -! CALL wfsteep(nbsp,O,Uall) -! ELSE IF(wfsd==3) THEN -! CALL jacobi_rotation(nbsp,O,Uall) -! END IF -! END IF -! IF(iprsta.GT.4) THEN -! WRITE( stdout, * ) "Out from DDYN" -! END IF -! ELSE -! ALLOCATE(Uspin(nupdwn(1), nupdwn(1)), Ospin(nw, nupdwn(1), nupdwn(1))) -! DO i=1, nupdwn(1) -! DO j=1, nupdwn(1) -! Uspin(i, j)=Uall(i, j) -! Ospin(:, i, j)=O(:, i, j) -! END DO -! END DO -! IF(.NOT.what1) THEN -! IF(wfsd==1) THEN -! CALL ddyn(nupdwn(1), Ospin, Uspin) -! ELSE IF (wfsd==2) THEN -! CALL wfsteep(nupdwn(1), Ospin, Uspin) -! ELSE -! CALL jacobi_rotation(nupdwn(1), Ospin, Uspin) -! END IF -! END IF -! DO i=1, nupdwn(1) -! DO j=1, nupdwn(1) -! Uall(i, j)=Uspin(i, j) -! O(:,i,j) =Ospin(:,i,j) -! END DO -! END DO -! DEALLOCATE(Uspin, Ospin) -! ALLOCATE(Uspin(nupdwn(2), nupdwn(2)), Ospin(nw, nupdwn(2), nupdwn(2))) -! DO i=1, nupdwn(2) -! DO j=1, nupdwn(2) -! Uspin(i, j)=Uall(i+nupdwn(1), j+nupdwn(1)) -! Ospin(:, i, j)=O(:, i+nupdwn(1), j+nupdwn(1)) -! END DO -! END DO -! IF(.NOT.what1) THEN -! IF(wfsd==1) THEN -! CALL ddyn(nupdwn(2), Ospin, Uspin) -! ELSE IF (wfsd==2) THEN -! CALL wfsteep(nupdwn(2), Ospin, Uspin) -! ELSE -! CALL jacobi_rotation(nupdwn(2), Ospin, Uspin) -! END IF -! END IF -! DO i=1, nupdwn(2) -! DO j=1, nupdwn(2) -! Uall(i+nupdwn(1), j+nupdwn(1))=Uspin(i, j) -! O(:,i+nupdwn(1),j+nupdwn(1))=Ospin(:,i,j) -! END DO -! END DO -! DEALLOCATE(Uspin, Ospin) -! END IF -! END IF -! -! ! Update C and bec -! cwf=ZERO -! ! cwf(:,:)=c(:,:,1,1) -! becwf=0.0d0 -! U2=Uall*ONE -! CALL ZGEMM('N','N',ngw,nbsp,nbsp,ONE,c,ngw,U2,nbsp,ZERO,cwf,ngw) -! ! call ZGEMM('nbsp','nbsp',ngw,nbsp,nbsp,ONE,cwf,ngw,U2,nbsp,ZERO,cwf,ngw) -! CALL DGEMM('N','N',nkb,nbsp,nbsp,ONE,bec,nkb,Uall,nbsp,ZERO,becwf,nkb) -! U2=ZERO -! IF(iprsta.GT.4) THEN -! WRITE( stdout, * ) "Updating Wafefunctions and Bec" -! END IF -! -! c(:,:)=cwf(:,:) -! bec(:,:)=becwf(:,:) -! -! IF(iprsta.GT.4) THEN -! WRITE( stdout, * ) "Wafefunctions and Bec Updated" -! END IF -! ! -! ! calculate wannier-function centers -! ! -! ALLOCATE( wr(nw), W(nw,nw), gr(nw,3), EW(nw,nw), f3(nw), f4(nw), mt0(nw), mt(nw) ) -! ! -! DO inw=1, nw -! gr(inw, :)=wfg(inw,1)*b1(:)+wfg(inw,2)*b2(:)+wfg(inw,3)*b3(:) -! END DO -! ! -! ! set up a matrix with the element (i,j) is G_i·G_j·weight(j) -! ! to check the correctness of choices on G vectors -! ! -! DO i=1, nw -! DO j=1, nw -! W(i,j)=DOT_PRODUCT(gr(i,:),gr(j,:))*weight(j) -! END DO -! END DO -! ! -! EW = W -! DO i=1,nw -! EW(i,i) = EW(i,i)-1.D0 -! END DO -! ! -! ! ... balance the phase factor if necessary -! ! -! ! adjust mt : very inefficient routine added by Young-Su -> must be improved -! DO i=1, nbsp -! mt0(:) = -AIMAG(LOG(O(:,i,i)))/tpi -! wr = MATMUL(EW,mt0) -! wrsq = SUM(wr(:)**2) -! IF ( wrsq .lt. 1.D-6 ) THEN -! mt = mt0 -! ELSE -! wrsqmin = 100.D0 -! COMB: DO k=3**nw-1,0,-1 -! tk=k -! DO j=nw,1,-1 -! f3(j)=tk/3**(j-1) -! tk=tk-f3(j)*3**(j-1) -! END DO -! mt(:)=mt0(:)+f3(:)-1 -! wr = MATMUL(EW,mt) -! wrsq = SUM(wr(:)**2) -! IF ( wrsq .lt. wrsqmin ) THEN -! wrsqmin = wrsq -! f4(:)=f3(:)-1 -! END IF -! END DO COMB -! mt = mt0 + f4 -! END IF -! ! -! wfc(1, i) = SUM(mt*weight(:)*gr(:,1))*alat -! wfc(2, i) = SUM(mt*weight(:)*gr(:,2))*alat -! wfc(3, i) = SUM(mt*weight(:)*gr(:,3))*alat -! ! -! END DO -! ! -! IF ( ionode ) THEN -! ! -! iunit = printout_base_unit( "wfc" ) -! CALL printout_base_open( "wfc" ) -! IF ( .NOT. what1 ) THEN -! ! -! ! ... pbc are imposed here in the range [0,1] -! ! -! DO i = 1, nbsp -! ! -! temp_vec(:) = MATMUL( ainv(:,:), wfc(:,i) ) -! ! -! temp_vec(:) = temp_vec(:) - floor (temp_vec(:)) -! ! -! temp_vec(:) = MATMUL( h(:,:), temp_vec(:) ) -! ! -! WRITE( iunit, '(3f20.14)' ) temp_vec(:) -! ! -! END DO -! ! -! END IF -! CALL printout_base_close( "wfc" ) -! ! -! END IF -! ! -! ! -! ! -! DEALLOCATE( wr, W, gr, EW, f3, f4, mt0, mt ) -! ! -! #if defined (__PARA) -! ! -! DEALLOCATE( psitot ) -! DEALLOCATE( psitot_pl ) -! DEALLOCATE( psitot_mi ) -! ! -! #endif -! ! -! DEALLOCATE( c_p, c_m ) -! ! -! DEALLOCATE( O ) -! DEALLOCATE( Oa ) -! DEALLOCATE( tagz ) -! DEALLOCATE( becwf, temp3, U2 ) -! DEALLOCATE( cwf, bec2, bec3, bec2up, bec3up ) -! IF( ALLOCATED( bec2dw ) ) DEALLOCATE( bec2dw ) -! IF( ALLOCATED( bec3dw ) ) DEALLOCATE( bec3dw ) -! -! CALL stop_clock('wf_2') -! ! -! RETURN -! ! -! END SUBROUTINE wf_new -! ! -!---------------------------------------------------------------------------- -SUBROUTINE ddyn( m, Omat, Umat) - !---------------------------------------------------------------------------- - ! ... This part of the subroutine wf has been added by Manu. It performes - ! ... Damped Dynamics on the A matrix to get the Unitary transformation to - ! ... obtain the wannier function at time(t+delta). It also updates the - ! ... quantities bec - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - USE wannier_base, ONLY : wf_friction, nsteps, tolw, adapt, wf_q, & - weight, nw, wfdt - USE cell_base, ONLY : alat - USE constants, ONLY : tpi, autoaf => BOHR_RADIUS_ANGS - USE control_flags, ONLY : iprsta - USE mp_global, ONLY : me_image - USE printout_base, ONLY : printout_base_open, printout_base_unit, & - printout_base_close - USE parallel_include - ! - IMPLICIT NONE - ! - INTEGER :: i, j, inw - INTEGER ,INTENT(in) :: m - REAL(DP), INTENT(inout) :: Umat(m,m) - COMPLEX(DP), INTENT(inout) :: Omat(nw,m,m) - COMPLEX(DP) :: U2(m,m),U3(m,m) - INTEGER :: ini, ierr1 - REAL(DP), ALLOCATABLE, DIMENSION(:) :: wr - REAL(DP), ALLOCATABLE, DIMENSION(:,:) :: W - REAL(DP) :: t0, fric,U(m,m), t2 - REAL(DP) :: A(m,m), oldt0, U1(m,m) - REAL(DP) :: Aminus(m,m), Aplus(m,m),f2(4*m) - REAL(DP) :: temp(m,m) - COMPLEX(DP) :: d(m,m) - COMPLEX(DP) :: f1(2*m-1), wp(m*(m+1)/2),z(m,m) - COMPLEX(DP), ALLOCATABLE, DIMENSION(:, :) :: X1 - COMPLEX(DP), ALLOCATABLE, DIMENSION(:, :, :) :: Oc - REAL(DP) , ALLOCATABLE , DIMENSION(:) :: mt - REAL(DP) :: spread, sp - INTEGER :: me, iunit - ! - me = me_image + 1 - ! - ALLOCATE(mt(nw)) - ALLOCATE(X1(m,m)) - ALLOCATE(Oc(nw,m,m)) - - fric=wf_friction - ALLOCATE (W(m,m),wr(m)) - - Umat=0.D0 - DO i=1,m - Umat(i,i)=1.D0 - END DO - - U2=Umat*ONE - - ! - ! update Oc using the initial guess of Uspin - ! - DO inw=1, nw - X1(:, :)=Omat(inw, :, :) - U3=ZERO - CALL ZGEMM ('T', 'N', m,m,m,ONE,U2,m,X1,m,ZERO,U3,m) - X1=ZERO - CALL ZGEMM ('N','N', m,m,m,ONE,U3,m,U2,m,ZERO,X1,m) - Oc(inw, :, :)=X1(:, :) - END DO - - U2=ZERO - U3=ZERO - - oldt0=0.D0 - A=0.D0 - Aminus=A - temp=Aminus - - - ! START ITERATIONS HERE - - DO ini=1, nsteps - - t0=0.D0 !use t0 to store the value of omega - DO inw=1, nw - DO i=1, m - t0=t0+DBLE(CONJG(Oc(inw, i, i))*Oc(inw, i, i)) - END DO - END DO - - IF(ABS(t0-oldt0).LT.tolw) THEN - IF(me.EQ.1) THEN - WRITE(27,*) "MLWF Generated at Step",ini - END IF - IF(iprsta.GT.4) THEN - WRITE( stdout, * ) "MLWF Generated at Step",ini - END IF - GO TO 241 - END IF - - IF(adapt) THEN - IF(oldt0.LT.t0) THEN - fric=fric/2.d0 - A=Aminus - Aminus=temp - END IF - END IF - - ! calculate d(omega)/dA and store result in W - ! this is the force for the damped dynamics - ! - - W=0.D0 - DO inw=1, nw - t2=weight(inw) - DO i=1,m - DO j=1,m - W(i,j)=W(i,j)+t2*DBLE(Oc(inw,i,j)*CONJG(Oc(inw,i,i) & - -Oc(inw,j,j))+CONJG(Oc(inw,j,i))*(Oc(inw,i,i)-Oc(inw,j,j))) - END DO - END DO - END DO - - - ! the verlet scheme to calculate A(t+wfdt) - - Aplus=0.D0 - - DO i=1,m - DO j=i+1,m - Aplus(i,j)=Aplus(i,j)+(2*wfdt/(2*wfdt+fric))*(2*A(i,j) & - -Aminus(i,j)+(wfdt*wfdt/wf_q)*W(i,j)) + (fric/(2*wfdt+fric))*Aminus(i,j) - ENDDO - ENDDO - - Aplus=Aplus-TRANSPOSE(Aplus) - Aplus=(Aplus-A) - - DO i=1, m - DO j=i,m - wp(i + (j-1)*j/2) = CMPLX(0.d0, Aplus(i,j)) - END DO - END DO - -#if ! defined __ESSL - CALL zhpev('V','U',m,wp,wr,z,m,f1,f2,ierr1) -#else - CALL zhpev(21, wp, wr, z, m, m, f2, 4*m) - ierr1 = 0 -#endif - - IF (ierr1.NE.0) THEN - WRITE( stdout, * ) "failed to diagonalize W!" - STOP - END IF - - d=0.D0 - DO i=1, m - d(i, i)=EXP(CI*wr(i)*wfdt) - END DO !d=exp(d) - - ! U=z*exp(d)*z+ - ! - U3=ZERO - CALL ZGEMM ('N', 'N', m,m,m,ONE,z,m,d,m,ZERO,U3,m) - U2=ZERO - CALL ZGEMM ('N','C', m,m,m,ONE,U3,m,z,m,ZERO,U2,m) - U=DBLE(U2) - U2=ZERO - U3=ZERO - - temp=Aminus - Aminus=A - A=Aplus - - - ! update Umat - ! - U1=ZERO - CALL DGEMM ('N', 'N', m,m,m,ONE,Umat,m,U,m,ZERO,U1,m) - - Umat=U1 - - ! update Oc - ! - U2=Umat*ONE - U3=ZERO - DO inw=1, nw - X1(:, :)=Omat(inw, :, :) - CALL ZGEMM ('T', 'N', m,m,m,ONE,U2,m,X1,m,ZERO,U3,m) - X1=ZERO - CALL ZGEMM ('N','N',m,m,m,ONE,U3,m,U2,m,ZERO,X1,m) - Oc(inw, :, :)=X1(:, :) - END DO - U2=ZERO - U3=ZERO - - IF(ABS(t0-oldt0).GE.tolw.AND.ini.GE.nsteps) THEN - IF(me.EQ.1) THEN - WRITE(27,*) "MLWF Not generated after",ini,"Steps." - END IF - IF(iprsta.GT.4) THEN - WRITE( stdout, * ) "MLWF Not generated after",ini,"Steps." - END IF - GO TO 241 - END IF - - oldt0=t0 - - END DO - -241 DEALLOCATE(wr, W) - - spread=0.0d0 - - IF(me.EQ.1) THEN - iunit = printout_base_unit( "spr" ) - CALL printout_base_open( "spr" ) - END IF - - DO i=1, m - ! - mt=1.D0-DBLE(Oc(:,i,i)*CONJG(Oc(:,i,i))) - sp = (alat*autoaf/tpi)**2*SUM(mt*weight) - ! - IF(me.EQ.1) THEN - WRITE(iunit, '(f10.7)') sp - END IF - IF ( sp < 0.D0 ) & - CALL errore( 'cp-wf', 'Something wrong WF Spread negative', 1 ) - ! - spread=spread+sp - ! - END DO - - IF(me.EQ.1) THEN - CALL printout_base_close( "spr" ) - END IF - - spread=spread/m - - IF(me.EQ.1) THEN - WRITE(24, '(f10.7)') spread - WRITE(27,*) "Average spread = ", spread - END IF - Omat=Oc - IF(iprsta.GT.4) THEN - WRITE( stdout, * ) "Average spread = ", spread - END IF - ! - DEALLOCATE (mt,X1,Oc) - ! - IF(iprsta.GT.4) THEN - WRITE( stdout, * ) "Leaving DDYN" - END IF - RETURN -END SUBROUTINE ddyn -! -!---------------------------------------------------------------------------- -SUBROUTINE wfunc_init( clwf, b1, b2, b3, ibrav ) - !---------------------------------------------------------------------------- - ! - USE io_global, ONLY : stdout - USE kinds, ONLY : DP - USE reciprocal_vectors, ONLY : gx, mill_l, gstart - USE gvecw, ONLY : ngw - USE electrons_base, ONLY : nbsp - USE wannier_base, ONLY : gnx, gnn, indexplus, indexminus, & - indexplusz, indexminusz, tag, tagp, & - wfg, weight, nw - USE cvan, ONLY : nvb - USE mp, ONLY : mp_barrier, mp_bcast, mp_gather, mp_set_displs - USE mp_global, ONLY : nproc_image, me_image, intra_image_comm, root_image - USE fft_base, ONLY : dfftp - USE parallel_include - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(in) :: b1(3),b2(3),b3(3) - INTEGER, INTENT(in) :: clwf, ibrav -#ifdef __PARA - INTEGER :: ntot, i, j, inw, ngppp(nproc_image) - INTEGER :: ii,ig,displs(nproc_image) -#else - INTEGER :: ierr, i,j,inw, ntot - INTEGER :: ii,ig -#endif - REAL (DP), ALLOCATABLE:: bigg(:,:) - INTEGER, ALLOCATABLE :: bign(:,:) - INTEGER :: nw1 - INTEGER, ALLOCATABLE :: i_1(:), j_1(:), k_1(:) - INTEGER :: ti, tj, tk - REAL(DP) ::vt, err1, err2, err3 - INTEGER :: ti1,tj1,tk1 - INTEGER :: me - ! - - me = me_image + 1 - ! - IF ( nbsp < nproc_image ) & - CALL errore( 'cp-wf', & - & 'Number of Processors is greater than the number of states', 1 ) - ! - ALLOCATE(gnx(3,ngw)) - ALLOCATE(gnn(3,ngw)) - vt=1.0d-4 - j=0 - DO i=1,ngw - gnx(1,i)=gx(1,i) - gnx(2,i)=gx(2,i) - gnx(3,i)=gx(3,i) - gnn(1,i)=mill_l(1,i) - gnn(2,i)=mill_l(2,i) - gnn(3,i)=mill_l(3,i) - END DO - -#ifdef __PARA - - ntot=0 - DO i=1,nproc_image - ngppp(i)=(dfftp%nwl(i)+1)/2 - END DO - - CALL mp_set_displs( ngppp, displs, ntot, nproc_image ) - - IF(me.EQ.1) THEN - ALLOCATE(bigg(3,ntot)) - ALLOCATE(bign(3,ntot)) - END IF - -#else - ntot=ngw - ALLOCATE(bigg(3,ntot)) - ALLOCATE(bign(3,ntot)) - bigg(1:3,1:ntot)=gnx(1:3,1:ntot) - bign(1:3,1:ntot)=gnn(1:3,1:ntot) -#endif - ! - CALL setwfg( ibrav, b1, b2, b3 ) - ! - nw1 = nw - - WRITE( stdout, * ) "WANNIER SETUP : check G vectors and weights" - DO i=1,nw1 - WRITE( stdout,'("inw = ",I1,":",3I4,F11.6)') i,wfg(i,:), weight(i) - END DO - - WRITE( stdout, * ) "Translations to be done", nw1 - ALLOCATE(indexplus(ntot,nw1)) - ALLOCATE(indexminus(ntot,nw1)) - ALLOCATE(tag(ntot,nw1)) - ALLOCATE(tagp(ntot,nw1)) - ALLOCATE(indexplusz(ngw)) - ALLOCATE(indexminusz(ngw)) - ALLOCATE(i_1(nw1)) - ALLOCATE(j_1(nw1)) - ALLOCATE(k_1(nw1)) - - indexplus=0 - indexminus=0 - tag=0 - tagp=0 - indexplusz=0 - indexminusz=0 - i_1(:)=wfg(:,1) - j_1(:)=wfg(:,2) - k_1(:)=wfg(:,3) - - - WRITE( stdout, * ) "ibrav selected:", ibrav - ! - IF(nvb.GT.0) CALL small_box_wf(i_1, j_1, k_1, nw1) -#ifdef __PARA - ! - CALL mp_barrier( intra_image_comm ) - ! - CALL mp_gather( gnx, bigg, ngppp, displs, root_image, intra_image_comm ) - ! - CALL mp_barrier( intra_image_comm ) - ! - CALL mp_gather( gnn, bign, ngppp, displs, root_image, intra_image_comm ) - ! -#endif - - IF(me.EQ.1) THEN - IF(clwf.EQ.5) THEN -#ifdef __PARA - DO ii=1,ntot - WRITE(21,*) bigg(:,ii) - END DO -#else - DO ii=1,ngw - WRITE(21,*) gx(1,ii), gx(2,ii), gx(3,ii) - END DO -#endif - CLOSE(21) - END IF - END IF - - DO inw=1,nw1 - IF(i_1(inw).EQ.0.AND.j_1(inw).EQ.0) THEN - DO ig=1,ngw - IF(gstart.EQ.2) THEN - indexminusz(1)=-1 - END IF - ! ti=(gnn(1,ig)+i_1(inw))*b1(1)+(gnn(2,ig)+j_1(inw))*b2(1)+(gnn(3,ig)+k_1(inw))*b3(1) - ! tj=(gnn(1,ig)+i_1(inw))*b1(2)+(gnn(2,ig)+j_1(inw))*b2(2)+(gnn(3,ig)+k_1(inw))*b3(2) - ! tk=(gnn(1,ig)+i_1(inw))*b1(3)+(gnn(2,ig)+j_1(inw))*b2(3)+(gnn(3,ig)+k_1(inw))*b3(3) - ti=(gnn(1,ig)+i_1(inw)) - tj=(gnn(2,ig)+j_1(inw)) - tk=(gnn(3,ig)+k_1(inw)) - DO ii=1,ngw - err1=ABS(gnx(1,ii)-ti) - err2=ABS(gnx(2,ii)-tj) - err3=ABS(gnx(3,ii)-tk) - IF(gnn(1,ii).EQ.ti.AND.gnn(2,ii).EQ.tj.AND.gnn(3,ii).EQ.tk) THEN - ! if(err1.lt.vt.and.err2.lt.vt.and.err3.lt.vt) then - indexplusz(ig)=ii - ! write (6,*) "Found +", ig,ii,inw, ti,tj,tk - ! write (6,*) "looking for", ti,tj,tk - GO TO 224 - ELSE - END IF - END DO - indexplusz(ig)=-1 - ! write (6,*) "Not Found +", ig,-1,inw - ! write (6,*) "looking for", ti,tj,tk - !224 ti=(-gnn(1,ig)+i_1(inw))*b1(1)+(-gnn(2,ig)+j_1(inw))*b2(1)+(-gnn(3,ig)+k_1(inw))*b3(1) - ! tj=(-gnn(1,ig)+i_1(inw))*b1(2)+(-gnn(2,ig)+j_1(inw))*b2(2)+(-gnn(3,ig)+k_1(inw))*b3(2) - ! tk=(-gnn(1,ig)+i_1(inw))*b1(3)+(-gnn(2,ig)+j_1(inw))*b2(3)+(-gnn(3,ig)+k_1(inw))*b3(3) -224 ti=(-gnn(1,ig)+i_1(inw)) - tj=(-gnn(2,ig)+j_1(inw)) - tk=(-gnn(3,ig)+k_1(inw)) - ti1=-gnn(1,ig)+i_1(inw) - tj1=-gnn(2,ig)+j_1(inw) - tk1=-gnn(3,ig)+k_1(inw) - IF(ti1.LT.0.OR.(ti1.EQ.0.AND.(tj1.LT.0.OR.(tj1.EQ.0.AND.tk1.LT.0)))) THEN - DO ii=1,ngw - err1=ABS(gnx(1,ii)+ti) - err2=ABS(gnx(2,ii)+tj) - err3=ABS(gnx(3,ii)+tk) - IF(gnn(1,ii).EQ.-ti.AND.gnn(2,ii).EQ.-tj.AND.gnn(3,ii).EQ.-tk) THEN - ! if(err1.lt.vt.and.err2.lt.vt.and.err3.lt.vt) then - indexminusz(ig)=ii - ! tag(ig,inw)=1 - ! write (6,*) "Found -", ig,ii,inw - ! write (6,*) "looking for", -ti,-tj,-tk - GO TO 223 - ELSE - END IF - END DO - indexminusz(ig)=-1 - ! tag(ig,inw)=1 - ! write (6,*) "Not Found -", ig,-1,inw - ! write (6,*) "looking for", -ti,-tj,-tk - ELSE - DO ii=1,ngw - err1=ABS(gnx(1,ii)-ti) - err2=ABS(gnx(2,ii)-tj) - err3=ABS(gnx(3,ii)-tk) - IF(gnn(1,ii).EQ.ti.AND.gnn(2,ii).EQ.tj.AND.gnn(3,ii).EQ.tk) THEN - ! if(err1.lt.vt.and.err2.lt.vt.and.err3.lt.vt) then - indexminusz(ig)=ii - ! tag(ig,inw)=-1 - ! write (6,*) "Found -", ig,ii,inw - ! write (6,*) "looking for", ti,tj,tk - GO TO 223 - ELSE - END IF - END DO - indexminusz(ig)=-1 - ! tag(ig,inw)=-1 - ! write (6,*) "Not Found -", ig,-1,inw - ! write (6,*) "looking for", ti,tj,tk - END IF -223 CONTINUE - END DO - WRITE( stdout, * ) "Translation", inw, "for", ngw, "G vectors" - ELSE -#ifdef __PARA - IF(me.EQ.1) THEN -#endif - DO ig=1,ntot - IF(gstart.EQ.2) THEN - indexminus(1,inw)=-1 - END IF - ! ti=(bign(1,ig)+i_1(inw))*b1(1)+(bign(2,ig)+j_1(inw))*b2(1)+(bign(3,ig)+k_1(inw))*b3(1) - ! tj=(bign(1,ig)+i_1(inw))*b1(2)+(bign(2,ig)+j_1(inw))*b2(2)+(bign(3,ig)+k_1(inw))*b3(2) - ! tk=(bign(1,ig)+i_1(inw))*b1(3)+(bign(2,ig)+j_1(inw))*b2(3)+(bign(3,ig)+k_1(inw))*b3(3) - ti=(bign(1,ig)+i_1(inw)) - tj=(bign(2,ig)+j_1(inw)) - tk=(bign(3,ig)+k_1(inw)) - ti1=bign(1,ig)+i_1(inw) - tj1=bign(2,ig)+j_1(inw) - tk1=bign(3,ig)+k_1(inw) - IF(ti1.LT.0.OR.(ti1.EQ.0.AND.(tj1.LT.0.OR.(tj1.EQ.0.AND.tk1.LT.0)))) THEN - DO ii=1,ntot - err1=ABS(bigg(1,ii)+ti) - err2=ABS(bigg(2,ii)+tj) - err3=ABS(bigg(3,ii)+tk) - ! if(err1.lt.vt.and.err2.lt.vt.and.err3.lt.vt) then - IF(bign(1,ii).EQ.-ti.AND.bign(2,ii).EQ.-tj.AND.bign(3,ii).EQ.-tk) THEN - indexplus(ig,inw)=ii - tagp(ig,inw)=1 - ! write (6,*) "Found +", ig,ii,inw - ! write (6,*) "looking for", -ti,-tj,-tk - GO TO 214 - ELSE - END IF - END DO - indexplus(ig,inw)=-1 - tagp(ig,inw)=1 - ! write (6,*) "Not Found +", ig,-1,inw - ! write (6,*) "looking for", -ti,-tj,-tk - ELSE - DO ii=1,ntot - err1=ABS(bigg(1,ii)-ti) - err2=ABS(bigg(2,ii)-tj) - err3=ABS(bigg(3,ii)-tk) - ! if(err1.lt.vt.and.err2.lt.vt.and.err3.lt.vt) then - IF(bign(1,ii).EQ.ti.AND.bign(2,ii).EQ.tj.AND.bign(3,ii).EQ.tk) THEN - indexplus(ig,inw)=ii - tagp(ig,inw)=-1 - ! write (6,*) "Found +", ig,ii,inw - ! write (6,*) "looking for", ti,tj,tk - GO TO 214 - ELSE - END IF - END DO - indexplus(ig,inw)=-1 - tagp(ig,inw)=-1 - ! write (6,*) "Not Found +", ig,-1,inw - ! write (6,*) "looking for", ti,tj,tk - END IF - !214 ti=(-bign(1,ig)+i_1(inw))*b1(1)+(-bign(2,ig)+j_1(inw))*b2(1)+(-bign(3,ig)+k_1(inw))*b3(1) - ! tj=(-bign(1,ig)+i_1(inw))*b1(2)+(-bign(2,ig)+j_1(inw))*b2(2)+(-bign(3,ig)+k_1(inw))*b3(2) - ! tk=(-bign(1,ig)+i_1(inw))*b1(3)+(-bign(2,ig)+j_1(inw))*b2(3)+(-bign(3,ig)+k_1(inw))*b3(3) -214 ti=(-bign(1,ig)+i_1(inw)) - tj=(-bign(2,ig)+j_1(inw)) - tk=(-bign(3,ig)+k_1(inw)) - ti1=-bign(1,ig)+i_1(inw) - tj1=-bign(2,ig)+j_1(inw) - tk1=-bign(3,ig)+k_1(inw) - IF(ti1.LT.0.OR.(ti1.EQ.0.AND.(tj1.LT.0.OR.(tj1.EQ.0.AND.tk1.LT.0)))) THEN - DO ii=1,ntot - err1=ABS(bigg(1,ii)+ti) - err2=ABS(bigg(2,ii)+tj) - err3=ABS(bigg(3,ii)+tk) - ! if(err1.lt.vt.and.err2.lt.vt.and.err3.lt.vt) then - IF(bign(1,ii).EQ.-ti.AND.bign(2,ii).EQ.-tj.AND.bign(3,ii).EQ.-tk) THEN - indexminus(ig,inw)=ii - tag(ig,inw)=1 - ! write (6,*) "Found -", ig,ii,inw - ! write (6,*) "looking for", -ti,-tj,-tk - GO TO 213 - ELSE - END IF - END DO - indexminus(ig,inw)=-1 - tag(ig,inw)=1 - ! write (6,*) "Not Found -", ig,-1,inw - ! write (6,*) "looking for", -ti,-tj,-tk - ELSE - DO ii=1,ntot - err1=ABS(bigg(1,ii)-ti) - err2=ABS(bigg(2,ii)-tj) - err3=ABS(bigg(3,ii)-tk) - ! if(err1.lt.vt.and.err2.lt.vt.and.err3.lt.vt) then - IF(bign(1,ii).EQ.ti.AND.bign(2,ii).EQ.tj.AND.bign(3,ii).EQ.tk) THEN - indexminus(ig,inw)=ii - tag(ig,inw)=-1 - ! write (6,*) "Found -", ig,ii,inw - ! write (6,*) "looking for", ti,tj,tk - GO TO 213 - ELSE - END IF - END DO - indexminus(ig,inw)=-1 - tag(ig,inw)=-1 - ! write (6,*) "Not Found -", ig,-1,inw - ! write (6,*) "looking for", ti,tj,tk - END IF -213 CONTINUE - END DO - WRITE( stdout, * ) "Translation", inw, "for", ntot, "G vectors" -#ifdef __PARA - END IF -#endif - END IF - END DO - -#ifdef __PARA - - CALL mp_barrier( intra_image_comm ) - ! - CALL mp_bcast( indexplus, root_image, intra_image_comm ) - CALL mp_bcast( indexminus, root_image, intra_image_comm ) - CALL mp_bcast( tag, root_image, intra_image_comm ) - CALL mp_bcast( tagp, root_image, intra_image_comm ) - - IF (me.EQ.1) THEN -#endif - DEALLOCATE(bigg) - DEALLOCATE(bign) -#ifdef __PARA - END IF -#endif - DEALLOCATE(i_1,j_1,k_1) - - RETURN -END SUBROUTINE wfunc_init -! -!---------------------------------------------------------------------------- -SUBROUTINE grid_map() - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE efcalc, ONLY : xdist, ydist, zdist - USE smooth_grid_dimensions, ONLY : nnrsx, nr1s, nr2s, nr3s, & - nr1sx, nr2sx, nr3sx - USE fft_base, ONLY : dffts - USE mp_global, ONLY : me_image - USE parallel_include - ! - IMPLICIT NONE - ! - INTEGER :: ir1, ir2, ir3, ibig3, me - ! - me = me_image + 1 - ! - ALLOCATE(xdist(nnrsx)) - ALLOCATE(ydist(nnrsx)) - ALLOCATE(zdist(nnrsx)) - ! - DO ir3=1,nr3s -#ifdef __PARA - ibig3 = ir3 - dffts%ipp( me ) - IF(ibig3.GT.0.AND.ibig3.LE.dffts%npp(me)) THEN -#else - ibig3=ir3 -#endif - DO ir2=1,nr2s - DO ir1=1,nr1s - xdist(ir1+(ir2-1)*nr1sx+(ibig3-1)*nr1sx*nr2sx) = & - & ((ir1-1)/DBLE(nr1sx)) - ydist(ir1+(ir2-1)*nr1sx+(ibig3-1)*nr1sx*nr2sx) = & - & ((ir2-1)/DBLE(nr2sx)) - zdist(ir1+(ir2-1)*nr1sx+(ibig3-1)*nr1sx*nr2sx) = & - & ((ir3-1)/DBLE(nr3sx)) - ! - END DO - END DO -#ifdef __PARA - END IF -#endif - END DO - RETURN -END SUBROUTINE grid_map -! -!---------------------------------------------------------------------------- -SUBROUTINE setwfg( ibrav, b1, b2, b3 ) - !---------------------------------------------------------------------------- - ! - ! ... added by Young-Su Lee ( Nov 2006 ) - ! Find G vectors for a given ibrav and celldms - ! - USE kinds, ONLY : DP - USE cell_base, ONLY : celldm - USE wannier_base, ONLY : wfg, nw, weight - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: b1(3), b2(3), b3(3) - INTEGER, INTENT(IN) :: ibrav - REAL(DP) :: tweight(6), t0, t1, t2, t3, t4, t5, t6 - INTEGER :: twfg(6,3), kk - - twfg(:,:) = 0 - - twfg(1,1)=1 - twfg(1,2)=0 - twfg(1,3)=0 - - twfg(2,1)=0 - twfg(2,2)=1 - twfg(2,3)=0 - - twfg(3,1)=0 - twfg(3,2)=0 - twfg(3,3)=1 - - SELECT CASE(ibrav) - - CASE(1) - ! - ! Cubic P [sc] - ! - nw = 3 - ! - ! - CASE(2) - ! - ! Cubic F [fcc] - ! - nw = 4 - - twfg(4,1)=-1 - twfg(4,2)=-1 - twfg(4,3)=-1 - ! - ! - CASE(3) - ! - ! Cubic I [bcc] - ! - nw = 6 - - twfg(4,1)=1 - twfg(4,2)=1 - twfg(4,3)=0 - - twfg(5,1)=0 - twfg(5,2)=1 - twfg(5,3)=1 - - twfg(6,1)=-1 - twfg(6,2)=0 - twfg(6,3)=1 - ! - ! - CASE(4) - ! - ! Hexagonal and Trigonal P - ! - nw = 4 - - twfg(4,1)=1 - twfg(4,2)=-1 - twfg(4,3)=0 - ! - ! - CASE(5) - ! - ! Trigonal R - ! - t0 = 1.D0/3.D0 - ! - IF ( celldm(4) .ge. t0 ) THEN - ! - nw = 4 - ! - twfg(4,1)=1 - twfg(4,2)=1 - twfg(4,3)=1 - ! - ELSE - ! - IF ( celldm(4) .gt. 0 ) THEN - ! - nw = 6 - ! - twfg(4,1)=1 - twfg(4,2)=1 - twfg(4,3)=0 - - twfg(5,1)=0 - twfg(5,2)=1 - twfg(5,3)=1 - - twfg(6,1)=1 - twfg(6,2)=0 - twfg(6,3)=1 - ! - ELSE IF ( celldm(4) .eq. 0 ) THEN - ! - nw = 3 - ! - ELSE - ! - nw = 6 - ! - twfg(4,1)=1 - twfg(4,2)=-1 - twfg(4,3)=0 - - twfg(5,1)=0 - twfg(5,2)=1 - twfg(5,3)=-1 - - twfg(6,1)=-1 - twfg(6,2)=0 - twfg(6,3)=1 - ! - END IF - ! - END IF - - CASE(6) - ! - ! Tetragonal P [st] - ! - nw = 3 - ! - ! - CASE(7) - ! - ! Tetragonal I [bct] - ! - nw = 6 - - twfg(4,1)=1 - twfg(4,2)=0 - twfg(4,3)=1 - - twfg(5,1)=0 - twfg(5,2)=1 - twfg(5,3)=-1 - - twfg(6,1)=1 - twfg(6,2)=1 - twfg(6,3)=0 - ! - ! - CASE(8) - ! - ! Orthorhombic P - ! - nw = 3 - ! - ! - CASE(9) - ! - ! Orthorhombic C - ! - IF (celldm(2).EQ.1) THEN ! Tetragonal P - ! - nw=3 - ! - ELSE - ! - nw = 4 - ! - IF ( celldm(2) < 1 ) THEN - ! - twfg(4,1)=1 - twfg(4,2)=-1 - twfg(4,3)=0 - ! - ELSE - ! - twfg(4,1)=1 - twfg(4,2)=1 - twfg(4,3)=0 - ! - END IF - ! - END IF - ! - ! - CASE(10) - ! - ! Orthorhombic F - ! - twfg(4,1)=1 - twfg(4,2)=1 - twfg(4,3)=1 - ! - IF ( celldm(2) .eq. 1 .AND. celldm(3) .eq. 1 ) THEN ! Cubic F - ! - nw = 4 - ! - ELSE - ! - nw = 6 - ! - IF ( celldm(2) .eq. 1 .AND. celldm(3) .ne. 1) THEN ! Tetragonal I - ! - twfg(5,1)=1 - twfg(5,2)=1 - twfg(5,3)=0 - twfg(6,1)=0 - twfg(6,2)=1 - twfg(6,3)=1 - ! - ELSE IF ( celldm(2) .ne. 1 .AND. celldm(3) .eq. 1) THEN ! Tetragonal I - ! - twfg(5,1)=1 - twfg(5,2)=1 - twfg(5,3)=0 - twfg(6,1)=1 - twfg(6,2)=0 - twfg(6,3)=1 - ! - ELSE IF ( celldm(2) .eq. celldm(3) ) THEN ! Tetragonal I - ! - twfg(5,1)=0 - twfg(5,2)=1 - twfg(5,3)=1 - twfg(6,1)=1 - twfg(6,2)=0 - twfg(6,3)=1 - ! - ELSE IF ( celldm(2) .gt. 1 .and. celldm(3) .gt. 1 ) THEN - ! - twfg(5,1)=0 - twfg(5,2)=1 - twfg(5,3)=1 - twfg(6,1)=1 - twfg(6,2)=0 - twfg(6,3)=1 - ! - ELSE IF ( celldm(2) .lt. celldm(3) ) THEN - ! - twfg(5,1)=1 - twfg(5,2)=1 - twfg(5,3)=0 - twfg(6,1)=1 - twfg(6,2)=0 - twfg(6,3)=1 - ! - ELSE - ! - twfg(5,1)=1 - twfg(5,2)=1 - twfg(5,3)=0 - twfg(6,1)=0 - twfg(6,2)=1 - twfg(6,3)=1 - ! - END IF - ! - END IF - ! - ! - CASE(11) - ! - ! Orthorhombic I - ! - nw = 6 - ! - twfg(4,1)=1 - twfg(4,2)=1 - twfg(4,3)=0 - - twfg(5,1)=0 - twfg(5,2)=1 - twfg(5,3)=1 - - twfg(6,1)=-1 - twfg(6,2)=0 - twfg(6,3)=1 - ! - ! - CASE(12) - ! - ! Monoclinic P - ! - IF ( celldm(4) .eq. 0 ) THEN ! Orthorhombic P - ! - nw = 3 - ! - ELSE - ! - nw = 4 - ! - t1 = SQRT(DOT_PRODUCT(b1,b1)) - t2 = SQRT(DOT_PRODUCT(b2,b2)) - t4 = DOT_PRODUCT(b1,b2)/t1/t2 - ! - t0 = - t4 * t1 / t2 - kk = NINT(t0) - ! - IF((kk.EQ.0).AND.(t0.GT.0)) kk=1 - IF((kk.EQ.0).AND.(t0.LT.0)) kk=-1 - - twfg(4,1)=1 - twfg(4,2)=kk - twfg(4,3)=0 - ! - END IF - ! - ! - CASE(0,13,14) - ! - ! Monoclinic C, Triclinic P, Free Cell - ! - nw = 6 - ! - t1 = SQRT(DOT_PRODUCT(b1,b1)) - t2 = SQRT(DOT_PRODUCT(b2,b2)) - t3 = SQRT(DOT_PRODUCT(b3,b3)) - t4 = DOT_PRODUCT(b1,b2)/t1/t2 - t5 = DOT_PRODUCT(b2,b3)/t2/t3 - t6 = DOT_PRODUCT(b3,b1)/t3/t1 - ! - t0 = - t4 * t1 / t2 - kk = NINT(t0) - ! - IF((kk.EQ.0).AND.(t0.GE.0)) kk=1 - IF((kk.EQ.0).AND.(t0.LT.0)) kk=-1 - - twfg(4,1)=1 - twfg(4,2)=kk - twfg(4,3)=0 - ! - t0 = - t5 * t2 / t3 - kk = NINT(t0) - ! - IF((kk.EQ.0).AND.(t0.GE.0)) kk=1 - IF((kk.EQ.0).AND.(t0.LT.0)) kk=-1 - ! - twfg(5,1)=0 - twfg(5,2)=1 - twfg(5,3)=kk - ! - t0 = - t6 * t3 / t1 - kk = NINT(t0) - ! - IF((kk.EQ.0).AND.(t0.GE.0)) kk=1 - IF((kk.EQ.0).AND.(t0.LT.0)) kk=-1 - ! - twfg(6,1)=kk - twfg(6,2)=0 - twfg(6,3)=1 - ! - ! - END SELECT - ! - CALL tric_wts2( b1, b2, b3, nw, twfg, tweight ) - ! - ALLOCATE(wfg(nw,3), weight(nw)) - ! - wfg(:,:) = twfg(1:nw,:) - weight(:) = tweight(1:nw) - ! - RETURN - ! -END SUBROUTINE setwfg -! -!---------------------------------------------------------------------------- -SUBROUTINE tric_wts( rp1, rp2, rp3, wts ) - !---------------------------------------------------------------------------- - ! - ! ... This subroutine computes the weights to be used for - ! ... R.P. translations in the WF calculation in the case - ! ... of ibrav=0 or ibrav=14 - ! - USE kinds, ONLY : DP - USE constants, ONLY : pi - USE cell_base, ONLY : tpiba, tpiba2 - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: rp1(3), rp2(3), rp3(3) - REAL(DP), INTENT(OUT) :: wts(6) - ! - REAL(DP) :: b1x, b2x, b3x, b1y, b2y, b3y, b1z, b2z, b3z - ! - ! - b1x = rp1(1)*tpiba - b2x = rp2(1)*tpiba - b3x = rp3(1)*tpiba - b1y = rp1(2)*tpiba - b2y = rp2(2)*tpiba - b3y = rp3(2)*tpiba - b1z = rp1(3)*tpiba - b2z = rp2(3)*tpiba - b3z = rp3(3)*tpiba - ! WRITE( stdout, * ) 'COMPUTING WEIGHTS NOW ...' - - wts(1) = tpiba2*(-b1z*b2x*b2z*b3x + b2y**2*b3x**2 + b1z*b2z*b3x**2 + & - b2z**2*b3x**2 - b1z*b2y*b2z*b3y - 2.D0*b2x*b2y*b3x*b3y + & - b2x**2*b3y**2 + b1z*b2z*b3y**2 + b2z**2*b3y**2 + & - b1z*b2x**2*b3z + b1z*b2y**2*b3z - b1z*b2x*b3x*b3z - & - 2.D0*b2x*b2z*b3x*b3z - b1z*b2y*b3y*b3z - & - 2.D0*b2y*b2z*b3y*b3z + b2x**2*b3z**2 + b2y**2*b3z**2 + & - b1x*(b2y**2*b3x + b2z**2*b3x - b2y*(b2x + b3x)*b3y - & - b2z*(b2x + b3x)*b3z + b2x*(b3y**2 + b3z**2)) + & - b1y*(b2x**2*b3y - b2x*b3x*(b2y + b3y) + & - b2z*b3y*(b2z - b3z) + b2y*(b3x**2 - b2z*b3z + b3z**2)))/ & - ((b1z*b2y*b3x - b1y*b2z*b3x - b1z*b2x*b3y + b1x*b2z*b3y & - + b1y*b2x*b3z - b1x*b2y*b3z)**2) - - wts(2) = tpiba2*(b1z**2*(b2x*b3x + b3x**2 + b3y*(b2y + b3y)) + & - b1y**2*(b2x*b3x + b3x**2 + b3z*(b2z + b3z)) - & - b1z*(-b2z*(b3x**2 + b3y**2) + (b2x*b3x + b2y*b3y)*b3z + & - b1x*(b2z*b3x + (b2x + 2.D0* b3x)*b3z)) - & - b1y*(b1x*(b2y*b3x + (b2x + 2.D0*b3x)*b3y) + & - b3y*(b1z*b2z + b2x*b3x + 2.D0*b1z*b3z + b2z*b3z) - & - b2y*(b3x**2 - b1z* b3z + b3z**2)) + & - b1x*(-b2y*b3x*b3y + b2x*b3y**2 - b2z*b3x*b3z + b2x*b3z**2 + & - b1x*(b2y*b3y + b3y**2 + b3z*(b2z + b3z))))/ & - ((b1z*b2y*b3x - b1y*b2z*b3x - b1z*b2x*b3y + b1x*b2z*b3y + & - b1y*b2x*b3z - b1x*b2y*b3z)**2) - - wts(3) = tpiba2*(b1z**2*(b2x**2 + b2x*b3x + b2y*(b2y + b3y)) - & - b1y*(2.D0*b1z*b2y*b2z + b2x*b2y*b3x - b2x**2*b3y + & - b1z*b2z*b3y - b2z**2*b3y + b1x*(2.D0*b2x*b2y + b2y*b3x + b2x*b3y) + & - b1z*b2y*b3z + b2y*b2z*b3z) + b1y**2*(b2x**2 + b2x*b3x + b2z*(b2z + b3z)) - & - b1z*(b2x*b2z*b3x + b2y*b2z*b3y - b2x**2*b3z - b2y**2*b3z + & - b1x*(2.D0*b2x*b2z + b2z*b3x + b2x*b3z)) + & - b1x*(b2y**2*b3x + b2z**2*b3x - b2x*b2y*b3y - b2x*b2z*b3z + & - b1x*(b2y**2 + b2y*b3y + b2z*(b2z + b3z))))/ & - ((b1z*b2y*b3x - b1y*b2z*b3x - b1z*b2x*b3y + b1x*b2z*b3y + b1y*b2x*b3z - & - b1x*b2y*b3z)**2) - - wts(4) = tpiba2*(b1z*(-b2z*(b3x**2 + b3y**2) + (b2x*b3x + b2y*b3y)*b3z) + & - b1y*(b3y*(b2x*b3x + b2z*b3z) - b2y*(b3x**2 + b3z**2)) + & - b1x*(b2y*b3x*b3y + b2z*b3x*b3z - b2x*(b3y**2 + b3z**2)))/ & - ((b1z*b2y*b3x - b1y*b2z*b3x - b1z*b2x*b3y + b1x*b2z*b3y + & - b1y*b2x*b3z - b1x*b2y*b3z)**2) - - wts(5) = -tpiba2*(b1z**2*(b2x*b3x + b2y*b3y) - b1x*b1z*(b2z*b3x + b2x*b3z) - & - b1y*(b1x*b2y*b3x + b1x*b2x*b3y + b1z*b2z*b3y + b1z*b2y*b3z) + & - b1y**2*(b2x*b3x + b2z*b3z) + b1x**2*(b2y*b3y + b2z*b3z))/ & - ((b1z*b2y*b3x - b1y*b2z*b3x - b1z*b2x*b3y + b1x*b2z*b3y + & - b1y*b2x*b3z - b1x*b2y*b3z)**2) - - wts(6) = -tpiba2*(b1z*(-b2x*b2z*b3x - b2y*b2z*b3y + b2x**2*b3z + b2y**2*b3z) + & - b1x*(b2y**2*b3x + b2z**2*b3x - b2x*b2y*b3y - b2x*b2z*b3z) + & - b1y*(-b2x*b2y*b3x + b2x**2*b3y + b2z*(b2z*b3y - b2y*b3z)))/ & - ((b1z*b2y*b3x - b1y*b2z*b3x - b1z*b2x*b3y + b1x*b2z*b3y + & - b1y*b2x*b3z - b1x*b2y*b3z)**2) - ! - RETURN - ! -END SUBROUTINE tric_wts -! -!---------------------------------------------------------------------------- -SUBROUTINE tric_wts2( rp1, rp2, rp3, nw, wfg, weight ) - !---------------------------------------------------------------------------- - ! - ! ... added by Young-Su Lee ( Nov 2006 ) - ! - ! Find the least square solutions of weights for G vectors - ! If the set of G vectors and calculated weights do not conform to the condition, - ! SUM_i weight_i G_ia G_ib = delta_ab - ! the code stops. - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: rp1(3), rp2(3), rp3(3) - INTEGER, INTENT(IN) :: wfg(6,3), nw - REAL(DP), INTENT(OUT) :: weight(6) - ! - REAL(DP) :: gp(6,nw), A(6,nw), gr(nw,3), S(6), R(6), WORK(1000), t - INTEGER :: i, LWORK, INFO - ! - DO i=1, nw - gr(i,:) = wfg(i,1)*rp1(:)+wfg(i,2)*rp2(:)+wfg(i,3)*rp3(:) - END DO - - DO i=1, nw - gp(1,i)=gr(i,1)*gr(i,1) - gp(2,i)=gr(i,2)*gr(i,2) - gp(3,i)=gr(i,3)*gr(i,3) - gp(4,i)=gr(i,1)*gr(i,2) - gp(5,i)=gr(i,2)*gr(i,3) - gp(6,i)=gr(i,3)*gr(i,1) - END DO - ! - R = 0.D0 - R(1:3) = 1.D0 - ! - LWORK=1000 - A = gp - S = R - ! - CALL DGELS( 'N', 6, nw, 1, A, 6, S, 6, WORK, LWORK, INFO ) - ! - IF (INFO .ne. 0) THEN - WRITE( stdout, * ) "failed to get a weight factor for ",INFO,"th vector" - STOP - END IF - ! - weight(1:nw) = S(:) - S=matmul(gp,weight(1:nw)) - ! - DO i=1, nw - IF ( weight(i) .lt. 0.D0 ) THEN - WRITE( stdout, * ) "WARNING: weight factor less than zero" - END IF - END DO - ! - DO i=1,6 - t = abs(S(i)-R(i)) - IF ( t .gt. 1.D-8 ) THEN - WRITE( stdout, * ) "G vectors do not satisfy the completeness condition",i,t - STOP - END IF - END DO - ! - RETURN - ! -END SUBROUTINE tric_wts2 -! -!---------------------------------------------------------------------------- -SUBROUTINE small_box_wf( i_1, j_1, k_1, nw1 ) - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - USE constants, ONLY : fpi - USE wannier_base, ONLY : expo - USE grid_dimensions, ONLY : nr1, nr2, nr3, nr1x, nr2x, nr3x, nnrx - USE fft_base, ONLY : dfftp - USE mp_global, ONLY : me_image - USE parallel_include - ! - IMPLICIT NONE - - INTEGER ir1, ir2, ir3, ibig3 , inw - REAL(DP) x - INTEGER , INTENT(in) :: nw1, i_1(nw1), j_1(nw1), k_1(nw1) - INTEGER :: me - - me = me_image + 1 - - ALLOCATE(expo(nnrx,nw1)) - - DO inw=1,nw1 - - WRITE( stdout, * ) inw ,":", i_1(inw), j_1(inw), k_1(inw) - - DO ir3=1,nr3 -#ifdef __PARA - ibig3 = ir3 - dfftp%ipp( me ) - IF(ibig3.GT.0.AND.ibig3.LE.dfftp%npp(me)) THEN -#else - ibig3=ir3 -#endif - DO ir2=1,nr2 - DO ir1=1,nr1 - x = (((ir1-1)/DBLE(nr1x))*i_1(inw) + & - & ((ir2-1)/DBLE(nr2x))*j_1(inw) + & - & ((ir3-1)/DBLE(nr3x))*k_1(inw))*0.5d0*fpi - expo(ir1+(ir2-1)*nr1x+(ibig3-1)*nr1x*nr2x,inw) = CMPLX(COS(x), -SIN(x)) - END DO - END DO -#ifdef __PARA - END IF -#endif - END DO - END DO - RETURN -END SUBROUTINE small_box_wf -! -!----------------------------------------------------------------------- -FUNCTION boxdotgridcplx(irb,qv,vr) - !----------------------------------------------------------------------- - ! - ! Calculate \sum_i qv(r_i)*vr(r_i) with r_i on box grid - ! array qv(r) is defined on box grid, array vr(r)on dense grid - ! irb : position of the box in the dense grid - ! Parallel execution: remember to sum the contributions from other nodes - ! - ! use ion_parameters - ! - USE kinds, ONLY : DP - USE grid_dimensions, ONLY : nnrx, nr1, nr2, nr3, nr1x, nr2x - USE smallbox_grid_dimensions, ONLY : nnrbx, nr1b, nr2b, nr3b, & - nr1bx, nr2bx - USE fft_base, ONLY : dfftp - USE mp_global, ONLY : me_image - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN):: irb(3) - COMPLEX(DP), INTENT(IN):: qv(nnrbx), vr(nnrx) - COMPLEX(DP) :: boxdotgridcplx - ! - INTEGER :: ir1, ir2, ir3, ir, ibig1, ibig2, ibig3, ibig, me - ! - me = me_image + 1 - ! - boxdotgridcplx = ZERO - - DO ir3=1,nr3b - ibig3=irb(3)+ir3-1 - ibig3=1+MOD(ibig3-1,nr3) -#ifdef __PARA - ibig3 = ibig3 - dfftp%ipp( me ) - IF (ibig3.GT.0.AND.ibig3.LE.dfftp%npp(me)) THEN -#endif - DO ir2=1,nr2b - ibig2=irb(2)+ir2-1 - ibig2=1+MOD(ibig2-1,nr2) - DO ir1=1,nr1b - ibig1=irb(1)+ir1-1 - ibig1=1+MOD(ibig1-1,nr1) - ibig=ibig1 + (ibig2-1)*nr1x + (ibig3-1)*nr1x*nr2x - ir =ir1 + (ir2-1)*nr1bx + (ir3-1)*nr1bx*nr2bx - boxdotgridcplx = boxdotgridcplx + qv(ir)*vr(ibig) - END DO - END DO -#ifdef __PARA - ENDIF -#endif - END DO - ! - RETURN - ! -END FUNCTION boxdotgridcplx -! -!---------------------------------------------------------------------------- -SUBROUTINE write_rho_g( rhog ) - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - USE gvecp, ONLY : ngm - USE reciprocal_vectors, ONLY : gx - USE electrons_base, ONLY : nspin - USE fft_base, ONLY : dfftp - USE mp_global, ONLY : nproc_image, me_image, root_image, intra_image_comm - USE mp, ONLY : mp_barrier, mp_gather, mp_set_displs - USE parallel_include - ! - IMPLICIT NONE - ! - COMPLEX(DP) ,INTENT(IN) :: rhog(ngm,nspin) - REAL(DP), ALLOCATABLE:: gnx(:,:), bigg(:,:) - COMPLEX(DP),ALLOCATABLE :: bigrho(:) - COMPLEX(DP) :: rhotmp_g(ngm) - INTEGER :: ntot, i, j, me -#ifdef __PARA - INTEGER ngdens(nproc_image), displs(nproc_image) -#endif - CHARACTER (LEN=6) :: name - CHARACTER (LEN=15) :: name2 - - me = me_image + 1 - - ALLOCATE(gnx(3,ngm)) - - DO i=1,ngm - gnx(1,i)=gx(1,i) - gnx(2,i)=gx(2,i) - gnx(3,i)=gx(3,i) - END DO - -#ifdef __PARA - - DO i=1,nproc_image - ngdens(i)=(dfftp%ngl(i)+1)/2 - END DO - - CALL mp_set_displs( ngdens, displs, ntot, nproc_image ) - - IF(me.EQ.1) THEN - ALLOCATE(bigg(3,ntot)) - END IF - - CALL mp_barrier(intra_image_comm) - - CALL mp_gather( gnx, bigg, ngdens, displs, root_image, intra_image_comm ) - - DO i=1,nspin - - rhotmp_g(1:ngm)=rhog(1:ngm,i) - - IF(me.EQ.1) THEN - ALLOCATE (bigrho(ntot)) - END IF - - CALL mp_barrier(intra_image_comm) - - CALL mp_gather( rhotmp_g, bigrho, ngdens, displs, root_image, intra_image_comm ) - - IF(me.EQ.1) THEN - IF(i.EQ.1) name2="CH_DEN_G_PARA.1" - IF(i.EQ.2) name2="CH_DEN_G_PARA.2" - OPEN(unit=57, file=name2) - DO j=1,ntot - WRITE(57,*) bigrho(j) - END DO - CLOSE(57) - DEALLOCATE(bigrho) - END IF - - WRITE( stdout, * ) "Charge density written to ", name2 - - END DO - - IF(me.EQ.1) THEN - name="G_PARA" - OPEN(unit=56, file=name) - DO i=1,ntot - WRITE(56,*) bigg(:,i) - END DO - CLOSE(56) - DEALLOCATE(bigg) - END IF - WRITE( stdout, * ) "G-vectors written to G_PARA" -#else - ntot=ngm - ALLOCATE(bigg(3,ntot)) - bigg(1:3,1:ntot)=gnx(1:3,1:ngm) - DO i=1,nspin - ALLOCATE(bigrho(ntot)) - bigrho(1:ngm)=rhog(1:ngm,i) - - IF(i.EQ.1) name2="CH_DEN_G_SERL.1" - IF(i.EQ.2) name2="CH_DEN_G_SERL.2" - - OPEN(unit=57, file=name2) - DO j=1,ntot - WRITE(57,*) bigrho(j) - END DO - CLOSE(57) - DEALLOCATE(bigrho) - - WRITE( stdout, * ) "Charge density written to", name2 - - END DO - - name="G_SERL" - OPEN(unit=56, file=name) - DO i=1,ntot - WRITE(56,*) bigg(:,i) - END DO - CLOSE(56) - DEALLOCATE(bigg) - WRITE( stdout, * ) "G-vectors written to G_SERL" -#endif - ! - DEALLOCATE(gnx) - ! - RETURN - ! -END SUBROUTINE write_rho_g -! -!---------------------------------------------------------------------------- -SUBROUTINE macroscopic_average( rhog, tau0, e_tuned ) - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE reciprocal_vectors, ONLY : gx - USE gvecp, ONLY : ngm - USE electrons_base, ONLY : nspin - USE tune, ONLY : npts, xdir, ydir, zdir, B, & - shift, start, av0, av1 - USE cell_base, ONLY : a1, a2, a3, tpiba, omega - USE ions_base, ONLY : nsp, na, zv, nax - USE constants, ONLY : pi, tpi - USE mp, ONLY : mp_barrier, mp_bcast, mp_gather, mp_set_displs - USE fft_base, ONLY : dfftp - USE mp_global, ONLY : nproc_image, me_image, root_image, intra_image_comm - USE parallel_include - ! - IMPLICIT NONE - ! - REAL(DP), ALLOCATABLE:: gnx(:,:), bigg(:,:) - COMPLEX(DP) ,INTENT(in) :: rhog(ngm,nspin) - COMPLEX(DP),ALLOCATABLE :: bigrho(:) - COMPLEX(DP), ALLOCATABLE :: rhotmp_g(:) - INTEGER ntot, i, j, ngz, l, isa - INTEGER ,ALLOCATABLE :: g_red(:,:) -#ifdef __PARA - INTEGER ngdens(nproc_image), displs( nproc_image ) -#endif - REAL(DP) zlen,vtot, pos(3,nax,nsp), a_direct(3,3),a_trans(3,3) - REAL(DP), INTENT(out) :: e_tuned(3) - REAL(DP), INTENT(in) :: tau0(3,nax) - REAL(DP),ALLOCATABLE :: v_mr(:), dz(:), gz(:), g_1(:,:), vbar(:), cd(:), v_final(:) - REAL(DP), ALLOCATABLE:: cdion(:), cdel(:), v_line(:), dist(:) - COMPLEX(DP),ALLOCATABLE :: rho_ion(:),v_1(:),vmac(:),rho_tot(:),rhogz(:), bigrhog(:) - INTEGER :: me - - me = me_image + 1 - - ALLOCATE(gnx(3,ngm)) - - DO i=1,ngm - gnx(1,i)=gx(1,i) - gnx(2,i)=gx(2,i) - gnx(3,i)=gx(3,i) - END DO - -#ifdef __PARA - - DO i=1,nproc_image - ngdens(i)=(dfftp%ngl(i)+1)/2 - END DO - - CALL mp_set_displs( ngdens, displs, ntot, nproc_image ) - -#else - - ntot=ngm - -#endif - - ALLOCATE(bigg(3,ntot)) - ALLOCATE (bigrho(ntot)) - ALLOCATE (bigrhog(2*ntot-1)) - -#ifdef __PARA - CALL mp_barrier( intra_image_comm ) - ! - CALL mp_gather( gnx, bigg, ngdens, displs, root_image,intra_image_comm ) - ! - CALL mp_bcast( bigg, root_image, intra_image_comm ) - ! - ALLOCATE( rhotmp_g( ngm ) ) - - rhotmp_g(1:ngm)=rhog(1:ngm,1) - - CALL mp_barrier( intra_image_comm ) - ! - CALL mp_gather( rhotmp_g, bigrho, ngdens, displs, root_image,intra_image_comm ) - ! - DEALLOCATE( rhotmp_g ) - ! - CALL mp_bcast( bigrho, root_image, intra_image_comm ) - ! -#else - ! - bigg(1:3,1:ntot)=gnx(1:3,1:ngm) - bigrho(1:ngm)=rhog(1:ngm,1) - ! -#endif - - ALLOCATE(g_1(3,2*ntot-1)) - ALLOCATE(g_red(3,2*ntot-1)) - - ALLOCATE(v_mr(npts)) - ALLOCATE(v_final(npts)) - ALLOCATE(dz(npts)) - ALLOCATE(vbar(npts)) - ALLOCATE(cd(npts)) - ALLOCATE(cdel(npts)) - ALLOCATE(cdion(npts)) - - !-- needed for non-orthogonal cells - - a_direct(1,1:3)=a1(1:3) - a_direct(2,1:3)=a2(1:3) - a_direct(3,1:3)=a3(1:3) - - a_trans=TRANSPOSE(a_direct) - - !--- Construct rho(-g) from rho(g). rgo(-g)=rho*(g) - - bigrhog(1:ntot)=bigrho(1:ntot) - g_1(:,1:ntot)=bigg(:,1:ntot) - DO i=2,ntot - bigrhog(ntot+i-1)=CONJG(bigrho(i)) - g_1(:,ntot+i-1)=-bigg(:,i) - END DO - - !--- needed fot non-orthogonal cells - - DO i=1,2*ntot-1 - g_red(:,i)=NINT(MATMUL(a_trans(:,:),g_1(:,i))*tpiba/tpi) - END DO - - !--- define the direction of the line - - xdir=1 - ydir=2 - - IF ((zdir).EQ.1) xdir=3 - IF ((zdir).EQ.2) ydir=3 - - IF(zdir.EQ.1) zlen=DSQRT(a1(1)**2+a1(2)**2+a1(3)**2) - IF(zdir.EQ.2) zlen=DSQRT(a2(1)**2+a2(2)**2+a2(3)**2) - IF(zdir.EQ.3) zlen=DSQRT(a3(1)**2+a3(2)**2+a3(3)**2) - - - !--- We need the potentiail only along zdir, so pick the appropriate G-vectors with Gxdir=Gydir=0 - - ngz=0 - DO i=1,2*ntot-1 - IF((g_red(xdir,i).EQ.0).AND.(g_red(ydir,i).EQ.0)) ngz=ngz+1 - END DO - - ALLOCATE(gz(ngz)) - ALLOCATE(rhogz(ngz)) - ALLOCATE(rho_ion(ngz)) - ALLOCATE(rho_tot(ngz)) - ALLOCATE(vmac(ngz)) - ALLOCATE(v_1(ngz)) - - !--- The G-vectors are output in units of 2*pi/a, so convert them to the correct values - - j=0 - DO i=1,2*ntot-1 - IF((g_red(xdir,i).EQ.0).AND.(g_red(ydir,i).EQ.0)) THEN - j=j+1 - gz(j)=g_1(zdir,i)*tpiba - rhogz(j)=bigrhog(i) - END IF - END DO - - isa = 0 - DO i=1,nsp - DO j=1,na(i) - isa = isa + 1 - pos(:,j,i)=tau0(:,isa) - END DO - END DO - - !--- Construct the ionic Charge density in G-space - - rho_ion = ZERO - ! - DO j=1,ngz - DO i=1,nsp - DO l=1,na(i) - rho_ion(j)=rho_ion(j)+zv(i)*EXP(-CI*gz(j)*pos(zdir,l,i))*EXP(-gz(j)**2/(4.D0*ONE)) - END DO - END DO - END DO - - rho_ion=rho_ion/omega - - !--- Construct the total Charge density in G-space - - rho_tot=rho_ion-rhogz - - !--- Construct the electrostatic potential and macroscopic average in G-space - - v_1(1)=ZERO - vmac(1)=ZERO - v_1(2:ngz)=4*pi*rho_tot(2:ngz)/gz(2:ngz)**2 - vmac(2:)=v_1(2:)*SIN(gz(2:)*b)/(gz(2:)*b) - - - !--- Calculate planewise average in R-space and FFT V(Gz) ---> V(z) ... well not really FFT but FT - - vbar=0.D0 - v_mr=0.D0 - cdel=0.D0 - cdion=0.D0 - cd=0.D0 - DO j=1,npts - dz(j)=(j-1)*zlen/(npts*1.D0) - DO i=1,ngz - vbar(j)=vbar(j)-DBLE(EXP(CI*gz(i)*dz(j))*v_1(i)) - v_mr(j)=v_mr(j)-DBLE(EXP(CI*gz(i)*dz(j))*vmac(i)) - cdel(j)=cdel(j)-DBLE(EXP(CI*gz(i)*dz(j))*rhogz(i)) - cdion(j)=cdion(j)+DBLE(EXP(CI*gz(i)*dz(j))*rho_ion(i)) - cd(j)=cd(j)+DBLE(EXP(CI*gz(i)*dz(j))*rho_tot(i)) - END DO - ! WRITE( stdout, * ) vbar(j), v_mr(j), cdel(j), cdion(j) - END DO - IF (shift) THEN - vtot=(v_mr(start)+v_mr(start-1))/2.D0 - v_final(1:npts-start+1)=v_mr(start:npts)-vtot - v_final(npts-start+2:npts)=v_mr(1:start-1)-vtot - ELSE - vtot=(v_mr(1)+v_mr(npts))/2.D0 - v_final(1:npts)=v_mr(1:npts)-vtot - END IF - - e_tuned=0.D0 - - ALLOCATE(v_line(1:av1-av0+1)) - ALLOCATE(dist(1:av1-av0+1)) - - - v_line(1:av1-av0+1)=v_final(av0:av1) - dist(1:av1-av0+1) =dz(av0:av1) - - e_tuned(zdir)=-(v_final(av1)-v_final(av0))/((av1-av0)*zlen/(npts*1.D0)) - - - DEALLOCATE(bigg,g_1,bigrho,bigrhog,g_red) - DEALLOCATE(gnx,v_mr,v_final,dz,vbar,cd,cdel,cdion) - DEALLOCATE(v_line, dist) - DEALLOCATE(gz,rhogz,rho_ion,rho_tot,vmac,v_1) - - RETURN -END SUBROUTINE macroscopic_average -! -!---------------------------------------------------------------------------- -SUBROUTINE least_square( npts, x, y, slope, intercept ) - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: npts - REAL(DP), INTENT(IN) :: x(npts), y(npts) - REAL(DP), INTENT(OUT):: slope, intercept - ! - INTEGER :: i - REAL(DP) :: sumx,sumy,sumx2,sumxy,sumsqx - REAL(DP) :: xav,yav - - sumxy=0.D0 - sumx =0.D0 - sumy =0.D0 - sumx2=0.D0 - DO i=1,npts - sumxy=sumxy+x(i)*y(i) - sumx =sumx +x(i) - sumy =sumy +y(i) - sumx2=sumx2+x(i)*x(i) - END DO - sumsqx=sumx**2 - xav=sumx/DBLE(npts) - yav=sumy/DBLE(npts) - - slope=(npts*sumxy - sumx*sumy)/(npts*sumx2 - sumsqx) - - intercept=yav-slope*xav - - RETURN - -END SUBROUTINE least_square -! -!---------------------------------------------------------------------------- -SUBROUTINE wfsteep( m, Omat, Umat) - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - USE wannier_base, ONLY : nw, weight, nit, tolw, wfdt, maxwfdt, nsd - USE control_flags, ONLY : iprsta - USE cell_base, ONLY : alat - USE constants, ONLY : tpi, autoaf => BOHR_RADIUS_ANGS - USE mp_global, ONLY : me_image - USE printout_base, ONLY : printout_base_open, printout_base_unit, & - printout_base_close - USE parallel_include - ! - IMPLICIT NONE - - ! (m,m) is the size of the matrix Ospin. - ! Ospin is input overlap matrix. - ! Uspin is the output unitary transformation. - ! Rough guess for Uspin can be carried in. - ! - ! conjugated gradient to search maximization - ! - INTEGER, INTENT(in) :: m - COMPLEX(DP), INTENT(inout) :: Omat(nw, m, m) - REAL(DP), INTENT(inout) :: Umat(m,m) - ! - INTEGER :: i, j, k, ierr, ti, tj, tk, inw - REAL(DP) :: slope, slope2, t1, t2, t3, mt(nw),t21,temp1,maxdt - REAL(DP) :: U(m,m), Wm(m,m), schd(m,m), f2(4*m) - REAL(DP) :: temp2,wfdtold,oldt1,t01, d3(m,m), d4(m,m), U1(m,m) - REAL(DP) :: spread, sp - REAL(DP), ALLOCATABLE :: wr(:) - REAL(DP), ALLOCATABLE :: W(:,:) - COMPLEX(DP) :: z(m, m), X(m, m), d(m,m) - COMPLEX(DP) :: f1(2*m-1), Oc(nw, m, m) - COMPLEX(DP) :: Oc2(nw, m, m),wp1(m*(m+1)/2), X1(m,m), U2(m,m), U3(m,m) - INTEGER :: me, iunit - ! - me = me_image + 1 - ! - ALLOCATE(W(m,m), wr(m)) - ! - Umat=0.D0 - DO i=1,m - Umat(i,i)=1.D0 - END DO - Oc=ZERO - Oc2=ZERO - X1=ZERO - U2=Umat*ONE - ! - ! update Oc using the initial guess of Uspin - ! - DO inw=1, nw - X1(:, :)=Omat(inw, :, :) - U3=ZERO - CALL ZGEMM ('T', 'N', m,m,m,ONE,U2,m,X1,m,ZERO,U3,m) - X1=ZERO - CALL ZGEMM ('N','N', m,m,m,ONE,U3,m,U2,m,ZERO,X1,m) - Oc(inw, :, :)=X1(:, :) - END DO - - U2=ZERO - U3=ZERO - - W=0.D0 - schd=0.D0 - oldt1=0.D0 - wfdtold=0.D0 - - DO k=1, nit - t01=0.D0 !use t1 to store the value of omiga - DO inw=1, nw - DO i=1, m - t01=t01+DBLE(CONJG(Oc(inw, i, i))*Oc(inw, i, i)) - END DO - END DO - - ! WRITE( stdout, * ) t01 - - IF(ABS(oldt1-t01).LT.tolw) THEN - IF(me.EQ.1) THEN - WRITE(27,*) "MLWF Generated at Step",k - END IF - IF(iprsta.GT.4) THEN - WRITE( stdout, * ) "MLWF Generated at Step",k - END IF - GO TO 40 - END IF - - ! oldt1=t01 - - ! calculate d(omiga)/dW and store result in W - ! W should be a real symmetric matrix for gamma-point calculation - ! - Wm=W - W=0.D0 - DO inw=1, nw - t2=weight(inw) - DO i=1,m - DO j=i+1,m - W(i,j)=W(i,j)+t2*DBLE(Oc(inw,i,j)*CONJG(Oc(inw,i,i) & - -Oc(inw,j,j))+CONJG(Oc(inw,j,i))*(Oc(inw,i,i)-Oc(inw,j,j))) - END DO - END DO - END DO - W=W-TRANSPOSE(W) - - ! calculate slope=d(omiga)/d(lamda) - slope=SUM(W**2) - - ! calculate slope2=d2(omiga)/d(lamda)2 - slope2=0.D0 - DO ti=1, m - DO tj=1, m - DO tk=1, m - t2=0.D0 - DO inw=1, nw - t2=t2+DBLE(Oc(inw,tj,tk)*CONJG(Oc(inw,tj,tj)+Oc(inw,tk,tk) & - -2.D0*Oc(inw,ti,ti))-4.D0*Oc(inw,ti,tk) & - *CONJG(Oc(inw,ti,tj)))*weight(inw) - END DO - slope2=slope2+W(tk,ti)*W(ti,tj)*2.D0*t2 - END DO - END DO - END DO - slope2=2.D0*slope2 - - ! use parabola approximation. Defined by 1 point and 2 slopes - IF (slope2.LT.0) wfdt=-slope/2.D0/slope2 - IF (maxwfdt.GT.0.AND.wfdt.GT.maxwfdt) wfdt=maxwfdt - - IF (k.LT.nsd) THEN - schd=W !use steepest-descent technique - - ! calculate slope=d(omiga)/d(lamda) - slope=SUM(schd**2) - - ! schd=schd*maxwfdt - DO i=1, m - DO j=i, m - wp1(i + (j-1)*j/2) = CMPLX(0.d0, schd(i,j)) - END DO - END DO - -#if defined (__ESSL) - ! - CALL zhpev(21, wp1, wr, z, m, m, f2, 4*m) - ! - ierr1 = 0 - ! -#else - ! - CALL zhpev('V','U',m,wp1,wr,z,m,f1,f2,ierr) - ! -#endif - - IF (ierr.NE.0) STOP 'failed to diagonalize W!' - - ELSE - ! - CALL DGEMM ('T','N', m,m,m,ONE,Wm,m,Wm,m,ZERO,d3,m) - - t1=0.D0 - DO i=1, m - t1=t1+d3(i, i) - END DO - IF (t1.NE.0) THEN - d4=(W-Wm) - CALL DGEMM ('T','N', m,m,m,ONE,W,m,d4,m,ZERO,d3,m) - t2=0.D0 - DO i=1, m - t2=t2+d3(i, i) - END DO - t3=t2/t1 - schd=W+schd*t3 - ELSE - schd=W - END IF - ! - ! calculate the new d(Lambda) for the new Search Direction - ! added by Manu. September 19, 2001 - ! - ! calculate slope=d(omiga)/d(lamda) - slope=SUM(schd**2) - !------------------------------------------------------------------------ - ! schd=schd*maxwfdt - DO i=1, m - DO j=i, m - wp1(i + (j-1)*j/2) = CMPLX(0.d0, schd(i,j)) - END DO - END DO - -#if defined __ESSL - CALL zhpev(21, wp1, wr, z, m, m, f2, 4*m) - ierr1 = 0 -#else - CALL zhpev('V','U',m,wp1,wr,z,m,f1,f2,ierr) -#endif - IF (ierr.NE.0) STOP 'failed to diagonalize W!' - - maxdt=maxwfdt - -11 d=0.D0 - DO i=1, m - d(i, i)=EXP(CI*(maxwfdt)*wr(i)) - END DO - - U3=ZERO - CALL ZGEMM ('N', 'N', m,m,m,ONE,z,m,d,m,ZERO,U3,m) - U2=ZERO - CALL ZGEMM ('N','C', m,m,m,ONE,U3,m,z,m,ZERO,U2,m) - U=DBLE(U2) - U2=ZERO - U3=ZERO - ! - ! update Uspin - U1=ZERO - CALL DGEMM ('N', 'N', m,m,m,ONE,Umat,m,U,m,ZERO,U1,m) - Umat=U1 - - ! - ! update Oc - ! - U2=Umat*ONE - U3=ZERO - DO inw=1, nw - X1(:,:)=Omat(inw,:,:) - CALL ZGEMM ('T', 'N', m,m,m,ONE,U2,m,X1,m,ZERO,U3,m) - X1=ZERO - CALL ZGEMM ('N','N',m,m,m,ONE,U3,m,U2,m,ZERO,X1,m) - Oc2(inw, :,:)=X(:,:) - END DO - U2=ZERO - U3=ZERO - ! - t21=0.D0 !use t21 to store the value of omiga - DO inw=1, nw - DO i=1, m - t21=t21+DBLE(CONJG(Oc2(inw, i, i))*Oc2(inw, i, i)) - END DO - END DO - - temp1=-((t01-t21)+slope*maxwfdt)/(maxwfdt**2) - temp2=slope - wfdt=-temp2/(2*temp1) - - IF (wfdt.GT.maxwfdt.OR.wfdt.LT.0.D0) THEN - maxwfdt=2*maxwfdt - GO TO 11 - END IF - - maxwfdt=maxdt - ! - ! - ! use parabola approximation. Defined by 2 point and 1 slopes - ! if (slope2.lt.0) wfdt=-slope/2.D0/slope2 - ! if (maxwfdt.gt.0.and.wfdt.gt.maxwfdt) wfdt=maxwfdt - ! - ! write(6, '(e12.5E2,1x,e11.5E2,1x,f6.2)') slope2, slope, wfdt - !------------------------------------------------------------------------- - ! - ! schd is the new searching direction - ! - END IF - - d=0.D0 - DO i=1, m - d(i, i)=EXP(CI*wfdt*wr(i)) - END DO !d=exp(d) - - - ! U=z*exp(d)*z+ - ! - U3=ZERO - CALL ZGEMM ('N', 'N', m,m,m,ONE,z,m,d,m,ZERO,U3,m) - U2=ZERO - CALL ZGEMM ('N','C', m,m,m,ONE,U3,m,z,m,ZERO,U2,m) - U=DBLE(U2) - U2=ZERO - U3=ZERO - - ! update Uspin - ! - U1=ZERO - CALL DGEMM ('N', 'N', m,m,m,ONE,Umat,m,U,m,ZERO,U1,m) - Umat=U1 - - ! update Oc - ! - U2=Umat*ONE - U3=ZERO - DO inw=1, nw - X1(:, :)=Omat(inw, :, :) - CALL ZGEMM ('T', 'N', m,m,m,ONE,U2,m,X1,m,ZERO,U3,m) - X1=ZERO - CALL ZGEMM ('N','N',m,m,m,ONE,U3,m,U2,m,ZERO,X1,m) - Oc(inw, :, :)=X1(:, :) - END DO - U2=ZERO - U3=ZERO - IF(ABS(t01-oldt1).GE.tolw.AND.k.GE.nit) THEN - IF(me.EQ.1) THEN - WRITE(27,*) "MLWF Not generated after",k,"Steps." - END IF - IF(iprsta.GT.4) THEN - WRITE( stdout, * ) "MLWF Not generated after",k,"Steps." - END IF - GO TO 40 - END IF - oldt1=t01 - END DO - -40 DEALLOCATE(W, wr) - - ! - ! calculate the spread - ! - ! write(24, *) "spread: (unit \AA^2)" - -!$$ - spread = 0.d0 -!$$ - - IF(me.EQ.1) THEN - iunit = printout_base_unit( "spr" ) - CALL printout_base_open( "spr" ) - END IF - - DO i=1, m - ! - mt=1.D0-DBLE(Oc(:,i,i)*CONJG(Oc(:,i,i))) - sp = (alat*autoaf/tpi)**2*SUM(mt*weight) - ! - IF(me.EQ.1) THEN - WRITE(iunit, '(f10.7)') sp - END IF - IF( sp < 0.D0 ) & - CALL errore( 'cp-wf', 'Something wrong WF Spread negative', 1 ) - ! - spread=spread+sp - ! - END DO - spread=spread/DBLE(m) - - IF(me.EQ.1) THEN - CALL printout_base_open( "spr" ) - END IF - - IF(me.EQ.1) THEN - WRITE(24, '(f10.7)') spread - WRITE(27,*) "Average spread = ", spread - END IF - ! - Omat=Oc - ! - RETURN -END SUBROUTINE wfsteep -! -! -! -!---------------------------------------------------------------------------- -SUBROUTINE write_psi( c, jw ) - !---------------------------------------------------------------------------- - ! ... for calwf 5 - M.S - ! ... collect wavefunctions on first node and write to file - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout, ionode - USE gvecw , ONLY : ngw - USE electrons_base, ONLY : nbspx - USE mp, ONLY : mp_barrier, mp_set_displs, mp_gather - USE fft_base, ONLY : dfftp - USE mp_global, ONLY : nproc_image, me_image, root_image, intra_image_comm - ! - IMPLICIT NONE - ! - INTEGER :: jw - COMPLEX(DP) :: c(ngw,nbspx) - ! - INTEGER ::i, proc, ntot, ngpwpp(nproc_image) - INTEGER ::displs(nproc_image) - COMPLEX(DP), ALLOCATABLE:: psitot(:) - -#if defined (__PARA) - ! - DO proc=1,nproc_image - ngpwpp(proc)=(dfftp%nwl(proc)+1)/2 - END DO - ! - CALL mp_set_displs( ngpwpp, displs, ntot, nproc_image ) - ! - ! allocate the needed work spaces - ! - IF ( me_image == root_image ) THEN - ALLOCATE(psitot(ntot)) - ELSE - ALLOCATE(psitot(1)) - END IF - ! - ! ... gather all psis arrays on the first node, in psitot - ! - CALL mp_barrier( intra_image_comm ) - ! - CALL mp_gather( c(:,jw), psitot, ngpwpp, displs, root_image, intra_image_comm ) - ! - ! write the node-number-independent array - ! - IF( me_image == root_image ) THEN - DO i=1,ntot - WRITE(22,*) psitot(i) - END DO - END IF - ! - DEALLOCATE(psitot) - -#else - ! - DO i=1,ngw - WRITE(22,*) c(i,jw) - END DO - ! -#endif - - IF( ionode ) WRITE( stdout, * ) "State Written", jw - ! - CALL stop_run( .TRUE. ) - ! - RETURN - ! -END SUBROUTINE write_psi -! -!---------------------------------------------------------------------------- -SUBROUTINE jacobi_rotation( m, Omat, Umat ) - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE wannier_base, ONLY : nw, weight, nit, tolw - USE cell_base, ONLY : alat - USE constants, ONLY : tpi - USE mp_global, ONLY : me_image - USE printout_base, ONLY : printout_base_open, printout_base_unit, & - printout_base_close - USE parallel_include - ! - IMPLICIT NONE - ! (m,m) is the size of the matrix Ospin. - ! Ospin is input overlap matrix. - ! Uspin is the output unitary transformation. - ! - ! Jacobi rotations method is used to minimize the spread. - ! (F. Gygi, J.-L. Fatterbert and E. Schwegler, Comput. Phys. Commun. 155, 1 (2003)) - ! - ! This subroutine has been written by Sylvie Stucki and Audrius Alkauskas - ! in the Chair of Atomic Scale Simulation in Lausanne (Switzerland) - ! under the direction of Prof. Alfredo Pasquarello. - ! - REAL(DP), PARAMETER :: autoaf=0.529177d0 - INTEGER, intent(in) :: m - COMPLEX(DP), DIMENSION(nw, m, m), intent(inout) :: Omat - REAL(DP), DIMENSION(m, m), intent(inout) :: Umat - LOGICAL :: stopCriteria - INTEGER :: iterationNumber, lig, col, i, nbMat - INTEGER, PARAMETER :: dimG=2 - REAL(DP), DIMENSION(2*nw, m, m):: OmatReal - REAL(DP), DIMENSION(dimG, dimG):: matrixG - REAL(DP), DIMENSION(dimG) :: eigenVec - REAL(DP) :: a1, a2 ! are the components aii-ajj and aij-aji of the matrixes used to build matrixG - REAL(DP) :: r, c, s ! For a single rotation - REAL(DP) :: bMinusa, outDiag ! To compute the eigenvector linked to the largest eigenvalue of matrixG - REAL(DP) :: newMat_ll, newMat_cc, newMat_lc, presentSpread, saveSpread, mt(nw) - REAL(DP), DIMENSION (m,2) :: newMat_cols - INTEGER :: me - ! - me = me_image + 1 - nbMat=2*nw - ! - WRITE(24, *) 'Spreads before optimization' - DO i=1, m - ! - mt=1.D0-DBLE(Omat(:,i,i)*CONJG(Omat(:,i,i))) - presentSpread = SUM(mt*weight) - presentSpread = (alat/tpi)*DSQRT(presentSpread) - WRITE(24, *) 'Spread of the ', i, '-th wannier function is ' , presentSpread - IF( presentSpread < 0.D0 ) & - CALL errore( 'cp-wf', 'Something is wrong, WannierF spread negative', 1 ) - ! - ENDDO - ! - Umat=0.D0 - DO i=1,m - Umat(i,i)=1.D0 - END DO - do i=1,m - write (*, *) Umat(i, :) - end do - do i = 1, nw - OmatReal((2*i-1), :, :) = real(Omat(i, :, :), DP) - OmatReal(2*i, :, :) = aimag(Omat(i, :, :)) - end do - ! - iterationNumber = 0 - stopCriteria = .false. - ! - ! Calculation of the spread - presentSpread = 0. - do i=1, nbMat - do lig=1, m-1 - do col = lig+1, m - presentSpread = presentSpread + OmatReal(i, lig, col)*OmatReal(i, lig, col) - end do - end do - end do - print *, "Initial spread : ", presentSpread - saveSpread=presentSpread - ! - ! ATTENTION! limite d'iteration = nit !!!! - do while ((.not. stopCriteria) .and. (iterationNumber 1 ) THEN - ! - DO proc=1,nproc_image - ! - recvcount(proc) = dfft%nnp * ( dfft%npp(proc) ) - ! - IF (proc == 1) THEN - displs(proc)=0 - ELSE - displs(proc)=displs(proc-1) + recvcount(proc-1) - ENDIF - ! - ENDDO - ! - ! gather the charge density on the first node - ! - call mp_barrier() - call mp_gather( f, fdist, recvcount, displs, meta_ionode_id, intra_image_comm ) - ! - ELSE - ! - ! one processor per image - ! - IF ( nr1 /= nr1x .OR. nr2 /= nr2x .OR. nr3 /= nr3x ) & - CALL errore('writetofile','dimension mistmatch',10) - ! - fdist(1:nr1x*nr2x*nr3x) = f(1:nnrx) - ! - ENDIF - - ! - ! write data to file - ! - IF ( meta_ionode ) THEN - ! - OPEN( 300, file = TRIM( filename ), status = 'unknown' ) - ! - SELECT CASE( TRIM( which_print ) ) - ! - CASE( 'all' ) - ! - WRITE( 300, * ) fdist(:) - ! - CASE( 'x' ) - ! - DO ir1 = 1, nr1 - total = 0.D0 - num = 0 - DO ir2 = nr2 / 2, nr2 / 2 - DO ir3 = nr3 / 2, nr3 / 2 - ir = compindex( ir1, ir2, ir3, nr1, nr2, nr3 ) - total = total + fdist( ir ) - num = num + 1 - END DO - END DO - total = total / DBLE( num ) - WRITE( 300, '(2E30.10)' ) DBLE( ir1 - 1 ) & - * delta1m, total - END DO - ! - CASE( 'y' ) - ! - DO ir2 = 1, nr2 - total = 0.D0 - num = 0 - DO ir1 = nr1 / 2, nr1 / 2 - DO ir3 = nr3 / 2, nr3 / 2 - ir = compindex( ir1, ir2, ir3, nr1, nr2, nr3 ) - total = total + fdist( ir ) - num = num + 1 - END DO - END DO - total = total / DBLE( num ) - WRITE( 300, '(2E30.10)' ) DBLE( ir2 - 1 ) & - * delta2m, total - END DO - ! - CASE( 'z' ) - ! - DO ir3 = 1, nr3 - total = 0.D0 - num = 0 - DO ir2 = 0, 0 ! nr2 / 2, nr2 / 2 - DO ir1 = 0, 0 !nr1 / 2, nr1 / 2 - ir = compindex( ir1, ir2, ir3, nr1, nr2, nr3 ) - total = total + fdist( ir ) - num = num + 1 - END DO - END DO - total = total / DBLE( num ) - WRITE( 300, '(2E30.10)' ) DBLE( ir3 - 1 ) & - * delta3m, total - END DO - ! - CASE( 'ax' ) - ! - DO ir1 = 1, nr1 - total = 0.D0 - num = 0 - DO ir2 = 1, nr2 - DO ir3 = 1, nr3 - ir = compindex( ir1, ir2, ir3, nr1, nr2, nr3 ) - total = total + fdist( ir ) - num = num + 1 - END DO - END DO - total = total / DBLE( num ) - WRITE( 300, '(2E30.10)' ) DBLE( ir1 - 1 ) & - * delta1m, total - END DO - ! - CASE( 'ay' ) - ! - DO ir2 = 1, nr2 - total = 0.D0 - num = 0 - DO ir1 = 1, nr1 - DO ir3 = 1, nr3 - ir = compindex( ir1, ir2, ir3, nr1, nr2, nr3 ) - total = total + fdist( ir ) - num = num + 1 - END DO - END DO - total = total / DBLE( num ) - WRITE( 300, '(2E30.10)' ) DBLE( ir2 - 1 ) & - * delta2m, total - END DO - ! - CASE( 'az' ) - ! - DO ir3 = 1, nr3 - total = 0.D0 - num = 0 - DO ir2 = 1, nr2 - DO ir1 = 1, nr1 - ir = compindex( ir1, ir2, ir3, nr1, nr2, nr3 ) - total = total + fdist( ir ) - num = num + 1 - END DO - END DO - total = total / DBLE( num ) - WRITE( 300, '(2E30.10)' ) DBLE( ir3 - 1 ) & - * delta3m, total - END DO - ! - END SELECT - ! - CLOSE( 300 ) - ! - ENDIF - - ! - ! cleanup local memory - ! - DEALLOCATE( displs, recvcount ) - ! - DEALLOCATE( fdist, STAT=ierr ) - IF ( ierr/=0 ) CALL errore('writetofile','deallocating fdist', ABS(ierr)) - ! - RETURN - ! -!-------------------------------------------------------------------- - END SUBROUTINE writetofile -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - FUNCTION compindex( ir1, ir2, ir3, nr1, nr2, nr3 ) -!-------------------------------------------------------------------- - ! ... Calculates the composite grid index corresponding - ! ... to ir1, ir2, ir3 - ! - IMPLICIT NONE - ! - INTEGER :: compindex - INTEGER, INTENT(IN) :: ir1, ir2, ir3 - INTEGER, INTENT(IN) :: nr1, nr2, nr3 - INTEGER :: jr1, jr2, jr3 - ! - jr1 = MODULO( ir1 - 1 , nr1 ) + 1 - jr2 = MODULO( ir2 - 1 , nr2 ) + 1 - jr3 = MODULO( ir3 - 1 , nr3 ) + 1 - ! - compindex = jr1 + ( jr2 -1 ) * nr1 + ( jr3 - 1 ) * nr1 * nr2 - ! - RETURN - ! -!-------------------------------------------------------------------- - END FUNCTION compindex -!-------------------------------------------------------------------- diff --git a/quantum_espresso/kcp/License b/quantum_espresso/kcp/License deleted file mode 100644 index 5b6e7c66c..000000000 --- a/quantum_espresso/kcp/License +++ /dev/null @@ -1,340 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1989, 1991 Free Software Foundation, Inc. - 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - - The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - - 2. You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - - 5. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 7. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 8. If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 9. The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) year name of author - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, the commands you use may -be called something other than `show w' and `show c'; they could even be -mouse-clicks or menu items--whatever suits your program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. - - , 1 April 1989 - Ty Coon, President of Vice - -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Library General -Public License instead of this License. diff --git a/quantum_espresso/kcp/Makefile b/quantum_espresso/kcp/Makefile deleted file mode 100644 index 2e5516d35..000000000 --- a/quantum_espresso/kcp/Makefile +++ /dev/null @@ -1,83 +0,0 @@ -default : - @echo 'to install, type at the shell prompt:' - @echo ' ./configure' - @echo ' make kcp' - -kcp : bindir mods libs libiotk afclib - if test -d CPV ; then \ - ( cd CPV ; if test "$(MAKE)" = "" ; then make $(MFLAGS) TLDEPS= kcp ; \ - else $(MAKE) $(MFLAGS) TLDEPS= kcp ; fi ) ; fi - -libiotk : - if test -d iotk ; then \ - ( cd iotk ; if test "$(MAKE)" = "" ; then make $(MFLAGS) TLDEPS= lib+util ; \ - else $(MAKE) $(MFLAGS) TLDEPS= lib+util ; fi ) ; fi - -mods : libiotk - ( cd Modules ; if test "$(MAKE)" = "" ; then make $(MFLAGS) TLDEPS= all ; \ - else $(MAKE) $(MFLAGS) TLDEPS= all ; fi ) - -afclib: - ( if test -d AFC90/src; then cd AFC90/src ; \ - if test "$(MAKE)" = "" ; then make $(MFLAGS) TLDEPS= libafc90.a ;\ - else $(MAKE) $(MFLAGS) TLDEPS= libafc90.a ; fi; fi ) - -libs : mods - ( cd clib ; if test "$(MAKE)" = "" ; then make $(MFLAGS) TLDEPS= all ; \ - else $(MAKE) $(MFLAGS) TLDEPS= all ; fi ) - ( cd flib ; if test "$(MAKE)" = "" ; then make $(MFLAGS) TLDEPS= all ; \ - else $(MAKE) $(MFLAGS) TLDEPS= all ; fi ) - -bindir : - test -d bin || mkdir bin - -# remove object files and executables -clean : - touch make.sys - for dir in \ - CPV Modules clib flib iotk AFC90 \ - ; do \ - if test -d $$dir ; then \ - ( cd $$dir ; \ - if test "$(MAKE)" = "" ; then make $(MFLAGS) TLDEPS= clean ; \ - else $(MAKE) $(MFLAGS) TLDEPS= clean ; fi ) \ - fi \ - done - - /bin/rm -rf bin/*.x tmp - #- cd tests; /bin/rm -rf CRASH *.out *.out2 - -# remove configuration files too -distclean veryclean : clean - - /bin/rm -rf make.sys \ - config.log configure.msg config.status autom4te.cache \ - espresso.tar.gz CPV/version.h ChangeLog* \ - intel.pcl */intel.pcl - - cd examples ; ./make_clean - - cd atomic_doc ; ./make_clean - - if test -d GUI ; then \ - ( cd GUI ; if test "$(MAKE)" = "" ; then make $(MFLAGS) TLDEPS= veryclean ; \ - else $(MAKE) $(MFLAGS) TLDEPS= veryclean ; fi ) \ - fi - -tar : - @if test -f espresso.tar.gz ; then /bin/rm espresso.tar.gz ; fi - # do not include unneeded stuff - find ./ -type f | grep -v -e /CVS/ -e /results/ -e'/\.' -e'\.o$$' \ - -e'\.mod$$' -e'\.a$$' -e'\.d$$' -e'\.i$$' -e'\.F90$$' -e'\.x$$' \ - -e'~$$' -e'\./GUI' | xargs tar rvf espresso.tar - gzip espresso.tar - -links : bindir - ( cd bin/ ; \ - for exe in \ - ../CPV/kcp.x \ - ../CPV/cppp.x \ - ; do \ - if test -f $$exe ; then ln -fs $$exe . ; fi \ - done \ - ) - -depend: - @echo 'Checking dependencies...' - - ( if test -x ./makedeps.sh ; then ./makedeps.sh ; fi) -# DO NOT DELETE diff --git a/quantum_espresso/kcp/Modules/Makefile b/quantum_espresso/kcp/Modules/Makefile deleted file mode 100644 index 75063ef45..000000000 --- a/quantum_espresso/kcp/Modules/Makefile +++ /dev/null @@ -1,98 +0,0 @@ -# Makefile for Modules - -include ../make.sys - -MODULES = \ -atom.o \ -autopilot.o \ -berry_phase.o \ -bfgs_module.o \ -cell_base.o \ -check_stop.o \ -clocks.o \ -constants.o \ -constraints_module.o \ -control_flags.o \ -descriptors.o \ -dspev_drv.o \ -electrons_base.o \ -energies.o \ -error_handler.o \ -exc_t.o \ -fft_base.o \ -fft_parallel.o \ -fft_scalar.o \ -fft_types.o \ -functionals.o \ -griddim.o \ -input_parameters.o \ -io_files.o \ -io_global.o \ -ions_base.o \ -ions_nose.o \ -kind.o \ -metagga.o \ -metadyn_base.o \ -metadyn_io.o \ -metadyn_vars.o \ -mm_dispersion.o \ -mp.o \ -mp_base.o \ -mp_global.o \ -mp_wave.o \ -path_base.o \ -path_formats.o \ -path_io_routines.o \ -path_opt_routines.o \ -path_reparametrisation.o \ -path_variables.o \ -parallel_include.o \ -parallel_types.o \ -parameters.o \ -parser.o \ -paw_variables.o \ -pseudo_types.o \ -printout_base.o \ -ptoolkit.o \ -radial_grids.o \ -random_numbers.o \ -read_namelists.o \ -read_ncpp.o \ -read_upf_v1.o \ -read_upf_v2.o \ -read_uspp.o \ -recvec.o \ -shmem_include.o \ -sic.o \ -smallbox.o \ -splinelib.o \ -stick_base.o \ -task_groups.o \ -timestep.o \ -twin_types.o \ -version.o \ -upf.o \ -upf_to_internal.o \ -uspp.o \ -vxc_t.o \ -vxcgc.o \ -wave_base.o \ -wavefunctions.o \ -wannier.o \ -write_upf_v2.o \ -xml_input.o \ -xml_io_base.o \ -zhpev_drv.o \ -wannier_new.o \ -wrappers.o\ -read_cards.o \ -read_oddalpha_file.o \ -compute_dipole.o #added by giovanni, from trunk version July 2012 - -all : $(MODULES) - - -clean : - - /bin/rm -f *.o *.d *.i *~ *.F90 *.mod *.L - -include make.depend diff --git a/quantum_espresso/kcp/Modules/atom.f90 b/quantum_espresso/kcp/Modules/atom.f90 deleted file mode 100644 index aa704030b..000000000 --- a/quantum_espresso/kcp/Modules/atom.f90 +++ /dev/null @@ -1,25 +0,0 @@ -! -! Copyright (C) 2004-2007 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!-------------------------------------------------------------------------- -! -MODULE atom - ! - ! ... The variables needed to describe the atoms and related quantities - ! - USE radial_grids, ONLY : radial_grid_type - ! - SAVE - ! - type(radial_grid_type), allocatable, target :: & - rgrid(:) ! the information on atomic radial grids. - ! NB: some of the subsequent data are therefore redundant - ! and will be eliminated in due course asap - INTEGER, ALLOCATABLE :: & - msh(:) ! the point at rcut - ! -END MODULE atom diff --git a/quantum_espresso/kcp/Modules/autopilot.f90 b/quantum_espresso/kcp/Modules/autopilot.f90 deleted file mode 100644 index ed123851f..000000000 --- a/quantum_espresso/kcp/Modules/autopilot.f90 +++ /dev/null @@ -1,859 +0,0 @@ -! autopilot.f90 -!******************************************************************************** -! autopilot.f90 Copyright (c) 2005 Targacept, Inc. -!******************************************************************************** -! The Autopilot Feature suite is a user level enhancement that enables the -! following features: -! automatic restart of a job; -! preconfiguration of job parameters; -! on-the-fly changes to job parameters; -! and pausing of a running job. -! -! For more information, see README.AUTOPILOT in document directory. -! -! This program is free software; you can redistribute it and/or modify it under -! the terms of the GNU General Public License as published by the Free Software -! Foundation; either version 2 of the License, or (at your option) any later version. -! This program is distributed in the hope that it will be useful, but WITHOUT ANY -! WARRANTY; without even the implied warranty of MERCHANTABILITY FOR A PARTICULAR -! PURPOSE. See the GNU General Public License at www.gnu.or/copyleft/gpl.txt for -! more details. -! -! THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. -! EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -! PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND THE -! PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, -! YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. -! -! IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING, -! WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE -! THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY -! GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR -! INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA -! BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A -! FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER -! OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. -! -! You should have received a copy of the GNU General Public License along with -! this program; if not, write to the -! Free Software Foundation, Inc., -! 51 Franklin Street, -! Fifth Floor, -! Boston, MA 02110-1301, USA. -! -! Targacept's address is -! 200 East First Street, Suite 300 -! Winston-Salem, North Carolina USA 27101-4165 -! Attn: Molecular Design. -! Email: atp@targacept.com -! -! This work was supported by the Advanced Technology Program of the -! National Institute of Standards and Technology (NIST), Award No. 70NANB3H3065 -! -!******************************************************************************** - - -MODULE autopilot - !--------------------------------------------------------------------------- - ! - ! This module handles the Autopilot Feature Suite - ! Written by Lee Atkinson, with help from the ATP team at Targacept, Inc - ! Created June 2005 - ! Modified by Yonas Abraham, Sept 2006 - ! - ! The address for Targacept, Inc. is: - ! 200 East First Street, Suite - ! 300, Winston-Salem, North Carolina 27101; - ! Attn: Molecular Design. - ! - ! See README.AUTOPILOT in the Doc directory for more information. - !--------------------------------------------------------------------------- - - USE kinds - USE parser, ONLY : read_line - - IMPLICIT NONE - SAVE - - INTEGER, parameter :: MAX_INT = huge(1) - INTEGER, parameter :: max_event_step = 32 !right now there can be upto 32 Autopilot Events - INTEGER, parameter :: n_auto_vars = 10 !right now there are only 10 Autopilot Variables - - INTEGER :: n_events - INTEGER :: event_index = 0 - INTEGER :: max_rules = 320 !(max_event_step * n_auto_vars) - INTEGER :: n_rules - INTEGER :: event_step(max_event_step) - INTEGER :: current_nfi - LOGICAL :: pilot_p = .FALSE. ! pilot property - LOGICAL :: restart_p = .FALSE. ! restart property - LOGICAL :: pause_p = .FALSE. ! pause property - INTEGER :: pilot_unit = 42 ! perhaps move this to io_files - CHARACTER(LEN=256) :: pilot_type - - ! AUTOPILOT VARIABLES - ! These are the variable tables which change the actual variable - ! dynamically during the course of a simulation. There are many - ! parameters which govern a simulation, yet only these are allowed - ! to be changed using the event rule mechanism. - ! Each of these tables are ytped according to their variable - ! and begin with event_ - - ! &CONTROL - INTEGER :: rule_isave(max_event_step) - INTEGER :: rule_iprint(max_event_step) - REAL(DP) :: rule_dt(max_event_step) - ! &SYSTEM - - ! &ELECTRONS - REAL(DP) :: rule_emass(max_event_step) - CHARACTER(LEN=80) :: rule_electron_dynamics(max_event_step) - REAL(DP) :: rule_electron_damping(max_event_step) - - - ! &IONS - CHARACTER(LEN=80) :: rule_ion_dynamics(max_event_step) - REAL(DP) :: rule_ion_damping(max_event_step) - CHARACTER(LEN=80) :: rule_ion_temperature(max_event_step) - - REAL(DP) :: rule_tempw(max_event_step) - ! &CELL - - ! &PHONON - - - ! Each rule also needs to be correlated (flagged) against the event time table - ! This is used to flag the a given variable is to be changed on an - ! event. Initially all set to false, a rule against an event makes it true - ! Each of these flags are LOGICALs and begin with event_ - ! &CONTROL - LOGICAL :: event_isave(max_event_step) - LOGICAL :: event_iprint(max_event_step) - LOGICAL :: event_dt(max_event_step) - ! &SYSTEM - - ! &ELECTRONS - LOGICAL :: event_emass(max_event_step) - LOGICAL :: event_electron_dynamics(max_event_step) - LOGICAL :: event_electron_damping(max_event_step) - - ! &IONS - LOGICAL :: event_ion_dynamics(max_event_step) - LOGICAL :: event_ion_damping(max_event_step) - LOGICAL :: event_ion_temperature(max_event_step) - - LOGICAL :: event_tempw(max_event_step) - ! &CELL - - ! &PHONON - - - PRIVATE - PUBLIC :: auto_check, init_autopilot, card_autopilot, add_rule, & - & assign_rule, restart_p, max_event_step, event_index, event_step, rule_isave, & - & rule_iprint, rule_dt, rule_emass, rule_electron_dynamics, rule_electron_damping, & - & rule_ion_dynamics, rule_ion_damping, rule_ion_temperature, rule_tempw, & - & event_isave, event_iprint, event_dt, event_emass, & - & event_electron_dynamics, event_electron_damping, event_ion_dynamics, & - & current_nfi, pilot_p, pilot_unit, pause_p,auto_error, parse_mailbox, & - & event_ion_damping, event_ion_temperature, event_tempw - -CONTAINS - - !---------------------------------------------------------------------------- - SUBROUTINE auto_error( calling_routine, message) - !---------------------------------------------------------------------------- - ! This routine calls errore based upon the pilot property flag. - ! If the flag is TRUE, the simulation will not stop, - ! but the pause property flag is set to TRUE, - ! causing pilot to force a state of sleep, - ! until the user can mail proper commands. - ! Otherwise, its assumed that dynamics have not started - ! and this call is an indirect result of read_cards. - ! Thus the simulation will stop. - ! Either way errore will always issues a warning message. - - USE io_global, ONLY : ionode_id - USE mp, ONLY : mp_bcast - - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(IN) :: calling_routine, message - ! the name of the calling calling_routinee - ! the output message - INTEGER :: ierr - ! the error flag - - IF (pilot_p) THEN - ! if ierr < 0 errore writes the message but does not stop - ierr = -1 - pause_p = .TRUE. - !call mp_bcast(pause_p, ionode_id) - ELSE - ! if ierr > 0 it stops - ierr = 1 - ENDIF - - CALL errore( calling_routine, message, ierr ) - - END SUBROUTINE auto_error - - - !----------------------------------------------------------------------- - ! AUTO (restart) MODE - ! - ! Checks if restart files are present, just like what readfile_cp does, - ! which calls cp_readfile which create a path to restart.xml. - ! This could be checked with inquire, as in check_restartfile. - ! If restart_mode=auto, and restart.xml is present, - ! then restart_mode="restart", else its "from_scratch". - ! Set other associated vars, appropriately. - ! - ! Put this in setcontrol_flags on the select statement - !----------------------------------------------------------------------- - LOGICAL FUNCTION auto_check (ndr, outdir) - USE io_global, ONLY: ionode, ionode_id - USE mp, ONLY : mp_bcast - IMPLICIT NONE - INTEGER, INTENT(IN) :: ndr ! I/O unit number - CHARACTER(LEN=*), INTENT(IN) :: outdir - CHARACTER(LEN=256) :: dirname, filename - CHARACTER (LEN=6), EXTERNAL :: int_to_char - LOGICAL :: restart_p = .FALSE. - INTEGER :: strlen - ! right now cp_readfile is called with outdir = ' ' - ! so, in keeping with the current design, - ! the responsibility of setting - ! ndr and outdir is the calling program - - - IF (ionode) THEN - dirname = 'RESTART' // int_to_char( ndr ) - IF ( LEN( outdir ) > 1 ) THEN - strlen = index(outdir,' ') - 1 - dirname = outdir(1:strlen) // '/' // dirname - END IF - - filename = TRIM( dirname ) // '/' // 'restart.xml' - INQUIRE( FILE = TRIM( filename ), EXIST = restart_p ) - - auto_check = restart_p - END IF - CALL mp_bcast(auto_check, ionode_id) - - return - - END FUNCTION auto_check - - - !----------------------------------------------------------------------- - ! INITIALIZE AUTOPILOT - ! - ! Must be done, even if not in use. - ! Add this as a call in read_cards.f90 sub: card_default_values - !----------------------------------------------------------------------- - SUBROUTINE init_autopilot - IMPLICIT NONE - integer :: event - - pause_p = .FALSE. - - ! Initialize all events to an iteration that should never occur - DO event=1,max_event_step - event_step(event) = MAX_INT - ENDDO - - n_events = 0 - n_rules = 0 - event_index = 1 - - ! Initialize here - ! &CONTROL - event_isave(:) = .false. - event_iprint(:) = .false. - event_dt(:) = .false. - ! &SYSTEM - ! &ELECTRONS - event_emass(:) = .false. - event_electron_dynamics(:) = .false. - event_electron_damping(:) = .false. - - ! &IONS - event_ion_dynamics(:) = .false. - event_ion_damping(:) = .false. - event_ion_temperature(:) = .false. - event_tempw(:) = .false. - ! &CELL - ! &PHONON - - rule_isave(:) = 0 - rule_iprint(:) = 0 - rule_dt(:) = 0.0_DP - rule_emass(:) = 0.0_DP - rule_electron_dynamics(:) = 'NONE' - rule_electron_damping(:) = 0.0_DP - rule_ion_dynamics(:) = 'NONE' - rule_ion_damping(:) = 0.0_DP - rule_ion_temperature(:) = 'NOT_CONTROLLED' - rule_tempw(:) = 0.01_DP - - END SUBROUTINE init_autopilot - - - - !----------------------------------------------------------------------- - ! subroutine CARD_AUTOPILOT - ! - ! called in READ_CARDS and in PARSE_MAILBOX - !----------------------------------------------------------------------- - SUBROUTINE card_autopilot( input_line ) - USE io_global, ONLY: ionode, ionode_id - USE mp, ONLY : mp_bcast - IMPLICIT NONE - INTEGER :: i, j, linelen - CHARACTER(LEN=256) :: input_line - LOGICAL :: process_this_line = .FALSE. - LOGICAL :: endrules = .FALSE. - LOGICAL :: tend = .FALSE. - LOGICAL, SAVE :: tread = .FALSE. - LOGICAL, EXTERNAL :: matches - CHARACTER(LEN=1), EXTERNAL :: capital - - ! This is so we do not read a autopilot card twice from the input file - IF (( .NOT. pilot_p ) .and. tread ) THEN - CALL errore( ' card_autopilot ', ' two occurrences ', 2 ) - END IF - - ! If this routined has been called from parse_mailbox - ! the pilot_type should be set - IF ( pilot_p ) THEN - ! IF its MANUAL then process this line first! - ! other skip this line and get the next - IF (TRIM(pilot_type) .eq. 'MANUAL') THEN - process_this_line = .TRUE. - ELSE IF (TRIM(pilot_type) .eq. 'PILOT') THEN - process_this_line = .FALSE. - ELSE IF (TRIM(pilot_type) .eq. 'AUTO') THEN - process_this_line = .FALSE. - ELSE - IF( ionode ) WRITE(*,*) 'AUTOPILOT: UNRECOGNIZED PILOT TYPE!', TRIM(pilot_type), '====' - GO TO 10 - END IF - ELSE - ! this routine is called from read_cards - pilot_type = 'AUTO' - process_this_line = .FALSE. - END IF - - j=0 - ! must use a local (j) since n_rules may not get updated correctly - DO WHILE ((.NOT. endrules) .and. j<=max_rules) - j=j+1 - - IF (j > max_rules) THEN - CALL auto_error( ' AutoPilot ','Maximum Number of Dynamic Rules May Have Been Execced!') - go to 10 - END IF - - - IF( ionode ) WRITE(*,*) 'card_autopilot 1: input_line ', input_line - - ! Assume that pilot_p is an indicator and that - ! this call to card_autopilot is from parse_mailbox - ! and not from read_cards - IF(pilot_p) THEN - IF ( .NOT. process_this_line ) THEN - ! get the next one - CALL read_line( input_line, end_of_file = tend) - END IF - ELSE - ! from read_cards - CALL read_line( input_line, end_of_file = tend) - END IF - - linelen = LEN_TRIM( input_line ) - - DO i = 1, linelen - input_line( i : i ) = capital( input_line( i : i ) ) - END DO - - IF( ionode ) WRITE(*,*) 'card_autopilot 2: input_line ', input_line - - ! If ENDRULES isnt found, add_rule will fail - ! and we run out of line anyway - IF ( tend .or. matches( 'ENDRULES', input_line ) ) GO TO 10 - - ! Assume this is a rule - IF( ionode ) write(*,*) 'about to add_rule: input_line ', input_line - CALL ADD_RULE(input_line) - ! now, do not process this line anymore - ! make sure we get the next one - process_this_line = .FALSE. - - END DO - - IF( ionode ) WRITE(*,*) 'AUTOPILOT SET' - -10 CONTINUE - - END SUBROUTINE card_autopilot - - - - - - !----------------------------------------------------------------------- - ! ADD RULE - !----------------------------------------------------------------------- - SUBROUTINE add_rule( input_line ) - USE io_global, ONLY: ionode, ionode_id - !USE mp, ONLY : mp_bcast - IMPLICIT NONE - integer :: i, j, linelen - integer :: eq1_pos, eq2_pos, plus_pos, colon_pos - CHARACTER(LEN=256) :: input_line - CHARACTER(LEN=32) :: var_label - CHARACTER(LEN=32) :: value_str - INTEGER :: on_step, now_step, plus_step - integer :: ios - integer :: event - - LOGICAL, EXTERNAL :: matches - CHARACTER(LEN=1), EXTERNAL :: capital - - - ! this is a temporary local variable - event = n_events - - ! important for parsing - i=0 - j=0 - eq1_pos = 0 - eq2_pos = 0 - plus_pos = 0 - colon_pos = 0 - - linelen=LEN_TRIM( input_line ) - - IF( ionode ) write(*,*) 'ADD_RULE: pilot_type', pilot_type - - - ! Attempt to get PLUS SYMBOL - i = 1 - do while( (plus_pos .eq. 0) .and. (i <= linelen) ) - i = i + 1 - if(input_line( i : i ) .eq. '+') then - plus_pos = i - endif - end do - - ! Attempt to get a colon - i = 1 - do while( (colon_pos .eq. 0) .and. (i <= linelen) ) - i = i + 1 - if(input_line( i : i ) .eq. ':') then - colon_pos = i - endif - end do - - ! Attempt to get first equals - i = 1 - do while( (eq1_pos .eq. 0) .and. (i <= linelen) ) - i = i + 1 - if(input_line( i : i ) .eq. '=') then - eq1_pos = i - endif - end do - - - ! Attempt to get second equals - if ((eq1_pos .ne. 0) .and. (eq1_pos < colon_pos)) then - i = colon_pos + 1 - do while( (eq2_pos .eq. 0) .and. (i <= linelen) ) - i = i + 1 - if(input_line( i : i ) .eq. '=') then - eq2_pos = i - endif - end do - endif - - ! Complain if there is a bad parse - if (colon_pos .eq. 0) then - call auto_error( ' AutoPilot ','Missing colon separator') - go to 20 - endif - - if (eq1_pos .eq. 0) then - call auto_error( ' AutoPilot ','Missing equals sign') - go to 20 - endif - - if ((plus_pos > 0) .and. (eq1_pos < colon_pos)) then - call auto_error( ' AutoPilot ','equals and plus found prior to colon') - go to 20 - endif - - - !================================================================================ - ! Detect events - IF ( (pilot_type .eq. 'MANUAL') .or. (pilot_type .eq. 'PILOT') ) THEN - !------------------------------------------- - !Do the equivalent of the following: - !READ(input_line, *) now_label, plus_label1, plus_step, colon_label, var_label, eq_label2, value_str - !Format: - ! [NOW [+ plus_step] :] var_label = value_str - !------------------------------------------- - - IF( ionode ) write(*,*) 'ADD_RULE: MANUAL STEERING' - - ! if there is a NOW, get it and try to get plus and plus_step - - IF ( matches( 'NOW', input_line ) ) THEN - ! Attempt to get PLUS_STEP - plus_step = 0 - ! if all is non-trivial, read a PLUS_STEP - if ((plus_pos > 0) .and. (colon_pos > plus_pos)) then - ! assume a number lies between - read(input_line(plus_pos+1:colon_pos-1),*,iostat=ios) plus_step - if(ios .ne. 0) then - CALL auto_error( ' AutoPilot ','Value Type Mismatch on NOW line!') - go to 20 - end if - end if - ! set NOW event - now_step = current_nfi + plus_step - ELSE - ! set NOW event - now_step = current_nfi - END IF - - - !================================================================================ - ! set event - ! - ! Heres where it get interesting - ! We may have a new event , or not! :) - - IF ( ((event-1) .gt. 0) .and. ( now_step .lt. event_step(event-1)) ) THEN - IF( ionode ) write(*,*) ' AutoPilot: current input_line', input_line - CALL auto_error( ' AutoPilot ','Dynamic Rule Event Out of Order!') - go to 20 - ENDIF - - IF ( (event .eq. 0) .or. ( now_step .gt. event_step(event)) ) THEN - ! new event - event = event + 1 - - IF (event > max_event_step) THEN - IF( ionode ) write(*,*) ' AutoPilot: current input_line', input_line - CALL auto_error( ' AutoPilot ','Maximum Number of Dynamic Rule Event Exceeded!') - go to 20 - ENDIF - - event_step(event) = now_step - n_events = event - ENDIF - - - ELSE IF ( matches( 'ON_STEP', input_line ) ) THEN - ! Assuming pilot_type is AUTO - ! if it isnt and ON_STEP these rules wont take anyway - - !------------------------------------------- - !Do the equivalent of the following: - !READ(input_line, *) on_step_label, eq_label1, on_step, colon_label, var_label, eq_label2, value_str - !Format: - ! ON_STEP = on_step : var_label = value_str - !------------------------------------------- - - IF( ionode ) write(*,*) 'ADD_RULE: POWER STEERING' - - ! Attempt to get ON_STEP - on_step = MAX_INT - ! if all is non-trivial, read a PLUS_STEP - if ((eq1_pos > 0) .and. (colon_pos > eq1_pos)) then - ! assume a number lies between - read(input_line(eq1_pos+1:colon_pos-1),*,iostat=ios) on_step - if(ios .ne. 0) then - CALL auto_error( ' AutoPilot ','Value Type Mismatch on ON_STEP line!') - go to 20 - end if - end if - - - - !================================================================================ - ! set event - ! - ! Heres where it get interesting - ! We may have a new event , or not! :) - - - IF ( ((event-1) .gt. 0) .and. ( on_step .lt. event_step(event-1)) ) THEN - IF( ionode ) write(*,*) ' AutoPilot: current input_line', input_line - CALL auto_error( ' AutoPilot ','Dynamic Rule Event Out of Order!') - go to 20 - ENDIF - - - IF ( (event .eq. 0) .or. (on_step .gt. event_step(event)) ) THEN - ! new event - event = event + 1 - IF (event > max_event_step) THEN - IF( ionode ) write(*,*) ' AutoPilot: current input_line', input_line - CALL auto_error( ' AutoPilot ','Maximum Number of Dynamic Rule Event Exceeded!') - go to 20 - ENDIF - event_step(event) = on_step - n_events = event - ENDIF - - END IF ! Event Detection Complete - - - !------------------------------------- - ! Now look for a label and a value - !------------------------------------- - - if (eq2_pos .eq. 0) then - var_label = input_line(colon_pos+1: eq1_pos-1) - read( input_line(eq1_pos+1:linelen), *, iostat=ios) value_str - if(ios .ne. 0) then - CALL auto_error( ' AutoPilot ','Value Type Mismatch on NOW_STEP line!') - go to 20 - end if - else - var_label = input_line(colon_pos+1: eq2_pos-1) - read( input_line(eq2_pos+1:linelen), *, iostat=ios) value_str - if(ios .ne. 0) then - CALL auto_error( ' AutoPilot ','Value Type Mismatch on ON_STEP line!') - go to 20 - end if - endif - - ! The Assignment must lie outside the new event scope since - ! there can exists more than one rule per event - - IF ( (n_rules+1) .gt. max_rules) THEN - IF( ionode ) write(*,*) ' AutoPilot: current n_rules', n_rules - CALL auto_error( ' AutoPilot ', ' invalid number of rules ') - go to 20 - END IF - - call assign_rule(event, var_label, value_str) - - IF( ionode ) write(*,*) 'n_rules=', n_rules - - CALL flush_unit(6) - -20 CONTINUE - - END SUBROUTINE add_rule - - - !----------------------------------------------------------------------- - ! ASSIGN_RULE - !----------------------------------------------------------------------- - SUBROUTINE assign_rule(event, var, value) - USE input_parameters, ONLY : isave, iprint, dt, tempw - USE io_global, ONLY: ionode, ionode_id - IMPLICIT NONE - INTEGER :: i, event, varlen - CHARACTER(LEN=32) :: var - CHARACTER(LEN=32) :: value - INTEGER :: int_value - REAL :: real_value - REAL(DP) :: realDP_value - LOGICAL :: assigned - LOGICAL, EXTERNAL :: matches - CHARACTER(LEN=1), EXTERNAL :: capital - - - var = TRIM(var) - varlen = LEN_TRIM(var) - - DO i = 1, varlen - var( i : i ) = capital( var( i : i ) ) - END DO - - - IF( ionode ) write(*,*) 'ASSIGNING RULE: event var value', event, var, value - assigned = .TRUE. - - IF ( matches( "ISAVE", var ) ) THEN - read(value, *) int_value - rule_isave(event) = int_value - event_isave(event) = .true. - ELSEIF ( matches( "IPRINT", var ) ) THEN - read(value, *) int_value - rule_iprint(event) = int_value - event_iprint(event) = .true. - ELSEIF ( matches( "DT", var ) ) THEN - read(value, *) real_value - rule_dt(event) = real_value - event_dt(event) = .true. - IF( ionode ) write(*,*) 'RULE_DT', rule_dt(event), 'EVENT', event - ELSEIF ( matches( "EMASS", var ) ) THEN - read(value, *) realDP_value - rule_emass(event) = realDP_value - event_emass(event) = .true. - ELSEIF ( matches( "ELECTRON_DYNAMICS", var ) ) THEN - read(value, *) value - if ((value .ne. 'SD') .and. (value .ne. 'VERLET') .and. (value .ne. 'DAMP') .and. (value .ne. 'NONE')) then - call auto_error(' autopilot ',' unknown electron_dynamics '//trim(value) ) - assigned = .FALSE. - go to 40 - endif - rule_electron_dynamics(event) = value - event_electron_dynamics(event) = .true. - ELSEIF ( matches( "ELECTRON_DAMPING", var ) ) THEN - read(value, *) realDP_value - rule_electron_damping(event) = realDP_value - event_electron_damping(event) = .true. - ELSEIF ( matches( "ION_DYNAMICS", var ) ) THEN - read(value, *) value - if ((value .ne. 'SD') .and. (value .ne. 'VERLET') .and. (value .ne. 'DAMP') .and. (value .ne. 'NONE')) then - call auto_error(' autopilot ',' unknown ion_dynamics '//trim(value) ) - assigned = .FALSE. - go to 40 - endif - rule_ion_dynamics(event) = value - event_ion_dynamics(event) = .true. - ELSEIF ( matches( "ION_DAMPING", var ) ) THEN - read(value, *) realDP_value - rule_ion_damping(event) = realDP_value - event_ion_damping(event) = .true. - ELSEIF ( matches( "ION_TEMPERATURE", var ) ) THEN - read(value, *) value - if ((value .ne. 'NOSE') .and. (value .ne. 'NOT_CONTROLLED') .and. (value .ne. 'RESCALING')) then - call auto_error(' autopilot ',' unknown ion_temperature '//trim(value) ) - assigned = .FALSE. - go to 40 - endif - rule_ion_temperature(event) = value - event_ion_temperature(event) = .true. - ELSEIF ( matches( "TEMPW", var ) ) THEN - read(value, *) realDP_value - rule_tempw(event) = realDP_value - event_tempw(event) = .true. - ELSE - CALL auto_error( 'autopilot', ' ASSIGN_RULE: FAILED '//trim(var)//' '//trim(value) ) - END IF - -40 if (assigned) then - n_rules = n_rules + 1 - IF( ionode ) write(*,*) 'Autopilot: Rule Assigned ', n_rules - else - IF( ionode ) write(*,*) 'Autopilot: Rule Assignment Failure ' - CALL auto_error( 'autopilot', ' ASSIGN_RULE: FAILED '//trim(var)//' '//trim(value) ) - endif - - END SUBROUTINE assign_rule - - - - - !----------------------------------------------------------------------- - ! PARSE_MAILBOX - ! - ! Read the mailbox with a mailbox parser - ! if it starts with ON_STEP, then apply to event table etc - ! if not the try to establish that its a variable to set right now - !----------------------------------------------------------------------- - SUBROUTINE parse_mailbox () - !use ifport, only: sleep - USE io_global, ONLY: ionode, ionode_id - USE mp, ONLY : mp_bcast, mp_barrier - IMPLICIT NONE - INTEGER :: i - CHARACTER(LEN=256) :: input_line - LOGICAL :: tend - - CHARACTER(LEN=1), EXTERNAL :: capital - LOGICAL, EXTERNAL :: matches - - - ! we can use this parser routine, since parse_unit=pilot_unit - CALL read_line( input_line, end_of_file=tend ) - IF (tend) GO TO 50 - - DO i = 1, LEN_TRIM( input_line ) - input_line( i : i ) = capital( input_line( i : i ) ) - END DO - - ! This conditional implements the PAUSE feature calling init_auto_pilot, - ! will reset this modules global PAUSE_P variable to FALSE - IF ( matches( "PAUSE", input_line ) .or. & - matches( "SLEEP", input_line ) .or. & - matches( "HOVER", input_line ) .or. & - matches( "WAIT", input_line ) .or. & - matches( "HOLD", input_line ) ) THEN - - IF( ionode ) write(*,*) 'SLEEPING' - IF( ionode ) write(*,*) 'INPUT_LINE=', input_line - pause_p = .TRUE. - ! now you can pass continue to resume - ELSE IF (matches( "CONTINUE", input_line ) .or. & - matches( "RESUME", input_line ) ) THEN - IF( ionode ) write(*,*) 'RUNNING' - IF( ionode ) write(*,*) 'INPUT_LINE=', input_line - pause_p = .FALSE. - - ! Now just quit this subroutine - ELSE - ! Also, We didnt see a PAUSE cmd! - pause_p = .FALSE. - - ! now lets detect the mode for card_autopilot - ! even though this line will be passed to it the first time - - IF ( matches( "AUTOPILOT", TRIM(input_line) ) ) THEN - IF( ionode ) WRITE(*,*) 'NEW AUTOPILOT COURSE DETECTED' - pilot_type ='AUTO' - ELSE IF (matches( "PILOT", TRIM(input_line) ) ) THEN - IF( ionode ) WRITE(*,*) 'RELATIVE PILOT COURSE CORRECTION DETECTED' - pilot_type ='PILOT' - ELSE IF (matches( "NOW", TRIM(input_line) ) ) THEN - IF( ionode ) WRITE(*,*) 'MANUAL PILOTING DETECTED' - pilot_type ='MANUAL' - ELSE - ! Well lets just pause since this guys is throwing trash - IF( ionode ) WRITE(*,*) 'MAILBOX CONTENTS NOT UNDERSTOOD: pausing' - pause_p = .TRUE. - ENDIF - - END IF - - IF (pause_p) GO TO 50 - - - ! ok if one adds a rule during steering` - ! event table must be cleared (from steer point) forward - ! - ! Every nodes gets this (and the call to card_autopilot - ! which calls add_rule, which calls assign_rule, etc - ! In this way we sync the event table - ! Then we shouldn't have to sync employ_rules variable - ! changes, or their subroutine side effects (like ions_nose_init) - - CALL init_autopilot() - - - IF( ionode ) WRITE(*,*) 'parse_mailbox: about to call card_autopilot: pilot_type', pilot_type - IF( ionode ) write(*,*) 'input_line=', input_line - CALL card_autopilot( input_line ) - - - ! this is needed just befor we end this subroutine -50 CONTINUE - !call mp_barrier() - - IF( ionode ) WRITE(*,*) 'end of parse' - - end subroutine parse_mailbox - - -END MODULE autopilot - diff --git a/quantum_espresso/kcp/Modules/basic_algebra_routines.f90 b/quantum_espresso/kcp/Modules/basic_algebra_routines.f90 deleted file mode 100644 index c66dc8913..000000000 --- a/quantum_espresso/kcp/Modules/basic_algebra_routines.f90 +++ /dev/null @@ -1,199 +0,0 @@ -! -! Copyright (C) 2003-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!---------------------------------------------------------------------------- -MODULE basic_algebra_routines - !---------------------------------------------------------------------------- - ! - ! ... Written by Carlo Sbraccia ( 16/12/2003 ) - ! - ! ... This module contains a limited number of functions and operators - ! ... for vectorial algebra. Wherever possible the appropriate BLAS routine - ! ... ( always the double precision version ) is used. - ! - ! ... List of public methods : - ! - ! x .dot. y dot product between vectors ( ) - ! x .ext. y external (vector) product between vectors ( ) - ! norm( x ) norm of a vector ( SQRT() ) - ! A .times. x matrix-vector multiplication ( A|x> ) - ! x .times. A vector-matrix multiplication ( 0 ) then - - ! find out local index in_l corresponding to the global index in(i) - - in_l = ig_local( in(i), ig_l2g, sortedig_l2g, SIZE( ig_l2g ) ) - - if( in_l > 0 ) then - - n_indi_snd(i) = n_indi_snd(i) + 1 - - ! find out the processor that own the G vector in(i) - ! and fill in the array of destination procs - - dest_indi( n_indi_snd(i), i ) = sticks_owner( mill(1,ig), mill(2,ig) ) - - ! array of index to of G-vecs to be sent to the processor - ! whose index is stored in dest_indi - - indi_l( n_indi_snd(i), i ) = in_l - - end if - - end if - if( sticks_owner( mill(1,ig), mill(2,ig) ) == ( me_image+1 ) ) then - n_indi_rcv(i) = n_indi_rcv(i) + 1 - if( in(i) > 0 ) then - sour_indi( n_indi_rcv(i), i ) = sticks_owner( mill( 1 , in(i) ), mill( 2 , in(i) ) ) - else - sour_indi( n_indi_rcv(i), i ) = -1 - end if - end if - - end do - - end do -! calculate dimension for the variable to be allocated - icnt_snd = 0 - do i = 1,8 - do ig = 1,n_indi_snd(i) - itmp = dest_indi(ig,i) - if(itmp.ne.(me_image+1)) then - icnt_snd(itmp,i) = icnt_snd(itmp,i) + 1 - end if - end do - end do - do i = 1,8 - icntix(i) = 0 - do j=1,nproc_image - if(icnt_snd(j,i).gt.icntix(i)) then - icntix(i) = icnt_snd(j,i) - end if - end do - end do - - - call mp_max( icntix(1:8), intra_image_comm ) - WRITE( stdout, fmt="(3X,'Dipole init ')" ) - DO i = 1, 8 - WRITE( stdout, fmt="(3X,'icntix ',I3,' = ',I5)" ) i, icntix(i) - END DO - - CALL ln_closeup( ) - - DEALLOCATE(icnt_snd) - DEALLOCATE(icnt_rcv) - - RETURN - END SUBROUTINE berry_setup - - - SUBROUTINE berry_closeup( ) - IF( allocated( indi_l ) ) deallocate(INDI_L ) - IF( allocated( sour_indi ) ) deallocate(SOUR_INDI) - IF( allocated( dest_indi ) ) deallocate(DEST_INDI) - RETURN - END SUBROUTINE berry_closeup - - - SUBROUTINE indi_of_ig( mill, indi ) - -! compute the array "indi" containing the position of -! translated G vectors, given the array of miller ( mill ) indexes of the -! G vectors. -! mill( 1 : 3 ) miller index of a G vectors -! indi( 1 ) = index of G whose miller index are: mill(1) + 1, mill(2), mill(3) - - IMPLICIT NONE - INTEGER :: LN_IND - EXTERNAL LN_IND -! - INTEGER, INTENT(IN) :: mill(:) - INTEGER, INTENT(OUT) :: indi(:) -! - INTEGER :: iri1, iri2, iri3, iricheck -! - iri1 = mill(1) - iri2 = mill(2) - iri3 = mill(3) - iricheck = iri1**2 + iri2**2 + iri3**2 - - if( iricheck == 0 ) then - - ! only positive directions for Gamma point when Gamma symmetry is used - - INDI(1) = LN_IND(1,0,0) - INDI(2) = 0 - INDI(3) = 0 - INDI(4) = LN_IND(0,1,0) - INDI(5) = 0 - INDI(6) = 0 - INDI(7) = LN_IND(0,0,1) - INDI(8) = 0 - - ELSE - - ! for gamma symmetry iri1 >= 0 - - INDI(1) = LN_IND( IRI1 + 1, IRI2, IRI3 ) - - IF( IRI1 > 0 ) THEN - INDI(2) = LN_IND( IRI1 - 1, IRI2, IRI3 ) - ELSE - INDI(2) = -1 ! LN_IND( IRI1 + 1, IRI2, IRI3 ) - ENDIF - - iricheck = iri2**2 + iri3**2 - IF( ( IRI1 < 2 ) .and. ( iricheck /= 0 ) ) THEN - INDI(3) = LN_IND( 1 - IRI1, -IRI2, -IRI3 ) - ELSE - INDI(3) = -1 - ENDIF - - INDI(4) = LN_IND(IRI1,IRI2+1,IRI3) - INDI(5) = LN_IND(IRI1,IRI2-1,IRI3) - IF( ( IRI1 == 0 ) .AND. ( IRI2 < 2 ) .and. ( iri3 /= 0 ) ) THEN - INDI(6) = LN_IND( 0, 1-IRI2, -IRI3 ) - ELSE - INDI(6) = -1 - ENDIF - - INDI(7)=LN_IND(IRI1,IRI2,IRI3+1) - INDI(8)=LN_IND(IRI1,IRI2,IRI3-1) - - END IF - - RETURN - END SUBROUTINE indi_of_ig - - - - END MODULE berry_phase diff --git a/quantum_espresso/kcp/Modules/bfgs_module.f90 b/quantum_espresso/kcp/Modules/bfgs_module.f90 deleted file mode 100644 index 507f536ee..000000000 --- a/quantum_espresso/kcp/Modules/bfgs_module.f90 +++ /dev/null @@ -1,851 +0,0 @@ -! -! Copyright (C) 2003-2007 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE bfgs_module - !---------------------------------------------------------------------------- - ! - ! ... Ionic relaxation through the Newton-Raphson optimization scheme - ! ... based on the Broyden-Fletcher-Goldfarb-Shanno algorithm for the - ! ... estimate of the inverse Hessian matrix. - ! ... The ionic relaxation is performed in cartesian coordinates using - ! ... a "trust radius" line search based on Wolfe conditions. - ! - ! ... Written by Carlo Sbraccia ( 5/12/2003 ) - ! ... Maintained by Carlo Sbraccia ( 2003-2007 ) - ! ... Modified for variable-cell-shape relaxation by - ! ... Javier Antonio Montoya and Stefano de Gironcoli (Dec 2007) - ! - ! ... references : - ! - ! ... 1) Roger Fletcher, Practical Methods of Optimization, John Wiley and - ! ... Sons, Chichester, 2nd edn, 1987. - ! ... 2) Salomon R. Billeter, Alexander J. Turner, Walter Thiel, - ! ... Phys. Chem. Chem. Phys. 2, 2177 (2000). - ! ... 3) Salomon R. Billeter, Alessandro Curioni, Wanda Andreoni, - ! ... Comput. Mat. Science 27, 437, (2003). - ! ... 4) Ren Weiqing, PhD Thesis: Numerical Methods for the Study of Energy - ! ... Landscapes and Rare Events. - ! - ! - USE kinds, ONLY : DP - USE io_files, ONLY : iunbfgs, prefix - USE constants, ONLY : eps16 - ! - USE basic_algebra_routines - ! - IMPLICIT NONE - ! - PRIVATE - ! - ! ... public methods - ! - PUBLIC :: bfgs, terminate_bfgs - ! - ! ... public variables - ! - PUBLIC :: bfgs_ndim, & - trust_radius_max, & - trust_radius_min, & - trust_radius_ini, & - w_1, & - w_2 - ! - ! ... global variables - ! - SAVE - ! - CHARACTER (len=8) :: fname="energy" ! name of the function to be minimized - ! - REAL(DP), ALLOCATABLE :: & - pos(:), &! positions + cell - grad(:), &! gradients + cell_force - pos_p(:), &! positions at the previous iteration - grad_p(:), &! gradients at the previous iteration - inv_hess(:,:), &! inverse hessian matrix ( updated using BFGS formula ) - metric(:,:), & - h_block(:,:), & - hinv_block(:,:), & - step(:), &! the last bfgs step - step_old(:), &! old bfgs steps - pos_old(:,:), &! list of m old positions - grad_old(:,:), &! list of m old gradients - pos_best(:) ! best extrapolated positions - REAL(DP) :: & - trust_radius, &! displacement along the bfgs direction - trust_radius_old, &! old displacement along the bfgs direction - energy_p ! energy at the previous iteration - INTEGER :: & - scf_iter, &! number of scf iterations - bfgs_iter, &! number of bfgs iterations - gdiis_iter ! number of gdiis iterations - ! - LOGICAL :: & - tr_min_hit ! .TRUE. if the trust_radius has already been - ! set to the minimum value at the previous step - ! - LOGICAL :: & - conv_bfgs ! .TRUE. when bfgs convergence has been achieved - ! - ! ... default values for all these variables are set in - ! ... Modules/read_namelist.f90 (SUBROUTINE ions_defaults) - ! - INTEGER :: & - bfgs_ndim ! dimension of the subspace for GDIIS - ! fixed to 1 for standard BFGS algorithm - REAL(DP) :: & - trust_radius_max, &! maximum allowed displacement - trust_radius_min, &! minimum allowed displacement - trust_radius_ini ! initial displacement - REAL(DP) :: & - w_1, &! parameters for Wolfe conditions - w_2 ! parameters for Wolfe conditions - ! - ! ... Note that trust_radius_max, trust_radius_min, trust_radius_ini, - ! ... w_1, w_2, bfgs_ndim have a default value, but can also be assigned - ! ... in the input. - ! -CONTAINS - ! - !------------------------------------------------------------------------ - SUBROUTINE bfgs( pos_in, h, energy, grad_in, fcell, fixion, scratch, stdout,& - energy_thr, grad_thr, cell_thr, energy_error, grad_error, & - cell_error, istep, nstep, step_accepted, stop_bfgs, lmovecell ) - !------------------------------------------------------------------------ - ! - ! ... list of input/output arguments : - ! - ! pos : vector containing 3N coordinates of the system ( x ) - ! energy : energy of the system ( V(x) ) - ! grad : vector containing 3N components of grad( V(x) ) - ! fixion : vector used to freeze a deg. of freedom - ! scratch : scratch directory - ! stdout : unit for standard output - ! energy_thr : treshold on energy difference for BFGS convergence - ! grad_thr : treshold on grad difference for BFGS convergence - ! the largest component of grad( V(x) ) is considered - ! energy_error : energy difference | V(x_i) - V(x_i-1) | - ! grad_error : the largest component of - ! | grad(V(x_i)) - grad(V(x_i-1)) | - ! cell_error : the largest component of: omega*(stress-press*I) - ! nstep : the maximun nuber of scf-steps - ! step_accepted : .TRUE. if a new BFGS step is done - ! stop_bfgs : .TRUE. if BFGS convergence has been achieved - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(INOUT) :: pos_in(:) - REAL(DP), INTENT(OUT) :: h(3,3) - REAL(DP), INTENT(INOUT) :: energy - REAL(DP), INTENT(INOUT) :: grad_in(:) - REAL(DP), INTENT(INOUT) :: fcell(3,3) - INTEGER, INTENT(IN) :: fixion(:) - CHARACTER(LEN=*), INTENT(IN) :: scratch - INTEGER, INTENT(IN) :: stdout - REAL(DP), INTENT(IN) :: energy_thr, grad_thr, cell_thr - INTEGER, INTENT(OUT) :: istep - INTEGER, INTENT(IN) :: nstep - REAL(DP), INTENT(OUT) :: energy_error, grad_error, cell_error - LOGICAL, INTENT(OUT) :: step_accepted, stop_bfgs - LOGICAL, INTENT(IN) :: lmovecell - ! - INTEGER :: n, i, j, k, nat - LOGICAL :: lwolfe - REAL(DP) :: dE0s, den - ! ... for scaled coordinates - REAL(DP) :: hinv(3,3),g(3,3),ginv(3,3),garbage - ! - ! - n = SIZE( pos_in ) + 9 - nat = size (pos_in) / 3 - if (nat*3 /= size (pos_in)) call errore('bfgs',' strange dimension',1) - ! - ! ... work-space allocation - ! - ALLOCATE( pos( n ) ) - ALLOCATE( grad( n ) ) - ! - ALLOCATE( grad_old( n, bfgs_ndim ) ) - ALLOCATE( pos_old( n, bfgs_ndim ) ) - ! - ALLOCATE( inv_hess( n, n ) ) - ! - ALLOCATE( pos_p( n ) ) - ALLOCATE( grad_p( n ) ) - ALLOCATE( step( n ) ) - ALLOCATE( step_old( n ) ) - ALLOCATE( pos_best( n ) ) - ! ... scaled coordinates work-space - ALLOCATE( hinv_block( n-9, n-9 ) ) - ! ... cell related work-space - ALLOCATE( metric( n , n ) ) - ! - ! ... the BFGS file read (pos & grad) in scaled coordinates - ! - call invmat(3, h, hinv, garbage) - hinv_block = 0.d0 - FORALL ( k=0:nat-1, i=1:3, j=1:3 ) hinv_block(i+3*k,j+3*k) = hinv(i,j) - ! - ! ... generate metric to work with scaled ionic coordinates - g = MATMUL(TRANSPOSE(h),h) - call invmat(3,g,ginv,garbage) - metric = 0.d0 - FORALL ( k=0:nat-1, i=1:3, j=1:3 ) metric(i+3*k,j+3*k) = g(i,j) - FORALL ( k=nat:nat+2, i=1:3, j=1:3 ) metric(i+3*k,j+3*k) = 10.0* ginv(i,j) - ! - ! ... generate bfgs vectors for the degrees of freedom and their gradients - pos = 0.0 - pos(1:n-9) = pos_in - if (lmovecell) FORALL( i=1:3, j=1:3) pos( n-9 + j+3*(i-1) ) = h(i,j) - grad = 0.0 - grad(1:n-9) = grad_in - if (lmovecell) FORALL( i=1:3, j=1:3) grad( n-9 + j+3*(i-1) ) = fcell(i,j) - ! - ! if the cell moves the quantity to be minimized is the enthalpy - IF ( lmovecell ) fname="enthalpy" - ! - CALL read_bfgs_file( pos, grad, fixion, energy, scratch, n, stdout ) - ! - scf_iter = scf_iter + 1 - istep = scf_iter - ! - ! ... convergence is checked here - ! - energy_error = ABS( energy_p - energy ) - grad_error = MAXVAL( ABS( MATMUL( TRANSPOSE(hinv_block), grad(1:n-9)) ) ) - conv_bfgs = energy_error < energy_thr - conv_bfgs = conv_bfgs .AND. ( grad_error < grad_thr ) - ! - IF( lmovecell) THEN - cell_error = MAXVAL( ABS( grad(n-8:n) ) ) - conv_bfgs = conv_bfgs .AND. ( cell_error < cell_thr ) - END IF - ! - stop_bfgs = conv_bfgs .OR. ( scf_iter >= nstep ) - ! - ! ... quick return if possible - ! - IF ( stop_bfgs ) GOTO 1000 - ! - ! ... some output is written - ! - WRITE( UNIT = stdout, & - & FMT = '(/,5X,"number of scf cycles",T30,"= ",I3)' ) scf_iter - WRITE( UNIT = stdout, & - & FMT = '(5X,"number of bfgs steps",T30,"= ",I3,/)' ) bfgs_iter - IF ( scf_iter > 1 ) WRITE( UNIT = stdout, & - & FMT = '(5X,A," old",T30,"= ",F18.10," Ry")' ) fname,energy_p - WRITE( UNIT = stdout, & - & FMT = '(5X,A," new",T30,"= ",F18.10," Ry",/)' ) fname,energy - ! - ! ... the bfgs algorithm starts here - ! - IF ( ( energy > energy_p ) .AND. ( scf_iter > 1 ) ) THEN - ! - ! ... the previous step is rejected, line search goes on - ! - step_accepted = .FALSE. - ! - WRITE( UNIT = stdout, & - & FMT = '(5X,"CASE: ",A,"_new > ",A,"_old",/)' ) fname,fname - ! - ! ... the new trust radius is obtained by quadratic interpolation - ! - ! ... E(s) = a*s*s + b*s + c ( we use E(0), dE(0), E(s') ) - ! - ! ... s_min = - 0.5*( dE(0)*s'*s' ) / ( E(s') - E(0) - dE(0)*s' ) - ! - dE0s = ( grad_p(:) .dot. step_old(:) ) - ! - den = energy - energy_p - dE0s - ! - IF ( den > eps16 ) THEN - ! - trust_radius = - 0.5_DP*dE0s*trust_radius_old / den - ! - ELSE - ! - ! ... no quadratic interpolation is possible: we use bisection - ! - trust_radius = 0.5_DP*trust_radius_old - ! - END IF - ! - WRITE( UNIT = stdout, & - & FMT = '(5X,"new trust radius",T30,"= ",F18.10," bohr")' ) & - trust_radius - ! - ! ... values from the last succeseful bfgs step are restored - ! - pos(:) = pos_p(:) - energy = energy_p - grad(:) = grad_p(:) - ! - IF ( trust_radius < trust_radius_min ) THEN - ! - ! ... the history is reset ( the history can be reset at most two - ! ... consecutive times ) - ! - WRITE( UNIT = stdout, & - FMT = '(/,5X,"trust_radius < trust_radius_min")' ) - WRITE( UNIT = stdout, FMT = '(/,5X,"resetting bfgs history",/)' ) - ! - IF ( tr_min_hit ) THEN - ! - ! ... the history has already been reset at the previous step : - ! ... something is going wrong - ! - CALL errore( 'bfgs', & - 'bfgs history already reset at previous step', 1 ) - ! - END IF - ! - CALL reset_bfgs( n ) - ! - step(:) = - ( inv_hess(:,:) .times. grad(:) ) - ! - trust_radius = trust_radius_min - ! - tr_min_hit = .TRUE. - ! - ELSE - ! - ! ... old bfgs direction ( normalized ) is recovered - ! - step(:) = step_old(:) / trust_radius_old - ! - tr_min_hit = .FALSE. - ! - END IF - ! - ELSE - ! - ! ... a new bfgs step is done - ! - bfgs_iter = bfgs_iter + 1 - ! - IF ( bfgs_iter == 1 ) THEN - ! - ! ... first iteration - ! - IF ( grad_error < 0.01_DP ) & - trust_radius_ini = MIN( 0.2_DP, trust_radius_ini ) - ! - step_accepted = .FALSE. - ! - ELSE - ! - step_accepted = .TRUE. - ! - WRITE( UNIT = stdout, & - & FMT = '(5X,"CASE: ",A,"_new < ",A,"_old",/)' ) fname,fname - ! - CALL check_wolfe_conditions( lwolfe, energy, grad ) - ! - CALL update_inverse_hessian( pos, grad, n, stdout ) - ! - END IF - ! - IF ( bfgs_ndim > 1 ) THEN - ! - ! ... GDIIS extrapolation - ! - CALL gdiis_step() - ! - ELSE - ! - ! ... standard Newton-Raphson step - ! - step(:) = - ( inv_hess(:,:) .times. grad(:) ) - ! - END IF - ! - IF ( ( grad(:) .dot. step(:) ) > 0.0_DP ) THEN - ! - WRITE( UNIT = stdout, & - FMT = '(5X,"uphill step: resetting bfgs history",/)' ) - ! - CALL reset_bfgs( n ) - ! - step(:) = - ( inv_hess(:,:) .times. grad(:) ) - ! - END IF - ! - ! ... the new trust radius is computed - ! - IF ( bfgs_iter == 1 ) THEN - ! - trust_radius = trust_radius_ini - ! - tr_min_hit = .FALSE. - ! - ELSE - ! - trust_radius = trust_radius_old - ! - CALL compute_trust_radius( lwolfe, energy, grad, n, stdout ) - ! - END IF - ! - WRITE( UNIT = stdout, & - & FMT = '(5X,"new trust radius",T30,"= ",F18.10," bohr")' ) & - trust_radius - ! - END IF - ! - ! ... step along the bfgs direction - ! - IF ( scnorm( step(:) ) < eps16 ) & - CALL errore( 'bfgs', 'NR step-length unreasonably short', 1 ) - ! - step(:) = trust_radius*step(:)/scnorm( step(:) ) - ! - ! ... information required by next iteration is saved here ( this must - ! ... be done before positions are updated ) - ! - CALL write_bfgs_file( pos, energy, grad, scratch ) - ! - ! ... positions and cell are updated - ! - pos(:) = pos(:) + step(:) - ! -1000 CONTINUE - ! ... input ions+cell variables - IF ( lmovecell ) FORALL( i=1:3, j=1:3) h(i,j) = pos( n-9 + j+3*(i-1) ) - pos_in = pos(1:n-9) - ! ... update forces - grad_in = grad(1:n-9) - ! - ! ... work-space deallocation - ! - DEALLOCATE( pos ) - DEALLOCATE( grad ) - DEALLOCATE( pos_p ) - DEALLOCATE( grad_p ) - DEALLOCATE( pos_old ) - DEALLOCATE( grad_old ) - DEALLOCATE( inv_hess ) - DEALLOCATE( step ) - DEALLOCATE( step_old ) - DEALLOCATE( pos_best ) - DEALLOCATE( hinv_block ) - DEALLOCATE( metric ) - ! - RETURN - ! - CONTAINS - ! - !-------------------------------------------------------------------- - SUBROUTINE gdiis_step() - !-------------------------------------------------------------------- - USE basic_algebra_routines - IMPLICIT NONE - ! - REAL(DP), ALLOCATABLE :: res(:,:), overlap(:,:), work(:) - INTEGER, ALLOCATABLE :: iwork(:) - INTEGER :: k, k_m, info - REAL(DP) :: gamma0 - ! - ! - gdiis_iter = gdiis_iter + 1 - ! - k = MIN( gdiis_iter, bfgs_ndim ) - k_m = k + 1 - ! - ALLOCATE( res( n, k ) ) - ALLOCATE( overlap( k_m, k_m ) ) - ALLOCATE( work( k_m ), iwork( k_m ) ) - ! - work(:) = 0.0_DP - iwork(:) = 0 - ! - ! ... the new direction is added to the workspace - ! - DO i = bfgs_ndim, 2, -1 - ! - pos_old(:,i) = pos_old(:,i-1) - grad_old(:,i) = grad_old(:,i-1) - ! - END DO - ! - pos_old(:,1) = pos(:) - grad_old(:,1) = grad(:) - ! - ! ... |res_i> = H^-1 \times |g_i> - ! - CALL DGEMM( 'N', 'N', n, k, n, 1.0_DP, & - inv_hess, n, grad_old, n, 0.0_DP, res, n ) - ! - ! ... overlap_ij = - ! - CALL DGEMM( 'T', 'N', k, k, n, 1.0_DP, & - res, n, res, n, 0.0_DP, overlap, k_m ) - ! - overlap( :, k_m) = 1.0_DP - overlap(k_m, : ) = 1.0_DP - overlap(k_m,k_m) = 0.0_DP - ! - ! ... overlap is inverted via Bunch-Kaufman diagonal pivoting method - ! - CALL DSYTRF( 'U', k_m, overlap, k_m, iwork, work, k_m, info ) - CALL DSYTRI( 'U', k_m, overlap, k_m, iwork, work, info ) - CALL errore( 'gdiis_step', 'error in Bunch-Kaufman inversion', info ) - ! - ! ... overlap is symmetrised - ! - FORALL( i = 1:k_m, j = 1:k_m, j > i ) overlap(j,i) = overlap(i,j) - ! - pos_best(:) = 0.0_DP - step(:) = 0.0_DP - ! - DO i = 1, k - ! - gamma0 = overlap(k_m,i) - ! - pos_best(:) = pos_best(:) + gamma0*pos_old(:,i) - ! - step(:) = step(:) - gamma0*res(:,i) - ! - END DO - ! - ! ... the step must be consistent with the last positions - ! - step(:) = step(:) + ( pos_best(:) - pos(:) ) - ! - IF ( ( grad(:) .dot. step(:) ) > 0.0_DP ) THEN - ! - ! ... if the extrapolated direction is uphill use only the - ! ... last gradient and reset gdiis history - ! - step(:) = - ( inv_hess(:,:) .times. grad(:) ) - ! - gdiis_iter = 0 - ! - END IF - ! - DEALLOCATE( res, overlap, work, iwork ) - ! - END SUBROUTINE gdiis_step - ! - END SUBROUTINE bfgs - ! - !------------------------------------------------------------------------ - SUBROUTINE reset_bfgs( n ) - !------------------------------------------------------------------------ - ! ... inv_hess in re-initalized to the initial guess - ! ... defined as the inverse metric - ! - INTEGER, INTENT(IN) :: n - ! - REAL(DP) :: garbage - ! - call invmat(n, metric, inv_hess, garbage) - ! - gdiis_iter = 0 - ! - END SUBROUTINE reset_bfgs - ! - !------------------------------------------------------------------------ - SUBROUTINE read_bfgs_file( pos, grad, fixion, energy, scratch, n, stdout ) - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(INOUT) :: pos(:) - REAL(DP), INTENT(INOUT) :: grad(:) - INTEGER, INTENT(IN) :: fixion(:) - CHARACTER(LEN=*), INTENT(IN) :: scratch - INTEGER, INTENT(IN) :: n - INTEGER, INTENT(IN) :: stdout - REAL(DP), INTENT(INOUT) :: energy - ! - CHARACTER(LEN=256) :: bfgs_file - LOGICAL :: file_exists - REAL(DP) :: garbage - ! - ! - bfgs_file = TRIM( scratch ) // TRIM( prefix ) // '.bfgs' - ! - INQUIRE( FILE = TRIM( bfgs_file ) , EXIST = file_exists ) - ! - IF ( file_exists ) THEN - ! - ! ... bfgs is restarted from file - ! - OPEN( UNIT = iunbfgs, FILE = TRIM( bfgs_file ), & - STATUS = 'UNKNOWN', ACTION = 'READ' ) - ! - READ( iunbfgs, * ) pos_p - READ( iunbfgs, * ) grad_p - READ( iunbfgs, * ) scf_iter - READ( iunbfgs, * ) bfgs_iter - READ( iunbfgs, * ) gdiis_iter - READ( iunbfgs, * ) energy_p - READ( iunbfgs, * ) pos_old - READ( iunbfgs, * ) grad_old - READ( iunbfgs, * ) inv_hess - READ( iunbfgs, * ) tr_min_hit - ! - CLOSE( UNIT = iunbfgs ) - ! - trust_radius_old = scnorm( pos(:) - pos_p(:) ) - ! - step_old = ( pos(:) - pos_p(:) ) / trust_radius_old - ! - ELSE - ! - ! ... bfgs initialization - ! - WRITE( UNIT = stdout, FMT = '(/,5X,"BFGS Geometry Optimization")' ) - ! - ! initialize the inv_hess to the inverse of the metric - call invmat(n, metric, inv_hess, garbage) - ! - pos_p = 0.0_DP - grad_p = 0.0_DP - scf_iter = 0 - bfgs_iter = 0 - gdiis_iter = 0 - energy_p = energy - step_old = 0.0_DP - ! - trust_radius_old = trust_radius_ini - ! - pos_old(:,:) = 0.0_DP - grad_old(:,:) = 0.0_DP - ! - tr_min_hit = .FALSE. - ! - END IF - ! - END SUBROUTINE read_bfgs_file - ! - !------------------------------------------------------------------------ - SUBROUTINE write_bfgs_file( pos, energy, grad, scratch ) - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: pos(:) - REAL(DP), INTENT(IN) :: energy - REAL(DP), INTENT(IN) :: grad(:) - CHARACTER(LEN=*), INTENT(IN) :: scratch - ! - ! - OPEN( UNIT = iunbfgs, FILE = TRIM( scratch )//TRIM( prefix )//'.bfgs', & - STATUS = 'UNKNOWN', ACTION = 'WRITE' ) - ! - WRITE( iunbfgs, * ) pos - WRITE( iunbfgs, * ) grad - WRITE( iunbfgs, * ) scf_iter - WRITE( iunbfgs, * ) bfgs_iter - WRITE( iunbfgs, * ) gdiis_iter - WRITE( iunbfgs, * ) energy - WRITE( iunbfgs, * ) pos_old - WRITE( iunbfgs, * ) grad_old - WRITE( iunbfgs, * ) inv_hess - WRITE( iunbfgs, * ) tr_min_hit - ! - CLOSE( UNIT = iunbfgs ) - ! - END SUBROUTINE write_bfgs_file - ! - !------------------------------------------------------------------------ - SUBROUTINE update_inverse_hessian( pos, grad, n, stdout ) - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: pos(:) - REAL(DP), INTENT(IN) :: grad(:) - INTEGER, INTENT(IN) :: n - INTEGER, INTENT(IN) :: stdout - ! - REAL(DP), ALLOCATABLE :: y(:), s(:) - REAL(DP), ALLOCATABLE :: Hy(:), yH(:) - REAL(DP) :: sdoty - ! - ALLOCATE( y( n ), s( n ), Hy( n ), yH( n ) ) - ! - s(:) = pos(:) - pos_p(:) - y(:) = grad(:) - grad_p(:) - ! - sdoty = ( s(:) .dot. y(:) ) - ! - IF ( ABS( sdoty ) < eps16 ) THEN - ! - ! ... the history is reset - ! - WRITE( stdout, '(/,5X,"WARNING: unexpected ", & - & "behaviour in update_inverse_hessian")' ) - WRITE( stdout, '( 5X," resetting bfgs history",/)' ) - ! - CALL reset_bfgs( n ) - ! - RETURN - ! - END IF - ! - Hy(:) = ( inv_hess .times. y(:) ) - yH(:) = ( y(:) .times. inv_hess ) - ! - ! ... BFGS update - ! - inv_hess = inv_hess + 1.0_DP / sdoty * & - ( ( 1.0_DP + ( y .dot. Hy ) / sdoty ) * matrix( s, s ) - & - ( matrix( s, yH ) + matrix( Hy, s ) ) ) - ! - DEALLOCATE( y, s, Hy, yH ) - ! - RETURN - ! - END SUBROUTINE update_inverse_hessian - ! - !------------------------------------------------------------------------ - SUBROUTINE check_wolfe_conditions( lwolfe, energy, grad ) - !------------------------------------------------------------------------ - IMPLICIT NONE - REAL(DP), INTENT(IN) :: energy - REAL(DP), INTENT(IN) :: grad(:) - LOGICAL, INTENT(OUT) :: lwolfe - ! - ! - lwolfe = ( energy - energy_p ) < w_1 * ( grad_p .dot. step_old ) - ! - lwolfe = lwolfe .AND. & - ABS( grad .dot. step_old ) > - w_2 * ( grad_p .dot. step_old ) - ! - END SUBROUTINE check_wolfe_conditions - ! - !------------------------------------------------------------------------ - SUBROUTINE compute_trust_radius( lwolfe, energy, grad, n, stdout ) - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(IN) :: lwolfe - REAL(DP), INTENT(IN) :: energy - REAL(DP), INTENT(IN) :: grad(:) - INTEGER, INTENT(IN) :: n - INTEGER, INTENT(IN) :: stdout - ! - REAL(DP) :: a - LOGICAL :: ltest - ! - ! - ltest = ( energy - energy_p ) < w_1 * ( grad_p .dot. step_old ) - ltest = ltest .AND. ( scnorm( step ) > trust_radius_old ) - ! - IF ( ltest ) THEN - ! - a = 1.5_DP - ! - ELSE - ! - a = 1.1_DP - ! - END IF - ! - IF ( lwolfe ) THEN - ! - trust_radius = MIN( trust_radius_max, 2.0_DP*a*trust_radius_old ) - ! - ELSE - ! - trust_radius = MIN( trust_radius_max, & - a*trust_radius_old, scnorm( step ) ) - ! - END IF - ! - IF ( trust_radius < trust_radius_min ) THEN - ! - ! ... the history is reset - ! - IF ( tr_min_hit ) THEN - ! - ! ... the history has already been reset at the previous step : - ! ... something is going wrong - ! - CALL errore( 'bfgs', 'history already reset at previous step', 1 ) - ! - END IF - ! - WRITE( UNIT = stdout, & - FMT = '(5X,"small trust_radius: resetting bfgs history",/)' ) - ! - CALL reset_bfgs( n ) - ! - step(:) = - ( inv_hess(:,:) .times. grad(:) ) - ! - trust_radius = trust_radius_min - ! - tr_min_hit = .TRUE. - ! - ELSE - ! - tr_min_hit = .FALSE. - ! - END IF - ! - END SUBROUTINE compute_trust_radius - ! - !----------------------------------------------------------------------- - REAL(DP) FUNCTION scnorm( vect ) - !----------------------------------------------------------------------- - IMPLICIT NONE - REAL(DP), INTENT(IN) :: vect(:) - ! - scnorm = SQRT( DOT_PRODUCT( vect , MATMUL( metric, vect ) ) ) - ! - END FUNCTION scnorm - ! - !------------------------------------------------------------------------ - SUBROUTINE terminate_bfgs( energy, energy_thr, grad_thr, cell_thr, & - lmovecell, stdout, scratch ) - !------------------------------------------------------------------------ - ! - USE io_files, ONLY : prefix, delete_if_present - ! - IMPLICIT NONE - REAL(DP), INTENT(IN) :: energy, energy_thr, grad_thr, cell_thr - LOGICAL, INTENT(IN) :: lmovecell - INTEGER, INTENT(IN) :: stdout - CHARACTER(LEN=*), INTENT(IN) :: scratch - ! - IF ( conv_bfgs ) THEN - ! - WRITE( UNIT = stdout, & - & FMT = '(/,5X,"bfgs converged in ",I3," scf cycles and ", & - & I3," bfgs steps")' ) scf_iter, bfgs_iter - IF ( lmovecell ) THEN - WRITE( UNIT = stdout, & - & FMT = '(5X,"(criteria: energy < ",E8.2,", force < ",E8.2, & - & ", cell < ",E8.2,")")') energy_thr, grad_thr, cell_thr - ELSE - WRITE( UNIT = stdout, & - & FMT = '(5X,"(criteria: energy < ",E8.2,", force < ",E8.2, & - & ")")') energy_thr, grad_thr - END IF - WRITE( UNIT = stdout, & - & FMT = '(/,5X,"End of BFGS Geometry Optimization")' ) - WRITE( UNIT = stdout, & - & FMT = '(/,5X,"Final ",A," = ",F18.10," Ry")' ) fname, energy - ! - CALL delete_if_present( TRIM( scratch ) // TRIM( prefix ) // '.bfgs' ) - ! - ELSE - ! - WRITE( UNIT = stdout, & - FMT = '(/,5X,"The maximum number of steps has been reached.")' ) - WRITE( UNIT = stdout, & - FMT = '(/,5X,"End of BFGS Geometry Optimization")' ) - ! - END IF - ! - END SUBROUTINE terminate_bfgs - ! -END MODULE bfgs_module diff --git a/quantum_espresso/kcp/Modules/cell_base.f90 b/quantum_espresso/kcp/Modules/cell_base.f90 deleted file mode 100644 index b009c1370..000000000 --- a/quantum_espresso/kcp/Modules/cell_base.f90 +++ /dev/null @@ -1,1098 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -!------------------------------------------------------------------------------! - MODULE cell_base -!------------------------------------------------------------------------------! - - USE kinds, ONLY : DP -! - IMPLICIT NONE - SAVE -! - -! ... periodicity box -! ... In the matrix "a" every row is the vector of each side of -! ... the cell in the real space - - TYPE boxdimensions - REAL(DP) :: a(3,3) ! direct lattice generators - REAL(DP) :: m1(3,3) ! reciprocal lattice generators - REAL(DP) :: omega ! cell volume = determinant of a - REAL(DP) :: g(3,3) ! metric tensor - REAL(DP) :: gvel(3,3) ! metric velocity - REAL(DP) :: pail(3,3) ! stress tensor ( scaled coor. ) - REAL(DP) :: paiu(3,3) ! stress tensor ( cartesian coor. ) - REAL(DP) :: hmat(3,3) ! cell parameters ( transpose of "a" ) - REAL(DP) :: hvel(3,3) ! cell velocity - REAL(DP) :: hinv(3,3) - REAL(DP) :: deth - INTEGER :: perd(3) - END TYPE boxdimensions - - REAL(DP) :: alat = 0.0_DP ! lattice parameter, often used to scale quantities - ! or in combination to other parameters/constants - ! to define new units - - ! celldm are che simulation cell parameters - - REAL(DP) :: celldm(6) = (/ 0.0_DP, 0.0_DP, 0.0_DP, 0.0_DP, 0.0_DP, 0.0_DP /) - - ! a1, a2 and a3 are the simulation cell base vector as calculated from celldm - - REAL(DP) :: a1(3) = (/ 0.0_DP, 0.0_DP, 0.0_DP /) - REAL(DP) :: a2(3) = (/ 0.0_DP, 0.0_DP, 0.0_DP /) - REAL(DP) :: a3(3) = (/ 0.0_DP, 0.0_DP, 0.0_DP /) - - ! b1, b2 and b3 are the simulation reciprocal lattice vectors - - REAL(DP) :: b1(3) = (/ 0.0_DP, 0.0_DP, 0.0_DP /) - REAL(DP) :: b2(3) = (/ 0.0_DP, 0.0_DP, 0.0_DP /) - REAL(DP) :: b3(3) = (/ 0.0_DP, 0.0_DP, 0.0_DP /) - - REAL(DP) :: ainv(3,3) = 0.0_DP - - REAl(DP) :: omega = 0.0_DP ! volume of the simulation cell - - REAL(DP) :: tpiba = 0.0_DP ! = 2 PI / alat - REAL(DP) :: tpiba2 = 0.0_DP ! = ( 2 PI / alat ) ** 2 - - ! direct lattice vectors and reciprocal lattice vectors - ! The folloving relations should alwais be kept valid - ! at( :, 1 ) = a1( : ) / alat ; h( :, 1 ) = a1( : ) - ! at( :, 2 ) = a2( : ) / alat ; h( :, 2 ) = a2( : ) - ! at( :, 3 ) = a3( : ) / alat ; h( :, 3 ) = a3( : ) - ! ht = h^t ; ainv = h^(-1) - ! - ! bg( :, 1 ) = b1( : ) - ! bg( :, 2 ) = b2( : ) - ! bg( :, 3 ) = b3( : ) - - REAL(DP) :: at(3,3) = RESHAPE( (/ 0.0_DP /), (/ 3, 3 /), (/ 0.0_DP /) ) - REAL(DP) :: bg(3,3) = RESHAPE( (/ 0.0_DP /), (/ 3, 3 /), (/ 0.0_DP /) ) - - INTEGER :: ibrav ! index of the bravais lattice - CHARACTER(len=9) :: symm_type ! 'cubic' or 'hexagonal' when ibrav=0 - - REAL(DP) :: h(3,3) = 0.0_DP ! simulation cell at time t - REAL(DP) :: hold(3,3) = 0.0_DP ! simulation cell at time t-delt - REAL(DP) :: hnew(3,3) = 0.0_DP ! simulation cell at time t+delt - REAL(DP) :: velh(3,3) = 0.0_DP ! simulation cell velocity - REAL(DP) :: deth = 0.0_DP ! determinant of h ( cell volume ) - - INTEGER :: iforceh(3,3) = 1 ! if iforceh( i, j ) = 0 then h( i, j ) - ! is not allowed to move - LOGICAL :: thdiag = .FALSE. ! True if only cell diagonal elements - ! should be updated - - REAL(DP) :: wmass = 0.0_DP ! cell fictitious mass - REAL(DP) :: press = 0.0_DP ! external pressure - - REAL(DP) :: frich = 0.0_DP ! firction parameter for cell damped dynamics - REAL(DP) :: greash = 1.0_DP ! greas parameter for damped dynamics - - LOGICAL :: tcell_base_init = .FALSE. - - INTERFACE cell_init - MODULE PROCEDURE cell_init_ht, cell_init_a - END INTERFACE - - INTERFACE pbcs - MODULE PROCEDURE pbcs_components, pbcs_vectors - END INTERFACE - - INTERFACE s_to_r - MODULE PROCEDURE s_to_r1, s_to_r1b, s_to_r3 - END INTERFACE - - INTERFACE r_to_s - MODULE PROCEDURE r_to_s1, r_to_s1b, r_to_s3 - END INTERFACE - -! -!------------------------------------------------------------------------------! - CONTAINS -!------------------------------------------------------------------------------! -! - - - -!------------------------------------------------------------------------------! -! ... set box -! ... box%m1(i,1) == b1(i) COLUMN are B vectors -! ... box%a(1,i) == a1(i) ROW are A vector -! ... box%omega == volume -! ... box%g(i,j) == metric tensor G -!------------------------------------------------------------------------------! - - SUBROUTINE cell_init_ht( what, box, hval ) - TYPE (boxdimensions) :: box - REAL(DP), INTENT(IN) :: hval(3,3) - CHARACTER, INTENT(IN) :: what - IF( what == 't' .OR. what == 'T' ) THEN - ! hval == ht - box%a = hval - box%hmat = TRANSPOSE( hval ) - ELSE - ! hval == hmat - box%hmat = hval - box%a = TRANSPOSE( hval ) - END IF - CALL gethinv( box ) - box%g = MATMUL( box%a(:,:), box%hmat(:,:) ) - box%gvel = 0.0_DP - box%hvel = 0.0_DP - box%pail = 0.0_DP - box%paiu = 0.0_DP - RETURN - END SUBROUTINE cell_init_ht - -!------------------------------------------------------------------------------! - - SUBROUTINE cell_init_a( box, a1, a2, a3 ) - TYPE (boxdimensions) :: box - REAL(DP) :: a1(3), a2(3), a3(3) - INTEGER :: i - DO i=1,3 - box%a(1,I) = A1(I) ! this is HT: the row are the lattice vectors - box%a(2,I) = A2(I) - box%a(3,I) = A3(I) - box%hmat(I,1) = A1(I) ! this is H : the column are the lattice vectors - box%hmat(I,2) = A2(I) - box%hmat(I,3) = A3(I) - END DO - box%pail = 0.0_DP - box%paiu = 0.0_DP - box%hvel = 0.0_DP - CALL gethinv(box) - box%g = MATMUL( box%a(:,:), box%hmat(:,:) ) - box%gvel = 0.0_DP - RETURN - END SUBROUTINE cell_init_a - -!------------------------------------------------------------------------------! - - SUBROUTINE r_to_s1 (r,s,box) - REAL(DP), intent(out) :: S(3) - REAL(DP), intent(in) :: R(3) - type (boxdimensions), intent(in) :: box - integer i,j - DO I=1,3 - S(I) = 0.0_DP - DO J=1,3 - S(I) = S(I) + R(J)*box%m1(J,I) - END DO - END DO - RETURN - END SUBROUTINE r_to_s1 - -!------------------------------------------------------------------------------! - - SUBROUTINE r_to_s3 ( r, s, na, nsp, hinv ) - REAL(DP), intent(out) :: S(:,:) - INTEGER, intent(in) :: na(:), nsp - REAL(DP), intent(in) :: R(:,:) - REAL(DP), intent(in) :: hinv(:,:) ! hinv = TRANSPOSE( box%m1 ) - integer :: i, j, ia, is, isa - isa = 0 - DO is = 1, nsp - DO ia = 1, na(is) - isa = isa + 1 - DO I=1,3 - S(I,isa) = 0.0_DP - DO J=1,3 - S(I,isa) = S(I,isa) + R(J,isa)*hinv(i,j) - END DO - END DO - END DO - END DO - RETURN - END SUBROUTINE r_to_s3 - -!------------------------------------------------------------------------------! - - SUBROUTINE r_to_s1b ( r, s, hinv ) - REAL(DP), intent(out) :: S(:) - REAL(DP), intent(in) :: R(:) - REAL(DP), intent(in) :: hinv(:,:) ! hinv = TRANSPOSE( box%m1 ) - integer :: i, j - DO I=1,3 - S(I) = 0.0_DP - DO J=1,3 - S(I) = S(I) + R(J)*hinv(i,j) - END DO - END DO - RETURN - END SUBROUTINE r_to_s1b - - -!------------------------------------------------------------------------------! - - SUBROUTINE s_to_r1 (S,R,box) - REAL(DP), intent(in) :: S(3) - REAL(DP), intent(out) :: R(3) - type (boxdimensions), intent(in) :: box - integer i,j - DO I=1,3 - R(I) = 0.0_DP - DO J=1,3 - R(I) = R(I) + S(J)*box%a(J,I) - END DO - END DO - RETURN - END SUBROUTINE s_to_r1 - -!------------------------------------------------------------------------------! - - SUBROUTINE s_to_r1b (S,R,h) - REAL(DP), intent(in) :: S(3) - REAL(DP), intent(out) :: R(3) - REAL(DP), intent(in) :: h(:,:) ! h = TRANSPOSE( box%a ) - integer i,j - DO I=1,3 - R(I) = 0.0_DP - DO J=1,3 - R(I) = R(I) + S(J)*h(I,j) - END DO - END DO - RETURN - END SUBROUTINE s_to_r1b - -!------------------------------------------------------------------------------! - - SUBROUTINE s_to_r3 ( S, R, na, nsp, h ) - REAL(DP), intent(in) :: S(:,:) - INTEGER, intent(in) :: na(:), nsp - REAL(DP), intent(out) :: R(:,:) - REAL(DP), intent(in) :: h(:,:) ! h = TRANSPOSE( box%a ) - integer :: i, j, ia, is, isa - isa = 0 - DO is = 1, nsp - DO ia = 1, na(is) - isa = isa + 1 - DO I = 1, 3 - R(I,isa) = 0.0_DP - DO J = 1, 3 - R(I,isa) = R(I,isa) + S(J,isa) * h(I,j) - END DO - END DO - END DO - END DO - RETURN - END SUBROUTINE s_to_r3 - - -! -!------------------------------------------------------------------------------! -! - - SUBROUTINE gethinv(box) - IMPLICIT NONE - TYPE (boxdimensions), INTENT (INOUT) :: box - ! - CALL invmat( 3, box%a, box%m1, box%omega ) - box%deth = box%omega - box%hinv = TRANSPOSE( box%m1 ) - ! - RETURN - END SUBROUTINE gethinv - - - FUNCTION get_volume( hmat ) - IMPLICIT NONE - REAL(DP) :: get_volume - REAL(DP) :: hmat( 3, 3 ) - get_volume = hmat(1,1)*(hmat(2,2)*hmat(3,3)-hmat(2,3)*hmat(3,2)) + & - hmat(1,2)*(hmat(2,3)*hmat(3,1)-hmat(2,1)*hmat(3,3)) + & - hmat(1,3)*(hmat(2,1)*hmat(3,2)-hmat(2,2)*hmat(3,1)) - RETURN - END FUNCTION get_volume -! -!------------------------------------------------------------------------------! -! - FUNCTION pbc(rin,box,nl) RESULT (rout) - IMPLICIT NONE - TYPE (boxdimensions) :: box - REAL (DP) :: rin(3) - REAL (DP) :: rout(3), s(3) - INTEGER, OPTIONAL :: nl(3) - - s = matmul(box%hinv(:,:),rin) - s = s - box%perd*nint(s) - rout = matmul(box%hmat(:,:),s) - IF (present(nl)) THEN - s = DBLE(nl) - rout = rout + matmul(box%hmat(:,:),s) - END IF - END FUNCTION pbc - -! -!------------------------------------------------------------------------------! -! - FUNCTION saw(emaxpos,eopreg,x) RESULT (sawout) - IMPLICIT NONE - REAL(DP) :: emaxpos,eopreg,x - REAL(DP) :: y, sawout, z - - z = x - emaxpos - y = z - floor(z) - - if (y.le.eopreg) then - - sawout = (0.5 - y/eopreg) * (1-eopreg) - - else - sawout = (-0.5 + (y-eopreg)/(1-eopreg)) * (1-eopreg) - - end if - -END FUNCTION saw - -! -!------------------------------------------------------------------------------! -! - SUBROUTINE get_cell_param(box,cell,ang) - IMPLICIT NONE - TYPE(boxdimensions), INTENT(in) :: box - REAL(DP), INTENT(out), DIMENSION(3) :: cell - REAL(DP), INTENT(out), DIMENSION(3), OPTIONAL :: ang -! This code gets the cell parameters given the h-matrix: -! a - cell(1)=sqrt(box%hmat(1,1)*box%hmat(1,1)+box%hmat(2,1)*box%hmat(2,1) & - +box%hmat(3,1)*box%hmat(3,1)) -! b - cell(2)=sqrt(box%hmat(1,2)*box%hmat(1,2)+box%hmat(2,2)*box%hmat(2,2) & - +box%hmat(3,2)*box%hmat(3,2)) -! c - cell(3)=sqrt(box%hmat(1,3)*box%hmat(1,3)+box%hmat(2,3)*box%hmat(2,3) & - +box%hmat(3,3)*box%hmat(3,3)) - IF (PRESENT(ang)) THEN -! gamma - ang(1)=acos((box%hmat(1,1)*box%hmat(1,2)+ & - box%hmat(2,1)*box%hmat(2,2) & - +box%hmat(3,1)*box%hmat(3,2))/(cell(1)*cell(2))) -! beta - ang(2)=acos((box%hmat(1,1)*box%hmat(1,3)+ & - box%hmat(2,1)*box%hmat(2,3) & - +box%hmat(3,1)*box%hmat(3,3))/(cell(1)*cell(3))) -! alpha - ang(3)=acos((box%hmat(1,2)*box%hmat(1,3)+ & - box%hmat(2,2)*box%hmat(2,3) & - +box%hmat(3,2)*box%hmat(3,3))/(cell(2)*cell(3))) -! ang=ang*180.0_DP/pi - - ENDIF - END SUBROUTINE get_cell_param - -!------------------------------------------------------------------------------! - - SUBROUTINE pbcs_components(x1, y1, z1, x2, y2, z2, m) -! ... This subroutine compute the periodic boundary conditions in the scaled -! ... variables system - USE kinds - INTEGER, INTENT(IN) :: M - REAL(DP), INTENT(IN) :: X1,Y1,Z1 - REAL(DP), INTENT(OUT) :: X2,Y2,Z2 - REAL(DP) MIC - MIC = DBLE(M) - X2 = X1 - DNINT(X1/MIC)*MIC - Y2 = Y1 - DNINT(Y1/MIC)*MIC - Z2 = Z1 - DNINT(Z1/MIC)*MIC - RETURN - END SUBROUTINE pbcs_components - -!------------------------------------------------------------------------------! - - SUBROUTINE pbcs_vectors(v, w, m) -! ... This subroutine compute the periodic boundary conditions in the scaled -! ... variables system - USE kinds - INTEGER, INTENT(IN) :: m - REAL(DP), INTENT(IN) :: v(3) - REAL(DP), INTENT(OUT) :: w(3) - REAL(DP) :: MIC - MIC = DBLE(M) - w(1) = v(1) - DNINT(v(1)/MIC)*MIC - w(2) = v(2) - DNINT(v(2)/MIC)*MIC - w(3) = v(3) - DNINT(v(3)/MIC)*MIC - RETURN - END SUBROUTINE pbcs_vectors - -!------------------------------------------------------------------------------! - - SUBROUTINE cell_base_init( ibrav_ , celldm_ , trd_ht, cell_symmetry, rd_ht, cell_units, & - a_ , b_ , c_ , cosab, cosac, cosbc, wc_ , total_ions_mass , press_ , & - frich_ , greash_ , cell_dofree ) - - USE constants, ONLY: bohr_radius_angs, au_gpa, pi, amu_au - USE io_global, ONLY: stdout - - IMPLICIT NONE - INTEGER, INTENT(IN) :: ibrav_ - REAL(DP), INTENT(IN) :: celldm_ (6) - LOGICAL, INTENT(IN) :: trd_ht - CHARACTER(LEN=*), INTENT(IN) :: cell_symmetry - REAL(DP), INTENT(IN) :: rd_ht (3,3) - CHARACTER(LEN=*), INTENT(IN) :: cell_units - REAL(DP), INTENT(IN) :: a_ , b_ , c_ , cosab, cosac, cosbc - CHARACTER(LEN=*), INTENT(IN) :: cell_dofree - REAL(DP), INTENT(IN) :: wc_ , frich_ , greash_ , total_ions_mass - REAL(DP), INTENT(IN) :: press_ ! external pressure from imput ( GPa ) - - - REAL(DP) :: b1(3), b2(3), b3(3) - REAL(DP) :: a, b, c, units - INTEGER :: j - - ! - ! ... set up crystal lattice, and initialize cell_base module - ! - - celldm = celldm_ - a = a_ - b = b_ - c = c_ - ibrav = ibrav_ - - IF ( ibrav == 0 .AND. .NOT. trd_ht ) & - CALL errore( ' cell_base_init ', ' ibrav=0: must read cell parameters', 1 ) - IF ( ibrav /= 0 .AND. trd_ht ) & - CALL errore( ' cell_base_init ', ' redundant data for cell parameters', 2 ) - - IF ( celldm(1) /= 0.0_DP .AND. a /= 0.0_DP ) THEN - CALL errore( ' cell_base_init ', ' do not specify both celldm and a,b,c!', 1 ) - END IF - - press = press_ / au_gpa - ! frich = frich_ ! for the time being this is set elsewhere - greash = greash_ - - WRITE( stdout, 105 ) - WRITE( stdout, 110 ) press_ -105 format(/,3X,'Simulation Cell Parameters (from input)') -110 format( 3X,'external pressure = ',f15.2,' [GPa]') - - wmass = wc_ - IF( wmass == 0.0_DP ) THEN - wmass = 3.0_DP / (4.0_DP * pi**2 ) * total_ions_mass - wmass = wmass * AMU_AU - WRITE( stdout,130) wmass - ELSE - WRITE( stdout,120) wmass - END IF -120 format(3X,'wmass (read from input) = ',f15.2,' [AU]') -130 format(3X,'wmass (calculated) = ',f15.2,' [AU]') - - IF( wmass <= 0.0_DP ) & - CALL errore(' cell_base_init ',' wmass out of range ',0) - - - - ! ... if celldm(1) /= 0 rd_ht should be in unit of alat - - IF ( trd_ht ) THEN - ! - SELECT CASE ( TRIM( cell_units ) ) - CASE ( 'bohr' ) - units = 1.0_DP - CASE ( 'angstrom' ) - units = 1.0_DP / BOHR_RADIUS_ANGS - CASE ( 'alat' ) - IF( celldm( 1 ) == 0.0_DP ) & - CALL errore( ' cell_base_init ', ' cell_parameter in alat without celldm(1) ', 1 ) - units = celldm( 1 ) - CASE DEFAULT - units = 1.0_DP - END SELECT - ! - symm_type = cell_symmetry - ! - ! The matrix "ht" in FPMD correspond to the transpose of matrix "at" in PW - ! - at = TRANSPOSE( rd_ht ) * units - WRITE( stdout, 210 ) - WRITE( stdout, 220 ) ( rd_ht( 1, j ), j = 1, 3 ) - WRITE( stdout, 220 ) ( rd_ht( 2, j ), j = 1, 3 ) - WRITE( stdout, 220 ) ( rd_ht( 3, j ), j = 1, 3 ) - ! - IF ( ANY( celldm(1:6) /= 0 ) .AND. TRIM( cell_units ) /= 'alat' ) THEN - WRITE( stdout, 230 ) - celldm(1:6) = 0.0_DP - END IF - ! - IF ( a /= 0 ) THEN - WRITE( stdout, 240 ) - a = 0.0_DP - b = 0.0_DP - c = 0.0_DP - END IF - ! -210 format(3X,'initial cell from CELL_PARAMETERS card') -220 format(3X,3F14.8) -230 format(3X,'celldm(1:6) are ignored') -240 format(3X,'a, b, c are ignored') - ! - - IF ( celldm(1) == 0.0_DP ) THEN - ! - ! ... input at are in atomic units: define alat - ! - celldm(1) = SQRT( at(1,1)**2 + at(1,2)**2 + at(1,3)**2 ) - END IF - - alat = celldm(1) - ! - ! ... bring at to alat units - ! - at(:,:) = at(:,:) / alat - - ELSE - - IF( a /= 0.0_DP ) THEN - - celldm(1) = a / bohr_radius_angs - celldm(2) = b / a - celldm(3) = c / a - IF ( ibrav /= 14 ) THEN - celldm(4) = cosab - ELSE - celldm(4) = cosbc - celldm(5) = cosac - celldm(6) = cosab - END IF - END IF - - ! - ! ... generate at (atomic units) - ! - CALL latgen( ibrav, celldm, at(1,1), at(1,2), at(1,3), omega ) - alat = celldm(1) - ! - ! ... bring at to alat units - ! - at(:,:) = at(:,:) / alat - - END IF - ! - a1 = at( :, 1 ) * alat - a2 = at( :, 2 ) * alat - a3 = at( :, 3 ) * alat - ! - CALL volume( alat, at(1,1), at(1,2), at(1,3), omega ) - ! - CALL recips( a1, a2, a3, b1, b2, b3 ) - ! - ainv( 1, : ) = b1( : ) - ainv( 2, : ) = b2( : ) - ainv( 3, : ) = b3( : ) - ! - bg( :, 1 ) = b1( : ) * alat - bg( :, 2 ) = b2( : ) * alat - bg( :, 3 ) = b3( : ) * alat - ! - ! ... The matrix "htm1" in FPMD correspond to the matrix "bg" in PW - ! - CALL init_dofree ( cell_dofree ) - ! - tcell_base_init = .TRUE. - - WRITE( stdout, 300 ) ibrav - WRITE( stdout, 305 ) alat - WRITE( stdout, 310 ) a1 - WRITE( stdout, 320 ) a2 - WRITE( stdout, 330 ) a3 - WRITE( stdout, * ) - WRITE( stdout, 350 ) b1 - WRITE( stdout, 360 ) b2 - WRITE( stdout, 370 ) b3 - WRITE( stdout, 340 ) omega -300 FORMAT( 3X, 'ibrav = ',I4) -305 FORMAT( 3X, 'alat = ',F14.8) -310 FORMAT( 3X, 'a1 = ',3F14.8) -320 FORMAT( 3X, 'a2 = ',3F14.8) -330 FORMAT( 3X, 'a3 = ',3F14.8) -350 FORMAT( 3X, 'b1 = ',3F14.8) -360 FORMAT( 3X, 'b2 = ',3F14.8) -370 FORMAT( 3X, 'b3 = ',3F14.8) -340 FORMAT( 3X, 'omega = ',F14.8) - - - RETURN - END SUBROUTINE cell_base_init - -!------------------------------------------------------------------------------! - SUBROUTINE init_dofree ( cell_dofree ) - - ! set constraints on cell dynamics/optimization - - CHARACTER(LEN=*), INTENT(IN) :: cell_dofree - - thdiag = .false. - SELECT CASE ( TRIM( cell_dofree ) ) - - CASE ( 'all', 'default' ) - iforceh = 1 - CASE ( 'volume' ) - CALL errore(' init_dofree ', & - ' cell_dofree = '//TRIM(cell_dofree)//' not yet implemented ', 1 ) - CASE ('x') - iforceh = 0 - iforceh(1,1) = 1 - CASE ('y') - iforceh = 0 - iforceh(2,2) = 1 - CASE ('z') - iforceh = 0 - iforceh(3,3) = 1 - CASE ('xy') - iforceh = 0 - iforceh(1,1) = 1 - iforceh(2,2) = 1 - CASE ('xz') - iforceh = 0 - iforceh(1,1) = 1 - iforceh(3,3) = 1 - CASE ('yz') - iforceh = 0 - iforceh(2,2) = 1 - iforceh(3,3) = 1 - CASE ('xyz') - thdiag = .true. - iforceh = 0 - iforceh(1,1) = 1 - iforceh(2,2) = 1 - iforceh(3,3) = 1 - CASE DEFAULT - CALL errore(' init_dofree ',' unknown cell_dofree '//TRIM(cell_dofree), 1 ) - - END SELECT - END SUBROUTINE init_dofree - -!------------------------------------------------------------------------------! - - SUBROUTINE cell_base_reinit( ht ) - - USE constants, ONLY: pi - USE io_global, ONLY: stdout - USE control_flags, ONLY: iprsta - - IMPLICIT NONE - REAL(DP), INTENT(IN) :: ht (3,3) - - REAL(DP) :: b1(3), b2(3), b3(3) - INTEGER :: j - - alat = sqrt( ht(1,1)*ht(1,1) + ht(1,2)*ht(1,2) + ht(1,3)*ht(1,3) ) - tpiba = 2.0_DP * pi / alat - tpiba2 = tpiba * tpiba - ! - ! The matrix "ht" in FPMD correspond to the transpose of matrix "at" in PW - ! - at = TRANSPOSE( ht ) - ! - IF( iprsta > 3 ) THEN - WRITE( stdout, 210 ) - WRITE( stdout, 220 ) ( ht( 1, j ), j = 1, 3 ) - WRITE( stdout, 220 ) ( ht( 2, j ), j = 1, 3 ) - WRITE( stdout, 220 ) ( ht( 3, j ), j = 1, 3 ) - END IF -210 format(3X,'Simulation cell parameters with the new cell:') -220 format(3X,3F14.8) - - ! - a1 = at( :, 1 ) - a2 = at( :, 2 ) - a3 = at( :, 3 ) - - at( :, : ) = at( :, : ) / alat - - CALL volume( alat, at(1,1), at(1,2), at(1,3), deth ) - omega = deth - - CALL recips( a1, a2, a3, b1, b2, b3 ) - ainv( 1, : ) = b1( : ) - ainv( 2, : ) = b2( : ) - ainv( 3, : ) = b3( : ) - - bg( :, 1 ) = b1( : ) * alat - bg( :, 2 ) = b2( : ) * alat - bg( :, 3 ) = b3( : ) * alat - - ! ... The matrix "htm1" in FPMD correspond to the matrix "bg" in PW - - IF( iprsta > 3 ) THEN - WRITE( stdout, 305 ) alat - WRITE( stdout, 310 ) a1 - WRITE( stdout, 320 ) a2 - WRITE( stdout, 330 ) a3 - WRITE( stdout, * ) - WRITE( stdout, 350 ) b1 - WRITE( stdout, 360 ) b2 - WRITE( stdout, 370 ) b3 - WRITE( stdout, 340 ) omega - END IF - -300 FORMAT( 3X, 'ibrav = ',I4) -305 FORMAT( 3X, 'alat = ',F14.8) -310 FORMAT( 3X, 'a1 = ',3F14.8) -320 FORMAT( 3X, 'a2 = ',3F14.8) -330 FORMAT( 3X, 'a3 = ',3F14.8) -350 FORMAT( 3X, 'b1 = ',3F14.8) -360 FORMAT( 3X, 'b2 = ',3F14.8) -370 FORMAT( 3X, 'b3 = ',3F14.8) -340 FORMAT( 3X, 'omega = ',F14.8) - - - RETURN - END SUBROUTINE cell_base_reinit - - - -!------------------------------------------------------------------------------! - - SUBROUTINE cell_steepest( hnew, h, delt, iforceh, fcell ) - REAL(DP), INTENT(OUT) :: hnew(3,3) - REAL(DP), INTENT(IN) :: h(3,3), fcell(3,3) - INTEGER, INTENT(IN) :: iforceh(3,3) - REAL(DP), INTENT(IN) :: delt - INTEGER :: i, j - REAL(DP) :: dt2 - dt2 = delt * delt - DO j=1,3 - DO i=1,3 - hnew(i,j) = h(i,j) + dt2 * fcell(i,j) * iforceh(i,j) - ENDDO - ENDDO - RETURN - END SUBROUTINE cell_steepest - - -!------------------------------------------------------------------------------! - - SUBROUTINE cell_verlet( hnew, h, hold, delt, iforceh, fcell, frich, tnoseh, hnos ) - REAL(DP), INTENT(OUT) :: hnew(3,3) - REAL(DP), INTENT(IN) :: h(3,3), hold(3,3), hnos(3,3), fcell(3,3) - INTEGER, INTENT(IN) :: iforceh(3,3) - REAL(DP), INTENT(IN) :: frich, delt - LOGICAL, INTENT(IN) :: tnoseh - - REAL(DP) :: htmp(3,3) - REAL(DP) :: verl1, verl2, verl3, dt2, ftmp - INTEGER :: i, j - - dt2 = delt * delt - - IF( tnoseh ) THEN - ftmp = 0.0_DP - htmp = hnos - ELSE - ftmp = frich - htmp = 0.0_DP - END IF - - verl1 = 2.0_DP / ( 1.0_DP + ftmp ) - verl2 = 1.0_DP - verl1 - verl3 = dt2 / ( 1.0_DP + ftmp ) - - DO j=1,3 - DO i=1,3 - hnew(i,j) = h(i,j) + ( ( verl1 - 1.0_DP ) * h(i,j) & - & + verl2 * hold(i,j) + & - verl3 * ( fcell(i,j) - htmp(i,j) ) ) * iforceh(i,j) - ENDDO - ENDDO - RETURN - END SUBROUTINE cell_verlet - -!------------------------------------------------------------------------------! - - subroutine cell_hmove( h, hold, delt, iforceh, fcell ) - REAL(DP), intent(out) :: h(3,3) - REAL(DP), intent(in) :: hold(3,3), fcell(3,3) - REAL(DP), intent(in) :: delt - integer, intent(in) :: iforceh(3,3) - REAL(DP) :: dt2by2, fac - integer :: i, j - dt2by2 = 0.5_DP * delt * delt - fac = dt2by2 - do i=1,3 - do j=1,3 - h(i,j) = hold(i,j) + fac * iforceh(i,j) * fcell(i,j) - end do - end do - return - end subroutine cell_hmove - -!------------------------------------------------------------------------------! - - subroutine cell_force( fcell, ainv, stress, omega, press, wmassIN ) - USE constants, ONLY : eps8 - REAL(DP), intent(out) :: fcell(3,3) - REAL(DP), intent(in) :: stress(3,3), ainv(3,3) - REAL(DP), intent(in) :: omega, press - REAL(DP), intent(in), optional :: wmassIN - integer :: i, j - REAL(DP) :: wmass - IF (.not. present(wmassIN)) THEN - wmass = 1.0 - ELSE - wmass = wmassIN - END IF - do j=1,3 - do i=1,3 - fcell(i,j) = ainv(j,1)*stress(i,1) + ainv(j,2)*stress(i,2) + ainv(j,3)*stress(i,3) - end do - end do - do j=1,3 - do i=1,3 - fcell(i,j) = fcell(i,j) - ainv(j,i) * press - end do - end do - IF( wmass < eps8 ) & - CALL errore( ' movecell ',' cell mass is less than 0 ! ', 1 ) - fcell = omega * fcell / wmass - return - end subroutine cell_force - -!------------------------------------------------------------------------------! - - subroutine cell_move( hnew, h, hold, delt, iforceh, fcell, frich, tnoseh, vnhh, velh, tsdc ) - REAL(DP), intent(out) :: hnew(3,3) - REAL(DP), intent(in) :: h(3,3), hold(3,3), fcell(3,3) - REAL(DP), intent(in) :: vnhh(3,3), velh(3,3) - integer, intent(in) :: iforceh(3,3) - REAL(DP), intent(in) :: frich, delt - logical, intent(in) :: tnoseh, tsdc - - REAL(DP) :: hnos(3,3) - - if( tnoseh ) then - hnos = vnhh * velh - else - hnos = 0.0_DP - end if -! - IF( tsdc ) THEN - call cell_steepest( hnew, h, delt, iforceh, fcell ) - ELSE - call cell_verlet( hnew, h, hold, delt, iforceh, fcell, frich, tnoseh, hnos ) - END IF - - return - end subroutine cell_move - -!------------------------------------------------------------------------------! - - SUBROUTINE cell_gamma( hgamma, ainv, h, velh ) - ! - ! Compute hgamma = g^-1 * dg/dt - ! that enters in the ions equation of motion - ! - IMPLICIT NONE - REAL(DP), INTENT(OUT) :: hgamma(3,3) - REAL(DP), INTENT(IN) :: ainv(3,3), h(3,3), velh(3,3) - REAL(DP) :: gm1(3,3), gdot(3,3) - ! - ! g^-1 inverse of metric tensor = (ht*h)^-1 = ht^-1 * h^-1 - ! - gm1 = MATMUL( ainv, TRANSPOSE( ainv ) ) - ! - ! dg/dt = d(ht*h)/dt = dht/dt*h + ht*dh/dt ! derivative of metrix tensor - ! - gdot = MATMUL( TRANSPOSE( velh ), h ) + MATMUL( TRANSPOSE( h ), velh ) - ! - hgamma = MATMUL( gm1, gdot ) - ! - RETURN - END SUBROUTINE cell_gamma - -!------------------------------------------------------------------------------! - - SUBROUTINE cell_update_vel( htp, ht0, htm, delt, velh ) - ! - IMPLICIT NONE - TYPE (boxdimensions) :: htp, ht0, htm - REAL(DP), INTENT(IN) :: delt - REAL(DP), INTENT(OUT) :: velh( 3, 3 ) - - velh(:,:) = ( htp%hmat(:,:) - htm%hmat(:,:) ) / ( 2.0d0 * delt ) - htp%gvel = ( htp%g(:,:) - htm%g(:,:) ) / ( 2.0d0 * delt ) - ht0%hvel = velh - - RETURN - END SUBROUTINE cell_update_vel - - -!------------------------------------------------------------------------------! - - subroutine cell_kinene( ekinh, temphh, velh ) - use constants, only: k_boltzmann_au - implicit none - REAL(DP), intent(out) :: ekinh, temphh(3,3) - REAL(DP), intent(in) :: velh(3,3) - integer :: i,j - ekinh = 0.0_DP - do j=1,3 - do i=1,3 - ekinh = ekinh + 0.5_DP*wmass*velh(i,j)*velh(i,j) - temphh(i,j) = wmass*velh(i,j)*velh(i,j)/k_boltzmann_au - end do - end do - return - end subroutine cell_kinene - -!------------------------------------------------------------------------------! - - function cell_alat( ) - real(DP) :: cell_alat - if( .NOT. tcell_base_init ) & - call errore( ' cell_alat ', ' alat has not been set ', 1 ) - cell_alat = alat - return - end function cell_alat - -! -!------------------------------------------------------------------------------! - END MODULE cell_base -!------------------------------------------------------------------------------! - - -!------------------------------------------------------------------------------! - MODULE cell_nose -!------------------------------------------------------------------------------! - - USE kinds, ONLY : DP -! - IMPLICIT NONE - SAVE - - REAL(DP) :: xnhh0(3,3) = 0.0_DP - REAL(DP) :: xnhhm(3,3) = 0.0_DP - REAL(DP) :: xnhhp(3,3) = 0.0_DP - REAL(DP) :: vnhh(3,3) = 0.0_DP - REAL(DP) :: temph = 0.0_DP ! Thermostat temperature (from input) - REAL(DP) :: fnoseh = 0.0_DP ! Thermostat frequency (from input) - REAL(DP) :: qnh = 0.0_DP ! Thermostat mass (computed) - -CONTAINS - - subroutine cell_nose_init( temph_init, fnoseh_init ) - USE constants, ONLY: pi, au_terahertz, k_boltzmann_au - REAL(DP), INTENT(IN) :: temph_init, fnoseh_init - ! set thermostat parameter for cell - qnh = 0.0_DP - temph = temph_init - fnoseh = fnoseh_init - if( fnoseh > 0.0_DP ) qnh = 2.0_DP * ( 3 * 3 ) * temph * k_boltzmann_au / & - (fnoseh*(2.0_DP*pi)*au_terahertz)**2 - return - end subroutine cell_nose_init - - subroutine cell_nosezero( vnhh, xnhh0, xnhhm ) - real(DP), intent(out) :: vnhh(3,3), xnhh0(3,3), xnhhm(3,3) - xnhh0=0.0_DP - xnhhm=0.0_DP - vnhh =0.0_DP - return - end subroutine cell_nosezero - - subroutine cell_nosevel( vnhh, xnhh0, xnhhm, delt ) - implicit none - REAL(DP), intent(inout) :: vnhh(3,3) - REAL(DP), intent(in) :: xnhh0(3,3), xnhhm(3,3), delt - vnhh(:,:)=2.0_DP*(xnhh0(:,:)-xnhhm(:,:))/delt-vnhh(:,:) - return - end subroutine cell_nosevel - - subroutine cell_noseupd( xnhhp, xnhh0, xnhhm, delt, qnh, temphh, temph, vnhh ) - use constants, only: k_boltzmann_au - implicit none - REAL(DP), intent(out) :: xnhhp(3,3), vnhh(3,3) - REAL(DP), intent(in) :: xnhh0(3,3), xnhhm(3,3), delt, qnh, temphh(3,3), temph - integer :: i, j - do j=1,3 - do i=1,3 - xnhhp(i,j) = 2.0_DP*xnhh0(i,j)-xnhhm(i,j) + & - (delt**2/qnh)* k_boltzmann_au * (temphh(i,j)-temph) - vnhh(i,j) =(xnhhp(i,j)-xnhhm(i,j))/( 2.0_DP * delt ) - end do - end do - return - end subroutine cell_noseupd - - - REAL(DP) function cell_nose_nrg( qnh, xnhh0, vnhh, temph, iforceh ) - use constants, only: k_boltzmann_au - implicit none - REAL(DP) :: qnh, vnhh( 3, 3 ), temph, xnhh0( 3, 3 ) - integer :: iforceh( 3, 3 ) - integer :: i, j - REAL(DP) :: enij - cell_nose_nrg = 0.0_DP - do i=1,3 - do j=1,3 - enij = 0.5_DP*qnh*vnhh(i,j)*vnhh(i,j)+temph*k_boltzmann_au*xnhh0(i,j) - cell_nose_nrg = cell_nose_nrg + iforceh( i, j ) * enij - enddo - enddo - return - end function cell_nose_nrg - - subroutine cell_nose_shiftvar( xnhhp, xnhh0, xnhhm ) - ! shift values of nose variables to start a new step - implicit none - REAL(DP), intent(out) :: xnhhm(3,3) - REAL(DP), intent(inout) :: xnhh0(3,3) - REAL(DP), intent(in) :: xnhhp(3,3) - xnhhm = xnhh0 - xnhh0 = xnhhp - return - end subroutine cell_nose_shiftvar - - - SUBROUTINE cell_nose_info() - - use constants, only: au_terahertz, pi - use time_step, only: delt - USE io_global, ONLY: stdout - USE control_flags, ONLY: tnoseh - - IMPLICIT NONE - - INTEGER :: nsvar - REAL(DP) :: wnoseh - - IF( tnoseh ) THEN - ! - IF( fnoseh <= 0.0_DP) & - CALL errore(' cell_nose_info ', ' fnoseh less than zero ', 1) - IF( delt <= 0.0_DP) & - CALL errore(' cell_nose_info ', ' delt less than zero ', 1) - - wnoseh = fnoseh * ( 2.0_DP * pi ) * au_terahertz - nsvar = ( 2.0_DP * pi ) / ( wnoseh * delt ) - - WRITE( stdout,563) temph, nsvar, fnoseh, qnh - END IF - - 563 format( //, & - & 3X,'cell dynamics with nose` temperature control:', /, & - & 3X,'Kinetic energy required = ', f10.5, ' (Kelvin) ', /, & - & 3X,'time steps per nose osc. = ', i5, /, & - & 3X,'nose` frequency = ', f10.3, ' (THz) ', /, & - & 3X,'nose` mass(es) = ', 20(1X,f10.3),//) - - RETURN - END SUBROUTINE cell_nose_info - - -! -!------------------------------------------------------------------------------! - END MODULE cell_nose -!------------------------------------------------------------------------------! - diff --git a/quantum_espresso/kcp/Modules/check_stop.f90 b/quantum_espresso/kcp/Modules/check_stop.f90 deleted file mode 100644 index 51a34c30d..000000000 --- a/quantum_espresso/kcp/Modules/check_stop.f90 +++ /dev/null @@ -1,161 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -! ... This module contains functions to check if the code should -! ... be smoothly stopped. -! ... In particular the function check_stop_now returns .TRUE. if -! ... either the user has created a given file or if the -! ... elapsed time is larger than max_seconds -! -!------------------------------------------------------------------------------! -MODULE check_stop -!------------------------------------------------------------------------------! - ! - USE kinds - ! - IMPLICIT NONE - ! - SAVE - ! - REAL(DP) :: max_seconds = 1.E+7_DP - ! - LOGICAL, PRIVATE :: tinit = .FALSE. - ! - REAL(DP) :: init_second - ! - CONTAINS - ! - ! ... internal procedures - ! - !----------------------------------------------------------------------- - SUBROUTINE check_stop_init() - !----------------------------------------------------------------------- - ! - USE input_parameters, ONLY : max_seconds_ => max_seconds - USE io_global, ONLY : meta_ionode, stdout - USE io_files, ONLY : prefix, exit_file, stopunit - ! - IMPLICIT NONE - ! - LOGICAL :: tex - REAL(DP), EXTERNAL :: cclock - ! - IF ( tinit ) & - WRITE( UNIT = stdout, & - FMT = '(/,5X,"WARNING: check_stop already initialized")' ) - ! - ! ... the exit_file name is set here - ! - exit_file = TRIM( prefix ) // '.EXIT' - ! - IF ( max_seconds_ > 0.0_DP ) max_seconds = max_seconds_ - ! - IF ( meta_ionode ) THEN - ! - INQUIRE( FILE = TRIM( exit_file ), EXIST = tex ) - ! - IF ( tex ) THEN - ! - OPEN( stopunit, FILE = TRIM( exit_file ), STATUS = 'OLD' ) - CLOSE( stopunit, STATUS = 'DELETE' ) - ! - END IF - ! - END IF - ! - init_second = cclock() - tinit = .TRUE. - ! - RETURN - ! - END SUBROUTINE check_stop_init - ! - !----------------------------------------------------------------------- - FUNCTION check_stop_now( inunit ) - !----------------------------------------------------------------------- - ! - USE mp, ONLY : mp_bcast - USE mp_global, ONLY : intra_image_comm - USE io_global, ONLY : ionode, ionode_id, meta_ionode, stdout - USE io_files, ONLY : exit_file, stopunit, iunexit - ! KNK_image - ! USE mp_global, ONLY : mpime, root, world_comm - ! - IMPLICIT NONE - ! - INTEGER, OPTIONAL, INTENT(IN) :: inunit - ! - INTEGER :: unit - LOGICAL :: check_stop_now, tex - REAL(DP) :: seconds - REAL(DP), EXTERNAL :: cclock - ! - ! - ! ... cclock is a C function returning the elapsed solar - ! ... time in seconds since the Epoch ( 00:00:00 1/1/1970 ) - ! - IF ( .NOT. tinit ) & - CALL errore( 'check_stop_now', 'check_stop not initialized', 1 ) - ! - unit = stdout - IF ( PRESENT( inunit ) ) unit = inunit - ! - check_stop_now = .FALSE. - ! - ! KNK_image - ! IF ( mpime == root ) THEN - IF ( ionode ) THEN - ! - INQUIRE( FILE = TRIM( exit_file ), EXIST = tex ) - ! - IF ( tex ) THEN - ! - check_stop_now = .TRUE. - ! - OPEN( UNIT = iunexit, FILE = TRIM( exit_file ) ) - CLOSE( UNIT = iunexit, STATUS = 'DELETE' ) - ! - ELSE - ! - seconds = cclock() - init_second - ! - check_stop_now = ( seconds > max_seconds ) - ! - END IF - ! - END IF - ! - ! KNK_image - ! CALL mp_bcast( check_stop_now, root, world_comm ) - CALL mp_bcast( check_stop_now, ionode_id, intra_image_comm ) - ! - IF ( check_stop_now .AND. meta_ionode ) THEN - ! - IF ( tex ) THEN - ! - WRITE( UNIT = unit, & - FMT = '(/,5X,"Program stopped by user request")' ) - ! - ELSE - ! - WRITE( UNIT = unit, & - FMT = '(/,5X,"Maximum CPU time exceeded")' ) - WRITE( UNIT = unit, & - FMT = '(/,5X,"max_seconds = ",F10.2)' ) max_seconds - WRITE( UNIT = unit, & - FMT = '(5X,"elapsed seconds = ",F10.2)' ) seconds - ! - END IF - ! - END IF - ! - RETURN - ! - END FUNCTION check_stop_now - ! -END MODULE check_stop diff --git a/quantum_espresso/kcp/Modules/clocks.f90 b/quantum_espresso/kcp/Modules/clocks.f90 deleted file mode 100644 index d0c452ec6..000000000 --- a/quantum_espresso/kcp/Modules/clocks.f90 +++ /dev/null @@ -1,546 +0,0 @@ -! -! Copyright (C) 2001-2007 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE mytime - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - ! - IMPLICIT NONE - ! - SAVE - ! - INTEGER, PARAMETER :: maxclock = 100 - REAL(DP), PARAMETER :: notrunning = - 1.0_DP - ! - REAL(DP) :: cputime(maxclock), t0cpu(maxclock) - REAL(DP) :: walltime, t0wall - CHARACTER(LEN=12) :: clock_label(maxclock) - INTEGER :: called(maxclock) - ! - INTEGER :: nclock = 0 - LOGICAL :: no - INTEGER :: trace_depth = 0 - ! -END MODULE mytime -! -!#define __TRACE -!---------------------------------------------------------------------------- -SUBROUTINE init_clocks( go ) - !---------------------------------------------------------------------------- - ! - ! ... flag = .TRUE. : clocks will run - ! ... flag = .FALSE. : only clock #1 will run - ! - USE kinds, ONLY : DP - USE mytime, ONLY : called, t0cpu, cputime, no, notrunning, maxclock, & - clock_label, walltime, t0wall - ! - IMPLICIT NONE - ! - LOGICAL :: go - INTEGER :: n - ! - ! - no = .NOT. go - ! - DO n = 1, maxclock - ! - called(n) = 0 - cputime(n) = 0.0_DP - t0cpu(n) = notrunning - clock_label(n) = ' ' - ! - END DO - ! - t0wall = 0.0_DP - walltime = 0.0_DP - ! - RETURN - ! -END SUBROUTINE init_clocks -! -!---------------------------------------------------------------------------- -SUBROUTINE start_clock( label ) - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - USE mp_global, ONLY : mpime - USE mytime, ONLY : nclock, clock_label, notrunning, no, maxclock, & - t0cpu, t0wall, trace_depth - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*) :: label - ! - CHARACTER(LEN=12) :: label_ - INTEGER :: n - REAL(DP), EXTERNAL :: scnds, cclock - ! -#if defined (__TRACE) - WRITE( stdout, '("mpime = ",I2,", TRACE (depth=",I2,") Start: ",A12)') mpime, trace_depth, label - trace_depth = trace_depth + 1 -#endif - ! - IF ( no .AND. ( nclock == 1 ) ) RETURN - ! - ! ... prevent trouble if label is longer than 12 characters - ! - label_ = TRIM ( label ) - ! - DO n = 1, nclock - ! - IF ( clock_label(n) == label_ ) THEN - ! - ! ... found previously defined clock: check if not already started, - ! ... store in t0cpu the starting time - ! - IF ( t0cpu(n) /= notrunning ) THEN -! WRITE( stdout, '("start_clock: clock # ",I2," for ",A12, & -! & " already started")' ) n, label_ - ELSE -#ifdef __WALLTIME - t0cpu(n) = cclock() -#else - t0cpu(n) = scnds() -#endif - IF ( n == 1 ) t0wall = cclock() - END IF - ! - RETURN - ! - END IF - ! - END DO - ! - ! ... clock not found : add new clock for given label - ! - IF ( nclock == maxclock ) THEN - ! - WRITE( stdout, '("start_clock: Too many clocks! call ignored")' ) - ! - ELSE - ! - nclock = nclock + 1 - clock_label(nclock) = label_ -#ifdef __WALLTIME - t0cpu(nclock) = cclock() -#else - t0cpu(nclock) = scnds() -#endif - IF ( nclock == 1 ) t0wall = cclock() - ! - END IF - ! - RETURN - ! -END SUBROUTINE start_clock -! -!---------------------------------------------------------------------------- -SUBROUTINE stop_clock( label ) - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - USE mp_global, ONLY : mpime - USE mytime, ONLY : no, nclock, clock_label, cputime, walltime, & - notrunning, called, t0cpu, t0wall, trace_depth - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*) :: label - ! - CHARACTER(LEN=12) :: label_ - INTEGER :: n - REAL(DP), EXTERNAL :: scnds, cclock - ! -#if defined (__TRACE) - trace_depth = trace_depth - 1 - WRITE( *, '("mpime = ",I2,", TRACE (depth=",I2,") End: ",A12)') mpime, trace_depth, label -#endif - ! - IF ( no ) RETURN - ! - ! ... prevent trouble if label is longer than 12 characters - ! - label_ = TRIM ( label ) - ! - DO n = 1, nclock - ! - IF ( clock_label(n) == label_ ) THEN - ! - ! ... found previously defined clock : check if properly initialised, - ! ... add elapsed time, increase the counter of calls - ! - IF ( t0cpu(n) == notrunning ) THEN - ! -! WRITE( stdout, '("stop_clock: clock # ",I2," for ",A12, & -! & " not running")' ) n, label - ! - ELSE - ! -#ifdef __WALLTIME - cputime(n) = cputime(n) + cclock() - t0cpu(n) -#else - cputime(n) = cputime(n) + scnds() - t0cpu(n) -#endif - IF ( n == 1 ) walltime = walltime + cclock() - t0wall - t0cpu(n) = notrunning - called(n) = called(n) + 1 - ! - END IF - ! - RETURN - ! - END IF - ! - END DO - ! - ! ... clock not found - ! - WRITE( stdout, '("stop_clock: no clock for ",A12," found !")' ) label - ! - RETURN - ! -END SUBROUTINE stop_clock -! -!---------------------------------------------------------------------------- -SUBROUTINE print_clock( label ) - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - USE mytime, ONLY : nclock, clock_label - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*) :: label - ! - CHARACTER(LEN=12) :: label_ - INTEGER :: n - ! - IF ( label == ' ' ) THEN - ! - WRITE( stdout, * ) - ! - DO n = 1, nclock - ! - CALL print_this_clock( n ) - ! - END DO - ! - ELSE - ! - ! ... prevent trouble if label is longer than 12 characters - ! - label_ = TRIM ( label ) - ! - DO n = 1, nclock - ! - IF ( clock_label(n) == label_ ) THEN - ! - CALL print_this_clock( n ) - ! - EXIT - ! - END IF - ! - END DO - ! - END IF - ! - RETURN - ! -END SUBROUTINE print_clock -! -! !---------------------------------------------------------------------------- -! SUBROUTINE print_clock_to_myfile( label ) -! !---------------------------------------------------------------------------- -! ! -! USE kinds, ONLY : DP -! USE io_global, ONLY : stdout -! USE mytime, ONLY : nclock, clock_label -! ! -! IMPLICIT NONE -! ! -! CHARACTER(LEN=*) :: label -! ! -! CHARACTER(LEN=12) :: label_ -! INTEGER :: n -! ! -! open(unit=40,file='aida.times',access = 'append') -! IF ( label == ' ' ) THEN -! ! -! WRITE( stdout, * ) -! ! -! DO n = 1, nclock -! ! -! CALL print_this_clock( n ) -! ! -! END DO -! ! -! ELSE -! ! -! ! ... prevent trouble if label is longer than 12 characters -! ! -! label_ = TRIM ( label ) -! ! -! DO n = 1, nclock -! ! -! IF ( clock_label(n) == label_ ) THEN -! ! -! CALL print_this_clock( n ) -! ! -! EXIT -! ! -! END IF -! ! -! END DO -! ! -! END IF -! ! -! RETURN -! ! -! END SUBROUTINE print_clock_to_myfile -!---------------------------------------------------------------------------- -SUBROUTINE print_this_clock( n ) - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - USE mytime, ONLY : no, nclock, clock_label, cputime, walltime, & - notrunning, called, t0cpu, t0wall - USE mp, ONLY : mp_max - USE mp_global, ONLY : intra_image_comm, my_image_id - ! - IMPLICIT NONE - ! - INTEGER :: n - REAL(DP) :: elapsed_cpu_time, elapsed_wall_time, nsec, msec - INTEGER :: nday, nhour, nmin, nmax, mday, mhour, mmin - ! - REAL(DP), EXTERNAL :: scnds, cclock - ! - ! - IF ( t0cpu(n) == notrunning ) THEN - ! - ! ... clock stopped, print the stored value for the cpu time - ! - elapsed_cpu_time = cputime(n) - elapsed_wall_time= walltime - ! - ELSE - ! - ! ... clock not stopped, print the current value of the cpu time - ! -#ifdef __WALLTIME - elapsed_cpu_time = cputime(n) + cclock() - t0cpu(n) -#else - elapsed_cpu_time = cputime(n) + scnds() - t0cpu(n) -#endif - elapsed_wall_time = walltime + cclock() - t0wall - ! - END If - ! - nmax = called(n) - ! - ! ... In the parallel case there are several possible approaches - ! ... The safest one is to leave each clock independent from the others - ! ... Another possibility is to print the maximum across all processors - ! ... This is done by uncommenting the following lines - ! - ! CALL mp_max( elapsed_cpu_time, intra_image_comm ) - ! CALL mp_max( elapsed_wall_time, intra_image_comm ) - ! CALL mp_max( nmax, intra_image_comm ) - ! - ! ... In the last line we assume that the maximum cpu time - ! ... is associated to the maximum number of calls - ! ... NOTA BENE: by uncommenting the above lines you may run into - ! ... serious trouble if clocks are not started on all nodes - ! - IF ( n == 1 ) THEN - ! - ! ... The first clock is written as days/hour/min/sec - ! - nday = elapsed_cpu_time / 86400 - nsec = elapsed_cpu_time - 86400 * nday - nhour = nsec / 3600 - nsec = nsec - 3600 * nhour - nmin = nsec / 60 - nsec = nsec - 60 * nmin - ! - ! ... The first clock writes elapsed (wall) time as well - ! - mday = elapsed_wall_time / 86400 - msec = elapsed_wall_time - 86400 * mday - mhour = msec / 3600 - msec = msec - 3600 * mhour - mmin = msec / 60 - msec = msec - 60 * mmin - ! - IF ( nday > 0 .OR. mday > 0 ) THEN - ! -#ifdef __WALLTIME - WRITE( stdout, & - '(5X,A12," : ",3X,I2,"d",3X,I2,"h",I2, "m wall time"/)' ) & - clock_label(n), mday, mhour, mmin -#else - WRITE( stdout, & - '(5X,A12," : ",3X,I2,"d",3X,I2,"h",I2, "m CPU time, ", & - & " ",3X,I2,"d",3X,I2,"h",I2, "m wall time"/)' ) & - clock_label(n), nday, nhour, nmin, mday, mhour, mmin -#endif - ! - ELSE IF ( nhour > 0 .OR. mhour > 0 ) THEN - ! -#ifdef __WALLTIME - WRITE( stdout, & - '(5X,A12," : ",3X,I2,"h",I2,"m wall time"/)' ) & - clock_label(n), mhour, mmin -#else - WRITE( stdout, & - '(5X,A12," : ",3X,I2,"h",I2,"m CPU time, ", & - & " ",3X,I2,"h",I2,"m wall time"/)' ) & - clock_label(n), nhour, nmin, mhour, mmin -#endif - ! - ELSE IF ( nmin > 0 .OR. mmin > 0 ) THEN - ! -#ifdef __WALLTIME - WRITE( stdout, & - '(5X,A12," : ",I2,"m",F5.2,"s wall time"/)' ) & - clock_label(n), mmin, msec -#else - WRITE( stdout, & - '(5X,A12," : ",I2,"m",F5.2,"s CPU time, ", & - & " ",I2,"m",F5.2,"s wall time"/)' ) & - clock_label(n), nmin, nsec, mmin, msec -#endif - ! - ELSE - ! -#ifdef __WALLTIME - WRITE( stdout, & - '(5X,A12," : ",3X,F5.2,"s wall time"/)' )& - clock_label(n), msec -#else - WRITE( stdout, & - '(5X,A12," : ",3X,F5.2,"s CPU time,",3X,F5.2,"s wall time"/)' )& - clock_label(n), nsec, msec -#endif - ! - END IF - ! - ELSE IF ( nmax == 1 .OR. t0cpu(n) /= notrunning ) THEN - ! - ! ... for clocks that have been called only once - ! - WRITE( stdout, & - '(5X,A12," :",F9.2,"s CPU")') clock_label(n), elapsed_cpu_time - ! - ELSE IF ( nmax == 0 ) THEN - ! - ! ... for clocks that have never been called - ! - WRITE( stdout, & - '("print_this: clock # ",I2," for ",A12," never called !")' ) & - n, clock_label(n) - ! - ELSE - ! - ! ... for all other clocks - ! - WRITE( stdout, & - '(5X,A12," :",F9.2,"s CPU (",I8," calls,",F8.3," s avg)")' ) & - clock_label(n), elapsed_cpu_time, & - nmax, ( elapsed_cpu_time / nmax ) - ! - END IF - ! - RETURN - ! -END SUBROUTINE print_this_clock -! -!---------------------------------------------------------------------------- -FUNCTION get_clock( label ) - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - USE mytime, ONLY : no, nclock, clock_label, cputime, & - notrunning, called, t0cpu - USE mp, ONLY : mp_max - USE mp_global, ONLY : intra_image_comm - ! - IMPLICIT NONE - ! - REAL(DP) :: get_clock - CHARACTER(LEN=*) :: label - INTEGER :: n - ! - REAL(DP), EXTERNAL :: scnds, cclock - ! - ! - IF ( no ) THEN - ! - IF ( label == clock_label(1) ) THEN - ! -#ifdef __WALLTIME - get_clock = cclock() -#else - get_clock = scnds() -#endif - ! - ELSE - ! - get_clock = notrunning - ! - END IF - ! - RETURN - ! - END IF - ! - DO n = 1, nclock - ! - IF ( label == clock_label(n) ) THEN - ! - IF ( t0cpu(n) == notrunning ) THEN - ! - get_clock = cputime(n) - ! - ELSE - ! -#ifdef __WALLTIME - get_clock = cputime(n) + cclock() - t0cpu(n) -#else - get_clock = cputime(n) + scnds() - t0cpu(n) -#endif - ! - END IF - ! - ! ... See comments in subroutine print_this_clock - ! - ! CALL mp_max( get_clock, intra_image_comm ) - ! - RETURN - ! - END IF - ! - END DO - ! - ! ... clock not found - ! - get_clock = notrunning - ! - WRITE( stdout, '("get_clock: no clock for ",A12," found !")') label - ! - RETURN - ! -END FUNCTION get_clock diff --git a/quantum_espresso/kcp/Modules/compute_dipole.f90 b/quantum_espresso/kcp/Modules/compute_dipole.f90 deleted file mode 100644 index 96bee6622..000000000 --- a/quantum_espresso/kcp/Modules/compute_dipole.f90 +++ /dev/null @@ -1,248 +0,0 @@ -! -! Copyright (C) 2007-2010 Quantum ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! ... original code written by Giovanni Cantele and Paolo Cazzato -! ... adapted to work in the parallel case by Carlo Sbraccia -! ... originally part of the makov_payne.f90 file -! ... adapted to accept any kind of density by Oliviero Andreussi -! -!-------------------------------------------------------------------- -SUBROUTINE compute_dipole( nnr, nspin, rho, r0, dipole, quadrupole ) -!-------------------------------------------------------------------- - USE kinds, ONLY : DP - USE cell_base, ONLY : at, bg, alat, omega - USE fft_base, ONLY : dfftp - USE mp_global, ONLY : me_image, intra_image_comm - USE mp, ONLY : mp_sum - ! - IMPLICIT NONE - ! - ! ... Define variables - ! - ! nnr is passed in input, but nnr should match dfftp%nnr - ! for the calculation to be meaningful - INTEGER, INTENT(IN) :: nnr, nspin - REAL(DP), INTENT(IN) :: rho( nnr, nspin ) - REAL(DP), INTENT(IN) :: r0(3) - REAL(DP), INTENT(OUT) :: dipole(0:3), quadrupole - ! - ! ... Local variables - ! - REAL(DP) :: r(3), rhoir - INTEGER :: i, j, k, ip, ir, ir_end, index, index0 - REAL(DP) :: inv_nr1, inv_nr2, inv_nr3 - ! - ! ... Initialization - ! - inv_nr1 = 1.D0 / DBLE( dfftp%nr1 ) - inv_nr2 = 1.D0 / DBLE( dfftp%nr2 ) - inv_nr3 = 1.D0 / DBLE( dfftp%nr3 ) - ! - dipole(:) = 0.D0 - quadrupole = 0.D0 - ! - index0 = 0 - ! -#if defined (__MPI) - DO i = 1, me_image - index0 = index0 + dfftp%nr1x*dfftp%nr2x*dfftp%npp(i) - END DO -#endif - ! -#if defined (__MPI) - ir_end = MIN(nnr,dfftp%nr1x*dfftp%nr2x*dfftp%npp(me_image+1)) -#else - ir_end = nnr -#endif - ! - DO ir = 1, ir_end - ! - ! ... three dimensional indexes - ! - index = index0 + ir - 1 - k = index / (dfftp%nr1x*dfftp%nr2x) - index = index - (dfftp%nr1x*dfftp%nr2x)*k - j = index / dfftp%nr1x - index = index - dfftp%nr1x*j - i = index - ! - DO ip = 1, 3 - r(ip) = DBLE( i )*inv_nr1*at(ip,1) + & - DBLE( j )*inv_nr2*at(ip,2) + & - DBLE( k )*inv_nr3*at(ip,3) - END DO - ! - r(:) = r(:) - r0(:) - ! - ! ... minimum image convention - ! - CALL cryst_to_cart( 1, r, bg, -1 ) - ! - r(:) = r(:) - ANINT( r(:) ) - ! - CALL cryst_to_cart( 1, r, at, 1 ) - ! - rhoir = rho( ir, 1 ) - ! - IF ( nspin == 2 ) rhoir = rhoir + rho(ir,2) - ! - ! ... dipole(0) = charge density - ! - dipole(0) = dipole(0) + rhoir - ! - DO ip = 1, 3 - ! - dipole(ip) = dipole(ip) + rhoir*r(ip) - quadrupole = quadrupole + rhoir*r(ip)**2 - ! - END DO - ! - END DO - ! - CALL mp_sum( dipole(0:3) , intra_image_comm ) - CALL mp_sum( quadrupole , intra_image_comm ) - ! - dipole(0) = dipole(0)*omega / DBLE( dfftp%nr1*dfftp%nr2*dfftp%nr3 ) - ! - DO ip = 1, 3 - dipole(ip) = dipole(ip)*omega / DBLE( dfftp%nr1*dfftp%nr2*dfftp%nr3 ) * alat - END DO - ! - quadrupole = quadrupole*omega / DBLE( dfftp%nr1*dfftp%nr2*dfftp%nr3 ) * alat**2 - ! - RETURN - ! -!---------------------------------------------------------------------------- - END SUBROUTINE compute_dipole -!---------------------------------------------------------------------------- - -!-------------------------------------------------------------------- -SUBROUTINE compute_wan_multipoles( nnr, nspin, rho, r0, dipole, quadrupole ) -!-------------------------------------------------------------------- - USE kinds, ONLY : DP - USE cell_base, ONLY : at, bg, alat, omega - USE fft_base, ONLY : dfftp - USE mp_global, ONLY : me_image, intra_image_comm - USE mp, ONLY : mp_sum - ! - IMPLICIT NONE - ! - ! ... Define variables - ! - ! nnr is passed in input, but nnr should match dfftp%nnr - ! for the calculation to be meaningful - INTEGER, INTENT(IN) :: nnr, nspin - REAL(DP), INTENT(IN) :: rho( nnr, nspin ) - REAL(DP), INTENT(IN) :: r0(3) - REAL(DP), INTENT(OUT) :: dipole(0:3), quadrupole(1:3,1:3) - ! - ! ... Local variables - ! - REAL(DP) :: r(3), rhoir - INTEGER :: i, j, k, ip, ipp, ir, ir_end, index, index0 - REAL(DP) :: inv_nr1, inv_nr2, inv_nr3 - ! - ! ... Initialization - ! - inv_nr1 = 1.D0 / DBLE( dfftp%nr1 ) - inv_nr2 = 1.D0 / DBLE( dfftp%nr2 ) - inv_nr3 = 1.D0 / DBLE( dfftp%nr3 ) - ! - dipole(:) = 0.D0 - quadrupole = 0.D0 - ! - index0 = 0 - ! -#if defined (__MPI) - DO i = 1, me_image - index0 = index0 + dfftp%nr1x*dfftp%nr2x*dfftp%npp(i) - END DO -#endif - ! -#if defined (__MPI) - ir_end = MIN(nnr,dfftp%nr1x*dfftp%nr2x*dfftp%npp(me_image+1)) -#else - ir_end = nnr -#endif - ! - DO ir = 1, ir_end - ! - ! ... three dimensional indexes - ! - index = index0 + ir - 1 - k = index / (dfftp%nr1x*dfftp%nr2x) - index = index - (dfftp%nr1x*dfftp%nr2x)*k - j = index / dfftp%nr1x - index = index - dfftp%nr1x*j - i = index - ! - DO ip = 1, 3 - r(ip) = DBLE( i )*inv_nr1*at(ip,1) + & - DBLE( j )*inv_nr2*at(ip,2) + & - DBLE( k )*inv_nr3*at(ip,3) - END DO - ! - r(:) = r(:) - r0(:) - ! - ! ... minimum image convention - ! - CALL cryst_to_cart( 1, r, bg, -1 ) - ! - r(:) = r(:) - ANINT( r(:) ) - ! - CALL cryst_to_cart( 1, r, at, 1 ) - ! - rhoir = rho( ir, 1 ) - ! - IF ( nspin == 2 ) rhoir = rhoir + rho(ir,2) - ! - ! ... dipole(0) = charge density - ! - dipole(0) = dipole(0) + rhoir - ! - DO ip = 1, 3 - ! - dipole(ip) = dipole(ip) + rhoir*r(ip) - ! - DO ipp = 1, ip - ! - quadrupole(ipp,ip) = quadrupole(ipp,ip) + rhoir*r(ip)*r(ipp) - ! - ENDDO - ! - END DO - ! - END DO - ! - CALL mp_sum( dipole(0:3) , intra_image_comm ) - CALL mp_sum( quadrupole , intra_image_comm ) - ! - ! Divinding by the unit of volume and setting the units for dipole - ! - dipole(0) = dipole(0)*omega / DBLE( dfftp%nr1*dfftp%nr2*dfftp%nr3 ) - ! - DO ip = 1, 3 - dipole(ip) = dipole(ip)*omega / DBLE( dfftp%nr1*dfftp%nr2*dfftp%nr3 ) * alat - END DO - ! - ! Symmetrizing, dividing by the unit of volume, centering, and setting the units for quadrupole - ! - DO ip = 1, 3 - DO ipp = 1, ip - ! - quadrupole(ipp,ip) = quadrupole(ipp,ip)*omega / DBLE( dfftp%nr1*dfftp%nr2*dfftp%nr3 ) * alat**2 & - -dipole(ipp)*dipole(ip) - quadrupole(ip,ipp) = quadrupole(ipp,ip) - ! - ENDDO - ENDDO - ! - RETURN - ! -!---------------------------------------------------------------------------- - END SUBROUTINE compute_wan_multipoles -!---------------------------------------------------------------------------- diff --git a/quantum_espresso/kcp/Modules/constants.f90 b/quantum_espresso/kcp/Modules/constants.f90 deleted file mode 100644 index 7b27ff41f..000000000 --- a/quantum_espresso/kcp/Modules/constants.f90 +++ /dev/null @@ -1,146 +0,0 @@ -! -! Copyright (C) 2002-2006 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE constants - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - ! - ! ... The constants needed everywhere - ! - IMPLICIT NONE - ! - SAVE - ! - ! ... Mathematical constants - ! - REAL(DP), PARAMETER :: pi = 3.14159265358979323846_DP - REAL(DP), PARAMETER :: tpi = 2.0_DP * pi - REAL(DP), PARAMETER :: fpi = 4.0_DP * pi - REAL(DP), PARAMETER :: sqrtpi = 1.77245385090551602729_DP - REAL(DP), PARAMETER :: sqrtpm1= 1.0_DP / sqrtpi - REAL(DP), PARAMETER :: sqrt2 = 1.41421356237309504880_DP - ! - COMPLEX(DP), PARAMETER :: CI = (0.0_DP,1.0_DP) - ! - ! ... Physical constants, SI (NIST 2018) - ! http://physics.nist.gov/constants - ! - REAL(DP), PARAMETER :: H_PLANCK_SI = 6.62607015E-34_DP ! J s - REAL(DP), PARAMETER :: K_BOLTZMANN_SI = 1.380649E-23_DP ! J K^-1 - REAL(DP), PARAMETER :: ELECTRON_SI = 1.602176634E-19_DP ! C - REAL(DP), PARAMETER :: ELECTRONVOLT_SI = 1.602176634E-19_DP ! J - REAL(DP), PARAMETER :: ELECTRONMASS_SI = 9.1093837015E-31_DP ! Kg - REAL(DP), PARAMETER :: HARTREE_SI = 4.3597447222071E-18_DP ! J - REAL(DP), PARAMETER :: RYDBERG_SI = HARTREE_SI/2.0_DP ! J - REAL(DP), PARAMETER :: BOHR_RADIUS_SI = 0.529177210903E-10_DP ! m - REAL(DP), PARAMETER :: AMU_SI = 1.66053906660E-27_DP ! Kg - REAL(DP), PARAMETER :: C_SI = 2.99792458E+8_DP ! m sec^-1 - ! - ! ... Physical constants, atomic units: - ! ... AU for "Hartree" atomic units (e = m = hbar = 1) - ! ... RY for "Rydberg" atomic units (e^2=2, m=1/2, hbar=1) - ! - REAL(DP), PARAMETER :: K_BOLTZMANN_AU = K_BOLTZMANN_SI / HARTREE_SI - REAL(DP), PARAMETER :: K_BOLTZMANN_RY = K_BOLTZMANN_SI / RYDBERG_SI - ! - ! ... Unit conversion factors: energy and masses - ! - REAL(DP), PARAMETER :: AUTOEV = HARTREE_SI / ELECTRONVOLT_SI - REAL(DP), PARAMETER :: RYTOEV = AUTOEV / 2.0_DP - REAL(DP), PARAMETER :: AMU_AU = AMU_SI / ELECTRONMASS_SI - REAL(DP), PARAMETER :: AMU_RY = AMU_AU / 2.0_DP - ! - ! ... Unit conversion factors: atomic unit of time, in s and ps - ! - REAL(DP), PARAMETER :: AU_SEC = H_PLANCK_SI/tpi/HARTREE_SI - REAL(DP), PARAMETER :: AU_PS = AU_SEC * 1.0E+12_DP - ! - ! ... Unit conversion factors: pressure (1 Pa = 1 J/m^3, 1GPa = 10 Kbar ) - ! - REAL(DP), PARAMETER :: AU_GPA = HARTREE_SI / BOHR_RADIUS_SI ** 3 & - / 1.0E+9_DP - REAL(DP), PARAMETER :: RY_KBAR = 10.0_DP * AU_GPA / 2.0_DP - ! - ! ... Unit conversion factors: 1 debye = 10^-18 esu*cm - ! ... = 3.3356409519*10^-30 C*m - ! ... = 0.208194346 e*A - ! ... ( 1 esu = (0.1/c) Am, c=299792458 m/s) - ! - REAL(DP), PARAMETER :: DEBYE_SI = 3.3356409519_DP * 1.0E-30_DP ! C*m - REAL(DP), PARAMETER :: AU_DEBYE = ELECTRON_SI * BOHR_RADIUS_SI / & - DEBYE_SI - ! - REAL(DP), PARAMETER :: eV_to_kelvin = ELECTRONVOLT_SI / K_BOLTZMANN_SI - REAL(DP), PARAMETER :: ry_to_kelvin = RYDBERG_SI / K_BOLTZMANN_SI - ! - ! Speed of light in atomic units - ! - REAL(DP), PARAMETER :: C_AU = C_SI / BOHR_RADIUS_SI * AU_SEC - ! - ! ... zero up to a given accuracy - ! - REAL(DP), PARAMETER :: eps4 = 1.0E-4_DP - REAL(DP), PARAMETER :: eps6 = 1.0E-6_DP - REAL(DP), PARAMETER :: eps8 = 1.0E-8_DP - REAL(DP), PARAMETER :: eps12 = 1.0E-12_DP - REAL(DP), PARAMETER :: eps14 = 1.0E-14_DP - REAL(DP), PARAMETER :: eps16 = 1.0E-16_DP - REAL(DP), PARAMETER :: eps24 = 1.0E-24_DP - REAL(DP), PARAMETER :: eps32 = 1.0E-32_DP - ! - REAL(DP), PARAMETER :: gsmall = 1.0E-12_DP - ! - REAL(DP), PARAMETER :: e2 = 2.0_DP ! the square of the electron charge - REAL(DP), PARAMETER :: degspin = 2.0_DP ! the number of spins per level - ! - !!!!!! COMPATIBIILITY - ! - REAL(DP), PARAMETER :: amconv = AMU_RY - REAL(DP), PARAMETER :: uakbar = RY_KBAR - REAL(DP), PARAMETER :: bohr_radius_cm = bohr_radius_si * 100.0_DP - REAL(DP), PARAMETER :: BOHR_RADIUS_ANGS = bohr_radius_cm * 1.0E8_DP - REAL(DP), PARAMETER :: ANGSTROM_AU = 1.0_DP/BOHR_RADIUS_ANGS - REAL(DP), PARAMETER :: DIP_DEBYE = AU_DEBYE - REAL(DP), PARAMETER :: AU_TERAHERTZ = AU_PS - REAL(DP), PARAMETER :: AU_TO_OHMCMM1 = 46000.0_DP ! (ohm cm)^-1 - ! - -END MODULE constants - -! perl script to create a program to list the available constants: -! extract with: grep '^!XX!' constants.f90 | sed 's,!XX!,,' > mkconstlist.pl -! then run: perl mkconstlist.pl constants.f90 > testme.f90 -! and compile and run: testme.f90 -!XX!#!/usr/bin/perl -w -!XX! -!XX!use strict; -!XX! -!XX!print <) { -!XX! if ( /REAL\s*\(DP\)\s*,\s*PARAMETER\s*::\s*([a-zA-Z_0-9]+)\s*=.*$/ ) { -!XX! print " WRITE (*,'(A18,G24.17)') '$1:',$1\n"; -!XX! } -!XX!} -!XX! -!XX!print < constr_target - USE input_parameters, ONLY : nconstr_inp, constr_tol_inp, & - ncolvar_inp, colvar_tol_inp, & - constr_type_inp, constr_inp, & - colvar_type_inp, colvar_inp, & - constr_target_set, colvar_target, & - colvar_target_set, nc_fields - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nat - REAL(DP), INTENT(IN) :: tau(3,nat) - INTEGER, INTENT(IN) :: ityp(nat) - REAL(DP), INTENT(IN) :: tau_units - ! - INTEGER :: i, j - INTEGER :: n, ia, ia0, ia1, ia2, ia3, n_type_coord1 - REAL(DP) :: d0(3), d1(3), d2(3) - REAL(DP) :: C00, C01, C02, C11, C12, C22 - REAL(DP) :: D01, D12 - REAL(DP) :: smoothing, r_c - INTEGER :: type_coord1, type_coord2 - REAL(DP) :: dtau(3), norm_dtau - REAL(DP) :: k(3), phase, norm_k - COMPLEX(DP) :: struc_fac - ! - CHARACTER(LEN=6), EXTERNAL :: int_to_char - ! - ! - nconstr = ncolvar_inp + nconstr_inp - ! - ! Be careful about what tolerance we want - ! - if (( ncolvar_inp > 0 ) .and. ( nconstr_inp == 0)) & - constr_tol = colvar_tol_inp - if (( ncolvar_inp == 0 ) .and. ( nconstr_inp > 0)) & - constr_tol = constr_tol_inp - if (( ncolvar_inp > 0 ) .and. ( nconstr_inp > 0)) & - constr_tol = MAX( constr_tol_inp, colvar_tol_inp ) - ! - ALLOCATE( lagrange( nconstr ) ) - ALLOCATE( constr_target( nconstr ) ) - ALLOCATE( constr_type( nconstr ) ) - ! - ALLOCATE( constr( nc_fields, nconstr ) ) - ALLOCATE( gp( nconstr ) ) - ! - ! ... setting constr to 0 to findout which elements have been - ! ... set to an atomic index. This is required for CP. - ! - constr = 0.0_DP - ! - ! ... NB: the first "ncolvar" constraints are collective variables (used - ! ... for meta-dynamics and free-energy smd), the remaining are real - ! ... constraints - ! - if (ncolvar_inp > 0) & - constr(:,1:ncolvar_inp) = colvar_inp(:,1:ncolvar_inp) - if (nconstr_inp > 0) & - constr(:,ncolvar_inp+1:nconstr) = constr_inp(:,1:nconstr_inp) - ! - ! ... set the largest possible distance among two atoms within - ! ... the supercell - ! - IF ( ncolvar_inp > 0 ) THEN - ! - IF ( ANY( colvar_type_inp(:) == 'distance' ) ) CALL compute_dmax() - ! - ELSE IF ( nconstr_inp > 0 ) THEN - ! - IF ( ANY( constr_type_inp(:) == 'distance' ) ) CALL compute_dmax() - ! - END IF - ! - ! ... initializations of constr_target values for the constraints : - ! - ! ... first the initialization of the collective variables - ! - DO ia = 1, ncolvar_inp - ! - SELECT CASE ( colvar_type_inp(ia) ) - CASE( 'type_coord' ) - ! - ! ... constraint on global coordination-number, i.e. the average - ! ... number of atoms of type B surrounding the atoms of type A - ! - constr_type(ia) = 1 - ! - IF ( colvar_target_set(ia) ) THEN - ! - constr_target(ia) = colvar_target(ia) - ! - CYCLE - ! - ELSE - ! - CALL set_type_coord( ia ) - ! - END IF - ! - CASE( 'atom_coord' ) - ! - ! ... constraint on local coordination-number, i.e. the average - ! ... number of atoms of type A surrounding a specific atom - ! - constr_type(ia) = 2 - ! - IF ( colvar_target_set(ia) ) THEN - ! - constr_target(ia) = colvar_target(ia) - ! - CYCLE - ! - ELSE - ! - CALL set_atom_coord( ia ) - ! - END IF - ! - CASE( 'distance' ) - ! - constr_type(ia) = 3 - ! - IF ( colvar_target_set(ia) ) THEN - ! - constr_target(ia) = colvar_target(ia) - ! - ELSE - ! - ia1 = ANINT( constr(1,ia) ) - ia2 = ANINT( constr(2,ia) ) - ! - dtau(:) = pbc( ( tau(:,ia1) - tau(:,ia2) )*tau_units ) - ! - constr_target(ia) = norm( dtau(:) ) - ! - END IF - ! - IF ( constr_target(ia) > dmax ) THEN - ! - WRITE( stdout, '(/,5X,"target = ",F12.8,/, & - & 5X,"dmax = ",F12.8)' ) & - constr_target(ia), dmax - ! - CALL errore( 'init_constraint', 'the target for coll.var. ' //& - & TRIM( int_to_char( ia ) ) // ' is larger than ' //& - & 'the largest possible value', 1 ) - ! - END IF - ! - CASE( 'planar_angle' ) - ! - ! ... constraint on planar angle (for the notation used here see - ! ... Appendix C of the Allen-Tildesley book) - ! - constr_type(ia) = 4 - ! - IF ( colvar_target_set(ia) ) THEN - ! - ! ... the input value of target for the torsional angle (given - ! ... in degrees) is converted to the cosine of the angle - ! - constr_target(ia) = COS( ( 180.0_DP - & - colvar_target(ia) )*tpi/360.0_DP ) - ! - CYCLE - ! - ELSE - ! - CALL set_planar_angle( ia ) - ! - END IF - ! - CASE( 'torsional_angle' ) - ! - ! ... constraint on torsional angle (for the notation used here - ! ... see Appendix C of the Allen-Tildesley book) - ! - constr_type(ia) = 5 - ! - IF ( colvar_target_set(ia) ) THEN - ! - ! ... the input value of target for the torsional angle (given - ! ... in degrees) is converted to the cosine of the angle - ! - constr_target(ia) = COS( colvar_target(ia)*tpi/360.0_DP ) - ! - CYCLE - ! - ELSE - ! - CALL set_torsional_angle( ia ) - ! - END IF - ! - CASE( 'struct_fac' ) - ! - ! ... constraint on structure factor at a given k-vector - ! - constr_type(ia) = 6 - ! - IF ( colvar_target_set(ia) ) THEN - ! - constr_target(ia) = colvar_target(ia) - ! - CYCLE - ! - ELSE - ! - CALL set_structure_factor( ia ) - ! - END IF - ! - CASE( 'sph_struct_fac' ) - ! - ! ... constraint on spherical average of the structure factor for - ! ... a given k-vector of norm k - ! - constr_type(ia) = 7 - ! - IF ( colvar_target_set(ia) ) THEN - ! - constr_target(ia) = colvar_target(ia) - ! - CYCLE - ! - ELSE - ! - CALL set_sph_structure_factor( ia ) - ! - END IF - ! - CASE( 'bennett_proj' ) - ! - ! ... constraint on the projection onto a given direction of the - ! ... vector defined by the position of one atom minus the center - ! ... of mass of the others - ! ... ( Ch.H. Bennett in Diffusion in Solids, Recent Developments, - ! ... Ed. by A.S. Nowick and J.J. Burton, New York 1975 ) - ! - constr_type(ia) = 8 - ! - IF ( colvar_target_set(ia) ) THEN - ! - constr_target(ia) = colvar_target(ia) - ! - CYCLE - ! - ELSE - ! - CALL set_bennett_proj( ia ) - ! - END IF - ! - CASE DEFAULT - ! - CALL errore( 'init_constraint', & - 'collective-variable type not implemented', 1 ) - ! - END SELECT - ! - END DO - ! - ! ... then then the initialization of the real constraints - ! - DO n = 1, nconstr_inp - ! - ia = ncolvar_inp + n - ! - SELECT CASE ( constr_type_inp(n) ) - CASE( 'type_coord' ) - ! - ! ... constraint on global coordination-number, i.e. the average - ! ... number of atoms of type B surrounding the atoms of type A - ! - constr_type(ia) = 1 - ! - IF ( constr_target_set(n) ) THEN - ! - constr_target(ia) = constr_target_(n) - ! - CYCLE - ! - ELSE - ! - CALL set_type_coord( ia ) - ! - END IF - ! - CASE( 'atom_coord' ) - ! - ! ... constraint on local coordination-number, i.e. the average - ! ... number of atoms of type A surrounding a specific atom - ! - constr_type(ia) = 2 - ! - IF ( constr_target_set(n) ) THEN - ! - constr_target(ia) = constr_target_(n) - ! - CYCLE - ! - ELSE - ! - CALL set_atom_coord( ia ) - ! - END IF - ! - CASE( 'distance' ) - ! - constr_type(ia) = 3 - ! - IF ( constr_target_set(n) ) THEN - ! - constr_target(ia) = constr_target_(n) - ! - ELSE - ! - ia1 = ANINT( constr(1,ia) ) - ia2 = ANINT( constr(2,ia) ) - ! - dtau(:) = pbc( ( tau(:,ia1) - tau(:,ia2) )*tau_units ) - ! - constr_target(ia) = norm( dtau(:) ) - ! - END IF - ! - IF ( constr_target(ia) > dmax ) THEN - ! - WRITE( stdout, '(/,5X,"target = ",F12.8,/, & - & 5X,"dmax = ",F12.8)' ) & - constr_target(ia), dmax - ! - CALL errore( 'init_constraint', 'the target for constraint ' //& - & TRIM( int_to_char( n ) ) // ' is larger than ' //& - & 'the largest possible value', 1 ) - ! - END IF - ! - CASE( 'planar_angle' ) - ! - ! ... constraint on planar angle (for the notation used here see - ! ... Appendix C of the Allen-Tildesley book) - ! - constr_type(ia) = 4 - ! - IF ( constr_target_set(n) ) THEN - ! - ! ... the input value of target for the torsional angle (given - ! ... in degrees) is converted to the cosine of the angle - ! - constr_target(ia) = COS( ( 180.0_DP - & - constr_target_(n) )*tpi/360.0_DP ) - ! - CYCLE - ! - ELSE - ! - CALL set_planar_angle( ia ) - ! - END IF - ! - CASE( 'torsional_angle' ) - ! - ! ... constraint on torsional angle (for the notation used here - ! ... see Appendix C of the Allen-Tildesley book) - ! - constr_type(ia) = 5 - ! - IF ( constr_target_set(n) ) THEN - ! - ! ... the input value of target for the torsional angle (given - ! ... in degrees) is converted to the cosine of the angle - ! - constr_target(ia) = COS( constr_target_(n)*tpi/360.0_DP ) - ! - CYCLE - ! - ELSE - ! - CALL set_torsional_angle( ia ) - ! - END IF - ! - CASE( 'struct_fac' ) - ! - ! ... constraint on structure factor at a given k-vector - ! - constr_type(ia) = 6 - ! - IF ( constr_target_set(n) ) THEN - ! - constr_target(ia) = constr_target_(n) - ! - CYCLE - ! - ELSE - ! - CALL set_structure_factor( ia ) - ! - END IF - ! - CASE( 'sph_struct_fac' ) - ! - ! ... constraint on spherical average of the structure factor for - ! ... a given k-vector of norm k - ! - constr_type(ia) = 7 - ! - IF ( constr_target_set(n) ) THEN - ! - constr_target(ia) = constr_target_(n) - ! - CYCLE - ! - ELSE - ! - CALL set_sph_structure_factor( ia ) - ! - END IF - ! - CASE( 'bennett_proj' ) - ! - ! ... constraint on the projection onto a given direction of the - ! ... vector defined by the position of one atom minus the center - ! ... of mass of the others - ! ... ( Ch.H. Bennett in Diffusion in Solids, Recent Developments, - ! ... Ed. by A.S. Nowick and J.J. Burton, New York 1975 ) - ! - constr_type(ia) = 8 - ! - IF ( constr_target_set(n) ) THEN - ! - constr_target(ia) = constr_target_(n) - ! - CYCLE - ! - ELSE - ! - CALL set_bennett_proj( ia ) - ! - END IF - ! - CASE DEFAULT - ! - CALL errore( 'init_constraint', & - 'constraint type not implemented', 1 ) - ! - END SELECT - ! - END DO - ! - RETURN - ! - CONTAINS - ! - !------------------------------------------------------------------- - SUBROUTINE set_type_coord( ia ) - !------------------------------------------------------------------- - ! - INTEGER, INTENT(IN) :: ia - ! - type_coord1 = ANINT( constr(1,ia) ) - type_coord2 = ANINT( constr(2,ia) ) - ! - r_c = constr(3,ia) - ! - smoothing = 1.0_DP / constr(4,ia) - ! - constr_target(ia) = 0.0_DP - ! - n_type_coord1 = 0 - ! - DO ia1 = 1, nat - ! - IF ( ityp(ia1) /= type_coord1 ) CYCLE - ! - DO ia2 = 1, nat - ! - IF ( ia2 == ia1 ) CYCLE - ! - IF ( ityp(ia2) /= type_coord2 ) CYCLE - ! - dtau(:) = pbc( ( tau(:,ia1) - tau(:,ia2) )*tau_units ) - ! - norm_dtau = norm( dtau(:) ) - ! - constr_target(ia) = constr_target(ia) + 1.0_DP / & - ( EXP( smoothing*( norm_dtau - r_c ) ) + 1.0_DP ) - ! - END DO - ! - n_type_coord1 = n_type_coord1 + 1 - ! - END DO - ! - constr_target(ia) = constr_target(ia) / DBLE( n_type_coord1 ) - ! - END SUBROUTINE set_type_coord - ! - !------------------------------------------------------------------- - SUBROUTINE set_atom_coord( ia ) - !------------------------------------------------------------------- - ! - INTEGER, INTENT(IN) :: ia - ! - ia1 = ANINT( constr(1,ia) ) - type_coord1 = ANINT( constr(2,ia) ) - ! - r_c = constr(3,ia) - ! - smoothing = 1.0_DP / constr(4,ia) - ! - constr_target(ia) = 0.0_DP - ! - DO ia2 = 1, nat - ! - IF ( ia2 == ia1 ) CYCLE - ! - IF ( ityp(ia2) /= type_coord1 ) CYCLE - ! - dtau(:) = pbc( ( tau(:,ia1) - tau(:,ia2) )*tau_units ) - ! - norm_dtau = norm( dtau(:) ) - ! - constr_target(ia) = constr_target(ia) + 1.0_DP / & - ( EXP( smoothing*( norm_dtau - r_c ) ) + 1.0_DP ) - ! - END DO - ! - END SUBROUTINE set_atom_coord - ! - !------------------------------------------------------------------- - SUBROUTINE set_planar_angle( ia ) - !------------------------------------------------------------------- - ! - INTEGER, INTENT(IN) :: ia - ! - ia0 = ANINT( constr(1,ia) ) - ia1 = ANINT( constr(2,ia) ) - ia2 = ANINT( constr(3,ia) ) - ! - d0(:) = pbc( ( tau(:,ia0) - tau(:,ia1) )*tau_units ) - d1(:) = pbc( ( tau(:,ia1) - tau(:,ia2) )*tau_units ) - ! - d0(:) = d0(:) / norm( d0(:) ) - d1(:) = d1(:) / norm( d1(:) ) - ! - constr_target(ia) = d0(:) .dot. d1(:) - ! - END SUBROUTINE set_planar_angle - ! - !------------------------------------------------------------------- - SUBROUTINE set_torsional_angle( ia ) - !------------------------------------------------------------------- - ! - INTEGER, INTENT(IN) :: ia - ! - ia0 = ANINT( constr(1,ia) ) - ia1 = ANINT( constr(2,ia) ) - ia2 = ANINT( constr(3,ia) ) - ia3 = ANINT( constr(4,ia) ) - ! - d0(:) = pbc( ( tau(:,ia0) - tau(:,ia1) )*tau_units ) - d1(:) = pbc( ( tau(:,ia1) - tau(:,ia2) )*tau_units ) - d2(:) = pbc( ( tau(:,ia2) - tau(:,ia3) )*tau_units ) - ! - C00 = d0(:) .dot. d0(:) - C01 = d0(:) .dot. d1(:) - C11 = d1(:) .dot. d1(:) - C02 = d0(:) .dot. d2(:) - C12 = d1(:) .dot. d2(:) - C22 = d2(:) .dot. d2(:) - ! - D01 = C00*C11 - C01*C01 - D12 = C11*C22 - C12*C12 - ! - constr_target(ia) = ( C01*C12 - C02*C11 ) / SQRT( D01*D12 ) - ! - END SUBROUTINE set_torsional_angle - ! - !------------------------------------------------------------------- - SUBROUTINE set_structure_factor( ia ) - !------------------------------------------------------------------- - ! - INTEGER, INTENT(IN) :: ia - ! - k(1) = constr(1,ia) * tpi / tau_units - k(2) = constr(2,ia) * tpi / tau_units - k(3) = constr(3,ia) * tpi / tau_units - ! - struc_fac = ( 0.0_DP, 0.0_DP ) - ! - DO i = 1, nat - ! - dtau(:) = pbc( ( tau(:,i) - tau(:,1) )*tau_units ) - ! - phase = k(:) .dot. dtau(:) - ! - struc_fac = struc_fac + CMPLX( COS( phase ), SIN( phase ) ) - ! - END DO - ! - constr_target(ia) = CONJG( struc_fac )*struc_fac / DBLE( nat*nat ) - ! - END SUBROUTINE set_structure_factor - ! - !------------------------------------------------------------------- - SUBROUTINE set_sph_structure_factor( ia ) - !------------------------------------------------------------------- - ! - INTEGER, INTENT(IN) :: ia - ! - norm_k = constr(1,ia)*tpi/tau_units - ! - constr_target(ia) = 0.0_DP - ! - DO i = 1, nat - 1 - ! - DO j = i + 1, nat - ! - dtau(:) = pbc( ( tau(:,i) - tau(:,j) )*tau_units ) - ! - norm_dtau = norm( dtau(:) ) - ! - phase = norm_k*norm_dtau - ! - IF ( phase < eps32 ) THEN - ! - constr_target(ia) = constr_target(ia) + 1.0_DP - ! - ELSE - ! - constr_target(ia) = constr_target(ia) + SIN( phase ) / phase - ! - END IF - ! - END DO - ! - END DO - ! - constr_target(ia) = 2.0_DP * fpi * constr_target(ia) / DBLE( nat ) - ! - END SUBROUTINE set_sph_structure_factor - ! - !------------------------------------------------------------------- - SUBROUTINE set_bennett_proj( ia ) - !------------------------------------------------------------------- - ! - INTEGER, INTENT(IN) :: ia - ! - ia0 = ANINT( constr(1,ia) ) - ! - d0(:) = tau(:,ia0) - d1(:) = SUM( tau(:,:), DIM = 2 ) - ! - d1(:) = pbc( ( d1(:) - d0(:) )*tau_units ) / DBLE( nat - 1 ) - & - pbc( d0(:)*tau_units ) - ! - d2(:) = constr(2:4,ia) - ! - constr_target(ia) = ( d1(:) .dot. d2(:) ) / tau_units - ! - END SUBROUTINE set_bennett_proj - ! - END SUBROUTINE init_constraint - ! - !----------------------------------------------------------------------- - SUBROUTINE constraint_grad( idx, nat, tau, & - if_pos, ityp, tau_units, g, dg ) - !----------------------------------------------------------------------- - ! - ! ... this routine computes the value of the constraint equation and - ! ... the corresponding constraint gradient - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: idx - INTEGER, INTENT(IN) :: nat - REAL(DP), INTENT(IN) :: tau(:,:) - INTEGER, INTENT(IN) :: if_pos(:,:) - INTEGER, INTENT(IN) :: ityp(:) - REAL(DP), INTENT(IN) :: tau_units - REAL(DP), INTENT(OUT) :: dg(:,:) - REAL(DP), INTENT(OUT) :: g - ! - INTEGER :: i, j - INTEGER :: ia, ia0, ia1, ia2, ia3, n_type_coord1 - REAL(DP) :: d0(3), d1(3), d2(3) - REAL(DP) :: inv_den, fac - REAL(DP) :: C00, C01, C02, C11, C12, C22 - REAL(DP) :: D01, D12, invD01, invD12 - REAL(DP) :: smoothing, r_c - INTEGER :: type_coord1, type_coord2 - REAL(DP) :: dtau(3), norm_dtau, norm_dtau_sq, expo - REAL(DP) :: r0(3), ri(3), k(3), phase, ksin(3), norm_k, sinxx - COMPLEX(DP) :: struc_fac - ! - REAL(DP), EXTERNAL :: DDOT - ! - ! - dg(:,:) = 0.0_DP - ! - SELECT CASE ( constr_type(idx) ) - CASE( 1 ) - ! - ! ... constraint on global coordination - ! - type_coord1 = ANINT( constr(1,idx) ) - type_coord2 = ANINT( constr(2,idx) ) - ! - r_c = constr(3,idx) - ! - smoothing = 1.0_DP / constr(4,idx) - ! - g = 0.0_DP - ! - n_type_coord1 = 0 - ! - DO ia1 = 1, nat - ! - IF ( ityp(ia1) /= type_coord1 ) CYCLE - ! - DO ia2 = 1, nat - ! - IF ( ia2 == ia1 ) CYCLE - ! - IF ( ityp(ia2) /= type_coord2 ) CYCLE - ! - dtau(:) = pbc( ( tau(:,ia1) - tau(:,ia2) )*tau_units ) - ! - norm_dtau = norm( dtau(:) ) - ! - dtau(:) = dtau(:) / norm_dtau - ! - expo = EXP( smoothing*( norm_dtau - r_c ) ) - ! - g = g + 1.0_DP / ( expo + 1.0_DP ) - ! - dtau(:) = dtau(:) * smoothing*expo / ( expo + 1.0_DP )**2 - ! - dg(:,ia2) = dg(:,ia2) + dtau(:) - dg(:,ia1) = dg(:,ia1) - dtau(:) - ! - END DO - ! - n_type_coord1 = n_type_coord1 + 1 - ! - END DO - ! - g = g / DBLE( n_type_coord1 ) - dg = dg / DBLE( n_type_coord1 ) - ! - g = ( g - constr_target(idx) ) - ! - CASE( 2 ) - ! - ! ... constraint on local coordination - ! - ia = ANINT( constr(1,idx) ) - type_coord1 = ANINT( constr(2,idx) ) - ! - r_c = constr(3,idx) - ! - smoothing = 1.0_DP / constr(4,idx) - ! - g = 0.0_DP - ! - DO ia1 = 1, nat - ! - IF ( ia1 == ia ) CYCLE - ! - IF ( ityp(ia1) /= type_coord1 ) CYCLE - ! - dtau(:) = pbc( ( tau(:,ia) - tau(:,ia1) )*tau_units ) - ! - norm_dtau = norm( dtau(:) ) - ! - dtau(:) = dtau(:) / norm_dtau - ! - expo = EXP( smoothing*( norm_dtau - r_c ) ) - ! - g = g + 1.0_DP / ( expo + 1.0_DP ) - ! - dtau(:) = dtau(:) * smoothing * expo / ( expo + 1.0_DP )**2 - ! - dg(:,ia1) = dg(:,ia1) + dtau(:) - dg(:,ia) = dg(:,ia) - dtau(:) - ! - END DO - ! - g = ( g - constr_target(idx) ) - ! - CASE( 3 ) - ! - ! ... constraint on distances - ! - ia1 = ANINT( constr(1,idx) ) - ia2 = ANINT( constr(2,idx) ) - ! - dtau(:) = pbc( ( tau(:,ia1) - tau(:,ia2) )*tau_units ) - ! - norm_dtau = norm( dtau(:) ) - ! - g = ( norm_dtau - constr_target(idx) ) - ! - dg(:,ia1) = dtau(:) / norm_dtau - ! - dg(:,ia2) = - dg(:,ia1) - ! - CASE( 4 ) - ! - ! ... constraint on planar angles (for the notation used here see - ! ... Appendix C of the Allen-Tildesley book) - ! - ia0 = ANINT( constr(1,idx) ) - ia1 = ANINT( constr(2,idx) ) - ia2 = ANINT( constr(3,idx) ) - ! - d0(:) = pbc( ( tau(:,ia0) - tau(:,ia1) )*tau_units ) - d1(:) = pbc( ( tau(:,ia1) - tau(:,ia2) )*tau_units ) - ! - C00 = d0(:) .dot. d0(:) - C01 = d0(:) .dot. d1(:) - C11 = d1(:) .dot. d1(:) - ! - inv_den = 1.0_DP / SQRT( C00*C11 ) - ! - g = ( C01 * inv_den - constr_target(idx) ) - ! - dg(:,ia0) = ( d1(:) - C01/C00*d0(:) ) * inv_den - dg(:,ia2) = ( C01/C11*d1(:) - d0(:) ) * inv_den - dg(:,ia1) = - dg(:,ia0) - dg(:,ia2) - ! - CASE( 5 ) - ! - ! ... constraint on torsional angle (for the notation used here - ! ... see Appendix C of the Allen-Tildesley book) - ! - ia0 = ANINT( constr(1,idx) ) - ia1 = ANINT( constr(2,idx) ) - ia2 = ANINT( constr(3,idx) ) - ia3 = ANINT( constr(4,idx) ) - ! - d0(:) = pbc( ( tau(:,ia0) - tau(:,ia1) )*tau_units ) - d1(:) = pbc( ( tau(:,ia1) - tau(:,ia2) )*tau_units ) - d2(:) = pbc( ( tau(:,ia2) - tau(:,ia3) )*tau_units ) - ! - C00 = d0(:) .dot. d0(:) - C01 = d0(:) .dot. d1(:) - C11 = d1(:) .dot. d1(:) - C02 = d0(:) .dot. d2(:) - C12 = d1(:) .dot. d2(:) - C22 = d2(:) .dot. d2(:) - ! - D01 = C00*C11 - C01*C01 - D12 = C11*C22 - C12*C12 - ! - IF ( ABS( D01 ) < eps32 .OR. ABS( D12 ) < eps32 ) & - CALL errore( 'constraint_grad', 'either D01 or D12 is zero', 1 ) - ! - invD01 = 1.0_DP / D01 - invD12 = 1.0_DP / D12 - ! - fac = C01*C12 - C02*C11 - ! - inv_den = 1.0_DP / SQRT( D01*D12 ) - ! - g = ( ( C01*C12 - C02*C11 )*inv_den - constr_target(idx) ) - ! - dg(:,ia0) = ( C12*d1(:) - C11*d2(:) - & - invD01*fac*( C11*d0(:) - C01*d1(:) ) )*inv_den - ! - dg(:,ia2) = ( C01*( d1(:) - d2(:) ) - & - ( C11 + C12 )*d0(:) + 2.0_DP*C02*d1(:) - & - invD12*fac*( ( C11 + C12 )*d2(:) - & - ( C12 + C22 )*d1(:) ) - & - invD01*fac*( C01*d0(:) - C00*d1(:) ) )*inv_den - ! - dg(:,ia3) = ( C11*d0(:) - C01*d1(:) - & - invD12*fac*( C12*d1(:) - C11*d2(:) ) )*inv_den - ! - dg(:,ia1) = - dg(:,ia0) - dg(:,ia2) - dg(:,ia3) - ! - CASE( 6 ) - ! - ! ... constraint on structure factor at a given k vector - ! - k(1) = constr(1,idx)*tpi/tau_units - k(2) = constr(2,idx)*tpi/tau_units - k(3) = constr(3,idx)*tpi/tau_units - ! - struc_fac = ( 1.0_DP, 0.0_DP ) - ! - r0(:) = tau(:,1) - ! - DO i = 1, nat - 1 - ! - dtau(:) = pbc( ( tau(:,i+1) - r0(:) )*tau_units ) - ! - phase = k(1)*dtau(1) + k(2)*dtau(2) + k(3)*dtau(3) - ! - struc_fac = struc_fac + CMPLX( COS( phase ), SIN( phase ) ) - ! - ri(:) = tau(:,i) - ! - DO j = i + 1, nat - ! - dtau(:) = pbc( ( tau(:,j) - ri(:) )*tau_units ) - ! - phase = k(1)*dtau(1) + k(2)*dtau(2) + k(3)*dtau(3) - ! - ksin(:) = k(:)*SIN( phase ) - ! - dg(:,i) = dg(:,i) + ksin(:) - dg(:,j) = dg(:,j) - ksin(:) - ! - END DO - ! - END DO - ! - g = ( CONJG( struc_fac )*struc_fac ) / DBLE( nat*nat ) - ! - g = ( g - constr_target(idx) ) - ! - dg(:,:) = dg(:,:)*2.0_DP/DBLE( nat*nat ) - ! - CASE( 7 ) - ! - ! ... constraint on spherical average of the structure factor for - ! ... a given k-vector of norm k - ! - norm_k = constr(1,idx)*tpi/tau_units - ! - g = 0.0_DP - ! - DO i = 1, nat - 1 - ! - ri(:) = tau(:,i) - ! - DO j = i + 1, nat - ! - dtau(:) = pbc( ( ri(:) - tau(:,j) )*tau_units ) - ! - norm_dtau_sq = dtau(1)**2 + dtau(2)**2 + dtau(3)**2 - ! - norm_dtau = SQRT( norm_dtau_sq ) - ! - phase = norm_k * norm_dtau - ! - IF ( phase < eps32 ) THEN - ! - g = g + 1.0_DP - ! - ELSE - ! - sinxx = SIN( phase ) / phase - ! - g = g + sinxx - ! - dtau(:) = dtau(:) / norm_dtau_sq*( COS( phase ) - sinxx ) - ! - dg(:,i) = dg(:,i) + dtau(:) - dg(:,j) = dg(:,j) - dtau(:) - ! - END IF - ! - END DO - ! - END DO - ! - g = ( 2.0_DP*fpi*g / DBLE( nat ) - constr_target(idx) ) - ! - dg(:,:) = 4.0_DP*fpi*dg(:,:) / DBLE( nat ) - ! - CASE( 8 ) - ! - ! ... constraint on Bennett projection - ! - ia0 = ANINT( constr(1,idx) ) - ! - d0(:) = tau(:,ia0) - d1(:) = SUM( tau(:,:), DIM = 2 ) - ! - d1(:) = pbc( ( d1(:) - d0(:) )*tau_units ) / DBLE( nat - 1 ) - & - pbc( d0(:)*tau_units ) - ! - d2(:) = constr(2:4,idx) - ! - g = ( d1(:) .dot. d2(:) ) / tau_units - constr_target( idx ) - ! - dg = 0.0_DP - ! - C00 = ( 1.0_DP / DBLE( nat - 1 ) ) / tau_units - C01 = -1.0_DP / tau_units - ! - DO i = 1, nat - ! - dg(:,i) = d2(:)*C00 - ! - END DO - ! - dg(:,ia0) = d2(:)*C01 - ! - END SELECT - ! - dg(:,:) = dg(:,:)*DBLE( if_pos(:,:) ) - ! - RETURN - ! - END SUBROUTINE constraint_grad - ! - !----------------------------------------------------------------------- - SUBROUTINE check_constraint( nat, taup, tau0, & - force, if_pos, ityp, tau_units, dt, massconv ) - !----------------------------------------------------------------------- - ! - ! ... update taup (predicted positions) so that the constraint equation - ! ... g=0 is satisfied, using the recursion formula: - ! - ! ... g(taup) - ! ... taup = taup - ----------------------- * dg(tau0) - ! ... M^-1 - ! - ! ... in normal cases the constraint equation should be satisfied at - ! ... the very first iteration. - ! - USE ions_base, ONLY : amass - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nat - REAL(DP), INTENT(INOUT) :: taup(3,nat) - REAL(DP), INTENT(IN) :: tau0(3,nat) - INTEGER, INTENT(IN) :: if_pos(3,nat) - REAL(DP), INTENT(INOUT) :: force(3,nat) - INTEGER, INTENT(IN) :: ityp(nat) - REAL(DP), INTENT(IN) :: tau_units - REAL(DP), INTENT(IN) :: dt - REAL(DP), INTENT(IN) :: massconv - ! - INTEGER :: na, i, idx, dim - REAL(DP), ALLOCATABLE :: dgp(:,:), dg0(:,:,:) - REAL(DP) :: g0 - REAL(DP) :: lambda, fac, invdtsq - LOGICAL, ALLOCATABLE :: ltest(:) - LOGICAL :: global_test - INTEGER, PARAMETER :: maxiter = 100 - ! - REAL(DP), EXTERNAL :: DDOT - ! - ! - ALLOCATE( dgp( 3, nat ) ) - ALLOCATE( dg0( 3, nat, nconstr ) ) - ! -! ALLOCATE( gp( nconstr ) ) - ALLOCATE( ltest( nconstr ) ) - ! - invdtsq = 1.0_DP / dt**2 - ! - dim = 3*nat - ! - DO idx = 1, nconstr - ! - CALL constraint_grad( idx, nat, tau0, & - if_pos, ityp, tau_units, g0, dg0(:,:,idx) ) - ! - END DO - ! - outer_loop: DO i = 1, maxiter - ! - inner_loop: DO idx = 1, nconstr - ! - ltest(idx) = .FALSE. - ! - CALL constraint_grad( idx, nat, taup, & - if_pos, ityp, tau_units, gp(idx), dgp ) - ! - ! ... check if gp = 0 - ! -#if defined (__DEBUG_CONSTRAINTS) - WRITE( stdout, '(2(2X,I3),F12.8)' ) i, idx, ABS( gp(idx) ) -#endif - ! - IF ( ABS( gp(idx) ) < constr_tol ) THEN - ! - ltest(idx) = .TRUE. - ! - CYCLE inner_loop - ! - END IF - ! - ! ... if gp <> 0 find new taup and check again - ! ... ( gp is in bohr and taup in tau_units ) - ! - DO na = 1, nat - ! - dgp(:,na) = dgp(:,na) / ( amass(ityp(na))*massconv ) - ! - END DO - ! - lambda = gp(idx) / DDOT( dim, dgp, 1, dg0(:,:,idx), 1 ) - ! - DO na = 1, nat - ! - fac = amass(ityp(na))*massconv*tau_units - ! - taup(:,na) = taup(:,na) - lambda*dg0(:,na,idx)/fac - ! - END DO - ! - lagrange(idx) = lagrange(idx) + lambda*invdtsq - ! - force(:,:) = force(:,:) - lambda*dg0(:,:,idx)*invdtsq - ! - END DO inner_loop - ! - global_test = ALL( ltest(:) ) - ! - ! ... all constraints are satisfied - ! - IF ( global_test ) EXIT outer_loop - ! - END DO outer_loop - ! - IF ( .NOT. global_test ) THEN - ! - ! ... error messages - ! - WRITE( stdout, '(/,5X,"Number of step(s): ",I3)') MIN( i, maxiter ) - WRITE( stdout, '(/,5X,"constr_target convergence: ")' ) - ! - DO i = 1, nconstr - ! - WRITE( stdout, '(5X,"constr # ",I3,2X,L1,3(2X,F16.10))' ) & - i, ltest(i), ABS( gp(i) ), constr_tol, constr_target(i) - ! - END DO - ! - CALL errore( 'check_constraint', & - 'on some constraint g = 0 is not satisfied', 1 ) - ! - END IF - ! - DEALLOCATE( dgp ) - DEALLOCATE( dg0 ) -! DEALLOCATE( gp ) - DEALLOCATE( ltest ) - ! - RETURN - ! - END SUBROUTINE check_constraint - ! - !----------------------------------------------------------------------- - SUBROUTINE remove_constr_force( nat, tau, & - if_pos, ityp, tau_units, force ) - !----------------------------------------------------------------------- - ! - ! ... the component of the force that is orthogonal to the - ! ... ipersurface defined by the constraint equations is removed - ! ... and the corresponding value of the lagrange multiplier computed - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nat - REAL(DP), INTENT(IN) :: tau(:,:) - INTEGER, INTENT(IN) :: if_pos(:,:) - INTEGER, INTENT(IN) :: ityp(:) - REAL(DP), INTENT(IN) :: tau_units - REAL(DP), INTENT(INOUT) :: force(:,:) - ! - INTEGER :: i, j, dim - REAL(DP) :: g, ndg, dgidgj - REAL(DP) :: norm_before, norm_after - REAL(DP), ALLOCATABLE :: dg(:,:,:) - REAL(DP), ALLOCATABLE :: dg_matrix(:,:) - INTEGER, ALLOCATABLE :: iwork(:) - ! - REAL(DP), EXTERNAL :: DDOT, DNRM2 - ! - ! - dim = 3*nat - ! - lagrange(:) = 0.0_DP - ! -#if defined (__REMOVE_CONSTRAINT_FORCE) - ! - norm_before = DNRM2( 3*nat, force, 1 ) - ! - ALLOCATE( dg( 3, nat, nconstr ) ) - ! - IF ( nconstr == 1 ) THEN - ! - CALL constraint_grad( 1, nat, tau, & - if_pos, ityp, tau_units, g, dg(:,:,1) ) - ! - lagrange(1) = DDOT( dim, force, 1, dg(:,:,1), 1 ) - ! - ndg = DDOT( dim, dg(:,:,1), 1, dg(:,:,1), 1 ) - ! - force(:,:) = force(:,:) - lagrange(1)*dg(:,:,1)/ndg - ! - ELSE - ! - ALLOCATE( dg_matrix( nconstr, nconstr ) ) - ALLOCATE( iwork( nconstr ) ) - ! - DO i = 1, nconstr - ! - CALL constraint_grad( i, nat, tau, & - if_pos, ityp, tau_units, g, dg(:,:,i) ) - ! - END DO - ! - DO i = 1, nconstr - ! - dg_matrix(i,i) = DDOT( dim, dg(:,:,i), 1, dg(:,:,i), 1 ) - ! - lagrange(i) = DDOT( dim, force, 1, dg(:,:,i), 1 ) - ! - DO j = i + 1, nconstr - ! - dgidgj = DDOT( dim, dg(:,:,i), 1, dg(:,:,j), 1 ) - ! - dg_matrix(i,j) = dgidgj - dg_matrix(j,i) = dgidgj - ! - END DO - ! - END DO - ! - CALL DGESV( nconstr, 1, dg_matrix, & - nconstr, iwork, lagrange, nconstr, i ) - ! - IF ( i /= 0 ) & - CALL errore( 'remove_constr_force', & - 'error in the solution of the linear system', i ) - ! - DO i = 1, nconstr - ! - force(:,:) = force(:,:) - lagrange(i)*dg(:,:,i) - ! - END DO - ! - DEALLOCATE( dg_matrix ) - DEALLOCATE( iwork ) - ! - END IF - ! -#if defined (__DEBUG_CONSTRAINTS) - ! - WRITE( stdout, '(/,5X,"Intermediate forces (Ry/au):",/)') - ! - DO i = 1, nat - ! - WRITE( stdout, '(5X,"atom ",I3," type ",I2,3X,"force = ",3F14.8)' ) & - i, ityp(i), force(:,i) - ! - END DO - ! -#endif - ! - norm_after = DNRM2( dim, force, 1 ) - ! - IF ( norm_before < norm_after ) THEN - ! - WRITE( stdout, '(/,5X,"norm before = ",F16.10)' ) norm_before - WRITE( stdout, '( 5X,"norm after = ",F16.10)' ) norm_after - ! - CALL errore( 'remove_constr_force', & - 'norm(F) before < norm(F) after', 1 ) - ! - END IF - ! - DEALLOCATE( dg ) - ! -#endif - ! - END SUBROUTINE remove_constr_force - ! - !----------------------------------------------------------------------- - SUBROUTINE remove_constr_vec( nat, tau, & - if_pos, ityp, tau_units, vec ) - !----------------------------------------------------------------------- - ! - ! ... the component of a displacement vector that is orthogonal to the - ! ... ipersurface defined by the constraint equations is removed - ! ... and the corresponding value of the lagrange multiplier computed - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nat - REAL(DP), INTENT(IN) :: tau(:,:) - INTEGER, INTENT(IN) :: if_pos(:,:) - INTEGER, INTENT(IN) :: ityp(:) - REAL(DP), INTENT(IN) :: tau_units - REAL(DP), INTENT(INOUT) :: vec(:,:) - ! - INTEGER :: i, j, dim - REAL(DP) :: g, ndg, dgidgj - REAL(DP), ALLOCATABLE :: dg(:,:,:), dg_matrix(:,:), lambda(:) - INTEGER, ALLOCATABLE :: iwork(:) - ! - REAL(DP), EXTERNAL :: DDOT, DNRM2 - ! - ! - dim = 3*nat - ! - ALLOCATE( lambda( nconstr ) ) - ALLOCATE( dg( 3, nat, nconstr ) ) - ! - IF ( nconstr == 1 ) THEN - ! - CALL constraint_grad( 1, nat, tau, & - if_pos, ityp, tau_units, g, dg(:,:,1) ) - ! - lambda(1) = DDOT( dim, vec, 1, dg(:,:,1), 1 ) - ! - ndg = DDOT( dim, dg(:,:,1), 1, dg(:,:,1), 1 ) - ! - vec(:,:) = vec(:,:) - lambda(1)*dg(:,:,1)/ndg - ! - ELSE - ! - ALLOCATE( dg_matrix( nconstr, nconstr ) ) - ALLOCATE( iwork( nconstr ) ) - ! - DO i = 1, nconstr - ! - CALL constraint_grad( i, nat, tau, & - if_pos, ityp, tau_units, g, dg(:,:,i) ) - ! - END DO - ! - DO i = 1, nconstr - ! - dg_matrix(i,i) = DDOT( dim, dg(:,:,i), 1, dg(:,:,i), 1 ) - ! - lambda(i) = DDOT( dim, vec, 1, dg(:,:,i), 1 ) - ! - DO j = i + 1, nconstr - ! - dgidgj = DDOT( dim, dg(:,:,i), 1, dg(:,:,j), 1 ) - ! - dg_matrix(i,j) = dgidgj - dg_matrix(j,i) = dgidgj - ! - END DO - ! - END DO - ! - CALL DGESV( nconstr, 1, dg_matrix, & - nconstr, iwork, lambda, nconstr, i ) - ! - IF ( i /= 0 ) & - CALL errore( 'remove_constr_vec', & - 'error in the solution of the linear system', i ) - ! - DO i = 1, nconstr - ! - vec(:,:) = vec(:,:) - lambda(i)*dg(:,:,i) - ! - END DO - ! - DEALLOCATE( dg_matrix ) - DEALLOCATE( iwork ) - ! - END IF - ! - DEALLOCATE( lambda, dg ) - ! - END SUBROUTINE remove_constr_vec - ! - !----------------------------------------------------------------------- - SUBROUTINE deallocate_constraint() - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - ! - IF ( ALLOCATED( lagrange ) ) DEALLOCATE( lagrange ) - IF ( ALLOCATED( constr ) ) DEALLOCATE( constr ) - IF ( ALLOCATED( constr_type ) ) DEALLOCATE( constr_type ) - IF ( ALLOCATED( constr_target ) ) DEALLOCATE( constr_target ) - IF ( ALLOCATED( gp ) ) DEALLOCATE( gp ) - ! - RETURN - ! - END SUBROUTINE deallocate_constraint - ! - !----------------------------------------------------------------------- - FUNCTION pbc( vect ) - !----------------------------------------------------------------------- - ! - ! ... periodic boundary conditions ( vect is assumed to be given - ! ... in cartesian coordinates and in atomic units ) - ! - USE cell_base, ONLY : at, bg, alat - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: vect(3) - REAL(DP) :: pbc(3) - ! - ! -#if defined (__USE_PBC) - ! - pbc(:) = MATMUL( vect(:), bg(:,:) )/alat - ! - pbc(:) = pbc(:) - ANINT( pbc(:) ) - ! - pbc(:) = MATMUL( at(:,:), pbc(:) )*alat - ! -#else - ! - pbc(:) = vect(:) - ! -#endif - RETURN - ! - END FUNCTION pbc - ! - !----------------------------------------------------------------------- - SUBROUTINE compute_dmax() - !----------------------------------------------------------------------- - ! - ! ... dmax corresponds to one half the shortest edge of the cell - ! - USE cell_base, ONLY : at, alat - ! - IMPLICIT NONE - ! - REAL(DP), PARAMETER :: x(3) = (/ 0.5_DP, 0.0_DP, 0.0_DP /), & - y(3) = (/ 0.0_DP, 0.5_DP, 0.0_DP /), & - z(3) = (/ 0.0_DP, 0.0_DP, 0.5_DP /) - ! - dmax = norm( MATMUL( at(:,:), x(:) ) ) - ! - dmax = MIN( dmax, norm( MATMUL( at(:,:), y(:) ) ) ) - dmax = MIN( dmax, norm( MATMUL( at(:,:), z(:) ) ) ) - ! - dmax = dmax*alat - ! - RETURN - ! - END SUBROUTINE compute_dmax - ! -END MODULE constraints_module diff --git a/quantum_espresso/kcp/Modules/control_flags.f90 b/quantum_espresso/kcp/Modules/control_flags.f90 deleted file mode 100644 index 61c3b0014..000000000 --- a/quantum_espresso/kcp/Modules/control_flags.f90 +++ /dev/null @@ -1,455 +0,0 @@ -! -! Copyright (C) 2002-2007 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!=----------------------------------------------------------------------------=! -MODULE control_flags - !=--------------------------------------------------------------------------=! - ! - ! ... this module contains all basic variables that controls the - ! ... execution flow - !---------------------------------------------- - ! - USE kinds - USE parameters - ! - IMPLICIT NONE - ! - SAVE - ! - PRIVATE - ! - TYPE convergence_criteria - ! - LOGICAL :: active - INTEGER :: nstep - REAL(DP) :: ekin - REAL(DP) :: derho - REAL(DP) :: force - ! - END TYPE convergence_criteria - ! - PUBLIC :: tbeg, nomore, nbeg, isave, iprint, tv0rd, nv0rd, tzeroc, tzerop, & - newnfi, tnewnfi, tfor, tpre, tzeroe, tsde, tsdp, tsdc, taurdr, & - ndr, ndw, tortho, non_ortho, ortho_eps, ortho_max, tstress, & - tprnfor, timing, memchk, tprnsfac, tcarpar, & - trane,dt_old,ampre, tranp, amprp, tdipole, t_diis, t_diis_simple,& - t_diis_rot, tnosee, tnosep, tnoseh, tcp, tcap, tdamp, tdampions, & - tconvthrs, tolp, convergence_criteria, tionstep, nstepe, & - tsteepdesc, tatomicwfc, tscreen, do_wf_cmplx, gamma_only, & !added:giovanni do_wf_cmplx - force_pairing, tchi2, do_ee, & - draw_pot, pot_number, & !added:linh draw vsic potentials - iprint_spreads, iprint_manifold_overlap, innerloop_until, & - hartree_only_sic !added:giovanni print spreads and manifold overlaps, and hartree-only sic -!$$ - PUBLIC :: do_innerloop, do_innerloop_empty, do_innerloop_cg, innerloop_dd_nstep,& - innerloop_cg_nsd, innerloop_cg_nreset, innerloop_nmax, & - innerloop_init_n, innerloop_cg_ratio, innerloop_atleast, l_comp_cmplxfctn_index -!$$ - ! - PUBLIC :: fix_dependencies, check_flags - PUBLIC :: tksw, evc_restart, trhor, thdyn, iprsta, trhow - PUBLIC :: twfcollect, printwfc - PUBLIC :: lkpoint_dir - PUBLIC :: program_name - ! - ! ... declare execution control variables - ! - CHARACTER(LEN=4) :: program_name = ' ' ! used to control execution flow - ! inside module: 'FPMD' or 'CP90' - ! - LOGICAL :: trhor = .FALSE. ! read rho from unit 47 (only cp, seldom used) - LOGICAL :: trhow = .FALSE. ! CP code, write rho to restart dir - LOGICAL :: tksw = .FALSE. ! CP: write Kohn-Sham states to restart dir - LOGICAL :: evc_restart = .FALSE. ! CP: write Kohn-Sham eigenstates as restart wavefunctions - ! - LOGICAL :: tsde = .FALSE. ! electronic steepest descent - LOGICAL :: tzeroe = .FALSE. ! set to zero the electronic velocities - LOGICAL :: tfor = .FALSE. ! move the ions ( calculate forces ) - LOGICAL :: tsdp = .FALSE. ! ionic steepest descent - LOGICAL :: tzerop = .FALSE. ! set to zero the ionic velocities - LOGICAL :: tprnfor = .FALSE. ! print forces to standard output - LOGICAL :: taurdr = .FALSE. ! read ionic position from standard input - LOGICAL :: tv0rd = .FALSE. ! read ionic velocities from standard input - LOGICAL :: tpre = .FALSE. ! calculate stress, and (in fpmd) variable cell dynamic - LOGICAL :: thdyn = .FALSE. ! variable-cell dynamics (only cp) - LOGICAL :: tsdc = .FALSE. ! cell geometry steepest descent - LOGICAL :: tzeroc = .FALSE. ! set to zero the cell geometry velocities - LOGICAL :: tstress = .FALSE. ! print stress to standard output - LOGICAL :: tortho = .FALSE. ! use iterative orthogonalization - LOGICAL :: non_ortho = .FALSE. ! non-orthogonal cp - LOGICAL :: tconjgrad = .FALSE. ! use conjugate gradient electronic minimization - LOGICAL :: timing = .FALSE. ! print out timing information - LOGICAL :: memchk = .FALSE. ! check for memory leakage - LOGICAL :: tprnsfac = .FALSE. ! print out structure factor - LOGICAL :: tcarpar = .FALSE. ! tcarpar is set TRUE for a "pure" Car Parrinello simulation - LOGICAL :: tdamp = .FALSE. ! Use damped dynamics for electrons - LOGICAL :: tdampions = .FALSE. ! Use damped dynamics for ions - LOGICAL :: tatomicwfc = .FALSE. ! Use atomic wavefunctions as starting guess for ch. density - LOGICAL :: tscreen = .FALSE. ! Use screened coulomb potentials for cluster calculations - LOGICAL :: twfcollect = .FALSE. ! Collect wave function in the restart file at the end of run. - LOGICAL :: lkpoint_dir = .TRUE. ! save each k point in a different directory - INTEGER :: printwfc = -1 ! Print wave functions, temporarely used only by ensemble-dft - LOGICAL :: force_pairing = .FALSE. ! Force pairing - LOGICAL :: tchi2 = .FALSE. ! Compute Chi^2 - LOGICAL :: do_ee = .FALSE. ! Compute periodi-image correction -!$$ - LOGICAL :: draw_pot = .FALSE. ! added:linh draw vsic potentials - INTEGER :: pot_number = 1 ! added:linh draw vsic potentials -!$$ - INTEGER :: iprint_spreads=-1 - INTEGER :: iprint_manifold_overlap=-1 - LOGICAL :: hartree_only_sic=.false. - INTEGER :: innerloop_until=-1 - LOGICAL :: do_outerloop = .TRUE. ! Do outer loop minimization - LOGICAL :: do_outerloop_empty = .TRUE. ! Do outer loop minimization - LOGICAL :: do_innerloop = .FALSE. ! Do inner loop minimization in case do_orbdep - LOGICAL :: do_innerloop_empty = .FALSE. ! Do inner loop minimization in case do_orbdep - LOGICAL :: l_comp_cmplxfctn_index = .FALSE. ! compute complexification index in case of CMPLX WFs - LOGICAL :: do_innerloop_cg = .FALSE. ! Do cg inner loop minimization with parabolic minimization in case do_orbdep - INTEGER :: innerloop_dd_nstep = 50 ! Number of outer loop damped dynamics steps before each inner loop minimization - INTEGER :: innerloop_cg_nsd = 20 ! Number of steepest-descent steps in doing conjugate-gradient inner loop minimization - INTEGER :: innerloop_cg_nreset = 10 ! Number of steps to reset the search direction to be the steepest-descent direction in inner loop minimization - INTEGER :: innerloop_nmax = 10000 ! Maximum number of inner loop minimization - INTEGER :: innerloop_init_n = 10000 ! Innerloop iterations with fixed threshold - INTEGER :: innerloop_atleast = 0 ! Minimum number of innerloop iterations performed - REAL(DP) :: innerloop_cg_ratio = 1.d-3 ! Innerloop ratio between the CG outerloop step and the innerloop threshold -!$$ - ! - TYPE (convergence_criteria) :: tconvthrs - ! thresholds used to check GS convergence - ! - ! ... Ionic vs Electronic step frequency - ! ... When "ion_nstep > 1" and "electron_dynamics = 'md' | 'sd' ", ions are - ! ... propagated every "ion_nstep" electronic step only if the electronic - ! ... "ekin" is lower than "ekin_conv_thr" - ! - LOGICAL :: tionstep = .FALSE. - INTEGER :: nstepe = 1 - ! parameters to control how many electronic steps - ! between ions move - - LOGICAL :: tsteepdesc = .FALSE. - ! parameters for electronic steepest desceent - - INTEGER :: nbeg = 0 ! internal code for initialization ( -1, 0, 1, 2, .. ) - INTEGER :: ndw = 0 ! - INTEGER :: ndr = 0 ! - INTEGER :: nomore = 0 ! - INTEGER :: iprint =10 ! print output every iprint step - INTEGER :: isave = 0 ! write restart to ndr unit every isave step - INTEGER :: nv0rd = 0 ! - INTEGER :: iprsta = 0 ! output verbosity (increasing from 0 to infinity) - LOGICAL :: do_wf_cmplx = .TRUE. !added:giovanni - ! - ! ... .TRUE. if only gamma point is used - ! - LOGICAL :: gamma_only = .TRUE. - ! - LOGICAL :: tnewnfi = .FALSE. - INTEGER :: newnfi = 0 - ! - ! This variable is used whenever a timestep change is requested - ! - REAL(DP) :: dt_old = -1.0_DP - ! - ! ... Wave function randomization - ! - LOGICAL :: trane = .FALSE. - REAL(DP) :: ampre = 0.0_DP - ! - ! ... Ionic position randomization - ! - LOGICAL :: tranp(nsx) = .FALSE. - REAL(DP) :: amprp(nsx) = 0.0_DP - ! - ! ... Read the cell from standard input - ! - LOGICAL :: tbeg = .FALSE. - ! - ! ... This flags control the calculation of the Dipole Moments - ! - LOGICAL :: tdipole = .FALSE. - ! - ! ... Flags that controls DIIS electronic minimization - ! - LOGICAL :: t_diis = .FALSE. - LOGICAL :: t_diis_simple = .FALSE. - LOGICAL :: t_diis_rot = .FALSE. - ! - ! ... Flag controlling the Nose thermostat for electrons - ! - LOGICAL :: tnosee = .FALSE. - ! - ! ... Flag controlling the Nose thermostat for the cell - ! - LOGICAL :: tnoseh = .FALSE. - ! - ! ... Flag controlling the Nose thermostat for ions - ! - LOGICAL :: tnosep = .FALSE. - LOGICAL :: tcap = .FALSE. - LOGICAL :: tcp = .FALSE. - REAL(DP) :: tolp = 0.0_DP ! tolerance for temperature variation - ! - REAL(DP), PUBLIC :: & - ekin_conv_thr = 0.0_DP, &! conv. threshold for fictitious e. kinetic energy - etot_conv_thr = 0.0_DP, &! conv. threshold for DFT energy -!$$ - esic_conv_thr = 0.0_DP, &! conv. threshold for SIC energy -!$$ - forc_conv_thr = 0.0_DP ! conv. threshold for atomic forces - INTEGER, PUBLIC :: & - ekin_maxiter = 100, &! max number of iter. for ekin convergence - etot_maxiter = 100, &! max number of iter. for etot convergence - forc_maxiter = 100 ! max number of iter. for atomic forces conv. - ! - ! ... Several variables controlling the run ( used mainly in PW calculations ) - ! - ! ... logical flags controlling the execution - ! - LOGICAL, PUBLIC :: & - lfixatom=.FALSE., &! if .TRUE. some atom is kept fixed - lscf =.FALSE., &! if .TRUE. the calc. is selfconsistent - lbfgs =.FALSE., &! if .TRUE. the calc. is a relaxation based on BFGS - lmd =.FALSE., &! if .TRUE. the calc. is a dynamics - llang =.FALSE., &! if .TRUE. the calc. is Langevin dynamics - lmetadyn=.FALSE., &! if .TRUE. the calc. is meta-dynamics - lpath =.FALSE., &! if .TRUE. the calc. is a path optimizations - lneb =.FALSE., &! if .TRUE. the calc. is NEB dynamics - lsmd =.FALSE., &! if .TRUE. the calc. is string dynamics - lwf =.FALSE., &! if .TRUE. the calc. is with wannier functions - lphonon =.FALSE., &! if .TRUE. the calc. is phonon - lbands =.FALSE., &! if .TRUE. the calc. is band structure - lconstrain=.FALSE.,&! if .TRUE. the calc. is constraint - ldamped =.FALSE., &! if .TRUE. the calc. is a damped dynamics - lcoarsegrained=.FALSE., &! if .TRUE. a coarse-grained phase-space is used - llondon =.FALSE., & ! if .TRUE. compute semi-empirical dispersion correction - restart =.FALSE. ! if .TRUE. restart from results of a preceding run - ! - ! ... pw self-consistency - ! - INTEGER, PUBLIC :: & - ngm0, &! used in mix_rho - niter, &! the maximum number of iteration - nmix, &! the number of iteration kept in the history - imix ! the type of mixing (0=plain,1=TF,2=local-TF) - REAL(DP), PUBLIC :: & - mixing_beta, &! the mixing parameter - tr2 ! the convergence threshold for potential - LOGICAL, PUBLIC :: & - conv_elec ! if .TRUE. electron convergence has been reached - ! - ! ... pw diagonalization - ! - REAL(DP), PUBLIC :: & - ethr ! the convergence threshold for eigenvalues - INTEGER, PUBLIC :: & - david, &! max dimension of subspace in Davidson diagonalization - isolve, &! Davidson or CG or DIIS diagonalization - max_cg_iter, &! maximum number of iterations in a CG di - diis_buff, &! dimension of the buffer in diis - diis_ndim ! dimension of reduced basis in DIIS - LOGICAL, PUBLIC :: & - diago_full_acc = .FALSE. ! if true, empty eigenvalues have the same - ! accuracy of the occupied ones - ! - ! ... wfc and rho extrapolation - ! - REAL(DP), PUBLIC :: & - alpha0, &! the mixing parameters for the extrapolation - beta0 ! of the starting potential - INTEGER, PUBLIC :: & - history, &! number of old steps available for potential updating - pot_order, &! type of potential updating ( see update_pot ) - wfc_order ! type of wavefunctions updating ( see update_pot ) - ! - ! ... ionic dynamics - ! - INTEGER, PUBLIC :: & - nstep = 1, &! number of ionic steps - istep = 0 ! current ionic step - LOGICAL, PUBLIC :: & - conv_ions ! if .TRUE. ionic convergence has been reached - REAL(DP), PUBLIC :: & - upscale ! maximum reduction of convergence threshold - ! - ! ... system's symmetries - ! - LOGICAL, PUBLIC :: & - nosym = .FALSE., &! if .TRUE. no symmetry is used - nosym_evc = .FALSE., &! if .TRUE. symmetry is used only to symmetrize - ! k points - noinv = .FALSE.,& ! if .TRUE. q=>-q symmetry not used in k-point generation - nofrac= .FALSE. ! if .TRUE. fractionary transations are not allowed - ! - ! ... phonon calculation - ! - INTEGER, PUBLIC :: & - modenum ! for single mode phonon calculation - ! - ! ... printout control - ! - INTEGER, PUBLIC :: & - io_level = 1 ! variable controlling the amount of I/O to file - INTEGER, PUBLIC :: & - iverbosity ! type of printing ( 0 few, 1 all ) - ! - ! ... miscellany - ! - LOGICAL, PUBLIC :: & - use_para_diag = .FALSE. ! if .TRUE. a fully distributed memory iteration - ! algorithm and parallel Householder algorithm are used - ! - LOGICAL, PUBLIC :: & - remove_rigid_rot = .FALSE. ! if .TRUE. the total torque acting on the atoms is - - LOGICAL, PUBLIC :: & - do_makov_payne = .FALSE. ! if .TRUE. makov-payne correction for isolated - ! system is used - ! removed - !LOGICAL, PUBLIC :: & - ! assume_isolated = .FALSE. ! if .TRUE. the system is assumed to be an - ! isolated molecule or cluster (in a supercell) - ! - INTEGER :: ortho_max = 0 ! maximum number of iterations in routine ortho - REAL(DP) :: ortho_eps = 0.0_DP ! threshold for convergence in routine ortho - ! - ! ... Linear Algebra parallelization - ! - INTEGER, PUBLIC :: & - ortho_para = 0 ! the number of processors to be used in linear algebra - ! ! parallel algorithm - ! - ! ... Task Groups parallelization - ! - LOGICAL, PUBLIC :: & - use_task_groups = .FALSE. ! if TRUE task groups parallelization is used - ! - ! ... Number of neighbouring cell to consider in ewald sum - ! - INTEGER, PUBLIC :: iesr = 1 - ! - ! ... Parameter for plotting Vh average - ! - LOGICAL, PUBLIC :: tvhmean = .FALSE. - ! if TRUE save Vh average to file Vh_mean.out - REAL(DP), PUBLIC :: vhrmin = 0.0_DP - ! starting "radius" for plotting - REAL(DP), PUBLIC :: vhrmax = 1.0_DP - ! maximum "radius" for plotting - CHARACTER(LEN=1), PUBLIC :: vhasse = 'Z' - ! averaging axis - - LOGICAL, PUBLIC :: tprojwfc = .FALSE. - ! in CP controls the printing of wave function projections - ! on atomic states - LOGICAL, PUBLIC :: tqr=.FALSE. ! if true the Q are in real space - - !LOGICAL, PUBLIC :: real_space=.false. ! if true, the beta functions are treated in real space - ! - ! ... External Forces on Ions - ! - LOGICAL, PUBLIC :: textfor = .FALSE. - - ! - ! ... end of module-scope declarations - ! - !=--------------------------------------------------------------------------=! - CONTAINS - !=--------------------------------------------------------------------------=! - ! - !------------------------------------------------------------------------ - SUBROUTINE fix_dependencies() - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - ! - ! ... Car Parrinello simulation - ! - tcarpar = .TRUE. - ! - IF ( t_diis .OR. tsteepdesc ) THEN - ! - tcarpar = .FALSE. - ! - END IF - ! - ! ... if thdyn = .FALSE. set TSDC and TZEROC to .FALSE. too. - ! - IF ( .NOT. thdyn ) THEN - ! - tsdc = .FALSE. - tzeroc = .FALSE. - ! - END IF - ! - IF ( .NOT. tfor ) THEN - ! - tzerop = .FALSE. - tv0rd = .FALSE. - tsdp = .FALSE. - tcp = .FALSE. - tcap = .FALSE. - tnosep = .FALSE. - ! - ELSE - ! - IF ( tsdp ) THEN - ! - tcp = .FALSE. - tcap = .FALSE. - tnosep = .FALSE. - tv0rd = .FALSE. - ! - END IF - ! - IF ( tv0rd ) tzerop = .TRUE. - ! - END IF - ! - IF ( tsde ) tnosee = .FALSE. - ! - CALL check_flags() - ! - RETURN - ! - END SUBROUTINE fix_dependencies - ! - !------------------------------------------------------------------------ - SUBROUTINE check_flags() - !------------------------------------------------------------------------ - ! - ! ... do some checks for consistency - ! - IF ( tnosee .AND. t_diis ) & - CALL errore( ' control_flags ', 'DIIS + ELECT. NOSE ? ', 0 ) - ! - !IF ( tortho .AND. t_diis ) & - ! CALL errore(' control_flags ','DIIS, ORTHO NOT PERMITTED',0) - ! - IF ( tnosep .AND. tcp ) & - CALL errore( ' control_flags ', ' TCP AND TNOSEP BOTH TRUE', 0 ) - ! - IF ( tnosep .AND. tcap ) & - CALL errore( ' control_flags ', ' TCAP AND TNOSEP BOTH TRUE', 0 ) - ! - IF ( tcp .AND. tcap ) & - CALL errore( ' control_flags ', ' TCP AND TCAP BOTH TRUE', 0 ) - ! - IF ( tdipole .AND. thdyn ) & - CALL errore( ' control_flags ', ' DIPOLE WITH CELL DYNAMICS ', 0 ) - ! - IF ( tv0rd .AND. tsdp ) & - CALL errore( ' control_flags ', & - & ' READING IONS VELOCITY WITH STEEPEST D.', 0 ) - ! - RETURN - ! - END SUBROUTINE check_flags - ! -END MODULE control_flags - diff --git a/quantum_espresso/kcp/Modules/descriptors.f90 b/quantum_espresso/kcp/Modules/descriptors.f90 deleted file mode 100644 index 9d968193d..000000000 --- a/quantum_espresso/kcp/Modules/descriptors.f90 +++ /dev/null @@ -1,201 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - - MODULE descriptors - ! - IMPLICIT NONE - SAVE - - INTEGER ldim_block, ldim_cyclic, ldim_block_cyclic, ldim_block_sca - INTEGER lind_block, lind_cyclic, lind_block_cyclic, lind_block_sca - INTEGER gind_block, gind_cyclic, gind_block_cyclic, gind_block_sca - EXTERNAL ldim_block, ldim_cyclic, ldim_block_cyclic, ldim_block_sca - EXTERNAL lind_block, lind_cyclic, lind_block_cyclic, lind_block_sca - EXTERNAL gind_block, gind_cyclic, gind_block_cyclic, gind_block_sca - - ! Descriptor for Cannon's algorithm - ! - ! Parameters to define and manage the Descriptor - ! of square matricxes block distributed on a square grid of processors - ! to be used with Cannon's algorithm for matrix multiplication - ! - INTEGER, PARAMETER :: descla_siz_ = 16 - INTEGER, PARAMETER :: ilar_ = 1 - INTEGER, PARAMETER :: nlar_ = 2 - INTEGER, PARAMETER :: ilac_ = 3 - INTEGER, PARAMETER :: nlac_ = 4 - INTEGER, PARAMETER :: nlax_ = 5 - INTEGER, PARAMETER :: lambda_node_ = 6 - INTEGER, PARAMETER :: la_n_ = 7 - INTEGER, PARAMETER :: la_nx_ = 8 - INTEGER, PARAMETER :: la_npr_ = 9 - INTEGER, PARAMETER :: la_npc_ = 10 - INTEGER, PARAMETER :: la_myr_ = 11 - INTEGER, PARAMETER :: la_myc_ = 12 - INTEGER, PARAMETER :: la_comm_ = 13 - INTEGER, PARAMETER :: la_me_ = 14 - INTEGER, PARAMETER :: la_nrl_ = 15 - INTEGER, PARAMETER :: la_nrlx_ = 16 - ! - ! desc( ilar_ ) globla index of the first row in the local block of lambda - ! desc( nlar_ ) number of row in the local block of lambda ( the "2" accounts for spin) - ! desc( ilac_ ) global index of the first column in the local block of lambda - ! desc( nlac_ ) number of column in the local block of lambda - ! desc( nlax_ ) leading dimension of the distribute lambda matrix - ! desc( lambda_node_ ) if > 0 the proc holds a block of the lambda matrix - ! desc( la_n_ ) global dimension of the matrix - ! desc( la_nx_ ) global leading dimension - ! desc( la_npr_ ) number of row processors - ! desc( la_npc_ ) number of column processors - ! desc( la_myr_ ) processor row index - ! desc( la_myc_ ) processor column index - ! desc( la_comm_ ) communicator - ! desc( la_me_ ) processor index ( from 0 to desc( la_npr_ ) * desc( la_npc_ ) - 1 ) - ! desc( la_nrl_ ) number of local row, when the matrix is cyclically distributed across proc - ! desc( la_nrlx_ ) leading dimension, when the matrix is distributed by row - - - CONTAINS - - !------------------------------------------------------------------------ - ! - SUBROUTINE descla_local_dims( i2g, nl, n, nx, np, me ) - IMPLICIT NONE - INTEGER, INTENT(OUT) :: i2g ! global index of the first local element - INTEGER, INTENT(OUT) :: nl ! local number of elements - INTEGER, INTENT(IN) :: n ! number of actual element in the global array - INTEGER, INTENT(IN) :: nx ! dimension of the global array (nx>=n) to be distributed - INTEGER, INTENT(IN) :: np ! number of processors - INTEGER, INTENT(IN) :: me ! taskid for which i2g and nl are computed - ! - ! note that we can distribute a global array larger than the - ! number of actual elements. This could be required for performance - ! reasons, and to have an equal partition of matrix having different size - ! like matrixes of spin-up and spin-down - ! -#if __SCALAPACK - nl = ldim_block_sca( nx, np, me ) - i2g = gind_block_sca( 1, nx, np, me ) -#else - nl = ldim_block( nx, np, me ) - i2g = gind_block( 1, nx, np, me ) -#endif - ! This is to try to keep a matrix N * N into the same - ! distribution of a matrix NX * NX, useful to have - ! the matrix of spin-up distributed in the same way - ! of the matrix of spin-down - ! - IF( i2g + nl - 1 > n ) nl = n - i2g + 1 - IF( nl < 0 ) nl = 0 - RETURN - ! - END SUBROUTINE descla_local_dims - ! - ! - SUBROUTINE descla_init( desc, n, nx, np, me, comm, includeme ) - ! - IMPLICIT NONE - INTEGER, INTENT(OUT) :: desc(:) - INTEGER, INTENT(IN) :: n ! the size of this matrix - INTEGER, INTENT(IN) :: nx ! the max among different matrixes sharing - ! this descriptor or the same data distribution - INTEGER, INTENT(IN) :: np(2), me(2), comm - INTEGER, INTENT(IN) :: includeme - INTEGER :: ir, nr, ic, nc, lnode, nlax, nrl, nrlx - INTEGER :: ip, npp - - IF( np(1) /= np(2) ) & - CALL errore( ' descla_init ', ' only square grid of proc are allowed ', 2 ) - IF( n < 0 ) & - CALL errore( ' descla_init ', ' dummy argument n less than 1 ', 3 ) - IF( nx < n ) & - CALL errore( ' descla_init ', ' dummy argument nx less than n ', 4 ) - IF( np(1) < 1 ) & - CALL errore( ' descla_init ', ' dummy argument np less than 1 ', 5 ) - - ! find the block maximum dimensions - -#if __SCALAPACK - nlax = ldim_block_sca( nx, np(1), 0 ) -#else - nlax = ldim_block( nx, np(1), 0 ) - DO ip = 1, np(1) - 1 - nlax = MAX( nlax, ldim_block( nx, np(1), ip ) ) - END DO -#endif - ! - ! find local dimensions, if appropriate - ! - IF( includeme == 1 ) THEN - ! - CALL descla_local_dims( ir, nr, n, nx, np(1), me(1) ) - CALL descla_local_dims( ic, nc, n, nx, np(2), me(2) ) - ! - lnode = 1 - ! - ELSE - ! - nr = 0 - nc = 0 - ! - ir = 0 - ic = 0 - ! - lnode = -1 - ! - END IF - - desc( ilar_ ) = ir - desc( nlar_ ) = nr - desc( ilac_ ) = ic - desc( nlac_ ) = nc - desc( nlax_ ) = nlax - desc( lambda_node_ ) = lnode - desc( la_n_ ) = n - desc( la_nx_ ) = nx - desc( la_npr_ ) = np(1) - desc( la_npc_ ) = np(2) - desc( la_myr_ ) = me(1) - desc( la_myc_ ) = me(2) - desc( la_comm_ ) = comm - desc( la_me_ ) = desc( la_myc_ ) + desc( la_myr_ ) * desc( la_npr_ ) - - npp = np(1) * np(2) - - ! Compute local dimension of the cyclically distributed matrix - ! - IF( includeme == 1 ) THEN - nrl = ldim_cyclic( n, npp, desc( la_me_ ) ) - ELSE - nrl = 0 - END IF - nrlx = n / npp + 1 - - desc( la_nrl_ ) = nrl - desc( la_nrlx_ ) = nrlx - - IF( nr < 0 .OR. nc < 0 ) & - CALL errore( ' descla_init ', ' wrong valune for computed nr and nc ', 1 ) - IF( nlax < 1 ) & - CALL errore( ' descla_init ', ' wrong value for computed nlax ', 2 ) - IF( nlax < nr ) & - CALL errore( ' descla_init ', ' nlax < nr ', ( nr - nlax ) ) - IF( nlax < nc ) & - CALL errore( ' descla_init ', ' nlax < nc ', ( nc - nlax ) ) - IF( nrlx < nrl ) & - CALL errore( ' descla_init ', ' nrlx < nrl ', ( nrl - nrlx ) ) - IF( nrl < 0 ) & - CALL errore( ' descla_init ', ' nrl < 0 ', ABS( nrl ) ) - - ! WRITE(*,*) 'me1,me2,nr,nc,ir,ic= ', me(1), me(2), nr, nc, ir, ic - - RETURN - END SUBROUTINE descla_init - - - END MODULE descriptors diff --git a/quantum_espresso/kcp/Modules/dspev_drv.f90 b/quantum_espresso/kcp/Modules/dspev_drv.f90 deleted file mode 100644 index d308e109e..000000000 --- a/quantum_espresso/kcp/Modules/dspev_drv.f90 +++ /dev/null @@ -1,749 +0,0 @@ -! -! Copyright (C) 2001-2008 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! - -MODULE dspev_module - - - IMPLICIT NONE - SAVE - PRIVATE - - PUBLIC :: pdspev_drv, dspev_drv, dgeev_drv - -#if defined __SCALAPACK - PUBLIC :: pdsyevd_drv -#endif - - -CONTAINS - - - SUBROUTINE ptredv( tv, a, lda, d, e, v, ldv, nrl, n, nproc, me, comm ) - -! -! Parallel version of the famous HOUSEHOLDER tridiagonalization -! Algorithm for simmetric matrix. -! -! AUTHOR : Carlo Cavazzoni - SISSA 1997 -! comments and suggestions to : carlo.cavazzoni@cineca.it -! -! REFERENCES : -! -! NUMERICAL RECIPES, THE ART OF SCIENTIFIC COMPUTING. -! W.H. PRESS, B.P. FLANNERY, S.A. TEUKOLSKY, AND W.T. VETTERLING, -! CAMBRIDGE UNIVERSITY PRESS, CAMBRIDGE. -! -! PARALLEL NUMERICAL ALGORITHMS, -! T.L. FREEMAN AND C.PHILLIPS, -! PRENTICE HALL INTERNATIONAL (1992). -! -! -! -! INPUTS : -! -! TV if it is true compute eigrnvectors "v" -! -! A(NRL,N) Local part of the global matrix A(N,N) to be reduced, -! only the upper triangle is needed. -! The rows of the matrix are distributed among processors -! with blocking factor 1. -! Example for NPROC = 4 : -! ROW | PE -! 1 | 0 -! 2 | 1 -! 3 | 2 -! 4 | 3 -! 5 | 0 -! 6 | 1 -! .. | .. -! -! LDA LEADING DIMENSION OF MATRIX A. -! -! LDV LEADING DIMENSION OF MATRIX V. -! -! NRL NUMBER OF ROWS BELONGING TO THE LOCAL PROCESSOR. -! -! N DIMENSION OF THE GLOBAL MATRIX. -! -! NPROC NUMBER OF PROCESSORS. -! -! ME INDEX OF THE LOCAL PROCESSOR (Starting from 0). -! -! -! OUTPUTS : -! -! V(NRL,N) Orthogonal transformation that tridiagonalize A, -! this matrix is distributed among processor -! in the same way as A. -! -! D(N) Diagonal elements of the tridiagonal matrix -! this vector is equal on all processors. -! -! E(N) Subdiagonal elements of the tridiagonal matrix -! this vector is equal on all processors. -! -! - USE kinds, ONLY : DP - - IMPLICIT NONE - - LOGICAL, INTENT(IN) :: tv - INTEGER, intent(in) :: N, NRL, LDA, LDV - INTEGER, intent(in) :: NPROC, ME, comm - REAL(DP) :: A(LDA,N), D(N), E(N), V(LDV,N) -! - REAL(DP), external ::ddot -! - REAL(DP) :: g, scalef, sigma, kappa, f, h, tmp - REAL(DP), ALLOCATABLE :: u(:) - REAL(DP), ALLOCATABLE :: p(:) - REAL(DP), ALLOCATABLE :: vtmp(:) - - REAL(DP) :: tu, tp, one_over_h - REAL(DP) :: one_over_scale - REAL(DP) :: redin(3), redout(3) - REAL(DP), ALLOCATABLE :: ul(:) - REAL(DP), ALLOCATABLE :: pl(:) - integer :: l, i, j, k, t, tl, ierr - integer :: kl, jl, ks, lloc - integer, ALLOCATABLE :: is(:) - integer, ALLOCATABLE :: ri(:) - - - ! .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... - - IF( N == 0 ) THEN - RETURN - END IF - - ALLOCATE( u( n+2 ), p( n+1 ), vtmp( n+2 ), ul( n ), pl( n ), is( n ), ri( n ) ) - - DO I = N, 1, -1 - IS(I) = (I-1)/NPROC - RI(I) = MOD((I-1),NPROC) ! owner of I-th row - IF(ME .le. RI(I) ) then - IS(I) = IS(I) + 1 - END IF - END DO - - DO I = N, 2, -1 - - L = I - 1 ! first element - H = 0.0_DP - - IF ( L > 1 ) THEN - - SCALEF = 0.0_DP - DO K = 1, is(l) - SCALEF = SCALEF + DABS( A(K,I) ) - END DO - -#if defined __PARA - CALL reduce_base_real( 1, scalef, comm, -1 ) -#endif - - IF ( SCALEF .EQ. 0.0_DP ) THEN - ! - IF (RI(L).EQ.ME) THEN - E(I) = A(is(L),I) - END IF - ! - ELSE - - ! ...... CALCULATION OF SIGMA AND H - - ONE_OVER_SCALE = 1.0_DP/SCALEF - SIGMA = 0.0_DP - DO k = 1,is(L) - A(k,I) = A(k,I) * ONE_OVER_SCALE - SIGMA = SIGMA + A(k,I)**2 - END DO - - IF( ri(l) .eq. me ) THEN - F = A( is(l), i ) - ELSE - F = 0.0_DP - END IF - - ! CONSTRUCTION OF VECTOR U - - vtmp( 1:l ) = 0.0_DP - - k = ME + 1 - DO kl = 1,is(l) - vtmp(k) = A(kl,I) - k = k + NPROC - END DO - - DO kl = 1,is(l) - UL(kl) = A(kl,I) - END DO - -#if defined __PARA - vtmp( l + 1 ) = sigma - vtmp( l + 2 ) = f - CALL reduce_base_real_to( L + 2, vtmp, u, comm, -1 ) - sigma = u( l + 1 ) - f = u( l + 2 ) -#else - u(1:l) = vtmp(1:l) -#endif - - G = -SIGN(SQRT(SIGMA),F) - H = SIGMA - F*G - ONE_OVER_H = 1.0_DP/H - E(I) = SCALEF*G - - U(L) = F - G - - IF( RI(L) == ME ) THEN - UL(is(l)) = F - G - A(is(l),I) = F - G - END IF - - ! CONSTRUCTION OF VECTOR P - - DO J = 1,L - - vtmp(j) = 0.0_DP - - DO KL = 1, IS(J) - vtmp(J) = vtmp(J) + A(KL,J) * UL(KL) - END DO - - IF( L > J .AND. ME == RI(J) ) then - DO K = J+1,L - vtmp(J) = vtmp(J) + A(IS(J),K) * U(K) - END DO - END IF - - vtmp(J) = vtmp(J) * ONE_OVER_H - - END DO - - KAPPA = 0.5_DP * ONE_OVER_H * ddot( l, vtmp, 1, u, 1 ) - -#if defined __PARA - vtmp( l + 1 ) = kappa - CALL reduce_base_real_to( L + 1, vtmp, p, comm, -1 ) - kappa = p( l + 1 ) -#else - p(1:l) = vtmp(1:l) -#endif - - CALL DAXPY( l, -kappa, u, 1, p, 1 ) - CALL DGER( is(l), l, -1.0_DP, ul, 1, p, 1, a, lda ) - CALL DGER( is(l), l, -1.0_DP, p( me + 1 ), nproc, u, 1, a, lda ) - - END IF - - ELSE - - IF(RI(L).EQ.ME) THEN - G = A(is(l),I) - END IF - -#if defined __PARA - CALL bcast_real( g, 1, ri( L ), comm ) -#endif - E(I) = G - - END IF - - D(I) = H - - END DO - - E(1) = 0.0_DP - D(1) = 0.0_DP - - IF( tv ) THEN - DO J = 1,N - V(1:nrl,J) = 0.0_DP - IF(RI(J).EQ.ME) THEN - V(IS(J),J) = 1.0_DP - END IF - END DO - - DO I = 2,N - L = I - 1 - LLOC = IS(L) - ! - IF( D(I) .NE. 0.0_DP ) THEN - ! - ONE_OVER_H = 1.0_DP/D(I) - ! - IF( lloc > 0 ) THEN - CALL DGEMV( 't', lloc, l, 1.0d0, v(1,1), ldv, a(1,i), 1, 0.0d0, p(1), 1 ) - ELSE - P(1:l) = 0.0d0 - END IF - - -#if defined __PARA - CALL reduce_base_real_to( L, p, vtmp, comm, -1 ) -#else - vtmp(1:l) = p(1:l) -#endif - - IF( lloc > 0 ) THEN - CALL DGER( lloc, l, -ONE_OVER_H, a(1,i), 1, vtmp, 1, v, ldv ) - END IF - - END IF - - END DO - - END IF - - - DO I = 1,N - U(I) = 0.0_DP - IF(RI(I).eq.ME) then - U(I) = A(IS(I),I) - END IF - END DO - -#if defined __PARA - CALL reduce_base_real_to( n, u, d, comm, -1 ) -#else - D(1:N) = U(1:N) -#endif - - DEALLOCATE( u, p, vtmp, ul, pl, is, ri ) - - RETURN - END SUBROUTINE ptredv - -!==----------------------------------------------==! - - SUBROUTINE ptqliv( tv, d, e, n, z, ldz, nrl, mpime, comm ) - -! -! Modified QL algorithm for CRAY T3E PARALLEL MACHINE -! calculate the eigenvectors and eigenvalues of a matrix reduced to -! tridiagonal form by PTREDV. -! -! AUTHOR : Carlo Cavazzoni - SISSA 1997 -! comments and suggestions to : carlo.cavazzoni@cineca.it -! -! REFERENCES : -! -! NUMERICAL RECIPES, THE ART OF SCIENTIFIC COMPUTING. -! W.H. PRESS, B.P. FLANNERY, S.A. TEUKOLSKY, AND W.T. VETTERLING, -! CAMBRIDGE UNIVERSITY PRESS, CAMBRIDGE. -! -! PARALLEL NUMERICAL ALGORITHMS, -! T.L. FREEMAN AND C.PHILLIPS, -! PRENTICE HALL INTERNATIONAL (1992). -! -! NOTE : the algorithm that finds the eigenvalues is not parallelized -! ( it scales as O(N^2) ), I preferred to parallelize only the -! updating of the eigenvectors because it is the most costly -! part of the algorithm ( it scales as O(N^3) ). -! For large matrix in practice all the time is spent in the updating -! that in this routine scales linearly with the number of processors, -! in fact there is no communication at all. -! -! -! INPUTS : -! -! TV if it is true compute eigrnvectors "z" -! -! D(N) Diagonal elements of the tridiagonal matrix -! this vector is equal on all processors. -! -! E(N) Subdiagonal elements of the tridiagonal matrix -! this vector is equal on all processors. -! -! N DIMENSION OF THE GLOBAL MATRIX. -! -! NRL NUMBER OF ROWS OF Z BELONGING TO THE LOCAL PROCESSOR. -! -! LDZ LEADING DIMENSION OF MATRIX Z. -! -! Z(LDZ,N) Orthogonal transformation that tridiagonalizes the original -! matrix A. -! The rows of the matrix are distributed among processors -! with blocking factor 1. -! Example for NPROC = 4 : -! ROW | PE -! 1 | 0 -! 2 | 1 -! 3 | 2 -! 4 | 3 -! 5 | 0 -! 6 | 1 -! .. | .. -! -! -! -! OUTPUTS : -! -! Z(LDZ,N) EIGENVECTORS OF THE ORIGINAL MATRIX. -! THE Jth COLUMN of Z contains the eigenvectors associated -! with the jth eigenvalue. -! The eigenvectors are scattered among processors (4PE examp. ) -! eigenvector | PE -! elements | -! V(1) | 0 -! V(2) | 1 -! V(3) | 2 -! V(4) | 3 -! V(5) | 0 -! V(6) | 1 -! .... .. -! -! D(N) Eigenvalues of the original matrix, -! this vector is equal on all processors. -! -! -! -! - USE kinds, ONLY : DP - - IMPLICIT NONE - - LOGICAL, INTENT(IN) :: tv - INTEGER, INTENT(IN) :: n, nrl, ldz, mpime, comm - REAL(DP) :: d(n), e(n) - REAL(DP) :: z(ldz,n) - - INTEGER :: i, iter, mk, k, l, m, ierr - REAL(DP) :: b, dd, f, g, p, r, c, s - REAL(DP), ALLOCATABLE :: cv(:,:) - REAL(DP), ALLOCATABLE :: fv1(:) - REAL(DP), ALLOCATABLE :: fv2(:) - - ALLOCATE( cv( 2,n ) ) - ALLOCATE( fv1( nrl ) ) - ALLOCATE( fv2( nrl ) ) - - do l = 2,n - e(l-1) = e(l) - end do - - do l=1,n - iter=0 -1 do m=l,n-1 - dd = abs(d(m))+abs(d(m+1)) - if ( abs(e(m))+dd .eq. dd ) goto 2 - end do - m=n - -2 if ( m /= l ) then - if ( iter == 200 ) then - call errore(' tqli ',' too many iterations ', iter) - end if - iter=iter+1 - ! - ! iteration is performed on one processor and results broadcast - ! to all others to prevent potential problems if all processors - ! do not behave in exactly the same way (even with the same data!) - ! - if ( mpime == 0 ) then - g=(d(l+1)-d(l))/(2.0_DP*e(l)) - r=pythag(g,1.0_DP) - g=d(m)-d(l)+e(l)/(g+sign(r,g)) - s=1.0_DP - c=1.0_DP - p=0.0_DP - do i=m-1,l,-1 - f=s*e(i) - b=c*e(i) - r=pythag(f,g) - e(i+1)=r - if ( r == 0.0_DP) then - d(i+1)=d(i+1)-p - e(m)=0.0_DP - goto 1 - endif - c=g/r - g=d(i+1)-p - s=f/r - r=(d(i)-g)*s+2.0_DP*c*b - p=s*r - d(i+1)=g+p - g=c*r-b - ! - cv(1,i-l+1) = c - cv(2,i-l+1) = s - !cv(1,i) = c - !cv(2,i) = s - end do - ! - d(l)=d(l)-p - e(l)=g - e(m)=0.0_DP - end if -#if defined __PARA - CALL bcast_real( cv, 2*(m-l), 0, comm ) - CALL bcast_real( d(l), m-l+1, 0, comm ) - CALL bcast_real( e(l), m-l+1, 0, comm ) -#endif - - if( tv ) then - do i=m-1,l,-1 - do k=1,nrl - fv2(k) =z(k,i+1) - end do - do k=1,nrl - fv1(k) =z(k,i) - end do - c = cv(1,i-l+1) - s = cv(2,i-l+1) - do k=1,nrl - z(k,i+1) =s*fv1(k) + c*fv2(k) - z(k,i) =c*fv1(k) - s*fv2(k) - end do - end do - end if - - goto 1 - - endif - end do - - DEALLOCATE( cv ) - DEALLOCATE( fv1 ) - DEALLOCATE( fv2 ) - - RETURN - END SUBROUTINE ptqliv - -!==----------------------------------------------==! - - - SUBROUTINE peigsrtv(tv,d,v,ldv,n,nrl) - - USE kinds, ONLY : DP -! -! This routine sorts eigenvalues and eigenvectors -! generated by PTREDV and PTQLIV. -! -! AUTHOR : Carlo Cavazzoni - SISSA 1997 -! comments and suggestions to : carlo.cavazzoni@cineca.it -! - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: tv - INTEGER, INTENT (IN) :: n,ldv,nrl - REAL(DP), INTENT(INOUT) :: d(n),v(ldv,n) - - INTEGER :: i,j,k - REAL(DP):: p - - do 13 i=1,n-1 - k=i - p=d(i) - do j=i+1,n - if(d(j).le.p)then - k=j - p=d(j) - endif - end do - if(k.ne.i)then - d(k)=d(i) - d(i)=p -! -! Exchange local elements of eigenvectors. -! - if( tv ) then - do j=1,nrl - p=v(j,i) - v(j,i)=v(j,k) - v(j,k)=p - END DO - end if - - endif -13 continue - return - END SUBROUTINE peigsrtv - - ! - !------------------------------------------------------------------------- - FUNCTION pythag(a,b) - USE kinds, ONLY : DP - IMPLICIT NONE - REAL(DP) :: a, b, pythag - REAL(DP) :: absa, absb - absa=abs(a) - absb=abs(b) - if(absa.gt.absb)then - pythag=absa*sqrt(1.0_DP+(absb/absa)**2) - else - if(absb.eq.0.0_DP)then - pythag=0.0_DP - else - pythag=absb*sqrt(1.0_DP+(absa/absb)**2) - endif - endif - return - END FUNCTION pythag - ! -!==----------------------------------------------==! - - SUBROUTINE pdspev_drv( jobz, ap, lda, w, z, ldz, & - nrl, n, nproc, mpime, comm ) - USE kinds, ONLY : DP - IMPLICIT NONE - CHARACTER, INTENT(IN) :: JOBZ - INTEGER, INTENT(IN) :: lda, ldz, nrl, n, nproc, mpime - INTEGER, INTENT(IN) :: comm - REAL(DP) :: ap( lda, * ), w( * ), z( ldz, * ) - REAL(DP), ALLOCATABLE :: sd( : ) - LOGICAL :: tv - ! - IF( n < 1 ) RETURN - ! - tv = .false. - IF( jobz == 'V' .OR. jobz == 'v' ) tv = .true. - - ALLOCATE ( sd ( n ) ) - CALL ptredv( tv, ap, lda, w, sd, z, ldz, nrl, n, nproc, mpime, comm) - CALL ptqliv( tv, w, sd, n, z, ldz, nrl, mpime, comm) - DEALLOCATE ( sd ) - CALL peigsrtv( tv, w, z, ldz, n, nrl) - - RETURN - END SUBROUTINE pdspev_drv - -!==----------------------------------------------==! - - SUBROUTINE dgeev_drv( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR ) - ! - USE kinds, ONLY : DP - IMPLICIT NONE - CHARACTER :: JOBVL, JOBVR - INTEGER :: IOPT, INFO, LDA, LDVR, LDVL, N - REAL(DP) :: WI( * ), WR( * ), VR( LDVR, * ), VL( LDVL , * ), A( LDA, * ) - ! - REAL(DP), ALLOCATABLE :: WORK(:) - INTEGER :: LWORK - - IF( n < 1 ) RETURN - - LWORK=4*n - ALLOCATE( work( LWORK ) ) - - CALL DGEEV(jobvl, jobvr, n, a(1,1), lda, wr(1), wi(1), vl(1,1), ldvl, vr(1,1), ldvr, work, lwork, info) - IF( info .NE. 0 ) THEN - CALL errore( ' dgeev_drv ', ' diagonalization failed ',info ) - END IF - - DEALLOCATE( work ) - - RETURN - ! - END SUBROUTINE dgeev_drv - -!==----------------------------------------------==! - - SUBROUTINE dspev_drv( JOBZ, UPLO, N, AP, W, Z, LDZ ) - USE kinds, ONLY : DP - IMPLICIT NONE - CHARACTER :: JOBZ, UPLO - INTEGER :: IOPT, INFO, LDZ, N - REAL(DP) :: AP( * ), W( * ), Z( LDZ, * ) - REAL(DP), ALLOCATABLE :: WORK(:) - - IF( n < 1 ) RETURN - - ALLOCATE( work( 3*n ) ) - -#if defined __ESSL - IOPT = 0 - IF((JOBZ .EQ. 'V') .OR. (JOBZ .EQ. 'v') ) iopt = iopt + 1 - IF((UPLO .EQ. 'U') .OR. (UPLO .EQ. 'u') ) iopt = iopt + 20 - CALL DSPEV(IOPT, ap, w, z, ldz, n, work, 3*n) -#else - CALL DSPEV(jobz, uplo, n, ap(1), w(1), z(1,1), ldz, work, INFO) - IF( info .NE. 0 ) THEN - CALL errore( ' dspev_drv ', ' diagonalization failed ',info ) - END IF -#endif - - DEALLOCATE( work ) - - RETURN - END SUBROUTINE dspev_drv - - -#if defined __SCALAPACK - - SUBROUTINE pdsyevd_drv( tv, n, nb, s, lds, w, ortho_cntx ) - USE kinds, ONLY : DP - IMPLICIT NONE - - LOGICAL, INTENT(IN) :: tv - ! if tv is true compute eigenvalues and eigenvectors (not used) - INTEGER, INTENT(IN) :: nb, n, ortho_cntx - ! nb = block size, n = matrix size, ortho_cntx = BLACS context - INTEGER, INTENT(IN) :: lds - ! lds = leading dim of s - REAL(DP) :: s(:,:), w(:) - ! input: s = matrix to be diagonalized - ! output: s = eigenvectors, w = eigenvalues - - INTEGER :: desch( 10 ) - REAL(DP) :: rtmp( 4 ) - INTEGER :: itmp( 4 ) - REAL(DP), ALLOCATABLE :: work(:) - REAL(DP), ALLOCATABLE :: vv(:,:) - INTEGER, ALLOCATABLE :: iwork(:) - INTEGER :: LWORK, LIWORK, info - CHARACTER :: jobv - ! - IF( SIZE( s, 1 ) /= lds ) & - CALL errore( ' pdsyevd_drv ', ' wrong matrix leading dimension ', 1 ) - ! - IF( tv ) THEN - ALLOCATE( vv( SIZE( s, 1 ), SIZE( s, 2 ) ) ) - jobv = 'V' - ELSE - CALL errore( ' pdsyevd_drv ', ' PDSYEVD does not compute eigenvalue only ', ABS( info ) ) - END IF - - CALL descinit( desch, n, n, nb, nb, 0, 0, ortho_cntx, SIZE( s, 1 ) , info ) - - IF( info /= 0 ) CALL errore( ' pdsyevd_drv ', ' desckinit ', ABS( info ) ) - - lwork = -1 - liwork = 1 - itmp = 0 - rtmp = 0.0_DP - - CALL PDSYEVD( jobv, 'L', n, s, 1, 1, desch, w, vv, 1, 1, desch, rtmp, lwork, itmp, liwork, info ) - - IF( info /= 0 ) CALL errore( ' pdsyevd_drv ', ' PDSYEVD ', ABS( info ) ) - - lwork = MAX( 131072, 2*INT( rtmp(1) ) + 1 ) - liwork = MAX( 8*n , itmp(1) + 1 ) - - ALLOCATE( work( lwork ) ) - ALLOCATE( iwork( liwork ) ) - - CALL PDSYEVD( jobv, 'L', n, s, 1, 1, desch, w, vv, 1, 1, desch, work, lwork, iwork, liwork, info ) - - IF( info /= 0 ) CALL errore( ' pdsyevd_drv ', ' PDSYEVD ', ABS( info ) ) - - IF( tv ) s = vv - - DEALLOCATE( work ) - DEALLOCATE( iwork ) - IF( ALLOCATED( vv ) ) DEALLOCATE( vv ) - RETURN - END SUBROUTINE pdsyevd_drv - -#endif - - -END MODULE dspev_module diff --git a/quantum_espresso/kcp/Modules/electrons_base.f90 b/quantum_espresso/kcp/Modules/electrons_base.f90 deleted file mode 100644 index e9efff2a0..000000000 --- a/quantum_espresso/kcp/Modules/electrons_base.f90 +++ /dev/null @@ -1,535 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!------------------------------------------------------------------------------! -MODULE electrons_base -!------------------------------------------------------------------------------! - - USE kinds, ONLY: DP -! - IMPLICIT NONE - SAVE - - INTEGER :: nbnd = 0 ! number electronic bands, each band contains - ! two spin states - INTEGER :: nbndx = 0 ! array dimension nbndx >= nbnd - INTEGER :: nspin = 0 ! nspin = number of spins (1=no spin, 2=LSDA) - INTEGER :: nel(2) = 0 ! number of electrons (up, down) - INTEGER :: nelt = 0 ! total number of electrons ( up + down ) - INTEGER :: nupdwn(2) = 0 ! number of states with spin up (1) and down (2) - INTEGER :: iupdwn(2) = 0 ! first state with spin (1) and down (2) - INTEGER :: nudx = 0 ! max (nupdw(1),nupdw(2)) - INTEGER :: nbsp = 0 ! total number of electronic states - ! (nupdwn(1)+nupdwn(2)) - INTEGER :: nbspx = 0 ! array dimension nbspx >= nbsp - - LOGICAL :: telectrons_base_initval = .FALSE. - LOGICAL :: keep_occ = .FALSE. ! if .true. when reading restart file keep - ! the occupations calculated in initval - - REAL(DP), ALLOCATABLE :: f(:) ! occupation numbers ( at gamma ) - REAL(DP) :: qbac = 0.0_DP ! background neutralizing charge - INTEGER, ALLOCATABLE :: ispin(:) ! spin of each state -! -!------------------------------------------------------------------------------! -CONTAINS -!------------------------------------------------------------------------------! - - SUBROUTINE electrons_base_initval(zv_, na_, nsp_, nelec_, nelup_, neldw_, nbnd_, & - nspin_, occupations_, f_inp, tot_charge_, multiplicity_, tot_magnetization_) - - USE constants, ONLY: eps8 - USE io_global, ONLY: stdout - USE control_flags, ONLY: iprsta - - REAL(DP), INTENT(IN) :: zv_(:), tot_charge_ - REAL(DP), INTENT(IN) :: nelec_, nelup_, neldw_ - REAL(DP), INTENT(IN) :: f_inp(:, :) - INTEGER, INTENT(IN) :: na_(:), nsp_, multiplicity_, tot_magnetization_ - INTEGER, INTENT(IN) :: nbnd_, nspin_ - CHARACTER(LEN=*), INTENT(IN) :: occupations_ - - REAL(DP) :: nelec, nelup, neldw, ocp, fsum - INTEGER :: iss, i, in - - nspin = nspin_ - ! - ! ... set nelec - ! - IF (nelec_ /= 0) THEN - nelec = nelec_ - ELSE - nelec = 0.0_DP - DO i = 1, nsp_ - nelec = nelec + na_(i)*zv_(i) - END DO - nelec = nelec - tot_charge_ - END IF - ! - ! ... set nelup/neldw - ! - nelup = nelup_ - neldw = neldw_ - call set_nelup_neldw(nelec, nelup, neldw, tot_magnetization_, & - multiplicity_) - - IF (ABS(nelec - (nelup + neldw)) > eps8) THEN - CALL errore(' electrons_base_initval ', ' inconsistent n. of electrons ', 2) - END IF - ! - ! Compute the number of bands - ! - IF (nbnd_ /= 0) THEN - nbnd = nbnd_ ! nbnd is given from input - ELSE - nbnd = NINT(MAX(nelup, neldw)) ! take the maximum between up and down states - END IF - - IF (nelec < 1) THEN - CALL errore(' electrons_base_initval ', ' nelec less than 1 ', 1) - END IF - ! - IF (ABS(NINT(nelec) - nelec) > eps8) THEN - CALL errore(' electrons_base_initval ', ' nelec must be integer', 2) - END IF - ! - IF (nbnd < 1) & - CALL errore(' electrons_base_initval ', ' nbnd out of range ', 1) - ! - - IF (nspin /= 1 .AND. nspin /= 2) THEN - WRITE (stdout, *) 'nspin = ', nspin - CALL errore(' electrons_base_initval ', ' nspin out of range ', 1) - END IF - - IF (MOD(nbnd, 2) == 0) THEN - nbspx = nbnd*nspin - ELSE - nbspx = (nbnd + 1)*nspin - END IF - - ALLOCATE (f(nbspx)) - ALLOCATE (ispin(nbspx)) - f = 0.0_DP - ispin = 0 - - iupdwn(1) = 1 - nel = 0 - - SELECT CASE (TRIM(occupations_)) - CASE ('bogus') - ! - ! empty-states calculation: occupancies have a (bogus) finite value - ! - ! bogus to ensure \sum_i f_i = Nelec (nelec is integer) - ! - f(:) = nelec/nbspx - nel(1) = nint(nelec) - nupdwn(1) = nbspx - if (nspin == 2) then - ! - ! bogus to ensure Nelec = Nup + Ndw - ! - nel(1) = (nint(nelec) + 1)/2 - nel(2) = nint(nelec)/2 - nupdwn(1) = nbnd - nupdwn(2) = nbnd - iupdwn(2) = nbnd + 1 - end if - ! - keep_occ = .true. - ! - CASE ('from_input') - ! - ! occupancies have been read from input - ! - ! count electrons - ! - IF (nspin == 1) THEN - nelec = SUM(f_inp(:, 1)) - nelup = nelec/2.0_DP - neldw = nelec/2.0_DP - ELSE - nelup = SUM(f_inp(:, 1)) - neldw = SUM(f_inp(:, 2)) - nelec = nelup + neldw - END IF - ! - ! count bands - ! - nupdwn(1) = 0 - nupdwn(2) = 0 - DO i = 1, nbnd - IF (nspin == 1) THEN - IF (f_inp(i, 1) > 0.0_DP) nupdwn(1) = nupdwn(1) + 1 - ELSE - IF (f_inp(i, 1) > 0.0_DP) nupdwn(1) = nupdwn(1) + 1 - IF (f_inp(i, 2) > 0.0_DP) nupdwn(2) = nupdwn(2) + 1 - END IF - END DO - ! - if (nspin == 1) then - nel(1) = nint(nelec) - iupdwn(1) = 1 - else - nel(1) = nint(nelup) - nel(2) = nint(neldw) - iupdwn(1) = 1 - iupdwn(2) = nupdwn(1) + 1 - end if - ! - DO iss = 1, nspin - DO in = iupdwn(iss), iupdwn(iss) - 1 + nupdwn(iss) - f(in) = f_inp(in - iupdwn(iss) + 1, iss) - END DO - END DO - ! - CASE ('fixed') - - if (nspin == 1) then - nel(1) = nint(nelec) - nupdwn(1) = nint(nelec/2.0_DP) - iupdwn(1) = 1 - else - IF (nelup + neldw /= nelec) THEN - CALL errore(' electrons_base_initval ', ' wrong # of up and down spin', 1) - END IF - nel(1) = nint(nelup) - nel(2) = nint(neldw) - nupdwn(1) = nint(nelup) - nupdwn(2) = nint(neldw) - iupdwn(1) = 1 - iupdwn(2) = nupdwn(1) + 1 - end if - -! if( (nspin == 1) .and. MOD( nint(nelec), 2 ) /= 0 ) & -! CALL errore(' electrons_base_initval ', & -! ' must use nspin=2 for odd number of electrons', 1 ) - - ! ocp = 2 for spinless systems, ocp = 1 for spin-polarized systems - ocp = 2.0_DP/nspin - ! - ! default filling: attribute ocp electrons to each states - ! until the good number of electrons is reached - do iss = 1, nspin - fsum = 0.0_DP - do in = iupdwn(iss), iupdwn(iss) - 1 + nupdwn(iss) - if (fsum + ocp < nel(iss) + 0.0001_DP) then - f(in) = ocp - else - f(in) = max(nel(iss) - fsum, 0.0_DP) - end if - fsum = fsum + f(in) - end do - end do - ! - CASE ('ensemble', 'ensemble-dft', 'edft', & - 'smearing') - - if (nspin == 1) then - ! - f(:) = nelec/nbnd - nel(1) = nint(nelec) - nupdwn(1) = nbnd - ! - else - ! - if (nelup .ne. 0) then - if ((nelup + neldw) .ne. nelec) then - CALL errore(' electrons_base_initval ', ' nelup+neldw .ne. nelec', 1) - end if - nel(1) = nelup - nel(2) = neldw - else - nel(1) = (nint(nelec) + 1)/2 - nel(2) = nint(nelec)/2 - end if - ! - nupdwn(1) = nbnd - nupdwn(2) = nbnd - iupdwn(2) = nbnd + 1 - ! - do iss = 1, nspin - do i = iupdwn(iss), iupdwn(iss) - 1 + nupdwn(iss) - f(i) = nel(iss)/DBLE(nupdwn(iss)) - end do - end do - ! - end if - - CASE DEFAULT - CALL errore(' electrons_base_initval ', ' occupation method not implemented', 1) - END SELECT - - do iss = 1, nspin - do in = iupdwn(iss), iupdwn(iss) - 1 + nupdwn(iss) - ispin(in) = iss - end do - end do - - nbndx = nupdwn(1) - nudx = nupdwn(1) - nbsp = nupdwn(1) + nupdwn(2) - - IF (nspin == 1) THEN - nelt = nel(1) - ELSE - nelt = nel(1) + nel(2) - END IF - - IF (nupdwn(1) < nupdwn(2)) & - CALL errore(' electrons_base_initval ', ' nupdwn(1) should be greather or equal nupdwn(2) ', 1) - - IF (nbnd < nupdwn(1)) & - CALL errore(' electrons_base_initval ', ' inconsistent nbnd, should be .GE. than nupdwn(1) ', 1) - - IF (nbspx < (nupdwn(1)*nspin)) & - CALL errore(' electrons_base_initval ', ' inconsistent nbspx, should be .GE. than nspin * nupdwn(1) ', 1) - - IF ((2*nbnd) < nelt) & - CALL errore(' electrons_base_initval ', ' too few states ', 1) - - IF (nbsp < INT(nelec*nspin/2.0_DP)) & - CALL errore(' electrons_base_initval ', ' too many electrons ', 1) - - telectrons_base_initval = .TRUE. - - RETURN - - END SUBROUTINE electrons_base_initval - -!---------------------------------------------------------------------------- - - subroutine set_nelup_neldw(nelec_, nelup_, neldw_, tot_magnetization_, & - multiplicity_) - ! - USE kinds, only: DP - ! - REAL(KIND=DP), intent(IN) :: nelec_ - REAL(KIND=DP), intent(INOUT) :: nelup_, neldw_ - INTEGER, intent(IN) :: tot_magnetization_, multiplicity_ - ! - REAL(KIND=DP) :: nelup_loc, neldw_loc - ! - ! - ! - IF (nelup_ > 0.0_DP .AND. neldw_ > 0.0_DP) THEN - nelup_loc = nelup_ - neldw_loc = neldw_ - ELSE IF (nelup_ > 0.0_DP .AND. neldw_ == 0.0_DP) THEN - nelup_loc = nelup_ - neldw_loc = nelec_ - nelup_ - ELSE IF (nelup_ == 0.0_DP .AND. neldw_ > 0.0_DP) THEN - neldw_loc = neldw_ - nelup_loc = nelec_ - neldw_ - ELSE - IF (multiplicity_ == 0 .AND. tot_magnetization_ < 0) THEN - ! default when multiplicity/tot_magnetization is unspecified - nelup_loc = INT(nelec_ + 1)/2 - neldw_loc = nelec_ - nelup_loc - else - if (multiplicity_ > 0 .AND. tot_magnetization_ < 0) then - ! only multiplicity was specified in the input - ! - ! ... various checks - ! non singlet multiplicity requires nspin=2 - if ((multiplicity_ > 1) .and. (nspin == 1)) & - CALL errore(' set_nelup_neldw ', & - 'spin multiplicity inconsistent with nspin=1 ', 2) - ! odd multiplicity requires an even number of electrons - ! even multiplicity requires an odd number of electrons - if (((MOD(multiplicity_, 2) == 0) .and. (MOD(NINT(nelec_), 2) == 0)) .or. & - ((MOD(multiplicity_, 2) == 1) .and. (MOD(NINT(nelec_), 2) == 1))) & - CALL errore(' set_nelup_neldw ', & - 'spin multiplicity inconsistent with total number of electrons ', 2) - ! - ! ... setting nelup/neldw - nelup_loc = (INT(nelec_) + (multiplicity_ - 1))/2 - neldw_loc = (INT(nelec_) - (multiplicity_ - 1))/2 - elseif (multiplicity_ == 0 .AND. tot_magnetization_ >= 0) then - ! only tot_magnetization was specified - ! - ! ... various checks - if ((tot_magnetization_ > 0) .and. (nspin == 1)) & - CALL errore(' set_nelup_neldw ', & - 'tot_magnetization is inconsistent with nspin=1 ', 2) - ! odd tot_magnetization requires an odd number of electrons - ! even tot_magnetization requires an even number of electrons - if (((MOD(tot_magnetization_, 2) == 0) .and. (MOD(NINT(nelec_), 2) == 1)) .or. & - ((MOD(tot_magnetization_, 2) == 1) .and. (MOD(NINT(nelec_), 2) == 0))) & - CALL errore(' set_nelup_neldw ', & - 'tot_magnetization is inconsistent with total number of electrons ', 2) - ! - ! ... setting nelup/neldw - nelup_loc = (INT(nelec_) + tot_magnetization_)/2 - neldw_loc = (INT(nelec_) - tot_magnetization_)/2 - elseif (multiplicity_ > 0 .AND. tot_magnetization_ >= 0) then - ! both multiplicity and tot_magnetization are specified - ! - ! various checks - call infomsg(' set_nelup_neldw ', & - 'specify EITHER tot_magnetization OR multiplicity, not both!') - ! compatibility check - if ((tot_magnetization_ + 1) .NE. multiplicity_) & - CALL errore(' set_nelup_neldw ', & - 'tot_magnetization and multiplicity are incompatible', 1) - ! - ! - ! - if ((tot_magnetization_ > 0) .and. (nspin == 1)) & - CALL errore(' set_nelup_neldw ', & - 'tot_magnetization is inconsistent with nspin=1 ', 2) - ! odd tot_magnetization requires an odd number of electrons - ! even tot_magnetization requires an even number of electrons - if (((MOD(tot_magnetization_, 2) == 0) .and. (MOD(NINT(nelec_), 2) == 1)) .or. & - ((MOD(tot_magnetization_, 2) == 1) .and. (MOD(NINT(nelec_), 2) == 0))) & - CALL errore(' set_nelup_neldw ', & - 'tot_magnetization is inconsistent with total number of electrons ', 2) - ! - ! ... setting nelup/neldw - nelup_loc = (INT(nelec_) + tot_magnetization_)/2 - neldw_loc = (INT(nelec_) - tot_magnetization_)/2 - end if - end IF - END IF - - nelup_ = nelup_loc - neldw_ = neldw_loc - - return - end subroutine set_nelup_neldw - -!---------------------------------------------------------------------------- - - SUBROUTINE deallocate_elct() - IF (ALLOCATED(f)) DEALLOCATE (f) - IF (ALLOCATED(ispin)) DEALLOCATE (ispin) - telectrons_base_initval = .FALSE. - RETURN - END SUBROUTINE deallocate_elct - -!------------------------------------------------------------------------------! -END MODULE electrons_base -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -MODULE electrons_nose -!------------------------------------------------------------------------------! - - USE kinds, ONLY: DP -! - IMPLICIT NONE - SAVE - - REAL(DP) :: fnosee = 0.0_DP ! frequency of the thermostat ( in THz ) - REAL(DP) :: qne = 0.0_DP ! mass of teh termostat - REAL(DP) :: ekincw = 0.0_DP ! kinetic energy to be kept constant - - REAL(DP) :: xnhe0 = 0.0_DP - REAL(DP) :: xnhep = 0.0_DP - REAL(DP) :: xnhem = 0.0_DP - REAL(DP) :: vnhe = 0.0_DP - -! -!------------------------------------------------------------------------------! -CONTAINS -!------------------------------------------------------------------------------! - - subroutine electrons_nose_init(ekincw_, fnosee_) - USE constants, ONLY: pi, au_terahertz - REAL(DP), INTENT(IN) :: ekincw_, fnosee_ - ! set thermostat parameter for electrons - qne = 0.0_DP - ekincw = ekincw_ - fnosee = fnosee_ - xnhe0 = 0.0_DP - xnhep = 0.0_DP - xnhem = 0.0_DP - vnhe = 0.0_DP - if (fnosee > 0.0_DP) qne = 4.0_DP*ekincw/(fnosee*(2.0_DP*pi)*au_terahertz)**2 - return - end subroutine electrons_nose_init - - function electrons_nose_nrg(xnhe0, vnhe, qne, ekincw) - ! compute energy term for nose thermostat - implicit none - real(dp) :: electrons_nose_nrg - real(dp), intent(in) :: xnhe0, vnhe, qne, ekincw - ! - electrons_nose_nrg = 0.5_DP*qne*vnhe*vnhe + 2.0_DP*ekincw*xnhe0 - ! - return - end function electrons_nose_nrg - - subroutine electrons_nose_shiftvar(xnhep, xnhe0, xnhem) - ! shift values of nose variables to start a new step - implicit none - real(dp), intent(out) :: xnhem - real(dp), intent(inout) :: xnhe0 - real(dp), intent(in) :: xnhep - ! - xnhem = xnhe0 - xnhe0 = xnhep - ! - return - end subroutine electrons_nose_shiftvar - - subroutine electrons_nosevel(vnhe, xnhe0, xnhem, delt) - implicit none - real(dp), intent(inout) :: vnhe - real(dp), intent(in) :: xnhe0, xnhem, delt - vnhe = 2.0_DP*(xnhe0 - xnhem)/delt - vnhe - return - end subroutine electrons_nosevel - - subroutine electrons_noseupd(xnhep, xnhe0, xnhem, delt, qne, ekinc, ekincw, vnhe) - implicit none - real(dp), intent(out) :: xnhep, vnhe - real(dp), intent(in) :: xnhe0, xnhem, delt, qne, ekinc, ekincw - xnhep = 2.0_DP*xnhe0 - xnhem + 2.0_DP*(delt**2/qne)*(ekinc - ekincw) - vnhe = (xnhep - xnhem)/(2.0_DP*delt) - return - end subroutine electrons_noseupd - - SUBROUTINE electrons_nose_info() - - use constants, only: au_terahertz, pi - use time_step, only: delt - USE io_global, ONLY: stdout - USE control_flags, ONLY: tnosee - - IMPLICIT NONE - - INTEGER :: nsvar - REAL(DP) :: wnosee - - IF (tnosee) THEN - ! - IF (fnosee <= 0.0_DP) & - CALL errore(' electrons_nose_info ', ' fnosee less than zero ', 1) - IF (delt <= 0.0_DP) & - CALL errore(' electrons_nose_info ', ' delt less than zero ', 1) - - wnosee = fnosee*(2.0_DP*pi)*au_terahertz - nsvar = (2.0_DP*pi)/(wnosee*delt) - - WRITE (stdout, 563) ekincw, nsvar, fnosee, qne - END IF - -563 format(//, & - & 3X, 'electrons dynamics with nose` temperature control:', /, & - & 3X, 'Kinetic energy required = ', f10.5, ' (a.u.) ', /, & - & 3X, 'time steps per nose osc. = ', i5, /, & - & 3X, 'nose` frequency = ', f10.3, ' (THz) ', /, & - & 3X, 'nose` mass(es) = ', 20(1X, f10.3), //) - - RETURN - END SUBROUTINE electrons_nose_info - -!------------------------------------------------------------------------------! -END MODULE electrons_nose -!------------------------------------------------------------------------------! diff --git a/quantum_espresso/kcp/Modules/energies.f90 b/quantum_espresso/kcp/Modules/energies.f90 deleted file mode 100644 index ab5054dce..000000000 --- a/quantum_espresso/kcp/Modules/energies.f90 +++ /dev/null @@ -1,285 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - - MODULE energies - - USE io_global, ONLY : stdout - USE kinds - IMPLICIT NONE - SAVE - - PRIVATE - - TYPE dft_energy_type - REAL(DP) :: ETOT - REAL(DP) :: SKIN - REAL(DP) :: EMKIN - REAL(DP) :: EHT - REAL(DP) :: EH - REAL(DP) :: SELF_EHTE - REAL(DP) :: EHTE - REAL(DP) :: EHTI - REAL(DP) :: EPSEU - REAL(DP) :: ENL - REAL(DP) :: ENT - REAL(DP) :: VXC - REAL(DP) :: EXC - REAL(DP) :: SELF_VXC - REAL(DP) :: SELF_EXC - REAL(DP) :: ESELF - REAL(DP) :: ESR - REAL(DP) :: EVDW - REAL(DP) :: EBAND - REAL(DP) :: EKIN - REAL(DP) :: ATOT ! Ensamble DFT - REAL(DP) :: ENTROPY ! Ensamble DFT - REAL(DP) :: EGRAND ! Ensamble DFT - REAL(DP) :: VAVE ! Ensamble DFT - REAL(DP) :: EEXTFOR ! Energy of the external forces - REAL(DP) :: EODD !added:giovanni EODD - END TYPE - - REAL(DP) :: EHTE = 0.0_DP - REAL(DP) :: SELF_EHTE = 0.0_DP - REAL(DP) :: EHTI = 0.0_DP - REAL(DP) :: EH = 0.0_DP - REAL(DP) :: EHT = 0.0_DP - REAL(DP) :: SELF_EXC = 0.0_DP - REAL(DP) :: SELF_VXC = 0.0_DP - REAL(DP) :: EKIN = 0.0_DP - REAL(DP) :: ESELF = 0.0_DP - REAL(DP) :: EVDW = 0.0_DP - REAL(DP) :: EPSEU = 0.0_DP - REAL(DP) :: ENT = 0.0_DP - REAL(DP) :: ETOT = 0.0_DP - REAL(DP) :: ENL = 0.0_DP - REAL(DP) :: ESR = 0.0_DP - REAL(DP) :: EXC = 0.0_DP - REAL(DP) :: VXC = 0.0_DP - REAL(DP) :: EBAND = 0.0_DP - REAL(DP) :: ATOT = 0.0_DP - REAL(DP) :: ENTROPY = 0.0_DP - REAL(DP) :: EGRAND = 0.0_DP - REAL(DP) :: VAVE = 0.0_DP ! average potential - REAL(DP) :: EEXTFOR = 0.0_DP ! Energy of the external forces - REAL(DP) :: EODD = 0.0_DP ! Energy of the external forces - - REAL(DP) :: enthal = 0.0_DP, ekincm - - PUBLIC :: dft_energy_type, total_energy, eig_total_energy, & - print_energies, debug_energies - - PUBLIC :: etot, eself, enl, ekin, epseu, esr, eht, exc, ekincm - PUBLIC :: self_exc, self_ehte - - PUBLIC :: atot, entropy, egrand, enthal, vave - - PUBLIC :: eextfor - PUBLIC :: eodd !added:giovanni - - CONTAINS - -! ---------------------------------------------------------------------------- ! - - SUBROUTINE total_energy( edft ) - - TYPE (dft_energy_type) :: edft - - eself = edft%eself - epseu = edft%epseu - ent = edft%ent - enl = edft%enl - evdw = edft%evdw - esr = edft%esr - ekin = edft%ekin - vxc = edft%vxc - ehti = edft%ehti - ehte = edft%ehte - self_ehte = edft%self_ehte - self_exc = edft%self_exc - self_vxc = edft%self_vxc - exc = edft%exc - eht = edft%eht - !eodd = edft%eodd - - !etot = ekin + eht + epseu + enl + exc + evdw - ent + eodd - etot = ekin + eht + epseu + enl + exc + evdw - ent + eodd - ! - edft%etot = etot - - RETURN - END SUBROUTINE total_energy - -! ---------------------------------------------------------------------------- ! - - SUBROUTINE eig_total_energy(ei) - IMPLICIT NONE - REAL(DP), INTENT(IN) :: ei(:) - INTEGER :: i - REAL(DP) etot_band, EII - eband = 0.0_DP - do i = 1, SIZE(ei) - eband = eband + ei(i) * 2.0_DP - end do - EII = ehti + ESR - ESELF - etot_band = eband - ehte + (exc-vxc) + eii - WRITE( stdout,200) etot_band, eband, ehte, (exc-vxc), eii - 200 FORMAT(' *** TOTAL ENERGY : ',F14.8,/ & - ,' eband : ',F14.8,/ & - ,' eh : ',F14.8,/ & - ,' xc : ',F14.8,/ & - ,' eii : ',F14.8) - RETURN - END SUBROUTINE eig_total_energy - -! ---------------------------------------------------------------------------- ! - - SUBROUTINE print_energies( tsic, iprsta, edft, sic_alpha, sic_epsilon, textfor ) - LOGICAL, INTENT(IN) :: tsic - TYPE (dft_energy_type), OPTIONAL, INTENT(IN) :: edft - INTEGER, OPTIONAL, INTENT(IN) :: iprsta - REAL(DP), OPTIONAL, INTENT(IN) :: sic_alpha, sic_epsilon - LOGICAL, OPTIONAL, INTENT(IN) :: textfor - - IF( PRESENT ( edft ) ) THEN - WRITE( stdout, * ) - WRITE( stdout, * ) - WRITE( stdout, 1 ) edft%etot - WRITE( stdout, 2 ) edft%ekin - WRITE( stdout, 3 ) edft%eht - WRITE( stdout, 4 ) edft%eself ! self interaction of the pseudocharges NOT SIC! - WRITE( stdout, 5 ) edft%esr - WRITE( stdout, 9 ) edft%epseu - WRITE( stdout, 10 ) edft%enl - WRITE( stdout, 11 ) edft%exc - IF( PRESENT( iprsta ) ) THEN - IF( iprsta > 1 ) THEN - WRITE( stdout, * ) - WRITE( stdout, 6 ) edft%eh - WRITE( stdout, 7 ) edft%ehte - WRITE( stdout, 8 ) edft%ehti - WRITE( stdout, 12 ) edft%evdw - WRITE( stdout, 13 ) edft%emkin - END IF - END IF - ELSE - ! - ! removed 999 line tag - !IF ( iprsta > 1 ) THEN - ! WRITE( stdout,101) etot, ekin, ehte, eht, esr, eself, epseu, enl, exc, vave - !ELSE - ! WRITE( stdout,100) etot, ekin, eht, esr, eself, epseu, enl, exc, vave - !ENDIF - ! - WRITE( stdout,100) etot, ekin, eht, esr, eself, epseu, enl, exc, vave, eodd, evdw-ent - ! - END IF - ! - IF( tsic ) THEN - ! - IF( .NOT. PRESENT( sic_alpha ) .OR. .NOT. PRESENT( sic_epsilon ) ) & - CALL errore( ' print_energies ', ' sic without parameters? ', 1 ) - - WRITE( stdout, fmt = "('Sic contributes in Mauri&al. approach:')" ) - WRITE( stdout, fmt = "('--------------------------------------')" ) - ! - ! qui e' da aggiungere i due parametetri alpha_si e si_epsilon che determinano "quanto" - ! correggo lo exc e hartree - ! - WRITE( stdout, 14 ) self_ehte, sic_epsilon - WRITE( stdout, 15 ) self_exc, sic_alpha - END IF - ! - IF( PRESENT( textfor ) ) THEN - IF( textfor ) WRITE( stdout, 16 ) eextfor - END IF - ! -1 FORMAT(6X,' total energy = ',F18.10,' Hartree a.u.') -2 FORMAT(6X,' kinetic energy = ',F18.10,' Hartree a.u.') -3 FORMAT(6X,' electrostatic energy = ',F18.10,' Hartree a.u.') -4 FORMAT(6X,' eself = ',F18.10,' Hartree a.u.') -5 FORMAT(6X,' esr = ',F18.10,' Hartree a.u.') -6 FORMAT(6X,' hartree energy = ',F18.10,' Hartree a.u.') -7 FORMAT(6X,' hartree ehte = ',F18.10,' Hartree a.u.') -8 FORMAT(6X,' hartree ehti = ',F18.10,' Hartree a.u.') -9 FORMAT(6X,' pseudopotential energy = ',F18.10,' Hartree a.u.') -10 FORMAT(6X,' n-l pseudopotential energy = ',F18.10,' Hartree a.u.') -11 FORMAT(6X,' exchange-correlation energy = ',F18.10,' Hartree a.u.') -12 FORMAT(6X,' van der waals energy = ',F18.10,' Hartree a.u.') -13 FORMAT(6X,' emass kinetic energy = ',F18.10,' Hartree a.u.') -14 FORMAT(6X,' hartree sic_ehte = ',F18.10,' Hartree a.u.', 1X, 'corr. factor = ',F6.3) -15 FORMAT(6X,' sic exchange-correla energy = ',F18.10,' Hartree a.u.', 1X, 'corr. factor = ',F6.3) -16 FORMAT(6X,' external force energy = ',F18.10,' Hartree a.u.') - - 100 format(//' total energy = ',f18.10,' Hartree a.u.'/ & - & ' kinetic energy = ',f18.10,' Hartree a.u.'/ & - & ' electrostatic energy = ',f18.10,' Hartree a.u.'/ & - & ' esr = ',f18.10,' Hartree a.u.'/ & - & ' eself = ',f18.10,' Hartree a.u.'/ & - & ' pseudopotential energy = ',f18.10,' Hartree a.u.'/ & - & ' n-l pseudopotential energy = ',f18.10,' Hartree a.u.'/ & - & ' exchange-correlation energy = ',f18.10,' Hartree a.u.'/ & - & ' average potential = ',f18.10,' Hartree a.u.'/ & - & ' odd energy = ',f18.10,' Hartree a.u.'/ & - & ' van der waals energy = ',f18.10,' Hartree a.u.'//) - - 101 format(//' total energy = ',f18.10,' Hartree a.u.'/ & - & ' kinetic energy = ',f18.10,' Hartree a.u.'/ & - & ' hartree energy = ',f18.10,' Hartree a.u.'/ & - & ' electrostatic energy = ',f18.10,' Hartree a.u.'/ & - & ' esr = ',f18.10,' Hartree a.u.'/ & - & ' eself = ',f18.10,' Hartree a.u.'/ & - & ' pseudopotential energy = ',f18.10,' Hartree a.u.'/ & - & ' n-l pseudopotential energy = ',f18.10,' Hartree a.u.'/ & - & ' exchange-correlation energy = ',f18.10,' Hartree a.u.'/ & - & ' average potential = ',f18.10,' Hartree a.u.'//) - - RETURN - END SUBROUTINE print_energies - - -! ---------------------------------------------------------------------------- ! - - SUBROUTINE debug_energies( edft ) - TYPE (dft_energy_type), OPTIONAL, INTENT(IN) :: edft - IF( PRESENT ( edft ) ) THEN - WRITE( stdout,2) edft%ETOT, edft%EKIN, edft%EHT, & - edft%ESELF, edft%ESR, edft%EH, & - edft%EPSEU, edft%ENL, edft%EXC, edft%VXC, edft%EVDW, edft%EHTE, & - edft%EHTI, edft%ENT, edft%EBAND, (edft%EXC-edft%VXC), & - (edft%EHTI+edft%ESR-edft%ESELF), & - edft%EBAND-edft%EHTE+(edft%EXC-edft%VXC)+(edft%EHTI+edft%ESR-edft%ESELF) - ELSE - WRITE( stdout,2) ETOT, EKIN, EHT, ESELF, ESR, EH, EPSEU, ENL, EXC, VXC, & - EVDW, EHTE, EHTI, ENT, EBAND, (EXC-VXC), (EHTI+ESR-ESELF), & - EBAND-EHTE+(EXC-VXC)+(EHTI+ESR-ESELF) - END IF -2 FORMAT(/,/ & - ,6X,' ETOT .... = ',F18.10,/ & - ,6X,' EKIN .... = ',F18.10,/ & - ,6X,' EHT ..... = ',F18.10,/ & - ,6X,' ESELF ... = ',F18.10,/ & - ,6X,' ESR ..... = ',F18.10,/ & - ,6X,' EH ...... = ',F18.10,/ & - ,6X,' EPSEU ... = ',F18.10,/ & - ,6X,' ENL ..... = ',F18.10,/ & - ,6X,' EXC ..... = ',F18.10,/ & - ,6X,' VXC ..... = ',F18.10,/ & - ,6X,' EVDW .... = ',F18.10,/ & - ,6X,' EHTE .... = ',F18.10,/ & - ,6X,' EHTI .... = ',F18.10,/ & - ,6X,' ENT ..... = ',F18.10,/ & - ,6X,' EBAND ... = ',F18.10,/ & - ,6X,' EXC-VXC ............................. = ',F18.10,/ & - ,6X,' EHTI+ESR-ESELF ...................... = ',F18.10,/ & - ,6X,' EBAND-EHTE+(EXC-VXC)+(EHTI+ESR-ESELF) = ',F18.10) - RETURN - END SUBROUTINE debug_energies - - - END MODULE energies diff --git a/quantum_espresso/kcp/Modules/error_handler.f90 b/quantum_espresso/kcp/Modules/error_handler.f90 deleted file mode 100644 index 953fcb6e3..000000000 --- a/quantum_espresso/kcp/Modules/error_handler.f90 +++ /dev/null @@ -1,246 +0,0 @@ -! -! Copyright (C) 2001-2007 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -SUBROUTINE errore(calling_routine, message, ierr) - !---------------------------------------------------------------------------- - ! - ! ... This is a simple routine which writes an error message to output: - ! ... if ierr <= 0 it does nothing, - ! ... if ierr > 0 it stops. - ! - ! ... **** Important note for parallel execution *** - ! - ! ... in parallel execution unit 6 is written only by the first node; - ! ... all other nodes have unit 6 redirected to nothing (/dev/null). - ! ... As a consequence an error not occurring on the first node - ! ... will be invisible. For T3E and ORIGIN machines, this problem - ! ... is solved by writing an error message to unit * instead of 6. - ! ... Whenever possible (IBM SP machines), we write to the standard - ! ... error, unit 0 (the message will appear in the error files - ! ... produced by loadleveler). - ! - USE io_global, ONLY: stdout - USE io_files, ONLY: crashunit, crash_file - USE parallel_include - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(IN) :: calling_routine, message - ! the name of the calling calling_routinee - ! the output messagee - INTEGER, INTENT(IN) :: ierr - ! the error flag - INTEGER :: mpime, mpierr - ! the task id - ! - ! - IF (ierr <= 0) RETURN - ! - ! ... the error message is written un the "*" unit - ! - WRITE (UNIT=*, FMT='(/,1X,78("%"))') - WRITE (UNIT=*, & - FMT='(5X,"from ",A," : error #",I10)') calling_routine, ierr - WRITE (UNIT=*, FMT='(5X,A)') message - WRITE (UNIT=*, FMT='(1X,78("%"),/)') - ! -#if defined (__PARA) && defined (__AIX) - ! - ! ... in the case of ibm machines it is also written on the "0" unit - ! ... which is automatically connected to stderr - ! - WRITE (UNIT=0, FMT='(/,1X,78("%"))') - WRITE (UNIT=0, & - FMT='(5X,"from ",A," : error #",I10)') calling_routine, ierr - WRITE (UNIT=0, FMT='(5X,A)') message - WRITE (UNIT=0, FMT='(1X,78("%"),/)') - ! -#endif - ! - WRITE (*, '(" stopping ...")') - ! - CALL flush_unit(stdout) - ! -#if defined (__PARA) && defined (__MPI) - ! - mpime = 0 - ! - CALL MPI_COMM_RANK(MPI_COMM_WORLD, mpime, mpierr) - ! - ! .. write the message to a file and close it before exiting - ! .. this will prevent loss of information on systems that - ! .. do not flush the open streams - ! .. added by C.C. - ! - OPEN (UNIT=crashunit, FILE=crash_file, & - POSITION='APPEND', STATUS='UNKNOWN') - ! - WRITE (UNIT=crashunit, FMT='(/,1X,78("%"))') - WRITE (UNIT=crashunit, FMT='(5X,"task #",I10)') mpime - WRITE (UNIT=crashunit, & - FMT='(5X,"from ",A," : error #",I10)') calling_routine, ierr - WRITE (UNIT=crashunit, FMT='(5X,A)') message - WRITE (UNIT=crashunit, FMT='(1X,78("%"),/)') - ! - CLOSE (UNIT=crashunit) - ! - ! ... try to exit in a smooth way - ! - CALL MPI_ABORT(MPI_COMM_WORLD, ierr, mpierr) - ! - CALL MPI_FINALIZE(mpierr) - ! -#endif - ! - ERROR STOP 1 - ! - RETURN - ! -END SUBROUTINE errore -! -!---------------------------------------------------------------------- -SUBROUTINE infomsg(routine, message) - !---------------------------------------------------------------------- - ! - ! ... This is a simple routine which writes an info message - ! ... from a given routine to output. - ! - USE io_global, ONLY: stdout, ionode - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*) :: routine, message - ! the name of the calling routine - ! the output message - ! - IF (ionode) THEN - ! - WRITE (stdout, '(5X,"Message from routine ",A,":")') routine - WRITE (stdout, '(5X,A)') message - ! - END IF - ! - RETURN - ! -END SUBROUTINE infomsg -! -module error_handler - implicit none - private - - public :: init_error, add_name, chop_name, error_mem, warning - - type chain - character(len=35) :: routine_name - type(chain), pointer :: previous_link - end type chain - - type(chain), pointer :: routine_chain - -contains - - subroutine init_error(routine_name) - implicit none - character(len=*), intent(in) :: routine_name - - allocate (routine_chain) - - routine_chain%routine_name = routine_name - nullify (routine_chain%previous_link) - - return - end subroutine init_error - - subroutine add_name(routine_name) - implicit none - character(len=*), intent(in) :: routine_name - type(chain), pointer :: new_link - - allocate (new_link) - new_link%routine_name = routine_name - new_link%previous_link => routine_chain - routine_chain => new_link - - return - end subroutine add_name - - subroutine chop_name - implicit none - type(chain), pointer :: chopped_chain - - chopped_chain => routine_chain%previous_link - deallocate (routine_chain) - routine_chain => chopped_chain - - return - end subroutine chop_name - - recursive subroutine trace_back(error_code) - - implicit none - integer :: error_code - - write (unit=*, fmt=*) " Called by ", routine_chain%routine_name - if (.not. associated(routine_chain%previous_link)) then - write (unit=*, fmt=*) & - " +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++" - write (unit=*, fmt=*) " " - if (error_code > 0) then - stop - else - return - end if - end if - - routine_chain => routine_chain%previous_link - call trace_back(error_code) - - end subroutine trace_back - - subroutine error_mem(message, error_code) - character(len=*), intent(in) :: message - integer, intent(in), optional :: error_code - integer :: action_code - type(chain), pointer :: save_chain - - if (present(error_code)) then - action_code = error_code - else - action_code = 1 - end if - - if (action_code /= 0) then - write (unit=*, fmt=*) " " - write (unit=*, fmt=*) & - " +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++" - - if (action_code > 0) then - write (unit=*, fmt=*) " Fatal error in routine `", & - trim(routine_chain%routine_name), "': ", message - else - write (unit=*, fmt=*) " Warning from routine `", & - trim(routine_chain%routine_name), "': ", message - save_chain => routine_chain - end if - write (unit=*, fmt=*) & - " +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++" - routine_chain => routine_chain%previous_link - call trace_back(action_code) - routine_chain => save_chain - end if - - return - end subroutine error_mem - - subroutine warning(message) - character(len=*), intent(in) :: message - call error_mem(message, -1) - return - end subroutine warning - -end module error_handler diff --git a/quantum_espresso/kcp/Modules/exc_t.f90 b/quantum_espresso/kcp/Modules/exc_t.f90 deleted file mode 100644 index 54b6f170f..000000000 --- a/quantum_espresso/kcp/Modules/exc_t.f90 +++ /dev/null @@ -1,51 +0,0 @@ -! -! Copyright (C) 2004 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!--------------------------------------------------------------- -function exc_t(rho,rhoc,lsd) - !--------------------------------------------------------------- - ! - use kinds, only : DP - use funct, only : xc, xc_spin - implicit none - integer:: lsd - real(DP) :: exc_t, rho(2),arho,rhot, zeta,rhoc - real(DP) :: ex, ec, vx(2), vc(2) - - real(DP),parameter:: e2 =2.0_DP - - exc_t=0.0_DP - - if(lsd == 0) then - ! - ! LDA case - ! - rhot = rho(1) + rhoc - arho = abs(rhot) - if (arho.gt.1.e-30_DP) then - call xc(arho,ex,ec,vx(1),vc(1)) - exc_t=e2*(ex+ec) - endif - else - ! - ! LSDA case - ! - rhot = rho(1)+rho(2)+rhoc - arho = abs(rhot) - if (arho.gt.1.e-30_DP) then - zeta = (rho(1)-rho(2)) / arho - ! In atomic this cannot happen, but in PAW zeta can become - ! a little larger than 1, or smaller than -1: - if( abs(zeta) > 1._dp) zeta = sign(1._dp, zeta) - call xc_spin(arho,zeta,ex,ec,vx(1),vx(2),vc(1),vc(2)) - exc_t=e2*(ex+ec) - endif - endif - - return -end function exc_t diff --git a/quantum_espresso/kcp/Modules/fft_base.f90 b/quantum_espresso/kcp/Modules/fft_base.f90 deleted file mode 100644 index 9469ed96d..000000000 --- a/quantum_espresso/kcp/Modules/fft_base.f90 +++ /dev/null @@ -1,1051 +0,0 @@ -! -! Copyright (C) 2006 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -#include "f_defs.h" -! -!---------------------------------------------------------------------- -! FFT base Module. -! Written by Carlo Cavazzoni -!---------------------------------------------------------------------- -! -!=----------------------------------------------------------------------=! - MODULE fft_base -!=----------------------------------------------------------------------=! - - USE kinds, ONLY: DP - USE parallel_include - - USE fft_types, ONLY: fft_dlay_descriptor - - IMPLICIT NONE - - ! ... data structure containing all information - ! ... about fft data distribution for a given - ! ... potential grid, and its wave functions sub-grid. - - TYPE ( fft_dlay_descriptor ) :: dfftp ! descriptor for dense grid - TYPE ( fft_dlay_descriptor ) :: dffts ! descriptor for smooth grid - TYPE ( fft_dlay_descriptor ) :: dfftb ! descriptor for box grids - - SAVE - - PRIVATE - - PUBLIC :: fft_scatter, grid_gather, grid_scatter - PUBLIC :: dfftp, dffts, dfftb, fft_dlay_descriptor - PUBLIC :: cgather_sym, cgather_smooth, cscatter_sym, cscatter_smooth - - - -!=----------------------------------------------------------------------=! - CONTAINS -!=----------------------------------------------------------------------=! -! -! -! -#if defined __NONBLOCKING_FFT -! -! NON BLOCKING SCATTER, should be better on switched network -! like infiniband, ethernet, myrinet -! -!----------------------------------------------------------------------- -subroutine fft_scatter ( f_in, nrx3, nxx_, f_aux, ncp_, npp_, sign, use_tg ) - !----------------------------------------------------------------------- - ! - ! transpose the fft grid across nodes - ! a) From columns to planes (sign > 0) - ! - ! "columns" (or "pencil") representation: - ! processor "me" has ncp_(me) contiguous columns along z - ! Each column has nrx3 elements for a fft of order nr3 - ! nrx3 can be =nr3+1 in order to reduce memory conflicts. - ! - ! The transpose take places in two steps: - ! 1) on each processor the columns are divided into slices along z - ! that are stored contiguously. On processor "me", slices for - ! processor "proc" are npp_(proc)*ncp_(me) big - ! 2) all processors communicate to exchange slices - ! (all columns with z in the slice belonging to "me" - ! must be received, all the others must be sent to "proc") - ! Finally one gets the "planes" representation: - ! processor "me" has npp_(me) complete xy planes - ! - ! b) From planes to columns (sign < 0) - ! - ! Quite the same in the opposite direction - ! - ! The output is overwritten on f_in ; f_aux is used as work space - ! - ! If optional argument "use_tg" is true the subroutines performs - ! the trasposition using the Task Groups distribution - ! -#ifdef __PARA - USE parallel_include -#endif - use mp_global, ONLY : nproc_pool, me_pool, intra_pool_comm, nproc, & - my_image_id, nogrp, pgrp_comm, nplist, me_pgrp, npgrp - USE kinds, ONLY : DP - - implicit none - - integer, intent(in) :: nrx3, nxx_, sign, ncp_ (:), npp_ (:) - complex (DP) :: f_in (nxx_), f_aux (nxx_) - logical, optional, intent(in) :: use_tg - -#ifdef __PARA - - INTEGER :: dest, from, k, ip, proc, ierr, me, ipoffset, nprocp, gproc, gcomm, i, kdest, kfrom - INTEGER :: sendcount(nproc_pool), sdispls(nproc_pool), recvcount(nproc_pool), rdispls(nproc_pool) - INTEGER :: offset(nproc_pool) - INTEGER :: sh(nproc_pool), rh(nproc_pool) - ! - LOGICAL :: use_tg_ , lrcv, lsnd - LOGICAL :: tsts(nproc_pool), tstr(nproc_pool) - INTEGER :: istat( MPI_STATUS_SIZE ) - -#if defined __HPM - ! CALL f_hpmstart( 10, 'scatter' ) -#endif - - ! - ! Task Groups - - use_tg_ = .FALSE. - - IF( PRESENT( use_tg ) ) use_tg_ = use_tg - - me = me_pool + 1 - ! - IF( use_tg_ ) THEN - ! This is the number of procs. in the plane-wave group - nprocp = npgrp - ipoffset = me_pgrp - gcomm = pgrp_comm - ELSE - nprocp = nproc_pool - ipoffset = me_pool - gcomm = intra_pool_comm - END IF - ! - if ( nprocp == 1 ) return - ! - call start_clock ('fft_scatter') - ! - ! sendcount(proc): amount of data processor "me" must send to processor - ! recvcount(proc): amount of data processor "me" must receive from - ! - ! offset is used to locate the slices to be sent to proc - ! sdispls+1 is the beginning of data that must be sent to proc - ! rdispls+1 is the beginning of data that must be received from pr - ! - IF( use_tg_ ) THEN - do proc = 1, nprocp - gproc = nplist( proc ) + 1 - sendcount (proc) = npp_ ( gproc ) * ncp_ (me) - recvcount (proc) = npp_ (me) * ncp_ ( gproc ) - end do - offset(1) = 0 - do proc = 2, nprocp - gproc = nplist( proc - 1 ) + 1 - offset(proc) = offset(proc - 1) + npp_ ( gproc ) - end do - ELSE - do proc = 1, nprocp - sendcount (proc) = npp_ (proc) * ncp_ (me) - recvcount (proc) = npp_ (me) * ncp_ (proc) - end do - offset(1) = 0 - do proc = 2, nprocp - offset(proc) = offset(proc - 1) + npp_ (proc - 1) - end do - END IF - ! - sdispls (1) = 0 - rdispls (1) = 0 - do proc = 2, nprocp - sdispls (proc) = sdispls (proc - 1) + sendcount (proc - 1) - rdispls (proc) = rdispls (proc - 1) + recvcount (proc - 1) - enddo - ! - ierr = 0 - ! - if ( sign > 0 ) then - ! - ! "forward" scatter from columns to planes - ! - ! step one: store contiguously the slices and send - ! - do ip = 1, nprocp - - ! the following two lines make the loop iterations different on each - ! proc in order to avoid that all procs send a msg at the same proc - ! at the same time. - ! - proc = ipoffset + 1 + ip - IF( proc > nprocp ) proc = proc - nprocp - - gproc = proc - IF( use_tg_ ) gproc = nplist( proc ) + 1 - ! - from = 1 + offset( proc ) - dest = 1 + sdispls( proc ) - ! - ! optimize for large parallel execution, where npp_ ( gproc ) ~ 1 - ! - SELECT CASE ( npp_ ( gproc ) ) - CASE ( 1 ) - do k = 1, ncp_ (me) - f_aux (dest + (k - 1) ) = f_in (from + (k - 1) * nrx3 ) - enddo - CASE ( 2 ) - do k = 1, ncp_ (me) - f_aux ( dest + (k - 1) * 2 - 1 + 1 ) = f_in ( from + (k - 1) * nrx3 - 1 + 1 ) - f_aux ( dest + (k - 1) * 2 - 1 + 2 ) = f_in ( from + (k - 1) * nrx3 - 1 + 2 ) - enddo - CASE ( 3 ) -!$omp parallel do - do k = 1, ncp_ (me) - f_aux ( dest + (k - 1) * 3 - 1 + 1 ) = f_in ( from + (k - 1) * nrx3 - 1 + 1 ) - f_aux ( dest + (k - 1) * 3 - 1 + 2 ) = f_in ( from + (k - 1) * nrx3 - 1 + 2 ) - f_aux ( dest + (k - 1) * 3 - 1 + 3 ) = f_in ( from + (k - 1) * nrx3 - 1 + 3 ) - enddo - CASE ( 4 ) -!$omp parallel do - do k = 1, ncp_ (me) - f_aux ( dest + (k - 1) * 4 - 1 + 1 ) = f_in ( from + (k - 1) * nrx3 - 1 + 1 ) - f_aux ( dest + (k - 1) * 4 - 1 + 2 ) = f_in ( from + (k - 1) * nrx3 - 1 + 2 ) - f_aux ( dest + (k - 1) * 4 - 1 + 3 ) = f_in ( from + (k - 1) * nrx3 - 1 + 3 ) - f_aux ( dest + (k - 1) * 4 - 1 + 4 ) = f_in ( from + (k - 1) * nrx3 - 1 + 4 ) - enddo - CASE DEFAULT -!$omp parallel do default(shared), private(i, kdest, kfrom) - do k = 1, ncp_ (me) - kdest = dest + (k - 1) * npp_ ( gproc ) - 1 - kfrom = from + (k - 1) * nrx3 - 1 - do i = 1, npp_ ( gproc ) - f_aux ( kdest + i ) = f_in ( kfrom + i ) - enddo - enddo - END SELECT - ! - ! post the non-blocking send, f_aux can't be overwritten until operation has completed - ! - call mpi_isend( f_aux( sdispls( proc ) + 1 ), sendcount( proc ), MPI_DOUBLE_COMPLEX, & - proc-1, me, gcomm, sh( proc ), ierr ) - ! - if( ABS(ierr) /= 0 ) call errore ('fft_scatter', ' forward send info<>0', ABS(ierr) ) - ! - ! - end do - ! - ! step two: receive - ! - do ip = 1, nprocp - ! - proc = ipoffset + 1 - ip - IF( proc < 1 ) proc = proc + nprocp - ! - ! now post the receive - ! - CALL mpi_irecv( f_in( rdispls( proc ) + 1 ), recvcount( proc ), MPI_DOUBLE_COMPLEX, & - proc-1, MPI_ANY_TAG, gcomm, rh( proc ), ierr ) - ! - if( ABS(ierr) /= 0 ) call errore ('fft_scatter', ' forward receive info<>0', ABS(ierr) ) - ! - tstr( proc ) = .false. - tsts( proc ) = .false. - ! - end do - ! - ! maybe useless; ensures that no garbage is present in the output - ! - f_in( rdispls( nprocp ) + recvcount( nprocp ) + 1 : SIZE( f_in ) ) = 0.0_DP - ! - lrcv = .false. - lsnd = .false. - ! - ! exit only when all test are true: message operation have completed - ! - do while ( .not. lrcv .or. .not. lsnd ) - lrcv = .true. - lsnd = .true. - do proc = 1, nprocp - ! - IF( .not. tstr( proc ) ) THEN - call mpi_test( rh( proc ), tstr( proc ), istat, ierr ) - END IF - ! - IF( .not. tsts( proc ) ) THEN - call mpi_test( sh( proc ), tsts( proc ), istat, ierr ) - END IF - ! - lrcv = lrcv .and. tstr( proc ) - lsnd = lsnd .and. tsts( proc ) - ! - end do - ! - end do - ! - else - ! - ! "backward" scatter from planes to columns - ! - do ip = 1, nprocp - - ! post the non blocking send - - proc = ipoffset + 1 + ip - IF( proc > nprocp ) proc = proc - nprocp - - call mpi_isend( f_in( rdispls( proc ) + 1 ), recvcount( proc ), MPI_DOUBLE_COMPLEX, & - proc-1, me, gcomm, sh( proc ), ierr ) - if( ABS(ierr) /= 0 ) call errore ('fft_scatter', ' backward send info<>0', ABS(ierr) ) - - ! post the non blocking receive - - proc = ipoffset + 1 - ip - IF( proc < 1 ) proc = proc + nprocp - - CALL mpi_irecv( f_aux( sdispls( proc ) + 1 ), sendcount( proc ), MPI_DOUBLE_COMPLEX, & - proc-1, MPI_ANY_TAG, gcomm, rh(proc), ierr ) - if( ABS(ierr) /= 0 ) call errore ('fft_scatter', ' backward receive info<>0', ABS(ierr) ) - - tstr( ip ) = .false. - tsts( ip ) = .false. - - end do - ! - lrcv = .false. - lsnd = .false. - ! - ! exit only when all test are true: message hsve been sent and received - ! - do while ( .not. lsnd ) - ! - lsnd = .true. - ! - do proc = 1, nprocp - ! - IF( .not. tsts( proc ) ) THEN - call mpi_test( sh( proc ), tsts( proc ), istat, ierr ) - END IF - - lsnd = lsnd .and. tsts( proc ) - - end do - - end do - ! - lrcv = .false. - ! - do while ( .not. lrcv ) - ! - lrcv = .true. - ! - do proc = 1, nprocp - - gproc = proc - IF( use_tg_ ) gproc = nplist(proc)+1 - - IF( .not. tstr( proc ) ) THEN - - call mpi_test( rh( proc ), tstr( proc ), istat, ierr ) - - IF( tstr( proc ) ) THEN - - from = 1 + sdispls( proc ) - dest = 1 + offset( proc ) - ! - ! optimize for large parallel execution, where npp_ ( gproc ) ~ 1 - ! - SELECT CASE ( npp_ ( gproc ) ) - CASE ( 1 ) - do k = 1, ncp_ (me) - f_in ( dest + (k - 1) * nrx3 ) = f_aux ( from + k - 1 ) - end do - CASE ( 2 ) - do k = 1, ncp_ ( me ) - f_in ( dest + (k - 1) * nrx3 - 1 + 1 ) = f_aux( from + (k - 1) * 2 - 1 + 1 ) - f_in ( dest + (k - 1) * nrx3 - 1 + 2 ) = f_aux( from + (k - 1) * 2 - 1 + 2 ) - enddo - CASE ( 3 ) -!$omp parallel do - do k = 1, ncp_ ( me ) - f_in ( dest + (k - 1) * nrx3 - 1 + 1 ) = f_aux( from + (k - 1) * 3 - 1 + 1 ) - f_in ( dest + (k - 1) * nrx3 - 1 + 2 ) = f_aux( from + (k - 1) * 3 - 1 + 2 ) - f_in ( dest + (k - 1) * nrx3 - 1 + 3 ) = f_aux( from + (k - 1) * 3 - 1 + 3 ) - enddo - CASE ( 4 ) -!$omp parallel do - do k = 1, ncp_ ( me ) - f_in ( dest + (k - 1) * nrx3 - 1 + 1 ) = f_aux( from + (k - 1) * 4 - 1 + 1 ) - f_in ( dest + (k - 1) * nrx3 - 1 + 2 ) = f_aux( from + (k - 1) * 4 - 1 + 2 ) - f_in ( dest + (k - 1) * nrx3 - 1 + 3 ) = f_aux( from + (k - 1) * 4 - 1 + 3 ) - f_in ( dest + (k - 1) * nrx3 - 1 + 4 ) = f_aux( from + (k - 1) * 4 - 1 + 4 ) - enddo - CASE DEFAULT -!$omp parallel do default(shared), private(i, kdest, kfrom) - do k = 1, ncp_ ( me ) - kdest = dest + (k - 1) * nrx3 - 1 - kfrom = from + (k - 1) * npp_ ( gproc ) - 1 - do i = 1, npp_ ( gproc ) - f_in ( kdest + i ) = f_aux( kfrom + i ) - enddo - enddo - END SELECT - - END IF - - END IF - - lrcv = lrcv .and. tstr( proc ) - - end do - - end do - - endif - - call stop_clock ('fft_scatter') - -#endif - -#if defined __HPM - ! CALL f_hpmstop( 10 ) -#endif - - return - -end subroutine fft_scatter -! -! -! -#else -! -! ALLTOALL based SCATTER, should be better on network -! with a defined topology, like on bluegene and cray machine -! -!----------------------------------------------------------------------- -subroutine fft_scatter ( f_in, nrx3, nxx_, f_aux, ncp_, npp_, sign, use_tg ) - !----------------------------------------------------------------------- - ! - ! transpose the fft grid across nodes - ! a) From columns to planes (sign > 0) - ! - ! "columns" (or "pencil") representation: - ! processor "me" has ncp_(me) contiguous columns along z - ! Each column has nrx3 elements for a fft of order nr3 - ! nrx3 can be =nr3+1 in order to reduce memory conflicts. - ! - ! The transpose take places in two steps: - ! 1) on each processor the columns are divided into slices along z - ! that are stored contiguously. On processor "me", slices for - ! processor "proc" are npp_(proc)*ncp_(me) big - ! 2) all processors communicate to exchange slices - ! (all columns with z in the slice belonging to "me" - ! must be received, all the others must be sent to "proc") - ! Finally one gets the "planes" representation: - ! processor "me" has npp_(me) complete xy planes - ! - ! b) From planes to columns (sign < 0) - ! - ! Quite the same in the opposite direction - ! - ! The output is overwritten on f_in ; f_aux is used as work space - ! - ! If optional argument "use_tg" is true the subroutines performs - ! the trasposition using the Task Groups distribution - ! -#ifdef __PARA - USE parallel_include -#endif - use mp_global, ONLY : nproc_pool, me_pool, intra_pool_comm, nproc, & - my_image_id, nogrp, pgrp_comm, nplist - USE kinds, ONLY : DP - - implicit none - - integer, intent(in) :: nrx3, nxx_, sign, ncp_ (:), npp_ (:) - complex (DP) :: f_in (nxx_), f_aux (nxx_) - logical, optional, intent(in) :: use_tg - -#ifdef __PARA - - integer :: dest, from, k, offset, proc, ierr, me, nprocp, gproc, gcomm, i, kdest, kfrom - integer :: sendcount (nproc_pool), sdispls (nproc_pool), recvcount (nproc_pool), rdispls (nproc_pool) - ! - LOGICAL :: use_tg_ - -#if defined __HPM - ! CALL f_hpmstart( 10, 'scatter' ) -#endif - - ! - ! Task Groups - - use_tg_ = .FALSE. - - IF( PRESENT( use_tg ) ) use_tg_ = use_tg - - me = me_pool + 1 - ! - IF( use_tg_ ) THEN - ! This is the number of procs. in the plane-wave group - nprocp = nproc_pool / nogrp - ELSE - nprocp = nproc_pool - END IF - ! - if (nprocp.eq.1) return - ! - call start_clock ('fft_scatter') - ! - ! sendcount(proc): amount of data processor "me" must send to processor - ! recvcount(proc): amount of data processor "me" must receive from - ! offset1(proc) is used to locate the slices to be sent to proc - ! sdispls(proc)+1 is the beginning of data that must be sent to proc - ! rdispls(proc)+1 is the beginning of data that must be received from pr - ! - ! - IF( use_tg_ ) THEN - do proc = 1, nprocp - gproc = nplist( proc ) + 1 - sendcount (proc) = npp_ ( gproc ) * ncp_ (me) - recvcount (proc) = npp_ (me) * ncp_ ( gproc ) - end do - ELSE - do proc = 1, nprocp - sendcount (proc) = npp_ (proc) * ncp_ (me) - recvcount (proc) = npp_ (me) * ncp_ (proc) - end do - END IF - ! - sdispls (1) = 0 - rdispls (1) = 0 - do proc = 2, nprocp - sdispls (proc) = sdispls (proc - 1) + sendcount (proc - 1) - rdispls (proc) = rdispls (proc - 1) + recvcount (proc - 1) - enddo - ! - - ierr = 0 - if (sign.gt.0) then - ! - ! "forward" scatter from columns to planes - ! - ! step one: store contiguously the slices - ! - offset = 1 - - do proc = 1, nprocp - from = offset - dest = 1 + sdispls (proc) - IF( use_tg_ ) THEN - gproc = nplist(proc)+1 - ELSE - gproc = proc - END IF - ! - ! optimize for large parallel execution, where npp_ ( gproc ) ~ 1 - ! - IF( npp_ ( gproc ) > 128 ) THEN - do k = 1, ncp_ (me) - call DCOPY (2 * npp_ ( gproc ), f_in (from + (k - 1) * nrx3), & - 1, f_aux (dest + (k - 1) * npp_ ( gproc ) ), 1) - enddo - ELSE IF( npp_ ( gproc ) == 1 ) THEN - do k = 1, ncp_ (me) - f_aux (dest + (k - 1) ) = f_in (from + (k - 1) * nrx3 ) - enddo - ELSE - do k = 1, ncp_ (me) - kdest = dest + (k - 1) * npp_ ( gproc ) - 1 - kfrom = from + (k - 1) * nrx3 - 1 - do i = 1, npp_ ( gproc ) - f_aux ( kdest + i ) = f_in ( kfrom + i ) - enddo - enddo - END IF - offset = offset + npp_ ( gproc ) - enddo - ! - ! maybe useless; ensures that no garbage is present in the output - ! - f_in = 0.0_DP - ! - ! step two: communication - ! - IF( use_tg_ ) THEN - gcomm = pgrp_comm - ELSE - gcomm = intra_pool_comm - END IF - - call mpi_barrier (gcomm, ierr) ! why barrier? for buggy openmpi over ib - - call mpi_alltoallv (f_aux(1), sendcount, sdispls, MPI_DOUBLE_COMPLEX, f_in(1), & - recvcount, rdispls, MPI_DOUBLE_COMPLEX, gcomm, ierr) - - if( ABS(ierr) /= 0 ) call errore ('fft_scatter', 'info<>0', ABS(ierr) ) - ! - else - ! - ! "backward" scatter from planes to columns - ! - ! step two: communication - ! - IF( use_tg_ ) THEN - gcomm = pgrp_comm - ELSE - gcomm = intra_pool_comm - END IF - - call mpi_barrier (gcomm, ierr) ! why barrier? for buggy openmpi over ib - - call mpi_alltoallv (f_in(1), recvcount, rdispls, MPI_DOUBLE_COMPLEX, f_aux(1), & - sendcount, sdispls, MPI_DOUBLE_COMPLEX, gcomm, ierr) - - if( ABS(ierr) /= 0 ) call errore ('fft_scatter', 'info<>0', ABS(ierr) ) - ! - ! step one: store contiguously the columns - ! - f_in = 0.0_DP - ! - offset = 1 - ! - do proc = 1, nprocp - from = 1 + sdispls (proc) - dest = offset - IF( use_tg_ ) THEN - gproc = nplist(proc)+1 - ELSE - gproc = proc - END IF - ! - ! optimize for large parallel execution, where npp_ ( gproc ) ~ 1 - ! - IF( npp_ ( gproc ) > 128 ) THEN - do k = 1, ncp_ (me) - call DCOPY ( 2 * npp_ ( gproc ), f_aux (from + (k - 1) * npp_ ( gproc ) ), 1, & - f_in (dest + (k - 1) * nrx3 ), 1 ) - enddo - ELSE IF ( npp_ ( gproc ) == 1 ) THEN - do k = 1, ncp_ (me) - f_in ( dest + (k - 1) * nrx3 ) = f_aux ( from + (k - 1) ) - end do - ELSE - do k = 1, ncp_ (me) - kdest = dest + (k - 1) * nrx3 - 1 - kfrom = from + (k - 1) * npp_ ( gproc ) - 1 - do i = 1, npp_ ( gproc ) - f_in ( kdest + i ) = f_aux( kfrom + i ) - enddo - enddo - END IF - ! - offset = offset + npp_ ( gproc ) - ! - enddo - - endif - - call stop_clock ('fft_scatter') - -#endif - -#if defined __HPM - ! CALL f_hpmstop( 10 ) -#endif - - return - -end subroutine fft_scatter - -#endif - -!---------------------------------------------------------------------------- -SUBROUTINE grid_gather( f_in, f_out ) - !---------------------------------------------------------------------------- - ! - ! ... gathers nproc_pool distributed data on the first processor of every pool - ! - ! ... REAL*8 f_in = distributed variable (nxx) - ! ... REAL*8 f_out = gathered variable (nrx1*nrx2*nrx3) - ! - USE kinds, ONLY : DP - USE parallel_include - USE mp_global, ONLY : intra_pool_comm, nproc_pool, me_pool, root_pool - ! - IMPLICIT NONE - ! - REAL(DP) :: f_in( : ), f_out( : ) - ! -#if defined (__PARA) - ! - INTEGER :: proc, info - INTEGER :: displs(0:nproc_pool-1), recvcount(0:nproc_pool-1) - ! - IF( SIZE( f_in ) < dfftp%nnr ) & - CALL errore( ' grid_gather ', ' f_in too small ', dfftp%nnr - SIZE( f_in ) ) - ! - CALL start_clock( 'gather' ) - ! - DO proc = 0, ( nproc_pool - 1 ) - ! - recvcount(proc) = dfftp%nnp * dfftp%npp(proc+1) - ! - IF ( proc == 0 ) THEN - ! - displs(proc) = 0 - ! - ELSE - ! - displs(proc) = displs(proc-1) + recvcount(proc-1) - ! - END IF - ! - END DO - ! - info = SIZE( f_out ) - displs( nproc_pool - 1 ) - recvcount( nproc_pool - 1 ) - ! - IF( info < 0 ) & - CALL errore( ' grid_gather ', ' f_out too small ', -info ) - ! - info = 0 - ! - CALL MPI_GATHERV( f_in, recvcount(me_pool), MPI_DOUBLE_PRECISION, f_out, & - recvcount, displs, MPI_DOUBLE_PRECISION, root_pool, & - intra_pool_comm, info ) - ! - CALL errore( 'gather', 'info<>0', info ) - ! - CALL stop_clock( 'gather' ) - ! -#endif - ! - RETURN - ! -END SUBROUTINE grid_gather - - -!---------------------------------------------------------------------------- -SUBROUTINE grid_scatter( f_in, f_out ) - !---------------------------------------------------------------------------- - ! - ! ... scatters data from the first processor of every pool - ! - ! ... REAL*8 f_in = gathered variable (nrx1*nrx2*nrx3) - ! ... REAL*8 f_out = distributed variable (nxx) - ! - USE mp_global, ONLY : intra_pool_comm, nproc_pool, & - me_pool, root_pool - USE kinds, ONLY : DP - USE parallel_include - ! - IMPLICIT NONE - ! - REAL(DP) :: f_in( : ), f_out( : ) - ! -#if defined (__PARA) - ! - INTEGER :: proc, info - INTEGER :: displs(0:nproc_pool-1), sendcount(0:nproc_pool-1) - ! - IF( SIZE( f_out ) < dfftp%nnr ) & - CALL errore( ' grid_scatter ', ' f_out too small ', dfftp%nnr - SIZE( f_in ) ) - ! - CALL start_clock( 'scatter' ) - ! - DO proc = 0, ( nproc_pool - 1 ) - ! - sendcount(proc) = dfftp%nnp * dfftp%npp(proc+1) - ! - IF ( proc == 0 ) THEN - ! - displs(proc) = 0 - ! - ELSE - ! - displs(proc) = displs(proc-1) + sendcount(proc-1) - ! - END IF - ! - END DO - ! - info = SIZE( f_in ) - displs( nproc_pool - 1 ) - sendcount( nproc_pool - 1 ) - ! - IF( info < 0 ) & - CALL errore( ' grid_scatter ', ' f_in too small ', -info ) - ! - info = 0 - ! - CALL MPI_SCATTERV( f_in, sendcount, displs, MPI_DOUBLE_PRECISION, & - f_out, sendcount(me_pool), MPI_DOUBLE_PRECISION, & - root_pool, intra_pool_comm, info ) - ! - CALL errore( 'scatter', 'info<>0', info ) - ! - IF ( sendcount(me_pool) /= dfftp%nnr ) f_out(sendcount(me_pool)+1:dfftp%nnr) = 0.D0 - ! - CALL stop_clock( 'scatter' ) - ! -#endif - ! - RETURN - ! -END SUBROUTINE grid_scatter -! -! ... "gather"-like subroutines -! -!----------------------------------------------------------------------- -SUBROUTINE cgather_sym( f_in, f_out ) - !----------------------------------------------------------------------- - ! - ! ... gather complex data for symmetrization (in phonon code) - ! ... COMPLEX*16 f_in = distributed variable (nrxx) - ! ... COMPLEX*16 f_out = gathered variable (nrx1*nrx2*nrx3) - ! - USE mp_global, ONLY : intra_pool_comm, intra_image_comm, & - nproc_pool, me_pool - USE mp, ONLY : mp_barrier - USE parallel_include - ! - IMPLICIT NONE - ! - COMPLEX(DP) :: f_in( : ), f_out(:) - ! -#if defined (__PARA) - ! - INTEGER :: proc, info - INTEGER :: displs(0:nproc_pool-1), recvcount(0:nproc_pool-1) - ! - ! - CALL start_clock( 'cgather' ) - ! - DO proc = 0, ( nproc_pool - 1 ) - ! - recvcount(proc) = 2 * dfftp%nnp * dfftp%npp(proc+1) - ! - IF ( proc == 0 ) THEN - ! - displs(proc) = 0 - ! - ELSE - ! - displs(proc) = displs(proc-1) + recvcount(proc-1) - ! - END IF - ! - END DO - ! - CALL mp_barrier( intra_pool_comm ) - ! - CALL MPI_ALLGATHERV( f_in, recvcount(me_pool), MPI_DOUBLE_PRECISION, & - f_out, recvcount, displs, MPI_DOUBLE_PRECISION, & - intra_pool_comm, info ) - ! - CALL errore( 'cgather_sym', 'info<>0', info ) - ! -! CALL mp_barrier( intra_image_comm ) - ! - CALL stop_clock( 'cgather' ) - ! -#endif - ! - RETURN - ! -END SUBROUTINE cgather_sym -! -!---------------------------------------------------------------------------- -SUBROUTINE cgather_smooth ( f_in, f_out ) - !---------------------------------------------------------------------------- - ! - ! ... gathers data on the smooth AND complex fft grid - ! - ! ... gathers nproc_pool distributed data on the first processor of every pool - ! - ! ... COMPLEX*16 f_in = distributed variable ( dffts%nnr ) - ! ... COMPLEX*16 f_out = gathered variable (nrx1s*nrx2s*nrx3s) - ! - USE mp_global, ONLY : intra_pool_comm, nproc_pool, me_pool, root_pool - USE mp, ONLY : mp_barrier - USE kinds, ONLY : DP - USE parallel_include - ! - IMPLICIT NONE - ! - COMPLEX(DP) :: f_in(:), f_out(:) - ! -#if defined (__PARA) - ! - INTEGER :: proc, info - INTEGER :: displs(0:nproc_pool-1), recvcount(0:nproc_pool-1) - ! - ! - CALL start_clock( 'gather' ) - ! - DO proc = 0, ( nproc_pool - 1 ) - ! - recvcount(proc) = 2 * dffts%nnp * dffts%npp(proc+1) - ! - IF ( proc == 0 ) THEN - ! - displs(proc) = 0 - ! - ELSE - ! - displs(proc) = displs(proc-1) + recvcount(proc-1) - ! - END IF - ! - END DO - ! - CALL mp_barrier( intra_pool_comm ) - ! - CALL MPI_GATHERV( f_in, recvcount(me_pool), MPI_DOUBLE_PRECISION, f_out, & - recvcount, displs, MPI_DOUBLE_PRECISION, root_pool, & - intra_pool_comm, info ) - ! - CALL errore( 'gather', 'info<>0', info ) - ! - CALL stop_clock( 'gather' ) - ! -#endif - ! - RETURN - ! -END SUBROUTINE cgather_smooth -! -! ... "scatter"-like subroutines -! -!---------------------------------------------------------------------------- -SUBROUTINE cscatter_sym( f_in, f_out ) - !---------------------------------------------------------------------------- - ! - ! ... scatters data from the first processor of every pool - ! - ! ... COMPLEX*16 f_in = gathered variable (nrx1*nrx2*nrx3) - ! ... COMPLEX*16 f_out = distributed variable (nxx) - ! - USE mp_global, ONLY : intra_pool_comm, nproc_pool, & - me_pool, root_pool - USE mp, ONLY : mp_barrier - USE kinds, ONLY : DP - USE parallel_include - ! - IMPLICIT NONE - ! - COMPLEX(DP) :: f_in(:), f_out(:) - ! -#if defined (__PARA) - ! - INTEGER :: proc, info - INTEGER :: displs(0:nproc_pool-1), sendcount(0:nproc_pool-1) - ! - ! - CALL start_clock( 'cscatter_sym' ) - ! - DO proc = 0, ( nproc_pool - 1 ) - ! - sendcount(proc) = 2 * dfftp%nnp * dfftp%npp(proc+1) - ! - IF ( proc == 0 ) THEN - ! - displs(proc) = 0 - ! - ELSE - ! - displs(proc) = displs(proc-1) + sendcount(proc-1) - ! - END IF - ! - END DO - ! - CALL mp_barrier( intra_pool_comm ) - ! - CALL MPI_SCATTERV( f_in, sendcount, displs, MPI_DOUBLE_PRECISION, & - f_out, sendcount(me_pool), MPI_DOUBLE_PRECISION, & - root_pool, intra_pool_comm, info ) - ! - CALL errore( 'cscatter_sym', 'info<>0', info ) - ! - IF ( sendcount(me_pool) /= dfftp%nnr ) f_out(sendcount(me_pool)+1: dfftp%nnr ) = 0.D0 - ! - CALL stop_clock( 'cscatter_sym' ) - ! -#endif - ! - RETURN - ! -END SUBROUTINE cscatter_sym -! -!---------------------------------------------------------------------------- -SUBROUTINE cscatter_smooth( f_in, f_out ) - !---------------------------------------------------------------------------- - ! - ! ... scatters data on the smooth AND complex fft grid - ! ... scatters data from the first processor of every pool - ! - ! ... COMPLEX*16 f_in = gathered variable (nrx1s*nrx2s*nrx3s) - ! ... COMPLEX*16 f_out = distributed variable ( dffts%nnr) - ! - USE mp_global, ONLY : intra_pool_comm, nproc_pool, & - me_pool, root_pool - USE mp, ONLY : mp_barrier - USE kinds, ONLY : DP - USE parallel_include - ! - IMPLICIT NONE - ! - COMPLEX(DP) :: f_in(:), f_out(:) - ! -#if defined (__PARA) - ! - INTEGER :: proc, info - INTEGER :: displs(0:nproc_pool-1), sendcount(0:nproc_pool-1) - ! - ! - CALL start_clock( 'scatter' ) - ! - DO proc = 0, ( nproc_pool - 1 ) - ! - sendcount(proc) = 2 * dffts%nnp * dffts%npp(proc+1) - ! - IF ( proc == 0 ) THEN - ! - displs(proc) = 0 - ! - ELSE - ! - displs(proc) = displs(proc-1) + sendcount(proc-1) - ! - END IF - ! - END DO - ! - CALL mp_barrier( intra_pool_comm ) - ! - CALL MPI_SCATTERV( f_in, sendcount, displs, MPI_DOUBLE_PRECISION, & - f_out, sendcount(me_pool), MPI_DOUBLE_PRECISION, & - root_pool, intra_pool_comm, info ) - ! - CALL errore( 'scatter', 'info<>0', info ) - ! - IF ( sendcount(me_pool) /= dffts%nnr ) f_out(sendcount(me_pool)+1: dffts%nnr ) = 0.D0 - ! - CALL stop_clock( 'scatter' ) - ! -#endif - ! - RETURN - ! -END SUBROUTINE cscatter_smooth - -!=----------------------------------------------------------------------=! - END MODULE fft_base -!=----------------------------------------------------------------------=! diff --git a/quantum_espresso/kcp/Modules/fft_parallel.f90 b/quantum_espresso/kcp/Modules/fft_parallel.f90 deleted file mode 100644 index 10c947a42..000000000 --- a/quantum_espresso/kcp/Modules/fft_parallel.f90 +++ /dev/null @@ -1,458 +0,0 @@ -! -! Copyright (C) 2001-2004 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!=---------------------------------------------------------------------==! -! -! -! Parallel 3D FFT high level Driver -! ( Charge density and Wave Functions ) -! -! Written and maintained by Carlo Cavazzoni -! Last update Apr. 2009 -! -!=---------------------------------------------------------------------==! -! -MODULE fft_parallel -! - IMPLICIT NONE - SAVE -! -CONTAINS -! -! General purpose driver, including Task groups parallelization -! -!---------------------------------------------------------------------------- -SUBROUTINE tg_cft3s( f, dfft, isgn, use_task_groups ) - !---------------------------------------------------------------------------- - ! - ! ... isgn = +-1 : parallel 3d fft for rho and for the potential - ! NOT IMPLEMENTED WITH TASK GROUPS - ! ... isgn = +-2 : parallel 3d fft for wavefunctions - ! - ! ... isgn = + : G-space to R-space, output = \sum_G f(G)exp(+iG*R) - ! ... fft along z using pencils (cft_1z) - ! ... transpose across nodes (fft_scatter) - ! ... and reorder - ! ... fft along y (using planes) and x (cft_2xy) - ! ... isgn = - : R-space to G-space, output = \int_R f(R)exp(-iG*R)/Omega - ! ... fft along x and y(using planes) (cft_2xy) - ! ... transpose across nodes (fft_scatter) - ! ... and reorder - ! ... fft along z using pencils (cft_1z) - ! - ! ... The array "planes" signals whether a fft is needed along y : - ! ... planes(i)=0 : column f(i,*,*) empty , don't do fft along y - ! ... planes(i)=1 : column f(i,*,*) filled, fft along y needed - ! ... "empty" = no active components are present in f(i,*,*) - ! ... after (isgn>0) or before (isgn<0) the fft on z direction - ! - ! ... Note that if isgn=+/-1 (fft on rho and pot.) all fft's are needed - ! ... and all planes(i) are set to 1 - ! - ! This driver is based on code written by Stefano de Gironcoli for PWSCF. - ! Task Group added by Costas Bekas, Oct. 2005, adapted from the CPMD code - ! (Alessandro Curioni) and revised by Carlo Cavazzoni 2007. - ! - USE fft_scalar, ONLY : cft_1z, cft_2xy - USE fft_base, ONLY : fft_scatter - USE kinds, ONLY : DP - USE mp_global, only : me_pool, nproc_pool, ogrp_comm, npgrp, nogrp, & - intra_pool_comm, nolist, nplist - USE fft_types, ONLY : fft_dlay_descriptor - USE parallel_include - - ! - IMPLICIT NONE - ! - COMPLEX(DP), INTENT(INOUT) :: f( : ) ! array containing data to be transformed - type (fft_dlay_descriptor), intent(in) :: dfft - ! descriptor of fft data layout - INTEGER, INTENT(IN) :: isgn ! fft direction - LOGICAL, OPTIONAL, INTENT(IN) :: use_task_groups - ! specify if you want to use task groups parallelization - ! - INTEGER :: me_p - INTEGER :: n1, n2, n3, nx1, nx2, nx3 - COMPLEX(DP), ALLOCATABLE :: yf(:), aux (:) - INTEGER :: planes( dfft%nr1x ) - LOGICAL :: use_tg - ! -#if defined __OPENMP - REAL(DP) :: tscale -#endif - ! - CALL start_clock( 'cft3s' ) - ! - IF( PRESENT( use_task_groups ) ) THEN - use_tg = use_task_groups - ELSE - use_tg = .FALSE. - END IF - ! - IF( use_tg .AND. .NOT. dfft%have_task_groups ) & - CALL errore( ' tg_cft3s ', ' call requiring task groups for a descriptor without task groups ', 1 ) - ! - n1 = dfft%nr1 - n2 = dfft%nr2 - n3 = dfft%nr3 - nx1 = dfft%nr1x - nx2 = dfft%nr2x - nx3 = dfft%nr3x - ! - IF( use_tg ) THEN - ALLOCATE( aux( nogrp * dfft%nnrx ) ) - ALLOCATE( YF ( nogrp * dfft%nnrx ) ) - ELSE - ALLOCATE( aux( dfft%nnrx ) ) - END IF - ! - me_p = me_pool + 1 - ! - IF ( isgn > 0 ) THEN - ! - IF ( isgn /= 2 ) THEN - ! - IF( use_tg ) & - CALL errore( ' tg_cfft ', ' task groups on large mesh not implemented ', 1 ) - ! - call cft_1z( f, dfft%nsp( me_p ), n3, nx3, isgn, aux ) - ! - planes = dfft%iplp - ! - ELSE - ! - CALL pack_group_sticks() - ! - IF( use_tg ) THEN - CALL cft_1z( yf, dfft%tg_nsw( me_p ), n3, nx3, isgn, aux ) - ELSE - call cft_1z( f, dfft%nsw( me_p ), n3, nx3, isgn, aux ) - END IF - ! - planes = dfft%iplw - ! - END IF - ! - CALL fw_scatter( isgn ) ! forwart scatter from stick to planes - ! - IF( use_tg ) THEN - CALL cft_2xy( f, dfft%tg_npp( me_p ), n1, n2, nx1, nx2, isgn, planes ) - ELSE - CALL cft_2xy( f, dfft%npp( me_p ), n1, n2, nx1, nx2, isgn, planes ) - END IF - ! - ELSE - ! - if ( isgn /= -2 ) then - ! - IF( use_tg ) & - CALL errore( ' tg_cfft ', ' task groups on large mesh not implemented ', 1 ) - ! - planes = dfft%iplp - ! - else - ! - planes = dfft%iplw - ! - endif - - IF( use_tg ) THEN - CALL cft_2xy( f, dfft%tg_npp( me_p ), n1, n2, nx1, nx2, isgn, planes ) - ELSE - call cft_2xy( f, dfft%npp( me_p ), n1, n2, nx1, nx2, isgn, planes) - END IF - ! - CALL bw_scatter( isgn ) - ! - IF ( isgn /= -2 ) THEN - ! - call cft_1z( aux, dfft%nsp( me_p ), n3, nx3, isgn, f ) - ! - ELSE - ! - IF( use_tg ) THEN - CALL cft_1z( aux, dfft%tg_nsw( me_p ), n3, nx3, isgn, yf ) - ELSE - call cft_1z( aux, dfft%nsw( me_p ), n3, nx3, isgn, f ) - END IF - ! - CALL unpack_group_sticks() - ! - END IF - ! -#if defined __OPENMP - tscale = 1.0_DP / (n1 * n2 * n3) - CALL ZDSCAL ( SIZE(f), tscale, f(1), 1); -#endif - ! - END IF - ! - DEALLOCATE( aux ) - ! - IF( use_tg ) THEN - DEALLOCATE( yf ) - END IF - ! - CALL stop_clock( 'cft3s' ) - ! - RETURN - ! -CONTAINS - ! - - SUBROUTINE pack_group_sticks() - - INTEGER :: ierr - ! - if( .NOT. use_tg ) return - ! - IF( dfft%tg_rdsp(nogrp) + dfft%tg_rcv(nogrp) > SIZE( yf ) ) THEN - CALL errore( ' tg_cfft ', ' inconsistent size ', 1 ) - END IF - IF( dfft%tg_psdsp(nogrp) + dfft%tg_snd(nogrp) > SIZE( f ) ) THEN - CALL errore( ' tg_cfft ', ' inconsistent size ', 2 ) - END IF - - CALL start_clock( 'ALLTOALL' ) - ! - ! Collect all the sticks of the different states, - ! in "yf" processors will have all the sticks of the OGRP - -#if defined __MPI - - CALL MPI_ALLTOALLV( f(1), dfft%tg_snd, dfft%tg_psdsp, MPI_DOUBLE_COMPLEX, yf(1), dfft%tg_rcv, & - & dfft%tg_rdsp, MPI_DOUBLE_COMPLEX, ogrp_comm, IERR) - IF( ierr /= 0 ) THEN - CALL errore( ' tg_cfft ', ' alltoall error 1 ', ABS(ierr) ) - END IF - -#endif - - CALL stop_clock( 'ALLTOALL' ) - ! - !YF Contains all ( ~ NOGRP*dfft%nsw(me) ) Z-sticks - ! - RETURN - END SUBROUTINE pack_group_sticks - - ! - - SUBROUTINE unpack_group_sticks() - ! - ! Bring pencils back to their original distribution - ! - INTEGER :: ierr - ! - if( .NOT. use_tg ) return - ! - IF( dfft%tg_usdsp(nogrp) + dfft%tg_snd(nogrp) > SIZE( f ) ) THEN - CALL errore( ' tg_cfft ', ' inconsistent size ', 3 ) - END IF - IF( dfft%tg_rdsp(nogrp) + dfft%tg_rcv(nogrp) > SIZE( yf ) ) THEN - CALL errore( ' tg_cfft ', ' inconsistent size ', 4 ) - END IF - - CALL start_clock( 'ALLTOALL' ) - -#if defined __MPI - CALL MPI_Alltoallv( yf(1), & - dfft%tg_rcv, dfft%tg_rdsp, MPI_DOUBLE_COMPLEX, f(1), & - dfft%tg_snd, dfft%tg_usdsp, MPI_DOUBLE_COMPLEX, ogrp_comm, IERR) - IF( ierr /= 0 ) THEN - CALL errore( ' tg_cfft ', ' alltoall error 2 ', ABS(ierr) ) - END IF -#endif - - CALL stop_clock( 'ALLTOALL' ) - - RETURN - END SUBROUTINE unpack_group_sticks - - ! - - SUBROUTINE fw_scatter( iopt ) - - !Transpose data for the 2-D FFT on the x-y plane - ! - !NOGRP*dfft%nnr: The length of aux and f - !nr3x: The length of each Z-stick - !aux: input - output - !f: working space - !isgn: type of scatter - !dfft%nsw(me) holds the number of Z-sticks proc. me has. - !dfft%npp: number of planes per processor - ! - ! - use fft_base, only: fft_scatter - ! - INTEGER, INTENT(IN) :: iopt - INTEGER :: nppx, ip, nnp, npp, ii, i, mc, j, ioff, it - ! - IF( iopt == 2 ) THEN - ! - IF( use_tg ) THEN - ! - nppx = dfft%tg_npp( me_p ) - npp = dfft%tg_npp( me_p ) - nnp = nx1*nx2 - ! - CALL fft_scatter( aux, nx3, nogrp*dfft%nnrx, f, dfft%tg_nsw, dfft%tg_npp, iopt, use_tg ) - ! - ELSE - ! - nppx = dfft%npp( me_p ) - IF( nproc_pool == 1 ) nppx = dfft%nr3x - npp = dfft%npp( me_p ) - nnp = dfft%nnp - ! - call fft_scatter( aux, nx3, dfft%nnr, f, dfft%nsw, dfft%npp, iopt ) - ! - END IF - ! - ! -!$omp parallel default(shared), private( ii, mc, j, i, ioff, ip, it ) -!$omp do - do i = 1, SIZE( f ) - f(i) = (0.d0, 0.d0) - end do - ! - ii = 0 - ! - do ip = 1, nproc_pool - ! - ioff = dfft%iss( ip ) - ! -!$omp do - do i = 1, dfft%nsw( ip ) - ! - mc = dfft%ismap( i + ioff ) - ! - it = ( ii + i - 1 ) * nppx - ! - do j = 1, npp - f( mc + ( j - 1 ) * nnp ) = aux( j + it ) - end do - ! - end do - ! - ii = ii + dfft%nsw( ip ) - ! - end do -!$omp end parallel - ! - ELSE IF( iopt == 1 ) THEN - ! - if ( nproc_pool == 1 ) then - nppx = dfft%nr3x - else - nppx = dfft%npp( me_p ) - end if - ! - call fft_scatter( aux, nx3, dfft%nnr, f, dfft%nsp, dfft%npp, iopt ) - ! -!$omp parallel default(shared) -!$omp do - do i = 1, SIZE(f) - f(i) = (0.d0, 0.d0) - end do - ! -!$omp do private(mc,j) - do i = 1, dfft%nst - mc = dfft%ismap( i ) - do j = 1, dfft%npp( me_p ) - f( mc + ( j - 1 ) * dfft%nnp ) = aux( j + ( i - 1 ) * nppx ) - end do - end do -!$omp end parallel - ! - END IF - ! - RETURN - END SUBROUTINE fw_scatter - - ! - - SUBROUTINE bw_scatter( iopt ) - ! - use fft_base, only: fft_scatter - ! - INTEGER, INTENT(IN) :: iopt - INTEGER :: nppx, ip, nnp, npp, ii, i, mc, j, it - ! - ! - IF( iopt == -2 ) THEN - ! - IF( use_tg ) THEN - ! - nppx = dfft%tg_npp( me_p ) - npp = dfft%tg_npp( me_p ) - nnp = nx1*nx2 - ! - ELSE - ! - nppx = dfft%npp( me_p ) - IF( nproc_pool == 1 ) nppx = dfft%nr3x - npp = dfft%npp( me_p ) - nnp = dfft%nnp - ! - END IF - - -!$omp parallel default(shared), private( mc, j, i, ii, ip, it ) - ii = 0 - do ip = 1, nproc_pool -!$omp do - do i = 1, dfft%nsw( ip ) - mc = dfft%ismap( i + dfft%iss( ip ) ) - it = (ii + i - 1)*nppx - do j = 1, npp - aux( j + it ) = f( mc + ( j - 1 ) * nnp ) - end do - end do - ii = ii + dfft%nsw( ip ) - end do -!$omp end parallel - ! - IF( use_tg ) THEN - ! - CALL fft_scatter( aux, nx3, nogrp*dfft%nnrx, f, dfft%tg_nsw, dfft%tg_npp, iopt, use_tg ) - ! - ELSE - ! - call fft_scatter( aux, nx3, dfft%nnr, f, dfft%nsw, dfft%npp, iopt ) - ! - END IF - ! - ELSE IF( iopt == -1 ) THEN - ! - if ( nproc_pool == 1 ) then - nppx = dfft%nr3x - else - nppx = dfft%npp( me_p ) - end if -!$omp parallel default(shared), private( mc, j, i ) -!$omp do - do i = 1, dfft%nst - mc = dfft%ismap( i ) - do j = 1, dfft%npp( me_p ) - aux( j + ( i - 1 ) * nppx ) = f( mc + ( j - 1 ) * dfft%nnp ) - end do - end do -!$omp end parallel - ! - call fft_scatter( aux, nx3, dfft%nnr, f, dfft%nsp, dfft%npp, iopt ) - ! - END IF - ! - RETURN - END SUBROUTINE bw_scatter - ! -END SUBROUTINE tg_cft3s -! -END MODULE fft_parallel diff --git a/quantum_espresso/kcp/Modules/fft_scalar.f90 b/quantum_espresso/kcp/Modules/fft_scalar.f90 deleted file mode 100644 index 2f707afa2..000000000 --- a/quantum_espresso/kcp/Modules/fft_scalar.f90 +++ /dev/null @@ -1,2217 +0,0 @@ -! -! Copyright (C) 2001-2008 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -!--------------------------------------------------------------------------! -! FFT scalar drivers Module - contains machine-dependent routines for: ! -! FFTW, FFTW3, ESSL, LINUX_ESSL, SCSL, SUNPERF, NEC ASL and ACML libraries ! -! (both 3d for serial execution and 1d+2d FFTs for parallel execution, ! -! excepted NEC ASL, 3d only, no parallel execution) ! -! Written by Carlo Cavazzoni, modified by P. Giannozzi, contributions ! -! by Martin Hilgemans, Guido Roma, Pascal Thibaudeau, Stephane Lefranc, ! -! Nicolas Lacorne, Filippo Spiga - Last update Aug 2008 ! -!--------------------------------------------------------------------------! - -#include "fft_defs.h" -#include "f_defs.h" - -!=----------------------------------------------------------------------=! - MODULE fft_scalar -!=----------------------------------------------------------------------=! - USE kinds - - IMPLICIT NONE - SAVE - - PRIVATE - PUBLIC :: cft_1z, cft_2xy, cft_b, cfft3d, cfft3ds - PUBLIC :: good_fft_dimension, allowed, good_fft_order - -! ... Local Parameter - - ! ndims Number of different FFT tables that the module - ! could keep into memory without reinitialization - ! nfftx Max allowed fft dimension - - INTEGER, PARAMETER :: ndims = 3, nfftx = 2049 - - ! Workspace that is statically allocated is defined here - ! in order to avoid multiple copies of the same workspace - ! lwork: Dimension of the work space array (if any) - -#if ( defined __ESSL || defined __LINUX_ESSL ) && !defined __FFTW - - ! ESSL IBM library: see the ESSL manual for DCFT - - INTEGER, PARAMETER :: lwork = 20000 + ( 2*nfftx + 256 ) * 64 + 3*nfftx - REAL (DP) :: work( lwork ) - -#elif defined __SCSL || defined __SUNPERF - - ! SGI scientific library scsl and SUN sunperf - - INTEGER, PARAMETER :: lwork = 2 * nfftx - COMPLEX (DP) :: work(lwork) - -#elif defined __FFTW3 - - ! Only FFTW_ESTIMATE is actually used - -#define FFTW_MEASURE 0 -#define FFTW_ESTIMATE 64 - -#endif - -!=----------------------------------------------------------------------=! - CONTAINS -!=----------------------------------------------------------------------=! - -! -!=----------------------------------------------------------------------=! -! -! -! -! FFT along "z" -! -! -! -!=----------------------------------------------------------------------=! -! - - SUBROUTINE cft_1z(c, nsl, nz, ldz, isign, cout) - -! driver routine for nsl 1d complex fft's of length nz -! ldz >= nz is the distance between sequences to be transformed -! (ldz>nz is used on some architectures to reduce memory conflicts) -! input : c(ldz*nsl) (complex) -! output : cout(ldz*nsl) (complex - NOTA BENE: transform is not in-place!) -! isign > 0 : forward (f(G)=>f(R)), isign <0 backward (f(R) => f(G)) -! Up to "ndims" initializations (for different combinations of input -! parameters nz, nsl, ldz) are stored and re-used if available - - INTEGER, INTENT(IN) :: isign - INTEGER, INTENT(IN) :: nsl, nz, ldz - - COMPLEX (DP) :: c(:), cout(:) - - REAL (DP) :: tscale - INTEGER :: i, err, idir, ip - INTEGER, SAVE :: zdims( 3, ndims ) = -1 - INTEGER, SAVE :: icurrent = 1 - LOGICAL :: done - -#if defined __HPM - INTEGER :: OMP_GET_THREAD_NUM -#endif - INTEGER :: tid - - ! ... Machine-Dependent parameters, work arrays and tables of factors - - ! ltabl Dimension of the tables of factors calculated at the - ! initialization stage - -#if defined __OPENMP - INTEGER :: offset, ldz_t -#endif - - -#if defined __FFTW || defined __FFTW3 - - ! Pointers to the "C" structures containing FFT factors ( PLAN ) - ! C_POINTER is defined in include/fft_defs.h - ! for 32bit executables, C_POINTER is integer(4) - ! for 64bit executables, C_POINTER is integer(8) - - C_POINTER, SAVE :: fw_planz( ndims ) = 0 - C_POINTER, SAVE :: bw_planz( ndims ) = 0 - -#elif defined __ACML - - INTEGER, PARAMETER :: ltabl = 3 * nfftx + 100 - INTEGER :: INFO - - COMPLEX (DP), SAVE :: fw_tablez( ltabl, ndims ) - COMPLEX (DP), SAVE :: bw_tablez( ltabl, ndims ) - -#elif defined __ESSL || defined __LINUX_ESSL - - ! ESSL IBM library: see the ESSL manual for DCFT - - INTEGER, PARAMETER :: ltabl = 20000 + 3 * nfftx - REAL (DP), SAVE :: fw_tablez( ltabl, ndims ) - REAL (DP), SAVE :: bw_tablez( ltabl, ndims ) - -#elif defined __SCSL - - ! SGI scientific library scsl - - INTEGER, PARAMETER :: ltabl = 2 * nfftx + 256 - REAL (DP), SAVE :: tablez (ltabl, ndims) - REAL (DP) :: DUMMY - INTEGER, SAVE :: isys(0:1) = (/ 1, 1 /) - -#elif defined __SUNPERF - - ! SUN sunperf library - - INTEGER, PARAMETER :: ltabl = 4 * nfftx + 15 - REAL (DP), SAVE :: tablez (ltabl, ndims) - -#endif - - IF( nsl < 0 ) THEN - CALL errore(" fft_scalar: cft_1z ", " nsl out of range ", nsl) - END IF - - ! - ! Here initialize table only if necessary - ! - - DO ip = 1, ndims - - ! first check if there is already a table initialized - ! for this combination of parameters - - done = ( nz == zdims(1,ip) ) -#if defined __ESSL || defined __LINUX_ESSL || defined __FFTW3 - - ! The initialization in ESSL and FFTW v.3 depends on all three parameters - - done = done .AND. ( nsl == zdims(2,ip) ) .AND. ( ldz == zdims(3,ip) ) -#endif - IF (done) EXIT - END DO - - IF( .NOT. done ) THEN - - ! no table exist for these parameters - ! initialize a new one - - ! WRITE( stdout, fmt="('DEBUG cft_1z, reinitializing tables ', I3)" ) icurrent - -#if defined __FFTW - -#if defined __OPENMP - - IF( fw_planz( icurrent) /= 0 ) CALL DESTROY_PLAN_1D( fw_planz( icurrent) ) - IF( bw_planz( icurrent) /= 0 ) CALL DESTROY_PLAN_1D( bw_planz( icurrent) ) - idir = -1; CALL CREATE_PLAN_1D( fw_planz( icurrent), nz, idir) - idir = 1; CALL CREATE_PLAN_1D( bw_planz( icurrent), nz, idir) - -#else - - IF( fw_planz( icurrent) /= 0 ) CALL DESTROY_PLAN_1D( fw_planz( icurrent) ) - IF( bw_planz( icurrent) /= 0 ) CALL DESTROY_PLAN_1D( bw_planz( icurrent) ) - idir = -1; CALL CREATE_PLAN_1D( fw_planz( icurrent), nz, idir) - idir = 1; CALL CREATE_PLAN_1D( bw_planz( icurrent), nz, idir) - -#endif - -#elif defined __ACML - -#if defined __OPENMP - - CALL ZFFT1MX(0, 1.0_DP, .FALSE., nsl, nz, c(1), 1, ldz, & - cout(1), 1, ldz, fw_tablez(1, icurrent), INFO) - CALL ZFFT1MX(0, 1.0_DP, .FALSE., nsl, nz, c(1), 1, ldz, & - cout(1), 1, ldz, bw_tablez(1, icurrent), INFO) -#else - - tscale = 1.0_DP / nz - CALL ZFFT1MX(0, tscale, .FALSE., nsl, nz, c(1), 1, ldz, & - cout(1), 1, ldz, fw_tablez(1, icurrent), INFO) - CALL ZFFT1MX(0, 1.0_DP, .FALSE., nsl, nz, c(1), 1, ldz, & - cout(1), 1, ldz, bw_tablez(1, icurrent), INFO) - -#endif - - -#elif defined __FFTW3 - - -#if defined __OPENMP - - IF( fw_planz( icurrent) /= 0 ) CALL dfftw_destroy_plan( fw_planz( icurrent) ) - IF( bw_planz( icurrent) /= 0 ) CALL dfftw_destroy_plan( bw_planz( icurrent) ) - idir = -1 - CALL dfftw_plan_many_dft( fw_planz( icurrent), 1, nz, nsl, c, & - (/SIZE(c)/), 1, ldz, cout, (/SIZE(cout)/), 1, ldz, idir, FFTW_ESTIMATE) - idir = 1 - CALL dfftw_plan_many_dft( bw_planz( icurrent), 1, nz, nsl, c, & - (/SIZE(c)/), 1, ldz, cout, (/SIZE(cout)/), 1, ldz, idir, FFTW_ESTIMATE) - -#else - - IF( fw_planz( icurrent) /= 0 ) CALL dfftw_destroy_plan( fw_planz( icurrent) ) - IF( bw_planz( icurrent) /= 0 ) CALL dfftw_destroy_plan( bw_planz( icurrent) ) - idir = -1 - CALL dfftw_plan_many_dft( fw_planz( icurrent), 1, nz, nsl, c, & - (/SIZE(c)/), 1, ldz, cout, (/SIZE(cout)/), 1, ldz, idir, FFTW_ESTIMATE) - idir = 1 - CALL dfftw_plan_many_dft( bw_planz( icurrent), 1, nz, nsl, c, & - (/SIZE(c)/), 1, ldz, cout, (/SIZE(cout)/), 1, ldz, idir, FFTW_ESTIMATE) - -#endif - -#elif defined __ESSL || defined __LINUX_ESSL - -#if defined __OPENMP - - tscale = 1.0_DP - CALL DCFT ( 1, c(1), 1, ldz, cout(1), 1, ldz, nz, 1, 1, & - tscale, fw_tablez(1, icurrent), ltabl, work(1), lwork) - CALL DCFT ( 1, c(1), 1, ldz, cout(1), 1, ldz, nz, 1, -1, & - 1.0_DP, bw_tablez(1, icurrent), ltabl, work(1), lwork) - -#else - - tscale = 1.0_DP / nz - - CALL DCFT ( 1, c(1), 1, ldz, cout(1), 1, ldz, nz, nsl, 1, & - tscale, fw_tablez(1, icurrent), ltabl, work(1), lwork) - CALL DCFT ( 1, c(1), 1, ldz, cout(1), 1, ldz, nz, nsl, -1, & - 1.0_DP, bw_tablez(1, icurrent), ltabl, work(1), lwork) - -#endif - -#elif defined __SCSL - - CALL ZZFFTM (0, nz, 0, 0.0_DP, DUMMY, 1, DUMMY, 1, & - tablez (1, icurrent), DUMMY, isys) - -#elif defined __SUNPERF - - CALL zffti (nz, tablez (1, icurrent) ) - -#else - - CALL errore(' cft_1z ',' no scalar fft driver specified ', 1) - -#endif - - zdims(1,icurrent) = nz; zdims(2,icurrent) = nsl; zdims(3,icurrent) = ldz; - ip = icurrent - icurrent = MOD( icurrent, ndims ) + 1 - - END IF - - ! - ! Now perform the FFTs using machine specific drivers - ! - -#if defined __FFT_CLOCKS - CALL start_clock( 'cft_1z' ) -#endif - -#if defined __FFTW - -#if defined __OPENMP - - ldz_t = ldz - ! - IF (isign < 0) THEN -!$omp parallel default(none) private(tid,offset,i) shared(c,isign,nsl,fw_planz,ip) & -!$omp & firstprivate(ldz_t) -#if defined __HPM - tid = OMP_GET_THREAD_NUM() - CALL f_hpmtstart( 40 + tid, "FW-1z" ) -#endif -!$omp do - DO i=1, nsl - offset = 1 + ((i-1)*ldz_t) - CALL FFT_Z_STICK_SINGLE(fw_planz( ip), c(offset), ldz_t) - END DO -!$omp end do -#if defined __HPM - CALL f_hpmtstop( 40 + tid ) -#endif -!$omp end parallel - ELSE IF (isign > 0) THEN -!$omp parallel default(none) private(tid,offset,i) shared(c,isign,nsl,bw_planz,ip) firstprivate(ldz_t) -#if defined __HPM - tid = OMP_GET_THREAD_NUM() - CALL f_hpmtstart( 10 + tid, "BW-1z" ) -#endif -!$omp do - DO i=1, nsl - offset = 1 + ((i-1)* ldz_t) - CALL FFT_Z_STICK_SINGLE(bw_planz( ip), c(offset), ldz_t) - END DO -!$omp end do -#if defined __HPM - CALL f_hpmtstop( 10 + tid ) -#endif -!$omp end parallel - END IF - - cout( 1 : ldz * nsl ) = c( 1 : ldz * nsl ) - -#else - - IF (isign < 0) THEN - CALL FFT_Z_STICK(fw_planz( ip), c(1), ldz, nsl) - cout( 1 : ldz * nsl ) = c( 1 : ldz * nsl ) / nz - ELSE IF (isign > 0) THEN - CALL FFT_Z_STICK(bw_planz( ip), c(1), ldz, nsl) - cout( 1 : ldz * nsl ) = c( 1 : ldz * nsl ) - END IF - -#endif - -#elif defined __ACML - -#if defined __OPENMP - - IF( isign < 0 ) THEN -!$omp parallel do private(offset, i, INFO) shared(c,fw_tablez,ip,ldz,nsl,cout) default(none) - DO i=1, nsl - offset = 1 + ((i-1)*ldz) - CALL ZFFT1DX (-1,1.0_DP,.FALSE.,ldz,c(offset),1,cout(offset),1, fw_tablez(1, ip), INFO ) - ENDDO -!$omp end parallel do - ELSE IF( isign > 0 ) THEN -!$omp parallel do private(offset, i, INFO) shared(c,bw_tablez,ip,ldz,nsl,cout) default(none) - DO i=1, nsl - offset = 1 + ((i-1)*ldz) - CALL ZFFT1DX (1,1.0_DP,.FALSE.,ldz,c(offset),1,cout(offset),1, bw_tablez(1, ip), INFO ) - ENDDO -!$omp end parallel do - END IF - -#else - - IF( isign < 0 ) THEN - tscale = 1.0_DP / nz - CALL ZFFT1MX(-1, tscale, .FALSE., nsl, ldz, c(1), 1, ldz, cout(1), 1, ldz, & - fw_tablez(1, ip),INFO) - ELSE IF( isign > 0 ) THEN - CALL ZFFT1MX(1, 1.0_DP, .FALSE., nsl, ldz, c(1), 1, ldz, cout(1), 1, ldz, & - bw_tablez(1, ip),INFO) - END IF - -#endif - -#elif defined __FFTW3 - -#if defined __OPENMP - - IF (isign < 0) THEN - CALL dfftw_execute_dft( fw_planz( ip), c, cout) - cout( 1 : ldz * nsl ) = cout( 1 : ldz * nsl ) / nz - ELSE IF (isign > 0) THEN - CALL dfftw_execute_dft( bw_planz( ip), c, cout) - END IF - -#else - - IF (isign < 0) THEN - CALL dfftw_execute_dft( fw_planz( ip), c, cout) - cout( 1 : ldz * nsl ) = cout( 1 : ldz * nsl ) / nz - ELSE IF (isign > 0) THEN - CALL dfftw_execute_dft( bw_planz( ip), c, cout) - END IF - -#endif - - -#elif defined __SCSL - - IF ( isign < 0 ) THEN - idir = -1 - tscale = 1.0_DP / nz - ELSE IF ( isign > 0 ) THEN - idir = 1 - tscale = 1.0_DP - END IF - IF (isign /= 0) CALL ZZFFTM (idir, nz, nsl, tscale, c(1), ldz, & - cout(1), ldz, tablez (1, ip), work, isys) - -#elif defined __ESSL || defined __LINUX_ESSL - - ! essl uses a different convention for forward/backward transforms - ! wrt most other implementations: notice the sign of "idir" - -#if defined __OPENMP - - IF( isign < 0 ) THEN -!$omp parallel do private(i,work,offset) shared(cout,c,ldz,nsl,nz,fw_tablez,ip) default(none) - DO i=1, nsl - offset = 1 + ((i-1)*ldz) - CALL DCFT (0, c(offset), 1, ldz, cout(offset), 1, ldz, nz, 1, 1, & - 1.0_DP, fw_tablez(1, ip), ltabl, work, lwork) - END DO -!$omp end parallel do - ELSE IF( isign > 0 ) THEN -!$omp parallel do private(i,work,offset) shared(cout,c,ldz,nsl,nz,bw_tablez,ip) default(none) - DO i=1, nsl - offset = 1 + ((i-1)*ldz) - CALL DCFT (0, c(offset), 1, ldz, cout(offset), 1, ldz, nz, 1, -1, & - 1.0_DP, bw_tablez(1, ip), ltabl, work, lwork) - END DO -!$omp end parallel do - END IF - -#else - - IF( isign < 0 ) THEN - idir =+1 - tscale = 1.0_DP / nz - CALL DCFT (0, c(1), 1, ldz, cout(1), 1, ldz, nz, nsl, idir, & - tscale, fw_tablez(1, ip), ltabl, work, lwork) - ELSE IF( isign > 0 ) THEN - idir =-1 - tscale = 1.0_DP - CALL DCFT (0, c(1), 1, ldz, cout(1), 1, ldz, nz, nsl, idir, & - tscale, bw_tablez(1, ip), ltabl, work, lwork) - END IF - -#endif - -#elif defined __SUNPERF - - IF ( isign < 0) THEN - DO i = 1, nsl - CALL zfftf ( nz, c(1+(i-1)*ldz), tablez ( 1, ip) ) - END DO - cout( 1 : ldz * nsl ) = c( 1 : ldz * nsl ) / nz - ELSE IF( isign > 0 ) THEN - DO i = 1, nsl - CALL zfftb ( nz, c(1+(i-1)*ldz), tablez ( 1, ip) ) - enddo - cout( 1 : ldz * nsl ) = c( 1 : ldz * nsl ) - END IF - -#else - - CALL errore(' cft_1z ',' no scalar fft driver specified ', 1) - -#endif - -#if defined __FFT_CLOCKS - CALL stop_clock( 'cft_1z' ) -#endif - - RETURN - END SUBROUTINE cft_1z - -! -! -!=----------------------------------------------------------------------=! -! -! -! -! FFT along "x" and "y" direction -! -! -! -!=----------------------------------------------------------------------=! -! -! - - SUBROUTINE cft_2xy(r, nzl, nx, ny, ldx, ldy, isign, pl2ix) - -! driver routine for nzl 2d complex fft's of lengths nx and ny -! input : r(ldx*ldy) complex, transform is in-place -! ldx >= nx, ldy >= ny are the physical dimensions of the equivalent -! 2d array: r2d(ldx, ldy) (x first dimension, y second dimension) -! (ldx>nx, ldy>ny used on some architectures to reduce memory conflicts) -! pl2ix(nx) (optional) is 1 for columns along y to be transformed -! isign > 0 : forward (f(G)=>f(R)), isign <0 backward (f(R) => f(G)) -! Up to "ndims" initializations (for different combinations of input -! parameters nx,ny,nzl,ldx) are stored and re-used if available - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: isign, ldx, ldy, nx, ny, nzl - INTEGER, OPTIONAL, INTENT(IN) :: pl2ix(:) - COMPLEX (DP) :: r( : ) - INTEGER :: i, k, j, err, idir, ip, kk - REAL(DP) :: tscale - INTEGER, SAVE :: icurrent = 1 - INTEGER, SAVE :: dims( 4, ndims) = -1 - LOGICAL :: dofft( nfftx ), done - INTEGER, PARAMETER :: stdout = 6 - -#if defined __HPM - INTEGER :: OMP_GET_THREAD_NUM -#endif - INTEGER :: tid -#if defined __OPENMP - INTEGER :: offset - INTEGER :: nx_t, ny_t, nzl_t, ldx_t, ldy_t -#endif - -#if defined __FFTW || defined __FFTW3 - - C_POINTER, SAVE :: fw_plan( 2, ndims ) = 0 - C_POINTER, SAVE :: bw_plan( 2, ndims ) = 0 - -#elif defined __ACML - - INTEGER, PARAMETER :: ltabl = 3 * nfftx + 100 - INTEGER :: INFO - - COMPLEX (DP), SAVE :: fw_tablex( ltabl, ndims ), bw_tablex( ltabl, ndims ) - COMPLEX (DP), SAVE :: fw_tabley( ltabl, ndims ), bw_tabley( ltabl, ndims ) - -#elif defined __ESSL || defined __LINUX_ESSL - - INTEGER, PARAMETER :: ltabl = 20000 + 3 * nfftx - REAL (DP), SAVE :: fw_tablex( ltabl, ndims ), fw_tabley( ltabl, ndims ) - REAL (DP), SAVE :: bw_tablex( ltabl, ndims ), bw_tabley( ltabl, ndims ) - -#elif defined __SCSL - - INTEGER, PARAMETER :: ltabl = 2 * nfftx + 256 - REAL (DP), SAVE :: tablex (ltabl, ndims), tabley(ltabl, ndims) - COMPLEX (DP) :: XY(nx+nx*ny) - REAL (DP) :: DUMMY - INTEGER, SAVE :: isys(0:1) = (/ 1, 1 /) - -#elif defined __SUNPERF - - INTEGER, PARAMETER :: ltabl = 4 * nfftx + 15 - REAL (DP), SAVE :: tablex (ltabl, ndims) - REAL (DP), SAVE :: tabley (ltabl, ndims) - -#endif - - -#if defined __SCSL - isys(0) = 1 -#endif - - dofft( 1 : nx ) = .TRUE. - IF( PRESENT( pl2ix ) ) THEN - IF( SIZE( pl2ix ) < nx ) & - CALL errore( ' cft_2xy ', ' wrong dimension for arg no. 8 ', 1 ) - DO i = 1, nx - IF( pl2ix(i) < 1 ) dofft( i ) = .FALSE. - END DO - END IF - - ! WRITE( stdout,*) 'DEBUG: ', COUNT( dofft ) - - ! - ! Here initialize table only if necessary - ! - - DO ip = 1, ndims - - ! first check if there is already a table initialized - ! for this combination of parameters - - done = ( ny == dims(1,ip) ) .AND. ( nx == dims(3,ip) ) -#if defined __ESSL || defined __LINUX_ESSL || defined __FFTW3 - ! The initialization in ESSL and FFTW v.3 depends on all four parameters - done = done .AND. ( ldx == dims(2,ip) ) .AND. ( nzl == dims(4,ip) ) -#endif - IF (done) EXIT - END DO - - IF( .NOT. done ) THEN - - ! no table exist for these parameters - ! initialize a new one - - ! WRITE( stdout, fmt="('DEBUG cft_2xy, reinitializing tables ', I3)" ) icurrent - -#if defined __FFTW - - IF( fw_plan( 2,icurrent) /= 0 ) CALL DESTROY_PLAN_1D( fw_plan( 2,icurrent) ) - IF( bw_plan( 2,icurrent) /= 0 ) CALL DESTROY_PLAN_1D( bw_plan( 2,icurrent) ) - idir = -1; CALL CREATE_PLAN_1D( fw_plan( 2,icurrent), ny, idir) - idir = 1; CALL CREATE_PLAN_1D( bw_plan( 2,icurrent), ny, idir) - - IF( fw_plan( 1,icurrent) /= 0 ) CALL DESTROY_PLAN_1D( fw_plan( 1,icurrent) ) - IF( bw_plan( 1,icurrent) /= 0 ) CALL DESTROY_PLAN_1D( bw_plan( 1,icurrent) ) - idir = -1; CALL CREATE_PLAN_1D( fw_plan( 1,icurrent), nx, idir) - idir = 1; CALL CREATE_PLAN_1D( bw_plan( 1,icurrent), nx, idir) - -#elif defined __ACML - -#if defined __OPENMP - - CALL ZFFT1MX(0, 1.0_DP, .TRUE., 1, ny, r(1), ldx, 1, r(1), ldx, 1,fw_tabley(1, icurrent), INFO) - CALL ZFFT1MX(0, 1.0_DP, .TRUE., 1, ny, r(1), ldx, 1, r(1), ldx, 1, bw_tabley(1, icurrent), INFO) - CALL ZFFT1MX(0, 1.0_DP, .TRUE., ny, nx, r(1), 1, ldx, r(1), 1, ldx, fw_tablex(1, icurrent), INFO) - CALL ZFFT1MX(0, 1.0_DP, .TRUE., ny, nx, r(1), 1, ldx, r(1), 1, ldx, bw_tablex(1, icurrent), INFO) - -#else - - tscale = 1.0_DP / ( nx * ny ) - - CALL ZFFT1MX(0, 1.0_DP, .TRUE., 1, ny, r(1), ldx, 1, r(1), ldx, 1,fw_tabley(1, icurrent), INFO) - CALL ZFFT1MX(0, 1.0_DP, .TRUE., 1, ny, r(1), ldx, 1, r(1), ldx, 1, bw_tabley(1, icurrent), INFO) - CALL ZFFT1MX(0, tscale, .TRUE., ny, nx, r(1), 1, ldx, r(1), 1, ldx, fw_tablex(1, icurrent), INFO) - CALL ZFFT1MX(0, 1.0_DP, .TRUE., ny, nx, r(1), 1, ldx, r(1), 1, ldx, bw_tablex(1, icurrent), INFO) - -#endif - - -#elif defined __FFTW3 - - IF ( ldx /= nx .OR. ldy /= ny ) THEN - IF( fw_plan(2,icurrent) /= 0 ) CALL dfftw_destroy_plan( fw_plan(2,icurrent) ) - IF( bw_plan(2,icurrent) /= 0 ) CALL dfftw_destroy_plan( bw_plan(2,icurrent) ) - idir = -1 - CALL dfftw_plan_many_dft( fw_plan(2,icurrent), 1, ny, 1, r(1:), & - (/ldx*ldy/), ldx, 1, r(1:), (/ldx*ldy/), ldx, 1, idir, & - FFTW_ESTIMATE) - idir = 1 - CALL dfftw_plan_many_dft( bw_plan(2,icurrent), 1, ny, 1, r(1:), & - (/ldx*ldy/), ldx, 1, r(1:), (/ldx*ldy/), ldx, 1, idir, & - FFTW_ESTIMATE) - - IF( fw_plan(1,icurrent) /= 0 ) CALL dfftw_destroy_plan( fw_plan(1,icurrent) ) - IF( bw_plan(1,icurrent) /= 0 ) CALL dfftw_destroy_plan( bw_plan(1,icurrent) ) - idir = -1 - CALL dfftw_plan_many_dft( fw_plan(1,icurrent), 1, nx, ny, r(1:), & - (/ldx*ldy/), 1, ldx, r(1:), (/ldx*ldy/), 1, ldx, idir, & - FFTW_ESTIMATE) - idir = 1 - CALL dfftw_plan_many_dft( bw_plan(1,icurrent), 1, nx, ny, r(1:), & - (/ldx*ldy/), 1, ldx, r(1:), (/ldx*ldy/), 1, ldx, idir, & - FFTW_ESTIMATE) - ELSE - IF( fw_plan( 1, icurrent) /= 0 ) CALL dfftw_destroy_plan( fw_plan( 1, icurrent) ) - IF( bw_plan( 1, icurrent) /= 0 ) CALL dfftw_destroy_plan( bw_plan( 1, icurrent) ) - idir = -1 - CALL dfftw_plan_many_dft( fw_plan( 1, icurrent), 2, (/nx, ny/), nzl,& - r(1:), (/nx, ny/), 1, nx*ny, r(1:), (/nx, ny/), 1, nx*ny, idir,& - FFTW_ESTIMATE) - idir = 1 - CALL dfftw_plan_many_dft( bw_plan( 1, icurrent), 2, (/nx, ny/), nzl,& - r(1:), (/nx, ny/), 1, nx*ny, r(1:), (/nx, ny/), 1, nx*ny, idir,& - FFTW_ESTIMATE) - END IF - -#elif defined __ESSL || defined __LINUX_ESSL - -#if defined __OPENMP - - tscale = 1.0_DP - -#else - - tscale = 1.0_DP / ( nx * ny ) - -#endif - - CALL DCFT ( 1, r(1), ldx, 1, r(1), ldx, 1, ny, 1, 1, 1.0_DP, & - fw_tabley( 1, icurrent), ltabl, work(1), lwork ) - CALL DCFT ( 1, r(1), ldx, 1, r(1), ldx, 1, ny, 1, -1, 1.0_DP, & - bw_tabley(1, icurrent), ltabl, work(1), lwork ) - CALL DCFT ( 1, r(1), 1, ldx, r(1), 1, ldx, nx, ny, 1, & - tscale, fw_tablex( 1, icurrent), ltabl, work(1), lwork) - CALL DCFT ( 1, r(1), 1, ldx, r(1), 1, ldx, nx, ny, -1, & - 1.0_DP, bw_tablex(1, icurrent), ltabl, work(1), lwork) - - -#elif defined __SCSL - - CALL ZZFFTMR (0, ny, 0, 0.0_DP, DUMMY, 1, DUMMY, 1, & - tabley (1, icurrent), DUMMY, isys) - CALL ZZFFTM (0, nx, 0, 0.0_DP, DUMMY, 1, DUMMY, 1, & - tablex (1, icurrent), DUMMY, isys) - -#elif defined __SUNPERF - - CALL zffti (ny, tabley (1, icurrent) ) - CALL zffti (nx, tablex (1, icurrent) ) - -#else - - CALL errore(' cft_2xy ',' no scalar fft driver specified ', 1) - -#endif - - dims(1,icurrent) = ny; dims(2,icurrent) = ldx; - dims(3,icurrent) = nx; dims(4,icurrent) = nzl; - ip = icurrent - icurrent = MOD( icurrent, ndims ) + 1 - - END IF - - ! - ! Now perform the FFTs using machine specific drivers - ! - -#if defined __FFT_CLOCKS - CALL start_clock( 'cft_2xy' ) -#endif - - -#if defined __FFTW - -#if defined __OPENMP - - nx_t = nx - ny_t = ny - nzl_t = nzl - ldx_t = ldx - ldy_t = ldy - ! - IF( isign < 0 ) THEN - ! -!$omp parallel default(none) private(offset,tid,k,j,i) shared(r,dofft,ip,fw_plan,nzl,nx) & -!$omp & firstprivate(nx_t, ny_t, nzl_t, ldx_t, ldy_t) -#if defined __HPM - tid = OMP_GET_THREAD_NUM() - CALL f_hpmtstart( 30 + tid, 'FW-2xy' ) -#endif -!$omp do - DO i=1,nzl - offset = 1+ ((i-1)*(ldx_t*ldy_t)) - CALL FFT_X_STICK_SINGLE( fw_plan(1,ip), r(offset), nx_t, ny_t, nzl_t, ldx_t, ldy_t ) - END DO -!$omp end do -!$omp do - do i = 1, nx - do k = 1, nzl - IF( dofft( i ) ) THEN - j = i + ldx_t*ldy_t * ( k - 1 ) - call FFT_Y_STICK(fw_plan(2,ip), r(j), ny_t, ldx_t) - END IF - end do - end do -!$omp end do -#if defined __HPM - CALL f_hpmtstop( 30 + tid ) -#endif -!$omp end parallel - ! - ELSE IF( isign > 0 ) THEN - ! -!$omp parallel default(none) private(offset,tid,k,j,i) shared(r,nx,nzl,dofft,ip,bw_plan) & -!$omp & firstprivate(nx_t, ny_t, nzl_t, ldx_t, ldy_t) -#if defined __HPM - tid = OMP_GET_THREAD_NUM() - CALL f_hpmtstart( 20 + tid, 'BW-2xy' ) -#endif -!$omp do - do i = 1, nx - do k = 1, nzl - IF( dofft( i ) ) THEN - j = i + ldx_t*ldy_t * ( k - 1 ) - call FFT_Y_STICK( bw_plan(2,ip), r(j), ny_t, ldx_t) - END IF - end do - end do -!$omp end do -!$omp do - DO i=1,nzl - offset = 1+ ((i-1)*(ldx_t*ldy_t)) - CALL FFT_X_STICK_SINGLE( bw_plan(1,ip), r(offset), nx_t, ny_t, nzl_t, ldx_t, ldy_t ) - END DO -!$omp end do -#if defined __HPM - CALL f_hpmtstop( 20 + tid ) -#endif -!$omp end parallel - ! - END IF - -#else - - IF( isign < 0 ) THEN - CALL FFT_X_STICK( fw_plan(1,ip), r(1), nx, ny, nzl, ldx, ldy ) - - do i = 1, nx - do k = 1, nzl - IF( dofft( i ) ) THEN - j = i + ldx*ldy * ( k - 1 ) - call FFT_Y_STICK(fw_plan(2,ip), r(j), ny, ldx) - END IF - end do - end do - tscale = 1.0_DP / ( nx * ny ) - CALL ZDSCAL( ldx * ldy * nzl, tscale, r(1), 1) - - ELSE IF( isign > 0 ) THEN - - do i = 1, nx - do k = 1, nzl - IF( dofft( i ) ) THEN - j = i + ldx*ldy * ( k - 1 ) - call FFT_Y_STICK( bw_plan(2,ip), r(j), ny, ldx) - END IF - end do - end do - - CALL FFT_X_STICK( bw_plan(1,ip), r(1), nx, ny, nzl, ldx, ldy ) - -END IF - -#endif - -#elif defined __ACML - -#if defined __OPENMP - - IF( isign < 0 ) THEN -!$omp parallel do private(kk,i,INFO) shared(nzl,nx,ny,dofft,ldx,ldy,r,fw_tablex,fw_tabley,ip) default(none) - do k = 1, nzl - kk = 1 + ( k - 1 ) * ldx * ldy - CALL ZFFT1MX(-1, 1.0_DP, .TRUE., ny, nx, r(kk), 1, ldx, r(kk), 1, ldx, fw_tablex(1, ip), INFO) - do i = 1, nx - IF( dofft( i ) ) THEN - kk = i + ( k - 1 ) * ldx * ldy - CALL ZFFT1MX(-1, 1.0_DP, .TRUE., 1, ny, r(kk), ldx, 1, r(kk), ldx, 1,fw_tabley(1, ip), INFO) - END IF - end do - end do -!$omp end parallel do - ELSE IF( isign > 0 ) THEN -!$omp parallel do private(kk,i,INFO) shared(nzl,nx,ny,dofft,ldx,ldy,r,bw_tabley,bw_tablex,ip) default(none) - DO k = 1, nzl - do i = 1, nx - IF( dofft( i ) ) THEN - kk = i + ( k - 1 ) * ldx * ldy - CALL ZFFT1MX(1, 1.0_DP, .TRUE., 1, ny, r(kk), ldx, 1, r(kk), ldx, 1, bw_tabley(1, ip), INFO) - END IF - end do - kk = 1 + ( k - 1 ) * ldx * ldy - CALL ZFFT1MX(1, 1.0_DP, .TRUE., ny, nx, r(kk), 1, ldx, r(kk), 1, ldx, bw_tablex(1, ip), INFO) - END DO -!$omp end parallel do - END IF - - -#else - - IF( isign < 0 ) THEN - tscale = 1.0_DP / ( nx * ny ) - do k = 1, nzl - kk = 1 + ( k - 1 ) * ldx * ldy - CALL ZFFT1MX(-1, tscale, .TRUE., ny, nx, r(kk), 1, ldx, r(kk), 1, ldx, fw_tablex(1, ip), INFO) - do i = 1, nx - IF( dofft( i ) ) THEN - kk = i + ( k - 1 ) * ldx * ldy - CALL ZFFT1MX(-1, 1.0_DP, .TRUE., 1, ny, r(kk), ldx, 1, r(kk), ldx, 1,fw_tabley(1, ip), INFO) - END IF - end do - end do - ELSE IF( isign > 0 ) THEN - DO k = 1, nzl - do i = 1, nx - IF( dofft( i ) ) THEN - kk = i + ( k - 1 ) * ldx * ldy - CALL ZFFT1MX(1, 1.0_DP, .TRUE., 1, ny, r(kk), ldx, 1, r(kk), ldx, 1, bw_tabley(1, ip), INFO) - END IF - end do - kk = 1 + ( k - 1 ) * ldx * ldy - CALL ZFFT1MX(1, 1.0_DP, .TRUE., ny, nx, r(kk), 1, ldx, r(kk), 1, ldx, bw_tablex(1, ip), INFO) - END DO - - END IF - -#endif - -#elif defined __FFTW3 - -#if defined __OPENMP - - IF ( ldx /= nx .OR. ldy /= ny ) THEN - IF( isign < 0 ) THEN - do j = 0, nzl-1 - CALL dfftw_execute_dft( fw_plan (1, ip), & - r(1+j*ldx*ldy:), r(1+j*ldx*ldy:)) - end do - do i = 1, nx - do k = 1, nzl - IF( dofft( i ) ) THEN - j = i + ldx*ldy * ( k - 1 ) - call dfftw_execute_dft( fw_plan ( 2, ip), r(j:), r(j:)) - END IF - end do - end do - tscale = 1.0_DP / ( nx * ny ) - CALL ZDSCAL( ldx * ldy * nzl, tscale, r(1), 1) - ELSE IF( isign > 0 ) THEN - do i = 1, nx - do k = 1, nzl - IF( dofft( i ) ) THEN - j = i + ldx*ldy * ( k - 1 ) - call dfftw_execute_dft( bw_plan ( 2, ip), r(j:), r(j:)) - END IF - end do - end do - do j = 0, nzl-1 - CALL dfftw_execute_dft( bw_plan( 1, ip), & - r(1+j*ldx*ldy:), r(1+j*ldx*ldy:)) - end do - END IF - ELSE - IF( isign < 0 ) THEN - call dfftw_execute_dft( fw_plan( 1, ip), r(1:), r(1:)) - tscale = 1.0_DP / ( nx * ny ) - CALL ZDSCAL( ldx * ldy * nzl, tscale, r(1), 1) - ELSE IF( isign > 0 ) THEN - call dfftw_execute_dft( bw_plan( 1, ip), r(1:), r(1:)) - END IF - END IF - -#else - - IF ( ldx /= nx .OR. ldy /= ny ) THEN - IF( isign < 0 ) THEN - do j = 0, nzl-1 - CALL dfftw_execute_dft( fw_plan (1, ip), & - r(1+j*ldx*ldy:), r(1+j*ldx*ldy:)) - end do - do i = 1, nx - do k = 1, nzl - IF( dofft( i ) ) THEN - j = i + ldx*ldy * ( k - 1 ) - call dfftw_execute_dft( fw_plan ( 2, ip), r(j:), r(j:)) - END IF - end do - end do - tscale = 1.0_DP / ( nx * ny ) - CALL ZDSCAL( ldx * ldy * nzl, tscale, r(1), 1) - ELSE IF( isign > 0 ) THEN - do i = 1, nx - do k = 1, nzl - IF( dofft( i ) ) THEN - j = i + ldx*ldy * ( k - 1 ) - call dfftw_execute_dft( bw_plan ( 2, ip), r(j:), r(j:)) - END IF - end do - end do - do j = 0, nzl-1 - CALL dfftw_execute_dft( bw_plan( 1, ip), & - r(1+j*ldx*ldy:), r(1+j*ldx*ldy:)) - end do - END IF - ELSE - IF( isign < 0 ) THEN - call dfftw_execute_dft( fw_plan( 1, ip), r(1:), r(1:)) - tscale = 1.0_DP / ( nx * ny ) - CALL ZDSCAL( ldx * ldy * nzl, tscale, r(1), 1) - ELSE IF( isign > 0 ) THEN - call dfftw_execute_dft( bw_plan( 1, ip), r(1:), r(1:)) - END IF - END IF - -#endif - -#elif defined __ESSL || defined __LINUX_ESSL - -#if defined __OPENMP - - IF( isign < 0 ) THEN -!$omp parallel do private(k,i,kk,work) default(none) shared(r,nzl,ny,ldx,ldy,nx,dofft,ip,fw_tabley,fw_tablex) - do k = 1, nzl - kk = 1 + ( k - 1 ) * ldx * ldy - CALL DCFT ( 0, r(kk), 1, ldx, r(kk), 1, ldx, nx, ny, 1, & - 1.0_DP, fw_tablex( 1, ip ), ltabl, work( 1 ), lwork) - do i = 1, nx - IF( dofft( i ) ) THEN - kk = i + ( k - 1 ) * ldx * ldy - call DCFT ( 0, r( kk ), ldx, 1, r( kk ), ldx, 1, ny, 1, & - 1, 1.0_DP, fw_tabley(1, ip), ltabl, work( 1 ), lwork) - END IF - end do - end do -!$omp end parallel do - ELSE IF( isign > 0 ) THEN -!$omp parallel do private(k,i,kk,work) default(none) shared(r,nzl,ny,ldx,ldy,nx,dofft,ip,bw_tabley,bw_tablex) - DO k = 1, nzl - do i = 1, nx - IF( dofft( i ) ) THEN - kk = i + ( k - 1 ) * ldx * ldy - call DCFT ( 0, r( kk ), ldx, 1, r( kk ), ldx, 1, ny, 1, & - -1, 1.0_DP, bw_tabley(1, ip), ltabl, work( 1 ), lwork) - END IF - end do - kk = 1 + ( k - 1 ) * ldx * ldy - CALL DCFT ( 0, r( kk ), 1, ldx, r( kk ), 1, ldx, nx, ny, -1, & - 1.0_DP, bw_tablex(1, ip), ltabl, work( 1 ), lwork) - END DO -!$omp end parallel do - END IF - -#else - - IF( isign < 0 ) THEN - idir = 1 - tscale = 1.0_DP / ( nx * ny ) - do k = 1, nzl - kk = 1 + ( k - 1 ) * ldx * ldy - CALL DCFT ( 0, r(kk), 1, ldx, r(kk), 1, ldx, nx, ny, idir, & - tscale, fw_tablex( 1, ip ), ltabl, work( 1 ), lwork) - do i = 1, nx - IF( dofft( i ) ) THEN - kk = i + ( k - 1 ) * ldx * ldy - call DCFT ( 0, r( kk ), ldx, 1, r( kk ), ldx, 1, ny, 1, & - idir, 1.0_DP, fw_tabley(1, ip), ltabl, work( 1 ), lwork) - END IF - end do - end do - ELSE IF( isign > 0 ) THEN - idir = -1 - DO k = 1, nzl - do i = 1, nx - IF( dofft( i ) ) THEN - kk = i + ( k - 1 ) * ldx * ldy - call DCFT ( 0, r( kk ), ldx, 1, r( kk ), ldx, 1, ny, 1, & - idir, 1.0_DP, bw_tabley(1, ip), ltabl, work( 1 ), lwork) - END IF - end do - kk = 1 + ( k - 1 ) * ldx * ldy - CALL DCFT ( 0, r( kk ), 1, ldx, r( kk ), 1, ldx, nx, ny, idir, & - 1.0_DP, bw_tablex(1, ip), ltabl, work( 1 ), lwork) - END DO - END IF -#endif - - -#elif defined __SCSL - - IF( isign < 0 ) THEN - - idir = -1 - tscale = 1.0_DP / (nx * ny) - DO k = 0, nzl-1 - kk = k * ldx * ldy -! FORWARD: ny FFTs in the X direction - CALL ZZFFTM ( idir, nx, ny, tscale, r(kk+1), ldx, r(kk+1), ldx, & - tablex (1, ip), work(1), isys ) -! FORWARD: nx FFTs in the Y direction - DO i = 1, nx - IF ( dofft(i) ) THEN -!DIR$IVDEP -!DIR$LOOP COUNT (50) - DO j = 0, ny-1 - XY(j+1) = r(i + (j) * ldx + kk) - END DO - CALL ZZFFT(idir, ny, 1.0_DP, XY, XY, tabley (1, ip), & - work(1), isys) -!DIR$IVDEP -!DIR$LOOP COUNT (50) - DO j = 0, ny-1 - r(i + (j) * ldx + kk) = XY(j+1) - END DO - END IF - END DO - END DO - - ELSE IF ( isign > 0 ) THEN - - idir = 1 - tscale = 1.0_DP - DO k = 0, nzl-1 -! BACKWARD: nx FFTs in the Y direction - kk = (k) * ldx * ldy - DO i = 1, nx - IF ( dofft(i) ) THEN -!DIR$IVDEP -!DIR$LOOP COUNT (50) - DO j = 0, ny-1 - XY(j+1) = r(i + (j) * ldx + kk) - END DO - CALL ZZFFT(idir, ny, 1.0_DP, XY, XY, tabley (1, ip), & - work(1), isys) -!DIR$IVDEP -!DIR$LOOP COUNT (50) - DO j = 0, ny-1 - r(i + (j) * ldx + kk) = XY(j+1) - END DO - END IF - END DO -! BACKWARD: ny FFTs in the X direction - CALL ZZFFTM ( idir, nx, ny, tscale, r(kk+1), ldx, r(kk+1), ldx, & - tablex (1, ip), work(1), isys ) - END DO - - END IF - -#elif defined __SUNPERF - - IF ( isign < 0 ) THEN - - DO k = 1, ny * nzl - kk = 1 + ( k - 1 ) * ldx - CALL zfftf ( nx, r (kk), tablex (1, ip) ) - END DO - - DO i = 1, nx - IF ( dofft(i) ) THEN - DO j = 1, nzl - kk = (j - 1) * ldx * ny + i - CALL ZCOPY (ny, r (kk), ldx, work, 1) - CALL zfftf (ny, work, tabley (1, ip) ) - CALL ZCOPY (ny, work, 1, r (kk), ldx) - END DO - END IF - END DO - CALL ZDSCAL ( ldx * ny * nzl, 1.0_DP/(nx * ny), r, 1) - - ELSE IF (isign > 0) THEN - - DO i = 1, nx - IF ( dofft(i) ) THEN - DO j = 1, nzl - kk = (j - 1) * ldx * ny + i - CALL ZCOPY (ny, r (kk), ldx, work, 1) - CALL zfftb (ny, work, tabley (1, ip) ) - CALL ZCOPY (ny, work, 1, r (kk), ldx) - END DO - END IF - END DO - - DO k = 1, ny * nzl - kk = 1 + ( k - 1 ) * ldx - CALL zfftb ( nx, r (kk), tablex (1, ip) ) - END DO - - END IF - -#else - - CALL errore(' cft_2xy ',' no scalar fft driver specified ', 1) - -#endif - -#if defined __FFT_CLOCKS - CALL stop_clock( 'cft_2xy' ) -#endif - - RETURN - - END SUBROUTINE cft_2xy - - -! -!=----------------------------------------------------------------------=! -! -! -! -! 3D scalar FFTs -! -! -! -!=----------------------------------------------------------------------=! -! - - SUBROUTINE cfft3d( f, nx, ny, nz, ldx, ldy, ldz, isign ) - - ! driver routine for 3d complex fft of lengths nx, ny, nz - ! input : f(ldx*ldy*ldz) complex, transform is in-place - ! ldx >= nx, ldy >= ny, ldz >= nz are the physical dimensions - ! of the equivalent 3d array: f3d(ldx,ldy,ldz) - ! (ldx>nx, ldy>ny, ldz>nz may be used on some architectures - ! to reduce memory conflicts - not implemented for FFTW) - ! isign > 0 : f(G) => f(R) ; isign < 0 : f(R) => f(G) - ! - ! Up to "ndims" initializations (for different combinations of input - ! parameters nx,ny,nz) are stored and re-used if available - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nx, ny, nz, ldx, ldy, ldz, isign - COMPLEX (DP) :: f(:) - INTEGER :: i, k, j, err, idir, ip - REAL(DP) :: tscale - INTEGER, SAVE :: icurrent = 1 - INTEGER, SAVE :: dims(3,ndims) = -1 - -#if defined __FFTW || defined __FFTW3 - - C_POINTER, save :: fw_plan(ndims) = 0 - C_POINTER, save :: bw_plan(ndims) = 0 - -#elif defined __ACML - - INTEGER, PARAMETER :: ltabl = 4 * nfftx + 300 - INTEGER :: INFO - - COMPLEX (DP), SAVE :: fw_table(ltabl,ndims) - COMPLEX (DP), SAVE :: bw_table(ltabl,ndims) - - -#elif defined __SCSL - - INTEGER, PARAMETER :: ltabl = (2 * nfftx + 256)*3 - REAL (DP), SAVE :: table (ltabl, ndims) - REAL (DP) :: DUMMY - INTEGER, SAVE :: isys(0:1) = (/ 1, 1 /) - -#elif defined __SUNPERF - - INTEGER, PARAMETER :: ltabl = (4 * nfftx + 15)*3 - REAL (DP), SAVE :: table (ltabl, ndims) - -#elif defined __SX6 - - INTEGER, PARAMETER :: ltabl = 60 - INTEGER, PARAMETER :: lwork = 195+6*nfftx - INTEGER, SAVE :: iw0(ltabl, ndims) - REAL (DP), SAVE :: auxp (lwork, ndims) - ! not sure whether auxp is work space or not - COMPLEX(DP), DIMENSION(:), ALLOCATABLE :: cw2 - -# if defined ASL && defined MICRO - INTEGER :: nbtasks - COMMON/NEC_ASL_PARA/nbtasks -# endif - -#endif - - IF ( nx < 1 ) & - call errore('cfft3',' nx is less than 1 ', 1) - IF ( ny < 1 ) & - call errore('cfft3',' ny is less than 1 ', 1) - IF ( nz < 1 ) & - call errore('cfft3',' nz is less than 1 ', 1) - -#if defined __SX6 -# if defined ASL - ALLOCATE (cw2(ldx*ldy*ldz)) - CALL zfc3cl (f(1), nx, ny, nz, ldx, ldy, ldz, err) -# else - ALLOCATE (cw2(6*ldx*ldy*ldz)) -# endif -#endif - ! - ! Here initialize table only if necessary - ! - ip = -1 - DO i = 1, ndims - - ! first check if there is already a table initialized - ! for this combination of parameters - - IF ( ( nx == dims(1,i) ) .and. & - ( ny == dims(2,i) ) .and. & - ( nz == dims(3,i) ) ) THEN - ip = i - EXIT - END IF - END DO - - IF( ip == -1 ) THEN - - ! no table exist for these parameters - ! initialize a new one - - -#if defined __FFTW - IF ( nx /= ldx .or. ny /= ldy .or. nz /= ldz ) & - call errore('cfft3','not implemented',1) - - IF( fw_plan(icurrent) /= 0 ) CALL DESTROY_PLAN_3D( fw_plan(icurrent) ) - IF( bw_plan(icurrent) /= 0 ) CALL DESTROY_PLAN_3D( bw_plan(icurrent) ) - idir = -1; CALL CREATE_PLAN_3D( fw_plan(icurrent), nx, ny, nz, idir) - idir = 1; CALL CREATE_PLAN_3D( bw_plan(icurrent), nx, ny, nz, idir) - -#elif defined __ACML - - IF ( nx /= ldx .or. ny /= ldy .or. nz /= ldz ) & - call errore('cfft3','not implemented',1) - - - tscale = 1.0_DP / DBLE( nx * ny * nz ) - CALL ZFFT3DY (0,tscale,.TRUE., nx,ny,nz,f(1),1,ldx,ldx*ldy,f(1),1,ldx, ldx*ldy, fw_table(1, icurrent),ltabl,INFO) - CALL ZFFT3DY (0,1.0_DP,.TRUE., nx,ny,nz,f(1),1,ldx,ldx*ldy,f(1),1,ldx, ldx*ldy, bw_table(1, icurrent),ltabl,INFO) - -#elif defined __FFTW3 - - IF ( nx /= ldx .or. ny /= ldy .or. nz /= ldz ) & - call errore('cfft3','not implemented',3) - IF( fw_plan(icurrent) /= 0 ) CALL dfftw_destroy_plan( fw_plan(icurrent) ) - IF( bw_plan(icurrent) /= 0 ) CALL dfftw_destroy_plan( bw_plan(icurrent) ) - idir = -1 - CALL dfftw_plan_dft_3d ( fw_plan(icurrent), nx, ny, nz, f(1:), & - f(1:), idir, FFTW_ESTIMATE) - idir = 1 - CALL dfftw_plan_dft_3d ( bw_plan(icurrent), nx, ny, nz, f(1:), & - f(1:), idir, FFTW_ESTIMATE) - -#elif defined __ESSL || defined __LINUX_ESSL - - ! no initialization for 3d FFT's from ESSL - -#elif defined __SCSL - - CALL zzfft3d (0, nx, ny, nz, 0.0_DP, DUMMY, 1, 1, DUMMY, 1, 1, & - table(1,icurrent), work(1), isys) - -#elif defined __SUNPERF - - CALL zfft3i ( nx, ny, nz, table (1,icurrent) ) - -#elif defined __SX6 - -# if defined ASL -# if defined MICRO - CALL hfc3fb (nx,ny,nz, f(1) , ldx, ldy, ldz, 0, & - iw0(1,icurrent), auxp(1,icurrent), cw2(1), nbtasks, err) -# else - CALL zfc3fb (nx,ny,nz, f(1), ldx, ldy, ldz, 0, & - iw0(1,icurrent), auxp(1,icurrent), cw2(1), err) -# endif -# else - CALL ZZFFT3D (0, nx,ny,nz, 1.0_DP, f(1), ldx, ldy, & - & f(1), ldx, ldy, auxp(1,icurrent), cw2(1), err) -# endif - - IF (err /= 0) CALL errore('cfft3d','FFT init returned an error ', err) - -#else - - CALL errore(' cfft3d ',' no scalar fft driver specified ', 1) - -#endif - - dims(1,icurrent) = nx; dims(2,icurrent) = ny; dims(3,icurrent) = nz - ip = icurrent - icurrent = MOD( icurrent, ndims ) + 1 - - END IF - - ! - ! Now perform the 3D FFT using the machine specific driver - ! - -#if defined __FFTW - IF( isign < 0 ) THEN - call FFTW_INPLACE_DRV_3D( fw_plan(ip), 1, f(1), 1, 1 ) - tscale = 1.0_DP / DBLE( nx * ny * nz ) - call ZDSCAL( nx * ny * nz, tscale, f(1), 1) - - ELSE IF( isign > 0 ) THEN - call FFTW_INPLACE_DRV_3D( bw_plan(ip), 1, f(1), 1, 1 ) - END IF - -#elif defined __ACML - - IF( isign < 0 ) THEN - tscale = 1.0_DP / DBLE( nx * ny * nz ) - CALL ZFFT3DY (-1,tscale,.TRUE., nx,ny,nz,f(1),1,ldx,ldx*ldy,f(1),1,ldx,ldx*ldy,fw_table(1, ip),ltabl,INFO) - ELSE IF( isign > 0 ) THEN - CALL ZFFT3DY (1,1.0_DP,.TRUE., nx,ny,nz,f(1),1,ldx,ldx*ldy,f(1),1,ldx,ldx*ldy,bw_table(1, ip),ltabl,INFO) - END IF - -#elif defined __FFTW3 - - IF( isign < 0 ) THEN - call dfftw_execute_dft( fw_plan(ip), f(1:), f(1:)) - tscale = 1.0_DP / DBLE( nx * ny * nz ) - call ZDSCAL( nx * ny * nz, tscale, f(1), 1) - - ELSE IF( isign > 0 ) THEN - - call dfftw_execute_dft( bw_plan(ip), f(1:), f(1:)) - - END IF - -#elif defined __ESSL || defined __LINUX_ESSL - - IF ( isign < 0 ) THEN - tscale = 1.0_DP / ( nx * ny * nz ) - idir = +1 - ELSE IF( isign > 0 ) THEN - tscale = 1.0_DP - idir = -1 - END IF - - IF( isign /= 0 ) CALL dcft3( f(1), ldx,ldx*ldy, f(1), ldx,ldx*ldy, & - nx,ny,nz, idir, tscale, work(1), lwork) - -#elif defined __SCSL - - IF ( isign /= 0 ) THEN - IF ( isign < 0 ) THEN - idir = -1 - tscale = 1.0_DP / DBLE( nx * ny * nz ) - ELSE IF ( isign > 0 ) THEN - idir = 1 - tscale = 1.0_DP - END IF - CALL ZZFFT3D ( idir, nx, ny, nz, tscale, f(1), ldx, ldy, & - f(1), ldx, ldy, table(1,ip), work(1), isys ) - END IF - -#elif defined __SUNPERF - - IF( isign < 0 ) THEN - CALL zfft3f ( nx, ny, nz, f(1), ldx, ldy, table(1,ip), ltabl ) - tscale = 1.0_DP / DBLE( nx * ny * nz ) - CALL ZDSCAL ( ldx*ldy*ldz, tscale, f(1), 1 ) - ELSE IF( isign > 0 ) THEN - CALL zfft3b ( nx, ny, nz, f(1), ldx, ldy, table(1,ip), ltabl ) - ENDIF - -#elif defined __SX6 - -# if defined ASL -# if defined MICRO - CALL hfc3bf (nx,ny,nz, f(1), ldx,ldy, ldz, & - -isign, iw0(1,ip), auxp(1,ip), cw2(1), nbtasks, err) -# else - CALL zfc3bf (nx,ny,nz, f(1), ldx,ldy, ldz, & - -isign, iw0(1,ip), auxp(1,ip), cw2(1), err) -# endif -# else - CALL ZZFFT3D (isign, nx,ny,nz, 1.0_DP, f(1), ldx,ldy, & - f(1), ldx,ldy, auxp(1,ip), cw2(1), err) -# endif - IF ( isign < 0) THEN - tscale = 1.0_DP / DBLE( nx * ny * nz ) - call ZDSCAL( ldx * ldy * ldz, tscale, f(1), 1) - END IF - IF (err /= 0) CALL errore('cfft3d','FFT returned an error ', err) - DEALLOCATE(cw2) - -#endif - - RETURN - END SUBROUTINE cfft3d - -! -!=----------------------------------------------------------------------=! -! -! -! -! 3D scalar FFTs, but using sticks! -! -! -! -!=----------------------------------------------------------------------=! -! - -SUBROUTINE cfft3ds (f, nx, ny, nz, ldx, ldy, ldz, isign, & - do_fft_x, do_fft_y) - ! - ! driver routine for 3d complex "reduced" fft - see cfft3d - ! The 3D fft are computed only on lines and planes which have - ! non zero elements. These lines and planes are defined by - ! the two integer vectors do_fft_x(ldy*nz) and do_fft_y(nz) - ! (1 = perform fft, 0 = do not perform fft) - ! The routine is implemented for essl and fftw library only - ! - !---------------------------------------------------------------------- - ! - implicit none - - integer :: nx, ny, nz, ldx, ldy, ldz, isign - ! - ! logical dimensions of the fft - ! physical dimensions of the f array - ! sign of the transformation - - complex(DP) :: f ( ldx * ldy * ldz ) - integer :: do_fft_x(:), do_fft_y(:) - ! - integer :: m, incx1, incx2 - INTEGER :: i, k, j, err, idir, ip, ii, jj - REAL(DP) :: tscale - INTEGER, SAVE :: icurrent = 1 - INTEGER, SAVE :: dims(3,ndims) = -1 - -#if defined __FFTW || __FFTW3 - - C_POINTER, SAVE :: fw_plan ( 3, ndims ) = 0 - C_POINTER, SAVE :: bw_plan ( 3, ndims ) = 0 - -#elif defined __ACML - - INTEGER, PARAMETER :: ltabl = 3 * nfftx + 100 - INTEGER :: INFO - - COMPLEX (DP), SAVE :: fw_table( ltabl, 3, ndims ) - COMPLEX (DP), SAVE :: bw_table( ltabl, 3, ndims ) - -#elif defined __ESSL || defined __LINUX_ESSL - - INTEGER, PARAMETER :: ltabl = 20000 + 3 * nfftx - REAL (DP), SAVE :: fw_table( ltabl, 3, ndims ) - REAL (DP), SAVE :: bw_table( ltabl, 3, ndims ) - -#endif - - tscale = 1.0_DP - - ! - ! ESSL sign convention for fft's is the opposite of the "usual" one - ! - - ! WRITE( stdout, fmt="('DEBUG cfft3ds :',6I6)") nx, ny, nz, ldx, ldy, ldz - ! WRITE( stdout, fmt="('DEBUG cfft3ds :',24I2)") do_fft_x - ! WRITE( stdout, fmt="('DEBUG cfft3ds :',24I2)") do_fft_y - - - IF( ny /= ldy ) & - CALL errore(' cfft3ds ', ' wrong dimensions: ny /= ldy ', 1 ) - - ip = -1 - DO i = 1, ndims - - ! first check if there is already a table initialized - ! for this combination of parameters - - IF( ( nx == dims(1,i) ) .and. ( ny == dims(2,i) ) .and. & - ( nz == dims(3,i) ) ) THEN - ip = i - EXIT - END IF - - END DO - - IF( ip == -1 ) THEN - - ! no table exist for these parameters - ! initialize a new one - -#if defined __FFTW - - IF( fw_plan( 1, icurrent) /= 0 ) CALL DESTROY_PLAN_1D( fw_plan( 1, icurrent) ) - IF( bw_plan( 1, icurrent) /= 0 ) CALL DESTROY_PLAN_1D( bw_plan( 1, icurrent) ) - IF( fw_plan( 2, icurrent) /= 0 ) CALL DESTROY_PLAN_1D( fw_plan( 2, icurrent) ) - IF( bw_plan( 2, icurrent) /= 0 ) CALL DESTROY_PLAN_1D( bw_plan( 2, icurrent) ) - IF( fw_plan( 3, icurrent) /= 0 ) CALL DESTROY_PLAN_1D( fw_plan( 3, icurrent) ) - IF( bw_plan( 3, icurrent) /= 0 ) CALL DESTROY_PLAN_1D( bw_plan( 3, icurrent) ) - idir = -1; CALL CREATE_PLAN_1D( fw_plan( 1, icurrent), nx, idir) - idir = 1; CALL CREATE_PLAN_1D( bw_plan( 1, icurrent), nx, idir) - idir = -1; CALL CREATE_PLAN_1D( fw_plan( 2, icurrent), ny, idir) - idir = 1; CALL CREATE_PLAN_1D( bw_plan( 2, icurrent), ny, idir) - idir = -1; CALL CREATE_PLAN_1D( fw_plan( 3, icurrent), nz, idir) - idir = 1; CALL CREATE_PLAN_1D( bw_plan( 3, icurrent), nz, idir) - -#elif defined __ACML - - ! x - direction - incx1 = 1; incx2 = ldx; m = 1 - - CALL ZFFT1MX(0, 1.0_DP, .TRUE., m, nx, f(1), incx1, incx2, f(1), incx1, incx2, fw_table(1, 1, icurrent), INFO) - CALL ZFFT1MX(0, 1.0_DP, .TRUE., m, nx, f(1), incx1, incx2, f(1), incx1, incx2, bw_table(1, 1, icurrent), INFO) - - ! y - direction - incx1 = ldx; incx2 = 1; m = nx; - - CALL ZFFT1MX(0, 1.0_DP, .TRUE., m, ny, f(1), incx1, incx2, f(1), incx1, incx2, fw_table(1, 2, icurrent), INFO) - CALL ZFFT1MX(0, 1.0_DP, .TRUE., m, ny, f(1), incx1, incx2, f(1), incx1, incx2, bw_table(1, 2, icurrent), INFO) - - ! z - direction - incx1 = ldx * ldy; incx2 = 1; m = ldx * ny - - CALL ZFFT1MX(0, 1.0_DP, .TRUE., m, nz, f(1), incx1, incx2, f(1), incx1, incx2, fw_table(1, 3, icurrent), INFO) - CALL ZFFT1MX(0, 1.0_DP, .TRUE., m, nz, f(1), incx1, incx2, f(1), incx1, incx2, bw_table(1, 3, icurrent), INFO) - -#elif defined __FFTW3 - IF( fw_plan( 1, icurrent) /= 0 ) & - CALL dfftw_destroy_plan( fw_plan( 1, icurrent) ) - IF( bw_plan( 1, icurrent) /= 0 ) & - CALL dfftw_destroy_plan( bw_plan( 1, icurrent) ) - IF( fw_plan( 2, icurrent) /= 0 ) & - CALL dfftw_destroy_plan( fw_plan( 2, icurrent) ) - IF( bw_plan( 2, icurrent) /= 0 ) & - CALL dfftw_destroy_plan( bw_plan( 2, icurrent) ) - IF( fw_plan( 3, icurrent) /= 0 ) & - CALL dfftw_destroy_plan( fw_plan( 3, icurrent) ) - IF( bw_plan( 3, icurrent) /= 0 ) & - CALL dfftw_destroy_plan( bw_plan( 3, icurrent) ) - idir = -1 - CALL dfftw_plan_many_dft( fw_plan( 1, icurrent), & - 1, nx, 1, f(1:), (/ldx, ldy, ldz/), 1, ldx, & - f(1:), (/ldx, ldy, ldz/), 1, ldx, idir, FFTW_ESTIMATE) - idir = 1 - CALL dfftw_plan_many_dft( bw_plan( 1, icurrent), & - 1, nx, 1, f(1:), (/ldx, ldy, ldz/), 1, ldx, & - f(1:), (/ldx, ldy, ldz/), 1, ldx, idir, FFTW_ESTIMATE) - idir = -1 - CALL dfftw_plan_many_dft( fw_plan( 2, icurrent), & - 1, ny, nx, f(1:), (/ldx, ldy, ldz/), ldx, 1, & - f(1:), (/ldx, ldy, ldz/), ldx, 1, idir, FFTW_ESTIMATE) - idir = 1 - CALL dfftw_plan_many_dft( bw_plan( 2, icurrent), & - 1, ny, nx, f(1:), (/ldx, ldy, ldz/), ldx, 1, & - f(1:), (/ldx, ldy, ldz/), ldx, 1, idir, FFTW_ESTIMATE) - idir = -1 - CALL dfftw_plan_many_dft( fw_plan( 3, icurrent), & - 1, nz, nx*ny, f(1:), (/ldx, ldy, ldz/), ldx*ldy, 1, & - f(1:), (/ldx, ldy, ldz/), ldx*ldy, 1, idir, FFTW_ESTIMATE) - idir = 1 - CALL dfftw_plan_many_dft( bw_plan( 3, icurrent), & - 1, nz, nx*ny, f(1:), (/ldx, ldy, ldz/), ldx*ldy, 1, & - f(1:), (/ldx, ldy, ldz/), ldx*ldy, 1, idir, FFTW_ESTIMATE) - -#elif defined __ESSL || defined __LINUX_ESSL - - tscale = 1.0_DP - ! x - direction - incx1 = 1; incx2 = ldx; m = 1 - CALL DCFT ( 1, f(1), incx1, incx2, f(1), incx1, incx2, nx, m, 1, 1.0_DP, & - fw_table( 1, 1, icurrent), ltabl, work(1), lwork ) - CALL DCFT ( 1, f(1), incx1, incx2, f(1), incx1, incx2, nx, m, -1, 1.0_DP, & - bw_table(1, 1, icurrent), ltabl, work(1), lwork ) - ! y - direction - incx1 = ldx; incx2 = 1; m = nx; - CALL DCFT ( 1, f(1), incx1, incx2, f(1), incx1, incx2, ny, m, 1, 1.0_DP, & - fw_table( 1, 2, icurrent), ltabl, work(1), lwork ) - CALL DCFT ( 1, f(1), incx1, incx2, f(1), incx1, incx2, ny, m, -1, 1.0_DP, & - bw_table(1, 2, icurrent), ltabl, work(1), lwork ) - ! z - direction - incx1 = ldx * ldy; incx2 = 1; m = ldx * ny - CALL DCFT ( 1, f(1), incx1, incx2, f(1), incx1, incx2, nz, m, 1, 1.0_DP, & - fw_table(1, 3, icurrent), ltabl, work(1), lwork ) - CALL DCFT ( 1, f(1), incx1, incx2, f(1), incx1, incx2, nz, m, -1, 1.0_DP, & - bw_table(1, 3, icurrent), ltabl, work(1), lwork ) - - -#else - - CALL errore(' cfft3ds ',' no scalar fft driver specified ', 1) - -#endif - - dims(1,icurrent) = nx; dims(2,icurrent) = ny; dims(3,icurrent) = nz - ip = icurrent - icurrent = MOD( icurrent, ndims ) + 1 - - END IF - - - IF ( isign > 0 ) THEN - - ! - ! i - direction ... - ! - - incx1 = 1; incx2 = ldx; m = 1 - - do k = 1, nz - do j = 1, ny - jj = j + ( k - 1 ) * ldy - ii = 1 + ldx * ( jj - 1 ) - if ( do_fft_x( jj ) == 1 ) THEN -#if defined __FFTW - call FFTW_INPLACE_DRV_1D( bw_plan( 1, ip), m, f( ii ), incx1, incx2 ) -#elif defined __ACML - CALL ZFFT1MX(1, 1.0_DP, .TRUE., m, nx, f(ii), incx1, incx2, f(ii), incx1, incx2, bw_table(1, 1, ip), INFO) -#elif defined __FFTW3 - call dfftw_execute_dft( bw_plan( 1, ip), f( ii: ), f( ii: ) ) -#elif defined __ESSL || defined __LINUX_ESSL - call dcft (0, f ( ii ), incx1, incx2, f ( ii ), incx1, incx2, nx, m, & - -isign, 1.0_DP, bw_table ( 1, 1, ip ), ltabl, work( 1 ), lwork) -#else - call errore(' cfft3ds ',' no scalar fft driver specified ', 1) -#endif - endif - enddo - enddo - - ! - ! ... j-direction ... - ! - - incx1 = ldx; incx2 = 1; m = nx - - do k = 1, nz - ii = 1 + ldx * ldy * ( k - 1 ) - if ( do_fft_y( k ) == 1 ) then -#if defined __FFTW - call FFTW_INPLACE_DRV_1D( bw_plan( 2, ip), m, f( ii ), incx1, incx2 ) -#elif defined __ACML - CALL ZFFT1MX(1, 1.0_DP, .TRUE., m, ny, f(ii), incx1, incx2, f(ii), incx1, incx2, bw_table(1, 2, ip), INFO) -#elif defined __FFTW3 - call dfftw_execute_dft( bw_plan( 2, ip), f( ii: ), f( ii: ) ) -#elif defined __ESSL || defined __LINUX_ESSL - call dcft (0, f ( ii ), incx1, incx2, f ( ii ), incx1, incx2, ny, m, & - -isign, 1.0_DP, bw_table ( 1, 2, ip ), ltabl, work( 1 ), lwork) -#else - call errore(' cfft3ds ',' no scalar fft driver specified ', 1) -#endif - endif - enddo - - ! - ! ... k-direction - ! - - incx1 = ldx * ldy; incx2 = 1; m = ldx * ny - -#if defined __FFTW - call FFTW_INPLACE_DRV_1D( bw_plan( 3, ip), m, f( 1 ), incx1, incx2 ) -#elif defined __ACML - CALL ZFFT1MX(1, 1.0_DP, .TRUE., m, nz, f(1), incx1, incx2, f(1), incx1, incx2, bw_table(1, 3, ip), INFO) -#elif defined __FFTW3 - call dfftw_execute_dft( bw_plan( 3, ip), f(1:), f(1:) ) -#elif defined __ESSL || defined __LINUX_ESSL - call dcft (0, f( 1 ), incx1, incx2, f( 1 ), incx1, incx2, nz, m, & - -isign, 1.0_DP, bw_table ( 1, 3, ip ), ltabl, work( 1 ), lwork) -#endif - - ELSE - - ! - ! ... k-direction - ! - - incx1 = ldx * ny; incx2 = 1; m = ldx * ny - -#if defined __FFTW - call FFTW_INPLACE_DRV_1D( fw_plan( 3, ip), m, f( 1 ), incx1, incx2 ) -#elif defined __ACML - CALL ZFFT1MX(-1, 1.0_DP, .TRUE., m, nz, f(1), incx1, incx2, f(1), incx1, incx2, fw_table(1, 3, ip), INFO) -#elif defined __FFTW3 - call dfftw_execute_dft( fw_plan( 3, ip), f(1:), f(1:) ) -#elif defined __ESSL || defined __LINUX_ESSL - call dcft (0, f( 1 ), incx1, incx2, f( 1 ), incx1, incx2, nz, m, & - -isign, 1.0_DP, fw_table ( 1, 3, ip ), ltabl, work( 1 ), lwork) - -#endif - - ! - ! ... j-direction ... - ! - - incx1 = ldx; incx2 = 1; m = nx - - do k = 1, nz - ii = 1 + ldx * ldy * ( k - 1 ) - if ( do_fft_y ( k ) == 1 ) then -#if defined __FFTW - call FFTW_INPLACE_DRV_1D( fw_plan( 2, ip), m, f( ii ), incx1, incx2 ) -#elif defined __ACML - CALL ZFFT1MX(-1, 1.0_DP, .TRUE., m, ny, f(ii), incx1, incx2, f(ii), incx1, incx2, fw_table(1, 2, ip), INFO) -#elif defined __FFTW3 - call dfftw_execute_dft( fw_plan( 2, ip), f( ii: ), f( ii: ) ) -#elif defined __ESSL || defined __LINUX_ESSL - call dcft (0, f ( ii ), incx1, incx2, f ( ii ), incx1, incx2, ny, m, & - -isign, 1.0_DP, fw_table ( 1, 2, ip ), ltabl, work( 1 ), lwork) -#else - call errore(' cfft3ds ',' no scalar fft driver specified ', 1) -#endif - endif - enddo - - ! - ! i - direction ... - ! - - incx1 = 1; incx2 = ldx; m = 1 - - do k = 1, nz - do j = 1, ny - jj = j + ( k - 1 ) * ldy - ii = 1 + ldx * ( jj - 1 ) - if ( do_fft_x( jj ) == 1 ) then -#if defined __FFTW - call FFTW_INPLACE_DRV_1D( fw_plan( 1, ip), m, f( ii ), incx1, incx2 ) -#elif defined __ACML - CALL ZFFT1MX(-1, 1.0_DP, .TRUE., m, nx, f(ii), incx1, incx2, f(ii), incx1, incx2, fw_table(1, 1, ip), INFO) -#elif defined __FFTW3 - call dfftw_execute_dft( fw_plan( 1, ip), f( ii: ), f( ii: ) ) -#elif defined __ESSL || defined __LINUX_ESSL - call dcft (0, f ( ii ), incx1, incx2, f ( ii ), incx1, incx2, nx, m, & - -isign, 1.0_DP, fw_table ( 1, 1, ip ), ltabl, work( 1 ), lwork) -#else - call errore(' cfft3ds ',' no scalar fft driver specified ', 1) -#endif - endif - enddo - enddo - - call DSCAL (2 * ldx * ldy * nz, 1.0_DP/(nx * ny * nz), f(1), 1) - - END IF - RETURN - END SUBROUTINE cfft3ds - -! -!=----------------------------------------------------------------------=! -! -! -! -! 3D parallel FFT on sub-grids -! -! -! -!=----------------------------------------------------------------------=! -! - SUBROUTINE cft_b ( f, nx, ny, nz, ldx, ldy, ldz, imin3, imax3, sgn ) - -! driver routine for 3d complex fft's on box grid, parallel case -! fft along xy is done only on planes that correspond to dense grid -! planes on the current processor, i.e. planes with imin3 <= nz <= imax3 -! implemented for essl, fftw, scsl, complib, only for sgn=1 (f(R) => f(G)) -! (beware: here the "essl" convention for the sign of the fft is used!) -! - implicit none - integer nx,ny,nz,ldx,ldy,ldz,imin3,imax3,sgn - complex(8) :: f(:) - - integer isign, naux, ibid, nplanes, nstart, k - real(DP) :: tscale - - integer :: ip, i - integer, save :: icurrent = 1 - integer, save :: dims( 4, ndims ) = -1 - -#if defined __FFTW || __FFTW3 - - C_POINTER, save :: bw_planz( ndims ) = 0 - C_POINTER, save :: bw_planxy( ndims ) = 0 - -#elif defined __ACML - - INTEGER, PARAMETER :: ltabl = 3 * nfftx + 100 - INTEGER :: INFO - - COMPLEX (DP), save :: aux3( ltabl, ndims ) - COMPLEX (DP), save :: aux2( ltabl, ndims ) - COMPLEX (DP), save :: aux1( ltabl, ndims ) - -#elif defined __ESSL || defined __LINUX_ESSL - - INTEGER, PARAMETER :: ltabl = 20000 + 3 * nfftx - real(8), save :: aux3( ltabl, ndims ) - real(8), save :: aux2( ltabl, ndims ) - real(8), save :: aux1( ltabl, ndims ) - -#elif defined __SCSL - - INTEGER, PARAMETER :: ltabl = 2 * nfftx + 256 - real(8), save :: bw_coeffz( ltabl, ndims ) - real(8), save :: bw_coeffy( ltabl, ndims ) - real(8), save :: bw_coeffx( ltabl, ndims ) - REAL (DP) :: DUMMY - INTEGER, SAVE :: isys(0:1) = (/ 1, 1 /) - -#endif - - isign = -sgn - tscale = 1.0_DP - - if ( isign > 0 ) then - call errore('cft_b','not implemented',isign) - end if -! -! 2d fft on xy planes - only needed planes are transformed -! note that all others are left in an unusable state -! - nplanes = imax3 - imin3 + 1 - nstart = ( imin3 - 1 ) * ldx * ldy + 1 - - ! - ! Here initialize table only if necessary - ! - - ip = -1 - DO i = 1, ndims - - ! first check if there is already a table initialized - ! for this combination of parameters - - IF ( ( nx == dims(1,i) ) .and. ( ny == dims(2,i) ) .and. & - ( nz == dims(3,i) ) .and. ( nplanes == dims(4,i) ) ) THEN - ip = i - EXIT - END IF - - END DO - - IF( ip == -1 ) THEN - - ! no table exist for these parameters - ! initialize a new one - -#if defined __FFTW - - if ( bw_planz(icurrent) /= 0 ) & - call DESTROY_PLAN_1D( bw_planz(icurrent) ) - call CREATE_PLAN_1D( bw_planz(icurrent), nz, 1 ) - - if ( bw_planxy(icurrent) /= 0 ) & - call DESTROY_PLAN_2D( bw_planxy(icurrent) ) - call CREATE_PLAN_2D( bw_planxy(icurrent), nx, ny, 1 ) -! -#elif defined __ACML - - if( nz /= dims(3,icurrent) ) then - CALL ZFFT1MX(0, 1.0_DP, .TRUE., ldx*ldy, nz, f(1), ldx*ldy, 1, f(1), ldx*ldy, 1, aux3(1, icurrent), INFO) - end if - - CALL ZFFT1MX(0, 1.0_DP, .TRUE., ldy*nplanes, nx, f(1), 1, ldx, f(1), 1, ldx, aux1(1, icurrent), INFO) - - if( ny /= dims(2,icurrent) ) then - CALL ZFFT1MX(0, 1.0_DP, .TRUE., ldx, ny, f(1), ldx, 1, f(1), ldx, 1, aux2(1, icurrent), INFO) - end if - - -#elif defined __FFTW3 - - if ( bw_planz(icurrent) /= 0 ) & - call dfftw_destroy_plan(bw_planz(icurrent)) - call dfftw_plan_many_dft( bw_planz(icurrent), 1, nz, ldx*ldy, & - f(1:), (/SIZE(f)/), ldx*ldy, 1, f(1:), (/SIZE(f)/), ldx*ldy, 1, & - 1, FFTW_ESTIMATE ) - - if ( bw_planxy(icurrent) /= 0 ) & - call dfftw_destroy_plan(bw_planxy(icurrent)) - call dfftw_plan_many_dft( bw_planxy(icurrent), 2, (/nx, ny/), nplanes,& - f(nstart:), (/ldx, ldy/), 1, ldx*ldy, f(nstart:), (/ldx, ldy/), & - 1, ldx*ldy, 1, FFTW_ESTIMATE ) - -#elif defined __ESSL || defined __LINUX_ESSL - - if( nz /= dims(3,icurrent) ) then - call dcft( 1, f(1), ldx*ldy, 1, f(1), ldx*ldy, 1, nz, ldx*ldy, & - isign, tscale, aux3(1,icurrent), ltabl, work(1), lwork) - end if - call dcft( 1, f(1), 1, ldx, f(1), 1, ldx, nx, ldy*nplanes, isign, & - tscale, aux1(1,icurrent), ltabl, work(1), lwork) - if( ny /= dims(2,icurrent) ) then - call dcft( 1, f(1), ldx, 1, f(1), ldx, 1, ny, ldx, isign, & - tscale, aux2(1,icurrent), ltabl, work(1), lwork) - end if - -#elif defined __SCSL - - CALL ZZFFT (0, nz, 0.0_DP, DUMMY, 1, bw_coeffz(1, icurrent), & - work(1), isys) - CALL ZZFFT (0, ny, 0.0_DP, DUMMY, 1, bw_coeffy(1, icurrent), & - work(1), isys) - CALL ZZFFT (0, nx, 0.0_DP, DUMMY, 1, bw_coeffx(1, icurrent), & - work(1), isys) - -#else - - CALL errore(' cft_b ',' no scalar fft driver specified ', 1) - -#endif - - dims(1,icurrent) = nx; dims(2,icurrent) = ny - dims(3,icurrent) = nz; dims(4,icurrent) = nplanes - ip = icurrent - icurrent = MOD( icurrent, ndims ) + 1 - - END IF - - -#if defined __FFTW - - call FFTW_INPLACE_DRV_1D( bw_planz(ip), ldx*ldy, f(1), ldx*ldy, 1 ) - call FFTW_INPLACE_DRV_2D( bw_planxy(ip), nplanes, f(nstart), 1, ldx*ldy ) - -#elif defined __ACML - - ! fft in the z-direction... - - CALL ZFFT1MX(1, 1.0_DP, .TRUE., ldx*ldy, nz, f(1), ldx*ldy, 1, f(1), ldx*ldy, 1, aux3(1, ip), INFO) - - ! x-direction - - CALL ZFFT1MX(1, 1.0_DP, .TRUE., ldy*nplanes, nx, f(nstart), 1, ldx, f(nstart), 1, ldx, aux1(1, ip), INFO) - - ! y-direction - - DO K = imin3, imax3 - nstart = ( k - 1 ) * ldx * ldy + 1 - CALL ZFFT1MX(1, 1.0_DP, .TRUE., ldx, ny, f(nstart), ldx, 1, f(nstart), ldx, 1, aux2(1, ip), INFO) - END DO - -#elif defined __FFTW3 - - call dfftw_execute_dft(bw_planz(ip), f(1:), f(1:)) - call dfftw_execute_dft(bw_planxy(ip), f(nstart:), f(nstart:)) - -#elif defined __ESSL || defined __LINUX_ESSL - - ! fft in the z-direction... - - call dcft( 0, f(1), ldx*ldy, 1, f(1), ldx*ldy, 1, nz, ldx*ldy, isign, & - tscale, aux3(1,ip), ltabl, work(1), lwork) - - ! x-direction - - call dcft( 0, f(nstart), 1, ldx, f(nstart), 1, ldx, nx, ldy*nplanes, & - isign, tscale, aux1(1,ip), ltabl, work(1), lwork) - - ! y-direction - - DO K = imin3, imax3 - nstart = ( k - 1 ) * ldx * ldy + 1 - call dcft( 0, f(nstart), ldx, 1, f(nstart), ldx, 1, ny, ldx, isign, & - tscale, aux2(1,ip), ltabl, work(1), lwork) - END DO - -#elif defined __SCSL - - CALL ZZFFTMR (1, nz, ldx*ldy, tscale, f(1), ldx*ldy, f(1), & - ldx*ldy, bw_coeffz(1, ip), work(1), isys) - CALL ZZFFTM (1, nx, ldy*nplanes, tscale, f(nstart), ldx, & - f(nstart), ldx, bw_coeffx(1, ip), work(1), isys) - DO k = imin3, imax3 - nstart = ( k - 1 ) * ldx * ldy + 1 - CALL ZZFFTMR (1, ny, ldx, tscale, f(nstart), ldx, f(nstart), & - ldx, bw_coeffy(1, ip), work(1), isys) - - END DO - -#endif - RETURN - END SUBROUTINE cft_b - -! -!=----------------------------------------------------------------------=! -! -! -! -! FFT support Functions/Subroutines -! -! -! -!=----------------------------------------------------------------------=! -! - -! -integer function good_fft_dimension (n) - ! - ! Determines the optimal maximum dimensions of fft arrays - ! Useful on some machines to avoid memory conflicts - ! - USE kinds, only : DP - IMPLICIT NONE - INTEGER :: n, nx - REAL(DP) :: log2n - ! - ! this is the default: max dimension = fft dimension - nx = n - ! -#if defined(__ESSL) || defined(__LINUX_ESSL) - log2n = LOG ( dble (n) ) / LOG ( 2.0_DP ) - ! log2n is the logarithm of n in base 2 - IF ( ABS (NINT(log2n) - log2n) < 1.0d-8 ) nx = n + 1 - ! if n is a power of 2 (log2n is integer) increase dimension by 1 -#elif defined(__SX6) - ! - if (mod (n, 2) ==0) nx = n + 1 - ! for nec vector machines: if n is even increase dimension by 1 -#endif - ! - good_fft_dimension = nx - return -end function good_fft_dimension - - -!=----------------------------------------------------------------------=! - -function allowed (nr) - - - ! find if the fft dimension is a good one - ! a "bad one" is either not implemented (as on IBM with ESSL) - ! or implemented but with awful performances (most other cases) - - USE kinds - - implicit none - integer :: nr - - logical :: allowed - integer :: pwr (5) - integer :: mr, i, fac, p, maxpwr - integer :: factors( 5 ) = (/ 2, 3, 5, 7, 11 /) - - ! find the factors of the fft dimension - - mr = nr - pwr = 0 - factors_loop: do i = 1, 5 - fac = factors (i) - maxpwr = NINT ( LOG( DBLE (mr) ) / LOG( DBLE (fac) ) ) + 1 - do p = 1, maxpwr - if ( mr == 1 ) EXIT factors_loop - if ( MOD (mr, fac) == 0 ) then - mr = mr / fac - pwr (i) = pwr (i) + 1 - endif - enddo - end do factors_loop - - IF ( nr /= ( mr * 2**pwr (1) * 3**pwr (2) * 5**pwr (3) * 7**pwr (4) * 11**pwr (5) ) ) & - CALL errore (' allowed ', ' what ?!? ', 1 ) - - if ( mr /= 1 ) then - - ! fft dimension contains factors > 11 : no good in any case - - allowed = .false. - - else - -#if defined __ESSL || defined __LINUX_ESSL - - ! IBM machines with essl libraries - - allowed = ( pwr(1) >= 1 ) .and. ( pwr(2) <= 2 ) .and. ( pwr(3) <= 1 ) .and. & - ( pwr(4) <= 1 ) .and. ( pwr(5) <= 1 ) .and. & - ( ( (pwr(2) == 0 ) .and. ( pwr(3) + pwr(4) + pwr(5) ) <= 2 ) .or. & - ( (pwr(2) /= 0 ) .and. ( pwr(3) + pwr(4) + pwr(5) ) <= 1 ) ) -#else - - ! fftw and all other cases: no factors 7 and 11 - - allowed = ( ( pwr(4) == 0 ) .and. ( pwr(5) == 0 ) ) - -#endif - - endif - - return -end function allowed - -!=----------------------------------------------------------------------=! - - INTEGER FUNCTION good_fft_order( nr, np ) - -! -! This function find a "good" fft order value grather or equal to "nr" -! -! nr (input) tentative order n of a fft -! -! np (optional input) if present restrict the search of the order -! in the ensamble of multiples of np -! -! Output: the same if n is a good number -! the closest higher number that is good -! an fft order is not good if not implemented (as on IBM with ESSL) -! or implemented but with awful performances (most other cases) -! - - IMPLICIT NONE - INTEGER, INTENT(IN) :: nr - INTEGER, OPTIONAL, INTENT(IN) :: np - INTEGER :: new - - new = nr - IF( PRESENT( np ) ) THEN - DO WHILE( ( ( .NOT. allowed( new ) ) .OR. ( MOD( new, np ) /= 0 ) ) .AND. ( new <= nfftx ) ) - new = new + 1 - END DO - ELSE - DO WHILE( ( .NOT. allowed( new ) ) .AND. ( new <= nfftx ) ) - new = new + 1 - END DO - END IF - - IF( new > nfftx ) & - CALL errore( ' good_fft_order ', ' fft order too large ', new ) - - good_fft_order = new - - RETURN - END FUNCTION good_fft_order - - -!=----------------------------------------------------------------------=! - END MODULE fft_scalar -!=----------------------------------------------------------------------=! diff --git a/quantum_espresso/kcp/Modules/fft_types.f90 b/quantum_espresso/kcp/Modules/fft_types.f90 deleted file mode 100644 index 7f63b6a3c..000000000 --- a/quantum_espresso/kcp/Modules/fft_types.f90 +++ /dev/null @@ -1,550 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -MODULE fft_types - - USE io_global, ONLY : stdout - - IMPLICIT NONE - SAVE - - - TYPE fft_dlay_descriptor - INTEGER :: nst ! total number of sticks - INTEGER, POINTER :: nsp(:) ! number of sticks per processor ( potential ) - ! using proc index starting from 1 !! - ! on proc mpime -> nsp( mpime + 1 ) - INTEGER, POINTER :: nsw(:) ! number of sticks per processor ( wave func ) - ! using proc index as above - INTEGER :: nr1 ! - INTEGER :: nr2 ! effective FFT dimensions - INTEGER :: nr3 ! - INTEGER :: nr1x ! - INTEGER :: nr2x ! FFT grids leading dimensions - INTEGER :: nr3x ! - INTEGER :: npl ! number of "Z" planes for this processor = npp( mpime + 1 ) - INTEGER :: nnp ! number of 0 and non 0 sticks in a plane ( ~nr1*nr2/nproc ) - INTEGER :: nnr ! local number of FFT grid elements ( ~nr1*nr2*nr3/proc ) - INTEGER :: ngt ! total number of non zero elemets (number of G-vec) - INTEGER, POINTER :: ngl(:) ! per proc. no. of non zero charge density/potential components - INTEGER, POINTER :: nwl(:) ! per proc. no. of non zero wave function plane components - INTEGER, POINTER :: npp(:) ! number of "Z" planes per processor - INTEGER, POINTER :: ipp(:) ! offset of the first "Z" plane on each proc ( 0 on the first proc!!!) - INTEGER, POINTER :: iss(:) ! index of the first stick on each proc - INTEGER, POINTER :: isind(:) ! for each position in the plane indicate the stick index - INTEGER, POINTER :: ismap(:) ! for each stick in the plane indicate the position - INTEGER, POINTER :: iplp(:) ! indicate which "Y" plane should be FFTed ( potential ) - INTEGER, POINTER :: iplw(:) ! indicate which "Y" plane should be FFTed ( wave func ) - ! - ! descriptor id and pointer, for future use - ! - INTEGER :: id - INTEGER :: tptr - ! - ! Sub (box) grid descriptor - ! - INTEGER, POINTER :: irb(:,:) ! the offset of the box corner - INTEGER, POINTER :: imin3(:) ! the starting local plane - INTEGER, POINTER :: imax3(:) ! the last local plane - INTEGER, POINTER :: np3(:) ! number of local plane for the box fft - ! - ! task groups - ! - LOGICAL :: have_task_groups - INTEGER :: nnrx ! maximum among nnr - INTEGER, POINTER :: tg_nsw(:) ! number of sticks per task group ( wave func ) - INTEGER, POINTER :: tg_npp(:) ! number of "Z" planes per task group - INTEGER, POINTER :: tg_snd(:) ! number of element to be sent in group redist - INTEGER, POINTER :: tg_rcv(:) ! number of element to be received in group redist - INTEGER, POINTER :: tg_psdsp(:)! send displacement for all to all (pack) - INTEGER, POINTER :: tg_usdsp(:)! send displacement for all to all (unpack) - INTEGER, POINTER :: tg_rdsp(:)! receive displacement for all to all - ! - END TYPE - - - INTEGER, PRIVATE :: icount = 0 - - -CONTAINS - - SUBROUTINE fft_dlay_allocate( desc, nproc, nx, ny ) - TYPE (fft_dlay_descriptor) :: desc - INTEGER, INTENT(IN) :: nproc, nx, ny - ALLOCATE( desc%nsp( nproc ) ) - ALLOCATE( desc%nsw( nproc ) ) - ALLOCATE( desc%ngl( nproc ) ) - ALLOCATE( desc%nwl( nproc ) ) - ALLOCATE( desc%npp( nproc ) ) - ALLOCATE( desc%ipp( nproc ) ) - ALLOCATE( desc%iss( nproc ) ) - ALLOCATE( desc%isind( nx * ny ) ) - ALLOCATE( desc%ismap( nx * ny ) ) - ALLOCATE( desc%iplp( nx ) ) - ALLOCATE( desc%iplw( nx ) ) - - desc%nsp = 0 - desc%nsw = 0 - desc%ngl = 0 - desc%nwl = 0 - desc%npp = 0 - desc%ipp = 0 - desc%iss = 0 - desc%isind = 0 - desc%ismap = 0 - desc%iplp = 0 - desc%iplw = 0 - - desc%id = 0 - - desc%have_task_groups = .FALSE. - NULLIFY( desc%tg_nsw ) - NULLIFY( desc%tg_npp ) - NULLIFY( desc%tg_snd ) - NULLIFY( desc%tg_rcv ) - NULLIFY( desc%tg_psdsp ) - NULLIFY( desc%tg_usdsp ) - NULLIFY( desc%tg_rdsp ) - - END SUBROUTINE fft_dlay_allocate - - - SUBROUTINE fft_dlay_deallocate( desc ) - TYPE (fft_dlay_descriptor) :: desc - IF ( ASSOCIATED( desc%nsp ) ) DEALLOCATE( desc%nsp ) - IF ( ASSOCIATED( desc%nsw ) ) DEALLOCATE( desc%nsw ) - IF ( ASSOCIATED( desc%ngl ) ) DEALLOCATE( desc%ngl ) - IF ( ASSOCIATED( desc%nwl ) ) DEALLOCATE( desc%nwl ) - IF ( ASSOCIATED( desc%npp ) ) DEALLOCATE( desc%npp ) - IF ( ASSOCIATED( desc%ipp ) ) DEALLOCATE( desc%ipp ) - IF ( ASSOCIATED( desc%iss ) ) DEALLOCATE( desc%iss ) - IF ( ASSOCIATED( desc%isind ) ) DEALLOCATE( desc%isind ) - IF ( ASSOCIATED( desc%ismap ) ) DEALLOCATE( desc%ismap ) - IF ( ASSOCIATED( desc%iplp ) ) DEALLOCATE( desc%iplp ) - IF ( ASSOCIATED( desc%iplw ) ) DEALLOCATE( desc%iplw ) - desc%id = 0 - IF( desc%have_task_groups ) THEN - IF ( ASSOCIATED( desc%tg_nsw ) ) DEALLOCATE( desc%tg_nsw ) - IF ( ASSOCIATED( desc%tg_npp ) ) DEALLOCATE( desc%tg_npp ) - IF ( ASSOCIATED( desc%tg_snd ) ) DEALLOCATE( desc%tg_snd ) - IF ( ASSOCIATED( desc%tg_rcv ) ) DEALLOCATE( desc%tg_rcv ) - IF ( ASSOCIATED( desc%tg_psdsp ) ) DEALLOCATE( desc%tg_psdsp ) - IF ( ASSOCIATED( desc%tg_usdsp ) ) DEALLOCATE( desc%tg_usdsp ) - IF ( ASSOCIATED( desc%tg_rdsp ) ) DEALLOCATE( desc%tg_rdsp ) - END IF - desc%have_task_groups = .FALSE. - END SUBROUTINE fft_dlay_deallocate - -!=----------------------------------------------------------------------------=! - - SUBROUTINE fft_box_allocate( desc, nproc, nat ) - TYPE (fft_dlay_descriptor) :: desc - INTEGER, INTENT(IN) :: nat, nproc - ALLOCATE( desc%irb( 3, nat ) ) - ALLOCATE( desc%imin3( nat ) ) - ALLOCATE( desc%imax3( nat ) ) - ALLOCATE( desc%npp( nproc ) ) - ALLOCATE( desc%ipp( nproc ) ) - ALLOCATE( desc%np3( nat ) ) - desc%irb = 0 - desc%imin3 = 0 - desc%imax3 = 0 - desc%npp = 0 - desc%ipp = 0 - desc%np3 = 0 - desc%have_task_groups = .FALSE. - END SUBROUTINE fft_box_allocate - - SUBROUTINE fft_box_deallocate( desc ) - TYPE (fft_dlay_descriptor) :: desc - IF( ASSOCIATED( desc%irb ) ) DEALLOCATE( desc%irb ) - IF( ASSOCIATED( desc%imin3 ) ) DEALLOCATE( desc%imin3 ) - IF( ASSOCIATED( desc%imax3 ) ) DEALLOCATE( desc%imax3 ) - IF( ASSOCIATED( desc%npp ) ) DEALLOCATE( desc%npp ) - IF( ASSOCIATED( desc%ipp ) ) DEALLOCATE( desc%ipp ) - IF( ASSOCIATED( desc%np3 ) ) DEALLOCATE( desc%np3 ) - desc%have_task_groups = .FALSE. - END SUBROUTINE fft_box_deallocate - - -!=----------------------------------------------------------------------------=! - - SUBROUTINE fft_dlay_set( desc, tk, nst, nr1, nr2, nr3, nr1x, nr2x, nr3x, me, & - nproc, nogrp, ub, lb, idx, in1, in2, ncp, ncpw, ngp, ngpw, st, stw ) - - TYPE (fft_dlay_descriptor) :: desc - - LOGICAL, INTENT(IN) :: tk - INTEGER, INTENT(IN) :: nst - INTEGER, INTENT(IN) :: nr1, nr2, nr3, nr1x, nr2x, nr3x - INTEGER, INTENT(IN) :: me ! processor index Starting from 1 - INTEGER, INTENT(IN) :: nproc ! number of processor - INTEGER, INTENT(IN) :: nogrp ! number of groups for task-grouping - INTEGER, INTENT(IN) :: idx(:) - INTEGER, INTENT(IN) :: in1(:) - INTEGER, INTENT(IN) :: in2(:) - INTEGER, INTENT(IN) :: ncp(:) - INTEGER, INTENT(IN) :: ncpw(:) - INTEGER, INTENT(IN) :: ngp(:) - INTEGER, INTENT(IN) :: ngpw(:) - INTEGER, INTENT(IN) :: lb(:), ub(:) - INTEGER, INTENT(IN) :: st( lb(1) : ub(1), lb(2) : ub(2) ) - INTEGER, INTENT(IN) :: stw( lb(1) : ub(1), lb(2) : ub(2) ) - - INTEGER :: npp( nproc ), n3( nproc ), nsp( nproc ) - INTEGER :: np, nq, i, is, iss, i1, i2, m1, m2, n1, n2, ip - - ! Task-grouping C. Bekas - ! - INTEGER :: sm - - IF( ( SIZE( desc%ngl ) < nproc ) .OR. ( SIZE( desc%npp ) < nproc ) .OR. & - ( SIZE( desc%ipp ) < nproc ) .OR. ( SIZE( desc%iss ) < nproc ) ) & - CALL errore( ' fft_dlay_set ', ' wrong descriptor dimensions ', 1 ) - - IF( ( nr1 > nr1x ) .OR. ( nr2 > nr2x ) .OR. ( nr3 > nr3x ) ) & - CALL errore( ' fft_dlay_set ', ' wrong fft dimensions ', 2 ) - - IF( ( SIZE( idx ) < nst ) .OR. ( SIZE( in1 ) < nst ) .OR. ( SIZE( in2 ) < nst ) ) & - CALL errore( ' fft_dlay_set ', ' wrong number of stick dimensions ', 3 ) - - IF( ( SIZE( ncp ) < nproc ) .OR. ( SIZE( ngp ) < nproc ) ) & - CALL errore( ' fft_dlay_set ', ' wrong stick dimensions ', 4 ) - - desc%have_task_groups = .FALSE. - - ! Set the number of "xy" planes for each processor - ! in other word do a slab partition along the z axis - - sm = 0 - npp = 0 - IF ( nproc == 1 ) THEN - npp(1) = nr3 - ELSE IF( nproc <= nr3 ) THEN - np = nr3 / nproc - nq = nr3 - np * nproc - DO i = 1, nproc - npp(i) = np - IF ( i <= nq ) npp(i) = np + 1 - END DO - ELSE - DO ip = 1, nr3 ! some compiler complains for empty DO loops - DO i = 1, nproc, nogrp - npp(i) = npp(i) + 1 - sm = sm + 1 - IF ( sm == nr3 ) EXIT - END DO - IF ( sm == nr3 ) EXIT - END DO - END IF - - desc%npp( 1:nproc ) = npp - desc%npl = npp( me ) - - ! Find out the index of the starting plane on each proc - - n3 = 0 - DO i = 2, nproc - n3(i) = n3(i-1) + npp(i-1) - END DO - - desc%ipp( 1:nproc ) = n3 - - ! Set the proper number of sticks - - IF( .NOT. tk ) THEN - desc%nst = 2*nst - 1 - ELSE - desc%nst = nst - END IF - - ! Set fft actual and leading dimensions - - desc%nr1 = nr1 - desc%nr2 = nr2 - desc%nr3 = nr3 - desc%nr1x = nr1x - desc%nr2x = nr2x - desc%nr3x = nr3x - desc%nnp = nr1x * nr2x ! see ncplane - - ! Set fft local workspace dimension - - IF ( nproc == 1 ) THEN - desc%nnr = nr1x * nr2x * nr3x - desc%nnrx = desc%nnr - ELSE - desc%nnr = MAX( nr3x * ncp(me), nr1x * nr2x * npp(me) ) - desc%nnr = MAX( 1, desc%nnr ) ! ensure that desc%nrr > 0 ( for extreme parallelism ) - desc%nnrx = desc%nnr - DO i = 1, nproc - desc%nnrx = MAX( desc%nnrx, nr3x * ncp( i ) ) - desc%nnrx = MAX( desc%nnrx, nr1x * nr2x * npp( i ) ) - END DO - desc%nnrx = MAX( 1, desc%nnrx ) ! ensure that desc%nrr > 0 ( for extreme parallelism ) - END IF - - - - desc%ngl( 1:nproc ) = ngp( 1:nproc ) - desc%nwl( 1:nproc ) = ngpw( 1:nproc ) - - IF( SIZE( desc%isind ) < ( nr1x * nr2x ) ) & - CALL errore( ' fft_dlay_set ', ' wrong descriptor dimensions, isind ', 5 ) - - IF( SIZE( desc%iplp ) < ( nr1x ) .OR. SIZE( desc%iplw ) < ( nr1x ) ) & - CALL errore( ' fft_dlay_set ', ' wrong descriptor dimensions, ipl ', 5 ) - - ! - ! 1. Temporarily store in the array "desc%isind" the index of the processor - ! that own the corresponding stick (index of proc starting from 1) - ! 2. Set the array elements of "desc%iplw" and "desc%iplp" to one - ! for that index corresponding to YZ planes containing at least one stick - ! this are used in the FFT transform along Y - ! - - desc%isind = 0 - desc%iplp = 0 - desc%iplw = 0 - - DO iss = 1, nst - is = idx( iss ) - i1 = in1( is ) - i2 = in2( is ) - IF( st( i1, i2 ) > 0 ) THEN - m1 = i1 + 1; if ( m1 < 1 ) m1 = m1 + nr1 - m2 = i2 + 1; if ( m2 < 1 ) m2 = m2 + nr2 - IF( stw( i1, i2 ) > 0 ) THEN - desc%isind( m1 + ( m2 - 1 ) * nr1x ) = st( i1, i2 ) - desc%iplw( m1 ) = 1 - ELSE - desc%isind( m1 + ( m2 - 1 ) * nr1x ) = -st( i1, i2 ) - END IF - desc%iplp( m1 ) = 1 - IF( .NOT. tk ) THEN - n1 = -i1 + 1; if ( n1 < 1 ) n1 = n1 + nr1 - n2 = -i2 + 1; if ( n2 < 1 ) n2 = n2 + nr2 - IF( stw( -i1, -i2 ) > 0 ) THEN - desc%isind( n1 + ( n2 - 1 ) * nr1x ) = st( -i1, -i2 ) - desc%iplw( n1 ) = 1 - ELSE - desc%isind( n1 + ( n2 - 1 ) * nr1x ) = -st( -i1, -i2 ) - END IF - desc%iplp( n1 ) = 1 - END IF - END IF - END DO - - ! - ! Compute for each proc the global index ( starting from 0 ) of the first - ! local stick ( desc%iss ) - ! - - DO i = 1, nproc - IF( i == 1 ) THEN - desc%iss( i ) = 0 - ELSE - desc%iss( i ) = desc%iss( i - 1 ) + ncp( i - 1 ) - END IF - END DO - - IF( SIZE( desc%ismap ) < ( nst ) ) & - CALL errore( ' fft_dlay_set ', ' wrong descriptor dimensions ', 6 ) - - ! - ! 1. Set the array desc%ismap which maps stick indexes to - ! position in the palne ( iss ) - ! 2. Re-set the array "desc%isind", that maps position - ! in the plane with stick indexes (it is the inverse of desc%ismap ) - ! - - ! wave function sticks first - - desc%ismap = 0 - nsp = 0 - DO iss = 1, SIZE( desc%isind ) - ip = desc%isind( iss ) - IF( ip > 0 ) THEN - nsp( ip ) = nsp( ip ) + 1 - desc%ismap( nsp( ip ) + desc%iss( ip ) ) = iss - IF( ip == me ) THEN - desc%isind( iss ) = nsp( ip ) - ELSE - desc%isind( iss ) = 0 - END IF - END IF - END DO - - ! chack number of stick against the input value - - IF( ANY( nsp( 1:nproc ) /= ncpw( 1:nproc ) ) ) THEN - DO ip = 1, nproc - WRITE( stdout,*) ' * ', ip, ' * ', nsp( ip ), ' /= ', ncpw( ip ) - END DO - CALL errore( ' fft_dlay_set ', ' inconsistent number of sticks ', 7 ) - END IF - - desc%nsw( 1:nproc ) = nsp - - ! then add pseudopotential stick - - DO iss = 1, SIZE( desc%isind ) - ip = desc%isind( iss ) - IF( ip < 0 ) THEN - nsp( -ip ) = nsp( -ip ) + 1 - desc%ismap( nsp( -ip ) + desc%iss( -ip ) ) = iss - IF( -ip == me ) THEN - desc%isind( iss ) = nsp( -ip ) - ELSE - desc%isind( iss ) = 0 - END IF - END IF - END DO - - ! chack number of stick against the input value - - IF( ANY( nsp( 1:nproc ) /= ncp( 1:nproc ) ) ) THEN - DO ip = 1, nproc - WRITE( stdout,*) ' * ', ip, ' * ', nsp( ip ), ' /= ', ncp( ip ) - END DO - CALL errore( ' fft_dlay_set ', ' inconsistent number of sticks ', 8 ) - END IF - - desc%nsp( 1:nproc ) = nsp - - icount = icount + 1 - desc%id = icount - - ! Initialize the pointer to the fft tables - - desc%tptr = icount - - RETURN - END SUBROUTINE fft_dlay_set - -!=----------------------------------------------------------------------------=! - - SUBROUTINE fft_box_set( desc, nr1b, nr2b, nr3b, nr1bx, nr2bx, nr3bx, nat, & - irb, me, nproc, npp, ipp ) - - IMPLICIT NONE - - TYPE (fft_dlay_descriptor) :: desc - - INTEGER, INTENT(IN) :: nat, me, nproc - INTEGER, INTENT(IN) :: irb( :, : ) - INTEGER, INTENT(IN) :: npp( : ) - INTEGER, INTENT(IN) :: ipp( : ) - INTEGER, INTENT(IN) :: nr1b, nr2b, nr3b, nr1bx, nr2bx, nr3bx - - INTEGER :: ir3, ibig3, irb3, imin3, imax3, nr3, isa - - IF( nat > SIZE( desc%irb, 2 ) ) THEN - WRITE( stdout, fmt="( ///,'NAT, SIZE = ',2I10)" ) nat, SIZE( desc%irb, 2 ) - CALL errore(" fft_box_set ", " inconsistent dimensions ", 1 ) - END IF - - IF( nproc > SIZE( desc%npp ) ) & - CALL errore(" fft_box_set ", " inconsistent dimensions ", 2 ) - - desc%nr1 = nr1b - desc%nr2 = nr2b - desc%nr3 = nr3b - desc%nr1x = nr1bx - desc%nr2x = nr2bx - desc%nr3x = nr3bx - - desc%irb( 1:3, 1:nat ) = irb( 1:3, 1:nat ) - desc%npp( 1:nproc ) = npp( 1:nproc ) - desc%ipp( 1:nproc ) = ipp( 1:nproc ) - - nr3 = SUM( npp( 1:nproc ) ) - - DO isa = 1, nat - - imin3 = nr3b - imax3 = 1 - irb3 = irb( 3, isa ) - - do ir3 = 1, nr3b - ibig3 = 1 + MOD( irb3 + ir3 - 2, nr3 ) - if( ibig3 < 1 .or. ibig3 > nr3 ) & - & call errore(' fft_box_set ',' ibig3 wrong ', ibig3 ) - ibig3 = ibig3 - ipp( me ) - if ( ibig3 > 0 .and. ibig3 <= npp(me) ) then - imin3 = min( imin3, ir3 ) - imax3 = max( imax3, ir3 ) - end if - end do - - desc%imin3( isa ) = imin3 - desc%imax3( isa ) = imax3 - desc%np3( isa ) = imax3 - imin3 + 1 - - END DO - - desc%have_task_groups = .FALSE. - - END SUBROUTINE fft_box_set - - -!=----------------------------------------------------------------------------=! - - SUBROUTINE fft_dlay_scalar( desc, ub, lb, nr1, nr2, nr3, nr1x, nr2x, nr3x, stw ) - - implicit none - - TYPE (fft_dlay_descriptor) :: desc - INTEGER, INTENT(IN) :: lb(:), ub(:) - INTEGER, INTENT(IN) :: stw( lb(2) : ub(2), lb(3) : ub(3) ) - - integer :: nr1, nr2, nr3, nr1x, nr2x, nr3x - integer :: m1, m2, i2, i3 - - IF( SIZE( desc%iplw ) < nr3x .OR. SIZE( desc%isind ) < nr2x * nr3x ) & - CALL errore(' fft_dlay_scalar ', ' wrong dimensions ', 1 ) - - desc%isind = 0 - desc%iplw = 0 - desc%iplp = 1 - desc%nr1 = nr1 - desc%nr2 = nr2 - desc%nr3 = nr3 - desc%nr1x = nr1x - desc%nr2x = nr2x - desc%nr3x = nr3x - - ! here we are setting parameter as if we were - ! in a serial code, sticks are along X dimension - ! and not along Z - - DO i2 = lb( 2 ), ub( 2 ) - DO i3 = lb( 3 ), ub( 3 ) - m1 = i2 + 1; if ( m1 < 1 ) m1 = m1 + nr2 - m2 = i3 + 1; if ( m2 < 1 ) m2 = m2 + nr3 - IF( stw( i2, i3 ) > 0 ) THEN - desc%isind( m1 + ( m2 - 1 ) * nr2x ) = 1 ! st( i1, i2 ) - desc%iplw( m2 ) = 1 - END IF - END DO - END DO - - desc%nnr = nr1x * nr2x * nr3x - desc%npl = nr3 - desc%nnp = nr1x * nr2x - desc%npp = nr3 - desc%ipp = 0 - desc%have_task_groups = .FALSE. - desc%nnrx = desc%nnr - - RETURN - END SUBROUTINE fft_dlay_scalar - - - -END MODULE fft_types diff --git a/quantum_espresso/kcp/Modules/functionals.f90 b/quantum_espresso/kcp/Modules/functionals.f90 deleted file mode 100644 index dd4964d35..000000000 --- a/quantum_espresso/kcp/Modules/functionals.f90 +++ /dev/null @@ -1,1627 +0,0 @@ -! -! Copyright (C) 2004-2009 Quantum ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!------------------------------------------------------------------- -module funct -!------------------------------------------------------------------- -! This module contains data defining the DFT functional in use -! and a number of functions and subroutines to manage them. -! Data are PRIVATE and are accessed and set only by function calls. -! Basic drivers to compute XC quantities are also included. -! -! setting routines: set_dft_from_name (previously which_dft) -! set_dft_from_indices -! enforce_input_dft -! start_exx -! stop_exx -! set_finite_size_volume -! retrive functions: get_dft_name -! get_iexch -! get_icorr -! get_igcx -! get_igcc -! get_exx_fraction -! dft_name -! write_dft_name -! logical functions: dft_is_gradient -! dft_is_meta -! dft_is_hybrid -! exx_is_active -! dft_has_finite_size_correction -! -! XC computation drivers: xc, xc_spin, gcxc, gcx_spin, gcc_spin, gcc_spin_more -! derivatives of XC computation drivers: dmxc, dmxc_spin, dmxc_nc, dgcxc, -! dgcxc_spin -! - USE io_global, ONLY: stdout - USE kinds, ONLY: DP - IMPLICIT NONE - PRIVATE - SAVE - ! subroutines/functions managing dft name and indices - PUBLIC :: set_dft_from_indices, set_dft_from_name - PUBLIC :: enforce_input_dft, write_dft_name, dft_name - PUBLIC :: get_dft_name, get_iexch, get_icorr, get_igcx, get_igcc - PUBLIC :: dft_is_gradient, dft_is_meta, dft_is_hybrid - ! additional subroutines/functions for hybrid functionals - PUBLIC :: start_exx, stop_exx, get_exx_fraction, exx_is_active - ! additional subroutines/functions for finite size corrections - PUBLIC :: dft_has_finite_size_correction, set_finite_size_volume - ! driver subroutines computing XC - PUBLIC :: xc, xc_spin, gcxc, gcx_spin, gcc_spin, gcc_spin_more - PUBLIC :: dmxc, dmxc_spin, dmxc_nc - PUBLIC :: dgcxc, dgcxc_spin - ! - ! PRIVATE variables defining the DFT functional - ! - PRIVATE :: dft, dft_shortname, iexch, icorr, igcx, igcc - PRIVATE :: discard_input_dft - PRIVATE :: isgradient, ismeta, ishybrid - PRIVATE :: exx_fraction, exx_started - PRIVATE :: has_finite_size_correction, & - finite_size_cell_volume, finite_size_cell_volume_set - ! - character (len=20) :: dft = 'not set' - character (len=6) :: dft_shortname = ' ' - ! - ! dft is the exchange-correlation functional, described by - ! any nonconflicting combination of the following keywords - ! (case-insensitive): - ! - ! Exchange: "nox" none iexch=0 - ! "sla" Slater (alpha=2/3) iexch=1 (default) - ! "sl1" Slater (alpha=1.0) iexch=2 - ! "rxc" Relativistic Slater iexch=3 - ! "oep" Optimized Effective Potential iexch=4 - ! "hf" Hartree-Fock iexch=5 - ! "pb0x" PBE0 (Slater*0.75+HF*0.25) iexch=6 - ! "b3lp" B3LYP(Slater*0.80+HF*0.20) iexch=7 - ! "kzk" Finite-size corrections iexch=8 - ! - ! Correlation: "noc" none icorr=0 - ! "pz" Perdew-Zunger icorr=1 (default) - ! "vwn" Vosko-Wilk-Nusair icorr=2 - ! "lyp" Lee-Yang-Parr icorr=3 - ! "pw" Perdew-Wang icorr=4 - ! "wig" Wigner icorr=5 - ! "hl" Hedin-Lunqvist icorr=6 - ! "obz" Ortiz-Ballone form for PZ icorr=7 - ! "obw" Ortiz-Ballone form for PW icorr=8 - ! "gl" Gunnarson-Lunqvist icorr=9 - ! "b3lp" B3LYP (same as "vwn") icorr=10 - ! "kzk" Finite-size corrections icorr=11 - ! - ! Gradient Correction on Exchange: - ! "nogx" none igcx =0 (default) - ! "b88" Becke88 (beta=0.0042) igcx =1 - ! "ggx" Perdew-Wang 91 igcx =2 - ! "pbx" Perdew-Burke-Ernzenhof exch igcx =3 - ! "rpb" revised PBE by Zhang-Yang igcx =4 - ! "hcth" Cambridge exch, Handy et al igcx =5 - ! "optx" Handy's exchange functional igcx =6 - ! "meta" TPSS meta-gga igcx =7 - ! "pb0x" PBE0 (PBE exchange*0.75) igcx =8 - ! "b3lp" B3LYP (Becke88*0.72) igcx =9 - ! "psx" PBEsol exchange igcx =10 - ! "wcx" Wu-Cohen igcx =11 - ! - ! Gradient Correction on Correlation: - ! "nogc" none igcc =0 (default) - ! "p86" Perdew86 igcc =1 - ! "ggc" Perdew-Wang 91 corr. igcc =2 - ! "blyp" Lee-Yang-Parr igcc =3 - ! "pbc" Perdew-Burke-Ernzenhof corr igcc =4 - ! "hcth" Cambridge corr, Handy et al igcc =5 - ! "meta" TPSS meta-gga igcc =6 - ! "b3lp" B3LYP (Lee-Yang-Parr*0.81) igcc =7 - ! "psc" PBEsol corr igcc =8 - ! - ! Special cases (dft_shortname): - ! "bp" = "b88+p86" = Becke-Perdew grad.corr. - ! "pw91" = "pw +ggx+ggc" = PW91 (aka GGA) - ! "blyp" = "sla+b88+lyp+blyp" = BLYP - ! "pbe" = "sla+pw+pbx+pbc" = PBE - ! "revpbe"="sla+pw+rpb+pbc" = revPBE (Zhang-Yang) - ! "pbesol"="sla+pw+psx+psc" = PBEsol - ! "hcth" = "nox+noc+hcth+hcth" =HCTH/120 - ! "olyp" = "nox+lyp+optx+blyp"!!! UNTESTED !!! - ! "tpss" = "sla+pw+meta+meta" = TPSS Meta-GGA - ! "wc" = "sla+pw+wcx+pbc" = Wu-Cohen - ! "pbe0" = "pb0x+pw+pb0x+pbc" = PBE0 - ! "b3lyp" = "b3lp+vwn+b3lp+b3lp"= B3LYP - ! - ! References: - ! pz J.P.Perdew and A.Zunger, PRB 23, 5048 (1981) - ! vwn S.H.Vosko, L.Wilk, M.Nusair, Can.J.Phys. 58,1200(1980) - ! wig E.P.Wigner, Trans. Faraday Soc. 34, 67 (1938) - ! hl L.Hedin and B.I.Lundqvist, J. Phys. C4, 2064 (1971) - ! gl O.Gunnarsson and B.I.Lundqvist, PRB 13, 4274 (1976) - ! pw J.P.Perdew and Y.Wang, PRB 45, 13244 (1992) - ! obpz G.Ortiz and P.Ballone, PRB 50, 1391 (1994) - ! obpw as above - ! b88 A.D.Becke, PRA 38, 3098 (1988) - ! p86 J.P.Perdew, PRB 33, 8822 (1986) - ! pbe J.P.Perdew, K.Burke, M.Ernzerhof, PRL 77, 3865 (1996) - ! pw91 J.P.Perdew and Y. Wang, PRB 46, 6671 (1992) - ! blyp C.Lee, W.Yang, R.G.Parr, PRB 37, 785 (1988) - ! hcth Handy et al, JCP 109, 6264 (1998) - ! olyp Handy et al, JCP 116, 5411 (2002) - ! revPBE Zhang and Yang, PRL 80, 890 (1998) - ! meta J.Tao, J.P.Perdew, V.N.Staroverov, G.E. Scuseria, - ! PRL 91, 146401 (2003) - ! kzk H.Kwee, S. Zhang, H. Krakauer, PRL 100, 126404 (2008) - ! pbe0 J.P.Perdew, M. Ernzerhof, K.Burke, JCP 105, 9982 (1996) - ! b3lyp P.J. Stephens,F.J. Devlin,C.F. Chabalowski,M.J. Frisch - ! J.Phys.Chem 98, 11623 (1994) - ! pbesol J.P. Perdew et al., PRL 100, 136406 (2008) - ! wc Z. Wu and R. E. Cohen, PRB 73, 235116 (2006) - ! - integer, parameter:: notset = -1 - ! - integer :: iexch = notset - integer :: icorr = notset - integer :: igcx = notset - integer :: igcc = notset - real(DP):: exx_fraction = 0.0_DP - logical :: isgradient = .false. - logical :: ismeta = .false. - logical :: ishybrid = .false. - logical :: exx_started = .false. - logical :: has_finite_size_correction = .false. - logical :: finite_size_cell_volume_set = .false. - real(DP):: finite_size_cell_volume = notset - - logical :: discard_input_dft = .false. - ! - ! internal indices for exchange-correlation - ! iexch: type of exchange - ! icorr: type of correlation - ! igcx: type of gradient correction on exchange - ! igcc: type of gradient correction on correlation - ! - ! ismeta: .TRUE. if gradient correction is of meta-gga type - ! ishybrid: .TRUE. if the xc functional is an HF+DFT hybrid like - ! PBE0 or B3LYP or HF itself - ! - ! see comments above and routine "set_dft_from_name" below - ! - ! data - integer :: nxc, ncc, ngcx, ngcc - parameter (nxc = 8, ncc =11, ngcx =11, ngcc = 8) - character (len=4) :: exc, corr - character (len=4) :: gradx, gradc - dimension exc (0:nxc), corr (0:ncc), gradx (0:ngcx), gradc (0: ngcc) - - data exc / 'NOX', 'SLA', 'SL1', 'RXC', 'OEP', 'HF', 'PB0X', 'B3LP', 'KZK' / - data corr / 'NOC', 'PZ', 'VWN', 'LYP', 'PW', 'WIG', 'HL', 'OBZ', & - 'OBW', 'GL' , 'B3LP', 'KZK' / - data gradx / 'NOGX', 'B88', 'GGX', 'PBX', 'RPB', 'HCTH', 'OPTX',& - 'META', 'PB0X', 'B3LP','PSX', 'WCX' / - data gradc / 'NOGC', 'P86', 'GGC', 'BLYP', 'PBC', 'HCTH', 'META',& - 'B3LP', 'PSC' / - -CONTAINS - !----------------------------------------------------------------------- - subroutine set_dft_from_name( dft_ ) - !----------------------------------------------------------------------- - ! - ! translates a string containing the exchange-correlation name - ! into internal indices iexch, icorr, igcx, igcc - ! - implicit none - ! input - character(len=*) :: dft_ - ! local - integer :: len, l, i - character (len=50):: dftout - logical, external :: matches - character (len=1), external :: capital - ! - ! - ! if - ! - if ( discard_input_dft ) return - ! - ! convert to uppercase - len = len_trim(dft_) - dftout = ' ' - do l = 1, len - dftout (l:l) = capital (dft_(l:l) ) - enddo - - ! exchange - iexch = notset - do i = 0, nxc - if (matches (exc (i), dftout) ) call set_dft_value (iexch, i) - enddo - - ! correlation - icorr = notset - do i = 0, ncc - if (matches (corr (i), dftout) ) call set_dft_value (icorr, i) - enddo - - ! gradient correction, exchange - igcx = notset - do i = 0, ngcx - if (matches (gradx (i), dftout) ) call set_dft_value (igcx, i) - enddo - - ! gradient correction, correlation - igcc = notset - do i = 0, ngcc - if (matches (gradc (i), dftout) ) call set_dft_value (igcc, i) - enddo - - ! special case : BLYP => B88 for gradient correction on exchange - if (matches ('BLYP', dftout) ) call set_dft_value (igcx, 1) - - ! special case : revPBE - if (matches ('REVPBE', dftout) ) then - call set_dft_value (icorr,4) - call set_dft_value (igcx, 4) - call set_dft_value (igcc, 4) - else if (matches('RPBE',dftout)) then - call errore('set_dft_from_name', & - & 'RPBE (Hammer-Hansen-Norskov) not implemented (revPBE is)',1) - else if (matches ('PBE0', dftout) ) then - ! special case : PBE0 - call set_dft_value (iexch,6) - call set_dft_value (icorr,4) - call set_dft_value (igcx, 8) - call set_dft_value (igcc, 4) - else if (matches ('PBESOL', dftout) ) then - ! special case : PBEsol - call set_dft_value (icorr,4) - call set_dft_value (igcx,10) - call set_dft_value (igcc, 8) - else if (matches ('PBE', dftout) ) then - ! special case : PBE - call set_dft_value (icorr,4) - call set_dft_value (igcx, 3) - call set_dft_value (igcc, 4) - else if (matches ('WC', dftout) ) then - ! special case : Wu-Cohen - call set_dft_value (icorr,4) - call set_dft_value (igcx,11) - call set_dft_value (igcc, 4) - else if (matches ('B3LYP', dftout) ) then - ! special case : B3LYP hybrid - call set_dft_value (iexch,7) - !!! cannot use set_dft_value due to conflict with blyp - icorr = 2 - call set_dft_value (igcx, 9) - !!! as above - igcc = 7 - endif - - if (matches ('PBC', dftout) ) then - ! special case : PBC = PW + PBC - call set_dft_value (icorr,4) - call set_dft_value (igcc, 4) - endif - - ! special case : BP = B88 + P86 - if (matches ('BP', dftout) ) then - call set_dft_value (igcx, 1) - call set_dft_value (igcc, 1) - endif - - ! special case : PW91 = GGX + GGC - if (matches ('PW91', dftout) ) then - call set_dft_value (igcx, 2) - call set_dft_value (igcc, 2) - endif - - ! special case : HCTH already contains LDA exchange and correlation - - if (matches('HCTH',dftout)) then - call set_dft_value(iexch,0) - call set_dft_value(icorr,0) - end if - - ! special case : OPTX already contains LDA exchange - - if (matches('OPTX',dftout)) then - call set_dft_value(iexch,0) - end if - - ! special case : OLYP = OPTX + LYP - - if (matches('OLYP',dftout)) then - call set_dft_value(iexch,0) - call set_dft_value(icorr,3) - call set_dft_value(igcx,6) - call set_dft_value(igcc,3) - end if - - ! - ! ... special case : TPSS meta-GGA Exc - ! - IF ( matches( 'TPSS', dftout ) ) THEN - ! - CALL set_dft_value( iexch, 1 ) - CALL set_dft_value( icorr, 4 ) - CALL set_dft_value( igcx, 7 ) - CALL set_dft_value( igcc, 6 ) - ! - END IF - ! - ! ... special cases : OEP and HF need not GC part (nor LDA...) - ! and include no correlation by default - ! - IF ( matches( 'OEP', dftout ) .OR. matches( 'HF', dftout )) THEN - ! - CALL set_dft_value( igcx, 0 ) - if (icorr == notset) call set_dft_value (icorr, 0) - ! - END IF - - - if (igcx == 6) & - call errore('set_dft_from_name','OPTX untested! please test',-igcx) - ! Default value: Slater exchange - if (iexch == notset) call set_dft_value (iexch, 1) - - ! Default value: Perdew-Zunger correlation - if (icorr == notset) call set_dft_value (icorr, 1) - - ! Default value: no gradient correction on exchange - if (igcx == notset) call set_dft_value (igcx, 0) - - ! Default value: no gradient correction on correlation - if (igcc == notset) call set_dft_value (igcc, 0) - - dft = dftout - - dftout = exc (iexch) //'-'//corr (icorr) //'-'//gradx (igcx) //'-' & - &//gradc (igcc) - ! WRITE( stdout,'(a)') dftout - - call set_auxiliary_flags - - return - end subroutine set_dft_from_name - ! - !----------------------------------------------------------------------- - subroutine set_auxiliary_flags - !----------------------------------------------------------------------- - ! set logical flags describing the complexity of the xc functional - ! define the fraction of exact exchange used by hybrid fuctionals - ! - logical, external :: matches - - isgradient = (igcx > 0) .or. (igcc > 0) - ismeta = (igcx == 7) .or. (igcx == 6 ) - - ! PBE0 - IF ( iexch==6 .or. igcx ==8 ) exx_fraction = 0.25_DP - ! HF or OEP - IF ( iexch==4 .or. iexch==5 ) exx_fraction = 1.0_DP - !B3LYP - IF ( matches( 'B3LP',dft ) .OR. matches( 'B3LYP',dft ) ) & - exx_fraction = 0.2_DP - ishybrid = ( exx_fraction /= 0.0_DP ) - - has_finite_size_correction = ( iexch==8 .or. icorr==11) - - return - end subroutine set_auxiliary_flags - ! - !----------------------------------------------------------------------- - subroutine set_dft_value (m, i) - !----------------------------------------------------------------------- - ! - implicit none - integer :: m, i - ! local - - if ( m /= notset .and. m /= i) & - call errore ('set_dft_value', 'two conflicting matching values', 1) - m = i - return - - end subroutine set_dft_value - - !----------------------------------------------------------------------- - subroutine enforce_input_dft (dft_) - ! - ! translates a string containing the exchange-correlation name - ! into internal indices and force any subsequent call to set_dft_from_name - ! to return without changing them - ! - implicit none - ! input - character(len=*) :: dft_ - ! data - - call set_dft_from_name (dft_) - if (dft == 'not set') call errore('enforce_input_dft','cannot fix unset dft',1) - discard_input_dft = .true. - - write (stdout,'(/,5x,a)') "!!! XC functional enforced from input :" - call write_dft_name - write (stdout,'(5x,a)') "!!! Any further DFT definition will be discarded" - write (stdout,'(5x,a)') "!!! Please, verify this is what you really want !" - - return - end subroutine enforce_input_dft - !----------------------------------------------------------------------- - subroutine start_exx - if (.not. ishybrid) & - call errore('start_exx','dft is not hybrid, wrong call',1) - exx_started = .true. - end subroutine start_exx - !----------------------------------------------------------------------- - subroutine stop_exx - if (.not. ishybrid) & - call errore('stop_exx','dft is not hybrid, wrong call',1) - exx_started = .false. - end subroutine stop_exx - !----------------------------------------------------------------------- - function exx_is_active () - logical exx_is_active - exx_is_active = exx_started - end function exx_is_active - - !----------------------------------------------------------------------- - function get_iexch () - integer get_iexch - get_iexch = iexch - return - end function get_iexch - !----------------------------------------------------------------------- - function get_icorr () - integer get_icorr - get_icorr = icorr - return - end function get_icorr - !----------------------------------------------------------------------- - function get_igcx () - integer get_igcx - get_igcx = igcx - return - end function get_igcx - !----------------------------------------------------------------------- - function get_igcc () - integer get_igcc - get_igcc = igcc - return - end function get_igcc - !----------------------------------------------------------------------- - function get_exx_fraction () - real(DP):: get_exx_fraction - get_exx_fraction = exx_fraction - return - end function get_exx_fraction - !----------------------------------------------------------------------- - function get_dft_name () - character (len=20) :: get_dft_name - get_dft_name = dft - return - end function get_dft_name - !----------------------------------------------------------------------- - function dft_is_gradient () - logical :: dft_is_gradient - dft_is_gradient = isgradient - return - end function dft_is_gradient - !----------------------------------------------------------------------- - function dft_is_meta () - logical :: dft_is_meta - dft_is_meta = ismeta - return - end function dft_is_meta - !----------------------------------------------------------------------- - function dft_is_hybrid () - logical :: dft_is_hybrid - dft_is_hybrid = ishybrid - return - end function dft_is_hybrid - !----------------------------------------------------------------------- - function dft_has_finite_size_correction () - logical :: dft_has_finite_size_correction - dft_has_finite_size_correction = has_finite_size_correction - return - end function dft_has_finite_size_correction - !----------------------------------------------------------------------- - subroutine set_finite_size_volume(volume) - real, intent (IN) :: volume - if (.not. has_finite_size_correction) & - call errore('set_finite_size_volume', & - 'dft w/o finite_size_correction, wrong call',1) - if (volume <= 0.d0) & - call errore('set_finite_size_volume', & - 'volume is not positive, check omega and/or nk1,nk2,nk3',1) - finite_size_cell_volume = volume - finite_size_cell_volume_set = .TRUE. - end subroutine set_finite_size_volume - !----------------------------------------------------------------------- - - !----------------------------------------------------------------------- - subroutine set_dft_from_indices(iexch_,icorr_,igcx_,igcc_) - integer :: iexch_, icorr_, igcx_, igcc_ - if ( discard_input_dft ) return - if (iexch == notset) iexch = iexch_ - if (iexch /= iexch_) then - write (stdout,*) iexch, iexch_ - call errore('set_dft',' conflicting values for iexch',1) - end if - if (icorr == notset) icorr = icorr_ - if (icorr /= icorr_) then - write (stdout,*) icorr, icorr_ - call errore('set_dft',' conflicting values for icorr',1) - end if - if (igcx == notset) igcx = igcx_ - if (igcx /= igcx_) then - write (stdout,*) igcx, igcx_ - call errore('set_dft',' conflicting values for igcx',1) - end if - if (igcc == notset) igcc = igcc_ - if (igcc /= igcc_) then - write (stdout,*) igcc, igcc_ - call errore('set_dft',' conflicting values for igcc',1) - end if - dft = exc (iexch) //'-'//corr (icorr) //'-'//gradx (igcx) //'-' & - &//gradc (igcc) - ! WRITE( stdout,'(a)') dft - call set_auxiliary_flags - return - end subroutine set_dft_from_indices - !--------------------------------------------------------------------- - subroutine dft_name(iexch_, icorr_, igcx_, igcc_, longname_, shortname_) - !--------------------------------------------------------------------- - ! convert the four indices iexch, icorr, igcx, igcc - ! into user-readable strings - ! - implicit none - integer iexch_, icorr_, igcx_, igcc_ - character (len=6) :: shortname_ - character (len=20):: longname_ - ! - if (iexch_==1.and.igcx_==0.and.igcc_==0) then - shortname_ = corr(icorr_) - else if (iexch_==1.and.icorr_==3.and.igcx_==1.and.igcc_==3) then - shortname_ = 'BLYP' - else if (iexch_==1.and.icorr_==1.and.igcx_==1.and.igcc_==0) then - shortname_ = 'B88' - else if (iexch_==1.and.icorr_==1.and.igcx_==1.and.igcc_==1) then - shortname_ = 'BP' - else if (iexch_==1.and.icorr_==4.and.igcx_==2.and.igcc_==2) then - shortname_ = 'PW91' - else if (iexch_==1.and.icorr_==4.and.igcx_==3.and.igcc_==4) then - shortname_ = 'PBE' - else if (iexch_==6.and.icorr_==4.and.igcx_==8.and.igcc_==4) then - shortname_ = 'PBE0' - else if (iexch_==1.and.icorr_==4.and.igcx_==4.and.igcc_==4) then - shortname_ = 'revPBE' - else if (iexch_==1.and.icorr_==4.and.igcx_==10.and.igcc_==8) then - shortname_ = 'PBESOL' - else if (iexch_==1.and.icorr_==4.and.igcx_==11.and.igcc_==4) then - shortname_ = 'WC' - else if (iexch_==7.and.(icorr_==10.or.icorr_==2).and.igcx_==9.and. & - igcc_==7) then - shortname_ = 'B3LYP' - else - shortname_ = ' ' - end if - write(longname_,'(4a5)') exc(iexch_),corr(icorr_),gradx(igcx_),gradc(igcc_) - - return -end subroutine dft_name - -subroutine write_dft_name -!----------------------------------------------------------------------- - WRITE( stdout, '(5X,"Exchange-correlation = ",A, & - & " (",4I1,")")') TRIM( dft ), iexch, icorr, igcx, igcc - return -end subroutine write_dft_name - -! -!----------------------------------------------------------------------- -!------- LDA DRIVERS -------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -subroutine xc (rho, ex, ec, vx, vc) - !----------------------------------------------------------------------- - ! lda exchange and correlation functionals - Hartree a.u. - ! - ! exchange : Slater, relativistic Slater - ! correlation: Ceperley-Alder (Perdew-Zunger parameters) - ! Vosko-Wilk-Nusair - ! Lee-Yang-Parr - ! Perdew-Wang - ! Wigner - ! Hedin-Lundqvist - ! Ortiz-Ballone (Perdew-Zunger formula) - ! Ortiz-Ballone (Perdew-Wang formula) - ! Gunnarsson-Lundqvist - ! - ! input : rho=rho(r) - ! definitions: E_x = \int E_x(rho) dr, E_x(rho) = rho\epsilon_c(rho) - ! same for correlation - ! output: ex = \epsilon_x(rho) ( NOT E_x(rho) ) - ! vx = dE_x(rho)/drho ( NOT d\epsilon_x(rho)/drho ) - ! ec, vc as above for correlation - ! - implicit none - - real(DP) :: rho, ec, vc, ex, vx - ! - real(DP), parameter :: small = 1.E-10_DP, third = 1.0_DP / 3.0_DP, & - pi34 = 0.6203504908994_DP ! pi34=(3/4pi)^(1/3) - real(DP) :: rs - ! - if (rho <= small) then - ec = 0.0_DP - vc = 0.0_DP - ex = 0.0_DP - vx = 0.0_DP - return - else - rs = pi34 / rho**third - ! rs as in the theory of metals: rs=(3/(4pi rho))^(1/3) - endif - !..exchange - if (iexch == 1) THEN ! 'sla' - call slater (rs, ex, vx) - ELSEIF (iexch == 2) THEN ! 'sl1' - call slater1(rs, ex, vx) - ELSEIF (iexch == 3) THEN ! 'rxc' - CALL slater_rxc(rs, ex, vx) - ELSEIF ((iexch == 4).or.(iexch==5)) THEN ! 'oep','hf' - IF (exx_started) then - ex = 0.0_DP - vx = 0.0_DP - else - call slater (rs, ex, vx) - endif - ELSEIF (iexch == 6) THEN ! 'pb0x' - CALL slater(rs, ex, vx) - if (exx_started) then - ex = 0.75_DP * ex - vx = 0.75_DP * vx - end if - ELSEIF (iexch == 7) THEN ! 'b3lyp' - CALL slater(rs, ex, vx) - if (exx_started) then - ex = 0.8_DP * ex - vx = 0.8_DP * vx - end if - ELSEIF (iexch == 8) THEN ! 'sla+kzk' - if (.NOT. finite_size_cell_volume_set) call errore ('XC',& - 'finite size corrected exchange used w/o initialization',1) - call slaterKZK (rs, ex, vx, finite_size_cell_volume) - else - ex = 0.0_DP - vx = 0.0_DP - endif - !..correlation - if (icorr == 1) then - call pz (rs, 1, ec, vc) - elseif (icorr == 2) then - call vwn (rs, ec, vc) - elseif (icorr == 3) then - call lyp (rs, ec, vc) - elseif (icorr == 4) then - call pw (rs, 1, ec, vc) - elseif (icorr == 5) then - call wigner (rs, ec, vc) - elseif (icorr == 6) then - call hl (rs, ec, vc) - elseif (icorr == 7) then - call pz (rs, 2, ec, vc) - elseif (icorr == 8) then - call pw (rs, 2, ec, vc) - elseif (icorr == 9) then - call gl (rs, ec, vc) - elseif (icorr ==10) then ! b3lyp - call vwn (rs, ec, vc) - elseif (icorr ==11) then - if (.NOT. finite_size_cell_volume_set) call errore ('XC',& - 'finite size corrected correlation used w/o initialization',1) - call pzKZK (rs, ec, vc, finite_size_cell_volume) - else - ec = 0.0_DP - vc = 0.0_DP - endif - ! - return -end subroutine xc -!!!!!!!!!!!!!!SPIN -!----------------------------------------------------------------------- -subroutine xc_spin (rho, zeta, ex, ec, vxup, vxdw, vcup, vcdw) - !----------------------------------------------------------------------- - ! lsd exchange and correlation functionals - Hartree a.u. - ! - ! exchange : Slater (alpha=2/3) - ! correlation: Ceperley & Alder (Perdew-Zunger parameters) - ! Perdew & Wang - ! - ! input : rho = rhoup(r)+rhodw(r) - ! zeta=(rhoup(r)-rhodw(r))/rho - ! - implicit none - - real(DP) :: rho, zeta, ex, ec, vxup, vxdw, vcup, vcdw - ! - real(DP), parameter :: small= 1.E-10_DP, third = 1.0_DP/3.0_DP, & - pi34= 0.6203504908994_DP ! pi34=(3/4pi)^(1/3) - real(DP) :: rs - ! - if (rho <= small) then - ec = 0.0_DP - vcup = 0.0_DP - vcdw = 0.0_DP - ex = 0.0_DP - vxup = 0.0_DP - vxdw = 0.0_DP - return - else - rs = pi34 / rho**third - endif - !..exchange - IF (iexch == 1) THEN ! 'sla' - call slater_spin (rho, zeta, ex, vxup, vxdw) - ELSEIF (iexch == 2) THEN ! 'sl1' - call slater1_spin (rho, zeta, ex, vxup, vxdw) - ELSEIF (iexch == 3) THEN ! 'rxc' - call slater_rxc_spin ( rho, zeta, ex, vxup, vxdw ) - ELSEIF ((iexch == 4).or.(iexch==5)) THEN ! 'oep','hf' - IF (exx_started) then - ex = 0.0_DP - vxup = 0.0_DP - vxdw = 0.0_DP - else - call slater_spin (rho, zeta, ex, vxup, vxdw) - endif - ELSEIF (iexch == 6) THEN ! 'pb0x' - call slater_spin (rho, zeta, ex, vxup, vxdw) - if (exx_started) then - ex = 0.75_DP * ex - vxup = 0.75_DP * vxup - vxdw = 0.75_DP * vxdw - end if - ELSEIF (iexch == 7) THEN ! 'b3lyp' - call slater_spin (rho, zeta, ex, vxup, vxdw) - if (exx_started) then - ex = 0.8_DP * ex - vxup = 0.8_DP * vxup - vxdw = 0.8_DP * vxdw - end if - ELSE - ex = 0.0_DP - vxup = 0.0_DP - vxdw = 0.0_DP - ENDIF - !..correlation - if (icorr == 0) then - ec = 0.0_DP - vcup = 0.0_DP - vcdw = 0.0_DP - elseif (icorr == 1) then - call pz_spin (rs, zeta, ec, vcup, vcdw) - elseif (icorr == 2) then - call vwn_spin (rs, zeta, ec, vcup, vcdw) - elseif (icorr == 3) then - call lsd_lyp (rho, zeta, ec, vcup, vcdw) ! from CP/FPMD (more_functionals) - elseif (icorr == 4) then - call pw_spin (rs, zeta, ec, vcup, vcdw) - else - call errore ('lsda_functional', 'not implemented', icorr) - endif - ! - return -end subroutine xc_spin -! -!----------------------------------------------------------------------- -!------- GRADIENT CORRECTIONS DRIVERS ---------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -subroutine gcxc (rho, grho, sx, sc, v1x, v2x, v1c, v2c) - !----------------------------------------------------------------------- - ! gradient corrections for exchange and correlation - Hartree a.u. - ! See comments at the beginning of module for implemented cases - ! - ! input: rho, grho=|\nabla rho|^2 - ! definition: E_x = \int E_x(rho,grho) dr - ! output: sx = E_x(rho,grho) - ! v1x= D(E_x)/D(rho) - ! v2x= D(E_x)/D( D rho/D r_alpha ) / |\nabla rho| - ! sc, v1c, v2c as above for correlation - ! - implicit none - - real(DP) :: rho, grho, sx, sc, v1x, v2x, v1c, v2c - real(DP), parameter:: small = 1.E-10_DP - - ! exchange - if (rho <= small) then - sx = 0.0_DP - v1x = 0.0_DP - v2x = 0.0_DP - elseif (igcx == 1) then - call becke88 (rho, grho, sx, v1x, v2x) - elseif (igcx == 2) then - call ggax (rho, grho, sx, v1x, v2x) - elseif (igcx == 3) then - call pbex (rho, grho, 1, sx, v1x, v2x) - elseif (igcx == 4) then - call pbex (rho, grho, 2, sx, v1x, v2x) - elseif (igcx == 5 .and. igcc == 5) then - call hcth(rho, grho, sx, v1x, v2x) - elseif (igcx == 6) then - call optx (rho, grho, sx, v1x, v2x) - elseif (igcx == 8) then ! 'pbe0' - call pbex (rho, grho, 1, sx, v1x, v2x) - if (exx_started) then - sx = 0.75_DP * sx - v1x = 0.75_DP * v1x - v2x = 0.75_DP * v2x - end if - elseif (igcx == 9) then ! 'b3lyp' - call becke88 (rho, grho, sx, v1x, v2x) - if (exx_started) then - sx = 0.72_DP * sx - v1x = 0.72_DP * v1x - v2x = 0.72_DP * v2x - end if - elseif (igcx ==10) then ! 'pbesol' - call pbex (rho, grho, 3, sx, v1x, v2x) - elseif (igcx ==11) then ! 'wc' - call wcx (rho, grho, sx, v1x, v2x) - else - sx = 0.0_DP - v1x = 0.0_DP - v2x = 0.0_DP - endif - ! correlation - if (rho.le.small) then - sc = 0.0_DP - v1c = 0.0_DP - v2c = 0.0_DP - elseif (igcc == 1) then - call perdew86 (rho, grho, sc, v1c, v2c) - elseif (igcc == 2) then - call ggac (rho, grho, sc, v1c, v2c) - elseif (igcc == 3) then - call glyp (rho, grho, sc, v1c, v2c) - elseif (igcc == 4) then - call pbec (rho, grho, 1, sc, v1c, v2c) - elseif (igcc == 7) then !'B3LYP' - call glyp (rho, grho, sc, v1c, v2c) - if (exx_started) then - sc = 0.81_DP * sc - v1c = 0.81_DP * v1c - v2c = 0.81_DP * v2c - end if - elseif (igcc == 8) then ! 'PBEsol' - call pbec (rho, grho, 2, sc, v1c, v2c) - else - ! note that if igcc == 5 the hcth functional is called above - sc = 0.0_DP - v1c = 0.0_DP - v2c = 0.0_DP - endif - ! - return -end subroutine gcxc -! -!!!!!!!!!!!!!!SPIN -!----------------------------------------------------------------------- -subroutine gcx_spin (rhoup, rhodw, grhoup2, grhodw2, & - sx, v1xup, v1xdw, v2xup, v2xdw) - !----------------------------------------------------------------------- - ! gradient corrections for exchange - Hartree a.u. - ! - implicit none - ! - ! dummy arguments - ! - real(DP) :: rhoup, rhodw, grhoup2, grhodw2, sx, v1xup, v1xdw, & - v2xup, v2xdw - ! up and down charge - ! up and down gradient of the charge - ! exchange and correlation energies - ! derivatives of exchange wr. rho - ! derivatives of exchange wr. grho - ! - real(DP), parameter :: small = 1.E-10_DP - real(DP) :: rho, sxup, sxdw - integer :: iflag - ! - ! - ! exchange - rho = rhoup + rhodw - if (rho <= small .or. igcx == 0) then - sx = 0.0_DP - v1xup = 0.0_DP - v2xup = 0.0_DP - v1xdw = 0.0_DP - v2xdw = 0.0_DP - elseif (igcx == 1) then - if (rhoup > small .and. sqrt (abs (grhoup2) ) > small) then - call becke88_spin (rhoup, grhoup2, sxup, v1xup, v2xup) - else - sxup = 0.0_DP - v1xup = 0.0_DP - v2xup = 0.0_DP - endif - if (rhodw > small .and. sqrt (abs (grhodw2) ) > small) then - call becke88_spin (rhodw, grhodw2, sxdw, v1xdw, v2xdw) - else - sxdw = 0.0_DP - v1xdw = 0.0_DP - v2xdw = 0.0_DP - endif - sx = sxup + sxdw - elseif (igcx == 2) then - if (rhoup > small .and. sqrt (abs (grhoup2) ) > small) then - call ggax (2.0_DP * rhoup, 4.0_DP * grhoup2, sxup, v1xup, v2xup) - else - sxup = 0.0_DP - v1xup = 0.0_DP - v2xup = 0.0_DP - endif - if (rhodw > small .and. sqrt (abs (grhodw2) ) > small) then - call ggax (2.0_DP * rhodw, 4.0_DP * grhodw2, sxdw, v1xdw, v2xdw) - else - sxdw = 0.0_DP - v1xdw = 0.0_DP - v2xdw = 0.0_DP - endif - sx = 0.5_DP * (sxup + sxdw) - v2xup = 2.0_DP * v2xup - v2xdw = 2.0_DP * v2xdw - elseif (igcx == 3 .or. igcx == 4 .or. igcx == 8 .or. igcx == 10) then - ! igcx=3: PBE, igcx=4: revised PBE, igcx=8 PBE0, igcx=10: PBEsol - if (igcx == 4) then - iflag = 2 - elseif (igcx == 10) then - iflag = 3 - else - iflag = 1 - endif - if (rhoup > small .and. sqrt (abs (grhoup2) ) > small) then - call pbex (2.0_DP * rhoup, 4.0_DP * grhoup2, iflag, sxup, v1xup, v2xup) - else - sxup = 0.0_DP - v1xup = 0.0_DP - v2xup = 0.0_DP - endif - if (rhodw > small .and. sqrt (abs (grhodw2) ) > small) then - call pbex (2.0_DP * rhodw, 4.0_DP * grhodw2, iflag, sxdw, v1xdw, v2xdw) - else - sxdw = 0.0_DP - v1xdw = 0.0_DP - v2xdw = 0.0_DP - endif - sx = 0.5_DP * (sxup + sxdw) - v2xup = 2.0_DP * v2xup - v2xdw = 2.0_DP * v2xdw - if (igcx == 8 .and. exx_started ) then - sx = 0.75_DP * sx - v1xup = 0.75_DP * v1xup - v1xdw = 0.75_DP * v1xdw - v2xup = 0.75_DP * v2xup - v2xdw = 0.75_DP * v2xdw - end if - elseif (igcx == 9) then - if (rhoup > small .and. sqrt (abs (grhoup2) ) > small) then - call becke88_spin (rhoup, grhoup2, sxup, v1xup, v2xup) - else - sxup = 0.0_DP - v1xup = 0.0_DP - v2xup = 0.0_DP - endif - if (rhodw > small .and. sqrt (abs (grhodw2) ) > small) then - call becke88_spin (rhodw, grhodw2, sxdw, v1xdw, v2xdw) - else - sxdw = 0.0_DP - v1xdw = 0.0_DP - v2xdw = 0.0_DP - endif - sx = sxup + sxdw - - if (exx_started ) then - sx = 0.72_DP * sx - v1xup = 0.72_DP * v1xup - v1xdw = 0.72_DP * v1xdw - v2xup = 0.72_DP * v2xup - v2xdw = 0.72_DP * v2xdw - end if - - elseif (igcx == 11) then ! 'Wu-Cohen' - if (rhoup > small .and. sqrt (abs (grhoup2) ) > small) then - call wcx (2.0_DP * rhoup, 4.0_DP * grhoup2, sxup, v1xup, v2xup) - else - sxup = 0.0_DP - v1xup = 0.0_DP - v2xup = 0.0_DP - endif - if (rhodw > small .and. sqrt (abs (grhodw2) ) > small) then - call wcx (2.0_DP * rhodw, 4.0_DP * grhodw2, sxdw, v1xdw, v2xdw) - else - sxdw = 0.0_DP - v1xdw = 0.0_DP - v2xdw = 0.0_DP - endif - sx = 0.5_DP * (sxup + sxdw) - v2xup = 2.0_DP * v2xup - v2xdw = 2.0_DP * v2xdw - - else - call errore ('gcx_spin', 'not implemented', igcx) - endif - ! - return -end subroutine gcx_spin -! -!----------------------------------------------------------------------- -subroutine gcc_spin (rho, zeta, grho, sc, v1cup, v1cdw, v2c) - !----------------------------------------------------------------------- - ! gradient corrections for correlations - Hartree a.u. - ! Implemented: Perdew86, GGA (PW91), PBE - ! - implicit none - ! - ! dummy arguments - ! - real(DP) :: rho, zeta, grho, sc, v1cup, v1cdw, v2c - ! the total charge - ! the magnetization - ! the gradient of the charge squared - ! exchange and correlation energies - ! derivatives of correlation wr. rho - ! derivatives of correlation wr. grho - - real(DP), parameter :: small = 1.E-10_DP, epsr=1.E-6_DP - ! - ! - if ( abs(zeta) > 1.0_DP ) then - sc = 0.0_DP - v1cup = 0.0_DP - v1cdw = 0.0_DP - v2c = 0.0_DP - return - else - ! - ! ... ( - 1.0 + epsr ) < zeta < ( 1.0 - epsr ) - zeta = SIGN( MIN( ABS( zeta ), ( 1.0_DP - epsr ) ) , zeta ) - endif - - if (igcc == 0 .or. rho <= small .or. sqrt(abs(grho)) <= small) then - sc = 0.0_DP - v1cup = 0.0_DP - v1cdw = 0.0_DP - v2c = 0.0_DP - elseif (igcc == 1) then - call perdew86_spin (rho, zeta, grho, sc, v1cup, v1cdw, v2c) - elseif (igcc == 2) then - call ggac_spin (rho, zeta, grho, sc, v1cup, v1cdw, v2c) - elseif (igcc == 4) then - call pbec_spin (rho, zeta, grho, 1, sc, v1cup, v1cdw, v2c) - elseif (igcc == 8) then - call pbec_spin (rho, zeta, grho, 2, sc, v1cup, v1cdw, v2c) - else - call errore ('lsda_functionals', 'not implemented', igcc) - endif - ! - return -end subroutine gcc_spin -! -! ================================================================== - SUBROUTINE gcc_spin_more( RHOA, RHOB, GRHOAA, GRHOBB, GRHOAB, & - SC, V1CA, V1CB, V2CA, V2CB, V2CAB ) -! ==--------------------------------------------------------------== -! == GRADIENT CORRECTIONS FOR EXCHANGE AND CORRELATION == -! == == -! == EXCHANGE : BECKE88 == -! == GGAX == -! == CORRELATION : PERDEW86 == -! == LEE, YANG & PARR == -! == GGAC == -! ==--------------------------------------------------------------== - - IMPLICIT NONE - REAL(DP) :: RHOA,RHOB,GRHOAA,GRHOBB,GRHOAB - REAL(DP) :: SC,V1CA,V2CA,V1CB,V2CB,V2CAB - - ! ... Gradient Correction for correlation - - REAL(DP) :: SMALL, RHO - PARAMETER(SMALL=1.E-20_DP) - - SC=0.0_DP - V1CA=0.0_DP - V2CA=0.0_DP - V1CB=0.0_DP - V2CB=0.0_DP - V2CAB=0.0_DP - IF( igcc == 3 ) THEN - RHO=RHOA+RHOB - IF(RHO.GT.SMALL) CALL LSD_GLYP(RHOA,RHOB,GRHOAA,GRHOAB,GRHOBB,SC,& - V1CA,V2CA,V1CB,V2CB,V2CAB) - ELSE - CALL errore( " gcc_spin_more ", " gradiet correction not implemented ", 1 ) - ENDIF -! ==--------------------------------------------------------------== - RETURN - END SUBROUTINE gcc_spin_more -! -!----------------------------------------------------------------------- -!------- DRIVERS FOR DERIVATIVES OF XC POTENTIAL ----------------------- -!----------------------------------------------------------------------- -! - !----------------------------------------------------------------------- - function dmxc (rho) - !----------------------------------------------------------------------- - ! - ! derivative of the xc potential with respect to the local density - ! - ! - implicit none - ! - real(DP), intent(in) :: rho - ! input: the charge density ( positive ) - real(DP) :: dmxc - ! output: the derivative of the xc potential - ! - ! local variables - ! - real(DP) :: dr, vxp, vcp, vxm, vcm, vx, ex, ec, rs - real(DP), external :: dpz - integer :: iflg - ! - real(DP), parameter :: small = 1.E-30_DP, e2 = 2.0_DP, & - pi34 = 0.75_DP / 3.141592653589793_DP, third = 1.0_DP /3.0_DP - ! - dmxc = 0.0_DP - if (rho < small) then - return - endif - ! - ! first case: analytical derivatives available - ! - if (get_iexch() == 1 .and. get_icorr() == 1) then - rs = (pi34 / rho) **third - !..exchange - call slater (rs, ex, vx) - dmxc = vx / (3.0_DP * rho) - !..correlation - iflg = 2 - if (rs < 1.0_DP) iflg = 1 - dmxc = dmxc + dpz (rs, iflg) - else - ! - ! second case: numerical derivatives - ! - dr = min (1.E-6_DP, 1.E-4_DP * rho) - call xc (rho + dr, ex, ec, vxp, vcp) - call xc (rho - dr, ex, ec, vxm, vcm) - dmxc = (vxp + vcp - vxm - vcm) / (2.0_DP * dr) - endif - ! - ! bring to rydberg units - ! - dmxc = e2 * dmxc - return - ! - end function dmxc - ! - !----------------------------------------------------------------------- - subroutine dmxc_spin (rhoup, rhodw, dmuxc_uu, dmuxc_ud, dmuxc_du, & - dmuxc_dd) - !----------------------------------------------------------------------- - ! derivative of the xc potential with respect to the local density - ! spin-polarized case - ! - implicit none - ! - real(DP), intent(in) :: rhoup, rhodw - ! input: spin-up and spin-down charge density - real(DP), intent(out) :: dmuxc_uu, dmuxc_ud, dmuxc_du, dmuxc_dd - ! output: up-up, up-down, down-up, down-down derivatives of the - ! XC functional - ! - ! local variables - ! - real(DP) :: rhotot, rs, zeta, fz, fz1, fz2, ex, vx, ecu, ecp, vcu, & - vcp, dmcu, dmcp, aa, bb, cc, dr, dz, ec, vxupm, vxdwm, vcupm, & - vcdwm, rho, vxupp, vxdwp, vcupp, vcdwp - real(DP), external :: dpz, dpz_polarized - integer :: iflg - ! - real(DP), parameter :: small = 1.E-30_DP, e2 = 2.0_DP, & - pi34 = 0.75_DP / 3.141592653589793_DP, third = 1.0_DP/3.0_DP, & - p43 = 4.0_DP / 3.0_DP, p49 = 4.0_DP / 9.0_DP, m23 = -2.0_DP / 3.0_DP, & - small_ud = 1.E-10_DP - ! - dmuxc_uu = 0.0_DP - dmuxc_du = 0.0_DP - dmuxc_ud = 0.0_DP - dmuxc_dd = 0.0_DP - ! - rhotot = rhoup + rhodw - if (rhotot <= small) return - zeta = (rhoup - rhodw) / rhotot - - if (abs (zeta) > 1.0_DP) return - if (get_iexch() == 1 .and. get_icorr() == 1) then - ! - ! first case: analytical derivative available - ! - !..exchange - if(rhoup>small_ud) then - rs = (pi34 / (2.0_DP * rhoup) ) **third - call slater (rs, ex, vx) - dmuxc_uu = vx / (3.0_DP * rhoup) - endif - if(rhodw>small_ud) then - rs = (pi34 / (2.0_DP * rhodw) ) **third - call slater (rs, ex, vx) - dmuxc_dd = vx / (3.0_DP * rhodw) - endif - !..correlation - rs = (pi34 / rhotot) **third - iflg = 2 - if (rs < 1.0_DP) iflg = 1 - dmcu = dpz (rs, iflg) - dmcp = dpz_polarized (rs, iflg) - call pz (rs, 1, ecu, vcu) - call pz_polarized (rs, ecp, vcp) - fz = ( (1.0_DP + zeta) **p43 + (1.0_DP - zeta) **p43 - 2.0_DP) & - / (2.0_DP**p43 - 2.0_DP) - fz1 = p43 * ( (1.0_DP + zeta) **third- (1.0_DP - zeta) **third) & - / (2.0_DP**p43 - 2.0_DP) - fz2 = p49 * ( (1.0_DP + zeta) **m23 + (1.0_DP - zeta) **m23) & - / (2.0_DP**p43 - 2.0_DP) - aa = dmcu + fz * (dmcp - dmcu) - bb = 2.0_DP * fz1 * (vcp - vcu - (ecp - ecu) ) / rhotot - cc = fz2 * (ecp - ecu) / rhotot - dmuxc_uu = dmuxc_uu + aa + (1.0_DP - zeta) * bb + (1.0_DP - zeta)**2 * cc - dmuxc_du = dmuxc_du + aa + ( - zeta) * bb + (zeta**2 - 1.0_DP) * cc - dmuxc_ud = dmuxc_du - dmuxc_dd = dmuxc_dd+aa - (1.0_DP + zeta) * bb + (1.0_DP + zeta)**2 * cc - else - rho = rhoup + rhodw - dr = min (1.E-6_DP, 1.E-4_DP * rho) - call xc_spin (rho - dr, zeta, ex, ec, vxupm, vxdwm, vcupm, vcdwm) - call xc_spin (rho + dr, zeta, ex, ec, vxupp, vxdwp, vcupp, vcdwp) - dmuxc_uu = (vxupp + vcupp - vxupm - vcupm) / (2.0_DP * dr) - dmuxc_ud = dmuxc_uu - dmuxc_dd = (vxdwp + vcdwp - vxdwm - vcdwm) / (2.0_DP * dr) - dmuxc_du = dmuxc_dd - ! dz = min (1.d-6, 1.d-4 * abs (zeta) ) - dz = 1.E-6_DP - call xc_spin (rho, zeta - dz, ex, ec, vxupm, vxdwm, vcupm, vcdwm) - call xc_spin (rho, zeta + dz, ex, ec, vxupp, vxdwp, vcupp, vcdwp) - dmuxc_uu = dmuxc_uu + (vxupp + vcupp - vxupm - vcupm) * & - (1.0_DP - zeta) / rho / (2.0_DP * dz) - dmuxc_ud = dmuxc_ud- (vxupp + vcupp - vxupm - vcupm) * & - (1.0_DP + zeta) / rho / (2.0_DP * dz) - dmuxc_du = dmuxc_du + (vxdwp + vcdwp - vxdwm - vcdwm) * & - (1.0_DP - zeta) / rho / (2.0_DP * dz) - dmuxc_dd = dmuxc_dd- (vxdwp + vcdwp - vxdwm - vcdwm) * & - (1.0_DP + zeta) / rho / (2.0_DP * dz) - endif - ! - ! bring to rydberg units - ! - dmuxc_uu = e2 * dmuxc_uu - dmuxc_du = e2 * dmuxc_du - dmuxc_ud = e2 * dmuxc_ud - dmuxc_dd = e2 * dmuxc_dd - ! - return - - end subroutine dmxc_spin - - !----------------------------------------------------------------------- - subroutine dmxc_nc (rho, mx, my, mz, dmuxc) - !----------------------------------------------------------------------- - ! derivative of the xc potential with respect to the local density - ! and magnetization - ! non colinear case - ! - implicit none - ! - real(DP), intent(in) :: rho, mx, my, mz - ! input: charge density and magnetization - real(DP), intent(out) :: dmuxc(4,4) - ! output: derivative of XC functional - ! - ! local variables - ! - REAL(DP) :: zeta, ex, ec, dr, dz, vxupm, vxdwm, vcupm, & - vcdwm, vxupp, vxdwp, vcupp, vcdwp, vxup, vxdw, vcup, vcdw - REAL(DP) :: amag, vs, dvxc_rho, dvxc_mx, dvxc_my, dvxc_mz, & - dbx_rho, dbx_mx, dbx_my, dbx_mz, dby_rho, dby_mx, & - dby_my, dby_mz, dbz_rho, dbz_mx, dbz_my, dbz_mz - REAL(DP), PARAMETER :: small = 1.E-30_DP, e2 = 2.0_DP - ! - ! - dmuxc = 0.0_DP - ! - IF (rho <= small) RETURN - amag = sqrt(mx**2+my**2+mz**2) - zeta = amag / rho - - IF (abs (zeta) > 1.0_DP) RETURN - CALL xc_spin (rho, zeta, ex, ec, vxup, vxdw, vcup, vcdw) - vs=0.5_DP*(vxup+vcup-vxdw-vcdw) - - dr = min (1.E-6_DP, 1.E-4_DP * rho) - CALL xc_spin (rho - dr, zeta, ex, ec, vxupm, vxdwm, vcupm, vcdwm) - CALL xc_spin (rho + dr, zeta, ex, ec, vxupp, vxdwp, vcupp, vcdwp) - dvxc_rho = ((vxupp + vcupp - vxupm - vcupm)+ & - (vxdwp + vcdwp - vxdwm - vcdwm)) / (4.0_DP * dr) - IF (amag > 1.E-10_DP) THEN - dbx_rho = ((vxupp + vcupp - vxupm - vcupm)- & - (vxdwp + vcdwp - vxdwm - vcdwm))* mx / (4.0_DP*dr*amag) - dby_rho = ((vxupp + vcupp - vxupm - vcupm)- & - (vxdwp + vcdwp - vxdwm - vcdwm))* my / (4.0_DP*dr*amag) - dbz_rho = ((vxupp + vcupp - vxupm - vcupm)- & - (vxdwp + vcdwp - vxdwm - vcdwm))* mz / (4.0_DP*dr*amag) -! dz = min (1.d-6, 1.d-4 * abs (zeta) ) - dz = 1.0E-6_DP - CALL xc_spin (rho, zeta - dz, ex, ec, vxupm, vxdwm, vcupm, vcdwm) - CALL xc_spin (rho, zeta + dz, ex, ec, vxupp, vxdwp, vcupp, vcdwp) - -! The variables are rho and m, so zeta depends on rho -! - dvxc_rho=dvxc_rho- ((vxupp + vcupp - vxupm - vcupm)+ & - (vxdwp + vcdwp - vxdwm - vcdwm))*zeta/rho/(4.0_DP * dz) - dbx_rho = dbx_rho-((vxupp + vcupp - vxupm - vcupm)- & - (vxdwp + vcdwp - vxdwm - vcdwm))*mx*zeta/rho/(4.0_DP*dz*amag) - dby_rho = dby_rho-((vxupp + vcupp - vxupm - vcupm)- & - (vxdwp + vcdwp - vxdwm - vcdwm))*my*zeta/rho/(4.0_DP*dz*amag) - dbz_rho = dbz_rho-((vxupp + vcupp - vxupm - vcupm)- & - (vxdwp + vcdwp - vxdwm - vcdwm))*mz*zeta/rho/(4.0_DP*dz*amag) -! -! here the derivatives with respect to m -! - dvxc_mx = ((vxupp + vcupp - vxupm - vcupm) + & - (vxdwp + vcdwp - vxdwm - vcdwm))*mx/rho/(4.0_DP*dz*amag) - dvxc_my = ((vxupp + vcupp - vxupm - vcupm) + & - (vxdwp + vcdwp - vxdwm - vcdwm))*my/rho/(4.0_DP*dz*amag) - dvxc_mz = ((vxupp + vcupp - vxupm - vcupm) + & - (vxdwp + vcdwp - vxdwm - vcdwm))*mz/rho/(4.0_DP*dz*amag) - dbx_mx = (((vxupp + vcupp - vxupm - vcupm) - & - (vxdwp + vcdwp - vxdwm - vcdwm))*mx**2*amag/rho/ & - (4.0_DP*dz) + vs*(my**2+mz**2))/amag**3 - dbx_my = (((vxupp + vcupp - vxupm - vcupm) - & - (vxdwp + vcdwp - vxdwm - vcdwm))*mx*my*amag/rho/ & - (4.0_DP*dz) - vs*(mx*my))/amag**3 - dbx_mz = (((vxupp + vcupp - vxupm - vcupm) - & - (vxdwp + vcdwp - vxdwm - vcdwm))*mx*mz*amag/rho/ & - (4.0_DP*dz) - vs*(mx*mz))/amag**3 - dby_mx = dbx_my - dby_my = (((vxupp + vcupp - vxupm - vcupm) - & - (vxdwp + vcdwp - vxdwm - vcdwm))*my**2*amag/rho/ & - (4.0_DP*dz) + vs*(mx**2+mz**2))/amag**3 - dby_mz = (((vxupp + vcupp - vxupm - vcupm) - & - (vxdwp + vcdwp - vxdwm - vcdwm))*my*mz*amag/rho/ & - (4.0_DP*dz) - vs*(my*mz))/amag**3 - dbz_mx = dbx_mz - dbz_my = dby_mz - dbz_mz = (((vxupp + vcupp - vxupm - vcupm) - & - (vxdwp + vcdwp - vxdwm - vcdwm))*mz**2*amag/rho/ & - (4.0_DP*dz) + vs*(mx**2+my**2))/amag**3 - dmuxc(1,1)=dvxc_rho - dmuxc(1,2)=dvxc_mx - dmuxc(1,3)=dvxc_my - dmuxc(1,4)=dvxc_mz - dmuxc(2,1)=dbx_rho - dmuxc(2,2)=dbx_mx - dmuxc(2,3)=dbx_my - dmuxc(2,4)=dbx_mz - dmuxc(3,1)=dby_rho - dmuxc(3,2)=dby_mx - dmuxc(3,3)=dby_my - dmuxc(3,4)=dby_mz - dmuxc(4,1)=dbz_rho - dmuxc(4,2)=dbz_mx - dmuxc(4,3)=dbz_my - dmuxc(4,4)=dbz_mz - ELSE - dmuxc(1,1)=dvxc_rho - ENDIF - ! - ! bring to rydberg units - ! - dmuxc = e2 * dmuxc - ! - RETURN - - end subroutine dmxc_nc - ! - !----------------------------------------------------------------------- - subroutine dgcxc (r, s2, vrrx, vsrx, vssx, vrrc, vsrc, vssc) - !----------------------------------------------------------------------- - USE kinds, only : DP - implicit none - real(DP) :: r, s2, vrrx, vsrx, vssx, vrrc, vsrc, vssc - real(DP) :: dr, s, ds - - real(DP) :: sx, sc, v1xp, v2xp, v1cp, v2cp, v1xm, v2xm, v1cm, & - v2cm - s = sqrt (s2) - dr = min (1.d-4, 1.d-2 * r) - - ds = min (1.d-4, 1.d-2 * s) - call gcxc (r + dr, s2, sx, sc, v1xp, v2xp, v1cp, v2cp) - - call gcxc (r - dr, s2, sx, sc, v1xm, v2xm, v1cm, v2cm) - vrrx = 0.5d0 * (v1xp - v1xm) / dr - - vrrc = 0.5d0 * (v1cp - v1cm) / dr - vsrx = 0.25d0 * (v2xp - v2xm) / dr - - vsrc = 0.25d0 * (v2cp - v2cm) / dr - call gcxc (r, (s + ds) **2, sx, sc, v1xp, v2xp, v1cp, v2cp) - - call gcxc (r, (s - ds) **2, sx, sc, v1xm, v2xm, v1cm, v2cm) - vsrx = vsrx + 0.25d0 * (v1xp - v1xm) / ds / s - - vsrc = vsrc + 0.25d0 * (v1cp - v1cm) / ds / s - vssx = 0.5d0 * (v2xp - v2xm) / ds / s - - vssc = 0.5d0 * (v2cp - v2cm) / ds / s - return - end subroutine dgcxc - ! - !----------------------------------------------------------------------- - subroutine dgcxc_spin (rup, rdw, gup, gdw, vrrxup, vrrxdw, vrsxup, & - vrsxdw, vssxup, vssxdw, vrrcup, vrrcdw, vrscup, vrscdw, vssc, & - vrzcup, vrzcdw) - !----------------------------------------------------------------------- - ! - ! This routine computes the derivative of the exchange and correlatio - ! potentials with respect to the density, the gradient and zeta - ! - USE kinds, only : DP - implicit none - real(DP), intent(in) :: rup, rdw, gup (3), gdw (3) - ! input: the charges and the gradient - real(DP), intent(out):: vrrxup, vrrxdw, vrsxup, vrsxdw, vssxup, & - vssxdw, vrrcup, vrrcdw, vrscup, vrscdw, vssc, vrzcup, vrzcdw - ! output: derivatives of the exchange and of the correlation - ! - ! local variables - ! - real(DP) :: r, zeta, sup2, sdw2, s2, s, sup, sdw, dr, dzeta, ds, & - drup, drdw, dsup, dsdw, sx, sc, v1xupp, v1xdwp, v2xupp, v2xdwp, & - v1xupm, v1xdwm, v2xupm, v2xdwm, v1cupp, v1cdwp, v2cp, v1cupm, & - v1cdwm, v2cm - ! charge densities and square gradients - ! delta charge densities and gra - ! delta gradients - ! energies - ! exchange potentials - ! exchange potentials - ! coorelation potentials - ! coorelation potentials - real(DP), parameter :: eps = 1.d-6 - ! - r = rup + rdw - if (r.gt.eps) then - zeta = (rup - rdw) / r - else - zeta = 2.d0 - endif - sup2 = gup (1) **2 + gup (2) **2 + gup (3) **2 - sdw2 = gdw (1) **2 + gdw (2) **2 + gdw (3) **2 - - s2 = (gup (1) + gdw (1) ) **2 + (gup (2) + gdw (2) ) **2 + & - (gup (3) + gdw (3) ) **2 - sup = sqrt (sup2) - sdw = sqrt (sdw2) - s = sqrt (s2) - ! - ! up part of exchange - ! - - if (rup.gt.eps.and.sup.gt.eps) then - drup = min (1.d-4, 1.d-2 * rup) - dsup = min (1.d-4, 1.d-2 * sdw) - ! - ! derivatives of exchange: up part - ! - call gcx_spin (rup + drup, rdw, sup2, sdw2, sx, v1xupp, v1xdwp, & - v2xupp, v2xdwp) - - call gcx_spin (rup - drup, rdw, sup2, sdw2, sx, v1xupm, v1xdwm, & - v2xupm, v2xdwm) - vrrxup = 0.5d0 * (v1xupp - v1xupm) / drup - vrsxup = 0.25d0 * (v2xupp - v2xupm) / drup - - call gcx_spin (rup, rdw, (sup + dsup) **2, sdw2, sx, v1xupp, & - v1xdwp, v2xupp, v2xdwp) - - call gcx_spin (rup, rdw, (sup - dsup) **2, sdw2, sx, v1xupm, & - v1xdwm, v2xupm, v2xdwm) - vrsxup = vrsxup + 0.25d0 * (v1xupp - v1xupm) / dsup / sup - vssxup = 0.5d0 * (v2xupp - v2xupm) / dsup / sup - else - vrrxup = 0.d0 - vrsxup = 0.d0 - vssxup = 0.d0 - endif - - if (rdw.gt.eps.and.sdw.gt.eps) then - drdw = min (1.d-4, 1.d-2 * rdw) - dsdw = min (1.d-4, 1.d-2 * sdw) - ! - ! derivatives of exchange: down part - ! - call gcx_spin (rup, rdw + drdw, sup2, sdw2, sx, v1xupp, v1xdwp, & - v2xupp, v2xdwp) - - call gcx_spin (rup, rdw - drdw, sup2, sdw2, sx, v1xupm, v1xdwm, & - v2xupm, v2xdwm) - vrrxdw = 0.5d0 * (v1xdwp - v1xdwm) / drdw - - vrsxdw = 0.25d0 * (v2xdwp - v2xdwm) / drdw - call gcx_spin (rup, rdw, sup2, (sdw + dsdw) **2, sx, v1xupp, & - v1xdwp, v2xupp, v2xdwp) - - call gcx_spin (rup, rdw, sup2, (sdw - dsdw) **2, sx, v1xupm, & - v1xdwm, v2xupm, v2xdwm) - vrsxdw = vrsxdw + 0.25d0 * (v1xdwp - v1xdwm) / dsdw / sdw - vssxdw = 0.5d0 * (v2xdwp - v2xdwm) / dsdw / sdw - else - vrrxdw = 0.d0 - vrsxdw = 0.d0 - vssxdw = 0.d0 - endif - ! - ! derivatives of correlation - ! - - if (r.gt.eps.and.abs (zeta) .le.1.d0.and.s.gt.eps) then - - dr = min (1.d-4, 1.d-2 * r) - call gcc_spin (r + dr, zeta, s2, sc, v1cupp, v1cdwp, v2cp) - - call gcc_spin (r - dr, zeta, s2, sc, v1cupm, v1cdwm, v2cm) - vrrcup = 0.5d0 * (v1cupp - v1cupm) / dr - - vrrcdw = 0.5d0 * (v1cdwp - v1cdwm) / dr - - ds = min (1.d-4, 1.d-2 * s) - call gcc_spin (r, zeta, (s + ds) **2, sc, v1cupp, v1cdwp, v2cp) - - call gcc_spin (r, zeta, (s - ds) **2, sc, v1cupm, v1cdwm, v2cm) - vrscup = 0.5d0 * (v1cupp - v1cupm) / ds / s - vrscdw = 0.5d0 * (v1cdwp - v1cdwm) / ds / s - - vssc = 0.5d0 * (v2cp - v2cm) / ds / s - dzeta = min (1.d-4, 1.d-2 * abs (zeta) ) - - if (dzeta.lt.1.d-7) dzeta = 1.d-7 - call gcc_spin (r, zeta + dzeta, s2, sc, v1cupp, v1cdwp, v2cp) - - call gcc_spin (r, zeta - dzeta, s2, sc, v1cupm, v1cdwm, v2cm) - vrzcup = 0.5d0 * (v1cupp - v1cupm) / dzeta - vrzcdw = 0.5d0 * (v1cdwp - v1cdwm) / dzeta - else - vrrcup = 0.d0 - vrrcdw = 0.d0 - vrscup = 0.d0 - vrscdw = 0.d0 - vssc = 0.d0 - vrzcup = 0.d0 - vrzcdw = 0.d0 - - endif - return - end subroutine dgcxc_spin - - end module funct diff --git a/quantum_espresso/kcp/Modules/griddim.f90 b/quantum_espresso/kcp/Modules/griddim.f90 deleted file mode 100644 index 3746aa6e3..000000000 --- a/quantum_espresso/kcp/Modules/griddim.f90 +++ /dev/null @@ -1,456 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -!=----------------------------------------------------------------------------=! - MODULE grid_dimensions -!=----------------------------------------------------------------------------=! - - ! This module contains the dimensions of the 3D real and reciprocal space - ! grid relative to the charde density and potential - - IMPLICIT NONE - SAVE - - INTEGER :: nr1 = 0 ! global first dimension of the 3D grid - INTEGER :: nr2 = 0 ! global second " " - INTEGER :: nr3 = 0 ! global third " " - INTEGER :: nr1x = 0 ! global leading dimension - INTEGER :: nr2x = 0 - INTEGER :: nr3x = 0 - INTEGER :: nr1l = 0 ! local first dimension - INTEGER :: nr2l = 0 ! - INTEGER :: nr3l = 0 ! - INTEGER :: nnrx = 0 ! size of the (local) array allocated for the FFT - ! in general could be different than the size of - ! the FFT grid - - ! ATTENTION: - ! "nnrx" is not to be confused with "nr1 * nr2 * nr3" - -!=----------------------------------------------------------------------------=! - END MODULE grid_dimensions -!=----------------------------------------------------------------------------=! - -!=----------------------------------------------------------------------------=! - MODULE smooth_grid_dimensions -!=----------------------------------------------------------------------------=! - - ! This module contains the dimensions of the 3D real and reciprocal space - ! grid relative to the smooth charge density ( see Vanderbilt Pseudopot ) - - IMPLICIT NONE - SAVE - - ! parameter description: same as above but for smooth grid - - INTEGER :: nr1s = 0 - INTEGER :: nr2s = 0 - INTEGER :: nr3s = 0 - INTEGER :: nr1sx = 0 - INTEGER :: nr2sx = 0 - INTEGER :: nr3sx = 0 - INTEGER :: nr1sl = 0 - INTEGER :: nr2sl = 0 - INTEGER :: nr3sl = 0 - INTEGER :: nnrsx = 0 - -!=----------------------------------------------------------------------------=! - END MODULE smooth_grid_dimensions -!=----------------------------------------------------------------------------=! - -!=----------------------------------------------------------------------------=! - MODULE smallbox_grid_dimensions -!=----------------------------------------------------------------------------=! - - ! This module contains the dimensions of the 3D real and reciprocal space - ! sub grid relative to the atomic augmentation charge density - ! ( see Vanderbilt Pseudopot ) - - IMPLICIT NONE - SAVE - - ! parameter description: same as above but for small box grid - - INTEGER :: nr1b = 0 - INTEGER :: nr2b = 0 - INTEGER :: nr3b = 0 - INTEGER :: nr1bx = 0 - INTEGER :: nr2bx = 0 - INTEGER :: nr3bx = 0 - INTEGER :: nr1bl = 0 - INTEGER :: nr2bl = 0 - INTEGER :: nr3bl = 0 - INTEGER :: nnrbx = 0 - -!=----------------------------------------------------------------------------=! - END MODULE smallbox_grid_dimensions -!=----------------------------------------------------------------------------=! - - - - -!=----------------------------------------------------------------------------=! - MODULE grid_subroutines -!=----------------------------------------------------------------------------=! - - ! This module contains subroutines that are related to grids - ! parameters - - USE kinds, ONLY: DP - - IMPLICIT NONE - SAVE - - CONTAINS - - - SUBROUTINE realspace_grids_init( alat, a1, a2, a3, gcutd, gcuts, ng, ngs ) - ! - USE grid_dimensions, ONLY: nr1, nr2, nr3, nr1x, nr2x, nr3x - USE smooth_grid_dimensions, ONLY: nr1s, nr2s, nr3s, nr1sx, nr2sx, nr3sx - USE smallbox_grid_dimensions, ONLY: nr1b, nr2b, nr3b, nr1bx, nr2bx, nr3bx, & - nnrbx, nr1bl, nr2bl, nr3bl - USE fft_scalar, only: good_fft_dimension, good_fft_order - USE io_global, only: stdout - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: alat - REAL(DP), INTENT(IN) :: a1(3), a2(3), a3(3) - REAL(DP), INTENT(IN) :: gcutd, gcuts - INTEGER, INTENT(OUT) :: ng, ngs - ! - REAL(DP) :: qk(3) = 0.0_DP - - IF( nr1 == 0 .OR. nr2 == 0 .OR. nr3 == 0 ) THEN - ! ... This subroutines calculates the size of the real and reciprocal dense grids - CALL ngnr_set( alat, a1, a2, a3, gcutd, qk, ng, nr1, nr2, nr3 ) - ELSE - WRITE( stdout, '( /, 3X,"Info: using nr1, nr2, nr3 values from input" )' ) - END IF - - nr1 = good_fft_order( nr1 ) - nr2 = good_fft_order( nr2 ) - nr3 = good_fft_order( nr3 ) - - nr1x = good_fft_dimension( nr1 ) - nr2x = nr2 - nr3x = good_fft_dimension( nr3 ) - - IF( nr1s == 0 .OR. nr2s == 0 .OR. nr3s == 0 ) THEN - ! ... This subroutines calculates the size of the real and reciprocal smoth grids - CALL ngnr_set( alat, a1, a2, a3, gcuts, qk, ngs, nr1s, nr2s, nr3s ) - ELSE - WRITE( stdout, '( /, 3X,"Info: using nr1s, nr2s, nr3s values from input" )' ) - END IF - - nr1s = good_fft_order( nr1s ) - nr2s = good_fft_order( nr2s ) - nr3s = good_fft_order( nr3s ) - - nr1sx = good_fft_dimension(nr1s) - nr2sx = nr2s - nr3sx = good_fft_dimension(nr3s) - - IF ( nr1s > nr1 .or. nr2s > nr2 .or. nr3s > nr3 ) THEN - CALL errore(' realspace_grids_init ', ' smooth grid larger than dense grid?',1) - END IF - - ! no default values for grid box: if nr*b=0, ignore - - IF( nr1b > 0 .AND. nr2b > 0 .AND. nr3b > 0 ) THEN - - nr1b = good_fft_order( nr1b ) ! small box is not parallelized - nr2b = good_fft_order( nr2b ) - nr3b = good_fft_order( nr3b ) - nr1bx = good_fft_dimension( nr1b ) - - ELSE - - nr1bx = nr1b - - END IF - - nr2bx = nr2b - nr3bx = nr3b - nnrbx = nr1bx * nr2bx * nr3bx - - nr1bl = nr1b - nr2bl = nr2b - nr3bl = nr3b - - IF ( nr1b > nr1 .or. nr2b > nr2 .or. nr3b > nr3 ) THEN - CALL errore(' realspace_grids_init ', ' box grid larger than dense grid?',1) - END IF - - RETURN - - END SUBROUTINE realspace_grids_init - -!=----------------------------------------------------------------------------=! - - SUBROUTINE realspace_grids_para( dfftp, dffts ) - - ! This subroutines sets local dimensions for real space grids - - USE io_global, ONLY: ionode, stdout - USE mp, ONLY: mp_sum - USE mp_global, ONLY: nproc_image - USE fft_types, ONLY: fft_dlay_descriptor - USE grid_dimensions, ONLY: nr1, nr2, nr3, nr1x, nr2x, nr3x - USE grid_dimensions, ONLY: nr1l, nr2l, nr3l, nnrx - USE smooth_grid_dimensions, ONLY: nr1s, nr2s, nr3s, nr1sx, nr2sx, nr3sx - USE smooth_grid_dimensions, ONLY: nr1sl, nr2sl, nr3sl, nnrsx - USE smallbox_grid_dimensions, ONLY: nr1b, nr2b, nr3b, nr1bx, nr2bx, nr3bx, nnrbx - USE smallbox_grid_dimensions, ONLY: nr1bl, nr2bl, nr3bl - - IMPLICIT NONE - - TYPE(fft_dlay_descriptor), INTENT(IN) :: dfftp, dffts - - INTEGER :: i - - ! ... Subroutine body - - ! set the actual (local) FFT dimensions - - nr1l = dfftp % nr1 - nr2l = dfftp % nr2 - nr3l = dfftp % npl - - nr1sl = dffts % nr1 - nr2sl = dffts % nr2 - nr3sl = dffts % npl - - ! set the dimensions of the array allocated for the FFT - ! this could in principle be different than the FFT dimensions - - nnrx = dfftp % nnr - nnrsx = dffts % nnr - - IF ( nr1s > nr1 .or. nr2s > nr2 .or. nr3s > nr3) & - & CALL errore(' pmeshset ', ' smooth grid larger than dense grid? ', 1 ) - - IF ( nr1b > nr1 .or. nr2b > nr2 .or. nr3b > nr3) & - & CALL errore(' pmeshset ', ' small box grid larger than dense grid? ', 1 ) - - IF(ionode) THEN - - WRITE( stdout,*) - WRITE( stdout,*) ' Real Mesh' - WRITE( stdout,*) ' ---------' - WRITE( stdout,1000) nr1, nr2, nr3, nr1l, nr2l, nr3l, 1, 1, nproc_image - WRITE( stdout,1010) nr1x, nr2x, nr3x - WRITE( stdout,1020) nnrx - WRITE( stdout,*) ' Number of x-y planes for each processors: ' - WRITE( stdout, fmt = '( 3X, "nr3l = ", 10I5 )' ) ( dfftp%npp( i ), i = 1, nproc_image ) - - WRITE( stdout,*) - WRITE( stdout,*) ' Smooth Real Mesh' - WRITE( stdout,*) ' ----------------' - WRITE( stdout,1000) nr1s, nr2s, nr3s, nr1sl, nr2sl, nr3sl, 1, 1, nproc_image - WRITE( stdout,1010) nr1sx, nr2sx, nr3sx - WRITE( stdout,1020) nnrsx - WRITE( stdout,*) ' Number of x-y planes for each processors: ' - WRITE( stdout, fmt = '( 3X, "nr3sl = ", 10I5 )' ) ( dffts%npp( i ), i = 1, nproc_image ) - - IF ( nr1b > 0 .AND. nr2b > 0 .AND. nr3b > 0 ) THEN - - WRITE( stdout,*) - WRITE( stdout,*) ' Small Box Real Mesh' - WRITE( stdout,*) ' -------------------' - WRITE( stdout,1000) nr1b, nr2b, nr3b, nr1bl, nr2bl, nr3bl, 1, 1, 1 - WRITE( stdout,1010) nr1bx, nr2bx, nr3bx - WRITE( stdout,1020) nnrbx - - END IF - END IF - -1000 FORMAT(3X, & - 'Global Dimensions Local Dimensions Processor Grid',/,3X, & - '.X. .Y. .Z. .X. .Y. .Z. .X. .Y. .Z.',/, & - 3(1X,I5),2X,3(1X,I5),2X,3(1X,I5) ) -1010 FORMAT(3X, 'Array leading dimensions ( nr1x, nr2x, nr3x ) = ', 3(1X,I5) ) -1020 FORMAT(3X, 'Local number of cell to store the grid ( nnrx ) = ', 1X, I9 ) - - RETURN - END SUBROUTINE realspace_grids_para - - - - SUBROUTINE ngnr_set( alat, a1, a2, a3, gcut, qk, ng, nr1, nr2, nr3 ) - -! this routine calculates the storage required for G vectors arrays -! ---------------------------------------------- -! END manual - -! ... declare modules - USE kinds, ONLY: DP - USE mp, ONLY: mp_max, mp_min, mp_sum - USE mp_global, ONLY: me_image, nproc_image, intra_image_comm - - IMPLICIT NONE - - INTEGER, INTENT(OUT) :: nr1, nr2, nr3, ng - REAL(DP), INTENT(IN) :: alat, a1(3), a2(3), a3(3), gcut, qk(3) - -! ... declare other variables - INTEGER :: i, j, k - INTEGER :: nr1tab, nr2tab, nr3tab, nr - INTEGER :: nb(3) - REAL(DP) :: gsq, sqgc - REAL(DP) :: c(3), g(3) - REAL(DP) :: b1(3), b2(3), b3(3) - LOGICAL :: tqk - -! ... end of declarations -! ---------------------------------------------- - -! ... me_image = processor number, starting from 0 - -! ... evaluate cutoffs in reciprocal space and the required mesh size - sqgc = sqrt(gcut) - nr = int(sqgc) + 2 ! nr = mesh size parameter - -! ... reciprocal lattice generators - call recips(a1, a2, a3, b1, b2, b3) - b1 = b1 * alat - b2 = b2 * alat - b3 = b3 * alat - -! ... verify that, for G -q symmetry in k-point generation - LOGICAL :: nosym_evc = .FALSE. - ! if .true. use symmetry only to symmetrize k points - LOGICAL :: force_symmorphic = .FALSE. - ! if .true. disable fractionary translations (nonsymmorphic groups) - - REAL(DP) :: ecfixed = 0.0_DP, qcutz = 0.0_DP, q2sigma = 0.0_DP - ! parameters for modified kinetic energy functional to be used - ! in variable-cell constant cut-off simulations - - CHARACTER(LEN=80) :: input_dft = 'none' - ! Variable used to overwrite dft definition contained in - ! pseudopotential files; 'none' means DFT is read from pseudos. - ! Only used in PW - allowed values: any legal DFT value - - REAL(DP) :: starting_magnetization( nsx ) = 0.0_DP - ! ONLY PW - - LOGICAL :: lda_plus_u = .FALSE. - ! Use DFT+U method - following are the needed parameters - INTEGER, PARAMETER :: nspinx=2 - REAL(DP) :: starting_ns_eigenvalue(lqmax,nspinx,nsx) = -1.0_DP - REAL(DP) :: hubbard_u(nsx) = 0.0_DP - REAL(DP) :: hubbard_alpha(nsx) = 0.0_DP - CHARACTER(LEN=80) :: U_projection_type = 'atomic' - - LOGICAL :: la2F = .FALSE. - ! For electron-phonon calculations - ! -#if defined (EXX) - LOGICAL :: x_gamma_extrapolation = .true. - ! ONLY PWSCF - INTEGER :: nqx1 = 1, nqx2 = 1, nqx3=1 - ! ONLY PWSCF -! REAL(DP) :: yukawa = 0.0_DP - ! ONLY PWSCF -#endif - - INTEGER :: edir = 0 - REAL(DP) :: emaxpos = 0.0_DP - REAL(DP) :: eopreg = 0.0_DP - REAL(DP) :: eamp = 0.0_DP - ! parameters for external electroc field - - LOGICAL :: noncolin = .FALSE. - LOGICAL :: lspinorb = .FALSE. - REAL(DP) :: lambda = 1.0_DP - REAL(DP) :: fixed_magnetization(3) = 0.0_DP - REAL(DP) :: angle1(nsx) = 0.0_DP - REAL(DP) :: angle2(nsx) = 0.0_DP - INTEGER :: report = 1 - ! Various parameters for noncollinear calculationso - - CHARACTER(LEN=80) :: constrained_magnetization = 'none' - ! Used to perform constrained calculations in magnetic systems - REAL(DP) :: B_field(3) = 0.0_DP - ! A fixed magnetic field defined by the vector B_field is added - ! to the exchange and correlation magnetic field. - - CHARACTER(LEN=80) :: sic = 'none' - ! CP only - SIC correction (D'avezac Mauri) - - REAL(DP) :: sic_epsilon = 0.0_DP - REAL(DP) :: sic_alpha = 0.0_DP - LOGICAL :: force_pairing = .FALSE. - ! Parameters for SIC calculation - - CHARACTER(LEN=80) :: assume_isolated = 'none' - ! - LOGICAL :: spline_ps = .false. - ! use spline interpolation for pseudopotential - LOGICAL :: do_orbdep = .false. -! DCC - ! add electrostatic embedding part (details in the EE namelist) - LOGICAL :: do_ee = .false. - ! add efield parameters - LOGICAL :: do_efield = .false. - REAL ( DP ) :: ampfield(3) = 0.0_DP - ! - LOGICAL :: london = .false. - ! if .true. compute semi-empirical dispersion term ( C6_ij / R_ij**6 ) - ! other DFT-D parameters ( see PW/mm_dispersion.f90 ) - REAL ( DP ) :: london_s6 = 0.75_DP , & ! default global scaling parameter for PBE - london_rcut = 200.00_DP - ! - LOGICAL :: do_wf_cmplx = .false. !added_giovanni - ! - LOGICAL :: do_spinsym = .false. - ! - REAL ( DP ) :: f_cutoff = 0.01_DP - LOGICAL :: fixed_state = .false. - INTEGER :: fixed_band = 1 - LOGICAL :: restart_from_wannier_pwscf= .false. !added by linh, to start KIPZ calculations using - - LOGICAL :: impose_bloch_symm = .false. - LOGICAL :: read_centers = .false. - INTEGER :: mp1 - INTEGER :: mp2 - INTEGER :: mp3 - LOGICAL :: offset_centers_occ = .false. - LOGICAL :: offset_centers_emp = .false. - ! impose Bloch symmetry on the WFs - ! mp1, mp2, mp3 are the dimensions of the Monkhorst-Pack mesh - ! for the Brillouin zone of the primitive cell in order to be - ! commensurate to the designed supercell. Equivalently, are the - ! number of repetitions of the primitive cell along the crystal - ! axis in order to form the supercell - ! offset_centers = .true. slightly shifts all the centers on [1,1,1] - ! direction, useful when some centers are on - ! the edge of the cell. The centers are then - ! kept in their original positions - - NAMELIST / system / ibrav, celldm, a, b, c, cosab, cosac, cosbc, nat, & - ntyp, nbnd, nelec, ecutwfc, ecutrho, nr1, nr2, nr3, nr1s, nr2s, & - nr3s, nr1b, nr2b, nr3b, nosym, nosym_evc, noinv, & - force_symmorphic, starting_magnetization, & - occupations, degauss, nelup, neldw, nspin, ecfixed, & - qcutz, q2sigma, lda_plus_U, Hubbard_U, Hubbard_alpha, & - edir, emaxpos, eopreg, eamp, smearing, starting_ns_eigenvalue, & - U_projection_type, input_dft, la2F, assume_isolated, & -#if defined (EXX) - x_gamma_extrapolation, nqx1, nqx2, nqx3, & -#endif - noncolin, lspinorb, lambda, angle1, angle2, report, & - constrained_magnetization, B_field, fixed_magnetization, & - sic, sic_epsilon, force_pairing, sic_alpha, & - tot_charge, multiplicity, tot_magnetization, & - spline_ps, london, london_s6, london_rcut, do_orbdep, do_ee, & - do_wf_cmplx, do_spinsym, f_cutoff, fixed_state, fixed_band, & - restart_from_wannier_pwscf, impose_bloch_symm, read_centers, & - mp1, mp2, mp3, offset_centers_occ, offset_centers_emp -! -!=----------------------------------------------------------------------------=! -! NKSIC Namelist Input Parameters -!=----------------------------------------------------------------------------=! -! - ! add non-Koopmans self-interaction correction parameters - -!$$ - REAL(DP) :: esic_conv_thr = 1.0E-5_DP - ! convergence criterion for self-interaction correction minimization - ! this criterion is met when "esic(n+1)-esic(n) < esic_conv_thr", - ! where "n" is the step index, "esic" the SIC energy - ! convergence is achieved when all criteria are met -!$$ - LOGICAL :: do_nk = .false. - LOGICAL :: do_pz = .false. - LOGICAL :: do_nki = .false. - LOGICAL :: do_nkpz = .false. - LOGICAL :: do_nkipz = .false. - LOGICAL :: do_wref = .true. - LOGICAL :: do_wxd = .true. - LOGICAL :: do_hf = .false. - LOGICAL :: do_pz_renorm = .false. - LOGICAL :: do_bare_eigs = .false. - REAL(DP) :: kfact = 1.d0 - ! - LOGICAL :: do_innerloop = .false. - LOGICAL :: do_innerloop_empty = .false. - LOGICAL :: do_innerloop_cg = .false. - INTEGER :: innerloop_dd_nstep = 50 - INTEGER :: innerloop_init_n = 10000 - INTEGER :: innerloop_atleast = 0 - REAL(DP) :: innerloop_cg_ratio = 1.d-3 - INTEGER :: innerloop_cg_nsd = 20 - INTEGER :: innerloop_cg_nreset = 10 - INTEGER :: innerloop_nmax = 10000 - INTEGER :: innerloop_until = -1 - INTEGER :: iprint_spreads=-1 !prints spread every nth step, -1 does not print spread !!added:giovanni - INTEGER :: iprint_manifold_overlap=-1 !prints manifold overlap with initial wavefunctions (random or from restart), when -1, no overlap is printed - LOGICAL :: hartree_only_sic - LOGICAL :: l_comp_cmplxfctn_index = .false. - ! - ! This variable overwrites the ones above - CHARACTER(80) :: which_orbdep=" " - CHARACTER(LEN=80) :: which_orbdep_allowed(14) - CHARACTER(LEN=80) :: which_orbdep_allowed_cmplx(9) - ! - DATA which_orbdep_allowed & - / "none", "nk", "non-koopmans", "nk0", "nki", & - "perdew-zunger", "pz", "pznk", "nkpz" ,"nkipz", "pznki", & - "hf", "b3lyp", "pbe0" / - DATA which_orbdep_allowed_cmplx & - / "none", "nk", "non-koopmans", "nk0", "nki", & - "perdew-zunger", "pz", "nkipz", "pznki"/ - ! - ! - ! ---------------- - LOGICAL :: odd_nkscalfact= .false. !added by linh, to compute different alphas - LOGICAL :: odd_nkscalfact_empty= .false. !added by linh, to compute different alphas for empty - LOGICAL :: restart_odd_nkscalfact= .false. !added: when you are running with odd_nkscalfact=.true., - ! you needs to set restart_odd_nkscalfact=.true. if you needs to restart the calculation. - LOGICAL :: wo_odd_in_empty_run = .false. !added: by linh, othorgnal empty manyfolds without computing ODD energy - INTEGER :: aux_empty_nbnd = 0 - ! - LOGICAL :: restart_from_wannier_cp= .false. !added by linh, to start KIPZ calculations using - ! wannier orbitals as starting. - CHARACTER(80) :: which_file_wannier=" " ! added by linh, name of the *.chk file which stores information - ! of wannier90 output. - ! - LOGICAL :: wannier_empty_only = .false. !added by linh, set wannier_empty_only if you want to start empty KIPZ calculation - ! and to use wannier orbitals as starting - ! - LOGICAL :: print_evc0_occ_empty= .false. !added:linh to save evc0 of occ and empty in xml_format - ! - LOGICAL :: print_wfc_anion = .false. !added by linh, to save the anion format N+1 systems. - INTEGER :: index_empty_to_save = 1 !added by linh, to save the anion format N+1 systems. - ! --------------- - ! - LOGICAL :: draw_pot = .false. !added:linh draw vsic potentials - LOGICAL :: sortwfc_spread = .false. !added:sort nksic minimizing orbitals & - ! according to their Culomb spreads - INTEGER :: pot_number = 1 !added:linh draw vsic potentials - ! - INTEGER :: nknmax = -1 - ! - REAL ( DP ) :: fref = 0.5_DP - REAL ( DP ) :: rhobarfact = 1.0_DP - REAL ( DP ) :: nkscalfact = 1.0_DP - REAL ( DP ) :: hfscalfact = 1.0_DP - REAL ( DP ) :: vanishing_rho_w = 1.0e-7_DP - ! - ! Linh: finite field - LOGICAL :: finite_field_introduced = .FALSE. - LOGICAL :: finite_field_for_empty_state = .FALSE. - ! - ! -!=-----BEGIN nksic input variables - NAMELIST / nksic / draw_pot, pot_number, & !added:linh draw vsic potentials - do_nk, do_pz, do_nki, do_nkpz, do_nkipz, do_hf, & - do_wref, do_wxd, fref, rhobarfact, ampfield, do_efield, & - do_hf, nknmax, & - ! - odd_nkscalfact, & !added:linh compute odd alpha - restart_odd_nkscalfact, print_evc0_occ_empty, wo_odd_in_empty_run, & !added:linh compute odd alpha - print_wfc_anion, index_empty_to_save, restart_from_wannier_cp, & - which_file_wannier, wannier_empty_only, odd_nkscalfact_empty, & - ! - nkscalfact, hfscalfact, vanishing_rho_w, which_orbdep, & - do_innerloop, do_innerloop_empty, do_innerloop_cg, innerloop_dd_nstep, & - innerloop_cg_nsd, innerloop_cg_nreset, innerloop_nmax, & - innerloop_init_n, innerloop_cg_ratio, do_pz_renorm, kfact, & - esic_conv_thr, do_bare_eigs, sortwfc_spread, iprint_spreads, & - iprint_manifold_overlap, innerloop_until, innerloop_atleast, & - hartree_only_sic, aux_empty_nbnd, & - ! - finite_field_introduced, finite_field_for_empty_state, l_comp_cmplxfctn_index - ! -! lgroup !NsC - -!=----END nksic input variables -! -!=----------------------------------------------------------------------------=! -! EE Namelist Input Parameters -!=----------------------------------------------------------------------------=! -! -! type of electrostatic embedding used - CHARACTER( LEN = 256 ) :: which_compensation = 'none' - logical :: tcc_odd = .true. -! kinetic energy cutoff for the coarse (MultiGrid) grid - REAL(DP) :: ecutcoarse = 100.0d0 -! amount of "new" correction introduced when mixing - REAL(DP) :: mixing_charge_compensation = 1.0 -! error tolerance for the multigrid solver - REAL(DP) :: errtol = 1.d-22 -! how early in scf itarations should the corrective pot start being calculated - REAL(DP) :: comp_thr = 1.d-2 -! nlev number of grid levels in the multigrid solver - INTEGER :: nlev = 2 -! itmax maximum number of iterations in the multigrid solver - INTEGER :: itmax = 1000 -! whichbc 0 if aperiodic - INTEGER :: whichbc(3) = 0 -! sets after how many scf cycles the corrective potential should be calculated - INTEGER :: n_charge_compensation = 5 -! - INTEGER :: ncompx = 1 - INTEGER :: ncompy = 1 - INTEGER :: ncompz = 1 - ! ONLY PWSCF -! - INTEGER :: mr1 = 0 - INTEGER :: mr2 = 0 - INTEGER :: mr3 = 0 - - REAL(DP) :: cellmin( 3 ) = 0.D0 - ! ONLY PWSCF - - REAL(DP) :: cellmax( 3 ) = 1.D0 - - NAMELIST / ee / which_compensation,tcc_odd, comp_thr, & - ncompx,n_charge_compensation, & - ncompy, ncompz,mixing_charge_compensation, & - mr1, mr2, mr3, ecutcoarse, & - errtol, nlev, itmax, whichbc, & - cellmin, cellmax - -!=----------------------------------------------------------------------------=! -! ELECTRONS Namelist Input Parameters -!=----------------------------------------------------------------------------=! - - REAL(DP) :: emass = 0.0_DP - ! effective electron mass in the CP Lagrangian, - ! in atomic units ( 1 a.u. of mass = 1/1822.9 a.m.u. = 9.10939 * 10^-31 kg ) - ! Typical values in CP simulation are between 100. and 1000. - - REAL(DP) :: emass_cutoff = 0.0_DP - ! mass cut-off (in Rydbergs) for the Fourier acceleration - ! effective mass is rescaled for "G" vector components with kinetic - ! energy above "emass_cutoff" - ! Use a value grether than "ecutwfc" to disable Fourier acceleration. - - CHARACTER(LEN=80) :: orthogonalization = 'ortho' - ! orthogonalization = 'Gram-Schmidt' | 'ortho'* - ! selects the orthonormalization method for electronic wave functions - ! 'Gram-Schmidt' use Gram-Schmidt algorithm - ! 'ortho' use iterative algorithm - - REAL(DP) :: ortho_eps = 1.E-8_DP - ! meaningful only if orthogonalization = 'ortho' - ! tolerance for iterative orthonormalization, - ! a value of 1.d-8 is usually sufficent - - INTEGER :: ortho_max = 20 - ! meaningful only if orthogonalization = 'ortho' - ! maximum number of iterations for orthonormalization - ! usually between 15 and 30. - - INTEGER :: ortho_para = 0 - ! meaningful only if orthogonalization = 'ortho' and parallel build - ! Suggested number of processors to be used for distributing - ! lambda matrixes and for parallel diagonalization - - INTEGER :: electron_maxstep = 1000 - ! maximum number of steps in electronic minimization - ! This parameter apply only when using 'cg' electronic or - ! ionic dynamics - - CHARACTER(LEN=80) :: electron_dynamics = 'none' - ! set how electrons should be moved - CHARACTER(LEN=80) :: electron_dynamics_allowed(6) - DATA electron_dynamics_allowed & - / 'default', 'sd', 'cg', 'damp', 'verlet', 'none' / - - REAL(DP) :: electron_damping = 0.0_DP - ! meaningful only if " electron_dynamics = 'damp' " - ! damping frequency times delta t, optimal values could be - ! calculated with the formula - ! sqrt(0.5*log((E1-E2)/(E2-E3))) - ! where E1 E2 E3 are successive values of the DFT total energy - ! in a steepest descent simulations - - CHARACTER(LEN=80) :: electron_velocities = 'default' - ! electron_velocities = 'zero' | 'default'* - ! 'zero' restart setting electronic velocities to zero - ! 'default' restart using electronic velocities of the previous run - - CHARACTER(LEN=80) :: electron_temperature = 'not_controlled' - ! electron_temperature = 'nose' | 'not_controlled'* | 'rescaling' - ! 'nose' control electronic temperature using Nose thermostat - ! see parameter "fnosee" and "ekincw" - ! 'rescaling' control electronic temperature via velocities rescaling - ! 'not_controlled' electronic temperature is not controlled - - REAL(DP) :: ekincw = 0.0_DP - ! meaningful only with "electron_temperature /= 'not_controlled' " - ! value of the average kinetic energy (in atomic units) forced - ! by the temperature control - - REAL(DP) :: fnosee = 0.0_DP - ! meaningful only with "electron_temperature = 'nose' " - ! oscillation frequency of the nose thermostat (in terahertz) - - CHARACTER(LEN=80) :: startingwfc = 'random' - ! startingwfc = 'atomic' | 'atomic+random' | 'random' | 'file' - ! define how the code should initialize the wave function - ! 'atomic' start from superposition of atomic wave functions - ! 'atomic+random' as above, plus randomization - ! 'random' start from random wave functions - ! 'file' read wavefunctions from file - - REAL(DP) :: ampre = 0.0_DP - ! meaningful only if "startingwfc = 'random'", amplitude of the - ! randomization ( allowed values: 0.0 - 1.0 ) - - REAL(DP) :: grease = 0.0_DP - ! a number <= 1, very close to 1: the damping in electronic - ! damped dynamics is multiplied at each time step by "grease" - ! (avoids overdamping close to convergence: Obsolete ?) - ! grease = 1 : normal damped dynamics - ! NOT used in FPMD - - INTEGER :: empty_states_nbnd = 0 - ! number of empty states to be calculated every iprint steps - ! default value is zero - - INTEGER :: empty_states_maxstep = 100 - ! meaningful only with "empty_states_nbnd > 0 " - ! maximum number of iteration in the empty states calculation - ! default is 100 - - REAL(DP) :: empty_states_ethr = 1.E-4_DP - ! meaningful only with "empty_states_nbnd > 0 " - ! wave function gradient threshold, for convergence of empty states - ! default value is ekin_conv_thr - - INTEGER :: diis_size = 0 - ! meaningful only with " electron_dynamics = 'diis' " - ! size of the matrix used for the inversion in the iterative subspace - ! default is 4, allowed value 1-5 - - INTEGER :: diis_nreset = 0 - ! meaningful only with " electron_dynamics = 'diis' " - ! number of steepest descendent step after a reset of the diis - ! iteration, default value is 3 - - REAL(DP) :: diis_hcut = 0.0_DP - ! meaningful only with " electron_dynamics = 'diis' " - ! energy cutoff (a.u.), above which an approximate diagonal - ! hamiltonian is used in finding the direction to the minimum - ! default is "1.0" - - REAL(DP) :: diis_wthr = 1.E-4_DP - ! meaningful only with " electron_dynamics = 'diis' " - ! convergence threshold for wave function - ! this criterion is satisfied when the maximum change - ! in the wave functions component between two diis steps - ! is less than this threshold - ! default value is ekin_conv_thr - - REAL(DP) :: diis_delt = 1.0_DP - ! meaningful only with " electron_dynamics = 'diis' " - ! electronic time step used in the steepest descendent step - ! default is "dt" - - INTEGER :: diis_maxstep = 100 - ! meaningful only with " electron_dynamics = 'diis' " - ! maximum number of iteration in the diis minimization - ! default is electron_maxstep - - LOGICAL :: diis_rot = .FALSE. - ! meaningful only with " electron_dynamics = 'diis' " - ! if "diis_rot = .TRUE." enable diis with charge mixing and rotations - ! default is "diis_rot = .FALSE." - - REAL(DP) :: diis_fthr = 1.E-3_DP - ! meaningful only with "electron_dynamics='diis' " and "diis_rot=.TRUE." - ! convergence threshold for ionic force - ! this criterion is satisfied when the maximum change - ! in the atomic force between two diis steps - ! is less than this threshold - ! default value is "0.0" - - REAL(DP) :: diis_temp = 0.0_DP - ! meaningful only with "electron_dynamics='diis' " and "diis_rot=.TRUE." - ! electronic temperature, significant only if ??? - - REAL(DP) :: diis_achmix = 0.0_DP - ! meaningful only with "electron_dynamics='diis' " and "diis_rot=.TRUE." - ! "A" parameter in the charge mixing formula - ! chmix = A * G^2 / (G^2 + G0^2) , G represents reciprocal lattice vectors - - REAL(DP) :: diis_g0chmix = 0.0_DP - ! meaningful only with "electron_dynamics='diis' " and "diis_rot=.TRUE." - ! "G0^2" parameter in the charge mixing formula - - INTEGER :: diis_nchmix = 0 - ! meaningful only with "electron_dynamics='diis' " and "diis_rot=.TRUE." - ! dimension of the charge mixing - - REAL(DP) :: diis_g1chmix = 0.0_DP - ! meaningful only with "electron_dynamics='diis' " and "diis_rot=.TRUE." - ! "G1^2" parameter in the charge mixing formula - ! metric = (G^2 + G1^2) / G^2 , G represents reciprocal lattice vectors - - INTEGER :: diis_nrot(3) = 0 - ! meaningful only with "electron_dynamics='diis' " and "diis_rot=.TRUE." - ! start upgrading the charge density every "diis_nrot(1)" steps, - ! then every "diis_nrot(2)", and at the end every "diis_nrot(3)", - ! depending on "diis_rothr" - - REAL(DP) :: diis_rothr(3) = 1.E-4_DP - ! meaningful only with "electron_dynamics='diis' " and "diis_rot=.TRUE." - ! threshold on the charge difference between two diis step - ! when max charge difference is less than "diis_rothr(1)", switch - ! between the "diis_nrot(1)" upgrade frequency to "diis_nrot(2)", - ! then when the max charge difference is less than "diis_rothr(2)", - ! switch between "diis_nrot(2)" and "diis_nrot(3)", upgrade frequency, - ! finally when the max charge difference is less than "diis_nrot(3)" - ! convergence is achieved - - REAL(DP) :: diis_ethr = 1.E-4_DP - ! meaningful only with "electron_dynamics='diis' " and "diis_rot=.TRUE." - ! convergence threshold for energy - ! this criterion is satisfied when the change - ! in the energy between two diis steps - ! is less than this threshold - ! default value is etot_conv_thr - - LOGICAL :: diis_chguess = .FALSE. - ! meaningful only with "electron_dynamics='diis' " and "diis_rot=.TRUE." - ! if "diis_chguess = .TRUE." enable charge density guess - ! between two diis step, defaut value is "diis_chguess = .FALSE." - - CHARACTER(LEN=80) :: mixing_mode = 'default' - ! mixing = ???? - ! define how to mix wave functions - ! NOT used in FPMD - - REAL(DP) :: mixing_beta = 0.0_DP - ! parameter for wave function mixing - ! NOT used in FPMD - - INTEGER :: mixing_ndim = 0 - ! dimension of wave function mixing - ! NOT used in FPMD - - CHARACTER(LEN=80) :: diagonalization = 'cg' - ! diagonalization = 'cg' | 'david' | 'david-serial' - ! algorithm used by PWscf for iterative diagonalization - - REAL(DP) :: diago_thr_init = 0.0_DP - ! convergence threshold for the firts iterative diagonalization. - ! NOT used in FPMD - - INTEGER :: diago_cg_maxiter = 100 - ! NOT used in FPMD - - INTEGER :: diago_david_ndim = 10 - ! NOT used in FPMD - - INTEGER :: diago_diis_ndim = 10 - ! NOT used in FPMD - - LOGICAL :: diago_full_acc = .FALSE. - - REAL(DP) :: conv_thr = 1.E-6_DP - ! convergence threshold in electronic ONLY minimizations - ! NOT used in FPMD - - INTEGER :: mixing_fixed_ns = 0 - ! PWSCF only - ! NOT used in FPMD - - CHARACTER(LEN=80) :: startingpot = 'potfile' - ! specify the file containing the DFT potential of the system - ! NOT used in FPMD - - INTEGER :: n_inner = 2 - ! number of inner loop per CG iteration. - - INTEGER :: niter_cold_restart = 1 - !frequency of full cold smearing inner cycle (in iterations) - - REAL(DP) :: lambda_cold - !step for not complete cold smearing inner cycle - - - LOGICAL :: tgrand = .FALSE. - ! whether to do grand-canonical calculations. - - REAL(DP) :: fermi_energy = 0.0_DP - ! chemical potential of the grand-canonical ensemble. - - CHARACTER(LEN=80) :: rotation_dynamics = "line-minimization" - ! evolution the rotational degrees of freedom. - - CHARACTER(LEN=80) :: occupation_dynamics = "line-minimization" - ! evolution of the occupational degrees of freedom. - - REAL(DP) :: rotmass = 0 - ! mass for the rotational degrees of freedom. - - REAL(DP) :: occmass = 0 - ! mass for the occupational degrees of freedom. - - REAL(DP) :: occupation_damping = 0 - ! damping for the rotational degrees of freedom. - - REAL(DP) :: rotation_damping = 0 - ! damping for the occupational degrees of freedom. - - LOGICAL :: tcg = .true. - ! if true perform in cpv conjugate gradient minimization of electron energy - - INTEGER :: maxiter = 100 - ! max number of conjugate gradient iterations - - REAL(DP) :: etresh =1.0E-7_DP - ! treshhold on energy - - REAL(DP) :: passop =0.3_DP - ! small step for parabolic interpolation - - INTEGER :: niter_cg_restart - !frequency of restart for the conjugate gradient algorithm in iterations - - INTEGER :: epol = 3 - ! electric field direction - - REAL(DP) :: efield =0.0_DP - ! electric field intensity in atomic units - - ! real_space routines for US pps - Logical :: real_space = .false. - - - REAL(DP) :: efield_cart(3) - ! electric field vector in cartesian system of reference - - INTEGER :: epol2 = 3 - ! electric field direction - - REAL(DP) :: efield2 =0.0_DP - ! electric field intensity in atomic units - - LOGICAL :: tqr = .FALSE. - ! US contributions are added in real space - - LOGICAL :: occupation_constraints = .FALSE. - ! If true perform CP dynamics with constrained occupations - ! to be used together with penalty functional ... - - LOGICAL :: do_outerloop = .TRUE. - ! If true, perform the outerloop when optimising the - ! filled electronic variational orbitals - - LOGICAL :: do_outerloop_empty = .TRUE. - ! If true, perform the outerloop when optimising the - ! empty electronic variational orbitals - - LOGICAL :: reortho = .FALSE. - ! If true, re-orthogonalize the non-scf empty states to the occupied - ! manifold - - NAMELIST / electrons / emass, emass_cutoff, orthogonalization, & - electron_maxstep, ortho_eps, ortho_max, electron_dynamics, & - electron_damping, electron_velocities, electron_temperature, & - ekincw, fnosee, ampre, grease, empty_states_nbnd, & - empty_states_maxstep, & - empty_states_ethr, diis_size, diis_nreset, diis_hcut, & - diis_wthr, diis_delt, diis_maxstep, diis_rot, diis_fthr, & - diis_temp, diis_achmix, diis_g0chmix, diis_g1chmix, & - diis_nchmix, diis_nrot, diis_rothr, diis_ethr, diis_chguess, & - mixing_mode, mixing_beta, mixing_ndim, mixing_fixed_ns, & - tqr, diago_cg_maxiter, diago_david_ndim, diagonalization , & - startingpot, startingwfc , conv_thr, diago_diis_ndim, & - diago_thr_init, n_inner, fermi_energy, rotmass, occmass, & - rotation_damping, occupation_damping, rotation_dynamics, & - occupation_dynamics, tcg, maxiter, etresh, passop, epol, & - efield, epol2, efield2, diago_full_acc, & - occupation_constraints, ortho_para, niter_cg_restart, & - niter_cold_restart, lambda_cold, efield_cart, real_space, & - do_outerloop, do_outerloop_empty, reortho - -! -!=----------------------------------------------------------------------------=! -! IONS Namelist Input Parameters -!=----------------------------------------------------------------------------=! -! - CHARACTER(LEN=80) :: phase_space = 'full' - ! phase_space = 'full' | 'coarse-grained' - ! 'full' the full phase-space is used for the ionic - ! dynamics - ! 'coarse-grained' a coarse-grained phase-space, defined by a set - ! of constraints, is used for the ionic dynamics - - CHARACTER(LEN=80) :: phase_space_allowed(2) - DATA phase_space_allowed / 'full', 'coarse-grained' / - - CHARACTER(LEN=80) :: ion_dynamics = 'none' - ! set how ions should be moved - CHARACTER(LEN=80) :: ion_dynamics_allowed(8) - DATA ion_dynamics_allowed / 'none', 'sd', 'cg', 'langevin', & - 'damp', 'verlet', 'bfgs', 'beeman' / - - REAL(DP) :: ion_radius(nsx) = 0.5_DP - ! pseudo-atomic radius of the i-th atomic species - ! (for Ewald summation), values between 0.5 and 2.0 are usually used. - - REAL(DP) :: ion_damping = 0.2_DP - ! meaningful only if " ion_dynamics = 'damp' " - ! damping frequency times delta t, optimal values could be - ! calculated with the formula - ! sqrt(0.5*log((E1-E2)/(E2-E3))) - ! where E1 E2 E3 are successive values of the DFT total energy - ! in a ionic steepest descent simulation - - CHARACTER(LEN=80) :: ion_positions = 'default' - ! ion_positions = 'default'* | 'from_input' - ! 'default' restart the simulation with atomic positions read - ! from the restart file - ! 'from_input' restart the simulation with atomic positions read - ! from standard input ( see the card 'ATOMIC_POSITIONS' ) - - CHARACTER(LEN=80) :: ion_velocities = 'default' - ! ion_velocities = 'zero' | 'default'* | 'random' | 'from_input' - ! 'default' restart the simulation with atomic velocities read - ! from the restart file - ! 'random' start the simulation with random atomic velocities - ! 'from_input' restart the simulation with atomic velocities read - ! from standard input (see the card 'ATOMIC_VELOCITIES' ) - ! 'zero' restart the simulation with atomic velocities set to zero - - CHARACTER(LEN=80) :: ion_temperature = 'not_controlled' - ! ion_temperature = 'nose' | 'not_controlled'* | 'rescaling' | - ! 'berendsen' | 'andersen' | 'rescale-v' | 'rescale-T' | 'reduce-T' - ! - ! 'nose' control ionic temperature using Nose thermostat - ! see parameters "fnosep" and "tempw" - ! 'rescaling' control ionic temperature via velocity rescaling - ! see parameters "tempw" and "tolp" - ! 'rescale-v' control ionic temperature via velocity rescaling - ! see parameters "tempw" and "nraise" - ! 'rescale-T' control ionic temperature via velocity rescaling - ! see parameter "delta_t" - ! 'reduce-T' reduce ionic temperature - ! see parameters "nraise", delta_t" - ! 'berendsen' control ionic temperature using "soft" velocity - ! rescaling - see parameters "tempw" and "nraise" - ! 'andersen' control ionic temperature using Andersen thermostat - ! see parameters "tempw" and "nraise" - ! 'not_controlled' ionic temperature is not controlled - - REAL(DP) :: tempw = 300.0_DP - ! meaningful only with "ion_temperature /= 'not_controlled' " - ! value of the ionic temperature (in Kelvin) forced - ! by the temperature control - - INTEGER, PARAMETER :: nhclm = 4 - REAL(DP) :: fnosep( nhclm ) = 50.0_DP - ! meaningful only with "ion_temperature = 'nose' " - ! oscillation frequency of the nose thermostat (in terahertz) - ! nhclm is the max length for the chain; it can be easily increased - ! since the restart file should be able to handle it - ! perhaps better to align nhclm by 4 - - INTEGER :: nhpcl = 0 - ! non-zero only with "ion_temperature = 'nose' " - ! this defines the length of the Nose-Hoover chain - - INTEGER :: nhptyp = 0 - ! this parameter set the nose hoover thermostat to more than one - - INTEGER :: nhgrp(nsx)=0 - ! this is the array to assign thermostats to atomic types - ! allows to use various thermostat setups - - INTEGER :: ndega = 0 - ! this is the parameter to control active degrees of freedom - ! used for temperature control and the Nose-Hoover chains - - REAL(DP) :: tolp = 50.0_DP - ! meaningful only with "ion_temperature = 'rescaling' " - ! tolerance (in Kelvin) of the rescaling. When ionic temperature - ! differs from "tempw" more than "tolp" apply rescaling. - - REAL(DP) :: fnhscl(nsx)=-1.0_DP - ! this is to scale the target energy, in case there are constraints - ! the dimension is the same as nhgrp, meaning that atomic type - ! i with a group nhgrp(i) is scaled by fnhscl(i) - - LOGICAL :: tranp(nsx) = .FALSE. - ! tranp(i) control the randomization of the i-th atomic specie - ! .TRUE. randomize ionic positions ( see "amprp" ) - ! .FALSE. do nothing - - REAL(DP) :: amprp(nsx) = 0.0_DP - ! amprp(i) meaningful only if "tranp(i) = .TRUE.", amplitude of the - ! randomization ( allowed values: 0.0 - 1.0 ) for the i-th atomic specie. - ! Add to the positions a random displacements vector ( in bohr radius ) - ! defined as: amprp( i ) * ( X, Y, Z ) - ! where X, Y, Z are pseudo random number in the interval [ -0.5 , 0.5 ] - - REAL(DP) :: greasp = 0.0_DP - ! same as "grease", for ionic damped dynamics - ! NOT used in FPMD - - INTEGER :: ion_nstepe = 1 - ! number of electronic steps for each ionic step - - INTEGER :: ion_maxstep = 1000 - ! maximum number of step in ionic minimization - - REAL(DP) :: upscale = 1.0_DP - ! This variable is NOT used in FPMD - - CHARACTER(LEN=80) :: pot_extrapolation = 'default', & - wfc_extrapolation = 'default' - ! These variables are used only by PWSCF - - LOGICAL :: refold_pos - LOGICAL :: remove_rigid_rot = .FALSE. - - ! - ! ... delta_T, nraise, tolp are used to change temperature in PWscf - ! - - REAL(DP) :: delta_t = 1.0_DP - - INTEGER :: nraise = 1 - - ! - ! ... variables added for "path" calculations - ! - - ! - ! ... these are two auxiliary variables used in read_cards to - ! ... distinguish among neb and smd done in the full phase-space - ! ... or in the coarse-grained phase-space - ! - LOGICAL :: full_phs_path_flag = .FALSE. - LOGICAL :: cg_phs_path_flag = .FALSE. - ! - INTEGER :: input_images = 0 - ! - INTEGER :: num_of_images = 0 - ! - CHARACTER(LEN=80) :: CI_scheme = 'no-CI' - ! CI_scheme = 'no-CI' | 'auto' | 'manual' - ! set the Climbing Image scheme - ! 'no-CI' Climbing Image is not used - ! 'auto' Standard Climbing Image - ! 'manual' the image is selected by hand - ! - CHARACTER(LEN=80) :: CI_scheme_allowed(3) - DATA CI_scheme_allowed / 'no-CI', 'auto', 'manual' / - ! - LOGICAL :: first_last_opt = .FALSE. - LOGICAL :: use_masses = .FALSE. - LOGICAL :: use_freezing = .FALSE. - LOGICAL :: fixed_tan = .FALSE. - ! - CHARACTER(LEN=80) :: opt_scheme = 'quick-min' - ! minimization_scheme = 'quick-min' | 'damped-dyn' | - ! 'mol-dyn' | 'sd' - ! set the minimization algorithm - ! 'quick-min' projected molecular dynamics - ! 'sd' steepest descent - ! 'broyden' broyden acceleration - ! 'langevin' langevin dynamics - ! - CHARACTER(LEN=80) :: opt_scheme_allowed(4) - DATA opt_scheme_allowed / 'quick-min', 'broyden', 'sd', 'langevin' / - ! - REAL (DP) :: temp_req = 0.0_DP - ! meaningful only when minimization_scheme = 'sim-annealing' - REAL (DP) :: ds = 1.0_DP - ! - REAL (DP) :: k_max = 0.1_DP, k_min = 0.1_DP - ! - REAL (DP) :: path_thr = 0.05_DP - - ! - ! ... variables added for new BFGS algorithm - ! - - INTEGER :: bfgs_ndim = 1 - - REAL(DP) :: trust_radius_max = 0.8_DP - REAL(DP) :: trust_radius_min = 1.E-3_DP - REAL(DP) :: trust_radius_ini = 0.5_DP - - REAL(DP) :: w_1 = 0.5E-1_DP - REAL(DP) :: w_2 = 0.5_DP - - REAL(DP) :: sic_rloc = 0.0_DP - - ! - ! ... variable for meta-dynamics - ! - INTEGER, PARAMETER :: max_nconstr = 100 - INTEGER :: fe_nstep = 100 - INTEGER :: sw_nstep = 10 - INTEGER :: eq_nstep = 0 - REAL(DP) :: g_amplitude = 0.005_DP - ! - REAL(DP) :: fe_step( max_nconstr ) = 0.4_DP - ! - NAMELIST / ions / phase_space, ion_dynamics, ion_radius, ion_damping, & - ion_positions, ion_velocities, ion_temperature, & - tempw, fnosep, nhgrp, fnhscl, nhpcl, nhptyp, ndega, tranp, & - amprp, greasp, tolp, ion_nstepe, ion_maxstep, & - refold_pos, upscale, delta_t, pot_extrapolation, & - wfc_extrapolation, nraise, remove_rigid_rot, & - num_of_images, CI_scheme, opt_scheme, use_masses, & - first_last_opt, ds, k_max, k_min, temp_req, & - path_thr, fixed_tan, use_freezing, & - trust_radius_max, trust_radius_min, & - trust_radius_ini, w_1, w_2, bfgs_ndim, sic_rloc, & - fe_step, fe_nstep, sw_nstep, eq_nstep, g_amplitude - -!=----------------------------------------------------------------------------=! -! CELL Namelist Input Parameters -!=----------------------------------------------------------------------------=! -! - CHARACTER(LEN=80) :: cell_parameters = 'default' - ! cell_parameters = 'default'* | 'from_input' - ! 'default' restart the simulation with cell parameters read - ! from the restart file or "celldm" if - ! "restart = 'from_scratch'" - ! 'from_input' restart the simulation with cell parameters - ! from standard input ( see the card 'CELL_PARAMETERS' ) - - CHARACTER(LEN=80) :: cell_dynamics = 'none' - ! set how the cell should be moved - CHARACTER(LEN=80) :: cell_dynamics_allowed(7) - DATA cell_dynamics_allowed / 'sd', 'pr', 'none', 'w', 'damp-pr', & - 'damp-w', 'bfgs' / - - CHARACTER(LEN=80) :: cell_velocities = 'default' - ! cell_velocities = 'zero' | 'default'* - ! 'zero' restart setting cell velocitiy to zero - ! 'default' restart using cell velocity of the previous run - - REAL(DP) :: press = 0.0_DP - ! external pressure (in GPa, remember 1 kbar = 10^8 Pa) - - REAL(DP) :: wmass = 0.0_DP - ! effective cell mass in the Parrinello-Rahman Lagrangian (in atomic units) - ! of the order of magnitude of the total atomic mass - ! (sum of the mass of the atoms) within the simulation cell. - ! if you do not specify this parameters, the code will compute - ! its value based on some physical consideration - - CHARACTER(LEN=80) :: cell_temperature = 'not_controlled' - ! cell_temperature = 'nose' | 'not_controlled'* | 'rescaling' - ! 'nose' control cell temperature using Nose thermostat - ! see parameters "fnoseh" and "temph" - ! 'rescaling' control cell temperature via velocities rescaling - ! 'not_controlled' cell temperature is not controlled - ! NOT used in FPMD - - REAL(DP) :: temph = 0.0_DP - ! meaningful only with "cell_temperature /= 'not_controlled' " - ! value of the cell temperature (in Kelvin) forced - ! by the temperature control - - REAL(DP) :: fnoseh = 1.0_DP - ! meaningful only with "cell_temperature = 'nose' " - ! oscillation frequency of the nose thermostat (in terahertz) - - REAL(DP) :: greash = 0.0_DP - ! same as "grease", for cell damped dynamics - - CHARACTER(LEN=80) :: cell_dofree = 'all' - ! cell_dofree = 'all'* | 'volume' | 'x' | 'y' | 'z' | 'xy' | 'xz' | 'yz' | 'xyz' - ! select which of the cell parameters should be moved - ! 'all' all axis and angles are propagated (default) - ! 'volume' the cell is simply rescaled, without changing the shape - ! 'x' only the "x" axis is moved - ! 'y' only the "y" axis is moved - ! 'z' only the "z" axis is moved - ! 'xy' only the "x" and "y" axis are moved, angles are unchanged - ! 'xz' only the "x" and "z" axis are moved, angles are unchanged - ! 'yz' only the "y" and "z" axis are moved, angles are unchanged - ! 'xyz' "x", "y" and "z" axis are moved, angles are unchanged - - REAL(DP) :: cell_factor = 0.0_DP - ! NOT used in FPMD - - INTEGER :: cell_nstepe = 1 - ! number of electronic steps for each cell step - - REAL(DP) :: cell_damping = 0.0_DP - ! meaningful only if " cell_dynamics = 'damp' " - ! damping frequency times delta t, optimal values could be - ! calculated with the formula - ! sqrt(0.5*log((E1-E2)/(E2-E3))) - ! where E1 E2 E3 are successive values of the DFT total energy - ! in a ionic steepest descent simulation - - REAL(DP) :: press_conv_thr = 0.5_DP - - NAMELIST / cell / cell_parameters, cell_dynamics, cell_velocities, & - press, wmass, cell_temperature, temph, fnoseh, & - cell_dofree, greash, cell_factor, cell_nstepe, & - cell_damping, press_conv_thr - -! -!=----------------------------------------------------------------------------=!! -! PRESS_AI Namelist Input Parameters -!=----------------------------------------------------------------------------=! -! -! - LOGICAL :: abivol = .FALSE. - LOGICAL :: abisur = .FALSE. - LOGICAL :: pvar = .FALSE. - LOGICAL :: fill_vac=.FALSE. - LOGICAL :: scale_at=.FALSE. - LOGICAL :: t_gauss =.FALSE. - LOGICAL :: jellium= .FALSE. - LOGICAL :: cntr(nsx)=.FALSE. - REAL(DP) :: P_ext = 0.0_DP - REAL(DP) :: P_in = 0.0_DP - REAL(DP) :: P_fin = 0.0_DP - REAL(DP) :: rho_thr = 0.0_DP - REAL(DP) :: step_rad(nsx) = 0.0_DP - REAL(DP) :: Surf_t = 0.0_DP - REAL(DP) :: dthr = 0.0_DP - REAL(DP) :: R_j = 0.0_DP - REAL(DP) :: h_j = 0.0_DP - REAL(DP) :: delta_eps = 0.0_DP - REAL(DP) :: delta_sigma=0.0_DP - INTEGER :: n_cntr = 0 - INTEGER :: axis = 0 - - NAMELIST / press_ai / abivol, P_ext, pvar, P_in, P_fin, rho_thr, & - & step_rad, delta_eps, delta_sigma, n_cntr, & - & fill_vac, scale_at, t_gauss, abisur, & - & Surf_t, dthr, cntr, axis, jellium, R_j, h_j - -! -!=----------------------------------------------------------------------------=! -! PHONON Namelist Input Parameters -!=----------------------------------------------------------------------------=! -! - - INTEGER :: modenum = 0 - - REAL(DP) :: xqq(3) = 0.0_DP - ! coordinates of q point for phonon calculation - - NAMELIST / phonon / modenum, xqq - -!=----------------------------------------------------------------------------=! -! WANNIER Namelist Input Parameters -!=----------------------------------------------------------------------------=! - - LOGICAL :: wf_efield - LOGICAL :: wf_switch - ! - INTEGER :: sw_len - ! - REAL(DP) :: efx0, efy0, efz0 - REAL(DP) :: efx1, efy1, efz1 - ! - INTEGER :: wfsd - ! - REAL(DP) :: wfdt - REAL(DP) :: maxwfdt - REAL(DP) :: wf_q - REAL(DP) :: wf_friction - ! - INTEGER :: nit - INTEGER :: nsd - INTEGER :: nsteps - ! - REAL(DP) :: tolw - ! - LOGICAL :: adapt - ! - INTEGER :: calwf - INTEGER :: nwf - INTEGER :: wffort - ! - LOGICAL :: writev - ! - NAMELIST / wannier / wf_efield, wf_switch, sw_len, efx0, efy0, efz0, & - efx1, efy1, efz1, wfsd, wfdt, maxwfdt, wf_q, & - wf_friction, nit, nsd, nsteps, tolw, adapt, & - calwf, nwf, wffort, writev - -! END manual -! ---------------------------------------------------------------------- - -!=----------------------------------------------------------------------------=! -! WANNIER_NEW Namelist Input Parameters -!=----------------------------------------------------------------------------=! - - LOGICAL :: & - plot_wannier = .FALSE.,& - ! if .TRUE. wannier number plot_wan_num is plotted - use_energy_int = .FALSE., & - ! if .TRUE. energy interval is used to generate wannier - print_wannier_coeff = .FALSE. - ! if .TRUE. - INTEGER, PARAMETER :: nwanx = 50 ! max number of wannier functions - INTEGER :: & - nwan, &! number of wannier functions - plot_wan_num = 0, &! number of wannier for plotting - plot_wan_spin = 1 ! spin of wannier for plotting - REAL(DP) :: & - constrain_pot(nwanx,2) ! constrained potential for wannier - NAMELIST / wannier_ac / plot_wannier, use_energy_int, nwan, & - plot_wan_num, plot_wan_spin, constrain_pot, print_wannier_coeff - -! END manual -! ---------------------------------------------------------------------- - - -! ---------------------------------------------------------------- -! BEGIN manual -! -!=----------------------------------------------------------------------------=! -! CARDS parameters -!=----------------------------------------------------------------------------=! -! -! Note: See file read_cards.f90 for card syntax and usage -! -! ATOMIC_SPECIES -! - CHARACTER(LEN=3) :: atom_label(nsx) = 'XX' ! label of the atomic species being read - CHARACTER(LEN=80) :: atom_pfile(nsx) = 'YY' ! pseudopotential file name - REAL(DP) :: atom_mass(nsx) = 0.0_DP ! atomic mass of the i-th atomic species - ! in atomic mass units: 1 a.m.u. = 1822.9 a.u. = 1.6605 * 10^-27 kg - LOGICAL :: taspc = .FALSE. - -! -! ATOMIC_POSITIONS -! - REAL(DP), ALLOCATABLE :: rd_pos(:,:) ! unsorted positions from input - INTEGER, ALLOCATABLE :: sp_pos(:) - INTEGER, ALLOCATABLE :: if_pos(:,:) - INTEGER, ALLOCATABLE :: id_loc(:) - INTEGER, ALLOCATABLE :: na_inp(:) - LOGICAL :: tapos = .FALSE. - CHARACTER(LEN=80) :: atomic_positions = 'crystal' - ! atomic_positions = 'bohr' | 'angstrong' | 'crystal' | 'alat' - ! select the units for the atomic positions being read from stdin - - ! - ! ... variable added for NEB ( C.S. 17/10/2003 ) - ! - REAL(DP), ALLOCATABLE :: pos(:,:) - ! -! -! ION_VELOCITIES -! - REAL(DP), ALLOCATABLE :: rd_vel(:,:) ! unsorted velocities from input - INTEGER, ALLOCATABLE :: sp_vel(:) - LOGICAL :: tavel = .FALSE. -! -! ATOMIC_FORCES -! - REAL(DP), ALLOCATABLE :: rd_for(:,:) ! external forces applied to single atoms - -! -! KPOINTS -! -! ... k-points inputs - LOGICAL :: tk_inp = .FALSE. - REAL(DP) :: xk(3,npk) = 0.0_DP, wk(npk) = 0.0_DP - INTEGER :: nkstot = 0, nk1 = 0, nk2 = 0, nk3 = 0, k1 = 0, k2 = 0, k3 = 0 - CHARACTER(LEN=80) :: k_points = 'gamma' - ! k_points = 'automatic' | 'crystal' | 'tpiba' | 'gamma'* - ! k_points = 'crystal_b' | 'tpiba_b' - ! select the k points mesh - ! 'automatic' k points mesh is generated automatically - ! with Monkhorst-Pack algorithm - ! 'crystal' k points mesh is given in stdin in scaled units - ! 'tpiba' k points mesh is given in stdin in units of ( 2 PI / alat ) - ! 'gamma' only gamma point is used ( default in CPMD simulation ) - ! _b means that a band input is given. The weights is a integer - ! number that gives the number of points between the present point - ! and the next. The weight of the last point is not used. -! -! NEWNFI -! - LOGICAL :: tnewnfi_card = .FALSE. - INTEGER :: newnfi_card = 0 - -! -! 2DPROCMESH -! - LOGICAL :: t2dpegrid_inp = .FALSE. - -! -! OCCUPATIONS -! - REAL(DP), ALLOCATABLE :: f_inp(:,:) - LOGICAL :: tf_inp = .FALSE. - -! -! VHMEAN -! -! ... card planar mean of the Hartree potential - LOGICAL :: tvhmean_inp = .FALSE. - INTEGER :: vhnr_inp = 0, vhiunit_inp = 0 - REAL(DP) :: vhrmin_inp = 0.0_dP, vhrmax_inp = 0.0_DP - CHARACTER :: vhasse_inp = 'X' - -! -! DIPOLE -! - LOGICAL :: tdipole_card = .FALSE. - -! -! ESR -! - INTEGER :: iesr_inp = 1 - -! -! NEIGHBOURS -! - LOGICAL :: tneighbo = .FALSE. - REAL(DP) :: neighbo_radius = 0.0_DP - -! -! CELL_PARAMETERS -! - REAL(DP) :: rd_ht(3,3) = 0.0_DP - CHARACTER(len=80) :: cell_symmetry = 'none' - CHARACTER(LEN=80) :: cell_units = 'alat' - LOGICAL :: trd_ht = .FALSE. - -! -! TURBO -! - LOGICAL :: tturbo_inp = .FALSE. - INTEGER :: nturbo_inp = 0 - -! -! CONSTRAINTS -! - INTEGER :: nc_fields = 4 ! max number of fields that is allowed to - ! define a constraint - - INTEGER :: nconstr_inp = 0 - REAL(DP) :: constr_tol_inp = 1.E-6_DP - ! - CHARACTER(LEN=20), ALLOCATABLE :: constr_type_inp(:) - REAL(DP), ALLOCATABLE :: constr_inp(:,:) - REAL(DP), ALLOCATABLE :: constr_target(:) - LOGICAL, ALLOCATABLE :: constr_target_set(:) - -! -! COLLECTIVE_VARS -! - INTEGER :: ncolvar_inp = 0 - REAL(DP) :: colvar_tol_inp = 1.E-6_DP - ! - CHARACTER(LEN=20), ALLOCATABLE :: colvar_type_inp(:) - REAL(DP), ALLOCATABLE :: colvar_inp(:,:) - REAL(DP), ALLOCATABLE :: colvar_target(:) - LOGICAL, ALLOCATABLE :: colvar_target_set(:) - -! -! KOHN_SHAM -! - INTEGER, ALLOCATABLE :: iprnks( :, : ) - INTEGER :: nprnks( nspinx ) = 0 - ! logical mask used to specify which kohn sham orbital should be - ! written to files 'KS.' - INTEGER, ALLOCATABLE :: iprnks_empty( :, : ) - INTEGER :: nprnks_empty( nspinx ) = 0 - ! logical mask used to specify which empty kohn sham orbital should be - ! written to files 'KS_EMP.' - -! -! CHI2 -! - LOGICAL :: tchi2_inp = .FALSE. - -! -! CLIMBING_IMAGES -! - ! - ! ... variable added for NEB ( C.S. 20/11/2003 ) - ! - LOGICAL, ALLOCATABLE :: climbing( : ) - -! -! PLOT_WANNIER -! - - INTEGER, PARAMETER :: nwf_max = 1000 - ! - INTEGER :: wannier_index( nwf_max ) - -! -! WANNIER_NEW -! - TYPE (wannier_data) :: wan_data(nwanx,2) - -! END manual -! ---------------------------------------------------------------------- - -CONTAINS - - SUBROUTINE allocate_input_ions( ntyp, nat ) - ! - INTEGER, INTENT(IN) :: ntyp, nat - ! - IF ( ALLOCATED( rd_pos ) ) DEALLOCATE( rd_pos ) - IF ( ALLOCATED( sp_pos ) ) DEALLOCATE( sp_pos ) - IF ( ALLOCATED( if_pos ) ) DEALLOCATE( if_pos ) - IF ( ALLOCATED( id_loc ) ) DEALLOCATE( id_loc ) - IF ( ALLOCATED( na_inp ) ) DEALLOCATE( na_inp ) - IF ( ALLOCATED( rd_vel ) ) DEALLOCATE( rd_vel ) - IF ( ALLOCATED( sp_vel ) ) DEALLOCATE( sp_vel ) - IF ( ALLOCATED( rd_for ) ) DEALLOCATE( rd_for ) - ! - ALLOCATE( rd_pos( 3, nat ) ) - ALLOCATE( sp_pos( nat) ) - ALLOCATE( if_pos( 3, nat ) ) - ALLOCATE( id_loc( nat) ) - ALLOCATE( na_inp( ntyp) ) - ALLOCATE( rd_vel( 3, nat ) ) - ALLOCATE( sp_vel( nat) ) - ALLOCATE( rd_for( 3, nat ) ) - ! - rd_pos = 0.0_DP - sp_pos = 0 - if_pos = 1 - id_loc = 0 - na_inp = 0 - rd_vel = 0.0_DP - sp_vel = 0 - rd_for = 0.0_DP - ! - RETURN - ! - END SUBROUTINE allocate_input_ions - - SUBROUTINE allocate_input_constr() - ! - IF ( ALLOCATED( constr_type_inp ) ) DEALLOCATE( constr_type_inp ) - IF ( ALLOCATED( constr_inp ) ) DEALLOCATE( constr_inp ) - IF ( ALLOCATED( constr_target ) ) DEALLOCATE( constr_target ) - IF ( ALLOCATED( constr_target_set ) ) DEALLOCATE( constr_target_set ) - ! - ALLOCATE( constr_type_inp( nconstr_inp ) ) - ALLOCATE( constr_target( nconstr_inp ) ) - ALLOCATE( constr_target_set( nconstr_inp ) ) - ! - ALLOCATE( constr_inp( nc_fields, nconstr_inp ) ) - ! - constr_type_inp = ' ' - constr_inp = 0.0_DP - constr_target = 0.0_DP - constr_target_set = .FALSE. - ! - RETURN - ! - END SUBROUTINE allocate_input_constr - - SUBROUTINE allocate_input_colvar() - ! - IF ( ALLOCATED( colvar_type_inp ) ) DEALLOCATE( colvar_type_inp ) - IF ( ALLOCATED( colvar_inp ) ) DEALLOCATE( colvar_inp ) - IF ( ALLOCATED( colvar_target ) ) DEALLOCATE( colvar_target ) - IF ( ALLOCATED( colvar_target_set ) ) DEALLOCATE( colvar_target_set ) - ! - ALLOCATE( colvar_type_inp( ncolvar_inp ) ) - ALLOCATE( colvar_target( ncolvar_inp ) ) - ALLOCATE( colvar_target_set( ncolvar_inp ) ) - ! - ALLOCATE( colvar_inp( nc_fields, ncolvar_inp ) ) - ! - colvar_type_inp = ' ' - colvar_inp = 0.0_DP - colvar_target = 0.0_DP - colvar_target_set = .FALSE. - ! - RETURN - ! - END SUBROUTINE allocate_input_colvar - ! - SUBROUTINE allocate_input_iprnks( nksx, nspin ) - ! - INTEGER, INTENT(IN) :: nksx, nspin - ! - IF( ALLOCATED( iprnks ) ) DEALLOCATE( iprnks ) - ! - ALLOCATE( iprnks( MAX( 1, nksx), nspin ) ) - ! - iprnks = 0 - ! - RETURN - ! - END SUBROUTINE allocate_input_iprnks - - SUBROUTINE allocate_input_iprnks_empty( nksx, nspin ) - ! - INTEGER, INTENT(IN) :: nksx, nspin - ! - IF( ALLOCATED( iprnks_empty ) ) DEALLOCATE( iprnks_empty ) - ! - ALLOCATE( iprnks_empty( MAX( 1, nksx), nspin ) ) - ! - iprnks_empty = 0 - ! - RETURN - ! - END SUBROUTINE allocate_input_iprnks_empty - - SUBROUTINE deallocate_input_parameters() - ! - IF ( ALLOCATED( rd_pos ) ) DEALLOCATE( rd_pos ) - IF ( ALLOCATED( sp_pos ) ) DEALLOCATE( sp_pos ) - IF ( ALLOCATED( if_pos ) ) DEALLOCATE( if_pos ) - IF ( ALLOCATED( id_loc ) ) DEALLOCATE( id_loc ) - IF ( ALLOCATED( na_inp ) ) DEALLOCATE( na_inp ) - IF ( ALLOCATED( rd_vel ) ) DEALLOCATE( rd_vel ) - IF ( ALLOCATED( sp_vel ) ) DEALLOCATE( sp_vel ) - IF ( ALLOCATED( rd_for ) ) DEALLOCATE( rd_for ) - ! - IF ( ALLOCATED( pos ) ) DEALLOCATE( pos ) - IF ( ALLOCATED( climbing ) ) DEALLOCATE( climbing ) - ! - IF ( ALLOCATED( constr_type_inp ) ) DEALLOCATE( constr_type_inp ) - IF ( ALLOCATED( constr_inp ) ) DEALLOCATE( constr_inp ) - IF ( ALLOCATED( constr_target ) ) DEALLOCATE( constr_target ) - IF ( ALLOCATED( constr_target_set ) ) DEALLOCATE( constr_target_set ) - ! - IF ( ALLOCATED( colvar_type_inp ) ) DEALLOCATE( colvar_type_inp ) - IF ( ALLOCATED( colvar_inp ) ) DEALLOCATE( colvar_inp ) - IF ( ALLOCATED( colvar_target ) ) DEALLOCATE( colvar_target ) - IF ( ALLOCATED( colvar_target_set ) ) DEALLOCATE( colvar_target_set ) - ! - IF ( ALLOCATED( iprnks ) ) DEALLOCATE( iprnks ) - IF ( ALLOCATED( iprnks_empty ) ) DEALLOCATE( iprnks_empty ) - ! - RETURN - ! - END SUBROUTINE deallocate_input_parameters - ! -!=----------------------------------------------------------------------------=! -! -END MODULE input_parameters -! -!=----------------------------------------------------------------------------=! diff --git a/quantum_espresso/kcp/Modules/io_files.f90 b/quantum_espresso/kcp/Modules/io_files.f90 deleted file mode 100644 index b2216944e..000000000 --- a/quantum_espresso/kcp/Modules/io_files.f90 +++ /dev/null @@ -1,256 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!=----------------------------------------------------------------------------=! -MODULE io_files -!=----------------------------------------------------------------------------=! - ! - USE parameters, ONLY: ntypx - ! - ! ... The name of the files - ! - IMPLICIT NONE - ! - SAVE - ! - CHARACTER(len=256) :: tmp_dir = './' ! directory for temporary files - CHARACTER(len=256) :: wfc_dir = 'undefined' ! directory for large files on each node, should be kept 'undefined' if not known - CHARACTER(len=256) :: prefix = 'os' ! prepended to file names - CHARACTER(len=6) :: nd_nmbr = '000000' ! node number (used only in parallel case) - CHARACTER(len=256) :: pseudo_dir = './' - CHARACTER(len=256) :: psfile( ntypx ) = 'UPF' - CHARACTER(len=256) :: scradir = './' - CHARACTER(len=256) :: outdir = './' - ! - CHARACTER(len=256) :: qexml_version = ' ' ! the format of the current qexml datafile - LOGICAL :: qexml_version_init = .FALSE. ! whether the fmt has been read or not - ! - CHARACTER(LEN=256) :: input_drho = ' ' ! name of the file with the input drho - CHARACTER(LEN=256) :: output_drho = ' ' ! name of the file with the output drho - ! - CHARACTER(LEN=256) :: band_file = ' ' - CHARACTER(LEN=256) :: tran_file = ' ' - CHARACTER(LEN=256) :: prefixt = ' ' - CHARACTER(LEN=256) :: prefixl = ' ' - CHARACTER(LEN=256) :: prefixs = ' ' - CHARACTER(LEN=256) :: prefixr = ' ' - CHARACTER(LEN=256) :: save_file = ' ' - CHARACTER(LEN=256) :: tran_prefix = ' ' ! prefix for restart directory - CHARACTER(LEN=12), PARAMETER :: tk_file = 'transmission' - CHARACTER(LEN=256) :: fil_loc = ' ' ! file with 2D eigenvectors and eigenvalues - CHARACTER(LEN=256) :: empty_file = ' ' - ! - CHARACTER(LEN=14), PARAMETER :: rho_name = 'CHARGE_DENSITY' - CHARACTER(LEN=17), PARAMETER :: rho_name_up = 'CHARGE_DENSITY.UP' - CHARACTER(LEN=19), PARAMETER :: rho_name_down = 'CHARGE_DENSITY.DOWN' - CHARACTER(LEN=14), PARAMETER :: rho_name_avg = 'CHARGE_AVERAGE' - ! - CHARACTER(LEN=4 ), PARAMETER :: chifile = 'CHI2' - CHARACTER(LEN=7 ), PARAMETER :: dielecfile = 'EPSILON' - ! - CHARACTER(LEN=5 ), PARAMETER :: crash_file = 'CRASH' - CHARACTER(LEN=7 ), PARAMETER :: stop_file = '.cpstop' - CHARACTER(LEN=2 ), PARAMETER :: ks_file = 'KS' - CHARACTER(LEN=6 ), PARAMETER :: ks_emp_file = 'KS_EMP' - CHARACTER(LEN=16), PARAMETER :: sfac_file = 'STRUCTURE_FACTOR' - CHARACTER (LEN=256) :: & - dat_file = 'os.dat', &! file containing the enegy profile - int_file = 'os.int', &! file containing the interpolated energy profile - path_file = 'os.path', &! file containing informations needed to restart a path simulation - xyz_file = 'os.xyz', &! file containing coordinates of all images in xyz format - axsf_file = 'os.axsf', &! file containing coordinates of all images in axsf format - broy_file = 'os.broyden' ! file containing broyden's history - CHARACTER (LEN=261) :: & - exit_file = "os.EXIT" ! file required for a soft exit - ! - CHARACTER (LEN=9), PARAMETER :: xmlpun_base = 'data-file' - CHARACTER (LEN=13), PARAMETER :: xmlpun = xmlpun_base // '.xml' - ! - ! ... The units where various variables are saved - ! - INTEGER :: rhounit = 17 - INTEGER :: emptyunit = 19 - ! - INTEGER :: emptyunitc0 = 119 ! by linh, unit for restart empty run - ! from evc0_empty - INTEGER :: emptyunitc0fixed = 129 ! by linh, unit for saving the - ! fixed ref. wfc in empty_run - ! - INTEGER :: crashunit = 15 - INTEGER :: stopunit = 7 - INTEGER :: ksunit = 18 - INTEGER :: sfacunit = 20 - INTEGER :: pseudounit = 10 - INTEGER :: chiunit = 20 - INTEGER :: dielecunit = 20 - INTEGER :: opt_unit = 20 ! optional unit - ! - ! ... units in pwscf - ! - INTEGER :: iunres = 1 ! unit for the restart of the run - INTEGER :: iunpun = 4 ! unit for saving the final results - INTEGER :: iunwfc = 10 ! unit with wavefunctions - INTEGER :: iunoldwfc = 11 ! unit with old wavefunctions - INTEGER :: iunoldwfc2 = 12 ! as above at step -2 - INTEGER :: iunat = 13 ! unit for saving (orthogonal) atomic wfcs - INTEGER :: iunsat = 14 ! unit for saving (orthogonal) atomic wfcs * S - INTEGER :: iunocc = 15 ! unit for saving the atomic n_{ij} - INTEGER :: iunigk = 16 ! unit for saving indices - INTEGER :: iunpaw = 17 ! unit for saving paw becsum and D_Hxc - ! - INTEGER :: iunexit = 26 ! unit for a soft exit - INTEGER :: iunupdate = 27 ! unit for saving old positions (extrapolation) - INTEGER :: iunnewimage = 28 ! unit for parallelization among images - INTEGER :: iunlock = 29 ! as above (locking file) - ! - INTEGER :: iunbfgs = 30 ! unit for the bfgs restart file - INTEGER :: iunatsicwfc = 31 ! unit for sic wfc - ! - INTEGER :: nwordwfc = 2 ! lenght of record in wavefunction file - INTEGER :: nwordatwfc = 2 ! lenght of record in atomic wfc file - INTEGER :: nwordwann = 2 ! lenght of record in sic wfc file - ! - ! ... "path" specific - ! - INTEGER :: iunpath = 6 ! unit for string output ( stdout or what else ) - INTEGER :: iunrestart = 21 ! unit for saving the restart file ( neb_file ) - INTEGER :: iundat = 22 ! unit for saving the enegy profile - INTEGER :: iunint = 23 ! unit for saving the interpolated energy profile - INTEGER :: iunxyz = 24 ! unit for saving coordinates ( xyz format ) - INTEGER :: iunaxsf = 25 ! unit for saving coordinates ( axsf format ) - INTEGER :: iunbroy = 26 ! unit for saving broyden's history - ! - ! ... meta-dynamics - ! - INTEGER :: iunmeta = 77 ! unit for saving meta-dynamics history - ! - ! ... Y. Kanai combined smd/cp method - ! - INTEGER :: smwout = 20 ! base value to compute index for replica files - ! - INTEGER :: vib_out = 20 ! output of phrozen phonon vibrational calculation - INTEGER :: vib_mass = 21 ! isotope masses used for the dynamical matrix - ! - !... finite electric field (Umari) - ! - INTEGER :: iunefield = 31 ! unit to store wavefunction for calculatin electric field operator - ! - INTEGER :: iunefieldm = 32 !unit to store projectors for hermitean electric field potential - ! - INTEGER :: iunefieldp = 33 !unit to store projectors for hermitean electric field potential - ! - ! ... Wannier - ! - INTEGER :: iunwpp = 113 - INTEGER :: iunwf = 114 - INTEGER :: nwordwpp = 2 - INTEGER :: nwordwf = 2 - -CONTAINS - ! - !----------------------------------------------------------------------- - FUNCTION trimcheck ( directory ) - !----------------------------------------------------------------------- - ! - ! ... verify if directory ends with /, add one if needed; - ! ... trim white spaces and put the result in trimcheck - ! - IMPLICIT NONE - ! - CHARACTER (LEN=*), INTENT(IN) :: directory - CHARACTER (LEN=256) :: trimcheck - INTEGER :: l - ! - l = LEN_TRIM( directory ) - IF ( l == 0 ) CALL errore( 'trimcheck', ' input name empty', 1) - ! - IF ( directory(l:l) == '/' ) THEN - trimcheck = TRIM ( directory) - ELSE - IF ( l < LEN( trimcheck ) ) THEN - trimcheck = TRIM ( directory ) // '/' - ELSE - CALL errore( 'trimcheck', ' input name too long', l ) - END IF - END IF - ! - RETURN - ! - END FUNCTION trimcheck - ! - !-------------------------------------------------------------------------- - FUNCTION find_free_unit() - !-------------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - INTEGER :: find_free_unit - INTEGER :: iunit - LOGICAL :: opnd - ! - ! - unit_loop: DO iunit = 99, 1, -1 - ! - INQUIRE( UNIT = iunit, OPENED = opnd ) - ! - IF ( .NOT. opnd ) THEN - ! - find_free_unit = iunit - ! - RETURN - ! - END IF - ! - END DO unit_loop - ! - CALL errore( 'find_free_unit()', 'free unit not found ?!?', 1 ) - ! - RETURN - ! - END FUNCTION find_free_unit - ! - !-------------------------------------------------------------------------- - SUBROUTINE delete_if_present( filename, in_warning ) - !-------------------------------------------------------------------------- - ! - USE io_global, ONLY : ionode, stdout - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(IN) :: filename - LOGICAL, OPTIONAL, INTENT(IN) :: in_warning - LOGICAL :: exst, warning - INTEGER :: iunit - ! - IF ( .NOT. ionode ) RETURN - ! - INQUIRE( FILE = filename, EXIST = exst ) - ! - IF ( exst ) THEN - ! - iunit = find_free_unit() - ! - warning = .FALSE. - ! - IF ( PRESENT( in_warning ) ) warning = in_warning - ! - OPEN( UNIT = iunit, FILE = filename , STATUS = 'OLD' ) - CLOSE( UNIT = iunit, STATUS = 'DELETE' ) - ! - IF ( warning ) & - WRITE( UNIT = stdout, FMT = '(/,5X,"WARNING: ",A, & - & " file was present; old file deleted")' ) filename - ! - END IF - ! - RETURN - ! - END SUBROUTINE delete_if_present - ! -!=----------------------------------------------------------------------------=! -END MODULE io_files -!=----------------------------------------------------------------------------=! diff --git a/quantum_espresso/kcp/Modules/io_global.f90 b/quantum_espresso/kcp/Modules/io_global.f90 deleted file mode 100644 index 0663f7117..000000000 --- a/quantum_espresso/kcp/Modules/io_global.f90 +++ /dev/null @@ -1,102 +0,0 @@ -! -! Copyright (C) 2002-2004 FPMD & PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE io_global - !---------------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - PRIVATE - SAVE - ! - PUBLIC :: io_global_start, io_global_getionode, io_global_getmeta - PUBLIC :: stdout, ionode, ionode_id, meta_ionode, meta_ionode_id - ! - INTEGER :: stdout = 6 ! unit connected to standard output - INTEGER :: ionode_id = 0 ! index of the i/o node - LOGICAL :: ionode = .TRUE. ! identifies the i/o node - INTEGER :: meta_ionode_id = 0 ! index of the i/o node for meta-codes - LOGICAL :: meta_ionode = .TRUE. ! identifies the i/o node for meta-codes - LOGICAL :: first = .TRUE. - ! - CONTAINS - ! - !----------------------------------------------------------------------- - SUBROUTINE io_global_start( mpime, ionode_set ) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: mpime, ionode_set - ! - ! - IF ( mpime == ionode_set ) THEN - ! - ionode = .TRUE. - meta_ionode = .TRUE. - ! - ELSE - ! - ionode = .FALSE. - meta_ionode = .FALSE. - ! - END IF - ! - ionode_id = ionode_set - meta_ionode_id = ionode_set - ! - first = .FALSE. - ! - RETURN - ! - END SUBROUTINE io_global_start - ! - ! - !----------------------------------------------------------------------- - SUBROUTINE io_global_getionode( ionode_out, ionode_id_out ) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(OUT) :: ionode_out - INTEGER, INTENT(OUT) :: ionode_id_out - ! - ! - IF ( first ) & - CALL errore( ' io_global_getionode ', ' ionode not yet defined ', 1 ) - ! - ionode_out = ionode - ionode_id_out = ionode_id - ! - RETURN - ! - END SUBROUTINE io_global_getionode - ! - ! - !----------------------------------------------------------------------- - SUBROUTINE io_global_getmeta( ionode_out, ionode_id_out ) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(OUT) :: ionode_out - INTEGER, INTENT(OUT) :: ionode_id_out - ! - ! - IF ( first ) & - CALL errore( ' io_global_getmeta ', ' meta_ionode not yet defined ', 1 ) - ! - ionode_out = meta_ionode - ionode_id_out = meta_ionode_id - ! - RETURN - ! - END SUBROUTINE io_global_getmeta - ! - ! -END MODULE io_global diff --git a/quantum_espresso/kcp/Modules/ions_base.f90 b/quantum_espresso/kcp/Modules/ions_base.f90 deleted file mode 100644 index 734441e25..000000000 --- a/quantum_espresso/kcp/Modules/ions_base.f90 +++ /dev/null @@ -1,876 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!------------------------------------------------------------------------------! - MODULE ions_base -!------------------------------------------------------------------------------! - - USE kinds, ONLY : DP - USE parameters, ONLY : ntypx -! - IMPLICIT NONE - SAVE - - ! nsp = number of species - ! na(is) = number of atoms of species is - ! nax = max number of atoms of a given species - ! nat = total number of atoms of all species - - INTEGER :: nsp = 0 - INTEGER :: na(ntypx) = 0 - INTEGER :: nax = 0 - INTEGER :: nat = 0 - - ! zv(is) = (pseudo-)atomic charge - ! pmass(is) = mass (converted to a.u.) of ions - ! rcmax(is) = Ewald radius (for ion-ion interactions) - - REAL(DP) :: zv(ntypx) = 0.0_DP - REAL(DP) :: pmass(ntypx) = 0.0_DP - REAL(DP) :: amass(ntypx) = 0.0_DP - REAL(DP) :: rcmax(ntypx) = 0.0_DP - - ! ityp( i ) = the type of i-th atom in stdin - ! atm( j ) = name of the type of the j-th atomic specie - ! tau( 1:3, i ) = position of the i-th atom - - INTEGER, ALLOCATABLE :: ityp(:) - REAL(DP), ALLOCATABLE :: tau(:,:) ! initial positions read from stdin (in bohr) - REAL(DP), ALLOCATABLE :: vel(:,:) ! initial velocities read from stdin (in bohr) - REAL(DP), ALLOCATABLE :: tau_srt(:,:) ! tau sorted by specie in bohr - REAL(DP), ALLOCATABLE :: vel_srt(:,:) ! vel sorted by specie in bohr - INTEGER, ALLOCATABLE :: ind_srt(:) ! index of tau sorted by specie - INTEGER, ALLOCATABLE :: ind_bck(:) ! reverse of ind_srt - CHARACTER(LEN=3) :: atm( ntypx ) - CHARACTER(LEN=3), ALLOCATABLE :: label_srt( : ) - CHARACTER(LEN=80) :: tau_units - - - INTEGER, ALLOCATABLE :: if_pos(:,:) ! if if_pos( x, i ) = 0 then x coordinate of - ! the i-th atom will be kept fixed - INTEGER, ALLOCATABLE :: iforce(:,:) ! if_pos sorted by specie - INTEGER :: fixatom = -1 ! to be removed - INTEGER :: ndofp = -1 ! ionic degree of freedom - INTEGER :: ndfrz = 0 ! frozen degrees of freedom - - REAL(DP) :: fricp ! friction parameter for damped dynamics - REAL(DP) :: greasp ! friction parameter for damped dynamics - - ! ... taui = real ionic positions in the center of mass reference - ! ... system at istep = 0 - ! ... this array is used to compute mean square displacements, - ! ... it is initialized when NBEG = -1, NBEG = 0 and TAURDR = .TRUE. - ! ... first index: x,y,z, second index: atom sortred by specie with respect input - ! ... this array is saved in the restart file - - REAL(DP), ALLOCATABLE :: taui(:,:) - - ! ... cdmi = center of mass reference system (related to the taui) - ! ... this vector is computed when NBEG = -1, NBEG = 0 and TAURDR = .TRUE. - ! ... this array is saved in the restart file - - REAL(DP) :: cdmi(3), cdm(3) - - ! ... cdms = center of mass computed for scaled positions (taus) - - REAL(DP) :: cdms(3) - ! - REAL(DP), ALLOCATABLE :: extfor(:,:) ! external forces on atoms - - LOGICAL :: tions_base_init = .FALSE. - LOGICAL, PRIVATE :: tdebug = .FALSE. - - - INTERFACE ions_vel - MODULE PROCEDURE ions_vel3, ions_vel2 - END INTERFACE - - -!------------------------------------------------------------------------------! - CONTAINS -!------------------------------------------------------------------------------! - - SUBROUTINE packtau( taup, tau, na, nsp ) - IMPLICIT NONE - REAL(DP), INTENT(OUT) :: taup( :, : ) - REAL(DP), INTENT(IN) :: tau( :, :, : ) - INTEGER, INTENT(IN) :: na( : ), nsp - INTEGER :: is, ia, isa - isa = 0 - DO is = 1, nsp - DO ia = 1, na( is ) - isa = isa + 1 - taup( :, isa ) = tau( :, ia, is ) - END DO - END DO - RETURN - END SUBROUTINE packtau - -!------------------------------------------------------------------------------! - - SUBROUTINE unpacktau( tau, taup, na, nsp ) - IMPLICIT NONE - REAL(DP), INTENT(IN) :: taup( :, : ) - REAL(DP), INTENT(OUT) :: tau( :, :, : ) - INTEGER, INTENT(IN) :: na( : ), nsp - INTEGER :: is, ia, isa - isa = 0 - DO is = 1, nsp - DO ia = 1, na( is ) - isa = isa + 1 - tau( :, ia, is ) = taup( :, isa ) - END DO - END DO - RETURN - END SUBROUTINE unpacktau - -!------------------------------------------------------------------------------! - - SUBROUTINE sort_tau( tausrt, isrt, tau, isp, nat, nsp ) - IMPLICIT NONE - REAL(DP), INTENT(OUT) :: tausrt( :, : ) - INTEGER, INTENT(OUT) :: isrt( : ) - REAL(DP), INTENT(IN) :: tau( :, : ) - INTEGER, INTENT(IN) :: nat, nsp, isp( : ) - INTEGER :: ina( nsp ), na( nsp ) - INTEGER :: is, ia - - ! ... count the atoms for each specie - na = 0 - DO ia = 1, nat - is = isp( ia ) - IF( is < 1 .OR. is > nsp ) & - CALL errore(' sorttau ', ' wrong species index for positions ', ia ) - na( is ) = na( is ) + 1 - END DO - - ! ... compute the index of the first atom in each specie - ina( 1 ) = 0 - DO is = 2, nsp - ina( is ) = ina( is - 1 ) + na( is - 1 ) - END DO - - ! ... sort the position according to atomic specie - na = 0 - DO ia = 1, nat - is = isp( ia ) - na( is ) = na( is ) + 1 - tausrt( :, na(is) + ina(is) ) = tau(:, ia ) - isrt ( na(is) + ina(is) ) = ia - END DO - RETURN - END SUBROUTINE sort_tau - -!------------------------------------------------------------------------------! - - SUBROUTINE unsort_tau( tau, tausrt, isrt, nat ) - IMPLICIT NONE - REAL(DP), INTENT(IN) :: tausrt( :, : ) - INTEGER, INTENT(IN) :: isrt( : ) - REAL(DP), INTENT(OUT) :: tau( :, : ) - INTEGER, INTENT(IN) :: nat - INTEGER :: isa, ia - DO isa = 1, nat - ia = isrt( isa ) - tau( :, ia ) = tausrt( :, isa ) - END DO - RETURN - END SUBROUTINE unsort_tau - - !------------------------------------------------------------------------- - SUBROUTINE ions_base_init( nsp_, nat_, na_, ityp_, tau_, vel_, amass_, & - atm_, if_pos_, tau_units_, alat_, a1_, a2_, & - a3_, rcmax_ , extfor_ ) - !------------------------------------------------------------------------- - ! - USE constants, ONLY: amu_au, bohr_radius_angs - USE io_global, ONLY: stdout - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nsp_, nat_, na_(:), ityp_(:) - REAL(DP), INTENT(IN) :: tau_(:,:) - REAL(DP), INTENT(IN) :: vel_(:,:) - REAL(DP), INTENT(IN) :: amass_(:) - CHARACTER(LEN=*), INTENT(IN) :: atm_(:) - CHARACTER(LEN=*), INTENT(IN) :: tau_units_ - INTEGER, INTENT(IN) :: if_pos_(:,:) - REAL(DP), INTENT(IN) :: alat_, a1_(3), a2_(3), a3_(3) - REAL(DP), INTENT(IN) :: rcmax_(:) - REAL(DP), INTENT(IN) :: extfor_(:,:) - ! - INTEGER :: i, ia, is - ! - ! - nsp = nsp_ - nat = nat_ - ! - IF ( nat < 1 ) & - CALL errore( 'ions_base_init ', 'nax out of range', 1 ) - IF ( nsp < 1 ) & - CALL errore( 'ions_base_init ', 'nsp out of range', 1 ) - IF ( nsp > SIZE( na ) ) & - CALL errore( 'ions_base_init ', & - & 'nsp too large, increase ntypx parameter ', 1 ) - ! - na(1:nsp) = na_(1:nsp) - nax = MAXVAL( na(1:nsp) ) - ! - atm(1:nsp) = atm_(1:nsp) - tau_units = TRIM( tau_units_ ) - ! - IF ( nat /= SUM( na(1:nsp) ) ) & - CALL errore( 'ions_base_init ','inconsistent nat and na ', 1 ) - ! - CALL deallocate_ions_base() - ! - ALLOCATE( ityp( nat ) ) - ALLOCATE( tau( 3, nat ) ) - ALLOCATE( vel( 3, nat ) ) - ALLOCATE( tau_srt( 3, nat ) ) - ALLOCATE( vel_srt( 3, nat ) ) - ALLOCATE( ind_srt( nat ) ) - ALLOCATE( ind_bck( nat ) ) - ALLOCATE( if_pos( 3, nat ) ) - ALLOCATE( iforce( 3, nat ) ) - ALLOCATE( taui( 3, nat ) ) - ALLOCATE( label_srt( nat ) ) - ALLOCATE( extfor( 3, nat ) ) - ! - ityp(1:nat) = ityp_(1:nat) - vel(:,1:nat) = vel_(:,1:nat) - if_pos(:,1:nat) = if_pos_(:,1:nat) - ! - ! ... radii, masses - ! - DO is = 1, nsp_ - ! - rcmax(is) = rcmax_(is) - ! - IF( rcmax(is) <= 0.0_DP ) & - CALL errore( 'ions_base_init ', 'invalid rcmax', is ) - ! - END DO - ! - SELECT CASE ( TRIM( tau_units ) ) - ! - ! ... convert input atomic positions to internally used format: - ! ... tau in atomic units - ! - CASE( 'alat' ) - ! - ! ... input atomic positions are divided by a0 - ! - tau(:,1:nat) = tau_(:,1:nat) * alat_ - vel(:,1:nat) = vel_(:,1:nat) * alat_ - ! - CASE( 'bohr' ) - ! - ! ... input atomic positions are in a.u.: do nothing - ! - tau(:,1:nat) = tau_(:,1:nat) - vel(:,1:nat) = vel_(:,1:nat) - ! - CASE( 'crystal' ) - ! - ! ... input atomic positions are in crystal axis ("scaled") - ! - DO ia = 1, nat - ! - DO i = 1, 3 - ! - tau(i,ia) = a1_(i) * tau_(1,ia) + & - a2_(i) * tau_(2,ia) + & - a3_(i) * tau_(3,ia) - ! - vel(i,ia) = a1_(i) * vel_(1,ia) + & - a2_(i) * vel_(2,ia) + & - a3_(i) * vel_(3,ia) - - END DO - ! - END DO - ! - CASE( 'angstrom' ) - ! - ! ... atomic positions in A - ! - tau(:,1:nat) = tau_(:,1:nat) / bohr_radius_angs - vel(:,1:nat) = vel_(:,1:nat) / bohr_radius_angs - ! - CASE DEFAULT - ! - CALL errore( 'ions_base_init',' tau_units = ' // & - & TRIM( tau_units ) // ' not implemented ', 1 ) - ! - END SELECT - ! - ! ... tau_srt : atomic species are ordered according to - ! ... the ATOMIC_SPECIES input card. Within each specie atoms are ordered - ! ... according to the ATOMIC_POSITIONS input card. - ! ... ind_srt : can be used to restore the original position - ! - CALL sort_tau( tau_srt, ind_srt, tau, ityp, nat, nsp ) - ! - vel_srt(:,:) = vel(:,ind_srt(:)) - ! - DO ia = 1, nat - ! - label_srt( ia ) = atm( ityp( ind_srt( ia ) ) ) - ! - END DO - ! - ! ... generate ind_bck from ind_srt (reverse sort list) - ! - DO ia = 1, nat - ! - ind_bck(ind_srt(ia)) = ia - ! - END DO - ! - DO ia = 1, nat - ! - extfor( :, ia ) = extfor_( :, ind_srt( ia ) ) - ! - END DO - ! - IF( tdebug ) THEN - WRITE( stdout, * ) 'ions_base_init: unsorted position and velocities' - DO ia = 1, nat - WRITE( stdout, fmt="(A3,3D12.4,3X,3D12.4)") & - atm( ityp( ia ) ), tau(1:3, ia), vel(1:3,ia) - END DO - WRITE( stdout, * ) 'ions_base_init: sorted position and velocities' - DO ia = 1, nat - WRITE( stdout, fmt="(A3,3D12.4,3X,3D12.4)") & - atm( ityp( ind_srt( ia ) ) ), tau_srt(1:3, ia), vel_srt(1:3,ia) - END DO - END IF - ! - ! ... The constrain on fixed coordinates is implemented using the array - ! ... if_pos whose value is 0 when the coordinate is to be kept fixed, 1 - ! ... otherwise. fixatom is maintained for compatibility. ( C.S. 15/10/2003 ) - ! - if_pos = 1 - if_pos(:,:) = if_pos_(:,1:nat) - ! - iforce = 0 - ! - iforce(:,:) = if_pos(:,ind_srt(:)) - ! - ndofp = COUNT( iforce /= 0 ) - ! - ndfrz = COUNT( iforce == 0 ) - ! - ! ... TEMP: calculate fixatom (to be removed) - ! - fixatom = 0 - ! - DO ia = 1, nat - ! - IF ( if_pos(1,ia) /= 0 .OR. & - if_pos(2,ia) /= 0 .OR. & - if_pos(3,ia) /= 0 ) CYCLE - ! - fixatom = fixatom + 1 - ! - END DO - ! - amass(1:nsp) = amass_(1:nsp) - ! - IF ( ANY( amass(1:nsp) <= 0.0_DP ) ) & - CALL errore( 'ions_base_init ', 'invalid mass', 1 ) - ! - pmass(1:nsp) = amass_(1:nsp) * amu_au - ! - CALL ions_cofmass( tau_srt, pmass, na, nsp, cdmi ) - ! - DO ia = 1, nat - ! - taui(1:3,ia) = tau_srt(1:3,ia) - cdmi(1:3) - ! - END DO - ! - tions_base_init = .TRUE. - ! - RETURN - ! - END SUBROUTINE ions_base_init - ! - !------------------------------------------------------------------------- - SUBROUTINE deallocate_ions_base() - !------------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - IF ( ALLOCATED( ityp ) ) DEALLOCATE( ityp ) - IF ( ALLOCATED( tau ) ) DEALLOCATE( tau ) - IF ( ALLOCATED( vel ) ) DEALLOCATE( vel ) - IF ( ALLOCATED( tau_srt ) ) DEALLOCATE( tau_srt ) - IF ( ALLOCATED( vel_srt ) ) DEALLOCATE( vel_srt ) - IF ( ALLOCATED( ind_srt ) ) DEALLOCATE( ind_srt ) - IF ( ALLOCATED( ind_bck ) ) DEALLOCATE( ind_bck ) - IF ( ALLOCATED( if_pos ) ) DEALLOCATE( if_pos ) - IF ( ALLOCATED( iforce ) ) DEALLOCATE( iforce ) - IF ( ALLOCATED( taui ) ) DEALLOCATE( taui ) - IF ( ALLOCATED( label_srt ) ) DEALLOCATE( label_srt ) - IF ( ALLOCATED( extfor ) ) DEALLOCATE( extfor ) - ! - tions_base_init = .FALSE. - ! - RETURN - ! - END SUBROUTINE deallocate_ions_base - ! - !------------------------------------------------------------------------- - SUBROUTINE ions_vel3( vel, taup, taum, na, nsp, dt ) - !------------------------------------------------------------------------- - USE constants, ONLY : eps8 - IMPLICIT NONE - REAL(DP) :: vel(:,:), taup(:,:), taum(:,:) - INTEGER :: na(:), nsp - REAL(DP) :: dt - INTEGER :: ia, is, i, isa - REAL(DP) :: fac - IF( dt < eps8 ) & - CALL errore( ' ions_vel3 ', ' dt <= 0 ', 1 ) - fac = 1.0_DP / ( dt * 2.0_DP ) - isa = 0 - DO is = 1, nsp - DO ia = 1, na(is) - isa = isa + 1 - DO i = 1, 3 - vel(i,isa) = ( taup(i,isa) - taum(i,isa) ) * fac - END DO - END DO - END DO - RETURN - END SUBROUTINE ions_vel3 - -!------------------------------------------------------------------------------! - - SUBROUTINE ions_vel2( vel, taup, taum, nat, dt ) - USE constants, ONLY : eps8 - IMPLICIT NONE - REAL(DP) :: vel(:,:), taup(:,:), taum(:,:) - INTEGER :: nat - REAL(DP) :: dt - INTEGER :: ia, i - REAL(DP) :: fac - IF( dt < eps8 ) & - CALL errore( ' ions_vel3 ', ' dt <= 0 ', 1 ) - fac = 1.0_DP / ( dt * 2.0_DP ) - DO ia = 1, nat - DO i = 1, 3 - vel(i,ia) = ( taup(i,ia) - taum(i,ia) ) * fac - END DO - END DO - RETURN - END SUBROUTINE ions_vel2 - -!------------------------------------------------------------------------------! - - SUBROUTINE ions_cofmass( tau, pmass, na, nsp, cdm ) - USE constants, ONLY : eps8 - IMPLICIT NONE - REAL(DP), INTENT(IN) :: tau(:,:), pmass(:) - REAL(DP), INTENT(OUT) :: cdm(3) - INTEGER, INTENT(IN) :: na(:), nsp - - REAL(DP) :: tmas - INTEGER :: is, i, ia, isa -! - tmas=0.0_DP - do is=1,nsp - tmas=tmas+na(is)*pmass(is) - end do - - if( tmas < eps8 ) & - call errore(' ions_cofmass ', ' total mass <= 0 ', 1 ) -! - do i=1,3 - cdm(i)=0.0_DP - isa = 0 - do is=1,nsp - do ia=1,na(is) - isa = isa + 1 - cdm(i)=cdm(i)+tau(i,isa)*pmass(is) - end do - end do - cdm(i)=cdm(i)/tmas - end do -! - RETURN - END SUBROUTINE ions_cofmass - -!------------------------------------------------------------------------------! - - SUBROUTINE randpos(tau, na, nsp, tranp, amprp, hinv, ifor ) - - USE cell_base, ONLY: r_to_s - USE io_global, ONLY: stdout - USE random_numbers, ONLY: randy - - IMPLICIT NONE - REAL(DP) :: hinv(3,3) - REAL(DP) :: tau(:,:) - INTEGER, INTENT(IN) :: ifor(:,:), na(:), nsp - LOGICAL, INTENT(IN) :: tranp(:) - REAL(DP), INTENT(IN) :: amprp(:) - REAL(DP) :: oldp(3), rand_disp(3), rdisp(3) - INTEGER :: k, is, isa, isa_s, isa_e, isat - - WRITE( stdout, 600 ) - - isat = 0 - DO is = 1, nsp - isa_s = isat + 1 - isa_e = isat + na(is) - IF( tranp(is) ) THEN - WRITE( stdout,610) is, na(is) - WRITE( stdout,615) - DO isa = isa_s, isa_e - oldp = tau(:,isa) - rand_disp = randy () - rand_disp = amprp(is) * ( rand_disp - 0.5_DP ) - rdisp = rand_disp - CALL r_to_s( rdisp(:), rand_disp(:), hinv ) - DO k = 1, 3 - tau(k,isa) = tau(k,isa) + rand_disp(k) * ifor(k,isa) - END DO - WRITE( stdout,620) (oldp(k),k=1,3), (tau(k,isa),k=1,3) - END DO - END IF - isat = isat + na(is) - END DO - - 600 FORMAT(//,3X,'Randomization of SCALED ionic coordinates') - 610 FORMAT( 3X,'Species ',I3,' atoms = ',I4) - 615 FORMAT( 3X,' Old Positions New Positions') - 620 FORMAT( 3X,3F10.6,2X,3F10.6) - RETURN - END SUBROUTINE randpos - -!------------------------------------------------------------------------------! - - SUBROUTINE ions_kinene( ekinp, vels, na, nsp, h, pmass ) - IMPLICIT NONE - REAL(DP), intent(out) :: ekinp ! ionic kinetic energy - REAL(DP), intent(in) :: vels(:,:) ! scaled ionic velocities - REAL(DP), intent(in) :: pmass(:) ! ionic masses - REAL(DP), intent(in) :: h(:,:) ! simulation cell - integer, intent(in) :: na(:), nsp - integer :: i, j, is, ia, ii, isa - ekinp = 0.0_DP - isa = 0 - do is=1,nsp - do ia=1,na(is) - isa = isa + 1 - do j=1,3 - do i=1,3 - do ii=1,3 - ekinp=ekinp+pmass(is)* h(j,i)*vels(i,isa)* h(j,ii)*vels(ii,isa) - end do - end do - end do - end do - end do - ekinp=0.5_DP*ekinp - return - END SUBROUTINE ions_kinene - -!------------------------------------------------------------------------------! - - subroutine ions_temp( tempp, temps, ekinpr, vels, na, nsp, h, pmass, ndega, nhpdim, atm2nhp, ekin2nhp ) - ! - use constants, only: k_boltzmann_au - ! - implicit none - ! - REAL(DP), intent(out) :: ekinpr, tempp - REAL(DP), intent(out) :: temps(:) - REAL(DP), intent(out) :: ekin2nhp(:) - REAL(DP), intent(in) :: vels(:,:) - REAL(DP), intent(in) :: pmass(:) - REAL(DP), intent(in) :: h(:,:) - integer, intent(in) :: na(:), nsp, ndega, nhpdim, atm2nhp(:) - ! - integer :: nat, i, j, is, ia, ii, isa - REAL(DP) :: cdmvel(3), eks, eks1 - ! - call ions_cofmass( vels, pmass, na, nsp, cdmvel ) - ! - nat = SUM( na(1:nsp) ) - ! - ekinpr = 0.0_DP - temps( 1:nsp ) = 0.0_DP - ekin2nhp(1:nhpdim) = 0.0_DP - ! - do i=1,3 - do j=1,3 - do ii=1,3 - isa = 0 - do is=1,nsp - eks = 0.0_DP - do ia=1,na(is) - isa = isa + 1 - eks1 = pmass(is)*h(j,i)*(vels(i,isa)-cdmvel(i))*h(j,ii)*(vels(ii,isa)-cdmvel(ii)) - eks=eks+eks1 - ekin2nhp(atm2nhp(isa)) = ekin2nhp(atm2nhp(isa)) + eks1 - end do - ekinpr = ekinpr + eks - temps(is) = temps(is) + eks - end do - end do - end do - end do - ! - do is = 1, nhpdim - ekin2nhp(is) = ekin2nhp(is) * 0.5_DP - enddo - ! - ! - do is = 1, nsp - if( na(is) < 1 ) call errore(' ions_temp ', ' 0 number of atoms ', 1 ) - temps( is ) = temps( is ) * 0.5_DP - temps( is ) = temps( is ) / k_boltzmann_au / ( 1.5_DP * na(is) ) - end do - ! - ekinpr = 0.5_DP * ekinpr - ! - IF( ndega < 1 ) THEN - tempp = 0.0_DP - ELSE - tempp = ekinpr / k_boltzmann_au * 2.0_DP / DBLE( ndega ) - END IF - ! - return - end subroutine ions_temp - -!------------------------------------------------------------------------------! - - subroutine ions_thermal_stress( stress, pmass, omega, h, vels, nsp, na ) - USE constants, ONLY : eps8 - REAL(DP), intent(inout) :: stress(3,3) - REAL(DP), intent(in) :: pmass(:), omega, h(3,3), vels(:,:) - integer, intent(in) :: nsp, na(:) - integer :: i, j, is, ia, isa - isa = 0 - if( omega < eps8 ) call errore(' ions_thermal_stress ', ' omega <= 0 ', 1 ) - do is = 1, nsp - do ia = 1, na(is) - isa = isa + 1 - do i = 1, 3 - do j = 1, 3 - stress(i,j) = stress(i,j) + pmass(is) / omega * & - & ( (h(i,1)*vels(1,isa)+h(i,2)*vels(2,isa)+h(i,3)*vels(3,isa)) * & - (h(j,1)*vels(1,isa)+h(j,2)*vels(2,isa)+h(j,3)*vels(3,isa)) ) - enddo - enddo - enddo - enddo - return - end subroutine ions_thermal_stress - -!------------------------------------------------------------------------------! - - subroutine ions_vrescal( tcap, tempw, tempp, taup, tau0, taum, na, nsp, fion, iforce, & - pmass, delt ) - use constants, only: pi, k_boltzmann_au, eps8 - USE random_numbers, ONLY : randy - implicit none - logical, intent(in) :: tcap - REAL(DP), intent(inout) :: taup(:,:) - REAL(DP), intent(in) :: tau0(:,:), taum(:,:), fion(:,:) - REAL(DP), intent(in) :: delt, pmass(:), tempw, tempp - integer, intent(in) :: na(:), nsp - integer, intent(in) :: iforce(:,:) - - REAL(DP) :: alfap, qr(3), alfar, gausp - REAL(DP) :: dt2by2 - integer :: i, ia, is, nat, isa - - dt2by2 = 0.5_DP * delt * delt - gausp = delt * sqrt( tempw * k_boltzmann_au ) - nat = SUM( na( 1:nsp ) ) - - if(.not.tcap) then - if( tempp < eps8 ) call errore(' ions_vrescal ', ' tempp <= 0 ', 1 ) - alfap = 0.5_DP * sqrt(tempw/tempp) - isa = 0 - do is=1,nsp - do ia=1,na(is) - isa = isa + 1 - do i=1,3 - taup(i,isa) = tau0(i,isa) + & - & alfap*(taup(i,isa)-taum(i,isa)) + & - & dt2by2/pmass(is)*fion(i,isa)*iforce(i,isa) - end do - end do - end do - else - do i=1,3 - qr(i)=0.0_DP - isa = 0 - do is=1,nsp - do ia=1,na(is) - isa = isa + 1 - alfar=gausp/sqrt(pmass(is))*cos(2.0_DP*pi*randy())*sqrt(-2.0_DP*log(randy())) - taup(i,isa)=alfar - qr(i)=qr(i)+alfar - end do - end do - qr(i)=qr(i)/nat - end do - isa = 0 - do is=1,nsp - do ia=1,na(is) - isa = isa + 1 - do i=1,3 - alfar=taup(i,isa)-qr(i) - taup(i,isa)=tau0(i,isa)+iforce(i,isa)* & - & (alfar+dt2by2/pmass(is)*fion(i,isa)) - end do - end do - end do - end if - return - end subroutine ions_vrescal - -!------------------------------------------------------------------------------! - - subroutine ions_shiftvar( varp, var0, varm ) - implicit none - REAL(DP), intent(in) :: varp(:,:) - REAL(DP), intent(out) :: varm(:,:), var0(:,:) - varm = var0 - var0 = varp - return - end subroutine ions_shiftvar - -!------------------------------------------------------------------------------! - - SUBROUTINE ions_reference_positions( tau ) - - ! Calculate the real position of atoms relative to the center of mass (cdm) - ! and store them in taui - ! cdmi: initial position of the center of mass (cdm) in cartesian coor. - - IMPLICIT NONE - - REAL(DP) :: tau( :, : ) - - INTEGER :: isa - - CALL ions_cofmass( tau, pmass, na, nsp, cdmi ) - DO isa = 1, nat - taui(:,isa) = tau(:,isa) - cdmi(:) - END DO - - RETURN - END SUBROUTINE ions_reference_positions - - -!------------------------------------------------------------------------------! - - - SUBROUTINE ions_displacement( dis, tau ) - - ! Calculate the sum of the quadratic displacements of the atoms in the ref. - ! of cdm respect to the initial positions. - ! taui: initial positions in real units in the ref. of cdm - - ! ---------------------------------------------- - ! att! tau_ref: starting position in center-of-mass ref. in real units - ! ---------------------------------------------- - - IMPLICIT NONE - - REAL (DP), INTENT(OUT) :: dis(:) - REAL (DP), INTENT(IN) :: tau(:,:) - - REAL(DP) :: rdist(3), r2, cdm(3) - INTEGER :: is, ia, isa - - ! ... Compute the current value of cdm "Centro Di Massa" - ! - CALL ions_cofmass(tau, pmass, na, nsp, cdm ) - ! - IF( SIZE( dis ) < nsp ) & - CALL errore(' displacement ',' size of dis too small ', 1) - isa = 0 - DO is = 1, nsp - dis(is) = 0.0_DP - r2 = 0.0_DP - DO ia = 1, na(is) - isa = isa + 1 - rdist = tau(:,isa) - cdm - r2 = r2 + SUM( ( rdist(:) - taui(:,isa) )**2 ) - END DO - dis(is) = dis(is) + r2 / DBLE(na(is)) - END DO - - RETURN - END SUBROUTINE ions_displacement - - !-------------------------------------------------------------------------- - SUBROUTINE ions_cofmsub( tausp, iforce, nat, cdm, cdm0 ) - !-------------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(INOUT) :: tausp(:,:) - INTEGER, INTENT(IN) :: iforce(:,:) - INTEGER, INTENT(IN) :: nat - REAL(DP), INTENT(IN) :: cdm(:), cdm0(:) - ! - INTEGER :: i, ia - ! - DO ia = 1, nat - ! - DO i = 1, 3 - ! - tausp(i,ia) = tausp(i,ia) + DBLE( iforce(i,ia) ) * ( cdm0(i) - cdm(i) ) - ! - END DO - ! - END DO - ! - RETURN - ! - END SUBROUTINE ions_cofmsub - - - REAL(DP) FUNCTION compute_eextfor( tau0 ) - IMPLICIT NONE - REAL(DP), OPTIONAL, INTENT(IN) :: tau0(:,:) - INTEGER :: i - REAL(DP) :: e - compute_eextfor = 0.0d0 - e = 0.0d0 - IF( PRESENT( tau0 ) ) THEN - DO i = 1, SIZE( extfor,2 ) - e = e + extfor( 3, i ) * tau0( 3, i ) & - + extfor( 2, i ) * tau0( 2, i ) & - + extfor( 1, i ) * tau0( 1, i ) - END DO - ELSE - DO i = 1, SIZE( extfor,2 ) - e = e + extfor( 3, i ) * tau( 3, i ) & - + extfor( 2, i ) * tau( 2, i ) & - + extfor( 1, i ) * tau( 1, i ) - END DO - END IF - compute_eextfor = - e - RETURN - END FUNCTION compute_eextfor - - - -!------------------------------------------------------------------------------! - END MODULE ions_base -!------------------------------------------------------------------------------! diff --git a/quantum_espresso/kcp/Modules/ions_nose.f90 b/quantum_espresso/kcp/Modules/ions_nose.f90 deleted file mode 100644 index b276a3205..000000000 --- a/quantum_espresso/kcp/Modules/ions_nose.f90 +++ /dev/null @@ -1,473 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!------------------------------------------------------------------------------! - MODULE ions_nose -!------------------------------------------------------------------------------! - - USE kinds, ONLY: DP -! - IMPLICIT NONE -! Some comments are in order on how Nose-Hoover chains work here (K.N. Kudin) -! the present code allows one to use "massive" Nose-Hoover chains: -! TOBIAS DJ, MARTYNA GJ, KLEIN ML -! JOURNAL OF PHYSICAL CHEMISTRY 97 (49): 12959-12966 DEC 9 1993 -! -! one chain for the whole system is specified by nhptyp=0 (or nothing) -! currently input options allow one chain per atomic type (nhptyp=1), -! one chain per atom (nhptyp=2), and fancy stuff with nhptyp=3 (& nhgrp) -! -! nhpdim is the total number of the resulting NH chains -! nhpend is 1 if there is a chain above all chains, otherwise it is 0 -! nhpbeg is usually 0, however, if using groups (nhptyp = 3), it might -! be desirable to have atoms with uncontrolled temperature, so then -! nhpbeg becomes 1, and all the "uncontrolled" atoms are assigned to the -! 1st thermostat that is always zero in velocity and so it does not -! affect ionic motion -! array atm2nhp(1:nat) gives the chain number from the atom list (which -! is sorted by type) -! anum2nhp is the number of degrees of freedom per chain (now just 3*nat_i) -! ekin2nhp is the kinetic energy of the present chain -! gkbt2nhp are the NH chain parameters -! qnp are the chain masses, qnp_ is a temporary array for now -! see subroutine ions_nose_allocate on what are the dimensions of these -! variables -! - INTEGER :: nhpcl=1, ndega, nhpdim=1, nhptyp=0, nhpbeg=0, nhpend=0 - INTEGER, ALLOCATABLE :: atm2nhp(:) - INTEGER, ALLOCATABLE :: anum2nhp(:) - REAL(DP), ALLOCATABLE :: vnhp(:), xnhp0(:), xnhpm(:), xnhpp(:), & - ekin2nhp(:), gkbt2nhp(:), scal2nhp(:), qnp(:), qnp_(:), fnosep(:) - - REAL(DP) :: gkbt = 0.0_DP - REAL(DP) :: kbt = 0.0_DP - REAL(DP) :: tempw = 0.0_DP - -!------------------------------------------------------------------------------! - CONTAINS -!------------------------------------------------------------------------------! - - subroutine ions_nose_init( tempw_ , fnosep_ , nhpcl_ , nhptyp_ , ndega_ , nhgrp_ , fnhscl_) - use constants, only: k_boltzmann_au, pi, au_terahertz - use control_flags, only: tnosep - use ions_base, only: ndofp, tions_base_init, nsp, nat, na - real(DP), intent(in) :: tempw_ , fnosep_(:), fnhscl_(:) - integer, intent(in) :: nhpcl_ , nhptyp_ , ndega_ , nhgrp_(:) - integer :: i, j, iat, is, ia - - IF( .NOT. tions_base_init ) & - CALL errore(' ions_nose_init ', ' you should call ions_base_init first ', 1 ) - ! - tempw = tempw_ - ! - IF( ALLOCATED( atm2nhp ) ) DEALLOCATE( atm2nhp ) - ALLOCATE( atm2nhp( nat ) ) - ! - atm2nhp(1:nat) = 1 - ! - if (tnosep) then - nhpcl = MAX( nhpcl_ , 1 ) - if (abs(nhptyp_).eq.1) then - nhptyp = 1 - if (nhptyp_.gt.0) nhpend = 1 - nhpdim = nsp - iat = 0 - do is=1,nsp - do ia=1,na(is) - iat = iat+1 - atm2nhp(iat) = is - enddo - enddo - elseif (abs(nhptyp_).eq.2) then - nhptyp = 2 - if (nhptyp_.gt.0) nhpend = 1 - nhpdim = nat - do i=1,nat - atm2nhp(i) = i - enddo - elseif (abs(nhptyp_).eq.3) then - nhptyp = 3 - if (nhptyp_.gt.0) nhpend = 1 - call set_atmnhp(nhgrp_,atm2nhp,nhpdim,nhpbeg) - endif - ! Add one more chain on top if needed - nhpdim = nhpdim + nhpend - - endif - ! - CALL ions_nose_allocate() - ! - ! Setup Nose-Hoover chain masses - ! - if ( ndega_ > 0 ) then - ndega = ndega_ - else if ( ndega_ < 0 ) then - ndega = ndofp - ( - ndega_ ) - else - ndega = ndofp - endif - - ! there is no need to initialize any Nose variables except for nhpcl - ! and ndega if the thermostat is not used - ! - - IF( tnosep ) THEN - - IF( nhpcl > SIZE( fnosep_ ) ) & - CALL errore(' ions_nose_init ', ' fnosep size too small ', nhpcl ) - - ! count the number of atoms per thermostat and set the value - anum2nhp = 0 - iat = 0 - ! Here we shall check if the scaling factors are provided - If (maxval(fnhscl_(1:nsp)).lt.0.0d0) then - scal2nhp = DBLE(ndega)/DBLE(3*nat) - else - scal2nhp = -1.0_DP - endif - ! - do is=1,nsp - do ia=1,na(is) - iat = iat+1 - anum2nhp(atm2nhp(iat)) = anum2nhp(atm2nhp(iat)) + 3 - if (scal2nhp(atm2nhp(iat)).lt.0.0_DP) & - scal2nhp(atm2nhp(iat)) = fnhscl_(is) - enddo - enddo - if (nhpend.eq.1) anum2nhp(nhpdim) = nhpdim - 1 - nhpbeg - ! set gkbt2nhp for each thermostat - do is=1,nhpdim - gkbt2nhp(is) = DBLE(anum2nhp(is)) * tempw * k_boltzmann_au - enddo - ! scale the target energy by some factor convering 3*nat to ndega - if (nhpdim.gt.1) then - do is=1,(nhpdim-nhpend) - if (scal2nhp(is).lt.0.0_DP) scal2nhp(is) = 1.0_DP - gkbt2nhp(is) = gkbt2nhp(is)*scal2nhp(is) - enddo - endif - ! - gkbt = DBLE( ndega ) * tempw * k_boltzmann_au - if (nhpdim.eq.1) gkbt2nhp(1) = gkbt - kbt = tempw * k_boltzmann_au - - fnosep(1) = fnosep_ (1) - if( fnosep(1) > 0.0_DP ) then - qnp_(1) = 2.0_DP * gkbt / ( fnosep(1) * ( 2.0_DP * pi ) * au_terahertz )**2 - end if - - if ( nhpcl > 1 ) then - do i = 2, nhpcl - fnosep(i) = fnosep_ (i) - if( fnosep(i) > 0.0_DP ) then - qnp_(i) = 2.0_DP * tempw * k_boltzmann_au / & - ( fnosep(i) * ( 2.0_DP * pi ) * au_terahertz )**2 - else - qnp_(i) = qnp_(1) / DBLE(ndega) - endif - enddo - endif - ! set the NH masses for all the chains - do j=1,nhpdim - qnp((j-1)*nhpcl+1) = qnp_(1)*gkbt2nhp(j)/gkbt - If (nhpcl > 1) then - do i=2,nhpcl - qnp((j-1)*nhpcl+i) = qnp_(i) - enddo - endif - enddo - END IF - - - ! WRITE( stdout,100) - ! WRITE( stdout,110) QNOSEP,TEMPW - ! WRITE( stdout,120) GLIB - ! WRITE( stdout,130) NSVAR - 100 FORMAT(//' * Temperature control of ions with nose thermostat'/) - 110 FORMAT(3X,'nose mass:',F12.4,' temperature (K):',F12.4) - 120 FORMAT(3X,'ionic degrees of freedom: ',F5.0) - 130 FORMAT(3X,'time steps per nose oscillation: ',I5,//) - - return - end subroutine ions_nose_init - - subroutine set_atmnhp(nhgrp,atm2nhp,nhpdim,nhpbeg) - ! - use ions_base, only: nsp, nat, na - IMPLICIT NONE - integer, intent(in) :: nhgrp(:) - integer, intent(out) :: nhpdim, nhpbeg, atm2nhp(:) - ! - integer :: i,iat,is,ia,igrpmax,ith - INTEGER, ALLOCATABLE :: indtmp(:) - ! - ! find maximum group - igrpmax = max(maxval(nhgrp(1:nsp)),1) - ! find out which groups are assigned (assuming gaps) - allocate(indtmp(igrpmax)) - indtmp=0 - do is=1,nsp - if (nhgrp(is).gt.0) indtmp(nhgrp(is)) = 1 - enddo - ! assign thermostat index to requested groups - ith = 0 - ! make the 1st thermostat idle if there are negative groups - if (minval(nhgrp(1:nsp)).lt.0) ith = 1 - nhpbeg = ith - ! - do i=1,igrpmax - if (indtmp(i).gt.0) then - ith = ith + 1 - indtmp(i) = ith - endif - enddo - ! assign thermostats to atoms depending on what is requested - iat = 0 - do is=1,nsp - do ia=1,na(is) - iat = iat+1 - if (nhgrp(is).gt.0) then - atm2nhp(iat) = indtmp(nhgrp(is)) - elseif (nhgrp(is).eq.0) then - ith = ith + 1 - atm2nhp(iat) = ith - else - atm2nhp(iat) = 1 - endif - enddo - enddo - nhpdim = ith - deallocate(indtmp) - return - ! - end subroutine set_atmnhp - - SUBROUTINE ions_nose_allocate() - ! - IMPLICIT NONE - ! - IF ( .NOT. ALLOCATED( vnhp ) ) ALLOCATE( vnhp( nhpcl*nhpdim ) ) - IF ( .NOT. ALLOCATED( xnhp0 ) ) ALLOCATE( xnhp0( nhpcl*nhpdim ) ) - IF ( .NOT. ALLOCATED( xnhpm ) ) ALLOCATE( xnhpm( nhpcl*nhpdim ) ) - IF ( .NOT. ALLOCATED( xnhpp ) ) ALLOCATE( xnhpp( nhpcl*nhpdim ) ) - IF ( .NOT. ALLOCATED( ekin2nhp ) ) ALLOCATE( ekin2nhp( nhpdim ) ) - IF ( .NOT. ALLOCATED( gkbt2nhp ) ) ALLOCATE( gkbt2nhp( nhpdim ) ) - IF ( .NOT. ALLOCATED( scal2nhp ) ) ALLOCATE( scal2nhp( nhpdim ) ) - IF ( .NOT. ALLOCATED( anum2nhp ) ) ALLOCATE( anum2nhp( nhpdim ) ) - IF ( .NOT. ALLOCATED( qnp ) ) ALLOCATE( qnp( nhpcl*nhpdim ) ) - IF ( .NOT. ALLOCATED( qnp_ ) ) ALLOCATE( qnp_( nhpcl ) ) - IF ( .NOT. ALLOCATED( fnosep ) ) ALLOCATE( fnosep( nhpcl ) ) - ! - vnhp = 0.0_DP - xnhp0 = 0.0_DP - xnhpm = 0.0_DP - xnhpp = 0.0_DP - qnp = 0.0_DP - qnp_ = 0.0_DP - ! - RETURN - ! - END SUBROUTINE ions_nose_allocate - - SUBROUTINE ions_nose_deallocate() - ! - IMPLICIT NONE - ! - IF ( ALLOCATED( vnhp ) ) DEALLOCATE( vnhp ) - IF ( ALLOCATED( xnhp0 ) ) DEALLOCATE( xnhp0 ) - IF ( ALLOCATED( xnhpm ) ) DEALLOCATE( xnhpm ) - IF ( ALLOCATED( xnhpp ) ) DEALLOCATE( xnhpp ) - IF ( ALLOCATED( ekin2nhp ) ) DEALLOCATE( ekin2nhp ) - IF ( ALLOCATED( gkbt2nhp ) ) DEALLOCATE( gkbt2nhp ) - IF ( ALLOCATED( scal2nhp ) ) DEALLOCATE( scal2nhp ) - IF ( ALLOCATED( anum2nhp ) ) DEALLOCATE( anum2nhp ) - IF ( ALLOCATED( qnp ) ) DEALLOCATE( qnp ) - IF ( ALLOCATED( qnp_ ) ) DEALLOCATE( qnp_ ) - IF ( ALLOCATED( fnosep ) ) DEALLOCATE( fnosep ) - ! - IF( ALLOCATED( atm2nhp ) ) DEALLOCATE( atm2nhp ) - ! - RETURN - ! - END SUBROUTINE ions_nose_deallocate - - SUBROUTINE ions_nose_info() - - use constants, only: au_terahertz, pi - use time_step, only: delt - USE io_global, ONLY: stdout - USE control_flags, ONLY: tnosep - use ions_base, only: nat - - IMPLICIT NONE - - INTEGER :: nsvar, i, j - REAL(DP) :: wnosep - - IF( tnosep ) THEN - ! - IF( fnosep(1) <= 0.0_DP) & - CALL errore(' ions_nose_info ', ' fnosep less than zero ', 1) - IF( delt <= 0.0_DP) & - CALL errore(' ions_nose_info ', ' delt less than zero ', 1) - - wnosep = fnosep(1) * ( 2.0_DP * pi ) * au_terahertz - nsvar = ( 2.0_DP * pi ) / ( wnosep * delt ) - - WRITE( stdout,563) tempw, nhpcl, ndega, nsvar - WRITE( stdout,564) (fnosep(i),i=1,nhpcl) - WRITE( stdout,565) nhptyp, (nhpdim-nhpend), nhpend , nhpbeg, & - (anum2nhp(j),j=1,nhpdim) - do j=1,nhpdim - WRITE( stdout,566) j,(qnp((j-1)*nhpcl+i),i=1,nhpcl) - enddo - WRITE( stdout,567) - do j=1,nat,20 - WRITE( stdout,568) atm2nhp(j:min(nat,j+19)) - enddo - END IF - - 563 format( //, & - & 3X,'ion dynamics with nose` temperature control:', /, & - & 3X,'temperature required = ', f10.5, ' (kelvin) ', /, & - & 3X,'NH chain length = ', i3, /, & - & 3X,'active degrees of freedom = ', i3, /, & - & 3X,'time steps per nose osc. = ', i5 ) - 564 format( //, & - & 3X,'nose` frequency(es) = ', 20(1X,f10.3) ) -! 565 format( //, & -! & 3X,'nose` mass(es) = ', 20(1X,f10.3), // ) - 565 FORMAT( //, & - & 3X,'the requested type of NH chains is ',I5, /, & - & 3X,'total number of thermostats used ',I5,1X,I1,1X,I1, /, & - & 3X,'ionic degrees of freedom for each chain ',20(1X,I3)) - 566 format( //, & - & 3X,'nose` mass(es) for chain ',i4,' = ', 20(1X,f10.3)) -567 format( //, & - & 3X,'atom i (in sorted order) is assigned to this thermostat :') -568 format(20(1X,I3)) - RETURN - END SUBROUTINE ions_nose_info - - - - subroutine ions_nosevel( vnhp, xnhp0, xnhpm, delt, nhpcl, nhpdim ) - implicit none - integer, intent(in) :: nhpcl, nhpdim - real(DP), intent(inout) :: vnhp(nhpcl,nhpdim) - real(DP), intent(in) :: xnhp0(nhpcl,nhpdim), xnhpm(nhpcl,nhpdim), delt - integer :: i,j - do j=1,nhpdim - do i=1,nhpcl - vnhp(i,j)=2.0_DP * (xnhp0(i,j)-xnhpm(i,j)) / delt-vnhp(i,j) - end do - end do - ! - ! this is equivalent to: - ! velocity = ( 3.0_DP * xnos0(1) - 4.0_DP * xnosm(1) + xnos2m(1) ) / ( 2.0_DP * delt ) - ! but we do not need variables at time t-2dt ( xnos2m ) - ! - return - end subroutine ions_nosevel - - - subroutine ions_noseupd( xnhpp, xnhp0, xnhpm, delt, qnp, ekin2nhp, gkbt2nhp, vnhp, kbt, nhpcl, nhpdim, nhpbeg, nhpend ) - implicit none - integer, intent(in) :: nhpcl, nhpdim, nhpbeg, nhpend - real(DP), intent(out) :: xnhpp(nhpcl,nhpdim) - real(DP), intent(in) :: xnhp0(nhpcl,nhpdim), xnhpm(nhpcl,nhpdim), delt, qnp(nhpcl,nhpdim), gkbt2nhp(:), kbt - real(DP), intent(inout) :: ekin2nhp(:), vnhp(nhpcl,nhpdim) - integer :: i, j - real(DP) :: dt2, zetfrc, vp1dlt, ekinend, vp1dend - - - ekinend = 0.0_DP - vp1dend = 0.0_DP - if ( nhpend == 1 ) vp1dend = 0.5_DP * delt * vnhp(1,nhpdim) - dt2 = delt**2 - if (nhpbeg.gt.0) then - xnhpp(:,1:nhpbeg) = 0.0_DP - vnhp (:,1:nhpbeg) = 0.0_DP - endif - do j=(1+nhpbeg),nhpdim - zetfrc = dt2 * ( 2.0_DP * ekin2nhp(j) - gkbt2nhp(j) ) - if ( nhpcl > 1 ) then - do i=1,(nhpcl-1) - vp1dlt = 0.5_DP * delt * vnhp(i+1,j) - xnhpp(i,j)=(2.0_DP * xnhp0(i,j)-(1.0_DP-vp1dlt)*xnhpm(i,j)+zetfrc/qnp(i,j))& - & /(1.0_DP+vp1dlt) -! xnhpp(i,j)=(4.d0*xnhp0(i,j)-(2.d0-delt*vnhp(i+1,j))*xnhpm(i,j)+2.0d0*dt2*zetfrc/qnp(i,j))& -! & /(2.d0+delt*vnhp(i+1,j)) - vnhp(i,j) =(xnhpp(i,j)-xnhpm(i,j))/( 2.0_DP * delt ) - zetfrc = dt2*(qnp(i,j)*vnhp(i,j)**2-kbt) - end do - end if - ! Last variable - i = nhpcl - if ( nhpend == 0 ) then - xnhpp(i,j)=2.0_DP * xnhp0(i,j)-xnhpm(i,j) + zetfrc / qnp(i,j) - vnhp(i,j) =(xnhpp(i,j)-xnhpm(i,j))/( 2.0_DP * delt ) - elseif (nhpend == 1) then - xnhpp(i,j)=(2.0_DP*xnhp0(i,j)-(1.0_DP-vp1dend)*xnhpm(i,j)+zetfrc/qnp(i,j))& - & /(1.0_DP+vp1dend) - vnhp(i,j) =(xnhpp(i,j)-xnhpm(i,j))/( 2.0_DP * delt ) - ekinend = ekinend + (qnp(i,j)*vnhp(i,j)**2) - if (j.eq.(nhpdim-nhpend)) then - ekin2nhp(nhpdim) = 0.5_DP*ekinend - vp1dend = 0.0_DP - endif - endif - enddo - ! Update velocities -! do i=1,nhpcl -! vnhp(i) =(xnhpp(i)-xnhpm(i))/( 2.0d0 * delt ) -! end do - ! These are the original expressions from cpr.f90 - ! xnhpp(1)=2.*xnhp0(1)-xnhpm(1)+2.*( delt**2 / qnp(1) )*(ekinpr-gkbt/2.) - ! vnhp(1) =(xnhpp(1)-xnhpm(1))/( 2.0d0 * delt ) - return - end subroutine ions_noseupd - - - - real(DP) function ions_nose_nrg( xnhp0, vnhp, qnp, gkbt2nhp, kbt, nhpcl, nhpdim ) - implicit none - integer :: nhpcl, nhpdim - real(DP) :: gkbt2nhp(:), qnp(nhpcl,nhpdim),vnhp(nhpcl,nhpdim),xnhp0(nhpcl,nhpdim),kbt - integer :: i,j - real(DP) :: stmp - ! - stmp = 0.0_DP - do j=1,nhpdim - stmp = stmp + 0.5_DP * qnp(1,j) * vnhp(1,j) * vnhp(1,j) + gkbt2nhp(j) * xnhp0(1,j) - if (nhpcl > 1) then - do i=2,nhpcl - stmp = stmp + 0.5_DP * qnp(i,j) * vnhp(i,j) * vnhp(i,j) + kbt * xnhp0(i,j) - enddo - endif - enddo - ions_nose_nrg = stmp - return - end function ions_nose_nrg - - - - subroutine ions_nose_shiftvar( xnhpp, xnhp0, xnhpm ) - ! shift values of nose variables to start a new step - implicit none - real(DP), intent(inout) :: xnhpm(:), xnhp0(:) - real(DP), intent(in) :: xnhpp(:) - ! - xnhpm = xnhp0 - xnhp0 = xnhpp - ! - return - end subroutine ions_nose_shiftvar - -!------------------------------------------------------------------------------! - END MODULE ions_nose -!------------------------------------------------------------------------------! diff --git a/quantum_espresso/kcp/Modules/kind.f90 b/quantum_espresso/kcp/Modules/kind.f90 deleted file mode 100644 index fd24469d3..000000000 --- a/quantum_espresso/kcp/Modules/kind.f90 +++ /dev/null @@ -1,64 +0,0 @@ -! -! Copyright (C) 2002-2004 quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!------------------------------------------------------------------------------! - MODULE kinds -!------------------------------------------------------------------------------! - - IMPLICIT NONE - SAVE -! ... kind definitions - INTEGER, PARAMETER :: DP = selected_real_kind(14,200) - INTEGER, PARAMETER :: sgl = selected_real_kind(6,30) - INTEGER, PARAMETER :: i4b = selected_int_kind(9) - PRIVATE - PUBLIC :: i4b, sgl, DP, print_kind_info -! -!------------------------------------------------------------------------------! -! - CONTAINS -! -!------------------------------------------------------------------------------! -! -!! Print information about the used data types. -! - SUBROUTINE print_kind_info (stdout) -! -!------------------------------------------------------------------------------! -! - IMPLICIT NONE - INTEGER, INTENT(IN) :: stdout -! - WRITE( stdout,'(/,T2,A)') 'DATA TYPE INFORMATION:' -! - WRITE( stdout,'(/,T2,A,T78,A,2(/,T2,A,T75,I6),3(/,T2,A,T67,E14.8))') & - 'REAL: Data type name:', 'DP', ' Kind value:', kind(0.0_DP), & - ' Precision:', precision(0.0_DP), & - ' Smallest nonnegligible quantity relative to 1:', & - epsilon(0.0_DP), ' Smallest positive number:', tiny(0.0_DP), & - ' Largest representable number:', huge(0.0_DP) - WRITE( stdout,'(/,T2,A,T78,A,2(/,T2,A,T75,I6),3(/,T2,A,T67,E14.8))') & - ' Data type name:', 'sgl', ' Kind value:', kind(0.0_sgl), & - ' Precision:', precision(0.0_sgl), & - ' Smallest nonnegligible quantity relative to 1:', & - epsilon(0.0_sgl), ' Smallest positive number:', tiny(0.0_sgl), & - ' Largest representable number:', huge(0.0_sgl) - WRITE( stdout,'(/,T2,A,T72,A,4(/,T2,A,T61,I20))') & - 'INTEGER: Data type name:', '(default)', ' Kind value:', & - kind(0), ' Bit size:', bit_size(0), & - ' Largest representable number:', huge(0) - WRITE( stdout,'(/,T2,A,T72,A,/,T2,A,T75,I6,/)') 'LOGICAL: Data type name:', & - '(default)', ' Kind value:', kind(.TRUE.) - WRITE( stdout,'(/,T2,A,T72,A,/,T2,A,T75,I6,/)') & - 'CHARACTER: Data type name:', '(default)', ' Kind value:', & - kind('C') -! - END SUBROUTINE print_kind_info -! -!------------------------------------------------------------------------------! - END MODULE kinds -!------------------------------------------------------------------------------! diff --git a/quantum_espresso/kcp/Modules/make.depend b/quantum_espresso/kcp/Modules/make.depend deleted file mode 100644 index 6f02a71e2..000000000 --- a/quantum_espresso/kcp/Modules/make.depend +++ /dev/null @@ -1,346 +0,0 @@ -atom.o : radial_grids.o -autopilot.o : input_parameters.o -autopilot.o : io_global.o -autopilot.o : kind.o -autopilot.o : mp.o -autopilot.o : parser.o -basic_algebra_routines.o : kind.o -berry_phase.o : io_global.o -berry_phase.o : mp.o -berry_phase.o : mp_global.o -berry_phase.o : recvec.o -berry_phase.o : stick_base.o -bfgs_module.o : basic_algebra_routines.o -bfgs_module.o : constants.o -bfgs_module.o : io_files.o -bfgs_module.o : kind.o -cell_base.o : constants.o -cell_base.o : control_flags.o -cell_base.o : io_global.o -cell_base.o : kind.o -cell_base.o : timestep.o -check_stop.o : input_parameters.o -check_stop.o : io_files.o -check_stop.o : io_global.o -check_stop.o : kind.o -check_stop.o : mp.o -check_stop.o : mp_global.o -clocks.o : io_global.o -clocks.o : kind.o -clocks.o : mp.o -clocks.o : mp_global.o -compute_dipole.o : cell_base.o -compute_dipole.o : fft_base.o -compute_dipole.o : kind.o -compute_dipole.o : mp.o -compute_dipole.o : mp_global.o -constants.o : kind.o -constraints_module.o : basic_algebra_routines.o -constraints_module.o : cell_base.o -constraints_module.o : constants.o -constraints_module.o : input_parameters.o -constraints_module.o : io_global.o -constraints_module.o : ions_base.o -constraints_module.o : kind.o -control_flags.o : kind.o -control_flags.o : parameters.o -dspev_drv.o : kind.o -electrons_base.o : constants.o -electrons_base.o : control_flags.o -electrons_base.o : io_global.o -electrons_base.o : kind.o -electrons_base.o : timestep.o -energies.o : io_global.o -energies.o : kind.o -error_handler.o : io_files.o -error_handler.o : io_global.o -error_handler.o : parallel_include.o -exc_t.o : functionals.o -exc_t.o : kind.o -fft_base.o : fft_types.o -fft_base.o : kind.o -fft_base.o : mp.o -fft_base.o : mp_global.o -fft_base.o : parallel_include.o -fft_parallel.o : fft_base.o -fft_parallel.o : fft_scalar.o -fft_parallel.o : fft_types.o -fft_parallel.o : kind.o -fft_parallel.o : mp_global.o -fft_parallel.o : parallel_include.o -fft_scalar.o : kind.o -fft_types.o : io_global.o -functionals.o : io_global.o -functionals.o : kind.o -griddim.o : fft_scalar.o -griddim.o : fft_types.o -griddim.o : io_global.o -griddim.o : kind.o -griddim.o : mp.o -griddim.o : mp_global.o -input_parameters.o : kind.o -input_parameters.o : parameters.o -input_parameters.o : wannier_new.o -io_files.o : io_global.o -io_files.o : parameters.o -ions_base.o : cell_base.o -ions_base.o : constants.o -ions_base.o : io_global.o -ions_base.o : kind.o -ions_base.o : parameters.o -ions_base.o : random_numbers.o -ions_nose.o : constants.o -ions_nose.o : control_flags.o -ions_nose.o : io_global.o -ions_nose.o : ions_base.o -ions_nose.o : kind.o -ions_nose.o : timestep.o -metadyn_base.o : basic_algebra_routines.o -metadyn_base.o : cell_base.o -metadyn_base.o : constants.o -metadyn_base.o : constraints_module.o -metadyn_base.o : control_flags.o -metadyn_base.o : input_parameters.o -metadyn_base.o : io_files.o -metadyn_base.o : io_global.o -metadyn_base.o : kind.o -metadyn_base.o : metadyn_io.o -metadyn_base.o : metadyn_vars.o -metadyn_base.o : mp.o -metadyn_base.o : random_numbers.o -metadyn_base.o : xml_io_base.o -metadyn_io.o : ../iotk/src/iotk_module.o -metadyn_io.o : constants.o -metadyn_io.o : constraints_module.o -metadyn_io.o : input_parameters.o -metadyn_io.o : io_files.o -metadyn_io.o : io_global.o -metadyn_io.o : ions_base.o -metadyn_io.o : kind.o -metadyn_io.o : metadyn_vars.o -metadyn_io.o : mp.o -metadyn_io.o : xml_io_base.o -metadyn_vars.o : control_flags.o -metadyn_vars.o : input_parameters.o -metadyn_vars.o : kind.o -metagga.o : kind.o -mm_dispersion.o : cell_base.o -mm_dispersion.o : io_global.o -mm_dispersion.o : ions_base.o -mm_dispersion.o : kind.o -mm_dispersion.o : mp.o -mm_dispersion.o : mp_global.o -mp.o : io_global.o -mp.o : kind.o -mp.o : parallel_include.o -mp_base.o : kind.o -mp_base.o : parallel_include.o -mp_global.o : mp.o -mp_global.o : parallel_include.o -mp_global.o : shmem_include.o -mp_wave.o : kind.o -mp_wave.o : parallel_include.o -parallel_include.o : kind.o -parallel_types.o : kind.o -parser.o : io_global.o -parser.o : kind.o -parser.o : mp.o -parser.o : mp_global.o -path_base.o : basic_algebra_routines.o -path_base.o : constants.o -path_base.o : constraints_module.o -path_base.o : control_flags.o -path_base.o : input_parameters.o -path_base.o : io_files.o -path_base.o : io_global.o -path_base.o : ions_base.o -path_base.o : kind.o -path_base.o : metadyn_base.o -path_base.o : metadyn_vars.o -path_base.o : mp.o -path_base.o : mp_global.o -path_base.o : path_formats.o -path_base.o : path_io_routines.o -path_base.o : path_opt_routines.o -path_base.o : path_reparametrisation.o -path_base.o : path_variables.o -path_base.o : random_numbers.o -path_io_routines.o : basic_algebra_routines.o -path_io_routines.o : cell_base.o -path_io_routines.o : constants.o -path_io_routines.o : control_flags.o -path_io_routines.o : input_parameters.o -path_io_routines.o : io_files.o -path_io_routines.o : io_global.o -path_io_routines.o : ions_base.o -path_io_routines.o : kind.o -path_io_routines.o : mp.o -path_io_routines.o : mp_global.o -path_io_routines.o : path_formats.o -path_io_routines.o : path_reparametrisation.o -path_io_routines.o : path_variables.o -path_opt_routines.o : basic_algebra_routines.o -path_opt_routines.o : constants.o -path_opt_routines.o : control_flags.o -path_opt_routines.o : io_files.o -path_opt_routines.o : io_global.o -path_opt_routines.o : kind.o -path_opt_routines.o : mp.o -path_opt_routines.o : path_variables.o -path_reparametrisation.o : basic_algebra_routines.o -path_reparametrisation.o : io_files.o -path_reparametrisation.o : io_global.o -path_reparametrisation.o : kind.o -path_reparametrisation.o : mp.o -path_reparametrisation.o : path_variables.o -path_reparametrisation.o : splinelib.o -path_variables.o : kind.o -paw_variables.o : kind.o -printout_base.o : io_global.o -printout_base.o : kind.o -printout_base.o : mp.o -printout_base.o : mp_global.o -pseudo_types.o : kind.o -pseudo_types.o : radial_grids.o -ptoolkit.o : descriptors.o -ptoolkit.o : dspev_drv.o -ptoolkit.o : io_global.o -ptoolkit.o : kind.o -ptoolkit.o : parallel_include.o -ptoolkit.o : zhpev_drv.o -radial_grids.o : constants.o -radial_grids.o : kind.o -random_numbers.o : kind.o -read_cards.o : autopilot.o -read_cards.o : constants.o -read_cards.o : input_parameters.o -read_cards.o : io_global.o -read_cards.o : kind.o -read_cards.o : parser.o -read_cards.o : wannier_new.o -read_cards.o : wrappers.o -read_namelists.o : constants.o -read_namelists.o : input_parameters.o -read_namelists.o : io_global.o -read_namelists.o : kind.o -read_namelists.o : mp.o -read_ncpp.o : functionals.o -read_ncpp.o : kind.o -read_ncpp.o : parameters.o -read_ncpp.o : pseudo_types.o -read_oddalpha_file.o : io_global.o -read_oddalpha_file.o : kind.o -read_oddalpha_file.o : mp.o -read_upf_v1.o : kind.o -read_upf_v1.o : pseudo_types.o -read_upf_v1.o : radial_grids.o -read_upf_v2.o : ../iotk/src/iotk_module.o -read_upf_v2.o : kind.o -read_upf_v2.o : parser.o -read_upf_v2.o : pseudo_types.o -read_upf_v2.o : radial_grids.o -read_uspp.o : constants.o -read_uspp.o : functionals.o -read_uspp.o : io_global.o -read_uspp.o : kind.o -read_uspp.o : parameters.o -read_uspp.o : pseudo_types.o -read_uspp.o : uspp.o -recvec.o : kind.o -recvec.o : mp.o -recvec.o : mp_global.o -shmem_include.o : kind.o -sic.o : io_global.o -sic.o : kind.o -smallbox.o : constants.o -smallbox.o : io_global.o -smallbox.o : kind.o -splinelib.o : kind.o -stick_base.o : control_flags.o -stick_base.o : fft_types.o -stick_base.o : io_global.o -stick_base.o : kind.o -stick_base.o : mp.o -stick_base.o : mp_global.o -task_groups.o : fft_types.o -task_groups.o : io_global.o -task_groups.o : kind.o -task_groups.o : mp_global.o -task_groups.o : parallel_include.o -timestep.o : kind.o -twin_types.o : control_flags.o -twin_types.o : kind.o -twin_types.o : mp.o -twin_types.o : mp_global.o -upf.o : ../iotk/src/iotk_module.o -upf.o : kind.o -upf.o : pseudo_types.o -upf.o : radial_grids.o -upf.o : read_upf_v1.o -upf.o : read_upf_v2.o -upf.o : write_upf_v2.o -upf_to_internal.o : functionals.o -upf_to_internal.o : pseudo_types.o -upf_to_internal.o : radial_grids.o -uspp.o : constants.o -uspp.o : kind.o -uspp.o : parameters.o -uspp.o : pseudo_types.o -uspp.o : random_numbers.o -uspp.o : twin_types.o -vxc_t.o : functionals.o -vxc_t.o : io_global.o -vxc_t.o : kind.o -vxcgc.o : constants.o -vxcgc.o : functionals.o -vxcgc.o : kind.o -vxcgc.o : radial_grids.o -wannier.o : kind.o -wannier_new.o : kind.o -wave_base.o : kind.o -wave_base.o : mp.o -wave_base.o : mp_global.o -wave_base.o : random_numbers.o -wavefunctions.o : kind.o -wrappers.o : kind.o -write_upf_v2.o : ../iotk/src/iotk_module.o -write_upf_v2.o : kind.o -write_upf_v2.o : pseudo_types.o -write_upf_v2.o : radial_grids.o -xml_input.o : ../iotk/src/iotk_module.o -xml_input.o : input_parameters.o -xml_input.o : io_files.o -xml_input.o : io_global.o -xml_input.o : kind.o -xml_input.o : version.o -xml_input.o : xml_io_base.o -xml_io_base.o : ../iotk/src/iotk_module.o -xml_io_base.o : constants.o -xml_io_base.o : control_flags.o -xml_io_base.o : io_files.o -xml_io_base.o : io_global.o -xml_io_base.o : kind.o -xml_io_base.o : mp.o -xml_io_base.o : mp_global.o -xml_io_base.o : mp_wave.o -xml_io_base.o : parser.o -xml_io_base.o : wrappers.o -zhpev_drv.o : io_global.o -zhpev_drv.o : kind.o -basic_algebra_routines.o : ../include/f_defs.h -constraints_module.o : ../include/f_defs.h -dspev_drv.o : ../include/f_defs.h -fft_base.o : ../include/f_defs.h -fft_parallel.o : ../include/f_defs.h -fft_scalar.o : ../include/f_defs.h -fft_scalar.o : ../include/fft_defs.h -mp_wave.o : ../include/f_defs.h -parser.o : ../include/f_defs.h -path_base.o : ../include/f_defs.h -path_io_routines.o : ../include/f_defs.h -path_reparametrisation.o : ../include/f_defs.h -ptoolkit.o : ../include/f_defs.h -wannier.o : ../include/f_defs.h -wannier_new.o : ../include/f_defs.h -wave_base.o : ../include/f_defs.h -zhpev_drv.o : ../include/f_defs.h diff --git a/quantum_espresso/kcp/Modules/metadyn_base.f90 b/quantum_espresso/kcp/Modules/metadyn_base.f90 deleted file mode 100644 index 709700b66..000000000 --- a/quantum_espresso/kcp/Modules/metadyn_base.f90 +++ /dev/null @@ -1,417 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE metadyn_base - !---------------------------------------------------------------------------- - ! - ! ... this module contains the core methods used to implement meta-dynamics - ! - ! ... meta-dynamics is implemented following these two references: - ! - ! ... 1) A. Laio and M. Parrinello; PNAS 99, 12562 (2002); - ! ... 2) C. Micheletti, A. Laio, and M Parrinello; PRL 92, 17061 (2004). - ! - ! ... code written by Carlo Sbraccia (2005) - ! - USE kinds, ONLY : DP - ! - IMPLICIT NONE - ! - CONTAINS - ! - !------------------------------------------------------------------------ - SUBROUTINE metadyn_init( progname, tau ) - !------------------------------------------------------------------------ - ! - USE kinds, ONLY : DP - USE input_parameters, ONLY : restart_mode - USE constraints_module, ONLY : constr_target - USE control_flags, ONLY : nstep, ndr - USE constants, ONLY : bohr_radius_angs - USE cell_base, ONLY : at, alat - USE metadyn_vars, ONLY : ncolvar, g_amplitude, fe_step, & - max_metadyn_iter, metadyn_fmt, & - gaussian_pos, first_metadyn_iter - USE metadyn_io, ONLY : read_metadyn_restart - USE io_files, ONLY : tmp_dir, outdir, prefix, iunaxsf, & - iunmeta, delete_if_present - USE io_global, ONLY : stdout, ionode - USE mp, ONLY : mp_bcast - USE xml_io_base, ONLY : restart_dir - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(IN) :: progname - REAL(DP), INTENT(INOUT) :: tau(:,:) - ! - CHARACTER(LEN=256) :: dirname - CHARACTER(LEN=4) :: c_ncolvar - CHARACTER(LEN=16) :: fe_step_fmt - ! - CHARACTER(LEN=6), EXTERNAL :: int_to_char - ! - ! - IF ( ncolvar < 1 ) & - CALL errore( 'metadyn_init', & - 'number of collective variables must be at least 1', 1 ) - ! - c_ncolvar = int_to_char( ncolvar ) - ! - metadyn_fmt = '(I5,' // TRIM( c_ncolvar ) // '(2X,F10.5),2X,F14.8,' // & - & TRIM( c_ncolvar ) // '(2X,F10.5),' // & - & TRIM( c_ncolvar ) // '(2X,F10.7))' - ! - IF ( nstep < 1 ) CALL errore( 'metadyn_init', 'nstep < 1', 1 ) - ! - max_metadyn_iter = nstep - ! - IF ( restart_mode == 'from_scratch' ) THEN - ! - IF ( ionode ) THEN - ! - OPEN( UNIT = iunaxsf, & - FILE = TRIM( prefix ) // ".axsf", STATUS = 'UNKNOWN' ) - ! - WRITE( UNIT = iunaxsf, & - FMT = '(" ANIMSTEPS ",I5)' ) max_metadyn_iter - ! - WRITE( UNIT = iunaxsf, FMT = '(" CRYSTAL ")' ) - WRITE( UNIT = iunaxsf, FMT = '(" PRIMVEC ")' ) - WRITE( UNIT = iunaxsf, FMT = '(3F14.10)' ) & - at(1,1) * alat * bohr_radius_angs, & - at(2,1) * alat * bohr_radius_angs, & - at(3,1) * alat * bohr_radius_angs - WRITE( UNIT = iunaxsf, FMT = '(3F14.10)' ) & - at(1,2) * alat * bohr_radius_angs, & - at(2,2) * alat * bohr_radius_angs, & - at(3,2) * alat * bohr_radius_angs - WRITE( UNIT = iunaxsf, FMT = '(3F14.10)' ) & - at(1,3) * alat * bohr_radius_angs, & - at(2,3) * alat * bohr_radius_angs, & - at(3,3) * alat * bohr_radius_angs - ! - END IF - ! - CALL delete_if_present( TRIM( prefix ) // '.metadyn' ) - ! - IF ( ionode ) THEN - ! - OPEN( UNIT = iunmeta, & - FILE = TRIM( prefix ) // '.metadyn', STATUS = 'NEW' ) - ! - WRITE( iunmeta, '(2(2X,I5))' ) ncolvar, max_metadyn_iter - WRITE( iunmeta, '(2(2X,F12.8))' ) g_amplitude - ! - fe_step_fmt = '(' // TRIM( c_ncolvar ) // '(2X,F12.8))' - ! - WRITE( iunmeta, fe_step_fmt ) fe_step(:) - ! - END IF - ! - first_metadyn_iter = 0 - ! - ELSE - ! - ! ... restarting from file - ! - IF ( progname == 'PW' ) THEN - ! - dirname = TRIM( tmp_dir ) // TRIM( prefix ) // '.save' - ! - ELSE IF ( progname == 'CP' ) THEN - ! - dirname = restart_dir( outdir, ndr ) - ! - ELSE - ! - CALL errore( 'metadyn_init', & - 'wrong calling program: ' // TRIM( progname ), 1 ) - ! - END IF - ! - CALL read_metadyn_restart( dirname, tau, alat ) - ! - IF ( ionode ) THEN - ! - OPEN( UNIT = iunaxsf, FILE = TRIM( prefix ) // ".axsf", & - STATUS = 'UNKNOWN', ACTION = 'WRITE', POSITION = 'APPEND' ) - OPEN( UNIT = iunmeta, FILE = TRIM( prefix ) // '.metadyn', & - STATUS = 'UNKNOWN', ACTION = 'WRITE', POSITION = 'APPEND' ) - ! - END IF - ! - END IF - ! - IF ( first_metadyn_iter == max_metadyn_iter ) THEN - ! - WRITE( stdout, '(/,5X,"Simulation already completed",/)' ) - ! - CLOSE( UNIT = iunmeta, STATUS = 'KEEP' ) - ! - CALL stop_run( .FALSE. ) - ! - END IF - ! - gaussian_pos(:) = constr_target(1:ncolvar) - ! - RETURN - ! - END SUBROUTINE metadyn_init - ! - !------------------------------------------------------------------------ - SUBROUTINE add_gaussians( iter ) - !------------------------------------------------------------------------ - ! - USE metadyn_vars, ONLY : ncolvar, metadyn_history, fe_grad, fe_step, & - dfe_acc, g_amplitude - USE basic_algebra_routines - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: iter - ! - INTEGER :: i - REAL(DP), ALLOCATABLE :: delta(:) - ! - ! ... history dependent term - ! - IF ( iter == 1 ) RETURN - ! - ALLOCATE( delta( ncolvar ) ) - ! - dfe_acc = 0.0_DP - ! - DO i = 1, iter - 1 - ! - delta = metadyn_history(:,iter) - metadyn_history(:,i) - ! - dfe_acc(:) = dfe_acc(:) + delta(:) / fe_step(:)**2 * & - EXP( - SUM( delta(:)**2 / ( 2.0_DP*fe_step(:)**2 ) ) ) - ! - END DO - ! - fe_grad(:) = fe_grad(:) - g_amplitude*dfe_acc(:) - ! - DEALLOCATE( delta ) - ! - RETURN - ! - END SUBROUTINE add_gaussians - ! - !------------------------------------------------------------------------ - SUBROUTINE add_domain_potential() - !------------------------------------------------------------------------ - ! - ! ... a repulsive potential is added to confine the collective variables - ! ... within the appropriate domain (used to avoid singularities): - ! - ! ... V(s) = a*( sigma / s )^12 - ! - ! ... where a is the amplitude of the gaussians used for meta-dynamics - ! - USE constraints_module, ONLY : constr_target, constr_type, dmax - USE metadyn_vars, ONLY : ncolvar, fe_grad, g_amplitude - ! - IMPLICIT NONE - ! - INTEGER :: i - REAL(DP) :: a, inv_s - ! - REAL(DP), PARAMETER :: coord_sigma = 0.050_DP - REAL(DP), PARAMETER :: stfac_sigma = 0.005_DP - ! - ! - a = 12.0_DP*g_amplitude - ! - DO i = 1, ncolvar - ! - SELECT CASE( constr_type(i) ) - CASE( 1, 2 ) - ! - ! ... coordination must always be larger than a minimum threshold - ! - inv_s = 1.0_DP / constr_target(i) - ! - fe_grad(i) = fe_grad(i) - a*inv_s*( coord_sigma*inv_s )**11 - ! - CASE( 6 ) - ! - ! ... the square modulus of the structure factor is never negative - ! ... or larger than one - ! - inv_s = 1.0_DP / constr_target(i) - ! - fe_grad(i) = fe_grad(i) - a*inv_s*( stfac_sigma*inv_s )**11 - ! - inv_s = 1.0_DP / ( 1.0_DP - constr_target(i) ) - ! - fe_grad(i) = fe_grad(i) - a*inv_s*( stfac_sigma*inv_s )**11 - ! - END SELECT - ! - END DO - ! - RETURN - ! - END SUBROUTINE add_domain_potential - ! - !------------------------------------------------------------------------ - SUBROUTINE evolve_collective_vars( norm_fe_grad ) - !------------------------------------------------------------------------ - ! - ! ... the collective variables are evolved taking care of the - ! ... additional constraints imposed by the domain definition - ! - USE constants, ONLY : eps32 - USE constraints_module, ONLY : constr_target - USE metadyn_vars, ONLY : ncolvar, fe_grad, fe_step, new_target, & - to_target, sw_nstep, gaussian_pos, & - g_amplitude - USE random_numbers, ONLY : randy - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: norm_fe_grad - ! - INTEGER :: i - REAL(DP) :: step - ! - ! - IF ( norm_fe_grad < eps32 ) & - CALL errore( 'evolve_collective_vars', 'norm( fe_grad ) = 0', 1 ) - ! - IF ( g_amplitude > 0.0_DP ) fe_grad(:) = fe_grad(:) / norm_fe_grad - ! - DO i = 1, ncolvar - ! - gaussian_pos(i) = constr_target(i) - fe_step(i)*fe_grad(i) - ! - step = ( 1.0_DP + 0.5_DP*randy() )*fe_step(i) - ! - new_target(i) = constr_target(i) - step*fe_grad(i) - ! - END DO - ! - CALL impose_domain_constraints() - ! - to_target(:) = ( new_target(:) - & - constr_target(1:ncolvar) ) / DBLE( sw_nstep ) - ! - RETURN - ! - END SUBROUTINE evolve_collective_vars - ! - !------------------------------------------------------------------------ - SUBROUTINE impose_domain_constraints() - !------------------------------------------------------------------------ - ! - USE constraints_module, ONLY : constr_type, dmax - USE metadyn_vars, ONLY : ncolvar, new_target - ! - IMPLICIT NONE - ! - INTEGER :: i - ! - ! - DO i = 1, ncolvar - ! - SELECT CASE( constr_type(i) ) - CASE( 1, 2 ) - ! - ! ... coordination must always be larger than zero - ! - new_target(i) = ABS( new_target(i) ) - ! - CASE( 3 ) - ! - ! ... a distance can never be larger than dmax ( check file - ! ... constraints_module.f90 for its definition ) - ! - IF ( new_target(i) > dmax ) & - new_target(i) = 2.0_DP*dmax - new_target(i) - ! - CASE( 4, 5 ) - ! - ! ... the cosine of the angle (planar or torsional) must be - ! ... within -1 and 1 - ! - IF ( new_target(i) > +1.0_DP ) new_target(i) = +2.0_DP - new_target(i) - IF ( new_target(i) < -1.0_DP ) new_target(i) = -2.0_DP - new_target(i) - ! - CASE( 6 ) - ! - ! ... the square modulus of the structure factor is never - ! ... negative or larger than one - ! - new_target(i) = ABS( new_target(i) ) - ! - IF ( new_target(i) > 1.0_DP ) new_target(i) = 2.0_DP - new_target(i) - ! - CASE( 7 ) - ! - ! ... the spherical average of the structure factor must be within - ! ... -1 and 1 - ! - IF ( new_target(i) > +1.0_DP ) new_target(i) = +2.0_DP - new_target(i) - IF ( new_target(i) < -1.0_DP ) new_target(i) = -2.0_DP - new_target(i) - ! - END SELECT - ! - END DO - ! - RETURN - ! - END SUBROUTINE impose_domain_constraints - ! - !------------------------------------------------------------------------ - SUBROUTINE set_target() - !------------------------------------------------------------------------ - ! - USE metadyn_vars, ONLY : ncolvar, to_target, to_new_target - USE constraints_module, ONLY : constr_target - ! - ! - IF ( to_new_target ) & - constr_target(1:ncolvar) = constr_target(1:ncolvar) + to_target(:) - ! - RETURN - ! - END SUBROUTINE set_target - ! - !------------------------------------------------------------------------ - SUBROUTINE mean_force( step, etot, energy_units ) - !------------------------------------------------------------------------ - ! - USE io_global, ONLY : stdout - USE metadyn_vars, ONLY : dfe_acc, etot_av, ncolvar, eq_nstep - USE constraints_module, ONLY : lagrange - ! - INTEGER, INTENT(IN) :: step - REAL(DP), INTENT(IN) :: etot, energy_units - CHARACTER(LEN=80) :: meanfor_fmt - ! - CHARACTER(LEN=6), EXTERNAL :: int_to_char - ! - ! - IF ( step <= eq_nstep ) RETURN - ! - etot_av = etot_av + etot - ! - dfe_acc(:) = dfe_acc(:) - lagrange(1:ncolvar) - ! - meanfor_fmt = '(/,5X,"MEAN-FORCE ESTIMATE ",' // & - & TRIM( int_to_char( ncolvar ) ) // '(X,F10.6),/)' - ! - WRITE( stdout, meanfor_fmt ) & - dfe_acc(:) / DBLE( step - eq_nstep ) / energy_units - ! - RETURN - ! - END SUBROUTINE mean_force - ! -END MODULE metadyn_base diff --git a/quantum_espresso/kcp/Modules/metadyn_io.f90 b/quantum_espresso/kcp/Modules/metadyn_io.f90 deleted file mode 100644 index 60a8b9de3..000000000 --- a/quantum_espresso/kcp/Modules/metadyn_io.f90 +++ /dev/null @@ -1,325 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE metadyn_io - !---------------------------------------------------------------------------- - ! - ! ... this module contains the I/O methods used by meta-dynamics - ! - ! ... code written by Carlo Sbraccia (2005) - ! - USE kinds, ONLY : DP - ! - USE iotk_module - ! - USE xml_io_base, ONLY : create_directory - ! - IMPLICIT NONE - ! - CHARACTER(iotk_attlenx) :: attr - ! - PRIVATE - ! - PUBLIC :: write_metadyn_restart, & - read_metadyn_restart, & - write_axsf_file - ! - CONTAINS - ! - !------------------------------------------------------------------------ - SUBROUTINE write_metadyn_restart( dirname, iter, tau, energy, pos_unit ) - !------------------------------------------------------------------------ - ! - USE metadyn_vars, ONLY : ncolvar, max_metadyn_iter, g_amplitude, & - gaussian_pos, fe_grad, fe_step - USE constraints_module, ONLY : constr_target - USE io_global, ONLY : ionode, ionode_id - USE mp, ONLY : mp_bcast - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(IN) :: dirname - INTEGER, INTENT(IN) :: iter - REAL(DP), INTENT(IN) :: tau(:,:) - REAL(DP), INTENT(IN) :: energy - REAL(DP), INTENT(IN) :: pos_unit - ! - INTEGER :: i - CHARACTER(LEN=256) :: filename, metadyn_dir - INTEGER :: iunit, ierr - ! - ! - IF ( ionode ) THEN - ! - ! ... look for an empty unit (only ionode needs it) - ! - CALL iotk_free_unit( iunit, ierr ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id ) - ! - CALL errore( 'write_metadyn_restart', & - 'no free units to write the restart file', ierr ) - ! - ! ... the restart information is written in a sub-directory of - ! .. the 'save' directory - ! - CALL create_directory( dirname ) - ! - metadyn_dir = TRIM( dirname ) // '/meta-dynamics' - ! - CALL create_directory( metadyn_dir ) - ! - filename = TRIM( metadyn_dir ) // '/' // "metadyn-descriptor.xml" - ! - ! ... only ionode writes the file - ! - IF ( .NOT. ionode ) RETURN - ! - ! ... descriptor file - ! - CALL iotk_open_write( iunit, FILE = filename, & - ROOT = "METADYNAMICS", BINARY = .FALSE. ) - ! - CALL iotk_write_dat( iunit, & - "NUM_OF_COLLECTIVE_VARIABLES", ncolvar ) - ! - CALL iotk_write_dat( iunit, & - "NUM_OF_STEPS", max_metadyn_iter ) - ! - CALL iotk_write_attr( attr, "UNITS", "Hartree", FIRST = .TRUE. ) - CALL iotk_write_dat( iunit, & - "GAUSSIAN_AMPLITUDE", g_amplitude, ATTR = attr ) - ! - CALL iotk_write_attr( attr, "UNITS", "depend on the" // & - & "type of collective variables", FIRST = .TRUE. ) - CALL iotk_write_dat( iunit, "GAUSSIAN_SPREAD", fe_step(:), ATTR = attr ) - ! - CALL iotk_write_dat( iunit, "STEP", iter ) - ! - DO i = 1, iter - ! - filename = 'iteration' // TRIM( iotk_index( i ) ) // '.xml' - ! - CALL iotk_link( iunit, "ITERATION" // TRIM( iotk_index( i ) ), & - filename, CREATE = .FALSE., BINARY = .FALSE. ) - ! - END DO - ! - CALL iotk_close_write( iunit ) - ! - ! ... information about the last step - ! - filename = TRIM( metadyn_dir ) // '/' // & - & 'iteration' // TRIM( iotk_index( iter ) ) // '.xml' - ! - CALL iotk_open_write( iunit, FILE = filename, ROOT = 'iteration' // & - & TRIM( iotk_index( iter ) ), BINARY = .FALSE. ) - ! - CALL iotk_write_begin( iunit, "IONS" ) - ! - CALL iotk_write_attr( attr, "UNITS", "Bohr", FIRST = .TRUE. ) - CALL iotk_write_empty( iunit, "UNITS_FOR_IONIC_POS", attr ) - ! - DO i = 1, SIZE( tau, DIM = 2 ) - ! - CALL iotk_write_attr( attr, "tau", tau(:,i)*pos_unit, FIRST = .TRUE. ) - CALL iotk_write_empty( iunit, & - & "ATOM" // TRIM( iotk_index( i ) ), attr ) - ! - END DO - ! - CALL iotk_write_end( iunit, "IONS" ) - ! - CALL iotk_write_dat( iunit, & - "COLLECTIVE_VARIABLES", constr_target(1:ncolvar) ) - ! - CALL iotk_write_dat( iunit, "GAUSSIAN_CENTERS", gaussian_pos(:) ) - ! - CALL iotk_write_attr( attr, "UNITS", "Hartree", FIRST = .TRUE. ) - CALL iotk_write_dat( iunit, "POTENTIAL_ENERGY", energy, ATTR = attr ) - ! - CALL iotk_write_attr( attr, "UNITS", "Hartree / Bohr", FIRST = .TRUE. ) - CALL iotk_write_dat( iunit, & - "POTENTIAL_OF_MEAN_FORCE", fe_grad(:), ATTR = attr ) - ! - CALL iotk_close_write( iunit ) - ! - RETURN - ! - END SUBROUTINE write_metadyn_restart - ! - !------------------------------------------------------------------------ - SUBROUTINE read_metadyn_restart( dirname, tau, pos_unit ) - !------------------------------------------------------------------------ - ! - USE metadyn_vars, ONLY : ncolvar, gaussian_pos, fe_grad, & - metadyn_history, first_metadyn_iter - USE constraints_module, ONLY : constr_target - USE io_global, ONLY : ionode, ionode_id - USE mp, ONLY : mp_bcast - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(IN) :: dirname - REAL(DP), INTENT(OUT) :: tau(:,:) - REAL(DP), INTENT(IN) :: pos_unit - ! - INTEGER :: ncolvar_in - INTEGER :: i - CHARACTER(LEN=256) :: filename, tag - INTEGER :: iunit, ierr - ! - ! - ! ... look for an empty unit - ! - IF ( ionode ) THEN - ! - CALL iotk_free_unit( iunit, ierr ) - ! - CALL errore( 'read_metadyn_restart', & - 'no free units to read the restart file', ierr ) - ! - filename = TRIM( dirname ) // & - & '/meta-dynamics/' // "metadyn-descriptor.xml" - ! - ! ... descriptor file - ! - CALL iotk_open_read( iunit, FILE = filename, IERR = ierr ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id ) - ! - CALL errore( 'read_metadyn_restart', & - 'restart file ' // TRIM( filename ) // ' not found', ierr ) - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_dat( iunit, & - "NUM_OF_COLLECTIVE_VARIABLES", ncolvar_in ) - ! - IF ( ncolvar_in == ncolvar ) THEN - ! - ncolvar = ncolvar_in - ! - ELSE - ! - CALL errore( 'read_metadyn_restart', & - 'wrong number of collective variables', 1 ) - ! - END IF - ! - CALL iotk_scan_dat( iunit, "STEP", first_metadyn_iter ) - ! - DO i = 1, first_metadyn_iter - ! - tag = "ITERATION" // TRIM( iotk_index( i ) ) - ! - CALL iotk_scan_begin( iunit, TRIM( tag ) ) - ! - CALL iotk_scan_dat( iunit, & - "GAUSSIAN_CENTERS", metadyn_history(:,i) ) - ! - CALL iotk_scan_end( iunit, TRIM( tag ) ) - ! - END DO - ! - CALL iotk_close_read( iunit ) - ! - ! ... information about the last step - ! - CALL iotk_open_read( iunit, FILE = filename ) - ! - tag = "ITERATION" // TRIM( iotk_index( first_metadyn_iter ) ) - ! - CALL iotk_scan_begin( iunit, TRIM( tag ) ) - ! - CALL iotk_scan_begin( iunit, "IONS" ) - ! - DO i = 1, SIZE( tau, DIM = 2 ) - ! - CALL iotk_scan_empty( iunit, & - "ATOM" // TRIM( iotk_index( i ) ), attr ) - CALL iotk_scan_attr( attr, "tau", tau(:,i) ) - ! - END DO - ! - CALL iotk_scan_end( iunit, "IONS" ) - ! - CALL iotk_scan_dat( iunit, & - "COLLECTIVE_VARIABLES", constr_target(1:ncolvar) ) - ! - CALL iotk_scan_dat( iunit, "GAUSSIAN_CENTERS", gaussian_pos(:) ) - CALL iotk_scan_dat( iunit, "POTENTIAL_OF_MEAN_FORCE", fe_grad(:) ) - ! - CALL iotk_scan_end( iunit, TRIM( tag ) ) - ! - CALL iotk_close_read( iunit ) - ! - ! ... positions are converted to internal units - ! - tau(:,:) = tau(:,:) / pos_unit - ! - END IF - ! - CALL mp_bcast( ncolvar, ionode_id ) - CALL mp_bcast( first_metadyn_iter, ionode_id ) - CALL mp_bcast( metadyn_history, ionode_id ) - CALL mp_bcast( tau, ionode_id ) - CALL mp_bcast( constr_target, ionode_id ) - CALL mp_bcast( gaussian_pos, ionode_id ) - CALL mp_bcast( fe_grad, ionode_id ) - ! - RETURN - ! - END SUBROUTINE read_metadyn_restart - ! - !------------------------------------------------------------------------ - SUBROUTINE write_axsf_file( image, tau, tau_units ) - !------------------------------------------------------------------------ - ! - USE input_parameters, ONLY : atom_label - USE io_files, ONLY : iunaxsf - USE constants, ONLY : bohr_radius_angs - USE ions_base, ONLY : nat, ityp - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: image - REAL(DP), INTENT(IN) :: tau(:,:) - REAL(DP), INTENT(IN) :: tau_units - ! - INTEGER :: ia - LOGICAL :: opnd - ! - ! - INQUIRE( UNIT = iunaxsf, OPENED = opnd ) - IF ( .NOT.opnd ) & - CALL errore( 'write_axsf_file', & - 'unit to write the axsf file is closed', 1 ) - ! - WRITE( UNIT = iunaxsf, FMT = '(" PRIMCOORD ",I5)' ) image - WRITE( UNIT = iunaxsf, FMT = '(I5," 1")' ) nat - ! - DO ia = 1, nat - ! - WRITE( UNIT = iunaxsf, FMT = '(A2,3(2X,F18.10))' ) & - TRIM( atom_label(ityp(ia)) ), & - tau(1,ia)*tau_units*bohr_radius_angs, & - tau(2,ia)*tau_units*bohr_radius_angs, & - tau(3,ia)*tau_units*bohr_radius_angs - ! - END DO - ! - RETURN - ! - END SUBROUTINE write_axsf_file - ! -END MODULE metadyn_io diff --git a/quantum_espresso/kcp/Modules/metadyn_vars.f90 b/quantum_espresso/kcp/Modules/metadyn_vars.f90 deleted file mode 100644 index 1dea19312..000000000 --- a/quantum_espresso/kcp/Modules/metadyn_vars.f90 +++ /dev/null @@ -1,108 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE metadyn_vars - !---------------------------------------------------------------------------- - ! - ! ... this module contains the variables necessary for the implementation of - ! ... meta-dynamics and for the calculation of free-energy barriers by means - ! ... of the fourier string method - ! - ! ... code written by Carlo Sbraccia (2005) - ! - USE kinds, ONLY : DP - ! - IMPLICIT NONE - ! - SAVE - ! - INTEGER :: ncolvar - ! - INTEGER :: fe_nstep, sw_nstep, eq_nstep - ! - REAL(DP), ALLOCATABLE :: dfe_acc(:) - REAL(DP), ALLOCATABLE :: fe_grad(:) - REAL(DP), ALLOCATABLE :: new_target(:) - REAL(DP), ALLOCATABLE :: to_target(:) - ! - LOGICAL :: to_new_target - ! - INTEGER :: max_metadyn_iter - ! - REAL(DP), ALLOCATABLE :: fe_step(:) - REAL(DP), ALLOCATABLE :: gaussian_pos(:) - ! - REAL(DP), ALLOCATABLE :: metadyn_history(:,:) - ! - REAL(DP) :: g_amplitude - ! - REAL(DP) :: etot_av - ! - INTEGER :: first_metadyn_iter - ! - CHARACTER(LEN=80) :: metadyn_fmt - ! - CONTAINS - ! - !------------------------------------------------------------------------ - SUBROUTINE init_metadyn_vars() - !------------------------------------------------------------------------ - ! - USE input_parameters, ONLY : ncolvar_inp, & - g_amplitude_ => g_amplitude, & - fe_step_ => fe_step, & - fe_nstep_ => fe_nstep, & - sw_nstep_ => sw_nstep, & - eq_nstep_ => eq_nstep - USE control_flags, ONLY : lmetadyn, nstep - ! - IMPLICIT NONE - ! - ! - ncolvar = ncolvar_inp - ! - ALLOCATE( fe_step( ncolvar ) ) - ALLOCATE( dfe_acc( ncolvar ) ) - ALLOCATE( fe_grad( ncolvar ) ) - ALLOCATE( new_target( ncolvar ) ) - ALLOCATE( to_target( ncolvar ) ) - ! - IF ( lmetadyn ) THEN - ! - ALLOCATE( gaussian_pos( ncolvar ) ) - ALLOCATE( metadyn_history( ncolvar, nstep ) ) - ! - END IF - ! - fe_nstep = fe_nstep_ - sw_nstep = sw_nstep_ - eq_nstep = eq_nstep_ - g_amplitude = g_amplitude_ - fe_step(:) = fe_step_(1:ncolvar) - ! - RETURN - ! - END SUBROUTINE init_metadyn_vars - ! - !------------------------------------------------------------------------ - SUBROUTINE deallocate_metadyn_vars() - !------------------------------------------------------------------------ - ! - IF ( ALLOCATED( fe_step ) ) DEALLOCATE( fe_step ) - IF ( ALLOCATED( dfe_acc ) ) DEALLOCATE( dfe_acc ) - IF ( ALLOCATED( fe_grad ) ) DEALLOCATE( fe_grad ) - IF ( ALLOCATED( new_target ) ) DEALLOCATE( new_target ) - IF ( ALLOCATED( to_target ) ) DEALLOCATE( to_target ) - IF ( ALLOCATED( metadyn_history ) ) DEALLOCATE( metadyn_history ) - IF ( ALLOCATED( gaussian_pos ) ) DEALLOCATE( gaussian_pos ) - ! - RETURN - ! - END SUBROUTINE deallocate_metadyn_vars - ! -END MODULE metadyn_vars diff --git a/quantum_espresso/kcp/Modules/metagga.f90 b/quantum_espresso/kcp/Modules/metagga.f90 deleted file mode 100644 index 26246e7f6..000000000 --- a/quantum_espresso/kcp/Modules/metagga.f90 +++ /dev/null @@ -1,670 +0,0 @@ -! -! Copyright (C) 2001-2006 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!----------------------------------------------------------------------- -subroutine tpsscxc(rho,grho,tau, & - sx,sc,v1x,v2x,v3x,v1c,v2c,v3c) - !----------------------------------------------------------------------- - ! tpss metaGGA corrections for exchange and correlation - Hartree a.u. - ! - ! input: rho, grho=|\nabla rho|^2 - ! definition: E_x = \int E_x(rho,grho) dr - ! output: sx = E_x(rho,grho) - ! v1x= D(E_x)/D(rho) - ! v2x= D(E_x)/D( D rho/D r_alpha ) / |\nabla rho| - ! sc, v1c, v2c as above for correlation - !c v3x= D(E_x)/D(tau) - ! tau is the kinetic energy density - ! the same applies to correlation terms - ! - ! input grho is |\nabla rho|**2 - ! - USE kinds, ONLY : DP - - implicit none - - real(DP) :: rho, grho, tau,sx, sc, v1x, v2x,v3x,v1c,v2c,v3c - real(DP) :: small - parameter (small = 1.E-10_DP) - ! exchange - if (rho.le.small) then - sx = 0.0_DP - v1x = 0.0_DP - v2x = 0.0_DP - sc = 0.0_DP - v1c = 0.0_DP - v2c = 0.0_DP - v3x = 0.0_DP - v3c=0.0_DP - return - end if - call metax(rho,grho,tau,sx,v1x,v2x,v3x) - ! - call metac(rho,grho,tau,sc,v1c,v2c,v3c) - ! - return -end subroutine tpsscxc -!c ================================================================== -subroutine metax(rho,grho2,tau,ex,v1x,v2x,v3x) - ! ==--------------------------------------------------------------== - ! == meta-GGA exchange potential and energy == - ! == == - ! ==--------------------------------------------------------------== - - USE kinds, ONLY : DP - - ! NOTA BENE: E_x(rho,grho)=rho\epsilon_x(rho,grho) - ! ex = E_x(rho,grho) NOT \epsilon_x(rho,grho) - ! v1x= D(E_x)/D(rho) - ! v2x= D(E_x)/D( D rho/D r_alpha ) / |\nabla rho| - ! v3x= D(E_x)/D( tau ) - ! tau is the kinetic energy density - ! the same applies to correlation terms - ! input grho2 is |\nabla rho|^2 - implicit none - ! INPUT - real(DP) :: rho,grho2,tau,rs - ! OUTPUT - real(DP) :: ex,v1x,v2x,v3x - ! LOCAL - real(DP) :: vx_unif,ex_unif - ! ex_unif: lda \epsilon_x(rho) - ! ec_unif: lda \epsilon_c(rho) - real(DP) :: small, pi34, third - parameter (small=1.E-10_DP) - parameter (pi34 = 0.6203504908994_DP, third = 1.0_DP / 3.0_DP) - ! fx=Fx(p,z) - ! fxp=d Fx / d p - ! fxz=d Fx / d z - real(DP) fx,f1x,f2x,f3x - - ! ==--------------------------------------------------------------== - if(abs(tau).lt.small) then - ex=0.0_DP - v1x=0.0_DP - v2x=0.0_DP - v3x=0.0_DP - return - endif - rs = pi34/rho**third - call slater(rs,ex_unif,vx_unif) - call metaFX(rho,grho2,tau,fx,f1x,f2x,f3x) - ex =rho*ex_unif - v1x=vx_unif*fx + ex*f1x - v2x=ex*f2x - v3x=ex*f3x - ex =ex*fx - - ! ==--------------------------------------------------------------== - return -end subroutine metax -!== ------------------------------------------------------------------ -subroutine metac(rho,grho2,tau,ec,v1c,v2c,v3c) - !== ------------------------------------------------------------------ - ! meta-GGA correlation energy and potentials - !== ------------------------------------------------------------------ - USE kinds, ONLY : DP - implicit none - ! INPUT - real(DP) :: rho, grho2, tau - ! OUTPUT - real(DP) :: ec, v1c,v2c,v3c - ! LOCAL - real(DP) :: z,z2,tauw,ec_rev,rs - real(DP) :: d1rev, d2rev, d3rev - ! d1ec= D ec_rev / D rho - ! d2ec= D ec_rev / D |D rho/ D r| / |\nabla rho| - ! d3ec= D ec_rev / D tau - real(DP) :: cf1,cf2,cf3 - real(DP) :: v1c_pbe, v2c_pbe, ec_pbe - real(DP) :: v1c_sum, v2c_sum, ec_sum - real(DP) :: vc_unif,ec_unif - real(DP) :: dd,cab,cabone - real(DP) :: rhoup,grhoup,dummy - real(DP) :: small, pi34,third - parameter(small=1.0E-10_DP) - parameter (pi34= 0.75_DP/3.141592653589793_DP, & - third=1.0_DP/3.0_DP) - parameter (dd=2.80_DP) !in unit of Hartree^-1 - parameter (cab=0.53_DP, cabone=1.0_DP+cab) - ! - if(abs(tau).lt.small) then - ec=0.0_DP - v1c=0.0_DP - v2c=0.0_DP - v3c=0.0_DP - return - endif - rhoup=0.5_DP*rho - grhoup=0.5_DP*SQRT(grho2) - if(rhoup.gt.small) then - call pw_spin((pi34/rhoup)**third,1.0_DP,ec_unif,vc_unif,dummy) - if(abs(grhoup).gt.small) then -!1.0_DP-small to avoid pow_e of 0 in pbec_spin - call pbec_spin(rhoup,1.0_DP-small,grhoup**2,1,& - ec_sum,v1c_sum,dummy,v2c_sum) - else - ec_sum=0.0_DP - v1c_sum=0.0_DP - v2c_sum=0.0_DP - endif - ec_sum = ec_sum/rhoup + ec_unif - v1c_sum = (v1c_sum + vc_unif-ec_sum)/rho !rho, not rhoup - v2c_sum = v2c_sum/(2.0_DP*rho) - else - ec_sum=0.0_DP - v1c_sum=0.0_DP - v2c_sum=0.0_DP - endif - ! - rs = (pi34/rho)**third - call pw (rs, 1, ec_unif, vc_unif) - ! PBE correlation energy and potential - ! ec_pbe=rho*H, not rho*(epsion_c_uinf + H) - ! v1c_pbe=D (rho*H) /D rho - ! v2c_pbe= for rho, 2 for - call pbec(rho,grho2,1,ec_pbe,v1c_pbe,v2c_pbe) - ec_pbe=ec_pbe/rho+ec_unif - v1c_pbe=(v1c_pbe+vc_unif-ec_pbe)/rho - v2c_pbe=v2c_pbe/rho - ! - if(ec_sum .lt. ec_pbe) then - ec_sum = ec_pbe - v1c_sum= v1c_pbe - v2c_sum= v2c_pbe - endif - ! - tauw=0.1250_DP*grho2/rho - z=tauw/tau - z2=z*z - ! - ec_rev=ec_pbe*(1+cab*z2)-cabone*z2*ec_sum - d1rev = v1c_pbe + (cab*v1c_pbe-cabone*v1c_sum)*z2 & - -(ec_pbe*cab - ec_sum*cabone)*2.0_DP*z2/rho - d2rev = v2c_pbe + (cab*v2c_pbe-cabone*v2c_sum)*z2 & - +(ec_pbe*cab - ec_sum*cabone)*4.0_DP*z2/grho2 - d3rev = -(ec_pbe*cab - ec_sum*cabone)*2.0_DP*z2/tau - ! - cf1=1.0_DP+dd*ec_rev*z2*z - cf2=rho*(1.0_DP+2.0_DP*z2*z*dd*ec_rev) - cf3=ec_rev*ec_rev*3.0_DP*dd*z2*z - v1c=ec_rev*cf1 + cf2*d1rev-cf3 - ! - cf3=cf3*rho - v2c=cf2*d2rev + cf3*2.0_DP/grho2 - v3c=cf2*d3rev - cf3/tau - - ec=rho*ec_rev*(1.0_DP+dd*ec_rev*z2*z) !-rho*ec_unif - v1c=v1c !-vc_unif - ! ==--------------------------------------------------------------== - return -end subroutine metac -! ================================================================== -subroutine metaFX(rho,grho2,tau,fx,f1x,f2x,f3x) - ! ================================================================== - USE kinds, ONLY : DP - implicit none - ! INPUT - ! charge density, square of gradient of rho, and kinetic energy density - real(DP) rho, grho2, tau - ! OUTPUT - ! fx = Fx(p,z) - ! f1x=D (Fx) / D rho - ! f2x=D (Fx) / D ( D rho/D r_alpha) /|nabla rho| - ! f3x=D (Fx) / D tau - real(DP) fx, f1x, f2x, f3x - ! LOCAL - real(DP) x, p, z, qb, al, localdp, dz - real(DP) dfdx, dxdp, dxdz, dqbdp, daldp, dqbdz, daldz - real(DP) fxp, fxz ! fxp =D fx /D p - real(DP) tauw, tau_unif - ! work variables - real(DP) xf1,xf2 - real(DP) xfac1, xfac2, xfac3,xfac4,xfac5,xfac6,xfac7,z2 - ! - real(DP) pi, THRD, ee, cc, kk, bb,miu,fac1,small - parameter(pi=3.141592653589793_DP) - parameter(THRD=0.3333333333333333_DP) - parameter(ee=1.537_DP) - parameter(cc=1.59096_DP) - parameter(kk=0.804_DP) - parameter(bb=0.40_DP) - parameter(miu=0.21951_DP) - parameter(fac1=9.57078000062731_DP) !fac1=(3*pi^2)^(2/3) - parameter(small=1.0E-6_DP) - !==------------------------------------------------------------- - tauw=0.125_DP*grho2/rho - z=tauw/tau - - p=sqrt(grho2)/rho**THRD/rho - p=p*p/(fac1*4.0_DP) - tau_unif=0.3_DP*fac1*rho**(5.0_DP/3.0_DP) - al=(tau-tauw)/tau_unif - al=abs(al) !make sure al is always .gt. 0.0_DP - qb=0.45_DP*(al-1.0_DP)/sqrt(1.0_DP+bb*al*(al-1.0_DP)) - qb=qb+2.0_DP*THRD*p - - ! calculate x(p,z) and fx - z2=z*z - xf1=10.0_DP/81.0_DP - xfac1=xf1+cc*z2/(1+z2)**2.0_DP - xfac2=146.0_DP/2025.0_DP - xfac3=sqrt(0.5_DP*(0.36_DP*z2+p*p)) - xfac4=xf1*xf1/kk - xfac5=2.0_DP*sqrt(ee)*xf1*0.36_DP - xfac6=xfac1*p+xfac2*qb**2.0_DP-73.0_DP/405.0_DP*qb*xfac3 - xfac6=xfac6+xfac4*p**2.0_DP+xfac5*z2+ee*miu*p**3.0_DP - xfac7=(1+sqrt(ee)*p) - x=xfac6/(xfac7*xfac7) - ! fx=kk-kk/(1.0_DP+x/kk) - fx=1.0_DP + kk-kk/(1.0_DP+x/kk) - - ! calculate the derivatives of fx w.r.t p and z - dfdx=(kk/(kk+x))**2.0_DP - daldp=5.0_DP*THRD*(tau/tauw-1.0_DP) - ! daldz=-0.50_DP*THRD* - ! * (tau/(2.0_DP*fac1*rho**THRD*0.1250_DP*sqrt(grho2)))**2.0_DP - daldz=-5.0_DP*THRD*p/z2 - dqbdz=0.45_DP*(0.50_DP*bb*(al-1.0_DP)+1.0_DP) - dqbdz=dqbdz/(1.0_DP+bb*al*(al-1.0_DP))**1.5_DP - - dqbdp=dqbdz*daldp+2.0_DP*THRD - dqbdz=dqbdz*daldz - ! calculate d x /d p - xf1=73.0_DP/405.0_DP/xfac3*0.50_DP*qb - xf2=2.0_DP*xfac2*qb-73.0_DP/405.0_DP*xfac3 - - dxdp=-xf1*p - dxdp=dxdp+xfac1+xf2*dqbdp - dxdp=dxdp+2.0_DP*xfac4*p - dxdp=dxdp+3.0_DP*ee*miu*p*p - dxdp=dxdp/(xfac7*xfac7)-2.0_DP*x*sqrt(ee)/xfac7 - ! d x/ dz - dxdz=-xf1*0.36_DP*z - xfac1=cc*2.0_DP*z*(1-z2)/(1+z2)**3.0_DP - dxdz=dxdz+xfac1*p+xf2*dqbdz - dxdz=dxdz+xfac5*2.0_DP*z - dxdz=dxdz/(xfac7*xfac7) - - fxp=dfdx*dxdp - fxz=dfdx*dxdz - ! calculate f1x - localdp=-8.0_DP*THRD*p/rho ! D p /D rho - dz=-z/rho ! D z /D rho - f1x=fxp*localdp+fxz*dz - ! f2x - localdp=2.0_DP/(fac1*4.0_DP*rho**(8.0_DP/3.0_DP)) - dz=2.0_DP*0.125_DP/(rho*tau) - f2x=fxp*localdp + fxz*dz - ! f3x - localdp=0.0_DP - dz=-z/tau - f3x=fxz*dz - - ! - - !==--------------------------------------------------------------- - return -end subroutine metaFX - -!----------------------------------------------------------------------- -!------------------------------------------------------------------- -subroutine tpsscx_spin(rhoup,rhodw,grhoup2,grhodw2,tauup,taudw,sx,& - v1xup,v1xdw,v2xup,v2xdw,v3xup,v3xdw) - !----------------------------------------------------------------------- - ! TPSS metaGGA for exchange - Hartree a.u. - ! - USE kinds, ONLY : DP - implicit none - ! - ! dummy arguments - ! - real(DP) :: rhoup, rhodw, grhoup2, grhodw2, sx, v1xup, v1xdw, & - v2xup, v2xdw - ! up and down charge - ! up and down gradient of the charge - ! exchange and correlation energies - ! derivatives of exchange wr. rho - ! derivatives of exchange wr. grho - ! - real(DP):: tauup,taudw, &! up and down kinetic energy density - v3xup,v3xdw ! derivatives of exchange wr. tau - real(DP) :: small - parameter (small = 1.E-10_DP) - real(DP) :: rho, sxup, sxdw - ! - ! exchange - rho = rhoup + rhodw - if (rhoup.gt.small.and.sqrt(abs(grhoup2)).gt.small & - .and. abs(tauup).gt.small) then - call metax(2.0_DP*rhoup,4.0_DP*grhoup2, & - 2.0_DP*tauup,sxup,v1xup,v2xup,v3xup) - else - sxup=0.0_DP - v1xup=0.0_DP - v2xup=0.0_DP - v3xup=0.0_DP - endif - if (rhodw.gt.small.and.sqrt(abs(grhodw2)).gt.small & - .and. abs(taudw).gt.small) then - call metax(2.0_DP*rhodw,4.0_DP*grhodw2, & - 2.0_DP*taudw,sxdw,v1xdw,v2xdw,v3xdw) - else - sxdw=0.0_DP - v1xdw=0.0_DP - v2xdw=0.0_DP - v3xdw=0.0_DP - endif - sx=0.5_DP*(sxup+sxdw) - v2xup=2.0_DP*v2xup - v2xdw=2.0_DP*v2xdw - ! - return -end subroutine tpsscx_spin -! -!----------------------------------------------------------------------- -subroutine tpsscc_spin(rho,zeta,grhoup,grhodw, & - atau,sc,v1cup,v1cdw,v2cup,v2cdw,v3c) -!----------------------------------------------------------------------- -! tpss metaGGA for correlations - Hartree a.u. -! - USE kinds, ONLY : DP - implicit none -! -! dummy arguments -! - real(DP) :: rho, zeta, grhoup(3),grhodw(3), sc, v1cup, v1cdw, v2c - ! the total charge - ! the magnetization - ! the gradient of the charge - ! exchange and correlation energies - ! derivatives of correlation wr. rho - ! derivatives of correlation wr. grho - real(DP) :: atau,v2cup(3),v2cdw(3),v3c,grho_vec(3),grho !grho=grho2 - real(DP) :: small - integer :: ipol - parameter (small = 1.E-10_DP) - ! - ! -! vector - grho_vec=grhoup+grhodw - grho=0.0_DP - do ipol=1,3 - grho = grho + grho_vec(ipol)**2 - end do -! -! - if (rho.le.small.or.abs (zeta) .gt.1.0_DP.or.sqrt (abs (grho) ) & - .le.small.or.abs(atau).lt.small) then - sc = 0.0_DP - v1cup = 0.0_DP - v1cdw = 0.0_DP - v2cup(:) = 0.0_DP - v2cdw(:) = 0.0_DP - v3c = 0.0_DP - else - call metac_spin(rho,zeta,grhoup,grhodw, & - atau,sc,v1cup,v1cdw,v2cup,v2cdw,v3c) - end if - ! - return -end subroutine tpsscc_spin -! - -!--------------------------------------------------------------- -subroutine metac_spin(rho,zeta,grhoup,grhodw, & - tau,sc,v1up,v1dw,v2up,v2dw,v3) -!--------------------------------------------------------------- - USE kinds, ONLY : DP - implicit none -! input - real(DP) :: rho, zeta,grhoup(3),grhodw(3), tau -! output - real(DP) :: sc, v1up, v1dw, v2up(3), v2dw(3), v3 -! local - real(DP) :: rhoup, rhodw,tauw,grhovec(3),grho2,grho,& - grhoup2,grhodw2 - !grhovec vector gradient of rho - !grho mod of gradient of rho - real(DP) :: ec_u, vcup_u, vcdw_u - real(DP) :: ec_pbe, v1up_pbe, v1dw_pbe,v2up_pbe(3),v2dw_pbe(3) - real(DP) :: ecup_0, v1up_0, v2up_0(3),v2_tmp - real(DP) :: ecdw_0, v1dw_0, v2dw_0(3) - real(DP) :: ec_rev, cab, aa, bb, aa2 - real(DP) :: z2,z,ca0,dca0da,dcabda,dcabdb - real(DP) :: term(3),term1,term2,term3 - real(DP) :: drev1up, drev1dw,drev2up(3),drev2dw(3),drev3 - real(DP) :: sum, dsum1up, dsum1dw,dsum2up(3),dsum2dw(3) - real(DP) :: dcab1up, dcab1dw,dcab2up(3),dcab2dw(3) - real(DP) :: db1up, db1dw, db2up(3), db2dw(3) - real(DP) :: da1up, da1dw - real(DP) :: ecup_til,ecdw_til - real(DP) :: v1up_uptil, v1up_dwtil, v2up_uptil(3),v2up_dwtil(3) - real(DP) :: v1dw_uptil, v1dw_dwtil, v2dw_uptil(3),v2dw_dwtil(3) - real(DP) :: small, pi34, p43, third, fac - parameter(small=1.0E-10_DP, & - fac=3.09366772628013593097_DP**2) -! fac = (3*PI**2)**(2/3) - parameter (pi34= 0.75_DP / 3.141592653589793_DP, & - p43=4.0_DP/3.0_DP,third=1.0_DP/3.0_DP) - integer:: ipol -!----------- - rhoup=(1+zeta)*0.5_DP*rho - rhodw=(1-zeta)*0.5_DP*rho - grho2=0.0_DP - grhoup2=0.0_DP - grhodw2=0.0_DP - do ipol=1,3 - grhovec(ipol)=grhoup(ipol)+grhodw(ipol) - grho2=grho2+grhovec(ipol)**2 - grhoup2=grhoup2+grhoup(ipol)**2 - grhodw2=grhodw2+grhodw(ipol)**2 - end do - grho=sqrt(grho2) -! - if(rho.gt.small) then - v2_tmp=0.0_DP - call pw_spin((pi34/rho)**third,zeta,ec_u,vcup_u,vcdw_u) - if((abs(grho).gt.small) .and. (zeta .le. 1.0_DP)) then - call pbec_spin(rho,zeta,grho2,1,& - ec_pbe,v1up_pbe,v1dw_pbe,v2_tmp) - else - ec_pbe=0.0_DP - v1up_pbe=0.0_DP - v1dw_pbe=0.0_DP - v2up_pbe=0.0_DP - endif - ec_pbe = ec_pbe/rho+ec_u -! v1xx_pbe = D_epsilon_c/ D_rho_xx :xx= up, dw - v1up_pbe = (v1up_pbe+vcup_u-ec_pbe)/rho - v1dw_pbe = (v1dw_pbe+vcdw_u-ec_pbe)/rho -! v2xx_pbe = (D_Ec / D grho)/rho = (D_Ec/ D |grho| /|grho|)*grho/rho - v2up_pbe = v2_tmp/rho*grhovec -! v2dw === v2up for PBE - v2dw_pbe = v2up_pbe - else - ec_pbe=0.0_DP - v1up_pbe=0.0_DP - v1dw_pbe=0.0_DP - v2up_pbe=0.0_DP - v2dw_pbe=0.0_DP - endif -! ec_pbe(rhoup,0,grhoup,0) - if(rhoup.gt.small) then - v2_tmp=0.0_DP - call pw_spin((pi34/rhoup)**third,1.0_DP,ec_u,vcup_u,vcdw_u) - if(sqrt(grhoup2).gt.small) then - call pbec_spin(rhoup,1.0_DP-small,grhoup2,1,& - ecup_0,v1up_0,v1dw_0,v2_tmp) - else - ecup_0=0.0_DP - v1up_0=0.0_DP - v2up_0=0.0_DP - endif - ecup_0 = ecup_0/rhoup + ec_u - v1up_0 = (v1up_0 + vcup_u-ecup_0)/rhoup - v2up_0 = v2_tmp/rhoup*grhoup - else - ecup_0 = 0.0_DP - v1up_0 = 0.0_DP - v2up_0 = 0.0_DP - endif -! - if(ecup_0.gt.ec_pbe) then - ecup_til = ecup_0 - v1up_uptil=v1up_0 - v2up_uptil=v2up_0 - v1up_dwtil=0.0_DP - v2up_dwtil=0.0_DP - else - ecup_til = ec_pbe - v1up_uptil= v1up_pbe - v1up_dwtil= v1dw_pbe - v2up_uptil= v2up_pbe - v2up_dwtil= v2up_pbe - endif -! ec_pbe(rhodw,0,grhodw,0) -! zeta = 1.0_DP - if(rhodw.gt.small) then - v2_tmp=0.0_DP - call pw_spin((pi34/rhodw)**third,-1.0_DP,ec_u,vcup_u,vcdw_u) - if(sqrt(grhodw2).gt.small) then - call pbec_spin(rhodw,-1.0_DP+small,grhodw2,1,& - ecdw_0,v1up_0,v1dw_0,v2_tmp) - else - ecdw_0=0.0_DP - v1dw_0=0.0_DP - v2dw_0=0.0_DP - endif - ecdw_0 = ecdw_0/rhodw + ec_u - v1dw_0 = (v1dw_0 + vcdw_u-ecdw_0)/rhodw - v2dw_0 = v2_tmp/rhodw*grhodw - else - ecdw_0 = 0.0_DP - v1dw_0 = 0.0_DP - v2dw_0 = 0.0_DP - endif -! - if(ecdw_0.gt.ec_pbe) then - ecdw_til = ecdw_0 - v1dw_dwtil=v1dw_0 - v2dw_dwtil=v2dw_0 - v1dw_uptil=0.0_DP - v2dw_uptil=0.0_DP - else - ecdw_til = ec_pbe - v1dw_dwtil= v1dw_pbe - v2dw_dwtil= v2dw_pbe - v1dw_uptil= v1up_pbe - v2dw_uptil= v2dw_pbe - endif -!cccccccccccccccccccccccccccccccccccccccccc-------checked - sum=(rhoup*ecup_til+rhodw*ecdw_til)/rho - dsum1up=(ecup_til-ecdw_til)*rhodw/rho**2 & - + (rhoup*v1up_uptil + rhodw*v1dw_uptil)/rho - dsum1dw=(ecdw_til-ecup_til)*rhoup/rho**2 & - + (rhodw*v1dw_dwtil + rhoup*v1up_dwtil)/rho -! vector - dsum2up=(rhoup*v2up_uptil + rhodw*v2dw_uptil)/rho - dsum2dw=(rhodw*v2dw_dwtil + rhoup*v2up_dwtil)/rho -!ccccccccccccccccccccccccccccccccccccccccc---------checked - aa=zeta -! bb=(rho*(grhoup-grhodw) - (rhoup-rhodw)*grho)**2 & -! /(4.0_DP*fac*rho**(14.0_DP/3.0_DP)) - bb=0.0_DP - do ipol=1,3 - term(ipol)= rhodw*grhoup(ipol)-rhoup*grhodw(ipol) - bb=bb+ term(ipol)**2 - end do -!vector - term=term/(fac*rho**(14.0_DP/3.0_DP)) - bb=bb/(fac*rho**(14.0_DP/3.0_DP)) -! bb=(rhodw*grhoup-rhoup*grhodw)**2/fac*rho**(-14.0_DP/3.0_DP) - aa2=aa*aa - ca0=0.53_DP+aa2*(0.87_DP+aa2*(0.50_DP+aa2*2.26_DP)) - dca0da = aa*(1.74_DP+aa2*(2.0_DP+aa2*13.56_DP)) - if(abs(aa).le.1.0_DP-small) then - term3 =(1.0_DP+aa)**(-p43) + (1.0_DP-aa)**(-p43) - term1=(1.0_DP+bb*0.50_DP*term3) - term2=(1.0_DP+aa)**(-7.0_DP/3.0_DP) + (1.0_DP-aa)**(-7.0_DP/3.0_DP) - cab =ca0/term1**4 - dcabda = (dca0da/ca0 + 8.0_DP/3.0_DP*bb*term2/term1)*cab - dcabdb = -2.0_DP*cab*term3/term1 - else - cab=0.0_DP - dcabda=0.0_DP - dcabdb=0.0_DP - endif - da1up=2.0_DP*rhodw/rho**2 - da1dw=-2.0_DP*rhoup/rho**2 - db1up=-2.0_DP*(grhodw(1)*term(1)+grhodw(2)*term(2)+grhodw(3)*term(3)) & - -14.0_DP/3.0_DP*bb/rho - db1dw= 2.0_DP*(grhoup(1)*term(1)+grhoup(2)*term(2)+grhoup(3)*term(3)) & - -14.0_DP/3.0_DP*bb/rho - !vector, not scalar - db2up= term*rhodw*2.0_DP - db2dw=-term*rhoup*2.0_DP -! - dcab1up = dcabda*da1up + dcabdb*db1up - dcab1dw = dcabda*da1dw + dcabdb*db1dw - !vector, not scalar - dcab2up = dcabdb*db2up - dcab2dw = dcabdb*db2dw -!cccccccccccccccccccccccccccccccccccccccccccccccccccccc------checked - tauw=0.1250_DP*grho2/rho - z=tauw/tau - z2=z*z -! - term1=1.0_DP+cab*z2 - term2=(1.0_DP+cab)*z2 - ec_rev = ec_pbe*term1-term2*sum -! - drev1up=v1up_pbe*term1 + & - ec_pbe*(z2*dcab1up - 2.0_DP*cab*z2/rho) & - + (2.0_DP*term2/rho - z2*dcab1up)*sum & - - term2*dsum1up -! - drev1dw=v1dw_pbe*term1 + & - ec_pbe*(z2*dcab1dw - 2.0_DP*cab*z2/rho) & - + (2.0_DP*term2/rho - z2*dcab1dw)*sum & - - term2*dsum1dw -! -! vector, not scalar - drev2up=v2up_pbe*term1 + & - ec_pbe*(z2*dcab2up+0.5_DP*cab*z/(rho*tau)*grhovec)& - - (term2*4.0_DP/grho2*grhovec + z2*dcab2up)*sum & - - term2*dsum2up - drev2dw=v2dw_pbe*term1 + & - ec_pbe*(z2*dcab2dw+0.5_DP*cab*z/(rho*tau)*grhovec) & - - (term2*4.0_DP/grho2*grhovec + z2*dcab2dw)*sum & - - term2*dsum2dw -! - drev3 = ((1.0_DP+cab)*sum-ec_pbe*cab)*2.0_DP*z2/tau -!ccccccccccccccccccccccccccccccccccccccccccccccccccc----checked - term1=ec_rev*(1.0_DP+2.8_DP*ec_rev*z2*z) - term2=(1.0_DP+5.6_DP*ec_rev*z2*z)*rho - term3=-8.4_DP*ec_rev*ec_rev*z2*z -! - v1up = term1 + term2*drev1up + term3 - v1dw = term1 + term2*drev1dw + term3 -! - term3=term3*rho - v3 = term2*drev3 + term3/tau -! - term3=-2.0_DP*term3/grho2 !grho/|grho|^2 = 1/grho - v2up = term2*drev2up + term3*grhovec - v2dw = term2*drev2dw + term3*grhovec - ! - ! - ! call pw_spin((pi34/rho)**third,zeta,ec_u,vcup_u,vcdw_u) - sc=rho*ec_rev*(1.0_DP+2.8_DP*ec_rev*z2*z) !-rho*ec_u - ! v1up=v1up-vcup_u - ! v1dw=v1dw-vcdw_u - - return -end subroutine metac_spin diff --git a/quantum_espresso/kcp/Modules/mm_dispersion.f90 b/quantum_espresso/kcp/Modules/mm_dispersion.f90 deleted file mode 100644 index d97a797fe..000000000 --- a/quantum_espresso/kcp/Modules/mm_dispersion.f90 +++ /dev/null @@ -1,688 +0,0 @@ -! -! Copyright (C) 2009 D. Forrer and M. Pavone -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!------------------------------------------------------------------------------ -! -MODULE london_module - ! - ! Module for Dispersion Correction - ! [ V. Barone et al. J. Comp. Chem., 30, 934 (2009) ] - ! [ S. Grimme, J. Comp. Chem., 27, 1787 (2006) ]. - ! - USE kinds , ONLY : DP - ! - IMPLICIT NONE - ! - SAVE - ! - ! - REAL ( DP ) , ALLOCATABLE , PRIVATE :: C6_i ( : ) , & - R_vdw ( : ) , & - C6_ij ( : , : ) , & - R_sum ( : , : ) , & - r ( : , : ) , & - dist2 ( : ) - ! - ! C6_i ( ntyp ) : atomic C6 coefficient of each atom type - ! R_vdw ( ntyp ) : Van der Waals Radii of each atom type - ! C6_ij ( ntyp , ntyp ) : C6 coefficients of each atom type pair: sqrt ( C6i * C6j ) - ! R_sum ( ntyp , ntyp ) : sum of VdW radii - ! r ( 3 , mxr ) : ordered distance vectors - ! dist2 ( mxr ) : ordered distances - ! - REAL ( DP ) , PUBLIC :: scal6 , lon_rcut - ! - ! scal6 : global scaling factor - ! lon_rcut : public cut-off radius - ! - INTEGER , PRIVATE :: mxr - ! - ! max number of r ( see rgen) - ! - REAL ( DP ) , PRIVATE :: r_cut , beta = 20.0_DP - ! - ! beta : damping function parameter - ! r_cut : cut-off radius in alat units - ! - CONTAINS - ! - !--------------------------------------------------------------------------- - ! Initialize parameters - !--------------------------------------------------------------------------- - ! - SUBROUTINE init_london ( ) - ! - ! extract parameters from database and compute C6_ij and R_sum(i,j) - ! - USE ions_base , ONLY : ntyp => nsp, & - atom_label => atm - ! - USE cell_base , ONLY : alat, omega - ! - USE io_global, ONLY : ionode, ionode_id, stdout - ! -#if defined __PARA - USE mp, ONLY : mp_bcast -#endif - ! - IMPLICIT NONE - ! - INTEGER, PARAMETER :: maxZ = 54 - REAL (DP) :: vdw_coeffs(2,maxZ) - ! vdw C6 and radii for the first 54 atoms - DATA vdw_coeffs / & - 4.857, 1.892,& - 2.775, 1.912,& - 55.853, 1.559,& - 55.853, 2.661,& - 108.584, 2.806,& - 60.710, 2.744,& - 42.670, 2.640,& - 24.284, 2.536,& - 26.018, 2.432,& - 21.855, 2.349,& - 198.087, 2.162,& - 198.087, 2.578,& - 374.319, 3.097,& - 320.200, 3.243,& - 271.980, 3.222,& - 193.230, 3.180,& - 175.885, 3.097,& - 159.927, 3.014,& - 374.666, 2.806,& - 374.666, 2.785,& - 374.666, 2.952,& - 374.666, 2.952,& - 374.666, 2.952,& - 374.666, 2.952,& - 374.666, 2.952,& - 374.666, 2.952,& - 374.666, 2.952,& - 374.666, 2.952,& - 374.666, 2.952,& - 374.666, 2.952,& - 589.405, 3.118,& - 593.221, 3.264,& - 567.896, 3.326,& - 438.498, 3.347,& - 432.600, 3.305,& - 416.642, 3.264,& - 855.833, 3.076,& - 855.833, 3.035,& - 855.833, 3.097,& - 855.833, 3.097,& - 855.833, 3.097,& - 855.833, 3.097,& - 855.833, 3.097,& - 855.833, 3.097,& - 855.833, 3.097,& - 855.833, 3.097,& - 855.833, 3.097,& - 855.833, 3.097,& - 1294.678, 3.160,& - 1342.899, 3.409,& - 1333.532, 3.555,& - 1101.101, 3.575,& - 1092.775, 3.575,& - 1040.391, 3.555/ - ! - INTEGER :: ilab , ata , atb , i - ! local : counter of atom type - ! ata , atb : counters of C6_ij matrix - ! counter - INTEGER, EXTERNAL :: atomic_number - !! - REAL ( DP ) :: R_0, C_0, e_cut , sls - ! local : buffers - ! - ! here we allocate parameters - ! - ALLOCATE ( C6_ij ( ntyp , ntyp ) , & - R_sum ( ntyp , ntyp ) ) - ! - IF ( ionode ) THEN - ! - ! and some buffers on ionode - ! - ALLOCATE ( C6_i ( ntyp ) , & - R_vdw ( ntyp ) ) - ! - ! here we initialize parameters to unphysical values - ! - C6_i ( : ) = -1.d0 - R_vdw ( : ) = -1.d0 - C6_ij ( : , : ) = -1.d0 - R_sum ( : , : ) = -1.d0 - ! - DO ilab = 1 , ntyp - ! - i = atomic_number ( atom_label ( ilab ) ) - IF ( i > 0 .AND. i < 55 ) THEN - C6_i ( ilab ) = vdw_coeffs(1,i) - R_vdw ( ilab ) = vdw_coeffs(2,i) - ELSE - CALL errore ( ' init_london ' ,& - 'atom ' // atom_label(ilab) //' not found ' , ilab ) - END IF - ! - END DO - ! - ! are there all the parameters we need? - ! - DO ilab = 1 , ntyp - ! - IF ( ( C6_i ( ilab ) < 0.d0 ) .or. & - ( R_vdw ( ilab ) < 0.d0 ) ) THEN - ! - CALL errore ( ' init_london ' ,& - ' one or more parameters not found ' , 4 ) - ! - END IF - ! - END DO - ! - ! ...here we store C6_ij parameters of each pair of atom types - ! into a square matrix C6_ij = sqrt ( C6_i * C6_j ) - ! - DO atb = 1 , ntyp - ! - DO ata = 1 , ntyp - ! - C6_ij ( ata , atb ) = sqrt ( C6_i ( ata ) * C6_i ( atb ) ) - ! - R_sum ( ata , atb ) = R_vdw ( ata ) + R_vdw ( atb ) - ! - END DO - ! - END DO - ! - WRITE ( stdout ,'( /, 5X, "-------------------------------------" , & - & /, 5X, "Parameters for Dispersion Correction:" , & - & /, 5X, "-------------------------------------" , & - & /, 5X, " atom VdW radius C_6 " , / )' ) - DO ata = 1 , ntyp - ! - WRITE (stdout , '( 8X, A3 , 6X , F7.3 , 8X , F7.3 )' ) & - atom_label ( ata ) , R_vdw ( ata ) , C6_i ( ata ) - ! - END DO - ! - ! ... atomic parameters are deallocated - ! - DEALLOCATE ( C6_i , R_vdw ) - ! - ! ... cutoff radius in alat units - ! - r_cut = lon_rcut / alat - ! - ! ... define a gross maximum bound of the mxr size - ! - mxr = INT ( ( 2 * ( lon_rcut + alat ) ) ** 3 / omega ) - ! - END IF - ! -#if defined __PARA - ! broadcast data to all processors - ! - CALL mp_bcast ( C6_ij, ionode_id ) - CALL mp_bcast ( R_sum, ionode_id ) - CALL mp_bcast ( r_cut, ionode_id ) - CALL mp_bcast ( mxr , ionode_id ) - ! -#endif - ! - ALLOCATE ( r ( 3 , mxr ) , dist2 ( mxr ) ) - ! - RETURN - ! - END SUBROUTINE init_london - ! - !--------------------------------------------------------------------------- - ! Compute dispersion energy - !--------------------------------------------------------------------------- - ! - FUNCTION energy_london ( alat , nat , ityp , at , bg , tau ) - ! - ! here we compute the dispersion contribution to the total energy - ! - ! E = - ( C_6^ij / R_ij ** 6 ) * f_damp ( R_ij ) * scal6 - ! - ! where f_damp is the damping function: - ! - ! f_damp ( R_ij ) = [ 1 + exp ( -beta ( R_ij / (R_i^0+R_j^0) - 1 )) ] ** (-1) - ! - ! and scal6 is a global scaling factor - ! -#if defined __PARA - USE mp_global, ONLY : mpime , nproc , intra_pool_comm - USE mp, ONLY : mp_sum -#endif - ! - IMPLICIT NONE - ! - !INTEGER , PARAMETER :: mxr = 500000 - ! local: max number of r ( see rgen ) - ! - INTEGER :: ata , atb , nrm , nr - ! locals : - ! ata , atb : atom counters - ! nrm : actual number of vectors computed by rgen - ! nr : counter - ! - INTEGER :: nprocs , first , last , resto , divid - ! locals : parallelization stuff - ! - INTEGER , INTENT ( IN ) :: nat , ityp ( nat ) - ! input: - ! nat : number of atoms - ! itype : type of each atom - ! - REAL ( DP ) :: dist , f_damp , energy_london , dtau ( 3 ) , dist6 - ! locals: - ! dist : distance R_ij between the current pair of atoms - ! f_damp : damping function - ! energy_london : the dispersion energy - ! dtau : output of rgen ( not used ) - ! dist6 : distance**6 - ! - REAL ( DP ) , INTENT ( IN ) :: alat , tau (3, nat) , & - at ( 3 , 3 ) , bg ( 3 , 3 ) - ! input : - ! alat : the cell parameter - ! tau : atomic positions in alat units - ! at : direct lattice vectors - ! bg : reciprocal lattice vectors - ! - energy_london = 0.d0 - ! -#if defined __PARA - ! - ! parallelization - ! - nprocs = nproc - ! - resto = MOD ( nat , nproc ) - divid = nat / nproc - ! - IF ( mpime + 1 <= resto ) THEN - ! - first = ( divid + 1 ) * mpime + 1 - last = ( divid + 1 ) * ( mpime + 1 ) - ! - ELSE - ! - first = ( ( divid + 1 ) * resto ) + ( divid ) * ( mpime - resto ) + 1 - last = ( divid + 1 ) * resto + ( divid ) * ( mpime - resto + 1 ) - ! - END IF - ! -#else - ! - first = 1 - last = nat -#endif - ! - ! ... the dispersion energy - ! - DO ata = first , last - ! - DO atb = 1 , nat - ! - dtau ( : ) = tau ( : , ata ) - tau ( : , atb ) - ! - CALL rgen ( dtau, r_cut, mxr, at, bg, r, dist2, nrm ) - ! - DO nr = 1 , nrm - ! - dist = alat * sqrt ( dist2 ( nr ) ) - dist6 = dist ** 6 - ! - f_damp = 1.d0 / ( 1.d0 + & - ! - exp ( -beta * ( dist / ( R_sum ( ityp ( atb ) , ityp ( ata ) ) ) - 1 ))) - ! - energy_london = energy_london - & - ( C6_ij ( ityp ( atb ) , ityp ( ata ) ) / dist6 ) * & - f_damp - ! - END DO - ! - END DO - ! - END DO - ! - energy_london = scal6 * 0.5d0 * energy_london - ! - ! -#if defined (__PARA) -999 CALL mp_sum ( energy_london , intra_pool_comm ) -#endif - ! - RETURN - ! - END FUNCTION energy_london - ! - !--------------------------------------------------------------------------- - ! Compute dispersion forces acting on atoms - !--------------------------------------------------------------------------- - ! - FUNCTION force_london ( alat , nat , ityp , at , bg , tau ) - ! - ! -#if defined __PARA - USE mp_global, ONLY : mpime , nproc , intra_pool_comm - USE mp, ONLY : mp_sum -#endif - ! - IMPLICIT NONE - ! - !INTEGER , PARAMETER :: mxr = 500000 - ! local: max number of r ( see rgen ) - ! - INTEGER :: ata , atb , nrm , nr , ipol - ! locals : - ! ata , atb : atom counters - ! nrm : actual number of vectors computed by rgen - ! nr : counter on neighbours shells - ! ipol : counter on coords - ! - INTEGER :: nprocs , first , last , resto, divid - ! locals : - ! nprocs : number of processors in use - ! first : lower bound on processor - ! last : upper - ! - INTEGER , INTENT ( IN ) :: nat , ityp ( nat ) - ! input: - ! nat : number of atoms - ! ityp : type of each atom - ! - REAL ( DP ) :: dist , f_damp , dtau ( 3 ) , force_london ( 3 , nat ) , & - dist6 , dist7 , exparg , expval , par , fac , add - ! locals : - ! dist : distance R_ij between the current pair of atoms - ! f_damp : damping function - ! dtau : \vec R_ij - ! force_london : dispersion forces - ! dist6 : dist**6 - ! dist7 : dist**7 - ! ... and some buffers - ! - REAL ( DP ) , INTENT ( IN ) :: alat , tau (3, nat) , & - at ( 3 , 3 ) , bg ( 3 , 3 ) - ! input: - ! alat : the cell parameter - ! tau : atomic positions in alat units - ! at : direct lattice vectors - ! bg : reciprocal lattice vectors - ! - ! - force_london ( : , : ) = 0.d0 - ! -#if defined __PARA - ! - ! parallelization - ! - nprocs = nproc - ! - resto = MOD ( nat , nproc ) - divid = nat / nproc - ! - IF ( mpime + 1 <= resto ) THEN - ! - first = ( divid + 1 ) * mpime + 1 - last = ( divid + 1 ) * ( mpime + 1 ) - ! - ELSE - ! - first = ( ( divid + 1 ) * resto ) + ( divid ) * ( mpime - resto ) + 1 - last = ( divid + 1 ) * resto + ( divid ) * ( mpime - resto + 1 ) - ! - END IF - ! -#else - ! - first = 1 - last = nat -#endif - ! - ! ... the dispersion forces - ! - DO ata = first , last - ! - DO atb = 1 , nat - ! - IF ( ata /= atb ) THEN - ! - dtau ( : ) = tau ( : , ata ) - tau ( : , atb ) - ! - ! generate neighbours shells - ! - CALL rgen ( dtau, r_cut, mxr, at, bg, r, dist2, nrm ) - ! - ! compute forces - ! - par = beta / ( R_sum ( ityp ( atb ) , ityp ( ata ) ) ) - ! - DO nr = 1 , nrm - ! - dist = alat * sqrt ( dist2 ( nr ) ) - dist6 = dist ** 6 - dist7 = dist6 * dist - ! - exparg = - beta * ( dist / ( R_sum ( ityp ( atb ) , ityp ( ata ) ) ) - 1 ) - ! - expval = exp ( exparg ) - ! - fac = C6_ij ( ityp ( atb ) , ityp ( ata ) ) / dist6 - ! - add = 6.d0 / dist - ! - DO ipol = 1 , 3 - ! - force_london ( ipol , ata ) = force_london ( ipol , ata ) + & - ( scal6 / ( 1 + expval ) * fac * & - ( - par * expval / ( 1.d0 + expval ) + add ) * & - r ( ipol , nr ) * alat / dist ) - ! - END DO - ! - END DO - ! - END IF - ! - END DO - ! - END DO - ! -#if defined (__PARA) -999 CALL mp_sum ( force_london , intra_pool_comm ) -#endif - ! - RETURN - ! - END FUNCTION force_london - ! - ! - !--------------------------------------------------------------------------- - ! Compute dispersion contribution to the stress tensor - !--------------------------------------------------------------------------- - ! - FUNCTION stres_london ( alat , nat , ityp , at , bg , tau , omega ) - ! - ! -#if defined __PARA - USE mp_global, ONLY : mpime , nproc , intra_pool_comm - USE mp, ONLY : mp_sum -#endif - ! - IMPLICIT NONE - ! - !INTEGER , PARAMETER :: mxr = 500000 - ! local: max number of r ( see rgen ) - ! - INTEGER :: ata , atb , nrm , nr , ipol , lpol , spol - ! locals : - ! ata , atb : atom counters - ! nrm : actual number of vectors computed by rgen - ! nr : counter on neighbours shells - ! xpol : coords counters ipol lpol spol - ! - INTEGER :: nprocs , first , last , resto, divid - ! locals : parallelization - ! - INTEGER , INTENT ( IN ) :: nat , ityp ( nat ) - ! input: - ! nat : number of atoms - ! ityp : type of each atom - ! - REAL ( DP ) :: dist , f_damp , dtau ( 3 ) , stres_london ( 3 , 3 ) , & - dist6 , dist7 , exparg , expval , par , fac , add - ! locals: - ! dist : distance R_ij of current pair of atoms - ! f_damp : damping function - ! dtau : \vec R_ij - ! stres_london : dispersion contribution to stress tensor - ! dist6 : dist**6 - ! dist7 : dist**7 - ! and some buffers - ! - REAL ( DP ) , INTENT ( IN ) :: alat , tau (3, nat) , omega , & - at ( 3 , 3 ) , bg ( 3 , 3 ) - ! input : - ! alat : the cell parameter - ! tau : atomic positions in alat units - ! omega : unit cell volume - ! at : direct lattice vectors - ! bg : reciprocal lattice vectors - ! - ! - ! - stres_london ( : , : ) = 0.d0 - ! - first=0 - last=0 - ! -#if defined __PARA - ! - ! parallelization - ! - nprocs = nproc - ! - resto = MOD ( nat , nproc ) - divid = nat / nproc - ! - IF ( mpime + 1 <= resto ) THEN - ! - first = ( divid + 1 ) * mpime + 1 - last = ( divid + 1 ) * ( mpime + 1 ) - ! - ELSE - ! - first = ( ( divid + 1 ) * resto ) + ( divid ) * ( mpime - resto ) + 1 - last = ( divid + 1 ) * resto + ( divid ) * ( mpime - resto + 1 ) - ! - END IF - ! -#else - ! - first = 1 - last = nat -#endif - ! - ! ... the dispersion stress tensor - ! - DO ata = first , last - ! - DO atb = 1 , nat - ! - dtau ( : ) = tau ( : , ata ) - tau ( : , atb ) - ! - ! generate neighbours shells - ! - CALL rgen ( dtau, r_cut, mxr, at, bg, r, dist2, nrm ) - ! - ! compute stress - ! - par = beta / ( R_sum ( ityp ( atb ) , ityp ( ata ) ) ) - ! - DO nr = 1 , nrm - ! - dist = alat * sqrt ( dist2 ( nr ) ) - dist6 = dist ** 6 - dist7 = dist6 * dist - ! - exparg = - beta * ( dist / ( R_sum ( ityp ( atb ) , ityp ( ata ) ) ) - 1 ) - ! - expval = exp ( exparg ) - ! - fac = C6_ij ( ityp ( atb ) , ityp ( ata ) ) / dist6 - ! - add = 6.d0 / dist - ! - DO ipol = 1 , 3 - ! - DO lpol = 1 , ipol - ! - stres_london ( lpol , ipol ) = stres_london ( lpol , ipol ) + & - ( scal6 / ( 1 + expval ) * fac * & - ( - par * expval / ( 1.d0 + expval ) + add ) * & - r ( ipol , nr ) * alat / dist ) * & - r ( lpol , nr ) * alat - ! - END DO - ! - END DO - ! - END DO - ! - END DO - ! - END DO - ! - DO ipol = 1 , 3 - ! - DO lpol = ipol + 1 , 3 - ! - stres_london ( lpol , ipol ) = stres_london ( ipol , lpol ) - ! - END DO - ! - END DO - ! - stres_london ( : , : ) = - stres_london ( : , : ) / ( 2.d0 * omega ) - ! -#if defined (__PARA) -999 CALL mp_sum ( stres_london , intra_pool_comm ) -#endif - ! - RETURN - ! - END FUNCTION stres_london - ! - !--------------------------------------------------------------------------- - ! clean memory - !--------------------------------------------------------------------------- - ! - SUBROUTINE dealloca_london - ! - ! - ! - IMPLICIT NONE - ! - IF ( ALLOCATED ( C6_i ) ) DEALLOCATE ( C6_i ) - IF ( ALLOCATED ( R_vdw ) ) DEALLOCATE ( R_vdw ) - IF ( ALLOCATED ( C6_ij ) ) DEALLOCATE ( C6_ij ) - IF ( ALLOCATED ( R_sum ) ) DEALLOCATE ( R_sum ) - IF ( ALLOCATED ( r ) ) DEALLOCATE ( r ) - IF ( ALLOCATED ( dist2 ) ) DEALLOCATE ( dist2 ) - ! - RETURN - ! - END SUBROUTINE dealloca_london - ! -END MODULE london_module diff --git a/quantum_espresso/kcp/Modules/mp.f90 b/quantum_espresso/kcp/Modules/mp.f90 deleted file mode 100644 index a1fa9ab23..000000000 --- a/quantum_espresso/kcp/Modules/mp.f90 +++ /dev/null @@ -1,2283 +0,0 @@ -! -! Copyright (C) 2002-2003 PWSCF-FPMD-CP90 group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -#if defined __HPM -# include "/cineca/prod/hpm/include/f_hpm.h" -#endif - - - -!------------------------------------------------------------------------------! - MODULE mp -!------------------------------------------------------------------------------! - USE kinds, ONLY : DP, i4b - USE io_global, ONLY : stdout - USE parallel_include - ! - IMPLICIT NONE - - PUBLIC :: mp_start, mp_end, mp_env, & - mp_bcast, mp_stop, mp_sum, mp_max, mp_min, mp_rank, mp_size, & - mp_gather, mp_get, mp_put, mp_barrier, mp_report, mp_group_free, & - mp_root_sum, mp_comm_free, mp_comm_create, mp_comm_group, mp_group_create, & - mp_comm_split, mp_set_displs -! - INTERFACE mp_bcast -#if defined __T3E - MODULE PROCEDURE mp_bcast_i1, mp_bcast_r1, mp_bcast_c1, & - mp_bcast_z, mp_bcast_zv, & - mp_bcast_iv, mp_bcast_rv, mp_bcast_cv, mp_bcast_l, mp_bcast_rm, & - mp_bcast_cm, mp_bcast_im, mp_bcast_it, mp_bcast_rt, mp_bcast_lv, & - mp_bcast_lm, mp_bcast_r4d, mp_bcast_r5d, mp_bcast_ct, mp_bcast_c4d, & - mp_bcast_i4b -#else - MODULE PROCEDURE mp_bcast_i1, mp_bcast_r1, mp_bcast_c1, & - mp_bcast_z, mp_bcast_zv, & - mp_bcast_iv, mp_bcast_rv, mp_bcast_cv, mp_bcast_l, mp_bcast_rm, & - mp_bcast_cm, mp_bcast_im, mp_bcast_it, mp_bcast_rt, mp_bcast_lv, & - mp_bcast_lm, mp_bcast_r4d, mp_bcast_r5d, mp_bcast_ct, mp_bcast_c4d -#endif - END INTERFACE - - INTERFACE mp_sum - MODULE PROCEDURE mp_sum_i1, mp_sum_iv, mp_sum_im, mp_sum_it, & - mp_sum_r1, mp_sum_rv, mp_sum_rm, mp_sum_rt, mp_sum_r4d, & - mp_sum_c1, mp_sum_cv, mp_sum_cm, mp_sum_ct, mp_sum_c4d, & - mp_sum_c5d, mp_sum_c6d, mp_sum_rmm, mp_sum_cmm - END INTERFACE - - INTERFACE mp_root_sum - MODULE PROCEDURE mp_root_sum_rm, mp_root_sum_cm - END INTERFACE - - INTERFACE mp_get - MODULE PROCEDURE mp_get_rv, mp_get_cv, mp_get_i1, mp_get_iv, & - mp_get_rm - END INTERFACE - - INTERFACE mp_put - MODULE PROCEDURE mp_put_rv, mp_put_cv, mp_put_i1, mp_put_iv, & - mp_put_rm - END INTERFACE - - INTERFACE mp_max - MODULE PROCEDURE mp_max_i, mp_max_r, mp_max_rv, mp_max_iv - END INTERFACE - INTERFACE mp_min - MODULE PROCEDURE mp_min_i, mp_min_r, mp_min_rv, mp_min_iv - END INTERFACE - INTERFACE mp_gather - MODULE PROCEDURE mp_gather_iv, mp_gatherv_rv, mp_gatherv_iv, & - mp_gatherv_rm, mp_gatherv_im, mp_gatherv_cv - END INTERFACE - INTERFACE mp_alltoall - MODULE PROCEDURE mp_alltoall_c3d, mp_alltoall_i3d - END INTERFACE - - INTEGER, ALLOCATABLE, PRIVATE, SAVE :: mp_call_count(:) - INTEGER, ALLOCATABLE, PRIVATE, SAVE :: mp_call_sizex(:) - - - CHARACTER(LEN=80), PRIVATE :: err_msg = ' ' - -!------------------------------------------------------------------------------! -! - CONTAINS -! -!------------------------------------------------------------------------------! -! -!------------------------------------------------------------------------------! -!..mp_gather_iv -!..Carlo Cavazzoni - SUBROUTINE mp_gather_iv(mydata, alldata, root, gid) - IMPLICIT NONE - INTEGER, INTENT(IN) :: mydata(:), root - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER, INTENT(OUT) :: alldata(:,:) - INTEGER :: msglen, ierr - - -#if defined (__MPI) - msglen = SIZE(mydata) - IF( msglen .NE. SIZE(alldata, 1) ) CALL mp_stop( 8000 ) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL MPI_GATHER(mydata, msglen, MPI_INTEGER, alldata, msglen, MPI_INTEGER, root, group, IERR) - IF (ierr/=0) CALL mp_stop( 8001 ) -#else - msglen = SIZE(mydata) - IF( msglen .NE. SIZE(alldata, 1) ) CALL mp_stop( 8002 ) - alldata(:,1) = mydata(:) -#endif - RETURN - END SUBROUTINE mp_gather_iv - -! -!------------------------------------------------------------------------------! -!..mp_start - SUBROUTINE mp_start - -! ... - IMPLICIT NONE - INTEGER :: ierr, taskid -! ... - ierr = 0 - taskid = 0 - - ALLOCATE( mp_call_count( 1000 ) ) - mp_call_count = 0 - ALLOCATE( mp_call_sizex( 1000 ) ) - mp_call_sizex = 0 - -#if defined(__MPI) || defined (__SHMEM) - CALL MPI_INIT(ierr) - IF (ierr/=0) CALL mp_stop( 8003 ) -#endif - -#if defined __HPM - - ! initialize the IBM Harware performance monitor - -# if defined(__MPI) || defined (__SHMEM) - CALL mpi_comm_rank( mpi_comm_world, taskid, ierr) -# endif - CALL f_hpminit( taskid, 'profiling' ) -#endif -! ... - - END SUBROUTINE mp_start -! -!------------------------------------------------------------------------------! -!..mp_end - - SUBROUTINE mp_end - IMPLICIT NONE - INTEGER :: ierr, taskid - - ierr = 0 - taskid = 0 - - IF ( ALLOCATED ( mp_call_count ) ) DEALLOCATE( mp_call_count ) - IF ( ALLOCATED ( mp_call_sizex ) ) DEALLOCATE( mp_call_sizex ) - -#if defined __HPM - - ! terminate the IBM Harware performance monitor - -# if defined(__MPI) - CALL mpi_comm_rank( mpi_comm_world, taskid, ierr) -# endif - CALL f_hpmterminate( taskid ) -#endif - -#if defined(__MPI) - CALL mpi_finalize(ierr) - IF (ierr/=0) CALL mp_stop( 8004 ) -#endif - RETURN - END SUBROUTINE mp_end -! -!------------------------------------------------------------------------------! -!..mp_env - - SUBROUTINE mp_env(numtask, taskid, groupid) - IMPLICIT NONE - INTEGER, INTENT (OUT) :: numtask, taskid, groupid - INTEGER :: ierr - - ierr = 0 - numtask = 1 - taskid = 0 - groupid = 0 - -#if defined(__MPI) - - CALL mpi_comm_rank(mpi_comm_world,taskid,ierr) - IF (ierr/=0) CALL mp_stop( 8005 ) - CALL mpi_comm_size(mpi_comm_world,numtask,ierr) - groupid = mpi_comm_world - IF (ierr/=0) CALL mp_stop( 8006 ) - -#endif - - RETURN - END SUBROUTINE mp_env - -!------------------------------------------------------------------------------! -!..mp_group - - SUBROUTINE mp_comm_group( comm, group ) - IMPLICIT NONE - INTEGER, INTENT (IN) :: comm - INTEGER, INTENT (OUT) :: group - INTEGER :: ierr - ierr = 0 -#if defined(__MPI) - CALL mpi_comm_group( comm, group, ierr ) - IF (ierr/=0) CALL mp_stop( 8007 ) -#else - group = 0 -#endif - END SUBROUTINE mp_comm_group - - SUBROUTINE mp_comm_split( old_comm, color, key, new_comm ) - IMPLICIT NONE - INTEGER, INTENT (IN) :: old_comm - INTEGER, INTENT (IN) :: color, key - INTEGER, INTENT (OUT) :: new_comm - INTEGER :: ierr - ierr = 0 -#if defined(__MPI) - CALL MPI_COMM_SPLIT( old_comm, color, key, new_comm, ierr ) - IF (ierr/=0) CALL mp_stop( 8008 ) -#else - new_comm = old_comm -#endif - END SUBROUTINE mp_comm_split - - - SUBROUTINE mp_group_create( group_list, group_size, old_grp, new_grp ) - IMPLICIT NONE - INTEGER, INTENT (IN) :: group_list(:), group_size, old_grp - INTEGER, INTENT (OUT) :: new_grp - INTEGER :: ierr - - ierr = 0 - new_grp = old_grp -#if defined(__MPI) - CALL mpi_group_incl( old_grp, group_size, group_list, new_grp, ierr ) - IF (ierr/=0) CALL mp_stop( 8009 ) -#endif - END SUBROUTINE mp_group_create - -!------------------------------------------------------------------------------! - SUBROUTINE mp_comm_create( old_comm, new_grp, new_comm ) - IMPLICIT NONE - INTEGER, INTENT (IN) :: old_comm - INTEGER, INTENT (IN) :: new_grp - INTEGER, INTENT (OUT) :: new_comm - INTEGER :: ierr - - ierr = 0 - new_comm = old_comm -#if defined(__MPI) - CALL mpi_comm_create( old_comm, new_grp, new_comm, ierr ) - IF (ierr/=0) CALL mp_stop( 8010 ) -#endif - END SUBROUTINE mp_comm_create - -!------------------------------------------------------------------------------! -!..mp_group_free - SUBROUTINE mp_group_free( group ) - IMPLICIT NONE - INTEGER, INTENT (INOUT) :: group - INTEGER :: ierr - ierr = 0 -#if defined(__MPI) - CALL mpi_group_free( group, ierr ) - IF (ierr/=0) CALL mp_stop( 8011 ) -#endif - END SUBROUTINE mp_group_free -!------------------------------------------------------------------------------! - - SUBROUTINE mp_comm_free( comm ) - IMPLICIT NONE - INTEGER, INTENT (INOUT) :: comm - INTEGER :: ierr - ierr = 0 -#if defined(__MPI) - IF( comm /= MPI_COMM_NULL ) THEN - CALL mpi_comm_free( comm, ierr ) - IF (ierr/=0) CALL mp_stop( 8012 ) - END IF -#endif - RETURN - END SUBROUTINE mp_comm_free - -!------------------------------------------------------------------------------! -!..mp_bcast - -#if defined (__T3E) - - SUBROUTINE mp_bcast_i4b(msg,source,gid) - IMPLICIT NONE - INTEGER(i4b) :: msg - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: source - INTEGER :: msglen, ierr, imsg - -#if defined(__MPI) - ierr = 0 - msglen = 1 - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - imsg = msg - CALL mpi_bcast(imsg, msglen, mpi_integer, source, group, ierr) - msg = imsg - IF (ierr/=0) CALL mp_stop( 8013 ) -#endif - END SUBROUTINE mp_bcast_i4b - -#endif - - -!------------------------------------------------------------------------------! -!..mp_bcast - - SUBROUTINE mp_bcast_i1(msg,source,gid) - IMPLICIT NONE - INTEGER :: msg - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen - -#if defined(__MPI) - msglen = 1 - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL BCAST_INTEGER( msg, msglen, source, group ) - mp_call_count( 1 ) = mp_call_count( 1 ) + 1 - mp_call_sizex( 1 ) = MAX( mp_call_sizex( 1 ), msglen ) -#endif - END SUBROUTINE mp_bcast_i1 -! -!------------------------------------------------------------------------------! - SUBROUTINE mp_bcast_iv(msg,source,gid) - IMPLICIT NONE - INTEGER :: msg(:) - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL BCAST_INTEGER( msg, msglen, source, group ) - mp_call_count( 2 ) = mp_call_count( 2 ) + 1 - mp_call_sizex( 2 ) = MAX( mp_call_sizex( 2 ), msglen ) -#endif - END SUBROUTINE mp_bcast_iv -! -!------------------------------------------------------------------------------! - SUBROUTINE mp_bcast_im( msg, source, gid ) - IMPLICIT NONE - INTEGER :: msg(:,:) - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL BCAST_INTEGER( msg, msglen, source, group ) - mp_call_count( 3 ) = mp_call_count( 3 ) + 1 - mp_call_sizex( 3 ) = MAX( mp_call_sizex( 3 ), msglen ) -#endif - END SUBROUTINE mp_bcast_im -! -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_bcast_it(msg,source,gid) - IMPLICIT NONE - INTEGER :: msg(:,:,:) - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL BCAST_INTEGER( msg, msglen, source, group ) - mp_call_count( 4 ) = mp_call_count( 4 ) + 1 - mp_call_sizex( 4 ) = MAX( mp_call_sizex( 4 ), msglen ) -#endif - END SUBROUTINE mp_bcast_it -! -!------------------------------------------------------------------------------! -! - SUBROUTINE mp_bcast_r1(msg,source,gid) - IMPLICIT NONE - REAL (DP) :: msg - INTEGER :: msglen, source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group -#if defined(__MPI) - msglen = 1 - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL bcast_real( msg, msglen, source, group ) - mp_call_count( 5 ) = mp_call_count( 5 ) + 1 - mp_call_sizex( 5 ) = MAX( mp_call_sizex( 5 ), msglen ) -#endif - END SUBROUTINE mp_bcast_r1 -! -!------------------------------------------------------------------------------! -! - SUBROUTINE mp_bcast_rv(msg,source,gid) - IMPLICIT NONE - REAL (DP) :: msg(:) - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen - -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL bcast_real( msg, msglen, source, group ) - mp_call_count( 6 ) = mp_call_count( 6 ) + 1 - mp_call_sizex( 6 ) = MAX( mp_call_sizex( 6 ), msglen ) -#endif - END SUBROUTINE mp_bcast_rv -! -!------------------------------------------------------------------------------! -! - SUBROUTINE mp_bcast_rm(msg,source,gid) - IMPLICIT NONE - REAL (DP) :: msg(:,:) - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL bcast_real( msg, msglen, source, group ) - mp_call_count( 7 ) = mp_call_count( 7 ) + 1 - mp_call_sizex( 7 ) = MAX( mp_call_sizex( 7 ), msglen ) -#endif - END SUBROUTINE mp_bcast_rm -! -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_bcast_rt(msg,source,gid) - IMPLICIT NONE - REAL (DP) :: msg(:,:,:) - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL bcast_real( msg, msglen, source, group ) - mp_call_count( 8 ) = mp_call_count( 8 ) + 1 - mp_call_sizex( 8 ) = MAX( mp_call_sizex( 8 ), msglen ) -#endif - END SUBROUTINE mp_bcast_rt -! -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_bcast_r4d(msg, source, gid) - IMPLICIT NONE - REAL (DP) :: msg(:,:,:,:) - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL bcast_real( msg, msglen, source, group ) - mp_call_count( 9 ) = mp_call_count( 9 ) + 1 - mp_call_sizex( 9 ) = MAX( mp_call_sizex( 9 ), msglen ) -#endif - END SUBROUTINE mp_bcast_r4d - -! -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_bcast_r5d(msg, source, gid) - IMPLICIT NONE - REAL (DP) :: msg(:,:,:,:,:) - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL bcast_real( msg, msglen, source, group ) - mp_call_count( 10 ) = mp_call_count( 10 ) + 1 - mp_call_sizex( 10 ) = MAX( mp_call_sizex( 10 ), msglen ) -#endif - END SUBROUTINE mp_bcast_r5d - -!------------------------------------------------------------------------------! -! - SUBROUTINE mp_bcast_c1(msg,source,gid) - IMPLICIT NONE - COMPLEX (DP) :: msg - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = 1 - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL bcast_real( msg, 2 * msglen, source, group ) - mp_call_count( 11 ) = mp_call_count( 11 ) + 1 - mp_call_sizex( 11 ) = MAX( mp_call_sizex( 11 ), msglen ) -#endif - END SUBROUTINE mp_bcast_c1 -! -!------------------------------------------------------------------------------! - SUBROUTINE mp_bcast_cv(msg,source,gid) - IMPLICIT NONE - COMPLEX (DP) :: msg(:) - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL bcast_real( msg, 2 * msglen, source, group ) - mp_call_count( 12 ) = mp_call_count( 12 ) + 1 - mp_call_sizex( 12 ) = MAX( mp_call_sizex( 12 ), msglen ) -#endif - END SUBROUTINE mp_bcast_cv -! -!------------------------------------------------------------------------------! - SUBROUTINE mp_bcast_cm(msg,source,gid) - IMPLICIT NONE - COMPLEX (DP) :: msg(:,:) - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL bcast_real( msg, 2 * msglen, source, group ) - mp_call_count( 13 ) = mp_call_count( 13 ) + 1 - mp_call_sizex( 13 ) = MAX( mp_call_sizex( 13 ), msglen ) -#endif - END SUBROUTINE mp_bcast_cm -! -!------------------------------------------------------------------------------! - SUBROUTINE mp_bcast_ct(msg,source,gid) - IMPLICIT NONE - COMPLEX (DP) :: msg(:,:,:) - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL bcast_real( msg, 2 * msglen, source, group ) - mp_call_count( 14 ) = mp_call_count( 14 ) + 1 - mp_call_sizex( 14 ) = MAX( mp_call_sizex( 14 ), msglen ) -#endif - END SUBROUTINE mp_bcast_ct - -! -!------------------------------------------------------------------------------! - SUBROUTINE mp_bcast_c4d(msg,source,gid) - IMPLICIT NONE - COMPLEX (DP) :: msg(:,:,:,:) - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL bcast_real( msg, 2 * msglen, source, group ) - mp_call_count( 15 ) = mp_call_count( 15 ) + 1 - mp_call_sizex( 15 ) = MAX( mp_call_sizex( 15 ), msglen ) -#endif - END SUBROUTINE mp_bcast_c4d - -! -!------------------------------------------------------------------------------! - - SUBROUTINE mp_bcast_l(msg,source,gid) - IMPLICIT NONE - LOGICAL :: msg - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = 1 - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL bcast_logical( msg, msglen, source, group ) - mp_call_count( 16 ) = mp_call_count( 16 ) + 1 - mp_call_sizex( 16 ) = MAX( mp_call_sizex( 16 ), msglen ) -#endif - END SUBROUTINE mp_bcast_l -! -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_bcast_lv(msg,source,gid) - IMPLICIT NONE - LOGICAL :: msg(:) - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL bcast_logical( msg, msglen, source, group ) - mp_call_count( 17 ) = mp_call_count( 17 ) + 1 - mp_call_sizex( 17 ) = MAX( mp_call_sizex( 17 ), msglen ) -#endif - END SUBROUTINE mp_bcast_lv - -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_bcast_lm(msg,source,gid) - IMPLICIT NONE - LOGICAL :: msg(:,:) - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL bcast_logical( msg, msglen, source, group ) - mp_call_count( 18 ) = mp_call_count( 18 ) + 1 - mp_call_sizex( 18 ) = MAX( mp_call_sizex( 18 ), msglen ) -#endif - END SUBROUTINE mp_bcast_lm - - -! -!------------------------------------------------------------------------------! -! - SUBROUTINE mp_bcast_z(msg,source,gid) - IMPLICIT NONE - CHARACTER (len=*) :: msg - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen, ierr, i - INTEGER, ALLOCATABLE :: imsg(:) -#if defined(__MPI) - ierr = 0 - msglen = len(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - IF (ierr/=0) CALL mp_stop( 8014 ) - ALLOCATE (imsg(1:msglen), STAT=ierr) - IF (ierr/=0) CALL mp_stop( 8015 ) - DO i = 1, msglen - imsg(i) = ichar(msg(i:i)) - END DO - CALL bcast_integer( imsg, msglen, source, group ) - DO i = 1, msglen - msg(i:i) = char(imsg(i)) - END DO - DEALLOCATE (imsg, STAT=ierr) - IF (ierr/=0) CALL mp_stop( 8016 ) - mp_call_count( 19 ) = mp_call_count( 19 ) + 1 - mp_call_sizex( 19 ) = MAX( mp_call_sizex( 19 ), msglen ) -#endif - END SUBROUTINE mp_bcast_z -! -!------------------------------------------------------------------------------! -! -!------------------------------------------------------------------------------! -! - SUBROUTINE mp_bcast_zv(msg,source,gid) - IMPLICIT NONE - CHARACTER (len=*) :: msg(:) - INTEGER :: source - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen, m1, m2, ierr, i, j - INTEGER, ALLOCATABLE :: imsg(:,:) -#if defined(__MPI) - ierr = 0 - m1 = LEN(msg) - m2 = SIZE(msg) - msglen = LEN(msg)*SIZE(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - ALLOCATE (imsg(1:m1,1:m2), STAT=ierr) - IF (ierr/=0) CALL mp_stop( 8017 ) - DO j = 1, m2 - DO i = 1, m1 - imsg(i,j) = ichar(msg(j)(i:i)) - END DO - END DO - CALL bcast_integer( imsg, msglen, source, group ) - DO j = 1, m2 - DO i = 1, m1 - msg(j)(i:i) = char(imsg(i,j)) - END DO - END DO - DEALLOCATE (imsg, STAT=ierr) - IF (ierr/=0) CALL mp_stop( 8018 ) - mp_call_count( 20 ) = mp_call_count( 20 ) + 1 - mp_call_sizex( 20 ) = MAX( mp_call_sizex( 20 ), msglen ) -#endif - END SUBROUTINE mp_bcast_zv -! -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_get_i1(msg_dest, msg_sour, mpime, dest, sour, ip, gid) - INTEGER :: msg_dest, msg_sour - INTEGER, INTENT(IN) :: dest, sour, ip, mpime - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group -#if defined(__MPI) - INTEGER :: istatus(MPI_STATUS_SIZE) -#endif - INTEGER :: ierr, nrcv - INTEGER :: msglen = 1 - -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid -#endif - - ! processors not taking part in the communication have 0 lenght message - - msglen = 0 - - IF(dest .NE. sour) THEN -#if defined(__MPI) - IF(mpime .EQ. sour) THEN - msglen=1 - CALL MPI_SEND( msg_sour, msglen, MPI_INTEGER, dest, ip, group, ierr) - IF (ierr/=0) CALL mp_stop( 8019 ) - ELSE IF(mpime .EQ. dest) THEN - msglen=1 - CALL MPI_RECV( msg_dest, msglen, MPI_INTEGER, sour, ip, group, istatus, IERR ) - IF (ierr/=0) CALL mp_stop( 8020 ) - CALL MPI_GET_COUNT(istatus, MPI_INTEGER, nrcv, ierr) - IF (ierr/=0) CALL mp_stop( 8021 ) - END IF -#endif - ELSE - msg_dest = msg_sour - END IF - -#if defined(__MPI) - CALL MPI_BARRIER(group, IERR) - IF (ierr/=0) CALL mp_stop( 8022 ) -#endif - - mp_call_count( 21 ) = mp_call_count( 21 ) + 1 - mp_call_sizex( 21 ) = MAX( mp_call_sizex( 21 ), msglen ) - - RETURN - END SUBROUTINE mp_get_i1 - -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_get_iv(msg_dest, msg_sour, mpime, dest, sour, ip, gid) - INTEGER :: msg_dest(:), msg_sour(:) - INTEGER, INTENT(IN) :: dest, sour, ip, mpime - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group -#if defined(__MPI) - INTEGER :: istatus(MPI_STATUS_SIZE) -#endif - INTEGER :: ierr, nrcv - INTEGER :: msglen - -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid -#endif - - ! processors not taking part in the communication have 0 lenght message - - msglen = 0 - - IF(sour .NE. dest) THEN -#if defined(__MPI) - IF(mpime .EQ. sour) THEN - msglen = SIZE(msg_sour) - CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_INTEGER, dest, ip, group, ierr) - IF (ierr/=0) CALL mp_stop( 8023 ) - ELSE IF(mpime .EQ. dest) THEN - CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_INTEGER, sour, ip, group, istatus, IERR ) - IF (ierr/=0) CALL mp_stop( 8024 ) - CALL MPI_GET_COUNT(istatus, MPI_INTEGER, nrcv, ierr) - IF (ierr/=0) CALL mp_stop( 8025 ) - msglen = nrcv - END IF -#endif - ELSE - msg_dest(1:SIZE(msg_sour)) = msg_sour(:) - msglen = SIZE(msg_sour) - END IF -#if defined(__MPI) - CALL MPI_BARRIER(group, IERR) - IF (ierr/=0) CALL mp_stop( 8026 ) -#endif - mp_call_count( 22 ) = mp_call_count( 22 ) + 1 - mp_call_sizex( 22 ) = MAX( mp_call_sizex( 22 ), msglen ) - RETURN - END SUBROUTINE mp_get_iv - -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_get_rv(msg_dest, msg_sour, mpime, dest, sour, ip, gid) - REAL (DP) :: msg_dest(:), msg_sour(:) - INTEGER, INTENT(IN) :: dest, sour, ip, mpime - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group -#if defined(__MPI) - INTEGER :: istatus(MPI_STATUS_SIZE) -#endif - INTEGER :: ierr, nrcv - INTEGER :: msglen - -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid -#endif - - ! processors not taking part in the communication have 0 lenght message - - msglen = 0 - - IF(sour .NE. dest) THEN -#if defined(__MPI) - IF(mpime .EQ. sour) THEN - msglen = SIZE(msg_sour) - CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_DOUBLE_PRECISION, dest, ip, group, ierr) - IF (ierr/=0) CALL mp_stop( 8027 ) - ELSE IF(mpime .EQ. dest) THEN - CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_DOUBLE_PRECISION, sour, ip, group, istatus, IERR ) - IF (ierr/=0) CALL mp_stop( 8028 ) - CALL MPI_GET_COUNT(istatus, MPI_DOUBLE_PRECISION, nrcv, ierr) - IF (ierr/=0) CALL mp_stop( 8029 ) - msglen = nrcv - END IF -#endif - ELSE - msg_dest(1:SIZE(msg_sour)) = msg_sour(:) - msglen = SIZE(msg_sour) - END IF -#if defined(__MPI) - CALL MPI_BARRIER(group, IERR) - IF (ierr/=0) CALL mp_stop( 8030 ) -#endif - mp_call_count( 23 ) = mp_call_count( 23 ) + 1 - mp_call_sizex( 23 ) = MAX( mp_call_sizex( 23 ), msglen ) - RETURN - END SUBROUTINE mp_get_rv - -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_get_rm(msg_dest, msg_sour, mpime, dest, sour, ip, gid) - REAL (DP) :: msg_dest(:,:), msg_sour(:,:) - INTEGER, INTENT(IN) :: dest, sour, ip, mpime - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group -#if defined(__MPI) - INTEGER :: istatus(MPI_STATUS_SIZE) -#endif - INTEGER :: ierr, nrcv - INTEGER :: msglen - -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid -#endif - - ! processors not taking part in the communication have 0 lenght message - - msglen = 0 - - IF(sour .NE. dest) THEN -#if defined(__MPI) - IF(mpime .EQ. sour) THEN - CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_DOUBLE_PRECISION, dest, ip, group, ierr) - IF (ierr/=0) CALL mp_stop( 8031 ) - msglen = SIZE(msg_sour) - ELSE IF(mpime .EQ. dest) THEN - CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_DOUBLE_PRECISION, sour, ip, group, istatus, IERR ) - IF (ierr/=0) CALL mp_stop( 8032 ) - CALL MPI_GET_COUNT(istatus, MPI_DOUBLE_PRECISION, nrcv, ierr) - IF (ierr/=0) CALL mp_stop( 8033 ) - msglen = nrcv - END IF -#endif - ELSE - msg_dest(1:SIZE(msg_sour,1), 1:SIZE(msg_sour,2)) = msg_sour(:,:) - msglen = SIZE( msg_sour ) - END IF -#if defined(__MPI) - CALL MPI_BARRIER(group, IERR) - IF (ierr/=0) CALL mp_stop( 8034 ) -#endif - mp_call_count( 24 ) = mp_call_count( 24 ) + 1 - mp_call_sizex( 24 ) = MAX( mp_call_sizex( 24 ), msglen ) - RETURN - END SUBROUTINE mp_get_rm - - -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_get_cv(msg_dest, msg_sour, mpime, dest, sour, ip, gid) - COMPLEX (DP) :: msg_dest(:), msg_sour(:) - INTEGER, INTENT(IN) :: dest, sour, ip, mpime - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group -#if defined(__MPI) - INTEGER :: istatus(MPI_STATUS_SIZE) -#endif - INTEGER :: ierr, nrcv - INTEGER :: msglen - -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid -#endif - - ! processors not taking part in the communication have 0 lenght message - - msglen = 0 - - IF( dest .NE. sour ) THEN -#if defined(__MPI) - IF(mpime .EQ. sour) THEN - CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_DOUBLE_COMPLEX, dest, ip, group, ierr) - IF (ierr/=0) CALL mp_stop( 8035 ) - msglen = SIZE(msg_sour) - ELSE IF(mpime .EQ. dest) THEN - CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_DOUBLE_COMPLEX, sour, ip, group, istatus, IERR ) - IF (ierr/=0) CALL mp_stop( 8036 ) - CALL MPI_GET_COUNT(istatus, MPI_DOUBLE_COMPLEX, nrcv, ierr) - IF (ierr/=0) CALL mp_stop( 8037 ) - msglen = nrcv - END IF -#endif - ELSE - msg_dest(1:SIZE(msg_sour)) = msg_sour(:) - msglen = SIZE(msg_sour) - END IF -#if defined(__MPI) - CALL MPI_BARRIER(group, IERR) - IF (ierr/=0) CALL mp_stop( 8038 ) -#endif - mp_call_count( 25 ) = mp_call_count( 25 ) + 1 - mp_call_sizex( 25 ) = MAX( mp_call_sizex( 25 ), msglen ) - RETURN - END SUBROUTINE mp_get_cv -!------------------------------------------------------------------------------! -! -! -!------------------------------------------------------------------------------! - - - SUBROUTINE mp_put_i1(msg_dest, msg_sour, mpime, sour, dest, ip, gid) - INTEGER :: msg_dest, msg_sour - INTEGER, INTENT(IN) :: dest, sour, ip, mpime - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group -#if defined(__MPI) - INTEGER :: istatus(MPI_STATUS_SIZE) -#endif - INTEGER :: ierr, nrcv - INTEGER :: msglen - -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid -#endif - - ! processors not taking part in the communication have 0 lenght message - - msglen = 0 - - IF(dest .NE. sour) THEN -#if defined(__MPI) - IF(mpime .EQ. sour) THEN - CALL MPI_SEND( msg_sour, 1, MPI_INTEGER, dest, ip, group, ierr) - IF (ierr/=0) CALL mp_stop( 8039 ) - msglen = 1 - ELSE IF(mpime .EQ. dest) THEN - CALL MPI_RECV( msg_dest, 1, MPI_INTEGER, sour, ip, group, istatus, IERR ) - IF (ierr/=0) CALL mp_stop( 8040 ) - CALL MPI_GET_COUNT(istatus, MPI_INTEGER, nrcv, ierr) - IF (ierr/=0) CALL mp_stop( 8041 ) - msglen = 1 - END IF -#endif - ELSE - msg_dest = msg_sour - msglen = 1 - END IF -#if defined(__MPI) - CALL MPI_BARRIER(group, IERR) - IF (ierr/=0) CALL mp_stop( 8042 ) -#endif - mp_call_count( 26 ) = mp_call_count( 26 ) + 1 - mp_call_sizex( 26 ) = MAX( mp_call_sizex( 26 ), msglen ) - RETURN - END SUBROUTINE mp_put_i1 - -!------------------------------------------------------------------------------! -! -! - SUBROUTINE mp_put_iv(msg_dest, msg_sour, mpime, sour, dest, ip, gid) - INTEGER :: msg_dest(:), msg_sour(:) - INTEGER, INTENT(IN) :: dest, sour, ip, mpime - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group -#if defined(__MPI) - INTEGER :: istatus(MPI_STATUS_SIZE) -#endif - INTEGER :: ierr, nrcv - INTEGER :: msglen -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid -#endif - ! processors not taking part in the communication have 0 lenght message - - msglen = 0 - - IF(sour .NE. dest) THEN -#if defined(__MPI) - IF(mpime .EQ. sour) THEN - CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_INTEGER, dest, ip, group, ierr) - IF (ierr/=0) CALL mp_stop( 8043 ) - msglen = SIZE(msg_sour) - ELSE IF(mpime .EQ. dest) THEN - CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_INTEGER, sour, ip, group, istatus, IERR ) - IF (ierr/=0) CALL mp_stop( 8044 ) - CALL MPI_GET_COUNT(istatus, MPI_INTEGER, nrcv, ierr) - IF (ierr/=0) CALL mp_stop( 8045 ) - msglen = nrcv - END IF -#endif - ELSE - msg_dest(1:SIZE(msg_sour)) = msg_sour(:) - msglen = SIZE(msg_sour) - END IF -#if defined(__MPI) - CALL MPI_BARRIER(group, IERR) - IF (ierr/=0) CALL mp_stop( 8046 ) -#endif - mp_call_count( 27 ) = mp_call_count( 27 ) + 1 - mp_call_sizex( 27 ) = MAX( mp_call_sizex( 27 ), msglen ) - RETURN - END SUBROUTINE mp_put_iv - -!------------------------------------------------------------------------------! -! -! - SUBROUTINE mp_put_rv(msg_dest, msg_sour, mpime, sour, dest, ip, gid) - REAL (DP) :: msg_dest(:), msg_sour(:) - INTEGER, INTENT(IN) :: dest, sour, ip, mpime - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group -#if defined(__MPI) - INTEGER :: istatus(MPI_STATUS_SIZE) -#endif - INTEGER :: ierr, nrcv - INTEGER :: msglen -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid -#endif - ! processors not taking part in the communication have 0 lenght message - - msglen = 0 - - IF(sour .NE. dest) THEN -#if defined(__MPI) - IF(mpime .EQ. sour) THEN - CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_DOUBLE_PRECISION, dest, ip, group, ierr) - IF (ierr/=0) CALL mp_stop( 8047 ) - msglen = SIZE(msg_sour) - ELSE IF(mpime .EQ. dest) THEN - CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_DOUBLE_PRECISION, sour, ip, group, istatus, IERR ) - IF (ierr/=0) CALL mp_stop( 8048 ) - CALL MPI_GET_COUNT(istatus, MPI_DOUBLE_PRECISION, nrcv, ierr) - IF (ierr/=0) CALL mp_stop( 8049 ) - msglen = nrcv - END IF -#endif - ELSE - msg_dest(1:SIZE(msg_sour)) = msg_sour(:) - msglen = SIZE(msg_sour) - END IF -#if defined(__MPI) - CALL MPI_BARRIER(group, IERR) - IF (ierr/=0) CALL mp_stop( 8050 ) -#endif - mp_call_count( 28 ) = mp_call_count( 28 ) + 1 - mp_call_sizex( 28 ) = MAX( mp_call_sizex( 28 ), msglen ) - RETURN - END SUBROUTINE mp_put_rv - -!------------------------------------------------------------------------------! -! -! - SUBROUTINE mp_put_rm(msg_dest, msg_sour, mpime, sour, dest, ip, gid) - REAL (DP) :: msg_dest(:,:), msg_sour(:,:) - INTEGER, INTENT(IN) :: dest, sour, ip, mpime - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group -#if defined(__MPI) - INTEGER :: istatus(MPI_STATUS_SIZE) -#endif - INTEGER :: ierr, nrcv - INTEGER :: msglen -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid -#endif - ! processors not taking part in the communication have 0 lenght message - - msglen = 0 - - IF(sour .NE. dest) THEN -#if defined(__MPI) - IF(mpime .EQ. sour) THEN - CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_DOUBLE_PRECISION, dest, ip, group, ierr) - IF (ierr/=0) CALL mp_stop( 8051 ) - msglen = SIZE(msg_sour) - ELSE IF(mpime .EQ. dest) THEN - CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_DOUBLE_PRECISION, sour, ip, group, istatus, IERR ) - IF (ierr/=0) CALL mp_stop( 8052 ) - CALL MPI_GET_COUNT(istatus, MPI_DOUBLE_PRECISION, nrcv, ierr) - IF (ierr/=0) CALL mp_stop( 8053 ) - msglen = nrcv - END IF -#endif - ELSE - msg_dest(1:SIZE(msg_sour,1),1:SIZE(msg_sour,2)) = msg_sour(:,:) - msglen = SIZE(msg_sour) - END IF -#if defined(__MPI) - CALL MPI_BARRIER(group, IERR) - IF (ierr/=0) CALL mp_stop( 8054 ) -#endif - mp_call_count( 29 ) = mp_call_count( 29 ) + 1 - mp_call_sizex( 29 ) = MAX( mp_call_sizex( 29 ), msglen ) - RETURN - END SUBROUTINE mp_put_rm - - -!------------------------------------------------------------------------------! -! -! - SUBROUTINE mp_put_cv(msg_dest, msg_sour, mpime, sour, dest, ip, gid) - COMPLEX (DP) :: msg_dest(:), msg_sour(:) - INTEGER, INTENT(IN) :: dest, sour, ip, mpime - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group -#if defined(__MPI) - INTEGER :: istatus(MPI_STATUS_SIZE) -#endif - INTEGER :: ierr, nrcv - INTEGER :: msglen -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid -#endif - ! processors not taking part in the communication have 0 lenght message - - msglen = 0 - - IF( dest .NE. sour ) THEN -#if defined(__MPI) - IF(mpime .EQ. sour) THEN - CALL MPI_SEND( msg_sour, SIZE(msg_sour), MPI_DOUBLE_COMPLEX, dest, ip, group, ierr) - IF (ierr/=0) CALL mp_stop( 8055 ) - msglen = SIZE(msg_sour) - ELSE IF(mpime .EQ. dest) THEN - CALL MPI_RECV( msg_dest, SIZE(msg_dest), MPI_DOUBLE_COMPLEX, sour, ip, group, istatus, IERR ) - IF (ierr/=0) CALL mp_stop( 8056 ) - CALL MPI_GET_COUNT(istatus, MPI_DOUBLE_COMPLEX, nrcv, ierr) - IF (ierr/=0) CALL mp_stop( 8057 ) - msglen = nrcv - END IF -#endif - ELSE - msg_dest(1:SIZE(msg_sour)) = msg_sour(:) - msglen = SIZE(msg_sour) - END IF -#if defined(__MPI) - CALL MPI_BARRIER(group, IERR) - IF (ierr/=0) CALL mp_stop( 8058 ) -#endif - mp_call_count( 30 ) = mp_call_count( 30 ) + 1 - mp_call_sizex( 30 ) = MAX( mp_call_sizex( 30 ), msglen ) - RETURN - END SUBROUTINE mp_put_cv - -! -!------------------------------------------------------------------------------! -! -!..mp_stop -! - SUBROUTINE mp_stop(code) - IMPLICIT NONE - INTEGER, INTENT (IN) :: code - WRITE( stdout, fmt='( "*** error in Message Passing (mp) module ***")' ) - WRITE( stdout, fmt='( "*** error msg: ",A60)' ) TRIM( err_msg ) - WRITE( stdout, fmt='( "*** error code: ",I5)' ) code -#if defined(__MPI) - CALL mpi_abort(mpi_comm_world,code) -#endif - STOP - END SUBROUTINE mp_stop -!------------------------------------------------------------------------------! -! -!..mp_sum - SUBROUTINE mp_sum_i1(msg,gid) - IMPLICIT NONE - INTEGER, INTENT (INOUT) :: msg - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = 1 - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL reduce_base_integer( msglen, msg, group, -1 ) - mp_call_count( 31 ) = mp_call_count( 31 ) + 1 - mp_call_sizex( 31 ) = MAX( mp_call_sizex( 31 ), msglen ) -#endif - END SUBROUTINE mp_sum_i1 -! -!------------------------------------------------------------------------------! - SUBROUTINE mp_sum_iv(msg,gid) - IMPLICIT NONE - INTEGER, INTENT (INOUT) :: msg(:) - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - msglen = size(msg) - CALL reduce_base_integer( msglen, msg, group, -1 ) - mp_call_count( 32 ) = mp_call_count( 32 ) + 1 - mp_call_sizex( 32 ) = MAX( mp_call_sizex( 32 ), msglen ) -#endif - END SUBROUTINE mp_sum_iv -! -!------------------------------------------------------------------------------! - - SUBROUTINE mp_sum_im(msg,gid) - IMPLICIT NONE - INTEGER, INTENT (INOUT) :: msg(:,:) - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - msglen = size(msg) - CALL reduce_base_integer( msglen, msg, group, -1 ) - mp_call_count( 33 ) = mp_call_count( 33 ) + 1 - mp_call_sizex( 33 ) = MAX( mp_call_sizex( 33 ), msglen ) -#endif - END SUBROUTINE mp_sum_im -! -!------------------------------------------------------------------------------! - - SUBROUTINE mp_sum_it(msg,gid) - IMPLICIT NONE - INTEGER, INTENT (INOUT) :: msg(:,:,:) - INTEGER, OPTIONAL, INTENT (IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - msglen = size(msg) - CALL reduce_base_integer( msglen, msg, group, -1 ) - mp_call_count( 34 ) = mp_call_count( 34 ) + 1 - mp_call_sizex( 34 ) = MAX( mp_call_sizex( 34 ), msglen ) -#endif - END SUBROUTINE mp_sum_it - -!------------------------------------------------------------------------------! - - SUBROUTINE mp_sum_r1(msg,gid) - IMPLICIT NONE - REAL (DP), INTENT (INOUT) :: msg - INTEGER, OPTIONAL, INTENT (IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = 1 - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL reduce_base_real( msglen, msg, group, -1 ) - mp_call_count( 35 ) = mp_call_count( 35 ) + 1 - mp_call_sizex( 35 ) = MAX( mp_call_sizex( 35 ), msglen ) -#endif - END SUBROUTINE mp_sum_r1 - -! -!------------------------------------------------------------------------------! - - SUBROUTINE mp_sum_rv(msg,gid) - IMPLICIT NONE - REAL (DP), INTENT (INOUT) :: msg(:) - INTEGER, OPTIONAL, INTENT (IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL reduce_base_real( msglen, msg, group, -1 ) - mp_call_count( 36 ) = mp_call_count( 36 ) + 1 - mp_call_sizex( 36 ) = MAX( mp_call_sizex( 36 ), msglen ) -#endif - END SUBROUTINE mp_sum_rv -! -!------------------------------------------------------------------------------! - - - SUBROUTINE mp_sum_rm(msg, gid) - IMPLICIT NONE - REAL (DP), INTENT (INOUT) :: msg(:,:) - INTEGER, OPTIONAL, INTENT (IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL reduce_base_real( msglen, msg, group, -1 ) - mp_call_count( 37 ) = mp_call_count( 37 ) + 1 - mp_call_sizex( 37 ) = MAX( mp_call_sizex( 37 ), msglen ) -#endif - END SUBROUTINE mp_sum_rm - - - SUBROUTINE mp_root_sum_rm( msg, res, root, gid ) - IMPLICIT NONE - REAL (DP), INTENT (IN) :: msg(:,:) - REAL (DP), INTENT (OUT) :: res(:,:) - INTEGER, INTENT (IN) :: root - INTEGER, OPTIONAL, INTENT (IN) :: gid - INTEGER :: group - INTEGER :: msglen, ierr, taskid - -#if defined(__MPI) - - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - - CALL mpi_comm_rank( group, taskid, ierr) - IF( ierr /= 0 ) CALL mp_stop( 8059 ) - ! - IF( taskid == root ) THEN - IF( msglen > size(res) ) CALL mp_stop( 8060 ) - END IF - - CALL reduce_base_real_to( msglen, msg, res, group, root ) - - mp_call_count( 38 ) = mp_call_count( 38 ) + 1 - mp_call_sizex( 38 ) = MAX( mp_call_sizex( 38 ), msglen ) - -#else - - res = msg - -#endif - - END SUBROUTINE mp_root_sum_rm - - - SUBROUTINE mp_root_sum_cm( msg, res, root, gid ) - IMPLICIT NONE - COMPLEX (DP), INTENT (IN) :: msg(:,:) - COMPLEX (DP), INTENT (OUT) :: res(:,:) - INTEGER, INTENT (IN) :: root - INTEGER, OPTIONAL, INTENT (IN) :: gid - INTEGER :: group - INTEGER :: msglen, ierr, taskid - -#if defined(__MPI) - - msglen = size(msg) - - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - - CALL mpi_comm_rank( group, taskid, ierr) - IF( ierr /= 0 ) CALL mp_stop( 8061 ) - - IF( taskid == root ) THEN - IF( msglen > size(res) ) CALL mp_stop( 8062 ) - END IF - - CALL reduce_base_real_to( 2 * msglen, msg, res, group, root ) - - mp_call_count( 39 ) = mp_call_count( 39 ) + 1 - mp_call_sizex( 39 ) = MAX( mp_call_sizex( 39 ), msglen ) - -#else - - res = msg - -#endif - - END SUBROUTINE mp_root_sum_cm - -! -!------------------------------------------------------------------------------! - - -!------------------------------------------------------------------------------! -! - - SUBROUTINE mp_sum_rmm( msg, res, root, gid ) - IMPLICIT NONE - REAL (DP), INTENT (IN) :: msg(:,:) - REAL (DP), INTENT (OUT) :: res(:,:) - INTEGER, OPTIONAL, INTENT (IN) :: root - INTEGER, OPTIONAL, INTENT (IN) :: gid - INTEGER :: group - INTEGER :: msglen - INTEGER :: taskid, ierr - - msglen = size(msg) - -#if defined(__MPI) - - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - - IF( PRESENT( root ) ) THEN - ! - CALL mpi_comm_rank( group, taskid, ierr) - IF( ierr /= 0 ) CALL mp_stop( 8063 ) - - IF( taskid == root ) THEN - IF( msglen > size(res) ) CALL mp_stop( 8064 ) - END IF - ! - CALL reduce_base_real_to( msglen, msg, res, group, root ) - ! - ELSE - ! - IF( msglen > size(res) ) CALL mp_stop( 8065 ) - ! - CALL reduce_base_real_to( msglen, msg, res, group, -1 ) - ! - END IF - - mp_call_count( 40 ) = mp_call_count( 40 ) + 1 - mp_call_sizex( 40 ) = MAX( mp_call_sizex( 40 ), msglen ) - -#else - res = msg -#endif - - END SUBROUTINE mp_sum_rmm - - -! -!------------------------------------------------------------------------------! - - - SUBROUTINE mp_sum_rt( msg, gid ) - IMPLICIT NONE - REAL (DP), INTENT (INOUT) :: msg(:,:,:) - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL reduce_base_real( msglen, msg, group, -1 ) - mp_call_count( 41 ) = mp_call_count( 41 ) + 1 - mp_call_sizex( 41 ) = MAX( mp_call_sizex( 41 ), msglen ) -#endif - END SUBROUTINE mp_sum_rt - -! -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_sum_r4d(msg,gid) - IMPLICIT NONE - REAL (DP), INTENT (INOUT) :: msg(:,:,:,:) - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL reduce_base_real( msglen, msg, group, -1 ) - mp_call_count( 42 ) = mp_call_count( 42 ) + 1 - mp_call_sizex( 42 ) = MAX( mp_call_sizex( 42 ), msglen ) -#endif - END SUBROUTINE mp_sum_r4d - - - -!------------------------------------------------------------------------------! - - SUBROUTINE mp_sum_c1(msg,gid) - IMPLICIT NONE - COMPLEX (DP), INTENT (INOUT) :: msg - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen - -#if defined(__MPI) - msglen = 1 - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL reduce_base_real( 2 * msglen, msg, group, -1 ) - mp_call_count( 43 ) = mp_call_count( 43 ) + 1 - mp_call_sizex( 43 ) = MAX( mp_call_sizex( 43 ), msglen ) -#endif - END SUBROUTINE mp_sum_c1 -! -!------------------------------------------------------------------------------! - - SUBROUTINE mp_sum_cv(msg,gid) - IMPLICIT NONE - COMPLEX (DP), INTENT (INOUT) :: msg(:) - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL reduce_base_real( 2 * msglen, msg, group, -1 ) - mp_call_count( 44 ) = mp_call_count( 44 ) + 1 - mp_call_sizex( 44 ) = MAX( mp_call_sizex( 44 ), msglen ) -#endif - END SUBROUTINE mp_sum_cv -! -!------------------------------------------------------------------------------! - - SUBROUTINE mp_sum_cm(msg, gid) - IMPLICIT NONE - COMPLEX (DP), INTENT (INOUT) :: msg(:,:) - INTEGER, OPTIONAL, INTENT (IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL reduce_base_real( 2 * msglen, msg, group, -1 ) - mp_call_count( 45 ) = mp_call_count( 45 ) + 1 - mp_call_sizex( 45 ) = MAX( mp_call_sizex( 45 ), msglen ) -#endif - END SUBROUTINE mp_sum_cm -! -!------------------------------------------------------------------------------! - - - SUBROUTINE mp_sum_cmm(msg, res, gid) - IMPLICIT NONE - COMPLEX (DP), INTENT (IN) :: msg(:,:) - COMPLEX (DP), INTENT (OUT) :: res(:,:) - INTEGER, OPTIONAL, INTENT (IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL reduce_base_real_to( 2 * msglen, msg, res, group, -1 ) - mp_call_count( 46 ) = mp_call_count( 46 ) + 1 - mp_call_sizex( 46 ) = MAX( mp_call_sizex( 46 ), msglen ) -#else - res = msg -#endif - END SUBROUTINE mp_sum_cmm - - -! -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_sum_ct(msg,gid) - IMPLICIT NONE - COMPLEX (DP), INTENT (INOUT) :: msg(:,:,:) - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = SIZE(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL reduce_base_real( 2 * msglen, msg, group, -1 ) - mp_call_count( 47 ) = mp_call_count( 47 ) + 1 - mp_call_sizex( 47 ) = MAX( mp_call_sizex( 47 ), msglen ) -#endif - END SUBROUTINE mp_sum_ct - -! -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_sum_c4d(msg,gid) - IMPLICIT NONE - COMPLEX (DP), INTENT (INOUT) :: msg(:,:,:,:) - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL reduce_base_real( 2 * msglen, msg, group, -1 ) - mp_call_count( 48 ) = mp_call_count( 48 ) + 1 - mp_call_sizex( 48 ) = MAX( mp_call_sizex( 48 ), msglen ) -#endif - END SUBROUTINE mp_sum_c4d -! -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_sum_c5d(msg,gid) - IMPLICIT NONE - COMPLEX (DP), INTENT (INOUT) :: msg(:,:,:,:,:) - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL reduce_base_real( 2 * msglen, msg, group, -1 ) - mp_call_count( 49 ) = mp_call_count( 49 ) + 1 - mp_call_sizex( 49 ) = MAX( mp_call_sizex( 49 ), msglen ) -#endif - END SUBROUTINE mp_sum_c5d - - -! -!------------------------------------------------------------------------------! -! -! Carlo Cavazzoni -! - SUBROUTINE mp_sum_c6d(msg,gid) - IMPLICIT NONE - COMPLEX (DP), INTENT (INOUT) :: msg(:,:,:,:,:,:) - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = size(msg) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL reduce_base_real( 2 * msglen, msg, group, -1 ) - mp_call_count( 50 ) = mp_call_count( 50 ) + 1 - mp_call_sizex( 50 ) = MAX( mp_call_sizex( 50 ), msglen ) -#endif - END SUBROUTINE mp_sum_c6d - - - -!------------------------------------------------------------------------------! - SUBROUTINE mp_max_i(msg,gid) - IMPLICIT NONE - INTEGER, INTENT (INOUT) :: msg - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - msglen = 1 - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL parallel_max_integer( msglen, msg, group, -1 ) - mp_call_count( 51 ) = mp_call_count( 51 ) + 1 - mp_call_sizex( 51 ) = MAX( mp_call_sizex( 51 ), msglen ) -#endif - END SUBROUTINE mp_max_i -! -!------------------------------------------------------------------------------! -! -!..mp_max_iv -!..Carlo Cavazzoni -! - SUBROUTINE mp_max_iv(msg,gid) - IMPLICIT NONE - INTEGER, INTENT (INOUT) :: msg(:) - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - msglen = size(msg) - CALL parallel_max_integer( msglen, msg, group, -1 ) - mp_call_count( 52 ) = mp_call_count( 52 ) + 1 - mp_call_sizex( 52 ) = MAX( mp_call_sizex( 52 ), msglen ) -#endif - END SUBROUTINE mp_max_iv -! -!---------------------------------------------------------------------- - - SUBROUTINE mp_max_r(msg,gid) - IMPLICIT NONE - REAL (DP), INTENT (INOUT) :: msg - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - msglen = 1 - CALL parallel_max_real( msglen, msg, group, -1 ) - mp_call_count( 53 ) = mp_call_count( 53 ) + 1 - mp_call_sizex( 53 ) = MAX( mp_call_sizex( 53 ), msglen ) -#endif - END SUBROUTINE mp_max_r -! -!------------------------------------------------------------------------------! - SUBROUTINE mp_max_rv(msg,gid) - IMPLICIT NONE - REAL (DP), INTENT (INOUT) :: msg(:) - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - msglen = size(msg) - CALL parallel_max_real( msglen, msg, group, -1 ) - mp_call_count( 54 ) = mp_call_count( 54 ) + 1 - mp_call_sizex( 54 ) = MAX( mp_call_sizex( 54 ), msglen ) -#endif - END SUBROUTINE mp_max_rv -!------------------------------------------------------------------------------! - SUBROUTINE mp_min_i(msg,gid) - IMPLICIT NONE - INTEGER, INTENT (INOUT) :: msg - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - msglen = 1 - CALL parallel_min_integer( msglen, msg, group, -1 ) - mp_call_count( 55 ) = mp_call_count( 55 ) + 1 - mp_call_sizex( 55 ) = MAX( mp_call_sizex( 55 ), msglen ) -#endif - END SUBROUTINE mp_min_i -!------------------------------------------------------------------------------! - SUBROUTINE mp_min_iv(msg,gid) - IMPLICIT NONE - INTEGER, INTENT (INOUT) :: msg(:) - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - msglen = SIZE(msg) - CALL parallel_min_integer( msglen, msg, group, -1 ) - mp_call_count( 56 ) = mp_call_count( 56 ) + 1 - mp_call_sizex( 56 ) = MAX( mp_call_sizex( 56 ), msglen ) -#endif - END SUBROUTINE mp_min_iv -!------------------------------------------------------------------------------! - SUBROUTINE mp_min_r(msg,gid) - IMPLICIT NONE - REAL (DP), INTENT (INOUT) :: msg - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - msglen = 1 - CALL parallel_min_real( msglen, msg, group, -1 ) - mp_call_count( 57 ) = mp_call_count( 57 ) + 1 - mp_call_sizex( 57 ) = MAX( mp_call_sizex( 57 ), msglen ) -#endif - END SUBROUTINE mp_min_r -! -!------------------------------------------------------------------------------! - SUBROUTINE mp_min_rv(msg,gid) - IMPLICIT NONE - REAL (DP), INTENT (INOUT) :: msg(:) - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: msglen -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - msglen = size(msg) - CALL parallel_min_real( msglen, msg, group, -1 ) - mp_call_count( 58 ) = mp_call_count( 58 ) + 1 - mp_call_sizex( 58 ) = MAX( mp_call_sizex( 58 ), msglen ) -#endif - END SUBROUTINE mp_min_rv - -!------------------------------------------------------------------------------! - - SUBROUTINE mp_barrier(gid) - IMPLICIT NONE - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: ierr -#if defined(__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL MPI_BARRIER(group,IERR) - IF (ierr/=0) CALL mp_stop( 8066 ) -#endif - END SUBROUTINE mp_barrier - -!------------------------------------------------------------------------------! -!.. Carlo Cavazzoni -!..mp_rank - FUNCTION mp_rank( comm ) - IMPLICIT NONE - INTEGER :: mp_rank - INTEGER, OPTIONAL, INTENT(IN) :: comm - INTEGER :: ierr, taskid - - ierr = 0 - taskid = 0 -#if defined(__MPI) - IF( PRESENT( comm ) ) THEN - CALL mpi_comm_rank(comm,taskid,ierr) - ELSE - CALL mpi_comm_rank(mpi_comm_world,taskid,ierr) - END IF - IF (ierr/=0) CALL mp_stop( 8067 ) -#endif - mp_rank = taskid - END FUNCTION mp_rank - -!------------------------------------------------------------------------------! -!.. Carlo Cavazzoni -!..mp_size - FUNCTION mp_size( comm ) - IMPLICIT NONE - INTEGER :: mp_size - INTEGER, OPTIONAL, INTENT(IN) :: comm - INTEGER :: ierr, numtask - - ierr = 0 - numtask = 1 -#if defined(__MPI) - IF( PRESENT( comm ) ) THEN - CALL mpi_comm_size(comm,numtask,ierr) - ELSE - CALL mpi_comm_size(mpi_comm_world,numtask,ierr) - END IF - IF (ierr/=0) CALL mp_stop( 8068 ) -#endif - mp_size = numtask - END FUNCTION mp_size - - SUBROUTINE mp_report - INTEGER :: i - WRITE( stdout, *) -#if defined(__MPI) -# if defined (__MP_STAT) - WRITE( stdout, 20 ) - DO i = 1, SIZE( mp_call_count ) - IF( mp_call_count( i ) > 0 ) THEN - WRITE( stdout, 30 ) i, mp_call_count( i ), mp_call_sizex( i ) - END IF - END DO -# endif -10 FORMAT(3X,'Message Passing, maximum message size (bytes) : ',I15) -20 FORMAT(3X,'Sub. calls maxsize') -30 FORMAT(3X,I4,I8,I10) -#else - WRITE( stdout, *) -#endif - RETURN - END SUBROUTINE mp_report - - -!------------------------------------------------------------------------------! -!..mp_gatherv_rv -!..Carlo Cavazzoni - - SUBROUTINE mp_gatherv_rv( mydata, alldata, recvcount, displs, root, gid) - IMPLICIT NONE - REAL(DP) :: mydata(:) - REAL(DP) :: alldata(:) - INTEGER, INTENT(IN) :: recvcount(:), displs(:), root - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: ierr, npe, myid - -#if defined (__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL mpi_comm_size( group, npe, ierr ) - IF (ierr/=0) CALL mp_stop( 8069 ) - CALL mpi_comm_rank( group, myid, ierr ) - IF (ierr/=0) CALL mp_stop( 8070 ) - ! - IF ( SIZE( recvcount ) < npe .OR. SIZE( displs ) < npe ) CALL mp_stop( 8071 ) - IF ( myid == root ) THEN - IF ( SIZE( alldata ) < displs( npe ) + recvcount( npe ) ) CALL mp_stop( 8072 ) - END IF - IF ( SIZE( mydata ) < recvcount( myid + 1 ) ) CALL mp_stop( 8073 ) - ! - CALL MPI_GATHERV( mydata, recvcount( myid + 1 ), MPI_DOUBLE_PRECISION, & - alldata, recvcount, displs, MPI_DOUBLE_PRECISION, root, group, ierr ) - IF (ierr/=0) CALL mp_stop( 8074 ) -#else - IF ( SIZE( alldata ) < recvcount( 1 ) ) CALL mp_stop( 8075 ) - IF ( SIZE( mydata ) < recvcount( 1 ) ) CALL mp_stop( 8076 ) - ! - alldata( 1:recvcount( 1 ) ) = mydata( 1:recvcount( 1 ) ) -#endif - RETURN - END SUBROUTINE mp_gatherv_rv - -!------------------------------------------------------------------------------! -!..mp_gatherv_cv -!..Carlo Cavazzoni - - SUBROUTINE mp_gatherv_cv( mydata, alldata, recvcount, displs, root, gid) - IMPLICIT NONE - COMPLEX(DP) :: mydata(:) - COMPLEX(DP) :: alldata(:) - INTEGER, INTENT(IN) :: recvcount(:), displs(:), root - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: ierr, npe, myid - -#if defined (__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL mpi_comm_size( group, npe, ierr ) - IF (ierr/=0) CALL mp_stop( 8069 ) - CALL mpi_comm_rank( group, myid, ierr ) - IF (ierr/=0) CALL mp_stop( 8070 ) - ! - IF ( SIZE( recvcount ) < npe .OR. SIZE( displs ) < npe ) CALL mp_stop( 8071 ) - IF ( myid == root ) THEN - IF ( SIZE( alldata ) < displs( npe ) + recvcount( npe ) ) CALL mp_stop( 8072 ) - END IF - IF ( SIZE( mydata ) < recvcount( myid + 1 ) ) CALL mp_stop( 8073 ) - ! - CALL MPI_GATHERV( mydata, recvcount( myid + 1 ), MPI_DOUBLE_COMPLEX, & - alldata, recvcount, displs, MPI_DOUBLE_COMPLEX, root, group, ierr ) - IF (ierr/=0) CALL mp_stop( 8074 ) -#else - IF ( SIZE( alldata ) < recvcount( 1 ) ) CALL mp_stop( 8075 ) - IF ( SIZE( mydata ) < recvcount( 1 ) ) CALL mp_stop( 8076 ) - ! - alldata( 1:recvcount( 1 ) ) = mydata( 1:recvcount( 1 ) ) -#endif - RETURN - END SUBROUTINE mp_gatherv_cv - -!------------------------------------------------------------------------------! -!..mp_gatherv_rv -!..Carlo Cavazzoni - - SUBROUTINE mp_gatherv_iv( mydata, alldata, recvcount, displs, root, gid) - IMPLICIT NONE - INTEGER :: mydata(:) - INTEGER :: alldata(:) - INTEGER, INTENT(IN) :: recvcount(:), displs(:), root - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: ierr, npe, myid - -#if defined (__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL mpi_comm_size( group, npe, ierr ) - IF (ierr/=0) CALL mp_stop( 8069 ) - CALL mpi_comm_rank( group, myid, ierr ) - IF (ierr/=0) CALL mp_stop( 8070 ) - ! - IF ( SIZE( recvcount ) < npe .OR. SIZE( displs ) < npe ) CALL mp_stop( 8071 ) - IF ( myid == root ) THEN - IF ( SIZE( alldata ) < displs( npe ) + recvcount( npe ) ) CALL mp_stop( 8072 ) - END IF - IF ( SIZE( mydata ) < recvcount( myid + 1 ) ) CALL mp_stop( 8073 ) - ! - CALL MPI_GATHERV( mydata, recvcount( myid + 1 ), MPI_INTEGER, & - alldata, recvcount, displs, MPI_INTEGER, root, group, ierr ) - IF (ierr/=0) CALL mp_stop( 8074 ) -#else - IF ( SIZE( alldata ) < recvcount( 1 ) ) CALL mp_stop( 8075 ) - IF ( SIZE( mydata ) < recvcount( 1 ) ) CALL mp_stop( 8076 ) - ! - alldata( 1:recvcount( 1 ) ) = mydata( 1:recvcount( 1 ) ) -#endif - RETURN - END SUBROUTINE mp_gatherv_iv - - -!------------------------------------------------------------------------------! -!..mp_gatherv_rm -!..Carlo Cavazzoni - - SUBROUTINE mp_gatherv_rm( mydata, alldata, recvcount, displs, root, gid) - IMPLICIT NONE - REAL(DP) :: mydata(:,:) ! Warning first dimension is supposed constant! - REAL(DP) :: alldata(:,:) - INTEGER, INTENT(IN) :: recvcount(:), displs(:), root - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: ierr, npe, myid, nsiz - INTEGER, ALLOCATABLE :: nrecv(:), ndisp(:) - - -#if defined (__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL mpi_comm_size( group, npe, ierr ) - IF (ierr/=0) CALL mp_stop( 8069 ) - CALL mpi_comm_rank( group, myid, ierr ) - IF (ierr/=0) CALL mp_stop( 8070 ) - ! - IF ( SIZE( recvcount ) < npe .OR. SIZE( displs ) < npe ) CALL mp_stop( 8071 ) - IF ( myid == root ) THEN - IF ( SIZE( alldata, 2 ) < displs( npe ) + recvcount( npe ) ) CALL mp_stop( 8072 ) - IF ( SIZE( alldata, 1 ) /= SIZE( mydata, 1 ) ) CALL mp_stop( 8072 ) - END IF - IF ( SIZE( mydata, 2 ) < recvcount( myid + 1 ) ) CALL mp_stop( 8073 ) - ! - ALLOCATE( nrecv( npe ), ndisp( npe ) ) - ! - nrecv( 1:npe ) = recvcount( 1:npe ) * SIZE( mydata, 1 ) - ndisp( 1:npe ) = displs( 1:npe ) * SIZE( mydata, 1 ) - ! - CALL MPI_GATHERV( mydata, nrecv( myid + 1 ), MPI_DOUBLE_PRECISION, & - alldata, nrecv, ndisp, MPI_DOUBLE_PRECISION, root, group, ierr ) - IF (ierr/=0) CALL mp_stop( 8074 ) - ! - DEALLOCATE( nrecv, ndisp ) - ! -#else - IF ( SIZE( alldata, 1 ) /= SIZE( mydata, 1 ) ) CALL mp_stop( 8075 ) - IF ( SIZE( alldata, 2 ) < recvcount( 1 ) ) CALL mp_stop( 8075 ) - IF ( SIZE( mydata, 2 ) < recvcount( 1 ) ) CALL mp_stop( 8076 ) - ! - alldata( :, 1:recvcount( 1 ) ) = mydata( :, 1:recvcount( 1 ) ) -#endif - RETURN - END SUBROUTINE mp_gatherv_rm - -!------------------------------------------------------------------------------! -!..mp_gatherv_im -!..Carlo Cavazzoni - - SUBROUTINE mp_gatherv_im( mydata, alldata, recvcount, displs, root, gid) - IMPLICIT NONE - INTEGER :: mydata(:,:) ! Warning first dimension is supposed constant! - INTEGER :: alldata(:,:) - INTEGER, INTENT(IN) :: recvcount(:), displs(:), root - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: group - INTEGER :: ierr, npe, myid, nsiz - INTEGER, ALLOCATABLE :: nrecv(:), ndisp(:) - - -#if defined (__MPI) - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - CALL mpi_comm_size( group, npe, ierr ) - IF (ierr/=0) CALL mp_stop( 8069 ) - CALL mpi_comm_rank( group, myid, ierr ) - IF (ierr/=0) CALL mp_stop( 8070 ) - ! - IF ( SIZE( recvcount ) < npe .OR. SIZE( displs ) < npe ) CALL mp_stop( 8071 ) - IF ( myid == root ) THEN - IF ( SIZE( alldata, 2 ) < displs( npe ) + recvcount( npe ) ) CALL mp_stop( 8072 ) - IF ( SIZE( alldata, 1 ) /= SIZE( mydata, 1 ) ) CALL mp_stop( 8072 ) - END IF - IF ( SIZE( mydata, 2 ) < recvcount( myid + 1 ) ) CALL mp_stop( 8073 ) - ! - ALLOCATE( nrecv( npe ), ndisp( npe ) ) - ! - nrecv( 1:npe ) = recvcount( 1:npe ) * SIZE( mydata, 1 ) - ndisp( 1:npe ) = displs( 1:npe ) * SIZE( mydata, 1 ) - ! - CALL MPI_GATHERV( mydata, nrecv( myid + 1 ), MPI_INTEGER, & - alldata, nrecv, ndisp, MPI_INTEGER, root, group, ierr ) - IF (ierr/=0) CALL mp_stop( 8074 ) - ! - DEALLOCATE( nrecv, ndisp ) - ! -#else - IF ( SIZE( alldata, 1 ) /= SIZE( mydata, 1 ) ) CALL mp_stop( 8075 ) - IF ( SIZE( alldata, 2 ) < recvcount( 1 ) ) CALL mp_stop( 8075 ) - IF ( SIZE( mydata, 2 ) < recvcount( 1 ) ) CALL mp_stop( 8076 ) - ! - alldata( :, 1:recvcount( 1 ) ) = mydata( :, 1:recvcount( 1 ) ) -#endif - RETURN - END SUBROUTINE mp_gatherv_im - - -!------------------------------------------------------------------------------! - - SUBROUTINE mp_set_displs( recvcount, displs, ntot, nproc ) - ! Given the number of elements on each processor (recvcount), this subroutine - ! sets the correct offsets (displs) to collect them on a single - ! array with contiguous elemets - IMPLICIT NONE - INTEGER, INTENT(IN) :: recvcount(:) ! number of elements on each processor - INTEGER, INTENT(OUT) :: displs(:) ! offsets/displacements - INTEGER, INTENT(OUT) :: ntot - INTEGER, INTENT(IN) :: nproc - INTEGER :: i - - displs( 1 ) = 0 - ! -#if defined (__MPI) - IF( nproc < 1 ) CALL mp_stop( 8090 ) - DO i = 2, nproc - displs( i ) = displs( i - 1 ) + recvcount( i - 1 ) - END DO - ntot = displs( nproc ) + recvcount( nproc ) -#else - ntot = recvcount( 1 ) -#endif - RETURN - END SUBROUTINE mp_set_displs - -!------------------------------------------------------------------------------! - - -SUBROUTINE mp_alltoall_c3d( sndbuf, rcvbuf, gid ) - IMPLICIT NONE - COMPLEX(DP) :: sndbuf( :, :, : ) - COMPLEX(DP) :: rcvbuf( :, :, : ) - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: nsiz, group, ierr, npe - -#if defined (__MPI) - - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - - CALL mpi_comm_size( group, npe, ierr ) - IF (ierr/=0) CALL mp_stop( 8069 ) - - IF ( SIZE( sndbuf, 3 ) < npe ) CALL mp_stop( 8069 ) - IF ( SIZE( rcvbuf, 3 ) < npe ) CALL mp_stop( 8069 ) - - nsiz = SIZE( sndbuf, 1 ) * SIZE( sndbuf, 2 ) - - CALL MPI_ALLTOALL( sndbuf, nsiz, MPI_DOUBLE_COMPLEX, & - rcvbuf, nsiz, MPI_DOUBLE_COMPLEX, group, ierr ) - - IF (ierr/=0) CALL mp_stop( 8074 ) - -#else - - rcvbuf = sndbuf - -#endif - - RETURN -END SUBROUTINE mp_alltoall_c3d - - -!------------------------------------------------------------------------------! - -SUBROUTINE mp_alltoall_i3d( sndbuf, rcvbuf, gid ) - IMPLICIT NONE - INTEGER :: sndbuf( :, :, : ) - INTEGER :: rcvbuf( :, :, : ) - INTEGER, OPTIONAL, INTENT(IN) :: gid - INTEGER :: nsiz, group, ierr, npe - -#if defined (__MPI) - - group = mpi_comm_world - IF( PRESENT( gid ) ) group = gid - - CALL mpi_comm_size( group, npe, ierr ) - IF (ierr/=0) CALL mp_stop( 8069 ) - - IF ( SIZE( sndbuf, 3 ) < npe ) CALL mp_stop( 8069 ) - IF ( SIZE( rcvbuf, 3 ) < npe ) CALL mp_stop( 8069 ) - - nsiz = SIZE( sndbuf, 1 ) * SIZE( sndbuf, 2 ) - - CALL MPI_ALLTOALL( sndbuf, nsiz, MPI_INTEGER, & - rcvbuf, nsiz, MPI_INTEGER, group, ierr ) - - IF (ierr/=0) CALL mp_stop( 8074 ) - -#else - - rcvbuf = sndbuf - -#endif - - RETURN -END SUBROUTINE mp_alltoall_i3d - - - -!------------------------------------------------------------------------------! - END MODULE mp -!------------------------------------------------------------------------------! - diff --git a/quantum_espresso/kcp/Modules/mp_base.f90 b/quantum_espresso/kcp/Modules/mp_base.f90 deleted file mode 100644 index ce31bb2fd..000000000 --- a/quantum_espresso/kcp/Modules/mp_base.f90 +++ /dev/null @@ -1,1014 +0,0 @@ -! -! Copyright (C) 2002-2008 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -! Wrapper for MPI implementations that have problems with large messages -! - - -! In some MPI implementation the communicaction subsystem -! crashes when message exceed a given size, so we need -! to break down MPI communications in smaller pieces -! -#define __MSGSIZ_MAX 100000 -#define __BCAST_MSGSIZ_MAX 100000 - -! Some implementation of MPI (OpenMPI) if it is not well tuned for the given -! network hardware (InfiniBand) tend to loose performance or get stuck inside collective -! routines if processors are not well synchronized, a barrier fix the problem -! -#define __USE_BARRIER - - -!=----------------------------------------------------------------------------=! -! - -SUBROUTINE synchronize( gid ) - USE parallel_include - IMPLICIT NONE - INTEGER, INTENT(IN) :: gid -#if defined __MPI && defined __USE_BARRIER - INTEGER :: ierr - CALL mpi_barrier( gid, ierr ) - IF( ierr /= 0 ) CALL errore( ' synchronize ', ' error in mpi_barrier ', ierr ) -#endif - RETURN -END SUBROUTINE synchronize - - -!=----------------------------------------------------------------------------=! -! - - SUBROUTINE BCAST_REAL( array, n, root, gid ) - USE kinds, ONLY: DP - USE parallel_include - IMPLICIT NONE - INTEGER, INTENT(IN) :: n, root, gid - REAL(DP) :: array( n ) -#if defined __MPI - INTEGER :: msgsiz_max = __BCAST_MSGSIZ_MAX - INTEGER :: nblk, blksiz, iblk, istart, ierr - -#if defined __TRACE - write(*,*) 'BCAST_REAL IN' -#endif - IF( n <= 0 ) GO TO 1 - -#if defined __USE_BARRIER - CALL synchronize( gid ) -#endif - - IF( n <= msgsiz_max ) THEN - CALL MPI_BCAST( array, n, MPI_DOUBLE_PRECISION, root, gid, ierr ) - IF( ierr /= 0 ) CALL errore( ' bcast_real ', ' error in mpi_bcast 1 ', ierr ) - ELSE - nblk = n / msgsiz_max - blksiz = msgsiz_max - DO iblk = 1, nblk - istart = (iblk-1)*msgsiz_max + 1 - CALL MPI_BCAST( array( istart ), blksiz, MPI_DOUBLE_PRECISION, root, gid, ierr ) - IF( ierr /= 0 ) CALL errore( ' bcast_real ', ' error in mpi_bcast 2 ', ierr ) - END DO - blksiz = MOD( n, msgsiz_max ) - IF( blksiz > 0 ) THEN - istart = nblk * msgsiz_max + 1 - CALL MPI_BCAST( array( istart ), blksiz, MPI_DOUBLE_PRECISION, root, gid, ierr ) - IF( ierr /= 0 ) CALL errore( ' bcast_real ', ' error in mpi_bcast 3 ', ierr ) - END IF - END IF - -1 CONTINUE -#if defined __TRACE - write(*,*) 'BCAST_REAL OUT' -#endif - -#endif - - RETURN - END SUBROUTINE BCAST_REAL - - - SUBROUTINE BCAST_INTEGER( array, n, root, gid ) - USE parallel_include - IMPLICIT NONE - INTEGER, INTENT(IN) :: n, root, gid - INTEGER :: array( n ) -#if defined __MPI - INTEGER :: msgsiz_max = __MSGSIZ_MAX - INTEGER :: nblk, blksiz, iblk, istart, ierr - -#if defined __TRACE - write(*,*) 'BCAST_INTEGER IN' -#endif - - IF( n <= 0 ) GO TO 1 - -#if defined __USE_BARRIER - CALL synchronize( gid ) -#endif - - IF( n <= msgsiz_max ) THEN - CALL MPI_BCAST( array, n, MPI_INTEGER, root, gid, ierr ) - IF( ierr /= 0 ) CALL errore( ' bcast_integer ', ' error in mpi_bcast 1 ', ierr ) - ELSE - nblk = n / msgsiz_max - blksiz = msgsiz_max - DO iblk = 1, nblk - istart = (iblk-1)*msgsiz_max + 1 - CALL MPI_BCAST( array( istart ), blksiz, MPI_INTEGER, root, gid, ierr ) - IF( ierr /= 0 ) CALL errore( ' bcast_integer ', ' error in mpi_bcast 2 ', ierr ) - END DO - blksiz = MOD( n, msgsiz_max ) - IF( blksiz > 0 ) THEN - istart = nblk * msgsiz_max + 1 - CALL MPI_BCAST( array( istart ), blksiz, MPI_INTEGER, root, gid, ierr ) - IF( ierr /= 0 ) CALL errore( ' bcast_integer ', ' error in mpi_bcast 3 ', ierr ) - END IF - END IF -1 CONTINUE -#if defined __TRACE - write(*,*) 'BCAST_INTEGER OUT' -#endif -#endif - RETURN - END SUBROUTINE BCAST_INTEGER - - - SUBROUTINE BCAST_LOGICAL( array, n, root, gid ) - USE parallel_include - IMPLICIT NONE - INTEGER, INTENT(IN) :: n, root, gid - LOGICAL :: array( n ) -#if defined __MPI - INTEGER :: msgsiz_max = __MSGSIZ_MAX - INTEGER :: nblk, blksiz, iblk, istart, ierr - -#if defined __TRACE - write(*,*) 'BCAST_LOGICAL IN' -#endif - - IF( n <= 0 ) GO TO 1 - -#if defined __USE_BARRIER - CALL synchronize( gid ) -#endif - - IF( n <= msgsiz_max ) THEN - CALL MPI_BCAST( array, n, MPI_LOGICAL, root, gid, ierr ) - IF( ierr /= 0 ) CALL errore( ' bcast_logical ', ' error in mpi_bcast 1 ', ierr ) - ELSE - nblk = n / msgsiz_max - blksiz = msgsiz_max - DO iblk = 1, nblk - istart = (iblk-1)*msgsiz_max + 1 - CALL MPI_BCAST( array( istart ), blksiz, MPI_LOGICAL, root, gid, ierr ) - IF( ierr /= 0 ) CALL errore( ' bcast_logical ', ' error in mpi_bcast 2 ', ierr ) - END DO - blksiz = MOD( n, msgsiz_max ) - IF( blksiz > 0 ) THEN - istart = nblk * msgsiz_max + 1 - CALL MPI_BCAST( array( istart ), blksiz, MPI_LOGICAL, root, gid, ierr ) - IF( ierr /= 0 ) CALL errore( ' bcast_logical ', ' error in mpi_bcast 3 ', ierr ) - END IF - END IF - -1 CONTINUE -#if defined __TRACE - write(*,*) 'BCAST_LOGICAL OUT' -#endif -#endif - RETURN - END SUBROUTINE BCAST_LOGICAL - - -! -! ... "reduce"-like subroutines -! -!---------------------------------------------------------------------------- -SUBROUTINE reduce_base_real( dim, ps, comm, root ) - !---------------------------------------------------------------------------- - ! - ! ... sums a distributed variable ps(dim) over the processors. - ! ... This version uses a fixed-length buffer of appropriate (?) dim - ! ... uses SHMEM if available, MPI otherwhise - ! - USE kinds, ONLY : DP - USE parallel_include - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: dim ! size of the array - REAL(DP) :: ps(dim) ! array whose elements have to be reduced - INTEGER, INTENT(IN) :: comm ! communicator - INTEGER, INTENT(IN) :: root ! if root < 0 perform a reduction to all procs - ! if root >= 0 perform a reduce only to root proc. - ! -#if defined (__PARA) - ! - INTEGER :: info, n, nbuf, nproc, myid - INTEGER, PARAMETER :: maxb = __MSGSIZ_MAX - ! -#if defined (__SHMEM) && (defined __ALTIX || defined __ORIGIN) - ! - ! ... SHMEM specific - ! - INCLUDE 'mpp/shmem.fh' - INTEGER :: sym_len - LOGICAL :: first - REAL(DP) :: buff(*), snd_buff(*) - POINTER (buff_p, buff), (snd_buff_p, snd_buff) - COMMON /sym_heap1/ buff_p, snd_buff_p, sym_len, first - INTEGER :: pWrkSync(SHMEM_REDUCE_SYNC_SIZE), pWrkData(1024*1024), start - DATA pWrkSync /SHMEM_REDUCE_SYNC_SIZE*SHMEM_SYNC_VALUE/ - DATA pWrkData / 1048576 * 0 / - ! -#else - ! - REAL(DP) :: buff(maxb) - ! the use of the common here could help the transfer of data to the network device - COMMON / mp_base_real / buff - ! -#endif - ! -#if defined __TRACE - write(*,*) 'reduce_base_real IN' -#endif - - CALL mpi_comm_size( comm, nproc, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_real', 'error in mpi_comm_size', info ) - - CALL mpi_comm_rank( comm, myid, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_real', 'error in mpi_comm_rank', info ) - ! - IF ( dim <= 0 .OR. nproc <= 1 ) GO TO 1 ! go to the end of the subroutine - ! - ! ... synchronize processes - ! -#if defined __USE_BARRIER - CALL synchronize( comm ) -#endif - ! - nbuf = dim / maxb - ! -#if defined (__SHMEM) && ( defined (__ALTIX) || defined (__ORIGIN) ) - IF (dim .GT. sym_len) THEN - IF (sym_len .NE. 0) THEN - CALL shpdeallc( snd_buff_p, info, -1 ) - END IF - sym_len = dim - CALL shpalloc( snd_buff_p, 2*sym_len, info, -1 ) - END IF - IF (first .NE. .TRUE.) THEN - CALL shpalloc( buff_p, 2*maxb, info, -1 ) - first = .TRUE. - END IF - snd_buff(1:dim) = ps(1:dim) - ! - start = myid * nproc - ! -#endif - ! - DO n = 1, nbuf - ! -#if defined (__SHMEM) && ( defined (__ALTIX) || defined (__ORIGIN) ) - CALL SHMEM_REAL8_SUM_TO_ALL( buff, snd_buff(1+(n-1)*maxb), maxb, start, 0, nproc, pWrkData, pWrkSync ) -#else - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+(n-1)*maxb), buff, maxb, MPI_DOUBLE_PRECISION, MPI_SUM, root, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_real', 'error in mpi_reduce 1', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+(n-1)*maxb), buff, maxb, MPI_DOUBLE_PRECISION, MPI_SUM, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_real', 'error in mpi_allreduce 1', info ) - END IF - ! -#endif - ! - IF( root < 0 ) THEN - ps((1+(n-1)*maxb):(n*maxb)) = buff(1:maxb) - ELSE IF( root == myid ) THEN - ps((1+(n-1)*maxb):(n*maxb)) = buff(1:maxb) - END IF - ! - END DO - ! - ! ... possible remaining elements < maxb - ! - IF ( ( dim - nbuf * maxb ) > 0 ) THEN - ! -#if defined (__SHMEM) && ( defined (__ALTIX) || defined (__ORIGIN) ) - ! - CALL SHMEM_REAL8_SUM_TO_ALL( buff, snd_buff(1+nbuf*maxb), (dim-nbuf*maxb), start, 0, nproc, pWrkData, pWrkSync ) - ! -#else - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+nbuf*maxb), buff, (dim-nbuf*maxb), MPI_DOUBLE_PRECISION, MPI_SUM, root, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_real', 'error in mpi_reduce 2', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+nbuf*maxb), buff, (dim-nbuf*maxb), MPI_DOUBLE_PRECISION, MPI_SUM, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_real', 'error in mpi_allreduce 2', info ) - END IF - ! -#endif - ! - IF( root < 0 ) THEN - ps((1+nbuf*maxb):dim) = buff(1:(dim-nbuf*maxb)) - ELSE IF( root == myid ) THEN - ps((1+nbuf*maxb):dim) = buff(1:(dim-nbuf*maxb)) - END IF - ! - END IF - ! -1 CONTINUE - ! -#if defined __TRACE - write(*,*) 'reduce_base_real OUT' -#endif - ! -#endif - ! - RETURN - ! -END SUBROUTINE reduce_base_real -! -! -! -!---------------------------------------------------------------------------- -SUBROUTINE reduce_base_integer( dim, ps, comm, root ) - !---------------------------------------------------------------------------- - ! - ! ... sums a distributed variable ps(dim) over the processors. - ! ... This version uses a fixed-length buffer of appropriate (?) dim - ! ... uses SHMEM if available, MPI otherwhise - ! - USE kinds, ONLY : DP - USE parallel_include - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: dim - INTEGER :: ps(dim) - INTEGER, INTENT(IN) :: comm ! communicator - INTEGER, INTENT(IN) :: root ! if root < 0 perform a reduction to all procs - ! if root >= 0 perform a reduce only to root proc. - ! -#if defined (__PARA) - ! - INTEGER :: info, n, nbuf, nproc, myid - INTEGER, PARAMETER :: maxb = __MSGSIZ_MAX - ! - INTEGER :: buff(maxb) - COMMON / mp_base_integer / buff - ! -#if defined __TRACE - write(*,*) 'reduce_base_integer IN' -#endif - ! - CALL mpi_comm_size( comm, nproc, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_integer', 'error in mpi_comm_size', info ) - - CALL mpi_comm_rank( comm, myid, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_integer', 'error in mpi_comm_rank', info ) - ! - IF ( dim <= 0 .OR. nproc <= 1 ) GO TO 1 ! go to the end of the subroutine - ! - ! ... synchronize processes - ! -#if defined __USE_BARRIER - CALL synchronize( comm ) -#endif - ! - nbuf = dim / maxb - ! - DO n = 1, nbuf - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+(n-1)*maxb), buff, maxb, MPI_INTEGER, MPI_SUM, root, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_integer', 'error in mpi_reduce 1', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+(n-1)*maxb), buff, maxb, MPI_INTEGER, MPI_SUM, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_integer', 'error in mpi_allreduce 1', info ) - END IF - ! - IF( root < 0 ) THEN - ps((1+(n-1)*maxb):(n*maxb)) = buff(1:maxb) - ELSE IF( root == myid ) THEN - ps((1+(n-1)*maxb):(n*maxb)) = buff(1:maxb) - END IF - ! - END DO - ! - ! ... possible remaining elements < maxb - ! - IF ( ( dim - nbuf * maxb ) > 0 ) THEN - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+nbuf*maxb), buff, (dim-nbuf*maxb), MPI_INTEGER, MPI_SUM, root, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_integer', 'error in mpi_reduce 2', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+nbuf*maxb), buff, (dim-nbuf*maxb), MPI_INTEGER, MPI_SUM, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_integer', 'error in mpi_allreduce 2', info ) - END IF - ! - IF( root < 0 ) THEN - ps((1+nbuf*maxb):dim) = buff(1:(dim-nbuf*maxb)) - ELSE IF( root == myid ) THEN - ps((1+nbuf*maxb):dim) = buff(1:(dim-nbuf*maxb)) - END IF - ! - END IF - ! -1 CONTINUE - ! -#if defined __TRACE - write(*,*) 'reduce_base_integer OUT' -#endif - ! -#endif - ! - RETURN - ! -END SUBROUTINE reduce_base_integer - -! -! ... "reduce"-like subroutines -! -!---------------------------------------------------------------------------- -SUBROUTINE reduce_base_real_to( dim, ps, psout, comm, root ) - !---------------------------------------------------------------------------- - ! - ! ... sums a distributed variable ps(dim) over the processors, - ! ... and store the results in variable psout. - ! ... This version uses a fixed-length buffer of appropriate (?) lenght - ! - USE kinds, ONLY : DP - USE parallel_include - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: dim - REAL(DP), INTENT(IN) :: ps(dim) - REAL(DP) :: psout(dim) - INTEGER, INTENT(IN) :: comm ! communecator - INTEGER, INTENT(IN) :: root ! if root < 0 perform a reduction to all procs - ! if root >= 0 perform a reduce only to root proc. - ! -#if defined (__PARA) - ! - INTEGER :: info, n, nbuf, nproc, myid - INTEGER, PARAMETER :: maxb = __MSGSIZ_MAX - ! -#if defined __TRACE - write(*,*) 'reduce_base_real_to IN' -#endif - - CALL mpi_comm_size( comm, nproc, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_real_to', 'error in mpi_comm_size', info ) - - CALL mpi_comm_rank( comm, myid, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_real_to', 'error in mpi_comm_rank', info ) - ! - IF ( dim > 0 .AND. nproc <= 1 ) THEN - psout = ps - END IF - IF( dim <= 0 .OR. nproc <= 1 ) GO TO 1 ! go to the end of the subroutine - ! - ! ... synchronize processes - ! -#if defined __USE_BARRIER - CALL synchronize( comm ) -#endif - ! - nbuf = dim / maxb - ! - DO n = 1, nbuf - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+(n-1)*maxb), psout(1+(n-1)*maxb), maxb, MPI_DOUBLE_PRECISION, MPI_SUM, root, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_real_to', 'error in mpi_reduce 1', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+(n-1)*maxb), psout(1+(n-1)*maxb), maxb, MPI_DOUBLE_PRECISION, MPI_SUM, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_real_to', 'error in mpi_allreduce 1', info ) - END IF - ! - END DO - ! - ! ... possible remaining elements < maxb - ! - IF ( ( dim - nbuf * maxb ) > 0 ) THEN - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+nbuf*maxb), psout(1+nbuf*maxb), (dim-nbuf*maxb), MPI_DOUBLE_PRECISION, MPI_SUM, root, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_real_to', 'error in mpi_reduce 2', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+nbuf*maxb), psout(1+nbuf*maxb), (dim-nbuf*maxb), MPI_DOUBLE_PRECISION, MPI_SUM, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_real_to', 'error in mpi_allreduce 2', info ) - END IF - ! - END IF - ! -1 CONTINUE - ! -#if defined __TRACE - write(*,*) 'reduce_base_real_to OUT' -#endif - ! -#endif - ! - RETURN - ! -END SUBROUTINE reduce_base_real_to -! -! -! -!---------------------------------------------------------------------------- -SUBROUTINE reduce_base_integer_to( dim, ps, psout, comm, root ) - !---------------------------------------------------------------------------- - ! - ! ... sums a distributed integer variable ps(dim) over the processors, and - ! ... saves the result on the output variable psout. - ! ... This version uses a fixed-length buffer of appropriate (?) lenght - ! - USE kinds, ONLY : DP - USE parallel_include - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: dim - INTEGER, INTENT(IN) :: ps(dim) - INTEGER :: psout(dim) - INTEGER, INTENT(IN) :: comm ! communecator - INTEGER, INTENT(IN) :: root ! if root < 0 perform a reduction to all procs - ! if root >= 0 perform a reduce only to root proc. - ! -#if defined (__PARA) - ! - INTEGER :: info, n, nbuf, nproc, myid - INTEGER, PARAMETER :: maxb = __MSGSIZ_MAX - ! -#if defined __TRACE - write(*,*) 'reduce_base_integer_to IN' -#endif - - CALL mpi_comm_size( comm, nproc, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_integer_to', 'error in mpi_comm_size', info ) - - CALL mpi_comm_rank( comm, myid, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_integer_to', 'error in mpi_comm_rank', info ) - ! - IF ( dim > 0 .AND. nproc <= 1 ) THEN - psout = ps - END IF - IF( dim <= 0 .OR. nproc <= 1 ) GO TO 1 ! go to the end of the subroutine - ! - ! ... synchronize processes - ! -#if defined __USE_BARRIER - CALL synchronize( comm ) -#endif - ! - nbuf = dim / maxb - ! - DO n = 1, nbuf - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+(n-1)*maxb), psout( 1+(n-1)*maxb ), maxb, MPI_INTEGER, MPI_SUM, root, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_integer_to', 'error in mpi_reduce 1', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+(n-1)*maxb), psout( 1+(n-1)*maxb ), maxb, MPI_INTEGER, MPI_SUM, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_integer_to', 'error in mpi_allreduce 1', info ) - END IF - ! - END DO - ! - ! ... possible remaining elements < maxb - ! - IF ( ( dim - nbuf * maxb ) > 0 ) THEN - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+nbuf*maxb), psout(1+nbuf*maxb), (dim-nbuf*maxb), MPI_INTEGER, MPI_SUM, root, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_integer_to', 'error in mpi_reduce 2', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+nbuf*maxb), psout(1+nbuf*maxb), (dim-nbuf*maxb), MPI_INTEGER, MPI_SUM, comm, info ) - IF( info /= 0 ) CALL errore( 'reduce_base_integer_to', 'error in mpi_allreduce 2', info ) - END IF - ! - END IF - ! -1 CONTINUE - ! -#if defined __TRACE - write(*,*) 'reduce_base_integer_to OUT' -#endif - ! -#endif - ! - RETURN - ! -END SUBROUTINE reduce_base_integer_to -! -! -! Parallel MIN and MAX -! - -!---------------------------------------------------------------------------- -SUBROUTINE parallel_min_integer( dim, ps, comm, root ) - !---------------------------------------------------------------------------- - ! - ! ... compute the minimum of a distributed variable ps(dim) over the processors. - ! ... This version uses a fixed-length buffer of appropriate (?) dim - ! - USE kinds, ONLY : DP - USE parallel_include - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: dim - INTEGER :: ps(dim) - INTEGER, INTENT(IN) :: comm ! communecator - INTEGER, INTENT(IN) :: root ! if root < 0 perform a reduction to all procs - ! if root >= 0 perform a reduce only to root proc. - ! -#if defined (__PARA) - ! - INTEGER :: info, n, nbuf, nproc, myid - INTEGER, PARAMETER :: maxb = __MSGSIZ_MAX - ! - INTEGER :: buff(maxb) - COMMON / mp_base_integer / buff - ! -#if defined __TRACE - write(*,*) 'parallel_min_integer IN' -#endif - ! - CALL mpi_comm_size( comm, nproc, info ) - IF( info /= 0 ) CALL errore( 'parallel_min_integer', 'error in mpi_comm_size', info ) - - CALL mpi_comm_rank( comm, myid, info ) - IF( info /= 0 ) CALL errore( 'parallel_min_integer', 'error in mpi_comm_rank', info ) - ! - IF ( dim <= 0 .OR. nproc <= 1 ) GO TO 1 - ! - ! ... synchronize processes - ! -#if defined __USE_BARRIER - CALL synchronize( comm ) -#endif - ! - nbuf = dim / maxb - ! - DO n = 1, nbuf - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+(n-1)*maxb), buff, maxb, MPI_INTEGER, MPI_MIN, root, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_min_integer', 'error in mpi_reduce 1', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+(n-1)*maxb), buff, maxb, MPI_INTEGER, MPI_MIN, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_min_integer', 'error in mpi_allreduce 1', info ) - END IF - ! - IF( root < 0 ) THEN - ps((1+(n-1)*maxb):(n*maxb)) = buff(1:maxb) - ELSE IF( root == myid ) THEN - ps((1+(n-1)*maxb):(n*maxb)) = buff(1:maxb) - END IF - ! - END DO - ! - ! ... possible remaining elements < maxb - ! - IF ( ( dim - nbuf * maxb ) > 0 ) THEN - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+nbuf*maxb), buff, (dim-nbuf*maxb), MPI_INTEGER, MPI_MIN, root, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_min_integer', 'error in mpi_reduce 2', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+nbuf*maxb), buff, (dim-nbuf*maxb), MPI_INTEGER, MPI_MIN, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_min_integer', 'error in mpi_allreduce 2', info ) - END IF - ! - IF( root < 0 ) THEN - ps((1+nbuf*maxb):dim) = buff(1:(dim-nbuf*maxb)) - ELSE IF( root == myid ) THEN - ps((1+nbuf*maxb):dim) = buff(1:(dim-nbuf*maxb)) - END IF - ! - END IF - ! -1 CONTINUE - ! -#if defined __TRACE - write(*,*) 'parallel_min_integer OUT' -#endif - ! -#endif - ! - RETURN - ! -END SUBROUTINE parallel_min_integer - -! -!---------------------------------------------------------------------------- -SUBROUTINE parallel_max_integer( dim, ps, comm, root ) - !---------------------------------------------------------------------------- - ! - ! ... compute the maximum of a distributed variable ps(dim) over the processors. - ! ... This version uses a fixed-length buffer of appropriate (?) dim - ! - USE kinds, ONLY : DP - USE parallel_include - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: dim - INTEGER :: ps(dim) - INTEGER, INTENT(IN) :: comm ! communecator - INTEGER, INTENT(IN) :: root ! if root < 0 perform a reduction to all procs - ! if root >= 0 perform a reduce only to root proc. - ! -#if defined (__PARA) - ! - INTEGER :: info, n, nbuf, nproc, myid - INTEGER, PARAMETER :: maxb = __MSGSIZ_MAX - ! - INTEGER :: buff(maxb) - COMMON / mp_base_integer / buff - ! -#if defined __TRACE - write(*,*) 'parallel_max_integer IN' -#endif - CALL mpi_comm_size( comm, nproc, info ) - IF( info /= 0 ) CALL errore( 'parallel_max_integer', 'error in mpi_comm_size', info ) - - CALL mpi_comm_rank( comm, myid, info ) - IF( info /= 0 ) CALL errore( 'parallel_max_integer', 'error in mpi_comm_rank', info ) - ! - IF ( dim <= 0 .OR. nproc <= 1 ) GO TO 1 - ! - ! ... synchronize processes - ! -#if defined __USE_BARRIER - CALL synchronize( comm ) -#endif - ! - nbuf = dim / maxb - ! - DO n = 1, nbuf - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+(n-1)*maxb), buff, maxb, MPI_INTEGER, MPI_MAX, root, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_max_integer', 'error in mpi_reduce 1', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+(n-1)*maxb), buff, maxb, MPI_INTEGER, MPI_MAX, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_max_integer', 'error in mpi_allreduce 1', info ) - END IF - ! - IF( root < 0 ) THEN - ps((1+(n-1)*maxb):(n*maxb)) = buff(1:maxb) - ELSE IF( root == myid ) THEN - ps((1+(n-1)*maxb):(n*maxb)) = buff(1:maxb) - END IF - ! - END DO - ! - ! ... possible remaining elements < maxb - ! - IF ( ( dim - nbuf * maxb ) > 0 ) THEN - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+nbuf*maxb), buff, (dim-nbuf*maxb), MPI_INTEGER, MPI_MAX, root, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_max_integer', 'error in mpi_reduce 2', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+nbuf*maxb), buff, (dim-nbuf*maxb), MPI_INTEGER, MPI_MAX, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_max_integer', 'error in mpi_allreduce 2', info ) - END IF - ! - IF( root < 0 ) THEN - ps((1+nbuf*maxb):dim) = buff(1:(dim-nbuf*maxb)) - ELSE IF( root == myid ) THEN - ps((1+nbuf*maxb):dim) = buff(1:(dim-nbuf*maxb)) - END IF - ! - END IF - ! -1 CONTINUE - ! -#if defined __TRACE - write(*,*) 'parallel_max_integer OUT' -#endif -#endif - ! - RETURN - ! -END SUBROUTINE parallel_max_integer - - -!---------------------------------------------------------------------------- -SUBROUTINE parallel_min_real( dim, ps, comm, root ) - !---------------------------------------------------------------------------- - ! - ! ... compute the minimum value of a distributed variable ps(dim) over the processors. - ! ... This version uses a fixed-length buffer of appropriate (?) dim - ! - USE kinds, ONLY : DP - USE parallel_include - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: dim - REAL(DP) :: ps(dim) - INTEGER, INTENT(IN) :: comm ! communecator - INTEGER, INTENT(IN) :: root ! if root < 0 perform a reduction to all procs - ! if root >= 0 perform a reduce only to root proc. - ! -#if defined (__PARA) - ! - INTEGER :: info, n, nbuf, nproc, myid - INTEGER, PARAMETER :: maxb = __MSGSIZ_MAX - ! - REAL(DP) :: buff(maxb) - COMMON / mp_base_real / buff - ! -#if defined __TRACE - write(*,*) 'parallel_min_real IN' -#endif - CALL mpi_comm_size( comm, nproc, info ) - IF( info /= 0 ) CALL errore( 'parallel_min_real', 'error in mpi_comm_size', info ) - - CALL mpi_comm_rank( comm, myid, info ) - IF( info /= 0 ) CALL errore( 'parallel_min_real', 'error in mpi_comm_rank', info ) - ! - IF ( dim <= 0 .OR. nproc <= 1 ) GO TO 1 - ! - ! ... synchronize processes - ! -#if defined __USE_BARRIER - CALL synchronize( comm ) -#endif - ! - nbuf = dim / maxb - ! - DO n = 1, nbuf - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+(n-1)*maxb), buff, maxb, MPI_DOUBLE_PRECISION, MPI_MIN, root, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_min_real', 'error in mpi_reduce 1', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+(n-1)*maxb), buff, maxb, MPI_DOUBLE_PRECISION, MPI_MIN, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_min_real', 'error in mpi_allreduce 1', info ) - END IF - ! - IF( root < 0 ) THEN - ps((1+(n-1)*maxb):(n*maxb)) = buff(1:maxb) - ELSE IF( root == myid ) THEN - ps((1+(n-1)*maxb):(n*maxb)) = buff(1:maxb) - END IF - ! - END DO - ! - ! ... possible remaining elements < maxb - ! - IF ( ( dim - nbuf * maxb ) > 0 ) THEN - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+nbuf*maxb), buff, (dim-nbuf*maxb), MPI_DOUBLE_PRECISION, MPI_MIN, root, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_min_real', 'error in mpi_reduce 2', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+nbuf*maxb), buff, (dim-nbuf*maxb), MPI_DOUBLE_PRECISION, MPI_MIN, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_min_real', 'error in mpi_allreduce 2', info ) - END IF - ! - IF( root < 0 ) THEN - ps((1+nbuf*maxb):dim) = buff(1:(dim-nbuf*maxb)) - ELSE IF( root == myid ) THEN - ps((1+nbuf*maxb):dim) = buff(1:(dim-nbuf*maxb)) - END IF - ! - END IF - ! -1 CONTINUE - ! -#if defined __TRACE - write(*,*) 'parallel_min_real OUT' -#endif -#endif - ! - RETURN - ! -END SUBROUTINE parallel_min_real - -! -!---------------------------------------------------------------------------- -SUBROUTINE parallel_max_real( dim, ps, comm, root ) - !---------------------------------------------------------------------------- - ! - ! ... compute the maximum value of a distributed variable ps(dim) over the processors. - ! ... This version uses a fixed-length buffer of appropriate (?) dim - ! - USE kinds, ONLY : DP - USE parallel_include - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: dim - REAL(DP) :: ps(dim) - INTEGER, INTENT(IN) :: comm ! communecator - INTEGER, INTENT(IN) :: root ! if root < 0 perform a reduction to all procs - ! if root >= 0 perform a reduce only to root proc. - ! -#if defined (__PARA) - ! - INTEGER :: info, n, nbuf, nproc, myid - INTEGER, PARAMETER :: maxb = __MSGSIZ_MAX - ! - REAL(DP) :: buff(maxb) - COMMON / mp_base_real / buff - ! -#if defined __TRACE - write(*,*) 'parallel_max_real IN' -#endif - - CALL mpi_comm_size( comm, nproc, info ) - IF( info /= 0 ) CALL errore( 'parallel_max_real', 'error in mpi_comm_size', info ) - - CALL mpi_comm_rank( comm, myid, info ) - IF( info /= 0 ) CALL errore( 'parallel_max_real', 'error in mpi_comm_rank', info ) - ! - IF ( dim <= 0 .OR. nproc <= 1 ) GO TO 1 - ! - ! ... synchronize processes - ! -#if defined __USE_BARRIER - CALL synchronize( comm ) -#endif - ! - nbuf = dim / maxb - ! - DO n = 1, nbuf - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+(n-1)*maxb), buff, maxb, MPI_DOUBLE_PRECISION, MPI_MAX, root, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_max_real', 'error in mpi_reduce 1', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+(n-1)*maxb), buff, maxb, MPI_DOUBLE_PRECISION, MPI_MAX, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_max_real', 'error in mpi_allreduce 1', info ) - END IF - ! - IF( root < 0 ) THEN - ps((1+(n-1)*maxb):(n*maxb)) = buff(1:maxb) - ELSE IF( root == myid ) THEN - ps((1+(n-1)*maxb):(n*maxb)) = buff(1:maxb) - END IF - ! - END DO - ! - ! ... possible remaining elements < maxb - ! - IF ( ( dim - nbuf * maxb ) > 0 ) THEN - ! - IF( root >= 0 ) THEN - CALL MPI_REDUCE( ps(1+nbuf*maxb), buff, (dim-nbuf*maxb), MPI_DOUBLE_PRECISION, MPI_MAX, root, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_max_real', 'error in mpi_reduce 2', info ) - ELSE - CALL MPI_ALLREDUCE( ps(1+nbuf*maxb), buff, (dim-nbuf*maxb), MPI_DOUBLE_PRECISION, MPI_MAX, comm, info ) - IF( info /= 0 ) CALL errore( 'parallel_max_real', 'error in mpi_allreduce 2', info ) - END IF - ! - IF( root < 0 ) THEN - ps((1+nbuf*maxb):dim) = buff(1:(dim-nbuf*maxb)) - ELSE IF( root == myid ) THEN - ps((1+nbuf*maxb):dim) = buff(1:(dim-nbuf*maxb)) - END IF - ! - END IF - ! -1 CONTINUE - ! -#if defined __TRACE - write(*,*) 'parallel_max_real OUT' -#endif - ! -#endif - ! - RETURN - ! -END SUBROUTINE parallel_max_real - - -SUBROUTINE hangup() -#if defined (__MPI) - IMPLICIT NONE - INCLUDE 'mpif.h' - INTEGER IERR - CALL MPI_BARRIER( MPI_COMM_WORLD, ierr ) - IF( ierr /= 0 ) CALL errore( ' hangup ', ' error in mpi_barrier ', ierr ) - CALL MPI_FINALIZE( ierr ) - IF( ierr /= 0 ) CALL errore( ' hangup ', ' error in mpi_finalize ', ierr ) -#endif - STOP 'hangup' -END SUBROUTINE hangup diff --git a/quantum_espresso/kcp/Modules/mp_global.f90 b/quantum_espresso/kcp/Modules/mp_global.f90 deleted file mode 100644 index 09125b112..000000000 --- a/quantum_espresso/kcp/Modules/mp_global.f90 +++ /dev/null @@ -1,498 +0,0 @@ -! -! Copyright (C) 2002-2004 PWSCF-FPMD-CP90 group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE mp_global - !---------------------------------------------------------------------------- - ! -#if defined (__SHMEM) - USE shmem_include -#endif - ! - USE parallel_include - ! - IMPLICIT NONE - ! - SAVE - ! - INTEGER :: mpime = 0 ! absolute processor index starting from 0 - INTEGER :: root = 0 ! index of the absolute root processor - INTEGER :: nproc = 1 ! absolute number of processor - INTEGER :: nproc_file = 1 ! absolute number of processor written in the - ! xml punch file - INTEGER :: world_comm = 0 ! communicator of all processor -#if defined __SCALAPACK - INTEGER :: me_blacs = 0 ! BLACS processor index starting from 0 - INTEGER :: np_blacs = 1 ! BLACS number of processor - INTEGER :: world_cntx = 0 ! BLACS context of all processor -#endif - - INTEGER :: kunit = 1 ! granularity of k-point distribution - ! - ! ... indeces ( all starting from 0 !!! ) - ! - INTEGER :: me_pool = 0 ! index of the processor within a pool - INTEGER :: me_image = 0 ! index of the processor within an image - INTEGER :: root_pool = 0 ! index of the root processor within a pool - INTEGER :: root_image = 0 ! index of the root processor within an image - INTEGER :: my_pool_id = 0 ! index of my pool - INTEGER :: my_image_id = 0 ! index of my image - INTEGER :: me_ortho(2) = 0 ! coordinates of the processors - INTEGER :: me_ortho1 = 0 ! task id for the ortho group - INTEGER :: me_pgrp = 0 ! task id for plane wave task group - ! - INTEGER :: npool = 1 ! number of "k-points"-pools - INTEGER :: nimage = 1 ! number of "path-images"-pools - INTEGER :: nogrp = 1 ! number of proc. in an orbital "task group" - INTEGER :: npgrp = 1 ! number of proc. in a plane-wave "task group" - INTEGER :: nproc_pool = 1 ! number of processor within a pool - INTEGER :: nproc_pool_file = 1 ! number of processor within a pool of - ! written in the xml punch file - INTEGER :: nproc_image = 1 ! number of processor within an image - INTEGER :: np_ortho(2) = 1 ! size of the processor grid used in ortho - INTEGER :: np_ortho1 = 1 ! size of the ortho group - INTEGER :: leg_ortho = 1 ! the distance in the father communicator - ! of two neighbour processors in ortho_comm - INTEGER, ALLOCATABLE :: nolist(:) ! list of processors in my orbital task group - INTEGER, ALLOCATABLE :: nplist(:) ! list of processors in my plane wave task group - ! - ! ... communicators - ! - INTEGER :: inter_pool_comm = 0 ! inter pool communicator - INTEGER :: intra_pool_comm = 0 ! intra pool communicator - INTEGER :: inter_image_comm = 0 ! inter image communicator - INTEGER :: intra_image_comm = 0 ! intra image communicator - INTEGER :: pgrp_comm = 0 ! plane-wave group communicator (task grouping) - INTEGER :: ogrp_comm = 0 ! orbital group communicarot (task grouping) - INTEGER :: ortho_comm = 0 ! communicator used for fast and memory saving ortho - INTEGER :: ortho_comm_id = 0 ! id of the ortho_comm -#if defined __SCALAPACK - INTEGER :: ortho_cntx = 0 ! BLACS context for ortho_comm -#endif - ! - CONTAINS - ! - !----------------------------------------------------------------------- - SUBROUTINE mp_global_start( root_i, mpime_i, group_i, nproc_i ) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: root_i, mpime_i, group_i, nproc_i - ! - root = root_i - mpime = mpime_i - world_comm = group_i - nproc = nproc_i - nproc_pool = nproc_i - nproc_image = nproc_i - my_pool_id = 0 - my_image_id = 0 - me_pool = mpime - me_image = mpime - me_pgrp = me_pool - root_pool = root - root_image = root - inter_pool_comm = group_i - intra_pool_comm = group_i - inter_image_comm = group_i - intra_image_comm = group_i - ortho_comm = group_i - ALLOCATE( nolist( nproc_i ) ) - ALLOCATE( nplist( nproc_i ) ) - nolist = 0 - nplist = 0 - ! - RETURN - ! - END SUBROUTINE mp_global_start - ! - !----------------------------------------------------------------------- - SUBROUTINE mp_global_group_start( mep, myp, nprocp, num_of_pools ) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: mep, myp, nprocp, num_of_pools - ! - me_pool = mep - my_pool_id = myp - nproc_pool = nprocp - npool = num_of_pools - ! - RETURN - ! - END SUBROUTINE mp_global_group_start - ! -! -!---------------------------------------------------------------------------- -SUBROUTINE init_pool( nimage_ , ntask_groups_ , nproc_ortho_ ) - !---------------------------------------------------------------------------- - ! - ! ... This routine initialize the pool : MPI division in pools and images - ! - USE mp, ONLY : mp_barrier, mp_bcast - USE parallel_include - ! - IMPLICIT NONE - ! - INTEGER, OPTIONAL, INTENT(IN) :: nimage_ - INTEGER, OPTIONAL, INTENT(IN) :: ntask_groups_ - INTEGER, OPTIONAL, INTENT(IN) :: nproc_ortho_ - ! - INTEGER :: ierr = 0 - INTEGER :: nproc_ortho - ! -#if defined (__PARA) - ! - ! - IF( PRESENT( nimage_ ) ) THEN - nimage = nimage_ - END IF - ! - ! ... here we set all parallel indeces (defined in mp_global): - ! - ! - ! ... number of cpus per image - ! - nproc_image = nproc / nimage - ! - IF ( nproc < nimage ) & - CALL errore( 'startup', 'nproc < nimage', 1 ) - ! - IF ( MOD( nproc, nimage ) /= 0 ) & - CALL errore( 'startup', 'nproc /= nproc_image * nimage', 1 ) - ! - ! ... my_image_id = image index for this processor ( 0 : nimage - 1 ) - ! ... me_image = processor index within the image ( 0 : nproc_image - 1 ) - ! - my_image_id = mpime / nproc_image - me_image = MOD( mpime, nproc_image ) - ! - CALL mp_barrier() - ! - ! ... the intra_image_comm communicator is created - ! - CALL MPI_COMM_SPLIT( MPI_COMM_WORLD, & - my_image_id, mpime, intra_image_comm, ierr ) - ! - CALL errore( 'init_pool', 'intra_image_comm is wrong', ierr ) - ! - CALL mp_barrier() - ! - ! ... the inter_image_comm communicator is created - ! - CALL MPI_COMM_SPLIT( MPI_COMM_WORLD, & - me_image, mpime, inter_image_comm, ierr ) - ! - CALL errore( 'init_pool', 'inter_image_comm is wrong', ierr ) - ! - ! ... number of cpus per pool of k-points (they are created inside each image) - ! - nproc_pool = nproc_image / npool - ! - IF ( MOD( nproc, npool ) /= 0 ) & - CALL errore( 'startup', 'nproc /= nproc_pool * npool', 1 ) - ! - ! ... my_pool_id = pool index for this processor ( 0 : npool - 1 ) - ! ... me_pool = processor index within the pool ( 0 : nproc_pool - 1 ) - ! - my_pool_id = me_image / nproc_pool - me_pool = MOD( me_image, nproc_pool ) - ! - CALL mp_barrier( intra_image_comm ) - ! - ! ... the intra_pool_comm communicator is created - ! - CALL MPI_COMM_SPLIT( intra_image_comm, & - my_pool_id, me_image, intra_pool_comm, ierr ) - ! - CALL errore( 'init_pool', 'intra_pool_comm is wrong', ierr ) - ! - CALL mp_barrier( intra_image_comm ) - ! - ! ... the inter_pool_comm communicator is created - ! - CALL MPI_COMM_SPLIT( intra_image_comm, & - me_pool, me_image, inter_pool_comm, ierr ) - ! - call errore( 'init_pool', 'inter_pool_comm is wrong', ierr ) - ! -#endif - ! - ! -#if defined __SCALAPACK - - CALL BLACS_PINFO( me_blacs, np_blacs ) - !WRITE(*,*) 'BLACS me_blacs, np_blacs = ', me_blacs, np_blacs - CALL BLACS_GET( -1, 0, world_cntx ) - !WRITE(*,*) 'BLACS world_cntx = ', world_cntx - -#endif - ! - nproc_ortho = nproc_pool - ! - IF( PRESENT( nproc_ortho_ ) ) THEN - IF( nproc_ortho_ < nproc_pool ) nproc_ortho = nproc_ortho_ - END IF - ! - CALL init_ortho_group( nproc_ortho, intra_pool_comm ) - ! - IF( PRESENT( ntask_groups_ ) ) THEN - IF( ntask_groups_ > 0 ) THEN - nogrp = ntask_groups_ - CALL init_task_groups( ) - END IF - END IF - ! - RETURN - ! -END SUBROUTINE init_pool -! -! -SUBROUTINE init_task_groups( ) - ! - INTEGER :: i, n1, ipos, color, key, ierr, itsk, ntsk - INTEGER :: pgroup( nproc_pool ) - ! - !SUBDIVIDE THE PROCESSORS IN GROUPS - ! - !THE NUMBER OF GROUPS HAS TO BE A DIVISOR OF THE NUMBER - !OF PROCESSORS - ! - IF( MOD( nproc_pool, nogrp ) /= 0 ) & - CALL errore( " init_pool ", " nogrp should be a divisor of nproc_pool ", 1 ) - ! - npgrp = nproc_pool / nogrp - - DO i = 1, nproc_pool - pgroup( i ) = i - 1 - ENDDO - ! - !LIST OF PROCESSORS IN MY ORBITAL GROUP - ! - ! processors in these group have contiguous indexes - ! - N1 = ( me_pool / NOGRP ) * NOGRP - 1 - DO i = 1, nogrp - nolist( I ) = pgroup( N1 + I + 1 ) - IF( me_pool == nolist( I ) ) ipos = i - 1 - ENDDO - ! - !LIST OF PROCESSORS IN MY PLANE WAVE GROUP - ! - DO I = 1, npgrp - nplist( I ) = pgroup( ipos + ( i - 1 ) * nogrp + 1 ) - ENDDO - - ! - !SET UP THE GROUPS - ! - ! - !CREATE ORBITAL GROUPS - ! -#if defined __MPI - color = me_pool / nogrp - key = MOD( me_pool , nogrp ) - CALL MPI_COMM_SPLIT( intra_pool_comm, color, key, ogrp_comm, ierr ) - if( ierr /= 0 ) & - CALL errore( ' task_groups_init ', ' creating ogrp_comm ', ABS(ierr) ) - CALL MPI_COMM_RANK( ogrp_comm, itsk, IERR ) - CALL MPI_COMM_SIZE( ogrp_comm, ntsk, IERR ) - IF( nogrp /= ntsk ) CALL errore( ' task_groups_init ', ' ogrp_comm size ', ntsk ) - DO i = 1, nogrp - IF( me_pool == nolist( i ) ) THEN - IF( (i-1) /= itsk ) CALL errore( ' task_groups_init ', ' ogrp_comm rank ', itsk ) - END IF - END DO -#endif - ! - !CREATE PLANEWAVE GROUPS - ! -#if defined __MPI - color = MOD( me_pool , nogrp ) - key = me_pool / nogrp - CALL MPI_COMM_SPLIT( intra_pool_comm, color, key, pgrp_comm, ierr ) - if( ierr /= 0 ) & - CALL errore( ' task_groups_init ', ' creating pgrp_comm ', ABS(ierr) ) - CALL MPI_COMM_RANK( pgrp_comm, itsk, IERR ) - CALL MPI_COMM_SIZE( pgrp_comm, ntsk, IERR ) - IF( npgrp /= ntsk ) CALL errore( ' task_groups_init ', ' pgrp_comm size ', ntsk ) - DO i = 1, npgrp - IF( me_pool == nplist( i ) ) THEN - IF( (i-1) /= itsk ) CALL errore( ' task_groups_init ', ' pgrp_comm rank ', itsk ) - END IF - END DO - me_pgrp = itsk -#endif - - - RETURN -END SUBROUTINE init_task_groups -! -! -SUBROUTINE init_ortho_group( nproc_try, comm_all ) - ! - USE mp, ONLY : mp_comm_free, mp_size, mp_rank, mp_sum - ! - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nproc_try, comm_all - - LOGICAL, SAVE :: first = .true. - INTEGER :: ierr, color, key, me_all, nproc_all - INTEGER :: np_ortho1 - -#if defined __SCALAPACK - INTEGER, ALLOCATABLE :: blacsmap(:,:) - INTEGER :: nprow, npcol, myrow, mycol -#endif - -#if defined __MPI - - me_all = mp_rank( comm_all ) - nproc_all = mp_size( comm_all ) - - IF( nproc_try > nproc_all ) THEN - CALL errore( " init_ortho_group ", " argument 1 out of range ", nproc_try ) - END IF - - IF( .NOT. first ) THEN - ! - ! free resources associated to the communicator - ! - CALL mp_comm_free( ortho_comm ) - ! -#if defined __SCALAPACK - CALL BLACS_GRIDEXIT( ortho_cntx ) -#endif - ! - END IF - - ! find the square closer (but lower) to nproc_try - ! - CALL grid2d_dims( 'S', nproc_try, np_ortho(1), np_ortho(2) ) - ! - np_ortho1 = np_ortho(1) * np_ortho(2) - ! - IF( nproc_all >= 4*np_ortho1 ) THEN - ! - ! here we choose a processor every 4, in order not to stress memory BW - ! on multi core procs, for which further performance enhancements are - ! possible using OpenMP BLAS inside regter/cegter/rdiaghg/cdiaghg - ! (to be implemented) - ! - color = 0 - IF( me_all < 4*np_ortho1 .AND. MOD( me_all, 4 ) == 0 ) color = 1 - ! - leg_ortho = 4 - ! - ELSE IF( nproc_all >= 2*np_ortho1 ) THEN - ! - ! here we choose a processor every 2, in order not to stress memory BW - ! - color = 0 - IF( me_all < 2*np_ortho1 .AND. MOD( me_all, 2 ) == 0 ) color = 1 - ! - leg_ortho = 2 - ! - ELSE - ! - ! here we choose the first processors - ! - color = 0 - IF( me_all < np_ortho1 ) color = 1 - ! - leg_ortho = 1 - ! - END IF - ! - key = me_all - ! - ! initialize the communicator for the new group - ! - CALL MPI_COMM_SPLIT( comm_all, color, key, ortho_comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " init_ortho_group ", " error splitting communicator ", ierr ) - ! - ! Computes coordinates of the processors, in row maior order - ! - me_ortho1 = mp_rank( ortho_comm ) - np_ortho1 = mp_size( ortho_comm ) - IF( color == 1 .AND. np_ortho1 /= np_ortho(1) * np_ortho(2) ) & - CALL errore( " init_ortho_group ", " wrong number of proc in ortho_comm ", ierr ) - ! - IF( me_all == 0 .AND. me_ortho1 /= 0 ) & - CALL errore( " init_ortho_group ", " wrong root in ortho_comm ", ierr ) - ! - if( color == 1 ) then - ortho_comm_id = 1 - CALL GRID2D_COORDS( 'R', me_ortho1, np_ortho(1), np_ortho(2), me_ortho(1), me_ortho(2) ) - CALL GRID2D_RANK( 'R', np_ortho(1), np_ortho(2), me_ortho(1), me_ortho(2), ierr ) - IF( ierr /= me_ortho1 ) & - CALL errore( " init_ortho_group ", " wrong coordinates in ortho_comm ", ierr ) - IF( me_ortho1*leg_ortho /= me_all ) & - CALL errore( " init_ortho_group ", " wrong rank assignment in ortho_comm ", ierr ) - else - ortho_comm_id = 0 - me_ortho(1) = me_ortho1 - me_ortho(2) = me_ortho1 - endif - - -#if defined __SCALAPACK - - IF( ortho_comm_id > 0 ) THEN - ALLOCATE( blacsmap( np_ortho(1), np_ortho(2) ) ) - blacsmap = 0 - blacsmap( me_ortho(1) + 1, me_ortho(2) + 1 ) = me_blacs - nprow = np_ortho(1) - npcol = np_ortho(2) - ELSE - nprow = np_ortho1 - npcol = 1 - ALLOCATE( blacsmap( np_ortho1, 1 ) ) - blacsmap = 0 - blacsmap( me_ortho1 + 1, 1 ) = me_blacs - END IF - - CALL mp_sum( blacsmap, ortho_comm ) - - !WRITE( 1000 + me_image, * ) '-----' - !WRITE( 1000 + me_image, * ) blacsmap - - ortho_cntx = world_cntx - CALL BLACS_GRIDMAP( ortho_cntx, blacsmap, nprow, nprow, npcol ) - - CALL BLACS_GRIDINFO( ortho_cntx, nprow, npcol, myrow, mycol ) - - !WRITE( 1000 + me_image, * ) nprow, npcol, myrow, mycol - - IF( ortho_comm_id > 0 ) THEN - IF( np_ortho(1) /= nprow ) CALL errore( ' init_ortho_group ', ' problem with SCALAPACK, wrong nprow ', 1 ) - IF( np_ortho(2) /= npcol ) CALL errore( ' init_ortho_group ', ' problem with SCALAPACK, wrong npcol ', 1 ) - IF( me_ortho(1) /= myrow ) CALL errore( ' init_ortho_group ', ' problem with SCALAPACK, wrong myrow ', 1 ) - IF( me_ortho(2) /= mycol ) CALL errore( ' init_ortho_group ', ' problem with SCALAPACK, wrong mycol ', 1 ) - END IF - - DEALLOCATE( blacsmap ) - -#endif - -#else - - ortho_comm_id = 1 - -#endif - - first = .false. - - RETURN -END SUBROUTINE init_ortho_group - ! - ! -END MODULE mp_global diff --git a/quantum_espresso/kcp/Modules/mp_wave.f90 b/quantum_espresso/kcp/Modules/mp_wave.f90 deleted file mode 100644 index 2b2383015..000000000 --- a/quantum_espresso/kcp/Modules/mp_wave.f90 +++ /dev/null @@ -1,780 +0,0 @@ -! -! Copyright (C) 2002-2008 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! - MODULE mp_wave - - IMPLICIT NONE - SAVE - - CONTAINS - - SUBROUTINE mergewf ( pw, pwt, ngwl, ig_l2g, mpime, nproc, root, comm ) - -! ... This subroutine merges the pieces of a wave functions (pw) splitted across -! ... processors into a total wave function (pwt) containing al the components -! ... in a pre-defined order (the same as if only one processor is used) - - USE kinds - USE parallel_include - - IMPLICIT NONE - - COMPLEX(DP), intent(in) :: PW(:) - COMPLEX(DP), intent(out) :: PWT(:) - INTEGER, INTENT(IN) :: mpime ! index of the calling processor ( starting from 0 ) - INTEGER, INTENT(IN) :: nproc ! number of processors - INTEGER, INTENT(IN) :: root ! root processor ( the one that should receive the data ) - INTEGER, INTENT(IN) :: comm ! communicator - INTEGER, INTENT(IN) :: ig_l2g(:) - INTEGER, INTENT(IN) :: ngwl - - INTEGER, ALLOCATABLE :: ig_ip(:) - COMPLEX(DP), ALLOCATABLE :: pw_ip(:) - - INTEGER :: ierr, i, ip, ngw_ip, ngw_lmax, itmp, igwx, gid - -#if defined __MPI - INTEGER :: istatus(MPI_STATUS_SIZE) -#endif - -! -! ... Subroutine Body -! - - igwx = MAXVAL( ig_l2g(1:ngwl) ) - -#if defined __MPI - - gid = comm - -! ... Get local and global wavefunction dimensions - CALL MPI_ALLREDUCE( ngwl, ngw_lmax, 1, MPI_INTEGER, MPI_MAX, gid, IERR ) - CALL MPI_ALLREDUCE( igwx, itmp, 1, MPI_INTEGER, MPI_MAX, gid, IERR ) - igwx = itmp - -#endif - - IF( igwx > SIZE( pwt ) ) & - CALL errore(' mergewf ',' wrong size for pwt ',SIZE(pwt) ) - -#if defined __MPI - - DO ip = 1, nproc - - IF( (ip-1) /= root ) THEN - -! ... In turn each processors send to root the wave components and their indexes in the -! ... global array - IF ( mpime == (ip-1) ) THEN - CALL MPI_SEND( ig_l2g, ngwl, MPI_INTEGER, ROOT, IP, gid, IERR ) - CALL MPI_SEND( pw(1), ngwl, MPI_DOUBLE_COMPLEX, ROOT, IP+NPROC, gid, IERR ) - END IF - IF ( mpime == root) THEN - ALLOCATE(ig_ip(ngw_lmax)) - ALLOCATE(pw_ip(ngw_lmax)) - CALL MPI_RECV( ig_ip, ngw_lmax, MPI_INTEGER, (ip-1), IP, gid, istatus, IERR ) - CALL MPI_RECV( pw_ip, ngw_lmax, MPI_DOUBLE_COMPLEX, (ip-1), IP+NPROC, gid, istatus, IERR ) - CALL MPI_GET_COUNT( istatus, MPI_DOUBLE_COMPLEX, ngw_ip, ierr ) - DO I = 1, ngw_ip - PWT(ig_ip(i)) = pw_ip(i) - END DO - DEALLOCATE(ig_ip) - DEALLOCATE(pw_ip) - END IF - - ELSE - - IF(mpime == root) THEN - DO I = 1, ngwl - PWT(ig_l2g(i)) = pw(i) - END DO - END IF - - END IF - - CALL MPI_BARRIER( gid, IERR ) - - END DO - -#elif ! defined __PARA - - DO I = 1, ngwl - ! WRITE( stdout,*) 'MW ', ig_l2g(i), i - PWT( ig_l2g(i) ) = pw(i) - END DO - -#else - - CALL errore(' MERGEWF ',' no communication protocol ',0) - -#endif - - RETURN - END SUBROUTINE mergewf - -!=----------------------------------------------------------------------------=! - - SUBROUTINE splitwf ( pw, pwt, ngwl, ig_l2g, mpime, nproc, root, comm ) - -! ... This subroutine splits a total wave function (pwt) containing al the components -! ... in a pre-defined order (the same as if only one processor is used), across -! ... processors (pw). - - USE kinds - USE parallel_include - IMPLICIT NONE - - COMPLEX(DP), INTENT(OUT) :: PW(:) - COMPLEX(DP), INTENT(IN) :: PWT(:) - INTEGER, INTENT(IN) :: mpime, nproc, root - INTEGER, INTENT(IN) :: comm ! communicator - INTEGER, INTENT(IN) :: ig_l2g(:) - INTEGER, INTENT(IN) :: ngwl - - INTEGER, ALLOCATABLE :: ig_ip(:) - COMPLEX(DP), ALLOCATABLE :: pw_ip(:) - - INTEGER ierr, i, ngw_ip, ip, ngw_lmax, gid, igwx, itmp - -#if defined __MPI - integer istatus(MPI_STATUS_SIZE) -#endif - -! -! ... Subroutine Body -! - - igwx = MAXVAL( ig_l2g(1:ngwl) ) - -#if defined __MPI - - gid = comm - -! ... Get local and global wavefunction dimensions - CALL MPI_ALLREDUCE(ngwl, ngw_lmax, 1, MPI_INTEGER, MPI_MAX, gid, IERR ) - CALL MPI_ALLREDUCE(igwx, itmp , 1, MPI_INTEGER, MPI_MAX, gid, IERR ) - igwx = itmp - -#endif - - IF( igwx > SIZE( pwt ) ) & - CALL errore(' splitwf ',' wrong size for pwt ',SIZE(pwt) ) - -#if defined __MPI - - DO ip = 1, nproc -! ... In turn each processor send to root the the indexes of its wavefunction conponents -! ... Root receive the indexes and send the componens of the wavefunction read from the disk (pwt) - IF ( (ip-1) /= root ) THEN - IF ( mpime == (ip-1) ) THEN - CALL MPI_SEND( ig_l2g, ngwl, MPI_INTEGER, ROOT, IP, gid,IERR) - CALL MPI_RECV( pw(1), ngwl, MPI_DOUBLE_COMPLEX, ROOT, IP+NPROC, gid, istatus, IERR ) - END IF - IF ( mpime == root ) THEN - ALLOCATE(ig_ip(ngw_lmax)) - ALLOCATE(pw_ip(ngw_lmax)) - CALL MPI_RECV( ig_ip, ngw_lmax, MPI_INTEGER, (ip-1), IP, gid, istatus, IERR ) - CALL MPI_GET_COUNT(istatus, MPI_INTEGER, ngw_ip, ierr) - DO i = 1, ngw_ip - pw_ip(i) = PWT(ig_ip(i)) - END DO - CALL MPI_SEND( pw_ip, ngw_ip, MPI_DOUBLE_COMPLEX, (ip-1), IP+NPROC, gid, IERR ) - DEALLOCATE(ig_ip) - DEALLOCATE(pw_ip) - END IF - ELSE - IF ( mpime == root ) THEN - DO i = 1, ngwl - pw(i) = PWT(ig_l2g(i)) - END DO - END IF - END IF - CALL MPI_BARRIER(gid, IERR) - END DO - -#elif ! defined __PARA - - DO I = 1, ngwl - pw(i) = pwt( ig_l2g(i) ) - END DO - -#else - - CALL errore(' SPLITWF ',' no communication protocol ',0) - -#endif - - RETURN - END SUBROUTINE splitwf - -!=----------------------------------------------------------------------------=! - - SUBROUTINE mergerho(rho, rhot, ngl, ig_l2g, mpime, nproc, root) - -! ... This subroutine merges the pieces of a charge density (rho) splitted across -! ... processors into a total charge (rhot) containing al the components -! ... in a pre-defined order (the same as if only one processor is used) - - USE kinds - USE parallel_include - - IMPLICIT NONE - - REAL(DP), INTENT(IN) :: rho(:) - REAL(DP), INTENT(OUT) :: rhot(:) - INTEGER, INTENT(IN) :: mpime, nproc, root - INTEGER, INTENT(IN) :: ig_l2g(:) - INTEGER, INTENT(IN) :: ngl - - INTEGER, ALLOCATABLE :: ig_ip(:) - REAL(DP), ALLOCATABLE :: rho_ip(:) - - INTEGER :: ierr, i, ip, ng_ip, ng_lmax, ng_g - -#if defined __MPI - INTEGER :: istatus(MPI_STATUS_SIZE) -#endif - -#if defined __MPI - -! ... Get local and global wavefunction dimensions - CALL MPI_ALLREDUCE(ngl, ng_lmax, 1, MPI_INTEGER, MPI_MAX, MPI_COMM_WORLD, ierr) - CALL MPI_ALLREDUCE(ngl, ng_g , 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierr) - IF( ng_g > SIZE( rhot ) ) THEN - CALL errore(' mergerho ',' wrong size for rho ',1 ) - END IF - - DO ip = 1, nproc - - IF( (ip-1) /= root ) THEN - -! ... In turn each processors send to root the rho components and their indexes in the -! ... global array - IF ( mpime == (ip-1) ) THEN - CALL MPI_SEND( ig_l2g, ngl, MPI_INTEGER, root, ip, MPI_COMM_WORLD, ierr) - CALL MPI_SEND( rho(1), ngl, MPI_DOUBLE_PRECISION, root, ip+nproc, MPI_COMM_WORLD,ierr) - END IF - IF ( mpime == root ) THEN - ALLOCATE( ig_ip(ng_lmax) ) - ALLOCATE( rho_ip(ng_lmax) ) - CALL MPI_RECV( ig_ip, ng_lmax, MPI_INTEGER, (ip-1), ip, MPI_COMM_WORLD, istatus, ierr ) - CALL MPI_RECV( rho_ip, ng_lmax, MPI_DOUBLE_PRECISION, (ip-1), ip+nproc, MPI_COMM_WORLD, istatus, ierr ) - CALL MPI_GET_COUNT(istatus, MPI_DOUBLE_PRECISION, ng_ip, ierr) - DO I = 1, ng_ip - rhot(ig_ip(i)) = rho_ip(i) - END DO - DEALLOCATE(ig_ip) - DEALLOCATE(rho_ip) - END IF - - ELSE - - IF(mpime == root) THEN - DO I = 1, ngl - rhot(ig_l2g(i)) = rho(i) - END DO - END IF - - END IF - - CALL MPI_BARRIER(MPI_COMM_WORLD, ierr) - - END DO - -#elif ! defined __PARA - - DO I = 1, ngl - rhot( ig_l2g(i) ) = rho(i) - END DO - -#else - - CALL errore(' mergerho ',' no communication protocol ',0) - -#endif - - RETURN - END SUBROUTINE mergerho - - - SUBROUTINE splitrho(rho, rhot, ngl, ig_l2g, mpime, nproc, root) - -! ... This subroutine splits rho containing al the G-vecs components -! ... in a pre-defined order (the same as if only one processor is used), across -! ... processors (rho). - - USE kinds - USE parallel_include - IMPLICIT NONE - - REAL(DP), INTENT(OUT) :: rho(:) - REAL(DP), INTENT(IN) :: rhot(:) - INTEGER, INTENT(IN) :: mpime, nproc, root - INTEGER, INTENT(IN) :: ig_l2g(:) - INTEGER, INTENT(IN) :: ngl - - INTEGER :: ierr, i, ng_ip, ip, ng_lmax, ng_g - -#if defined __MPI - INTEGER :: istatus(MPI_STATUS_SIZE) -#endif - - INTEGER, ALLOCATABLE :: ig_ip(:) - COMPLEX(DP), ALLOCATABLE :: rho_ip(:) - -#if defined __MPI - -! ... Get local and global rho dimensions - CALL MPI_ALLREDUCE(ngl, ng_lmax, 1, MPI_INTEGER, MPI_MAX, MPI_COMM_WORLD, ierr) - CALL MPI_ALLREDUCE(ngl, ng_g , 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierr) - IF( ng_g > SIZE( rhot ) ) THEN - CALL errore(' splitrho ',' wrong size for rhot ', 1 ) - END IF - - DO ip = 1, nproc -! ... In turn each processor send to root the the indexes of its rho conponents -! ... Root receive the indexes and send the componens of the rho read from the disk (rhot) - IF ( (ip-1) /= root ) THEN - IF ( mpime == (ip-1) ) THEN - CALL MPI_SEND( ig_l2g, ngl, MPI_INTEGER, root, ip, MPI_COMM_WORLD, ierr) - CALL MPI_RECV( rho(1), ngl, MPI_DOUBLE_PRECISION, root, ip+nproc, MPI_COMM_WORLD, istatus, ierr ) - END IF - IF ( mpime == root ) THEN - ALLOCATE(ig_ip(ng_lmax)) - ALLOCATE(rho_ip(ng_lmax)) - CALL MPI_RECV( ig_ip, ng_lmax, MPI_INTEGER, (ip-1), IP, MPI_COMM_WORLD, istatus, ierr ) - CALL MPI_GET_COUNT(istatus, MPI_INTEGER, ng_ip, ierr) - DO i = 1, ng_ip - rho_ip(i) = rhot(ig_ip(i)) - END DO - CALL MPI_SEND( rho_ip, ng_ip, MPI_DOUBLE_PRECISION, (ip-1), ip+nproc, MPI_COMM_WORLD, ierr) - DEALLOCATE(ig_ip) - DEALLOCATE(rho_ip) - END IF - ELSE - IF ( mpime == root ) THEN - DO i = 1, ngl - rho(i) = rhot(ig_l2g(i)) - END DO - END IF - END IF - CALL MPI_BARRIER(MPI_COMM_WORLD, ierr) - END DO - -#elif ! defined __PARA - - DO i = 1, ngl - rho(i) = rhot( ig_l2g(i) ) - END DO - -#else - - CALL errore(' splitrho ',' no communication protocol ',0) - -#endif - - RETURN - END SUBROUTINE splitrho - -!=----------------------------------------------------------------------------=! - - - SUBROUTINE mergeig(igl, igtot, ngl, mpime, nproc, root, comm) - -! ... This subroutine merges the pieces of a vector splitted across -! ... processors into a total vector (igtot) containing al the components -! ... in a pre-defined order (the same as if only one processor is used) - - USE kinds - USE parallel_include - - IMPLICIT NONE - - INTEGER, intent(in) :: igl(:) - INTEGER, intent(out) :: igtot(:) - INTEGER, INTENT(IN) :: mpime ! index of the calling processor ( starting from 0 ) - INTEGER, INTENT(IN) :: nproc ! number of processors - INTEGER, INTENT(IN) :: root ! root processor ( the one that should receive the data ) - INTEGER, INTENT(IN) :: comm ! communicator - INTEGER, INTENT(IN) :: ngl - - INTEGER, ALLOCATABLE :: ig_ip(:) - - INTEGER :: ierr, i, ip, ng_ip, ng_lmax, ng_g, gid, igs - -#if defined __MPI - INTEGER :: istatus(MPI_STATUS_SIZE) -#endif - -#if defined __MPI - - gid = comm - -! ... Get local and global wavefunction dimensions - CALL MPI_ALLREDUCE( ngl, ng_lmax, 1, MPI_INTEGER, MPI_MAX, gid, IERR ) - CALL MPI_ALLREDUCE( ngl, ng_g , 1, MPI_INTEGER, MPI_SUM, gid, IERR ) - IF( ng_g > SIZE( igtot ) ) THEN - CALL errore(' mergeig ',' wrong size for igtot ',SIZE(igtot) ) - END IF - - igs = 1 - - DO ip = 1, nproc - - IF( (ip-1) /= root ) THEN - -! ... In turn each processors send to root the wave components and their indexes in the -! ... global array - IF ( mpime == (ip-1) ) THEN - CALL MPI_SEND( igl(1), ngl, MPI_INTEGER, ROOT, IP, gid, IERR ) - END IF - IF ( mpime == root) THEN - ALLOCATE( ig_ip(ng_lmax) ) - CALL MPI_RECV( ig_ip, ng_lmax, MPI_INTEGER, (ip-1), IP, gid, istatus, IERR ) - CALL MPI_GET_COUNT( istatus, MPI_INTEGER, ng_ip, ierr ) - DO i = 1, ng_ip - igtot( igs + i - 1 ) = ig_ip( i ) - END DO - DEALLOCATE(ig_ip) - END IF - - ELSE - - IF(mpime == root) THEN - ng_ip = ngl - DO i = 1, ngl - igtot( igs + i - 1 ) = igl( i ) - END DO - END IF - - END IF - - IF(mpime == root) THEN - igs = igs + ng_ip - END IF - - CALL MPI_BARRIER( gid, IERR ) - - END DO - -#elif ! defined __PARA - - igtot( 1:ngl ) = igl( 1:ngl ) - -#else - - CALL errore(' mergeig ',' no communication protocol ',0) - -#endif - - RETURN - END SUBROUTINE mergeig - -!=----------------------------------------------------------------------------=! - - SUBROUTINE splitig(igl, igtot, ngl, mpime, nproc, root, comm) - -! ... This subroutine splits a replicated vector (igtot) stored on the root proc -! ... across processors (igl). - - USE kinds - USE parallel_include - IMPLICIT NONE - - INTEGER, INTENT(OUT) :: igl(:) - INTEGER, INTENT(IN) :: igtot(:) - INTEGER, INTENT(IN) :: mpime, nproc, root - INTEGER, INTENT(IN) :: comm ! communicator - INTEGER, INTENT(IN) :: ngl - - INTEGER ierr, i, ng_ip, ip, ng_lmax, ng_g, gid, igs - -#if defined __MPI - integer istatus(MPI_STATUS_SIZE) -#endif - - INTEGER, ALLOCATABLE :: ig_ip(:) - -#if defined __MPI - - gid = comm - -! ... Get local and global wavefunction dimensions - CALL MPI_ALLREDUCE(ngl, ng_lmax, 1, MPI_INTEGER, MPI_MAX, gid, IERR ) - CALL MPI_ALLREDUCE(ngl, ng_g , 1, MPI_INTEGER, MPI_SUM, gid, IERR ) - IF( ng_g > SIZE( igtot ) ) THEN - CALL errore(' splitig ',' wrong size for igtot ', SIZE(igtot) ) - END IF - - igs = 1 - - DO ip = 1, nproc - -! ... In turn each processor sends to root the indices of its wavefunction components -! ... Root receives the indices and sends the components of the wavefunction read from the disk (pwt) - - IF ( (ip-1) /= root ) THEN - - IF ( mpime == (ip-1) ) THEN - CALL MPI_SEND( ngl, 1 , MPI_INTEGER, ROOT, IP, gid,IERR) - CALL MPI_RECV( igl, ngl, MPI_INTEGER, ROOT, IP+NPROC, gid, istatus, IERR ) - END IF - - IF ( mpime == root ) THEN - ALLOCATE(ig_ip(ng_lmax)) - CALL MPI_RECV( ng_ip, 1, MPI_INTEGER, (ip-1), IP, gid, istatus, IERR ) - DO i = 1, ng_ip - ig_ip(i) = igtot( igs + i - 1) - END DO - CALL MPI_SEND( ig_ip, ng_ip, MPI_INTEGER, (ip-1), IP+NPROC, gid, IERR ) - DEALLOCATE(ig_ip) - END IF - - ELSE - - IF ( mpime == root ) THEN - ng_ip = ngl - DO i = 1, ng_ip - igl(i) = igtot( igs + i - 1) - END DO - END IF - - END IF - - IF( mpime == root ) igs = igs + ng_ip - - CALL MPI_BARRIER(gid, IERR) - - END DO - -#elif ! defined __PARA - - igl( 1:ngl ) = igtot( 1:ngl ) - -#else - - CALL errore(' splitig ',' no communication protocol ',0) - -#endif - - RETURN - END SUBROUTINE splitig - -!=----------------------------------------------------------------------------=! - - SUBROUTINE pwscatter( c, ctmp, ngw, indi_l, sour_indi, dest_indi, & - n_indi_rcv, n_indi_snd, icntix, mpime, nproc, group ) - - USE kinds - USE parallel_include - - implicit none - - integer :: indi_l(:) ! list of G-vec index to be exchanged - integer :: sour_indi(:) ! the list of source processors - integer :: dest_indi(:) ! the list of destination processors - integer :: n_indi_rcv ! number of G-vectors to be received - integer :: n_indi_snd ! number of G-vectors to be sent - integer :: icntix ! total number of G-vec to be exchanged - INTEGER, INTENT(IN) :: nproc, mpime, group - - COMPLEX(DP) :: c(:) - COMPLEX(DP) :: ctmp(:) - integer :: ngw - - integer :: ig, icsize - INTEGER :: me, idest, isour, ierr - - COMPLEX(DP), ALLOCATABLE :: my_buffer( : ) - COMPLEX(DP), ALLOCATABLE :: mp_snd_buffer( : ) - COMPLEX(DP), ALLOCATABLE :: mp_rcv_buffer( : ) - INTEGER, ALLOCATABLE :: ibuf(:) - - ! - ! ... SUBROUTINE BODY - ! - - me = mpime + 1 - - if( icntix .lt. 1 ) then - icsize = 1 - else - icsize = icntix - endif - - ALLOCATE( mp_snd_buffer( icsize * nproc ) ) - ALLOCATE( mp_rcv_buffer( icsize * nproc ) ) - ALLOCATE( my_buffer( ngw ) ) - ALLOCATE( ibuf( nproc ) ) - ctmp = CMPLX( 0.0_DP, 0.0_DP ) - - ! WRITE( stdout,*) 'D: ', nproc, mpime, group - - ibuf = 0 - DO IG = 1, n_indi_snd - idest = dest_indi(ig) - ibuf(idest) = ibuf(idest) + 1; - if(idest .ne. me) then - mp_snd_buffer( ibuf(idest) + (idest-1)*icsize ) = C( indi_l( ig ) ) - else - my_buffer(ibuf(idest)) = C(indi_l(ig)) - end if - end do - -#if defined __MPI - call MPI_ALLTOALL( mp_snd_buffer(1), icsize, MPI_DOUBLE_COMPLEX, & - mp_rcv_buffer(1), icsize, MPI_DOUBLE_COMPLEX, & - group, ierr) -#else - - CALL errore(' pwscatter ',' no communication protocol ',0) - -#endif - - ibuf = 0 - DO IG = 1, n_indi_rcv - isour = sour_indi(ig) - if(isour.gt.0 .and. isour.ne.me) then - ibuf(isour) = ibuf(isour) + 1 - CTMP(ig) = mp_rcv_buffer(ibuf(isour) + (isour-1)*icsize) - else if(isour.gt.0) then - ibuf(isour) = ibuf(isour) + 1 - CTMP(ig) = my_buffer(ibuf(isour)) - else - CTMP(ig) = (0.0_DP,0.0_DP) - end if - end do - - DEALLOCATE( mp_snd_buffer ) - DEALLOCATE( mp_rcv_buffer ) - DEALLOCATE( my_buffer ) - DEALLOCATE( ibuf ) - - RETURN - END SUBROUTINE pwscatter - - - - -!=----------------------------------------------------------------------------=! - -SUBROUTINE redistwf( c_dist_pw, c_dist_st, npw_p, nst_p, comm, idir ) - ! - ! Redistribute wave function. - ! c_dist_pw are the wave functions with plane waves distributed over processors - ! c_dist_st are the wave functions with electronic states distributed over processors - ! - USE kinds - USE parallel_include - - implicit none - - COMPLEX(DP) :: c_dist_pw(:,:) - COMPLEX(DP) :: c_dist_st(:,:) - INTEGER, INTENT(IN) :: npw_p(:) ! the number of plane wave on each processor - INTEGER, INTENT(IN) :: nst_p(:) ! the number of states on each processor - INTEGER, INTENT(IN) :: comm ! group communicator - INTEGER, INTENT(IN) :: idir ! direction of the redistribution - ! idir > 0 c_dist_pw --> c_dist_st - ! idir < 0 c_dist_pw <-- c_dist_st - - INTEGER :: mpime, nproc, ierr, npw_t, nst_t, proc, i, j, ngpww - INTEGER, ALLOCATABLE :: rdispls(:), recvcount(:) - INTEGER, ALLOCATABLE :: sendcount(:), sdispls(:) - COMPLEX(DP), ALLOCATABLE :: ctmp( : ) - -#ifdef __MPI - CALL mpi_comm_rank( comm, mpime, ierr ) - IF( ierr /= 0 ) CALL errore( ' wf_redist ', ' mpi_comm_rank ', ierr ) - CALL mpi_comm_size( comm, nproc, ierr ) - IF( ierr /= 0 ) CALL errore( ' wf_redist ', ' mpi_comm_size ', ierr ) - - ALLOCATE( rdispls( nproc ), recvcount( nproc ), sendcount( nproc ), sdispls( nproc ) ) - - npw_t = 0 - nst_t = 0 - DO proc=1,nproc - sendcount(proc) = npw_p(mpime+1) * nst_p(proc) - recvcount(proc) = npw_p(proc) * nst_p(mpime+1) - npw_t = npw_t + npw_p(proc) - nst_t = nst_t + nst_p(proc) - END DO - sdispls(1)=0 - rdispls(1)=0 - DO proc=2,nproc - sdispls(proc) = sdispls(proc-1) + sendcount(proc-1) - rdispls(proc) = rdispls(proc-1) + recvcount(proc-1) - END DO - - ALLOCATE( ctmp( npw_t * nst_p( mpime + 1 ) ) ) - - IF( idir > 0 ) THEN - ! - ! ... Step 1. Communicate to all Procs so that each proc has all - ! ... G-vectors and some states instead of all states and some - ! ... G-vectors. This information is stored in the 1-d array ctmp. - ! - CALL MPI_BARRIER( comm, ierr ) - IF( ierr /= 0 ) CALL errore( ' wf_redist ', ' mpi_barrier ', ierr ) - ! - CALL MPI_ALLTOALLV( c_dist_pw, sendcount, sdispls, MPI_DOUBLE_COMPLEX, & - & ctmp, recvcount, rdispls, MPI_DOUBLE_COMPLEX, comm, ierr) - IF( ierr /= 0 ) CALL errore( ' wf_redist ', ' mpi_alltoallv ', ierr ) - ! - ! Step 2. Convert the 1-d array ctmp into a 2-d array consistent with the - ! original notation c(ngw,nbsp). Psitot contains ntot = SUM_Procs(ngw) G-vecs - ! and nstat states instead of all nbsp states - ! - ngpww = 0 - DO proc = 1, nproc - DO i = 1, nst_p(mpime+1) - DO j = 1, npw_p(proc) - c_dist_st( j + ngpww, i ) = ctmp( rdispls(proc) + j + (i-1) * npw_p(proc) ) - END DO - END DO - ngpww = ngpww + npw_p(proc) - END DO - - ELSE - ! - ! Step 4. Convert the 2-d array c_dist_st into 1-d array - ! - ngpww = 0 - DO proc = 1, nproc - DO i = 1, nst_p(mpime+1) - DO j = 1, npw_p(proc) - ctmp( rdispls(proc) + j + (i-1) * npw_p(proc) ) = c_dist_st( j + ngpww, i ) - END DO - END DO - ngpww = ngpww + npw_p(proc) - END DO - ! - ! Step 5. Redistribute among processors. The result is stored in 2-d - ! array c_dist_pw consistent with the notation c(ngw,nbsp) - ! - CALL MPI_BARRIER( comm, ierr ) - IF( ierr /= 0 ) CALL errore( ' wf_redist ', ' mpi_barrier ', ierr ) - - CALL MPI_ALLTOALLV( ctmp, recvcount, rdispls, MPI_DOUBLE_COMPLEX, & - & c_dist_pw, sendcount , sdispls, MPI_DOUBLE_COMPLEX, comm, ierr ) - IF( ierr /= 0 ) CALL errore( ' wf_redist ', ' mpi_alltoallv ', ierr ) - - - END IF - - DEALLOCATE( ctmp ) - DEALLOCATE( rdispls, recvcount, sendcount, sdispls ) -#endif - RETURN -END SUBROUTINE redistwf - - -!=----------------------------------------------------------------------------=! - - END MODULE mp_wave diff --git a/quantum_espresso/kcp/Modules/parallel_include.f90 b/quantum_espresso/kcp/Modules/parallel_include.f90 deleted file mode 100644 index 7ce4473fb..000000000 --- a/quantum_espresso/kcp/Modules/parallel_include.f90 +++ /dev/null @@ -1,26 +0,0 @@ -! -! Copyright (C) 2003-2004 Carlo Cavazzoni -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!------------------------------------------------------------------------------! -! SISSA Code Interface -- Carlo Cavazzoni -!------------------------------------------------------------------------------C - MODULE parallel_include - - USE kinds - LOGICAL tparallel - -#if defined __MPI || defined __SHMEM -! -! Include file for MPI -! - INCLUDE 'mpif.h' - DATA tparallel /.true./ -#else - DATA tparallel /.false./ -#endif - - END MODULE parallel_include diff --git a/quantum_espresso/kcp/Modules/parallel_types.f90 b/quantum_espresso/kcp/Modules/parallel_types.f90 deleted file mode 100644 index aca209eb0..000000000 --- a/quantum_espresso/kcp/Modules/parallel_types.f90 +++ /dev/null @@ -1,106 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - - MODULE parallel_types - USE kinds - IMPLICIT NONE - PRIVATE - SAVE - - - TYPE processors_grid - INTEGER :: context ! Communication handle, grid identification - INTEGER :: nproc ! number of processors in the grid - INTEGER :: my_pe ! process index (0 ... nproc -1) - INTEGER :: npx ! Grid dimensions : - INTEGER :: npy ! (nprows, npcolumns, npplanes) - INTEGER :: npz ! - INTEGER :: mex ! Processor coordinates: - INTEGER :: mey ! (mex, mey, mez) - INTEGER :: mez ! 0 <= mex < npx-1 - ! 0 <= mey < npy-1 - ! 0 <= mez < npz-1 - END TYPE - - ! ... Valid values for data distribution - ! - INTEGER, PARAMETER :: BLOCK_CYCLIC_DIST = 1 - INTEGER, PARAMETER :: BLOCK_PARTITION_DIST = 2 - INTEGER, PARAMETER :: FREE_PATTERN_DIST = 3 - INTEGER, PARAMETER :: REPLICATED_DATA_DIST = 4 - INTEGER, PARAMETER :: CYCLIC_DIST = 5 - -! ---------------------------------------------- -! BEGIN manual -! -! Given the Array |a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11| -! and three processors P0, P1, P2 -! -! in the BLOCK_PARTITION_DIST scheme, the Array is partitioned -! as follow -! P0 P1 P2 -! |a1 a2 a3 a4| |a5 a6 a7 a8| |a9 a10 a11| -! -! in the BLOCK_CYCLIC_DIST scheme the Array is first partitioned -! into blocks (i.e. of size 2) |a1 a2|a3 a4|a5 a6|a7 a8|a9 a10|a11| -! Then the block are distributed cyclically among P0, P1 and P2 -! P0 P1 P2 -! |a1 a2|a7 a8| |a3 a4|a9 a10| |a5 a6|a11| -! -! in the CYCLIC_DIST scheme the Array elements are distributed round robin -! among P0, P1 and P2 -! P0 P1 P2 -! |a1 a4 a7 a10| |a2 a5 a8 a11| |a3 a6 a9| -! -! ---------------------------------------------- -! END manual - - - - TYPE descriptor - INTEGER :: matrix_type ! = 1, for dense matrices - TYPE (processors_grid) :: grid ! Communication handle - INTEGER :: nx ! rows, number of rows in the global array - INTEGER :: ny ! columns, number of columns in the global array - INTEGER :: nz ! planes, number of planes in the global array - INTEGER :: nxblk ! row_block, if DIST = BLOCK_CICLYC_DIST, - ! this value represent the blocking factor - ! used to distribute the rows of the array, - ! otherwise this is the size of local block of rows - INTEGER :: nyblk ! column_block, same as row_block but for columns - INTEGER :: nzblk ! plane_block, same as row_block but for planes - INTEGER :: nxl ! local_rows, number of rows in the local array - INTEGER :: nyl ! local_columns, number of columns in the local array - INTEGER :: nzl ! local_planes, number of planes in the local array - INTEGER :: ixl ! irow - INTEGER :: iyl ! icolumn - INTEGER :: izl ! iplane - INTEGER :: ipexs ! row_src_pe, process row over which the first row - ! of the array is distributed - INTEGER :: ipeys ! column_src_pe, process column over which the first column - ! of the array is distributed - INTEGER :: ipezs ! plane_src_pe, process plane over which the first plane - ! of the array is distributed - INTEGER :: ldx ! local_ld, leading dimension of the local sub-block of the array - INTEGER :: ldy ! local_sub_ld, sub-leading dimension of the local sub-block - ! of the array - INTEGER :: ldz ! - - INTEGER :: xdist ! row_dist - INTEGER :: ydist ! column_dist - INTEGER :: zdist ! plane_dist - END TYPE - - - PUBLIC :: processors_grid - - PUBLIC :: BLOCK_CYCLIC_DIST, BLOCK_PARTITION_DIST, & - FREE_PATTERN_DIST, REPLICATED_DATA_DIST, CYCLIC_DIST - - - END MODULE parallel_types diff --git a/quantum_espresso/kcp/Modules/parameters.f90 b/quantum_espresso/kcp/Modules/parameters.f90 deleted file mode 100644 index 83ca15e50..000000000 --- a/quantum_espresso/kcp/Modules/parameters.f90 +++ /dev/null @@ -1,22 +0,0 @@ -! -! Copyright (C) 2001-2009 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -MODULE parameters - - IMPLICIT NONE - SAVE - - INTEGER, PARAMETER :: & - ntypx = 10, &! max number of different types of atom - npsx = ntypx, &! max number of different PPs (obsolete) - nsx = ntypx, &! max number of atomic species (CP) - npk = 40000, &! max number of k-points - lmaxx = 3, &! max non local angular momentum (l=0 to lmaxx) - lqmax= 2*lmaxx+1 ! max number of angular momenta of Q - -END MODULE parameters diff --git a/quantum_espresso/kcp/Modules/parser.f90 b/quantum_espresso/kcp/Modules/parser.f90 deleted file mode 100644 index 341be9d8b..000000000 --- a/quantum_espresso/kcp/Modules/parser.f90 +++ /dev/null @@ -1,411 +0,0 @@ -! -! Copyright (C) 2001-2004 Carlo Cavazzoni and PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -! ... SUBROUTINE field_count: accepts two string (one of them is optional) -! and one integer and count the number of fields -! in the string separated by a blank or a tab -! character. If the optional string is specified -! (it has anyway len=1) it is assumed as the -! separator character. -! Ignores any character following the exclamation -! mark (fortran comment) -! -! ... SUBROUTINE con_cam: counts the number of fields in a string -! separated by the optional character -! -! ... SUBROUTINE field_compare: accepts two strings and one integer. Counts the -! fields contained in the first string and -! compares it with the integer. -! If they are less than the integer calls the -! routine error and show by the second string the -! name of the field where read-error occurred. -! -! ... SUBROUTINE version_parse: Determine the major, minor and patch numbers from -! a version string with the fmt "i.j.k" -! -! ... FUNCTION version_compare: Compare two version strings; the result can be -! "newer", "equal", "older", "" -! -#include "f_defs.h" -! -!---------------------------------------------------------------------------- -MODULE parser - !---------------------------------------------------------------------------- - ! - USE io_global, ONLY : stdout - USE kinds - ! - PRIVATE - ! - PUBLIC :: parse_unit, field_count, read_line, get_field - PUBLIC :: version_parse, version_compare - ! - INTEGER :: parse_unit = 5 ! normally 5, but can be set otherwise - ! - CONTAINS - ! - ! - !-------------------------------------------------------------------------- - PURE SUBROUTINE field_count( num, line, car ) - !-------------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - INTEGER, INTENT(OUT) :: num - CHARACTER(LEN=*), INTENT(IN) :: line - CHARACTER(LEN=1), OPTIONAL, INTENT(IN) :: car -#if defined (__XLF) - ! ... with the IBM xlf compiler some combination of flags lead to - ! ... variables being defined as static, hence giving a conflict - ! ... with PURE function. We then force the variable to be AUTOMATIC - CHARACTER(LEN=1), AUTOMATIC :: sep1, sep2 - INTEGER, AUTOMATIC :: j -#else - CHARACTER(LEN=1) :: sep1, sep2 - INTEGER :: j -#endif - ! - ! - num = 0 - ! - IF ( .NOT. present(car) ) THEN - ! - sep1 = char(32) ! ... blank character - sep2 = char(9) ! ... tab character - ! - DO j = 2, MAX( LEN( line ), 256 ) - ! - IF ( line(j:j) == '!' .OR. line(j:j) == char(0) ) THEN - ! - IF ( line(j-1:j-1) /= sep1 .AND. line(j-1:j-1) /= sep2 ) THEN - ! - num = num + 1 - ! - END IF - ! - EXIT - ! - END IF - ! - IF ( ( line(j:j) == sep1 .OR. line(j:j) == sep2 ) .AND. & - ( line(j-1:j-1) /= sep1 .AND. line(j-1:j-1) /= sep2 ) ) THEN - ! - num = num + 1 - ! - END IF - ! - END DO - ! - ELSE - ! - sep1 = car - ! - DO j = 2, MAX( LEN( line ), 256 ) - ! - IF ( line(j:j) == '!' .OR. & - line(j:j) == char(0) .OR. line(j:j) == char(32) ) THEN - ! - IF ( line(j-1:j-1) /= sep1 ) num = num + 1 - ! - EXIT - ! - END IF - ! - IF ( line(j:j) == sep1 .AND. line(j-1:j-1) /= sep1 ) num = num + 1 - ! - END DO - ! - END IF - ! - RETURN - ! - END SUBROUTINE field_count - ! - ! - !-------------------------------------------------------------------------- - SUBROUTINE read_line( line, nfield, field, end_of_file ) - !-------------------------------------------------------------------------- - ! - USE mp, ONLY : mp_bcast - USE mp_global, ONLY : world_comm - USE io_global, ONLY : ionode, ionode_id - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(OUT) :: line - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: field - INTEGER, OPTIONAL, INTENT(IN) :: nfield - LOGICAL, OPTIONAL, INTENT(OUT) :: end_of_file - LOGICAL :: tend - ! - ! - IF( LEN( line ) < 256 ) THEN - CALL errore(' read_line ', ' input line too short ', MAX(LEN(line),1) ) - END IF - ! - IF ( ionode ) THEN -30 READ (parse_unit, fmt='(A256)', ERR=10, END=10) line - IF( line == ' ' .OR. line(1:1) == '#' ) GO TO 30 - tend = .FALSE. - GO TO 20 -10 tend = .TRUE. -20 CONTINUE - END IF - ! - CALL mp_bcast( tend, ionode_id, world_comm ) - CALL mp_bcast( line, ionode_id, world_comm ) - ! - IF( PRESENT(end_of_file) ) THEN - end_of_file = tend - ELSE IF( tend ) THEN - CALL infomsg(' read_line ', ' end of file ' ) - ELSE - IF( PRESENT(field) ) CALL field_compare( line, nfield, field ) - END IF - ! - RETURN - ! - END SUBROUTINE read_line - ! - ! - !-------------------------------------------------------------------------- - SUBROUTINE field_compare( str, nf, var ) - !-------------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(IN) :: var - INTEGER, INTENT(IN) :: nf - CHARACTER(LEN=*), INTENT(IN) :: str - INTEGER :: nc - ! - CALL field_count( nc, str ) - ! - IF( nc < nf ) & - CALL errore( ' field_compare ', & - & ' wrong number of fields: ' // TRIM( var ), 1 ) - ! - RETURN - ! - END SUBROUTINE field_compare - ! - ! - !-------------------------------------------------------------------------- - SUBROUTINE con_cam(num, line, car) - !-------------------------------------------------------------------------- - CHARACTER(LEN=*) :: line - CHARACTER(LEN=1) :: sep - CHARACTER(LEN=1), OPTIONAL :: car - INTEGER :: num, j - - num = 0 - IF (len(line) .GT. 256 ) THEN - WRITE( stdout,*) 'riga ', line - WRITE( stdout,*) 'lunga ', len(line) - num = -1 - RETURN - END IF - - WRITE( stdout,*) '1riga ', line - WRITE( stdout,*) '1lunga ', len(line) - IF ( .NOT. present(car) ) THEN - sep=char(32) !char(32) is the blank character - ELSE - sep=car - END IF - - DO j=2, MAX(len(line),256) - IF ( line(j:j) == '!' .OR. line(j:j) == char(0)) THEN - RETURN - END IF - IF ( (line(j:j) .EQ. sep) .AND. & - (line(j-1:j-1) .NE. sep) ) THEN - num = num + 1 - END IF - END DO - RETURN - END SUBROUTINE con_cam - ! - !-------------------------------------------------------------------------- - SUBROUTINE version_parse(str, major, minor, patch, ierr) - !-------------------------------------------------------------------------- - ! - ! Determine the major, minor and patch numbers from - ! a version string with the fmt "i.j.k" - ! - ! The ierr variable assumes the following values - ! - ! ierr < 0 emtpy string - ! ierr = 0 no problem - ! ierr > 0 fatal error - ! - IMPLICIT NONE - CHARACTER(*), INTENT(in) :: str - INTEGER, INTENT(out) :: major, minor, patch, ierr - ! - INTEGER :: i1, i2, length - INTEGER :: ierrtot - CHARACTER(10) :: num(3) - - ! - major = 0 - minor = 0 - patch = 0 - - length = LEN_TRIM( str ) - ! - IF ( length == 0 ) THEN - ! - ierr = -1 - RETURN - ! - ENDIF - - i1 = SCAN( str, ".") - i2 = SCAN( str, ".", BACK=.TRUE.) - ! - IF ( i1 == 0 .OR. i2 == 0 .OR. i1 == i2 ) THEN - ! - ierr = 1 - RETURN - ! - ENDIF - ! - num(1) = str( 1 : i1-1 ) - num(2) = str( i1+1 : i2-1 ) - num(3) = str( i2+1 : ) - ! - ierrtot = 0 - ! - READ( num(1), *, IOSTAT=ierr ) major - IF (ierr/=0) RETURN - ! - READ( num(2), *, IOSTAT=ierr ) minor - IF (ierr/=0) RETURN - ! - READ( num(3), *, IOSTAT=ierr ) patch - IF (ierr/=0) RETURN - ! - END SUBROUTINE version_parse - ! - !-------------------------------------------------------------------------- - FUNCTION version_compare(str1, str2) - !-------------------------------------------------------------------------- - ! - ! Compare two version strings; the result is - ! - ! "newer": str1 is newer that str2 - ! "equal": str1 is equal to str2 - ! "older": str1 is older than str2 - ! " ": str1 or str2 has a wrong format - ! - IMPLICIT NONE - CHARACTER(*) :: str1, str2 - CHARACTER(10) :: version_compare - ! - INTEGER :: version1(3), version2(3) - INTEGER :: basis, icheck1, icheck2 - INTEGER :: ierr - ! - - version_compare = " " - ! - CALL version_parse( str1, version1(1), version1(2), version1(3), ierr) - IF ( ierr/=0 ) RETURN - ! - CALL version_parse( str2, version2(1), version2(2), version2(3), ierr) - IF ( ierr/=0 ) RETURN - ! - ! - basis = 1000 - ! - icheck1 = version1(1) * basis**2 + version1(2)* basis + version1(3) - icheck2 = version2(1) * basis**2 + version2(2)* basis + version2(3) - ! - IF ( icheck1 > icheck2 ) THEN - ! - version_compare = 'newer' - ! - ELSEIF( icheck1 == icheck2 ) THEN - ! - version_compare = 'equal' - ! - ELSE - ! - version_compare = 'older' - ! - ENDIF - ! - END FUNCTION version_compare - ! - !-------------------------------------------------------------------------- - SUBROUTINE get_field(n, field, str, sep) - !-------------------------------------------------------------------------- - ! Extract whitespace-separated nth block from string - IMPLICIT NONE - INTEGER,INTENT(IN) :: n - CHARACTER(len=*),INTENT(OUT) :: field - CHARACTER(len=*),INTENT(IN) :: str - CHARACTER(len=1),OPTIONAL,INTENT(IN) :: sep - INTEGER :: i,j,z ! block start and end - INTEGER :: k ! block counter - CHARACTER(len=1) :: sep1, sep2 - !print*, "------------- parser start -------------" - !print '(3a)', "string: -->", str,"<--" - IF(present(sep)) THEN - sep1 = sep - sep2 = sep ! redundant, but easy - ELSE - sep1 = char(32) ! ... blank character - sep2 = char(9) ! ... tab char - ENDIF - ! - k = 1 ! counter for the required block - ! - DO i = 1,len(str) - ! look for the beginning of the required block - z = MAX(i-1,1) - !print '(2a1,3i4,2l)', str(i:i), str(z:z), i,z,k,n,& - ! (str(i:i) == sep1 .or. str(i:i) == sep2), (str(z:z) /= sep1 .and. str(z:z) /= sep2) - IF( k == n) EXIT - IF( (str(i:i) == sep1 .or. str(i:i) == sep2) & - .and. & - (str(z:z) /= sep1 .and. str(z:z) /= sep2) & - ) & - k = k+1 - ENDDO - ! - !print*, "i found: ",i - DO j = i,len(str) - ! look for the beginning of the next block - z = MAX(j-1,1) - IF( (str(j:j) == sep1 .or. str(j:j) == sep2) & - .and. & - (str(z:z) /= sep1 .and. str(z:z) /= sep2) & - ) & - k = k+1 - IF( k >n) EXIT - ENDDO - !print*, "j found: ",j - ! - IF (j <= len(str)) THEN - ! if we are here, the reqired block was followed by a separator - ! and another field, we have to trash one char (a separator) - field = TRIM(adjustl(str(i:j-1))) - !print*, "taking: ",i,j-2 - ELSE - ! if we are here, it was the last block in str, we have to take - ! all the remaining chars - field = TRIM(adjustl(str(i:len(str)))) - !print*, "taking from ",i - ENDIF - !print*, "------------- parser end -------------" - - END SUBROUTINE get_field - -END MODULE parser diff --git a/quantum_espresso/kcp/Modules/path_base.f90 b/quantum_espresso/kcp/Modules/path_base.f90 deleted file mode 100644 index b18600f7e..000000000 --- a/quantum_espresso/kcp/Modules/path_base.f90 +++ /dev/null @@ -1,1194 +0,0 @@ -! -! Copyright (C) 2003-2007 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!--------------------------------------------------------------------------- -MODULE path_base - !--------------------------------------------------------------------------- - ! - ! ... This module contains most of the subroutines and functions needed by - ! ... the implementation of "NEB" and "SMD" methods into Quantum-ESPRESSO - ! - ! ... Other relevant files are: - ! - ! ... Modules/path_variables.f90 - ! ... Modules/path_io_routines.f90 - ! ... Modules/path_opt_routines.f90 - ! ... Modules/path_reparametrisation.f90 - ! ... Modules/path_formats.f90 - ! ... PW/compute_scf.f90 - ! ... PW/compute_fes_grads.f90 - ! ... CPV/compute_scf.f90 - ! ... CPV/compute_fes_grads.f90 - ! - ! ... The code is based on the NEB algorithm described in : - ! - ! ... 1) G. Henkelman, B.P. Uberuaga, and H. Jonsson; - ! ... J.Chem.Phys., 113, 9901, (2000) - ! ... 2) G. Henkelman, and H. Jonsson; J.Chem.Phys., 113, 9978, (2000) - ! - ! ... More details about the implementation can be found at - ! - ! ... http://www.sissa.it/cm/thesis/2005/sbraccia.pdf - ! - ! ... Code written and maintained by Carlo Sbraccia ( 2003-2007 ) - ! - USE kinds, ONLY : DP - USE constants, ONLY : eps32, pi, autoev, bohr_radius_angs, eV_to_kelvin - USE io_files, ONLY : iunpath - USE io_global, ONLY : meta_ionode, meta_ionode_id - USE mp, ONLY : mp_bcast - ! - USE basic_algebra_routines - ! - PRIVATE - ! - PUBLIC :: initialize_path - PUBLIC :: search_mep - ! - CONTAINS - ! - ! ... module procedures - ! - !----------------------------------------------------------------------- - SUBROUTINE initialize_path() - !----------------------------------------------------------------------- - ! - USE input_parameters, ONLY : pos_ => pos, & - climbing_ => climbing, & - restart_mode, nstep, input_images - USE control_flags, ONLY : conv_elec, lcoarsegrained - USE ions_base, ONLY : nat, amass, ityp, if_pos - USE metadyn_vars, ONLY : ncolvar - USE io_files, ONLY : prefix, tmp_dir, path_file, dat_file, & - int_file, xyz_file, axsf_file, broy_file - USE path_variables, ONLY : climbing, pos, istep_path, nstep_path, & - dim1, num_of_images, pes, grad_pes, mass, & - use_masses, tangent, error, path_length, & - deg_of_freedom, frozen, use_freezing, k, & - k_min, tune_load_balance, grad, posold, & - elastic_grad, pending_image, first_last_opt - USE mp_global, ONLY : nimage - USE path_io_routines, ONLY : read_restart - USE path_variables, ONLY : path_allocation - ! - IMPLICIT NONE - ! - INTEGER :: i, fii, lii - LOGICAL :: file_exists - ! - ! ... output files are set - ! - path_file = TRIM( prefix ) // ".path" - dat_file = TRIM( prefix ) // ".dat" - int_file = TRIM( prefix ) // ".int" - xyz_file = TRIM( prefix ) // ".xyz" - axsf_file = TRIM( prefix ) // ".axsf" - ! - broy_file = TRIM( tmp_dir ) // TRIM( prefix ) // ".broyden" - ! - ! ... istep is initialised to zero - ! - istep_path = 0 - pending_image = 0 - conv_elec = .TRUE. - ! - ! ... the dimension of all "path" arrays (dim1) is set here - ! ... ( it corresponds to the dimension of the configurational space ) - ! - IF ( lcoarsegrained ) THEN - ! - dim1 = ncolvar - ! - use_masses = .FALSE. - use_freezing = .FALSE. - ! - ELSE - ! - dim1 = 3*nat - ! - END IF - ! - IF ( nimage > 1 ) THEN - ! - ! ... the automatic tuning of the load balance in - ! ... image-parallelisation is switched off by default - ! - tune_load_balance = .FALSE. - ! - ! ... in the case of image-parallelisation the number of images - ! ... to be optimised must be larger than nimage - ! - IF ( first_last_opt ) THEN - ! - fii = 1 - lii = num_of_images - ! - ELSE - ! - fii = 2 - lii = num_of_images - 1 - ! - END IF - ! - IF ( nimage > ( lii - fii + 1 ) ) & - CALL errore( 'initialize_path', 'nimage is ' // & - & 'larger than the available number of images', 1 ) - ! - END IF - ! - ! ... dynamical allocation of arrays - ! - CALL path_allocation() - ! - IF ( use_masses ) THEN - ! - ! ... mass weighted coordinates are used - ! - DO i = 1, nat - ! - mass(3*i-2) = amass(ityp(i)) - mass(3*i-1) = amass(ityp(i)) - mass(3*i-0) = amass(ityp(i)) - ! - END DO - ! - ELSE - ! - mass = 1.0_DP - ! - END IF - ! - ! ... initialization of the allocatable arrays - ! - pos(:,1:input_images) = pos_(1:dim1,1:input_images) - ! - pes = 0.0_DP - grad_pes = 0.0_DP - elastic_grad = 0.0_DP - tangent = 0.0_DP - grad = 0.0_DP - error = 0.0_DP - frozen = .FALSE. - ! - k = k_min - ! - IF ( ALLOCATED( climbing_ ) ) THEN - ! - climbing = climbing_ - ! - ELSE - ! - climbing = .FALSE. - ! - END IF - ! - ! ... initial path is read from file ( restart_mode == "restart" ) or - ! ... generated from the input images ( restart_mode = "from_scratch" ) - ! ... It is always read from file in the case of "free-energy" - ! ... calculations - ! - IF ( restart_mode == "restart" ) THEN - ! - IF ( meta_ionode ) THEN - ! - INQUIRE( FILE = path_file, EXIST = file_exists ) - ! - IF ( .NOT. file_exists ) THEN - ! - WRITE( iunpath, & - & '(/,5X,"restart file ''",A,"'' not found: ", & - & /,5X,"starting from scratch")' ) TRIM( path_file ) - ! - restart_mode = "from_scratch" - ! - END IF - ! - END IF - ! - CALL mp_bcast( restart_mode, meta_ionode_id ) - ! - END IF - ! - IF ( restart_mode == "restart" ) THEN - ! - CALL read_restart() - ! - ! ... consistency between the input value of nstep and the value - ! ... of nstep_path read from the restart_file is checked - ! - IF ( nstep == 0 ) THEN - ! - istep_path = 0 - nstep_path = nstep - ! - END IF - ! - IF ( nstep > nstep_path ) nstep_path = nstep - ! - ! ... in case first_last_opt has been set to true, reset the frozen - ! ... array to false (all the images have to be optimized, at least - ! ... on the first iteration) - ! - IF ( first_last_opt ) frozen = .FALSE. - ! - ! ... path length is computed here - ! - path_length = 0.0_DP - ! - DO i = 1, ( num_of_images - 1 ) - ! - path_length = path_length + norm( pos(:,i+1) - pos(:,i) ) - ! - END DO - ! - ELSE - ! - CALL initial_guess() - ! - posold(:,:) = pos(:,:) - ! - END IF - ! - ! ... the actual number of degrees of freedom is computed - ! - deg_of_freedom = 0 - ! - DO i = 1, nat - ! - IF ( if_pos(1,i) == 1 ) deg_of_freedom = deg_of_freedom + 1 - IF ( if_pos(2,i) == 1 ) deg_of_freedom = deg_of_freedom + 1 - IF ( if_pos(3,i) == 1 ) deg_of_freedom = deg_of_freedom + 1 - ! - END DO - ! - RETURN - ! - END SUBROUTINE initialize_path - ! - !-------------------------------------------------------------------- - SUBROUTINE initial_guess() - !-------------------------------------------------------------------- - ! - ! ... linear interpolation - ! - USE input_parameters, ONLY : input_images - USE path_variables, ONLY : pos, dim1, num_of_images, path_length - USE path_formats, ONLY : summary_fmt - USE io_files, ONLY : iunpath - ! - IMPLICIT NONE - ! - REAL(DP) :: s - INTEGER :: i, j - ! - REAL(DP), ALLOCATABLE :: pos_n(:,:), dr(:,:), image_spacing(:) - ! - ! - IF ( meta_ionode ) THEN - ! - ALLOCATE( pos_n( dim1, num_of_images ) ) - ALLOCATE( dr( dim1, input_images - 1 ) ) - ALLOCATE( image_spacing( input_images - 1 ) ) - ! - DO i = 1, input_images - 1 - ! - dr(:,i) = ( pos(:,i+1) - pos(:,i) ) - ! - image_spacing(i) = norm( dr(:,i) ) - ! - END DO - ! - path_length = SUM( image_spacing(:) ) - ! - DO i = 1, input_images - 1 - ! - dr(:,i) = dr(:,i) / image_spacing(i) - ! - END DO - ! - pos_n(:,1) = pos(:,1) - ! - i = 1 - s = 0.0_DP - ! - DO j = 2, num_of_images - 1 - ! - s = s + path_length / DBLE( num_of_images - 1 ) - ! - IF ( s > image_spacing(i) ) THEN - ! - s = s - image_spacing(i) - ! - i = i + 1 - ! - END IF - ! - IF ( i >= input_images ) & - CALL errore( 'initialize_path', 'i >= input_images', i ) - ! - pos_n(:,j) = pos(:,i) + s * dr(:,i) - ! - END DO - ! - pos_n(:,num_of_images) = pos(:,input_images) - ! - pos(:,:) = pos_n(:,:) - ! - path_length = 0.0_DP - ! - DO i = 1, num_of_images - 1 - ! - path_length = path_length + norm( pos(:,i+1) - pos(:,i) ) - ! - END DO - ! - WRITE( UNIT = iunpath, & - FMT = '(/,5X,"initial path length",& - & T35," = ",F7.4," bohr")' ) path_length - ! - WRITE( UNIT = iunpath, & - FMT = '(5X,"initial inter-image distance",T35," = ",F7.4, & - &" bohr")' ) path_length / DBLE( num_of_images - 1 ) - ! - DEALLOCATE( image_spacing, dr, pos_n ) - ! - END IF - ! - CALL mp_bcast( pos, meta_ionode_id ) - CALL mp_bcast( path_length, meta_ionode_id ) - ! - RETURN - ! - END SUBROUTINE initial_guess - ! - !----------------------------------------------------------------------- - FUNCTION real_space_tangent( i ) RESULT( rtan ) - !----------------------------------------------------------------------- - ! - ! ... improved definition of the tangent (see JCP 113, 9978) - ! - USE path_variables, ONLY : dim1, pos, num_of_images, pes - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: i - REAL(DP) :: rtan( dim1 ) - ! - REAL(DP) :: V_previous, V_actual, V_next - REAL(DP) :: abs_next, abs_previous - REAL(DP) :: delta_V_max, delta_V_min - ! - ! - IF ( i == 1 ) THEN - ! - rtan(:) = pos(:,i+1) - pos(:,i) - ! - RETURN - ! - ELSE IF ( i == num_of_images ) THEN - ! - rtan(:) = pos(:,i) - pos(:,i-1) - ! - RETURN - ! - END IF - ! - V_previous = pes( i - 1 ) - V_actual = pes( i ) - V_next = pes( i + 1 ) - ! - IF ( ( V_next > V_actual ) .AND. ( V_actual > V_previous ) ) THEN - ! - rtan(:) = pos(:,i+1) - pos(:,i) - ! - ELSE IF ( ( V_next < V_actual ) .AND. ( V_actual < V_previous ) ) THEN - ! - rtan(:) = pos(:,i) - pos(:,i-1) - ! - ELSE - ! - abs_next = ABS( V_next - V_actual ) - abs_previous = ABS( V_previous - V_actual ) - ! - delta_V_max = MAX( abs_next, abs_previous ) - delta_V_min = MIN( abs_next, abs_previous ) - ! - IF ( V_next > V_previous ) THEN - ! - rtan(:) = ( pos(:,i+1) - pos(:,i) ) * delta_V_max + & - ( pos(:,i) - pos(:,i-1) ) * delta_V_min - ! - ELSE IF ( V_next < V_previous ) THEN - ! - rtan(:) = ( pos(:,i+1) - pos(:,i) ) * delta_V_min + & - ( pos(:,i) - pos(:,i-1) ) * delta_V_max - ! - ELSE - ! - rtan(:) = pos(:,i+1) - pos(:,i-1) - ! - END IF - ! - END IF - ! - rtan(:) = rtan(:) / norm( rtan(:) ) - ! - RETURN - ! - END FUNCTION real_space_tangent - ! - !------------------------------------------------------------------------ - SUBROUTINE elastic_constants() - !------------------------------------------------------------------------ - ! - USE path_variables, ONLY : num_of_images, Emax, Emin, & - k_max, k_min, k, pes - ! - IMPLICIT NONE - ! - INTEGER :: i - REAL(DP) :: delta_E - REAL(DP) :: k_sum, k_diff - ! - ! - ! ... standard neb ( with springs ) - ! - k_sum = k_max + k_min - k_diff = k_max - k_min - ! - k(:) = k_min - ! - delta_E = Emax - Emin - ! - IF ( delta_E > eps32 ) THEN - ! - DO i = 1, num_of_images - ! - k(i) = 0.5_DP*( k_sum - k_diff * & - COS( pi * ( pes(i) - Emin ) / delta_E ) ) - ! - END DO - ! - END IF - ! - k(:) = 0.5_DP*k(:) - ! - RETURN - ! - END SUBROUTINE elastic_constants - ! - !------------------------------------------------------------------------ - SUBROUTINE neb_gradient() - !------------------------------------------------------------------------ - ! - USE path_variables, ONLY : pos, grad, elastic_grad, grad_pes, k, & - num_of_images, climbing, mass, tangent - ! - IMPLICIT NONE - ! - INTEGER :: i - ! - ! - IF ( meta_ionode ) THEN - ! - CALL elastic_constants() - ! - gradient_loop: DO i = 1, num_of_images - ! - IF ( i > 1 .AND. i < num_of_images ) THEN - ! - ! ... elastic gradient only along the path ( variable elastic - ! ... consatnt is used ) NEB recipe - ! - elastic_grad = tangent(:,i) * 0.5_DP * & - ( ( k(i) + k(i-1) ) * norm( pos(:,i) - pos(:,(i-1)) ) - & - ( k(i) + k(i+1) ) * norm( pos(:,(i+1)) - pos(:,i) ) ) - ! - END IF - ! - ! ... total gradient on each image ( climbing image is used if - ! ... required ) only the component of the pes gradient orthogonal - ! ... to the path is used - ! - grad(:,i) = grad_pes(:,i) / SQRT( mass(:) ) - ! - IF ( climbing(i) ) THEN - ! - grad(:,i) = grad(:,i) - & - 2.0_DP*tangent(:,i)*( grad(:,i) .dot. tangent(:,i) ) - ! - ELSE IF ( i > 1 .AND. i < num_of_images ) THEN - ! - grad(:,i) = elastic_grad + grad(:,i) - & - tangent(:,i)*( grad(:,i) .dot. tangent(:,i) ) - ! - END IF - ! - END DO gradient_loop - ! - END IF - ! - CALL mp_bcast( grad, meta_ionode_id ) - ! - RETURN - ! - END SUBROUTINE neb_gradient - ! - !----------------------------------------------------------------------- - SUBROUTINE smd_gradient() - !----------------------------------------------------------------------- - ! - USE ions_base, ONLY : if_pos - USE path_variables, ONLY : dim1, mass, num_of_images, grad_pes, & - tangent, llangevin, lang, grad, ds, & - temp_req - USE path_variables, ONLY : climbing - USE random_numbers, ONLY : gauss_dist - ! - IMPLICIT NONE - ! - INTEGER :: i - ! - ! - IF ( meta_ionode ) THEN - ! - grad(:,:) = 0.0_DP - lang(:,:) = 0.0_DP - ! - ! ... we project pes gradients and gaussian noise - ! - DO i = 1, num_of_images - ! - IF ( llangevin ) THEN - ! - ! ... the random term used in langevin dynamics is generated here - ! - lang(:,i) = gauss_dist( 0.0_DP, SQRT( 2.0_DP*temp_req*ds ), dim1 ) - ! - lang(:,i) = lang(:,i)*DBLE( RESHAPE( if_pos, (/ dim1 /) ) ) - ! - END IF - ! - grad(:,i) = grad_pes(:,i) / SQRT( mass(:) ) - ! - IF ( climbing(i) ) THEN - ! - grad(:,i) = grad(:,i) - & - 2.0_DP*tangent(:,i)*( grad(:,i) .dot. tangent(:,i) ) - ! - ELSE IF ( i > 1 .AND. i < num_of_images ) THEN - ! - ! ... projection of the pes gradients - ! - grad(:,i) = grad(:,i) - & - tangent(:,i)*( grad(:,i) .dot. tangent(:,i) ) - ! - IF ( llangevin ) THEN - ! - lang(:,i) = lang(:,i) - & - tangent(:,i)*( lang(:,i) .dot. tangent(:,i) ) - ! - END IF - ! - END IF - ! - END DO - ! - END IF - ! - CALL mp_bcast( grad, meta_ionode_id ) - CALL mp_bcast( lang, meta_ionode_id ) - ! - RETURN - ! - END SUBROUTINE smd_gradient - ! - ! ... shared routines - ! - !----------------------------------------------------------------------- - FUNCTION new_tangent() RESULT( ntan ) - !----------------------------------------------------------------------- - ! - USE path_variables, ONLY : dim1, num_of_images - ! - IMPLICIT NONE - ! - REAL(DP) :: ntan( dim1, num_of_images ) - ! - INTEGER :: i - ! - ! - IF ( meta_ionode ) THEN - ! - DO i = 1, num_of_images - ! - ntan(:,i) = real_space_tangent( i ) - ! - END DO - ! - END IF - ! - CALL mp_bcast( ntan, meta_ionode_id ) - ! - RETURN - ! - END FUNCTION new_tangent - ! - !----------------------------------------------------------------------- - SUBROUTINE compute_error( err_out ) - !----------------------------------------------------------------------- - ! - USE path_variables, ONLY : pos, posold, num_of_images, grad, & - use_freezing, first_last_opt, path_thr, & - error, frozen, lquick_min - USE mp_global, ONLY : nimage - ! - IMPLICIT NONE - ! - REAL(DP), OPTIONAL, INTENT(OUT) :: err_out - ! - INTEGER :: i - INTEGER :: fii, lii, freed, num_of_scf_images - REAL(DP) :: err_max - LOGICAL :: first - ! - ! - IF ( first_last_opt ) THEN - ! - fii = 1 - lii = num_of_images - ! - frozen = .FALSE. - ! - ELSE - ! - fii = 2 - lii = num_of_images - 1 - ! - frozen = .FALSE. - ! - ! ... the first and the last images are always frozen - ! - frozen(fii-1) = .TRUE. - frozen(lii+1) = .TRUE. - ! - END IF - ! - IF ( meta_ionode ) THEN - ! - DO i = 1, num_of_images - ! - ! ... the error is given by the largest component of the gradient - ! ... vector ( PES + SPRINGS in the neb case ) - ! - error(i) = MAXVAL( ABS( grad(:,i) ) ) / bohr_radius_angs * autoev - ! - END DO - ! - err_max = MAXVAL( error(fii:lii), 1 ) - ! - IF ( use_freezing ) THEN - ! - frozen(fii:lii) = ( error(fii:lii) < & - MAX( 0.5_DP*err_max, path_thr ) ) - ! - END IF - ! - IF ( nimage > 1 .AND. use_freezing ) THEN - ! - find_scf_images: DO - ! - num_of_scf_images = COUNT( .NOT.frozen(fii:lii) ) - ! - IF ( num_of_scf_images >= nimage ) EXIT find_scf_images - ! - first = .TRUE. - ! - search: DO i = fii, lii - ! - IF ( .NOT.frozen(i) ) CYCLE search - ! - IF ( first ) THEN - ! - first = .FALSE. - freed = i - ! - CYCLE search - ! - END IF - ! - IF ( error(i) > error(freed) ) freed = i - ! - END DO search - ! - frozen(freed) = .FALSE. - ! - END DO find_scf_images - ! - END IF - ! - IF ( use_freezing .AND. lquick_min ) THEN - ! - ! ... the old positions of the frozen images are set to the - ! ... present position (equivalent to resetting the velocity) - ! - FORALL( i = fii:lii, frozen(i) ) posold(:,i) = pos(:,i) - ! - END IF - ! - END IF - ! - CALL mp_bcast( error, meta_ionode_id ) - CALL mp_bcast( err_max, meta_ionode_id ) - CALL mp_bcast( frozen, meta_ionode_id ) - CALL mp_bcast( posold, meta_ionode_id ) - ! - IF ( PRESENT( err_out ) ) err_out = err_max - ! - RETURN - ! - END SUBROUTINE compute_error - ! - !------------------------------------------------------------------------ - SUBROUTINE born_oppenheimer_pes( stat ) - !------------------------------------------------------------------------ - ! - USE path_variables, ONLY : nim => num_of_images, & - pending_image, istep_path, pes, & - first_last_opt, Emin, Emax, Emax_index - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(OUT) :: stat - ! - INTEGER :: fii, lii - ! - ! - IF ( istep_path == 0 .OR. first_last_opt ) THEN - ! - fii = 1 - lii = nim - ! - ELSE - ! - fii = 2 - lii = nim - 1 - ! - END IF - ! - IF ( pending_image /= 0 ) fii = pending_image - ! - CALL compute_scf( fii, lii, stat ) - ! - IF ( .NOT. stat ) RETURN - ! - Emin = MINVAL( pes(1:nim) ) - Emax = MAXVAL( pes(1:nim) ) - Emax_index = MAXLOC( pes(1:nim), 1 ) - ! - RETURN - ! - END SUBROUTINE born_oppenheimer_pes - ! - !------------------------------------------------------------------------ - SUBROUTINE born_oppenheimer_fes( stat ) - !------------------------------------------------------------------------ - ! - USE path_variables, ONLY : num_of_images, pending_image, & - istep_path, first_last_opt - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(OUT) :: stat - ! - INTEGER :: fii, lii - ! - ! - IF ( istep_path == 0 .OR. first_last_opt ) THEN - ! - fii = 1 - lii = num_of_images - ! - ELSE - ! - fii = 2 - lii = num_of_images - 1 - ! - END IF - ! - IF ( pending_image /= 0 ) fii = pending_image - ! - CALL compute_fes_grads( fii, lii, stat ) - ! - RETURN - ! - END SUBROUTINE born_oppenheimer_fes - ! - !------------------------------------------------------------------------ - SUBROUTINE fe_profile() - !------------------------------------------------------------------------ - ! - USE path_variables, ONLY : nim => num_of_images - USE path_variables, ONLY : pos, pes, grad_pes, & - Emin, Emax, Emax_index - ! - IMPLICIT NONE - ! - INTEGER :: i - ! - ! - pes(:) = 0.0_DP - ! - DO i = 2, nim - ! - pes(i) = pes(i-1) + 0.5_DP*( ( pos(:,i) - pos(:,i-1) ) .dot. & - ( grad_pes(:,i) + grad_pes(:,i-1) ) ) - ! - END DO - ! - Emin = MINVAL( pes(1:nim) ) - Emax = MAXVAL( pes(1:nim) ) - Emax_index = MAXLOC( pes(1:nim), 1 ) - ! - RETURN - ! - END SUBROUTINE fe_profile - ! - !----------------------------------------------------------------------- - SUBROUTINE check_domain() - !----------------------------------------------------------------------- - ! - USE path_variables, ONLY : pos, num_of_images, & - istep_path, first_last_opt - USE constraints_module, ONLY : constr_target - USE metadyn_base, ONLY : impose_domain_constraints - ! - IMPLICIT NONE - ! - INTEGER :: fii, lii, i - ! - ! - IF ( istep_path == 0 .OR. first_last_opt ) THEN - ! - fii = 1 - lii = num_of_images - ! - ELSE - ! - fii = 2 - lii = num_of_images - 1 - ! - END IF - ! - DO i = fii, lii - ! - constr_target(:) = pos(:,i) - ! - CALL impose_domain_constraints() - ! - END DO - ! - RETURN - ! - END SUBROUTINE check_domain - ! - !----------------------------------------------------------------------- - SUBROUTINE search_mep() - !----------------------------------------------------------------------- - ! - USE control_flags, ONLY : lneb, lsmd, lcoarsegrained - USE path_variables, ONLY : conv_path, istep_path, nstep_path, & - pending_image, activation_energy, & - err_max, pes, climbing, CI_scheme, & - Emax_index, fixed_tan, tangent - USE path_io_routines, ONLY : write_restart, write_dat_files, write_output - USE path_formats, ONLY : scf_iter_fmt - ! - USE path_reparametrisation - ! - IMPLICIT NONE - ! - LOGICAL :: stat - ! - REAL(DP), EXTERNAL :: get_clock - ! - ! - conv_path = .FALSE. - ! - CALL search_mep_init() - ! - IF ( istep_path == nstep_path ) THEN - ! - CALL write_dat_files() - ! - CALL write_output() - ! - pending_image = 0 - ! - CALL write_restart() - ! - RETURN - ! - END IF - ! - ! ... path optimisation loop - ! - optimisation: DO - ! - ! ... new positions are saved on file: it has to be done here - ! ... because, in the event of an unexpected crash the new positions - ! ... would be lost. At this stage the forces and the energies are - ! ... not yet known (but are not necessary for restarting); the - ! ... restart file is written again as soon as the energies and - ! ... forces have been computed. - ! - CALL write_restart() - ! - IF ( meta_ionode ) & - WRITE( UNIT = iunpath, FMT = scf_iter_fmt ) istep_path + 1 - ! - ! ... energies and gradients acting on each image of the path (in real - ! ... space) are computed calling a driver for the scf calculations - ! - IF ( lcoarsegrained ) THEN - ! - CALL born_oppenheimer_fes( stat ) - ! - ELSE - ! - CALL born_oppenheimer_pes( stat ) - ! - END IF - ! - IF ( .NOT. stat ) THEN - ! - conv_path = .FALSE. - ! - EXIT optimisation - ! - END IF - ! - ! ... istep_path is updated after a self-consistency step has been - ! ... completed - ! - istep_path = istep_path + 1 - ! - ! ... the new tangent is computed here : - ! ... the improved definition of tangent requires the energies - ! - IF ( .NOT. fixed_tan ) tangent(:,:) = new_tangent() - ! - IF ( lcoarsegrained ) CALL fe_profile() - ! - IF ( CI_scheme == "auto" ) THEN - ! - climbing = .FALSE. - ! - climbing(Emax_index) = .TRUE. - ! - END IF - ! - IF ( lneb ) CALL neb_gradient() - IF ( lsmd ) CALL smd_gradient() - ! - ! ... the forward activation energy is computed here - ! - activation_energy = ( pes(Emax_index) - pes(1) )*autoev - ! - ! ... the error is computed here (frozen images are also set here) - ! - CALL compute_error( err_max ) - ! - ! ... information is written on the files - ! - CALL write_dat_files() - ! - ! ... information is written on the standard output - ! - CALL write_output() - ! - ! ... the restart file is written - ! - CALL write_restart() - ! - ! ... exit conditions - ! - IF ( check_exit( err_max ) ) EXIT optimisation - ! - ! ... if convergence is not yet achieved, the path is optimised - ! - CALL optimisation_step() - ! - IF ( lcoarsegrained ) CALL check_domain() - ! - IF ( lsmd ) CALL reparametrise() - ! - END DO optimisation - ! - ! ... the restart file is written before the exit - ! - CALL write_restart() - ! - RETURN - ! - END SUBROUTINE search_mep - ! - !------------------------------------------------------------------------ - SUBROUTINE search_mep_init() - !------------------------------------------------------------------------ - ! - USE control_flags, ONLY : lsmd - USE path_variables, ONLY : pending_image, tangent - ! - USE path_reparametrisation - ! - IMPLICIT NONE - ! - ! - IF ( pending_image /= 0 ) RETURN - ! - IF ( lsmd ) CALL reparametrise() - ! - tangent(:,:) = new_tangent() - ! - RETURN - ! - END SUBROUTINE search_mep_init - ! - !------------------------------------------------------------------------ - FUNCTION check_exit( err_max ) - !------------------------------------------------------------------------ - ! - USE input_parameters, ONLY : num_of_images_inp => num_of_images - USE control_flags, ONLY : lneb, lsmd - USE path_variables, ONLY : path_thr, istep_path, nstep_path, & - conv_path, pending_image, & - num_of_images, llangevin - USE path_formats, ONLY : final_fmt - ! - IMPLICIT NONE - ! - LOGICAL :: check_exit - REAL(DP), INTENT(IN) :: err_max - LOGICAL :: exit_condition - ! - ! - check_exit = .FALSE. - ! - ! ... the program checks if the convergence has been achieved - ! - exit_condition = ( .NOT.llangevin .AND. & - ( num_of_images == num_of_images_inp ) .AND. & - ( err_max <= path_thr ) ) - ! - IF ( exit_condition ) THEN - ! - IF ( meta_ionode ) THEN - ! - WRITE( UNIT = iunpath, FMT = final_fmt ) - ! - IF ( lneb ) & - WRITE( UNIT = iunpath, & - FMT = '(/,5X,"neb: convergence achieved in ",I3, & - & " iterations" )' ) istep_path - IF ( lsmd ) & - WRITE( UNIT = iunpath, & - FMT = '(/,5X,"smd: convergence achieved in ",I3, & - & " iterations" )' ) istep_path - ! - END IF - ! - pending_image = 0 - ! - conv_path = .TRUE. - check_exit = .TRUE. - ! - RETURN - ! - END IF - ! - ! ... the program checks if the maximum number of iterations has - ! ... been reached - ! - IF ( istep_path >= nstep_path ) THEN - ! - IF ( meta_ionode ) THEN - ! - WRITE( UNIT = iunpath, FMT = final_fmt ) - ! - IF ( lneb ) & - WRITE( UNIT = iunpath, & - FMT = '(/,5X,"neb: reached the maximum number of ", & - & "steps")' ) - IF ( lsmd ) & - WRITE( UNIT = iunpath, & - FMT = '(/,5X,"smd: reached the maximum number of ", & - & "steps")' ) - ! - END IF - ! - pending_image = 0 - ! - check_exit = .TRUE. - ! - RETURN - ! - END IF - ! - RETURN - ! - END FUNCTION check_exit - ! - !------------------------------------------------------------------------ - SUBROUTINE optimisation_step() - !------------------------------------------------------------------------ - ! - USE path_variables, ONLY : num_of_images, frozen, lsteep_des, & - lquick_min, lbroyden, llangevin, istep_path - USE path_opt_routines, ONLY : quick_min, broyden, steepest_descent, & - langevin - ! - IMPLICIT NONE - ! - INTEGER :: image - ! - ! - IF ( lbroyden ) THEN - ! - CALL broyden() - ! - ELSE - ! - DO image = 1, num_of_images - ! - IF ( frozen(image) ) CYCLE - ! - IF ( lsteep_des ) THEN - ! - CALL steepest_descent( image ) - ! - ELSE IF ( llangevin ) THEN - ! - CALL langevin( image ) - ! - ELSE IF ( lquick_min ) THEN - ! - CALL quick_min( image, istep_path ) - ! - END IF - ! - END DO - ! - END IF - ! - RETURN - ! - END SUBROUTINE optimisation_step - ! -END MODULE path_base diff --git a/quantum_espresso/kcp/Modules/path_formats.f90 b/quantum_espresso/kcp/Modules/path_formats.f90 deleted file mode 100644 index 31feff64b..000000000 --- a/quantum_espresso/kcp/Modules/path_formats.f90 +++ /dev/null @@ -1,52 +0,0 @@ -! -! Copyright (C) 2003-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE path_formats - !---------------------------------------------------------------------------- - ! - ! ... this module contains the I/O formats used by all "path"-routines - ! - ! ... Written by Carlo Sbraccia ( 2003-2005 ) - ! - CHARACTER (LEN=*), PARAMETER :: & - lattice_vectors = "(3(2X,F14.10),/,3(2X,F14.10),/,3(2X,F14.10))" - ! - CHARACTER (LEN=*), PARAMETER :: & - restart_first = "(3(2X,F18.12),3(2X,F18.12),3(2X,I1))", & - restart_others = "(3(2X,F18.12),3(2X,F18.12))" - ! - CHARACTER (LEN=*), PARAMETER :: & - quick_min = "(9(2X,F18.12))", & - energy = "(2X,F18.10)" - ! - CHARACTER (LEN=*), PARAMETER :: & - dat_fmt = "(3(2X,F16.10))", & - int_fmt = "(2(2X,F16.10))", & - xyz_fmt = "(A2,3(2X,F14.10))", & - axsf_fmt = "(A2,6(2X,F14.10))" - ! - CHARACTER (LEN=*), PARAMETER :: & - scf_iter_fmt = "(/,5X,30('-'),(1X,'iteration ',I3,1X),30('-'),/)", & - scf_fmt = "(5X,'tcpu = ',F8.1," // & - & "' self-consistency for image ', I3)", & - scf_fmt_para = "(5X,'cpu = ',I2,' tcpu = ',F8.1," // & - & "' self-consistency for image ', I3)" - ! - CHARACTER (LEN=*), PARAMETER :: & - run_info = "(5X,'image',8X,'energy (eV)',8X,'error (eV/A)',8X,'frozen',/)" - ! - CHARACTER (LEN=*), PARAMETER :: & - run_output = "(5X,I5,4X,F15.7,10X,F10.6,12X,L1)" - ! - CHARACTER (LEN=*), PARAMETER :: & - summary_fmt = "(5X,A,T35,' = ',1X,A)" - ! - CHARACTER (LEN=*), PARAMETER :: & - final_fmt = "(/,5X,75('-'),/)" - ! -END MODULE path_formats diff --git a/quantum_espresso/kcp/Modules/path_io_routines.f90 b/quantum_espresso/kcp/Modules/path_io_routines.f90 deleted file mode 100644 index 4125d188a..000000000 --- a/quantum_espresso/kcp/Modules/path_io_routines.f90 +++ /dev/null @@ -1,1009 +0,0 @@ -! -! Copyright (C) 2002-2006 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!---------------------------------------------------------------------------- -MODULE path_io_routines - !---------------------------------------------------------------------------- - ! - ! ... This module contains all subroutines used for I/O in path - ! ... optimisations - ! - ! ... Written by Carlo Sbraccia ( 2003-2006 ) - ! - USE kinds, ONLY : DP - USE constants, ONLY : pi, autoev, bohr_radius_angs, eV_to_kelvin - USE io_global, ONLY : meta_ionode, meta_ionode_id - USE mp, ONLY : mp_bcast - ! - USE basic_algebra_routines - ! - IMPLICIT NONE - ! - PRIVATE - ! - PUBLIC :: io_path_start, io_path_stop - PUBLIC :: path_summary - PUBLIC :: read_restart - PUBLIC :: write_restart, write_dat_files, write_output - PUBLIC :: new_image_init, get_new_image, stop_other_images - ! - CONTAINS - ! - !----------------------------------------------------------------------- - SUBROUTINE io_path_start() - !----------------------------------------------------------------------- - ! - USE io_global, ONLY : stdout - USE io_global, ONLY : ionode, ionode_id - USE mp_global, ONLY : me_image, root_image - ! - IMPLICIT NONE - ! - ! - ! ... the I/O node is set again according to the number of parallel - ! ... images that have been required: for each parallel image there - ! ... is only one node that does I/O - ! - IF ( me_image == root_image ) THEN - ! - ionode = .TRUE. - ! - ELSE - ! - ionode = .FALSE. - ! - END IF - ! - ionode_id = root_image - ! - ! ... stdout is connected to a file ( different for each image ) - ! ... via unit 117 ( only root_image performes I/O ) - ! - IF ( me_image == root_image ) stdout = 117 - ! - RETURN - ! - END SUBROUTINE io_path_start - ! - ! - !----------------------------------------------------------------------- - SUBROUTINE io_path_stop() - !----------------------------------------------------------------------- - ! - USE io_global, ONLY : stdout, io_global_start - USE mp_global, ONLY : mpime, root - ! - IMPLICIT NONE - ! - ! - ! ... the original I/O node is set again - ! - CALL io_global_start( mpime, root ) - ! - ! ... stdout is reconnected to standard output unit - ! - stdout = 6 - ! - RETURN - ! - END SUBROUTINE io_path_stop - ! - !----------------------------------------------------------------------- - SUBROUTINE path_summary() - !----------------------------------------------------------------------- - ! - USE input_parameters, ONLY : restart_mode, calculation, opt_scheme - USE control_flags, ONLY : lneb, lsmd, lcoarsegrained - USE path_variables, ONLY : climbing, nstep_path, num_of_images, & - path_length, path_thr, ds, use_masses, & - first_last_opt, temp_req, use_freezing, & - k_min, k_max, CI_scheme, fixed_tan, & - llangevin - USE path_formats, ONLY : summary_fmt - USE io_files, ONLY : iunpath - ! - IMPLICIT NONE - ! - INTEGER :: i - REAL(DP) :: k_ratio - CHARACTER(LEN=256) :: outline - CHARACTER(LEN=20) :: nim_char, nstep_path_char - ! - CHARACTER(LEN=6), EXTERNAL :: int_to_char - ! - ! - IF ( .NOT. meta_ionode ) RETURN - ! - ! ... details of the calculation are written on output - ! - nstep_path_char = int_to_char( nstep_path ) - nim_char = int_to_char( num_of_images ) - ! - WRITE( iunpath, * ) - WRITE( iunpath, summary_fmt ) "calculation", TRIM( calculation ) - WRITE( iunpath, summary_fmt ) "restart_mode", TRIM( restart_mode ) - WRITE( iunpath, summary_fmt ) "opt_scheme", TRIM( opt_scheme ) - WRITE( iunpath, summary_fmt ) "num_of_images", TRIM( nim_char ) - WRITE( iunpath, summary_fmt ) "nstep", TRIM( nstep_path_char ) - WRITE( iunpath, summary_fmt ) "CI_scheme", TRIM( CI_scheme ) - ! - WRITE( UNIT = iunpath, & - FMT = '(5X,"first_last_opt",T35," = ",1X,L1)' ) first_last_opt - ! - WRITE( UNIT = iunpath, & - FMT = '(5X,"coarse-grained phase-space",T35, " = ",1X,L1)' ) & - lcoarsegrained - ! - WRITE( UNIT = iunpath, & - FMT = '(5X,"use_freezing",T35," = ",1X,L1)' ) use_freezing - ! - WRITE( UNIT = iunpath, & - FMT = '(5X,"ds",T35," = ",1X,F6.4," a.u.")' ) ds - ! - IF ( lneb ) THEN - ! - WRITE( UNIT = iunpath, & - FMT = '(5X,"k_max",T35," = ",1X,F6.4," a.u.")' ) k_max - WRITE( UNIT = iunpath, & - FMT = '(5X,"k_min",T35," = ",1X,F6.4," a.u.")' ) k_min - ! - k_ratio = k_min / k_max - ! - WRITE( UNIT = iunpath, FMT = '(5X,"suggested k_max",T35, & - & " = ",1X,F6.4," a.u.")' ) ( pi / ds )**2 / 16.0_DP - ! - WRITE( UNIT = iunpath, FMT = '(5X,"suggested k_min",T35, & - & " = ",1X,F6.4," a.u.")' ) ( pi / ds )**2 / 16.0_DP * k_ratio - ! - END IF - ! - IF ( lsmd ) THEN - ! - WRITE( UNIT = iunpath, & - FMT = '(5X,"fixed_tan",T35," = ",1X,L1)' ) fixed_tan - ! - IF ( llangevin ) & - WRITE( UNIT = iunpath, & - FMT = '(5X,"required temperature",T35, & - &" = ",F6.1," K")' ) temp_req * eV_to_kelvin*autoev - ! - END IF - ! - WRITE( UNIT = iunpath, & - FMT = '(5X,"path_thr",T35," = ",1X,F6.4," eV / A")' ) path_thr - ! - IF ( CI_scheme == "manual" ) THEN - ! - outline = '' - ! - DO i = 2, num_of_images - ! - IF ( climbing(i) ) outline = TRIM( outline ) // ' ' // & - & TRIM( int_to_char( i ) ) // ',' - ! - END DO - ! - WRITE( UNIT = iunpath, & - FMT = '(/,5X,"list of climbing images :",2X,A)' ) & - TRIM( outline ) - ! - END IF - ! - RETURN - ! - END SUBROUTINE path_summary - ! - !----------------------------------------------------------------------- - SUBROUTINE read_restart() - !----------------------------------------------------------------------- - ! - USE control_flags, ONLY : lsmd, lcoarsegrained - USE io_files, ONLY : iunpath, iunrestart, path_file - USE input_parameters, ONLY : if_pos - USE path_variables, ONLY : nim => num_of_images - USE path_variables, ONLY : istep_path, nstep_path, frozen, dim1,& - pending_image, pos, pes, grad_pes, & - lquick_min, posold, Emax, Emin, & - Emax_index - USE path_reparametrisation, ONLY : spline_interpolation - ! - IMPLICIT NONE - ! - INTEGER :: i, j, ia, ierr - INTEGER :: nim_inp - CHARACTER(LEN=256) :: input_line - LOGICAL :: exists - LOGICAL, EXTERNAL :: matches - ! - ! - IF ( meta_ionode ) THEN - ! - WRITE( UNIT = iunpath, & - FMT = '(/,5X,"reading file ''",A,"''",/)') TRIM( path_file ) - ! - INQUIRE( FILE = TRIM( path_file ), EXIST = exists ) - ! - IF ( .NOT. exists ) & - CALL errore( 'read_restart', 'restart file not found', 1 ) - ! - OPEN( UNIT = iunrestart, FILE = path_file, STATUS = "OLD", & - ACTION = "READ" ) - ! - READ( UNIT = iunrestart, FMT = '(256A)' ) input_line - ! - IF ( matches( "RESTART INFORMATION", input_line ) ) THEN - ! - READ( UNIT = iunrestart, FMT = * ) istep_path - READ( UNIT = iunrestart, FMT = * ) nstep_path - READ( UNIT = iunrestart, FMT = * ) pending_image - ! - ELSE - ! - ! ... mandatory fields - ! - CALL errore( 'read_restart', 'RESTART INFORMATION missing', 1 ) - ! - END IF - ! - READ( UNIT = iunrestart, FMT = '(256A)' ) input_line - ! - IF ( matches( "NUMBER OF IMAGES", input_line ) ) THEN - ! - ! ... optional field - ! - READ( UNIT = iunrestart, FMT = * ) nim_inp - ! - IF ( nim_inp > nim ) & - CALL errore( 'read_restart', & - 'wrong number of images in the restart file', 1 ) - ! - READ( UNIT = iunrestart, FMT = '(256A)' ) input_line - ! - ELSE - ! - nim_inp = nim - ! - END IF - ! - IF ( .NOT. ( matches( "ENERGIES, POSITIONS AND GRADIENTS", & - input_line ) ) ) THEN - ! - ! ... mandatory fields - ! - CALL errore( 'read_restart', & - 'ENERGIES, POSITIONS AND GRADIENTS missing', 1 ) - ! - END IF - ! - IF ( lcoarsegrained ) THEN - ! - DO i = 1, nim_inp - ! - READ( UNIT = iunrestart, FMT = * ) - ! - DO j = 1, dim1 - ! - READ( UNIT = iunrestart, FMT = * ) pos(j,i), grad_pes(j,i) - ! - END DO - ! - END DO - ! - ELSE - ! - READ( UNIT = iunrestart, FMT = * ) - READ( UNIT = iunrestart, FMT = * ) pes(1) - ! - ia = 0 - ! - if_pos = 0 - ! - DO j = 1, dim1, 3 - ! - ia = ia + 1 - ! - READ( UNIT = iunrestart, FMT = * ) & - pos(j+0,1), & - pos(j+1,1), & - pos(j+2,1), & - grad_pes(j+0,1), & - grad_pes(j+1,1), & - grad_pes(j+2,1), & - if_pos(1,ia), & - if_pos(2,ia), & - if_pos(3,ia) - ! - grad_pes(:,1) = grad_pes(:,1) * & - DBLE( RESHAPE( if_pos, (/ dim1 /) ) ) - ! - END DO - ! - DO i = 2, nim_inp - ! - READ( UNIT = iunrestart, FMT = * ) - READ( UNIT = iunrestart, FMT = * ) pes(i) - ! - DO j = 1, dim1, 3 - ! - READ( UNIT = iunrestart, FMT = * ) & - pos(j+0,i), & - pos(j+1,i), & - pos(j+2,i), & - grad_pes(j+0,i), & - grad_pes(j+1,i), & - grad_pes(j+2,i) - ! - END DO - ! - grad_pes(:,i) = grad_pes(:,i) * & - DBLE( RESHAPE( if_pos, (/ dim1 /) ) ) - ! - END DO - ! - END IF - ! - READ( UNIT = iunrestart, FMT = '(256A)', IOSTAT = ierr ) input_line - ! - IF ( ( ierr == 0 ) .AND. lquick_min ) THEN - ! - IF ( matches( "QUICK-MIN FIELDS", input_line ) ) THEN - ! - ! ... optional fields - ! - IF ( lcoarsegrained ) THEN - ! - DO i = 1, nim_inp - ! - READ( UNIT = iunrestart, FMT = * ) - READ( UNIT = iunrestart, FMT = * ) frozen(i) - ! - DO j = 1, dim1 - ! - READ( UNIT = iunrestart, FMT = * ) posold(j,i) - ! - END DO - ! - END DO - ! - ELSE - ! - DO i = 1, nim_inp - ! - READ( UNIT = iunrestart, FMT = * ) - READ( UNIT = iunrestart, FMT = * ) frozen(i) - ! - DO j = 1, dim1, 3 - ! - READ( UNIT = iunrestart, FMT = * ) & - posold(j+0,i), & - posold(j+1,i), & - posold(j+2,i) - ! - END DO - ! - posold(:,i) = posold(:,i) * & - DBLE( RESHAPE( if_pos, (/ dim1 /) ) ) - ! - END DO - ! - END IF - ! - END IF - ! - END IF - ! - CLOSE( iunrestart ) - ! - IF ( nim_inp /= nim ) THEN - ! - ! ... the input path is reinterpolated to have the required - ! ... number of images - ! - CALL spline_interpolation( pos, 1, nim, nim_inp ) - CALL spline_interpolation( pes, 1, nim, nim_inp ) - CALL spline_interpolation( grad_pes, 1, nim, nim_inp ) - ! - IF ( lquick_min ) THEN - ! - CALL spline_interpolation( posold, 1, nim, nim_inp ) - ! - frozen(:) = .FALSE. - ! - END IF - ! - END IF - ! - IF ( pending_image == 0 ) THEN - ! - Emin = MINVAL( pes(:) ) - Emax = MAXVAL( pes(:) ) - Emax_index = MAXLOC( pes(:), 1 ) - ! - END IF - ! - END IF - ! - ! ... broadcast to all nodes - ! - CALL mp_bcast( istep_path, meta_ionode_id ) - CALL mp_bcast( nstep_path, meta_ionode_id ) - CALL mp_bcast( pending_image, meta_ionode_id ) - ! - CALL mp_bcast( pos, meta_ionode_id ) - CALL mp_bcast( if_pos, meta_ionode_id ) - CALL mp_bcast( pes, meta_ionode_id ) - CALL mp_bcast( grad_pes, meta_ionode_id ) - ! - CALL mp_bcast( Emax, meta_ionode_id ) - CALL mp_bcast( Emin, meta_ionode_id ) - CALL mp_bcast( Emax_index, meta_ionode_id ) - ! - IF ( lquick_min ) THEN - ! - CALL mp_bcast( frozen, meta_ionode_id ) - CALL mp_bcast( posold, meta_ionode_id ) - ! - END IF - ! - RETURN - ! - END SUBROUTINE read_restart - ! - !----------------------------------------------------------------------- - SUBROUTINE write_restart() - !----------------------------------------------------------------------- - ! - USE input_parameters, ONLY : if_pos - USE io_files, ONLY : iunrestart, path_file, tmp_dir - USE control_flags, ONLY : conv_elec, lcoarsegrained - USE path_variables, ONLY : istep_path, nstep_path, pending_image, & - dim1, num_of_images, pos, pes, grad_pes, & - posold, frozen, lquick_min - USE path_formats, ONLY : energy, restart_first, restart_others, & - quick_min - ! - IMPLICIT NONE - ! - INTEGER :: i, j, ia - CHARACTER(LEN=256) :: file - ! - CHARACTER(LEN=6), EXTERNAL :: int_to_char - ! - IF ( meta_ionode ) THEN - ! - ! ... first the restart file is written in the working directory - ! - OPEN( UNIT = iunrestart, FILE = path_file, STATUS = "UNKNOWN", & - ACTION = "WRITE" ) - ! - CALL write_common_fields( iunrestart ) - ! - IF ( lquick_min ) THEN - ! - CALL write_quick_min_fields( iunrestart ) - ! - END IF - ! - CLOSE( iunrestart ) - ! - ! ... then, if pending_image == 0, it is also written on the - ! ... scratch direcoty (a backup copy at each iteration) - ! - IF ( pending_image == 0 ) THEN - ! - file = TRIM( tmp_dir ) // & - TRIM( path_file ) // TRIM( int_to_char( istep_path ) ) - ! - OPEN( UNIT = iunrestart, FILE = TRIM( file ), & - STATUS = "UNKNOWN", ACTION = "WRITE" ) - ! - CALL write_common_fields( iunrestart ) - ! - IF ( lquick_min ) THEN - ! - CALL write_quick_min_fields( iunrestart ) - ! - END IF - ! - CLOSE( iunrestart ) - ! - END IF - ! - END IF - ! - CONTAINS - ! - !------------------------------------------------------------------- - SUBROUTINE write_common_fields( in_unit ) - !------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: in_unit - ! - ! - WRITE( UNIT = in_unit, FMT = '("RESTART INFORMATION")' ) - ! - WRITE( UNIT = in_unit, FMT = '(I8)' ) istep_path - WRITE( UNIT = in_unit, FMT = '(I8)' ) nstep_path - WRITE( UNIT = in_unit, FMT = '(I8)' ) pending_image - ! - WRITE( UNIT = in_unit, FMT = '("NUMBER OF IMAGES")' ) - ! - WRITE( UNIT = in_unit, FMT = '(I4)' ) num_of_images - ! - WRITE( UNIT = in_unit, & - FMT = '("ENERGIES, POSITIONS AND GRADIENTS")' ) - ! - DO i = 1, num_of_images - ! - WRITE( UNIT = in_unit, FMT = '("Image: ",I4)' ) i - ! - IF ( lcoarsegrained ) THEN - ! - DO j = 1, dim1 - ! - WRITE( UNIT = in_unit, & - FMT = '(2(2X,F18.12))' ) pos(j,i), grad_pes(j,i) - ! - END DO - ! - ELSE - ! - WRITE( UNIT = in_unit, FMT = energy ) pes(i) - ! - ia = 0 - ! - DO j = 1, dim1, 3 - ! - ia = ia + 1 - ! - IF ( i == 1 ) THEN - ! - WRITE( UNIT = in_unit, FMT = restart_first ) & - pos(j+0,i), & - pos(j+1,i), & - pos(j+2,i), & - grad_pes(j+0,i), & - grad_pes(j+1,i), & - grad_pes(j+2,i), & - if_pos(1,ia), & - if_pos(2,ia), & - if_pos(3,ia) - ! - ELSE - ! - WRITE( UNIT = in_unit, FMT = restart_others ) & - pos(j+0,i), & - pos(j+1,i), & - pos(j+2,i), & - grad_pes(j+0,i), & - grad_pes(j+1,i), & - grad_pes(j+2,i) - ! - END IF - ! - END DO - ! - END IF - ! - END DO - ! - RETURN - ! - END SUBROUTINE write_common_fields - ! - !------------------------------------------------------------------- - SUBROUTINE write_quick_min_fields( in_unit ) - !------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: in_unit - ! - ! - WRITE( UNIT = in_unit, FMT = '("QUICK-MIN FIELDS")' ) - ! - DO i = 1, num_of_images - ! - WRITE( UNIT = in_unit, FMT = '("Image: ",I4)' ) i - WRITE( UNIT = in_unit, & - FMT = '(2(L1,1X))' ) frozen(i) - ! - IF ( lcoarsegrained ) THEN - ! - DO j = 1, dim1 - ! - WRITE( UNIT = in_unit, & - FMT = '(2X,F18.12)' ) posold(j,i) - ! - END DO - ! - ELSE - ! - DO j = 1, dim1, 3 - ! - WRITE( UNIT = in_unit, FMT = quick_min ) & - posold(j+0,i), & - posold(j+1,i), & - posold(j+2,i) - ! - END DO - ! - END IF - ! - END DO - ! - RETURN - ! - END SUBROUTINE write_quick_min_fields - ! - END SUBROUTINE write_restart - ! - !----------------------------------------------------------------------- - SUBROUTINE write_dat_files() - !----------------------------------------------------------------------- - ! - USE constants, ONLY : pi - USE input_parameters, ONLY : atom_label - USE control_flags, ONLY : lcoarsegrained - USE cell_base, ONLY : alat, at - USE ions_base, ONLY : ityp, nat - USE path_formats, ONLY : dat_fmt, int_fmt, xyz_fmt, axsf_fmt - USE path_variables, ONLY : pos, grad_pes, pes, num_of_images, & - tangent, dim1, error - USE io_files, ONLY : iundat, iunint, iunxyz, iunaxsf, & - dat_file, int_file, xyz_file, axsf_file - ! - IMPLICIT NONE - ! - REAL(DP) :: r, delta, x - REAL(DP), ALLOCATABLE :: a(:), b(:), c(:), d(:), f(:), s(:) - REAL(DP) :: ener, ener_0 - INTEGER :: i, j, ia - INTEGER, PARAMETER :: max_i = 250 - ! - ! - IF ( .NOT. meta_ionode ) RETURN - ! - ! ... the *.dat and *.int files are written here - ! - OPEN( UNIT = iundat, FILE = dat_file, STATUS = "UNKNOWN", & - ACTION = "WRITE" ) - OPEN( UNIT = iunint, FILE = int_file, STATUS = "UNKNOWN", & - ACTION = "WRITE" ) - ! - ALLOCATE( a( num_of_images - 1 ) ) - ALLOCATE( b( num_of_images - 1 ) ) - ALLOCATE( c( num_of_images - 1 ) ) - ALLOCATE( d( num_of_images - 1 ) ) - ALLOCATE( f( num_of_images ) ) - ALLOCATE( s( num_of_images ) ) - ! - f(:) = 0.0_DP - ! - DO i = 2, num_of_images - 1 - ! - f(i) = - ( grad_pes(:,i) .dot. tangent(:,i) ) - ! - END DO - ! - s(1) = 0.0_DP - ! - DO i = 1, num_of_images - 1 - ! - r = norm( pos(:,i+1) - pos(:,i) ) - ! - s(i+1) = s(i) + r - ! - ! ... cubic interpolation - ! - a(i) = 2.0_DP*( pes(i) - pes(i+1) ) / r**3 - ( f(i) + f(i+1) ) / r**2 - ! - b(i) = 3.0_DP*( pes(i+1) - pes(i) ) / r**2 + ( 2.0_DP*f(i) + f(i+1) ) / r - ! - c(i) = - f(i) - ! - d(i) = pes(i) - ! - END DO - ! - DO i = 1, num_of_images - ! - WRITE( UNIT = iundat, FMT = dat_fmt ) & - ( s(i) / s(num_of_images) ), ( pes(i) - pes(1) )*autoev, error(i) - ! - END DO - ! - i = 1 - ! - delta = s(num_of_images) / DBLE( max_i ) - ! - DO j = 0, max_i - ! - r = DBLE( j ) * delta - ! - IF ( r >= s(i+1) .AND. i < num_of_images - 1 ) i = i + 1 - ! - x = r - s(i) - ! - ener = a(i)*x**3 + b(i)*x**2 + c(i)*x + d(i) - ! - IF ( j == 0 ) ener_0 = ener - ! - WRITE( UNIT = iunint, FMT = int_fmt ) & - ( r / s(num_of_images) ), ( ener - ener_0 )*autoev - ! - END DO - ! - DEALLOCATE( a, b, c, d, f, s ) - ! - CLOSE( UNIT = iundat ) - CLOSE( UNIT = iunint ) - ! - IF ( lcoarsegrained ) RETURN - ! - ! ... the *.xyz file is written here - ! - OPEN( UNIT = iunxyz, FILE = xyz_file, & - STATUS = "UNKNOWN", ACTION = "WRITE" ) - ! - DO i = 1, num_of_images - ! - WRITE( UNIT = iunxyz, FMT = '(I5,/)' ) nat - ! - DO ia = 1, nat - ! - WRITE( UNIT = iunxyz, FMT = xyz_fmt ) & - TRIM( atom_label( ityp( ia ) ) ), & - pos(3*ia-2,i) * bohr_radius_angs, & - pos(3*ia-1,i) * bohr_radius_angs, & - pos(3*ia-0,i) * bohr_radius_angs - ! - END DO - ! - END DO - ! - CLOSE( UNIT = iunxyz ) - ! - ! ... the *.axsf file is written here - ! - OPEN( UNIT = iunaxsf, FILE = axsf_file, STATUS = "UNKNOWN", & - ACTION = "WRITE" ) - ! - WRITE( UNIT = iunaxsf, FMT = '(" ANIMSTEPS ",I3)' ) num_of_images - WRITE( UNIT = iunaxsf, FMT = '(" CRYSTAL ")' ) - WRITE( UNIT = iunaxsf, FMT = '(" PRIMVEC ")' ) - WRITE( UNIT = iunaxsf, FMT = '(3F14.10)' ) & - at(1,1) * alat * bohr_radius_angs, & - at(2,1) * alat * bohr_radius_angs, & - at(3,1) * alat * bohr_radius_angs - WRITE( UNIT = iunaxsf, FMT = '(3F14.10)' ) & - at(1,2) * alat * bohr_radius_angs, & - at(2,2) * alat * bohr_radius_angs, & - at(3,2) * alat * bohr_radius_angs - WRITE( UNIT = iunaxsf, FMT = '(3F14.10)' ) & - at(1,3) * alat * bohr_radius_angs, & - at(2,3) * alat * bohr_radius_angs, & - at(3,3) * alat * bohr_radius_angs - ! - DO i = 1, num_of_images - ! - WRITE( UNIT = iunaxsf, FMT = '(" PRIMCOORD ",I3)' ) i - WRITE( UNIT = iunaxsf, FMT = '(I5," 1")' ) nat - ! - DO ia = 1, nat - ! - WRITE( UNIT = iunaxsf, FMT = axsf_fmt ) & - TRIM( atom_label(ityp(ia)) ), & - pos(3*ia-2,i) * bohr_radius_angs, & - pos(3*ia-1,i) * bohr_radius_angs, & - pos(3*ia-0,i) * bohr_radius_angs, & - - grad_pes(3*ia-2,i) / bohr_radius_angs, & - - grad_pes(3*ia-1,i) / bohr_radius_angs, & - - grad_pes(3*ia-0,i) / bohr_radius_angs - ! - END DO - ! - END DO - ! - CLOSE( UNIT = iunaxsf ) - ! - END SUBROUTINE write_dat_files - ! - !----------------------------------------------------------------------- - SUBROUTINE write_output() - !----------------------------------------------------------------------- - ! - USE io_files, ONLY : iunpath - USE path_variables, ONLY : num_of_images, error, path_length, & - activation_energy, pes, pos, frozen, & - CI_scheme, Emax_index - USE path_formats, ONLY : run_info, run_output - ! - IMPLICIT NONE - ! - ! ... local variables - ! - INTEGER :: image - REAL (DP) :: inter_image_distance - ! - ! - IF ( .NOT. meta_ionode ) RETURN - ! - WRITE( UNIT = iunpath, & - FMT = '(/,5X,"activation energy (->) = ",F10.6," eV")' ) & - activation_energy - WRITE( UNIT = iunpath, & - FMT = '(5X,"activation energy (<-) = ",F10.6," eV",/)' ) & - activation_energy + ( pes(1) - pes(num_of_images) ) * autoev - ! - WRITE( UNIT = iunpath, FMT = run_info ) - ! - path_length = 0.0_DP - ! - DO image = 1, num_of_images - ! - IF ( image > 1 ) & - path_length = path_length + & - norm( pos(:,image) - pos(:,image-1) ) - ! - WRITE( UNIT = iunpath, FMT = run_output ) & - image, pes(image) * autoev, error(image), frozen(image) - ! - END DO - ! - inter_image_distance = path_length / DBLE( num_of_images - 1 ) - ! - IF ( CI_scheme == "auto" ) & - WRITE( UNIT = iunpath, & - FMT = '(/,5X,"climbing image = ",I2)' ) Emax_index - ! - WRITE( UNIT = iunpath, & - FMT = '(/,5X,"path length",& - & T26," = ",F6.3," bohr")' ) path_length - WRITE( UNIT = iunpath, & - FMT = '(5X,"inter-image distance", & - & T26," = ",F6.3," bohr")' ) inter_image_distance - ! - END SUBROUTINE write_output - ! - !----------------------------------------------------------------------- - SUBROUTINE new_image_init( fii, outdir ) - !----------------------------------------------------------------------- - ! - ! ... this subroutine initializes the file needed for the - ! ... parallelization among images - ! - USE io_files, ONLY : iunnewimage, prefix - USE path_variables, ONLY : tune_load_balance - USE mp_global, ONLY : nimage - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: fii - CHARACTER(LEN=*), INTENT(IN) :: outdir - ! - ! - IF ( nimage == 1 .OR. .NOT.tune_load_balance ) RETURN - ! - OPEN( UNIT = iunnewimage, FILE = TRIM( outdir ) // & - & TRIM( prefix ) // '.newimage' , STATUS = 'UNKNOWN' ) - ! - WRITE( iunnewimage, * ) fii + nimage - ! - CLOSE( UNIT = iunnewimage, STATUS = 'KEEP' ) - ! - RETURN - ! - END SUBROUTINE new_image_init - ! - !----------------------------------------------------------------------- - SUBROUTINE get_new_image( image, outdir ) - !----------------------------------------------------------------------- - ! - ! ... this subroutine is used to get the new image to work on - ! ... the "prefix.LOCK" file is needed to avoid (when present) that - ! ... other jobs try to read/write on file "prefix.newimage" - ! - USE io_files, ONLY : iunnewimage, iunlock, prefix - USE io_global, ONLY : ionode - USE path_variables, ONLY : tune_load_balance - USE mp_global, ONLY : nimage - ! - IMPLICIT NONE - ! - INTEGER, INTENT(INOUT) :: image - CHARACTER(LEN=*), INTENT(IN) :: outdir - ! - INTEGER :: ioerr - CHARACTER(LEN=256) :: filename - LOGICAL :: opened - ! - ! - IF ( .NOT.ionode ) RETURN - ! - IF ( nimage > 1 ) THEN - ! - IF ( tune_load_balance ) THEN - ! - filename = TRIM( outdir ) // TRIM( prefix ) // '.LOCK' - ! - open_loop: DO - ! - OPEN( UNIT = iunlock, FILE = TRIM( filename ), & - & IOSTAT = ioerr, STATUS = 'NEW' ) - ! - IF ( ioerr > 0 ) CYCLE open_loop - ! - INQUIRE( UNIT = iunnewimage, OPENED = opened ) - ! - IF ( .NOT. opened ) THEN - ! - OPEN( UNIT = iunnewimage, FILE = TRIM( outdir ) // & - & TRIM( prefix ) // '.newimage' , STATUS = 'OLD' ) - ! - READ( iunnewimage, * ) image - ! - CLOSE( UNIT = iunnewimage, STATUS = 'DELETE' ) - ! - OPEN( UNIT = iunnewimage, FILE = TRIM( outdir ) // & - & TRIM( prefix ) // '.newimage' , STATUS = 'NEW' ) - ! - WRITE( iunnewimage, * ) image + 1 - ! - CLOSE( UNIT = iunnewimage, STATUS = 'KEEP' ) - ! - EXIT open_loop - ! - END IF - ! - END DO open_loop - ! - CLOSE( UNIT = iunlock, STATUS = 'DELETE' ) - ! - ELSE - ! - image = image + nimage - ! - END IF - ! - ELSE - ! - image = image + 1 - ! - END IF - ! - RETURN - ! - END SUBROUTINE get_new_image - ! - !----------------------------------------------------------------------- - SUBROUTINE stop_other_images() - !----------------------------------------------------------------------- - ! - ! ... this subroutine is used to send a stop signal to other images - ! ... this is done by creating the exit_file on the working directory - ! - USE io_files, ONLY : iunexit, exit_file - USE io_global, ONLY : ionode - ! - IMPLICIT NONE - ! - ! - IF ( .NOT. ionode ) RETURN - ! - OPEN( UNIT = iunexit, FILE = TRIM( exit_file ) ) - CLOSE( UNIT = iunexit, STATUS = 'KEEP' ) - ! - RETURN - ! - END SUBROUTINE stop_other_images - ! -END MODULE path_io_routines diff --git a/quantum_espresso/kcp/Modules/path_opt_routines.f90 b/quantum_espresso/kcp/Modules/path_opt_routines.f90 deleted file mode 100644 index c5a2eb24d..000000000 --- a/quantum_espresso/kcp/Modules/path_opt_routines.f90 +++ /dev/null @@ -1,307 +0,0 @@ -! -! Copyright (C) 2003-2006 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!-------------------------------------------------------------------------- -MODULE path_opt_routines - !--------------------------------------------------------------------------- - ! - ! ... This module contains all subroutines and functions needed for - ! ... the optimisation of the reaction path (NEB and SMD calculations) - ! - ! ... Written by Carlo Sbraccia ( 2003-2006 ) - ! - USE kinds, ONLY : DP - USE constants, ONLY : eps8, eps16 - USE path_variables, ONLY : ds, pos, grad - USE io_global, ONLY : meta_ionode, meta_ionode_id - USE mp, ONLY : mp_bcast - ! - USE basic_algebra_routines - ! - IMPLICIT NONE - ! - PRIVATE - ! - PUBLIC :: langevin, steepest_descent, quick_min, broyden - ! - CONTAINS - ! - !---------------------------------------------------------------------- - SUBROUTINE langevin( idx ) - !---------------------------------------------------------------------- - ! - USE path_variables, ONLY : lang - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: idx - ! - IF ( meta_ionode ) THEN - ! - pos(:,idx) = pos(:,idx) - ds*grad(:,idx) + lang(:,idx) - ! - END IF - ! - CALL mp_bcast( pos, meta_ionode_id ) - ! - RETURN - ! - END SUBROUTINE langevin - ! - !---------------------------------------------------------------------- - SUBROUTINE steepest_descent( idx ) - !---------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: idx - ! - IF ( meta_ionode ) THEN - ! - pos(:,idx) = pos(:,idx) - ds*ds*grad(:,idx) - ! - END IF - ! - CALL mp_bcast( pos, meta_ionode_id ) - ! - RETURN - ! - END SUBROUTINE steepest_descent - ! - !---------------------------------------------------------------------- - SUBROUTINE quick_min( idx, istep ) - !---------------------------------------------------------------------- - ! - ! ... projected Verlet algorithm - ! - USE path_variables, ONLY : dim1, posold - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: idx, istep - ! - REAL(DP), ALLOCATABLE :: vel(:), force_versor(:), step(:) - REAL(DP) :: projection, norm_grad, norm_vel, norm_step - ! - REAL(DP), PARAMETER :: max_step = 0.6_DP ! in bohr - ! - ! - IF ( meta_ionode ) THEN - ! - ALLOCATE( vel( dim1 ), force_versor( dim1 ), step( dim1 ) ) - ! - vel(:) = pos(:,idx) - posold(:,idx) - ! - norm_grad = norm( grad(:,idx) ) - ! - norm_vel = norm( vel(:) ) - ! - IF ( norm_grad > eps16 .AND. norm_vel > eps16 ) THEN - ! - force_versor(:) = - grad(:,idx) / norm_grad - ! - projection = ( vel(:) .dot. force_versor(:) ) - ! - vel(:) = MAX( 0.0_DP, projection ) * force_versor(:) - ! - ELSE - ! - vel(:) = 0.0_DP - ! - END IF - ! - posold(:,idx) = pos(:,idx) - ! - step(:) = vel(:) - ds*ds*grad(:,idx) - ! - norm_step = norm( step(:) ) - ! - step(:) = step(:) / norm_step - ! - pos(:,idx) = pos(:,idx) + step(:) * MIN( norm_step, max_step ) - ! - DEALLOCATE( vel, force_versor, step ) - ! - END IF - ! - CALL mp_bcast( pos, meta_ionode_id ) - CALL mp_bcast( posold, meta_ionode_id ) - ! - RETURN - ! - END SUBROUTINE quick_min - ! - ! ... Broyden (rank one) optimisation - ! - !----------------------------------------------------------------------- - SUBROUTINE broyden() - !----------------------------------------------------------------------- - ! - USE control_flags, ONLY : lsmd - USE io_files, ONLY : broy_file, iunbroy, iunpath - USE path_variables, ONLY : dim1, frozen, tangent, nim => num_of_images - ! - IMPLICIT NONE - ! - REAL(DP), ALLOCATABLE :: t(:), g(:), s(:,:) - INTEGER :: k, i, j, I_in, I_fin - REAL(DP) :: s_norm, coeff, norm_g - REAL(DP) :: J0 - LOGICAL :: exists - ! - REAL(DP), PARAMETER :: step_max = 0.6_DP - INTEGER, PARAMETER :: broyden_ndim = 5 - ! - ! - ! ... starting guess for the inverse Jacobian - ! - J0 = ds*ds - ! - ALLOCATE( g( dim1*nim ) ) - ALLOCATE( s( dim1*nim, broyden_ndim ) ) - ALLOCATE( t( dim1*nim ) ) - ! - g(:) = 0.0_DP - t(:) = 0.0_DP - ! - DO i = 1, nim - ! - I_in = ( i - 1 )*dim1 + 1 - I_fin = i * dim1 - ! - IF ( frozen(i) ) CYCLE - ! - IF ( lsmd ) t(I_in:I_fin) = tangent(:,i) - ! - g(I_in:I_fin) = grad(:,i) - ! - END DO - ! - norm_g = MAXVAL( ABS( g ) ) - ! - IF ( norm_g == 0.0_DP ) RETURN - ! - IF ( meta_ionode ) THEN - ! - ! ... open the file containing the broyden's history - ! - INQUIRE( FILE = broy_file, EXIST = exists ) - ! - IF ( exists ) THEN - ! - OPEN( UNIT = iunbroy, FILE = broy_file, STATUS = "OLD" ) - ! - READ( UNIT = iunbroy , FMT = * ) i - ! - ! ... if the number of images is changed the broyden history is - ! ... reset and the algorithm starts from scratch - ! - exists = ( i == nim ) - ! - END IF - ! - IF ( exists ) THEN - ! - READ( UNIT = iunbroy , FMT = * ) k - READ( UNIT = iunbroy , FMT = * ) s(:,:) - ! - k = k + 1 - ! - ELSE - ! - s(:,:) = 0.0_DP - ! - k = 1 - ! - END IF - ! - CLOSE( UNIT = iunbroy ) - ! - ! ... Broyden's update - ! - IF ( k > broyden_ndim ) THEN - ! - ! ... the Broyden's subspace is swapped and the projection of - ! ... s along the current tangent is removed (this last thing - ! ... in the smd case only, otherwise t = 0.0_DP) - ! - k = broyden_ndim - ! - DO j = 1, k - 1 - ! - s(:,j) = s(:,j+1) - t(:) * ( s(:,j+1) .dot. t(:) ) - ! - END DO - ! - END IF - ! - s(:,k) = - J0 * g(:) - ! - IF ( k > 1 ) THEN - ! - DO j = 1, k - 2 - ! - s(:,k) = s(:,k) + ( s(:,j) .dot. s(:,k) ) / & - ( s(:,j) .dot. s(:,j) ) * s(:,j+1) - ! - END DO - ! - coeff = ( s(:,k-1) .dot. ( s(:,k-1) - s(:,k) ) ) - ! - IF ( coeff > eps8 ) THEN - ! - s(:,k) = ( s(:,k-1) .dot. s(:,k-1) ) / coeff * s(:,k) - ! - END IF - ! - END IF - ! - IF ( ( s(:,k) .dot. g(:) ) > 0.0_DP ) THEN - ! - ! ... uphill step : history reset - ! - WRITE( UNIT = iunpath, & - FMT = '(/,5X,"broyden uphill step : history is reset",/)' ) - ! - k = 1 - ! - s(:,:) = 0.0_DP - s(:,k) = - J0 * g(:) - ! - END IF - ! - s_norm = norm( s(:,k) ) - ! - s(:,k) = s(:,k) / s_norm * MIN( s_norm, step_max ) - ! - ! ... save the file containing the history - ! - OPEN( UNIT = iunbroy, FILE = broy_file ) - ! - WRITE( UNIT = iunbroy, FMT = * ) nim - WRITE( UNIT = iunbroy, FMT = * ) k - WRITE( UNIT = iunbroy, FMT = * ) s - ! - CLOSE( UNIT = iunbroy ) - ! - ! ... broyden's step - ! - pos(:,1:nim) = pos(:,1:nim) + RESHAPE( s(:,k), (/ dim1, nim /) ) - ! - END IF - ! - CALL mp_bcast( pos, meta_ionode_id ) - ! - DEALLOCATE( t ) - DEALLOCATE( g ) - DEALLOCATE( s ) - ! - RETURN - ! - END SUBROUTINE broyden - ! -END MODULE path_opt_routines diff --git a/quantum_espresso/kcp/Modules/path_reparametrisation.f90 b/quantum_espresso/kcp/Modules/path_reparametrisation.f90 deleted file mode 100644 index 9f0f6a572..000000000 --- a/quantum_espresso/kcp/Modules/path_reparametrisation.f90 +++ /dev/null @@ -1,309 +0,0 @@ -! -! Copyright (C) 2003-2006 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!--------------------------------------------------------------------------- -MODULE path_reparametrisation - !--------------------------------------------------------------------------- - ! - ! ... This module contains all subroutines and functions needed for - ! ... the reparametrisation of the path in the string method - ! - ! ... Written by Carlo Sbraccia ( 2003-2006 ) - ! - USE kinds, ONLY : DP - USE io_files, ONLY : iunpath - USE io_global, ONLY : meta_ionode, meta_ionode_id - USE mp, ONLY : mp_bcast - ! - USE basic_algebra_routines - ! - PRIVATE - ! - PUBLIC :: reparametrise, spline_interpolation - ! - INTERFACE spline_interpolation - ! - MODULE PROCEDURE spline_interpolation_1D, spline_interpolation_2D - ! - END INTERFACE - ! - CONTAINS - ! - ! ... reparametrisation routines in real space - ! - !------------------------------------------------------------------------ - SUBROUTINE reparametrise() - !------------------------------------------------------------------------ - ! - USE path_variables, ONLY : pos - USE path_variables, ONLY : nim => num_of_images - USE path_variables, ONLY : climbing - ! - IMPLICIT NONE - ! - INTEGER :: i, ni, nf - ! - ! - IF ( meta_ionode ) THEN - ! - IF ( ANY( climbing(:) ) ) THEN - ! - ni = 1 - ! - DO i = 2, nim - ! - IF ( .NOT. climbing(i) ) CYCLE - ! - nf = i - ! - CALL spline_interpolation( pos, ni, nf ) - ! - ni = nf - ! - END DO - ! - nf = nim - ! - CALL spline_interpolation( pos, ni, nf ) - ! - ELSE - ! - ni = 1 - nf = nim - ! - CALL spline_interpolation( pos, ni, nf ) - ! - END IF - ! - END IF - ! - CALL mp_bcast( pos, meta_ionode_id ) - ! - RETURN - ! - END SUBROUTINE reparametrise - ! - !-------------------------------------------------------------------- - SUBROUTINE spline_interpolation_1D( vec, ni, nf, nim ) - !-------------------------------------------------------------------- - ! - USE splinelib, ONLY : dosplineint - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(INOUT) :: vec(:) - INTEGER, INTENT(IN) :: ni, nf - INTEGER, INTENT(IN), OPTIONAL :: nim - ! - INTEGER :: i, j - INTEGER :: nio, nfo - REAL(DP) :: delta, length - REAL(DP), ALLOCATABLE :: new_vec(:) - REAL(DP), ALLOCATABLE :: old_mesh(:), new_mesh(:) - ! - ! - IF ( PRESENT( nim ) ) THEN - ! - nio = 1 - nfo = nim - ! - ELSE - ! - nio = ni - nfo = nf - ! - END IF - ! - ! ... cubic spline interpolation - ! - ALLOCATE( new_vec( ni:nf ) ) - ! - ALLOCATE( old_mesh( nio:nfo ) ) - ALLOCATE( new_mesh( ni:nf ) ) - ! - old_mesh(:) = 0.0_DP - new_mesh(:) = 0.0_DP - ! - DO i = nio, nfo - 1 - ! - old_mesh(i+1) = old_mesh(i) + ABS( vec(i+1) - vec(i) ) - ! - END DO - ! - length = old_mesh(nfo) - ! - delta = length / DBLE( nf - ni ) - ! - DO j = 0, nf - ni - ! - new_mesh(j+ni) = DBLE(j) * delta - ! - END DO - ! - old_mesh(:) = old_mesh(:) / length - new_mesh(:) = new_mesh(:) / length - ! - CALL dosplineint( old_mesh(:), vec(nio:nfo), new_mesh(:), new_vec(:) ) - ! - vec(ni:nf) = new_vec(:) - ! - DEALLOCATE( new_vec, old_mesh, new_mesh ) - ! - RETURN - ! - END SUBROUTINE spline_interpolation_1D - ! - !-------------------------------------------------------------------- - SUBROUTINE spline_interpolation_2D( vec, ni, nf, nim ) - !-------------------------------------------------------------------- - ! - USE splinelib, ONLY : dosplineint - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(INOUT) :: vec(:,:) - INTEGER, INTENT(IN) :: ni, nf - INTEGER, INTENT(IN), OPTIONAL :: nim - ! - INTEGER :: i, j - INTEGER :: nio, nfo - INTEGER :: dim1 - REAL(DP) :: delta, length - REAL(DP), ALLOCATABLE :: new_vec(:,:) - REAL(DP), ALLOCATABLE :: old_mesh(:), new_mesh(:) - ! - ! - dim1 = SIZE( vec, 1 ) - ! - IF ( PRESENT( nim ) ) THEN - ! - nio = 1 - nfo = nim - ! - ELSE - ! - nio = ni - nfo = nf - ! - END IF - ! - ! ... cubic spline interpolation - ! - ALLOCATE( new_vec( dim1, ni:nf ) ) - ! - ALLOCATE( old_mesh( nio:nfo ) ) - ALLOCATE( new_mesh( ni:nf ) ) - ! - old_mesh(:) = 0.0_DP - new_mesh(:) = 0.0_DP - ! - DO i = nio, nfo - 1 - ! - old_mesh(i+1) = old_mesh(i) + norm( vec(:,i+1) - vec(:,i) ) - ! - END DO - ! - length = old_mesh(nfo) - ! - delta = length / DBLE( nf - ni ) - ! - DO j = 0, nf - ni - ! - new_mesh(j+ni) = DBLE(j) * delta - ! - END DO - ! - old_mesh(:) = old_mesh(:) / length - new_mesh(:) = new_mesh(:) / length - ! - CALL dosplineint( old_mesh(:), vec(:,nio:nfo), new_mesh(:), new_vec(:,:) ) - ! - vec(:,ni:nf) = new_vec(:,:) - ! - DEALLOCATE( new_vec, old_mesh, new_mesh ) - ! - RETURN - ! - END SUBROUTINE spline_interpolation_2D - ! - !-------------------------------------------------------------------- - SUBROUTINE cubic_interpolation( ni, nf ) - !-------------------------------------------------------------------- - ! - USE path_variables, ONLY : dim1, pos - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ni, nf - ! - INTEGER :: i, j - REAL(DP) :: r, delta, x - REAL(DP), ALLOCATABLE :: a(:,:), b(:,:), c(:,:), d(:,:), t(:,:), s(:) - ! - ALLOCATE( a( dim1, ni:nf-1 ) ) - ALLOCATE( b( dim1, ni:nf-1 ) ) - ALLOCATE( c( dim1, ni:nf-1 ) ) - ALLOCATE( d( dim1, ni:nf-1 ) ) - ALLOCATE( t( dim1, ni:nf ) ) - ALLOCATE( s( ni:nf ) ) - ! - t(:,ni) = pos(:,ni+1) - pos(:,ni) - t(:,nf) = pos(:,nf) - pos(:,nf-1) - ! - DO i = ni+1, nf - 1 - ! - t(:,i) = ( pos(:,i+1) - pos(:,i-1) ) / 2.0_DP - ! - END DO - ! - s(ni) = 0.0_DP - ! - DO i = ni, nf - 1 - ! - r = norm( pos(:,i+1) - pos(:,i) ) - ! - s(i+1) = s(i) + r - ! - ! ... cubic interpolation - ! - a(:,i) = 2.0_DP *( pos(:,i) - pos(:,i+1) ) / r**3 + & - ( t(:,i) + t(:,i+1) ) / r**2 - ! - b(:,i) = 3.0_DP *( pos(:,i+1) - pos(:,i) ) / r**2 - & - ( 2.0_DP*t(:,i) + t(:,i+1) ) / r - ! - c(:,i) = t(:,i) - ! - d(:,i) = pos(:,i) - ! - END DO - ! - i = ni - ! - delta = s(nf) / DBLE( nf - ni ) - ! - DO j = ni, nf - ! - r = DBLE( j - ni ) * delta - ! - IF ( r >= s(i+1) .AND. i < nf - 1 ) i = i + 1 - ! - x = r - s(i) - ! - pos(:,j) = a(:,i)*x**3 + b(:,i)*x**2 + c(:,i)*x + d(:,i) - ! - END DO - ! - DEALLOCATE( a, b, c, d, t, s ) - ! - RETURN - ! - END SUBROUTINE cubic_interpolation - ! -END MODULE path_reparametrisation diff --git a/quantum_espresso/kcp/Modules/path_variables.f90 b/quantum_espresso/kcp/Modules/path_variables.f90 deleted file mode 100644 index f5a0c444b..000000000 --- a/quantum_espresso/kcp/Modules/path_variables.f90 +++ /dev/null @@ -1,152 +0,0 @@ -! -! Copyright (C) 2003-2006 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!-------------------------------------------------------------------------- -MODULE path_variables - !--------------------------------------------------------------------------- - ! - ! ... This module contains all variables needed by path optimisations - ! - ! ... Written by Carlo Sbraccia ( 2003-2006 ) - ! - USE kinds, ONLY : DP - ! - IMPLICIT NONE - ! - SAVE - ! - ! ... "general" variables : - ! - LOGICAL :: & - conv_path ! .TRUE. when "path" convergence has been - ! achieved - LOGICAL :: & - first_last_opt, &! if .TRUE. the first and the last image - ! are optimised too. - use_masses, &! if .TRUE. mass weighted coordinates are - ! used - fixed_tan, &! if. TRUE. the projection is done using the - ! tangent of the average path - use_freezing, &! if .TRUE. images are optimised according - ! to their error (see frozen array) - tune_load_balance ! if .TRUE. the load balance for image - ! parallelisation is tuned at - ! runtime - INTEGER :: & - dim1, &! dimension of the configuration space - num_of_images, &! number of images - deg_of_freedom, &! number of degrees of freedom - ! ( dim1 - #( of fixed coordinates ) ) - pending_image ! last image for which scf has not been - ! achieved - REAL(DP) :: & - ds, &! the optimization step - path_thr, &! convergence threshold - temp_req, &! required temperature - activation_energy, &! forward activatation energy - err_max, &! the largest error - path_length ! length of the path - LOGICAL :: & - lsteep_des = .FALSE., &! .TRUE. if opt_scheme = "sd" - lquick_min = .FALSE., &! .TRUE. if opt_scheme = "quick-min" - lbroyden = .FALSE., &! .TRUE. if opt_scheme = "broyden" - llangevin = .FALSE. ! .TRUE. if opt_scheme = "langevin" - INTEGER :: & - istep_path, &! iteration in the optimization procedure - nstep_path ! maximum number of iterations - ! - ! ... "general" real space arrays - ! - REAL(DP), ALLOCATABLE :: & - pes(:), &! the potential enrgy along the path - error(:) ! the error from the true MEP - REAL(DP), ALLOCATABLE :: & - pos(:,:), &! reaction path - grad_pes(:,:), &! gradients acting on the path - tangent(:,:) ! tangent to the path - LOGICAL, ALLOCATABLE :: & - frozen(:) ! .TRUE. if the image or mode has not - ! to be optimized - ! - ! ... "neb specific" variables : - ! - LOGICAL, ALLOCATABLE :: & - climbing(:) ! .TRUE. if the image is required to climb - CHARACTER(LEN=20) :: & - CI_scheme ! Climbing Image scheme - INTEGER :: & - Emax_index ! index of the image with the highest energy - ! - REAL (DP) :: & - k_max, &! - k_min, &! - Emax, &! - Emin ! - ! - ! ... real space arrays - ! - REAL(DP), ALLOCATABLE :: & - elastic_grad(:), &! elastic part of the gradients - mass(:), &! atomic masses - k(:) ! elastic constants - REAL(DP), ALLOCATABLE :: & - posold(:,:), &! old positions (for the quick-min) - grad(:,:), &! - lang(:,:) ! langevin random force - ! - CONTAINS - ! - !---------------------------------------------------------------------- - SUBROUTINE path_allocation() - !---------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - ALLOCATE( pos( dim1, num_of_images ) ) - ! - ALLOCATE( posold( dim1, num_of_images ) ) - ALLOCATE( grad( dim1, num_of_images ) ) - ALLOCATE( grad_pes( dim1, num_of_images ) ) - ALLOCATE( tangent( dim1, num_of_images ) ) - ! - ALLOCATE( pes( num_of_images ) ) - ALLOCATE( k( num_of_images ) ) - ALLOCATE( error( num_of_images ) ) - ALLOCATE( climbing( num_of_images ) ) - ALLOCATE( frozen( num_of_images ) ) - ! - ALLOCATE( mass( dim1 ) ) - ALLOCATE( elastic_grad( dim1 ) ) - ! - ALLOCATE( lang( dim1, num_of_images ) ) - ! - END SUBROUTINE path_allocation - ! - ! - !---------------------------------------------------------------------- - SUBROUTINE path_deallocation() - !---------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - IF ( ALLOCATED( pos ) ) DEALLOCATE( pos ) - IF ( ALLOCATED( posold ) ) DEALLOCATE( posold ) - IF ( ALLOCATED( grad ) ) DEALLOCATE( grad ) - IF ( ALLOCATED( pes ) ) DEALLOCATE( pes ) - IF ( ALLOCATED( grad_pes ) ) DEALLOCATE( grad_pes ) - IF ( ALLOCATED( k ) ) DEALLOCATE( k ) - IF ( ALLOCATED( mass ) ) DEALLOCATE( mass ) - IF ( ALLOCATED( elastic_grad ) ) DEALLOCATE( elastic_grad ) - IF ( ALLOCATED( tangent ) ) DEALLOCATE( tangent ) - IF ( ALLOCATED( error ) ) DEALLOCATE( error ) - IF ( ALLOCATED( climbing ) ) DEALLOCATE( climbing ) - IF ( ALLOCATED( frozen ) ) DEALLOCATE( frozen ) - IF ( ALLOCATED( lang ) ) DEALLOCATE( lang ) - ! - END SUBROUTINE path_deallocation - ! -END MODULE path_variables diff --git a/quantum_espresso/kcp/Modules/paw_variables.f90 b/quantum_espresso/kcp/Modules/paw_variables.f90 deleted file mode 100644 index 0dc7b0ded..000000000 --- a/quantum_espresso/kcp/Modules/paw_variables.f90 +++ /dev/null @@ -1,72 +0,0 @@ -MODULE paw_variables - ! - USE kinds, ONLY : DP - ! - IMPLICIT NONE - PUBLIC - SAVE - - !!!!!!!!!!!!!!!!!!!!!!!! - !!!! Control flags: !!!! - - ! Set to true after initialization, to prevent double allocs: - LOGICAL :: paw_is_init = .false. - ! Analogous to okvan in "uspp_param" (Modules/uspp.f90) - LOGICAL :: & - okpaw = .FALSE. ! if .TRUE. at least one pseudo is PAW - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!!! Pseudopotential data: !!!! - - ! There is (almost) no pseudopotential data here, it is all stored in the upf type. - ! See files pseudo_types.f90 and read_uspp.f90 - - ! Constant to be added to etot to get all-electron energy - REAL(DP) :: total_core_energy = 0._dp - ! true if all the pseudopotentials are PAW - LOGICAL :: only_paw - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!!! Initialization data: !!!! - - INTEGER,PARAMETER :: lm_fact = 3 ! To converge E_xc integrate up to LM = lm_fact * lm_max - INTEGER,PARAMETER :: lm_fact_x = 3 ! As above, for gradient corrected functionals - INTEGER,PARAMETER :: xlm = 2 ! Additional factor to add to have a good grad.corr. - INTEGER,PARAMETER :: radial_grad_style = 0 ! = 0 or 1, algorithm to use for d/dr - - TYPE paw_radial_integrator - ! the following variables are used to integrate radial sampling - INTEGER :: lmax ! max l component that can be integrated correctly - INTEGER :: ladd ! additional l max that have been added for grad.corr. - INTEGER :: lm_max ! as above, but +1 and squared - INTEGER :: nx ! number of integration directions - REAL(DP),POINTER :: ww(:) ! integration weights (one per direction) - REAL(DP),POINTER :: ylm(:,:) ! Y_lm(nx,lm_max) - REAL(DP),POINTER :: wwylm(:,:) ! ww(nx) * Y_lm(nx,lm_max) - ! additional variables for gradient correction - REAL(DP),POINTER :: dylmt(:,:),&! |d(ylm)/dtheta|**2 - dylmp(:,:) ! |d(ylm)/dphi|**2 - REAL(DP),POINTER :: cotg_th(:) ! cos(theta)/sin(theta) (for divergence) - END TYPE - TYPE(paw_radial_integrator), ALLOCATABLE :: & - rad(:) ! information to integrate different atomic species - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!!! self-consistent variables: !!!! - - ! This type contains some useful data that has to be passed to all - ! functions, but cannot stay in global variables for parallel: - TYPE paw_info - INTEGER :: a ! atom index - INTEGER :: t ! atom type index = itype(a) - INTEGER :: m ! atom mesh = g(t)%mesh - INTEGER :: b ! number of beta functions = upf(t)%nbeta - INTEGER :: l ! max angular index l+1 -> (l+1)**2 is max - ! lm index, it is used to allocate rho - END TYPE - - ! Analogous to deeq in "uspp_param" (Modules/uspp.f90) - REAL(DP), ALLOCATABLE :: & - ddd_paw(:,:,:) ! D: D^1_{ij} - \tilde{D}^1_{ij} (only Hxc part) - - END MODULE paw_variables diff --git a/quantum_espresso/kcp/Modules/printout_base.f90 b/quantum_espresso/kcp/Modules/printout_base.f90 deleted file mode 100644 index ab26b360b..000000000 --- a/quantum_espresso/kcp/Modules/printout_base.f90 +++ /dev/null @@ -1,353 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -! This module contains subroutines to print computed quantities to -! standard output and ASCII file - -MODULE printout_base - - IMPLICIT NONE - SAVE - - CHARACTER(LEN=75) :: title - ! ... title of the simulation - - CHARACTER(LEN=256) :: fort_unit(30:45) - ! ... fort_unit = fortran units for saving physical quantity - - CHARACTER(LEN=256) :: pprefix - ! ... prefix combined with the output path - -CONTAINS - - - SUBROUTINE printout_base_init( outdir, prefix ) - - USE io_global, ONLY: ionode, ionode_id - USE mp_global, ONLY: intra_image_comm -! KNK_nimage -! USE mp_global, ONLY: my_image_id - USE mp, ONLY: mp_bcast - - INTEGER :: iunit, ierr - CHARACTER(LEN=*), INTENT(IN) :: outdir - CHARACTER(LEN=*), INTENT(IN) :: prefix - ! KNK_nimage - ! CHARACTER(LEN=6), EXTERNAL :: int_to_char - - - IF( prefix /= ' ' ) THEN - pprefix = TRIM( prefix ) - ELSE - pprefix = 'fpmd' - END IF - ! KNK_nimage - ! if (my_image_id > 0) pprefix = TRIM(pprefix) // '_' // TRIM(int_to_char( my_image_id )) -! - IF( outdir /= ' ' ) THEN - pprefix = TRIM( outdir ) // '/' // TRIM( pprefix ) - END IF - - ierr = 0 - - IF( ionode ) THEN - fort_unit(30) = trim(pprefix)//'.con' - fort_unit(31) = trim(pprefix)//'.eig' - fort_unit(32) = trim(pprefix)//'.pol' - fort_unit(33) = trim(pprefix)//'.evp' - fort_unit(34) = trim(pprefix)//'.vel' - fort_unit(35) = trim(pprefix)//'.pos' - fort_unit(36) = trim(pprefix)//'.cel' - fort_unit(37) = trim(pprefix)//'.for' - fort_unit(38) = trim(pprefix)//'.str' - fort_unit(39) = trim(pprefix)//'.nos' - fort_unit(40) = trim(pprefix)//'.the' - fort_unit(41) = trim(pprefix)//'.spr' ! wannier spread - fort_unit(42) = trim(pprefix)//'.wfc' ! wannier function - fort_unit(43) = trim(pprefix)//'.ham' ! norm of the ham matrices - fort_unit(44) = trim(pprefix)//'.sha' ! self-hartree !added:giovanni - fort_unit(45) = trim(pprefix)//'.ovp' ! manifold overlap !added:giovanni - ! - DO iunit = LBOUND( fort_unit, 1 ), UBOUND( fort_unit, 1 ) - IF(iunit.le.43) THEN - OPEN(UNIT=iunit, FILE=fort_unit(iunit), & - STATUS='unknown', POSITION='append', IOSTAT = ierr ) - CLOSE( iunit ) - ELSE - OPEN(UNIT=iunit, FILE=fort_unit(iunit), & - STATUS='unknown', ACCESS='sequential', ACTION='write', IOSTAT = ierr ) - CLOSE( iunit ) - ENDIF - END DO - END IF - - CALL mp_bcast(ierr, ionode_id, intra_image_comm) - IF( ierr /= 0 ) & - CALL errore(' printout_base_init ',' error in opening unit, check outdir ',iunit) - - RETURN - END SUBROUTINE printout_base_init - - - SUBROUTINE printout_base_open( suffix ) - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: suffix - INTEGER :: iunit - LOGICAL :: ok - ! ... Open units 30, 31, ... 42 for simulation output - IF( PRESENT( suffix ) ) THEN - IF( LEN( suffix ) /= 3 ) & - CALL errore(" printout_base_open ", " wrong suffix ", 1 ) - ok = .false. - END IF - DO iunit = LBOUND( fort_unit, 1 ), UBOUND( fort_unit, 1 ) - IF( PRESENT( suffix ) ) THEN - IF( index( fort_unit(iunit), suffix, back=.TRUE. ) == ( len_trim( fort_unit(iunit) ) - 2 ) ) THEN - OPEN( UNIT=iunit, FILE=fort_unit(iunit), STATUS='unknown', POSITION='append') - ok = .true. - END IF - ELSE - OPEN( UNIT=iunit, FILE=fort_unit(iunit), STATUS='unknown', POSITION='append') - END IF - END DO - IF( PRESENT( suffix ) ) THEN - IF( .NOT. ok ) & - CALL errore(" printout_base_open ", " file with suffix "//suffix//" not found ", 1 ) - END IF - RETURN - END SUBROUTINE printout_base_open - - - FUNCTION printout_base_unit( suffix ) - ! return the unit corresponding to a given suffix - CHARACTER(LEN=*), INTENT(IN) :: suffix - INTEGER :: printout_base_unit - INTEGER :: iunit - LOGICAL :: ok - IF( LEN( suffix ) /= 3 ) & - CALL errore(" printout_base_unit ", " wrong suffix ", 1 ) - ok = .false. - DO iunit = LBOUND( fort_unit, 1 ), UBOUND( fort_unit, 1 ) - IF( index( fort_unit(iunit), suffix, back=.TRUE. ) == ( len_trim( fort_unit(iunit) ) - 2 ) ) THEN - printout_base_unit = iunit - ok = .true. - END IF - END DO - IF( .NOT. ok ) & - CALL errore(" printout_base_unit ", " file with suffix "//suffix//" not found ", 1 ) - RETURN - END FUNCTION printout_base_unit - - - FUNCTION printout_base_name( suffix ) - ! return the full name of a print out file with a given suffix - CHARACTER(LEN=*), INTENT(IN) :: suffix - CHARACTER(LEN=256) :: printout_base_name - INTEGER :: iunit - LOGICAL :: ok - IF( LEN( suffix ) /= 3 ) & - CALL errore(" printout_base_name ", " wrong suffix ", 1 ) - ok = .false. - DO iunit = LBOUND( fort_unit, 1 ), UBOUND( fort_unit, 1 ) - IF( index( fort_unit(iunit), suffix, back=.TRUE. ) == ( len_trim( fort_unit(iunit) ) - 2 ) ) THEN - printout_base_name = fort_unit(iunit) - ok = .true. - END IF - END DO - IF( .NOT. ok ) & - CALL errore(" printout_base_name ", " file with suffix "//suffix//" not found ", 1 ) - RETURN - END FUNCTION printout_base_name - - - - SUBROUTINE printout_base_close( suffix ) - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: suffix - INTEGER :: iunit - LOGICAL :: topen - LOGICAL :: ok - ! ... Close and flush unit 30, ... 42 - IF( PRESENT( suffix ) ) THEN - IF( LEN( suffix ) /= 3 ) & - CALL errore(" printout_base_close ", " wrong suffix ", 1 ) - ok = .false. - END IF - DO iunit = LBOUND( fort_unit, 1 ), UBOUND( fort_unit, 1 ) - IF( PRESENT( suffix ) ) THEN - IF( index( fort_unit(iunit), suffix, back=.TRUE. ) == ( len_trim( fort_unit(iunit) ) - 2 ) ) THEN - INQUIRE( UNIT=iunit, OPENED=topen ) - IF( topen ) CLOSE(iunit) - ok = .true. - END IF - ELSE - INQUIRE( UNIT=iunit, OPENED=topen ) - IF (topen) CLOSE(iunit) - END IF - END DO - IF( PRESENT( suffix ) ) THEN - IF( .NOT. ok ) & - CALL errore(" printout_base_close ", " file with suffix "//suffix//" not found ", 1 ) - END IF - RETURN - END SUBROUTINE printout_base_close - - - SUBROUTINE printout_pos( iunit, tau, nat, what, nfi, tps, label, fact, sort, head ) - ! - USE kinds - ! - INTEGER, INTENT(IN) :: iunit, nat - REAL(DP), INTENT(IN) :: tau( :, : ) - CHARACTER(LEN=3), INTENT(IN), OPTIONAL :: what - INTEGER, INTENT(IN), OPTIONAL :: nfi - REAL(DP), INTENT(IN), OPTIONAL :: tps - CHARACTER(LEN=3), INTENT(IN), OPTIONAL :: label( : ) - REAL(DP), INTENT(IN), OPTIONAL :: fact - INTEGER, INTENT(IN), OPTIONAL :: sort( : ) - CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: head - ! - INTEGER :: ia, k - REAL(DP) :: f - ! - IF( PRESENT( fact ) ) THEN - f = fact - ELSE - f = 1.0_DP - END IF - ! - IF( PRESENT( head ) ) THEN - WRITE( iunit, 10 ) head - END IF - ! - IF( PRESENT( what ) ) THEN - IF ( what == 'xyz' ) WRITE( iunit, *) nat - END IF - ! - IF( PRESENT( nfi ) .AND. PRESENT( tps ) ) THEN - WRITE( iunit, 30 ) nfi, tps - ELSE IF( PRESENT( what ) ) THEN - IF( what == 'pos' ) THEN - WRITE( iunit, 40 ) - ELSE IF( what == 'vel' ) THEN - WRITE( iunit, 50 ) - ELSE IF( what == 'for' ) THEN - WRITE( iunit, 60 ) - END IF - END IF - ! - IF( PRESENT( label ) ) THEN - IF( PRESENT( sort ) ) THEN - DO ia = 1, nat - WRITE( iunit, 255 ) label( sort(ia) ), ( f * tau(k, sort(ia) ),k = 1,3) - END DO - ELSE - DO ia = 1, nat - WRITE( iunit, 255 ) label(ia), ( f * tau(k,ia),k = 1,3) - END DO - END IF - ELSE - DO ia = 1, nat - WRITE( iunit, 252 ) (tau(k,ia),k = 1,3) - END DO - END IF - 10 FORMAT(3X,A) - 30 FORMAT(I7,1X,ES18.8) - 40 FORMAT(3X,'ATOMIC_POSITIONS') - 50 FORMAT(3X,'ATOMIC_VELOCITIES') - 60 FORMAT(3X,'Forces acting on atoms (au):') -255 FORMAT(3X,A3,3ES14.6) -252 FORMAT(3ES14.6) - RETURN - END SUBROUTINE printout_pos - - - - SUBROUTINE printout_cell( iunit, h, nfi, tps ) - ! - USE kinds - ! - INTEGER, INTENT(IN) :: iunit - REAL(DP), INTENT(IN) :: h(3,3) - INTEGER, INTENT(IN), OPTIONAL :: nfi - REAL(DP), INTENT(IN), OPTIONAL :: tps - ! - INTEGER :: i, j - ! - IF( PRESENT( nfi ) .AND. PRESENT( tps ) ) THEN - WRITE( iunit, 30 ) nfi, tps - ELSE - WRITE( iunit, 40 ) - END IF - ! - DO i = 1, 3 - WRITE( iunit, 100 ) (h(i,j),j=1,3) - END DO - ! - 30 FORMAT(I7,1X,ES18.8) - 40 FORMAT(3X,'CELL_PARAMETERS') -100 FORMAT(3ES18.8) - RETURN - END SUBROUTINE printout_cell - - - - SUBROUTINE printout_stress( iunit, str, nfi, tps ) - ! - USE kinds - ! - INTEGER, INTENT(IN) :: iunit - REAL(DP), INTENT(IN) :: str(3,3) - INTEGER, INTENT(IN), OPTIONAL :: nfi - REAL(DP), INTENT(IN), OPTIONAL :: tps - ! - INTEGER :: i, j - ! - IF( PRESENT( nfi ) .AND. PRESENT( tps ) ) THEN - WRITE( iunit, 30 ) nfi, tps - ELSE - WRITE( iunit, 40 ) - END IF - ! - DO i = 1, 3 - WRITE( iunit, 100 ) (str(i,j),j=1,3) - END DO - ! - 30 FORMAT(I7,1X,ES18.8) - 40 FORMAT(3X,'Total stress (GPa)') -100 FORMAT(3(ES18.8,1X)) - RETURN - END SUBROUTINE printout_stress - - - SUBROUTINE printout_matrix_norm( iunit, matrix_h, matrix_ah, nfi, tps ) - ! - ! matrix_h: norm of the hermitean part of matrix - ! matrix_ah: norm of the anti-hermitean part of matrix - ! - USE kinds - ! - INTEGER, INTENT(IN) :: iunit - REAL(DP), INTENT(IN) :: matrix_h, matrix_ah - INTEGER, INTENT(IN) :: nfi - REAL(DP), INTENT(IN), OPTIONAL :: tps - ! - INTEGER :: i, j - ! - IF( PRESENT( tps ) ) THEN - WRITE( iunit, 30 ) nfi, tps, matrix_h, matrix_ah - ELSE - WRITE( iunit, 40 ) nfi, matrix_h, matrix_ah - END IF - ! - 30 FORMAT(I7,1X,ES18.8,1X,2ES22.12) - 40 FORMAT(3X,I7,1X,2ES22.12) -100 FORMAT(3ES18.8) - RETURN - END SUBROUTINE printout_matrix_norm - - -END MODULE printout_base diff --git a/quantum_espresso/kcp/Modules/pseudo_types.f90 b/quantum_espresso/kcp/Modules/pseudo_types.f90 deleted file mode 100644 index fbae80b4a..000000000 --- a/quantum_espresso/kcp/Modules/pseudo_types.f90 +++ /dev/null @@ -1,282 +0,0 @@ -! -! Copyright (C) 2002-2008 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - MODULE pseudo_types - -! this module contains the definitions of several TYPE structures, -! together with their allocation/deallocation routines - - USE kinds, ONLY: DP - use radial_grids, ONLY: radial_grid_type - - IMPLICIT NONE - SAVE - ! - ! Additional data to make a PAW setup out of an US pseudo, - ! they are all stored on a radial grid: - TYPE paw_in_upf - REAL(DP),POINTER :: ae_rho_atc(:) ! AE core charge (pseudo ccharge - ! is already included in upf) - REAL(DP),POINTER :: pfunc(:,:,:),&! Psi_i(r)*Psi_j(r) - ptfunc(:,:,:) ! as above, but for pseudo - REAL(DP),POINTER :: ae_vloc(:) ! AE local potential (pseudo vloc - ! is already included in upf) - REAL(DP),POINTER :: oc(:) ! starting occupation used to init becsum - ! they differ from US ones because they - ! are indexed on BETA functions, non on WFC - REAL(DP),POINTER :: augmom(:,:,:) ! multipole AE-pseudo (i,j,l=0:2*lmax) - REAL(DP) :: raug ! augfunction max radius - INTEGER :: iraug ! index on rgrid closer to, and >, raug - INTEGER :: lmax_aug ! max angmom of augmentation functions, it is == - ! to 2* max{l of pseudized wavefunctions} - ! note that nqlc of upf also includes the angmom of - ! empty virtual channel used to generate local potential - REAL(DP) :: core_energy ! constant to add in order to get all-electron energy - CHARACTER(len=12):: augshape ! shape of augmentation charge - END TYPE paw_in_upf - - - TYPE pseudo_upf - CHARACTER(LEN=80):: generated='' ! generator software - CHARACTER(LEN=80):: author='' ! pseudopotential's author - CHARACTER(LEN=80):: date='' ! generation date - CHARACTER(LEN=80):: comment='' ! author's comment - CHARACTER(LEN=2) :: psd='' ! Element label - CHARACTER(LEN=20) :: typ='' ! Pseudo type ( NC or US or PAW) - CHARACTER(len=6) :: rel='' ! relativistic: {no|scalar|full} - LOGICAL :: tvanp ! .true. if Ultrasoft - LOGICAL :: tcoulombp ! .true. if Coulomb 1/r potential - LOGICAL :: nlcc ! Non linear core corrections - CHARACTER(LEN=20) :: dft ! Exch-Corr type - REAL(DP) :: zp ! z valence - REAL(DP) :: etotps ! total energy - REAL(DP) :: ecutwfc ! suggested cut-off for wfc - REAL(DP) :: ecutrho ! suggested cut-off for rho - ! - CHARACTER(len=11) :: nv ! UPF file three-digit version i.e. 2.0.0 - INTEGER :: lmax ! maximum l component in beta - INTEGER :: lmax_rho ! max l componet in charge (should be 2*lmax) - ! Wavefunctions and projectors - INTEGER :: nwfc ! number of atomic wavefunctions - INTEGER :: nbeta ! number of projectors - INTEGER, POINTER :: kbeta(:) ! kbeta(nbeta) see below - INTEGER :: kkbeta ! kkbeta=max(kbeta(:)) - ! kbeta<=mesh is the number of grid points for each beta function - ! beta(r,nb) = 0 for r > r(kbeta(nb)) - ! kkbeta<=mesh is the largest of such number so that for all beta - ! beta(r,nb) = 0 for r > r(kkbeta) - ! - INTEGER, POINTER :: lll(:) ! lll(nbeta) l of each projector - REAL(DP), POINTER :: beta(:,:) ! beta(mesh,nbeta) projectors - ! - CHARACTER(LEN=2), POINTER :: els(:) ! els(nwfc) label of wfc - CHARACTER(LEN=2), POINTER :: els_beta(:) ! els(nbeta) label of beta - INTEGER, POINTER :: nchi(:) ! lchi(nwfc) value of pseudo-n for wavefcts - INTEGER, POINTER :: lchi(:) ! lchi(nwfc) value of l for wavefcts - REAL(DP), POINTER :: oc(:) ! oc(nwfc) occupancies for wavefcts - REAL(DP), POINTER :: epseu(:) ! pseudo one-particle energy (nwfc) - REAL(DP), POINTER :: rcut_chi(:)! rcut_chi(nwfc) cutoff innner radius - REAL(DP), POINTER :: rcutus_chi(:)! rcutus_chi(nwfc) ultrasoft outer radius - ! Chi and rho_at are only used for initial density and initial wfcs: - REAL(DP), POINTER :: chi(:,:) ! chi(mesh,nwfc) atomic wavefcts - REAL(DP), POINTER :: rho_at(:) ! rho_at(mesh) atomic charge - ! Minimal radial grid: - INTEGER :: mesh ! number of points in the radial mesh - REAL(DP) :: xmin ! the minimum x of the linear mesh - REAL(DP) :: rmax ! the maximum radius of the mesh - REAL(DP) :: zmesh ! the nuclear charge used for mesh - REAL(DP) :: dx ! the deltax of the linear mesh - REAL(DP), POINTER :: r(:) ! r(mesh) radial grid - REAL(DP), POINTER :: rab(:) ! rab(mesh) dr(x)/dx (x=linear grid) - ! Pseudized core charge - REAL(DP), POINTER :: rho_atc(:) ! rho_atc(mesh) atomic core charge - ! Local potential - INTEGER :: lloc ! L of channel used to generate local potential - ! (if < 0 it was generated by smoothing AE potential) - REAL(DP) :: rcloc ! vloc = v_ae for r > rcloc - REAL(DP), POINTER :: vloc(:) ! vloc(mesh) local atomic potential - ! - REAL(DP), POINTER :: dion(:,:) ! dion(nbeta,nbeta) atomic D_{mu,nu} - ! Augmentation - LOGICAL :: q_with_l ! if .true. qfunc is pseudized in - ! different ways for different l - INTEGER :: nqf ! number of Q coefficients - INTEGER :: nqlc ! number of angular momenta in Q - REAL(DP):: qqq_eps ! qfunc is null if its norm is .lt. qqq_eps - REAL(DP), POINTER :: rinner(:) ! rinner(0:2*lmax) r_L - REAL(DP), POINTER :: qqq(:,:) ! qqq(nbeta,nbeta) q_{mu,nu} - ! Augmentation without L dependecy - REAL(DP), POINTER :: qfunc(:,:) ! qfunc(mesh,nbeta*(nbeta+1)/2) - ! Q_{mu,nu}(|r|) function for |r|> r_L - ! Augmentation depending on L (optional, compulsory for PAW) - REAL(DP), POINTER :: qfuncl(:,:,:)! qfuncl(mesh,nbeta*(nbeta+1)/2,l) - ! Q_{mu,nu}(|r|) function for |r|> r_L - ! Analitycal coeffs cor small r expansion of qfunc (Vanderbilt's code) - REAL(DP), POINTER :: qfcoef(:,:,:,:) ! qfcoef(nqf,0:2*lmax,nbeta,nbeta) - ! coefficients for Q for |r| 0 ) THEN - ! - np = desc( la_npr_ ) * desc( la_npc_ ) - nx = desc( nlax_ ) - npr = desc( la_npr_ ) - npc = desc( la_npc_ ) - ! - IF( desc( la_myr_ ) == 0 .AND. desc( la_myc_ ) == 0 ) THEN - ALLOCATE( buf( nx, nx * np ) ) - ELSE - ALLOCATE( buf( 1, 1 ) ) - END IF - ! - IF( lda /= nx ) & - CALL errore( " dsqmcll ", " inconsistent dimension lda ", lda ) - ! - IF( desc( la_n_ ) /= n ) & - CALL errore( " dsqmcll ", " inconsistent dimension n ", n ) - ! - CALL mpi_gather( a, nx*nx, mpi_double_precision, & - buf, nx*nx, mpi_double_precision, 0, desc( la_comm_ ) , ierr ) - ! - IF( ierr /= 0 ) & - CALL errore( " dsqmcll ", " in gather ", ABS( ierr ) ) - ! - IF( desc( la_myr_ ) == 0 .AND. desc( la_myc_ ) == 0 ) THEN - DO ipc = 1, npc - CALL descla_local_dims( ic, nc, n, desc( la_nx_ ), npc, ipc-1 ) - DO ipr = 1, npr - CALL descla_local_dims( ir, nr, n, desc( la_nx_ ), npr, ipr-1 ) - noff = ( ipc - 1 + npc * ( ipr - 1 ) ) * nx - DO j = 1, nc - DO i = 1, nr - ar( i + ir - 1, j + ic - 1 ) = buf( i, j + noff ) - END DO - END DO - END DO - END DO - END IF - ! - DEALLOCATE( buf ) - ! - END IF - ! - CALL mpi_bcast( ar, ldar * n, mpi_double_precision, 0, comm, ierr ) - ! - IF( ierr /= 0 ) & - CALL errore( " dsqmcll ", " in bcast ", ABS( ierr ) ) - -#else - - DO j = 1, n - DO i = 1, n - ar( i, j ) = a( i, j ) - END DO - END DO - -#endif - - RETURN -END SUBROUTINE dsqmcll - - -SUBROUTINE zsqmcll( n, a, lda, ar, ldar, desc, comm ) - ! - ! double complex (Z) SQuare Matrix CoLLect - ! This sub. take a distributed square matrix "a" and collect - ! the block assigned to processors into a replicated matrix "ar", - ! matrix is distributed as described by descriptor desc - ! - USE kinds - USE descriptors - ! - implicit none - ! - INTEGER, INTENT(IN) :: n - INTEGER, INTENT(IN) :: ldar - COMPLEX(DP) :: ar(ldar,*) ! matrix to be merged, replicated on all proc - INTEGER, INTENT(IN) :: lda - COMPLEX(DP) :: a(lda,*) - INTEGER, INTENT(IN) :: desc( descla_siz_ ) - INTEGER, INTENT(IN) :: comm - ! - INTEGER :: i, j - -#if defined __MPI - ! - INTEGER :: np, nx, ipc, ipr, npr, npc, noff - INTEGER :: ierr, ir, ic, nr, nc - - COMPLEX(DP), ALLOCATABLE :: buf(:,:) - ! - IF( desc( lambda_node_ ) > 0 ) THEN - ! - np = desc( la_npr_ ) * desc( la_npc_ ) - nx = desc( nlax_ ) - npr = desc( la_npr_ ) - npc = desc( la_npc_ ) - ! - IF( desc( la_myr_ ) == 0 .AND. desc( la_myc_ ) == 0 ) THEN - ALLOCATE( buf( nx, nx * np ) ) - ELSE - ALLOCATE( buf( 1, 1 ) ) - END IF - ! - IF( lda /= nx ) & - CALL errore( " zsqmcll ", " inconsistent dimension lda ", lda ) - ! - IF( desc( la_n_ ) /= n ) & - CALL errore( " zsqmcll ", " inconsistent dimension n ", n ) - ! - CALL mpi_gather( a, nx*nx, mpi_double_complex, & - buf, nx*nx, mpi_double_complex, 0, desc( la_comm_ ) , ierr ) - ! - IF( ierr /= 0 ) & - CALL errore( " zsqmcll ", " in gather ", ABS( ierr ) ) - ! - IF( desc( la_myr_ ) == 0 .AND. desc( la_myc_ ) == 0 ) THEN - DO ipc = 1, npc - CALL descla_local_dims( ic, nc, n, desc( la_nx_ ), npc, ipc-1 ) - DO ipr = 1, npr - CALL descla_local_dims( ir, nr, n, desc( la_nx_ ), npr, ipr-1 ) - noff = ( ipc - 1 + npc * ( ipr - 1 ) ) * nx - DO j = 1, nc - DO i = 1, nr - ar( i + ir - 1, j + ic - 1 ) = buf( i, j + noff ) - END DO - END DO - END DO - END DO - END IF - ! - DEALLOCATE( buf ) - ! - END IF - ! - CALL mpi_bcast( ar, ldar * n, mpi_double_complex, 0, comm, ierr ) - ! - IF( ierr /= 0 ) & - CALL errore( " zsqmcll ", " in bcast ", ABS( ierr ) ) - -#else - - DO j = 1, n - DO i = 1, n - ar( i, j ) = a( i, j ) - END DO - END DO - -#endif - - RETURN -END SUBROUTINE zsqmcll - - -! --------------------------------------------------------------------------------- - -SUBROUTINE dsqmwpb( n, a, lda, desc ) - ! - ! Double precision SQuare Matrix WiPe Border subroutine - ! - USE kinds - USE descriptors - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: n - INTEGER, INTENT(IN) :: lda - REAL(DP) :: a(lda,*) ! matrix to be redistributed into b - INTEGER, INTENT(IN) :: desc( descla_siz_ ) - ! - INTEGER :: i, j - ! - DO j = 1, desc( nlac_ ) - DO i = desc( nlar_ ) + 1, desc( nlax_ ) - a( i, j ) = 0_DP - END DO - END DO - DO j = desc( nlac_ ) + 1, desc( nlax_ ) - DO i = 1, desc( nlax_ ) - a( i, j ) = 0_DP - END DO - END DO - ! - RETURN -END SUBROUTINE dsqmwpb - -! --------------------------------------------------------------------------------- - -SUBROUTINE dsqmsym( n, a, lda, desc ) - ! - ! Double precision SQuare Matrix SYMmetrization - ! - USE kinds - USE descriptors - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: n - INTEGER, INTENT(IN) :: lda - REAL(DP) :: a(lda,*) - INTEGER, INTENT(IN) :: desc( descla_siz_ ) -#if defined __MPI - INTEGER :: istatus( MPI_STATUS_SIZE ) -#endif - INTEGER :: i, j - INTEGER :: comm - INTEGER :: nr, nc, dest, sreq, ierr, sour - REAL(DP) :: atmp - -#if defined __MPI - - IF( desc( lambda_node_ ) <= 0 ) THEN - RETURN - END IF - - IF( n /= desc( la_n_ ) ) & - CALL errore( " dsqmsym ", " wrong global dim n ", n ) - IF( lda /= desc( nlax_ ) ) & - CALL errore( " dsqmsym ", " wrong leading dim lda ", lda ) - - comm = desc( la_comm_ ) - - nr = desc( nlar_ ) - nc = desc( nlac_ ) - IF( desc( la_myc_ ) == desc( la_myr_ ) ) THEN - ! - ! diagonal block, procs work locally - ! - DO j = 1, nc - DO i = j + 1, nr - a(i,j) = a(j,i) - END DO - END DO - ! - ELSE IF( desc( la_myc_ ) > desc( la_myr_ ) ) THEN - ! - ! super diagonal block, procs send the block to sub diag. - ! - CALL GRID2D_RANK( 'R', desc( la_npr_ ), desc( la_npc_ ), & - desc( la_myc_ ), desc( la_myr_ ), dest ) - CALL mpi_isend( a, lda*lda, MPI_DOUBLE_PRECISION, dest, 1, comm, sreq, ierr ) - ! - IF( ierr /= 0 ) & - CALL errore( " dsqmsym ", " in isend ", ABS( ierr ) ) - ! - ELSE IF( desc( la_myc_ ) < desc( la_myr_ ) ) THEN - ! - ! sub diagonal block, procs receive the block from super diag, - ! then transpose locally - ! - CALL GRID2D_RANK( 'R', desc( la_npr_ ), desc( la_npc_ ), & - desc( la_myc_ ), desc( la_myr_ ), sour ) - CALL mpi_recv( a, lda*lda, MPI_DOUBLE_PRECISION, sour, 1, comm, istatus, ierr ) - ! - IF( ierr /= 0 ) & - CALL errore( " dsqmsym ", " in recv ", ABS( ierr ) ) - ! - DO j = 1, lda - DO i = j + 1, lda - atmp = a(i,j) - a(i,j) = a(j,i) - a(j,i) = atmp - END DO - END DO - ! - END IF - - IF( desc( la_myc_ ) > desc( la_myr_ ) ) THEN - ! - CALL MPI_Wait( sreq, istatus, ierr ) - ! - IF( ierr /= 0 ) & - CALL errore( " dsqmsym ", " in wait ", ABS( ierr ) ) - ! - END IF - -#else - - DO j = 1, n - ! - DO i = j + 1, n - ! - a(i,j) = a(j,i) - ! - END DO - ! - END DO - -#endif - - RETURN -END SUBROUTINE dsqmsym - - -SUBROUTINE zsqmher( n, a, lda, desc ) - ! - ! double complex (Z) SQuare Matrix HERmitianize - ! - USE kinds - USE descriptors - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: n - INTEGER, INTENT(IN) :: lda - COMPLEX(DP) :: a(lda,lda) - INTEGER, INTENT(IN) :: desc( descla_siz_ ) -#if defined __MPI - INTEGER :: istatus( MPI_STATUS_SIZE ) -#endif - INTEGER :: i, j - INTEGER :: comm, myid - INTEGER :: nr, nc, dest, sreq, ierr, sour - COMPLEX(DP) :: atmp - COMPLEX(DP), ALLOCATABLE :: tst1(:,:) - COMPLEX(DP), ALLOCATABLE :: tst2(:,:) - -#if defined __MPI - - IF( desc( lambda_node_ ) <= 0 ) THEN - RETURN - END IF - - IF( n /= desc( la_n_ ) ) & - CALL errore( " zsqmsym ", " wrong global dim n ", n ) - IF( lda /= desc( nlax_ ) ) & - CALL errore( " zsqmsym ", " wrong leading dim lda ", lda ) - - comm = desc( la_comm_ ) - - nr = desc( nlar_ ) - nc = desc( nlac_ ) - IF( desc( la_myc_ ) == desc( la_myr_ ) ) THEN - ! - ! diagonal block, procs work locally - ! - DO j = 1, nc - a(j,j) = CMPLX( REAL( a(j,j) ), 0_DP ) - DO i = j + 1, nr - a(i,j) = CONJG( a(j,i) ) - END DO - END DO - ! - ELSE IF( desc( la_myc_ ) > desc( la_myr_ ) ) THEN - ! - ! super diagonal block, procs send the block to sub diag. - ! - CALL GRID2D_RANK( 'R', desc( la_npr_ ), desc( la_npc_ ), & - desc( la_myc_ ), desc( la_myr_ ), dest ) - CALL mpi_isend( a, lda*lda, MPI_DOUBLE_COMPLEX, dest, 1, comm, sreq, ierr ) - ! - IF( ierr /= 0 ) & - CALL errore( " zsqmher ", " in mpi_isend ", ABS( ierr ) ) - ! - ELSE IF( desc( la_myc_ ) < desc( la_myr_ ) ) THEN - ! - ! sub diagonal block, procs receive the block from super diag, - ! then transpose locally - ! - CALL GRID2D_RANK( 'R', desc( la_npr_ ), desc( la_npc_ ), & - desc( la_myc_ ), desc( la_myr_ ), sour ) - CALL mpi_recv( a, lda*lda, MPI_DOUBLE_COMPLEX, sour, 1, comm, istatus, ierr ) - ! - IF( ierr /= 0 ) & - CALL errore( " zsqmher ", " in mpi_recv ", ABS( ierr ) ) - ! - DO j = 1, lda - DO i = j + 1, lda - atmp = a(i,j) - a(i,j) = a(j,i) - a(j,i) = atmp - END DO - END DO - DO j = 1, nc - DO i = 1, nr - a(i,j) = CONJG( a(i,j) ) - END DO - END DO - ! - END IF - - IF( desc( la_myc_ ) > desc( la_myr_ ) ) THEN - ! - CALL MPI_Wait( sreq, istatus, ierr ) - ! - IF( ierr /= 0 ) & - CALL errore( " zsqmher ", " in MPI_Wait ", ABS( ierr ) ) - ! - END IF - -#if defined __PIPPO - CALL MPI_Comm_rank( comm, myid, ierr ) - ALLOCATE( tst1( n, n ) ) - ALLOCATE( tst2( n, n ) ) - tst1 = 0.0d0 - tst2 = 0.0d0 - do j = 1, desc( nlac_ ) - do i = 1, desc( nlar_ ) - tst1( i + desc( ilar_ ) - 1, j + desc( ilac_ ) - 1 ) = a( i , j ) - end do - end do - CALL MPI_REDUCE( tst1, tst2, n*n, MPI_DOUBLE_COMPLEX, MPI_SUM, 0, comm, ierr ) - IF( myid == 0 ) THEN - DO j = 1, n - ! - IF( tst2(j,j) /= CMPLX( REAL( tst2(j,j) ), 0_DP ) ) WRITE( 4000, * ) j, tst2(j,j) - ! - DO i = j + 1, n - ! - IF( tst2(i,j) /= CONJG( tst2(j,i) ) ) WRITE( 4000, * ) i,j, tst2(i,j) - ! - END DO - ! - END DO - END IF - - DEALLOCATE( tst1 ) - DEALLOCATE( tst2 ) -#endif - -#else - - DO j = 1, n - ! - a(j,j) = CMPLX( REAL( a(j,j) ), 0_DP ) - ! - DO i = j + 1, n - ! - a(i,j) = CONJG( a(j,i) ) - ! - END DO - ! - END DO - -#endif - - RETURN -END SUBROUTINE zsqmher - - -! --------------------------------------------------------------------------------- - - -SUBROUTINE dsqmred( na, a, lda, desca, nb, b, ldb, descb ) - ! - ! Double precision SQuare Matrix REDistribution - ! - ! Copy a global "na * na" matrix locally stored in "a", - ! and distributed as described by "desca", into a larger - ! global "nb * nb" matrix stored in "b" and distributed - ! as described in "descb". - ! - ! If you want to read, get prepared for an headache! - ! Written struggling by Carlo Cavazzoni. - ! - USE kinds - USE descriptors - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: na - INTEGER, INTENT(IN) :: lda - REAL(DP) :: a(lda,lda) ! matrix to be redistributed into b - INTEGER, INTENT(IN) :: desca( descla_siz_ ) - INTEGER, INTENT(IN) :: nb - INTEGER, INTENT(IN) :: ldb - REAL(DP) :: b(ldb,ldb) - INTEGER, INTENT(IN) :: descb( descla_siz_ ) - - INTEGER :: ipc, ipr, npc, npr - INTEGER :: ipr_old, ir_old, nr_old, irx_old - INTEGER :: ipc_old, ic_old, nc_old, icx_old - INTEGER :: myrow, mycol, ierr, rank - INTEGER :: col_comm, row_comm, comm, sreq - INTEGER :: nr_new, ir_new, irx_new, ir, nr, nrtot, irb, ire - INTEGER :: nc_new, ic_new, icx_new, ic, nc, nctot, icb, ice - INTEGER :: ib, i, j, myid - INTEGER :: nrsnd( desca( la_npr_ ) ) - INTEGER :: ncsnd( desca( la_npr_ ) ) - INTEGER :: displ( desca( la_npr_ ) ) - INTEGER :: irb_new( desca( la_npr_ ) ) - INTEGER :: ire_new( desca( la_npr_ ) ) - INTEGER :: icb_new( desca( la_npr_ ) ) - INTEGER :: ice_new( desca( la_npr_ ) ) - REAL(DP), ALLOCATABLE :: buf(:) - REAL(DP), ALLOCATABLE :: ab(:,:) - REAL(DP), ALLOCATABLE :: tst1(:,:) - REAL(DP), ALLOCATABLE :: tst2(:,:) -#if defined __MPI - INTEGER :: istatus( MPI_STATUS_SIZE ) -#endif - - IF( desca( lambda_node_ ) <= 0 ) THEN - RETURN - END IF - - ! preliminary consistency checks - - IF( nb < na ) & - CALL errore( " dsqmred ", " nb < na, this sub. work only with nb >= na ", nb ) - IF( nb /= descb( la_n_ ) ) & - CALL errore( " dsqmred ", " wrong global dim nb ", nb ) - IF( na /= desca( la_n_ ) ) & - CALL errore( " dsqmred ", " wrong global dim na ", na ) - IF( ldb /= descb( nlax_ ) ) & - CALL errore( " dsqmred ", " wrong leading dim ldb ", ldb ) - IF( lda /= desca( nlax_ ) ) & - CALL errore( " dsqmred ", " wrong leading dim lda ", lda ) - - npr = desca( la_npr_ ) - myrow = desca( la_myr_ ) - npc = desca( la_npc_ ) - mycol = desca( la_myc_ ) - comm = desca( la_comm_ ) - -#if defined __MPI - - ! split communicator into row and col communicators - - CALL MPI_Comm_rank( comm, myid, ierr ) - IF( ierr /= 0 ) & - CALL errore( " dsqmred ", " in MPI_Comm_rank 1 ", ABS( ierr ) ) - - CALL MPI_Comm_split( comm, mycol, myrow, col_comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " dsqmred ", " in MPI_Comm_split 1 ", ABS( ierr ) ) - - CALL MPI_Comm_split( comm, myrow, mycol, row_comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " dsqmred ", " in MPI_Comm_split 2 ", ABS( ierr ) ) - - CALL MPI_Comm_rank( col_comm, rank, ierr ) - IF( ierr /= 0 ) & - CALL errore( " dsqmred ", " in MPI_Comm_rank 2 ", ABS( ierr ) ) - IF( rank /= myrow ) & - CALL errore( " dsqmred ", " building col_comm ", rank ) - - CALL MPI_Comm_rank( row_comm, rank, ierr ) - IF( ierr /= 0 ) & - CALL errore( " dsqmred ", " in MPI_Comm_rank 3 ", ABS( ierr ) ) - IF( rank /= mycol ) & - CALL errore( " dsqmred ", " building row_comm ", rank ) - - ALLOCATE( buf( descb( nlax_ ) * descb( nlax_ ) ) ) - ALLOCATE( ab( descb( nlax_ ), desca( nlax_ ) ) ) - - ! write( 3000 + myid, * ) 'na, nb = ', na, nb - - DO j = 1, descb( nlac_ ) - DO i = 1, descb( nlar_ ) - b( i, j ) = 0.0d0 - END DO - END DO - - ab = 0.0d0 - - ! first redistribute rows, column groups work in parallel - - DO ipr = 1, npr - ! - CALL descla_local_dims( ir_new, nr_new, nb, descb( la_nx_ ), npr, ipr-1 ) - ! - irx_new = ir_new + nr_new - 1 - - ! write( 3000 + myid, * ) 'ir_new, nr_new, irx_new = ', ir_new, nr_new, irx_new - ! - DO ipr_old = 1, npr - ! - CALL descla_local_dims( ir_old, nr_old, na, desca( la_nx_ ), npr, ipr_old-1 ) - ! - irx_old = ir_old + nr_old - 1 - ! - ! write( 3000 + myid, * ) 'ir_old, nr_old, irx_old = ', ir_old, nr_old, irx_old - ! - IF( ir_old >= ir_new .AND. ir_old <= irx_new ) THEN - ! - nrsnd( ipr_old ) = MIN( nr_old, irx_new - ir_old + 1 ) - irb = 1 - ire = nrsnd( ipr_old ) - irb_new( ipr_old ) = ir_old - ir_new + 1 - ire_new( ipr_old ) = irb_new( ipr_old ) + nrsnd( ipr_old ) - 1 - ! - ELSE IF( ir_new >= ir_old .AND. ir_new <= irx_old ) THEN - ! - nrsnd( ipr_old ) = irx_old - ir_new + 1 - irb = ir_new - ir_old + 1 - ire = nr_old - irb_new( ipr_old ) = 1 - ire_new( ipr_old ) = nrsnd( ipr_old ) - ! - ELSE - nrsnd( ipr_old ) = 0 - irb = 0 - ire = 0 - irb_new( ipr_old ) = 0 - ire_new( ipr_old ) = 0 - END IF - ! - ! write( 3000 + myid, * ) 'ipr_old, nrsnd = ', ipr_old, nrsnd( ipr_old ) - ! write( 3000 + myid, * ) 'ipr_old, irb, ire = ', ipr_old, irb, ire - ! write( 3000 + myid, * ) 'ipr_old, irb_new, ire_new = ', ipr_old, irb_new( ipr_old ), ire_new( ipr_old ) - ! - IF( ( myrow == ipr_old - 1 ) .AND. ( nrsnd( ipr_old ) > 0 ) ) THEN - IF( myrow /= ipr - 1 ) THEN - ib = 0 - DO j = 1, desca( nlac_ ) - DO i = irb, ire - ib = ib + 1 - buf( ib ) = a( i, j ) - END DO - END DO - CALL mpi_isend( buf, ib, MPI_DOUBLE_PRECISION, ipr-1, ipr, col_comm, sreq, ierr ) - IF( ierr /= 0 ) & - CALL errore( " dsqmred ", " in mpi_isend ", ABS( ierr ) ) - ELSE - DO j = 1, desca( nlac_ ) - ib = irb - DO i = irb_new( ipr_old ), ire_new( ipr_old ) - ab( i, j ) = a( ib, j ) - ib = ib + 1 - END DO - END DO - END IF - END IF - ! - IF( nrsnd( ipr_old ) /= ire - irb + 1 ) & - CALL errore( " dsqmred ", " somthing wrong with row 1 ", nrsnd( ipr_old ) ) - IF( nrsnd( ipr_old ) /= ire_new( ipr_old ) - irb_new( ipr_old ) + 1 ) & - CALL errore( " dsqmred ", " somthing wrong with row 2 ", nrsnd( ipr_old ) ) - ! - nrsnd( ipr_old ) = nrsnd( ipr_old ) * desca( nlac_ ) - ! - END DO - ! - IF( myrow == ipr - 1 ) THEN - DO ipr_old = 1, npr - IF( nrsnd( ipr_old ) > 0 ) THEN - IF( myrow /= ipr_old - 1 ) THEN - CALL mpi_recv( buf, nrsnd(ipr_old), MPI_DOUBLE_PRECISION, ipr_old-1, ipr, col_comm, istatus, ierr ) - IF( ierr /= 0 ) & - CALL errore( " dsqmred ", " in mpi_recv ", ABS( ierr ) ) - CALL mpi_get_count( istatus, MPI_DOUBLE_PRECISION, ib, ierr) - IF( ierr /= 0 ) & - CALL errore( " dsqmred ", " in mpi_get_count ", ABS( ierr ) ) - IF( ib /= nrsnd(ipr_old) ) & - CALL errore( " dsqmred ", " somthing wrong with row 3 ", ib ) - ib = 0 - DO j = 1, desca( nlac_ ) - DO i = irb_new( ipr_old ), ire_new( ipr_old ) - ib = ib + 1 - ab( i, j ) = buf( ib ) - END DO - END DO - END IF - END IF - END DO - ELSE - DO ipr_old = 1, npr - IF( myrow == ipr_old - 1 .AND. nrsnd( ipr_old ) > 0 ) THEN - CALL MPI_Wait( sreq, istatus, ierr ) - IF( ierr /= 0 ) & - CALL errore( " dsqmred ", " in MPI_Wait ", ABS( ierr ) ) - END IF - END DO - END IF - ! - END DO - - ! then redistribute cols, row groups work in parallel - - DO ipc = 1, npc - ! - CALL descla_local_dims( ic_new, nc_new, nb, descb( la_nx_ ), npc, ipc-1 ) - ! - icx_new = ic_new + nc_new - 1 - ! - ! write( 3000 + myid, * ) 'ic_new, nc_new, icx_new = ', ic_new, nc_new, icx_new - ! - DO ipc_old = 1, npc - ! - CALL descla_local_dims( ic_old, nc_old, na, desca( la_nx_ ), npc, ipc_old-1 ) - ! - icx_old = ic_old + nc_old - 1 - ! - ! write( 3000 + myid, * ) 'ic_old, nc_old, icx_old = ', ic_old, nc_old, icx_old - ! - IF( ic_old >= ic_new .AND. ic_old <= icx_new ) THEN - ! - ncsnd( ipc_old ) = MIN( nc_old, icx_new - ic_old + 1 ) - icb = 1 - ice = ncsnd( ipc_old ) - icb_new( ipc_old ) = ic_old - ic_new + 1 - ice_new( ipc_old ) = icb_new( ipc_old ) + ncsnd( ipc_old ) - 1 - ! - ELSE IF( ic_new >= ic_old .AND. ic_new <= icx_old ) THEN - ! - ncsnd( ipc_old ) = icx_old - ic_new + 1 - icb = ic_new - ic_old + 1 - ice = nc_old - icb_new( ipc_old ) = 1 - ice_new( ipc_old ) = ncsnd( ipc_old ) - ! - ELSE - ncsnd( ipc_old ) = 0 - icb = 0 - ice = 0 - icb_new( ipc_old ) = 0 - ice_new( ipc_old ) = 0 - END IF - ! - ! write( 3000 + myid, * ) 'ipc_old, ncsnd = ', ipc_old, ncsnd( ipc_old ) - ! write( 3000 + myid, * ) 'ipc_old, icb, ice = ', ipc_old, icb, ice - ! write( 3000 + myid, * ) 'ipc_old, icb_new, ice_new = ', ipc_old, icb_new( ipc_old ), ice_new( ipc_old ) - - IF( ( mycol == ipc_old - 1 ) .AND. ( ncsnd( ipc_old ) > 0 ) ) THEN - IF( mycol /= ipc - 1 ) THEN - ib = 0 - DO j = icb, ice - DO i = 1, descb( nlax_ ) - ib = ib + 1 - buf( ib ) = ab( i, j ) - END DO - END DO - CALL mpi_isend( buf, ib, MPI_DOUBLE_PRECISION, ipc-1, ipc, row_comm, sreq, ierr ) - IF( ierr /= 0 ) & - CALL errore( " dsqmred ", " in mpi_isend 2 ", ABS( ierr ) ) - ELSE - ib = icb - DO j = icb_new( ipc_old ), ice_new( ipc_old ) - DO i = 1, descb( nlax_ ) - b( i, j ) = ab( i, ib ) - END DO - ib = ib + 1 - END DO - END IF - END IF - - IF( ncsnd( ipc_old ) /= ice-icb+1 ) & - CALL errore( " dsqmred ", " somthing wrong with col 1 ", ncsnd( ipc_old ) ) - IF( ncsnd( ipc_old ) /= ice_new( ipc_old ) - icb_new( ipc_old ) + 1 ) & - CALL errore( " dsqmred ", " somthing wrong with col 2 ", ncsnd( ipc_old ) ) - ! - ncsnd( ipc_old ) = ncsnd( ipc_old ) * descb( nlax_ ) - ! - END DO - ! - IF( mycol == ipc - 1 ) THEN - DO ipc_old = 1, npc - IF( ncsnd( ipc_old ) > 0 ) THEN - IF( mycol /= ipc_old - 1 ) THEN - ib = icb_new( ipc_old ) - CALL mpi_recv( b( 1, ib ), ncsnd(ipc_old), MPI_DOUBLE_PRECISION, ipc_old-1, ipc, row_comm, istatus, ierr ) - IF( ierr /= 0 ) & - CALL errore( " dsqmred ", " in mpi_recv 2 ", ABS( ierr ) ) - CALL MPI_GET_COUNT( istatus, MPI_DOUBLE_PRECISION, ib, ierr ) - IF( ierr /= 0 ) & - CALL errore( " dsqmred ", " in MPI_GET_COUNT 2 ", ABS( ierr ) ) - IF( ib /= ncsnd(ipc_old) ) & - CALL errore( " dsqmred ", " somthing wrong with col 3 ", ib ) - END IF - END IF - END DO - ELSE - DO ipc_old = 1, npc - IF( mycol == ipc_old - 1 .AND. ncsnd( ipc_old ) > 0 ) THEN - CALL MPI_Wait( sreq, istatus, ierr ) - IF( ierr /= 0 ) & - CALL errore( " dsqmred ", " in MPI_Wait 2 ", ABS( ierr ) ) - END IF - END DO - END IF - ! - END DO - - DEALLOCATE( ab ) - DEALLOCATE( buf ) - - CALL mpi_comm_free( col_comm, ierr ) - - IF( ierr /= 0 ) & - CALL errore( " dsqmred ", " in mpi_comm_free 1 ", ABS( ierr ) ) - - CALL mpi_comm_free( row_comm, ierr ) - - IF( ierr /= 0 ) & - CALL errore( " dsqmred ", " in mpi_comm_free 2 ", ABS( ierr ) ) - -#if defined __PIPPO - - ! this is for debugging, tests through global matrix, if - ! the two matrix (pre and before the redistribution) coincide. - - ALLOCATE( tst1( nb, nb ) ) - ALLOCATE( tst2( nb, nb ) ) - ALLOCATE( ab( nb, nb ) ) - - ab = 0.0d0 - - do j = 1, desca( nlac_ ) - do i = 1, desca( nlar_ ) - ab( i + desca( ilar_ ) - 1, j + desca( ilac_ ) - 1 ) = a( i , j ) - end do - end do - - CALL MPI_REDUCE( ab, tst1, nb*nb, MPI_DOUBLE_PRECISION, MPI_SUM, 0, comm, ierr ) - - ab = 0.0d0 - - do j = 1, descb( nlac_ ) - do i = 1, descb( nlar_ ) - ab( i + descb( ilar_ ) - 1, j + descb( ilac_ ) - 1 ) = b( i , j ) - end do - end do - - CALL MPI_REDUCE( ab, tst2, nb*nb, MPI_DOUBLE_PRECISION, MPI_SUM, 0, comm, ierr ) - - IF( myid == 0 ) THEN - write( 1000, * ) na, nb, SUM( ABS( tst2 - tst1 ) ) - END IF - - DEALLOCATE( ab ) - DEALLOCATE( tst2 ) - DEALLOCATE( tst1 ) - -#endif - -#endif - - RETURN -END SUBROUTINE dsqmred - - - -SUBROUTINE zsqmred( na, a, lda, desca, nb, b, ldb, descb ) - ! - ! double complex (Z) SQuare Matrix REDistribution - ! - ! Copy a global "na * na" matrix locally stored in "a", - ! and distributed as described by "desca", into a larger - ! global "nb * nb" matrix stored in "b" and distributed - ! as described in "descb". - ! - ! If you want to read, get prepared for an headache! - ! Written struggling by Carlo Cavazzoni. - ! - USE kinds - USE descriptors - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: na - INTEGER, INTENT(IN) :: lda - COMPLEX(DP) :: a(lda,lda) ! matrix to be redistributed into b - INTEGER, INTENT(IN) :: desca( descla_siz_ ) - INTEGER, INTENT(IN) :: nb - INTEGER, INTENT(IN) :: ldb - COMPLEX(DP) :: b(ldb,ldb) - INTEGER, INTENT(IN) :: descb( descla_siz_ ) - - INTEGER :: ipc, ipr, npc, npr - INTEGER :: ipr_old, ir_old, nr_old, irx_old - INTEGER :: ipc_old, ic_old, nc_old, icx_old - INTEGER :: myrow, mycol, ierr, rank - INTEGER :: col_comm, row_comm, comm, sreq - INTEGER :: nr_new, ir_new, irx_new, ir, nr, nrtot, irb, ire - INTEGER :: nc_new, ic_new, icx_new, ic, nc, nctot, icb, ice - INTEGER :: ib, i, j, myid - INTEGER :: nrsnd( desca( la_npr_ ) ) - INTEGER :: ncsnd( desca( la_npr_ ) ) - INTEGER :: displ( desca( la_npr_ ) ) - INTEGER :: irb_new( desca( la_npr_ ) ) - INTEGER :: ire_new( desca( la_npr_ ) ) - INTEGER :: icb_new( desca( la_npr_ ) ) - INTEGER :: ice_new( desca( la_npr_ ) ) - COMPLEX(DP), ALLOCATABLE :: buf(:) - COMPLEX(DP), ALLOCATABLE :: ab(:,:) - COMPLEX(DP), ALLOCATABLE :: tst1(:,:) - COMPLEX(DP), ALLOCATABLE :: tst2(:,:) -#if defined __MPI - INTEGER :: istatus( MPI_STATUS_SIZE ) -#endif - - IF( desca( lambda_node_ ) <= 0 ) THEN - RETURN - END IF - - ! preliminary consistency checks - - IF( nb < na ) & - CALL errore( " zsqmred ", " nb < na, this sub. work only with nb >= na ", nb ) - IF( nb /= descb( la_n_ ) ) & - CALL errore( " zsqmred ", " wrong global dim nb ", nb ) - IF( na /= desca( la_n_ ) ) & - CALL errore( " zsqmred ", " wrong global dim na ", na ) - IF( ldb /= descb( nlax_ ) ) & - CALL errore( " zsqmred ", " wrong leading dim ldb ", ldb ) - IF( lda /= desca( nlax_ ) ) & - CALL errore( " zsqmred ", " wrong leading dim lda ", lda ) - - npr = desca( la_npr_ ) - myrow = desca( la_myr_ ) - npc = desca( la_npc_ ) - mycol = desca( la_myc_ ) - comm = desca( la_comm_ ) - -#if defined __MPI - - ! split communicator into row and col communicators - - CALL MPI_Comm_rank( comm, myid, ierr ) - IF( ierr /= 0 ) & - CALL errore( " zsqmred ", " in MPI_Comm_rank 1 ", ABS( ierr ) ) - - CALL MPI_Comm_split( comm, mycol, myrow, col_comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " zsqmred ", " in MPI_Comm_split 1 ", ABS( ierr ) ) - - CALL MPI_Comm_split( comm, myrow, mycol, row_comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " zsqmred ", " in MPI_Comm_split 2 ", ABS( ierr ) ) - - CALL MPI_Comm_rank( col_comm, rank, ierr ) - IF( ierr /= 0 ) & - CALL errore( " zsqmred ", " in MPI_Comm_rank 2 ", ABS( ierr ) ) - IF( rank /= myrow ) & - CALL errore( " zsqmred ", " building col_comm ", rank ) - - CALL MPI_Comm_rank( row_comm, rank, ierr ) - IF( ierr /= 0 ) & - CALL errore( " zsqmred ", " in MPI_Comm_rank 3 ", ABS( ierr ) ) - IF( rank /= mycol ) & - CALL errore( " zsqmred ", " building row_comm ", rank ) - - ALLOCATE( buf( descb( nlax_ ) * descb( nlax_ ) ) ) - ALLOCATE( ab( descb( nlax_ ), desca( nlax_ ) ) ) - - DO j = 1, descb( nlac_ ) - DO i = 1, descb( nlar_ ) - b( i, j ) = ( 0_DP , 0_DP ) - END DO - END DO - - ab = ( 0_DP , 0_DP ) - - ! first redistribute rows, column groups work in parallel - - DO ipr = 1, npr - ! - CALL descla_local_dims( ir_new, nr_new, nb, descb( la_nx_ ), npr, ipr-1 ) - ! - irx_new = ir_new + nr_new - 1 - ! - DO ipr_old = 1, npr - ! - CALL descla_local_dims( ir_old, nr_old, na, desca( la_nx_ ), npr, ipr_old-1 ) - ! - irx_old = ir_old + nr_old - 1 - ! - IF( ir_old >= ir_new .AND. ir_old <= irx_new ) THEN - ! - nrsnd( ipr_old ) = MIN( nr_old, irx_new - ir_old + 1 ) - irb = 1 - ire = nrsnd( ipr_old ) - irb_new( ipr_old ) = ir_old - ir_new + 1 - ire_new( ipr_old ) = irb_new( ipr_old ) + nrsnd( ipr_old ) - 1 - ! - ELSE IF( ir_new >= ir_old .AND. ir_new <= irx_old ) THEN - ! - nrsnd( ipr_old ) = irx_old - ir_new + 1 - irb = ir_new - ir_old + 1 - ire = nr_old - irb_new( ipr_old ) = 1 - ire_new( ipr_old ) = nrsnd( ipr_old ) - ! - ELSE - nrsnd( ipr_old ) = 0 - irb = 0 - ire = 0 - irb_new( ipr_old ) = 0 - ire_new( ipr_old ) = 0 - END IF - ! - IF( ( myrow == ipr_old - 1 ) .AND. ( nrsnd( ipr_old ) > 0 ) ) THEN - IF( myrow /= ipr - 1 ) THEN - ib = 0 - DO j = 1, desca( nlac_ ) - DO i = irb, ire - ib = ib + 1 - buf( ib ) = a( i, j ) - END DO - END DO - CALL mpi_isend( buf, ib, MPI_DOUBLE_COMPLEX, ipr-1, ipr, col_comm, sreq, ierr ) - IF( ierr /= 0 ) & - CALL errore( " zsqmred ", " in mpi_isend 1 ", ABS( ierr ) ) - ELSE - DO j = 1, desca( nlac_ ) - ib = irb - DO i = irb_new( ipr_old ), ire_new( ipr_old ) - ab( i, j ) = a( ib, j ) - ib = ib + 1 - END DO - END DO - END IF - END IF - ! - IF( nrsnd( ipr_old ) /= ire - irb + 1 ) & - CALL errore( " zsqmred ", " somthing wrong with row 1 ", nrsnd( ipr_old ) ) - IF( nrsnd( ipr_old ) /= ire_new( ipr_old ) - irb_new( ipr_old ) + 1 ) & - CALL errore( " zsqmred ", " somthing wrong with row 2 ", nrsnd( ipr_old ) ) - ! - nrsnd( ipr_old ) = nrsnd( ipr_old ) * desca( nlac_ ) - ! - END DO - ! - IF( myrow == ipr - 1 ) THEN - DO ipr_old = 1, npr - IF( nrsnd( ipr_old ) > 0 ) THEN - IF( myrow /= ipr_old - 1 ) THEN - CALL mpi_recv( buf, nrsnd(ipr_old), MPI_DOUBLE_COMPLEX, ipr_old-1, ipr, col_comm, istatus, ierr ) - IF( ierr /= 0 ) & - CALL errore( " zsqmred ", " in mpi_recv 1 ", ABS( ierr ) ) - CALL MPI_GET_COUNT( istatus, MPI_DOUBLE_COMPLEX, ib, ierr) - IF( ierr /= 0 ) & - CALL errore( " zsqmred ", " in MPI_GET_COUNT 1 ", ABS( ierr ) ) - IF( ib /= nrsnd(ipr_old) ) & - CALL errore( " zsqmred ", " somthing wrong with row 3 ", ib ) - ib = 0 - DO j = 1, desca( nlac_ ) - DO i = irb_new( ipr_old ), ire_new( ipr_old ) - ib = ib + 1 - ab( i, j ) = buf( ib ) - END DO - END DO - END IF - END IF - END DO - ELSE - DO ipr_old = 1, npr - IF( myrow == ipr_old - 1 .AND. nrsnd( ipr_old ) > 0 ) THEN - CALL MPI_Wait( sreq, istatus, ierr ) - IF( ierr /= 0 ) & - CALL errore( " zsqmred ", " in MPI_Wait 1 ", ABS( ierr ) ) - END IF - END DO - END IF - ! - END DO - - ! then redistribute cols, row groups work in parallel - - DO ipc = 1, npc - ! - CALL descla_local_dims( ic_new, nc_new, nb, descb( la_nx_ ), npc, ipc-1 ) - ! - icx_new = ic_new + nc_new - 1 - ! - DO ipc_old = 1, npc - ! - CALL descla_local_dims( ic_old, nc_old, na, desca( la_nx_ ), npc, ipc_old-1 ) - ! - icx_old = ic_old + nc_old - 1 - ! - IF( ic_old >= ic_new .AND. ic_old <= icx_new ) THEN - ! - ncsnd( ipc_old ) = MIN( nc_old, icx_new - ic_old + 1 ) - icb = 1 - ice = ncsnd( ipc_old ) - icb_new( ipc_old ) = ic_old - ic_new + 1 - ice_new( ipc_old ) = icb_new( ipc_old ) + ncsnd( ipc_old ) - 1 - ! - ELSE IF( ic_new >= ic_old .AND. ic_new <= icx_old ) THEN - ! - ncsnd( ipc_old ) = icx_old - ic_new + 1 - icb = ic_new - ic_old + 1 - ice = nc_old - icb_new( ipc_old ) = 1 - ice_new( ipc_old ) = ncsnd( ipc_old ) - ! - ELSE - ncsnd( ipc_old ) = 0 - icb = 0 - ice = 0 - icb_new( ipc_old ) = 0 - ice_new( ipc_old ) = 0 - END IF - ! - IF( ( mycol == ipc_old - 1 ) .AND. ( ncsnd( ipc_old ) > 0 ) ) THEN - IF( mycol /= ipc - 1 ) THEN - ib = 0 - DO j = icb, ice - DO i = 1, descb( nlax_ ) - ib = ib + 1 - buf( ib ) = ab( i, j ) - END DO - END DO - CALL mpi_isend( buf, ib, MPI_DOUBLE_COMPLEX, ipc-1, ipc, row_comm, sreq, ierr ) - IF( ierr /= 0 ) & - CALL errore( " zsqmred ", " in mpi_isend 2 ", ABS( ierr ) ) - ELSE - ib = icb - DO j = icb_new( ipc_old ), ice_new( ipc_old ) - DO i = 1, descb( nlax_ ) - b( i, j ) = ab( i, ib ) - END DO - ib = ib + 1 - END DO - END IF - END IF - - IF( ncsnd( ipc_old ) /= ice-icb+1 ) & - CALL errore( " zsqmred ", " somthing wrong with col 1 ", ncsnd( ipc_old ) ) - IF( ncsnd( ipc_old ) /= ice_new( ipc_old ) - icb_new( ipc_old ) + 1 ) & - CALL errore( " zsqmred ", " somthing wrong with col 2 ", ncsnd( ipc_old ) ) - ! - ncsnd( ipc_old ) = ncsnd( ipc_old ) * descb( nlax_ ) - ! - END DO - ! - IF( mycol == ipc - 1 ) THEN - DO ipc_old = 1, npc - IF( ncsnd( ipc_old ) > 0 ) THEN - IF( mycol /= ipc_old - 1 ) THEN - ib = icb_new( ipc_old ) - CALL mpi_recv( b( 1, ib ), ncsnd(ipc_old), MPI_DOUBLE_COMPLEX, ipc_old-1, ipc, row_comm, istatus, ierr ) - IF( ierr /= 0 ) & - CALL errore( " zsqmred ", " in mpi_recv 2 ", ABS( ierr ) ) - CALL MPI_GET_COUNT( istatus, MPI_DOUBLE_COMPLEX, ib, ierr ) - IF( ierr /= 0 ) & - CALL errore( " zsqmred ", " in MPI_GET_COUNT 2 ", ABS( ierr ) ) - IF( ib /= ncsnd(ipc_old) ) & - CALL errore( " zsqmred ", " somthing wrong with col 3 ", ib ) - END IF - END IF - END DO - ELSE - DO ipc_old = 1, npc - IF( mycol == ipc_old - 1 .AND. ncsnd( ipc_old ) > 0 ) THEN - CALL MPI_Wait( sreq, istatus, ierr ) - IF( ierr /= 0 ) & - CALL errore( " zsqmred ", " in MPI_Wait 2 ", ABS( ierr ) ) - END IF - END DO - END IF - ! - END DO - - DEALLOCATE( ab ) - DEALLOCATE( buf ) - - CALL mpi_comm_free( col_comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " zsqmred ", " in mpi_comm_free 1 ", ABS( ierr ) ) - - CALL mpi_comm_free( row_comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " zsqmred ", " in mpi_comm_free 2 ", ABS( ierr ) ) - -#if defined __PIPPO - - ! this is for debugging, tests through global matrix, if - ! the two matrix (pre and before the redistribution) coincide. - - ALLOCATE( tst1( nb, nb ) ) - ALLOCATE( tst2( nb, nb ) ) - ALLOCATE( ab( nb, nb ) ) - - ab = 0.0d0 - - do j = 1, desca( nlac_ ) - do i = 1, desca( nlar_ ) - ab( i + desca( ilar_ ) - 1, j + desca( ilac_ ) - 1 ) = a( i , j ) - end do - end do - - CALL MPI_REDUCE( ab, tst1, nb*nb, MPI_DOUBLE_COMPLEX, MPI_SUM, 0, comm, ierr ) - - ab = 0.0d0 - - do j = 1, descb( nlac_ ) - do i = 1, descb( nlar_ ) - ab( i + descb( ilar_ ) - 1, j + descb( ilac_ ) - 1 ) = b( i , j ) - end do - end do - - CALL MPI_REDUCE( ab, tst2, nb*nb, MPI_DOUBLE_COMPLEX, MPI_SUM, 0, comm, ierr ) - - IF( myid == 0 ) THEN - write( 4000, * ) na, nb, SUM( ABS( tst2 - tst1 ) ) - END IF - - DEALLOCATE( ab ) - DEALLOCATE( tst2 ) - DEALLOCATE( tst1 ) - -#endif - -#endif - - RETURN -END SUBROUTINE zsqmred - - - -! --------------------------------------------------------------------------------- - - -SUBROUTINE rep_matmul_drv( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC, comm ) - ! - ! Parallel matrix multiplication with replicated matrix - ! written by Carlo Cavazzoni - ! - implicit none - ! - CHARACTER(LEN=1), INTENT(IN) :: transa, transb - INTEGER, INTENT(IN) :: m, n, k - REAL(DP), INTENT(IN) :: alpha, beta - INTEGER, INTENT(IN) :: lda, ldb, ldc - REAL(DP) :: a(lda,*), b(ldb,*), c(ldc,*) - INTEGER, INTENT(IN) :: comm - ! - ! DGEMM PERFORMS ONE OF THE MATRIX-MATRIX OPERATIONS - ! - ! C := ALPHA*OP( A )*OP( B ) + BETA*C, - ! - ! WHERE OP( X ) IS ONE OF - ! - ! OP( X ) = X OR OP( X ) = X', - ! - ! ALPHA AND BETA ARE SCALARS, AND A, B AND C ARE MATRICES, WITH OP( A ) - ! AN M BY K MATRIX, OP( B ) A K BY N MATRIX AND C AN M BY N MATRIX. - ! - ! - ! - -#if defined __MPI - - ! - - INTEGER :: ME, I, II, J, JJ, IP, SOUR, DEST, INFO, IERR, ioff, ldx - INTEGER :: NB, IB_S, NB_SOUR, IB_SOUR, IBUF - INTEGER :: nproc, mpime, q, r - - REAL(DP), ALLOCATABLE :: auxa( : ) - REAL(DP), ALLOCATABLE :: auxc( : ) - - ! - ! ... BODY - ! - - CALL MPI_COMM_SIZE(comm, NPROC, IERR) - CALL MPI_COMM_RANK(comm, MPIME, IERR) - - IF ( NPROC == 1 ) THEN - - ! if there is only one proc no need of using parallel alg. - - CALL DGEMM(TRANSA, TRANSB, M, N, K, alpha, A, lda, B, ldb, beta, C, ldc) - - RETURN - - END IF - - ME = MPIME + 1 - Q = INT( m / NPROC ) - R = MOD( m , NPROC ) - - ! ... Find out the number of elements in the local block - ! along "M" first dimension os matrix A - - NB = Q - IF( ME <= R ) NB = NB + 1 - - ! ... Find out the global index of the local first row - - IF( ME <= R ) THEN - ib_s = (Q+1)*(ME-1) + 1 - ELSE - ib_s = Q*(ME-1) + R + 1 - END IF - - ldx = m / nproc + 1 - - ALLOCATE( auxa( MAX( n, k ) * ldx ) ) - ALLOCATE( auxc( MAX( n, m ) * ldx ) ) - - IF( TRANSA == 'N' .OR. TRANSA == 'n' ) THEN - ibuf = 0 - ioff = ib_s - 1 - DO J = 1, k - DO I = 1, NB - auxa( ibuf + I ) = A( I + ioff, J ) - END DO - ibuf = ibuf + ldx - END DO - ELSE - ibuf = 0 - ioff = ib_s - 1 - DO J = 1, k - DO I = 1, NB - auxa( ibuf + I ) = A( J, I + ioff ) - END DO - ibuf = ibuf + ldx - END DO - !ioff = ib_s - 1 - !call mytranspose( A( 1, ioff + 1 ), lda, auxa(1), ldx, m, nb) - END IF - - IF( beta /= 0.0_DP ) THEN - ibuf = 0 - ioff = ib_s - 1 - DO J = 1, n - DO I = 1, NB - auxc( ibuf + I ) = C( I + ioff, J ) - END DO - ibuf = ibuf + ldx - END DO - END IF - - CALL DGEMM( 'N', transb, nb, n, k, alpha, auxa(1), ldx, B, ldb, beta, auxc(1), ldx ) - - ! ... Here processors exchange blocks - - DO IP = 0, NPROC-1 - - ! ... Find out the number of elements in the block of processor SOUR - - NB_SOUR = q - IF( (IP+1) .LE. r ) NB_SOUR = NB_SOUR+1 - - ! ... Find out the global index of the first row owned by SOUR - - IF( (IP+1) .LE. r ) THEN - ib_sour = (Q+1)*IP + 1 - ELSE - ib_sour = Q*IP + R + 1 - END IF - - IF( mpime == ip ) auxa(1:n*ldx) = auxc(1:n*ldx) - - CALL MPI_BCAST( auxa(1), ldx*n, mpi_double_precision, ip, comm, IERR) - - IF( ierr /= 0 ) & - CALL errore( " rep_matmul_drv ", " in MPI_BCAST ", ABS( ierr ) ) - - IBUF = 0 - ioff = IB_SOUR - 1 - DO J = 1, N - DO I = 1, NB_SOUR - C( I + ioff, J ) = AUXA( IBUF + I ) - END DO - IBUF = IBUF + ldx - END DO - - END DO - - DEALLOCATE( auxa, auxc ) - -#else - - ! if we are not compiling with __MPI this is equivalent to a blas call - - CALL DGEMM(TRANSA, TRANSB, m, N, k, alpha, A, lda, B, ldb, beta, C, ldc) - -#endif - - RETURN - -END SUBROUTINE rep_matmul_drv - - -SUBROUTINE zrep_matmul_drv( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC, comm ) - ! - ! Parallel matrix multiplication with replicated matrix - ! written by Carlo Cavazzoni - ! - implicit none - ! - CHARACTER(LEN=1), INTENT(IN) :: transa, transb - INTEGER, INTENT(IN) :: m, n, k - COMPLEX(DP), INTENT(IN) :: alpha, beta - INTEGER, INTENT(IN) :: lda, ldb, ldc - COMPLEX(DP) :: a(lda,*), b(ldb,*), c(ldc,*) - INTEGER, INTENT(IN) :: comm - ! - ! DGEMM PERFORMS ONE OF THE MATRIX-MATRIX OPERATIONS - ! - ! C := ALPHA*OP( A )*OP( B ) + BETA*C, - ! - ! WHERE OP( X ) IS ONE OF - ! - ! OP( X ) = X OR OP( X ) = X', - ! - ! ALPHA AND BETA ARE SCALARS, AND A, B AND C ARE MATRICES, WITH OP( A ) - ! AN M BY K MATRIX, OP( B ) A K BY N MATRIX AND C AN M BY N MATRIX. - ! - ! - ! - -#if defined __MPI - - ! - - INTEGER :: ME, I, II, J, JJ, IP, SOUR, DEST, INFO, IERR, ioff, ldx - INTEGER :: NB, IB_S, NB_SOUR, IB_SOUR, IBUF - INTEGER :: nproc, mpime, q, r - - COMPLEX(DP), ALLOCATABLE :: auxa( : ) - COMPLEX(DP), ALLOCATABLE :: auxc( : ) - - ! - ! ... BODY - ! - - CALL MPI_COMM_SIZE(comm, NPROC, IERR) - CALL MPI_COMM_RANK(comm, MPIME, IERR) - - IF ( NPROC == 1 ) THEN - - ! if there is only one proc no need of using parallel alg. - - CALL ZGEMM(TRANSA, TRANSB, M, N, K, alpha, A, lda, B, ldb, beta, C, ldc) - - RETURN - - END IF - - ME = MPIME + 1 - Q = INT( m / NPROC ) - R = MOD( m , NPROC ) - - ! ... Find out the number of elements in the local block - ! along "M" first dimension os matrix A - - NB = Q - IF( ME <= R ) NB = NB + 1 - - ! ... Find out the global index of the local first row - - IF( ME <= R ) THEN - ib_s = (Q+1)*(ME-1) + 1 - ELSE - ib_s = Q*(ME-1) + R + 1 - END IF - - ldx = m / nproc + 1 - - ALLOCATE( auxa( MAX( n, k ) * ldx ) ) - ALLOCATE( auxc( MAX( n, m ) * ldx ) ) - - IF( TRANSA == 'N' .OR. TRANSA == 'n' ) THEN - ibuf = 0 - ioff = ib_s - 1 - DO J = 1, k - DO I = 1, NB - auxa( ibuf + I ) = A( I + ioff, J ) - END DO - ibuf = ibuf + ldx - END DO - ELSE - ibuf = 0 - ioff = ib_s - 1 - DO J = 1, k - DO I = 1, NB - auxa( ibuf + I ) = CONJG( A( J, I + ioff ) ) - END DO - ibuf = ibuf + ldx - END DO - !ioff = ib_s - 1 - !call mytranspose( A( 1, ioff + 1 ), lda, auxa(1), ldx, m, nb) - END IF - - IF( beta /= 0.0_DP ) THEN - ibuf = 0 - ioff = ib_s - 1 - DO J = 1, n - DO I = 1, NB - auxc( ibuf + I ) = C( I + ioff, J ) - END DO - ibuf = ibuf + ldx - END DO - END IF - - CALL ZGEMM( 'N', transb, nb, n, k, alpha, auxa(1), ldx, B, ldb, beta, auxc(1), ldx ) - - ! ... Here processors exchange blocks - - DO IP = 0, NPROC-1 - - ! ... Find out the number of elements in the block of processor SOUR - - NB_SOUR = q - IF( (IP+1) .LE. r ) NB_SOUR = NB_SOUR+1 - - ! ... Find out the global index of the first row owned by SOUR - - IF( (IP+1) .LE. r ) THEN - ib_sour = (Q+1)*IP + 1 - ELSE - ib_sour = Q*IP + R + 1 - END IF - - IF( mpime == ip ) auxa(1:n*ldx) = auxc(1:n*ldx) - - CALL MPI_BCAST( auxa(1), ldx*n, mpi_double_complex, ip, comm, IERR) - - IF( ierr /= 0 ) & - CALL errore( " zrep_matmul_drv ", " in MPI_BCAST ", ABS( ierr ) ) - - IBUF = 0 - ioff = IB_SOUR - 1 - DO J = 1, N - DO I = 1, NB_SOUR - C( I + ioff, J ) = AUXA( IBUF + I ) - END DO - IBUF = IBUF + ldx - END DO - - END DO - - DEALLOCATE( auxa, auxc ) - -#else - - ! if we are not compiling with __MPI this is equivalent to a blas call - - CALL ZGEMM(TRANSA, TRANSB, m, N, k, alpha, A, lda, B, ldb, beta, C, ldc) - -#endif - - RETURN - -END SUBROUTINE zrep_matmul_drv - - -#if defined __SCALAPACK - - SUBROUTINE pdsyevd_drv( tv, n, nb, s, w, ortho_cntx ) - - LOGICAL, INTENT(IN) :: tv - INTEGER, INTENT(IN) :: nb, n, ortho_cntx - REAL(DP) :: s(:,:), w(:) - - INTEGER :: desch( 10 ) - REAL(DP) :: rtmp( 4 ) - INTEGER :: itmp( 4 ) - REAL(DP), ALLOCATABLE :: work(:) - REAL(DP), ALLOCATABLE :: vv(:,:) - INTEGER, ALLOCATABLE :: iwork(:) - INTEGER :: LWORK, LIWORK, info - CHARACTER :: jobv - ! - IF( tv ) THEN - ALLOCATE( vv( SIZE( s, 1 ), SIZE( s, 2 ) ) ) - jobv = 'V' - ELSE - CALL errore( ' pdsyevd_drv ', ' PDSYEVD does not compute eigenvalue only ', ABS( info ) ) - END IF - - CALL descinit( desch, n, n, nb, nb, 0, 0, ortho_cntx, SIZE( s, 1 ) , info ) - - IF( info /= 0 ) CALL errore( ' pdsyevd_drv ', ' desckinit ', ABS( info ) ) - - lwork = -1 - liwork = 1 - itmp = 0 - rtmp = 0.0_DP - - CALL PDSYEVD( jobv, 'L', n, s, 1, 1, desch, w, vv, 1, 1, desch, rtmp, lwork, itmp, liwork, info ) - - IF( info /= 0 ) CALL errore( ' pdsyevd_drv ', ' PDSYEVD ', ABS( info ) ) - - lwork = MAX( 131072, 2*INT( rtmp(1) ) + 1 ) - liwork = MAX( 8*n , itmp(1) + 1 ) - - ALLOCATE( work( lwork ) ) - ALLOCATE( iwork( liwork ) ) - - CALL PDSYEVD( jobv, 'L', n, s, 1, 1, desch, w, vv, 1, 1, desch, work, lwork, iwork, liwork, info ) - - IF( info /= 0 ) CALL errore( ' pdsyevd_drv ', ' PDSYEVD ', ABS( info ) ) - - IF( tv ) s = vv - - DEALLOCATE( work ) - DEALLOCATE( iwork ) - DEALLOCATE( vv ) - RETURN - END SUBROUTINE pdsyevd_drv - - - SUBROUTINE pzheevd_drv( tv, n, nb, h, w, ortho_cntx ) - - LOGICAL, INTENT(IN) :: tv - INTEGER, INTENT(IN) :: nb, n, ortho_cntx - COMPLEX(DP) :: h(:,:) - REAL(DP) :: w(:) - - COMPLEX(DP) :: ztmp( 4 ) - REAL(DP) :: rtmp( 4 ) - INTEGER :: itmp( 4 ) - COMPLEX(DP), ALLOCATABLE :: work(:) - COMPLEX(DP), ALLOCATABLE :: v(:,:) - REAL(DP), ALLOCATABLE :: rwork(:) - INTEGER, ALLOCATABLE :: iwork(:) - INTEGER :: LWORK, LRWORK, LIWORK - INTEGER :: desch( 10 ), info - CHARACTER :: jobv - ! - IF( tv ) THEN - ALLOCATE( v( SIZE( h, 1 ), SIZE( h, 2 ) ) ) - jobv = 'V' - ELSE - CALL errore( ' pzheevd_drv ', ' pzheevd does not compute eigenvalue only ', ABS( info ) ) - END IF - - CALL descinit( desch, n, n, nb, nb, 0, 0, ortho_cntx, SIZE( h, 1 ) , info ) - - lwork = -1 - lrwork = -1 - liwork = -1 - CALL PZHEEVD( 'V', 'L', n, h, 1, 1, desch, w, v, 1, 1, & - desch, ztmp, LWORK, rtmp, LRWORK, itmp, LIWORK, INFO ) - - IF( info /= 0 ) CALL errore( ' cdiaghg ', ' PZHEEVD ', ABS( info ) ) - - lwork = INT( REAL(ztmp(1)) ) + 1 - lrwork = INT( rtmp(1) ) + 1 - liwork = itmp(1) + 1 - - ALLOCATE( work( lwork ) ) - ALLOCATE( rwork( lrwork ) ) - ALLOCATE( iwork( liwork ) ) - - CALL PZHEEVD( 'V', 'L', n, h, 1, 1, desch, w, v, 1, 1, & - desch, work, LWORK, rwork, LRWORK, iwork, LIWORK, INFO ) - - IF( info /= 0 ) CALL errore( ' cdiaghg ', ' PZHEEVD ', ABS( info ) ) - - h = v - - DEALLOCATE( work ) - DEALLOCATE( rwork ) - DEALLOCATE( iwork ) - DEALLOCATE( v ) - RETURN - END SUBROUTINE pzheevd_drv - - -#endif - - -!==----------------------------------------------==! -END MODULE parallel_toolkit -!==----------------------------------------------==! - -! -! -!=----------------------------------------------------------------------------=! -! -! -! Cannon's algorithms for parallel matrix multiplication -! written by Carlo Cavazzoni -! -! -! - -SUBROUTINE sqr_mm_cannon( transa, transb, n, alpha, a, lda, b, ldb, beta, c, ldc, desc ) - ! - ! Parallel square matrix multiplication with Cannon's algorithm - ! - USE kinds, ONLY : DP - USE descriptors, ONLY : ilar_ , nlar_ , ilac_ , nlac_ , nlax_ , & - la_comm_ , lambda_node_ , la_npr_ , la_npc_ , la_myr_ , la_myc_ - ! - IMPLICIT NONE - ! - CHARACTER(LEN=1), INTENT(IN) :: transa, transb - INTEGER, INTENT(IN) :: n - REAL(DP), INTENT(IN) :: alpha, beta - INTEGER, INTENT(IN) :: lda, ldb, ldc - REAL(DP) :: a(lda,*), b(ldb,*), c(ldc,*) - INTEGER, INTENT(IN) :: desc(*) - ! - ! performs one of the matrix-matrix operations - ! - ! C := ALPHA*OP( A )*OP( B ) + BETA*C, - ! - ! where op( x ) is one of - ! - ! OP( X ) = X OR OP( X ) = X', - ! - ! alpha and beta are scalars, and a, b and c are square matrices - ! -#if defined (__MPI) - ! - include 'mpif.h' - ! -#endif - ! - integer :: ierr - integer :: np - integer :: i, j, nr, nc, nb, iter, rowid, colid - logical :: ta, tb - INTEGER :: comm - ! - ! - real(DP), allocatable :: bblk(:,:), ablk(:,:) - ! -#if defined (__MPI) - ! - integer :: istatus( MPI_STATUS_SIZE ) - ! -#endif - ! - IF( desc( lambda_node_ ) < 0 ) THEN - ! - ! processors not interested in this computation return quickly - ! - RETURN - ! - END IF - - IF( n < 1 ) THEN - RETURN - END IF - - IF( desc( la_npr_ ) == 1 ) THEN - ! - ! quick return if only one processor is used - ! - CALL dgemm( TRANSA, TRANSB, n, n, n, alpha, a, lda, b, ldb, beta, c, ldc) - ! - RETURN - ! - END IF - - IF( desc( la_npr_ ) /= desc( la_npc_ ) ) & - CALL errore( ' sqr_mm_cannon ', ' works only with square processor mesh ', 1 ) - ! - ! Retrieve communicator and mesh geometry - ! - np = desc( la_npr_ ) - comm = desc( la_comm_ ) - rowid = desc( la_myr_ ) - colid = desc( la_myc_ ) - ! - ! Retrieve the size of the local block - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - nb = desc( nlax_ ) - ! -#if defined (__MPI) - CALL MPI_BARRIER( comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " sqr_mm_cannon ", " in MPI_BARRIER ", ABS( ierr ) ) -#endif - ! - allocate( ablk( nb, nb ) ) - DO j = 1, nc - DO i = 1, nr - ablk( i, j ) = a( i, j ) - END DO - END DO - ! - ! Clear memory outside the matrix block - ! - DO j = nc+1, nb - DO i = 1, nb - ablk( i, j ) = 0.0_DP - END DO - END DO - DO j = 1, nb - DO i = nr+1, nb - ablk( i, j ) = 0.0_DP - END DO - END DO - ! - ! - allocate( bblk( nb, nb ) ) - DO j = 1, nc - DO i = 1, nr - bblk( i, j ) = b( i, j ) - END DO - END DO - ! - ! Clear memory outside the matrix block - ! - DO j = nc+1, nb - DO i = 1, nb - bblk( i, j ) = 0.0_DP - END DO - END DO - DO j = 1, nb - DO i = nr+1, nb - bblk( i, j ) = 0.0_DP - END DO - END DO - ! - ! - ta = ( TRANSA == 'T' .OR. TRANSA == 't' ) - tb = ( TRANSB == 'T' .OR. TRANSB == 't' ) - ! - ! Shift A rowid+1 places to the west - ! - IF( ta ) THEN - CALL shift_exch_block( ablk, 'W', 1 ) - ELSE - CALL shift_block( ablk, 'W', rowid+1, 1 ) - END IF - ! - ! Shift B colid+1 places to the north - ! - IF( tb ) THEN - CALL shift_exch_block( bblk, 'N', np+1 ) - ELSE - CALL shift_block( bblk, 'N', colid+1, np+1 ) - END IF - ! - ! Accumulate on C - ! - CALL dgemm( TRANSA, TRANSB, nr, nc, nb, alpha, ablk, nb, bblk, nb, beta, c, ldc) - ! - DO iter = 2, np - ! - ! Shift A 1 places to the east - ! - CALL shift_block( ablk, 'E', 1, iter ) - ! - ! Shift B 1 places to the south - ! - CALL shift_block( bblk, 'S', 1, np+iter ) - ! - ! Accumulate on C - ! - CALL dgemm( TRANSA, TRANSB, nr, nc, nb, alpha, ablk, nb, bblk, nb, 1.0_DP, c, ldc) - ! - END DO - - deallocate( ablk, bblk ) - - RETURN - -CONTAINS - - SUBROUTINE shift_block( blk, dir, ln, tag ) - ! - ! Block shift - ! - IMPLICIT NONE - REAL(DP) :: blk( :, : ) - CHARACTER(LEN=1), INTENT(IN) :: dir ! shift direction - INTEGER, INTENT(IN) :: ln ! shift lenght - INTEGER, INTENT(IN) :: tag ! communication tag - ! - INTEGER :: icdst, irdst, icsrc, irsrc, idest, isour - ! - IF( dir == 'W' ) THEN - ! - irdst = rowid - irsrc = rowid - icdst = MOD( colid - ln + np, np ) - icsrc = MOD( colid + ln + np, np ) - ! - ELSE IF( dir == 'E' ) THEN - ! - irdst = rowid - irsrc = rowid - icdst = MOD( colid + ln + np, np ) - icsrc = MOD( colid - ln + np, np ) - ! - ELSE IF( dir == 'N' ) THEN - - irdst = MOD( rowid - ln + np, np ) - irsrc = MOD( rowid + ln + np, np ) - icdst = colid - icsrc = colid - - ELSE IF( dir == 'S' ) THEN - - irdst = MOD( rowid + ln + np, np ) - irsrc = MOD( rowid - ln + np, np ) - icdst = colid - icsrc = colid - - ELSE - - CALL errore( ' sqr_mm_cannon ', ' unknown shift direction ', 1 ) - - END IF - ! - CALL GRID2D_RANK( 'R', np, np, irdst, icdst, idest ) - CALL GRID2D_RANK( 'R', np, np, irsrc, icsrc, isour ) - ! -#if defined (__MPI) - ! - CALL MPI_SENDRECV_REPLACE(blk, nb*nb, MPI_DOUBLE_PRECISION, & - idest, tag, isour, tag, comm, istatus, ierr) - IF( ierr /= 0 ) & - CALL errore( " sqr_mm_cannon ", " in MPI_SENDRECV_REPLACE ", ABS( ierr ) ) - ! -#endif - RETURN - END SUBROUTINE shift_block - - SUBROUTINE shift_exch_block( blk, dir, tag ) - ! - ! Combined block shift and exchange - ! only used for the first step - ! - IMPLICIT NONE - REAL(DP) :: blk( :, : ) - CHARACTER(LEN=1), INTENT(IN) :: dir - INTEGER, INTENT(IN) :: tag - ! - INTEGER :: icdst, irdst, icsrc, irsrc, idest, isour - INTEGER :: icol, irow - ! - IF( dir == 'W' ) THEN - ! - icol = rowid - irow = colid - ! - irdst = irow - icdst = MOD( icol - irow-1 + np, np ) - ! - irow = rowid - icol = MOD( colid + rowid+1 + np, np ) - ! - irsrc = icol - icsrc = irow - ! - ELSE IF( dir == 'N' ) THEN - ! - icol = rowid - irow = colid - ! - icdst = icol - irdst = MOD( irow - icol-1 + np, np ) - ! - irow = MOD( rowid + colid+1 + np, np ) - icol = colid - ! - irsrc = icol - icsrc = irow - - ELSE - - CALL errore( ' sqr_mm_cannon ', ' unknown shift_exch direction ', 1 ) - - END IF - ! - CALL GRID2D_RANK( 'R', np, np, irdst, icdst, idest ) - CALL GRID2D_RANK( 'R', np, np, irsrc, icsrc, isour ) - ! -#if defined (__MPI) - ! - CALL MPI_SENDRECV_REPLACE(blk, nb*nb, MPI_DOUBLE_PRECISION, & - idest, tag, isour, tag, comm, istatus, ierr) - IF( ierr /= 0 ) & - CALL errore( " sqr_mm_cannon ", " in MPI_SENDRECV_REPLACE 2 ", ABS( ierr ) ) - ! -#endif - RETURN - END SUBROUTINE shift_exch_block - -END SUBROUTINE sqr_mm_cannon - - -!=----------------------------------------------------------------------------=! - -SUBROUTINE sqr_zmm_cannon( transa, transb, n, alpha, a, lda, b, ldb, beta, c, ldc, desc ) - ! - ! Parallel square matrix multiplication with Cannon's algorithm - ! - USE kinds, ONLY : DP - USE descriptors, ONLY : ilar_ , nlar_ , ilac_ , nlac_ , nlax_ , & - la_comm_ , lambda_node_ , la_npr_ , la_npc_ , la_myr_ , la_myc_ - ! - IMPLICIT NONE - ! - CHARACTER(LEN=1), INTENT(IN) :: transa, transb - INTEGER, INTENT(IN) :: n - COMPLEX(DP), INTENT(IN) :: alpha, beta - INTEGER, INTENT(IN) :: lda, ldb, ldc - COMPLEX(DP) :: a(lda,*), b(ldb,*), c(ldc,*) - INTEGER, INTENT(IN) :: desc(*) - ! - ! performs one of the matrix-matrix operations - ! - ! C := ALPHA*OP( A )*OP( B ) + BETA*C, - ! - ! where op( x ) is one of - ! - ! OP( X ) = X OR OP( X ) = X', - ! - ! alpha and beta are scalars, and a, b and c are square matrices - ! -#if defined (__MPI) - ! - include 'mpif.h' - ! -#endif - ! - INTEGER :: ierr - INTEGER :: np - INTEGER :: i, j, nr, nc, nb, iter, rowid, colid - LOGICAL :: ta, tb - INTEGER :: comm - ! - ! - COMPLEX(DP), ALLOCATABLE :: bblk(:,:), ablk(:,:) - COMPLEX(DP) :: zone = ( 1.0_DP, 0.0_DP ) - COMPLEX(DP) :: zzero = ( 0.0_DP, 0.0_DP ) - ! -#if defined (__MPI) - ! - integer :: istatus( MPI_STATUS_SIZE ) - ! -#endif - ! - IF( desc( lambda_node_ ) < 0 ) THEN - ! - ! processors not interested in this computation return quickly - ! - RETURN - ! - END IF - - IF( n < 1 ) THEN - RETURN - END IF - - IF( desc( la_npr_ ) == 1 ) THEN - ! - ! quick return if only one processor is used - ! - CALL zgemm( TRANSA, TRANSB, n, n, n, alpha, a, lda, b, ldb, beta, c, ldc) - ! - RETURN - ! - END IF - - IF( desc( la_npr_ ) /= desc( la_npc_ ) ) & - CALL errore( ' sqr_zmm_cannon ', ' works only with square processor mesh ', 1 ) - ! - ! Retrieve communicator and mesh geometry - ! - np = desc( la_npr_ ) - comm = desc( la_comm_ ) - rowid = desc( la_myr_ ) - colid = desc( la_myc_ ) - ! - ! Retrieve the size of the local block - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - nb = desc( nlax_ ) - ! -#if defined (__MPI) - CALL MPI_BARRIER( comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " sqr_zmm_cannon ", " in MPI_BARRIER ", ABS( ierr ) ) -#endif - ! - allocate( ablk( nb, nb ) ) - DO j = 1, nc - DO i = 1, nr - ablk( i, j ) = a( i, j ) - END DO - END DO - ! - ! Clear memory outside the matrix block - ! - DO j = nc+1, nb - DO i = 1, nb - ablk( i, j ) = zzero - END DO - END DO - DO j = 1, nb - DO i = nr+1, nb - ablk( i, j ) = zzero - END DO - END DO - ! - ! - allocate( bblk( nb, nb ) ) - DO j = 1, nc - DO i = 1, nr - bblk( i, j ) = b( i, j ) - END DO - END DO - ! - ! Clear memory outside the matrix block - ! - DO j = nc+1, nb - DO i = 1, nb - bblk( i, j ) = zzero - END DO - END DO - DO j = 1, nb - DO i = nr+1, nb - bblk( i, j ) = zzero - END DO - END DO - ! - ! - ta = ( TRANSA == 'C' .OR. TRANSA == 'c' ) - tb = ( TRANSB == 'C' .OR. TRANSB == 'c' ) - ! - ! Shift A rowid+1 places to the west - ! - IF( ta ) THEN - CALL shift_exch_block( ablk, 'W', 1 ) - ELSE - CALL shift_block( ablk, 'W', rowid+1, 1 ) - END IF - ! - ! Shift B colid+1 places to the north - ! - IF( tb ) THEN - CALL shift_exch_block( bblk, 'N', np+1 ) - ELSE - CALL shift_block( bblk, 'N', colid+1, np+1 ) - END IF - ! - ! Accumulate on C - ! - CALL zgemm( TRANSA, TRANSB, nr, nc, nb, alpha, ablk, nb, bblk, nb, beta, c, ldc) - ! - DO iter = 2, np - ! - ! Shift A 1 places to the east - ! - CALL shift_block( ablk, 'E', 1, iter ) - ! - ! Shift B 1 places to the south - ! - CALL shift_block( bblk, 'S', 1, np+iter ) - ! - ! Accumulate on C - ! - CALL zgemm( TRANSA, TRANSB, nr, nc, nb, alpha, ablk, nb, bblk, nb, zone, c, ldc) - ! - END DO - - deallocate( ablk, bblk ) - - RETURN - -CONTAINS - - SUBROUTINE shift_block( blk, dir, ln, tag ) - ! - ! Block shift - ! - IMPLICIT NONE - COMPLEX(DP) :: blk( :, : ) - CHARACTER(LEN=1), INTENT(IN) :: dir ! shift direction - INTEGER, INTENT(IN) :: ln ! shift lenght - INTEGER, INTENT(IN) :: tag ! communication tag - ! - INTEGER :: icdst, irdst, icsrc, irsrc, idest, isour - ! - IF( dir == 'W' ) THEN - ! - irdst = rowid - irsrc = rowid - icdst = MOD( colid - ln + np, np ) - icsrc = MOD( colid + ln + np, np ) - ! - ELSE IF( dir == 'E' ) THEN - ! - irdst = rowid - irsrc = rowid - icdst = MOD( colid + ln + np, np ) - icsrc = MOD( colid - ln + np, np ) - ! - ELSE IF( dir == 'N' ) THEN - - irdst = MOD( rowid - ln + np, np ) - irsrc = MOD( rowid + ln + np, np ) - icdst = colid - icsrc = colid - - ELSE IF( dir == 'S' ) THEN - - irdst = MOD( rowid + ln + np, np ) - irsrc = MOD( rowid - ln + np, np ) - icdst = colid - icsrc = colid - - ELSE - - CALL errore( ' sqr_zmm_cannon ', ' unknown shift direction ', 1 ) - - END IF - ! - CALL GRID2D_RANK( 'R', np, np, irdst, icdst, idest ) - CALL GRID2D_RANK( 'R', np, np, irsrc, icsrc, isour ) - ! -#if defined (__MPI) - ! - CALL MPI_SENDRECV_REPLACE(blk, nb*nb, MPI_DOUBLE_COMPLEX, & - idest, tag, isour, tag, comm, istatus, ierr) - IF( ierr /= 0 ) & - CALL errore( " sqr_zmm_cannon ", " in MPI_SENDRECV_REPLACE 1 ", ABS( ierr ) ) - ! -#endif - RETURN - END SUBROUTINE shift_block - ! - SUBROUTINE shift_exch_block( blk, dir, tag ) - ! - ! Combined block shift and exchange - ! only used for the first step - ! - IMPLICIT NONE - COMPLEX(DP) :: blk( :, : ) - CHARACTER(LEN=1), INTENT(IN) :: dir - INTEGER, INTENT(IN) :: tag - ! - INTEGER :: icdst, irdst, icsrc, irsrc, idest, isour - INTEGER :: icol, irow - ! - IF( dir == 'W' ) THEN - ! - icol = rowid - irow = colid - ! - irdst = irow - icdst = MOD( icol - irow-1 + np, np ) - ! - irow = rowid - icol = MOD( colid + rowid+1 + np, np ) - ! - irsrc = icol - icsrc = irow - ! - ELSE IF( dir == 'N' ) THEN - ! - icol = rowid - irow = colid - ! - icdst = icol - irdst = MOD( irow - icol-1 + np, np ) - ! - irow = MOD( rowid + colid+1 + np, np ) - icol = colid - ! - irsrc = icol - icsrc = irow - - ELSE - - CALL errore( ' sqr_zmm_cannon ', ' unknown shift_exch direction ', 1 ) - - END IF - ! - CALL GRID2D_RANK( 'R', np, np, irdst, icdst, idest ) - CALL GRID2D_RANK( 'R', np, np, irsrc, icsrc, isour ) - ! -#if defined (__MPI) - ! - CALL MPI_SENDRECV_REPLACE(blk, nb*nb, MPI_DOUBLE_COMPLEX, & - idest, tag, isour, tag, comm, istatus, ierr) - IF( ierr /= 0 ) & - CALL errore( " sqr_zmm_cannon ", " in MPI_SENDRECV_REPLACE 2 ", ABS( ierr ) ) - ! -#endif - RETURN - END SUBROUTINE shift_exch_block - -END SUBROUTINE sqr_zmm_cannon - -! -! -! -! - -SUBROUTINE sqr_tr_cannon_real( n, a, lda, b, ldb, desc ) - ! - ! Parallel square matrix transposition with Cannon's algorithm - ! - USE kinds, ONLY : DP - USE descriptors, ONLY : ilar_ , nlar_ , ilac_ , nlac_ , nlax_ , la_npc_ , la_n_ , & - la_comm_ , lambda_node_ , la_npr_ , la_myr_ , la_myc_ - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: n - INTEGER, INTENT(IN) :: lda, ldb - REAL(DP) :: a(lda,*), b(ldb,*) - INTEGER, INTENT(IN) :: desc(*) - ! -#if defined (__MPI) - ! - INCLUDE 'mpif.h' - ! -#endif - ! - INTEGER :: ierr - INTEGER :: np, rowid, colid - INTEGER :: i, j, nr, nc, nb - INTEGER :: comm - ! - REAL(DP), ALLOCATABLE :: ablk(:,:) - ! -#if defined (__MPI) - ! - INTEGER :: istatus( MPI_STATUS_SIZE ) - ! -#endif - ! - IF( desc( lambda_node_ ) < 0 ) THEN - RETURN - END IF - - IF( n < 1 ) THEN - RETURN - END IF - - IF( desc( la_npr_ ) == 1 ) THEN - CALL mytranspose( a, lda, b, ldb, n, n ) - RETURN - END IF - - IF( desc( la_npr_ ) /= desc( la_npc_ ) ) & - CALL errore( ' sqr_tr_cannon ', ' works only with square processor mesh ', 1 ) - IF( n /= desc( la_n_ ) ) & - CALL errore( ' sqr_tr_cannon ', ' inconsistent size n ', 1 ) - IF( lda /= desc( nlax_ ) ) & - CALL errore( ' sqr_tr_cannon ', ' inconsistent size lda ', 1 ) - IF( ldb /= desc( nlax_ ) ) & - CALL errore( ' sqr_tr_cannon ', ' inconsistent size ldb ', 1 ) - - comm = desc( la_comm_ ) - - rowid = desc( la_myr_ ) - colid = desc( la_myc_ ) - np = desc( la_npr_ ) - ! - ! Compute the size of the local block - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - nb = desc( nlax_ ) - ! - allocate( ablk( nb, nb ) ) - DO j = 1, nc - DO i = 1, nr - ablk( i, j ) = a( i, j ) - END DO - END DO - DO j = nc+1, nb - DO i = 1, nb - ablk( i, j ) = 0.0_DP - END DO - END DO - DO j = 1, nb - DO i = nr+1, nb - ablk( i, j ) = 0.0_DP - END DO - END DO - ! - CALL exchange_block( ablk ) - ! -#if defined (__MPI) - CALL MPI_BARRIER( comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " sqr_tr_cannon ", " in MPI_BARRIER ", ABS( ierr ) ) -#endif - ! - DO j = 1, nr - DO i = 1, nc - b( j, i ) = ablk( i, j ) - END DO - END DO - ! - deallocate( ablk ) - - RETURN - -CONTAINS - - SUBROUTINE exchange_block( blk ) - ! - ! Block exchange ( transpose ) - ! - IMPLICIT NONE - REAL(DP) :: blk( :, : ) - ! - INTEGER :: icdst, irdst, icsrc, irsrc, idest, isour - ! - irdst = colid - icdst = rowid - irsrc = colid - icsrc = rowid - ! - CALL GRID2D_RANK( 'R', np, np, irdst, icdst, idest ) - CALL GRID2D_RANK( 'R', np, np, irsrc, icsrc, isour ) - ! -#if defined (__MPI) - ! - CALL MPI_SENDRECV_REPLACE(blk, nb*nb, MPI_DOUBLE_PRECISION, & - idest, np+np+1, isour, np+np+1, comm, istatus, ierr) - IF( ierr /= 0 ) & - CALL errore( " sqr_tr_cannon ", " in MPI_SENDRECV_REPLACE ", ABS( ierr ) ) - ! -#endif - - RETURN - END SUBROUTINE - -END SUBROUTINE sqr_tr_cannon_real - - -SUBROUTINE sqr_tr_cannon_cmplx( n, a, lda, b, ldb, desc ) - ! - ! Parallel square matrix transposition with Cannon's algorithm - ! - USE kinds, ONLY : DP - USE descriptors, ONLY : ilar_ , nlar_ , ilac_ , nlac_ , nlax_ , la_npc_ , la_n_ , & - la_comm_ , lambda_node_ , la_npr_ , la_myr_ , la_myc_ - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: n - INTEGER, INTENT(IN) :: lda, ldb - COMPLEX(DP) :: a(lda,*), b(ldb,*) - INTEGER, INTENT(IN) :: desc(*) - ! -#if defined (__MPI) - ! - INCLUDE 'mpif.h' - ! -#endif - ! - INTEGER :: ierr - INTEGER :: np, rowid, colid - INTEGER :: i, j, nr, nc, nb - INTEGER :: comm - ! - COMPLEX(DP), ALLOCATABLE :: ablk(:,:) - ! -#if defined (__MPI) - ! - INTEGER :: istatus( MPI_STATUS_SIZE ) - ! -#endif - ! - IF( desc( lambda_node_ ) < 0 ) THEN - RETURN - END IF - - IF( n < 1 ) THEN - RETURN - END IF - IF( desc( la_npr_ ) == 1 ) THEN - CALL mytransposezc( a, lda, b, ldb, n, n ) - RETURN - END IF - IF( desc( la_npr_ ) /= desc( la_npc_ ) ) & - CALL errore( ' sqr_tr_cannon ', ' works only with square processor mesh ', 1 ) - IF( n /= desc( la_n_ ) ) & - CALL errore( ' sqr_tr_cannon ', ' inconsistent size n ', 1 ) - IF( lda /= desc( nlax_ ) ) & - CALL errore( ' sqr_tr_cannon ', ' inconsistent size lda ', 1 ) - IF( ldb /= desc( nlax_ ) ) & - CALL errore( ' sqr_tr_cannon ', ' inconsistent size ldb ', 1 ) - - comm = desc( la_comm_ ) - - rowid = desc( la_myr_ ) - colid = desc( la_myc_ ) - np = desc( la_npr_ ) - ! - ! Compute the size of the local block - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - nb = desc( nlax_ ) - ! - allocate( ablk( nb, nb ) ) - DO j = 1, nc - DO i = 1, nr - ablk( i, j ) = a( i, j ) - END DO - END DO - DO j = nc+1, nb - DO i = 1, nb - ablk( i, j ) = CMPLX(0.d0,0.d0) - END DO - END DO - DO j = 1, nb - DO i = nr+1, nb - ablk( i, j ) = CMPLX(0.d0,0.d0) - END DO - END DO - ! - CALL exchange_block( ablk ) - ! -#if defined (__MPI) - CALL MPI_BARRIER( comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " sqr_tr_cannon ", " in MPI_BARRIER ", ABS( ierr ) ) -#endif - ! - DO j = 1, nr - DO i = 1, nc - b( j, i ) = CONJG(ablk( i, j )) - END DO - END DO - ! - deallocate( ablk ) - - RETURN - -CONTAINS - - SUBROUTINE exchange_block( blk ) - ! - ! Block exchange ( transpose ) - ! - IMPLICIT NONE - COMPLEX(DP) :: blk( :, : ) - ! - INTEGER :: icdst, irdst, icsrc, irsrc, idest, isour - ! - irdst = colid - icdst = rowid - irsrc = colid - icsrc = rowid - ! - CALL GRID2D_RANK( 'R', np, np, irdst, icdst, idest ) - CALL GRID2D_RANK( 'R', np, np, irsrc, icsrc, isour ) - ! -#if defined (__MPI) - ! - CALL MPI_SENDRECV_REPLACE(blk, nb*nb, MPI_DOUBLE_COMPLEX, & - idest, np+np+1, isour, np+np+1, comm, istatus, ierr) - IF( ierr /= 0 ) & - CALL errore( " sqr_tr_cannon ", " in MPI_SENDRECV_REPLACE ", ABS( ierr ) ) - ! -#endif - - RETURN - END SUBROUTINE - - -END SUBROUTINE sqr_tr_cannon_cmplx - -! - -SUBROUTINE redist_row2col_real( n, a, b, ldx, nx, desc ) - ! - ! redistribute a, array whose second dimension is distributed over processor row, - ! to obtain b, with the second dim. distributed over processor clolumn - ! - USE kinds, ONLY : DP - USE descriptors, ONLY : ilar_ , nlar_ , ilac_ , nlac_ , nlax_ , la_npc_ , la_n_ , & - la_comm_ , lambda_node_ , la_npr_ , la_myr_ , la_myc_ - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: n - INTEGER, INTENT(IN) :: ldx, nx - REAL(DP) :: a(ldx,nx), b(ldx,nx) - INTEGER, INTENT(IN) :: desc(*) - ! -#if defined (__MPI) - ! - INCLUDE 'mpif.h' - ! -#endif - ! - INTEGER :: ierr - INTEGER :: np, rowid, colid - INTEGER :: comm - INTEGER :: icdst, irdst, icsrc, irsrc, idest, isour - ! -#if defined (__MPI) - ! - INTEGER :: istatus( MPI_STATUS_SIZE ) - ! -#endif - ! - IF( desc( lambda_node_ ) < 0 ) THEN - RETURN - END IF - - IF( n < 1 ) THEN - RETURN - END IF - - IF( desc( la_npr_ ) == 1 ) THEN - b = a - RETURN - END IF - - IF( desc( la_npr_ ) /= desc( la_npc_ ) ) & - CALL errore( ' redist_row2col ', ' works only with square processor mesh ', 1 ) - IF( n /= desc( la_n_ ) ) & - CALL errore( ' redist_row2col ', ' inconsistent size n ', 1 ) - IF( nx /= desc( nlax_ ) ) & - CALL errore( ' redist_row2col ', ' inconsistent size lda ', 1 ) - - comm = desc( la_comm_ ) - - rowid = desc( la_myr_ ) - colid = desc( la_myc_ ) - np = desc( la_npr_ ) - ! - irdst = colid - icdst = rowid - irsrc = colid - icsrc = rowid - ! - CALL GRID2D_RANK( 'R', np, np, irdst, icdst, idest ) - CALL GRID2D_RANK( 'R', np, np, irsrc, icsrc, isour ) - ! -#if defined (__MPI) - ! - CALL MPI_BARRIER( comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " redist_row2col ", " in MPI_BARRIER ", ABS( ierr ) ) - ! - CALL MPI_SENDRECV(a, ldx*nx, MPI_DOUBLE_PRECISION, idest, np+np+1, & - b, ldx*nx, MPI_DOUBLE_PRECISION, isour, np+np+1, comm, istatus, ierr) - IF( ierr /= 0 ) & - CALL errore( " redist_row2col ", " in MPI_SENDRECV ", ABS( ierr ) ) - ! -#else - b = a -#endif - ! - RETURN - -END SUBROUTINE redist_row2col_real - -SUBROUTINE redist_row2col_cmplx( n, a, b, ldx, nx, desc ) - ! - ! redistribute a, array whose second dimension is distributed over processor row, - ! to obtain b, with the second dim. distributed over processor clolumn - ! - USE kinds, ONLY : DP - USE descriptors, ONLY : ilar_ , nlar_ , ilac_ , nlac_ , nlax_ , la_npc_ , la_n_ , & - la_comm_ , lambda_node_ , la_npr_ , la_myr_ , la_myc_ - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: n - INTEGER, INTENT(IN) :: ldx, nx - COMPLEX(DP) :: a(ldx,nx), b(ldx,nx) - INTEGER, INTENT(IN) :: desc(*) - ! -#if defined (__MPI) - ! - INCLUDE 'mpif.h' - ! -#endif - ! - INTEGER :: ierr - INTEGER :: np, rowid, colid - INTEGER :: comm - INTEGER :: icdst, irdst, icsrc, irsrc, idest, isour - ! -#if defined (__MPI) - ! - INTEGER :: istatus( MPI_STATUS_SIZE ) - ! -#endif - ! - IF( desc( lambda_node_ ) < 0 ) THEN - RETURN - END IF - - IF( n < 1 ) THEN - RETURN - END IF - - IF( desc( la_npr_ ) == 1 ) THEN - b = a - RETURN - END IF - - IF( desc( la_npr_ ) /= desc( la_npc_ ) ) & - CALL errore( ' redist_row2col ', ' works only with square processor mesh ', 1 ) - IF( n /= desc( la_n_ ) ) & - CALL errore( ' redist_row2col ', ' inconsistent size n ', 1 ) - IF( nx /= desc( nlax_ ) ) & - CALL errore( ' redist_row2col ', ' inconsistent size lda ', 1 ) - - comm = desc( la_comm_ ) - - rowid = desc( la_myr_ ) - colid = desc( la_myc_ ) - np = desc( la_npr_ ) - ! - irdst = colid - icdst = rowid - irsrc = colid - icsrc = rowid - ! - CALL GRID2D_RANK( 'R', np, np, irdst, icdst, idest ) - CALL GRID2D_RANK( 'R', np, np, irsrc, icsrc, isour ) - ! -#if defined (__MPI) - ! - CALL MPI_BARRIER( comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " redist_row2col ", " in MPI_BARRIER ", ABS( ierr ) ) - ! - CALL MPI_SENDRECV(a, ldx*nx, MPI_DOUBLE_COMPLEX, idest, np+np+1, & - b, ldx*nx, MPI_DOUBLE_COMPLEX, isour, np+np+1, comm, istatus, ierr) - IF( ierr /= 0 ) & - CALL errore( " redist_row2col ", " in MPI_SENDRECV ", ABS( ierr ) ) - ! -#else - b = a -#endif - ! - RETURN - -END SUBROUTINE redist_row2col_cmplx - -! -! -! - -SUBROUTINE cyc2blk_redist( n, a, lda, nca, b, ldb, ncb, desc ) - ! - ! Parallel square matrix redistribution. - ! A (input) is cyclically distributed by rows across processors - ! B (output) is distributed by block across 2D processors grid - ! - USE kinds, ONLY : DP - USE descriptors, ONLY : ilar_ , nlar_ , ilac_ , nlac_ , nlax_ , lambda_node_ , la_npr_ , & - descla_siz_ , la_npc_ , la_n_ , la_me_ , la_comm_ - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: n - INTEGER, INTENT(IN) :: lda, nca, ldb, ncb - REAL(DP) :: a( lda, nca ), b( ldb, ncb ) - INTEGER :: desc( descla_siz_ ) - ! -#if defined (__MPI) - ! - include 'mpif.h' - ! -#endif - ! - integer :: ierr, itag - integer :: np, ip, me, nproc, comm_a - integer :: ip_ir, ip_ic, ip_nr, ip_nc, il, nbuf, ip_irl - integer :: i, ii, j, jj, nr, nc, nb, nrl, irl, ir, ic - ! - real(DP), allocatable :: rcvbuf(:,:,:) - real(DP), allocatable :: sndbuf(:,:) - integer, allocatable :: ip_desc(:,:) - ! - character(len=256) :: msg - ! -#if defined (__MPI) - - IF( desc( lambda_node_ ) < 0 ) THEN - RETURN - END IF - - np = desc( la_npr_ ) ! dimension of the processor mesh - nb = desc( nlax_ ) ! leading dimension of the local matrix block - me = desc( la_me_ ) ! my processor id (starting from 0) - comm_a = desc( la_comm_ ) - nproc = desc( la_npr_ ) * desc( la_npc_ ) - - IF( np /= desc( la_npc_ ) ) & - CALL errore( ' cyc2blk_redist ', ' works only with square processor mesh ', 1 ) - IF( n < 1 ) & - CALL errore( ' cyc2blk_redist ', ' n less or equal zero ', 1 ) - IF( desc( la_n_ ) < nproc ) & - CALL errore( ' cyc2blk_redist ', ' nb less than the number of proc ', 1 ) - - ALLOCATE( ip_desc( descla_siz_ , nproc ) ) - - CALL mpi_barrier( comm_a, ierr ) - - CALL mpi_allgather( desc, descla_siz_ , mpi_integer, ip_desc, descla_siz_ , mpi_integer, comm_a, ierr ) - IF( ierr /= 0 ) & - CALL errore( " cyc2blk_redist ", " in mpi_allgather ", ABS( ierr ) ) - ! - nbuf = (nb/nproc+2) * nb - ! - ALLOCATE( sndbuf( nb/nproc+2, nb ) ) - ALLOCATE( rcvbuf( nb/nproc+2, nb, nproc ) ) - - DO ip = 0, nproc - 1 - ! - IF( ip_desc( nlax_ , ip + 1 ) /= nb ) & - CALL errore( ' cyc2blk_redist ', ' inconsistent block dim nb ', 1 ) - ! - IF( ip_desc( lambda_node_ , ip + 1 ) > 0 ) THEN - - ip_nr = ip_desc( nlar_ , ip + 1) - ip_nc = ip_desc( nlac_ , ip + 1) - ip_ir = ip_desc( ilar_ , ip + 1) - ip_ic = ip_desc( ilac_ , ip + 1) - ! - DO j = 1, ip_nc - jj = j + ip_ic - 1 - il = 1 - DO i = 1, ip_nr - ii = i + ip_ir - 1 - IF( MOD( ii - 1, nproc ) == me ) THEN - CALL check_sndbuf_index() - sndbuf( il, j ) = a( ( ii - 1 )/nproc + 1, jj ) - il = il + 1 - END IF - END DO - END DO - - END IF - - CALL mpi_barrier( comm_a, ierr ) - - CALL mpi_gather( sndbuf, nbuf, mpi_double_precision, & - rcvbuf, nbuf, mpi_double_precision, ip, comm_a, ierr ) - IF( ierr /= 0 ) & - CALL errore( " cyc2blk_redist ", " in mpi_gather ", ABS( ierr ) ) - - END DO - - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - ir = desc( ilar_ ) - ic = desc( ilac_ ) - ! - DO ip = 0, nproc - 1 - DO j = 1, nc - il = 1 - DO i = 1, nr - ii = i + ir - 1 - IF( MOD( ii - 1, nproc ) == ip ) THEN - CALL check_rcvbuf_index() - b( i, j ) = rcvbuf( il, j, ip+1 ) - il = il + 1 - END IF - END DO - END DO - END DO - ! - ! - DEALLOCATE( ip_desc ) - DEALLOCATE( rcvbuf ) - DEALLOCATE( sndbuf ) - -#else - - b( 1:n, 1:n ) = a( 1:n, 1:n ) - -#endif - - RETURN - -CONTAINS - - SUBROUTINE check_sndbuf_index() - CHARACTER(LEN=38), SAVE :: msg = ' check_sndbuf_index in cyc2blk_redist ' - IF( j > SIZE(sndbuf,2) ) CALL errore( msg, ' j > SIZE(sndbuf,2) ', ip+1 ) - IF( il > SIZE(sndbuf,1) ) CALL errore( msg, ' il > SIZE(sndbuf,1) ', ip+1 ) - IF( ( ii - 1 )/nproc + 1 < 1 ) CALL errore( msg, ' ( ii - 1 )/nproc + 1 < 1 ', ip+1 ) - IF( ( ii - 1 )/nproc + 1 > lda ) CALL errore( msg, ' ( ii - 1 )/nproc + 1 > SIZE(a,1) ', ip+1 ) - IF( jj < 1 ) CALL errore( msg, ' jj < 1 ', ip+1 ) - IF( jj > n ) CALL errore( msg, ' jj > n ', ip+1 ) - RETURN - END SUBROUTINE check_sndbuf_index - - SUBROUTINE check_rcvbuf_index() - CHARACTER(LEN=38), SAVE :: msg = ' check_rcvbuf_index in cyc2blk_redist ' - IF( i > ldb ) CALL errore( msg, ' i > ldb ', ip+1 ) - IF( j > ldb ) CALL errore( msg, ' j > ldb ', ip+1 ) - IF( j > nb ) CALL errore( msg, ' j > nb ', ip+1 ) - IF( il > SIZE( rcvbuf, 1 ) ) CALL errore( msg, ' il too large ', ip+1 ) - RETURN - END SUBROUTINE check_rcvbuf_index - -END SUBROUTINE cyc2blk_redist - - -SUBROUTINE cyc2blk_zredist( n, a, lda, nca, b, ldb, ncb, desc ) - ! - ! Parallel square matrix redistribution. - ! A (input) is cyclically distributed by rows across processors - ! B (output) is distributed by block across 2D processors grid - ! - USE kinds, ONLY : DP - USE descriptors, ONLY : ilar_ , nlar_ , ilac_ , nlac_ , nlax_ , lambda_node_ , la_npr_ , & - descla_siz_ , la_npc_ , la_n_ , la_me_ , la_comm_ - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: n - INTEGER, INTENT(IN) :: lda, nca, ldb, ncb - COMPLEX(DP) :: a( lda, nca ), b( ldb, ncb ) - INTEGER :: desc( descla_siz_ ) - ! -#if defined (__MPI) - ! - include 'mpif.h' - ! -#endif - ! - integer :: ierr, itag - integer :: np, ip, me, nproc, comm_a - integer :: ip_ir, ip_ic, ip_nr, ip_nc, il, nbuf, ip_irl - integer :: i, ii, j, jj, nr, nc, nb, nrl, irl, ir, ic - ! - COMPLEX(DP), allocatable :: rcvbuf(:,:,:) - COMPLEX(DP), allocatable :: sndbuf(:,:) - integer, allocatable :: ip_desc(:,:) - ! - character(len=256) :: msg - ! -#if defined (__MPI) - - IF( desc( lambda_node_ ) < 0 ) THEN - RETURN - END IF - - np = desc( la_npr_ ) ! dimension of the processor mesh - nb = desc( nlax_ ) ! leading dimension of the local matrix block - me = desc( la_me_ ) ! my processor id (starting from 0) - comm_a = desc( la_comm_ ) - nproc = desc( la_npr_ ) * desc( la_npc_ ) - - IF( np /= desc( la_npc_ ) ) & - CALL errore( ' cyc2blk_zredist ', ' works only with square processor mesh ', 1 ) - IF( n < 1 ) & - CALL errore( ' cyc2blk_zredist ', ' n less or equal zero ', 1 ) - IF( desc( la_n_ ) < nproc ) & - CALL errore( ' cyc2blk_zredist ', ' nb less than the number of proc ', 1 ) - - ALLOCATE( ip_desc( descla_siz_ , nproc ) ) - - CALL mpi_barrier( comm_a, ierr ) - - CALL mpi_allgather( desc, descla_siz_ , mpi_integer, ip_desc, descla_siz_ , mpi_integer, comm_a, ierr ) - IF( ierr /= 0 ) & - CALL errore( " cyc2blk_zredist ", " in mpi_allgather ", ABS( ierr ) ) - ! - nbuf = (nb/nproc+2) * nb - ! - ALLOCATE( sndbuf( nb/nproc+2, nb ) ) - ALLOCATE( rcvbuf( nb/nproc+2, nb, nproc ) ) - - DO ip = 0, nproc - 1 - ! - IF( ip_desc( lambda_node_ , ip + 1 ) > 0 ) THEN - - ip_nr = ip_desc( nlar_ , ip + 1) - ip_nc = ip_desc( nlac_ , ip + 1) - ip_ir = ip_desc( ilar_ , ip + 1) - ip_ic = ip_desc( ilac_ , ip + 1) - ! - DO j = 1, ip_nc - jj = j + ip_ic - 1 - il = 1 - DO i = 1, ip_nr - ii = i + ip_ir - 1 - IF( MOD( ii - 1, nproc ) == me ) THEN - CALL check_sndbuf_index() - sndbuf( il, j ) = a( ( ii - 1 )/nproc + 1, jj ) - il = il + 1 - END IF - END DO - END DO - - END IF - - CALL mpi_barrier( comm_a, ierr ) - - CALL mpi_gather( sndbuf, nbuf, mpi_double_complex, & - rcvbuf, nbuf, mpi_double_complex, ip, comm_a, ierr ) - IF( ierr /= 0 ) & - CALL errore( " cyc2blk_zredist ", " in mpi_gather ", ABS( ierr ) ) - - END DO - - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - ir = desc( ilar_ ) - ic = desc( ilac_ ) - ! - DO ip = 0, nproc - 1 - DO j = 1, nc - il = 1 - DO i = 1, nr - ii = i + ir - 1 - IF( MOD( ii - 1, nproc ) == ip ) THEN - CALL check_rcvbuf_index() - b( i, j ) = rcvbuf( il, j, ip+1 ) - il = il + 1 - END IF - END DO - END DO - END DO - ! - ! - DEALLOCATE( ip_desc ) - DEALLOCATE( rcvbuf ) - DEALLOCATE( sndbuf ) - -#else - - b( 1:n, 1:n ) = a( 1:n, 1:n ) - -#endif - - RETURN - -CONTAINS - - SUBROUTINE check_sndbuf_index() - CHARACTER(LEN=38), SAVE :: msg = ' check_sndbuf_index in cyc2blk_zredist ' - IF( j > SIZE(sndbuf,2) ) CALL errore( msg, ' j > SIZE(sndbuf,2) ', ip+1 ) - IF( il > SIZE(sndbuf,1) ) CALL errore( msg, ' il > SIZE(sndbuf,1) ', ip+1 ) - IF( ( ii - 1 )/nproc + 1 < 1 ) CALL errore( msg, ' ( ii - 1 )/nproc + 1 < 1 ', ip+1 ) - IF( ( ii - 1 )/nproc + 1 > SIZE(a,1) ) CALL errore( msg, ' ( ii - 1 )/nproc + 1 > SIZE(a,1) ', ip+1 ) - IF( jj < 1 ) CALL errore( msg, ' jj < 1 ', ip+1 ) - IF( jj > n ) CALL errore( msg, ' jj > n ', ip+1 ) - RETURN - END SUBROUTINE check_sndbuf_index - - SUBROUTINE check_rcvbuf_index() - CHARACTER(LEN=38), SAVE :: msg = ' check_rcvbuf_index in cyc2blk_zredist ' - IF( i > ldb ) CALL errore( msg, ' i > ldb ', ip+1 ) - IF( j > ldb ) CALL errore( msg, ' j > ldb ', ip+1 ) - IF( j > nb ) CALL errore( msg, ' j > nb ', ip+1 ) - IF( il > SIZE( rcvbuf, 1 ) ) CALL errore( msg, ' il too large ', ip+1 ) - RETURN - END SUBROUTINE check_rcvbuf_index - -END SUBROUTINE cyc2blk_zredist - - - - -SUBROUTINE blk2cyc_redist( n, a, lda, nca, b, ldb, ncb, desc ) - ! - ! Parallel square matrix redistribution. - ! A (output) is cyclically distributed by rows across processors - ! B (input) is distributed by block across 2D processors grid - ! - USE kinds, ONLY : DP - USE descriptors, ONLY : ilar_ , nlar_ , ilac_ , nlac_ , nlax_ , lambda_node_ , la_npr_ , & - descla_siz_ , la_npc_ , la_n_ , la_me_ , la_comm_ - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: n - INTEGER, INTENT(IN) :: lda, nca, ldb, ncb - REAL(DP) :: a( lda, nca ), b( ldb, ncb ) - INTEGER :: desc( descla_siz_ ) - ! -#if defined (__MPI) - ! - include 'mpif.h' - ! -#endif - ! - integer :: ierr, itag - integer :: np, ip, me, comm_a, nproc - integer :: ip_ir, ip_ic, ip_nr, ip_nc, il, nbuf, ip_irl - integer :: i, ii, j, jj, nr, nc, nb, nrl, irl, ir, ic - ! - real(DP), allocatable :: rcvbuf(:,:,:) - real(DP), allocatable :: sndbuf(:,:) - integer, allocatable :: ip_desc(:,:) - ! - character(len=256) :: msg - ! -#if defined (__MPI) - - IF( desc( lambda_node_ ) < 0 ) THEN - RETURN - END IF - - np = desc( la_npr_ ) ! dimension of the processor mesh - nb = desc( nlax_ ) ! leading dimension of the local matrix block - me = desc( la_me_ ) ! my processor id (starting from 0) - comm_a = desc( la_comm_ ) - nproc = desc( la_npr_ ) * desc( la_npc_ ) - - IF( np /= desc( la_npc_ ) ) & - CALL errore( ' blk2cyc_redist ', ' works only with square processor mesh ', 1 ) - IF( n < 1 ) & - CALL errore( ' blk2cyc_redist ', ' n less or equal zero ', 1 ) - IF( desc( la_n_ ) < nproc ) & - CALL errore( ' blk2cyc_redist ', ' nb less than the number of proc ', 1 ) - - ALLOCATE( ip_desc( descla_siz_ , nproc ) ) - - CALL mpi_barrier( comm_a, ierr ) - - CALL mpi_allgather( desc, descla_siz_ , mpi_integer, ip_desc, descla_siz_ , mpi_integer, comm_a, ierr ) - IF( ierr /= 0 ) & - CALL errore( " blk2cyc_redist ", " in mpi_allgather ", ABS( ierr ) ) - ! - nbuf = (nb/nproc+2) * nb - ! - ALLOCATE( sndbuf( nb/nproc+2, nb ) ) - ALLOCATE( rcvbuf( nb/nproc+2, nb, nproc ) ) - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - ir = desc( ilar_ ) - ic = desc( ilac_ ) - ! - DO ip = 0, nproc - 1 - DO j = 1, nc - il = 1 - DO i = 1, nr - ii = i + ir - 1 - IF( MOD( ii - 1, nproc ) == ip ) THEN - sndbuf( il, j ) = b( i, j ) - il = il + 1 - END IF - END DO - END DO - CALL mpi_barrier( comm_a, ierr ) - CALL mpi_gather( sndbuf, nbuf, mpi_double_precision, & - rcvbuf, nbuf, mpi_double_precision, ip, comm_a, ierr ) - IF( ierr /= 0 ) & - CALL errore( " blk2cyc_redist ", " in mpi_gather ", ABS( ierr ) ) - END DO - ! - - DO ip = 0, nproc - 1 - ! - IF( ip_desc( lambda_node_ , ip + 1 ) > 0 ) THEN - - ip_nr = ip_desc( nlar_ , ip + 1) - ip_nc = ip_desc( nlac_ , ip + 1) - ip_ir = ip_desc( ilar_ , ip + 1) - ip_ic = ip_desc( ilac_ , ip + 1) - ! - DO j = 1, ip_nc - jj = j + ip_ic - 1 - il = 1 - DO i = 1, ip_nr - ii = i + ip_ir - 1 - IF( MOD( ii - 1, nproc ) == me ) THEN - a( ( ii - 1 )/nproc + 1, jj ) = rcvbuf( il, j, ip+1 ) - il = il + 1 - END IF - END DO - END DO - - END IF - - END DO - ! - DEALLOCATE( ip_desc ) - DEALLOCATE( rcvbuf ) - DEALLOCATE( sndbuf ) - -#else - - a( 1:n, 1:n ) = b( 1:n, 1:n ) - -#endif - - RETURN - -END SUBROUTINE blk2cyc_redist - - -SUBROUTINE blk2cyc_zredist( n, a, lda, nca, b, ldb, ncb, desc ) - ! - ! Parallel square matrix redistribution. - ! A (output) is cyclically distributed by rows across processors - ! B (input) is distributed by block across 2D processors grid - ! - USE kinds, ONLY : DP - USE descriptors, ONLY : ilar_ , nlar_ , ilac_ , nlac_ , nlax_ , lambda_node_ , la_npr_ , & - descla_siz_ , la_npc_ , la_n_ , la_me_ , la_comm_ - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: n - INTEGER, INTENT(IN) :: lda, nca, ldb, ncb - COMPLEX(DP) :: a( lda, nca ), b( ldb, ncb ) - INTEGER :: desc( descla_siz_ ) - ! -#if defined (__MPI) - ! - include 'mpif.h' - ! -#endif - ! - integer :: ierr, itag - integer :: np, ip, me, comm_a, nproc - integer :: ip_ir, ip_ic, ip_nr, ip_nc, il, nbuf, ip_irl - integer :: i, ii, j, jj, nr, nc, nb, nrl, irl, ir, ic - ! - COMPLEX(DP), allocatable :: rcvbuf(:,:,:) - COMPLEX(DP), allocatable :: sndbuf(:,:) - integer, allocatable :: ip_desc(:,:) - ! - character(len=256) :: msg - ! -#if defined (__MPI) - - IF( desc( lambda_node_ ) < 0 ) THEN - RETURN - END IF - - np = desc( la_npr_ ) ! dimension of the processor mesh - nb = desc( nlax_ ) ! leading dimension of the local matrix block - me = desc( la_me_ ) ! my processor id (starting from 0) - comm_a = desc( la_comm_ ) - nproc = desc( la_npr_ ) * desc( la_npc_ ) - - IF( np /= desc( la_npc_ ) ) & - CALL errore( ' blk2cyc_zredist ', ' works only with square processor mesh ', 1 ) - IF( n < 1 ) & - CALL errore( ' blk2cyc_zredist ', ' n less or equal zero ', 1 ) - IF( desc( la_n_ ) < nproc ) & - CALL errore( ' blk2cyc_zredist ', ' nb less than the number of proc ', 1 ) - - ALLOCATE( ip_desc( descla_siz_ , nproc ) ) - - CALL mpi_barrier( comm_a, ierr ) - - CALL mpi_allgather( desc, descla_siz_ , mpi_integer, ip_desc, descla_siz_ , mpi_integer, comm_a, ierr ) - IF( ierr /= 0 ) & - CALL errore( " blk2cyc_zredist ", " in mpi_allgather ", ABS( ierr ) ) - ! - nbuf = (nb/nproc+2) * nb - ! - ALLOCATE( sndbuf( nb/nproc+2, nb ) ) - ALLOCATE( rcvbuf( nb/nproc+2, nb, nproc ) ) - ! - nr = desc( nlar_ ) - nc = desc( nlac_ ) - ir = desc( ilar_ ) - ic = desc( ilac_ ) - ! - DO ip = 0, nproc - 1 - DO j = 1, nc - il = 1 - DO i = 1, nr - ii = i + ir - 1 - IF( MOD( ii - 1, nproc ) == ip ) THEN - sndbuf( il, j ) = b( i, j ) - il = il + 1 - END IF - END DO - END DO - CALL mpi_barrier( comm_a, ierr ) - CALL mpi_gather( sndbuf, nbuf, mpi_double_complex, & - rcvbuf, nbuf, mpi_double_complex, ip, comm_a, ierr ) - IF( ierr /= 0 ) & - CALL errore( " blk2cyc_zredist ", " in mpi_gather ", ABS( ierr ) ) - END DO - ! - - DO ip = 0, nproc - 1 - ! - IF( ip_desc( lambda_node_ , ip + 1 ) > 0 ) THEN - - ip_nr = ip_desc( nlar_ , ip + 1) - ip_nc = ip_desc( nlac_ , ip + 1) - ip_ir = ip_desc( ilar_ , ip + 1) - ip_ic = ip_desc( ilac_ , ip + 1) - ! - DO j = 1, ip_nc - jj = j + ip_ic - 1 - il = 1 - DO i = 1, ip_nr - ii = i + ip_ir - 1 - IF( MOD( ii - 1, nproc ) == me ) THEN - a( ( ii - 1 )/nproc + 1, jj ) = rcvbuf( il, j, ip+1 ) - il = il + 1 - END IF - END DO - END DO - - END IF - - END DO - ! - DEALLOCATE( ip_desc ) - DEALLOCATE( rcvbuf ) - DEALLOCATE( sndbuf ) - -#else - - a( 1:n, 1:n ) = b( 1:n, 1:n ) - -#endif - - RETURN - -END SUBROUTINE blk2cyc_zredist -! -! -! -! Double Complex and Double Precision Cholesky Factorization of -! an Hermitan/Symmetric block distributed matrix -! written by Carlo Cavazzoni -! -! - -SUBROUTINE qe_pzpotrf( sll, ldx, n, desc ) - ! - use descriptors, ONLY: descla_local_dims, descla_siz_ , la_myr_ , la_myc_ , la_me_ , nlax_ ,& - nlar_ , nlac_ , ilar_ , ilac_ , la_comm_ , la_nx_ , la_npr_ , la_npc_ - use parallel_include - use kinds - ! - implicit none - ! - integer :: n, ldx - integer :: desc( descla_siz_ ) - real(DP) :: one, zero - complex(DP) :: sll( ldx, ldx ), cone, czero - integer :: myrow, mycol, ierr - integer :: jb, info, ib, kb - integer :: jnr, jir, jic, jnc - integer :: inr, iir, iic, inc - integer :: knr, kir, kic, knc - integer :: nr, nc - integer :: rcomm, ccomm, color, key, myid, np - complex(DP), allocatable :: ssnd( :, : ), srcv( :, : ) - - one = 1.0_DP - cone = 1.0_DP - zero = 0.0_DP - czero = 0.0_DP - -#if defined __MPI - - myrow = desc( la_myr_ ) - mycol = desc( la_myc_ ) - myid = desc( la_me_ ) - np = desc( la_npr_ ) - - IF( desc( la_npr_ ) /= desc( la_npc_ ) ) THEN - CALL errore( ' pzpotrf ', ' only square grid are allowed ', 1 ) - END IF - - IF( ldx /= desc( nlax_ ) ) THEN - CALL errore( ' pzpotrf ', ' wrong leading dimension ldx ', ldx ) - END IF - - nr = desc( nlar_ ) - nc = desc( nlac_ ) - - ALLOCATE( ssnd( ldx, ldx ) ) - ALLOCATE( srcv( ldx, ldx ) ) - - DO jb = 1, np - ! - ! Update and factorize the current diagonal block and test - ! for non-positive-definiteness. - ! - CALL descla_local_dims( jir, jnr, n, desc( la_nx_ ), np, jb-1 ) - ! - ! since we loop on diagonal blocks/procs we have jnc == jnr - ! - jnc = jnr - ! - ! prepare row and colum communicators - IF( ( myrow >= ( jb-1 ) ) .AND. ( mycol <= ( jb-1 ) ) ) THEN - color = mycol - key = myrow - ELSE - color = np - key = myid - END IF - ! - CALL mpi_comm_split( desc( la_comm_ ) , color, key, ccomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pzpotrf ", " in mpi_comm_split 1 ", ABS( ierr ) ) - ! - IF( myrow >= jb-1 .and. mycol <= jb-1 ) THEN - color = myrow - key = mycol - ELSE - color = np - key = myid - END IF - ! - CALL mpi_comm_split( desc( la_comm_ ), color, key, rcomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pzpotrf ", " in mpi_comm_split 2 ", ABS( ierr ) ) - ! - ! here every process can work independently, then we need a reduce. - ! - IF( jb > 1 ) THEN - ! - DO ib = 1, jb - 1 - IF( ( myrow == ( jb - 1 ) ) .AND. ( mycol == ( ib - 1 ) ) ) THEN - ! - ! this is because only the lover triangle of ssnd will be set to 0 by ZHERK - ! - ssnd = 0.0_DP - ! - ! remember: matrix ssnd is nr*nr, and procs on the diagonale have nr == nc - ! - CALL ZHERK( 'L', 'N', nr, nc, -ONE, sll, ldx, zero, ssnd, ldx ) - ! - END IF - END DO - IF( ( myrow == ( jb - 1 ) ) .AND. ( mycol == ( jb - 1 ) ) ) THEN - ssnd = sll - END IF - ! - IF( ( myrow == ( jb - 1 ) ) .AND. ( mycol <= ( jb - 1 ) ) ) THEN - ! - ! accumulate on the diagonal block/proc - ! - CALL mpi_barrier( rcomm, ierr ) - - CALL MPI_REDUCE( ssnd, sll, ldx*ldx, MPI_DOUBLE_COMPLEX, MPI_SUM, jb-1, rcomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pzpotrf ", " in MPI_REDUCE 1 ", ABS( ierr ) ) - ! - END IF - ! - END IF - ! - ! Only proj ( jb-1, jb-1 ) operates this - ! - info = 0 - ! - IF( ( myrow == ( jb - 1 ) ) .AND. ( mycol == ( jb - 1 ) ) ) THEN - CALL ZPOTF2( 'L', jnr, sll, ldx, INFO ) - IF( info /= 0 ) & - CALL errore( " pzpotrf ", " problems computing cholesky decomposition ", ABS( info ) ) - END IF - ! - IF( ( jb > 1 ) .AND. ( jb < np ) ) THEN - ! - ! Compute the current block column. - ! - ! processors ( 1 : jb - 1, jb ) should bcast their blocs - ! along column to processor ( 1 : jb - 1, jb + 1 : nb ) - ! - IF( ( myrow == ( jb - 1 ) ) .AND. ( mycol < ( jb - 1 ) ) ) THEN - CALL mpi_barrier( ccomm, ierr ) - CALL mpi_bcast( sll, ldx*ldx, MPI_DOUBLE_COMPLEX, 0, ccomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pzpotrf ", " in mpi_bcast 1 ", ABS( ierr ) ) - ELSE IF( ( myrow > ( jb - 1 ) ) .AND. ( mycol < ( jb - 1 ) ) ) THEN - CALL mpi_barrier( ccomm, ierr ) - CALL mpi_bcast( srcv, ldx*ldx, MPI_DOUBLE_COMPLEX, 0, ccomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pzpotrf ", " in mpi_bcast 2 ", ABS( ierr ) ) - END IF - ! - DO ib = jb + 1, np - CALL descla_local_dims( iir, inr, n, desc( la_nx_ ), np, ib-1 ) - DO kb = 1, jb - 1 - CALL descla_local_dims( kic, knc, n, desc( la_nx_ ), np, kb-1 ) - IF( ( myrow == ( ib - 1 ) ) .AND. ( mycol == ( kb - 1 ) ) ) THEN - CALL ZGEMM( 'N', 'C', inr, jnr, knc, -CONE, sll, ldx, srcv, ldx, czero, ssnd, ldx ) - END IF - END DO - IF( ( myrow == ( ib - 1 ) ) .AND. ( mycol == ( jb - 1 ) ) ) THEN - ssnd = sll - END IF - END DO - ! - ! processors ( jb, jb + 1 : nb ) should collect block along row, - ! from processors ( 1 : jb - 1, jb + 1 : nb ) - ! - DO kb = jb + 1, np - IF( ( myrow == ( kb - 1 ) ) .AND. ( mycol <= ( jb - 1 ) ) ) THEN - IF( ( jb == 1 ) ) THEN - IF( mycol == ( jb - 1 ) ) THEN - sll = ssnd - END IF - ELSE - CALL mpi_barrier( rcomm, ierr ) - CALL MPI_REDUCE( ssnd, sll, ldx*ldx, MPI_DOUBLE_COMPLEX, MPI_SUM, jb-1, rcomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pzpotrf ", " in mpi_reduce 2 ", ABS( ierr ) ) - END IF - END IF - END DO - ! - END IF - ! - IF( jb < np ) THEN - ! - ! processor "jb,jb" should broadcast his block to procs ( jb+1 : nb, jb ) - ! - IF( ( myrow == ( jb - 1 ) ) .AND. ( mycol == ( jb - 1 ) ) ) THEN - CALL mpi_barrier( ccomm, ierr ) - CALL mpi_bcast( sll, ldx*ldx, MPI_DOUBLE_COMPLEX, 0, ccomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pzpotrf ", " in mpi_bcast 3 ", ABS( ierr ) ) - ELSE IF( ( myrow > ( jb - 1 ) ) .AND. ( mycol == ( jb - 1 ) ) ) THEN - CALL mpi_barrier( ccomm, ierr ) - CALL mpi_bcast( srcv, ldx*ldx, MPI_DOUBLE_COMPLEX, 0, ccomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pzpotrf ", " in mpi_bcast 4 ", ABS( ierr ) ) - END IF - ! - DO ib = jb + 1, np - IF( ( myrow == ( ib - 1 ) ) .AND. ( mycol == ( jb - 1 ) ) ) THEN - CALL ZTRSM( 'R', 'L', 'C', 'N', nr, nc, CONE, srcv, ldx, sll, ldx ) - END IF - END DO - ! - END IF - ! - CALL mpi_comm_free( rcomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pzpotrf ", " in mpi_comm_free 1 ", ABS( ierr ) ) - ! - CALL mpi_comm_free( ccomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pzpotrf ", " in mpi_comm_free 2 ", ABS( ierr ) ) - ! - END DO - - DEALLOCATE( srcv, ssnd ) - -#else - - CALL ZPOTRF( 'L', n, sll, ldx, info ) - - IF( info /= 0 ) & - CALL errore( " pzpotrf ", " problems computing cholesky decomposition ", ABS( info ) ) - -#endif - - return -END SUBROUTINE qe_pzpotrf - -! now the Double Precision subroutine - -SUBROUTINE qe_pdpotrf( sll, ldx, n, desc ) - ! - use descriptors, ONLY: descla_local_dims, descla_siz_ , la_myr_ , la_myc_ , la_me_ , nlax_ , & - nlar_ , nlac_ , ilar_ , ilac_ , la_comm_ , la_nx_ , la_npr_ , la_npc_ - use parallel_include - use kinds - ! - implicit none - ! - integer :: n, ldx - integer :: desc( descla_siz_ ) - REAL(DP) :: one, zero - REAL(DP) :: sll( ldx, ldx ) - integer :: myrow, mycol, ierr - integer :: jb, info, ib, kb - integer :: jnr, jir, jic, jnc - integer :: inr, iir, iic, inc - integer :: knr, kir, kic, knc - integer :: nr, nc - integer :: rcomm, ccomm, color, key, myid, np - REAL(DP), ALLOCATABLE :: ssnd( :, : ), srcv( :, : ) - - one = 1.0_DP - zero = 0.0_DP - -#if defined __MPI - - myrow = desc( la_myr_ ) - mycol = desc( la_myc_ ) - myid = desc( la_me_ ) - np = desc( la_npr_ ) - - IF( desc( la_npr_ ) /= desc( la_npc_ ) ) THEN - CALL errore( ' pdpotrf ', ' only square grid are allowed ', 1 ) - END IF - - IF( ldx /= desc( nlax_ ) ) THEN - CALL errore( ' pdpotrf ', ' wrong leading dimension ldx ', ldx ) - END IF - - nr = desc( nlar_ ) - nc = desc( nlac_ ) - - ALLOCATE( ssnd( ldx, ldx ) ) - ALLOCATE( srcv( ldx, ldx ) ) - - DO jb = 1, np - ! - ! Update and factorize the current diagonal block and test - ! for non-positive-definiteness. - ! - CALL descla_local_dims( jir, jnr, n, desc( la_nx_ ), np, jb-1 ) - ! - ! since we loop on diagonal blocks/procs we have jnc == jnr - ! - jnc = jnr - ! - ! prepare row and colum communicators - IF( ( myrow >= ( jb-1 ) ) .AND. ( mycol <= ( jb-1 ) ) ) THEN - color = mycol - key = myrow - ELSE - color = np - key = myid - END IF - ! - CALL mpi_comm_split( desc( la_comm_ ) , color, key, ccomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdpotrf ", " in mpi_comm_split 1 ", ABS( ierr ) ) - ! - IF( myrow >= jb-1 .and. mycol <= jb-1 ) THEN - color = myrow - key = mycol - ELSE - color = np - key = myid - END IF - ! - CALL mpi_comm_split( desc( la_comm_ ), color, key, rcomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdpotrf ", " in mpi_comm_split 2 ", ABS( ierr ) ) - ! - ! here every process can work independently, then we need a reduce. - ! - IF( jb > 1 ) THEN - ! - DO ib = 1, jb - 1 - IF( ( myrow == ( jb - 1 ) ) .AND. ( mycol == ( ib - 1 ) ) ) THEN - ! - ! this is because only the lover triangle of ssnd will be set to 0 by ZHERK - ! - ssnd = 0_DP - ! - ! remember: matrix ssnd is nr*nr, and procs on the diagonale have nr == nc - ! - CALL DSYRK( 'L', 'N', nr, nc, -ONE, sll, ldx, zero, ssnd, ldx ) - ! - END IF - END DO - IF( ( myrow == ( jb - 1 ) ) .AND. ( mycol == ( jb - 1 ) ) ) THEN - ssnd = sll - END IF - ! - IF( ( myrow == ( jb - 1 ) ) .AND. ( mycol <= ( jb - 1 ) ) ) THEN - ! - ! accumulate on the diagonal block/proc - ! - CALL MPI_REDUCE( ssnd, sll, ldx*ldx, MPI_DOUBLE_PRECISION, MPI_SUM, jb-1, rcomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdpotrf ", " in MPI_REDUCE 1 ", ABS( ierr ) ) - ! - END IF - ! - END IF - ! - ! Only proj ( jb-1, jb-1 ) operates this - ! - info = 0 - ! - IF( ( myrow == ( jb - 1 ) ) .AND. ( mycol == ( jb - 1 ) ) ) THEN - CALL DPOTRF( 'L', jnr, sll, ldx, INFO ) - IF( info /= 0 ) & - CALL errore( " pdpotrf ", " problems computing cholesky decomposition ", ABS( info ) ) - END IF - ! - IF( ( jb > 1 ) .AND. ( jb < np ) ) THEN - ! - ! Compute the current block column. - ! - ! processors ( 1 : jb - 1, jb ) should bcast their blocs - ! along column to processor ( 1 : jb - 1, jb + 1 : nb ) - ! - IF( ( myrow == ( jb - 1 ) ) .AND. ( mycol < ( jb - 1 ) ) ) THEN - CALL mpi_barrier( ccomm, ierr ) - CALL mpi_bcast( sll, ldx*ldx, MPI_DOUBLE_PRECISION, 0, ccomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdpotrf ", " in mpi_bcast 1 ", ABS( ierr ) ) - ELSE IF( ( myrow > ( jb - 1 ) ) .AND. ( mycol < ( jb - 1 ) ) ) THEN - CALL mpi_barrier( ccomm, ierr ) - CALL mpi_bcast( srcv, ldx*ldx, MPI_DOUBLE_PRECISION, 0, ccomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdpotrf ", " in mpi_bcast 2 ", ABS( ierr ) ) - END IF - ! - DO ib = jb + 1, np - CALL descla_local_dims( iir, inr, n, desc( la_nx_ ), np, ib-1 ) - DO kb = 1, jb - 1 - CALL descla_local_dims( kic, knc, n, desc( la_nx_ ), np, kb-1 ) - IF( ( myrow == ( ib - 1 ) ) .AND. ( mycol == ( kb - 1 ) ) ) THEN - CALL DGEMM( 'N', 'T', inr, jnr, knc, -ONE, sll, ldx, srcv, ldx, zero, ssnd, ldx ) - END IF - END DO - IF( ( myrow == ( ib - 1 ) ) .AND. ( mycol == ( jb - 1 ) ) ) THEN - ssnd = sll - END IF - END DO - ! - ! processors ( jb, jb + 1 : nb ) should collect block along row, - ! from processors ( 1 : jb - 1, jb + 1 : nb ) - ! - DO kb = jb + 1, np - IF( ( myrow == ( kb - 1 ) ) .AND. ( mycol <= ( jb - 1 ) ) ) THEN - IF( ( jb == 1 ) ) THEN - IF( mycol == ( jb - 1 ) ) THEN - sll = ssnd - END IF - ELSE - CALL MPI_REDUCE( ssnd, sll, ldx*ldx, MPI_DOUBLE_PRECISION, MPI_SUM, jb-1, rcomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdpotrf ", " in mpi_reduce 2 ", ABS( ierr ) ) - END IF - END IF - END DO - ! - END IF - ! - IF( jb < np ) THEN - ! - ! processor "jb,jb" should broadcast his block to procs ( jb+1 : nb, jb ) - ! - IF( ( myrow == ( jb - 1 ) ) .AND. ( mycol == ( jb - 1 ) ) ) THEN - CALL mpi_barrier( ccomm, ierr ) - CALL mpi_bcast( sll, ldx*ldx, MPI_DOUBLE_PRECISION, 0, ccomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdpotrf ", " in mpi_bcast 3 ", ABS( ierr ) ) - ELSE IF( ( myrow > ( jb - 1 ) ) .AND. ( mycol == ( jb - 1 ) ) ) THEN - CALL mpi_barrier( ccomm, ierr ) - CALL mpi_bcast( srcv, ldx*ldx, MPI_DOUBLE_PRECISION, 0, ccomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdpotrf ", " in mpi_bcast 4 ", ABS( ierr ) ) - END IF - ! - DO ib = jb + 1, np - IF( ( myrow == ( ib - 1 ) ) .AND. ( mycol == ( jb - 1 ) ) ) THEN - CALL DTRSM( 'R', 'L', 'T', 'N', nr, nc, ONE, srcv, ldx, sll, ldx ) - END IF - END DO - ! - END IF - ! - CALL mpi_comm_free( rcomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdpotrf ", " in mpi_comm_free 1 ", ABS( ierr ) ) - - CALL mpi_comm_free( ccomm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdpotrf ", " in mpi_comm_free 2 ", ABS( ierr ) ) - ! - END DO - - DEALLOCATE( srcv, ssnd ) - -#else - - CALL DPOTRF( 'L', n, sll, ldx, info ) - - IF( info /= 0 ) & - CALL errore( " pzpotrf ", " problems computing cholesky decomposition ", ABS( info ) ) - -#endif - - return -END SUBROUTINE qe_pdpotrf - -! -! -! -! - -SUBROUTINE qe_pztrtri ( sll, ldx, n, desc ) - - ! pztrtri computes the parallel inversion of a lower triangular matrix - ! distribuited among the processes using a 2-D block partitioning. - ! The algorithm is based on the schema below and executes the model - ! recursively to each column C2 under the diagonal. - ! - ! |-------|-------| |--------------------|--------------------| - ! | A1 | 0 | | C1 = trtri(A1) | 0 | - ! A = |-------|-------| C = |--------------------|--------------------| - ! | A2 | A3 | | C2 = -C3 * A2 * C1 | C3 = trtri(A3) | - ! |-------|-------| |--------------------|--------------------| - ! - ! The recursive steps of multiplication (C2 = -C3 * A2 * C1) is based on the Cannon's algorithms - ! for parallel matrix multiplication and is done with BLACS(dgemm) - ! - ! - ! Arguments - ! ============ - ! - ! sll = local block of data - ! ldx = leading dimension of one block - ! n = size of the global array diributed among the blocks - ! desc = descriptor of the matrix distribution - ! - ! - ! written by Ivan Girotto - ! - - USE kinds - USE parallel_include - USE descriptors, ONLY: descla_local_dims, descla_siz_ , la_myr_ , la_myc_ , la_me_ , nlax_ , & - nlar_ , nlac_ , ilar_ , ilac_ , la_comm_ , la_nx_ , la_npr_ , la_npc_ - - IMPLICIT NONE - - INTEGER, INTENT( IN ) :: n, ldx - INTEGER, INTENT( IN ) :: desc( descla_siz_ ) - COMPLEX(DP), INTENT( INOUT ) :: sll( ldx, ldx ) - - COMPLEX(DP), PARAMETER :: ONE = (1.0_DP, 0.0_DP) - COMPLEX(DP), PARAMETER :: ZERO = (0.0_DP, 0.0_DP) - -#if defined __MPI - INTEGER :: status(MPI_STATUS_SIZE) -#endif - INTEGER :: req(2), ierr, col_comm - INTEGER :: send, recv, group_rank, group_size - INTEGER :: myrow, mycol, np, myid, comm - - ! counters - INTEGER :: k, i, j, count, step_count, shiftcount, cicle - INTEGER :: C3dim ! Dimension of submatrix B - INTEGER :: nc, nr ! Local dimension of block - INTEGER :: info, sup_recv - INTEGER :: idrowref, idcolref, idref, idrecv - - ! B and BUF_RECV are used to overload the computation of matrix multiplication and the shift of the blocks - COMPLEX(DP), ALLOCATABLE, DIMENSION( :, : ) :: B, C, BUF_RECV - COMPLEX(DP) :: first - - myrow = desc( la_myr_ ) - mycol = desc( la_myc_ ) - myid = desc( la_me_ ) - np = desc( la_npr_ ) - comm = desc( la_comm_ ) - - IF( desc( la_npr_ ) /= desc( la_npc_ ) ) THEN - CALL errore( ' pztrtri ', ' only square grid are allowed ', 1 ) - END IF - IF( ldx /= desc( nlax_ ) ) THEN - CALL errore( ' pztrtri ', ' wrong leading dimension ldx ', ldx ) - END IF - - nr = desc( nlar_ ) - nc = desc( nlac_ ) - - ! clear elements outside local meaningful block nr*nc - - DO j = nc+1, ldx - DO i = 1, ldx - sll( i, j ) = zero - END DO - END DO - DO j = 1, ldx - DO i = nr+1, ldx - sll( i, j ) = zero - END DO - END DO - -#if defined __MPI - - ALLOCATE( B( ldx, ldx ) ) - ALLOCATE( C( ldx, ldx ) ) - ALLOCATE( BUF_RECV ( ldx, ldx ) ) - - IF( np == 2 ) THEN - ! - ! special case with 4 proc, 2x2 grid - ! - IF( myrow == mycol ) THEN - CALL compute_ztrtri() - END IF - ! - CALL GRID2D_RANK( 'R', np, np, 1, 0, idref ) - ! - IF( myrow == 0 .AND. mycol == 0 ) THEN - CALL MPI_Send(sll, ldx*ldx, MPI_DOUBLE_COMPLEX, idref, 0, comm, ierr) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in mpi_send 1 ", ABS( ierr ) ) - END IF - ! - IF( myrow == 1 .AND. mycol == 1 ) THEN - CALL MPI_Send(sll, ldx*ldx, MPI_DOUBLE_COMPLEX, idref, 1, comm, ierr) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in mpi_send 2 ", ABS( ierr ) ) - END IF - ! - IF( myrow == 1 .AND. mycol == 0 ) THEN - ! - CALL GRID2D_RANK( 'R', np, np, 0, 0, i ) - CALL GRID2D_RANK( 'R', np, np, 1, 1, j ) - ! - CALL MPI_Irecv( B, ldx*ldx, MPI_DOUBLE_COMPLEX, i, 0, comm, req(1), ierr) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in mpi_irecv 3 ", ABS( ierr ) ) - ! - CALL MPI_Irecv( C, ldx*ldx, MPI_DOUBLE_COMPLEX, j, 1, comm, req(2), ierr) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in mpi_irecv 4 ", ABS( ierr ) ) - ! - CALL MPI_Wait(req(1), status, ierr) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Wait 5 ", ABS( ierr ) ) - ! - CALL zgemm('N', 'N', ldx, ldx, ldx, ONE, sll, ldx, b, ldx, ZERO, buf_recv, ldx) - ! - CALL MPI_Wait(req(2), status, ierr) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Wait 6 ", ABS( ierr ) ) - ! - CALL zgemm('N', 'N', ldx, ldx, ldx, -ONE, c, ldx, buf_recv, ldx, ZERO, sll, ldx) - ! - END IF - ! - IF( myrow == 0 .AND. mycol == 1 ) THEN - ! - sll = zero - ! - END IF - ! - DEALLOCATE( b, c, buf_recv ) - ! - RETURN - ! - END IF - - - IF( myrow >= mycol ) THEN - ! - ! only procs on lower triangle partecipates - ! - CALL MPI_Comm_split( comm, mycol, myrow, col_comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Comm_split 9 ", ABS( ierr ) ) - - CALL MPI_Comm_size( col_comm, group_size, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Comm_size 10 ", ABS( ierr ) ) - ! - CALL MPI_Comm_rank( col_comm, group_rank, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Comm_rank 11 ", ABS( ierr ) ) - ! - ELSE - ! - ! other procs stay at the window! - ! - CALL MPI_Comm_split( comm, MPI_UNDEFINED, MPI_UNDEFINED, col_comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Comm_split 12 ", ABS( ierr ) ) - ! - sll = zero - ! - END IF - ! - - ! Compute the inverse of a lower triangular - ! along the diagonal of the global array with BLAS(ztrtri) - ! - IF( mycol == myrow ) THEN - ! - CALL compute_ztrtri() - ! - ELSE IF( myrow > mycol ) THEN - ! - buf_recv = sll - ! - END IF - - IF( myrow >= mycol ) THEN - ! - ! Broadcast the diagonal blocks to the processors under the diagonal - ! - CALL MPI_Bcast( sll, ldx*ldx, MPI_DOUBLE_COMPLEX, 0, col_comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Bcast 13 ", ABS( ierr ) ) - ! - END IF - - ! Compute A2 * C1 and start the Cannon's algorithm shifting the blocks of column one place to the North - ! - IF( myrow > mycol ) THEN - ! - CALL zgemm( 'N', 'N', ldx, ldx, ldx, ONE, buf_recv, ldx, sll, ldx, ZERO, c, ldx ) - ! - send = shift( 1, group_rank, 1, ( group_size - 1 ), 'N' ) - recv = shift( 1, group_rank, 1, ( group_size - 1 ), 'S' ) - ! - CALL MPI_Sendrecv( c, ldx*ldx, MPI_DOUBLE_COMPLEX, send, 0, buf_recv, & - ldx*ldx, MPI_DOUBLE_COMPLEX, recv, 0, col_comm, status, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Sendrecv 14 ", ABS( ierr ) ) - ! - END IF - - ! Execute the Cannon's algorithm to compute ricorsively the multiplication of C2 = -C3 * A2 * C1 - ! - DO count = ( np - 2 ), 0, -1 - C3dim = (np-1) - count ! Dimension of the submatrix C3 - first = ZERO - cicle = 0 - IF( ( myrow > count ) .AND. ( mycol >= count ) ) THEN - idcolref = count + 1 - idrowref = myrow - CALL GRID2D_RANK( 'R', np, np, idrowref, idcolref, idref ) - idrecv = idref - 1 - ! Compute C2 = -C3 * A2 * C1 - DO shiftcount = count, np-2 - IF(mycol>count)THEN - ! Execute the virtual shift of the matrix C3 along the row in order to know which processor - ! have to send the block to C2 - IF( cicle == 0)THEN - ! virtual shift of the block i,j of the submatrix C3 i place to West - send = shift(idref, myid, myrow-count, C3dim, 'W') - ELSE - ! virtual shift of the block i,j of the submatrix C3 i place to West - send = shift(idref, send, 1, C3dim, 'E') - END IF - IF(send==idref)THEN - CALL MPI_Send(sll, ldx*ldx, MPI_DOUBLE_COMPLEX, idrecv, myid, comm, ierr) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Send 15 ", ABS( ierr ) ) - END IF - ELSE - IF( cicle == 0)THEN - ! virtual shift of the block i,j of the submatrix C3 i place to West - sup_recv = shift(idref, myid+1, myrow-count, C3dim, 'E') - ELSE - ! virtual shift of the block i,j of the submatrix C3 i place to West - sup_recv = shift(idref, sup_recv, 1, C3dim, 'W') - END IF - CALL MPI_Recv(C, ldx*ldx, MPI_DOUBLE_COMPLEX, sup_recv, sup_recv, comm, status, ierr) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Recv 16 ", ABS( ierr ) ) - send = shift(1, group_rank, 1, (group_size-1), 'S') - recv = shift(1, group_rank, 1, (group_size-1), 'N') - ! with the no-blocking communication the computation and the shift of the column block are overapped - ! - IF( MOD( cicle, 2 ) == 0 ) THEN - CALL MPI_Isend(BUF_RECV, ldx*ldx, MPI_DOUBLE_COMPLEX, send, group_rank+cicle, col_comm, req(1), ierr) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Isend 17 ", ABS( ierr ) ) - CALL MPI_Irecv(B, ldx*ldx, MPI_DOUBLE_COMPLEX, recv, recv+cicle, col_comm, req(2), ierr) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Irecv 18 ", ABS( ierr ) ) - CALL zgemm('N', 'N', ldx, ldx, ldx, -ONE, C, ldx, BUF_RECV, ldx, first, sll, ldx) - ELSE - CALL MPI_Isend(B, ldx*ldx, MPI_DOUBLE_COMPLEX, send, group_rank+cicle, col_comm, req(1), ierr) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Isend 19 ", ABS( ierr ) ) - CALL MPI_Irecv(BUF_RECV, ldx*ldx, MPI_DOUBLE_COMPLEX, recv, recv+cicle, col_comm, req(2), ierr) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Irecv 20 ", ABS( ierr ) ) - CALL zgemm('N', 'N', ldx, ldx, ldx, -ONE, C, ldx, B, ldx, ONE, sll, ldx) - END IF - ! - CALL MPI_Wait(req(1), status, ierr) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Wait 21 ", ABS( ierr ) ) - ! - CALL MPI_Wait(req(2), status, ierr) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in MPI_Wait 22 ", ABS( ierr ) ) - ! - END IF - cicle = cicle + 1 - first = ONE - END DO - END IF - END DO - - IF( myrow >= mycol ) THEN - CALL mpi_comm_free( col_comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pztrtri ", " in mpi_comm_free 25 ", ABS( ierr ) ) - END IF - - DEALLOCATE(B) - DEALLOCATE(C) - DEALLOCATE(BUF_RECV) - -#else - - CALL compute_ztrtri() - -#endif - - CONTAINS - - SUBROUTINE compute_ztrtri() - ! - ! clear the upper triangle (excluding diagonal terms) and - ! - DO j = 1, ldx - DO i = 1, j-1 - sll ( i, j ) = zero - END DO - END DO - ! - CALL ztrtri( 'L', 'N', nr, sll, ldx, info ) - ! - IF( info /= 0 ) THEN - CALL errore( ' pztrtri ', ' problem in the local inversion ', info ) - END IF - ! - END SUBROUTINE compute_ztrtri - - - INTEGER FUNCTION shift ( idref, id, pos, size, dir ) - - IMPLICIT NONE - - INTEGER :: idref, id, pos, size - CHARACTER ( LEN = 1 ) :: dir - - IF( ( dir == 'E' ) .OR. ( dir == 'S' ) ) THEN - shift = idref + MOD ( ( id - idref ) + pos, size ) - ELSE IF( ( dir == 'W' ) .OR. ( dir == 'N' ) ) THEN - shift = idref + MOD ( ( id - idref ) - pos + size, size ) - ELSE - shift = -1 - END IF - - RETURN - - END FUNCTION shift - -END SUBROUTINE qe_pztrtri - -! now the Double Precision subroutine - -SUBROUTINE qe_pdtrtri ( sll, ldx, n, desc ) - - ! pztrtri computes the parallel inversion of a lower triangular matrix - ! distribuited among the processes using a 2-D block partitioning. - ! The algorithm is based on the schema below and executes the model - ! recursively to each column C2 under the diagonal. - ! - ! |-------|-------| |--------------------|--------------------| - ! | A1 | 0 | | C1 = trtri(A1) | 0 | - ! A = |-------|-------| C = |--------------------|--------------------| - ! | A2 | A3 | | C2 = -C3 * A2 * C1 | C3 = trtri(A3) | - ! |-------|-------| |--------------------|--------------------| - ! - ! The recursive steps of multiplication (C2 = -C3 * A2 * C1) is based on the Cannon's algorithms - ! for parallel matrix multiplication and is done with BLACS(dgemm) - ! - ! - ! Arguments - ! ============ - ! - ! sll = local block of data - ! ldx = leading dimension of one block - ! n = size of the global array diributed among the blocks - ! desc = descriptor of the matrix distribution - ! - ! - ! written by Ivan Girotto - ! - - USE kinds - USE parallel_include - USE descriptors, ONLY: descla_local_dims, descla_siz_ , la_myr_ , la_myc_ , la_me_ , nlax_ , & - nlar_ , nlac_ , ilar_ , ilac_ , la_comm_ , la_nx_ , la_npr_ , la_npc_ - - IMPLICIT NONE - - INTEGER, INTENT( IN ) :: n, ldx - INTEGER, INTENT( IN ) :: desc( descla_siz_ ) - REAL(DP), INTENT( INOUT ) :: sll( ldx, ldx ) - - REAL(DP), PARAMETER :: ONE = 1.0_DP - REAL(DP), PARAMETER :: ZERO = 0.0_DP - -#if defined __MPI - INTEGER :: status(MPI_STATUS_SIZE) -#endif - INTEGER :: req(2), ierr, col_comm - INTEGER :: send, recv, group_rank, group_size - INTEGER :: myrow, mycol, np, myid, comm - - ! counters - INTEGER :: k, i, j, count, step_count, shiftcount, cicle - INTEGER :: C3dim ! Dimension of submatrix B - INTEGER :: nc, nr ! Local dimension of block - INTEGER :: info, sup_recv - INTEGER :: idrowref, idcolref, idref, idrecv - - ! B and BUF_RECV are used to overload the computation of matrix multiplication and the shift of the blocks - REAL(DP), ALLOCATABLE, DIMENSION( :, : ) :: B, C, BUF_RECV - REAL(DP) :: first - - myrow = desc( la_myr_ ) - mycol = desc( la_myc_ ) - myid = desc( la_me_ ) - np = desc( la_npr_ ) - comm = desc( la_comm_ ) - - IF( desc( la_npr_ ) /= desc( la_npc_ ) ) THEN - CALL errore( ' pdtrtri ', ' only square grid are allowed ', 1 ) - END IF - IF( ldx /= desc( nlax_ ) ) THEN - CALL errore( ' pdtrtri ', ' wrong leading dimension ldx ', ldx ) - END IF - - nr = desc( nlar_ ) - nc = desc( nlac_ ) - - ! clear elements outside local meaningful block nr*nc - - DO j = nc+1, ldx - DO i = 1, ldx - sll( i, j ) = zero - END DO - END DO - DO j = 1, ldx - DO i = nr+1, ldx - sll( i, j ) = zero - END DO - END DO - -#if defined __MPI - - ALLOCATE( B( ldx, ldx ) ) - ALLOCATE( C( ldx, ldx ) ) - ALLOCATE( BUF_RECV ( ldx, ldx ) ) - - IF( np == 2 ) THEN - ! - ! special case with 4 proc, 2x2 grid - ! - IF( myrow == mycol ) THEN - CALL compute_dtrtri() - END IF - ! - CALL GRID2D_RANK( 'R', np, np, 1, 0, idref ) - ! - IF( myrow == 0 .AND. mycol == 0 ) THEN - CALL MPI_Send(sll, ldx*ldx, MPI_DOUBLE_PRECISION, idref, 0, comm, ierr) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Send 1 ", ABS( ierr ) ) - END IF - ! - IF( myrow == 1 .AND. mycol == 1 ) THEN - CALL MPI_Send(sll, ldx*ldx, MPI_DOUBLE_PRECISION, idref, 1, comm, ierr) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Send 2 ", ABS( ierr ) ) - END IF - ! - IF( myrow == 1 .AND. mycol == 0 ) THEN - ! - CALL GRID2D_RANK( 'R', np, np, 0, 0, i ) - CALL GRID2D_RANK( 'R', np, np, 1, 1, j ) - ! - CALL MPI_Irecv( B, ldx*ldx, MPI_DOUBLE_PRECISION, i, 0, comm, req(1), ierr) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Irecv 3 ", ABS( ierr ) ) - ! - CALL MPI_Irecv( C, ldx*ldx, MPI_DOUBLE_PRECISION, j, 1, comm, req(2), ierr) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Irecv 4 ", ABS( ierr ) ) - ! - CALL MPI_Wait(req(1), status, ierr) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Wait 5 ", ABS( ierr ) ) - ! - CALL dgemm('N', 'N', ldx, ldx, ldx, ONE, sll, ldx, b, ldx, ZERO, buf_recv, ldx) - ! - CALL MPI_Wait(req(2), status, ierr) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Wait 6 ", ABS( ierr ) ) - ! - CALL dgemm('N', 'N', ldx, ldx, ldx, -ONE, c, ldx, buf_recv, ldx, ZERO, sll, ldx) - ! - END IF - ! - IF( myrow == 0 .AND. mycol == 1 ) THEN - ! - sll = zero - ! - END IF - ! - DEALLOCATE( b, c, buf_recv ) - ! - RETURN - ! - END IF - - - IF( myrow >= mycol ) THEN - ! - ! only procs on lower triangle partecipates - ! - CALL MPI_Comm_split( comm, mycol, myrow, col_comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Comm_split 9 ", ABS( ierr ) ) - - CALL MPI_Comm_size( col_comm, group_size, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Comm_size 10 ", ABS( ierr ) ) - - CALL MPI_Comm_rank( col_comm, group_rank, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Comm_rank 11 ", ABS( ierr ) ) - ! - ELSE - ! - ! other procs stay at the window! - ! - CALL MPI_Comm_split( comm, MPI_UNDEFINED, MPI_UNDEFINED, col_comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Comm_split 12 ", ABS( ierr ) ) - ! - sll = zero - ! - END IF - ! - - ! Compute the inverse of a lower triangular - ! along the diagonal of the global array with BLAS(ztrtri) - ! - IF( mycol == myrow ) THEN - ! - CALL compute_dtrtri() - ! - ELSE IF( myrow > mycol ) THEN - ! - buf_recv = sll - ! - END IF - - IF( myrow >= mycol ) THEN - ! - ! Broadcast the diagonal blocks to the processors under the diagonal - ! - CALL MPI_Bcast( sll, ldx*ldx, MPI_DOUBLE_PRECISION, 0, col_comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Bcast 13 ", ABS( ierr ) ) - ! - END IF - - ! Compute A2 * C1 and start the Cannon's algorithm shifting the blocks of column one place to the North - ! - IF( myrow > mycol ) THEN - ! - CALL dgemm( 'N', 'N', ldx, ldx, ldx, ONE, buf_recv, ldx, sll, ldx, ZERO, c, ldx ) - ! - send = shift( 1, group_rank, 1, ( group_size - 1 ), 'N' ) - recv = shift( 1, group_rank, 1, ( group_size - 1 ), 'S' ) - ! - CALL MPI_Sendrecv( c, ldx*ldx, MPI_DOUBLE_PRECISION, send, 0, buf_recv, & - ldx*ldx, MPI_DOUBLE_PRECISION, recv, 0, col_comm, status, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Sendrecv 14 ", ABS( ierr ) ) - ! - END IF - - ! Execute the Cannon's algorithm to compute ricorsively the multiplication of C2 = -C3 * A2 * C1 - ! - DO count = ( np - 2 ), 0, -1 - C3dim = (np-1) - count ! Dimension of the submatrix C3 - first = ZERO - cicle = 0 - IF( ( myrow > count ) .AND. ( mycol >= count ) ) THEN - idcolref = count + 1 - idrowref = myrow - CALL GRID2D_RANK( 'R', np, np, idrowref, idcolref, idref ) - idrecv = idref - 1 - ! Compute C2 = -C3 * A2 * C1 - DO shiftcount = count, np-2 - IF(mycol>count)THEN - ! Execute the virtual shift of the matrix C3 along the row in order to know which processor - ! have to send the block to C2 - IF( cicle == 0)THEN - ! virtual shift of the block i,j of the submatrix C3 i place to West - send = shift(idref, myid, myrow-count, C3dim, 'W') - ELSE - ! virtual shift of the block i,j of the submatrix C3 i place to West - send = shift(idref, send, 1, C3dim, 'E') - END IF - IF(send==idref)THEN - CALL MPI_Send(sll, ldx*ldx, MPI_DOUBLE_PRECISION, idrecv, myid, comm, ierr) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Send 15 ", ABS( ierr ) ) - END IF - ELSE - IF( cicle == 0)THEN - ! virtual shift of the block i,j of the submatrix C3 i place to West - sup_recv = shift(idref, myid+1, myrow-count, C3dim, 'E') - ELSE - ! virtual shift of the block i,j of the submatrix C3 i place to West - sup_recv = shift(idref, sup_recv, 1, C3dim, 'W') - END IF - CALL MPI_Recv(C, ldx*ldx, MPI_DOUBLE_PRECISION, sup_recv, sup_recv, comm, status, ierr) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Recv 16 ", ABS( ierr ) ) - send = shift(1, group_rank, 1, (group_size-1), 'S') - recv = shift(1, group_rank, 1, (group_size-1), 'N') - ! with the no-blocking communication the computation and the shift of the column block are overapped - IF( MOD( cicle, 2 ) == 0 ) THEN - ! - CALL MPI_Isend(BUF_RECV, ldx*ldx, MPI_DOUBLE_PRECISION, send, group_rank+cicle, col_comm, req(1), ierr) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Isend 17 ", ABS( ierr ) ) - CALL MPI_Irecv(B, ldx*ldx, MPI_DOUBLE_PRECISION, recv, recv+cicle, col_comm, req(2), ierr) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Irecv 18 ", ABS( ierr ) ) - ! - CALL dgemm('N', 'N', ldx, ldx, ldx, -ONE, C, ldx, BUF_RECV, ldx, first, sll, ldx) - ! - ELSE - ! - CALL MPI_Isend(B, ldx*ldx, MPI_DOUBLE_PRECISION, send, group_rank+cicle, col_comm, req(1), ierr) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Isend 19 ", ABS( ierr ) ) - CALL MPI_Irecv(BUF_RECV, ldx*ldx, MPI_DOUBLE_PRECISION, recv, recv+cicle, col_comm, req(2), ierr) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Irecv 20 ", ABS( ierr ) ) - ! - CALL dgemm('N', 'N', ldx, ldx, ldx, -ONE, C, ldx, B, ldx, ONE, sll, ldx) - ! - END IF - ! - CALL MPI_Wait(req(1), status, ierr) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Wait 21 ", ABS( ierr ) ) - CALL MPI_Wait(req(2), status, ierr) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in MPI_Wait 22 ", ABS( ierr ) ) - ! - END IF - cicle = cicle + 1 - first = ONE - END DO - END IF - END DO - - IF( myrow >= mycol ) THEN - CALL mpi_comm_free( col_comm, ierr ) - IF( ierr /= 0 ) & - CALL errore( " pdtrtri ", " in mpi_comm_free 25 ", ABS( ierr ) ) - END IF - - DEALLOCATE(B) - DEALLOCATE(C) - DEALLOCATE(BUF_RECV) - -#else - - CALL compute_dtrtri() - -#endif - - CONTAINS - - SUBROUTINE compute_dtrtri() - ! - ! clear the upper triangle (excluding diagonal terms) and - ! - DO j = 1, ldx - DO i = 1, j-1 - sll ( i, j ) = zero - END DO - END DO - ! - CALL dtrtri( 'L', 'N', nr, sll, ldx, info ) - ! - IF( info /= 0 ) THEN - CALL errore( ' pdtrtri ', ' problem in the local inversion ', info ) - END IF - ! - END SUBROUTINE compute_dtrtri - - - INTEGER FUNCTION shift ( idref, id, pos, size, dir ) - - IMPLICIT NONE - - INTEGER :: idref, id, pos, size - CHARACTER ( LEN = 1 ) :: dir - - IF( ( dir == 'E' ) .OR. ( dir == 'S' ) ) THEN - shift = idref + MOD ( ( id - idref ) + pos, size ) - ELSE IF( ( dir == 'W' ) .OR. ( dir == 'N' ) ) THEN - shift = idref + MOD ( ( id - idref ) - pos + size, size ) - ELSE - shift = -1 - END IF - - RETURN - - END FUNCTION shift - -END SUBROUTINE qe_pdtrtri - - - -SUBROUTINE qe_pdsyevd( tv, n, desc, hh, ldh, e ) - USE kinds - USE descriptors, ONLY : descla_siz_ , lambda_node_ , nlax_ , la_nrl_ , & - la_npc_ , la_npr_ , la_me_ , la_comm_ , la_nrlx_ , & - nlar_ , la_myc_ , la_myr_ - USE dspev_module, ONLY : pdspev_drv - IMPLICIT NONE - LOGICAL, INTENT(IN) :: tv - ! if tv is true compute eigenvalues and eigenvectors (not used) - INTEGER, INTENT(IN) :: n, ldh - ! n = matrix size, ldh = leading dimension of hh - INTEGER, INTENT(IN) :: desc( descla_siz_ ) - ! desc = descrittore della matrice - REAL(DP) :: hh( ldh, ldh ) - ! input: hh = matrix to be diagonalized - REAL(DP) :: e( n ) - ! output: hh = eigenvectors, e = eigenvalues - - INTEGER :: nrlx, nrl - REAL(DP), ALLOCATABLE :: diag(:,:), vv(:,:) - CHARACTER :: jobv - - nrl = desc( la_nrl_ ) - nrlx = desc( la_nrlx_ ) - - ALLOCATE( diag( nrlx, n ) ) - ALLOCATE( vv( nrlx, n ) ) - - jobv = 'N' - IF( tv ) jobv = 'V' - ! - ! Redistribute matrix "hh" into "diag", - ! matrix "hh" is block distributed, matrix diag is cyclic distributed - - CALL blk2cyc_redist( n, diag, nrlx, n, hh, ldh, ldh, desc ) - ! - CALL pdspev_drv( jobv, diag, nrlx, e, vv, nrlx, nrl, n, & - desc( la_npc_ ) * desc( la_npr_ ), desc( la_me_ ), desc( la_comm_ ) ) - ! - IF( tv ) CALL cyc2blk_redist( n, vv, nrlx, n, hh, ldh, ldh, desc ) - ! - DEALLOCATE( vv ) - DEALLOCATE( diag ) - - RETURN -END SUBROUTINE - -SUBROUTINE qe_pzheevd( tv, n, desc, hh, ldh, e ) - USE kinds - USE descriptors, ONLY : descla_siz_ , lambda_node_ , nlax_ , la_nrl_ , & - la_npc_ , la_npr_ , la_me_ , la_comm_ , la_nrlx_ , & - nlar_ , la_myc_ , la_myr_ - USE zhpev_module, ONLY : pzhpev_drv - IMPLICIT NONE - LOGICAL, INTENT(IN) :: tv - ! if tv is true compute eigenvalues and eigenvectors (not used) - INTEGER, INTENT(IN) :: n, ldh - ! n = matrix size, ldh = leading dimension of hh - INTEGER, INTENT(IN) :: desc( descla_siz_ ) - ! desc = descrittore della matrice - COMPLEX(DP) :: hh( ldh, ldh ) - ! input: hh = matrix to be diagonalized - REAL(DP) :: e( n ) - ! output: hh = eigenvectors, e = eigenvalues - - INTEGER :: nrlx, nrl - COMPLEX(DP), ALLOCATABLE :: diag(:,:), vv(:,:) - CHARACTER :: jobv - - nrl = desc( la_nrl_ ) - nrlx = desc( la_nrlx_ ) - ! - ALLOCATE( diag( nrlx, n ) ) - ALLOCATE( vv( nrlx, n ) ) - ! - jobv = 'N' - IF( tv ) jobv = 'V' - - CALL blk2cyc_zredist( n, diag, nrlx, n, hh, ldh, ldh, desc ) - ! - CALL pzhpev_drv( jobv, diag, nrlx, e, vv, nrlx, nrl, n, & - desc( la_npc_ ) * desc( la_npr_ ), desc( la_me_ ), desc( la_comm_ ) ) - ! - if( tv ) CALL cyc2blk_zredist( n, vv, nrlx, n, hh, ldh, ldh, desc ) - ! - DEALLOCATE( vv ) - DEALLOCATE( diag ) - - RETURN -END SUBROUTINE - - - -SUBROUTINE sqr_dsetmat( what, n, alpha, a, lda, desc ) - ! - ! Set the values of a square distributed matrix - ! - USE kinds, ONLY : DP - USE descriptors, ONLY : ilar_ , nlar_ , ilac_ , nlac_ , nlax_ , descla_siz_ , & - lambda_node_ , la_npr_ , la_npc_ , la_myr_ , la_myc_ - ! - IMPLICIT NONE - ! - CHARACTER(LEN=1), INTENT(IN) :: what - ! what = 'A' set all the values of "a" equal to alpha - ! what = 'U' set the values in the upper triangle of "a" equal to alpha - ! what = 'L' set the values in the lower triangle of "a" equal to alpha - ! what = 'D' set the values in the diagonal of "a" equal to alpha - INTEGER, INTENT(IN) :: n - ! dimension of the matrix - REAL(DP), INTENT(IN) :: alpha - ! value to be assigned to elements of "a" - INTEGER, INTENT(IN) :: lda - ! leading dimension of a - REAL(DP) :: a(lda,*) - ! matrix whose values have to be set - INTEGER, INTENT(IN) :: desc( descla_siz_ ) - ! descriptor of matrix a - - INTEGER :: i, j - - IF( desc( lambda_node_ ) < 0 ) THEN - ! - ! processors not interested in this computation return quickly - ! - RETURN - ! - END IF - - SELECT CASE( what ) - CASE( 'U', 'u' ) - IF( desc( la_myc_ ) > desc( la_myr_ ) ) THEN - DO j = 1, desc( nlac_ ) - DO i = 1, desc( nlar_ ) - a( i, j ) = alpha - END DO - END DO - ELSE IF( desc( la_myc_ ) == desc( la_myr_ ) ) THEN - DO j = 1, desc( nlac_ ) - DO i = 1, j - 1 - a( i, j ) = alpha - END DO - END DO - END IF - CASE( 'L', 'l' ) - IF( desc( la_myc_ ) < desc( la_myr_ ) ) THEN - DO j = 1, desc( nlac_ ) - DO i = 1, desc( nlar_ ) - a( i, j ) = alpha - END DO - END DO - ELSE IF( desc( la_myc_ ) == desc( la_myr_ ) ) THEN - DO j = 1, desc( nlac_ ) - DO i = j - 1, desc( nlar_ ) - a( i, j ) = alpha - END DO - END DO - END IF - CASE( 'D', 'd' ) - IF( desc( la_myc_ ) == desc( la_myr_ ) ) THEN - DO i = 1, desc( nlar_ ) - a( i, i ) = alpha - END DO - END IF - CASE DEFAULT - DO j = 1, desc( nlac_ ) - DO i = 1, desc( nlar_ ) - a( i, j ) = alpha - END DO - END DO - END SELECT - ! - RETURN -END SUBROUTINE sqr_dsetmat - - -SUBROUTINE sqr_zsetmat( what, n, alpha, a, lda, desc ) - ! - ! Set the values of a square distributed matrix - ! - USE kinds, ONLY : DP - USE descriptors, ONLY : ilar_ , nlar_ , ilac_ , nlac_ , nlax_ , descla_siz_ , & - lambda_node_ , la_npr_ , la_npc_ , la_myr_ , la_myc_ - ! - IMPLICIT NONE - ! - CHARACTER(LEN=1), INTENT(IN) :: what - ! what = 'A' set all the values of "a" equal to alpha - ! what = 'U' set the values in the upper triangle of "a" equal to alpha - ! what = 'L' set the values in the lower triangle of "a" equal to alpha - ! what = 'D' set the values in the diagonal of "a" equal to alpha - ! what = 'H' clear the imaginary part of the diagonal of "a" - INTEGER, INTENT(IN) :: n - ! dimension of the matrix - COMPLEX(DP), INTENT(IN) :: alpha - ! value to be assigned to elements of "a" - INTEGER, INTENT(IN) :: lda - ! leading dimension of a - COMPLEX(DP) :: a(lda,*) - ! matrix whose values have to be set - INTEGER, INTENT(IN) :: desc( descla_siz_ ) - ! descriptor of matrix a - - INTEGER :: i, j - - IF( desc( lambda_node_ ) < 0 ) THEN - ! - ! processors not interested in this computation return quickly - ! - RETURN - ! - END IF - - SELECT CASE( what ) - CASE( 'U', 'u' ) - IF( desc( la_myc_ ) > desc( la_myr_ ) ) THEN - DO j = 1, desc( nlac_ ) - DO i = 1, desc( nlar_ ) - a( i, j ) = alpha - END DO - END DO - ELSE IF( desc( la_myc_ ) == desc( la_myr_ ) ) THEN - DO j = 1, desc( nlac_ ) - DO i = 1, j - 1 - a( i, j ) = alpha - END DO - END DO - END IF - CASE( 'L', 'l' ) - IF( desc( la_myc_ ) < desc( la_myr_ ) ) THEN - DO j = 1, desc( nlac_ ) - DO i = 1, desc( nlar_ ) - a( i, j ) = alpha - END DO - END DO - ELSE IF( desc( la_myc_ ) == desc( la_myr_ ) ) THEN - DO j = 1, desc( nlac_ ) - DO i = j - 1, desc( nlar_ ) - a( i, j ) = alpha - END DO - END DO - END IF - CASE( 'D', 'd' ) - IF( desc( la_myc_ ) == desc( la_myr_ ) ) THEN - DO i = 1, desc( nlar_ ) - a( i, i ) = alpha - END DO - END IF - CASE( 'H', 'h' ) - IF( desc( la_myc_ ) == desc( la_myr_ ) ) THEN - DO i = 1, desc( nlar_ ) - a( i, i ) = CMPLX( REAL( a(i,i) ), 0_DP ) - END DO - END IF - CASE DEFAULT - DO j = 1, desc( nlac_ ) - DO i = 1, desc( nlar_ ) - a( i, j ) = alpha - END DO - END DO - END SELECT - ! - RETURN -END SUBROUTINE sqr_zsetmat diff --git a/quantum_espresso/kcp/Modules/radial_grids.f90 b/quantum_espresso/kcp/Modules/radial_grids.f90 deleted file mode 100644 index 61e2271e8..000000000 --- a/quantum_espresso/kcp/Modules/radial_grids.f90 +++ /dev/null @@ -1,481 +0,0 @@ -! -! Copyright (C) 2004 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -MODULE radial_grids - !============================================================================ - ! - ! Module containing type definitions and auxiliary routines to deal with - ! data on logarithmic radial grids. - ! Should contain low level routines and no reference to other modules - ! (with the possible exception of kinds and parameters) so as to be - ! call-able from any other module. - ! - ! content: - ! - ! - ndmx : parameter definition max grid dimension - ! - ! - radial_grid_type : derived type definition for radial grids - ! - ! - do_mesh : a routine to build the radial mesh - ! - ! - check_mesh : a routine to check if grid is consistently set - ! - ! - hartree : a routine that solve the Poisson's equation on radial grid - ! - ! - series : a simple routine returning the coefficient of the polynomial - ! describing the leading behavior of a function f at small r. - ! - ! - write_grid_on_file, read_grid_from_file : I/O routines - ! - !============================================================================ - ! - USE kinds, ONLY: dp - ! - IMPLICIT NONE - ! - integer, parameter :: & - ndmx=3500 ! the maximum mesh size - -TYPE radial_grid_type - - INTEGER :: & - mesh ! the actual number of mesh points - REAL(DP),POINTER :: & - r(:), & ! the radial mesh - r2(:), & ! the square of the radial mesh - rab(:), & ! d r(x) / d x where x is the linear grid - sqr(:), & ! the square root of the radial mesh - rm1(:), & ! 1 / r - rm2(:), & ! 1 / r**2 - rm3(:) ! 1 / r**3 - REAL(DP) :: & - xmin, & ! the minimum x - rmax, & ! the maximum radial point - zmesh, & ! the ionic charge used for the mesh - dx ! the deltax of the linear mesh -END TYPE radial_grid_type - - PRIVATE - PUBLIC :: ndmx, radial_grid_type, & - do_mesh, check_mesh, hartree, series, & - write_grid_on_file, read_grid_from_file, & - allocate_radial_grid,& - deallocate_radial_grid,& - nullify_radial_grid,& - radial_grid_COPY - - interface deallocate_radial_grid - module procedure & - deallocate_radial_grid_s,& ! only one - deallocate_radial_grid_v ! an array - end interface - - !============================================================================ - ! - CONTAINS -! -! Build the radial (logarithmic) grid -! -! r(i) = exp ( xmin + (i-1) dx ) / zmesh i=1,mesh -! r2(i) is r(i) square, sqr(i) is sqrt(r(i)) and -! rab(i) is the integration element = r(i)*dx -! -! more general grid definitions are possible but currently not implemented -! (example: Vanderbilt's grid, same as above but starting at r=0) -! r(i) = exp ( xmin ) * ( exp( (i-1)*dx ) - 1.0_dp ) / zmesh -! rab(i) = ( r(i) + exp(xmin)/zmesh ) * dx -! -!--------------------------------------------------------------- - subroutine radial_grid_COPY(X,Y) -!--------------------------------------------------------------- - type(radial_grid_type),intent(in) :: X - type(radial_grid_type),intent(inout) :: Y - ! - call deallocate_radial_grid(Y) - call allocate_radial_grid(Y, X%mesh) - ! - Y%r(1:X%mesh) = X%r(1:X%mesh) - Y%r2(1:X%mesh) = X%r2(1:X%mesh) - Y%rab(1:X%mesh) = X%rab(1:X%mesh) - Y%sqr(1:X%mesh) = X%sqr(1:X%mesh) - Y%rm1(1:X%mesh) = X%rm1(1:X%mesh) - Y%rm2(1:X%mesh) = X%rm2(1:X%mesh) - Y%rm3(1:X%mesh) = X%rm3(1:X%mesh) - ! - Y%xmin = X%xmin - Y%rmax = X%rmax - Y%zmesh = X%zmesh - Y%dx = X%dx - end subroutine radial_grid_COPY -! -!--------------------------------------------------------------- - subroutine allocate_radial_grid(grid,mesh) -!--------------------------------------------------------------- - type(radial_grid_type),intent(inout) :: grid - integer,intent(in) :: mesh - if(mesh>ndmx) & - call errore('allocate_radial_grid', 'mesh>ndmx',1) - allocate( & - grid%r(mesh), & - grid%r2(mesh), & ! the square of the radial mesh - grid%rab(mesh), & ! d r(x) / d x where x is the linear grid - grid%sqr(mesh), & ! the square root of the radial mesh - grid%rm1(mesh), & ! 1 / r - grid%rm2(mesh), & ! 1 / r**2 - grid%rm3(mesh) ) ! 1 / r**3 - grid%mesh = mesh - end subroutine allocate_radial_grid -! -!--------------------------------------------------------------- - subroutine deallocate_radial_grid_s(grid) -!--------------------------------------------------------------- - type(radial_grid_type),intent(inout) :: grid - if (associated(grid%r)) deallocate(grid%r) - if (associated(grid%r2)) deallocate(grid%r2) - if (associated(grid%rab)) deallocate(grid%rab) - if (associated(grid%sqr)) deallocate(grid%sqr) - if (associated(grid%rm1)) deallocate(grid%rm1) - if (associated(grid%rm2)) deallocate(grid%rm2) - if (associated(grid%rm3)) deallocate(grid%rm3) - grid%mesh = 0 - call nullify_radial_grid(grid) - end subroutine deallocate_radial_grid_s -!--------------------------------------------------------------- - subroutine deallocate_radial_grid_v(grid) -!--------------------------------------------------------------- - type(radial_grid_type),intent(inout) :: grid(:) - integer :: n - do n = 1,size(grid) - if (associated(grid(n)%r)) deallocate(grid(n)%r) - if (associated(grid(n)%r2)) deallocate(grid(n)%r2) - if (associated(grid(n)%rab)) deallocate(grid(n)%rab) - if (associated(grid(n)%sqr)) deallocate(grid(n)%sqr) - if (associated(grid(n)%rm1)) deallocate(grid(n)%rm1) - if (associated(grid(n)%rm2)) deallocate(grid(n)%rm2) - if (associated(grid(n)%rm3)) deallocate(grid(n)%rm3) - grid(n)%mesh = 0 - enddo - !deallocate(grid) - end subroutine deallocate_radial_grid_v - -!--------------------------------------------------------------- - subroutine nullify_radial_grid(grid) -!--------------------------------------------------------------- - type(radial_grid_type),intent(inout) :: grid - nullify( & - grid%r, & - grid%r2, & ! the square of the radial mesh - grid%rab, & ! d r(x) / d x where x is the linear grid - grid%sqr, & ! the square root of the radial mesh - grid%rm1, & ! 1 / r - grid%rm2, & ! 1 / r**2 - grid%rm3 ) ! 1 / r**3 - grid%mesh = -1 - end subroutine nullify_radial_grid -! -!--------------------------------------------------------------- - subroutine do_mesh(rmax,zmesh,xmin,dx,ibound,grid) -!--------------------------------------------------------------- -! - use kinds, only : DP - implicit none - type(radial_grid_type),intent(out) :: grid - - integer, intent(in) :: ibound - real(DP),intent(in) :: rmax, zmesh, dx - real(DP),intent(inout):: xmin - - real(DP) :: xmax, x - integer :: mesh, i - ! - xmax=log(rmax*zmesh) - mesh=(xmax-xmin)/dx+1 - ! - ! mesh must be odd for simpson integration. - ! - mesh=2*(mesh/2)+1 - if(mesh+1 > ndmx) call errore('do_mesh','ndmx is too small',1) - if(ibound == 1) xmin=xmax-dx*(mesh-1) - ! - call deallocate_radial_grid(grid) - call allocate_radial_grid(grid,mesh) - ! - do i=1,mesh - x=xmin+DBLE(i-1)*dx - grid%r(i) = exp(x)/zmesh - grid%r2(i) = grid%r(i)*grid%r(i) - grid%rab(i) = grid%r(i)*dx - grid%sqr(i) = sqrt(grid%r(i)) - grid%rm1(i) = 1._dp/grid%r(i) - grid%rm2(i) = 1._dp/grid%r(i)**2 - grid%rm3(i) = 1._dp/grid%r(i)**3 - end do - ! - grid%mesh = mesh - grid%dx = dx - grid%xmin = xmin - grid%rmax = rmax - grid%zmesh = zmesh - - return - end subroutine do_mesh -! -! check that logarithmic grid is consistently set -!--------------------------------------------------------------- - subroutine check_mesh(grid) -!--------------------------------------------------------------- -! - use kinds, only : DP - use constants, only : eps8 - implicit none - type(radial_grid_type),intent(in) :: grid - integer :: i - - if (grid%mesh < 0 ) call errore('check_mesh','grid%mesh < 0 ',1) - do i=1,grid%mesh - if (abs(grid%r2(i)/grid%r(i)**2-1.d0) > eps8 ) & - call errore('check_mesh',' r2(i) is different ',i) - if (abs(grid%sqr(i)/sqrt(grid%r(i))-1.d0) > eps8 ) & - call errore('check_mesh',' sqr(i) is different ',i) - if (abs(grid%rab(i)/(grid%r(i)*grid%dx)-1.d0) > eps8 ) & - call errore('check_mesh',' rab(i) is different ',i) - end do - - return - end subroutine check_mesh -! -! Solution of the Poisson's equation on a radial (logarithmic) grid -!--------------------------------------------------------------- -subroutine hartree(k,nst,mesh,grid,f,vh) - !--------------------------------------------------------------- - ! - use kinds, only : DP -! use radial_grids, only: radial_grid_type - implicit none - integer,intent(in):: & - k, & ! input: the k of the equation - nst, & ! input: at low r, f goes as r**nst - mesh ! input: the dimension of the mesh - - type(radial_grid_type), intent(in) :: & - grid ! input: the radial grid - real(DP), intent(in):: & - f(mesh) ! input: the 4\pi r2 \rho function - real(DP), intent(out):: & - vh(mesh) ! output: the required solution - ! - ! local variables - ! - integer :: & - k21, & ! 2k+1 - nk1, & ! nst-k-1 - ierr, & ! integer variable for allocation control - i ! counter - - real(DP):: & - c0,c2,c3, & ! coefficients of the polynomial expansion close to r=0 - ch, & ! dx squared / 12.0 - xkh2, & ! ch * f - ei, di, & ! auxiliary variables for the diagonal and - ! off diagonal elements of the matrix - f1, fn, & ! variables used for the boundary condition - vhim1, vhi ! variables for the right hand side - - real(DP), allocatable:: & - d(:), & ! the diagonal elements of - ! the tridiagonal sys. - e(:) ! the off diagonal elements - ! of the trid. sys. - ! - ! Allocate space for the diagonal and off diagonal elements - ! - if (mesh.ne.grid%mesh) call errore('hartree',' grid dimension mismatch',1) - allocate(d(mesh),stat=ierr) - allocate(e(mesh),stat=ierr) - - if (ierr.ne.0) call errore('hartree',' error allocating d or e',1) - ! - ! Find the series expansion of the solution close to r=0 - ! - k21=2*k+1 - nk1=nst-k-1 - if(nk1.le.0) then - write(6,100) k,nst -100 format(5x,'stop in "hartree": k=',i3,' nst=',i3) - stop - !else if(nk1.ge.4) then - ! not sure whether the following is really correct, but the above wasn't - else if(nk1.ge.3) then - c2=0.0_dp - c3=0.0_dp - else - e(1)=0.0_dp - do i=1,4 - d(i)=-k21*f(i)/grid%r(i)**nst - end do - call series(d,grid%r,grid%r2,e(nk1)) - c2=e(1)/(4.0_dp*k+6.0_dp) - c3=e(2)/(6.0_dp*k+12.0_dp) - end if - ! - ! Set the main auxiliary parameters - ! - ch=grid%dx*grid%dx/12.0_dp - xkh2=ch*(DBLE(k)+0.5_dp)**2 - ei=1.0_dp-xkh2 - di=-(2.0_dp+10.0_dp*xkh2) - ! - ! Set the diagonal and the off diagonal elements of the - ! linear system, compute a part of the right hand side - ! - do i=2,mesh - d(i)=-di - e(i)=-ei - vh(i)=k21*ch*grid%sqr(i)*f(i) - end do - ! - ! Use the boundary condition to eliminate the value of the - ! solution in the first point from the first equation. This - ! part for the diagonal element - ! - f1=(grid%sqr(1)/grid%sqr(2))**k21 - d(2)=d(2)-ei*f1 - ! - ! Use the boundary condition to eliminate the value of the - ! solution in the last point from the last equation - ! - fn=(grid%sqr(mesh-1)/grid%sqr(mesh))**k21 - d(mesh-1)=d(mesh-1)-ei*fn - ! - ! In the first point vh(1) has the same definition as in the other points - ! - vhim1=k21*ch*grid%sqr(1)*f(1) - ! - ! Compute the right hand side using the auxiliary quantity vh(i). - ! - do i=2,mesh-1 - vhi=vh(i) - vh(i)=vhim1+10.0_dp*vhi+vh(i+1) - vhim1=vhi - end do - ! - ! Use the boundary condition to eliminate the value of the solution in the - ! first point from the first equation. This part for the right hand side. - ! - vh(2)=vh(2)-ei*grid%sqr(1)**k21*(c2*(grid%r2(2)-grid%r2(1)) & - +c3*(grid%r(2)**3-grid%r(1)**3)) - ! - ! solve the linear system with lapack routine dptsv - ! - call dptsv(mesh-2,1,d(2),e(2),vh(2),mesh-2,ierr) - if (ierr.ne.0) call errore('hartree', 'error in lapack', ierr) - ! - ! Set the value of the solution at the first and last point - ! First, find c0 from the solution in the second point - ! - c0=vh(2)/grid%sqr(2)**k21-c2*grid%r2(2)-c3*grid%r(2)*grid%r2(2) - ! - ! and then use the series expansion at the first point - ! - vh(1)=grid%sqr(1)**k21*(c0+c2*grid%r2(1)+c3*grid%r(1)**3) - ! - ! the solution at the last point is given by the boundary - ! condition - ! - vh(mesh)=vh(mesh-1)*fn - ! - ! The solution must be divided by r (from the equation) - ! and multiplied by the square root of r (from the log - ! mesh transformation) - ! - do i=1,mesh - vh(i)= vh(i) / grid%sqr(i) - end do - - deallocate(e) - deallocate(d) - - return -end subroutine hartree -! -! simple routine returning the coefficient of the polynomial -! describing the leading behavior of a function f at small r. -!--------------------------------------------------------------- -subroutine series(f,r,r2,b) - !--------------------------------------------------------------- - ! - use kinds, only : DP - implicit none - real(DP):: dr21,dr31,dr32,dr41,dr42,dr43,df21,df32,df43, & - ddf42,ddf31 - real(DP):: f(4),r(4),r2(4),b(0:3) - dr21=r(2)-r(1) - dr31=r(3)-r(1) - dr32=r(3)-r(2) - dr41=r(4)-r(1) - dr42=r(4)-r(2) - dr43=r(4)-r(3) - df21=(f(2)-f(1))/dr21 - df32=(f(3)-f(2))/dr32 - df43=(f(4)-f(3))/dr43 - ddf42=(df43-df32)/dr42 - ddf31=(df32-df21)/dr31 - b(3)=(ddf42-ddf31)/dr41 - b(2)=ddf31-b(3)*(r(1)+r(2)+r(3)) - b(1)=df21-b(2)*(r(2)+r(1))-b(3)*(r2(1)+r2(2)+r(1)*r(2)) - b(0)=f(1)-r(1)*(b(1)+r(1)*(b(2)+r(1)*b(3))) - return -end subroutine series -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -! -! I/O routines -! -!---------------------------------------------------------------------- -subroutine write_grid_on_file(iunit,grid) -! use radial_grids, only: radial_grid_type - implicit none - type(radial_grid_type), intent(in) :: grid - integer, intent(in) :: iunit - integer :: n -! - WRITE(iunit,'(i8)') grid%mesh - WRITE(iunit,'(e20.10)') grid%dx - WRITE(iunit,'(e20.10)') grid%xmin - WRITE(iunit,'(e20.10)') grid%zmesh - WRITE(iunit,'(e20.10)') (grid%r(n), n=1,grid%mesh) - WRITE(iunit,'(e20.10)') (grid%r2(n), n=1,grid%mesh) - WRITE(iunit,'(e20.10)') (grid%sqr(n), n=1,grid%mesh) -! WRITE(iunit,'(e20.10)') (grid%rab(n), n=1,grid%mesh) - return -end subroutine write_grid_on_file - -subroutine read_grid_from_file(iunit,grid) -! use radial_grids, only: radial_grid_type - implicit none - type(radial_grid_type), intent(out) :: grid - integer, intent(in) :: iunit - integer :: n -! - READ(iunit,'(i8)') grid%mesh - READ(iunit,'(e20.10)') grid%dx - READ(iunit,'(e20.10)') grid%xmin - READ(iunit,'(e20.10)') grid%zmesh - READ(iunit,'(e20.10)') (grid%r(n), n=1,grid%mesh) - READ(iunit,'(e20.10)') (grid%r2(n), n=1,grid%mesh) - READ(iunit,'(e20.10)') (grid%sqr(n), n=1,grid%mesh) -! READ(iunit,'(e20.10)') (grid%rab(n), n=1,grid%mesh) - grid%rab(1:grid%mesh) = grid%r(1:grid%mesh) * grid%dx - grid%rm1(1:grid%mesh) = 1._dp/grid%r(1:grid%mesh) - grid%rm2(1:grid%mesh) = 1._dp/grid%r2(1:grid%mesh) - grid%rm3(1:grid%mesh) = 1._dp/grid%r(1:grid%mesh)**3 - - return -end subroutine read_grid_from_file - -!---------------------------------------------------------------------- -END MODULE radial_grids diff --git a/quantum_espresso/kcp/Modules/random_numbers.f90 b/quantum_espresso/kcp/Modules/random_numbers.f90 deleted file mode 100644 index 0651dcc3e..000000000 --- a/quantum_espresso/kcp/Modules/random_numbers.f90 +++ /dev/null @@ -1,155 +0,0 @@ -! -! Copyright (C) 2001-2008 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE random_numbers - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - ! - IMPLICIT NONE - ! - INTERFACE gauss_dist - ! - MODULE PROCEDURE gauss_dist_scal, gauss_dist_vect - ! - END INTERFACE - ! - CONTAINS - ! - !------------------------------------------------------------------------ - FUNCTION randy ( irand ) - !------------------------------------------------------------------------ - ! - ! x=rand(n) : reseed with initial seed idum=n - ! if randy is not explicitly initialized, it will be - ! initialized with seed idum=0 the first time it is called - ! x=rand( ) : generate uniform real(DP) numbers x in [0,1] - ! - REAL(DP) :: randy - INTEGER, optional :: irand - ! - INTEGER , PARAMETER :: m = 714025, & - ia = 1366, & - ic = 150889, & - ntab = 97 - REAL(DP), PARAMETER :: rm = 1.0_DP / m - INTEGER :: j - INTEGER, SAVE :: ir(ntab), iy, idum=0 - LOGICAL, SAVE :: first=.true. - ! - IF ( present(irand) ) THEN - idum = irand - first=.true. - END IF - - IF ( first ) THEN - ! - first = .false. - idum = MOD( ic - idum, m ) - ! - DO j=1,ntab - idum=mod(ia*idum+ic,m) - ir(j)=idum - END DO - idum=mod(ia*idum+ic,m) - iy=idum - END IF - j=1+(ntab*iy)/m - IF( j > ntab .OR. j < 1 ) call errore('randy','j out of range',j) - iy=ir(j) - randy=iy*rm - idum=mod(ia*idum+ic,m) - ir(j)=idum - ! - RETURN - ! - END FUNCTION randy - ! - !----------------------------------------------------------------------- - FUNCTION gauss_dist_scal( mu, sigma ) - !----------------------------------------------------------------------- - ! - ! ... this function generates a number taken from a normal - ! ... distribution of mean value \mu and variance \sigma - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: mu - REAL(DP), INTENT(IN) :: sigma - REAL(DP) :: gauss_dist_scal - ! - REAL(DP) :: x1, x2, w - ! - ! - gaussian_loop: DO - ! - x1 = 2.0_DP * randy() - 1.0_DP - x2 = 2.0_DP * randy() - 1.0_DP - ! - w = x1 * x1 + x2 * x2 - ! - IF ( w < 1.0_DP ) EXIT gaussian_loop - ! - END DO gaussian_loop - ! - w = SQRT( ( - 2.0_DP * LOG( w ) ) / w ) - ! - gauss_dist_scal = x1 * w * sigma + mu - ! - RETURN - ! - END FUNCTION gauss_dist_scal - ! - !----------------------------------------------------------------------- - FUNCTION gauss_dist_vect( mu, sigma, dim ) - !----------------------------------------------------------------------- - ! - ! ... this function generates an array of numbers taken from a normal - ! ... distribution of mean value \mu and variance \sigma - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: mu - REAL(DP), INTENT(IN) :: sigma - INTEGER, INTENT(IN) :: dim - REAL(DP) :: gauss_dist_vect( dim ) - ! - REAL(DP) :: x1, x2, w - INTEGER :: i - ! - ! - DO i = 1, dim, 2 - ! - gaussian_loop: DO - ! - x1 = 2.0_DP * randy() - 1.0_DP - x2 = 2.0_DP * randy() - 1.0_DP - ! - w = x1 * x1 + x2 * x2 - ! - IF ( w < 1.0_DP ) EXIT gaussian_loop - ! - END DO gaussian_loop - ! - w = SQRT( ( - 2.0_DP * LOG( w ) ) / w ) - ! - gauss_dist_vect(i) = x1 * w * sigma - ! - IF ( i >= dim ) EXIT - ! - gauss_dist_vect(i+1) = x2 * w * sigma - ! - END DO - ! - gauss_dist_vect(:) = gauss_dist_vect(:) + mu - ! - RETURN - ! - END FUNCTION gauss_dist_vect - ! -END MODULE random_numbers diff --git a/quantum_espresso/kcp/Modules/read_cards.f90 b/quantum_espresso/kcp/Modules/read_cards.f90 deleted file mode 100644 index 4f0ca03eb..000000000 --- a/quantum_espresso/kcp/Modules/read_cards.f90 +++ /dev/null @@ -1,2633 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!--------------------------------------------------------------------------- -MODULE read_cards_module - !--------------------------------------------------------------------------- - ! - ! ... This module handles the reading of cards from standard input - ! ... Written by Carlo Cavazzoni and modified for "path" implementation - ! ... by Carlo Sbraccia - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - USE constants, ONLY : angstrom_au - USE parser, ONLY : field_count, read_line, get_field - USE io_global, ONLY : ionode, ionode_id - ! - USE input_parameters - ! - IMPLICIT NONE - ! - SAVE - ! - PRIVATE - ! - PUBLIC :: read_cards - ! - ! ... end of module-scope declarations - ! - ! ---------------------------------------------- - ! - CONTAINS - ! - ! ... Read CARDS .... - ! - ! ... subroutines - ! - !---------------------------------------------------------------------- - SUBROUTINE card_default_values( prog ) - !---------------------------------------------------------------------- - ! - USE autopilot, ONLY : init_autopilot - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog - ! - ! - ! ... mask that control the printing of selected Kohn-Sham occupied - ! ... orbitals, default allocation - ! - CALL allocate_input_iprnks( 0, nspin ) - nprnks = 0 - ! - ! ... mask that control the printing of selected Kohn-Sham unoccupied - ! ... orbitals, default allocation - ! - CALL allocate_input_iprnks_empty( 0, nspin ) - nprnks_empty = 0 - ! - ! ... Simulation cell from standard input - ! - trd_ht = .FALSE. - rd_ht = 0.0_DP - ! - ! ... dipole - ! - tdipole_card = .FALSE. - ! - ! ... Constraints - ! - nconstr_inp = 0 - constr_tol_inp = 1.E-6_DP - ! - ! ... ionic mass initialization - ! - atom_mass = 0.0_DP - ! - ! ... dimension of the real space Ewald summation - ! - iesr_inp = 1 - ! - ! ... k-points - ! - k_points = 'gamma' - tk_inp = .FALSE. - nkstot = 1 - nk1 = 0 - nk2 = 0 - nk3 = 0 - k1 = 0 - k2 = 0 - k3 = 0 - ! - ! ... neighbours - ! - tneighbo = .FALSE. - neighbo_radius = 0.0_DP - ! - ! ... Turbo - ! - tturbo_inp = .FALSE. - nturbo_inp = 0 - ! - ! ... Grids - ! - t2dpegrid_inp = .FALSE. - ! - ! ... Electronic states - ! - tf_inp = .FALSE. - ! - ! ... Hartree planar mean - ! - tvhmean_inp = .false. - vhnr_inp = 0 - vhiunit_inp = 0 - vhrmin_inp = 0.0_DP - vhrmax_inp = 0.0_DP - vhasse_inp = 'K' - ! - ! ... tchi - ! - tchi2_inp = .FALSE. - ! - ! ... ion_velocities - ! - tavel = .FALSE. - ! - ! ... setnfi - ! - newnfi_card = -1 - tnewnfi_card = .FALSE. - ! - CALL init_autopilot() - ! - RETURN - ! - END SUBROUTINE card_default_values - ! - ! - !---------------------------------------------------------------------- - SUBROUTINE read_cards( prog ) - !---------------------------------------------------------------------- - ! - USE autopilot, ONLY : card_autopilot - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! calling program ( FP, PW, CP ) - CHARACTER(LEN=256) :: input_line - CHARACTER(LEN=80) :: card - CHARACTER(LEN=1), EXTERNAL :: capital - LOGICAL :: tend - INTEGER :: i - ! - ! - CALL card_default_values( prog ) - ! - 100 CALL read_line( input_line, end_of_file=tend ) - ! - IF( tend ) GO TO 120 - IF( input_line == ' ' .OR. input_line(1:1) == '#' ) GO TO 100 - ! - READ (input_line, *) card - ! - DO i = 1, LEN_TRIM( input_line ) - input_line( i : i ) = capital( input_line( i : i ) ) - END DO - ! - IF ( TRIM(card) == 'AUTOPILOT' ) THEN - ! - CALL card_autopilot( input_line ) - ! - ELSE IF ( TRIM(card) == 'ATOMIC_SPECIES' ) THEN - ! - CALL card_atomic_species( input_line, prog ) - ! - ELSE IF ( TRIM(card) == 'ATOMIC_POSITIONS' ) THEN - ! - CALL card_atomic_positions( input_line, prog ) - ! - ELSE IF ( TRIM(card) == 'ATOMIC_FORCES' ) THEN - ! - CALL card_atomic_forces( input_line, prog ) - ! - ELSE IF ( TRIM(card) == 'SETNFI' ) THEN - ! - CALL card_setnfi( input_line ) - IF ( ( prog == 'PW' .OR. prog == 'CP' ) .AND. ionode ) & - WRITE( stdout,'(A)') 'Warning: card '//trim(input_line)//' ignored' - ! - ELSE IF ( TRIM(card) == 'CONSTRAINTS' ) THEN - ! - CALL card_constraints( input_line ) - ! - ELSE IF ( TRIM(card) == 'COLLECTIVE_VARS' ) THEN - ! - CALL card_collective_vars( input_line ) - ! - ELSE IF ( TRIM(card) == 'VHMEAN' ) THEN - ! - CALL card_vhmean( input_line ) - IF ( ( prog == 'PW' .OR. prog == 'CP' ) .AND. ionode ) & - WRITE( stdout,'(A)') 'Warning: card '//trim(input_line)//' ignored' - ! - ELSE IF ( TRIM(card) == 'DIPOLE' ) THEN - ! - CALL card_dipole( input_line ) - IF ( ( prog == 'PW' .OR. prog == 'CP' ) .AND. ionode ) & - WRITE( stdout,'(A)') 'Warning: card '//trim(input_line)//' ignored' - ! - ELSE IF ( TRIM(card) == 'ESR' ) THEN - ! - CALL card_esr( input_line ) - IF ( ( prog == 'PW' .OR. prog == 'CP' ) .AND. ionode ) & - WRITE( stdout,'(A)') 'Warning: card '//trim(input_line)//' ignored' - ! - ELSE IF ( TRIM(card) == 'K_POINTS' ) THEN - ! - IF ( prog == 'CP' ) THEN - IF( ionode ) WRITE( stdout,'(A)') 'Warning: card '//trim(input_line)//' ignored' - ELSE - CALL card_kpoints( input_line ) - END IF - ! - ELSE IF ( TRIM(card) == 'NEIGHBOURS' ) THEN - ! - CALL card_neighbours( input_line ) - IF ( ( prog == 'PW' .OR. prog == 'CP' ) .AND. ionode ) & - WRITE( stdout,'(A)') 'Warning: card '//trim(input_line)//' ignored' - ! - ELSE IF ( TRIM(card) == 'OCCUPATIONS' ) THEN - ! - CALL card_occupations( input_line ) - ! - ELSE IF ( TRIM(card) == 'CELL_PARAMETERS' ) THEN - ! - CALL card_cell_parameters( input_line ) - ! - ELSE IF ( TRIM(card) == 'TURBO' ) THEN - ! - CALL card_turbo( input_line ) - IF ( ( prog == 'PW' .OR. prog == 'CP' ) .AND. ionode ) & - WRITE( stdout,'(A)') 'Warning: card '//trim(input_line)//' ignored' - ! - ELSE IF ( TRIM(card) == 'ATOMIC_VELOCITIES' ) THEN - ! - CALL card_ion_velocities( input_line ) - IF ( ( prog == 'PW' .OR. prog == 'CP' ) .AND. ionode ) & - WRITE( stdout,'(A)') 'Warning: card '//trim(input_line)//' ignored' - ! - ELSE IF ( TRIM(card) == 'KSOUT' ) THEN - ! - CALL card_ksout( input_line ) - IF ( ( prog == 'PW' ) .AND. ionode ) & - WRITE( stdout,'(a)') 'Warning: card '//trim(input_line)//' ignored' - ! - ELSE IF ( TRIM(card) == 'KSOUT_EMPTY' ) THEN - ! - CALL card_ksout_empty( input_line ) - IF ( ( prog == 'PW' ) .AND. ionode ) & - WRITE( stdout,'(A)') 'Warning: card '//trim(input_line)//' ignored' - ! - ELSE IF ( TRIM(card) == 'CLIMBING_IMAGES' ) THEN - ! - CALL card_climbing_images( input_line ) - - ELSE IF ( TRIM(card) == 'PLOT_WANNIER' ) THEN - ! - CALL card_plot_wannier( input_line ) - - ELSE IF ( TRIM(card) == 'WANNIER_AC' .AND. ( prog == 'WA' )) THEN - ! - CALL card_wannier_ac( input_line ) - - ELSE - ! - IF ( ionode ) & - WRITE( stdout,'(A)') 'Warning: card '//TRIM(input_line)//' ignored' - ! - END IF - ! - ! ... END OF LOOP ... ! - ! - GOTO 100 - ! -120 CONTINUE - ! - RETURN - ! - END SUBROUTINE read_cards - ! - ! - ! ... Description of the allowed input CARDS for FPMD code - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! ATOMIC_SPECIES - ! - ! set the atomic species been read and their pseudopotential file - ! - ! Syntax: - ! - ! ATOMIC_SPECIE - ! label(1) mass(1) psfile(1) - ! ... ... ... - ! label(n) mass(n) psfile(n) - ! - ! Example: - ! - ! ATOMIC_SPECIES - ! O 16.0 O.BLYP.UPF - ! H 1.00 H.fpmd.UPF - ! - ! Where: - ! - ! label(i) ( character(len=4) ) label of the atomic species - ! mass(i) ( real ) atomic mass - ! ( in u.m.a, carbon mass is 12.0 ) - ! psfile(i) ( character(len=80) ) file name of the pseudopotential - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_atomic_species( input_line, prog ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - CHARACTER(LEN=2) :: prog - INTEGER :: is, ip, ierr - CHARACTER(LEN=4) :: lb_pos - CHARACTER(LEN=256) :: psfile - LOGICAL, SAVE :: tread = .FALSE. - ! - ! - IF ( tread ) THEN - CALL errore( ' card_atomic_species ', ' two occurrences', 2 ) - END IF - IF ( ntyp > nsx ) THEN - CALL errore( ' card_atomic_species ', ' nsp out of range ', ntyp ) - END IF - ! - DO is = 1, ntyp - ! - CALL read_line( input_line ) - READ( input_line, *, iostat=ierr ) lb_pos, atom_mass(is), psfile - CALL errore( ' card_atomic_species ', 'cannot read atomic specie from: '//TRIM(input_line), ABS(ierr)) - atom_pfile(is) = TRIM( psfile ) - lb_pos = ADJUSTL( lb_pos ) - atom_label(is) = TRIM( lb_pos ) - ! -! IF ( atom_mass(is) <= 0.0_DP ) THEN -! CALL errore( ' card_atomic_species ',' invalid atom_mass ', is ) -! END IF - DO ip = 1, is - 1 - IF ( atom_label(ip) == atom_label(is) ) THEN - CALL errore( ' card_atomic_species ', & - & ' two occurrences of the same atomic label ', is ) - END IF - END DO - ! - END DO - taspc = .TRUE. - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE card_atomic_species - ! - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! ATOMIC_POSITIONS - ! - ! set the atomic positions in the cell - ! - ! Syntax: - ! - ! ATOMIC_POSITIONS (units_option) - ! label(1) tau(1,1) tau(2,1) tau(3,1) mbl(1,1) mbl(2,1) mbl(3,1) - ! label(2) tau(1,2) tau(2,2) tau(3,2) mbl(1,2) mbl(2,2) mbl(3,2) - ! ... ... ... ... ... - ! label(n) tau(1,n) tau(2,n) tau(3,n) mbl(1,3) mbl(2,3) mbl(3,3) - ! - ! Example: - ! - ! ATOMIC_POSITIONS (bohr) - ! O 0.0099 0.0099 0.0000 0 0 0 - ! H 1.8325 -0.2243 -0.0001 1 1 1 - ! H -0.2243 1.8325 0.0002 1 1 1 - ! - ! Where: - ! - ! units_option == crystal position are given in scaled units - ! units_option == bohr position are given in Bohr - ! units_option == angstrom position are given in Angstrom - ! units_option == alat position are given in units of alat - ! - ! label(k) ( character(len=4) ) atomic type - ! tau(:,k) ( real ) coordinates of the k-th atom - ! mbl(:,k) ( integer ) mbl(i,k) > 0 the i-th coord. of the - ! k-th atom is allowed to be moved - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - ! ... routine modified for NEB ( C.S. 21/10/2003 ) - ! ... routine modified for SMD ( Y.K. 15/04/2004 ) - ! - SUBROUTINE card_atomic_positions( input_line, prog ) - ! - USE wrappers, ONLY: feval_infix - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - CHARACTER(LEN=2) :: prog - CHARACTER(LEN=4) :: lb_pos - INTEGER :: ia, k, is, nfield, idx, rep_i - LOGICAL, EXTERNAL :: matches - LOGICAL :: tend - LOGICAL, SAVE :: tread = .FALSE. - ! - INTEGER :: ifield, ierr - REAL(DP) :: field_value - CHARACTER(len=256) :: field_str, error_msg - ! - ! - IF ( tread ) THEN - CALL errore( 'card_atomic_positions', 'two occurrences', 2 ) - END IF - IF ( .NOT. taspc ) THEN - CALL errore( 'card_atomic_positions', & - & 'ATOMIC_SPECIES must be present before', 2 ) - END IF - IF ( ntyp > nsx ) THEN - CALL errore( 'card_atomic_positions', 'nsp out of range', ntyp ) - END IF - IF ( nat < 1 ) THEN - CALL errore( 'card_atomic_positions', 'nat out of range', nat ) - END IF - ! - if_pos = 1 - ! - sp_pos = 0 - rd_pos = 0.0_DP - na_inp = 0 - ! - IF ( matches( "CRYSTAL", input_line ) ) THEN - atomic_positions = 'crystal' - ELSE IF ( matches( "BOHR", input_line ) ) THEN - atomic_positions = 'bohr' - ELSE IF ( matches( "ANGSTROM", input_line ) ) THEN - atomic_positions = 'angstrom' - ELSE IF ( matches( "ALAT", input_line ) ) THEN - atomic_positions = 'alat' - ELSE - IF ( TRIM( ADJUSTL( input_line ) ) /= 'ATOMIC_POSITIONS' ) THEN - CALL errore( 'read_cards ', & - & 'unknown option for ATOMIC_POSITION: '& - & // input_line, 1 ) - END IF - IF ( prog == 'FP' ) atomic_positions = 'bohr' - IF ( prog == 'CP' ) atomic_positions = 'bohr' - IF ( prog == 'PW' ) atomic_positions = 'alat' - END IF - ! - - IF ( full_phs_path_flag ) THEN - ! - IF ( ALLOCATED( pos ) ) DEALLOCATE( pos ) - ALLOCATE( pos( 3*nat, num_of_images ) ) - pos(:,:) = 0.0_DP - ! - IF ( calculation == 'smd' .AND. prog == 'CP' ) THEN - ! - CALL errore( 'read_cards', & - 'smd no longer implemented in CP', 1 ) - ! - ELSE - ! - CALL read_line( input_line, end_of_file = tend ) - IF ( tend ) & - CALL errore( 'read_cards', & - 'end of file reading atomic positions (path)', 1 ) - ! - IF ( matches( "first_image", input_line ) ) THEN - ! - input_images = 1 - CALL path_read_images( input_images ) - ! - ELSE - ! - CALL errore( 'read_cards', & - 'first_image missing in ATOMIC_POSITION', 1 ) - ! - END IF - ! - read_conf_loop: DO - ! - CALL read_line( input_line, end_of_file = tend ) - ! - IF ( tend ) & - CALL errore( 'read_cards', 'end of file reading ' // & - & 'atomic positions (path)', input_images + 1 ) - ! - input_images = input_images + 1 - IF ( input_images > num_of_images ) & - CALL errore( 'read_cards', & - & 'too many images in ATOMIC_POSITION', 1 ) - ! - IF ( matches( "intermediate_image", input_line ) ) THEN - ! - CALL path_read_images( input_images ) - ! - ELSE - ! - EXIT read_conf_loop - ! - END IF - ! - END DO read_conf_loop - ! - IF ( matches( "last_image", input_line ) ) THEN - ! - CALL path_read_images( input_images ) - ! - ELSE - ! - CALL errore( 'read_cards ', & - 'last_image missing in ATOMIC_POSITION', 1 ) - ! - END IF - ! - END IF - ! - ELSE - ! - - reader_loop : DO ia = 1,nat,1 - ! - CALL read_line( input_line, end_of_file = tend ) - IF ( tend ) & - CALL errore( 'read_cards', & - 'end of file reading atomic positions', ia ) - ! - CALL field_count( nfield, input_line ) - - ! - IF ( sic /= 'none' .AND. nfield /= 8 ) & - CALL errore( 'read_cards', & - 'ATOMIC_POSITIONS with sic, 8 columns required', 1 ) - ! - IF ( nfield /= 4 .and. nfield /= 7 .and. nfield /= 8) & - CALL errore( 'read_cards', 'wrong number of columns ' // & - & 'in ATOMIC_POSITIONS', ia ) - - ! read atom symbol (column 1) and coordinate - CALL get_field(1, lb_pos, input_line) - lb_pos = TRIM(lb_pos) - ! - error_msg = 'Error while parsing atomic position card.' - ! read field 2 (atom X coordinate) - CALL get_field(2, field_str, input_line) - rd_pos(1,ia) = feval_infix(ierr, field_str ) - CALL errore('card_atomic_positions', error_msg, ierr) - ! read field 2 (atom Y coordinate) - CALL get_field(3, field_str, input_line) - rd_pos(2,ia) = feval_infix(ierr, field_str ) - CALL errore('card_atomic_positions', error_msg, ierr) - ! read field 2 (atom Z coordinate) - CALL get_field(4, field_str, input_line) - rd_pos(3,ia) = feval_infix(ierr, field_str ) - CALL errore('card_atomic_positions', error_msg, ierr) - ! - IF ( nfield >= 7 ) THEN - ! read constrains (fields 5-7, if present) - CALL get_field(5, field_str, input_line) - read(field_str, *) if_pos(1,ia) - CALL get_field(6, field_str, input_line) - read(field_str, *) if_pos(2,ia) - CALL get_field(7, field_str, input_line) - read(field_str, *) if_pos(3,ia) - ENDIF - ! - IF ( nfield == 8 ) THEN - CALL get_field(5, field_str, input_line) - read(field_str, *) id_loc(ia) - END IF - ! - match_label: DO is = 1, ntyp - ! - IF ( TRIM(lb_pos) == TRIM( atom_label(is) ) ) THEN - ! - sp_pos(ia) = is - EXIT match_label - ! - END IF - ! - END DO match_label - ! - - - IF( ( sp_pos(ia) < 1 ) .OR. ( sp_pos(ia) > ntyp ) ) THEN - ! - CALL errore( 'read_cards', 'species '//TRIM(lb_pos)// & - & ' in ATOMIC_POSITIONS is nonexistent', ia ) - ! - END IF - ! - is = sp_pos(ia) - ! - na_inp(is) = na_inp(is) + 1 - ! - - END DO reader_loop - ! - END IF - ! -! DO is = 1, ntyp -! IF( na_inp( is ) < 1 ) THEN -! CALL errore( 'read_cards', & -! 'no atom found in ATOMIC_POSITIONS for species '//TRIM(atom_label(is)), is ) -! END IF -! END DO - ! - tapos = .TRUE. - tread = .TRUE. - ! - - RETURN - ! - CONTAINS - ! - !------------------------------------------------------------------- - SUBROUTINE path_read_images( image ) - !------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: image - ! - ! - DO ia = 1, nat - ! - idx = 3 * ( ia - 1 ) - ! - CALL read_line( input_line, end_of_file = tend ) - ! - IF ( tend ) & - CALL errore( 'read_cards', & - 'end of file reading atomic positions', ia ) - ! - CALL field_count( nfield, input_line ) - ! - IF ( nfield == 4 ) THEN - ! - READ( input_line, * ) lb_pos, pos((idx+1),image), & - pos((idx+2),image), & - pos((idx+3),image) - ! - ELSE IF ( nfield == 7 ) THEN - ! - IF ( image /= 1 ) THEN - ! - CALL errore( 'read_cards', & - & 'wrong number of columns in ' // & - & 'ATOMIC_POSITIONS', sp_pos(ia) ) - ! - END IF - ! - READ( input_line, * ) lb_pos, pos((idx+1),image), & - pos((idx+2),image), & - pos((idx+3),image), & - if_pos(1,ia), & - if_pos(2,ia), & - if_pos(3,ia) - ! - ELSE - ! - CALL errore( 'read_cards', & - & 'wrong number of columns in ' // & - & 'ATOMIC_POSITIONS', sp_pos(ia) ) - ! - END IF - ! - IF ( image == 1 ) THEN - ! - lb_pos = ADJUSTL( lb_pos ) - ! - match_label_path: DO is = 1, ntyp - ! - IF ( TRIM( lb_pos ) == TRIM( atom_label(is) ) ) THEN - ! - sp_pos(ia) = is - ! - EXIT match_label_path - ! - END IF - ! - END DO match_label_path - ! - IF ( ( sp_pos(ia) < 1 ) .OR. ( sp_pos(ia) > ntyp ) ) THEN - ! - CALL errore( 'read_cards', & - 'wrong index in ATOMIC_POSITIONS', ia ) - ! - END IF - ! - is = sp_pos(ia) - ! - na_inp( is ) = na_inp( is ) + 1 - ! - END IF - ! - END DO - ! - RETURN - ! - END SUBROUTINE path_read_images - ! - END SUBROUTINE card_atomic_positions - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! ATOMIC_FORCES - ! - ! read external forces (in atomic units) from standard input - ! - ! Syntax: - ! - ! ATOMIC_FORCES - ! label Fx(1) Fy(1) Fz(1) - ! ..... - ! label Fx(n) Fy(n) Fz(n) - ! - ! Example: - ! - ! ??? - ! - ! Where: - ! - ! label (character(len=4)) atomic label - ! Fx(:), Fy(:) and Fz(:) (REAL) x, y and z component of the external force - ! acting on the ions whose coordinate are given - ! in the same line in card ATOMIC_POSITION - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_atomic_forces( input_line, prog ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - CHARACTER(LEN=2) :: prog - INTEGER :: ia, k, nfield - LOGICAL, SAVE :: tread = .FALSE. - CHARACTER(LEN=4) :: lb - ! - ! - IF( tread ) THEN - CALL errore( ' card_atomic_forces ', ' two occurrences ', 2 ) - END IF - ! - IF( .NOT. taspc ) THEN - CALL errore( ' card_atomic_forces ', & - & ' ATOMIC_SPECIES must be present before ', 2 ) - END IF - ! - rd_for = 0.0_DP - ! - DO ia = 1, nat - ! - CALL read_line( input_line ) - CALL field_count( nfield, input_line ) - IF ( nfield == 4 ) THEN - READ(input_line,*) lb, ( rd_for(k,ia), k = 1, 3 ) - ELSE IF( nfield == 3 ) THEN - READ(input_line,*) ( rd_for(k,ia), k = 1, 3 ) - ELSE - CALL errore( ' iosys ', ' wrong entries in ATOMIC_FORCES ', ia ) - END IF - ! - END DO - ! - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE card_atomic_forces - ! - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! K_POINTS - ! - ! use the specified set of k points - ! - ! Syntax: - ! - ! K_POINTS (mesh_option) - ! n - ! xk(1,1) xk(2,1) xk(3,1) wk(1) - ! ... ... ... ... - ! xk(1,n) xk(2,n) xk(3,n) wk(n) - ! - ! Example: - ! - ! K_POINTS - ! 10 - ! 0.1250000 0.1250000 0.1250000 1.00 - ! 0.1250000 0.1250000 0.3750000 3.00 - ! 0.1250000 0.1250000 0.6250000 3.00 - ! 0.1250000 0.1250000 0.8750000 3.00 - ! 0.1250000 0.3750000 0.3750000 3.00 - ! 0.1250000 0.3750000 0.6250000 6.00 - ! 0.1250000 0.3750000 0.8750000 6.00 - ! 0.1250000 0.6250000 0.6250000 3.00 - ! 0.3750000 0.3750000 0.3750000 1.00 - ! 0.3750000 0.3750000 0.6250000 3.00 - ! - ! Where: - ! - ! mesh_option == automatic k points mesh is generated automatically - ! with Monkhorst-Pack algorithm - ! mesh_option == crystal k points mesh is given in stdin in scaled - ! units - ! mesh_option == tpiba k points mesh is given in stdin in units - ! of ( 2 PI / alat ) - ! mesh_option == gamma only gamma point is used ( default in - ! CPMD simulation ) - ! mesh_option == tpiba_b as tpiba but the weights gives the - ! number of points between this point - ! and the next - ! mesh_option == crystal_b as crystal but the weights gives the - ! number of points between this point and - ! the next - ! - ! n ( integer ) number of k points - ! xk(:,i) ( real ) coordinates of i-th k point - ! wk(i) ( real ) weights of i-th k point - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_kpoints( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - INTEGER :: i, j - INTEGER :: nkaux - INTEGER, ALLOCATABLE :: wkaux(:) - REAL(DP), ALLOCATABLE :: xkaux(:,:) - REAL(DP) :: delta - LOGICAL, EXTERNAL :: matches - LOGICAL, SAVE :: tread = .FALSE. - LOGICAL :: tend - LOGICAL :: kband = .FALSE. - ! - ! - IF ( tread ) THEN - CALL errore( ' card_kpoints ', ' two occurrences', 2 ) - END IF - ! - IF ( matches( "AUTOMATIC", input_line ) ) THEN - ! automatic generation of k-points - k_points = 'automatic' - ELSE IF ( matches( "CRYSTAL", input_line ) ) THEN - ! input k-points are in crystal (reciprocal lattice) axis - k_points = 'crystal' - IF ( matches( "_B", input_line ) ) kband=.true. - ELSE IF ( matches( "TPIBA", input_line ) ) THEN - ! input k-points are in 2pi/a units - k_points = 'tpiba' - IF ( matches( "_B", input_line ) ) kband=.true. - ELSE IF ( matches( "GAMMA", input_line ) ) THEN - ! Only Gamma (k=0) is used - k_points = 'gamma' - ELSE - ! by default, input k-points are in 2pi/a units - k_points = 'tpiba' - END IF - ! - IF ( k_points == 'automatic' ) THEN - ! - ! ... automatic generation of k-points - ! - nkstot = 0 - CALL read_line( input_line, end_of_file = tend ) - IF (tend) GO TO 10 - READ(input_line, *, END=10, ERR=10) nk1, nk2, nk3, k1, k2 ,k3 - IF ( k1 < 0 .OR. k1 > 1 .OR. & - k2 < 0 .OR. k2 > 1 .OR. & - k3 < 0 .OR. k3 > 1 ) CALL errore & - ('card_kpoints', 'invalid offsets: must be 0 or 1', 1) - IF ( nk1 <= 0 .OR. nk2 <= 0 .OR. nk3 <= 0 ) CALL errore & - ('card_kpoints', 'invalid values for nk1, nk2, nk3', 1) - - ! - ELSE IF ( ( k_points == 'tpiba' ) .OR. ( k_points == 'crystal' ) ) THEN - ! - ! ... input k-points are in 2pi/a units - ! - CALL read_line( input_line, end_of_file = tend ) - IF (tend) GO TO 10 - READ(input_line, *, END=10, ERR=10) nkstot - IF ( nkstot > SIZE (xk,2) ) CALL errore & - ('card_kpoints', 'too many k-points',nkstot) - ! - DO i = 1, nkstot - CALL read_line( input_line, end_of_file = tend ) - IF (tend) GO TO 10 - READ(input_line,*, END=10, ERR=10) xk(1,i), xk(2,i), xk(3,i), wk(i) - END DO - IF (kband) THEN - nkaux=nkstot - ALLOCATE(xkaux(3,nkstot)) - ALLOCATE(wkaux(nkstot)) - xkaux(:,1:nkstot)=xk(:,1:nkstot) - wkaux(1:nkstot)=NINT(wk(1:nkstot)) - nkstot=0 - DO i=1,nkaux-1 - delta=1.0_DP/wkaux(i) - DO j=0,wkaux(i)-1 - nkstot=nkstot+1 - IF ( nkstot > SIZE (xk,2) ) CALL errore & - ('card_kpoints', 'too many k-points',nkstot) - xk(:,nkstot)=xkaux(:,i)+delta*j*(xkaux(:,i+1)-xkaux(:,i)) - wk(nkstot)=1.0_DP - ENDDO - ENDDO - nkstot=nkstot+1 - xk(:,nkstot)=xkaux(:,nkaux) - wk(nkstot)=1.0_DP - DEALLOCATE(xkaux) - DEALLOCATE(wkaux) - ENDIF - ! - ELSE IF ( k_points == 'gamma' ) THEN - ! - nkstot = 1 - xk(:,1) = 0.0_DP - wk(1) = 1.0_DP - ! - END IF - ! - tread = .TRUE. - tk_inp = .TRUE. - ! - RETURN -10 CALL errore ('card_kpoints', ' error or end of file while reading ' & - & // TRIM(k_points) // ' k points', 1) - ! - END SUBROUTINE card_kpoints - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! SETNFI - ! - ! Reset the step counter to the specified value - ! - ! Syntax: - ! - ! SETNFI - ! nfi - ! - ! Example: - ! - ! SETNFI - ! 100 - ! - ! Where: - ! - ! nfi (integer) new value for the step counter - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_setnfi( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - LOGICAL, SAVE :: tread = .FALSE. - ! - ! - IF ( tread ) THEN - CALL errore( ' card_setnfi ', ' two occurrences', 2 ) - END IF - CALL read_line( input_line ) - READ(input_line,*) newnfi_card - tnewnfi_card = .TRUE. - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE card_setnfi - ! - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! 2DPROCMESH - ! - ! Distribute the Y and Z FFT dimensions across processors, - ! instead of Z dimension only ( default distribution ) - ! - ! Syntax: - ! - ! 2DPROCMESH - ! - ! Where: - ! - ! no parameters - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! OCCUPATIONS - ! - ! use the specified occupation numbers for electronic states. - ! Note that you should specify 10 values per line maximum! - ! - ! Syntax (nspin == 1): - ! - ! OCCUPATIONS - ! f(1) .... .... f(10) - ! f(11) .... f(nbnd) - ! - ! Syntax (nspin == 2): - ! - ! OCCUPATIONS - ! u(1) .... .... u(10) - ! u(11) .... u(nbnd) - ! d(1) .... .... d(10) - ! d(11) .... d(nbnd) - ! - ! Example: - ! - ! OCCUPATIONS - ! 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 - ! 2.0 2.0 2.0 2.0 2.0 1.0 1.0 - ! - ! Where: - ! - ! f(:) (real) these are the occupation numbers - ! for LDA electronic states. - ! - ! u(:) (real) these are the occupation numbers - ! for LSD spin == 1 electronic states - ! d(:) (real) these are the occupation numbers - ! for LSD spin == 2 electronic states - ! - ! Note, maximum 10 values per line! - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_occupations( input_line ) - ! - USE wrappers, ONLY: feval_infix - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line, field_str - INTEGER :: is, nx10, i, j, nspin0 - INTEGER :: nfield, nbnd_read, nf, ierr - LOGICAL, SAVE :: tread = .FALSE. - LOGICAL :: tef - ! - ! - IF ( tread ) THEN - CALL errore( ' card_occupations ', ' two occurrences', 2 ) - END IF - nspin0=nspin - if (nspin == 4) nspin0=1 - ! - IF ( nbnd == 0 ) CALL errore( ' card_occupations ', ' nbnd not specified', 1 ) - ! - ALLOCATE ( f_inp ( nbnd, nspin0 ) ) - DO is = 1, nspin0 - ! - nbnd_read = 0 - DO WHILE ( nbnd_read < nbnd) - CALL read_line( input_line, end_of_file=tef ) - IF (tef) CALL errore('card_occupations',& - 'Missing occupations, end of file reached',1) - CALL field_count( nfield, input_line ) - ! - DO nf = 1,nfield - nbnd_read = nbnd_read+1 - CALL get_field(nf, field_str, input_line) - ! - f_inp(nbnd_read,is) = feval_infix(ierr, field_str ) - CALL errore('card_occupations',& - 'Error parsing occupation: '//TRIM(field_str), nbnd_read*ierr) - ENDDO - ENDDO - ! - END DO - ! - tf_inp = .TRUE. - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE card_occupations - ! - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! VHMEAN - ! - ! Calculation of potential average along a given axis - ! - ! Syntax: - ! - ! VHMEAN - ! unit nr rmin rmax asse - ! - ! Example: - ! - ! ???? - ! - ! Where: - ! - ! ???? - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_vhmean( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - LOGICAL, SAVE :: tread = .FALSE. - ! - ! - IF ( tread ) THEN - CALL errore( ' card_vhmean ', ' two occurrences', 2 ) - END IF - ! - tvhmean_inp = .TRUE. - CALL read_line( input_line ) - READ(input_line,*) & - vhiunit_inp, vhnr_inp, vhrmin_inp, vhrmax_inp, vhasse_inp - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE card_vhmean - ! - ! - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! DIPOLE - ! - ! calculate polarizability - ! - ! Syntax: - ! - ! DIPOLE - ! - ! Where: - ! - ! no parameters - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_dipole( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - LOGICAL, SAVE :: tread = .FALSE. - ! - ! - IF ( tread ) THEN - CALL errore( ' card_dipole ', ' two occurrences', 2 ) - END IF - ! - tdipole_card = .TRUE. - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE card_dipole - ! - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! IESR - ! - ! use the specified number of neighbour cells for Ewald summations - ! - ! Syntax: - ! - ! ESR - ! iesr - ! - ! Example: - ! - ! ESR - ! 3 - ! - ! Where: - ! - ! iesr (integer) determines the number of neighbour cells to be - ! considered: - ! iesr = 1 : nearest-neighbour cells (default) - ! iesr = 2 : next-to-nearest-neighbour cells - ! and so on - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_esr( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - LOGICAL, SAVE :: tread = .FALSE. - ! - IF ( tread ) THEN - CALL errore( ' card_esr ', ' two occurrences', 2 ) - END IF - CALL read_line( input_line ) - READ(input_line,*) iesr_inp - ! - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE card_esr - ! - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! NEIGHBOURS - ! - ! calculate the neighbours of (and the disance from) each atoms below - ! the distance specified by the parameter - ! - ! Syntax: - ! - ! NEIGHBOURS - ! cut_radius - ! - ! Example: - ! - ! NEIGHBOURS - ! 4.0 - ! - ! Where: - ! - ! cut_radius ( real ) radius of the region where atoms are - ! considered as neighbours ( in a.u. ) - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_neighbours( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - LOGICAL, SAVE :: tread = .FALSE. - ! - ! - IF ( tread ) THEN - CALL errore( ' card_neighbours ', ' two occurrences', 2 ) - END IF - ! - CALL read_line( input_line ) - READ(input_line, *) neighbo_radius - ! - tneighbo = .TRUE. - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE card_neighbours - ! - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! CELL_PARAMETERS - ! - ! use the specified cell dimensions - ! - ! Syntax: - ! - ! CELL_PARAMETERS - ! HT(1,1) HT(1,2) HT(1,3) - ! HT(2,1) HT(2,2) HT(2,3) - ! HT(3,1) HT(3,2) HT(3,3) - ! - ! Example: - ! - ! CELL_PARAMETERS - ! 24.50644311 0.00004215 -0.14717844 - ! -0.00211522 8.12850030 1.70624903 - ! 0.16447787 0.74511792 23.07395418 - ! - ! Where: - ! - ! HT(i,j) (real) cell dimensions ( in a.u. ), - ! note the relation with lattice vectors: - ! HT(1,:) = A1, HT(2,:) = A2, HT(3,:) = A3 - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_cell_parameters( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - INTEGER :: i, j - LOGICAL, EXTERNAL :: matches - LOGICAL, SAVE :: tread = .FALSE. - ! - ! - IF ( tread ) THEN - CALL errore( ' card_cell_parameters ', ' two occurrences', 2 ) - END IF - ! - IF ( matches( 'HEXAGONAL', input_line ) ) then - cell_symmetry = 'hexagonal' - ELSE - cell_symmetry = 'cubic' - END IF - ! - IF ( matches( "BOHR", input_line ) ) THEN - cell_units = 'bohr' - ELSE IF ( matches( "ANGSTROM", input_line ) ) THEN - cell_units = 'angstrom' - ELSE - cell_units = 'alat' - END IF - ! - DO i = 1, 3 - CALL read_line( input_line ) - READ(input_line,*) ( rd_ht( i, j ), j = 1, 3 ) - END DO - ! - trd_ht = .TRUE. - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE card_cell_parameters - ! - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! TURBO - ! - ! allocate space to store electronic states in real space while - ! computing charge density, and then reuse the stored state - ! in the calculation of forces instead of repeating the FFT - ! - ! Syntax: - ! - ! TURBO - ! nturbo - ! - ! Example: - ! - ! TURBO - ! 64 - ! - ! Where: - ! - ! nturbo (integer) number of states to be stored - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_turbo( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - LOGICAL, SAVE :: tread = .FALSE. - ! - ! - IF ( tread ) THEN - CALL errore( ' card_turbo ', ' two occurrences', 2 ) - END IF - ! - CALL read_line( input_line ) - READ(input_line,*) nturbo_inp - ! - IF( (nturbo_inp < 0) .OR. (nturbo_inp > (nbnd/2)) ) THEN - CALL errore( ' card_turbo ', ' NTURBO OUT OF RANGE ', nturbo_inp ) - END IF - ! - tturbo_inp = .TRUE. - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE - ! - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! ATOMIC_VELOCITIES - ! - ! read velocities (in atomic units) from standard input - ! - ! Syntax: - ! - ! ATOMIC_VELOCITIES - ! label(1) Vx(1) Vy(1) Vz(1) - ! .... - ! label(n) Vx(n) Vy(n) Vz(n) - ! - ! Example: - ! - ! ??? - ! - ! Where: - ! - ! label (character(len=4)) atomic label - ! Vx(:), Vy(:) and Vz(:) (REAL) x, y and z velocity components of - ! the ions - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_ion_velocities( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - INTEGER :: ia, k, is, nfield - LOGICAL, SAVE :: tread = .FALSE. - CHARACTER(LEN=4) :: lb_vel - ! - ! - IF( tread ) THEN - CALL errore( ' card_ion_velocities ', ' two occurrences', 2 ) - END IF - ! - IF( .NOT. taspc ) THEN - CALL errore( ' card_ion_velocities ', & - & ' ATOMIC_SPECIES must be present before ', 2 ) - END IF - ! - rd_vel = 0.0_DP - sp_vel = 0 - ! - IF ( ion_velocities == 'from_input' ) THEN - ! - tavel = .TRUE. - ! - DO ia = 1, nat - ! - CALL read_line( input_line ) - CALL field_count( nfield, input_line ) - IF ( nfield == 4 ) THEN - READ(input_line,*) lb_vel, ( rd_vel(k,ia), k = 1, 3 ) - ELSE - CALL errore( ' iosys ', & - & ' wrong entries in ION_VELOCITIES ', ia ) - END IF - ! - match_label: DO is = 1, ntyp - IF ( TRIM( lb_vel ) == atom_label(is) ) THEN - sp_vel(ia) = is - EXIT match_label - END IF - END DO match_label - ! - IF ( sp_vel(ia) < 1 .OR. sp_vel(ia) > ntyp ) THEN - CALL errore( ' iosys ', ' wrong LABEL in ION_VELOCITIES ', ia ) - END IF - ! - END DO - ! - END IF - ! - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! CONSTRAINTS - ! - ! Ionic Constraints - ! - ! Syntax: - ! - ! CONSTRAINTS - ! NCONSTR CONSTR_TOL - ! CONSTR_TYPE(.) CONSTR(1,.) CONSTR(2,.) ... { CONSTR_TARGET(.) } - ! - ! Where: - ! - ! NCONSTR(INTEGER) number of constraints - ! - ! CONSTR_TOL tolerance for keeping the constraints - ! satisfied - ! - ! CONSTR_TYPE(.) type of constrain: - ! 1: for fixed distances ( two atom indexes must - ! be specified ) - ! 2: for fixed planar angles ( three atom indexes - ! must be specified ) - ! - ! CONSTR(1,.) CONSTR(2,.) ... - ! - ! indices object of the constraint, as - ! they appear in the 'POSITION' CARD - ! - ! CONSTR_TARGET target for the constrain ( in the case of - ! planar angles it is the COS of the angle ). - ! this variable is optional. - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_constraints( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - INTEGER :: i, nfield - LOGICAL, SAVE :: tread = .FALSE. - ! - ! - IF ( tread ) CALL errore( 'card_constraints', 'two occurrences', 2 ) - ! - CALL read_line( input_line ) - ! - CALL field_count( nfield, input_line ) - ! - IF ( nfield == 1 ) THEN - ! - READ( input_line, * ) nconstr_inp - ! - ELSE IF ( nfield == 2 ) THEN - ! - READ( input_line, * ) nconstr_inp, constr_tol_inp - ! - ELSE - ! - CALL errore( 'card_constraints', 'too many fields', nfield ) - ! - END IF - WRITE(stdout,'(5x,a,i4,a,f12.6)') & - 'Reading',nconstr_inp,' constraints; tolerance:', constr_tol_inp - ! - CALL allocate_input_constr() - ! - DO i = 1, nconstr_inp - ! - CALL read_line( input_line ) - ! - READ( input_line, * ) constr_type_inp(i) - ! - CALL field_count( nfield, input_line ) - ! - IF ( nfield > nc_fields + 2 ) & - CALL errore( 'card_constraints', & - 'too many fields for this constraint', i ) - ! - SELECT CASE( constr_type_inp(i) ) - CASE( 'type_coord', 'atom_coord' ) - ! - IF ( nfield == 5 ) THEN - ! - READ( input_line, * ) constr_type_inp(i), & - constr_inp(1,i), & - constr_inp(2,i), & - constr_inp(3,i), & - constr_inp(4,i) - ! - WRITE(stdout,'(7x,i3,a,i3,a,i2,a,2f12.6)') & - i,') '//constr_type_inp(i)(1:4),INT(constr_inp(1,i)) ,' coordination wrt type:', INT(constr_inp(2,i)), & - ' cutoff distance and smoothing:', constr_inp(3:4,i) - ELSE IF ( nfield == 6 ) THEN - ! - READ( input_line, * ) constr_type_inp(i), & - constr_inp(1,i), & - constr_inp(2,i), & - constr_inp(3,i), & - constr_inp(4,i), & - constr_target(i) - ! - constr_target_set(i) = .TRUE. - ! - WRITE(stdout,'(7x,i3,a,i3,a,i2,a,2f12.6,a,f12.6)') & - i,') '//constr_type_inp(i)(1:4),INT(constr_inp(1,i)) ,' coordination wrt type:', INT(constr_inp(2,i)), & - ' cutoff distance and smoothing:', constr_inp(3:4,i), & - '; target:', constr_target(i) - ELSE - ! - CALL errore( 'card_constraints', 'type_coord, ' // & - & 'atom_coord: wrong number of fields', nfield ) - ! - END IF - ! - CASE( 'distance' ) - ! - IF ( nfield == 3 ) THEN - ! - READ( input_line, * ) constr_type_inp(i), & - constr_inp(1,i), & - constr_inp(2,i) - ! - WRITE(stdout,'(7x,i3,a,i3,a,i3)') & - i,') distance from atom:', INT(constr_inp(1,i)), ' to:', INT(constr_inp(2,i)) - ELSE IF ( nfield == 4 ) THEN - ! - READ( input_line, * ) constr_type_inp(i), & - constr_inp(1,i), & - constr_inp(2,i), & - constr_target(i) - ! - constr_target_set(i) = .TRUE. - ! - WRITE(stdout,'(7x,i3,a,i3,a,i3,a,f12.6)') & - i,') distance from atom', INT(constr_inp(1,i)), ' to atom', INT(constr_inp(2,i)), & - '; target:', constr_target(i) - ELSE - ! - CALL errore( 'card_constraints', & - & 'distance: wrong number of fields', nfield ) - ! - END IF - ! - CASE( 'planar_angle' ) - ! - IF ( nfield == 4 ) THEN - ! - READ( input_line, * ) constr_type_inp(i), & - constr_inp(1,i), & - constr_inp(2,i), & - constr_inp(3,i) - ! - WRITE(stdout, '(7x,i3,a,3i3)') & - i,') planar angle between atoms: ', INT(constr_inp(1:3,i)) - ELSE IF ( nfield == 5 ) THEN - ! - READ( input_line, * ) constr_type_inp(i), & - constr_inp(1,i), & - constr_inp(2,i), & - constr_inp(3,i), & - constr_target(i) - ! - constr_target_set(i) = .TRUE. - ! - WRITE(stdout, '(7x,i3,a,3i3,a,f12.6)') & - i,') planar angle between atoms: ', INT(constr_inp(1:3,i)), '; target:', constr_target(i) - ELSE - ! - CALL errore( 'card_constraints', & - & 'planar_angle: wrong number of fields', nfield ) - ! - END IF - ! - CASE( 'torsional_angle' ) - ! - IF ( nfield == 5 ) THEN - ! - READ( input_line, * ) constr_type_inp(i), & - constr_inp(1,i), & - constr_inp(2,i), & - constr_inp(3,i), & - constr_inp(4,i) - ! - WRITE(stdout, '(7x,i3,a,4i3)') & - i,') torsional angle between atoms: ', INT(constr_inp(1:4,i)) - ELSE IF ( nfield == 6 ) THEN - ! - READ( input_line, * ) constr_type_inp(i), & - constr_inp(1,i), & - constr_inp(2,i), & - constr_inp(3,i), & - constr_inp(4,i), & - constr_target(i) - ! - constr_target_set(i) = .TRUE. - ! - WRITE(stdout, '(7x,i3,a,4i3,a,f12.6)') & - i,') torsional angle between atoms: ', INT(constr_inp(1:4,i)), '; target:', constr_target(i) - ELSE - ! - CALL errore( 'card_constraints', & - & 'torsional_angle: wrong number of fields', nfield ) - ! - END IF - ! - CASE( 'bennett_proj' ) - ! - IF ( nfield == 5 ) THEN - ! - READ( input_line, * ) constr_type_inp(i), & - constr_inp(1,i), & - constr_inp(2,i), & - constr_inp(3,i), & - constr_inp(4,i) - ! - WRITE(stdout, '(7x,i3,a,i3,a,3f12.6)') & - i,') bennet projection of atom ', INT(constr_inp(1,i)), ' along vector:', constr_inp(2:4,i) - ELSE IF ( nfield == 6 ) THEN - ! - READ( input_line, * ) constr_type_inp(i), & - constr_inp(1,i), & - constr_inp(2,i), & - constr_inp(3,i), & - constr_inp(4,i), & - constr_target(i) - ! - constr_target_set(i) = .TRUE. - ! - WRITE(stdout, '(7x,i3,a,i3,a,3f12.6,a,f12.6)') & - i,') bennet projection of atom ', INT(constr_inp(1,i)), ' along vector:', constr_inp(2:4,i), & - '; target:', constr_target(i) - ELSE - ! - CALL errore( 'card_constraints', & - & 'bennett_proj: wrong number of fields', nfield ) - ! - END IF - ! - CASE DEFAULT - ! - CALL errore( 'card_constraints', 'unknown constraint ' // & - & 'type: ' // TRIM( constr_type_inp(i) ), 1 ) - ! - END SELECT - ! - END DO - ! - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE card_constraints - ! - SUBROUTINE card_collective_vars( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - INTEGER :: i, nfield - LOGICAL :: ltest - LOGICAL, SAVE :: tread = .FALSE. - ! - ! - IF ( tread ) CALL errore( 'card_collective_vars', 'two occurrences', 2 ) - ! - CALL read_line( input_line ) - ! - CALL field_count( nfield, input_line ) - ! - IF ( nfield == 1 ) THEN - ! - READ( input_line, * ) ncolvar_inp - ! - ELSE IF ( nfield == 2 ) THEN - ! - READ( input_line, * ) ncolvar_inp, colvar_tol_inp - ! - ELSE - ! - CALL errore( 'card_collective_vars', 'too many fields', nfield ) - ! - END IF - ! - CALL allocate_input_colvar() - ! - IF ( cg_phs_path_flag ) THEN - ! - input_images = 2 - ! - IF( ALLOCATED( pos ) ) DEALLOCATE( pos ) - ! - ALLOCATE( pos( ncolvar_inp, input_images ) ) - ! - pos(:,:) = 0.0_DP - ! - END IF - ! - DO i = 1, ncolvar_inp - ! - CALL read_line( input_line ) - ! - READ( input_line, * ) colvar_type_inp(i) - ! - CALL field_count( nfield, input_line ) - ! - ltest = ( ( nfield <= nc_fields + 2 ) .OR. & - ( cg_phs_path_flag .AND. ( nfield <= nc_fields + 4 ) ) ) - ! - IF ( .NOT. ltest ) & - CALL errore( 'card_collective_vars', 'too many fields for ' // & - & 'this constraint: ' // TRIM( constr_type_inp(i) ), i ) - ! - SELECT CASE( colvar_type_inp(i) ) - CASE( 'type_coord', 'atom_coord' ) - ! - IF ( cg_phs_path_flag ) THEN - ! - READ( input_line, * ) colvar_type_inp(i), & - colvar_inp(1,i), & - colvar_inp(2,i), & - colvar_inp(3,i), & - colvar_inp(4,i), & - pos(i,1), & - pos(i,2) - ! - ELSE IF ( nfield == 5 ) THEN - ! - READ( input_line, * ) colvar_type_inp(i), & - colvar_inp(1,i), & - colvar_inp(2,i), & - colvar_inp(3,i), & - colvar_inp(4,i) - ! - ELSE - ! - CALL errore( 'card_collective_vars', 'type_coord, ' // & - & 'atom_coord: wrong number of fields', nfield ) - ! - END IF - ! - CASE( 'distance' ) - ! - IF ( cg_phs_path_flag ) THEN - ! - READ( input_line, * ) colvar_type_inp(i), & - colvar_inp(1,i), & - colvar_inp(2,i), & - pos(i,1), & - pos(i,2) - ! - ELSE IF ( nfield == 3 ) THEN - ! - READ( input_line, * ) colvar_type_inp(i), & - colvar_inp(1,i), & - colvar_inp(2,i) - ! - ELSE - ! - CALL errore( 'card_collective_vars', & - & 'distance: wrong number of fields', nfield ) - ! - END IF - ! - CASE( 'planar_angle' ) - ! - IF ( cg_phs_path_flag ) THEN - ! - READ( input_line, * ) colvar_type_inp(i), & - colvar_inp(1,i), & - colvar_inp(2,i), & - colvar_inp(3,i), & - pos(i,1), & - pos(i,2) - ! - ELSE IF ( nfield == 4 ) THEN - ! - READ( input_line, * ) colvar_type_inp(i), & - colvar_inp(1,i), & - colvar_inp(2,i), & - colvar_inp(3,i) - ! - ELSE - ! - CALL errore( 'card_collective_vars', & - & 'planar_angle: wrong number of fields', nfield ) - ! - END IF - ! - CASE( 'torsional_angle' ) - ! - IF ( cg_phs_path_flag ) THEN - ! - READ( input_line, * ) colvar_type_inp(i), & - colvar_inp(1,i), & - colvar_inp(2,i), & - colvar_inp(3,i), & - colvar_inp(4,i), & - pos(i,1), & - pos(i,2) - ! - ELSE IF ( nfield == 5 ) THEN - ! - READ( input_line, * ) colvar_type_inp(i), & - colvar_inp(1,i), & - colvar_inp(2,i), & - colvar_inp(3,i), & - colvar_inp(4,i) - ! - ELSE - ! - CALL errore( 'card_collective_vars', & - & 'torsional_angle: wrong number of fields', nfield ) - ! - END IF - ! - CASE( 'struct_fac' ) - ! - IF ( cg_phs_path_flag ) THEN - ! - READ( input_line, * ) colvar_type_inp(i), & - colvar_inp(1,i), & - colvar_inp(2,i), & - colvar_inp(3,i), & - pos(i,1), & - pos(i,2) - ! - ELSE IF ( nfield == 4 ) THEN - ! - READ( input_line, * ) colvar_type_inp(i), & - colvar_inp(1,i), & - colvar_inp(2,i), & - colvar_inp(3,i) - ! - ELSE - ! - CALL errore( 'card_collective_vars', & - & 'struct_fac: wrong number of fields', nfield ) - ! - END IF - ! - CASE( 'sph_struct_fac' ) - ! - IF ( cg_phs_path_flag ) THEN - ! - READ( input_line, * ) colvar_type_inp(i), & - colvar_inp(1,i), & - pos(i,1), & - pos(i,2) - ! - ELSE IF ( nfield == 2 ) THEN - ! - READ( input_line, * ) colvar_type_inp(i), & - colvar_inp(1,i) - ! - ELSE - ! - CALL errore( 'card_collective_vars', & - & 'sph_struct_fac: wrong number of fields', nfield ) - ! - END IF - ! - CASE( 'bennett_proj' ) - ! - IF ( cg_phs_path_flag ) THEN - ! - READ( input_line, * ) constr_type_inp(i), & - constr_inp(1,i), & - constr_inp(2,i), & - constr_inp(3,i), & - constr_inp(4,i), & - pos(i,1), & - pos(i,2) - ! - ELSE IF ( nfield == 5 ) THEN - ! - READ( input_line, * ) constr_type_inp(i), & - constr_inp(1,i), & - constr_inp(2,i), & - constr_inp(3,i), & - constr_inp(4,i) - ! - ELSE - ! - CALL errore( 'card_collective_vars', & - & 'bennett_proj: wrong number of fields', nfield ) - ! - END IF - ! - CASE DEFAULT - ! - CALL errore( 'card_collective_vars', 'unknown collective ' // & - & 'variable: ' // TRIM( colvar_type_inp(i) ), 1 ) - ! - END SELECT - ! - END DO - ! - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE card_collective_vars - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! KSOUT - ! - ! Enable the printing of Kohn Sham states - ! - ! Syntax ( nspin == 2 ): - ! - ! KSOUT - ! nu - ! iu(1) iu(2) iu(3) .. iu(nu) - ! nd - ! id(1) id(2) id(3) .. id(nd) - ! - ! Syntax ( nspin == 1 ): - ! - ! KSOUT - ! ns - ! is(1) is(2) is(3) .. is(ns) - ! - ! Example: - ! - ! ??? - ! - ! Where: - ! - ! nu (integer) number of spin=1 states to be printed - ! iu(:) (integer) indexes of spin=1 states, the state iu(k) - ! is saved to file KS_UP.iu(k) - ! - ! nd (integer) number of spin=2 states to be printed - ! id(:) (integer) indexes of spin=2 states, the state id(k) - ! is saved to file KS_DW.id(k) - ! - ! ns (integer) number of LDA states to be printed - ! is(:) (integer) indexes of LDA states, the state is(k) - ! is saved to file KS.is(k) - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_ksout( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - LOGICAL, SAVE :: tread = .FALSE. - INTEGER :: i, s, nksx - TYPE occupancy_type - INTEGER, pointer :: occs(:) - END TYPE occupancy_type - TYPE(occupancy_type), ALLOCATABLE :: is(:) - ! - IF ( tread ) THEN - CALL errore( ' card_ksout ', ' two occurrences', 2 ) - END IF - ! - nprnks = 0 - nksx = 0 - ! - ALLOCATE ( is (nspin) ) - ! - DO s = 1, nspin - ! - CALL read_line( input_line ) - READ(input_line, *) nprnks( s ) - ! - IF ( nprnks( s ) < 1 ) THEN - CALL errore( ' card_ksout ', ' wrong number of states ', 2 ) - END IF - ! - ALLOCATE( is(s)%occs( 1:nprnks(s) ) ) - ! - CALL read_line( input_line ) - READ(input_line, *) ( is(s)%occs(i), i = 1, nprnks( s ) ) - ! - nksx = MAX( nksx, nprnks( s ) ) - ! - END DO - ! - CALL allocate_input_iprnks( nksx, nspin ) - ! - DO s = 1, nspin - ! - DO i = 1, nprnks( s ) - ! - iprnks( i, s ) = is(s)%occs(i) - ! - END DO - ! - DEALLOCATE( is(s)%occs ) - ! - END DO - ! - DEALLOCATE( is ) - ! - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE - ! - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! KSOUT_EMPTY - ! - ! Enable the printing of empty Kohn Sham states - ! - ! Syntax ( nspin == 2 ): - ! - ! KSOUT_EMPTY - ! nu - ! iu(1) iu(2) iu(3) .. iu(nu) - ! nd - ! id(1) id(2) id(3) .. id(nd) - ! - ! Syntax ( nspin == 1 ): - ! - ! KSOUT_EMPTY - ! ns - ! is(1) is(2) is(3) .. is(ns) - ! - ! Example: - ! - ! ??? - ! - ! Where: - ! - ! nu (integer) number of spin=1 empty states to be printed - ! iu(:) (integer) indexes of spin=1 empty states, the state iu(k) - ! is saved to file KS_EMP_UP.iu(k) - ! - ! nd (integer) number of spin=2 empty states to be printed - ! id(:) (integer) indexes of spin=2 empty states, the state id(k) - ! is saved to file KS_EMP_DW.id(k) - ! - ! ns (integer) number of LDA empty states to be printed - ! is(:) (integer) indexes of LDA empty states, the state is(k) - ! is saved to file KS_EMP.is(k) - ! - ! Note: the first empty state has index "1" ! - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_ksout_empty( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - LOGICAL, SAVE :: tread = .FALSE. - INTEGER :: nksx, i, s - TYPE occupancy_type - INTEGER, pointer :: occs(:) - END TYPE occupancy_type - TYPE(occupancy_type), ALLOCATABLE :: is(:) - ! - IF ( tread ) THEN - CALL errore( ' card_ksout_empty ', ' two occurrences', 2 ) - END IF - ! - ALLOCATE ( is (nspin) ) - ! - nprnks_empty = 0 - nksx = 0 - ! - DO s = 1, nspin - ! - CALL read_line( input_line ) - READ(input_line,*) nprnks_empty( s ) - ! - IF ( nprnks_empty( s ) < 1 ) THEN - CALL errore( ' card_ksout_empty ', ' wrong number of states ', 2 ) - END IF - ! - ALLOCATE( is(s)%occs( 1:nprnks_empty( s ) ) ) - ! - CALL read_line( input_line ) - READ(input_line,*) ( is(s)%occs( i ), i = 1, nprnks_empty( s ) ) - ! - nksx = MAX( nksx, nprnks_empty( s ) ) - ! - END DO - ! - CALL allocate_input_iprnks_empty( nksx, nspin ) - ! - DO s = 1, nspin - ! - DO i = 1, nprnks_empty( s ) - ! - iprnks_empty( i, s ) = is(s)%occs( i ) - ! - END DO - ! - DEALLOCATE( is(s)%occs ) - ! - END DO - ! - DEALLOCATE( is ) - ! - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE - ! - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! CLIMBING_IMAGES - ! - ! Needed to explicitly specify which images have to climb - ! - ! Syntax: - ! - ! CLIMBING_IMAGES - ! index1, ..., indexN - ! - ! Where: - ! - ! index1, ..., indexN are indices of the images that have to climb - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_climbing_images( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - LOGICAL, SAVE :: tread = .FALSE. - LOGICAL, EXTERNAL :: matches - ! - INTEGER :: i - CHARACTER(LEN=5) :: i_char - ! - CHARACTER(LEN=6), EXTERNAL :: int_to_char - ! - ! - IF ( tread ) & - CALL errore( ' card_climbing_images ', ' two occurrences', 2 ) - ! - IF ( CI_scheme == 'manual' ) THEN - ! - IF ( ALLOCATED( climbing ) ) DEALLOCATE( climbing ) - ! - ALLOCATE( climbing( num_of_images ) ) - ! - climbing(:) = .FALSE. - ! - CALL read_line( input_line ) - ! - DO i = 1, num_of_images - ! - i_char = int_to_char( i ) - ! - IF ( matches( ' ' // TRIM( i_char ) // ',' , & - ' ' // TRIM( input_line ) // ',' ) ) & - climbing(i) = .TRUE. - ! - END DO - ! - END IF - ! - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE card_climbing_images - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! PLOT WANNIER - ! - ! Needed to specify the indices of the wannier functions that - ! have to be plotted - ! - ! Syntax: - ! - ! PLOT_WANNIER - ! index1, ..., indexN - ! - ! Where: - ! - ! index1, ..., indexN are indices of the wannier functions - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_plot_wannier( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - LOGICAL, SAVE :: tread = .FALSE. - LOGICAL, EXTERNAL :: matches - ! - INTEGER :: i, ib - CHARACTER(LEN=5) :: i_char - CHARACTER(LEN=6), EXTERNAL :: int_to_char - ! - ! - IF ( tread ) & - CALL errore( 'card_plot_wannier', 'two occurrences', 2 ) - ! - IF ( nwf > 0 ) THEN - ! - IF ( nwf > nwf_max ) & - CALL errore( 'card_plot_wannier', 'too many wannier functions', 1 ) - ! - CALL read_line( input_line ) - ! - ib = 0 - ! - DO i = 1, nwf_max - ! - i_char = int_to_char( i ) - ! - IF ( matches( ' ' // TRIM( i_char ) // ',', & - ' ' // TRIM( input_line ) // ',' ) ) THEN - ! - ib = ib + 1 - ! - IF ( ib > nwf ) & - CALL errore( 'card_plot_wannier', 'too many indices', 1 ) - ! - wannier_index(ib) = i - ! - END IF - ! - END DO - ! - END IF - ! - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE card_plot_wannier - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - ! - ! - ! TEMPLATE - ! - ! This is a template card info section - ! - ! Syntax: - ! - ! TEMPLATE - ! RVALUE IVALUE - ! - ! Example: - ! - ! ??? - ! - ! Where: - ! - ! RVALUE (real) This is a real value - ! IVALUE (integer) This is an integer value - ! - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_template( input_line ) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - LOGICAL, SAVE :: tread = .FALSE. - ! - ! - IF ( tread ) THEN - CALL errore( ' card_template ', ' two occurrences', 2 ) - END IF - ! - ! .... CODE HERE - ! - tread = .TRUE. - ! - RETURN - ! - END SUBROUTINE - ! - ! - !------------------------------------------------------------------------ - ! BEGIN manual - !---------------------------------------------------------------------- - !WANNIER_AC - !Wannier# 1 10.5 15.7 2 - !atom 1 - !d 1 0.45 - !p 3 0.55 - !Wannier# 2 10.5 15.7 1 - !atom 3 - !p 1 0.8 - !Spin#2: - !Wannier# 1 10.5 15.7 2 - !atom 1 - !d 1 0.45 - !p 3 0.55 - !Wannier# 2 10.5 15.7 1 - !atom 3 - !p 1 0.8 - !---------------------------------------------------------------------- - ! END manual - !------------------------------------------------------------------------ - ! - SUBROUTINE card_wannier_ac( input_line ) - ! - USE wannier_new, only: nwan - - IMPLICIT NONE - ! - CHARACTER(LEN=256) :: input_line - INTEGER :: i,j,k, nfield, iwan, ning, iatom,il,im,ispin - LOGICAL :: tend - REAL :: c, b_from, b_to - CHARACTER(LEN=10) :: text, lo - - ispin = 1 - ! - DO i = 1, nwan - ! - CALL read_line( input_line, end_of_file = tend ) - ! - IF ( tend ) & - CALL errore( 'read_cards', & - 'end of file reading trial wfc composition', i ) - ! - CALL field_count( nfield, input_line ) - ! - IF ( nfield == 4 ) THEN - READ(input_line,*) text, iwan, b_from, b_to - ning = 1 - ELSE IF ( nfield == 5 ) THEN - READ(input_line,*) text, iwan, b_from, b_to, ning - ELSE - CALL errore( 'read_cards', & - 'wrong format', nfield ) - END IF - IF(iwan.ne.i) CALL errore( 'read_cards', 'wrong wannier order', iwan) - - ! Read atom number - CALL read_line( input_line, end_of_file = tend ) - READ(input_line,*) text, iatom - ! - wan_data(iwan,ispin)%iatom = iatom - wan_data(iwan,ispin)%ning = ning - wan_data(iwan,ispin)%bands_from = b_from - wan_data(iwan,ispin)%bands_to = b_to - ! - DO j=1, ning - CALL read_line( input_line, end_of_file = tend ) - ! - IF ( tend ) & - CALL errore( 'read_cards', & - 'not enough wavefunctions', j ) - IF (ning.eq.1) THEN - READ(input_line,*) lo,im - c = 1.d0 - ELSE - READ(input_line,*) lo,im,c - END IF - - SELECT CASE(TRIM(lo)) - CASE('s') - il = 0 - CASE('p') - il = 1 - CASE('d') - il = 2 - CASE('f') - il = 3 - CASE DEFAULT - CALL errore( 'read_cards', & - 'wrong l-label', 1 ) - END SELECT - - wan_data(iwan,ispin)%ing(j)%l = il - wan_data(iwan,ispin)%ing(j)%m = im - wan_data(iwan,ispin)%ing(j)%c = c - END DO - END DO - - !Is there spin 2 information? - CALL read_line( input_line, end_of_file = tend ) - ! - IF ( .NOT. tend ) then - READ(input_line,*) text - IF ( TRIM(text) == 'Spin#2:') then ! ok, there is spin 2 data - ispin = 2 - ! - DO i = 1, nwan - ! - CALL read_line( input_line, end_of_file = tend ) - ! - IF ( tend ) & - CALL errore( 'read_cards', & - 'end of file reading trial wfc composition', i ) - ! - CALL field_count( nfield, input_line ) - ! - IF ( nfield == 4 ) THEN - READ(input_line,*) text, iwan, b_from, b_to - ning = 1 - ELSE IF ( nfield == 4 ) THEN - READ(input_line,*) text, iwan, b_from, b_to, ning - ELSE - CALL errore( 'read_cards', & - 'wrong format', nfield ) - END IF - IF(iwan.ne.i) CALL errore( 'read_cards', 'wrong wannier order', iwan) - - ! Read atom number - CALL read_line( input_line, end_of_file = tend ) - READ(input_line,*) text, iatom - ! - wan_data(iwan,ispin)%iatom = iatom - wan_data(iwan,ispin)%ning = ning - wan_data(iwan,ispin)%bands_from = b_from - wan_data(iwan,ispin)%bands_to = b_to - ! - DO j=1, ning - CALL read_line( input_line, end_of_file = tend ) - ! - IF ( tend ) & - CALL errore( 'read_cards', & - 'not enough wavefunctions', j ) - IF (ning.eq.1) THEN - READ(input_line,*) lo,im - c = 1.d0 - ELSE - READ(input_line,*) lo,im,c - END IF - - SELECT CASE(TRIM(lo)) - CASE('s') - il = 0 - CASE('p') - il = 1 - CASE('d') - il = 2 - CASE('f') - il = 3 - CASE DEFAULT - CALL errore( 'read_cards', & - 'wrong l-label', 1 ) - END SELECT - - wan_data(iwan,ispin)%ing(j)%l = il - wan_data(iwan,ispin)%ing(j)%m = im - wan_data(iwan,ispin)%ing(j)%c = c - END DO - END DO - END IF - END IF - ! - RETURN - ! - END SUBROUTINE card_wannier_ac -END MODULE read_cards_module diff --git a/quantum_espresso/kcp/Modules/read_namelists.f90 b/quantum_espresso/kcp/Modules/read_namelists.f90 deleted file mode 100644 index 484aa04f9..000000000 --- a/quantum_espresso/kcp/Modules/read_namelists.f90 +++ /dev/null @@ -1,2369 +0,0 @@ -! -! Copyright (C) 2002-2008 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE read_namelists_module - !---------------------------------------------------------------------------- - ! - ! ... this module handles the reading of input namelists - ! ... written by: Carlo Cavazzoni - ! -------------------------------------------------- - ! - USE kinds, ONLY: DP - USE input_parameters - ! - IMPLICIT NONE - ! - SAVE - ! - PRIVATE - ! - REAL(DP), PARAMETER :: sm_not_set = -20.0_DP - ! - PUBLIC :: read_namelists, sm_not_set - ! - ! ... end of module-scope declarations - ! - ! ---------------------------------------------- - ! -CONTAINS - ! - !=-----------------------------------------------------------------------=! - ! - ! Variables initialization for Namelist CONTROL - ! - !=-----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE control_defaults(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - ! - ! - IF (prog == 'PW') THEN - title = ' ' - calculation = 'scf' - ELSE - title = 'MD Simulation' - calculation = 'cp' - END IF - verbosity = 'default' - IF (prog == 'PW') restart_mode = 'from_scratch' - IF (prog == 'CP') restart_mode = 'restart' - nstep = 50 - IF (prog == 'PW') iprint = 100000 - IF (prog == 'CP') iprint = 10 - IF (prog == 'PW') isave = 0 - IF (prog == 'CP') isave = 100 - ! - tstress = .FALSE. - tprnfor = .FALSE. - tabps = .FALSE. - ! - IF (prog == 'PW') dt = 20.0_DP - IF (prog == 'CP') dt = 1.0_DP - ! - ndr = 50 - ndw = 50 - ! - ! ... use the path specified as outdir and the filename prefix - ! ... to store output data - ! - CALL get_env('ESPRESSO_TMPDIR', outdir) - IF (TRIM(outdir) == ' ') outdir = './' - IF (prog == 'PW') prefix = 'pwscf' - IF (prog == 'CP') prefix = 'cp' - ! - ! ... directory containing the pseudopotentials - ! - CALL get_env('ESPRESSO_PSEUDO', pseudo_dir) - IF (TRIM(pseudo_dir) == ' ') THEN - CALL get_env('HOME', pseudo_dir) - pseudo_dir = TRIM(pseudo_dir)//'/espresso/pseudo/' - END IF - ! - refg = 0.05_DP - max_seconds = 1.E+7_DP - ekin_conv_thr = 1.E-6_DP - etot_conv_thr = 1.E-4_DP - forc_conv_thr = 1.E-3_DP - disk_io = 'default' - evc_restart = .FALSE. - dipfield = .FALSE. - lberry = .FALSE. - gdir = 0 - nppstr = 0 - wf_collect = .FALSE. - printwfc = -1 - lelfield = .FALSE. - nberrycyc = 1 - lkpoint_dir = .TRUE. - ! - saverho = .TRUE. - ! - write_hr = .FALSE. - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Variables initialization for Namelist SYSTEM - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE system_defaults(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - ! - ! - ibrav = -1 - celldm = (/0.0_DP, 0.0_DP, 0.0_DP, 0.0_DP, 0.0_DP, 0.0_DP/) - a = 0.0_DP - b = 0.0_DP - c = 0.0_DP - cosab = 0.0_DP - cosac = 0.0_DP - cosbc = 0.0_DP - nat = 0 - ntyp = 0 - nbnd = 0 - nelec = 0.0_DP - tot_charge = 0.0_DP - tot_magnetization = -1 - multiplicity = 0 - ecutwfc = 0.0_DP - ecutrho = 0.0_DP - nr1 = 0 - nr2 = 0 - nr3 = 0 - nr1s = 0 - nr2s = 0 - nr3s = 0 - nr1b = 0 - nr2b = 0 - nr3b = 0 - occupations = 'fixed' - smearing = 'gaussian' - degauss = 0.0_DP - nelup = 0.0_DP - neldw = 0.0_DP - nspin = 1 - nosym = .FALSE. - nosym_evc = .FALSE. - force_symmorphic = .FALSE. - noinv = .FALSE. - ecfixed = 0.0_DP - qcutz = 0.0_DP - q2sigma = 0.01_DP - input_dft = 'none' -! -! ... set starting_magnetization to an invalid value: -! ... in PW starting_magnetization MUST be set for at least one atomic type -! ... (unless the magnetization is set in other ways) -! ... in CP starting_magnetization MUST REMAIN UNSET -! - starting_magnetization = sm_not_set - - IF (prog == 'PW') THEN - ! - starting_ns_eigenvalue = -1.0_DP - U_projection_type = 'atomic' - ! - END IF - lda_plus_U = .FALSE. - Hubbard_U = 0.0_DP - Hubbard_alpha = 0.0_DP - edir = 1 - emaxpos = 0.5_DP - eopreg = 0.1_DP - eamp = 0.0_DP - ! - ! ... postprocessing of DOS & phonons & el-ph - la2F = .FALSE. - ! - ! ... non collinear program variables - ! - lspinorb = .FALSE. - noncolin = .FALSE. - lambda = 1.0_DP - constrained_magnetization = 'none' - fixed_magnetization = 0.0_DP - B_field = 0.0_DP - angle1 = 0.0_DP - angle2 = 0.0_DP - report = 1 - ! - assume_isolated = 'none' - ! - spline_ps = .false. - ! - real_space = .false. - ! - ! ... DFT-D - ! - london = .false. - london_s6 = 0.75_DP - london_rcut = 200.00_DP - ! - ! - do_efield = .false. - ampfield = 0.0_dp - ! - draw_pot = .false. !added:linh draw vsic potentials - sortwfc_spread = .false. - pot_number = 1 !added:linh draw vsic potentials - ! - odd_nkscalfact = .false. !added:linh orbital dependent alpha - odd_nkscalfact_empty = .false. !added:linh orbital dependent alpha - restart_odd_nkscalfact = .false. !added:linh orbital dependent alpha - wo_odd_in_empty_run = .false. - aux_empty_nbnd = 0 - restart_from_wannier_cp = .false. - which_file_wannier = " " - wannier_empty_only = .false. - print_evc0_occ_empty = .false. ! added:linh to save empty wfc. - print_wfc_anion = .false. ! added:linh to constructe anion output - index_empty_to_save = 1 ! added:linh to constructe anion output - ! - do_orbdep = .false. - do_wf_cmplx = .false.!added:giovanni - ! -! DCC - do_ee = .false. ! main switch of EE (electrostatic embedding) - do_spinsym = .false. ! whether to apply spin up-down symmmetry - ! - f_cutoff = 0.01_DP - fixed_state = .false. - fixed_band = 1 - restart_from_wannier_pwscf = .false. - ! - impose_bloch_symm = .false. - read_centers = .false. - mp1 = 1 - mp2 = 1 - mp3 = 1 - offset_centers_occ = .false. - offset_centers_emp = .false. - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Variables initialization for Namelist NKSIC - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE nksic_defaults(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - ! -!$$ - esic_conv_thr = 1.E-5_DP -!$$ - do_nk = .false. ! main switch of NK (non-Koopmans, fref) - do_pz = .false. ! main switch of PZ SIC - do_nki = .false. ! main switch of NKI (non-Koopmans, integral ref) - do_nkpz = .false. ! main switch of NK (non-Koopmans) on top of PZ - do_nkipz = .false. ! main switch of NK (non-Koopmans) on top of PZ -!$$ - do_innerloop = .false. ! main switch of inner loop minimization - do_innerloop_empty = .false. ! main switch of inner loop minimization - l_comp_cmplxfctn_index = .false. ! compute the complexification index - do_innerloop_cg = .false. ! main switch of cg inner loop minimization - innerloop_dd_nstep = 50 ! number of outer loop damped dynamics steps between each inner loop minimization - innerloop_cg_nsd = 20 ! number of initial steepest-descent steps in cg inner loop minimization - innerloop_cg_nreset = 10 ! number of cg steps after which the search direction is set to the steepest-descent direction in inner loop minimization - innerloop_nmax = 10000 ! maximum number of inner loop steps - innerloop_cg_ratio = 1.d-3 - innerloop_init_n = innerloop_nmax - innerloop_until = -1 - innerloop_atleast = 0 -!$$ - nkscalfact = 1.0_DP ! NK coeffcient - hfscalfact = 1.0_DP ! HF coefficient - nknmax = -1 ! if <> -1, index of the last orbital on which NK is applied - do_hf = .false. ! main switch for HF calculations - do_wxd = .true. ! include cross-terms in NK potential - do_wref = .true. ! include reference variational terms - do_pz_renorm = .false. - do_bare_eigs = .false. - kfact = 0.d0 - fref = 0.5_DP - rhobarfact = 1.0_DP - vanishing_rho_w = 1.0e-12_DP - which_orbdep = " " - ! - iprint_spreads = -1 - iprint_manifold_overlap = -1 - hartree_only_sic = .false. - ! - finite_field_introduced = .FALSE. - finite_field_for_empty_state = .FALSE. - ! - RETURN - - END SUBROUTINE -! DCC - !=----------------------------------------------------------------------=! - ! - ! Variables initialization for Namelist EE - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE ee_defaults(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - ! - ! - ncompx = 1 - ncompy = 1 - ncompz = 1 - mr1 = 0 - mr2 = 0 - mr3 = 0 - ecutcoarse = 100.D0 - errtol = 1.d-22 - nlev = 2 - itmax = 1000 - whichbc = 0 -! centercompx = 0.D0 -! centercompy = 0.D0 -! centercompz = 0.D0 -! spreadcomp = -9999.D0 - mixing_charge_compensation = 1.0D0 - n_charge_compensation = 5 - comp_thr = 1.D-4 -! multipole = 'dipole' - which_compensation = 'none' - tcc_odd = .true. -! poisson_maxiter = 5000 -! poisson_thr = 1.D-6 -! comp_thr = 1.D-2 -! ebc_thr = 1.D-2 -! rhoionmax = 1.D0 -! smoothspr = 0.25D0 -! deltapot = 5.D-1 - nlev = 2 -! which_smoothing = 'sphere' - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Variables initialization for Namelist ELECTRONS - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE electrons_defaults(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - ! - ! - emass = 400.0_DP - emass_cutoff = 2.5_DP - orthogonalization = 'ortho' - ortho_eps = 1.E-8_DP - ortho_max = 20 - ortho_para = 0 - electron_maxstep = 100 - ! - ! ... ( 'sd' | 'cg' | 'damp' | 'verlet' | 'none' | 'diis' ) - ! - electron_dynamics = 'none' - electron_damping = 0.1_DP - ! - ! ... ( 'zero' | 'default' ) - ! - electron_velocities = 'default' - ! - ! ... ( 'nose' | 'not_controlled' | 'rescaling') - ! - electron_temperature = 'not_controlled' - ekincw = 0.001_DP - fnosee = 1.0_DP - ampre = 0.0_DP - grease = 1.0_DP - IF (prog == 'PW') THEN - ! - startingwfc = 'atomic' - startingpot = 'atomic' - ! - ELSE - ! - startingwfc = 'random' - startingpot = ' ' - ! - END IF - conv_thr = 1.E-6_DP - empty_states_maxstep = 100 - empty_states_ethr = 0.0_DP - diis_size = 4 - diis_nreset = 3 - diis_hcut = 1.0_DP - diis_wthr = 0.0_DP - diis_delt = 0.0_DP - diis_maxstep = 100 - diis_rot = .FALSE. - diis_fthr = 0.0_DP - diis_temp = 0.0_DP - diis_achmix = 0.0_DP - diis_g0chmix = 0.0_DP - diis_g1chmix = 0.0_DP - diis_nchmix = 3 - diis_nrot = 3 - diis_rothr = 0.0_DP - diis_ethr = 0.0_DP - diis_chguess = .FALSE. - mixing_mode = 'plain' - mixing_fixed_ns = 0 - mixing_beta = 0.7_DP - mixing_ndim = 8 - diagonalization = 'david' - diago_thr_init = 0.0_DP - diago_cg_maxiter = 20 - diago_david_ndim = 4 - diago_diis_ndim = 3 - diago_full_acc = .FALSE. - ! - sic = 'none' - sic_epsilon = 0.0_DP - sic_alpha = 0.0_DP - force_pairing = .false. - ! - fermi_energy = 0.0_DP - n_inner = 2 - niter_cold_restart = 1 - lambda_cold = 0.03_DP - rotation_dynamics = "line-minimization" - occupation_dynamics = "line-minimization" - rotmass = 0.0_DP - occmass = 0.0_DP - rotation_damping = 0.0_DP - occupation_damping = 0.0_DP - ! - tcg = .FALSE. - maxiter = 100 - passop = 0.3_DP - niter_cg_restart = 20 - etresh = 1.E-6_DP - ! - epol = 3 - efield = 0.0_DP - epol2 = 3 - efield2 = 0.0_DP - efield_cart(1) = 0.d0 - efield_cart(2) = 0.d0 - efield_cart(3) = 0.d0 - ! - occupation_constraints = .false. - ! - do_outerloop = .true. - do_outerloop_empty = .true. - ! - reortho = .false. - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Variables initialization for Namelist WANNIER_AC - ! - !---------------------------------------------------------------------- - SUBROUTINE wannier_ac_defaults(prog) - !---------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - ! - ! - plot_wannier = .FALSE. - use_energy_int = .FALSE. - print_wannier_coeff = .FALSE. - nwan = 0 - constrain_pot = 0.d0 - plot_wan_num = 0 - plot_wan_spin = 1 - ! - RETURN - ! - END SUBROUTINE - - !=----------------------------------------------------------------------=! - ! - ! Variables initialization for Namelist IONS - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE ions_defaults(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - ! - ! - ! ... ( 'full' | 'coarse-grained' ) - ! - phase_space = 'full' - ! - ! ... ( 'sd' | 'cg' | 'damp' | 'verlet' | 'none' | 'bfgs' | 'beeman' ) - ! - ion_dynamics = 'none' - ion_radius = 0.5_DP - ion_damping = 0.1_DP - ! - ! ... ( 'default' | 'from_input' ) - ! - ion_positions = 'default' - ! - ! ... ( 'zero' | 'default' | 'from_input' ) - ! - ion_velocities = 'default' - ! - ! ... ( 'nose' | 'not_controlled' | 'rescaling' | 'berendsen' | - ! 'andersen' | 'langevin' ) - ! - ion_temperature = 'not_controlled' - ! - tempw = 300.0_DP - fnosep = -1.0_DP - fnosep(1) = 1.0_DP - nhpcl = 0 - nhptyp = 0 - ndega = 0 - tranp = .FALSE. - amprp = 0.0_DP - greasp = 1.0_DP - tolp = 100.0_DP - ion_nstepe = 1 - ion_maxstep = 100 - delta_t = 1.0_DP - nraise = 1 - ! - refold_pos = .FALSE. - remove_rigid_rot = .FALSE. - ! - upscale = 10.0_DP - pot_extrapolation = 'atomic' - wfc_extrapolation = 'none' - ! - ! - ! ... defaults for "path" optimisations variables - ! - num_of_images = 0 - first_last_opt = .FALSE. - use_masses = .FALSE. - use_freezing = .FALSE. - opt_scheme = 'quick-min' - temp_req = 0.0_DP - ds = 1.0_DP - path_thr = 0.05_DP - CI_scheme = 'no-CI' - k_max = 0.1_DP - k_min = 0.1_DP - fixed_tan = .FALSE. - ! - ! ... BFGS defaults - ! - bfgs_ndim = 1 - trust_radius_max = 0.8_DP ! bohr - trust_radius_min = 1.E-4_DP ! bohr - trust_radius_ini = 0.5_DP ! bohr - w_1 = 0.01_DP - w_2 = 0.50_DP - ! - sic_rloc = 0.0_DP - ! - ! ... meta-dynamics defaults - ! - fe_step = 0.4_DP - fe_nstep = 100 - sw_nstep = 10 - eq_nstep = 0 - g_amplitude = 0.005_DP - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Variables initialization for Namelist CELL - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE cell_defaults(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - ! - ! - cell_parameters = 'default' - ! - ! ... ( 'sd' | 'pr' | 'none' | 'w' | 'damp-pr' | 'damp-w' | 'bfgs' ) - ! - cell_dynamics = 'none' - ! - ! ... ( 'zero' | 'default' ) - ! - cell_velocities = 'default' - press = 0.0_DP - wmass = 0.0_DP - ! - ! ... ( 'nose' | 'not_controlled' | 'rescaling' ) - ! - cell_temperature = 'not_controlled' - temph = 0.0_DP - fnoseh = 1.0_DP - greash = 1.0_DP - ! - ! ... ('all'* | 'volume' | 'x' | 'y' | 'z' | 'xy' | 'xz' | 'yz' | 'xyz' ) - ! - cell_dofree = 'all' - cell_factor = 0.0_DP - cell_nstepe = 1 - cell_damping = 0.0_DP - press_conv_thr = 0.5_DP - ! - RETURN - ! - END SUBROUTINE - ! - ! - !=----------------------------------------------------------------------=! - ! - ! Variables initialization for Namelist PRESS_AI - ! - !=----------------------------------------------------------------------=! - ! - !---------------------------------------------------------------------- - SUBROUTINE press_ai_defaults(prog) - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - ! - abivol = .false. - abisur = .false. - pvar = .false. - fill_vac = .false. - cntr = .false. - scale_at = .false. - t_gauss = .false. - jellium = .false. - - P_ext = 0.0_DP - P_in = 0.0_DP - P_fin = 0.0_DP - Surf_t = 0.0_DP - rho_thr = 0.0_DP - dthr = 0.0_DP - step_rad = 0.0_DP - delta_eps = 0.0_DP - delta_sigma = 0.0_DP - R_j = 0.0_DP - h_j = 0.0_DP - - n_cntr = 0 - axis = 3 - ! - RETURN - ! - END SUBROUTINE - ! - - !=----------------------------------------------------------------------=! - ! - ! Variables initialization for Namelist PHONON - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE phonon_defaults(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - ! - ! - modenum = 0 - xqq = 0.0_DP - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Variables initialization for Namelist WANNIER - ! - !----------------------------------------------------------------------- - SUBROUTINE wannier_defaults(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - ! - ! - wf_efield = .FALSE. - wf_switch = .FALSE. - ! - sw_len = 1 - ! - efx0 = 0.0_DP - efy0 = 0.0_DP - efz0 = 0.0_DP - efx1 = 0.0_DP - efy1 = 0.0_DP - efz1 = 0.0_DP - ! - wfsd = 1 - ! - wfdt = 5.0_DP - maxwfdt = 0.30_DP - wf_q = 1500.0_DP - wf_friction = 0.3_DP - ! - nit = 10 - nsd = 10 - nsteps = 20 - ! - tolw = 1.E-8_DP - ! - adapt = .TRUE. - ! - calwf = 3 - nwf = 0 - wffort = 40 - ! - writev = .FALSE. - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Broadcast variables values for Namelist CONTROL - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE control_bcast() - !----------------------------------------------------------------------- - ! - USE io_global, ONLY: ionode_id - USE mp, ONLY: mp_bcast - ! - IMPLICIT NONE - ! - CALL mp_bcast(title, ionode_id) - CALL mp_bcast(calculation, ionode_id) - CALL mp_bcast(verbosity, ionode_id) - CALL mp_bcast(restart_mode, ionode_id) - CALL mp_bcast(nstep, ionode_id) - CALL mp_bcast(iprint, ionode_id) - CALL mp_bcast(isave, ionode_id) - CALL mp_bcast(tstress, ionode_id) - CALL mp_bcast(tprnfor, ionode_id) - CALL mp_bcast(tabps, ionode_id) - CALL mp_bcast(dt, ionode_id) - CALL mp_bcast(ndr, ionode_id) - CALL mp_bcast(ndw, ionode_id) - CALL mp_bcast(outdir, ionode_id) - CALL mp_bcast(wfcdir, ionode_id) - CALL mp_bcast(prefix, ionode_id) - CALL mp_bcast(max_seconds, ionode_id) - CALL mp_bcast(ekin_conv_thr, ionode_id) - CALL mp_bcast(etot_conv_thr, ionode_id) - CALL mp_bcast(forc_conv_thr, ionode_id) - CALL mp_bcast(pseudo_dir, ionode_id) - CALL mp_bcast(refg, ionode_id) - CALL mp_bcast(disk_io, ionode_id) - CALL mp_bcast(evc_restart, ionode_id) - CALL mp_bcast(tefield, ionode_id) - CALL mp_bcast(tefield2, ionode_id) - CALL mp_bcast(dipfield, ionode_id) - CALL mp_bcast(lberry, ionode_id) - CALL mp_bcast(gdir, ionode_id) - CALL mp_bcast(nppstr, ionode_id) - CALL mp_bcast(lkpoint_dir, ionode_id) - CALL mp_bcast(wf_collect, ionode_id) - CALL mp_bcast(printwfc, ionode_id) - CALL mp_bcast(lelfield, ionode_id) - CALL mp_bcast(nberrycyc, ionode_id) - CALL mp_bcast(saverho, ionode_id) - CALL mp_bcast(write_hr, ionode_id) - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Broadcast variables values for Namelist SYSTEM - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE system_bcast() - !----------------------------------------------------------------------- - ! - USE io_global, ONLY: ionode_id - USE mp, ONLY: mp_bcast - ! - IMPLICIT NONE - ! - CALL mp_bcast(ibrav, ionode_id) - CALL mp_bcast(celldm, ionode_id) - CALL mp_bcast(a, ionode_id) - CALL mp_bcast(b, ionode_id) - CALL mp_bcast(c, ionode_id) - CALL mp_bcast(cosab, ionode_id) - CALL mp_bcast(cosac, ionode_id) - CALL mp_bcast(cosbc, ionode_id) - CALL mp_bcast(nat, ionode_id) - CALL mp_bcast(ntyp, ionode_id) - CALL mp_bcast(nbnd, ionode_id) - CALL mp_bcast(nelec, ionode_id) - CALL mp_bcast(tot_charge, ionode_id) - CALL mp_bcast(tot_magnetization, ionode_id) - CALL mp_bcast(multiplicity, ionode_id) - CALL mp_bcast(ecutwfc, ionode_id) - CALL mp_bcast(ecutrho, ionode_id) - CALL mp_bcast(nr1, ionode_id) - CALL mp_bcast(nr2, ionode_id) - CALL mp_bcast(nr3, ionode_id) - CALL mp_bcast(nr1s, ionode_id) - CALL mp_bcast(nr2s, ionode_id) - CALL mp_bcast(nr3s, ionode_id) - CALL mp_bcast(nr1b, ionode_id) - CALL mp_bcast(nr2b, ionode_id) - CALL mp_bcast(nr3b, ionode_id) - CALL mp_bcast(occupations, ionode_id) - CALL mp_bcast(smearing, ionode_id) - CALL mp_bcast(degauss, ionode_id) - CALL mp_bcast(nelup, ionode_id) - CALL mp_bcast(neldw, ionode_id) - CALL mp_bcast(nspin, ionode_id) - CALL mp_bcast(nosym, ionode_id) - CALL mp_bcast(nosym_evc, ionode_id) - CALL mp_bcast(noinv, ionode_id) - CALL mp_bcast(force_symmorphic, ionode_id) - CALL mp_bcast(ecfixed, ionode_id) - CALL mp_bcast(qcutz, ionode_id) - CALL mp_bcast(q2sigma, ionode_id) - CALL mp_bcast(input_dft, ionode_id) -#ifdef EXX - CALL mp_bcast(x_gamma_extrapolation, ionode_id) - CALL mp_bcast(nqx1, ionode_id) - CALL mp_bcast(nqx2, ionode_id) - CALL mp_bcast(nqx3, ionode_id) -#endif - CALL mp_bcast(starting_magnetization, ionode_id) - CALL mp_bcast(starting_ns_eigenvalue, ionode_id) - CALL mp_bcast(U_projection_type, ionode_id) - CALL mp_bcast(lda_plus_U, ionode_id) - CALL mp_bcast(Hubbard_U, ionode_id) - CALL mp_bcast(Hubbard_alpha, ionode_id) - CALL mp_bcast(edir, ionode_id) - CALL mp_bcast(emaxpos, ionode_id) - CALL mp_bcast(eopreg, ionode_id) - CALL mp_bcast(eamp, ionode_id) - CALL mp_bcast(la2F, ionode_id) - ! - ! ... non collinear broadcast - ! - CALL mp_bcast(lspinorb, ionode_id) - CALL mp_bcast(noncolin, ionode_id) - CALL mp_bcast(angle1, ionode_id) - CALL mp_bcast(angle2, ionode_id) - CALL mp_bcast(report, ionode_id) - CALL mp_bcast(constrained_magnetization, ionode_id) - CALL mp_bcast(B_field, ionode_id) - CALL mp_bcast(fixed_magnetization, ionode_id) - CALL mp_bcast(lambda, ionode_id) - ! - CALL mp_bcast(assume_isolated, ionode_id) - CALL mp_bcast(spline_ps, ionode_id) - ! - CALL mp_bcast(do_efield, ionode_id) - CALL mp_bcast(ampfield, ionode_id) - ! - CALL mp_bcast(london, ionode_id) - CALL mp_bcast(london_s6, ionode_id) - CALL mp_bcast(london_rcut, ionode_id) - ! - CALL mp_bcast(do_ee, ionode_id) - CALL mp_bcast(do_orbdep, ionode_id) - CALL mp_bcast(do_wf_cmplx, ionode_id) - CALL mp_bcast(do_spinsym, ionode_id) - ! - CALL mp_bcast(f_cutoff, ionode_id) - CALL mp_bcast(fixed_band, ionode_id) - CALL mp_bcast(fixed_state, ionode_id) - CALL mp_bcast(restart_from_wannier_pwscf, ionode_id) - ! - CALL mp_bcast(impose_bloch_symm, ionode_id) - CALL mp_bcast(read_centers, ionode_id) - CALL mp_bcast(mp1, ionode_id) - CALL mp_bcast(mp2, ionode_id) - CALL mp_bcast(mp3, ionode_id) - CALL mp_bcast(offset_centers_occ, ionode_id) - CALL mp_bcast(offset_centers_emp, ionode_id) - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Broadcast variables values for Namelist NKSIC - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE nksic_bcast() - !----------------------------------------------------------------------- - ! - USE io_global, ONLY: ionode_id - USE mp, ONLY: mp_bcast - ! -!$$ - CALL mp_bcast(esic_conv_thr, ionode_id) -!$$ - CALL mp_bcast(which_orbdep, ionode_id) - CALL mp_bcast(do_nk, ionode_id) - CALL mp_bcast(do_pz, ionode_id) - CALL mp_bcast(do_nki, ionode_id) - CALL mp_bcast(do_nkpz, ionode_id) - CALL mp_bcast(do_nkipz, ionode_id) -!$$ - CALL mp_bcast(do_innerloop, ionode_id) - CALL mp_bcast(do_innerloop_empty, ionode_id) - CALL mp_bcast(do_innerloop_cg, ionode_id) - CALL mp_bcast(innerloop_dd_nstep, ionode_id) - CALL mp_bcast(innerloop_cg_nsd, ionode_id) - CALL mp_bcast(innerloop_cg_nreset, ionode_id) - CALL mp_bcast(innerloop_nmax, ionode_id) - CALL mp_bcast(innerloop_init_n, ionode_id) - CALL mp_bcast(innerloop_atleast, ionode_id) - CALL mp_bcast(innerloop_cg_ratio, ionode_id) - CALL mp_bcast(innerloop_until, ionode_id) - CALL mp_bcast(draw_pot, ionode_id) - CALL mp_bcast(sortwfc_spread, ionode_id) - CALL mp_bcast(pot_number, ionode_id) - CALL mp_bcast(nknmax, ionode_id) - CALL mp_bcast(nkscalfact, ionode_id) - CALL mp_bcast(hfscalfact, ionode_id) - CALL mp_bcast(do_hf, ionode_id) - CALL mp_bcast(do_wref, ionode_id) - CALL mp_bcast(do_wxd, ionode_id) - CALL mp_bcast(vanishing_rho_w, ionode_id) - CALL mp_bcast(fref, ionode_id) - CALL mp_bcast(odd_nkscalfact, ionode_id) - CALL mp_bcast(odd_nkscalfact_empty, ionode_id) - CALL mp_bcast(restart_odd_nkscalfact, ionode_id) - CALL mp_bcast(wo_odd_in_empty_run, ionode_id) - CALL mp_bcast(aux_empty_nbnd, ionode_id) - CALL mp_bcast(restart_from_wannier_cp, ionode_id) - CALL mp_bcast(which_file_wannier, ionode_id) - CALL mp_bcast(wannier_empty_only, ionode_id) - CALL mp_bcast(print_evc0_occ_empty, ionode_id) - CALL mp_bcast(print_wfc_anion, ionode_id) - CALL mp_bcast(index_empty_to_save, ionode_id) - CALL mp_bcast(rhobarfact, ionode_id) - CALL mp_bcast(do_pz_renorm, ionode_id) - CALL mp_bcast(do_bare_eigs, ionode_id) - CALL mp_bcast(kfact, ionode_id) - ! - CALL mp_bcast(iprint_spreads, ionode_id) - CALL mp_bcast(iprint_manifold_overlap, ionode_id) - CALL mp_bcast(hartree_only_sic, ionode_id) - CALL mp_bcast(finite_field_introduced, ionode_id) - CALL mp_bcast(finite_field_for_empty_state, ionode_id) - ! - CALL mp_bcast(l_comp_cmplxfctn_index, ionode_id) - ! - RETURN - ! - END SUBROUTINE nksic_bcast - !=----------------------------------------------------------------------=! - ! - ! Broadcast variables values for Namelist EE - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE ee_bcast() - !----------------------------------------------------------------------- - ! - USE io_global, ONLY: ionode_id - USE mp, ONLY: mp_bcast - ! - IMPLICIT NONE - ! - CALL mp_bcast(ecutcoarse, ionode_id) - CALL mp_bcast(mixing_charge_compensation, ionode_id) - CALL mp_bcast(errtol, ionode_id) - CALL mp_bcast(comp_thr, ionode_id) - CALL mp_bcast(nlev, ionode_id) - CALL mp_bcast(itmax, ionode_id) - CALL mp_bcast(whichbc, ionode_id) - CALL mp_bcast(n_charge_compensation, ionode_id) - CALL mp_bcast(ncompx, ionode_id) - CALL mp_bcast(ncompy, ionode_id) - CALL mp_bcast(ncompz, ionode_id) - CALL mp_bcast(mr1, ionode_id) - CALL mp_bcast(mr2, ionode_id) - CALL mp_bcast(mr3, ionode_id) - CALL mp_bcast(which_compensation, ionode_id) - CALL mp_bcast(tcc_odd, ionode_id) - CALL mp_bcast(cellmin, ionode_id) - CALL mp_bcast(cellmax, ionode_id) - - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Broadcast variables values for Namelist ELECTRONS - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE electrons_bcast() - !----------------------------------------------------------------------- - ! - USE io_global, ONLY: ionode_id - USE mp, ONLY: mp_bcast - ! - IMPLICIT NONE - ! - CALL mp_bcast(emass, ionode_id) - CALL mp_bcast(emass_cutoff, ionode_id) - CALL mp_bcast(orthogonalization, ionode_id) - CALL mp_bcast(electron_maxstep, ionode_id) - CALL mp_bcast(ortho_eps, ionode_id) - CALL mp_bcast(ortho_max, ionode_id) - CALL mp_bcast(ortho_para, ionode_id) - CALL mp_bcast(electron_dynamics, ionode_id) - CALL mp_bcast(electron_damping, ionode_id) - CALL mp_bcast(electron_velocities, ionode_id) - CALL mp_bcast(electron_temperature, ionode_id) - CALL mp_bcast(conv_thr, ionode_id) - CALL mp_bcast(ekincw, ionode_id) - CALL mp_bcast(fnosee, ionode_id) - CALL mp_bcast(startingwfc, ionode_id) - CALL mp_bcast(ampre, ionode_id) - CALL mp_bcast(grease, ionode_id) - CALL mp_bcast(startingpot, ionode_id) - CALL mp_bcast(empty_states_maxstep, ionode_id) - CALL mp_bcast(empty_states_ethr, ionode_id) - CALL mp_bcast(diis_size, ionode_id) - CALL mp_bcast(diis_nreset, ionode_id) - CALL mp_bcast(diis_hcut, ionode_id) - CALL mp_bcast(diis_wthr, ionode_id) - CALL mp_bcast(diis_delt, ionode_id) - CALL mp_bcast(diis_maxstep, ionode_id) - CALL mp_bcast(diis_rot, ionode_id) - CALL mp_bcast(diis_fthr, ionode_id) - CALL mp_bcast(diis_temp, ionode_id) - CALL mp_bcast(diis_achmix, ionode_id) - CALL mp_bcast(diis_g0chmix, ionode_id) - CALL mp_bcast(diis_g1chmix, ionode_id) - CALL mp_bcast(diis_nchmix, ionode_id) - CALL mp_bcast(diis_nrot, ionode_id) - CALL mp_bcast(diis_rothr, ionode_id) - CALL mp_bcast(diis_ethr, ionode_id) - CALL mp_bcast(diis_chguess, ionode_id) - CALL mp_bcast(mixing_fixed_ns, ionode_id) - CALL mp_bcast(mixing_mode, ionode_id) - CALL mp_bcast(mixing_beta, ionode_id) - CALL mp_bcast(mixing_ndim, ionode_id) - CALL mp_bcast(tqr, ionode_id) - CALL mp_bcast(diagonalization, ionode_id) - CALL mp_bcast(diago_thr_init, ionode_id) - CALL mp_bcast(diago_cg_maxiter, ionode_id) - CALL mp_bcast(diago_david_ndim, ionode_id) - CALL mp_bcast(diago_diis_ndim, ionode_id) - CALL mp_bcast(diago_full_acc, ionode_id) - CALL mp_bcast(sic, ionode_id) - CALL mp_bcast(sic_epsilon, ionode_id) - CALL mp_bcast(sic_alpha, ionode_id) - CALL mp_bcast(force_pairing, ionode_id) - CALL mp_bcast(do_outerloop, ionode_id) - CALL mp_bcast(do_outerloop_empty, ionode_id) - CALL mp_bcast(reortho, ionode_id) - ! - ! ... ensemble-DFT - ! - CALL mp_bcast(fermi_energy, ionode_id) - CALL mp_bcast(n_inner, ionode_id) - CALL mp_bcast(niter_cold_restart, ionode_id) - CALL mp_bcast(lambda_cold, ionode_id) - CALL mp_bcast(rotation_dynamics, ionode_id) - CALL mp_bcast(occupation_dynamics, ionode_id) - CALL mp_bcast(rotmass, ionode_id) - CALL mp_bcast(occmass, ionode_id) - CALL mp_bcast(rotation_damping, ionode_id) - CALL mp_bcast(occupation_damping, ionode_id) - ! - ! ... conjugate gradient - ! - CALL mp_bcast(tcg, ionode_id) - CALL mp_bcast(maxiter, ionode_id) - CALL mp_bcast(etresh, ionode_id) - CALL mp_bcast(passop, ionode_id) - CALL mp_bcast(niter_cg_restart, ionode_id) - ! - ! ... electric field - ! - CALL mp_bcast(epol, ionode_id) - CALL mp_bcast(efield, ionode_id) - ! - CALL mp_bcast(epol2, ionode_id) - CALL mp_bcast(efield2, ionode_id) - CALL mp_bcast(efield_cart, ionode_id) - ! - ! ... occupation constraints ... - ! - CALL mp_bcast(occupation_constraints, ionode_id) - ! - ! ... real space ... - CALL mp_bcast(real_space, ionode_id) - RETURN - ! - END SUBROUTINE - ! - ! - !=----------------------------------------------------------------------=! - ! - ! Broadcast variables values for Namelist IONS - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE ions_bcast() - !----------------------------------------------------------------------- - ! - USE io_global, ONLY: ionode_id - USE mp, ONLY: mp_bcast - ! - IMPLICIT NONE - ! - CALL mp_bcast(phase_space, ionode_id) - CALL mp_bcast(ion_dynamics, ionode_id) - CALL mp_bcast(ion_radius, ionode_id) - CALL mp_bcast(ion_damping, ionode_id) - CALL mp_bcast(ion_positions, ionode_id) - CALL mp_bcast(ion_velocities, ionode_id) - CALL mp_bcast(ion_temperature, ionode_id) - CALL mp_bcast(tempw, ionode_id) - CALL mp_bcast(fnosep, ionode_id) - CALL mp_bcast(nhgrp, ionode_id) - CALL mp_bcast(fnhscl, ionode_id) - CALL mp_bcast(nhpcl, ionode_id) - CALL mp_bcast(nhptyp, ionode_id) - CALL mp_bcast(ndega, ionode_id) - CALL mp_bcast(tranp, ionode_id) - CALL mp_bcast(amprp, ionode_id) - CALL mp_bcast(greasp, ionode_id) - CALL mp_bcast(tolp, ionode_id) - CALL mp_bcast(ion_nstepe, ionode_id) - CALL mp_bcast(ion_maxstep, ionode_id) - CALL mp_bcast(delta_t, ionode_id) - CALL mp_bcast(nraise, ionode_id) - CALL mp_bcast(refold_pos, ionode_id) - CALL mp_bcast(remove_rigid_rot, ionode_id) - CALL mp_bcast(upscale, ionode_id) - CALL mp_bcast(pot_extrapolation, ionode_id) - CALL mp_bcast(wfc_extrapolation, ionode_id) - ! - ! ... "path" variables broadcast - ! - CALL mp_bcast(num_of_images, ionode_id) - CALL mp_bcast(first_last_opt, ionode_id) - CALL mp_bcast(use_masses, ionode_id) - CALL mp_bcast(use_freezing, ionode_id) - CALL mp_bcast(fixed_tan, ionode_id) - CALL mp_bcast(CI_scheme, ionode_id) - CALL mp_bcast(opt_scheme, ionode_id) - CALL mp_bcast(temp_req, ionode_id) - CALL mp_bcast(ds, ionode_id) - CALL mp_bcast(k_max, ionode_id) - CALL mp_bcast(k_min, ionode_id) - CALL mp_bcast(path_thr, ionode_id) - ! - ! ... BFGS - ! - CALL mp_bcast(bfgs_ndim, ionode_id) - CALL mp_bcast(trust_radius_max, ionode_id) - CALL mp_bcast(trust_radius_min, ionode_id) - CALL mp_bcast(trust_radius_ini, ionode_id) - CALL mp_bcast(w_1, ionode_id) - CALL mp_bcast(w_2, ionode_id) - ! - CALL mp_bcast(sic_rloc, ionode_id) - ! - CALL mp_bcast(fe_step, ionode_id) - CALL mp_bcast(fe_nstep, ionode_id) - CALL mp_bcast(sw_nstep, ionode_id) - CALL mp_bcast(eq_nstep, ionode_id) - CALL mp_bcast(g_amplitude, ionode_id) - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Broadcast variables values for Namelist CELL - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE cell_bcast() - !----------------------------------------------------------------------- - ! - USE io_global, ONLY: ionode_id - USE mp, ONLY: mp_bcast - ! - IMPLICIT NONE - ! - CALL mp_bcast(cell_parameters, ionode_id) - CALL mp_bcast(cell_dynamics, ionode_id) - CALL mp_bcast(cell_velocities, ionode_id) - CALL mp_bcast(cell_dofree, ionode_id) - CALL mp_bcast(press, ionode_id) - CALL mp_bcast(wmass, ionode_id) - CALL mp_bcast(cell_temperature, ionode_id) - CALL mp_bcast(temph, ionode_id) - CALL mp_bcast(fnoseh, ionode_id) - CALL mp_bcast(greash, ionode_id) - CALL mp_bcast(cell_factor, ionode_id) - CALL mp_bcast(cell_nstepe, ionode_id) - CALL mp_bcast(cell_damping, ionode_id) - CALL mp_bcast(press_conv_thr, ionode_id) - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Broadcast variables values for Namelist PRESS_AI - ! - !=----------------------------------------------------------------------=! - ! - !---------------------------------------------------------------------- - SUBROUTINE press_ai_bcast() - !---------------------------------------------------------------------- - ! - USE io_global, ONLY: ionode_id - USE mp, ONLY: mp_bcast - ! - IMPLICIT NONE - ! - ! - CALL mp_bcast(abivol, ionode_id) - CALL mp_bcast(abisur, ionode_id) - CALL mp_bcast(t_gauss, ionode_id) - CALL mp_bcast(cntr, ionode_id) - CALL mp_bcast(P_ext, ionode_id) - CALL mp_bcast(Surf_t, ionode_id) - CALL mp_bcast(pvar, ionode_id) - CALL mp_bcast(P_in, ionode_id) - CALL mp_bcast(P_fin, ionode_id) - CALL mp_bcast(delta_eps, ionode_id) - CALL mp_bcast(delta_sigma, ionode_id) - CALL mp_bcast(fill_vac, ionode_id) - CALL mp_bcast(scale_at, ionode_id) - CALL mp_bcast(n_cntr, ionode_id) - CALL mp_bcast(axis, ionode_id) - CALL mp_bcast(rho_thr, ionode_id) - CALL mp_bcast(dthr, ionode_id) - CALL mp_bcast(step_rad, ionode_id) - CALL mp_bcast(jellium, ionode_id) - CALL mp_bcast(R_j, ionode_id) - CALL mp_bcast(h_j, ionode_id) - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------------=! - ! - ! Broadcast variables values for Namelist PHONON - ! - !=----------------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE phonon_bcast() - !----------------------------------------------------------------------- - ! - USE io_global, ONLY: ionode_id - USE mp, ONLY: mp_bcast - ! - IMPLICIT NONE - ! - CALL mp_bcast(modenum, ionode_id) - CALL mp_bcast(xqq, ionode_id) - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------------=! - ! - ! Broadcast variables values for Namelist WANNIER - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE wannier_bcast() - !----------------------------------------------------------------------- - ! - USE io_global, ONLY: ionode_id - USE mp, ONLY: mp_bcast - ! - IMPLICIT NONE - ! - CALL mp_bcast(wf_efield, ionode_id) - CALL mp_bcast(wf_switch, ionode_id) - CALL mp_bcast(sw_len, ionode_id) - CALL mp_bcast(efx0, ionode_id) - CALL mp_bcast(efy0, ionode_id) - CALL mp_bcast(efz0, ionode_id) - CALL mp_bcast(efx1, ionode_id) - CALL mp_bcast(efy1, ionode_id) - CALL mp_bcast(efz1, ionode_id) - CALL mp_bcast(wfsd, ionode_id) - CALL mp_bcast(wfdt, ionode_id) - CALL mp_bcast(maxwfdt, ionode_id) - CALL mp_bcast(wf_q, ionode_id) - CALL mp_bcast(wf_friction, ionode_id) - CALL mp_bcast(nit, ionode_id) - CALL mp_bcast(nsd, ionode_id) - CALL mp_bcast(nsteps, ionode_id) - CALL mp_bcast(tolw, ionode_id) - CALL mp_bcast(adapt, ionode_id) - CALL mp_bcast(calwf, ionode_id) - CALL mp_bcast(nwf, ionode_id) - CALL mp_bcast(wffort, ionode_id) - CALL mp_bcast(writev, ionode_id) - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------------=! - ! - ! Broadcast variables values for Namelist WANNIER_NEW - ! - !=----------------------------------------------------------------------------=! - ! - !---------------------------------------------------------------------- - SUBROUTINE wannier_ac_bcast() - !---------------------------------------------------------------------- - ! - USE io_global, ONLY: ionode_id - USE mp, ONLY: mp_bcast - ! - IMPLICIT NONE - ! - ! - CALL mp_bcast(plot_wannier, ionode_id) - CALL mp_bcast(use_energy_int, ionode_id) - CALL mp_bcast(print_wannier_coeff, ionode_id) - CALL mp_bcast(nwan, ionode_id) - CALL mp_bcast(plot_wan_num, ionode_id) - CALL mp_bcast(plot_wan_spin, ionode_id) -! CALL mp_bcast( wan_data,ionode_id ) - CALL mp_bcast(constrain_pot, ionode_id) - RETURN - ! - END SUBROUTINE - - ! - !=----------------------------------------------------------------------=! - ! - ! Check input values for Namelist CONTROL - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE control_checkin(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - CHARACTER(LEN=20) :: sub_name = ' control_checkin ' - INTEGER :: i - LOGICAL :: allowed = .FALSE. - ! - ! - DO i = 1, SIZE(calculation_allowed) - IF (TRIM(calculation) == calculation_allowed(i)) allowed = .TRUE. - END DO - IF (.NOT. allowed) & - CALL errore(sub_name, ' calculation '''// & - & TRIM(calculation)//''' not allowed ', 1) - IF (prog == 'CP') THEN - IF (calculation == 'phonon') & - CALL errore(sub_name, ' calculation '//calculation// & - & ' not implemented ', 1) - END IF - IF (ndr < 50) & - CALL errore(sub_name, ' ndr out of range ', 1) - IF (ndw > 0 .AND. ndw < 50) & - CALL errore(sub_name, ' ndw out of range ', 1) - IF (nstep < 0) & - CALL errore(sub_name, ' nstep out of range ', 1) - IF (iprint < 1) & - CALL errore(sub_name, ' iprint out of range ', 1) - - IF (prog == 'PW') THEN - IF (isave > 0) & - CALL infomsg(sub_name, ' isave not used in PW ') - ELSE - IF (isave < 1) & - CALL errore(sub_name, ' isave out of range ', 1) - END IF - - IF (dt < 0.0_DP) & - CALL errore(sub_name, ' dt out of range ', 1) - IF (max_seconds < 0.0_DP) & - CALL errore(sub_name, ' max_seconds out of range ', 1) - - IF (ekin_conv_thr < 0.0_DP) THEN - IF (prog == 'PW') THEN - CALL infomsg(sub_name, ' ekin_conv_thr not used in PW ') - ELSE - CALL errore(sub_name, ' ekin_conv_thr out of range ', 1) - END IF - END IF - - IF (etot_conv_thr < 0.0_DP) & - CALL errore(sub_name, ' etot_conv_thr out of range ', 1) - IF (forc_conv_thr < 0.0_DP) & - CALL errore(sub_name, ' forc_conv_thr out of range ', 1) - IF (prog == 'CP') THEN - IF (dipfield) & - CALL infomsg(sub_name, ' dipfield not yet implemented ') - IF (lberry) & - CALL infomsg(sub_name, ' lberry not implemented yet ') - IF (gdir /= 0) & - CALL infomsg(sub_name, ' gdir not used ') - IF (nppstr /= 0) & - CALL infomsg(sub_name, ' nppstr not used ') - END IF - ! - IF (prog == 'PW' .AND. TRIM(restart_mode) == 'reset_counters') THEN - CALL infomsg(sub_name, ' restart_mode == reset_counters'// & - & ' not implemented in PW ') - END IF - ! - IF (refg < 0) & - CALL errore(sub_name, ' wrong table interval refg ', 1) - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Check input values for Namelist SYSTEM - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE system_checkin(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - CHARACTER(LEN=20) :: sub_name = ' system_checkin ' - INTEGER :: i - LOGICAL :: allowed = .FALSE. - ! - ! - IF (ibrav < 0 .OR. ibrav > 14) & - CALL errore(sub_name, ' ibrav out of range ', MAX(1, ibrav)) - ! - IF ((ibrav /= 0) .AND. (celldm(1) == 0.0_DP) .AND. (a == 0.0_DP)) & - CALL errore(' iosys ', & - & ' invalid lattice parameters ( celldm or a )', 1) - ! - IF (nat < 0) & - CALL errore(sub_name, ' nat less than zero ', MAX(nat, 1)) - ! - IF (ntyp < 0) & - CALL errore(sub_name, ' ntyp less than zero ', MAX(ntyp, 1)) - IF (ntyp < 0 .OR. ntyp > nsx) & - CALL errore(sub_name, & - & ' ntyp too large, increase NSX ', MAX(ntyp, 1)) - ! - IF (nspin < 1 .OR. nspin > 4 .OR. nspin == 3) & - CALL errore(sub_name, ' nspin out of range ', MAX(nspin, 1)) - ! - IF (ecutwfc <= 0.0_DP) & - CALL errore(sub_name, ' ecutwfc out of range ', 1) - IF (ecutrho < 0.0_DP) & - CALL errore(sub_name, ' ecutrho out of range ', 1) - ! - IF (prog == 'CP') THEN - IF (degauss /= 0.0_DP) & - CALL infomsg(sub_name, ' degauss is not used in CP ') - END IF - ! - IF (nelup < 0.0_DP .OR. nelup > nelec) & - CALL errore(sub_name, ' nelup out of range ', 1) - IF (neldw < 0.0_DP .OR. neldw > nelec) & - CALL errore(sub_name, ' neldw out of range ', 1) - IF (ecfixed < 0.0_DP) & - CALL errore(sub_name, ' ecfixed out of range ', 1) - IF (qcutz < 0.0_DP) & - CALL errore(sub_name, ' qcutz out of range ', 1) - IF (q2sigma < 0.0_DP) & - CALL errore(sub_name, ' q2sigma out of range ', 1) - IF (prog == 'CP') THEN - IF (ANY(starting_magnetization /= SM_NOT_SET)) & - CALL infomsg(sub_name,& - & ' starting_magnetization is not used in CP ') - IF (lda_plus_U) & - CALL infomsg(sub_name, ' lda_plus_U is not used in CP ') - IF (la2F) & - CALL infomsg(sub_name, ' la2F is not used in CP ') - IF (ANY(Hubbard_U /= 0.0_DP)) & - CALL infomsg(sub_name, ' Hubbard_U is not used in CP ') - IF (ANY(Hubbard_alpha /= 0.0_DP)) & - CALL infomsg(sub_name, ' Hubbard_alpha is not used in CP ') - IF (nosym) & - CALL infomsg(sub_name, ' nosym not implemented in CP ') - IF (nosym_evc) & - CALL infomsg(sub_name, ' nosym_evc not implemented in CP ') - IF (noinv) & - CALL infomsg(sub_name, ' noinv not implemented in CP ') - END IF - ! - ! ... non collinear check - ! - IF (noncolin) THEN - ! - IF (diagonalization == 'cg') & - CALL errore(sub_name, ' cg not allowed with noncolin ', 1) - ! - END IF - ! - ! ... control on SIC variables - ! - IF (sic /= 'none') THEN - ! - IF (sic_epsilon > 1.0_DP) & - CALL errore(sub_name, & - & ' invalid sic_epsilon, greater than 1.', 1) - IF (sic_epsilon < 0.0_DP) & - CALL errore(sub_name, & - & ' invalid sic_epsilon, less than 0 ', 1) - IF (sic_alpha > 1.0_DP) & - CALL errore(sub_name, & - & ' invalid sic_alpha, greater than 1.', 1) - IF (sic_alpha < 0.0_DP) & - CALL errore(sub_name, & - & ' invalid sic_alpha, less than 0 ', 1) - ! - IF (.NOT. force_pairing) & - CALL errore(sub_name, & - & ' invalid force_pairing with sic activated', 1) - IF (nspin /= 2) & - CALL errore(sub_name, & - & ' invalid nspin with sic activated', 1) - IF ((nelup == 0) .AND. (neldw == 0)) & - CALL errore(sub_name, & - & ' invalid nelup and neldwn spin with sic activated', 1) - IF (nelup /= (neldw + 1)) & - CALL errore(sub_name, & - & ' invalid nelup /= (neldwn +1) spin with sic activated', 1) - ! - END IF - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Check input values for Namelist NKSIC - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE nksic_checkin(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - CHARACTER(LEN=20) :: sub_name = ' system_checkin ' - INTEGER :: i - LOGICAL :: allowed = .FALSE. - - ! - ! ... control on NKSIC (and orbital dependent) variables - ! -!$$ - IF (esic_conv_thr < 0.0_DP) & - CALL errore(sub_name, ' esic_conv_thr out of range ', 1) -!$$ - IF (LEN_TRIM(which_orbdep) > 0) THEN - ! - DO i = 1, SIZE(which_orbdep_allowed) - IF (TRIM(which_orbdep) == which_orbdep_allowed(i)) allowed = .TRUE. - END DO - IF (.NOT. allowed) & - CALL errore(sub_name, ' which_orbdep '''// & - & TRIM(which_orbdep)//''' not allowed ', 1) - - IF (do_wf_cmplx) THEN - DO i = 1, SIZE(which_orbdep_allowed_cmplx) - IF (TRIM(which_orbdep) == which_orbdep_allowed_cmplx(i)) allowed = .TRUE. - END DO - IF (.NOT. allowed) & - CALL errore(sub_name, ' which_orbdep '''// & - & TRIM(which_orbdep)//''' not allowed with complex wavefunctions', 1) - END IF - ! - END IF - ! - RETURN - - END SUBROUTINE nksic_checkin - ! - !=----------------------------------------------------------------------=! - ! - ! Check input values for Namelist ELECTRONS - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE electrons_checkin(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - CHARACTER(LEN=20) :: sub_name = ' electrons_checkin ' - INTEGER :: i - LOGICAL :: allowed = .FALSE. - ! - ! - DO i = 1, SIZE(electron_dynamics_allowed) - IF (TRIM(electron_dynamics) == & - electron_dynamics_allowed(i)) allowed = .TRUE. - END DO - IF (.NOT. allowed) & - CALL errore(sub_name, ' electron_dynamics '''//& - & TRIM(electron_dynamics)//''' not allowed ', 1) - IF (emass <= 0.0_DP) & - CALL errore(sub_name, ' emass less or equal 0 ', 1) - IF (emass_cutoff <= 0.0_DP) & - CALL errore(sub_name, ' emass_cutoff less or equal 0 ', 1) - IF (ortho_eps <= 0.0_DP) & - CALL errore(sub_name, ' ortho_eps less or equal 0 ', 1) - IF (ortho_max < 1) & - CALL errore(sub_name, ' ortho_max less than 1 ', 1) - IF (ortho_para < 0) & - CALL errore(sub_name, ' ortho_para less than 0 ', 1) - IF (fnosee <= 0.0_DP) & - CALL errore(sub_name, ' fnosee less or equal 0 ', 1) - IF (ekincw <= 0.0_DP) & - CALL errore(sub_name, ' ekincw less or equal 0 ', 1) - IF (empty_states_maxstep < 0) & - CALL errore(sub_name,& - & ' invalid empty_states_maxstep, less than 0 ', 1) - IF (empty_states_ethr < 0.0_DP) & - CALL errore(sub_name, & - & ' invalid empty_states_ethr, less than 0 ', 1) - IF (occupation_constraints) & - CALL errore(sub_name, ' occupation_constraints not yet implemented ', 1) - -! - RETURN - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Check input values for Namelist IONS - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE ions_checkin(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - CHARACTER(LEN=20) :: sub_name = ' ions_checkin ' - INTEGER :: i - LOGICAL :: allowed = .FALSE. - ! - ! - DO i = 1, SIZE(phase_space_allowed) - IF (TRIM(phase_space) == phase_space_allowed(i)) allowed = .TRUE. - END DO - IF (.NOT. allowed) & - CALL errore(sub_name, ' phase_space '''// & - & TRIM(phase_space)//''' not allowed ', 1) - ! - allowed = .FALSE. - DO i = 1, SIZE(ion_dynamics_allowed) - IF (TRIM(ion_dynamics) == ion_dynamics_allowed(i)) allowed = .TRUE. - END DO - IF (.NOT. allowed) & - CALL errore(sub_name, ' ion_dynamics '''// & - & TRIM(ion_dynamics)//''' not allowed ', 1) - IF (tempw <= 0.0_DP) & - CALL errore(sub_name, ' tempw out of range ', 1) - IF (fnosep(1) <= 0.0_DP) & - CALL errore(sub_name, ' fnosep out of range ', 1) - IF (nhpcl > nhclm) & - CALL infomsg(sub_name, ' nhpcl should be less than nhclm') - IF (nhpcl < 0) & - CALL infomsg(sub_name, ' nhpcl out of range ') - IF (ion_nstepe <= 0) & - CALL errore(sub_name, ' ion_nstepe out of range ', 1) - IF (ion_maxstep < 0) & - CALL errore(sub_name, ' ion_maxstep out of range ', 1) - ! - ! ... general "path" variables checkin - ! - IF (ds < 0.0_DP) & - CALL errore(sub_name, ' ds out of range ', 1) - IF (temp_req < 0.0_DP) & - CALL errore(sub_name, ' temp_req out of range ', 1) - ! - allowed = .FALSE. - DO i = 1, SIZE(opt_scheme_allowed) - IF (TRIM(opt_scheme) == & - opt_scheme_allowed(i)) allowed = .TRUE. - END DO - IF (.NOT. allowed) & - CALL errore(sub_name, ' opt_scheme '''// & - & TRIM(opt_scheme)//''' not allowed ', 1) - ! - IF (calculation == 'neb' .OR. & - calculation == 'smd' .OR. calculation == 'fpmd-neb') THEN - ! - IF (phase_space == 'coarse-grained') THEN - ! - full_phs_path_flag = .FALSE. - cg_phs_path_flag = .TRUE. - ! - IF (calculation /= 'neb' .AND. calculation /= 'smd') & - CALL errore(sub_name, & - & ' coarse-grained phase-space is presently'// & - & ' allowed only for neb or smd ', 1) - ! - ELSE - ! - full_phs_path_flag = .TRUE. - cg_phs_path_flag = .FALSE. - ! - END IF - ! - END IF - ! - ! ... NEB specific checkin - ! - IF (k_max < 0.0_DP) CALL errore(sub_name, 'k_max out of range', 1) - IF (k_min < 0.0_DP) CALL errore(sub_name, 'k_min out of range', 1) - IF (k_max < k_min) CALL errore(sub_name, 'k_max < k_min', 1) - ! - allowed = .FALSE. - DO i = 1, SIZE(CI_scheme_allowed) - IF (TRIM(CI_scheme) == CI_scheme_allowed(i)) allowed = .TRUE. - END DO - ! - IF (.NOT. allowed) & - CALL errore(sub_name, ' CI_scheme '''// & - & TRIM(CI_scheme)//''' not allowed ', 1) - ! - IF (sic /= 'none' .and. sic_rloc == 0.0_DP) & - CALL errore(sub_name, ' invalid sic_rloc with sic activated ', 1) - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Check input values for Namelist CELL - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE cell_checkin(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - CHARACTER(LEN=20) :: sub_name = ' cell_checkin ' - INTEGER :: i - LOGICAL :: allowed = .FALSE. - ! - ! - DO i = 1, SIZE(cell_dynamics_allowed) - IF (TRIM(cell_dynamics) == & - cell_dynamics_allowed(i)) allowed = .TRUE. - END DO - IF (.NOT. allowed) & - CALL errore(sub_name, ' cell_dynamics '''// & - TRIM(cell_dynamics)//''' not allowed ', 1) - IF (wmass < 0.0_DP) & - CALL errore(sub_name, ' wmass out of range ', 1) - IF (prog == 'CP') THEN - IF (cell_factor /= 0.0_DP) & - CALL infomsg(sub_name, ' cell_factor not used in CP ') - END IF - IF (cell_nstepe <= 0) & - CALL errore(sub_name, ' cell_nstepe out of range ', 1) - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Check input values for Namelist PHONON - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE phonon_checkin(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - ! - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Check input values for Namelist WANNIER - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE wannier_checkin(prog) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - CHARACTER(LEN=20) :: sub_name = 'wannier_checkin' - ! - IF (calwf < 1 .OR. calwf > 5) & - CALL errore(sub_name, ' calwf out of range ', 1) - ! - IF (wfsd < 1 .OR. wfsd > 3) & - CALL errore(sub_name, ' wfsd out of range ', 1) ! - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Check input values for Namelist WANNIER_NEW - ! - !=----------------------------------------------------------------------=! - ! - !---------------------------------------------------------------------- - SUBROUTINE wannier_ac_checkin(prog) - !-------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - CHARACTER(LEN=20) :: sub_name = 'wannier_new_checkin' - ! - ! - IF (nwan > nwanx) & - CALL errore(sub_name, ' nwan out of range ', 1) - - IF (plot_wan_num < 0 .OR. plot_wan_num > nwan) & - CALL errore(sub_name, ' plot_wan_num out of range ', 1) - - IF (plot_wan_spin < 0 .OR. plot_wan_spin > 2) & - CALL errore(sub_name, ' plot_wan_spin out of range ', 1) - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Set values according to the "calculation" variable - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE fixval(prog) - !----------------------------------------------------------------------- - ! - USE constants, ONLY: e2 - ! - IMPLICIT NONE - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - CHARACTER(LEN=20) :: sub_name = ' fixval ' - ! - ! - SELECT CASE (TRIM(calculation)) - CASE ('scf') - IF (prog == 'CP') THEN - electron_dynamics = 'damp' - ion_dynamics = 'none' - cell_dynamics = 'none' - END IF - CASE ('nscf', 'bands') - IF (prog == 'CP') occupations = 'bogus' - IF (prog == 'CP') electron_dynamics = 'damp' - CASE ('phonon') - IF (prog == 'CP') & - CALL errore(sub_name, ' calculation '//TRIM(calculation)// & - & ' not implemented ', 1) - CASE ('raman') - CALL errore(sub_name, ' calculation '//TRIM(calculation)// & - & ' no longer implemented ', 1) - CASE ('cp-wf') - IF (prog == 'CP') THEN - electron_dynamics = 'damp' - ion_dynamics = 'damp' - END IF - IF (prog == 'PW') & - CALL errore(sub_name, ' calculation '// & - & TRIM(calculation)//' not implemented ', 1) - CASE ('relax') - IF (prog == 'CP') THEN - electron_dynamics = 'damp' - ion_dynamics = 'damp' - ELSE IF (prog == 'PW') THEN - ion_dynamics = 'bfgs' - END IF - CASE ('md', 'cp') - IF (prog == 'CP') THEN - electron_dynamics = 'verlet' - ion_dynamics = 'verlet' - ELSE IF (prog == 'PW') THEN - ion_dynamics = 'verlet' - END IF - CASE ('vc-relax') - IF (prog == 'CP') THEN - electron_dynamics = 'damp' - ion_dynamics = 'damp' - cell_dynamics = 'damp-pr' - ELSE IF (prog == 'PW') THEN - ion_dynamics = 'bfgs' - cell_dynamics = 'bfgs' - END IF - CASE ('vc-md', 'vc-cp') - IF (prog == 'CP') THEN - electron_dynamics = 'verlet' - ion_dynamics = 'verlet' - cell_dynamics = 'pr' - ELSE IF (prog == 'PW') THEN - ion_dynamics = 'beeman' - END IF - CASE ('neb') - ! - ! ... "path" optimizations - ! - IF (prog == 'CP') THEN - ! - electron_dynamics = 'damp' - ion_dynamics = 'none' - cell_dynamics = 'none' - ! - END IF - ! - CASE ('fpmd-neb') - ! - ! ... "path" optimizations using fpmd as scf engine - ! - electron_dynamics = 'damp' - ion_dynamics = 'none' - cell_dynamics = 'none' - ! - CASE ('smd') - ! - IF (prog == 'CP') THEN - ! - electron_dynamics = 'damp' - ion_dynamics = 'damp' - ! - END IF - ! - CASE ('fpmd') - ! - ! Compatibility with old FPMD - ! - IF (prog == 'PW') & - CALL errore(sub_name, ' calculation '// & - & TRIM(calculation)//' not implemented ', 1) - ! - electron_dynamics = 'sd' - ion_dynamics = 'none' - cell_dynamics = 'none' - ! - CASE ('metadyn') - ! - CASE DEFAULT - ! - CALL errore(sub_name, ' calculation '// & - & TRIM(calculation)//' not implemented ', 1) - ! - END SELECT - ! - IF (prog == 'PW') THEN - ! - IF (calculation == 'nscf' .OR. & - calculation == 'bands' .OR. & - calculation == 'phonon') THEN - ! - startingpot = 'file' - startingwfc = 'atomic' - ! - ELSE IF (restart_mode == "from_scratch") THEN - ! - startingwfc = 'atomic' - startingpot = 'atomic' - ! - ELSE - ! - startingwfc = 'file' - startingpot = 'file' - ! - END IF - ! - END IF - ! - IF (TRIM(sic) /= 'none') THEN - IF (nspin == 2 .AND. nelec > 1 .AND. & - (nelup == neldw .OR. nelup == neldw + 1)) force_pairing = .TRUE. - END IF - ! - IF (calculation == 'metadyn' .AND. & - prog == 'CP') g_amplitude = g_amplitude/e2 - ! - RETURN - ! - END SUBROUTINE - ! - !=----------------------------------------------------------------------=! - ! - ! Namelist parsing main routine - ! - !=----------------------------------------------------------------------=! - ! - !----------------------------------------------------------------------- - SUBROUTINE read_namelists(prog) - !----------------------------------------------------------------------- - ! - ! this routine reads data from standard input and puts them into - ! module-scope variables (accessible from other routines by including - ! this module, or the one that contains them) - ! ---------------------------------------------- - ! - ! ... declare modules - ! - USE io_global, ONLY: ionode, ionode_id - USE mp, ONLY: mp_bcast - ! - IMPLICIT NONE - ! - ! ... declare variables - ! - CHARACTER(LEN=2) :: prog ! ... specify the calling program - ! prog = 'PW' pwscf - ! prog = 'CP' cpr - ! - ! ... declare other variables - ! - INTEGER :: ios - ! - ! ... end of declarations - ! - ! ---------------------------------------------- - ! - ! - IF (prog /= 'PW' .AND. prog /= 'CP') & - CALL errore(' read_namelists ', ' unknown calling program ', 1) - ! - ! ... default settings for all namelists - ! - CALL control_defaults(prog) - CALL system_defaults(prog) - CALL nksic_defaults(prog) - CALL electrons_defaults(prog) - CALL ions_defaults(prog) - CALL cell_defaults(prog) - CALL phonon_defaults(prog) - CALL ee_defaults(prog) - ! - ! ... Here start reading standard input file - ! - ! ... CONTROL namelist - ! - ios = 0 - IF (ionode) THEN - READ (5, control, iostat=ios) - END IF - CALL mp_bcast(ios, ionode_id) - IF (ios /= 0) THEN - CALL errore(' read_namelists ', & - & ' reading namelist control ', ABS(ios)) - END IF - ! - CALL control_bcast() - CALL control_checkin(prog) - ! - ! ... fixval changes some default values according to the value - ! ... of "calculation" read in CONTROL namelist - ! - CALL fixval(prog) - ! - ! ... SYSTEM namelist - ! - ios = 0 - IF (ionode) THEN - READ (5, system, iostat=ios) - END IF - CALL mp_bcast(ios, ionode_id) - IF (ios /= 0) THEN - CALL errore(' read_namelists ', & - & ' reading namelist system ', ABS(ios)) - END IF - ! - CALL system_bcast() - ! - CALL system_checkin(prog) - ! - CALL allocate_input_ions(ntyp, nat) - ! - ! ... ELECTRONS namelist - ! - ios = 0 - IF (ionode) THEN - READ (5, electrons, iostat=ios) - END IF - CALL mp_bcast(ios, ionode_id) - IF (ios /= 0) THEN - CALL errore(' read_namelists ', & - & ' reading namelist electrons ', ABS(ios)) - END IF - ! - CALL electrons_bcast() - CALL electrons_checkin(prog) - ! - ! ... IONS namelist - ! - ios = 0 - IF (ionode) THEN - ! - IF (TRIM(calculation) == 'relax' .OR. & - TRIM(calculation) == 'md' .OR. & - TRIM(calculation) == 'vc-relax' .OR. & - TRIM(calculation) == 'vc-md' .OR. & - TRIM(calculation) == 'cp' .OR. & - TRIM(calculation) == 'vc-cp' .OR. & - TRIM(calculation) == 'smd' .OR. & - TRIM(calculation) == 'cp-wf' .OR. & - TRIM(calculation) == 'neb' .OR. & - TRIM(calculation) == 'fpmd' .OR. & - TRIM(calculation) == 'fpmd-neb' .OR. & - TRIM(calculation) == 'metadyn') READ (5, ions, iostat=ios) - ! - END IF - CALL mp_bcast(ios, ionode_id) - IF (ios /= 0) THEN - CALL errore(' read_namelists ', & - & ' reading namelist ions ', ABS(ios)) - END IF - ! - CALL ions_bcast() - CALL ions_checkin(prog) - ! - ! ... CELL namelist - ! - ios = 0 - IF (ionode) THEN - IF (TRIM(calculation) == 'vc-relax' .OR. & - TRIM(calculation) == 'vc-cp' .OR. & - TRIM(calculation) == 'vc-md' .OR. & - TRIM(calculation) == 'fpmd' .OR. & - TRIM(calculation) == 'fpmd-neb' .OR. & - TRIM(calculation) == 'vc-md') THEN - READ (5, cell, iostat=ios) - END IF - END IF - CALL mp_bcast(ios, ionode_id) - IF (ios /= 0) THEN - CALL errore(' read_namelists ', & - & ' reading namelist cell ', ABS(ios)) - END IF - ! - CALL cell_bcast() - CALL cell_checkin(prog) - ! - ios = 0 - IF (ionode) THEN - if (tabps) then - READ (5, press_ai, iostat=ios) - end if - END IF - CALL mp_bcast(ios, ionode_id) - IF (ios /= 0) THEN - CALL errore(' read_namelists ', & - & ' reading namelist press_ai ', ABS(ios)) - END IF - ! - CALL press_ai_bcast() - ! - ! ... EE namelist - ! - IF (do_ee) THEN - ios = 0 - IF (ionode) READ (5, ee, iostat=ios) - CALL mp_bcast(ios, ionode_id) - IF (ios /= 0) CALL errore(' read_namelists ', & - & ' reading namelist ee ', ABS(ios)) - END IF - CALL ee_bcast() - ! - ! ... NKSIC namelist - ! - IF (do_orbdep) THEN - ! - ios = 0 - IF (ionode) THEN - READ (5, nksic, iostat=ios) - END IF - CALL mp_bcast(ios, ionode_id) - IF (ios /= 0) THEN - CALL errore(' read_namelists ', & - & ' reading namelist nksic ', ABS(ios)) - END IF - ! - CALL nksic_bcast() - ! - CALL nksic_checkin(prog) - ! - END IF - - ! - ! ... PHONON namelist - ! - ios = 0 - IF (ionode) THEN - IF (TRIM(calculation) == 'phonon') THEN - READ (5, phonon, iostat=ios) - END IF - END IF - CALL mp_bcast(ios, ionode_id) - IF (ios /= 0) THEN - CALL errore(' read_namelists ', & - & ' reading namelist phonon ', ABS(ios)) - END IF - ! - CALL phonon_bcast() - CALL phonon_checkin(prog) - ! - ! ... WANNIER NAMELIST - ! - CALL wannier_defaults(prog) - ios = 0 - IF (ionode) THEN - IF (TRIM(calculation) == 'cp-wf') THEN - READ (5, wannier, iostat=ios) - END IF - END IF - CALL mp_bcast(ios, ionode_id) - IF (ios /= 0) THEN - CALL errore(' read_namelists ', & - & ' reading namelist wannier ', ABS(ios)) - END IF - ! - CALL wannier_bcast() - CALL wannier_checkin(prog) - ! - ! ... WANNIER_NEW NAMELIST - ! - CALL wannier_ac_defaults(prog) - ios = 0 - IF (ionode) THEN - IF (use_wannier) THEN - READ (5, wannier_ac, iostat=ios) - END IF - END IF - CALL mp_bcast(ios, ionode_id) - IF (ios /= 0) THEN - CALL errore(' read_namelists ', & - & ' reading namelist wannier_new ', ABS(ios)) - END IF - ! - CALL wannier_ac_bcast() - CALL wannier_ac_checkin(prog) - ! - RETURN - ! - END SUBROUTINE read_namelists - ! -END MODULE read_namelists_module diff --git a/quantum_espresso/kcp/Modules/read_ncpp.f90 b/quantum_espresso/kcp/Modules/read_ncpp.f90 deleted file mode 100644 index 2a88e41d2..000000000 --- a/quantum_espresso/kcp/Modules/read_ncpp.f90 +++ /dev/null @@ -1,267 +0,0 @@ -! -! Copyright (C) 2001-2007 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!----------------------------------------------------------------------- -subroutine read_ncpp (iunps, np, upf) - !----------------------------------------------------------------------- - ! - USE kinds, only: dp - USE parameters, ONLY: lmaxx - use funct, only: set_dft_from_name, dft_is_meta, dft_is_hybrid - USE pseudo_types - - implicit none - ! - TYPE (pseudo_upf) :: upf - integer :: iunps, np - ! - real(DP) :: cc(2), alpc(2), aps(6,0:3), alps(3,0:3), & - a_nlcc, b_nlcc, alpha_nlcc - real(DP) :: x, vll - real(DP), allocatable:: vnl(:,:) - real(DP), parameter :: rcut = 10.d0, e2 = 2.d0 - real(DP), external :: qe_erf - integer :: nlc, nnl, lmax, lloc - integer :: nb, ios, i, l, ir - logical :: bhstype, numeric - ! - !==================================================================== - ! read norm-conserving PPs - ! - read (iunps, '(a)', end=300, err=300, iostat=ios) upf%dft - if (upf%dft(1:2) .eq.'**') upf%dft = 'PZ' - read (iunps, *, err=300, iostat=ios) upf%psd, upf%zp, lmax, nlc, & - nnl, upf%nlcc, lloc, bhstype - if (nlc > 2 .or. nnl > 3) & - call errore ('read_ncpp', 'Wrong nlc or nnl', np) - if (nlc*nnl < 0) call errore ('read_ncpp', 'nlc*nnl < 0 ? ', np) - if (upf%zp <= 0d0 .or. upf%zp > 100 ) & - call errore ('read_ncpp', 'Wrong zp ', np) - ! - ! In numeric pseudopotentials both nlc and nnl are zero. - ! - numeric = (nlc <= 0) .and. (nnl <= 0) - ! - if (lloc == -1000) lloc = lmax - if (lloc < 0 .or. lmax < 0 .or. & - .not.numeric .and. (lloc > min(lmax+1,lmaxx+1) .or. & - lmax > max(lmaxx,lloc)) .or. & - numeric .and. (lloc > lmax .or. lmax > lmaxx) ) & - call errore ('read_ncpp', 'wrong lmax and/or lloc', np) - if (.not.numeric ) then - ! - ! read here pseudopotentials in analytic form - ! - read (iunps, *, err=300, iostat=ios) & - (alpc(i), i=1,2), (cc(i), i=1,2) - if (abs (cc(1)+cc(2)-1.d0) > 1.0d-6) & - call errore ('read_ncpp', 'wrong pseudopotential coefficients', 1) - do l = 0, lmax - read (iunps, *, err=300, iostat=ios) (alps(i,l), i=1,3), & - (aps(i,l), i=1,6) - enddo - if (upf%nlcc ) then - read (iunps, *, err=300, iostat=ios) & - a_nlcc, b_nlcc, alpha_nlcc - if (alpha_nlcc <= 0.d0) call errore('read_ncpp','alpha_nlcc=0',np) - endif - endif - read (iunps, *, err=300, iostat=ios) upf%zmesh, upf%xmin, upf%dx, & - upf%mesh, upf%nwfc - if ( upf%mesh <= 0) & - call errore ('read_ncpp', 'wrong nuymber of mesh points', np) - if ( upf%nwfc < 0 .or. & - (upf%nwfc < lmax .and. lloc == lmax) .or. & - (upf%nwfc < lmax+1 .and. lloc /= lmax) ) & - call errore ('read_ncpp', 'wrong no. of wfcts', np) - ! - ! Here pseudopotentials in numeric form are read - ! - ALLOCATE ( upf%chi(upf%mesh,upf%nwfc), upf%rho_atc(upf%mesh) ) - upf%rho_atc(:) = 0.d0 - ALLOCATE ( upf%lchi(upf%nwfc), upf%oc(upf%nwfc) ) - allocate (vnl(upf%mesh, 0:lmax)) - if (numeric ) then - do l = 0, lmax - read (iunps, '(a)', err=300, iostat=ios) - read (iunps, *, err=300, iostat=ios) (vnl(ir,l), ir=1,upf%mesh ) - enddo - if ( upf%nlcc ) then - read (iunps, *, err=300, iostat=ios) (upf%rho_atc(ir), ir=1,upf%mesh) - endif - endif - ! - ! Here pseudowavefunctions (in numeric form) are read - ! - do nb = 1, upf%nwfc - read (iunps, '(a)', err=300, iostat=ios) - read (iunps, *, err=300, iostat=ios) upf%lchi(nb), upf%oc(nb) - ! - ! Test lchi and occupation numbers - ! - if (nb <= lmax .and. upf%lchi(nb)+1 /= nb) & - call errore ('read_ncpp', 'order of wavefunctions', 1) - if (upf%lchi(nb) > lmaxx .or. upf%lchi(nb) < 0) & - call errore ('read_ncpp', 'wrong lchi', np) - if (upf%oc(nb) < 0.d0 .or. upf%oc(nb) > 2.d0*(2*upf%lchi(nb)+1)) & - call errore ('read_ncpp', 'wrong oc', np) - read (iunps, *, err=300, iostat=ios) ( upf%chi(ir,nb), ir=1,upf%mesh ) - enddo - ! - !==================================================================== - ! PP read: now setup - ! - IF ( numeric ) THEN - upf%generated='Generated by old ld1 code (numerical format)' - ELSE - upf%generated='From published tables, or generated by old fitcar code (analytical format)' - END IF - call set_dft_from_name( upf%dft ) - ! -#if defined (EXX) -#else - IF ( dft_is_hybrid() ) & - CALL errore( 'read_ncpp ', 'HYBRID XC not implemented in PWscf', 1 ) -#endif - ! - ! calculate the number of beta functions - ! - upf%nbeta = 0 - do l = 0, lmax - if (l /= lloc ) upf%nbeta = upf%nbeta + 1 - enddo - ALLOCATE ( upf%lll(upf%nbeta) ) - nb = 0 - do l = 0, lmax - if (l /= lloc ) then - nb = nb + 1 - upf%lll (nb) = l - end if - enddo - ! - ! compute the radial mesh - ! - ALLOCATE ( upf%r(upf%mesh), upf%rab(upf%mesh) ) - do ir = 1, upf%mesh - x = upf%xmin + DBLE (ir - 1) * upf%dx - upf%r(ir) = exp (x) / upf%zmesh - upf%rab(ir) = upf%dx * upf%r(ir) - enddo - do ir = 1, upf%mesh - if ( upf%r(ir) > rcut) then - upf%kkbeta = ir - go to 5 - end if - end do - upf%kkbeta = upf%mesh - ! - ! ... force kkbeta to be odd for simpson integration (obsolete?) - ! -5 upf%kkbeta = 2 * ( ( upf%kkbeta + 1 ) / 2) - 1 - ! - ALLOCATE ( upf%kbeta(upf%nbeta) ) - upf%kbeta(:) = upf%kkbeta - ALLOCATE ( upf%vloc(upf%mesh) ) - upf%vloc (:) = 0.d0 - ! - if (.not. numeric) then - ! - ! bring analytic potentials into numerical form - ! - IF ( nlc == 2 .AND. nnl == 3 .AND. bhstype ) & - CALL bachel( alps(1,0), aps(1,0), 1, lmax ) - ! - do i = 1, nlc - do ir = 1, upf%kkbeta - upf%vloc (ir) = upf%vloc (ir) - upf%zp * e2 * cc (i) * & - qe_erf ( sqrt (alpc(i)) * upf%r(ir) ) / upf%r(ir) - end do - end do - do l = 0, lmax - vnl (:, l) = upf%vloc (1:upf%mesh) - do i = 1, nnl - vnl (:, l) = vnl (:, l) + e2 * (aps (i, l) + & - aps (i + 3, l) * upf%r (:) **2) * & - exp ( - upf%r(:) **2 * alps (i, l) ) - enddo - enddo - if ( upf%nlcc ) then - upf%rho_atc(:) = ( a_nlcc + b_nlcc*upf%r(:)**2 ) * & - exp ( -upf%r(:)**2 * alpha_nlcc ) - end if - ! - end if - ! - ! assume l=lloc as local part and subtract from the other channels - ! - if (lloc <= lmax ) & - upf%vloc (:) = vnl (:, lloc) - ! lloc > lmax is allowed for PP in analytical form only - ! it means that only the erf part is taken as local part - do l = 0, lmax - if (l /= lloc) vnl (:, l) = vnl(:, l) - upf%vloc(:) - enddo - ! - ! compute the atomic charges - ! - ALLOCATE ( upf%rho_at (upf%mesh) ) - upf%rho_at(:) = 0.d0 - do nb = 1, upf%nwfc - if ( upf%oc(nb) > 0.d0) then - do ir = 1, upf%mesh - upf%rho_at(ir) = upf%rho_at(ir) + upf%oc(nb) * upf%chi(ir,nb)**2 - enddo - endif - enddo - !==================================================================== - ! convert to separable (KB) form - ! - ALLOCATE ( upf%beta (upf%mesh, upf%nbeta) ) - ALLOCATE ( upf%dion (upf%nbeta,upf%nbeta), upf%lll (upf%nbeta) ) - upf%dion (:,:) = 0.d0 - nb = 0 - do l = 0, lmax - if (l /= lloc ) then - nb = nb + 1 - ! upf%beta is used here as work space - do ir = 1, upf%kkbeta - upf%beta (ir, nb) = upf%chi(ir, l+1) **2 * vnl(ir, l) - end do - call simpson (upf%kkbeta, upf%beta (1, nb), upf%rab, vll ) - upf%dion (nb, nb) = 1.d0 / vll - ! upf%beta stores projectors |beta(r)> = |V_nl(r)phi(r)> - do ir = 1, upf%kkbeta - upf%beta (ir, nb) = vnl (ir, l) * upf%chi (ir, l + 1) - enddo - upf%lll (nb) = l - endif - enddo - deallocate (vnl) - ! - ! for compatibility with USPP - ! - upf%nqf = 0 - upf%nqlc= 0 - upf%tvanp =.false. - upf%tpawp =.false. - upf%has_so=.false. - ! - ! Set additional, not present, variables to dummy values - allocate(upf%els(upf%nwfc)) - upf%els(:) = 'nX' - allocate(upf%els_beta(upf%nbeta)) - upf%els_beta(:) = 'nX' - allocate(upf%rcut(upf%nbeta), upf%rcutus(upf%nbeta)) - upf%rcut(:) = 0._dp - upf%rcutus(:) = 0._dp - ! - return - -300 call errore ('read_ncpp', 'pseudo file is empty or wrong', abs (np) ) -end subroutine read_ncpp - diff --git a/quantum_espresso/kcp/Modules/read_oddalpha_file.f90 b/quantum_espresso/kcp/Modules/read_oddalpha_file.f90 deleted file mode 100644 index d216ca1d1..000000000 --- a/quantum_espresso/kcp/Modules/read_oddalpha_file.f90 +++ /dev/null @@ -1,60 +0,0 @@ -!-------------------------------------------------------------------------- -subroutine read_oddalpha_file (file_odd_alpha, number_alpha, alpha_orb, spread_orb, & - delta_spread_orb, center_orb, delta_center_orb, iflag_alpha) - !----------------------------------------------------------------------- - ! - USE io_global, ONLY : stdout, ionode_id, ionode - USE mp, ONLY : mp_bcast - USE kinds, only : DP - - ! - implicit none - ! - character (len=*) :: file_odd_alpha - ! - integer :: number_alpha, iflag_alpha - ! - real(DP):: alpha_orb(number_alpha), spread_orb(number_alpha), & - delta_spread_orb(number_alpha), center_orb (number_alpha, 3), & - delta_center_orb(number_alpha) - ! - integer :: iun_alphafile, ia, ipol, ios - ! - if (ionode) then - ! - if (file_odd_alpha == ' ') call errore ('file_odd_alpha', 'filename missing', 1) - ! - iun_alphafile = 4 - ! - write( stdout, '(5x,"Reading orbital alpha from file ",a)') TRIM(file_odd_alpha) - ! - open (unit = iun_alphafile, file = file_odd_alpha, form = 'formatted', & - status = 'old', iostat = ios) - ! - rewind (iun_alphafile) - ! - read (iun_alphafile, *) number_alpha - ! - do ia = 1, number_alpha - read (iun_alphafile, * ) alpha_orb(ia), spread_orb(ia), delta_spread_orb(ia), & - ( center_orb(ia,ipol), ipol=1,3 ), delta_center_orb(ia), & - iflag_alpha - enddo - ! - close (unit = iun_alphafile) - ! - endif - ! - call mp_bcast( number_alpha, ionode_id ) - call mp_bcast( iflag_alpha, ionode_id ) - call mp_bcast( alpha_orb, ionode_id ) - call mp_bcast( spread_orb, ionode_id ) - call mp_bcast( delta_spread_orb, ionode_id ) - call mp_bcast( center_orb, ionode_id ) - call mp_bcast( delta_center_orb, ionode_id ) - call mp_bcast( iflag_alpha, ionode_id ) - ! - return - ! -end subroutine read_oddalpha_file - diff --git a/quantum_espresso/kcp/Modules/read_upf_v1.f90 b/quantum_espresso/kcp/Modules/read_upf_v1.f90 deleted file mode 100644 index d354d76c0..000000000 --- a/quantum_espresso/kcp/Modules/read_upf_v1.f90 +++ /dev/null @@ -1,832 +0,0 @@ - -! Copyright (C) 2002-2008 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -!=----------------------------------------------------------------------------=! - MODULE read_upf_v1_module -!=----------------------------------------------------------------------------=! - -! this module handles the reading of pseudopotential data - -! ... declare modules - USE kinds, ONLY: DP - USE radial_grids, ONLY: allocate_radial_grid - IMPLICIT NONE - SAVE - PRIVATE - PUBLIC :: read_upf_v1, scan_begin, scan_end - CONTAINS -! -!--------------------------------------------------------------------- -subroutine read_upf_v1 (iunps, upf, grid, ierr, header_only) - !--------------------------------------------------------------------- - ! - ! read pseudopotential "upf" in the Unified Pseudopotential Format - ! from unit "iunps" - return error code in "ierr" (success: ierr=0) - ! - use pseudo_types - use radial_grids, only : radial_grid_type - ! - implicit none - ! - INTEGER, INTENT(IN) :: iunps - INTEGER, INTENT(OUT) :: ierr - LOGICAL, INTENT(IN), OPTIONAL :: header_only - TYPE (pseudo_upf), INTENT(INOUT) :: upf - TYPE (radial_grid_type), TARGET, INTENT(INOUT) :: grid - ! - ! Local variables - ! - integer :: ios - character (len=80) :: dummy - logical, external :: matches - ! - ! Prepare the pointers - ! CALL nullify_pseudo_upf( upf ) should be nullified when instantiated - ! - upf%grid => grid - ! - ! First check if this pseudo-potential has spin-orbit information - ! - ierr = 1 - ios = 0 - upf%q_with_l=.false. - upf%has_so=.false. - upf%has_gipaw = .false. - addinfo_loop: do while (ios == 0) - read (iunps, *, iostat = ios, err = 200) dummy - if (matches ("", dummy) ) then - upf%has_so=.true. - endif - if ( matches ( "", dummy ) ) then - upf%has_gipaw = .true. - endif - if (matches ("", dummy) ) then - upf%q_with_l=.true. - endif - enddo addinfo_loop - - !------->Search for Header - ! This version doesn't use the new routine scan_begin - ! because this search must set extra flags for - ! compatibility with other pp format reading - ierr = 1 - ios = 0 - rewind(iunps) - header_loop: do while (ios == 0) - read (iunps, *, iostat = ios, err = 200) dummy - if (matches ("", dummy) ) then - ierr = 0 - call read_pseudo_header (upf, iunps) - exit header_loop - endif - enddo header_loop - ! - ! this should be read from the PP_INFO section - ! - upf%generated='Generated by new atomic code, or converted to UPF format' - - IF ( PRESENT (header_only) ) THEN - IF ( header_only ) RETURN - END IF - if (ierr .ne. 0) return - - call scan_end (iunps, "HEADER") - - ! WRITE( stdout, * ) "Reading pseudopotential file in UPF format" - - !-------->Search for mesh information - call scan_begin (iunps, "MESH", .true.) - call read_pseudo_mesh (upf, iunps) - call scan_end (iunps, "MESH") - !-------->If present, search for nlcc - if ( upf%nlcc ) then - call scan_begin (iunps, "NLCC", .true.) - call read_pseudo_nlcc (upf, iunps) - call scan_end (iunps, "NLCC") - else - ALLOCATE( upf%rho_atc( upf%mesh ) ) - upf%rho_atc = 0.0_DP - endif - !-------->Fake 1/r potential: do not read PP - if (.not. matches ("1/r", upf%typ) ) then - !-------->Search for Local potential - call scan_begin (iunps, "LOCAL", .true.) - call read_pseudo_local (upf, iunps) - call scan_end (iunps, "LOCAL") - !-------->Search for Nonlocal potential - call scan_begin (iunps, "NONLOCAL", .true.) - call read_pseudo_nl (upf, iunps) - call scan_end (iunps, "NONLOCAL") - !-------- - end if - !-------->Search for atomic wavefunctions - call scan_begin (iunps, "PSWFC", .true.) - call read_pseudo_pswfc (upf, iunps) - call scan_end (iunps, "PSWFC") - !-------->Search for atomic charge - call scan_begin (iunps, "RHOATOM", .true.) - call read_pseudo_rhoatom (upf, iunps) - call scan_end (iunps, "RHOATOM") - !-------->Search for add_info - if (upf%has_so) then - call scan_begin (iunps, "ADDINFO", .true.) - call read_pseudo_addinfo (upf, iunps) - call scan_end (iunps, "ADDINFO") - endif - !-------->GIPAW data - IF ( upf%has_gipaw ) then - CALL scan_begin ( iunps, "GIPAW_RECONSTRUCTION_DATA", .false. ) - CALL read_pseudo_gipaw ( upf, iunps ) - CALL scan_end ( iunps, "GIPAW_RECONSTRUCTION_DATA" ) - END IF - !--- Try to get the core radius if not present. Needed by the - ! atomic code for old pseudo files - IF (upf%nbeta>0) THEN ! rcutus may be unallocated if nbeta=0 - IF(upf%rcutus(1)<1.e-9_DP) THEN - call scan_begin (iunps, "INFO", .true.) - call read_pseudo_ppinfo (upf, iunps) - call scan_end (iunps, "INFO") - ENDIF - ENDIF - -200 return - -end subroutine read_upf_v1 -!--------------------------------------------------------------------- - - -subroutine scan_begin (iunps, string, rew) - !--------------------------------------------------------------------- - ! - implicit none - ! Unit of the input file - integer :: iunps - ! Label to be matched - character (len=*) :: string - ! String read from file - character (len=75) :: rstring - ! Flag if .true. rewind the file - logical, external :: matches - logical :: rew - integer :: ios - - ios = 0 - if (rew) rewind (iunps) - do while (ios==0) - read (iunps, *, iostat = ios, err = 300) rstring - if (matches ("", rstring) ) return - enddo - return -300 call errore ('scan_begin', 'No '//string//' block', abs (ios) ) -end subroutine scan_begin -!--------------------------------------------------------------------- - -subroutine scan_end (iunps, string) - !--------------------------------------------------------------------- - implicit none - ! Unit of the input file - integer :: iunps - ! Label to be matched - character (len=*) :: string - ! String read from file - character (len=75) :: rstring - logical, external :: matches - - read (iunps, '(a)', end = 300, err = 300) rstring - if (matches ("", rstring) ) return - return -300 call errore ('scan_end', & - 'No '//string//' block end statement, possibly corrupted file', -1) -end subroutine scan_end -! -!--------------------------------------------------------------------- - -subroutine read_pseudo_header (upf, iunps) - !--------------------------------------------------------------------- - ! - USE pseudo_types, ONLY: pseudo_upf - USE kinds - - implicit none - ! - TYPE (pseudo_upf), INTENT(INOUT) :: upf - integer :: iunps - ! - integer :: nw - character (len=80) :: dummy - logical, external :: matches - - ! Version number (presently ignored) - read (iunps, *, err = 100, end = 100) upf%nv , dummy - ! Element label - read (iunps, *, err = 100, end = 100) upf%psd , dummy - ! Type of pseudo (1/r cannot be read with default format!!!) - read (iunps, '(a80)', err = 100, end = 100) dummy - upf%typ=trim(adjustl(dummy)) - ! - if (matches ('US', upf%typ) ) then - upf%tvanp = .true. - upf%tpawp = .false. - upf%tcoulombp = .false. - else if (matches ('PAW', upf%typ) ) then - ! Note: if tvanp is set to false the results are wrong! - upf%tvanp = .true. - upf%tpawp = .true. - upf%tcoulombp = .false. - else if (matches ('NC', upf%typ) ) then - upf%tvanp = .false. - upf%tpawp = .false. - upf%tcoulombp = .false. - else if (matches ('1/r', upf%typ) ) then - upf%tvanp = .false. - upf%tpawp = .false. - upf%tcoulombp = .true. - else - call errore ('read_pseudo_header', 'unknown pseudo type', 1) - endif - - read (iunps, *, err = 100, end = 100) upf%nlcc , dummy - - read (iunps, '(a20,t24,a)', err = 100, end = 100) upf%dft, dummy - - read (iunps, * ) upf%zp , dummy - read (iunps, * ) upf%etotps, dummy - read (iunps, * ) upf%ecutwfc, upf%ecutrho - read (iunps, * ) upf%lmax , dummy - read (iunps, *, err = 100, end = 100) upf%mesh , dummy - upf%grid%mesh = upf%mesh - call allocate_radial_grid(upf%grid,upf%grid%mesh) -! IF ( upf%grid%mesh > SIZE (upf%grid%r) ) & -! CALL errore('read_pseudo_header', 'too many grid points', 1) - - read (iunps, *, err = 100, end = 100) upf%nwfc, upf%nbeta , dummy - read (iunps, '(a)', err = 100, end = 100) dummy - ALLOCATE( upf%els( upf%nwfc ), upf%lchi( upf%nwfc ), upf%oc( upf%nwfc ) ) - do nw = 1, upf%nwfc - read (iunps, * ) upf%els (nw), upf%lchi (nw), upf%oc (nw) - enddo - - return - -100 call errore ('read_pseudo_header', 'Reading pseudo file', 1 ) -end subroutine read_pseudo_header - -!--------------------------------------------------------------------- - -subroutine read_pseudo_mesh (upf, iunps) - !--------------------------------------------------------------------- - ! - USE kinds - USE pseudo_types, ONLY: pseudo_upf - - implicit none - ! - integer :: iunps - TYPE (pseudo_upf), INTENT(INOUT) :: upf - ! - integer :: ir - - IF(associated(upf%grid)) THEN - upf%r => upf%grid%r - upf%rab => upf%grid%rab - ELSE - ALLOCATE( upf%r( upf%mesh ), upf%rab( upf%mesh ) ) - ENDIF - upf%r = 0.0_DP - upf%rab = 0.0_DP - - call scan_begin (iunps, "R", .false.) - read (iunps, *, err = 100, end = 100) (upf%r(ir), ir=1,upf%mesh ) - call scan_end (iunps, "R") - call scan_begin (iunps, "RAB", .false.) - read (iunps, *, err = 101, end = 101) (upf%rab(ir), ir=1,upf%mesh ) - call scan_end (iunps, "RAB") -! upf%grid%r(1:upf%mesh) = upf%r(1:upf%mesh) -! upf%grid%rab(1:upf%mesh) = upf%rab(1:upf%mesh) - - return - -100 call errore ('read_pseudo_mesh', 'Reading pseudo file (R) for '//upf%psd,1) -101 call errore ('read_pseudo_mesh', 'Reading pseudo file (RAB) for '//upf%psd,2) -end subroutine read_pseudo_mesh - - -!--------------------------------------------------------------------- -subroutine read_pseudo_nlcc (upf, iunps) - !--------------------------------------------------------------------- - ! - USE kinds - USE pseudo_types, ONLY: pseudo_upf - - implicit none - ! - integer :: iunps - TYPE (pseudo_upf), INTENT(INOUT) :: upf - ! - integer :: ir - ! - ALLOCATE( upf%rho_atc( upf%mesh ) ) - upf%rho_atc = 0.0_DP - - read (iunps, *, err = 100, end = 100) (upf%rho_atc(ir), ir=1,upf%mesh ) - ! - return - -100 call errore ('read_pseudo_nlcc', 'Reading pseudo file', 1) - return -end subroutine read_pseudo_nlcc - -!--------------------------------------------------------------------- -subroutine read_pseudo_local (upf, iunps) - !--------------------------------------------------------------------- - ! - USE kinds - USE pseudo_types, ONLY: pseudo_upf - - implicit none - ! - integer :: iunps - TYPE (pseudo_upf), INTENT(INOUT) :: upf - ! - integer :: ir - ! - ALLOCATE( upf%vloc( upf%mesh ) ) - upf%vloc = 0.0_DP - - read (iunps, *, err=100, end=100) (upf%vloc(ir) , ir=1,upf%mesh ) - - return - -100 call errore ('read_pseudo_local','Reading pseudo file', 1) - return -end subroutine read_pseudo_local - -!--------------------------------------------------------------------- - -subroutine read_pseudo_nl (upf, iunps) - !--------------------------------------------------------------------- - ! - USE kinds - USE pseudo_types, ONLY: pseudo_upf - - implicit none - ! - integer :: iunps - TYPE (pseudo_upf), INTENT(INOUT) :: upf - ! - integer :: nb, mb, ijv, n, ir, ios, idum, ldum, icon, lp, i, ikk, l, l1,l2, nd - ! counters - character (len=75) :: dummy - ! - ! Threshold for qfunc to be considered zero (inserted in version UPF v2) - upf%qqq_eps = -1._dp - ! - if ( upf%nbeta == 0) then - upf%nqf = 0 - upf%nqlc= 0 - upf%kkbeta = 0 - ALLOCATE( upf%kbeta( 1 ) ) - ALLOCATE( upf%lll( 1 ) ) - ALLOCATE( upf%beta( upf%mesh, 1 ) ) - ALLOCATE( upf%dion( 1, 1 ) ) - ALLOCATE( upf%rinner( 1 ) ) - ALLOCATE( upf%qqq ( 1, 1 ) ) - ALLOCATE( upf%qfunc ( upf%mesh, 1 ) ) - ALLOCATE( upf%qfcoef( 1, 1, 1, 1 ) ) - ALLOCATE( upf%rcut( 1 ) ) - ALLOCATE( upf%rcutus( 1 ) ) - ALLOCATE( upf%els_beta( 1 ) ) - return - end if - ALLOCATE( upf%kbeta( upf%nbeta ) ) - ALLOCATE( upf%lll( upf%nbeta ) ) - ALLOCATE( upf%beta( upf%mesh, upf%nbeta ) ) - ALLOCATE( upf%dion( upf%nbeta, upf%nbeta ) ) - ALLOCATE( upf%rcut( upf%nbeta ) ) - ALLOCATE( upf%rcutus( upf%nbeta ) ) - ALLOCATE( upf%els_beta( upf%nbeta ) ) - - upf%kkbeta = 0 - upf%lll = 0 - upf%beta = 0.0_DP - upf%dion = 0.0_DP - upf%rcut = 0.0_DP - upf%rcutus = 0.0_DP - upf%els_beta = ' ' - - do nb = 1, upf%nbeta - call scan_begin (iunps, "BETA", .false.) - read (iunps, *, err = 100, end = 100) idum, upf%lll(nb), dummy - read (iunps, *, err = 100, end = 100) ikk - upf%kbeta(nb) = ikk - upf%kkbeta = MAX ( upf%kkbeta, upf%kbeta(nb) ) - read (iunps, *, err = 100, end = 100) (upf%beta(ir,nb), ir=1,ikk) - - read (iunps, *, err=200,iostat=ios) upf%rcut(nb), upf%rcutus(nb) - read (iunps, *, err=200,iostat=ios) upf%els_beta(nb) - call scan_end (iunps, "BETA") -200 continue - enddo - - - call scan_begin (iunps, "DIJ", .false.) - read (iunps, *, err = 101, end = 101) nd, dummy - do icon = 1, nd - read (iunps, *, err = 101, end = 101) nb, mb, upf%dion(nb,mb) - upf%dion (mb,nb) = upf%dion (nb,mb) - enddo - call scan_end (iunps, "DIJ") - - - if ( upf%tvanp .or. upf%tpawp) then - call scan_begin (iunps, "QIJ", .false.) - read (iunps, *, err = 102, end = 102) upf%nqf - upf%nqlc = 2 * upf%lmax + 1 - ALLOCATE( upf%rinner( upf%nqlc ) ) - ALLOCATE( upf%qqq ( upf%nbeta, upf%nbeta ) ) - IF (upf%q_with_l .or. upf%tpawp) then - ALLOCATE( upf%qfuncl ( upf%mesh, upf%nbeta*(upf%nbeta+1)/2, 0:2*upf%lmax ) ) - upf%qfuncl = 0.0_DP - ELSE - ALLOCATE( upf%qfunc ( upf%mesh, upf%nbeta*(upf%nbeta+1)/2 ) ) - upf%qfunc = 0.0_DP - ENDIF - ALLOCATE( upf%qfcoef( MAX( upf%nqf,1 ), upf%nqlc, upf%nbeta, upf%nbeta ) ) - upf%rinner = 0.0_DP - upf%qqq = 0.0_DP - upf%qfcoef = 0.0_DP - if ( upf%nqf /= 0) then - call scan_begin (iunps, "RINNER", .false.) - read (iunps,*,err=103,end=103) ( idum, upf%rinner(i), i=1,upf%nqlc ) - call scan_end (iunps, "RINNER") - end if - do nb = 1, upf%nbeta - do mb = nb, upf%nbeta - - read (iunps,*,err=102,end=102) idum, idum, ldum, dummy - !" i j (l)" - if (ldum /= upf%lll(mb) ) then - call errore ('read_pseudo_nl','inconsistent angular momentum for Q_ij', 1) - end if - - read (iunps,*,err=104,end=104) upf%qqq(nb,mb), dummy - ! "Q_int" - upf%qqq(mb,nb) = upf%qqq(nb,mb) - ! ijv is the combined (nb,mb) index - ijv = mb * (mb-1) / 2 + nb - IF (upf%q_with_l .or. upf%tpawp) THEN - l1=upf%lll(nb) - l2=upf%lll(mb) - DO l=abs(l1-l2),l1+l2 - read (iunps, *, err=105, end=105) (upf%qfuncl(n,ijv,l), & - n=1,upf%mesh) - END DO - ELSE - read (iunps, *, err=105, end=105) (upf%qfunc(n,ijv), n=1,upf%mesh) - ENDIF - - if ( upf%nqf > 0 ) then - call scan_begin (iunps, "QFCOEF", .false.) - read (iunps,*,err=106,end=106) & - ( ( upf%qfcoef(i,lp,nb,mb), i=1,upf%nqf ), lp=1,upf%nqlc ) - do i = 1, upf%nqf - do lp = 1, upf%nqlc - upf%qfcoef(i,lp,mb,nb) = upf%qfcoef(i,lp,nb,mb) - end do - end do - call scan_end (iunps, "QFCOEF") - end if - - enddo - enddo - call scan_end (iunps, "QIJ") - else - upf%nqf = 1 - upf%nqlc = 2 * upf%lmax + 1 - ALLOCATE( upf%rinner( upf%nqlc ) ) - ALLOCATE( upf%qqq ( upf%nbeta, upf%nbeta ) ) - ALLOCATE( upf%qfunc ( upf%mesh, upf%nbeta*(upf%nbeta+1)/2 ) ) - ALLOCATE( upf%qfcoef( upf%nqf, upf%nqlc, upf%nbeta, upf%nbeta ) ) - upf%rinner = 0.0_DP - upf%qqq = 0.0_DP - upf%qfunc = 0.0_DP - upf%qfcoef = 0.0_DP - endif - - - return - -100 call errore ('read_pseudo_nl', 'Reading pseudo file (BETA)', 1 ) -101 call errore ('read_pseudo_nl', 'Reading pseudo file (DIJ)', 2 ) -102 call errore ('read_pseudo_nl', 'Reading pseudo file (QIJ)', 3 ) -103 call errore ('read_pseudo_nl', 'Reading pseudo file (RINNER)',4) -104 call errore ('read_pseudo_nl', 'Reading pseudo file (qqq)', 5 ) -105 call errore ('read_pseudo_nl', 'Reading pseudo file (qfunc)',6 ) -106 call errore ('read_pseudo_nl', 'Reading pseudo file (qfcoef)',7) -end subroutine read_pseudo_nl - - -!--------------------------------------------------------------------- -subroutine read_pseudo_pswfc (upf, iunps) - !--------------------------------------------------------------------- - ! - USE kinds - USE pseudo_types, ONLY: pseudo_upf - ! - implicit none - ! - integer :: iunps - TYPE (pseudo_upf), INTENT(INOUT) :: upf - ! - character (len=75) :: dummy - integer :: nb, ir - - ALLOCATE( upf%chi( upf%mesh, MAX( upf%nwfc, 1 ) ) ) - upf%chi = 0.0_DP - do nb = 1, upf%nwfc - read (iunps, *, err=100, end=100) dummy !Wavefunction labels - read (iunps, *, err=100, end=100) ( upf%chi(ir,nb), ir=1,upf%mesh ) - enddo - - return - -100 call errore ('read_pseudo_pswfc', 'Reading pseudo file', 1) -end subroutine read_pseudo_pswfc - -!--------------------------------------------------------------------- -subroutine read_pseudo_rhoatom (upf, iunps) - !--------------------------------------------------------------------- - ! - USE kinds - USE pseudo_types, ONLY: pseudo_upf - ! - implicit none - ! - integer :: iunps - TYPE (pseudo_upf), INTENT(INOUT) :: upf - ! - integer :: ir - ! - ALLOCATE( upf%rho_at( upf%mesh ) ) - upf%rho_at = 0.0_DP - read (iunps,*,err=100,end=100) ( upf%rho_at(ir), ir=1,upf%mesh ) - ! - return - -100 call errore ('read_pseudo_rhoatom','Reading pseudo file', 1) -end subroutine read_pseudo_rhoatom -! -!--------------------------------------------------------------------- -subroutine read_pseudo_addinfo (upf, iunps) -!--------------------------------------------------------------------- -! -! This routine reads from the new UPF file, -! and the total angular momentum jjj of the beta and jchi of the -! wave-functions. -! - USE pseudo_types, ONLY: pseudo_upf - USE kinds - implicit none - integer :: iunps - - TYPE (pseudo_upf), INTENT(INOUT) :: upf - integer :: nb - - ALLOCATE( upf%nn(upf%nwfc) ) - ALLOCATE( upf%epseu(upf%nwfc), upf%jchi(upf%nwfc) ) - ALLOCATE( upf%jjj(upf%nbeta) ) - - upf%nn=0 - upf%epseu=0.0_DP - upf%jchi=0.0_DP - do nb = 1, upf%nwfc - read (iunps, *,err=100,end=100) upf%els(nb), & - upf%nn(nb), upf%lchi(nb), upf%jchi(nb), upf%oc(nb) - if ( abs ( upf%jchi(nb)-upf%lchi(nb)-0.5_dp ) > 1.0d-7 .and. & - abs ( upf%jchi(nb)-upf%lchi(nb)+0.5_dp ) > 1.0d-7 ) then - call infomsg ( 'read_pseudo_upf', 'obsolete ADDINFO section ignored') - upf%has_so = .false. - return - end if - enddo - - upf%jjj=0.0_DP - do nb = 1, upf%nbeta - read (iunps, *, err=100,end=100) upf%lll(nb), upf%jjj(nb) - if ( abs ( upf%lll(nb)-upf%jjj(nb)-0.5_dp) > 1.0d-7 .and. & - abs ( upf%lll(nb)-upf%jjj(nb)+0.5_dp) > 1.0d-7 ) then - call infomsg ( 'read_pseudo_upf', 'obsolete ADDINFO section ignored') - upf%has_so = .false. - return - end if - enddo - - read(iunps, *) upf%xmin, upf%rmax, upf%zmesh, upf%dx - upf%grid%dx = upf%dx - upf%grid%xmin = upf%xmin - upf%grid%zmesh= upf%zmesh - upf%grid%mesh = upf%mesh - - return -100 call errore ('read_pseudo_addinfo','Reading pseudo file', 1) -end subroutine read_pseudo_addinfo -! -!--------------------------------------------------------------------- -SUBROUTINE read_pseudo_gipaw ( upf, iunps ) - !--------------------------------------------------------------------- - ! - USE kinds - USE pseudo_types, ONLY : pseudo_upf - ! - implicit none - ! - INTEGER :: iunps - TYPE ( pseudo_upf ), INTENT ( INOUT ) :: upf - ! - - CALL scan_begin ( iunps, "GIPAW_FORMAT_VERSION", .false. ) - READ ( iunps, *, err=100, end=100 ) upf%gipaw_data_format - CALL scan_end ( iunps, "GIPAW_FORMAT_VERSION" ) - - IF ( upf%gipaw_data_format == 1 ) THEN - CALL read_pseudo_gipaw_core_orbitals ( upf, iunps ) - CALL read_pseudo_gipaw_local ( upf, iunps ) - CALL read_pseudo_gipaw_orbitals ( upf, iunps ) - ELSE - CALL errore ( 'read_pseudo_gipaw', 'UPF/GIPAW in unknown format', 1 ) - END IF - - RETURN - -100 CALL errore ( 'read_pseudo_gipaw', 'Reading pseudo file', 1 ) -END SUBROUTINE read_pseudo_gipaw - -!--------------------------------------------------------------------- -SUBROUTINE read_pseudo_gipaw_core_orbitals ( upf, iunps ) - !--------------------------------------------------------------------- - ! - USE kinds - USE pseudo_types, ONLY : pseudo_upf - ! - IMPLICIT NONE - ! - INTEGER :: iunps - TYPE ( pseudo_upf ), INTENT ( INOUT ) :: upf - ! - CHARACTER ( LEN = 75 ) :: dummy1, dummy2 - INTEGER :: nb, ir - - CALL scan_begin ( iunps, "GIPAW_CORE_ORBITALS", .false. ) - READ ( iunps, *, err=100, end=100 ) upf%gipaw_ncore_orbitals - - ALLOCATE ( upf%gipaw_core_orbital_n(upf%gipaw_ncore_orbitals) ) - ALLOCATE ( upf%gipaw_core_orbital_l(upf%gipaw_ncore_orbitals) ) - ALLOCATE ( upf%gipaw_core_orbital_el(upf%gipaw_ncore_orbitals) ) - ALLOCATE ( upf%gipaw_core_orbital(upf%mesh,upf%gipaw_ncore_orbitals) ) - upf%gipaw_core_orbital = 0.0_dp - - DO nb = 1, upf%gipaw_ncore_orbitals - CALL scan_begin ( iunps, "GIPAW_CORE_ORBITAL", .false. ) - READ (iunps, *, err=100, end=100) & - upf%gipaw_core_orbital_n(nb), upf%gipaw_core_orbital_l(nb), & - dummy1, dummy2, upf%gipaw_core_orbital_el(nb) - READ ( iunps, *, err=100, end=100 ) & - ( upf%gipaw_core_orbital(ir,nb), ir = 1, upf%mesh ) - CALL scan_end ( iunps, "GIPAW_CORE_ORBITAL" ) - END DO - - CALL scan_end ( iunps, "GIPAW_CORE_ORBITALS" ) - - RETURN - -100 CALL errore ( 'read_pseudo_gipaw_core_orbitals', 'Reading pseudo file', 1 ) -END SUBROUTINE read_pseudo_gipaw_core_orbitals - -!--------------------------------------------------------------------- -SUBROUTINE read_pseudo_gipaw_local ( upf, iunps ) - !--------------------------------------------------------------------- - ! - USE kinds - USE pseudo_types, ONLY : pseudo_upf - ! - IMPLICIT NONE - ! - INTEGER :: iunps - TYPE ( pseudo_upf ), INTENT ( INOUT ) :: upf - ! - INTEGER :: ir - - CALL scan_begin ( iunps, "GIPAW_LOCAL_DATA", .false. ) - - ALLOCATE ( upf%gipaw_vlocal_ae(upf%mesh) ) - ALLOCATE ( upf%gipaw_vlocal_ps(upf%mesh) ) - - CALL scan_begin ( iunps, "GIPAW_VLOCAL_AE", .false. ) - - READ ( iunps, *, err=100, end=100 ) & - ( upf%gipaw_vlocal_ae(ir), ir = 1, upf%mesh ) - - CALL scan_end ( iunps, "GIPAW_VLOCAL_AE" ) - - CALL scan_begin ( iunps, "GIPAW_VLOCAL_PS", .false. ) - - READ ( iunps, *, err=100, end=100 ) & - ( upf%gipaw_vlocal_ps(ir), ir = 1, upf%mesh ) - - CALL scan_end ( iunps, "GIPAW_VLOCAL_PS" ) - - CALL scan_end ( iunps, "GIPAW_LOCAL_DATA" ) - - RETURN - -100 CALL errore ( 'read_pseudo_gipaw_local', 'Reading pseudo file', 1 ) -END SUBROUTINE read_pseudo_gipaw_local - -!--------------------------------------------------------------------- -SUBROUTINE read_pseudo_gipaw_orbitals ( upf, iunps ) - !--------------------------------------------------------------------- - ! - USE kinds - USE pseudo_types, ONLY : pseudo_upf - ! - IMPLICIT NONE - ! - INTEGER :: iunps - TYPE ( pseudo_upf ), INTENT ( INOUT ) :: upf - ! - CHARACTER ( LEN = 75 ) :: dummy - INTEGER :: nb, ir - - CALL scan_begin ( iunps, "GIPAW_ORBITALS", .false. ) - READ ( iunps, *, err=100, end=100 ) upf%gipaw_wfs_nchannels - - ALLOCATE ( upf%gipaw_wfs_el(upf%gipaw_wfs_nchannels) ) - ALLOCATE ( upf%gipaw_wfs_ll(upf%gipaw_wfs_nchannels) ) - ALLOCATE ( upf%gipaw_wfs_rcut(upf%gipaw_wfs_nchannels) ) - ALLOCATE ( upf%gipaw_wfs_rcutus(upf%gipaw_wfs_nchannels) ) - ALLOCATE ( upf%gipaw_wfs_ae(upf%mesh,upf%gipaw_wfs_nchannels) ) - ALLOCATE ( upf%gipaw_wfs_ps(upf%mesh,upf%gipaw_wfs_nchannels) ) - - inquire ( unit = iunps, name = dummy ) - DO nb = 1, upf%gipaw_wfs_nchannels - CALL scan_begin ( iunps, "GIPAW_AE_ORBITAL", .false. ) - READ (iunps, *, err=100, end=100) & - upf%gipaw_wfs_el(nb), upf%gipaw_wfs_ll(nb) - READ ( iunps, *, err=100, end=100 ) & - ( upf%gipaw_wfs_ae(ir,nb), ir = 1, upf%mesh ) - CALL scan_end ( iunps, "GIPAW_AE_ORBITAL" ) - - CALL scan_begin ( iunps, "GIPAW_PS_ORBITAL", .false. ) - READ (iunps, *, err=100, end=100) & - upf%gipaw_wfs_rcut(nb), upf%gipaw_wfs_rcutus(nb) - READ ( iunps, *, err=100, end=100 ) & - ( upf%gipaw_wfs_ps(ir,nb), ir = 1, upf%mesh ) - CALL scan_end ( iunps, "GIPAW_PS_ORBITAL" ) - END DO - - CALL scan_end ( iunps, "GIPAW_ORBITALS" ) - - RETURN - -100 CALL errore ( 'read_pseudo_gipaw_orbitals', 'Reading pseudo file', 1 ) -END SUBROUTINE read_pseudo_gipaw_orbitals -! - -subroutine read_pseudo_ppinfo (upf, iunps) - !--------------------------------------------------------------------- - ! - USE pseudo_types, ONLY: pseudo_upf - USE kinds, ONLY : dp - - implicit none - ! - TYPE (pseudo_upf), INTENT(INOUT) :: upf - integer :: iunps - character (len=80) :: dummy - logical, external :: matches - real(dp) :: rdummy - integer :: idummy, nb, ios - - ios=0 - DO while (ios==0) - READ (iunps, '(a)', err = 100, end = 100, iostat=ios) dummy - IF (matches ("Rcut", dummy) ) THEN - DO nb=1,upf%nbeta - READ (iunps, '(a2,2i3,f6.2,3f19.11)',err=100, end=100,iostat=ios) & - upf%els_beta(nb), idummy, & - idummy, rdummy, upf%rcut(nb), upf%rcutus (nb), rdummy - ENDDO - ios=100 - ENDIF - ENDDO -100 RETURN - END SUBROUTINE read_pseudo_ppinfo - -!=----------------------------------------------------------------------------=! - END MODULE read_upf_v1_module -!=----------------------------------------------------------------------------=! diff --git a/quantum_espresso/kcp/Modules/read_upf_v2.f90 b/quantum_espresso/kcp/Modules/read_upf_v2.f90 deleted file mode 100644 index 339764462..000000000 --- a/quantum_espresso/kcp/Modules/read_upf_v2.f90 +++ /dev/null @@ -1,617 +0,0 @@ -! -! Copyright (C) 2008 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!=----------------------------------------------------------------------------=! - MODULE read_upf_v2_module -!=----------------------------------------------------------------------------=! -! this module handles the reading of pseudopotential data - -! ... declare modules - USE kinds, ONLY: DP - USE pseudo_types, ONLY: pseudo_upf - USE radial_grids, ONLY: radial_grid_type - USE parser, ONLY : version_compare - USE iotk_module - ! - PRIVATE - PUBLIC :: read_upf_v2 - CONTAINS - -!------------------------------------------------+ -SUBROUTINE read_upf_v2(u, upf, grid, ierr) ! - !---------------------------------------------+ - ! Read pseudopotential in UPF format version 2, uses iotk - ! - USE pseudo_types, ONLY: nullify_pseudo_upf, deallocate_pseudo_upf - USE radial_grids, ONLY: radial_grid_type, nullify_radial_grid - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data - TYPE(radial_grid_type),OPTIONAL,INTENT(INOUT),TARGET :: grid - ! - INTEGER,OPTIONAL,INTENT(OUT):: ierr ! /= 0 if something went wrong - CHARACTER(len=iotk_namlenx) :: root - CHARACTER(len=iotk_attlenx) :: attr - INTEGER :: ierr_ - LOGICAL :: found - LOGICAL,EXTERNAL :: matches - CHARACTER(len=6),PARAMETER :: max_version = '2.0.1' - ! - ! Prepare the type . Should be done where upf is instantiated - ! CALL deallocate_pseudo_upf(upf) - ! CALL nullify_pseudo_upf(upf) - ! - ! IF(present(grid)) call nullify_radial_grid(grid) - ! nullify(upf%grid) - ! - ! Initialize the file - CALL iotk_open_read(u, attr=attr, root=root, ierr=ierr_) - ! - IF((abs(ierr_)>0) .or. .not. matches('UPF',root) ) THEN - ! - CALL iotk_close_read(u,ierr=ierr) - IF(.not. present(ierr)) & - CALL errore('read_upf_v2','Cannot open UPF file.',1) - ierr = 1 - RETURN - ENDIF - - CALL iotk_scan_attr(attr, 'version', upf%nv) - IF (version_compare(upf%nv, max_version) == 'newer') & - CALL errore('read_upf_v2',& - 'Unknown UPF format version: '//TRIM(upf%nv),1) - ! - ! Skip human-readable header - CALL iotk_scan_begin(u,'PP_INFO',found=found) - if(found) CALL iotk_scan_end(u,'PP_INFO') - ! - ! Read machine-readable header - CALL read_header(u, upf) - IF(upf%tpawp .and. .not. present(grid)) & - CALL errore('read_upf_v2', 'PAW requires a radial_grid_type.', 1) - ! - ! CHECK for bug in version 2.0.0 of UPF file, occurring for ultrasoft pseudopotentials - IF ( version_compare(upf%nv, '2.0.1') == 'older' .and. upf%tvanp .and. & - .not. upf%tpawp ) CALL errore('read_upf_v2',& - 'Ultrasoft and PAW pseudopotential generated with & - & code version equal or older than QE 4.0.5 can contain & - & a bug compromising the quality of the calculation. & - & regenerate the pseudopotential file with a newer version & - & of the ld1 code!', 1) - - ! Read radial grid mesh - CALL read_mesh(u, upf, grid) - ! Read non-linear core correction charge - ALLOCATE( upf%rho_atc(upf%mesh) ) - IF(upf%nlcc) THEN - CALL iotk_scan_dat(u, 'PP_NLCC', upf%rho_atc) - ELSE - ! A null core charge simplifies several functions, mostly in PAW - upf%rho_atc(1:upf%mesh) = 0._dp - ENDIF - ! Read local potential - IF(.not. upf%tcoulombp) THEN - ALLOCATE( upf%vloc(upf%mesh) ) - CALL iotk_scan_dat(u, 'PP_LOCAL', upf%vloc) - ENDIF - ! Read nonlocal components: projectors, augmentation, hamiltonian elements - write(6,*) "read_nonlocal" !!!ddebug - CALL read_nonlocal(u, upf) - ! Read initial pseudo wavefunctions - ! (usually only wfcs with occupancy > 0) - CALL read_pswfc(u, upf) - ! Read all-electron and pseudo wavefunctions - CALL read_full_wfc(u, upf) - ! Read valence atomic density (used for initial density) - ALLOCATE( upf%rho_at(upf%mesh) ) - CALL iotk_scan_dat(u, 'PP_RHOATOM', upf%rho_at) - ! Read additional info for full-relativistic calculation - CALL read_spin_orb(u, upf) - ! Read additional data for PAW (All-electron charge, wavefunctions, vloc..) - CALL read_paw(u, upf) - ! Read data dor gipaw reconstruction - CALL read_gipaw(u, upf) - ! - ! Close the file (not the unit!) - CALL iotk_close_read(u) - - RETURN - - CONTAINS - ! - SUBROUTINE read_header(u, upf) - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data - INTEGER :: ierr ! /= 0 if something went wrong - CHARACTER(len=iotk_attlenx) :: attr - ! - INTEGER :: nw - ! - ! Read HEADER section with some initialization data - CALL iotk_scan_empty(u, 'PP_HEADER', attr=attr) - CALL iotk_scan_attr(attr, 'generated', upf%generated, default='') - CALL iotk_scan_attr(attr, 'author', upf%author, default='anonymous') - CALL iotk_scan_attr(attr, 'date', upf%date, default='') - CALL iotk_scan_attr(attr, 'comment', upf%comment, default='') - ! - CALL iotk_scan_attr(attr, 'element', upf%psd) - CALL iotk_scan_attr(attr, 'pseudo_type', upf%typ) - CALL iotk_scan_attr(attr, 'relativistic', upf%rel) - ! - CALL iotk_scan_attr(attr, 'is_ultrasoft', upf%tvanp) - CALL iotk_scan_attr(attr, 'is_paw', upf%tpawp) - CALL iotk_scan_attr(attr, 'is_coulomb', upf%tcoulombp, default=.false.) - ! - CALL iotk_scan_attr(attr, 'has_so', upf%has_so, default=.false.) - CALL iotk_scan_attr(attr, 'has_wfc', upf%has_wfc, default=upf%tpawp) - CALL iotk_scan_attr(attr, 'has_gipaw', upf%has_gipaw, default=.false.) - ! - CALL iotk_scan_attr(attr, 'core_correction',upf%nlcc) - CALL iotk_scan_attr(attr, 'functional', upf%dft) - CALL iotk_scan_attr(attr, 'z_valence', upf%zp) - CALL iotk_scan_attr(attr, 'total_psenergy', upf%etotps, default=0._dp) - CALL iotk_scan_attr(attr, 'wfc_cutoff', upf%ecutwfc, default=0._dp) - CALL iotk_scan_attr(attr, 'rho_cutoff', upf%ecutrho, default=0._dp) - CALL iotk_scan_attr(attr, 'l_max', upf%lmax) - CALL iotk_scan_attr(attr, 'l_max_rho', upf%lmax_rho, default=2*upf%lmax) - CALL iotk_scan_attr(attr, 'l_local', upf%lloc, default=0) - CALL iotk_scan_attr(attr, 'mesh_size', upf%mesh) - CALL iotk_scan_attr(attr, 'number_of_wfc', upf%nwfc) - CALL iotk_scan_attr(attr, 'number_of_proj', upf%nbeta) - ! - !CALL iotk_scan_end(u, 'PP_HEADER') - !CALL debug_pseudo_upf(upf) - ! - RETURN - END SUBROUTINE read_header - ! - SUBROUTINE read_mesh(u, upf, grid) - USE radial_grids, ONLY: allocate_radial_grid - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data - TYPE(radial_grid_type),OPTIONAL,INTENT(INOUT),TARGET :: grid - ! - INTEGER :: ierr ! /= 0 if something went wrong - CHARACTER(len=iotk_attlenx) :: attr - LOGICAL :: found - ! - CALL iotk_scan_begin(u, 'PP_MESH', attr=attr) - - CALL iotk_scan_attr(attr, 'dx', upf%dx, default=0._dp) - CALL iotk_scan_attr(attr, 'mesh', upf%mesh, default=upf%mesh) - CALL iotk_scan_attr(attr, 'xmin', upf%xmin, default=0._dp) - CALL iotk_scan_attr(attr, 'rmax', upf%rmax, default=0._dp) - CALL iotk_scan_attr(attr, 'zmesh',upf%zmesh, default=0._dp) - IF (present(grid)) THEN - CALL allocate_radial_grid(grid, upf%mesh) - ! - grid%dx = upf%dx - grid%mesh = upf%mesh - grid%xmin = upf%xmin - grid%rmax = upf%rmax - grid%zmesh = upf%zmesh - ! - upf%grid => grid - upf%r => upf%grid%r - upf%rab => upf%grid%rab - ELSE - ALLOCATE( upf%r( upf%mesh ), upf%rab( upf%mesh ) ) - ENDIF - ! - CALL iotk_scan_dat(u, 'PP_R', upf%r(1:upf%mesh)) - CALL iotk_scan_dat(u, 'PP_RAB', upf%rab(1:upf%mesh)) - ! - IF (present(grid)) THEN - ! Reconstruct additional grids - upf%grid%r2 = upf%r**2 - upf%grid%sqr = sqrt(upf%r) - upf%grid%rm1 = upf%r**(-1) - upf%grid%rm2 = upf%r**(-2) - upf%grid%rm3 = upf%r**(-3) - ENDIF - - CALL iotk_scan_end(u, 'PP_MESH') - ! - RETURN - END SUBROUTINE read_mesh - ! - SUBROUTINE read_nonlocal(u, upf) - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data - CHARACTER(len=iotk_attlenx) :: attr - ! - INTEGER :: nb,mb,ln,lm,l,nmb,ierr=0 - !INTEGER :: nb_=-1,mb_=-1,l_=-1,nmb_=-1 - REAL(DP):: zeros(upf%mesh) - LOGICAL :: isnull, found - zeros=0._dp - ! - ! modified by AF - !IF (upf%tcoulombp) RETURN - IF (upf%tcoulombp) upf%nbeta = 0 - ! - ! Allocate space for non-local part - IF ( upf%nbeta == 0) then - upf%nqf = 0 - upf%nqlc= 0 - upf%qqq_eps= -1._dp - upf%kkbeta = 0 - ALLOCATE( upf%kbeta(1), & - upf%lll(1), & - upf%beta(upf%mesh,1), & - upf%dion(1,1), & - upf%rinner(1), & - upf%qqq(1,1), & - upf%qfunc(upf%mesh,1),& - upf%qfcoef(1,1,1,1), & - upf%rcut(1), & - upf%rcutus(1), & - upf%els_beta(1) ) - ! - !CALL iotk_scan_end(u, 'PP_NONLOCAL') - RETURN - END IF - ! - ! - CALL iotk_scan_begin(u, 'PP_NONLOCAL') - ! - ALLOCATE( upf%kbeta(upf%nbeta), & - upf%lll(upf%nbeta), & - upf%beta(upf%mesh, upf%nbeta), & - upf%dion(upf%nbeta, upf%nbeta),& - upf%rcut(upf%nbeta), & - upf%rcutus(upf%nbeta), & - upf%els_beta(upf%nbeta) ) - - ! - ! Read the projectors: - DO nb = 1,upf%nbeta - CALL iotk_scan_dat(u, 'PP_BETA'//iotk_index( nb ), & - upf%beta(:,nb), attr=attr) - CALL iotk_scan_attr(attr, 'label', upf%els_beta(nb), default='Xn') - CALL iotk_scan_attr(attr, 'angular_momentum', upf%lll(nb)) - CALL iotk_scan_attr(attr, 'cutoff_radius_index', upf%kbeta(nb), default=upf%mesh) - CALL iotk_scan_attr(attr, 'cutoff_radius', upf%rcut(nb), default=0._dp) - CALL iotk_scan_attr(attr, 'norm_conserving_radius', upf%rcutus(nb), default=0._dp) - ENDDO - ! - ! Read the hamiltonian terms D_ij - CALL iotk_scan_dat(u, 'PP_DIJ', upf%dion, attr=attr) - ! CALL iotk_scan_attr(attr, 'non_zero_elements', upf%nd) - ! - ! Read the augmentation charge section - augmentation : & - IF(upf%tvanp .or. upf%tpawp) THEN - ! - CALL iotk_scan_begin(u, 'PP_AUGMENTATION', attr=attr) - CALL iotk_scan_attr(attr, 'q_with_l', upf%q_with_l) - CALL iotk_scan_attr(attr, 'nqf', upf%nqf) - CALL iotk_scan_attr(attr, 'nqlc', upf%nqlc, default=2*upf%lmax+1) - IF (upf%tpawp) THEN - CALL iotk_scan_attr(attr,'shape', upf%paw%augshape, default='UNKNOWN') - CALL iotk_scan_attr(attr,'cutoff_r', upf%paw%raug, default=0._dp) - CALL iotk_scan_attr(attr,'cutoff_r_index', upf%paw%iraug, default=upf%mesh) - CALL iotk_scan_attr(attr,'l_max_aug', upf%paw%lmax_aug, default=upf%lmax_rho) - ENDIF - ! a negative number means that all qfunc are stored - CALL iotk_scan_attr(attr,'augmentation_epsilon',upf%qqq_eps, default=-1._dp) - ! - ALLOCATE( upf%rinner( upf%nqlc ) ) - ALLOCATE( upf%qqq ( upf%nbeta, upf%nbeta ) ) - write(6,*) "q_with_l", upf%q_with_l, upf%mesh, upf%nbeta - IF ( upf%q_with_l ) THEN - ALLOCATE( upf%qfuncl ( upf%mesh, upf%nbeta*(upf%nbeta+1)/2, 0:2*upf%lmax ) ) - upf%qfuncl=0._dp - ELSE - ALLOCATE( upf%qfunc (upf%mesh, upf%nbeta*(upf%nbeta+1)/2) ) - ENDIF - ! - ! Read the integrals of the Q functions - CALL iotk_scan_dat(u, 'PP_Q',upf%qqq ) - ! - ! read charge multipoles (only if PAW) - IF( upf%tpawp ) THEN - ALLOCATE(upf%paw%augmom(upf%nbeta,upf%nbeta, 0:2*upf%lmax)) - CALL iotk_scan_dat(u, 'PP_MULTIPOLES', upf%paw%augmom) - ENDIF - ! - ! Read polinomial coefficients for Q_ij expansion at small radius - IF(upf%nqf <= 0) THEN - upf%rinner(:) = 0._dp - ALLOCATE( upf%qfcoef(1,1,1,1) ) - upf%qfcoef = 0._dp - ELSE - ALLOCATE( upf%qfcoef( MAX( upf%nqf,1 ), upf%nqlc, upf%nbeta, upf%nbeta ) ) - CALL iotk_scan_dat(u, 'PP_QFCOEF',upf%qfcoef, attr=attr) - CALL iotk_scan_dat(u, 'PP_RINNER',upf%rinner, attr=attr) - ENDIF - ! - ! Read augmentation charge Q_ij - ultrasoft_or_paw : & - IF( upf%tvanp) THEN - DO nb = 1,upf%nbeta - ln = upf%lll(nb) - DO mb = nb,upf%nbeta - lm = upf%lll(mb) - nmb = mb * (mb-1) /2 + nb - q_with_l : & - IF( upf%q_with_l ) THEN - DO l = abs(ln-lm),ln+lm,2 ! only even terms - CALL iotk_scan_dat(u, 'PP_QIJL'//iotk_index((/nb,mb,l/)),& - upf%qfuncl(:,nmb,l),default=zeros,attr=attr) - ENDDO - ELSE q_with_l - CALL iotk_scan_dat(u, 'PP_QIJ'//iotk_index((/nb,mb/)),& - upf%qfunc(:,nmb),attr=attr,default=zeros) - ENDIF q_with_l - ENDDO - ENDDO - ! - ENDIF ultrasoft_or_paw - ! - CALL iotk_scan_end(u, 'PP_AUGMENTATION') - ! - ENDIF augmentation - ! - ! Maximum radius of beta projector: outer radius to integrate - upf%kkbeta = MAXVAL(upf%kbeta(1:upf%nbeta)) - ! For PAW augmentation charge may extend a bit further: - IF(upf%tpawp) upf%kkbeta = MAX(upf%kkbeta, upf%paw%iraug) - ! - CALL iotk_scan_end(u, 'PP_NONLOCAL') - ! - RETURN - END SUBROUTINE read_nonlocal - ! - SUBROUTINE read_pswfc(u, upf) - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data - INTEGER :: ierr ! /= 0 if something went wrong - CHARACTER(len=iotk_attlenx) :: attr - ! - INTEGER :: nw - ! - CALL iotk_scan_begin(u, 'PP_PSWFC') - ! - ALLOCATE( upf%chi(upf%mesh,upf%nwfc) ) - ALLOCATE( upf%els(upf%nwfc), & - upf%oc(upf%nwfc), & - upf%lchi(upf%nwfc), & - upf%nchi(upf%nwfc), & - upf%rcut_chi(upf%nwfc), & - upf%rcutus_chi(upf%nwfc), & - upf%epseu(upf%nwfc) & - ) - ! - DO nw = 1,upf%nwfc - CALL iotk_scan_dat(u, 'PP_CHI'//iotk_index(nw), & - upf%chi(:,nw), attr=attr) - CALL iotk_scan_attr(attr, 'label', upf%els(nw), default='Xn') - CALL iotk_scan_attr(attr, 'l', upf%lchi(nw)) - CALL iotk_scan_attr(attr, 'occupation', upf%oc(nw)) - CALL iotk_scan_attr(attr, 'n', upf%nchi(nw), default=upf%lchi(nw)-1) - CALL iotk_scan_attr(attr, 'pseudo_energy', upf%epseu(nw), default=0._dp) - CALL iotk_scan_attr(attr, 'cutoff_radius', upf%rcut_chi(nw),default=0._dp) - CALL iotk_scan_attr(attr, 'ultrasoft_cutoff_radius', upf%rcutus_chi(nw),default=0._dp) - ENDDO - ! - CALL iotk_scan_end(u, 'PP_PSWFC') - ! - RETURN - END SUBROUTINE read_pswfc - - SUBROUTINE read_full_wfc(u, upf) - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data - INTEGER :: ierr ! /= 0 if something went wrong - CHARACTER(len=iotk_attlenx) :: attr - ! - INTEGER :: nb - ! - IF(.not. upf%has_wfc) RETURN - ! - CALL iotk_scan_begin(u, 'PP_FULL_WFC') - ! - ALLOCATE( upf%aewfc(upf%mesh, upf%nbeta) ) - DO nb = 1,upf%nbeta - CALL iotk_scan_dat(u, 'PP_AEWFC'//iotk_index(nb), & - upf%aewfc(:,nb), attr=attr) - ENDDO - - ALLOCATE( upf%pswfc(upf%mesh, upf%nbeta) ) - DO nb = 1,upf%nbeta - CALL iotk_scan_dat(u, 'PP_PSWFC'//iotk_index(nb), & - upf%pswfc(:,nb), attr=attr) - ENDDO - CALL iotk_scan_end(u, 'PP_FULL_WFC') - ! - END SUBROUTINE read_full_wfc - - ! - SUBROUTINE read_spin_orb(u, upf) - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data - INTEGER :: ierr ! /= 0 if something went wrong - - CHARACTER(len=iotk_attlenx) :: attr - ! - INTEGER :: nw, nb - ! - IF (.not. upf%has_so) RETURN - ! - CALL iotk_scan_begin(u, 'PP_SPIN_ORB') - ! - ALLOCATE (upf%nn(upf%nwfc)) - ALLOCATE (upf%jchi(upf%nwfc)) - ! - DO nw = 1,upf%nwfc - CALL iotk_scan_empty(u, 'PP_RELWFC'//iotk_index(nw),& - attr=attr) - !CALL iotk_scan_attr(attr, 'els', upf%els(nw)) ! already read - CALL iotk_scan_attr(attr, 'nn', upf%nn(nw)) - !CALL iotk_scan_attr(attr, 'lchi', upf%lchi(nw)) ! already read - CALL iotk_scan_attr(attr, 'jchi', upf%jchi(nw)) - !CALL iotk_scan_attr(attr, 'oc', upf%oc(nw)) ! already read - ENDDO - ! - ALLOCATE(upf%jjj(upf%nbeta)) - ! - DO nb = 1,upf%nbeta - CALL iotk_scan_empty(u, 'PP_RELBETA'//iotk_index(nb),& - attr=attr) - CALL iotk_scan_attr(attr, 'lll', upf%lll(nb)) - CALL iotk_scan_attr(attr, 'jjj', upf%jjj(nb)) - ENDDO - ! - CALL iotk_scan_end(u, 'PP_SPIN_ORB') - ! - RETURN - END SUBROUTINE read_spin_orb - ! - SUBROUTINE read_paw(u, upf) - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data - INTEGER :: ierr ! /= 0 if something went wrong - - ! - CHARACTER(len=iotk_attlenx) :: attr - ! - INTEGER :: nb,nb1 - - IF (.not. upf%tpawp ) RETURN - - CALL iotk_scan_begin(u, 'PP_PAW', attr=attr) - CALL iotk_scan_attr(attr, 'paw_data_format', upf%paw_data_format) - IF(upf%paw_data_format /= 2) & - CALL errore('read_upf_v1::read_paw',& - 'Unknown format of PAW data.',1) - CALL iotk_scan_attr(attr, 'core_energy', upf%paw%core_energy, default=0._dp) - ! - ! Full occupation (not only > 0 ones) - ALLOCATE( upf%paw%oc(upf%nbeta) ) - CALL iotk_scan_dat(u, 'PP_OCCUPATIONS',upf%paw%oc) - ! - ! All-electron core charge - ALLOCATE( upf%paw%ae_rho_atc(upf%mesh) ) - CALL iotk_scan_dat(u, 'PP_AE_NLCC', upf%paw%ae_rho_atc) - ! - ! All-electron local potential - ALLOCATE( upf%paw%ae_vloc(upf%mesh) ) - CALL iotk_scan_dat(u, 'PP_AE_VLOC', upf%paw%ae_vloc) - ! - ALLOCATE(upf%paw%pfunc(upf%mesh, upf%nbeta,upf%nbeta) ) - upf%paw%pfunc(:,:,:) = 0._dp - DO nb=1,upf%nbeta - DO nb1=1,nb - upf%paw%pfunc (1:upf%mesh, nb, nb1) = & - upf%aewfc(1:upf%mesh, nb) * upf%aewfc(1:upf%mesh, nb1) - upf%paw%pfunc(upf%paw%iraug+1:,nb,nb1) = 0._dp - ! - upf%paw%pfunc (1:upf%mesh, nb1, nb) = upf%paw%pfunc (1:upf%mesh, nb, nb1) - ENDDO - ENDDO - ! - ! Pseudo wavefunctions (not only the ones for oc > 0) - ! All-electron wavefunctions - ALLOCATE(upf%paw%ptfunc(upf%mesh, upf%nbeta,upf%nbeta) ) - upf%paw%ptfunc(:,:,:) = 0._dp - DO nb=1,upf%nbeta - DO nb1=1,upf%nbeta - upf%paw%ptfunc (1:upf%mesh, nb, nb1) = & - upf%pswfc(1:upf%mesh, nb) * upf%pswfc(1:upf%mesh, nb1) - upf%paw%ptfunc(upf%paw%iraug+1:,nb,nb1) = 0._dp - ! - upf%paw%ptfunc (1:upf%mesh, nb1, nb) = upf%paw%ptfunc (1:upf%mesh, nb, nb1) - ENDDO - ENDDO - ! - ! Finalize - CALL iotk_scan_end(u, 'PP_PAW') - - RETURN - END SUBROUTINE read_paw -! - SUBROUTINE read_gipaw(u, upf) - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data - INTEGER :: ierr ! /= 0 if something went wrong - ! - CHARACTER(len=iotk_attlenx) :: attr - ! - INTEGER :: nb - IF (.not. upf%has_gipaw ) RETURN - - CALL iotk_scan_begin(u, 'PP_GIPAW', attr=attr) - CALL iotk_scan_attr(attr, 'gipaw_data_format', upf%gipaw_data_format) - IF(upf%gipaw_data_format /= 2) & - CALL infomsg('read_upf_v2::read_gipaw','Unknown format version') - ! - CALL iotk_scan_begin(u, 'PP_GIPAW_CORE_ORBITALS', attr=attr) - CALL iotk_scan_attr(attr, 'number_of_core_orbitals', upf%gipaw_ncore_orbitals) - ALLOCATE ( upf%gipaw_core_orbital_n(upf%gipaw_ncore_orbitals) ) - ALLOCATE ( upf%gipaw_core_orbital_el(upf%gipaw_ncore_orbitals) ) - ALLOCATE ( upf%gipaw_core_orbital_l(upf%gipaw_ncore_orbitals) ) - ALLOCATE ( upf%gipaw_core_orbital(upf%mesh,upf%gipaw_ncore_orbitals) ) - DO nb = 1,upf%gipaw_ncore_orbitals - CALL iotk_scan_dat(u, 'PP_GIPAW_CORE_ORBITAL'//iotk_index(nb), & - upf%gipaw_core_orbital(:,nb), attr=attr) - CALL iotk_scan_attr(attr, 'label', upf%gipaw_core_orbital_el(nb)) - CALL iotk_scan_attr(attr, 'n', upf%gipaw_core_orbital_n(nb)) - CALL iotk_scan_attr(attr, 'l', upf%gipaw_core_orbital_l(nb)) - ENDDO - CALL iotk_scan_end(u, 'PP_GIPAW_CORE_ORBITALS') - ! - ! Read valence all-electron and pseudo orbitals and their labels - CALL iotk_scan_begin(u, 'PP_GIPAW_ORBITALS', attr=attr) - CALL iotk_scan_attr(attr, 'number_of_valence_orbitals', upf%gipaw_wfs_nchannels) - ALLOCATE ( upf%gipaw_wfs_el(upf%gipaw_wfs_nchannels) ) - ALLOCATE ( upf%gipaw_wfs_ll(upf%gipaw_wfs_nchannels) ) - ALLOCATE ( upf%gipaw_wfs_rcut(upf%gipaw_wfs_nchannels) ) - ALLOCATE ( upf%gipaw_wfs_rcutus(upf%gipaw_wfs_nchannels) ) - ALLOCATE ( upf%gipaw_wfs_ae(upf%mesh,upf%gipaw_wfs_nchannels) ) - ALLOCATE ( upf%gipaw_wfs_ps(upf%mesh,upf%gipaw_wfs_nchannels) ) - ! - DO nb = 1,upf%gipaw_wfs_nchannels - CALL iotk_scan_begin(u, 'PP_GIPAW_ORBITAL'//iotk_index(nb), attr=attr) - CALL iotk_scan_attr(attr, 'label', upf%gipaw_wfs_el(nb)) - CALL iotk_scan_attr(attr, 'l', upf%gipaw_wfs_ll(nb)) - CALL iotk_scan_attr(attr, 'cutoff_radius', upf%gipaw_wfs_rcut(nb)) - CALL iotk_scan_attr(attr, 'ultrasoft_cutoff_radius', upf%gipaw_wfs_rcutus(nb),& - default=upf%gipaw_wfs_rcut(nb)) - ! read all-electron orbital - CALL iotk_scan_dat(u, 'PP_GIPAW_WFS_AE', upf%gipaw_wfs_ae(:,nb)) - ! read pseudo orbital - CALL iotk_scan_dat(u, 'PP_GIPAW_WFS_PS', upf%gipaw_wfs_ps(:,nb)) - ! - CALL iotk_scan_end(u, 'PP_GIPAW_ORBITAL'//iotk_index(nb)) - ENDDO - CALL iotk_scan_end(u, 'PP_GIPAW_ORBITALS') - ! - ! Read all-electron and pseudo local potentials - ALLOCATE ( upf%gipaw_vlocal_ae(upf%mesh) ) - ALLOCATE ( upf%gipaw_vlocal_ps(upf%mesh) ) - CALL iotk_scan_begin(u, 'PP_GIPAW_VLOCAL') - CALL iotk_scan_dat(u, 'PP_GIPAW_VLOCAL_AE',upf%gipaw_vlocal_ae(:)) - CALL iotk_scan_dat(u, 'PP_GIPAW_VLOCAL_PS',upf%gipaw_vlocal_ae(:)) - CALL iotk_scan_end(u, 'PP_GIPAW_VLOCAL') - ! - CALL iotk_scan_end(u, 'PP_GIPAW') - - RETURN - END SUBROUTINE read_gipaw -! -END SUBROUTINE read_upf_v2 -! -END MODULE read_upf_v2_module diff --git a/quantum_espresso/kcp/Modules/read_uspp.f90 b/quantum_espresso/kcp/Modules/read_uspp.f90 deleted file mode 100644 index 1bfac6ebb..000000000 --- a/quantum_espresso/kcp/Modules/read_uspp.f90 +++ /dev/null @@ -1,823 +0,0 @@ -! -! Copyright (C) 2006-2007 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!--------------------------------------------------------------------- -MODULE read_uspp_module - !--------------------------------------------------------------------- - ! - ! routines reading ultrasoft pseudopotentials in older formats: - ! Vanderbilt's code and Andrea's RRKJ3 format - ! - USE kinds, ONLY: DP - USE parameters, ONLY: lmaxx, lqmax - USE io_global, ONLY: stdout - USE funct, ONLY: set_dft_from_name, dft_is_hybrid, dft_is_meta, & - set_dft_from_indices - ! - ! Variables above are not modified, variables below are - ! - USE uspp_param, ONLY: oldvan - ! - IMPLICIT NONE - SAVE - PRIVATE - PUBLIC :: readvan, readrrkj - ! -CONTAINS - !--------------------------------------------------------------------- - subroutine readvan( iunps, is, upf ) - !--------------------------------------------------------------------- - ! - ! Read Vanderbilt pseudopotential from unit "iunps" - ! for species "is" into the structure "upf" - ! info on DFT level in module "funct" - ! - ! ------------------------------------------------------ - ! Important: - ! ------------------------------------------------------ - ! The order of all l-dependent objects is always s,p,d - ! ------------------------------------------------------ - ! potentials, e.g. vloc_at, are really r*v(r) - ! wave funcs, e.g. chi, are really proportional to r*psi(r) - ! and are normalized so int (chi**2) dr = 1 - ! thus psi(r-vec)=(1/r)*chi(r)*y_lm(theta,phi) - ! conventions carry over to beta, etc - ! charge dens, e.g. rho_atc, really 4*pi*r**2*rho - ! - ! ------------------------------------------------------ - ! Notes on qfunc and qfcoef: - ! ------------------------------------------------------ - ! Since Q_ij(r) is the product of two orbitals like - ! psi_{l1,m1}^star * psi_{l2,m2}, it can be decomposed by - ! total angular momentum L, where L runs over | l1-l2 | , - ! | l1-l2 | +2 , ... , l1+l2. (L=0 is the only component - ! needed by the atomic program, which assumes spherical - ! charge symmetry.) - ! - ! Recall qfunc(r) = y1(r) * y2(r) where y1 and y2 are the - ! radial parts of the wave functions defined according to - ! - ! psi(r-vec) = (1/r) * y(r) * Y_lm(r-hat) . - ! - ! For each total angular momentum L, we pseudize qfunc(r) - ! inside rc as: - ! - ! qfunc(r) = r**(L+2) * [ a_1 + a_2*r**2 + a_3*r**4 ] - ! - ! in such a way as to match qfunc and its 1'st derivative at - ! rc, and to preserve - ! - ! integral dr r**L * qfunc(r) , - ! - ! i.e., to preserve the L'th moment of the charge. The array - ! qfunc has been set inside rc to correspond to this pseudized - ! version using the minimal L, namely L = | l1-l2 | (e.g., L=0 - ! for diagonal elements). The coefficients a_i (i=1,2,3) - ! are stored in the array qfcoef(i,L+1,j,k) for each L so that - ! the correctly pseudized versions of qfunc can be reconstructed - ! for each L. (Note that for given l1 and l2, only the values - ! L = | l1-l2 | , | l1-l2 | +2 , ... , l1+l2 are ever used.) - ! ------------------------------------------------------ - ! - USE constants, ONLY : fpi - USE pseudo_types - ! - implicit none - ! - ! First the arguments passed to the subroutine - ! - TYPE (pseudo_upf) :: upf - integer & - & is, &! The number of the pseudopotential - & iunps ! The unit of the pseudo file - ! - ! Local variables - - real(DP) & - & exfact, &! index of the exchange and correlation used - & etotpseu, &! total pseudopotential energy - & eloc, &! energy of the local potential - & dummy, &! dummy real variable - & rinner1, &! rinner if only one is present - & rcloc ! the cut-off radius of the local potential - real(DP), allocatable:: & - & ee(:), &! the energy of the valence states - & rc(:), &! the cut-off radii of the pseudopotential - & eee(:), &! energies of the beta function - & ddd(:,:) ! the screened D_{\mu,\nu} parameters - integer, allocatable :: & - & nnlz(:), &! The nlm values of the valence states - & iptype(:) ! more recent parameters - integer & - & iver(3), &! contains the version of generating code - & idmy(3), &! contains the date of creation of the pseudo - & ifpcor, &! for core correction, 0 otherwise - & ios, &! integer variable for I/O control - & i, &! dummy counter - & keyps, &! the type of pseudopotential. Only US allowed - & irel, &! says if the pseudopotential is relativistic - & ifqopt, &! level of Q optimization - & npf, &! as above - & nang, &! number of angular momenta in pseudopotentials - & lloc, &! angular momentum of the local part of PPs - & lp, &! counter on Q angular momenta - & l, &! counter on angular momenta - & iv, jv, ijv, &! beta function counter - & ir ! mesh points counter - ! - character(len=20) :: title - character(len=60) fmt - ! - ! We first check the input variables - ! - if (is <= 0) & - call errore('readvan','routine called with wrong 1st argument', 1) - if (iunps <= 0 .or. iunps >= 100000) & - call errore('readvan','routine called with wrong 2nd argument', 1) - ! - read(iunps, *, err=100 ) & - (iver(i),i=1,3), (idmy(i),i=1,3) - write(upf%generated, & - "('Generated by Vanderbilt code, v. ',i1,'.',i1,'.',i1)") iver - ! - if ( iver(1) > 7 .or. iver(1) < 1 .or. & - iver(2) > 9 .or. iver(2) < 0 .or. & - iver(3) > 9 .or. iver(3) < 0 ) & - call errore('readvan','wrong file version read',1) - ! - read( iunps, '(a20,3f15.9)', err=100, iostat=ios ) & - title, upf%zmesh, upf%zp, exfact - ! - upf%psd = title(1:2) - ! - if ( upf%zmesh < 1 .or. upf%zmesh > 100.0_DP) & - call errore( 'readvan','wrong zmesh read', is ) - if ( upf%zp <= 0.0_DP .or. upf%zp > 100.0_DP) & - call errore('readvan','wrong atomic charge read', is ) - if ( exfact < -6 .or. exfact > 6) & - & call errore('readvan','Wrong xc in pseudopotential',1) - ! convert from "our" conventions to Vanderbilt conventions - call dftname_cp (nint(exfact), upf%dft) - call set_dft_from_name( upf%dft ) -#if !defined (EXX) - IF ( dft_is_hybrid() ) & - CALL errore( 'readvan', 'HYBRID XC not implemented', 1 ) -#endif - IF ( dft_is_meta() ) & - CALL errore( 'readvan ', 'META-GGA not implemented', 1 ) - ! - read( iunps, '(2i5,1pe19.11)', err=100, iostat=ios ) & - upf%nwfc, upf%mesh, etotpseu - if ( upf%nwfc < 0 ) & - call errore( 'readvan', 'wrong nchi read', upf%nwfc ) - if ( upf%mesh < 0 ) & - call errore( 'readvan','wrong mesh', is ) - ! - ! info on pseudo eigenstates - energies are not used - ! - ALLOCATE ( upf%oc(upf%nwfc), upf%lchi(upf%nwfc) ) - ALLOCATE ( nnlz(upf%nwfc), ee(upf%nwfc) ) - read( iunps, '(i5,2f15.9)', err=100, iostat=ios ) & - ( nnlz(iv), upf%oc(iv), ee(iv), iv=1,upf%nwfc ) - do iv = 1, upf%nwfc - i = nnlz(iv) / 100 - upf%lchi(iv) = nnlz(iv)/10 - i * 10 - enddo - read( iunps, '(2i5,f15.9)', err=100, iostat=ios ) & - keyps, ifpcor, rinner1 - upf%nlcc = (ifpcor == 1) - ! - ! keyps= 0 --> standard hsc pseudopotential with exponent 4.0 - ! 1 --> standard hsc pseudopotential with exponent 3.5 - ! 2 --> vanderbilt modifications using defaults - ! 3 --> new generalized eigenvalue pseudopotentials - ! 4 --> frozen core all-electron case - if ( keyps < 0 .or. keyps > 4 ) then - call errore('readvan','wrong keyps',keyps) - else if (keyps == 4) then - call errore('readvan','keyps not implemented',keyps) - end if - upf%tvanp = (keyps == 3) - upf%tpawp = .false. - ! - ! Read information on the angular momenta, and on Q pseudization - ! (version > 3.0) - ! - if (iver(1) >= 3) then - read( iunps, '(2i5,f9.5,2i5,f9.5)', err=100, iostat=ios ) & - nang, lloc, eloc, ifqopt, upf%nqf, dummy -!!! PWSCF: lmax(is)=nang, lloc(is)=lloc - ! - ! NB: In the Vanderbilt atomic code the angular momentum goes - ! from 1 to nang - ! - if ( nang < 0 ) & - call errore(' readvan', 'Wrong nang read', nang) - if ( lloc == -1 ) lloc = nang+1 - if ( lloc > nang+1 .or. lloc < 0 ) & - call errore( 'readvan', 'wrong lloc read', is ) - if ( upf%nqf < 0 ) & - call errore(' readvan', 'Wrong nqf read', upf%nqf) - if ( ifqopt < 0 ) & - call errore( 'readvan', 'wrong ifqopt read', is ) - else - ! old format: no distinction between nang and nchi - nang = upf%nwfc - end if - ! - ! Read and test the values of rinner (version > 5.1) - ! rinner = radius at which to cut off partial core or q_ij - ! - ALLOCATE ( upf%rinner(2*nang-1) ) - if (10*iver(1)+iver(2) >= 51) then - ! - read( iunps, *, err=100, iostat=ios ) & - (upf%rinner(lp), lp=1,2*nang-1 ) - ! - do lp = 1, 2*nang-1 - if (upf%rinner(lp) < 0.0_DP) & - call errore('readvan','Wrong rinner read', is ) - enddo - else if (iver(1) > 3) then - do lp = 2, 2*nang-1 - upf%rinner(lp)=rinner1 - end do - end if - ! - if (iver(1) >= 4) & - read( iunps, '(i5)',err=100, iostat=ios ) irel - ! - ! set the number of angular momentum terms in q_ij to read in - ! - if (iver(1) == 1) then - oldvan(is) = .TRUE. - ! old format: no optimization of q_ij => 3-term taylor series - upf%nqf=3 - upf%nqlc=5 - else if (iver(1) == 2) then - upf%nqf=3 - upf%nqlc = 2*nang - 1 - else - upf%nqlc = 2*nang - 1 - end if - ! - if ( upf%nqlc > lqmax .or. upf%nqlc < 0 ) & - call errore(' readvan', 'Wrong nqlc read', upf%nqlc ) - ! - ALLOCATE ( rc(nang) ) - read( iunps, '(1p4e19.11)', err=100, iostat=ios ) & - ( rc(l), l=1,nang ) - ! - ! reads the number of beta functions - ! - read( iunps, '(2i5)', err=100, iostat=ios ) & - upf%nbeta, upf%kkbeta - ! - ALLOCATE ( upf%kbeta(upf%nbeta) ) - upf%kbeta(:) = upf%kkbeta - ! - if( upf%nbeta < 0 ) & - call errore( 'readvan','nbeta wrong', is ) - if( upf%kkbeta > upf%mesh .or. upf%kkbeta < 0 ) & - call errore( 'readvan','kkbeta wrong or too large', is ) - ! - ! Now reads the main Vanderbilt parameters - ! - ALLOCATE ( upf%lll(upf%nbeta) ) - ALLOCATE ( upf%beta(upf%mesh,upf%nbeta) ) - ALLOCATE ( upf%dion(upf%nbeta,upf%nbeta), upf%qqq(upf%nbeta,upf%nbeta) ) -! write(6,*) "allocating qfunc", upf%mesh -! stop - ALLOCATE ( upf%qfunc(upf%mesh,upf%nbeta*(upf%nbeta+1)/2) ) - ALLOCATE ( upf%qfcoef(upf%nqf, upf%nqlc, upf%nbeta, upf%nbeta) ) - ALLOCATE ( eee(upf%nbeta), ddd(upf%nbeta,upf%nbeta) ) - do iv=1,upf%nbeta - read( iunps, '(i5)',err=100, iostat=ios ) upf%lll(iv) - read( iunps, '(1p4e19.11)',err=100, iostat=ios ) & - eee(iv), ( upf%beta(ir,iv), ir=1,upf%kkbeta ) - do ir=upf%kkbeta+1,upf%mesh - upf%beta(ir,iv)=0.0_DP - enddo - if ( upf%lll(iv) > lmaxx .or. upf%lll(iv) < 0 ) & - call errore( 'readvan', 'lll wrong or too large ', is ) - do jv=iv,upf%nbeta - ! - ! the symmetric matric Q_{nb,mb} is stored in packed form - ! Q(iv,jv) => qfunc(ijv) as defined below (for jv >= iv) - ! - ijv = jv * (jv-1) / 2 + iv - read( iunps, '(1p4e19.11)', err=100, iostat=ios ) & - upf%dion(iv,jv), ddd(iv,jv), upf%qqq(iv,jv), & - (upf%qfunc(ir,ijv),ir=1,upf%kkbeta), & - ((upf%qfcoef(i,lp,iv,jv),i=1,upf%nqf),lp=1,upf%nqlc) - do ir=upf%kkbeta+1,upf%mesh - upf%qfunc(ir,ijv)=0.0_DP - enddo - ! - ! Use the symmetry of the coefficients - ! - if ( iv /= jv ) then - upf%dion(jv,iv)=upf%dion(iv,jv) - upf%qqq(jv,iv) =upf%qqq(iv,jv) - upf%qfcoef(:,:,jv,iv)=upf%qfcoef(:,:,iv,jv) - end if - enddo - enddo - ! - ! Set additional, not present, variables to dummy values - ALLOCATE(upf%els(upf%nwfc)) - upf%els(:) = 'nX' - ALLOCATE(upf%els_beta(upf%nbeta)) - upf%els_beta(:) = 'nX' - ALLOCATE(upf%rcut(upf%nbeta), upf%rcutus(upf%nbeta)) - upf%rcut(:) = 0._dp - upf%rcutus(:) = 0._dp - - DEALLOCATE (ddd) - ! - ! for versions later than 7.2 - ! - if (10*iver(1)+iver(2) >= 72) then - ALLOCATE (iptype(upf%nbeta)) - read( iunps, '(6i5)',err=100, iostat=ios ) & - (iptype(iv), iv=1,upf%nbeta) - read( iunps, '(i5,f15.9)',err=100, iostat=ios ) & - npf, dummy - DEALLOCATE (iptype) - end if - ! - ! read the local potential - ! - ALLOCATE ( upf%vloc(upf%mesh) ) - read( iunps, '(1p4e19.11)',err=100, iostat=ios ) & - rcloc, ( upf%vloc(ir), ir=1,upf%mesh ) - ! - ! If present reads the core charge rho_atc(r)=4*pi*r**2*rho_core(r) - ! - if ( upf%nlcc ) then - ALLOCATE ( upf%rho_atc(upf%mesh) ) - if (iver(1) >= 7) & - read( iunps, '(1p4e19.11)', err=100, iostat=ios ) dummy - read( iunps, '(1p4e19.11)', err=100, iostat=ios ) & - ( upf%rho_atc(ir), ir=1,upf%mesh ) - endif - ! - ! Read the screened local potential (not used) - ! - ALLOCATE ( upf%rho_at(upf%mesh) ) - read( iunps, '(1p4e19.11)', err=100, iostat=ios ) & - (upf%rho_at(ir), ir=1,upf%mesh) - ! - ! Read the valence atomic charge - ! - read( iunps, '(1p4e19.11)', err=100, iostat=ios ) & - (upf%rho_at(ir), ir=1,upf%mesh) - ! - ! Read the logarithmic mesh (if version > 1) - ! - ALLOCATE ( upf%r(upf%mesh), upf%rab(upf%mesh) ) - if (iver(1) >1) then - read( iunps, '(1p4e19.11)',err=100, iostat=ios ) & - (upf%r(ir),ir=1,upf%mesh) - read( iunps, '(1p4e19.11)',err=100, iostat=ios ) & - (upf%rab(ir),ir=1,upf%mesh) - else - ! - ! generate herman-skillman mesh (if version = 1) - ! - call herman_skillman_grid & - ( upf%mesh, upf%zmesh, upf%r, upf%rab ) - end if - ! - ! convert vloc to the conventions used in the rest of the code - ! (as read from Vanderbilt's format it is r*v_loc(r)) - ! - do ir = 2, upf%mesh - upf%vloc (ir) = upf%vloc (ir) / upf%r(ir) - enddo - upf%vloc (1) = upf%vloc (2) - ! - ! set rho_atc(r)=rho_core(r) (without 4*pi*r^2 factor, - ! for compatibility with rho_atc in the non-US case) - ! - if (upf%nlcc) then - upf%rho_atc(1) = 0.0_DP - do ir=2,upf%mesh - upf%rho_atc(ir) = upf%rho_atc(ir)/fpi/upf%r(ir)**2 - enddo - end if - ! - ! Read the wavefunctions of the atom - ! - if (iver(1) >= 7) then - read( iunps, *, err=100, iostat=ios ) i - if (i /= upf%nwfc) & - call errore('readvan','unexpected or unimplemented case',1) - end if - ! - ALLOCATE ( upf%chi(upf%mesh, upf%nwfc) ) - if (iver(1) >= 6) & - read( iunps, *, err=100, iostat=ios ) & - ( (upf%chi(ir,iv), ir=1,upf%mesh), iv=1,upf%nwfc ) - ! - if (iver(1) == 1) then - ! - ! old version: read the q_l(r) and fit them with the Vanderbilt's form - ! - call fit_qrl ( ) - ! - end if - ! - ! Here we write on output information on the pseudopotential - ! - WRITE( stdout,200) is -200 format (/4x,60('=')/4x,'| pseudopotential report', & - & ' for atomic species:',i3,11x,'|') - WRITE( stdout,300) 'pseudo potential version', & - iver(1), iver(2), iver(3) -300 format (4x,'| ',1a30,3i4,13x,' |' /4x,60('-')) - WRITE( stdout,400) title, upf%dft -400 format (4x,'| ',2a20,' exchange-corr |') - WRITE( stdout,500) upf%zmesh, is, upf%zp, exfact -500 format (4x,'| z =',f5.0,4x,'zv(',i2,') =',f5.0,4x,'exfact =', & - & f10.5, 9x,'|') - WRITE( stdout,600) ifpcor, etotpseu -600 format (4x,'| ifpcor = ',i2,10x,' atomic energy =',f10.5, & - & ' Ry',6x,'|') - WRITE( stdout,700) -700 format(4x,'| index orbital occupation energy',14x,'|') - WRITE( stdout,800) ( iv, nnlz(iv), upf%oc(iv), ee(iv), iv=1,upf%nwfc ) - DEALLOCATE (ee, nnlz) -800 format(4x,'|',i5,i11,5x,f10.2,f12.2,15x,'|') - if (iver(1) >= 3 .and. nang > 0) then - write(fmt,900) 2*nang-1, 40-8*(2*nang-2) -900 format('(4x,''| rinner ='',',i1,'f8.4,',i2,'x,''|'')') - WRITE( stdout,fmt) (upf%rinner(lp),lp=1,2*nang-1) - end if - WRITE( stdout,1000) -1000 format(4x,'| new generation scheme:',32x,'|') - WRITE( stdout,1100) upf%nbeta, upf%kkbeta, rcloc -1100 format(4x,'| nbeta = ',i2,5x,'kkbeta =',i5,5x,'rcloc =',f10.4,4x,& - & '|'/4x,'| ibeta l epsilon rcut',25x,'|') - do iv = 1, upf%nbeta - lp=upf%lll(iv)+1 - WRITE( stdout,1200) iv,upf%lll(iv),eee(iv),rc(lp) -1200 format(4x,'|',5x,i2,6x,i2,4x,2f7.2,25x,'|') - enddo - WRITE( stdout,1300) -1300 format (4x,60('=')) - ! - DEALLOCATE (eee, rc) - return -100 call errore('readvan','error reading pseudo file', abs(ios) ) - ! - CONTAINS - !----------------------------------------------------------------------- - subroutine fit_qrl ( ) - !----------------------------------------------------------------------- - ! - ! find coefficients qfcoef that fit the pseudized qrl in US PP - ! these coefficients are written to file in newer versions of the - ! Vanderbilt PP generation code but not in some ancient versions - ! - implicit none - ! - real (kind=DP), allocatable :: qrl(:,:), a(:,:), ainv(:,:), b(:), x(:) - real (kind=DP) :: deta - integer :: iv, jv, ijv, lmin, lmax, l, ir, irinner, i,j - ! - ! - allocate ( a(upf%nqf,upf%nqf), ainv(upf%nqf,upf%nqf) ) - allocate ( b(upf%nqf), x(upf%nqf) ) - ALLOCATE ( qrl(upf%kkbeta, upf%nqlc) ) - ! - do iv=1,upf%nbeta - do jv=iv,upf%nbeta - ! - ! original version, assuming lll(jv) >= lll(iv) - ! lmin=lll(jv,is)-lll(iv,is)+1 - ! lmax=lmin+2*lll(iv,is) - ! note that indices run from 1 to Lmax+1, not from 0 to Lmax - ! - lmin = ABS( upf%lll(jv) - upf%lll(iv) ) + 1 - lmax = upf%lll(jv) + upf%lll(iv) + 1 - IF ( lmin < 1 .OR. lmax > SIZE(qrl,2)) & - CALL errore ('fit_qrl', 'bad 2rd dimension for array qrl', 1) - ! - ! read q_l(r) for all l - ! - read(iunps,*, err=100) & - ( (qrl(ir,l),ir=1,upf%kkbeta), l=lmin,lmax) - ! - ijv = jv * (jv-1) / 2 + iv - ! - do l=lmin,lmax - ! - ! reconstruct rinner - ! - do ir=upf%kkbeta,1,-1 - if ( abs(qrl(ir,l)-upf%qfunc(ir,ijv)) > 1.0d-6) go to 10 - end do -10 irinner = ir+1 - upf%rinner(l) = upf%r(irinner) - ! - ! least square minimization: find - ! qrl = sum_i c_i r^{l+1}r^{2i-2} for r < rinner - ! - a(:,:) = 0.0_DP - b(:) = 0.0_DP - do i = 1, upf%nqf - do ir=1,irinner - b(i) = b(i) + upf%r(ir)**(2*i-2+l+1) * qrl(ir,l) - end do - do j = i, upf%nqf - do ir=1,irinner - a(i,j) = a(i,j) + upf%r(ir)**(2*i-2+l+1) * & - upf%r(ir)**(2*j-2+l+1) - end do - if (j > i) a(j,i) = a(i,j) - end do - end do - ! - call invmat (upf%nqf, a, ainv, deta) - ! - do i = 1, upf%nqf - upf%qfcoef(i,l,iv,jv) = dot_product(ainv(i,:),b(:)) - if (iv /= jv) upf%qfcoef(i,l,jv,iv) = upf%qfcoef(i,l,iv,jv) - end do - end do - end do - end do - ! - deallocate ( qrl, x, b , ainv, a ) - return - ! -100 call errore('readvan','error reading Q_L(r)', 1 ) - end subroutine fit_qrl - ! - end subroutine readvan - !----------------------------------------------------------------------- - SUBROUTINE herman_skillman_grid (mesh,z,r,rab) - !----------------------------------------------------------------------- - ! - ! generate Herman-Skillman radial grid (obsolescent) - ! c - 0.88534138/z**(1/3) - ! - IMPLICIT NONE - ! - INTEGER mesh - REAL(DP) :: z, r(mesh), rab(mesh) - ! - REAL(DP) :: deltax,pi - INTEGER :: nblock,i,j,k - ! - pi=4.0_DP*ATAN(1.0_DP) - nblock = mesh/40 - i=1 - r(i)=0.0_DP - deltax=0.0025_DP*0.5_DP*(3.0_DP*pi/4.0_DP)**(2.0_DP/3.0_DP)/z**(1.0_DP/3.0_DP) - DO j=1,nblock - DO k=1,40 - i=i+1 - r(i)=r(i-1)+deltax - rab(i)=deltax - END DO - deltax=deltax+deltax - END DO - ! - RETURN - END SUBROUTINE herman_skillman_grid - ! - !--------------------------------------------------------------------- - subroutine readrrkj( iunps, is, upf ) - !--------------------------------------------------------------------- - ! - ! This routine reads Vanderbilt pseudopotentials produced by the - ! code of Andrea Dal Corso. Hard PPs are first generated - ! according to the Rabe Rappe Kaxiras Johannopoulos recipe. - ! Ultrasoft PP's are subsequently generated from the hard PP's. - ! - ! Output parameters in module "uspp_param" - ! info on DFT level in module "dft" - ! - USE constants, ONLY : fpi - USE pseudo_types - ! - implicit none - ! - ! First the arguments passed to the subroutine - ! - TYPE (pseudo_upf) :: upf - integer :: & - is, &! The index of the pseudopotential - iunps ! the unit from with pseudopotential is read - ! - ! Local variables - ! - integer:: iexch, icorr, igcx, igcc - - integer:: & - nb,mb, ijv,&! counters on beta functions - n, &! counter on mesh points - ir, &! counters on mesh points - pseudotype,&! the type of pseudopotential - ios, &! I/O control - ndum, &! dummy integer variable - l ! counter on angular momentum - real(DP):: & - x, &! auxiliary variable - etotps, &! total energy of the pseudoatom - rdum ! dummy real variable - ! - logical :: & - rel ! if true the atomic calculation is relativistic - ! - character(len=75) :: & - titleps ! the title of the pseudo - ! - integer :: & - lmax ! max angular momentum - character(len=2) :: & - adum ! dummy character variable - ! - ! We first check the input variables - ! - if (is <= 0) & - call errore('readrrkj','routine called with wrong 1st argument', 1) - if (iunps <= 0 .or. iunps >= 100000) & - call errore('readrrkj','routine called with wrong 2nd argument', 1) - ! - read( iunps, '(a75)', err=100, iostat=ios ) & - titleps - upf%psd = titleps(7:8) - ! - read( iunps, '(i5)',err=100, iostat=ios ) & - pseudotype - upf%tvanp = (pseudotype == 3) - upf%tpawp = .false. - - if ( upf%tvanp ) then - upf%generated = & - "RRKJ3 Ultrasoft PP, generated by Andrea Dal Corso code" - else - upf%generated = & - "RRKJ3 norm-conserving PP, generated by Andrea Dal Corso code" - endif - - read( iunps, '(2l5)',err=100, iostat=ios ) & - rel, upf%nlcc - read( iunps, '(4i5)',err=100, iostat=ios ) & - iexch, icorr, igcx, igcc - ! - ! workaround to keep track of which dft was read - ! See also upf2internals - ! - write( upf%dft, "('INDEX:',4i1)") iexch,icorr,igcx,igcc - call set_dft_from_indices(iexch,icorr,igcx,igcc) - - read( iunps, '(2e17.11,i5)') & - upf%zp, etotps, lmax - if ( upf%zp < 1 .or. upf%zp > 100 ) & - call errore('readrrkj','wrong potential read',is) - ! - read( iunps, '(4e17.11,i5)',err=100, iostat=ios ) & - upf%xmin, rdum, upf%zmesh, upf%dx, upf%mesh - ! - if ( upf%mesh < 0) & - call errore('readrrkj', 'wrong mesh',is) - ! - read( iunps, '(2i5)', err=100, iostat=ios ) & - upf%nwfc, upf%nbeta - ! - if ( upf%nbeta < 0) & - call errore('readrrkj', 'wrong nbeta', is) - if ( upf%nwfc < 0 ) & - call errore('readrrkj', 'wrong nchi', is) - ! - read( iunps, '(1p4e19.11)', err=100, iostat=ios ) & - ( rdum, nb=1,upf%nwfc ) - read( iunps, '(1p4e19.11)', err=100, iostat=ios ) & - ( rdum, nb=1,upf%nwfc ) - ! - ALLOCATE ( upf%oc(upf%nwfc), upf%lchi(upf%nwfc), upf%lll(upf%nwfc) ) - ! - do nb=1,upf%nwfc - read(iunps,'(a2,2i3,f6.2)',err=100,iostat=ios) & - adum, ndum, upf%lchi(nb), upf%oc(nb) - upf%lll(nb)=upf%lchi(nb) - ! - ! oc < 0 distinguishes between bound states from unbound states - ! - if ( upf%oc(nb) <= 0.0_DP) upf%oc(nb) = -1.0_DP - enddo - ! - ALLOCATE ( upf%kbeta(upf%nbeta) ) - ALLOCATE ( upf%dion(upf%nbeta,upf%nbeta), upf%qqq(upf%nbeta,upf%nbeta) ) - ALLOCATE ( upf%beta(upf%mesh,upf%nbeta) ) - ALLOCATE ( upf%qfunc(upf%mesh,upf%nbeta*(upf%nbeta+1)/2) ) - upf%kkbeta = 0 - do nb=1,upf%nbeta - read ( iunps, '(i6)',err=100, iostat=ios ) upf%kbeta(nb) - upf%kkbeta = MAX ( upf%kkbeta, upf%kbeta(nb) ) - read ( iunps, '(1p4e19.11)',err=100, iostat=ios ) & - ( upf%beta(ir,nb), ir=1,upf%kbeta(nb)) - do ir=upf%kbeta(nb)+1,upf%mesh - upf%beta(ir,nb)=0.0_DP - enddo - do mb=1,nb - ! - ! the symmetric matric Q_{nb,mb} is stored in packed form - ! Q(nb,mb) => qfunc(ijv) as defined below (for mb <= nb) - ! - ijv = nb * (nb - 1) / 2 + mb - read( iunps, '(1p4e19.11)', err=100, iostat=ios ) & - upf%dion(nb,mb) - if (pseudotype == 3) then - read(iunps,'(1p4e19.11)',err=100,iostat=ios) & - upf%qqq(nb,mb) - read(iunps,'(1p4e19.11)',err=100,iostat=ios) & - (upf%qfunc(n,ijv),n=1,upf%mesh) - else - upf%qqq(nb,mb)=0.0_DP - upf%qfunc(:,ijv)=0.0_DP - endif - if ( mb /= nb ) then - upf%dion(mb,nb)=upf%dion(nb,mb) - upf%qqq(mb,nb)=upf%qqq(nb,mb) - end if - enddo - enddo - ! - ! reads the local potential - ! - ALLOCATE ( upf%vloc(upf%mesh) ) - read( iunps, '(1p4e19.11)',err=100, iostat=ios ) & - rdum, ( upf%vloc(ir), ir=1,upf%mesh ) - ! - ! reads the atomic charge - ! - ALLOCATE ( upf%rho_at(upf%mesh) ) - read( iunps, '(1p4e19.11)', err=100, iostat=ios ) & - ( upf%rho_at(ir), ir=1,upf%mesh ) - ! - ! if present reads the core charge - ! - if ( upf%nlcc ) then - ALLOCATE ( upf%rho_atc(upf%mesh) ) - read( iunps, '(1p4e19.11)', err=100, iostat=ios ) & - ( upf%rho_atc(ir), ir=1,upf%mesh ) - endif - ! - ! read the pseudo wavefunctions of the atom - ! - ALLOCATE ( upf%chi(upf%mesh, upf%nwfc) ) - read( iunps, '(1p4e19.11)', err=100, iostat=ios ) & - ((upf%chi(ir,nb),ir=1,upf%mesh),nb=1,upf%nwfc) - ! - ! set several variables for compatibility with the rest of the code - ! - upf%nqf=0 - upf%nqlc=2*lmax+1 - if ( upf%nqlc > lqmax .or. upf%nqlc < 0 ) & - call errore(' readrrkj', 'Wrong nqlc', upf%nqlc ) - ALLOCATE ( upf%rinner(upf%nqlc) ) - do l=1,upf%nqlc - upf%rinner(l)=0.0_DP - enddo - ! - ! compute the radial mesh - ! - ALLOCATE ( upf%r(upf%mesh), upf%rab(upf%mesh) ) - do ir = 1, upf%mesh - x = upf%xmin + DBLE(ir-1) * upf%dx - upf%r(ir) = EXP(x) / upf%zmesh - upf%rab(ir) = upf%dx * upf%r(ir) - end do - ! - ! set rho_atc(r)=rho_core(r) (without 4*pi*r^2 factor) - ! - if ( upf%nlcc ) then - do ir=1,upf%mesh - upf%rho_atc(ir) = upf%rho_atc(ir)/fpi/upf%r(ir)**2 - enddo - end if - ! - ! Set additional, not present, variables to dummy values - allocate(upf%els(upf%nwfc)) - upf%els(:) = 'nX' - allocate(upf%els_beta(upf%nbeta)) - upf%els_beta(:) = 'nX' - allocate(upf%rcut(upf%nbeta), upf%rcutus(upf%nbeta)) - upf%rcut(:) = 0._dp - upf%rcutus(:) = 0._dp - ! - return -100 call errore('readrrkj','Reading pseudo file',abs(ios)) - stop - end subroutine readrrkj - ! -end module read_uspp_module diff --git a/quantum_espresso/kcp/Modules/recvec.f90 b/quantum_espresso/kcp/Modules/recvec.f90 deleted file mode 100644 index 33c3c0fc0..000000000 --- a/quantum_espresso/kcp/Modules/recvec.f90 +++ /dev/null @@ -1,325 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -!=----------------------------------------------------------------------------=! - MODULE gvecw -!=----------------------------------------------------------------------------=! - USE kinds, ONLY: DP - - IMPLICIT NONE - SAVE - - ! ... G vectors less than the wave function cut-off ( ecutwfc ) - INTEGER :: ngw = 0 ! local number of G vectors - INTEGER :: ngwt = 0 ! in parallel execution global number of G vectors, - ! in serial execution this is equal to ngw - INTEGER :: ngwl = 0 ! number of G-vector shells up to ngw - INTEGER :: ngwx = 0 ! maximum local number of G vectors - INTEGER :: ng0 = 0 ! first G-vector with nonzero modulus - ! needed in the parallel case (G=0 is on one node only!) - - REAL(DP) :: ecutw = 0.0_DP - REAL(DP) :: gcutw = 0.0_DP - - ! values for costant cut-off computations - - REAL(DP) :: ecfix = 0.0_DP ! value of the constant cut-off - REAL(DP) :: ecutz = 0.0_DP ! height of the penalty function (above ecfix) - REAL(DP) :: ecsig = 0.0_DP ! spread of the penalty function around ecfix - LOGICAL :: tecfix = .FALSE. ! .TRUE. if constant cut-off is in use - - ! augmented cut-off for k-point calculation - - REAL(DP) :: ekcut = 0.0_DP - REAL(DP) :: gkcut = 0.0_DP - - ! array of G vectors module plus penalty function for constant cut-off - ! simulation. - ! - ! ggp = g + ( agg / tpiba**2 ) * ( 1 + erf( ( tpiba2 * g - e0gg ) / sgg ) ) - - REAL(DP), ALLOCATABLE, TARGET :: ggp(:) - - CONTAINS - - SUBROUTINE deallocate_gvecw - IF( ALLOCATED( ggp ) ) DEALLOCATE( ggp ) - END SUBROUTINE deallocate_gvecw - -!=----------------------------------------------------------------------------=! - END MODULE gvecw -!=----------------------------------------------------------------------------=! - -!=----------------------------------------------------------------------------=! - MODULE gvecp -!=----------------------------------------------------------------------------=! - USE kinds, ONLY: DP - - IMPLICIT NONE - SAVE - - ! ... G vectors less than the potential cut-off ( ecutrho ) - INTEGER :: ngm = 0 ! local number of G vectors - INTEGER :: ngmt = 0 ! in parallel execution global number of G vectors, - ! in serial execution this is equal to ngm - INTEGER :: ngml = 0 ! number of G-vector shells up to ngw - INTEGER :: ngmx = 0 ! maximum local number of G vectors - - REAL(DP) :: ecutp = 0.0_DP - REAL(DP) :: gcutp = 0.0_DP - -!=----------------------------------------------------------------------------=! - END MODULE gvecp -!=----------------------------------------------------------------------------=! - -!=----------------------------------------------------------------------------=! - MODULE gvecs -!=----------------------------------------------------------------------------=! - USE kinds, ONLY: DP - - IMPLICIT NONE - SAVE - - ! ... G vectors less than the smooth grid cut-off ( ? ) - INTEGER :: ngs = 0 ! local number of G vectors - INTEGER :: ngst = 0 ! in parallel execution global number of G vectors, - ! in serial execution this is equal to ngw - INTEGER :: ngsl = 0 ! number of G-vector shells up to ngw - INTEGER :: ngsx = 0 ! maximum local number of G vectors - - INTEGER, ALLOCATABLE :: nps(:), nms(:) - - REAL(DP) :: ecuts = 0.0_DP - REAL(DP) :: gcuts = 0.0_DP - - REAL(DP) :: dual = 0.0_DP - LOGICAL :: doublegrid = .FALSE. - - CONTAINS - - SUBROUTINE deallocate_gvecs() - IF( ALLOCATED( nps ) ) DEALLOCATE( nps ) - IF( ALLOCATED( nms ) ) DEALLOCATE( nms ) - END SUBROUTINE deallocate_gvecs - -!=----------------------------------------------------------------------------=! - END MODULE gvecs -!=----------------------------------------------------------------------------=! - -!=----------------------------------------------------------------------------=! - MODULE gvecb -!=----------------------------------------------------------------------------=! - USE kinds, ONLY: DP - - IMPLICIT NONE - SAVE - - ! ... G vectors less than the box grid cut-off ( ? ) - INTEGER :: ngb = 0 ! local number of G vectors - INTEGER :: ngbt = 0 ! in parallel execution global number of G vectors, - ! in serial execution this is equal to ngw - INTEGER :: ngbl = 0 ! number of G-vector shells up to ngw - INTEGER :: ngbx = 0 ! maximum local number of G vectors - - REAL(DP), ALLOCATABLE :: gb(:), gxb(:,:), glb(:) - INTEGER, ALLOCATABLE :: npb(:), nmb(:), iglb(:) - INTEGER, ALLOCATABLE :: mill_b(:,:) - - REAL(DP) :: ecutb = 0.0_DP - REAL(DP) :: gcutb = 0.0_DP - - CONTAINS - - SUBROUTINE gvecb_set( ecut, tpibab ) - IMPLICIT NONE - REAL(DP), INTENT(IN) :: ecut, tpibab - ecutb = ecut - gcutb = ecut / tpibab / tpibab - RETURN - END SUBROUTINE gvecb_set - - SUBROUTINE deallocate_gvecb() - IF( ALLOCATED( gb ) ) DEALLOCATE( gb ) - IF( ALLOCATED( gxb ) ) DEALLOCATE( gxb ) - IF( ALLOCATED( glb ) ) DEALLOCATE( glb ) - IF( ALLOCATED( npb ) ) DEALLOCATE( npb ) - IF( ALLOCATED( nmb ) ) DEALLOCATE( nmb ) - IF( ALLOCATED( iglb ) ) DEALLOCATE( iglb ) - IF( ALLOCATED( mill_b ) ) DEALLOCATE( mill_b ) - END SUBROUTINE deallocate_gvecb - -!=----------------------------------------------------------------------------=! - END MODULE gvecb -!=----------------------------------------------------------------------------=! - - -!=----------------------------------------------------------------------------=! - MODULE reciprocal_vectors -!=----------------------------------------------------------------------------=! - - USE kinds, ONLY: DP - USE gvecp - USE gvecb - USE gvecs - USE gvecw - - IMPLICIT NONE - SAVE - - ! ... declare module-scope variables - - LOGICAL :: gzero = .TRUE. ! .TRUE. if the first G vectors on this processor is - ! the null G vector ( i.e. |G| == 0 ) - INTEGER :: gstart = 2 ! index of the first G vectors whose module is greather - ! than 0 . - ! gstart = 2 when gzero == .TRUE., gstart = 1 otherwise - - ! G^2 in increasing order (in units of tpiba2=(2pi/a)^2) - ! - REAL(DP), ALLOCATABLE, TARGET :: g(:) - - ! shells of G^2 - ! - REAL(DP), ALLOCATABLE, TARGET :: gl(:) - - ! G-vectors cartesian components ( units tpiba =(2pi/a) ) - ! - REAL(DP), ALLOCATABLE, TARGET :: gx(:,:) - - ! g2_g = all G^2 in increasing order, replicated on all procs - ! - REAL(DP), ALLOCATABLE, TARGET :: g2_g(:) - - ! mill_g = miller index of G vecs (increasing order), replicated on all procs - ! - INTEGER, ALLOCATABLE, TARGET :: mill_g(:,:) - - ! mill_l = miller index of G vecs local to the processors - ! - INTEGER, ALLOCATABLE, TARGET :: mill_l(:,:) - - ! ig_l2g = "l2g" means local to global, this array converts a local - ! G-vector index into the global index, in other words - ! the index of the G-v. in the overall array of G-vectors - ! - INTEGER, ALLOCATABLE, TARGET :: ig_l2g(:) - - ! sortedig_l2g = array obtained by sorting ig_l2g - ! - ! - INTEGER, ALLOCATABLE, TARGET :: sortedig_l2g(:) - - ! igl = index of the g-vector shells - ! - INTEGER, ALLOCATABLE, TARGET :: igl(:) - - ! bi = base vector used to generate the reciprocal space - ! - REAL(DP) :: bi1(3) = (/ 0.0_DP, 0.0_DP, 0.0_DP /) - REAL(DP) :: bi2(3) = (/ 0.0_DP, 0.0_DP, 0.0_DP /) - REAL(DP) :: bi3(3) = (/ 0.0_DP, 0.0_DP, 0.0_DP /) - - CONTAINS - - SUBROUTINE deallocate_recvecs - IF( ALLOCATED( g ) ) DEALLOCATE( g ) - IF( ALLOCATED( gl ) ) DEALLOCATE( gl ) - IF( ALLOCATED( gx ) ) DEALLOCATE( gx ) - IF( ALLOCATED( g2_g ) ) DEALLOCATE( g2_g ) - IF( ALLOCATED( mill_g ) ) DEALLOCATE( mill_g ) - IF( ALLOCATED( mill_l ) ) DEALLOCATE( mill_l ) - IF( ALLOCATED( ig_l2g ) ) DEALLOCATE( ig_l2g ) - IF( ALLOCATED( sortedig_l2g ) ) DEALLOCATE( sortedig_l2g ) - IF( ALLOCATED( igl ) ) DEALLOCATE( igl ) - CALL deallocate_gvecw( ) - CALL deallocate_gvecs( ) - CALL deallocate_gvecb( ) - END SUBROUTINE deallocate_recvecs - -!=----------------------------------------------------------------------------=! - END MODULE reciprocal_vectors -!=----------------------------------------------------------------------------=! - - -!=----------------------------------------------------------------------------=! - MODULE recvecs_indexes -!=----------------------------------------------------------------------------=! - - IMPLICIT NONE - SAVE - - ! np = fft index for G> - ! nm = fft index for G< - ! in1p,in2p,in3p = G components in crystal axis - - - INTEGER, ALLOCATABLE :: np(:), nm(:), in1p(:), in2p(:), in3p(:) - - CONTAINS - - SUBROUTINE deallocate_recvecs_indexes - IF( ALLOCATED( np ) ) DEALLOCATE( np ) - IF( ALLOCATED( nm ) ) DEALLOCATE( nm ) - IF( ALLOCATED( in1p ) ) DEALLOCATE( in1p ) - IF( ALLOCATED( in2p ) ) DEALLOCATE( in2p ) - IF( ALLOCATED( in3p ) ) DEALLOCATE( in3p ) - END SUBROUTINE deallocate_recvecs_indexes - -!=----------------------------------------------------------------------------=! - END MODULE recvecs_indexes -!=----------------------------------------------------------------------------=! - - -!=----------------------------------------------------------------------------=! - MODULE recvecs_subroutines -!=----------------------------------------------------------------------------=! - - IMPLICIT NONE - SAVE - - CONTAINS - - SUBROUTINE recvecs_init( ngm_ , ngw_ , ngs_ ) - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_max, mp_sum - USE gvecw, ONLY: ngw, ngwx, ngwt - USE gvecp, ONLY: ngm, ngmx, ngmt - USE gvecs, ONLY: ngs, ngsx, ngst - - IMPLICIT NONE - INTEGER, INTENT(IN) :: ngm_ , ngw_ , ngs_ - - ngm = ngm_ - ngw = ngw_ - ngs = ngs_ - - ! - ! calculate maxima over all processors - ! - ngwx = ngw - ngmx = ngm - ngsx = ngs - CALL mp_max( ngwx, intra_image_comm ) - CALL mp_max( ngmx, intra_image_comm ) - CALL mp_max( ngsx, intra_image_comm ) - ! - ! calculate SUM over all processors - ! - ngwt = ngw - ngmt = ngm - ngst = ngs - CALL mp_sum( ngwt, intra_image_comm ) - CALL mp_sum( ngmt, intra_image_comm ) - CALL mp_sum( ngst, intra_image_comm ) - - RETURN - END SUBROUTINE recvecs_init - -!=----------------------------------------------------------------------------=! - END MODULE recvecs_subroutines -!=----------------------------------------------------------------------------=! diff --git a/quantum_espresso/kcp/Modules/shmem_include.f90 b/quantum_espresso/kcp/Modules/shmem_include.f90 deleted file mode 100644 index d9ac20130..000000000 --- a/quantum_espresso/kcp/Modules/shmem_include.f90 +++ /dev/null @@ -1,53 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -!------------------------------------------------------------------------------! -! Author : Carlo Cavazzoni (CINECA) -! Update : October 1999 -!------------------------------------------------------------------------------! -! -! This is a fixed format file -! -!------------------------------------------------------------------------------C -! -! Holds External information for Message Passing Systems -! -!------------------------------------------------------------------------------C - - MODULE shmem_include - - USE kinds - IMPLICIT NONE - SAVE - - LOGICAL TSHMEM - -#if defined __SHMEM -! -! Include file for SHMEM Library -! - INCLUDE 'mpp/shmem.fh' - INTEGER, PARAMETER :: mp_shmem_bufsize = & - MAX(524288,SHMEM_REDUCE_MIN_WRKDATA_SIZE) - INTEGER PSYNCB(SHMEM_BARRIER_SYNC_SIZE) - INTEGER PSYNCC(SHMEM_COLLECT_SYNC_SIZE) - INTEGER PSYNC_STA(SHMEM_REDUCE_SYNC_SIZE) - REAL(DP), SAVE :: mp_shmem_buffer(mp_shmem_bufsize) - REAL(DP), SAVE :: mp_shmem_work(mp_shmem_bufsize) - - DATA PSYNC_STA /SHMEM_REDUCE_SYNC_SIZE*SHMEM_SYNC_VALUE/ - DATA PSYNCB /SHMEM_BARRIER_SYNC_SIZE*SHMEM_SYNC_VALUE/ - DATA PSYNCC /SHMEM_COLLECT_SYNC_SIZE*SHMEM_SYNC_VALUE/ - DATA TSHMEM /.TRUE./ - -#else -! - DATA TSHMEM /.FALSE./ -#endif -! - END MODULE shmem_include diff --git a/quantum_espresso/kcp/Modules/sic.f90 b/quantum_espresso/kcp/Modules/sic.f90 deleted file mode 100644 index 85bfa70d1..000000000 --- a/quantum_espresso/kcp/Modules/sic.f90 +++ /dev/null @@ -1,138 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -!------------------------------------------------------------------------------! - MODULE sic_module -!------------------------------------------------------------------------------! -! -! The versions after 3.0 contain also the self-interaction-correction method -! has proposed by Mauri et al. (PRB 2005), taking also into account the 'comment' -! proposed by Sprik et al. (ICR 2005). -! Thus, we introduce the parameters sic_alpha and sic_epsilon to correct the -! exchange-correlation and the electronic hartree potentials, respectively. -! They are two empirical parameters, thus to remain in a ab-initio -! set them equal to 1.0_DP. -! Sprik et al. showed that, in same cases, i.e. OH radical, it should be better -! to under estimate the correction to ex-ch, since in same way the exch already -! corrects the electronic hartree part. -! HOW AND WHEN USE THE SIC:: -! Fran's personal considerations: -! the SIC is a way to correct the self-interaction WHEN -! ONE and only ONE e- lives in an unpaired electronic level -! we have choosen for it the spin up -! Remember to select nspin == 2 and nelup = neldw + 1 -! the other e- are fictitious calculate in a LSD approach: -! infact, even if the paired e- feel a different potential (for spin up and spin dw) -! we constrain them to have the same force, and the same eigenvalues, the same eigenstates -! When you applied this SIC scheme to a molecule or to an atom, which are neutral, -! remember that you have to consider another correction to the energy level as proposed -! by Landau: infact if you start from a neutral system and subtract the self-intereaction -! the unpaired e- feels a charge system. Thus remeber a correction term ~2.317(Madelung)/2L_box - - - USE kinds, ONLY: DP -! - IMPLICIT NONE - SAVE - - INTEGER, ALLOCATABLE :: ind_localisation(:) - INTEGER :: nat_localisation = 0 - LOGICAL :: print_localisation = .FALSE. ! Calculates hartree energy around specified atoms - INTEGER :: self_interaction = 0 - REAL(DP) :: sic_epsilon = 0.0_DP - REAL(DP) :: sic_alpha = 0.0_DP - REAL(DP) :: sic_rloc = 0.0_DP - REAL(DP), ALLOCATABLE :: pos_localisation(:,:) - -!------------------------------------------------------------------------------! - CONTAINS -!------------------------------------------------------------------------------! - - SUBROUTINE sic_initval( nat_ , id_loc_ , sic_ , sic_epsilon_ , sic_alpha_, sic_rloc_ ) - - IMPLICIT NONE - INTEGER, INTENT(IN) :: nat_ - INTEGER, INTENT(IN) :: id_loc_ (:) - CHARACTER(LEN=*), INTENT(IN) :: sic_ - REAL(DP), INTENT(IN) :: sic_epsilon_ - REAL(DP), INTENT(IN) :: sic_alpha_ - REAL(DP), INTENT(IN) :: sic_rloc_ - - select case ( TRIM( sic_ ) ) - case ( 'sic_mac' ) - self_interaction = 2 - case default - self_interaction = 0 - end select - sic_epsilon = sic_epsilon_ - sic_alpha = sic_alpha_ - sic_rloc = sic_rloc_ - ! counting the atoms around which i want to calculate the charge localization - IF( ALLOCATED( ind_localisation ) ) DEALLOCATE( ind_localisation ) - ALLOCATE( ind_localisation( nat_ ) ) - ind_localisation( 1 : nat_ ) = id_loc_ ( 1 : nat_ ) - nat_localisation = COUNT( ind_localisation > 0 ) - IF( ALLOCATED( pos_localisation ) ) DEALLOCATE( pos_localisation ) - ALLOCATE( pos_localisation( 4, MAX( nat_localisation, 1 ) ) ) - ! - IF( nat_localisation > 0 ) print_localisation = .TRUE. - ! - RETURN - END SUBROUTINE sic_initval - -!------------------------------------------------------------------------------! - - SUBROUTINE deallocate_sic() - IMPLICIT NONE - IF( ALLOCATED( pos_localisation ) ) DEALLOCATE( pos_localisation ) - IF( ALLOCATED( ind_localisation ) ) DEALLOCATE( ind_localisation ) - RETURN - END SUBROUTINE deallocate_sic - -!------------------------------------------------------------------------------! - - SUBROUTINE sic_info( ) - - USE io_global, ONLY: stdout - IMPLICIT NONE - - ! - ! prints the type of USIC we will do : - ! - - IF( self_interaction == 0 ) THEN - RETURN - END IF - - WRITE(stdout, 591) - WRITE(stdout, 592) self_interaction - WRITE(stdout, 593) - !!select case (self_interaction) - - IF ( self_interaction /= 0 ) THEN - - write(stdout,*) & - ' Unpaired-electron self-interaction correction by Mauri', self_interaction - write(stdout,*) & - ' E_USIC_EHTE = U_hartree[rho_up + rho_dw]- sic_espilon * U_hartree[rho_up-rhp_down]' - write(stdout,*) & - ' E_USIC_XC = E_xc[rho_up,rho_dw] - sic_alpha( E_xc[rho_up,rho_dw] + E_xc[rho_dw, rho_dw]) ' - - END IF !!select - - 591 FORMAT( 3X,'') - 592 FORMAT( 3X,'Introducing a Mauri Avezac Calandra Self_Interaction Correction: ', I3) - 593 FORMAT( 3X,'----------------------------------------') - - RETURN - END SUBROUTINE sic_info - - -!------------------------------------------------------------------------------! - END MODULE sic_module -!------------------------------------------------------------------------------! diff --git a/quantum_espresso/kcp/Modules/smallbox.f90 b/quantum_espresso/kcp/Modules/smallbox.f90 deleted file mode 100644 index 9daba2750..000000000 --- a/quantum_espresso/kcp/Modules/smallbox.f90 +++ /dev/null @@ -1,80 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -!------------------------------------------------------------------------------! - MODULE small_box -!------------------------------------------------------------------------------! - - ! This module contains the basis vector of the small sub-cell (small box) - ! used for charge augmentation process - - USE kinds, ONLY : DP -! - IMPLICIT NONE - SAVE - - ! a1, a2 and a3 are the simulation cell base vector as calculated from celldm - - REAL(DP) :: a1b(3) = (/ 0.0_DP, 0.0_DP, 0.0_DP /) - REAL(DP) :: a2b(3) = (/ 0.0_DP, 0.0_DP, 0.0_DP /) - REAL(DP) :: a3b(3) = (/ 0.0_DP, 0.0_DP, 0.0_DP /) - - REAL(DP) :: b1b(3) = (/ 0.0_DP, 0.0_DP, 0.0_DP /) - REAL(DP) :: b2b(3) = (/ 0.0_DP, 0.0_DP, 0.0_DP /) - REAL(DP) :: b3b(3) = (/ 0.0_DP, 0.0_DP, 0.0_DP /) - - REAL(DP) :: ainvb(3,3) = 0.0_DP - - REAl(DP) :: omegab = 0.0_DP ! volume of the small boxes - - REAL(DP) :: tpibab = 0.0_DP - - REAL(DP) :: alatb = 0.0_DP - -!------------------------------------------------------------------------------! - CONTAINS -!------------------------------------------------------------------------------! -! - - SUBROUTINE small_box_set( alat, omega, a1, a2, a3, rat1, rat2, rat3 ) - USE constants, ONLY: pi - USE io_global, ONLY: stdout - IMPLICIT NONE - REAL(DP), INTENT(IN) :: alat, omega, a1(3), a2(3), a3(3), rat1, rat2, rat3 - - alatb = alat * rat1 - IF( alatb <= 0.0_DP ) CALL errore(' small_box_set ', ' alatb <= 0 ', 1 ) - tpibab = 2.0_DP * pi / alatb - a1b = a1 * rat1 - a2b = a2 * rat2 - a3b = a3 * rat3 - omegab = omega * rat1 * rat2 * rat3 -! - CALL recips( a1b, a2b, a3b, b1b, b2b, b3b ) - b1b = b1b * alatb - b2b = b2b * alatb - b3b = b3b * alatb - - WRITE( stdout,*) - WRITE( stdout,220) -220 format( 3X, 'unit vectors of box grid cell',/, & - & 3X, 'in real space:',25x,'in reciprocal space:') - WRITE( stdout,'(3X,3f10.4,10x,3f10.4)') a1b, b1b - WRITE( stdout,'(3X,3f10.4,10x,3f10.4)') a2b, b2b - WRITE( stdout,'(3X,3f10.4,10x,3f10.4)') a3b, b3b - - ainvb(1,:) = b1b(:) / alatb - ainvb(2,:) = b2b(:) / alatb - ainvb(3,:) = b3b(:) / alatb - - RETURN - END SUBROUTINE small_box_set -! -!------------------------------------------------------------------------------! - END MODULE small_box -!------------------------------------------------------------------------------! diff --git a/quantum_espresso/kcp/Modules/splinelib.f90 b/quantum_espresso/kcp/Modules/splinelib.f90 deleted file mode 100644 index d29de0096..000000000 --- a/quantum_espresso/kcp/Modules/splinelib.f90 +++ /dev/null @@ -1,293 +0,0 @@ -! -! Copyright (C) 2004-2006 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!--------------------------------------------------------------------------- -MODULE splinelib - !--------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - ! - IMPLICIT NONE - ! - PRIVATE - ! - PUBLIC :: dosplineint, spline, splint, splint_deriv - ! - INTERFACE dosplineint - ! - MODULE PROCEDURE dosplineint_1D, dosplineint_2D - ! - END INTERFACE - ! - CONTAINS - ! - !------------------------------------------------------------------------ - SUBROUTINE spline( xdata, ydata, startu, startd, d2y ) - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: xdata(:), ydata(:), startu, startd - REAL(DP), INTENT(OUT) :: d2y(:) - ! - INTEGER :: i, k, ydim - REAL(DP) :: p, sig - REAL(DP), ALLOCATABLE :: u(:) - ! - ! - ydim = SIZE( ydata ) - ! - ALLOCATE( u( ydim ) ) - ! - u(1) = startu - d2y(1) = startd - ! - DO i = 2, ydim - 1 - ! - sig = ( xdata(i) - xdata(i-1) ) / ( xdata(i+1) - xdata(i-1) ) - p = sig * d2y(i- 1) + 2.0_DP - d2y(i) = ( sig - 1.0_DP ) / p - u(i) = ( 6.0_DP * ( ( ydata(i+1) - ydata(i) ) / & - ( xdata(i+1) - xdata(i) ) - ( ydata(i) - ydata(i-1) ) / & - ( xdata(i) - xdata(i-1) ) ) / & - ( xdata(i+1) - xdata(i-1) ) - sig * u(i-1) ) / p - ! - END DO - ! - d2y(ydim) = 0 - ! - DO k = ydim - 1, 1, -1 - ! - d2y(k) = d2y(k) * d2y(k+1) + u(k) - ! - END DO - ! - DEALLOCATE( u ) - ! - END SUBROUTINE spline - ! - !------------------------------------------------------------------------ - FUNCTION splint( xdata, ydata, d2y, x ) - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: xdata(:), ydata(:), d2y(:) - REAL(DP), INTENT(IN) :: x - ! - REAL(DP) :: splint - INTEGER :: khi, klo, xdim - REAL(DP) :: a, b, h - ! - ! - xdim = SIZE( xdata ) - ! - klo = 1 - khi = xdim - ! - klo = MAX( MIN( locate( xdata, x ), ( xdim - 1 ) ), 1 ) - ! - khi = klo + 1 - ! - h = xdata(khi) - xdata(klo) - ! - a = ( xdata(khi) - x ) / h - b = ( x - xdata(klo) ) / h - ! - splint = a * ydata(klo) + b * ydata(khi) + & - ( ( a**3 - a ) * d2y(klo) + ( b**3 - b ) * d2y(khi) ) * & - ( h**2 ) / 6.0_DP - - END FUNCTION splint - - - !------------------------------------------------------------------------ - FUNCTION splint_deriv( xdata, ydata, d2y, x ) - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: xdata(:), ydata(:), d2y(:) - REAL(DP), INTENT(IN) :: x - ! - REAL(DP) :: splint_deriv - INTEGER :: khi, klo, xdim - REAL(DP) :: a, b, da, db, h - ! - ! - xdim = SIZE( xdata ) - ! - klo = 1 - khi = xdim - ! - klo = MAX( MIN( locate( xdata, x ), ( xdim - 1 ) ), 1 ) - ! - khi = klo + 1 - ! - h = xdata(khi) - xdata(klo) - ! - a = ( xdata(khi) - x ) / h - b = ( x - xdata(klo) ) / h - da = -1.0_DP / h - db = 1.0_DP / h - ! - splint_deriv = da * ydata(klo) + db * ydata(khi) + & - ( ( 3.0_DP*a**2 - 1.0_DP ) * da * d2y(klo) + & - ( 3.0_DP*b**2 - 1.0_DP ) * db * d2y(khi) ) * & - ( h**2 ) / 6.0_DP - - END FUNCTION splint_deriv - - !------------------------------------------------------------------- - FUNCTION locate( xx, x ) - !------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - REAL(DP), INTENT(IN) :: xx(:) - REAL(DP), INTENT(IN) :: x - ! - INTEGER :: locate - INTEGER :: n, jl, jm, ju - LOGICAL :: ascnd - ! - ! - n = SIZE( xx ) - ascnd = ( xx(n) >= xx(1) ) - jl = 0 - ju = n + 1 - ! - main_loop: DO - ! - IF ( ( ju - jl ) <= 1 ) EXIT main_loop - ! - jm = ( ju + jl ) / 2 - ! - IF ( ascnd .EQV. ( x >= xx(jm) ) ) THEN - ! - jl = jm - ! - ELSE - ! - ju = jm - ! - END IF - ! - END DO main_loop - ! - IF ( x == xx(1) ) THEN - ! - locate = 1 - ! - ELSE IF ( x == xx(n) ) THEN - ! - locate = n - 1 - ! - ELSE - ! - locate = jl - ! - END IF - ! - END FUNCTION locate - ! - ! - !------------------------------------------------------------------------ - SUBROUTINE dosplineint_1D( old_mesh, old_vec, new_mesh, new_vec ) - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - ! - REAL (DP), INTENT(IN) :: old_mesh(:), new_mesh(:) - REAL (DP), INTENT(IN) :: old_vec(:) - REAL (DP), INTENT(OUT) :: new_vec(:) - ! - REAL (DP), ALLOCATABLE :: d2y(:) - INTEGER :: i - INTEGER :: old_dim, new_dim - ! - ! - old_dim = SIZE( old_vec ) - new_dim = SIZE( new_vec ) - ! - IF ( old_dim /= SIZE( old_mesh ) ) & - CALL errore( 'dosplineint', & - 'dimensions of old_mesh and old_vec do not match', 1 ) - ! - IF ( new_dim /= SIZE( new_mesh ) ) & - CALL errore( 'dosplineint', & - 'dimensions of new_mesh and new_vec do not match', 1 ) - ! - ALLOCATE( d2y( old_dim ) ) - ! - d2y = 0 - ! - CALL spline( old_mesh , old_vec(:), 0.0_DP, 0.0_DP, d2y ) - ! - DO i = 1, new_dim - ! - new_vec(i) = splint( old_mesh, old_vec(:), d2y, new_mesh(i) ) - ! - END DO - ! - DEALLOCATE( d2y ) - ! - END SUBROUTINE dosplineint_1D - ! - !------------------------------------------------------------------------ - SUBROUTINE dosplineint_2D( old_mesh, old_vec, new_mesh, new_vec ) - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - ! - REAL (DP), INTENT(IN) :: old_mesh(:), new_mesh(:) - REAL (DP), INTENT(IN) :: old_vec(:,:) - REAL (DP), INTENT(OUT) :: new_vec(:,:) - ! - REAL (DP), ALLOCATABLE :: d2y(:) - INTEGER :: dim, i, j - INTEGER :: old_dim, new_dim - ! - ! - dim = SIZE( old_vec, 1 ) - ! - IF( dim /= SIZE( new_vec, 1 ) ) & - CALL errore( 'dosplineint', & - 'dimensions of old_vec and new_vec do not match', 1 ) - ! - old_dim = SIZE( old_vec, 2 ) - new_dim = SIZE( new_vec, 2 ) - ! - IF ( old_dim /= SIZE( old_mesh, 1 ) ) & - CALL errore( 'dosplineint', & - 'dimensions of old_mesh and old_vec do not match', 1 ) - ! - IF ( new_dim /= SIZE( new_mesh, 1 ) ) & - CALL errore( 'dosplineint', & - 'dimensions of new_mesh and new_vec do not match', 1 ) - ! - ALLOCATE( d2y( old_dim ) ) - ! - DO i = 1, dim - ! - d2y = 0 - ! - CALL spline( old_mesh , old_vec(i,:), 0.0_DP, 0.0_DP, d2y ) - ! - DO j = 1, new_dim - ! - new_vec(i,j) = splint( old_mesh, old_vec(i,:), d2y, new_mesh(j) ) - ! - END DO - ! - END DO - ! - DEALLOCATE( d2y ) - ! - END SUBROUTINE dosplineint_2D - ! -END MODULE splinelib diff --git a/quantum_espresso/kcp/Modules/stick_base.f90 b/quantum_espresso/kcp/Modules/stick_base.f90 deleted file mode 100644 index 7c3988664..000000000 --- a/quantum_espresso/kcp/Modules/stick_base.f90 +++ /dev/null @@ -1,828 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -!=----------------------------------------------------------------------= - MODULE stick_base -!=----------------------------------------------------------------------= - - USE kinds - USE io_global, ONLY: ionode - - IMPLICIT NONE - PRIVATE - SAVE - - PUBLIC :: sticks_maps, sticks_sort, sticks_countg, sticks_dist, sticks_pairup - PUBLIC :: sticks_owner, sticks_deallocate, pstickset, sticks_maps_scalar - -! ... sticks_owner : stick owner, sticks_owner( i, j ) is the index of the processor -! ... (starting from 1) owning the stick whose x and y coordinate are i and j. - - INTEGER, ALLOCATABLE, TARGET :: sticks_owner( : , : ) - - INTERFACE sticks_dist - MODULE PROCEDURE sticks_dist1 - END INTERFACE - -!=----------------------------------------------------------------------= - CONTAINS -!=----------------------------------------------------------------------= - - SUBROUTINE sticks_maps( tk, ub, lb, b1, b2, b3, gcut, gcutw, gcuts, st, stw, sts ) - - USE mp, ONLY: mp_sum - USE mp_global, ONLY: me_pool, nproc_pool, intra_pool_comm - - LOGICAL, INTENT(IN) :: tk ! if true use the full space grid - INTEGER, INTENT(IN) :: ub(:) ! upper bounds for i-th grid dimension - INTEGER, INTENT(IN) :: lb(:) ! lower bounds for i-th grid dimension - REAL(DP) , INTENT(IN) :: b1(:), b2(:), b3(:) ! reciprocal space base vectors - REAL(DP) , INTENT(IN) :: gcut ! cut-off for potentials - REAL(DP) , INTENT(IN) :: gcutw ! cut-off for plane waves - REAL(DP) , INTENT(IN) :: gcuts ! cut-off for smooth mesh - INTEGER, INTENT(OUT) :: st( lb(1): ub(1), lb(2):ub(2) ) ! stick map for potential - INTEGER, INTENT(OUT) :: stw(lb(1): ub(1), lb(2):ub(2) ) ! stick map for wave functions - INTEGER, INTENT(OUT) :: sts(lb(1): ub(1), lb(2):ub(2) ) ! stick map for smooth mesh - - INTEGER :: i, j, k, kip - REAL(DP) :: gsq - - stw = 0 - st = 0 - sts = 0 - -! ... Here find the basic maps of sticks st, stw and sts for the potential -! ... cut-off gcut, wavefunction cut-off gcutw, and smooth mesh cut-off gcuts - -! ... st(i,j) will contain the number of G vectors of the stick whose -! ... indices are (i,j). - -#if defined (__EKO) - write(*,*) ! Workaround for EKOPath compiler bug -#endif - IF( .NOT. tk ) THEN - - kip = 0 + ABS(lb(3)) + 1 - IF( MOD( kip, nproc_pool ) == me_pool ) THEN - st (0,0) = st (0,0) + 1 - stw(0,0) = stw(0,0) + 1 - sts(0,0) = sts(0,0) + 1 - END IF - - DO i= 0, 0 - DO j= 0, 0 - DO k= 1, ub(3) - kip = k + ABS(lb(3)) + 1 - IF( MOD( kip, nproc_pool ) == me_pool ) THEN - gsq= (DBLE(i)*b1(1)+DBLE(j)*b2(1)+DBLE(k)*b3(1) )**2 - gsq=gsq+(DBLE(i)*b1(2)+DBLE(j)*b2(2)+DBLE(k)*b3(2) )**2 - gsq=gsq+(DBLE(i)*b1(3)+DBLE(j)*b2(3)+DBLE(k)*b3(3) )**2 - IF(gsq.LE.gcut ) THEN - st(i,j) = st(i,j) + 1 - IF(gsq.LE.gcutw) THEN - stw(i,j) = stw(i,j) + 1 - END IF - IF(gsq.LE.gcuts) THEN - sts(i,j) = sts(i,j) + 1 - END IF - END IF - END IF - END DO - END DO - END DO - - DO i = 0, 0 - DO j = 1, ub(2) - DO k = lb(3), ub(3) - kip = k + ABS(lb(3)) + 1 - IF( MOD( kip, nproc_pool) == me_pool ) THEN - gsq= (DBLE(i)*b1(1)+DBLE(j)*b2(1)+DBLE(k)*b3(1) )**2 - gsq=gsq+(DBLE(i)*b1(2)+DBLE(j)*b2(2)+DBLE(k)*b3(2) )**2 - gsq=gsq+(DBLE(i)*b1(3)+DBLE(j)*b2(3)+DBLE(k)*b3(3) )**2 - IF(gsq.LE.gcut ) THEN - st(i,j) = st(i,j) + 1 - IF(gsq.LE.gcutw) THEN - stw(i,j) = stw(i,j) + 1 - END IF - IF(gsq.LE.gcuts) THEN - sts(i,j) = sts(i,j) + 1 - END IF - END IF - END IF - END DO - END DO - END DO - - DO i = 1, ub(1) - DO j = lb(2), ub(2) - DO k = lb(3), ub(3) - kip = k + ABS(lb(3)) + 1 - IF( MOD( kip, nproc_pool) == me_pool ) THEN - gsq= (DBLE(i)*b1(1)+DBLE(j)*b2(1)+DBLE(k)*b3(1) )**2 - gsq=gsq+(DBLE(i)*b1(2)+DBLE(j)*b2(2)+DBLE(k)*b3(2) )**2 - gsq=gsq+(DBLE(i)*b1(3)+DBLE(j)*b2(3)+DBLE(k)*b3(3) )**2 - IF(gsq.LE.gcut ) THEN - st(i,j) = st(i,j) + 1 - IF(gsq.LE.gcutw) THEN - stw(i,j) = stw(i,j) + 1 - END IF - IF(gsq.LE.gcuts) THEN - sts(i,j) = sts(i,j) + 1 - END IF - END IF - END IF - END DO - END DO - END DO - - ELSE - - DO i= lb(1), ub(1) - DO j= lb(2), ub(2) - DO k= lb(3), ub(3) - kip = k + ABS(lb(3)) + 1 - IF( MOD( kip, nproc_pool ) == me_pool ) THEN - gsq= (DBLE(i)*b1(1)+DBLE(j)*b2(1)+DBLE(k)*b3(1) )**2 - gsq=gsq+(DBLE(i)*b1(2)+DBLE(j)*b2(2)+DBLE(k)*b3(2) )**2 - gsq=gsq+(DBLE(i)*b1(3)+DBLE(j)*b2(3)+DBLE(k)*b3(3) )**2 - IF(gsq.LE.gcut ) THEN - st(i,j) = st(i,j) + 1 - END IF - IF(gsq.LE.gcutw) THEN - stw(i,j) = stw(i,j) + 1 - END IF - IF(gsq.LE.gcuts) THEN - sts(i,j) = sts(i,j) + 1 - END IF - END IF - END DO - END DO - END DO - - END IF - - CALL mp_sum(st ,intra_pool_comm ) - CALL mp_sum(stw ,intra_pool_comm ) - CALL mp_sum(sts ,intra_pool_comm ) - -#if defined __STICKS_DEBUG -! Test sticks - WRITE( 6,*) 'testtesttesttesttesttesttesttesttesttest' - WRITE( 6,*) 'lb = ', lb(1), lb(2) - WRITE( 6,*) 'ub = ', ub(1), ub(2) - WRITE( 6,*) 'counts = ', COUNT( st > 0 ), COUNT( stw > 0 ), COUNT( sts > 0 ) - WRITE( 6,*) 'cut-offs = ', gcut, gcutw, gcuts - WRITE( 6,*) 'b1 = ', b1(1:3) - WRITE( 6,*) 'b2 = ', b2(1:3) - WRITE( 6,*) 'b3 = ', b3(1:3) - DO i = lb(1), ub(1) - DO j = lb(2), ub(2) - WRITE( 6,'(2I4,3I6)') i,j,st(i,j),stw(i,j),sts(i,j) - END DO - END DO - WRITE( 6,*) 'testtesttesttesttesttesttesttesttesttest' -! Test sticks -#endif - - RETURN - END SUBROUTINE sticks_maps - -!=----------------------------------------------------------------------= - - SUBROUTINE sticks_maps_scalar( lgamma, ub, lb, b1, b2, b3, gcutm, gkcut, gcutms, stw, ngm, ngms ) - - LOGICAL, INTENT(IN) :: lgamma ! if true use gamma point simmetry - INTEGER, INTENT(IN) :: ub(:) ! upper bounds for i-th grid dimension - INTEGER, INTENT(IN) :: lb(:) ! lower bounds for i-th grid dimension - REAL(DP) , INTENT(IN) :: b1(:), b2(:), b3(:) ! reciprocal space base vectors - REAL(DP) , INTENT(IN) :: gcutm ! cut-off for potentials - REAL(DP) , INTENT(IN) :: gkcut ! cut-off for plane waves - REAL(DP) , INTENT(IN) :: gcutms ! cut-off for smooth mesh - ! - INTEGER, INTENT(OUT) :: ngm, ngms - ! - ! stick map for wave functions, note that map is taken in YZ plane - ! - INTEGER, INTENT(OUT) :: stw( lb(2) : ub(2), lb(3) : ub(3) ) - - INTEGER :: i1, i2, i3, n1, n2, n3 - REAL(DP) :: amod - - ngm = 0 - ngms = 0 - - n1 = MAX( ABS( lb(1) ), ABS( ub(1) ) ) - n2 = MAX( ABS( lb(2) ), ABS( ub(2) ) ) - n3 = MAX( ABS( lb(3) ), ABS( ub(3) ) ) - - loop1: do i1 = - n1, n1 - ! - ! Gamma-only: exclude space with x<0 - ! - if (lgamma .and. i1 < 0) cycle loop1 - ! - loop2: do i2 = - n2, n2 - ! - ! Gamma-only: exclude plane with x=0, y<0 - ! - if(lgamma .and. i1 == 0.and. i2 < 0) cycle loop2 - ! - loop3: do i3 = - n3, n3 - ! - ! Gamma-only: exclude line with x=0, y=0, z<0 - ! - if(lgamma .and. i1 == 0 .and. i2 == 0 .and. i3 < 0) cycle loop3 - ! - amod = (i1 * b1 (1) + i2 * b2 (1) + i3 * b3 (1) ) **2 + & - (i1 * b1 (2) + i2 * b2 (2) + i3 * b3 (2) ) **2 + & - (i1 * b1 (3) + i2 * b2 (3) + i3 * b3 (3) ) **2 - if (amod <= gcutm) ngm = ngm + 1 - if (amod <= gcutms) ngms = ngms + 1 - if (amod <= gkcut ) then - stw( i2, i3 ) = 1 - if (lgamma) stw( -i2, -i3 ) = 1 - end if - enddo loop3 - enddo loop2 - enddo loop1 - - RETURN - END SUBROUTINE sticks_maps_scalar - - -!=----------------------------------------------------------------------= - - SUBROUTINE sticks_sort( ngc, ngcw, ngcs, nct, idx ) - -! ... This subroutine sorts the sticks indexes, according to -! ... the lenght and type of the sticks, wave functions sticks -! ... first, then smooth mesh sticks, and finally potential -! ... sticks - - USE mp_global, ONLY: nproc_pool - - ! lenghts of sticks, ngc for potential mesh, ngcw for wave functions mesh - ! and ngcs for smooth mesh - - INTEGER, INTENT(IN) :: ngc(:), ngcw(:), ngcs(:) - - ! nct, total number of sticks - - INTEGER, INTENT(IN) :: nct - - ! index, on output, new sticks indexes - - INTEGER, INTENT(OUT) :: idx(:) - - INTEGER :: mc, nr3x, ic - REAL(DP) :: dn3 - REAL(DP), ALLOCATABLE :: aux(:) - - nr3x = MAXVAL( ngc(1:nct) ) + 1 - dn3 = REAL( nr3x ) - - IF( nproc_pool > 1 ) THEN - ALLOCATE( aux( nct ) ) - DO mc = 1, nct - aux(mc) = ngcw(mc) - aux(mc) = dn3 * aux(mc) + ngcs(mc) - aux(mc) = dn3 * aux(mc) + ngc(mc) - aux(mc) = -aux(mc) - idx(mc) = 0 - END DO - CALL hpsort( nct, aux(1), idx(1)) - DEALLOCATE( aux ) - ELSE - ic = 0 - do mc = 1, nct - if( ngcw(mc) > 0 ) then - ic = ic + 1 - idx(ic) = mc - endif - end do - do mc = 1, nct - if( ngcs(mc) > 0 .AND. ngcw(mc) == 0 ) then - ic = ic + 1 - idx(ic) = mc - endif - end do - do mc = 1, nct - if( ngc(mc) > 0 .AND. ngcs(mc) == 0 .AND. ngcw(mc) == 0 ) then - ic = ic + 1 - idx(ic) = mc - endif - end do - END IF - -#if defined __STICKS_DEBUG - WRITE( 6,*) '-----------------' - WRITE( 6,*) 'STICKS_SORT DEBUG' - DO mc = 1, nct - WRITE( 6, fmt="(4I10)" ) idx(mc), ngcw( idx(mc) ), ngcs( idx(mc) ), ngc( idx(mc) ) - END DO - WRITE( 6,*) '-----------------' -#endif - - RETURN - END SUBROUTINE sticks_sort - -!=----------------------------------------------------------------------= - - SUBROUTINE sticks_countg( tk, ub, lb, st, stw, sts, in1, in2, ngc, ngcw, ngcs ) - - INTEGER, INTENT(IN) :: ub(:), lb(:) - INTEGER, INTENT(IN) :: st( lb(1): ub(1), lb(2):ub(2) ) ! stick map for potential - INTEGER, INTENT(IN) :: stw(lb(1): ub(1), lb(2):ub(2) ) ! stick map for wave functions - INTEGER, INTENT(IN) :: sts(lb(1): ub(1), lb(2):ub(2) ) ! stick map for smooth mesh - LOGICAL, INTENT(IN) :: tk - - INTEGER, INTENT(OUT) :: in1(:), in2(:) - INTEGER, INTENT(OUT) :: ngc(:), ngcw(:), ngcs(:) - - INTEGER :: j1, j2, i1, i2, nct, min_size - -! -! ... initialize the sticks indexes array ist -! ... nct counts columns containing G-vectors for the dense grid -! ... ncts counts columns contaning G-vectors for the smooth grid -! - nct = 0 - - ngc = 0 - ngcs = 0 - ngcw = 0 - - min_size = MIN( SIZE( in1 ), SIZE( in2 ), SIZE( ngc ), SIZE( ngcw ), SIZE( ngcs ) ) - - DO j2 = 0, ( ub(2) - lb(2) ) - DO j1 = 0, ( ub(1) - lb(1) ) - - i1 = j1 - if( i1 > ub(1) ) i1 = lb(1) + ( i1 - ub(1) ) - 1 - - i2 = j2 - if( i2 > ub(2) ) i2 = lb(2) + ( i2 - ub(2) ) - 1 - - IF( st( i1, i2 ) > 0 ) THEN - - ! this sticks contains G-vectors - - nct = nct + 1 - IF( nct > min_size ) & - CALL errore(' sticks_countg ',' too many sticks ', nct ) - - in1(nct) = i1 - in2(nct) = i2 - - ngc(nct) = st( i1 , i2) - IF( stw( i1, i2 ) .GT. 0 ) ngcw(nct) = stw( i1 , i2) - IF( sts( i1, i2 ) .GT. 0 ) ngcs(nct) = sts( i1 , i2) - - END IF - - ! WRITE(7,fmt="(5I5)") i1, i2, nct, ngc(nct), ngcw( nct ) - - END DO - END DO - - RETURN - END SUBROUTINE sticks_countg - -!=----------------------------------------------------------------------= - - SUBROUTINE sticks_dist1( tk, ub, lb, idx, in1, in2, ngc, ngcw, ngcs, nct, & - ncp, ncpw, ncps, ngp, ngpw, ngps, stown, stownw, stowns ) - - USE mp_global, ONLY: nproc_pool - - LOGICAL, INTENT(IN) :: tk - - INTEGER, INTENT(IN) :: ub(:), lb(:), idx(:) - INTEGER, INTENT(OUT) :: stown( lb(1): ub(1), lb(2):ub(2) ) ! stick map for potential - INTEGER, INTENT(OUT) :: stownw(lb(1): ub(1), lb(2):ub(2) ) ! stick map for wave functions - INTEGER, INTENT(OUT) :: stowns(lb(1): ub(1), lb(2):ub(2) ) ! stick map for smooth mesh - - INTEGER, INTENT(IN) :: in1(:), in2(:) - INTEGER, INTENT(IN) :: ngc(:), ngcw(:), ngcs(:) - INTEGER, INTENT(IN) :: nct - INTEGER, INTENT(OUT) :: ncp(:), ncpw(:), ncps(:) - INTEGER, INTENT(OUT) :: ngp(:), ngpw(:), ngps(:) - - INTEGER :: mc, i1, i2, i, j, jj - - ncp = 0 - ncps = 0 - ncpw = 0 - ngp = 0 - ngps = 0 - ngpw = 0 - - stown = 0 - stownw = 0 - stowns = 0 - - DO mc = 1, nct - - i = idx( mc ) -! -! index contains the desired ordering of sticks (see above) -! - i1 = in1( i ) - i2 = in2( i ) -! - if ( ( .NOT. tk ) .AND. ( (i1 < 0) .or. ( (i1 == 0) .and. (i2 < 0) ) ) ) go to 30 -! - jj = 1 - - if ( ngcw(i) > 0 ) then -! -! this is an active sticks: find which processor has currently -! the smallest number of plane waves -! - do j = 1, nproc_pool - if ( ngpw(j) < ngpw(jj) ) then - jj = j - else if ( ( ngpw(j) == ngpw(jj) ) .AND. ( ncpw(j) < ncpw(jj) ) ) then - jj = j - end if - end do - - else -! -! this is an inactive sticks: find which processor has currently -! the smallest number of G-vectors -! - do j = 1, nproc_pool - if ( ngp(j) < ngp(jj) ) jj = j - end do - - end if -! - ! potential mesh - - ncp(jj) = ncp(jj) + 1 - ngp(jj) = ngp(jj) + ngc(i) - stown(i1,i2) = jj - - ! smooth mesh - - if ( ngcs(i) > 0 ) then - ncps(jj) = ncps(jj) + 1 - ngps(jj) = ngps(jj) + ngcs(i) - stowns(i1,i2) = jj - endif - - ! wave functions mesh - - if ( ngcw(i) > 0 ) then - ncpw(jj) = ncpw(jj) + 1 - ngpw(jj) = ngpw(jj) + ngcw(i) - stownw(i1,i2) = jj - endif - - 30 continue - - END DO - - RETURN - END SUBROUTINE sticks_dist1 - -!=----------------------------------------------------------------------= - - SUBROUTINE sticks_pairup( tk, ub, lb, idx, in1, in2, ngc, ngcw, ngcs, nct, & - ncp, ncpw, ncps, ngp, ngpw, ngps, stown, stownw, stowns ) - - USE mp_global, ONLY: nproc_pool - - LOGICAL, INTENT(IN) :: tk - - INTEGER, INTENT(IN) :: ub(:), lb(:), idx(:) - INTEGER, INTENT(INOUT) :: stown( lb(1): ub(1), lb(2):ub(2) ) ! stick map for potential - INTEGER, INTENT(INOUT) :: stownw(lb(1): ub(1), lb(2):ub(2) ) ! stick map for wave functions - INTEGER, INTENT(INOUT) :: stowns(lb(1): ub(1), lb(2):ub(2) ) ! stick map for wave functions - - INTEGER, INTENT(IN) :: in1(:), in2(:) - INTEGER, INTENT(IN) :: ngc(:), ngcw(:), ngcs(:) - INTEGER, INTENT(IN) :: nct - INTEGER, INTENT(OUT) :: ncp(:), ncpw(:), ncps(:) - INTEGER, INTENT(OUT) :: ngp(:), ngpw(:), ngps(:) - - INTEGER :: mc, i1, i2, i, jj - - IF ( .NOT. tk ) THEN - - ! when gamma symmetry is used only the sticks of half reciprocal space - ! are generated, then here we pair-up the sticks with those of the other - ! half of the space, using the gamma symmetry relation - ! Note that the total numero of stick "nct" is not modified - - DO mc = 1, nct - i = idx(mc) - i1 = in1(i) - i2 = in2(i) - IF( i1 == 0 .and. i2 == 0 ) THEN - jj = stown( i1, i2 ) - if( jj > 0 ) ngp( jj ) = ngp( jj ) + ngc( i ) - 1 - jj = stowns( i1, i2 ) - if( jj > 0 ) ngps( jj ) = ngps( jj ) + ngcs( i ) - 1 - jj = stownw( i1, i2 ) - if( jj > 0 ) ngpw( jj ) = ngpw( jj ) + ngcw( i ) - 1 - ELSE - jj = stown( i1, i2 ) - if( jj > 0 ) then - stown( -i1, -i2 ) = jj - ncp( jj ) = ncp( jj ) + 1 - ngp( jj ) = ngp( jj ) + ngc( i ) - end if - jj = stowns( i1, i2 ) - if( jj > 0 ) then - stowns( -i1, -i2 ) = jj - ncps( jj ) = ncps( jj ) + 1 - ngps( jj ) = ngps( jj ) + ngcs( i ) - end if - jj = stownw( i1, i2 ) - if( jj > 0 ) then - stownw( -i1, -i2 ) = jj - ncpw( jj ) = ncpw( jj ) + 1 - ngpw( jj ) = ngpw( jj ) + ngcw( i ) - end if - END IF - END DO - - END IF - - IF( ALLOCATED( sticks_owner ) ) DEALLOCATE( sticks_owner ) - ALLOCATE( sticks_owner( lb(1): ub(1), lb(2):ub(2) ) ) - - sticks_owner( :, : ) = ABS( stown( :, :) ) - - RETURN - END SUBROUTINE sticks_pairup - -!=----------------------------------------------------------------------= - - - SUBROUTINE pstickset( dfftp, dffts, alat, a1, a2, a3, gcut, gkcut, gcuts, & - nr1, nr2, nr3, nr1x, nr2x, nr3x, nr1s, nr2s, nr3s, nr1sx, nr2sx, nr3sx, & - ngw, ngm, ngs ) - - USE kinds, ONLY: DP - USE mp_global, ONLY: me_pool, nproc_pool, intra_pool_comm, nogrp - USE control_flags, ONLY: gamma_only, do_wf_cmplx !added:giovanni - USE io_global, ONLY: ionode - USE io_global, ONLY: stdout - USE fft_types, ONLY: fft_dlay_descriptor, fft_dlay_allocate, fft_dlay_set, & - fft_dlay_scalar - - - TYPE(fft_dlay_descriptor), INTENT(INOUT) :: dfftp, dffts - REAL(DP), INTENT(IN) :: a1(3), a2(3), a3(3), alat - REAL(DP), INTENT(IN) :: gcut, gkcut, gcuts - INTEGER, INTENT(IN) :: nr1, nr2, nr3, nr1x, nr2x, nr3x - INTEGER, INTENT(IN) :: nr1s, nr2s, nr3s, nr1sx, nr2sx, nr3sx - INTEGER, INTENT(OUT) :: ngw, ngm, ngs - - LOGICAL :: tk -! ... tk logical flag, TRUE if the symulation does not have the -! ... GAMMA symmetry - - REAL(DP) :: b1(3), b2(3), b3(3) -! ... b1, b2, b3 reciprocal space base vectors. - - INTEGER :: ub(3), lb(3) -! ... ub(i), lb(i) upper and lower miller indexes - -! -! ... Plane Waves -! - - INTEGER, ALLOCATABLE :: stw(:,:) -! ... stick map (wave functions), stw(i,j) = number of G-vector in the -! ... stick whose x and y miller index are i and j - - INTEGER, ALLOCATABLE :: nstpw(:) -! ... number of sticks (wave functions), nstpw(ip) = number of stick -! ... for processor ip - - INTEGER, ALLOCATABLE :: sstpw(:) -! ... number of G-vectors (wave functions), sstpw(ip) = sum of the -! ... sticks lenght for processor ip = number of G-vectors -! ... owned by the processor ip - - INTEGER :: nstw, nstpwx -! ... nstw local number of sticks (wave functions) -! ... nstpwx maximum among all processors of nstw - -! -! ... Potentials -! - - INTEGER, ALLOCATABLE :: st(:,:) -! ... stick map (potentials), st(i,j) = number of G-vector in the -! ... stick whose x and y miller index are i and j - - INTEGER, ALLOCATABLE :: nstp(:) -! ... number of sticks (potentials), nstp(ip) = number of stick -! ... for processor ip - - INTEGER, ALLOCATABLE :: sstp(:) -! ... number of G-vectors (potentials), sstp(ip) = sum of the -! ... sticks lenght for processor ip = number of G-vectors -! ... owned by the processor ip - - INTEGER :: nst, nstpx -! ... nst local number of sticks (potentials) -! ... nstpx maximum among all processors of nst - -! -! ... Smooth Mesh -! - - INTEGER, ALLOCATABLE :: sts(:,:) -! ... stick map (smooth mesh), sts(i,j) = number of G-vector in the -! ... stick whose x and y miller index are i and j - - INTEGER, ALLOCATABLE :: nstps(:) -! ... number of sticks (smooth mesh), nstp(ip) = number of stick -! ... for processor ip - - INTEGER, ALLOCATABLE :: sstps(:) -! ... number of G-vectors (smooth mesh), sstps(ip) = sum of the -! ... sticks lenght for processor ip = number of G-vectors -! ... owned by the processor ip - - INTEGER :: nsts -! ... nsts local number of sticks (smooth mesh) - - - INTEGER, ALLOCATABLE :: ist(:,:) ! sticks indexes ordered - - - - INTEGER :: ip, ngm_ , ngs_ - INTEGER, ALLOCATABLE :: idx(:) - - tk = .NOT. (gamma_only)!.and..not.do_wf_cmplx)!added:giovanni do_wf_cmplx - ub(1) = ( nr1 - 1 ) / 2 - ub(2) = ( nr2 - 1 ) / 2 - ub(3) = ( nr3 - 1 ) / 2 - lb = - ub - - ! ... reciprocal lattice generators - - CALL recips( a1, a2, a3, b1, b2, b3 ) - b1 = b1 * alat - b2 = b2 * alat - b3 = b3 * alat - - ! ... Allocate maps - - ALLOCATE( stw ( lb(1):ub(1), lb(2):ub(2) ) ) - ALLOCATE( st ( lb(1):ub(1), lb(2):ub(2) ) ) - ALLOCATE( sts ( lb(1):ub(1), lb(2):ub(2) ) ) - - st = 0 - stw = 0 - sts = 0 - -! ... Fill in the stick maps, for given g-space base (b1,b2,b3) and cut-off - - CALL sticks_maps( tk, ub, lb, b1, b2, b3, gcut, gkcut, gcuts, st, stw, sts ) - -! ... Now count the number of stick nst and nstw - - nst = COUNT( st > 0 ) - nstw = COUNT( stw > 0 ) - nsts = COUNT( sts > 0 ) - - IF (ionode) THEN - WRITE( stdout,*) - WRITE( stdout,10) - 10 FORMAT(3X,'Stick Mesh',/, & - 3X,'----------') - WRITE( stdout,15) nst, nstw, nsts - 15 FORMAT( 3X, 'nst =', I6, ', nstw =', I6, ', nsts =', I6 ) - END IF - - ALLOCATE(ist(nst,5)) - - ALLOCATE(nstp(nproc_pool)) - ALLOCATE(sstp(nproc_pool)) - - ALLOCATE(nstpw(nproc_pool)) - ALLOCATE(sstpw(nproc_pool)) - - ALLOCATE(nstps(nproc_pool)) - ALLOCATE(sstps(nproc_pool)) - -! ... initialize the sticks indexes array ist - - CALL sticks_countg( tk, ub, lb, st, stw, sts, & - ist(:,1), ist(:,2), ist(:,4), ist(:,3), ist(:,5) ) - -! ... Sorts the sticks according to their lenght - - ALLOCATE( idx( nst ) ) - - CALL sticks_sort( ist(:,4), ist(:,3), ist(:,5), nst, idx ) - - ! ... Set as first stick the stick containing the G=0 - ! - ! DO iss = 1, nst - ! IF( ist( idx( iss ), 1 ) == 0 .AND. ist( idx( iss ), 2 ) == 0 ) EXIT - ! END DO - ! itmp = idx( 1 ) - ! idx( 1 ) = idx( iss ) - ! idx( iss ) = itmp - - CALL sticks_dist( tk, ub, lb, idx, ist(:,1), ist(:,2), ist(:,4), ist(:,3), ist(:,5), & - nst, nstp, nstpw, nstps, sstp, sstpw, sstps, st, stw, sts ) - - ngw = sstpw( me_pool + 1 ) - ngm = sstp( me_pool + 1 ) - ngs = sstps( me_pool + 1 ) - - CALL sticks_pairup( tk, ub, lb, idx, ist(:,1), ist(:,2), ist(:,4), ist(:,3), ist(:,5), & - nst, nstp, nstpw, nstps, sstp, sstpw, sstps, st, stw, sts ) - - ! ... Allocate and Set fft data layout descriptors - -#if defined __PARA - - CALL fft_dlay_allocate( dfftp, nproc_pool, nr1x, nr2x ) - CALL fft_dlay_allocate( dffts, nproc_pool, nr1sx, nr2sx ) - - CALL fft_dlay_set( dfftp, tk, nst, nr1, nr2, nr3, nr1x, nr2x, nr3x, (me_pool+1), & - nproc_pool, nogrp, ub, lb, idx, ist(:,1), ist(:,2), nstp, nstpw, sstp, sstpw, st, stw ) - CALL fft_dlay_set( dffts, tk, nsts, nr1s, nr2s, nr3s, nr1sx, nr2sx, nr3sx, (me_pool+1), & - nproc_pool, nogrp, ub, lb, idx, ist(:,1), ist(:,2), nstps, nstpw, sstps, sstpw, sts, stw ) - -#else - - DEALLOCATE( stw ) - ALLOCATE( stw( lb(2) : ub(2), lb(3) : ub(3) ) ) - - CALL sticks_maps_scalar( (.not.tk), ub, lb, b1, b2, b3, gcut, gkcut, gcuts, stw, ngm_ , ngs_ ) - - IF( ngm_ /= ngm ) CALL errore( ' pstickset ', ' inconsistent ngm ', ABS( ngm - ngm_ ) ) - IF( ngs_ /= ngs ) CALL errore( ' pstickset ', ' inconsistent ngs ', ABS( ngs - ngs_ ) ) - - CALL fft_dlay_allocate( dfftp, nproc_pool, MAX(nr1x, nr3x), nr2x ) - CALL fft_dlay_allocate( dffts, nproc_pool, MAX(nr1sx, nr3sx), nr2sx ) - - CALL fft_dlay_scalar( dfftp, ub, lb, nr1, nr2, nr3, nr1x, nr2x, nr3x, stw ) - CALL fft_dlay_scalar( dffts, ub, lb, nr1s, nr2s, nr3s, nr1sx, nr2sx, nr3sx, stw ) - -#endif - -! ... Maximum number of sticks (potentials) - nstpx = MAXVAL( nstp ) -! ... Maximum number of sticks (wave func.) - nstpwx = MAXVAL( nstpw ) - - IF (ionode) WRITE( stdout,119) - 119 FORMAT(3X,' PEs n.st n.stw n.sts n.g n.gw n.gs') - DO ip = 1, nproc_pool - IF (ionode) THEN - WRITE( stdout,120) ip, nstp(ip), nstpw(ip), nstps(ip), sstp(ip), sstpw(ip), sstps(ip) - END IF - END DO - IF (ionode) THEN - WRITE( stdout,120) 0, SUM(nstp), SUM(nstpw), SUM(nstps), SUM(sstp), SUM(sstpw), SUM(sstps) - END IF - 120 FORMAT(3X,7I8) - - - DEALLOCATE( ist ) - DEALLOCATE( idx ) - - DEALLOCATE( st, stw, sts ) - DEALLOCATE( sstp ) - DEALLOCATE( nstp ) - DEALLOCATE( sstpw ) - DEALLOCATE( nstpw ) - DEALLOCATE( sstps ) - DEALLOCATE( nstps ) - - IF(ionode) WRITE( stdout,*) - - RETURN - END SUBROUTINE pstickset - - -!=----------------------------------------------------------------------= - - SUBROUTINE sticks_deallocate - IF( ALLOCATED( sticks_owner ) ) DEALLOCATE( sticks_owner ) - RETURN - END SUBROUTINE sticks_deallocate - - -!=----------------------------------------------------------------------= - END MODULE stick_base -!=----------------------------------------------------------------------= diff --git a/quantum_espresso/kcp/Modules/task_groups.f90 b/quantum_espresso/kcp/Modules/task_groups.f90 deleted file mode 100755 index 8630ebd89..000000000 --- a/quantum_espresso/kcp/Modules/task_groups.f90 +++ /dev/null @@ -1,225 +0,0 @@ -! -! Copyright (C) 2002-2004 PWSCF-FPMD-CP90 group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!----------------------------------------- -! Contributed by C. Bekas, October 2005 -! Revised by C. Cavazzoni -!-------------------------------------------- - -MODULE task_groups - - USE kinds, ONLY: DP - - IMPLICIT NONE - SAVE - - -CONTAINS - - -!======================================================================================== -! ADDED SUBROUTINEs FOR TASK GROUP PARALLIZATION -! C. Bekas, IBM Research, Zurich -! - GROUPS: Define and initialize Task Groups -! - tg_ivfftw: Inverse FFT driver for Task Groups -!======================================================================================= - - -!----------------------------------------------------------------------- -! SUBROUTINE GROUPS (added by C. Bekas) -! Define groups for task group parallilization -!----------------------------------------------------------------------- - -SUBROUTINE task_groups_init( dffts ) - - USE parallel_include - ! - USE mp_global, ONLY : me_pool, nproc_pool, intra_pool_comm - USE mp_global, ONLY : NOGRP, NPGRP, ogrp_comm, pgrp_comm - USE mp_global, ONLY : nolist, nplist - USE io_global, only : stdout - USE fft_types, only : fft_dlay_descriptor - - ! T.G. - ! NPGRP: Number of processors per group - ! NOGRP: Number of group - - IMPLICIT NONE - - TYPE(fft_dlay_descriptor), INTENT(INOUT) :: dffts - - !---------------------------------- - !Local Variables declaration - !---------------------------------- - - INTEGER :: I - INTEGER :: IERR - INTEGER :: num_planes, num_sticks - INTEGER :: nnrsx_vec ( nproc_pool ) - INTEGER :: pgroup( nproc_pool ) - INTEGER :: strd - - ! - WRITE( stdout, 100 ) nogrp, npgrp - -100 FORMAT( /,3X,'Task Groups are in use',/,3X,'groups and procs/group : ',I5,I5 ) - - !Find maximum chunk of local data concerning coefficients of eigenfunctions in g-space - -#if defined __MPI - CALL MPI_Allgather( dffts%nnr, 1, MPI_INTEGER, nnrsx_vec, 1, MPI_INTEGER, intra_pool_comm, IERR) - strd = MAXVAL( nnrsx_vec( 1:nproc_pool ) ) -#else - strd = dffts%nnr -#endif - - IF( strd /= dffts%nnrx ) CALL errore( ' task_groups_init ', ' inconsistent nnrx ', 1 ) - - !------------------------------------------------------------------------------------- - !C. Bekas...TASK GROUP RELATED. FFT DATA STRUCTURES ARE ALREADY DEFINED ABOVE - !------------------------------------------------------------------------------------- - !dfft%nsw(me) holds the number of z-sticks for the current processor per wave-function - !We can either send these in the group with an mpi_allgather...or put the - !in the PSIS vector (in special positions) and send them with them. - !Otherwise we can do this once at the beginning, before the loop. - !we choose to do the latter one. - !------------------------------------------------------------------------------------- - ! - ALLOCATE( dffts%tg_nsw(nproc_pool)) - ALLOCATE( dffts%tg_npp(nproc_pool)) - - num_sticks = 0 - num_planes = 0 - DO i = 1, nogrp - num_sticks = num_sticks + dffts%nsw( nolist(i) + 1 ) - num_planes = num_planes + dffts%npp( nolist(i) + 1 ) - ENDDO - -#if defined __MPI - CALL MPI_ALLGATHER(num_sticks, 1, MPI_INTEGER, dffts%tg_nsw(1), 1, MPI_INTEGER, intra_pool_comm, IERR) - CALL MPI_ALLGATHER(num_planes, 1, MPI_INTEGER, dffts%tg_npp(1), 1, MPI_INTEGER, intra_pool_comm, IERR) -#else - dffts%tg_nsw(1) = num_sticks - dffts%tg_npp(1) = num_planes -#endif - - ALLOCATE( dffts%tg_snd( nogrp ) ) - ALLOCATE( dffts%tg_rcv( nogrp ) ) - ALLOCATE( dffts%tg_psdsp( nogrp ) ) - ALLOCATE( dffts%tg_usdsp( nogrp ) ) - ALLOCATE( dffts%tg_rdsp( nogrp ) ) - - dffts%tg_snd(1) = dffts%nr3x * dffts%nsw( me_pool + 1 ) - IF( dffts%nr3x * dffts%nsw( me_pool + 1 ) > dffts%nnrx ) THEN - CALL errore( ' task_groups_init ', ' inconsistent dffts%nnrx ', 1 ) - END IF - dffts%tg_psdsp(1) = 0 - dffts%tg_usdsp(1) = 0 - dffts%tg_rcv(1) = dffts%nr3x * dffts%nsw( nolist(1) + 1 ) - dffts%tg_rdsp(1) = 0 - DO i = 2, nogrp - dffts%tg_snd(i) = dffts%nr3x * dffts%nsw( me_pool + 1 ) - dffts%tg_psdsp(i) = dffts%tg_psdsp(i-1) + dffts%nnrx - dffts%tg_usdsp(i) = dffts%tg_usdsp(i-1) + dffts%tg_snd(i-1) - dffts%tg_rcv(i) = dffts%nr3x * dffts%nsw( nolist(i) + 1 ) - dffts%tg_rdsp(i) = dffts%tg_rdsp(i-1) + dffts%tg_rcv(i-1) - ENDDO - - ! ALLOCATE( dffts%tg_sca_snd( nproc_pool / nogrp ) ) - ! ALLOCATE( dffts%tg_sca_rcv( nproc_pool / nogrp ) ) - ! ALLOCATE( dffts%tg_sca_sdsp( nproc_pool / nogrp ) ) - ! ALLOCATE( dffts%tg_sca_rdsp( nproc_pool / nogrp ) ) - ! ALLOCATE( dffts%tg_sca_off( nproc_pool / nogrp ) ) - - ! do i = 1, nproc_pool / nogrp - ! dffts%tg_sca_snd (i) = dffts%tg_npp ( nplist( i ) + 1 ) * dffts%tg_nsw ( me_pool + 1 ) - ! dffts%tg_sca_rcv (i) = dffts%tg_npp ( me_pool + 1 ) * dffts%tg_nsw ( nplist( i ) + 1 ) - ! end do - ! dffts%tg_sca_off(1) = 0 - ! do i = 2, nproc_pool / nogrp - ! dffts%tg_sca_off(i) = dffts%tg_sca_off(i - 1) + dffts%tg_npp ( nplist( i - 1 ) + 1 ) - ! end do - ! dffts%tg_sca_sdsp (1) = 0 - ! dffts%tg_sca_rdsp (1) = 0 - ! do i = 2, nproc_pool / nogrp - ! dffts%tg_sca_sdsp (i) = dffts%tg_sca_sdsp (i - 1) + dffts%tg_sca_snd (i - 1) - ! dffts%tg_sca_rdsp (i) = dffts%tg_sca_rdsp (i - 1) + dffts%tg_sca_rcv (i - 1) - ! enddo - - dffts%have_task_groups = .TRUE. - - RETURN - -END SUBROUTINE task_groups_init - -! - -SUBROUTINE tg_gather( dffts, v, tg_v ) - ! - USE parallel_include - ! - USE mp_global, ONLY : me_pool, nogrp, ogrp_comm, nolist - USE fft_types, only : fft_dlay_descriptor - - ! T.G. - ! NPGRP: Number of processors per group - ! NOGRP: Number of group - - IMPLICIT NONE - - TYPE(fft_dlay_descriptor), INTENT(IN) :: dffts - - REAL(DP) :: v(:) - REAL(DP) :: tg_v(:) - - INTEGER :: nsiz, i, ierr, nsiz_tg - INTEGER :: recv_cnt( nogrp ), recv_displ( nogrp ) - - nsiz_tg = dffts%nnrx * nogrp - - IF( SIZE( tg_v ) < nsiz_tg ) & - call errore( ' tg_gather ', ' tg_v too small ', ( nsiz_tg - SIZE( tg_v ) ) ) - - nsiz = dffts%npp( me_pool+1 ) * dffts%nr1x * dffts%nr2x - - IF( SIZE( v ) < nsiz ) & - call errore( ' tg_gather ', ' v too small ', ( nsiz - SIZE( v ) ) ) - - ! - ! The potential in v is distributed accros all processors - ! We need to redistribute it so that it is completely contained in the - ! processors of an orbital TASK-GROUP - ! - recv_cnt(1) = dffts%npp( nolist(1) + 1 ) * dffts%nr1x * dffts%nr2x - recv_displ(1) = 0 - DO i = 2, NOGRP - recv_cnt(i) = dffts%npp( nolist(i) + 1 ) * dffts%nr1x * dffts%nr2x - recv_displ(i) = recv_displ(i-1) + recv_cnt(i-1) - ENDDO - - ! clean only elements that will not be overwritten - ! - DO i = recv_displ(nogrp) + recv_cnt( nogrp ) + 1, SIZE( tg_v ) - tg_v( i ) = 0.0d0 - END DO - -#if defined (__PARA) && defined (__MPI) - - CALL MPI_Allgatherv( v(1), nsiz, MPI_DOUBLE_PRECISION, & - tg_v(1), recv_cnt, recv_displ, MPI_DOUBLE_PRECISION, ogrp_comm, IERR) - ! - IF( ierr /= 0 ) & - call errore( ' tg_gather ', ' MPI_Allgatherv ', ABS( ierr ) ) - -#endif - - - RETURN -END SUBROUTINE - - -END MODULE task_groups diff --git a/quantum_espresso/kcp/Modules/timestep.f90 b/quantum_espresso/kcp/Modules/timestep.f90 deleted file mode 100644 index e62489c74..000000000 --- a/quantum_espresso/kcp/Modules/timestep.f90 +++ /dev/null @@ -1,68 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - - -! AB INITIO COSTANT PRESSURE MOLECULAR DYNAMICS -! ---------------------------------------------- -! Car-Parrinello Parallel Program -! Carlo Cavazzoni - Gerardo Ballabio -! SISSA, Trieste, Italy - 1997-99 -! Last modified: Sat Feb 12 11:43:48 MET 2000 -! ---------------------------------------------- -! BEGIN manual - - MODULE time_step - -! (describe briefly what this module does...) -! ---------------------------------------------- -! routines in this module: -! SUBROUTINE set_time_step(dt) -! ---------------------------------------------- -! END manual -! ---------------------------------------------- - - USE kinds - IMPLICIT NONE - SAVE - - PRIVATE - -! ... declare module-scope variables - REAL(DP) :: delthal, twodelt, fordt2, dt2, dt2by2, delt - REAL(DP) :: tps ! elapsed simulated time in picoseconds - - PUBLIC :: set_time_step, tps, delt, twodelt, dt2, dt2by2 - -! end of module-scope declarations -! ---------------------------------------------- - - CONTAINS - -! subroutines -! ---------------------------------------------- -! ---------------------------------------------- - SUBROUTINE set_time_step(dt) - - REAL(DP), INTENT(IN) :: dt - - delt = dt - dt2 = dt ** 2 - fordt2 = 4.0_DP * dt2 - delthal = 0.5_DP * delt - twodelt = 2.0_DP * delt - dt2by2 = 0.5_DP * dt2 - tps = 0.0_DP - - RETURN - END SUBROUTINE set_time_step - -! ---------------------------------------------- -! ---------------------------------------------- - - END MODULE time_step - diff --git a/quantum_espresso/kcp/Modules/twin_types.f90 b/quantum_espresso/kcp/Modules/twin_types.f90 deleted file mode 100644 index 52d419bcd..000000000 --- a/quantum_espresso/kcp/Modules/twin_types.f90 +++ /dev/null @@ -1,518 +0,0 @@ -! -! Copyright (C) 2002-2005 FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! #include "f_defs.h" -! -!---------------------------------------------------------------------------- -MODULE twin_types - !---------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE control_flags, ONLY : gamma_only, do_wf_cmplx - ! - - IMPLICIT NONE - - INTERFACE init_twin - MODULE PROCEDURE init_twin_matrix, init_twin_tensor - END INTERFACE - - INTERFACE set_twin - MODULE PROCEDURE set_twin_matrix, set_twin_tensor, set_index_twin_matrix, set_index_twin_tensor - END INTERFACE - - INTERFACE copy_twin - MODULE PROCEDURE copy_twin_matrix, copy_twin_tensor - END INTERFACE - - INTERFACE zaxpy_twin - MODULE PROCEDURE zaxpy_twin_matrix, zaxpy_twin_tensor - END INTERFACE - - INTERFACE allocate_twin - MODULE PROCEDURE allocate_twin_matrix, allocate_twin_tensor - END INTERFACE - - INTERFACE deallocate_twin - MODULE PROCEDURE deallocate_twin_matrix, deallocate_twin_tensor - END INTERFACE - - INTERFACE twin_mp_sum - MODULE PROCEDURE tmatrix_mp_sum, ttensor_mp_sum - END INTERFACE - - INTERFACE twin_mp_bcast - MODULE PROCEDURE tmatrix_mp_bcast, ttensor_mp_bcast - END INTERFACE - - TYPE :: twin_matrix - - REAL(DP), DIMENSION(:,:), POINTER :: rvec - COMPLEX(DP), DIMENSION(:,:), POINTER :: cvec - - INTEGER :: xdim - INTEGER :: ydim - - LOGICAL :: isalloc - LOGICAL :: iscmplx - - END TYPE twin_matrix - - TYPE :: twin_tensor - - REAL(DP), DIMENSION(:,:,:), POINTER :: rvec - COMPLEX(DP), DIMENSION(:,:,:), POINTER :: cvec - - INTEGER :: xdim - INTEGER :: ydim - INTEGER :: zdim - - LOGICAL :: isalloc - LOGICAL :: iscmplx - - END TYPE twin_tensor -!! rvec-> rdata -!! ierr ovunque - CONTAINS - - SUBROUTINE init_twin_matrix(tmatrix, lgam) - - type(twin_matrix) :: tmatrix - logical, intent(in) :: lgam - - tmatrix%isalloc=.false. - tmatrix%iscmplx = .not.lgam - - return - END SUBROUTINE init_twin_matrix - - SUBROUTINE set_twin_matrix(tmatrix, value) - - type(twin_matrix) :: tmatrix - COMPLEX(DP), INTENT(IN) :: value - - IF(tmatrix%iscmplx) THEN - tmatrix%cvec=value - ELSE - tmatrix%rvec = DBLE(value) - ENDIF - - return - END SUBROUTINE set_twin_matrix - - SUBROUTINE set_index_twin_matrix(tmatrix,i,j, value) - - type(twin_matrix) :: tmatrix - COMPLEX(DP), INTENT(IN) :: value - INTEGER, INTENT(IN) :: i,j - - IF(tmatrix%iscmplx) THEN - tmatrix%cvec(i,j)=value - ELSE - tmatrix%rvec(i,j) = DBLE(value) - ENDIF - - return - END SUBROUTINE set_index_twin_matrix - - SUBROUTINE init_twin_tensor(ttensor, lgam) - - type(twin_tensor) :: ttensor - logical, intent(in) :: lgam - - ttensor%isalloc=.false. - ttensor%iscmplx = .not.lgam - - return - END SUBROUTINE init_twin_tensor - - SUBROUTINE set_twin_tensor(ttensor, value) - - type(twin_tensor) :: ttensor - COMPLEX(DP), INTENT(IN) :: value - - IF(ttensor%iscmplx) THEN - ttensor%cvec=value - ELSE - ttensor%rvec = DBLE(value) - ENDIF - - return - END SUBROUTINE set_twin_tensor - - SUBROUTINE set_index_twin_tensor(ttensor,i,j,k, value) - - type(twin_tensor) :: ttensor - COMPLEX(DP), INTENT(IN) :: value - INTEGER, INTENT(IN) :: i,j,k - - IF(ttensor%iscmplx) THEN - ttensor%cvec(i,j,k)=value - ELSE - ttensor%rvec(i,j,k) = DBLE(value) - ENDIF - - return - END SUBROUTINE set_index_twin_tensor - - SUBROUTINE copy_twin_matrix(tmatrix1,tmatrix2) - - type(twin_matrix) :: tmatrix1,tmatrix2 - - character(len=17) :: subname="copy_twin_tensor" - - IF(tmatrix1%xdim.ne.tmatrix2%xdim .OR. tmatrix1%ydim.ne.tmatrix2%ydim) THEN - call errore(subname,"copying twin matrices with incompatible size", 1) - ENDIF -! COMPLEX(DP), INTENT(IN) :: value - - IF(tmatrix1%iscmplx) THEN - IF(tmatrix2%iscmplx) THEN - tmatrix1%cvec(:,:)=tmatrix2%cvec(:,:) - ELSE - call errore(subname,"copying real tensor into complex tensor", 1) - tmatrix1%cvec(:,:)=tmatrix2%rvec(:,:) - ENDIF - ELSE - IF(.not.tmatrix2%iscmplx) THEN - tmatrix1%rvec(:,:)=tmatrix2%rvec(:,:) - ELSE - call errore(subname,"copying complex tensor into real tensor", 1) - tmatrix1%rvec(:,:)=tmatrix2%cvec(:,:) - ENDIF - ENDIF - - return - END SUBROUTINE copy_twin_matrix - - SUBROUTINE zaxpy_twin_matrix(tmatrix1,tmatrix2, coef) - - type(twin_matrix) :: tmatrix1,tmatrix2 - COMPLEX(DP) :: coef - character(len=17) :: subname="copy_twin_tensor" -! COMPLEX(DP), INTENT(IN) :: value - - IF(tmatrix1%xdim.ne.tmatrix2%xdim .OR. tmatrix1%ydim.ne.tmatrix2%ydim) THEN - call errore(subname,"copying twin matrices with incompatible size", 1) - ENDIF - - IF(tmatrix1%iscmplx) THEN - IF(tmatrix2%iscmplx) THEN - tmatrix1%cvec(:,:)=tmatrix2%cvec(:,:)+coef*tmatrix1%cvec(:,:) - ELSE - call errore(subname,"copying real tensor into complex tensor", 1) - tmatrix1%cvec(:,:)=tmatrix2%rvec(:,:)+DBLE(coef*tmatrix1%cvec(:,:)) - ENDIF - ELSE - IF(.not.tmatrix2%iscmplx) THEN - tmatrix1%rvec(:,:)=tmatrix2%rvec(:,:)+DBLE(coef)*tmatrix1%rvec(:,:) - ELSE - call errore(subname,"copying complex tensor into real tensor", 1) - tmatrix1%rvec(:,:)=tmatrix2%cvec(:,:)+coef*tmatrix1%rvec(:,:) - ENDIF - ENDIF - - return - END SUBROUTINE zaxpy_twin_matrix - - SUBROUTINE copy_twin_tensor(ttensor1,ttensor2) - - type(twin_tensor) :: ttensor1, ttensor2 - character(len=17) :: subname="copy_twin_tensor" -! COMPLEX(DP), INTENT(IN) :: value - - IF(ttensor1%xdim.ne.ttensor2%xdim .OR. ttensor1%ydim.ne.ttensor2%ydim & - .OR. ttensor1%zdim.ne.ttensor2%zdim) THEN - call errore(subname,"copying twin tensors with incompatible size", 1) - ENDIF - - IF(ttensor1%iscmplx) THEN - IF(ttensor2%iscmplx) THEN - ttensor1%cvec(:,:,:)=ttensor2%cvec(:,:,:) - ELSE - call errore(subname,"copying real tensor into complex tensor", 1) - ttensor1%cvec(:,:,:)=ttensor2%rvec(:,:,:) - ENDIF - ELSE - IF(.not.ttensor2%iscmplx) THEN - ttensor1%rvec(:,:,:)=ttensor2%rvec(:,:,:) - ELSE - call errore(subname,"copying complex tensor into real tensor", 1) - ttensor1%rvec(:,:,:)=ttensor2%cvec(:,:,:) - ENDIF - ENDIF - - return - END SUBROUTINE copy_twin_tensor - - SUBROUTINE zaxpy_twin_tensor(ttensor1,ttensor2, coef) - - type(twin_tensor) :: ttensor1,ttensor2 - COMPLEX(DP) :: coef - character(len=17) :: subname="copy_twin_tensor" -! COMPLEX(DP), INTENT(IN) :: value - - IF(ttensor1%xdim.ne.ttensor2%xdim .OR. ttensor1%ydim.ne.ttensor2%ydim & - .OR. ttensor1%zdim.ne.ttensor2%zdim) THEN - call errore(subname,"copying twin tensors with incompatible size", 1) - ENDIF - - IF(ttensor1%iscmplx) THEN - IF(ttensor2%iscmplx) THEN - ttensor1%cvec(:,:,:)=ttensor2%cvec(:,:,:)+coef*ttensor1%cvec(:,:,:) - ELSE - call errore(subname,"copying real tensor into complex tensor", 1) - ttensor1%cvec(:,:,:)=ttensor2%rvec(:,:,:)+DBLE(coef*ttensor1%cvec(:,:,:)) - ENDIF - ELSE - IF(.not.ttensor2%iscmplx) THEN - ttensor1%rvec(:,:,:)=ttensor2%rvec(:,:,:)+DBLE(coef)*ttensor1%rvec(:,:,:) - ELSE - call errore(subname,"copying complex tensor into real tensor", 1) - ttensor1%rvec(:,:,:)=ttensor2%cvec(:,:,:)+coef*ttensor1%rvec(:,:,:) - ENDIF - ENDIF - - return - END SUBROUTINE zaxpy_twin_tensor - - SUBROUTINE allocate_twin_matrix(tmatrix,xlen,ylen,doreal) - - type(twin_matrix) :: tmatrix - INTEGER, INTENT(IN) :: xlen,ylen - LOGICAL, INTENT(IN) :: doreal - - character(len=24) :: subname="allocate_twin_matrix" - INTEGER :: ierr - - IF(tmatrix%isalloc) THEN - call deallocate_twin(tmatrix) - ENDIF - - IF(.not.doreal) THEN - !write(6,*) "TWIN:allocating complex matrix", xlen, ylen -! nullify(tmatrix%cvec) - ALLOCATE(tmatrix%cvec(max(1,xlen),max(1,ylen)), STAT=ierr) - IF(ierr/=0) call errore(subname,"allocating twin_matrix cvec", abs(ierr)) - tmatrix%iscmplx=.true. - tmatrix%cvec=CMPLX(0.d0,0.d0) - ELSE - !write(6,*) "TWIN:allocating real matrix", xlen, ylen -! nullify(tmatrix%rvec) - allocate(tmatrix%rvec(max(1,xlen),max(1,ylen)), STAT=ierr) - IF(ierr/=0) call errore(subname,"allocating twin_matrix rvec", abs(ierr)) - tmatrix%iscmplx=.false. - tmatrix%rvec=0.d0 - ENDIF - - tmatrix%xdim=max(1,xlen) - tmatrix%ydim=max(1,ylen) - tmatrix%isalloc=.true. - return - - END SUBROUTINE allocate_twin_matrix - - SUBROUTINE deallocate_twin_matrix(tmatrix) - - type(twin_matrix) :: tmatrix - - CHARACTER(len=26) :: subname="deallocate_twin_matrix" - INTEGER :: ierr - - IF(.not.tmatrix%iscmplx) THEN - IF(associated(tmatrix%rvec)) THEN - deallocate(tmatrix%rvec, STAT=ierr) - nullify(tmatrix%rvec) - IF(ierr/=0) call errore(subname,"deallocating twin_matrix rvec", abs(ierr)) - ENDIF - ENDIF - - IF(tmatrix%iscmplx) THEN - !write(6,*) "deallocating cvec", tmatrix%xdim, tmatrix%ydim, tmatrix%iscmplx, tmatrix%isalloc, associated(tmatrix%rvec) - IF(associated(tmatrix%cvec)) THEN - deallocate(tmatrix%cvec, STAT=ierr) - nullify(tmatrix%cvec) - IF(ierr/=0) call errore(subname,"deallocating twin_matrix cvec", abs(ierr)) - ENDIF - ENDIF - - tmatrix%xdim=0 - tmatrix%ydim=0 - tmatrix%iscmplx=.false. - tmatrix%isalloc=.false. - return - END SUBROUTINE deallocate_twin_matrix - - SUBROUTINE allocate_twin_tensor(ttensor,xlen,ylen,zlen,doreal) - - type(twin_tensor) :: ttensor - INTEGER, INTENT(IN) :: xlen,ylen,zlen - LOGICAL :: doreal - - character(len=24) :: subname="allocate_twin_tensor" - INTEGER :: ierr - - IF(ttensor%isalloc) THEN - call deallocate_twin(ttensor) - ENDIF - nullify(ttensor%rvec) - nullify(ttensor%cvec) - - IF(.not.doreal) THEN - ALLOCATE(ttensor%cvec(max(1,xlen),max(1,ylen),max(1,zlen)), STAT=ierr) - IF(ierr/=0) call errore(subname,"allocating twin_tensor cvec", abs(ierr)) - ttensor%iscmplx=.true. - ttensor%cvec=CMPLX(0.d0,0.d0) - ELSE - ALLOCATE(ttensor%rvec(max(1,xlen),max(1,ylen),max(1,zlen)), STAT=ierr) - IF(ierr/=0) call errore(subname,"allocating twin_tensor rvec", abs(ierr)) - ttensor%iscmplx=.false. - ttensor%rvec=0.d0 - ENDIF - - ttensor%xdim=max(1,xlen) - ttensor%ydim=max(1,ylen) - ttensor%ydim=max(1,zlen) - ttensor%isalloc=.true. - return - - END SUBROUTINE allocate_twin_tensor - - SUBROUTINE deallocate_twin_tensor(ttensor) - - type(twin_tensor) :: ttensor - character(len=26) :: subname="deallocate_twin_tensor" - - INTEGER :: ierr - - IF(.not.ttensor%iscmplx) THEN - IF(associated(ttensor%rvec)) THEN - DEALLOCATE(ttensor%rvec, STAT=ierr) - nullify(ttensor%rvec) - IF(ierr/=0) call errore(subname,"deallocating twin_tensor rvec", abs(ierr)) - ENDIF - ENDIF - - IF(ttensor%iscmplx) THEN - IF(associated(ttensor%cvec)) THEN - DEALLOCATE(ttensor%cvec, STAT=ierr) - nullify(ttensor%cvec) - IF(ierr/=0) call errore(subname,"deallocating twin_tensor cvec", abs(ierr)) - ENDIF - ENDIF - - ttensor%xdim=0 - ttensor%ydim=0 - ttensor%zdim=0 - - ttensor%iscmplx=.false. - ttensor%isalloc=.false. - nullify(ttensor%rvec) - nullify(ttensor%cvec) - - return - END SUBROUTINE deallocate_twin_tensor - - SUBROUTINE tmatrix_mp_sum(tmatrix) - - use mp, only: mp_sum, mp_bcast - use mp_global, ONLY : intra_image_comm - - IMPLICIT NONE - - type(twin_matrix) :: tmatrix - - IF(.not.tmatrix%iscmplx) THEN - call mp_sum(tmatrix%rvec, intra_image_comm) - ELSE - call mp_sum(tmatrix%cvec, intra_image_comm) - ENDIF - - END SUBROUTINE tmatrix_mp_sum - - SUBROUTINE tmatrix_mp_bcast(tmatrix, node) - - use mp, only: mp_sum, mp_bcast - use mp_global, ONLY : intra_image_comm - - IMPLICIT NONE - - type(twin_matrix) :: tmatrix - integer :: node - - IF(.not.tmatrix%iscmplx) THEN - call mp_bcast(tmatrix%rvec, node, intra_image_comm) - ELSE - call mp_bcast(tmatrix%cvec, node, intra_image_comm) - ENDIF - - END SUBROUTINE tmatrix_mp_bcast - - SUBROUTINE ttensor_mp_bcast(ttensor, node) - - use mp, only: mp_sum, mp_bcast - use mp_global, ONLY : intra_image_comm - - IMPLICIT NONE - - type(twin_tensor) :: ttensor - integer :: node - - IF(.not.ttensor%iscmplx) THEN - call mp_bcast(ttensor%rvec, node, intra_image_comm) - ELSE - call mp_bcast(ttensor%cvec, node, intra_image_comm) - ENDIF - - END SUBROUTINE ttensor_mp_bcast - - SUBROUTINE ttensor_mp_sum(ttensor) - - use mp, only: mp_sum, mp_bcast - use mp_global, ONLY : intra_image_comm - - IMPLICIT NONE - - type(twin_tensor) :: ttensor - - IF(.not.ttensor%iscmplx) THEN - call mp_sum(ttensor%rvec, intra_image_comm) - ELSE - call mp_sum(ttensor%cvec, intra_image_comm) - ENDIF - - END SUBROUTINE ttensor_mp_sum - - complex(DP) FUNCTION scalar_twin(vec1,vec2,sizevec,gstart,lgam) - - complex(DP), dimension(:) :: vec1,vec2 - integer :: gstart - logical :: lgam - integer :: sizevec - character(len=12) :: subname="scalar_twin" - - complex(DP) :: aid - - if((size(vec1).ne.sizevec) .or. (size(vec2).ne.sizevec)) then - call errore(subname,"inconsistent vector size", 1) - endif - - aid=CMPLX(0.d0,0.d0) - if(lgam) then - aid=2.d0*DBLE(DOT_PRODUCT(vec1(1:sizevec),vec2(1:sizevec))) - if(gstart == 2) then - aid=aid - DBLE(CONJG(vec1(1))*vec2(1)) - endif - else - aid=DOT_PRODUCT(CONJG(vec1(1:sizevec)),vec2(1:sizevec)) - endif - - scalar_twin=aid - - END FUNCTION scalar_twin - -END MODULE twin_types diff --git a/quantum_espresso/kcp/Modules/upf.f90 b/quantum_espresso/kcp/Modules/upf.f90 deleted file mode 100644 index dfe93cf25..000000000 --- a/quantum_espresso/kcp/Modules/upf.f90 +++ /dev/null @@ -1,115 +0,0 @@ -! Copyright (C) 2008 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!=----------------------------------------------------------------------------=! - MODULE upf_module -!=----------------------------------------------------------------------------=! -! this module handles reading and writing of unified pseudopotential format (UPF) -! it can manage v2 read/write and v1 read only. -! -! A macro to trim both from left and right -#define TRIM(a) trim(adjustl(a)) - ! - USE kinds, ONLY: DP - USE pseudo_types, ONLY: pseudo_upf, deallocate_pseudo_upf - USE iotk_module - ! - USE read_upf_v1_module - USE read_upf_v2_module - USE write_upf_v2_module - ! - IMPLICIT NONE - PUBLIC - ! - CONTAINS - -!------------------------------------------------+ -SUBROUTINE read_upf(upf, grid, ierr, unit, filename) ! - !---------------------------------------------+ - ! Read pseudopotential in UPF format version 2, uses iotk - ! - USE radial_grids, ONLY: radial_grid_type, deallocate_radial_grid - USE read_upf_v1_module,ONLY: read_upf_v1 - IMPLICIT NONE - INTEGER,INTENT(IN),OPTIONAL :: unit ! i/o unit - CHARACTER(len=*),INTENT(IN),OPTIONAL :: filename ! i/o filename - TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data - TYPE(radial_grid_type),OPTIONAL,INTENT(INOUT),TARGET :: grid - INTEGER,INTENT(OUT) :: ierr - ! - INTEGER :: u ! i/o unit - - ierr = 0 - - IF(.not. present(unit)) THEN - IF (.not. present(filename)) & - CALL errore('read_upf',& - 'You have to specify at least one between filename and unit',1) - CALL iotk_free_unit(u) - ELSE - u = unit - ENDIF - ! - IF(present(filename)) & - open (unit = u, file = filename, status = 'old', form = & - 'formatted', iostat = ierr) - IF(ierr>0) CALL errore('read_upf', 'Cannot open file: '//TRIM(filename),1) - ! - CALL read_upf_v2( u, upf, grid, ierr ) - ! - IF(ierr>0) THEN - REWIND(u) - CALL deallocate_pseudo_upf( upf ) - CALL deallocate_radial_grid( grid ) - CALL read_upf_v1( u, upf, grid, ierr ) - ENDIF - - RETURN - -END SUBROUTINE read_upf - -!------------------------------------------------+ -SUBROUTINE write_upf(upf, conf, unit, filename) ! - !---------------------------------------------+ - ! Write pseudopotential in UPF format version 2, uses iotk - ! - IMPLICIT NONE - TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data - TYPE(pseudo_config),OPTIONAL,INTENT(IN):: conf ! the pseudo GENERATION data - INTEGER,INTENT(IN),OPTIONAL :: unit ! i/o unit - CHARACTER(len=*),INTENT(IN),OPTIONAL :: filename ! i/o filename - ! - INTEGER :: u, ierr ! i/o unit and error handler - - ierr = 0 - - IF(.not. present(unit)) THEN - IF (.not. present(filename)) & - CALL errore('read_upf_v2',& - 'You have to specify at least one between filename and unit',1) - CALL iotk_free_unit(u) - ELSE - u = unit - ENDIF - ! - IF(present(filename)) & - open (unit = u, file = filename, status = 'unknown', form = & - 'formatted', iostat = ierr) - IF(ierr>0) CALL errore('write_upf', 'Cannot open file: '//TRIM(filename),1) - ! - CALL write_upf_v2( u, upf, conf ) - ! - IF(ierr>0) & - CALL errore('write_upf','Errore while writing pseudopotential file',1) - -END SUBROUTINE write_upf - - -!=----------------------------------------------------------------------------=! - END MODULE upf_module -!=----------------------------------------------------------------------------=! -#undef TRIM - diff --git a/quantum_espresso/kcp/Modules/upf_to_internal.f90 b/quantum_espresso/kcp/Modules/upf_to_internal.f90 deleted file mode 100644 index 70faed44c..000000000 --- a/quantum_espresso/kcp/Modules/upf_to_internal.f90 +++ /dev/null @@ -1,73 +0,0 @@ -! -! Copyright (C) 2004-2007 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! This module is USEd, for the time being, as an interface -! between the UPF pseudo type and the pseudo variables internal representation - -!=----------------------------------------------------------------------------=! - MODULE upf_to_internal -!=----------------------------------------------------------------------------=! - - IMPLICIT NONE - PRIVATE - PUBLIC :: set_pseudo_upf - SAVE - -!=----------------------------------------------------------------------------=! - CONTAINS -!=----------------------------------------------------------------------------=! -! -!--------------------------------------------------------------------- -subroutine set_pseudo_upf (is, upf, grid) - !--------------------------------------------------------------------- - ! - ! set "is"-th pseudopotential using the Unified Pseudopotential Format - ! dummy argument ( upf ) - convert and copy to internal variables - ! - USE funct, ONLY: set_dft_from_name, set_dft_from_indices, dft_is_meta - ! - USE pseudo_types - USE radial_grids, ONLY: radial_grid_type, allocate_radial_grid - ! - implicit none - ! - integer :: is - ! - ! Local variables - ! - integer :: iexch,icorr,igcx,igcc - TYPE(radial_grid_type),target,optional :: grid ! if present reconstruct radial grid. - ! (only for old format pseudos) - TYPE (pseudo_upf) :: upf - ! - ! - ! workaround for rrkj format - it contains the indices, not the name - if ( upf%dft(1:6)=='INDEX:') then - read( upf%dft(7:10), '(4i1)') iexch,icorr,igcx,igcc - call set_dft_from_indices(iexch,icorr,igcx,igcc) - else - call set_dft_from_name( upf%dft ) - end if - ! - if(present(grid)) then - call allocate_radial_grid(grid,upf%mesh) - grid%dx = upf%dx - grid%xmin = upf%xmin - grid%zmesh= upf%zmesh - grid%mesh = upf%mesh - ! - grid%r (1:upf%mesh) = upf%r (1:upf%mesh) - grid%rab(1:upf%mesh) = upf%rab(1:upf%mesh) - upf%grid => grid - endif - ! -end subroutine set_pseudo_upf - - -!=----------------------------------------------------------------------------=! - END MODULE upf_to_internal -!=----------------------------------------------------------------------------=! diff --git a/quantum_espresso/kcp/Modules/uspp.f90 b/quantum_espresso/kcp/Modules/uspp.f90 deleted file mode 100644 index 195033011..000000000 --- a/quantum_espresso/kcp/Modules/uspp.f90 +++ /dev/null @@ -1,331 +0,0 @@ -! -! Copyright (C) 2004 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -MODULE uspp_param - ! - ! ... Ultrasoft and Norm-Conserving pseudopotential parameters - ! - USE kinds, ONLY : DP - USE parameters, ONLY : npsx - USE pseudo_types, ONLY : pseudo_upf - ! - SAVE - PUBLIC :: n_atom_wfc - ! - TYPE (pseudo_upf), ALLOCATABLE, TARGET :: upf(:) - - INTEGER :: & - nh(npsx), &! number of beta functions per atomic type - nhm, &! max number of different beta functions per atom - nbetam, &! max number of beta functions - iver(3,npsx) ! version of the atomic code - INTEGER :: & - lmaxkb, &! max angular momentum - lmaxq ! max angular momentum + 1 for Q functions - LOGICAL :: & - newpseudo(npsx), &! if .TRUE. multiple projectors are allowed - oldvan(npsx) ! old version of Vanderbilt PPs, using - ! Herman-Skillman grid - obsolescent -CONTAINS - ! - !---------------------------------------------------------------------------- - FUNCTION n_atom_wfc( nat, ityp, noncolin ) - !---------------------------------------------------------------------------- - ! - ! ... Find number of starting atomic orbitals - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nat, ityp(nat) - LOGICAL, INTENT(IN), OPTIONAL :: noncolin - INTEGER :: n_atom_wfc - ! - INTEGER :: na, nt, n - LOGICAL :: non_col - ! - ! - non_col = .FALSE. - IF ( PRESENT (noncolin) ) non_col=noncolin - n_atom_wfc = 0 - ! - DO na = 1, nat - ! - nt = ityp(na) - ! - DO n = 1, upf(nt)%nwfc - ! - IF ( upf(nt)%oc(n) >= 0.D0 ) THEN - ! - IF ( non_col ) THEN - ! - IF ( upf(nt)%has_so ) THEN - ! - n_atom_wfc = n_atom_wfc + 2 * upf(nt)%lchi(n) - ! - IF ( ABS( upf(nt)%jchi(n)-upf(nt)%lchi(n) - 0.5D0 ) < 1.D-6 ) & - n_atom_wfc = n_atom_wfc + 2 - ! - ELSE - ! - n_atom_wfc = n_atom_wfc + 2 * ( 2 * upf(nt)%lchi(n) + 1 ) - ! - END IF - ! - ELSE - ! - n_atom_wfc = n_atom_wfc + 2 * upf(nt)%lchi(n) + 1 - ! - END IF - END IF - END DO - END DO - ! - RETURN - ! - END FUNCTION n_atom_wfc - -END MODULE uspp_param -! -MODULE uspp - ! - ! Ultrasoft PPs: - ! - Clebsch-Gordan coefficients "ap", auxiliary variables "lpx", "lpl" - ! - beta and q functions of the solid - ! - USE kinds, ONLY: DP - USE parameters, ONLY: lmaxx, lqmax - USE twin_types !added:giovanni - IMPLICIT NONE - PRIVATE - SAVE - PUBLIC :: nlx, lpx, lpl, ap, aainit, indv, nhtol, nhtolm, nkb, nkbus, & - vkb, dvan, deeq, qq, nhtoj, ijtoh, beta, becsum, okvan, deallocate_uspp - PUBLIC :: qq_so, dvan_so, deeq_nc - INTEGER, PARAMETER :: & - nlx = (lmaxx+1)**2, &! maximum number of combined angular momentum - mx = 2*lqmax-1 ! maximum magnetic angular momentum of Q - INTEGER :: &! for each pair of combined momenta lm(1),lm(2): - lpx(nlx,nlx), &! maximum combined angular momentum LM - lpl(nlx,nlx,mx) ! list of combined angular momenta LM - REAL(DP) :: & - ap(lqmax*lqmax,nlx,nlx) - ! Clebsch-Gordan coefficients for spherical harmonics - ! - INTEGER :: nkb, &! total number of beta functions, with struct.fact. - nkbus ! as above, for US-PP only - ! - INTEGER, ALLOCATABLE ::& - indv(:,:), &! indes linking atomic beta's to beta's in the solid - nhtol(:,:), &! correspondence n <-> angular momentum l - nhtolm(:,:), &! correspondence n <-> combined lm index for (l,m) - ijtoh(:,:,:) ! correspondence beta indexes ih,jh -> composite index ijh - ! - LOGICAL :: & - okvan = .FALSE. ! if .TRUE. at least one pseudo is Vanderbilt - ! - COMPLEX(DP), ALLOCATABLE, TARGET :: & - vkb(:,:) ! all beta functions in reciprocal space - REAL(DP), ALLOCATABLE :: & - becsum(:,:,:) ! \sum_i f(i) -! !begin_modified:giovanni -! type(twin_tensor) :: & -! becsum ! \sum_i f(i) -! !end_modified:giovanni - REAL(DP), ALLOCATABLE :: & - dvan(:,:,:), &! the D functions of the solid - deeq(:,:,:,:), &! the integral of V_eff and Q_{nm} - qq(:,:,:), &! the q functions in the solid - nhtoj(:,:) ! correspondence n <-> total angular momentum - ! - COMPLEX(DP), ALLOCATABLE :: & ! variables for spin-orbit/noncolinear case: - qq_so(:,:,:,:), &! Q_{nm} - dvan_so(:,:,:,:), &! D_{nm} - deeq_nc(:,:,:,:) ! \int V_{eff}(r) Q_{nm}(r) dr - ! - ! spin-orbit coupling: qq and dvan are complex, qq has additional spin index - ! noncolinear magnetism: deeq is complex (even in absence of spin-orbit) - ! - REAL(DP), ALLOCATABLE :: & - beta(:,:,:) ! beta functions for CP (without struct.factor) - ! -CONTAINS - ! - !----------------------------------------------------------------------- - subroutine aainit(lli) - !----------------------------------------------------------------------- - ! - ! this routine computes the coefficients of the expansion of the product - ! of two real spherical harmonics into real spherical harmonics. - ! - ! Y_limi(r) * Y_ljmj(r) = \sum_LM ap(LM,limi,ljmj) Y_LM(r) - ! - ! On output: - ! ap the expansion coefficients - ! lpx for each input limi,ljmj is the number of LM in the sum - ! lpl for each input limi,ljmj points to the allowed LM - ! - ! The indices limi,ljmj and LM assume the order for real spherical - ! harmonics given in routine ylmr2 - ! - implicit none - ! - ! input: the maximum li considered - ! - integer :: lli - ! - ! local variables - ! - integer :: llx, l, li, lj - real(DP) , allocatable :: r(:,:), rr(:), ylm(:,:), mly(:,:) - ! an array of random vectors: r(3,llx) - ! the norm of r: rr(llx) - ! the real spherical harmonics for array r: ylm(llx,llx) - ! the inverse of ylm considered as a matrix: mly(llx,llx) - real(DP) :: dum - ! - if (lli < 0) call errore('aainit','lli not allowed',lli) - - if (lli*lli > nlx) call errore('aainit','nlx is too small ',lli*lli) - - llx = (2*lli-1)**2 - if (2*lli-1 > lqmax) & - call errore('aainit','ap leading dimension is too small',llx) - - allocate (r( 3, llx )) - allocate (rr( llx )) - allocate (ylm( llx, llx )) - allocate (mly( llx, llx )) - - r(:,:) = 0.0_DP - ylm(:,:) = 0.0_DP - mly(:,:) = 0.0_DP - ap(:,:,:)= 0.0_DP - - ! - generate an array of random vectors (uniform deviate on unitary sphere) - - call gen_rndm_r(llx,r,rr) - - ! - generate the real spherical harmonics for the array: ylm(ir,lm) - - call ylmr2(llx,llx,r,rr,ylm) - - !- store the inverse of ylm(ir,lm) in mly(lm,ir) - - call invmat(llx, ylm, mly, dum) - - !- for each li,lj compute ap(l,li,lj) and the indices, lpx and lpl - do li = 1, lli*lli - do lj = 1, lli*lli - lpx(li,lj)=0 - do l = 1, llx - ap(l,li,lj) = compute_ap(l,li,lj,llx,ylm,mly) - if (abs(ap(l,li,lj)) > 1.d-3) then - lpx(li,lj) = lpx(li,lj) + 1 - if (lpx(li,lj) > mx) & - call errore('aainit','mx dimension too small', lpx(li,lj)) - lpl(li,lj,lpx(li,lj)) = l - end if - end do - end do - end do - - deallocate(mly) - deallocate(ylm) - deallocate(rr) - deallocate(r) - - return - end subroutine aainit - ! - !----------------------------------------------------------------------- - subroutine gen_rndm_r(llx,r,rr) - !----------------------------------------------------------------------- - ! - generate an array of random vectors (uniform deviate on unitary sphere) - ! - USE constants, ONLY: tpi - USE random_numbers, ONLY: randy - - implicit none - ! - ! first the I/O variables - ! - integer :: llx ! input: the dimension of r and rr - - real(DP) :: & - r(3,llx), &! output: an array of random vectors - rr(llx) ! output: the norm of r - ! - ! here the local variables - ! - integer :: ir - real(DP) :: costheta, sintheta, phi - - do ir = 1, llx - costheta = 2.0_DP * randy() - 1.0_DP - sintheta = SQRT ( 1.0_DP - costheta*costheta) - phi = tpi * randy() - r (1,ir) = sintheta * cos(phi) - r (2,ir) = sintheta * sin(phi) - r (3,ir) = costheta - rr(ir) = 1.0_DP - end do - - return - end subroutine gen_rndm_r - ! - !----------------------------------------------------------------------- - function compute_ap(l,li,lj,llx,ylm,mly) - !----------------------------------------------------------------------- - !- given an l and a li,lj pair compute ap(l,li,lj) - implicit none - ! - ! first the I/O variables - ! - integer :: & - llx, &! the dimension of ylm and mly - l,li,lj ! the arguments of the array ap - - real(DP) :: & - compute_ap, &! this function - ylm(llx,llx),&! the real spherical harmonics for array r - mly(llx,llx) ! the inverse of ylm considered as a matrix - ! - ! here the local variables - ! - integer :: ir - - compute_ap = 0.0_DP - do ir = 1,llx - compute_ap = compute_ap + mly(l,ir)*ylm(ir,li)*ylm(ir,lj) - end do - - return - end function compute_ap - ! - !----------------------------------------------------------------------- - SUBROUTINE deallocate_uspp() - !----------------------------------------------------------------------- - ! - IF( ALLOCATED( nhtol ) ) DEALLOCATE( nhtol ) - IF( ALLOCATED( indv ) ) DEALLOCATE( indv ) - IF( ALLOCATED( nhtolm ) ) DEALLOCATE( nhtolm ) - IF( ALLOCATED( nhtoj ) ) DEALLOCATE( nhtoj ) - IF( ALLOCATED( ijtoh ) ) DEALLOCATE( ijtoh ) - IF( ALLOCATED( vkb ) ) DEALLOCATE( vkb ) -! CALL deallocate_twin( becsum ) !modified:giovanni - IF( ALLOCATED( becsum ) ) DEALLOCATE( becsum ) - IF( ALLOCATED( qq ) ) DEALLOCATE( qq ) - IF( ALLOCATED( dvan ) ) DEALLOCATE( dvan ) - IF( ALLOCATED( deeq ) ) DEALLOCATE( deeq ) - IF( ALLOCATED( qq_so ) ) DEALLOCATE( qq_so ) - IF( ALLOCATED( dvan_so ) ) DEALLOCATE( dvan_so ) - IF( ALLOCATED( deeq_nc ) ) DEALLOCATE( deeq_nc ) - ! - END SUBROUTINE deallocate_uspp - ! -END MODULE uspp - diff --git a/quantum_espresso/kcp/Modules/version.f90 b/quantum_espresso/kcp/Modules/version.f90 deleted file mode 100644 index 786495ad2..000000000 --- a/quantum_espresso/kcp/Modules/version.f90 +++ /dev/null @@ -1,17 +0,0 @@ -! -! Copyright (C) 2003-2009 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE global_version - ! - IMPLICIT NONE - ! - SAVE - ! - CHARACTER (LEN=6) :: version_number = '4.1' - ! -END MODULE global_version diff --git a/quantum_espresso/kcp/Modules/vxc_t.f90 b/quantum_espresso/kcp/Modules/vxc_t.f90 deleted file mode 100644 index 8ba6cc25a..000000000 --- a/quantum_espresso/kcp/Modules/vxc_t.f90 +++ /dev/null @@ -1,54 +0,0 @@ -! -! Copyright (C) 2004 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!--------------------------------------------------------------- -subroutine vxc_t(rho,rhoc,lsd,vxc) - !--------------------------------------------------------------- - ! - ! this function returns the XC potential in LDA or LSDA approximation - ! - - use io_global, only : stdout - use kinds, only : DP - use funct, only : xc, xc_spin - implicit none - integer:: lsd - real(DP):: vxc(2), rho(2),rhoc,arho,zeta - real(DP):: vx(2), vc(2), ex, ec - ! - real(DP), parameter :: e2=2.0_dp, eps=1.e-30_dp - - vxc(1)=0.0_dp - if (lsd.eq.1) vxc(2)=0.0_dp - - if (lsd.eq.0) then - ! - ! LDA case - ! - arho=abs(rho(1)+rhoc) - if (arho.gt.eps) then - call xc(arho,ex,ec,vx(1),vc(1)) - vxc(1)=e2*(vx(1)+vc(1)) - endif - else - ! - ! LSDA case - ! - arho = abs(rho(1)+rho(2)+rhoc) - if (arho.gt.eps) then - zeta = (rho(1)-rho(2)) / arho - ! zeta has to stay between -1 and 1, but can get a little - ! out the bound during the first iterations. - if (abs(zeta).gt.1.0_dp) zeta = sign(1._dp, zeta) - call xc_spin(arho,zeta,ex,ec,vx(1),vx(2),vc(1),vc(2)) - vxc(1) = e2*(vx(1)+vc(1)) - vxc(2) = e2*(vx(2)+vc(2)) - endif - endif - - return -end subroutine vxc_t diff --git a/quantum_espresso/kcp/Modules/vxcgc.f90 b/quantum_espresso/kcp/Modules/vxcgc.f90 deleted file mode 100644 index e9d3619f0..000000000 --- a/quantum_espresso/kcp/Modules/vxcgc.f90 +++ /dev/null @@ -1,296 +0,0 @@ -! -! Copyright (C) 2004 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!--------------------------------------------------------------- -subroutine vxcgc(ndm,mesh,nspin,r,r2,rho,rhoc,vgc,egc,iflag) - !--------------------------------------------------------------- - ! - ! - ! This routine computes the exchange and correlation potential and - ! energy to be added to the local density, to have the first - ! gradient correction. - ! In input the density is rho(r) (multiplied by 4*pi*r2). - ! - ! The units of the potential are Ryd. - ! - use kinds, only : DP - use constants, only : fpi - use funct, only : gcxc, gcx_spin, gcc_spin - implicit none - integer, intent(in) :: ndm,mesh,nspin,iflag - real(DP), intent(in) :: r(mesh), r2(mesh), rho(ndm,2), rhoc(ndm) - real(DP), intent(out):: vgc(ndm,2), egc(ndm) - - integer :: i, is, ierr - real(DP) :: sx,sc,v1x,v2x,v1c,v2c - real(DP) :: v1xup, v1xdw, v2xup, v2xdw, v1cup, v1cdw - real(DP) :: segno, arho - real(DP) :: rh, zeta, grh2, grho2(2) - real(DP),parameter :: eps=1.e-12_dp - - real(DP), allocatable :: grho(:,:), h(:,:), dh(:), rhoaux(:,:) - ! - ! First compute the charge and the charge gradient, assumed - ! to have spherical symmetry. The gradient is the derivative of - ! the charge with respect to the modulus of r. - ! - allocate(rhoaux(mesh,2),stat=ierr) - allocate(grho(mesh,2),stat=ierr) - allocate(h(mesh,2),stat=ierr) - allocate(dh(mesh),stat=ierr) - - egc=0.0_dp - vgc=0.0_dp - - do is=1,nspin - do i=1, mesh - rhoaux(i,is)=(rho(i,is)+rhoc(i)/nspin)/fpi/r2(i) - enddo - call radial_gradient(rhoaux(1,is),grho(1,is),r,mesh,iflag) - enddo - - if (nspin.eq.1) then - ! - ! GGA case - ! - do i=1,mesh - arho=abs(rhoaux(i,1)) - segno=sign(1.0_dp,rhoaux(i,1)) - if (arho.gt.eps.and.abs(grho(i,1)).gt.eps) then - call gcxc(arho,grho(i,1)**2,sx,sc,v1x,v2x,v1c,v2c) - egc(i)=(sx+sc)*segno - vgc(i,1)= v1x+v1c - h(i,1) =(v2x+v2c)*grho(i,1)*r2(i) - ! if (i.lt.4) write(6,'(f20.12,e20.12,2f20.12)') & - ! rho(i,1), grho(i,1)**2, & - ! vgc(i,1),h(i,1) - else - vgc(i,1)=0.0_dp - egc(i)=0.0_dp - h(i,1)=0.0_dp - endif - end do - else - ! - ! this is the \sigma-GGA case - ! - do i=1,mesh - ! - ! NB: the special or wrong cases where one or two charges - ! or gradients are zero or negative must - ! be detected within the gcxc_spin routine - ! - ! spin-polarised case - ! - do is = 1, nspin - grho2(is)=grho(i,is)**2 - enddo - - call gcx_spin (rhoaux(i, 1), rhoaux(i, 2), grho2(1), grho2(2), & - sx, v1xup, v1xdw, v2xup, v2xdw) - rh = rhoaux(i, 1) + rhoaux(i, 2) - if (rh.gt.eps) then - zeta = (rhoaux (i, 1) - rhoaux (i, 2) ) / rh - grh2 = (grho (i, 1) + grho (i, 2) ) **2 - call gcc_spin (rh, zeta, grh2, sc, v1cup, v1cdw, v2c) - else - sc = 0.0_dp - v1cup = 0.0_dp - v1cdw = 0.0_dp - v2c = 0.0_dp - endif - - egc(i)=sx+sc - vgc(i,1)= v1xup+v1cup - vgc(i,2)= v1xdw+v1cdw - h(i,1) =((v2xup+v2c)*grho(i,1)+v2c*grho(i,2))*r2(i) - h(i,2) =((v2xdw+v2c)*grho(i,2)+v2c*grho(i,1))*r2(i) - ! if (i.lt.4) write(6,'(f20.12,e20.12,2f20.12)') & - ! rho(i,1)*2.0_dp, grho(i,1)**2*4.0_dp, & - ! vgc(i,1), h(i,2) - enddo - endif - ! - ! We need the gradient of h to calculate the last part of the exchange - ! and correlation potential. - ! - do is=1,nspin - call radial_gradient(h(1,is),dh,r,mesh,iflag) - ! - ! Finally we compute the total exchange and correlation energy and - ! potential. We put the original values on the charge and multiply - ! by two to have as output Ry units. - - do i=1, mesh - vgc(i,is)=vgc(i,is)-dh(i)/r2(i) - vgc(i,is)=2.0_dp*vgc(i,is) - if (is.eq.1) egc(i)=2.0_dp*egc(i) - ! if (is.eq.1.and.i.lt.4) write(6,'(3f20.12)') & - ! vgc(i,1) - enddo - enddo - - deallocate(dh) - deallocate(h) - deallocate(grho) - deallocate(rhoaux) - - return -end subroutine vxcgc - -subroutine radial_gradient(f,gf,r,mesh,iflag) -! -! This subroutine calculates the derivative with respect to r of a -! radial function defined on the mesh r. If iflag=0 it uses all mesh -! points. If iflag=1 it uses only a coarse grained mesh close to the -! origin, to avoid large errors in the derivative when the function -! is too smooth. -! -use kinds, only : DP -use radial_grids, only : series -implicit none -integer, intent(in) :: mesh, iflag -real(DP), intent(in) :: f(mesh), r(mesh) -real(DP), intent(out) :: gf(mesh) - -integer :: i,j,k,imin,npoint -real(DP) :: delta, b(5), faux(6), raux(6) -! -! This formula is used in the all-electron case. -! -if (iflag==0) then - do i=2, mesh-1 - gf(i)=( (r(i+1)-r(i))**2*(f(i-1)-f(i)) & - -(r(i-1)-r(i))**2*(f(i+1)-f(i)) ) & - /((r(i+1)-r(i))*(r(i-1)-r(i))*(r(i+1)-r(i-1))) - enddo - gf(mesh)=0.0_dp -! -! The gradient in the first point is a linear interpolation of the -! gradient at point 2 and 3. -! - gf(1) = gf(2) + (gf(3)-gf(2)) * (r(1)-r(2)) / (r(3)-r(2)) - return -endif -! -! If the input function is slowly changing (as the pseudocharge), -! the previous formula is affected by numerical errors close to the -! origin where the r points are too close one to the other. Therefore -! we calculate the gradient on a coarser mesh. This gradient is often -! more accurate but still does not remove all instabilities observed -! with the GGA. -! At larger r the distances between points become larger than delta -! and this formula coincides with the previous one. -! (ADC 08/2007) -! - -delta=0.00001_dp - -imin=1 -points: do i=2, mesh - do j=i+1,mesh - if (r(j)>r(i)+delta) then - do k=i-1,1,-1 - if (r(k)r(imin+1)+(k-1)*delta) then - faux(k)=gf(i) - raux(k)=r(i) - j=i+1 - cycle points_fit - endif - enddo -enddo points_fit -call fit_pol(raux,faux,npoint,3,b) -do i=1,imin - gf(i)=b(1)+r(i)*(b(2)+r(i)*(b(3)+r(i)*b(4))) -enddo -return -end subroutine radial_gradient - -subroutine fit_pol(xdata,ydata,n,degree,b) -! -! This routine finds the coefficients of the least-square polynomial which -! interpolates the n input data points. -! -use kinds, ONLY : DP -implicit none - -integer, intent(in) :: n, degree -real(DP), intent(in) :: xdata(n), ydata(n) -real(DP), intent(out) :: b(degree+1) - -integer :: ipiv(degree+1), info, i, j, k -real(DP) :: bmat(degree+1,degree+1), amat(degree+1,n) - -amat(1,:)=1.0_DP -do i=2,degree+1 - do j=1,n - amat(i,j)=amat(i-1,j)*xdata(j) - enddo -enddo -do i=1,degree+1 - b(i)=0.0_DP - do k=1,n - b(i)=b(i)+ydata(k)*xdata(k)**(i-1) - enddo -enddo -do i=1,degree+1 - do j=1,degree+1 - bmat(i,j)=0.0_DP - do k=1,n - bmat(i,j)=bmat(i,j)+amat(i,k)*amat(j,k) - enddo - enddo -enddo -! -! This lapack routine solves the linear system that gives the -! coefficients of the interpolating polynomial. -! -call DGESV(degree+1, 1, bmat, degree+1, ipiv, b, degree+1, info) - -if (info.ne.0) call errore('pol_fit','problems with the linear system', & - abs(info)) -return -end subroutine fit_pol - diff --git a/quantum_espresso/kcp/Modules/wannier.f90 b/quantum_espresso/kcp/Modules/wannier.f90 deleted file mode 100644 index e30497998..000000000 --- a/quantum_espresso/kcp/Modules/wannier.f90 +++ /dev/null @@ -1,54 +0,0 @@ -! -! Copyright (C) 2003 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -module wannier - USE kinds, only : DP - !integer, allocatable :: nnb(:) ! #b (ik) - integer :: nnb ! #b - integer, allocatable :: kpb(:,:) ! k+b (ik,ib) - integer, allocatable :: g_kpb(:,:,:) ! G_k+b (ipol,ik,ib) - integer, allocatable :: ig_(:,:) ! G_k+b (ipol,ik,ib) - integer, allocatable :: lw(:,:), mw(:,:) ! l and m of wannier (16,n_wannier) - integer, allocatable :: num_sph(:) ! num. func. in lin. comb., (n_wannier) - logical, allocatable :: excluded_band(:) - integer :: iun_nnkp, iun_mmn, iun_amn, iun_band, iun_spn, iun_plot, nnbx, nexband - integer :: n_wannier !number of WF - integer :: n_proj !number of projection (=#WF unless spinors then =#WF/2) - complex(DP), allocatable :: gf(:,:) ! guding_function(npwx,n_wannier) - integer :: ispinw, ikstart, ikstop, iknum - character(LEN=15) :: wan_mode ! running mode - logical :: logwann, wvfn_formatted, write_unk, write_unkg, & - write_amn, write_mmn, reduce_unk, write_spn - ! input data from nnkp file - real(DP), allocatable :: center_w(:,:) ! center_w(3,n_wannier) - integer, allocatable :: l_w(:), mr_w(:) ! l and mr of wannier (n_wannier) as from table 3.1,3.2 of spec. - integer, allocatable :: r_w(:) ! index of radial function (n_wannier) as from table 3.3 of spec. - real(DP), allocatable :: xaxis(:,:),zaxis(:,:) ! xaxis and zaxis(3,n_wannier) - real(DP), allocatable :: alpha_w(:) ! alpha_w(n_wannier) ( called zona in wannier spec) - ! - real(DP), allocatable :: csph(:,:) ! expansion coefficients of gf on QE ylm function (16,n_wannier) - CHARACTER(len=256) :: seedname = 'wannier' ! prepended to file names in wannier90 - ! For implementation of wannier_lib - integer :: mp_grid(3) ! dimensions of MP k-point grid - real(DP) :: rlatt(3,3),glatt(3,3) ! real and recip lattices (Cartesian co-ords, units of Angstrom) - real(DP), allocatable :: kpt_latt(:,:) ! k-points in crystal co-ords. kpt_latt(3,iknum) - real(DP), allocatable :: atcart(:,:) ! atom centres in Cartesian co-ords and Angstrom units. atcart(3,nat) - integer :: num_bands ! number of bands left after exclusions - character(len=3), allocatable :: atsym(:) ! atomic symbols. atsym(nat) - integer :: num_nnmax=12 - complex(DP), allocatable :: m_mat(:,:,:,:), a_mat(:,:,:) - complex(DP), allocatable :: u_mat(:,:,:), u_mat_opt(:,:,:) - logical, allocatable :: lwindow(:,:) - real(DP), allocatable :: wann_centers(:,:),wann_spreads(:) - real(DP) :: spreads(3) - real(DP), allocatable :: eigval(:,:) -end module wannier -! - - diff --git a/quantum_espresso/kcp/Modules/wannier_new.f90 b/quantum_espresso/kcp/Modules/wannier_new.f90 deleted file mode 100644 index 54ef41d86..000000000 --- a/quantum_espresso/kcp/Modules/wannier_new.f90 +++ /dev/null @@ -1,55 +0,0 @@ -! Copyright (C) 2006-2008 Dmitry Korotin - dmitry@korotin.name -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!-------------------------------------------------------------------------- -! -#include "f_defs.h" - -MODULE wannier_new - ! - ! ... Variables to construct and store wannier functions - ! - USE kinds, ONLY : DP - ! - SAVE - ! - INTEGER, PARAMETER :: ningx = 10 ! max number of trial wavefunction ingredients - - LOGICAL :: & - use_wannier, &! if .TRUE. wannier functions are constructed - rkmesh, &! if .TRUE. regular k-mesh without symmetry is used !now used in input_parameters_mod - plot_wannier, &! if .TRUE. wannier number plot_wan_num is plotted - use_energy_int, &! if .TRUE. uses energy interval for wannier generation, not band numbers - print_wannier_coeff ! if .TRUE. computes and prints coefficients of wannier decomp. on atomic functions - INTEGER :: & - nwan, &! number of wannier functions - plot_wan_num, &! number of wannier for plotting - plot_wan_spin ! spin of wannier for plotting - REAL(kind=DP), allocatable :: & - wan_pot(:,:), &! constrained potential - wannier_energy(:,:), &! energy of each wannier (of each spin) - wannier_occ(:,:,:) ! occupation matrix of wannier functions(of each spin) - COMPLEX(kind=DP), allocatable :: & - pp(:,:), &! projections - coef(:,:,:) ! coefficients of wannier decomp. on atomic functions - - TYPE ingredient - INTEGER :: l = 0, & ! l value for atomic wfc - m = 0, & ! m value for atomic wfc - iatomwfc = 0 ! number of corresponding atomic orbital - REAL :: c = 0.d0 ! coefficient - END TYPE ingredient - - TYPE wannier_data - INTEGER :: iatom = 0, & - ning = 0 - REAL :: bands_from = 0.d0, & - bands_to = 0.d0 - TYPE (ingredient) :: ing(ningx) - END TYPE wannier_data - - TYPE (wannier_data), allocatable :: wan_in(:,:) -END MODULE wannier_new diff --git a/quantum_espresso/kcp/Modules/wave_base.f90 b/quantum_espresso/kcp/Modules/wave_base.f90 deleted file mode 100644 index 453d33255..000000000 --- a/quantum_espresso/kcp/Modules/wave_base.f90 +++ /dev/null @@ -1,707 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -#include "f_defs.h" - -! BEGIN manual - -!==----------------------------------------------==! - MODULE wave_base -!==----------------------------------------------==! - - -! (describe briefly what this module does...) -! ---------------------------------------------- - -! END manual - - USE kinds - - IMPLICIT NONE - SAVE - PRIVATE - - REAL(DP) :: frice = 0.0_DP ! friction parameter for electronic - ! damped dynamics - REAL(DP) :: grease = 0.0_DP ! friction parameter for electronic - ! damped dynamics - - PUBLIC :: dotp, hpsi, rande_base, gram_kp_base, gram_gamma_base - PUBLIC :: converg_base, rande_base_s, scalw - - PUBLIC :: wave_steepest - PUBLIC :: wave_verlet - PUBLIC :: wave_speed2 - - PUBLIC :: frice, grease - - INTERFACE dotp - MODULE PROCEDURE dotp_gamma, dotp_kp, dotp_gamma_n, dotp_kp_n - END INTERFACE - - INTERFACE hpsi - MODULE PROCEDURE hpsi_gamma, hpsi_kp - END INTERFACE - - INTERFACE converg_base - MODULE PROCEDURE converg_base_gamma, converg_base_kp - END INTERFACE - -!==----------------------------------------------==! - CONTAINS -!==----------------------------------------------==! - - SUBROUTINE gram_kp_base(wf, gid) - USE mp, ONLY: mp_sum - COMPLEX(DP) :: wf(:,:) - INTEGER, INTENT(IN) :: gid - COMPLEX(DP), PARAMETER :: one = ( 1.0_DP,0.0_DP) - COMPLEX(DP), PARAMETER :: onem = (-1.0_DP,0.0_DP) - COMPLEX(DP), PARAMETER :: zero = ( 0.0_DP,0.0_DP) - REAL(DP), PARAMETER :: small = 1.e-16_DP - COMPLEX(DP), ALLOCATABLE :: s(:) - REAL(DP) :: anorm - INTEGER :: ib, ngw, nb - ngw = SIZE(wf, 1) - nb = SIZE(wf, 2) - ALLOCATE( s(nb) ) - DO ib = 1, nb - IF(ib > 1)THEN - s = zero - CALL ZGEMV & - ('C', ngw, ib-1, one, wf(1,1), ngw, wf(1,ib), 1, zero, s(1), 1) - CALL mp_sum(s,gid) - CALL ZGEMV & - ('N', ngw, ib-1, onem, wf(1,1), ngw, s(1), 1, one, wf(1,ib), 1) - END IF - anorm = SUM( DBLE( wf(:,ib) * CONJG(wf(:,ib)) ) ) - CALL mp_sum(anorm, gid) - anorm = 1.0_DP / MAX( SQRT(anorm), small ) - CALL ZDSCAL(ngw, anorm, wf(1,ib), 1) - END DO - DEALLOCATE( s ) - RETURN - END SUBROUTINE gram_kp_base - -!==----------------------------------------------==! -!==----------------------------------------------==! -! BEGIN manual - SUBROUTINE gram_gamma_base(wf, gzero, gid) - -! Gram-Schmidt ortogonalization procedure -! input: cp(2,ngik,n) = ( .... ) -! ( .... ) -! ( ...............................................) -! ( .... ) -! output: the same orthogonalized -! ---------------------------------------------- -! line 7&8 : s(k) = - k=1,..,i-1 (orthonormal) -! i (non-orthogonal) -! line 9 : s(k) = 2*sum_g{} + s(k) -! line 10 : = - sum_k {s(k) } -! lines 12-15: normalize |psi(i)> -! note: line 2 com. out due to im()=0 for all k (gam. p. is ass.) -! s(k) is added in 9 to av. doub. count. of -! |psi(i)> after line 10 is orthogonal to |psi(k)> k=1,...,i-1 -! ---------------------------------------------- -! END manual - - USE mp, ONLY: mp_sum - USE mp_global, ONLY: mpime - - COMPLEX(DP), INTENT(INOUT) :: wf(:,:) - INTEGER, INTENT(IN) :: gid - LOGICAL, INTENT(IN) :: gzero - - REAL(DP), PARAMETER :: one = 1.0_DP - REAL(DP), PARAMETER :: two = 2.0_DP - REAL(DP), PARAMETER :: onem = -1.0_DP - REAL(DP), PARAMETER :: zero = 0.0_DP - REAL(DP), PARAMETER :: small = 1.e-16_DP - REAL(DP) :: DNRM2 - REAL(DP), ALLOCATABLE :: s(:) - REAL(DP) :: anorm, wftmp - INTEGER :: ib, nwfr, ngw, nb - - ngw = SIZE(wf, 1) - nb = SIZE(wf, 2) - nwfr = SIZE(wf, 1) * 2 - ALLOCATE( s(nb) ) - DO ib = 1, nb - IF(ib.GT.1)THEN - s = zero -! ... only the processor that own G=0 - IF(gzero) THEN - wftmp = -DBLE(wf(1,ib)) - CALL DAXPY(ib-1, wftmp, wf(1,1), nwfr, s(1), 1) - END IF - - CALL DGEMV('T', nwfr, ib-1, two, wf(1,1), nwfr, wf(1,ib), 1, one, s(1), 1) - CALL mp_sum(s, gid) - !WRITE( stdout, fmt = '(I3, 16F8.2)' ) mpime, s(1:nb) - CALL DGEMV('N', nwfr, ib-1, onem, wf(1,1), nwfr, s(1), 1, one, wf(1,ib), 1) - END IF - IF(gzero) THEN - anorm = DNRM2( 2*(ngw-1), wf(2,ib), 1) - anorm = 2.0_DP * anorm**2 + DBLE( wf(1,ib) * CONJG(wf(1,ib)) ) - ELSE - anorm = DNRM2( 2*ngw, wf(1,ib), 1) - anorm = 2.0_DP * anorm**2 - END IF - CALL mp_sum(anorm, gid) - anorm = 1.0_DP / MAX( small, SQRT(anorm) ) - CALL DSCAL( 2*ngw, anorm, wf(1,ib), 1) - END DO - DEALLOCATE( s ) - - RETURN - END SUBROUTINE gram_gamma_base - - -!==----------------------------------------------==! -!==----------------------------------------------==! - - FUNCTION hpsi_kp( c, dc ) - -! (describe briefly what this routine does...) -! ---------------------------------------------- - - IMPLICIT NONE - - COMPLEX(DP) :: ZDOTC - - COMPLEX(DP) :: c(:,:) - COMPLEX(DP) :: dc(:) - - COMPLEX(DP), DIMENSION( SIZE( c, 2 ) ) :: hpsi_kp - - INTEGER :: jb, ngw, nx - -! ... end of declarations -! ---------------------------------------------- - - IF( SIZE( c, 1 ) /= SIZE( dc ) ) & - CALL errore(' hpsi_kp ', ' wrong sizes ', 1 ) - - ngw = SIZE( c, 1 ) - nx = SIZE( c, 2 ) - - DO jb = 1, nx - hpsi_kp( jb ) = - ZDOTC( ngw, c(1,jb), 1, dc(1), 1) - END DO - - RETURN - END FUNCTION hpsi_kp - -!==----------------------------------------------==! -!==----------------------------------------------==! - - FUNCTION hpsi_gamma( gzero, c, ngw, dc, n, noff ) - - IMPLICIT NONE - - COMPLEX(DP) :: c(:,:) - COMPLEX(DP) :: dc(:) - LOGICAL, INTENT(IN) :: gzero - INTEGER, INTENT(IN) :: n, noff, ngw - - REAL(DP), DIMENSION( n ) :: hpsi_gamma - - COMPLEX(DP) :: ZDOTC - - INTEGER :: j - - IF(gzero) THEN - DO j = 1, n - hpsi_gamma(j) = & - - DBLE( (2.0_DP * ZDOTC(ngw-1, c(2,j+noff-1), 1, dc(2), 1) + c(1,j+noff-1)*dc(1)) ) - END DO - ELSE - DO j = 1, n - hpsi_gamma(j) = - DBLE( (2.0_DP * ZDOTC(ngw, c(1,j+noff-1), 1, dc(1), 1)) ) - END DO - END IF - RETURN - END FUNCTION hpsi_gamma - -!==----------------------------------------------==! -!==----------------------------------------------==! - - -! BEGIN manual - - SUBROUTINE converg_base_gamma(gzero, cgrad, gemax, cnorm) - -! this routine checks for convergence, by computing the norm of the -! gradients of wavefunctions -! version for the Gamma point -! ---------------------------------------------- -! END manual - - USE mp, ONLY: mp_sum, mp_max - USE mp_global, ONLY: intra_image_comm - - IMPLICIT NONE - -! ... declare subroutine arguments - COMPLEX(DP) :: cgrad(:,:,:) - LOGICAL, INTENT(IN) :: gzero - REAL(DP), INTENT(OUT) :: gemax, cnorm - -! ... declare other variables - INTEGER :: imx, IZAMAX, i, nb, ngw - REAL(DP) :: gemax_l - -! ... end of declarations -! ---------------------------------------------- - - ngw = SIZE( cgrad, 1) - nb = SIZE( cgrad, 2) - - gemax_l = 0.0_DP - cnorm = 0.0_DP - - DO i = 1, nb - imx = IZAMAX( ngw, cgrad(1, i, 1), 1 ) - IF ( gemax_l < ABS( cgrad(imx, i, 1) ) ) THEN - gemax_l = ABS ( cgrad(imx, i, 1) ) - END IF - cnorm = cnorm + dotp(gzero, cgrad(:,i,1), cgrad(:,i,1)) - END DO - - CALL mp_max(gemax_l, intra_image_comm) - CALL mp_sum(nb, intra_image_comm) - CALL mp_sum(ngw, intra_image_comm) - - gemax = gemax_l - cnorm = SQRT( cnorm / (nb * ngw) ) - - RETURN - END SUBROUTINE converg_base_gamma - -! ---------------------------------------------- -! ---------------------------------------------- -! BEGIN manual - - SUBROUTINE converg_base_kp(weight, cgrad, gemax, cnorm) - - -! this routine checks for convergence, by computing the norm of the -! gradients of wavefunctions -! version for generic k-points -! ---------------------------------------------- -! END manual - - USE mp, ONLY: mp_sum, mp_max - USE mp_global, ONLY: intra_image_comm - - IMPLICIT NONE - -! ... declare subroutine arguments - COMPLEX(DP) :: cgrad(:,:,:) - REAL(DP), INTENT(IN) :: weight(:) - REAL(DP), INTENT(OUT) :: gemax, cnorm - -! ... declare other variables - INTEGER :: nb, ngw, nk, iabs, IZAMAX, i, ik - REAL(DP) :: gemax_l, cnormk - COMPLEX(DP) :: ZDOTC - -! ... end of declarations -! ---------------------------------------------- - - ngw = SIZE( cgrad, 1) - nb = SIZE( cgrad, 2) - nk = SIZE( cgrad, 3) - - gemax_l = 0.0_DP - cnorm = 0.0_DP - - DO ik = 1, nk - cnormk = 0.0_DP - DO i = 1, nb - iabs = IZAMAX( ngw, cgrad(1,i,ik), 1) - IF( gemax_l < ABS( cgrad(iabs,i,ik) ) ) THEN - gemax_l = ABS( cgrad(iabs,i,ik) ) - END IF - cnormk = cnormk + DBLE( ZDOTC(ngw, cgrad(1,i,ik), 1, cgrad(1,i,ik), 1)) - END DO - cnormk = cnormk * weight(ik) - cnorm = cnorm + cnormk - END DO - - CALL mp_max(gemax_l, intra_image_comm) - CALL mp_sum(cnorm, intra_image_comm) - CALL mp_sum(nb, intra_image_comm) - CALL mp_sum(ngw, intra_image_comm) - - gemax = gemax_l - cnorm = SQRT( cnorm / ( nb * ngw ) ) - - RETURN - END SUBROUTINE converg_base_kp - - - -!==----------------------------------------------==! -!==----------------------------------------------==! - - REAL(DP) FUNCTION wdot_gamma(gzero, ng, a, b) - - LOGICAL, INTENT(IN) :: gzero - COMPLEX(DP) :: a(:), b(:) - INTEGER, OPTIONAL, INTENT(IN) :: ng - - REAL(DP) :: DDOT - INTEGER :: n - - n = MIN( SIZE(a), SIZE(b) ) - IF ( PRESENT (ng) ) n = MIN( n, ng ) - - IF ( n < 1 ) & - CALL errore( ' wdot_gamma ', ' wrong dimension ', 1 ) - - IF (gzero) THEN - wdot_gamma = DDOT( 2*(n-1), a(2), 1, b(2), 1) - wdot_gamma = 2.0_DP * wdot_gamma + DBLE( a(1) ) * DBLE( b(1) ) - ELSE - wdot_gamma = 2.0_DP * DDOT( 2*n, a(1), 1, b(1), 1) - END IF - - RETURN - END FUNCTION wdot_gamma - -!==----------------------------------------------==! -!==----------------------------------------------==! - - REAL(DP) FUNCTION dotp_gamma(gzero, ng, a, b) - -! ... Compute the dot product between distributed complex vectors "a" and "b" -! ... representing HALF-SPACE complex wave functions, with the G-point symmetry -! ... a( -G ) = CONJG( a( G ) ). Only half of the values plus G=0 are really -! ... stored in the array. -! -! ... dotp = < a | b > -! - - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - - REAL(DP) :: DDOT - REAL(DP) :: dot_tmp - INTEGER, INTENT(IN) :: ng - LOGICAL, INTENT(IN) :: gzero - - COMPLEX(DP) :: a(:), b(:) - INTEGER :: n - - n = MIN( SIZE(a), SIZE(b) ) - n = MIN( n, ng ) - - IF ( n < 1 ) & - CALL errore( ' dotp_gamma ', ' wrong dimension ', 1 ) - -! ... gzero is true on the processor where the first element of the -! ... input arrays is the coefficient of the G=0 plane wave -! - IF (gzero) THEN - dot_tmp = DDOT( 2*(n-1), a(2), 1, b(2), 1) - dot_tmp = 2.0_DP * dot_tmp + DBLE( a(1) ) * DBLE( b(1) ) - ELSE - dot_tmp = DDOT( 2*n, a(1), 1, b(1), 1) - dot_tmp = 2.0_DP*dot_tmp - END IF - - CALL mp_sum( dot_tmp, intra_image_comm ) - dotp_gamma = dot_tmp - - RETURN - END FUNCTION dotp_gamma - -!==----------------------------------------------==! -!==----------------------------------------------==! - - REAL(DP) FUNCTION dotp_gamma_n(gzero, a, b) - -! ... Compute the dot product between distributed complex vectors "a" and "b" -! ... representing HALF-SPACE complex wave functions, with the G-point symmetry -! ... a( -G ) = CONJG( a( G ) ). Only half of the values plus G=0 are really -! ... stored in the array. - - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - - LOGICAL, INTENT(IN) :: gzero - - COMPLEX(DP) :: a(:), b(:) - INTEGER :: n - - n = MIN( SIZE(a), SIZE(b) ) - - IF ( n < 1 ) & - CALL errore( ' dotp_gamma_n ', ' wrong dimension ', 1 ) - - dotp_gamma_n = dotp_gamma(gzero, n, a, b) - - RETURN - END FUNCTION - - -!==----------------------------------------------==! -!==----------------------------------------------==! - - COMPLEX(DP) FUNCTION dotp_kp(ng, a, b) - -! ... Compute the dot product between distributed complex vectors "a" and "b" -! ... representing FULL-SPACE complex wave functions - - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - - COMPLEX(DP) :: ZDOTC - INTEGER, INTENT(IN) :: ng - COMPLEX(DP) :: a(:),b(:) - - COMPLEX(DP) :: dot_tmp - INTEGER :: n - - n = MIN( SIZE(a), SIZE(b) ) - n = MIN( n, ng ) - - IF ( n < 1 ) & - CALL errore( ' dotp_kp ', ' wrong dimension ', 1 ) - - dot_tmp = ZDOTC(ng, a(1), 1, b(1), 1) - - CALL mp_sum(dot_tmp, intra_image_comm) - dotp_kp = dot_tmp - - RETURN - END FUNCTION dotp_kp - -!==----------------------------------------------==! -!==----------------------------------------------==! - - COMPLEX(DP) FUNCTION dotp_kp_n(a, b) - -! ... Compute the dot product between distributed complex vectors "a" and "b" -! ... representing FULL-SPACE complex wave functions - - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - - COMPLEX(DP) ZDOTC - COMPLEX(DP), INTENT(IN) :: a(:),b(:) - - COMPLEX(DP) :: dot_tmp - INTEGER :: n - - n = MIN( SIZE(a), SIZE(b) ) - - IF ( n < 1 ) & - CALL errore( ' dotp_kp_n ', ' wrong dimension ', 1 ) - - dot_tmp = ZDOTC( n, a(1), 1, b(1), 1) - - CALL mp_sum( dot_tmp, intra_image_comm ) - dotp_kp_n = dot_tmp - - RETURN - END FUNCTION dotp_kp_n - -!==----------------------------------------------==! -!==----------------------------------------------==! - - COMPLEX(DP) FUNCTION wdot_kp(ng, a, b) - -! ... Compute the dot product between complex vectors "a" and "b" -! ... representing FULL-SPACE complex wave functions -! ... Note this is a _SCALAR_ subroutine - - COMPLEX(DP) :: a(:), b(:) - INTEGER, INTENT(IN), OPTIONAL :: ng - - COMPLEX(DP) :: ZDOTC - INTEGER :: n - - n = MIN( SIZE(a), SIZE(b) ) - IF ( PRESENT (ng) ) n = MIN( n, ng ) - - IF ( n < 1 ) & - CALL errore( ' dotp_kp_n ', ' wrong dimension ', 1 ) - - wdot_kp = ZDOTC(n, a(1), 1, b(1), 1) - - RETURN - END FUNCTION wdot_kp - -!==----------------------------------------------==! -!==----------------------------------------------==! - - SUBROUTINE rande_base(wf,ampre) - -! randomize wave functions coefficients -! ---------------------------------------------- - USE random_numbers, ONLY : randy - IMPLICIT NONE -! ... declare subroutine arguments - COMPLEX(DP) :: wf(:,:) - REAL(DP), INTENT(IN) :: ampre - -! ... declare other variables - INTEGER i, j - REAL(DP) rranf1, rranf2 -! ... end of declarations -! ---------------------------------------------- - DO i = 1, SIZE(wf, 2) - DO j = 1, SIZE( wf, 1) - rranf1 = 0.5_DP - randy() - rranf2 = 0.5_DP - randy() - wf(j,i) = wf(j,i) + ampre * CMPLX(rranf1, rranf2) - END DO - END DO - RETURN - END SUBROUTINE rande_base - -!==----------------------------------------------==! - - SUBROUTINE rande_base_s(wf,ampre) - -! randomize wave functions coefficients -! ---------------------------------------------- - USE random_numbers, ONLY : randy - IMPLICIT NONE -! ... declare subroutine arguments - COMPLEX(DP) :: wf(:) - REAL(DP), INTENT(IN) :: ampre -! ... declare other variables - INTEGER j - REAL(DP) rranf1, rranf2 -! ... end of declarations -! ---------------------------------------------- - DO j = 1, SIZE( wf ) - rranf1 = 0.5_DP - randy() - rranf2 = 0.5_DP - randy() - wf(j) = wf(j) + ampre * CMPLX(rranf1, rranf2) - END DO - RETURN - END SUBROUTINE rande_base_s - -!==----------------------------------------------==! -!==----------------------------------------------==! - - - REAL(DP) FUNCTION scalw(gzero, RR1, RR2, metric) - - USE mp_global, ONLY: intra_image_comm - USE mp, ONLY: mp_sum - - IMPLICIT NONE - - COMPLEX(DP), INTENT(IN) :: rr1(:), rr2(:), metric(:) - LOGICAL, INTENT(IN) :: gzero - INTEGER :: ig, gstart, ngw - REAL(DP) :: rsc - - ngw = MIN( SIZE(rr1), SIZE(rr2), SIZE(metric) ) - rsc = 0.0_DP - - gstart = 1 - IF (gzero) gstart = 2 - - DO ig = gstart, ngw - rsc = rsc + rr1( ig ) * CONJG( rr2( ig ) ) * metric( ig ) - END DO - - CALL mp_sum(rsc, intra_image_comm) - - scalw = rsc - - RETURN - END FUNCTION scalw - -!==----------------------------------------------==! -!==----------------------------------------------==! - - SUBROUTINE wave_steepest( CP, C0, dt2m, grad, ngw, idx ) - IMPLICIT NONE - COMPLEX(DP), INTENT(OUT) :: CP(:) - COMPLEX(DP), INTENT(IN) :: C0(:) - COMPLEX(DP), INTENT(IN) :: grad(:) - REAL(DP), INTENT(IN) :: dt2m(:) - INTEGER, OPTIONAL, INTENT(IN) :: ngw, idx - ! - ! - IF( PRESENT( ngw ) .AND. PRESENT( idx ) ) THEN - CP( : ) = C0( : ) + dt2m(:) * grad( (idx-1)*ngw+1 : idx*ngw ) - ELSE - CP( : ) = C0( : ) + dt2m(:) * grad(:) - END IF - ! - RETURN - END SUBROUTINE wave_steepest - -!==----------------------------------------------==! -!==----------------------------------------------==! - - SUBROUTINE wave_verlet( cm, c0, ver1, ver2, ver3, grad, ngw, idx ) - IMPLICIT NONE - COMPLEX(DP), INTENT(INOUT) :: cm(:) - COMPLEX(DP), INTENT(IN) :: c0(:) - COMPLEX(DP), INTENT(IN) :: grad(:) - REAL(DP), INTENT(IN) :: ver1, ver2, ver3(:) - INTEGER, OPTIONAL, INTENT(IN) :: ngw, idx - ! - IF( PRESENT( ngw ) .AND. PRESENT( idx ) ) THEN - cm( : ) = ver1 * c0( : ) + ver2 * cm( : ) + ver3( : ) * grad( (idx-1)*ngw+1:idx*ngw) - ELSE - cm( : ) = ver1 * c0( : ) + ver2 * cm( : ) + ver3( : ) * grad( : ) - END IF - ! - RETURN - END SUBROUTINE wave_verlet - -!==----------------------------------------------==! -!==----------------------------------------------==! - - FUNCTION wave_speed2( cp, cm, wmss, fact, lgam)!added:giovanni lgam - IMPLICIT NONE - COMPLEX(DP), INTENT(IN) :: cp(:) - COMPLEX(DP), INTENT(IN) :: cm(:) - REAL(DP) :: wmss(:), fact - REAL(DP) :: wave_speed2 - REAL(DP) :: ekinc - COMPLEX(DP) :: speed - INTEGER :: j - LOGICAL :: lgam!added:giovanni - - - IF(lgam) THEN - speed = ( cp(1) - cm(1) ) - ekinc = fact * wmss(1) * CONJG( speed ) * speed - DO j = 2, SIZE( cp ) - speed = ( cp(j) - cm(j) ) - ekinc = ekinc + wmss(j) * CONJG( speed ) * speed - END DO - ELSE -!begin_added:giovanni - speed = ( cp(1) - cm(1) ) - ekinc = 0.5d0 * wmss(1) * CONJG( speed ) * speed - DO j = 2, SIZE( cp ) - speed = ( cp(j) - cm(j) ) - ekinc = ekinc + 0.5d0 * wmss(j) * CONJG( speed ) * speed - END DO -!end_added:giovanni - ENDIF - wave_speed2 = ekinc - RETURN - END FUNCTION wave_speed2 - -!==----------------------------------------------==! - END MODULE wave_base -!==----------------------------------------------==! diff --git a/quantum_espresso/kcp/Modules/wavefunctions.f90 b/quantum_espresso/kcp/Modules/wavefunctions.f90 deleted file mode 100644 index a8c3402cc..000000000 --- a/quantum_espresso/kcp/Modules/wavefunctions.f90 +++ /dev/null @@ -1,63 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -!=----------------------------------------------------------------------------=! - MODULE wavefunctions_module -!=----------------------------------------------------------------------------=! - USE kinds, ONLY : DP - - IMPLICIT NONE - SAVE - - ! - COMPLEX(DP), ALLOCATABLE, TARGET :: & - evc(:,:) ! wavefunctions in the PW basis set - ! noncolinear case: first index - ! is a combined PW + spin index - ! - COMPLEX(DP) , ALLOCATABLE, TARGET :: & - psic(:), & ! additional memory for FFT - psic_nc(:,:) ! as above for the noncolinear case - ! - ! electronic wave functions, FPMD code - ! - COMPLEX(DP), ALLOCATABLE :: c0(:,:) ! wave functions at time t - COMPLEX(DP), ALLOCATABLE :: cm(:,:) ! wave functions at time t-delta t - COMPLEX(DP), ALLOCATABLE :: cp(:,:) ! wave functions at time t+delta t - COMPLEX(DP), ALLOCATABLE :: cstart(:,:) ! wave functions at start - COMPLEX(DP), ALLOCATABLE :: c0_fixed(:,:) ! wave functions at start fixed - COMPLEX(DP), ALLOCATABLE :: c0fixed_emp(:,:) ! empty wave functions at start fixed - COMPLEX(DP), ALLOCATABLE :: c0_occ_emp_aux(:,:) ! empty wave functions to saved - COMPLEX(DP), ALLOCATABLE :: c0fixed_aux(:,:) ! empty wave functions to saved - COMPLEX(DP), ALLOCATABLE :: ctot_aux(:,:) - - ! below dual wavefunctions, allocated only in the non orthogonal case - COMPLEX(DP), ALLOCATABLE :: cdual(:,:) ! dual wave functions at time t - COMPLEX(DP), ALLOCATABLE :: cmdual(:,:) ! dual wave functions at time t - - - CONTAINS - - SUBROUTINE deallocate_wavefunctions - IF( ALLOCATED( c0 ) ) DEALLOCATE( c0 ) - IF( ALLOCATED( cm ) ) DEALLOCATE( cm ) - IF( ALLOCATED( cp ) ) DEALLOCATE( cp ) - IF( ALLOCATED( psic_nc ) ) DEALLOCATE( psic_nc ) - IF( ALLOCATED( psic ) ) DEALLOCATE( psic ) - IF( ALLOCATED( evc ) ) DEALLOCATE( evc ) - IF( ALLOCATED( cdual ) ) DEALLOCATE( cdual ) - IF( ALLOCATED( cmdual ) ) DEALLOCATE( cmdual ) - IF( ALLOCATED( cstart ) ) DEALLOCATE( cstart ) - IF( ALLOCATED( c0_fixed ) ) DEALLOCATE( c0_fixed ) - IF( ALLOCATED( c0_occ_emp_aux ) ) DEALLOCATE( c0_occ_emp_aux ) - IF( ALLOCATED( c0fixed_aux ) ) DEALLOCATE( c0fixed_aux ) - END SUBROUTINE deallocate_wavefunctions - -!=----------------------------------------------------------------------------=! - END MODULE wavefunctions_module -!=----------------------------------------------------------------------------=! diff --git a/quantum_espresso/kcp/Modules/wrappers.f90 b/quantum_espresso/kcp/Modules/wrappers.f90 deleted file mode 100644 index e306b03d5..000000000 --- a/quantum_espresso/kcp/Modules/wrappers.f90 +++ /dev/null @@ -1,87 +0,0 @@ -! -! Copyright (C) 2004-2009 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!-------------------------------------------------------------------------- -! -MODULE wrappers - ! - ! these routines are used to pass fortran strings to C routines in a - ! safe way. Strings are converted to integer arrays here, passed to - ! C wrappers, converted back to strings. Other ways to pass fortran - ! strings to C turned out to be non portable and not safe - ! - USE kinds, ONLY : DP - IMPLICIT NONE - SAVE -CONTAINS - ! - FUNCTION feval_infix( ierr, str ) - REAL(DP) :: feval_infix - INTEGER :: ierr - CHARACTER(LEN=*) :: str - INTEGER :: i, ilen - INTEGER, ALLOCATABLE :: istr(:) - REAL(DP), EXTERNAL :: eval_infix_wrapper - ALLOCATE( istr( LEN( str ) ) ) - DO i = 1, LEN( str ) - istr(i) = ICHAR( str(i:i) ) - IF( istr(i) < 0 .OR. istr(i) > 127 ) & - CALL errore( ' feval_infix ', ' invalid character ', ABS( istr(i) ) ) - END DO - ilen = LEN( str ) - feval_infix = eval_infix_wrapper( ierr, istr, ilen ) - DEALLOCATE( istr ) - RETURN - END FUNCTION - ! - FUNCTION f_mkdir( dirname ) - INTEGER :: f_mkdir - CHARACTER(LEN=*) :: dirname - INTEGER :: i, ilen - INTEGER, ALLOCATABLE :: istr(:) - INTEGER, EXTERNAL :: c_mkdir_int - ALLOCATE( istr( LEN( dirname ) ) ) - DO i = 1, LEN( dirname ) - istr(i) = ICHAR( dirname(i:i) ) - IF( istr(i) < 0 .OR. istr(i) > 127 ) & - CALL errore( ' f_mkdir ', ' invalid character ', ABS( istr(i) ) ) - END DO - ilen = LEN( dirname ) - f_mkdir = c_mkdir_int( istr, ilen ) - DEALLOCATE( istr ) - RETURN - END FUNCTION - ! - FUNCTION f_rename( oldname, newname ) - INTEGER :: f_rename - CHARACTER(LEN=*) :: oldname - CHARACTER(LEN=*) :: newname - INTEGER :: i, lold, lnew - INTEGER, ALLOCATABLE :: iold(:) - INTEGER, ALLOCATABLE :: inew(:) - INTEGER, EXTERNAL :: c_rename_int - lold = LEN( oldname ) - lnew = LEN( newname ) - ALLOCATE( iold( lold ) ) - ALLOCATE( inew( lnew ) ) - DO i = 1, lold - iold(i) = ICHAR( oldname(i:i) ) - IF( iold(i) < 0 .OR. iold(i) > 127 ) & - CALL errore( ' f_rename ', ' invalid character ', ABS( iold(i) ) ) - END DO - DO i = 1, lnew - inew(i) = ICHAR( newname(i:i) ) - IF( inew(i) < 0 .OR. inew(i) > 127 ) & - CALL errore( ' f_rename ', ' invalid character ', ABS( inew(i) ) ) - END DO - f_rename = c_rename_int( iold, lold, inew, lnew ) - DEALLOCATE( inew ) - DEALLOCATE( iold ) - RETURN - END FUNCTION - ! -END MODULE diff --git a/quantum_espresso/kcp/Modules/write_upf_v2.f90 b/quantum_espresso/kcp/Modules/write_upf_v2.f90 deleted file mode 100644 index 99d3fcde4..000000000 --- a/quantum_espresso/kcp/Modules/write_upf_v2.f90 +++ /dev/null @@ -1,608 +0,0 @@ -! -! Copyright (C) 2008 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!=----------------------------------------------------------------------------=! - MODULE write_upf_v2_module -!=----------------------------------------------------------------------------=! -! this module handles the writing of pseudopotential data - -! ... declare modules - USE kinds, ONLY: DP - USE pseudo_types, ONLY: pseudo_upf - USE radial_grids, ONLY: radial_grid_type - USE iotk_module - ! - IMPLICIT NONE - ! - PRIVATE - PUBLIC :: write_upf_v2, pseudo_config, deallocate_pseudo_config - - TYPE pseudo_config - INTEGER :: nwfs - CHARACTER(len=32) :: pseud - CHARACTER(len=2),POINTER :: els(:) !=> null() ! label - INTEGER,POINTER :: nns(:) !=> null() ! n - INTEGER,POINTER :: lls(:) !=> null() ! l - REAL(DP),POINTER :: ocs(:) !=> null() ! occupation - REAL(DP),POINTER :: rcut(:) !=> null() ! NC cutoff radius - REAL(DP),POINTER :: rcutus(:) !=> null() ! US cutoff radius - REAL(DP),POINTER :: enls(:) !=> null() ! energy - END TYPE pseudo_config - - CONTAINS - -!-------------------------------+ -SUBROUTINE write_upf_v2(u, upf, conf) ! - !----------------------------+ - ! Write pseudopotential in UPF format version 2, uses iotk - ! - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data - ! optional: configuration used to generate the pseudopotential - TYPE(pseudo_config),OPTIONAL,INTENT(IN) :: conf - ! - CHARACTER(len=iotk_attlenx) :: attr - ! - ! Initialize the file - CALL iotk_write_attr(attr, 'version', TRIM(upf%nv), first=.true.) - CALL iotk_open_write(u, attr=attr, root='UPF', skip_head=.true.) - ! - ! Write human-readable header - CALL write_info(u, upf, conf) - ! - ! Write machine-readable header - CALL write_header(u, upf) - ! Write radial grid mesh - CALL write_mesh(u, upf) - ! Write non-linear core correction charge - IF(upf%nlcc) CALL iotk_write_dat(u, 'PP_NLCC', upf%rho_atc, columns=4) - ! Write local potential - IF(.not. upf%tcoulombp) THEN - CALL iotk_write_dat(u, 'PP_LOCAL', upf%vloc, columns=4) - ELSE - CALL iotk_write_attr(attr, 'type', '1/r', first=.true.) - CALL iotk_write_attr(attr, 'comment', 'Coulomb 1/r potential') - CALL iotk_write_empty(u, 'PP_NLCC', attr=attr) - ENDIF - ! Write nonlocal components: projectors, augmentation, hamiltonian elements - CALL write_nonlocal(u, upf) - ! Write initial pseudo wavefunctions - ! (usually only wfcs with occupancy > 0) - CALL write_pswfc(u, upf) - ! If included, write all-electron and pseudo wavefunctions - CALL write_full_wfc(u, upf) - ! Write valence atomic density (used for initial density) - CALL iotk_write_dat(u, 'PP_RHOATOM', upf%rho_at, columns=4) - ! Write additional info for full-relativistic calculation - CALL write_spin_orb(u, upf) - ! Write additional data for PAW (All-electron charge, wavefunctions, vloc..) - CALL write_paw(u, upf) - ! Write additional data for GIPAW reconstruction - CALL write_gipaw(u, upf) - ! - ! Close the file (not the unit!) - CALL iotk_close_write(u) - - CONTAINS - ! - SUBROUTINE write_info(u, upf, conf) - ! Write human-readable header - ! The header is written directly, not via iotk - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data - ! optional: configuration used to generate the pseudopotential - TYPE(pseudo_config),OPTIONAL,INTENT(IN) :: conf - ! - INTEGER :: nb ! aux counter - INTEGER :: ierr ! /= 0 if something went wrong - ! - CALL iotk_write_begin(u,'PP_INFO') - ! All the section has to fit in a comment, otherwise iotk will complain: - !WRITE(u, '(2x,a)', err=100) '' - ! - CALL iotk_write_end(u,'PP_INFO') - CALL iotk_write_comment(u,' ') - CALL iotk_write_comment(u,' END OF HUMAN READABLE SECTION ') - CALL iotk_write_comment(u,' ') - ! - RETURN -100 CALL errore('write_upf_v2::write_info', 'Writing pseudo file', 1) - END SUBROUTINE write_info - ! - SUBROUTINE write_header(u, upf) - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data - INTEGER :: ierr ! /= 0 if something went wrong - - CHARACTER(len=iotk_attlenx) :: attr - ! - INTEGER :: nw - ! - ! Write HEADER section with some initialization data - !CALL iotk_write_attr(attr, 'version', upf%nv, first=.true., newline=.true.) - CALL iotk_write_attr(attr, 'generated', TRIM(upf%generated),first=.true.) - CALL iotk_write_attr(attr, 'author', TRIM(upf%author), newline=.true.) - CALL iotk_write_attr(attr, 'date', TRIM(upf%date), newline=.true.) - CALL iotk_write_attr(attr, 'comment', TRIM(upf%comment), newline=.true.) - ! - CALL iotk_write_attr(attr, 'element', upf%psd, newline=.true.) - CALL iotk_write_attr(attr, 'pseudo_type', TRIM(upf%typ), newline=.true.) - CALL iotk_write_attr(attr, 'relativistic', TRIM(upf%rel), newline=.true.) - ! - CALL iotk_write_attr(attr, 'is_ultrasoft', upf%tvanp, newline=.true.) - CALL iotk_write_attr(attr, 'is_paw', upf%tpawp, newline=.true.) - CALL iotk_write_attr(attr, 'is_coulomb', upf%tcoulombp, newline=.true.) - ! - CALL iotk_write_attr(attr, 'has_so', upf%has_so, newline=.true.) - CALL iotk_write_attr(attr, 'has_wfc', upf%has_wfc, newline=.true.) - CALL iotk_write_attr(attr, 'has_gipaw', upf%has_gipaw, newline=.true.) - ! - CALL iotk_write_attr(attr, 'core_correction',upf%nlcc, newline=.true.) - CALL iotk_write_attr(attr, 'functional', upf%dft, newline=.true.) - CALL iotk_write_attr(attr, 'z_valence', upf%zp, newline=.true.) - CALL iotk_write_attr(attr, 'total_psenergy', upf%etotps, newline=.true.) - CALL iotk_write_attr(attr, 'wfc_cutoff', upf%ecutwfc, newline=.true.) - CALL iotk_write_attr(attr, 'rho_cutoff', upf%ecutrho, newline=.true.) - CALL iotk_write_attr(attr, 'l_max', upf%lmax, newline=.true.) - CALL iotk_write_attr(attr, 'l_max_rho', upf%lmax_rho, newline=.true.) - CALL iotk_write_attr(attr, 'l_local', upf%lloc, newline=.true.) - CALL iotk_write_attr(attr, 'mesh_size', upf%mesh, newline=.true.) - CALL iotk_write_attr(attr, 'number_of_wfc', upf%nwfc, newline=.true.) - CALL iotk_write_attr(attr, 'number_of_proj', upf%nbeta, newline=.true.) - CALL iotk_write_empty(u, 'PP_HEADER', attr=attr) - ! - !CALL iotk_write_end(u, 'PP_HEADER') - ! - RETURN - END SUBROUTINE write_header - ! - SUBROUTINE write_mesh(u, upf) - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data - INTEGER :: ierr ! /= 0 if something went wrong - - CHARACTER(len=iotk_attlenx) :: attr - ! - CALL iotk_write_attr(attr, 'dx', upf%dx, first=.true.) - CALL iotk_write_attr(attr, 'mesh', upf%mesh) - CALL iotk_write_attr(attr, 'xmin', upf%xmin) - CALL iotk_write_attr(attr, 'rmax', upf%rmax) - CALL iotk_write_attr(attr, 'zmesh',upf%zmesh) - CALL iotk_write_begin(u, 'PP_MESH', attr=attr) - ! - CALL iotk_write_dat(u, 'PP_R', upf%r, columns=4) - CALL iotk_write_dat(u, 'PP_RAB', upf%rab, columns=4) - ! - CALL iotk_write_end(u, 'PP_MESH') - ! - RETURN - END SUBROUTINE write_mesh - ! - SUBROUTINE write_nonlocal(u, upf) - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data - INTEGER :: ierr ! /= 0 if something went wrong - - CHARACTER(len=iotk_attlenx) :: attr - ! - INTEGER :: nb,mb,ln,lm,l,nmb - LOGICAL :: isnull - ! - IF (upf%tcoulombp) RETURN - ! - CALL iotk_write_begin(u, 'PP_NONLOCAL') - ! - ! Write the projectors: - DO nb = 1,upf%nbeta - CALL iotk_write_attr(attr, 'index', nb, first=.true.) - CALL iotk_write_attr(attr, 'label', upf%els_beta(nb)) - CALL iotk_write_attr(attr, 'angular_momentum', upf%lll(nb)) - CALL iotk_write_attr(attr, 'cutoff_radius_index', upf%kbeta(nb)) - CALL iotk_write_attr(attr, 'cutoff_radius', upf%rcut(nb)) - CALL iotk_write_attr(attr, 'norm_conserving_radius', upf%rcutus(nb)) - CALL iotk_write_dat(u, 'PP_BETA'//iotk_index( nb ), & - upf%beta(:,nb), attr=attr, columns=4) - ENDDO - ! - ! Write the hamiltonian terms D_ij - CALL iotk_write_dat(u, 'PP_DIJ', upf%dion, columns=4) - ! - ! Write the augmentation charge section - augmentation : & - IF(upf%tvanp .or. upf%tpawp) THEN - CALL iotk_write_attr(attr, 'q_with_l', upf%q_with_l, first=.true.) - CALL iotk_write_attr(attr, 'nqf', upf%nqf) - CALL iotk_write_attr(attr, 'nqlc', upf%nqlc) - IF (upf%tpawp) THEN - CALL iotk_write_attr(attr,'shape', TRIM(upf%paw%augshape)) - CALL iotk_write_attr(attr,'cutoff_r', upf%paw%raug) - CALL iotk_write_attr(attr,'cutoff_r_index', upf%paw%iraug) - CALL iotk_write_attr(attr,'augmentation_epsilon',upf%qqq_eps) - CALL iotk_write_attr(attr,'l_max_aug', upf%paw%lmax_aug) - ENDIF - ! - CALL iotk_write_begin(u, 'PP_AUGMENTATION', attr=attr) - ! - ! Write the integrals of the Q functions - CALL iotk_write_dat(u, 'PP_Q',upf%qqq, columns=4) - ! - ! Write charge multipoles (only if PAW) - IF ( upf%tpawp ) THEN - CALL iotk_write_comment(u, ' augmentation charge multipoles (only for PAW) ') - CALL iotk_write_dat(u, 'PP_MULTIPOLES', upf%paw%augmom, columns=4) - ENDIF - ! - ! Write polinomial coefficients for Q_ij expansion at small radius - IF ( upf%nqf > 0) THEN - CALL iotk_write_comment(u, ' polinomial expansion of Q_ij at small radius ') - CALL iotk_write_dat(u, 'PP_QFCOEF',upf%qfcoef, attr=attr, columns=4) - CALL iotk_write_dat(u, 'PP_RINNER',upf%rinner, attr=attr, columns=4) - ENDIF - ! - ! Write augmentation charge Q_ij - DO nb = 1,upf%nbeta - ln = upf%lll(nb) - DO mb = nb,upf%nbeta - lm = upf%lll(mb) - nmb = mb * (mb-1) /2 + nb - IF( upf%q_with_l ) THEN - DO l = abs(ln-lm),ln+lm,2 ! only even terms - CALL iotk_write_attr(attr, 'first_index', nb, first=.true.) - CALL iotk_write_attr(attr, 'second_index', mb) - CALL iotk_write_attr(attr, 'composite_index', nmb) - CALL iotk_write_attr(attr, 'angular_momentum', l) - ! - isnull = .false. ! omit functions that are multiplied by zero - IF( upf%tpawp ) isnull = (abs(upf%paw%augmom(nb,mb,l)) < upf%qqq_eps) - ! - IF ( isnull ) THEN - CALL iotk_write_attr(attr, 'is_null', isnull) - CALL iotk_write_empty(u, 'PP_QIJL'//iotk_index((/nb,mb,l/)),& - attr=attr) - ELSE - CALL iotk_write_dat(u, 'PP_QIJL'//iotk_index((/nb,mb,l/)),& - upf%qfuncl(:,nmb,l),attr=attr, columns=4) - ENDIF - ENDDO - ELSE - CALL iotk_write_attr(attr, 'first_index', nb, first=.true.) - CALL iotk_write_attr(attr, 'second_index', mb) - CALL iotk_write_attr(attr, 'composite_index', nmb) - ! - isnull = .false. ! omit functions that are multiplied by zero - IF( upf%tpawp ) isnull = ( abs(upf%qqq(nb,mb)) < upf%qqq_eps ) - IF ( isnull ) THEN - CALL iotk_write_attr(attr, 'is_null', isnull) - CALL iotk_write_empty(u, 'PP_QIJ'//iotk_index((/nb,mb/)),& - attr=attr) - ELSE - CALL iotk_write_dat(u, 'PP_QIJ'//iotk_index((/nb,mb/)),& - upf%qfunc(:,nmb),attr=attr, columns=4) - ENDIF - ENDIF - ENDDO - ENDDO - ! - CALL iotk_write_end(u, 'PP_AUGMENTATION') - ! - ENDIF augmentation - ! - CALL iotk_write_end(u, 'PP_NONLOCAL') - ! - RETURN - END SUBROUTINE write_nonlocal - ! - SUBROUTINE write_pswfc(u, upf) - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data - INTEGER :: ierr ! /= 0 if something went wrong - - CHARACTER(len=iotk_attlenx) :: attr - ! - INTEGER :: nw - ! - CALL iotk_write_begin(u, 'PP_PSWFC') - ! - DO nw = 1,upf%nwfc - CALL iotk_write_attr(attr, 'index', nw, first=.true.) - CALL iotk_write_attr(attr, 'label', upf%els(nw)) - CALL iotk_write_attr(attr, 'l', upf%lchi(nw)) - CALL iotk_write_attr(attr, 'occupation', upf%oc(nw)) - CALL iotk_write_attr(attr, 'n', upf%nchi(nw)) - CALL iotk_write_attr(attr, 'pseudo_energy', upf%epseu(nw)) - CALL iotk_write_attr(attr, 'cutoff_radius', upf%rcut_chi(nw)) - CALL iotk_write_attr(attr, 'ultrasoft_cutoff_radius', upf%rcutus_chi(nw)) - CALL iotk_write_dat(u, 'PP_CHI'//iotk_index(nw), & - upf%chi(:,nw), columns=4, attr=attr) - ENDDO - ! - CALL iotk_write_end(u, 'PP_PSWFC') - ! - RETURN - END SUBROUTINE write_pswfc - ! - SUBROUTINE write_spin_orb(u, upf) - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data - INTEGER :: ierr ! /= 0 if something went wrong - - CHARACTER(len=iotk_attlenx) :: attr - ! - INTEGER :: nw, nb - ! - IF (.not. upf%has_so) RETURN - ! - CALL iotk_write_begin(u, 'PP_SPIN_ORB') - ! - DO nw = 1,upf%nwfc - CALL iotk_write_attr(attr, 'index', nw, first=.true.) - CALL iotk_write_attr(attr, 'els', upf%els(nw)) - CALL iotk_write_attr(attr, 'nn', upf%nn(nw)) - CALL iotk_write_attr(attr, 'lchi', upf%lchi(nw)) - CALL iotk_write_attr(attr, 'jchi', upf%jchi(nw)) - CALL iotk_write_attr(attr, 'oc', upf%oc(nw)) - CALL iotk_write_empty(u, 'PP_RELWFC'//iotk_index(nw),& - attr=attr) - ENDDO - ! - DO nb = 1,upf%nbeta - CALL iotk_write_attr(attr, 'index', nb, first=.true.) - CALL iotk_write_attr(attr, 'lll', upf%lll(nb)) - CALL iotk_write_attr(attr, 'jjj', upf%jjj(nb)) - CALL iotk_write_empty(u, 'PP_RELBETA'//iotk_index(nb),& - attr=attr) - ENDDO - ! - CALL iotk_write_end(u, 'PP_SPIN_ORB') - ! - RETURN - END SUBROUTINE write_spin_orb - ! - - SUBROUTINE write_full_wfc(u, upf) - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data - INTEGER :: ierr ! /= 0 if something went wrong - ! - CHARACTER(len=iotk_attlenx) :: attr - ! - INTEGER :: nb - - IF(.not. upf%has_wfc) RETURN - - CALL iotk_write_attr(attr, 'number_of_wfc', upf%nbeta, first=.true.) - CALL iotk_write_begin(u, 'PP_FULL_WFC', attr=attr) - ! All-electron wavefunctions corresponding to beta functions - DO nb = 1,upf%nbeta - CALL iotk_write_attr(attr, 'index', nb, first=.true.) - CALL iotk_write_attr(attr, 'label', upf%els_beta(nb)) - CALL iotk_write_attr(attr, 'l', upf%lll(nb)) - CALL iotk_write_dat(u, 'PP_AEWFC'//iotk_index(nb), & - upf%aewfc(:,nb), columns=4, attr=attr) - ENDDO - ! Pseudo wavefunctions - DO nb = 1,upf%nbeta - CALL iotk_write_attr(attr, 'index', nb, first=.true.) - CALL iotk_write_attr(attr, 'label', upf%els_beta(nb)) - CALL iotk_write_attr(attr, 'l', upf%lll(nb)) - CALL iotk_write_dat(u, 'PP_PSWFC'//iotk_index(nb), & - upf%pswfc(:,nb), columns=4, attr=attr) - ENDDO - ! Finalize - CALL iotk_write_end(u, 'PP_FULL_WFC') - - END SUBROUTINE write_full_wfc - - SUBROUTINE write_paw(u, upf) - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data - INTEGER :: ierr ! /= 0 if something went wrong - ! - CHARACTER(len=iotk_attlenx) :: attr - ! - INTEGER :: nb - - IF (.not. upf%tpawp ) RETURN - - CALL iotk_write_attr(attr, 'paw_data_format', upf%paw_data_format, first=.true.) - CALL iotk_write_attr(attr, 'core_energy', upf%paw%core_energy) - CALL iotk_write_begin(u, 'PP_PAW', attr=attr) - ! Full occupation (not only > 0 ones) - CALL iotk_write_dat(u, 'PP_OCCUPATIONS',upf%paw%oc, columns=4) - ! All-electron core charge - CALL iotk_write_dat(u, 'PP_AE_NLCC', upf%paw%ae_rho_atc, columns=4) - ! All-electron local potential - CALL iotk_write_dat(u, 'PP_AE_VLOC', upf%paw%ae_vloc,columns=4) - ! - CALL iotk_write_end(u, 'PP_PAW') - - RETURN - END SUBROUTINE write_paw -! - SUBROUTINE write_gipaw(u, upf) - IMPLICIT NONE - INTEGER,INTENT(IN) :: u ! i/o unit - TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data - INTEGER :: ierr ! /= 0 if something went wrong - ! - CHARACTER(len=iotk_attlenx) :: attr - ! - INTEGER :: nb - IF (.not. upf%has_gipaw ) RETURN - - CALL iotk_write_attr(attr, 'gipaw_data_format', upf%gipaw_data_format, first=.true.) - CALL iotk_write_begin(u, 'PP_GIPAW', attr=attr) - - CALL iotk_write_attr(attr, 'number_of_core_orbitals', upf%gipaw_ncore_orbitals, first=.true.) - CALL iotk_write_begin(u, 'PP_GIPAW_CORE_ORBITALS', attr=attr) - DO nb = 1,upf%gipaw_ncore_orbitals - CALL iotk_write_attr(attr, 'index', nb, first=.true.) - CALL iotk_write_attr(attr, 'label', upf%gipaw_core_orbital_el(nb)) - CALL iotk_write_attr(attr, 'n', upf%gipaw_core_orbital_n(nb)) - CALL iotk_write_attr(attr, 'l', upf%gipaw_core_orbital_l(nb)) - CALL iotk_write_dat(u, 'PP_GIPAW_CORE_ORBITAL'//iotk_index(nb), & - upf%gipaw_core_orbital(:,nb), columns=4, attr=attr) - ENDDO - CALL iotk_write_end(u, 'PP_GIPAW_CORE_ORBITALS') - ! - ! Write valence all-electron and pseudo orbitals - CALL iotk_write_attr(attr, 'number_of_valence_orbitals', upf%gipaw_wfs_nchannels, first=.true.) - CALL iotk_write_begin(u, 'PP_GIPAW_ORBITALS', attr=attr) - ! - DO nb = 1,upf%gipaw_wfs_nchannels - CALL iotk_write_attr(attr, 'index', nb, first=.true.) - CALL iotk_write_attr(attr, 'label', upf%gipaw_wfs_el(nb)) - CALL iotk_write_attr(attr, 'l', upf%gipaw_wfs_ll(nb)) - CALL iotk_write_attr(attr, 'cutoff_radius', upf%gipaw_wfs_rcut(nb)) - CALL iotk_write_attr(attr, 'ultrasoft_cutoff_radius', upf%gipaw_wfs_rcutus(nb)) - CALL iotk_write_begin(u, 'PP_GIPAW_ORBITAL'//iotk_index(nb), attr=attr) - ! - CALL iotk_write_dat(u, 'PP_GIPAW_WFS_AE', upf%gipaw_wfs_ae(:,nb), columns=4) - CALL iotk_write_dat(u, 'PP_GIPAW_WFS_PS', upf%gipaw_wfs_ps(:,nb), columns=4) - ! - CALL iotk_write_end(u, 'PP_GIPAW_ORBITAL'//iotk_index(nb)) - ENDDO - CALL iotk_write_end(u, 'PP_GIPAW_ORBITALS') - ! - ! Write all-electron and pseudo local potentials - CALL iotk_write_begin(u, 'PP_GIPAW_VLOCAL') - CALL iotk_write_dat(u, 'PP_GIPAW_VLOCAL_AE', & - upf%gipaw_vlocal_ae(:), columns=4) - CALL iotk_write_dat(u, 'PP_GIPAW_VLOCAL_PS', & - upf%gipaw_vlocal_ae(:), columns=4) - CALL iotk_write_end(u, 'PP_GIPAW_VLOCAL') - ! - CALL iotk_write_end(u, 'PP_GIPAW') - - RETURN - END SUBROUTINE write_gipaw -! -! Remove '<' and '>' from string, replacing them with '/', necessary -! or iotk will complain while read-skipping PP_INFO section. - FUNCTION CHECK(in) RESULT (out) - CHARACTER(len=*) :: in - CHARACTER(len=len(in)) :: out - INTEGER :: i - DO i = 1,len(in) - IF ( in(i:i) == '<' .or. in(i:i) == '>' ) THEN - out(i:i) = '/' - ELSE - out(i:i) = in(i:i) - ENDIF - ENDDO - END FUNCTION CHECK -END SUBROUTINE write_upf_v2 - - SUBROUTINE deallocate_pseudo_config(conf) - TYPE(pseudo_config),INTENT(INOUT) :: conf - if (associated(conf%els) ) deallocate(conf%els) - if (associated(conf%nns) ) deallocate(conf%nns) - if (associated(conf%lls) ) deallocate(conf%lls) - if (associated(conf%ocs) ) deallocate(conf%ocs) - if (associated(conf%rcut) ) deallocate(conf%rcut) - if (associated(conf%rcutus)) deallocate(conf%rcutus) - if (associated(conf%enls) ) deallocate(conf%enls) - - END SUBROUTINE deallocate_pseudo_config - -END MODULE write_upf_v2_module diff --git a/quantum_espresso/kcp/Modules/xml_input.f90 b/quantum_espresso/kcp/Modules/xml_input.f90 deleted file mode 100644 index 88c5d3adc..000000000 --- a/quantum_espresso/kcp/Modules/xml_input.f90 +++ /dev/null @@ -1,175 +0,0 @@ -! -! Copyright (C) 2002-2005 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!=----------------------------------------------------------------------------=! -! -MODULE xml_input - - USE xml_io_base - USE iotk_module - USE kinds - - IMPLICIT NONE - PRIVATE - - PUBLIC :: xml_input_dump - - INTERFACE dump_keyword - MODULE PROCEDURE dump_keyword_str, dump_keyword_i - END INTERFACE - - CONTAINS - - SUBROUTINE xml_input_dump - - USE io_global, ONLY : ionode, stdout - USE io_files, ONLY : iunpun - USE global_version, ONLY : version_number - USE input_parameters - - CHARACTER(LEN=256) :: filename - INTEGER :: ierr - - return - - filename = 'qe_input.xml' - - IF ( ionode ) THEN - ! - ! ... Open XML descriptor - ! - WRITE( stdout, '(/,3X,"Dumping input parameters",/)' ) - ! - CALL iotk_open_write( iunpun, FILE = filename, BINARY = .FALSE., IERR = ierr ) - ! - END IF - - IF ( ionode ) THEN - - CALL iotk_write_attr( attr, "targetNamespace", "http://www.deisa.org/pwscf/3_2", FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "elementFormDefault", "qualified" ) - CALL iotk_write_attr( attr, "xmlns", "http://www.w3.org/2001/XMLSchema" ) - CALL iotk_write_attr( attr, "xmlns:tns", "http://www.deisa.org/pwscf/3_2" ) - CALL iotk_write_begin( iunpun, "schema", attr ) - - CALL write_header( "Quantum-ESPRESSO", TRIM(version_number) ) - - CALL iotk_write_attr( attr, "section_type", "namelist", FIRST = .TRUE. ) - CALL iotk_write_begin( iunpun, "CONTROLS", attr ) - CALL dump_keyword( "title", title, "namelist", " " ) - CALL dump_keyword( "calculation", calculation, "namelist", " ", calculation_allowed ) - CALL dump_keyword( "verbosity", verbosity, "namelist", " ", verbosity_allowed ) - CALL dump_keyword( "restart_mode", restart_mode, "namelist", " ", restart_mode_allowed ) - CALL dump_keyword( "nstep", nstep, "namelist", " ", min_value = 1 ) - CALL dump_keyword( "iprint", iprint, "namelist", " ", min_value = 1 ) - CALL iotk_write_end( iunpun, "CONTROLS" ) - - CALL iotk_write_attr( attr, "section_type", "namelist", FIRST = .TRUE. ) - CALL iotk_write_begin( iunpun, "SYSTEM", attr ) - CALL iotk_write_end( iunpun, "SYSTEM" ) - - CALL iotk_write_attr( attr, "section_type", "namelist", FIRST = .TRUE. ) - CALL iotk_write_begin( iunpun, "ELECTRONS", attr ) - CALL iotk_write_end( iunpun, "ELECTRONS" ) - - CALL iotk_write_attr( attr, "section_type", "namelist", FIRST = .TRUE. ) - CALL iotk_write_begin( iunpun, "IONS", attr ) - CALL iotk_write_end( iunpun, "IONS" ) - - CALL iotk_write_attr( attr, "section_type", "namelist", FIRST = .TRUE. ) - CALL iotk_write_begin( iunpun, "CELL", attr ) - CALL iotk_write_end( iunpun, "CELL" ) - - CALL iotk_write_attr( attr, "section_type", "card", FIRST = .TRUE. ) - CALL iotk_write_begin( iunpun, "ATOMIC_SPECIES", attr ) - CALL iotk_write_end( iunpun, "ATOMIC_SPECIES" ) - - CALL iotk_write_attr( attr, "section_type", "card", FIRST = .TRUE. ) - CALL iotk_write_begin( iunpun, "ATOMIC_POSITIONS", attr ) - CALL iotk_write_end( iunpun, "ATOMIC_POSITIONS" ) - - CALL iotk_write_attr( attr, "section_type", "card", FIRST = .TRUE. ) - CALL iotk_write_begin( iunpun, "K_POINTS", attr ) - CALL iotk_write_end( iunpun, "K_POINTS" ) - - CALL iotk_write_end( iunpun, "schema" ) - - END IF - - IF ( ionode ) CALL iotk_close_write( iunpun ) - - RETURN - END SUBROUTINE - - - SUBROUTINE dump_keyword_str( kname, defval, usage, descr, allowed ) - USE io_files, ONLY : iunpun - CHARACTER(LEN=*) :: kname - CHARACTER(LEN=*) :: defval - CHARACTER(LEN=*) :: usage - CHARACTER(LEN=*) :: descr - CHARACTER(LEN=*), OPTIONAL :: allowed(:) - CALL iotk_write_attr( attr, "required", "no", FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "repeat", "no") - CALL iotk_write_begin( iunpun, "KEYWORD", ATTR = attr ) - CALL iotk_write_attr( attr, "type", "default", FIRST = .TRUE. ) - CALL iotk_write_dat( iunpun, "NAME", kname, ATTR = attr ) - CALL iotk_write_attr( attr, "kind", "STRING", FIRST = .TRUE. ) ! type - CALL iotk_write_begin( iunpun, "DATA_TYPE", ATTR = attr ) - CALL iotk_write_dat( iunpun, "N_VAR", 1 ) - CALL iotk_write_end( iunpun, "DATA_TYPE" ) - IF( usage == "namelist" ) THEN - CALL iotk_write_dat( iunpun, "USAGE", kname//" = value" ) - ELSE - CALL iotk_write_dat( iunpun, "USAGE", usage ) - END IF - IF( PRESENT( allowed ) ) THEN - CALL iotk_write_dat( iunpun, "ALLOWED_VALUES", allowed ) - END IF - CALL iotk_write_dat( iunpun, "DESCRIPTION", descr ) - CALL iotk_write_dat( iunpun, "DEFAULT_VALUE", defval ) - CALL iotk_write_end( iunpun, "KEYWORD" ) - RETURN - END SUBROUTINE - - SUBROUTINE dump_keyword_i( kname, defval, usage, descr, min_value, max_value ) - USE io_files, ONLY : iunpun - CHARACTER(LEN=*) :: kname - INTEGER :: defval ! type - CHARACTER(LEN=*) :: usage - CHARACTER(LEN=*) :: descr - INTEGER, OPTIONAL :: min_value ! type - INTEGER, OPTIONAL :: max_value ! type - CALL iotk_write_attr( attr, "required", "no", FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "repeat", "no") - CALL iotk_write_begin( iunpun, "KEYWORD", ATTR = attr ) - CALL iotk_write_attr( attr, "type", "default", FIRST = .TRUE. ) - CALL iotk_write_dat( iunpun, "NAME", kname, ATTR = attr ) - CALL iotk_write_attr( attr, "kind", "INTEGER", FIRST = .TRUE. ) ! type - CALL iotk_write_begin( iunpun, "DATA_TYPE", ATTR = attr ) - CALL iotk_write_dat( iunpun, "N_VAR", 1 ) - CALL iotk_write_end( iunpun, "DATA_TYPE" ) - IF( usage == "namelist" ) THEN - CALL iotk_write_dat( iunpun, "USAGE", kname//" = value" ) - ELSE - CALL iotk_write_dat( iunpun, "USAGE", usage ) - END IF - IF( PRESENT( min_value ) ) THEN - CALL iotk_write_dat( iunpun, "MIN_VALUE", min_value ) - END IF - IF( PRESENT( max_value ) ) THEN - CALL iotk_write_dat( iunpun, "MAX_VALUE", max_value ) - END IF - CALL iotk_write_dat( iunpun, "DESCRIPTION", descr ) - CALL iotk_write_dat( iunpun, "DEFAULT_VALUE", defval ) - CALL iotk_write_end( iunpun, "KEYWORD" ) - RETURN - END SUBROUTINE - - -END MODULE diff --git a/quantum_espresso/kcp/Modules/xml_io_base.f90 b/quantum_espresso/kcp/Modules/xml_io_base.f90 deleted file mode 100644 index f48bb70a3..000000000 --- a/quantum_espresso/kcp/Modules/xml_io_base.f90 +++ /dev/null @@ -1,2456 +0,0 @@ -! -! Copyright (C) 2005-2008 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -MODULE xml_io_base - !---------------------------------------------------------------------------- - ! - ! ... this module contains some common subroutines used to read and write - ! ... in XML format the data produced by Quantum-ESPRESSO package - ! - ! ... written by Carlo Sbraccia (2005) - ! ... modified by Andrea Ferretti (2006-08) - ! - USE iotk_module - ! - USE kinds, ONLY : DP - USE io_files, ONLY : tmp_dir, prefix, iunpun, xmlpun, & - current_fmt_version => qexml_version - USE io_global, ONLY : ionode, ionode_id, stdout - USE mp, ONLY : mp_bcast - USE parser, ONLY : version_compare - ! - IMPLICIT NONE - PRIVATE - ! - CHARACTER(5), PARAMETER :: fmt_name = "QEXML" - CHARACTER(5), PARAMETER :: fmt_version = "1.4.0" - ! - LOGICAL, PARAMETER :: rho_binary = .TRUE. - ! - LOGICAL, PARAMETER :: pot_binary = .TRUE. - ! - CHARACTER(iotk_attlenx) :: attr - ! - ! - PUBLIC :: fmt_name, fmt_version - PUBLIC :: current_fmt_version - ! - PUBLIC :: rho_binary - PUBLIC :: pot_binary - ! - PUBLIC :: attr - ! - PUBLIC :: create_directory, kpoint_dir, wfc_filename, copy_file, & - restart_dir, check_restartfile, check_file_exst, & - pp_check_file, save_history, save_print_counter, & - read_print_counter, set_kpoints_vars, & - write_header, write_control, write_control_ph, & - write_status_ph, write_q, & - write_cell, write_ions, write_symmetry, write_planewaves, & - write_efield, write_spin, write_magnetization, write_xc, & - write_occ, write_bz, & - write_phonon, write_rho_xml, write_wfc, write_wfc_cmplx, write_eig, & - read_wfc, read_rho_xml, write_pot_xml, read_pot_xml - ! - INTERFACE write_wfc - module procedure write_wfc_real, write_wfc_cmplx - END INTERFACE - - INTERFACE write_planewaves - module procedure write_planewaves_real, write_planewaves_cmplx - END INTERFACE - ! - CONTAINS - ! - !------------------------------------------------------------------------ - SUBROUTINE create_directory( dirname ) - !------------------------------------------------------------------------ - ! - USE wrappers, ONLY : f_mkdir - USE mp, ONLY : mp_barrier - USE mp_global, ONLY : me_image, intra_image_comm - ! - CHARACTER(LEN=*), INTENT(IN) :: dirname - ! - INTEGER :: ierr - - CHARACTER(LEN=6), EXTERNAL :: int_to_char - ! - IF ( ionode ) ierr = f_mkdir( TRIM( dirname ) ) - ! - CALL mp_bcast ( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'create_directory', & - 'unable to create directory ' // TRIM( dirname ), ierr ) - ! - ! ... syncronize all jobs (not sure it is really useful) - ! - CALL mp_barrier( intra_image_comm ) - ! - ! ... check whether the scratch directory is writable - ! - IF ( ionode ) THEN - ! - OPEN( UNIT = 4, FILE = TRIM( dirname ) // '/test' // & - TRIM( int_to_char( me_image ) ), IOSTAT = ierr ) - CLOSE( UNIT = 4, STATUS = 'DELETE' ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'create_directory:', & - TRIM( dirname ) // ' non existent or non writable', ierr ) - ! - RETURN - ! - END SUBROUTINE create_directory - ! - !------------------------------------------------------------------------ - FUNCTION kpoint_dir( basedir, ik ) - !------------------------------------------------------------------------ - ! - CHARACTER(LEN=256) :: kpoint_dir - CHARACTER(LEN=*), INTENT(IN) :: basedir - INTEGER, INTENT(IN) :: ik - ! - CHARACTER(LEN=256) :: kdirname - CHARACTER(LEN=5) :: kindex - CHARACTER(LEN=6) :: kindex1 - ! - IF (ik<99999) THEN - WRITE( kindex, FMT = '( I5.5 )' ) ik - kdirname = TRIM( basedir ) // '/K' // kindex - ELSEIF (ik<999999) THEN - WRITE( kindex1, FMT = '( I6.6 )' ) ik - kdirname = TRIM( basedir ) // '/K' // kindex1 - ELSE - call errore('kpoint_dir','ik too large, increase format',1) - ENDIF - ! - kpoint_dir = TRIM( kdirname ) - ! - RETURN - ! - END FUNCTION kpoint_dir - ! - !------------------------------------------------------------------------ - FUNCTION wfc_filename( basedir, name, ik, ipol, tag, extension, dir ) - !------------------------------------------------------------------------ - ! - CHARACTER(LEN=256) :: wfc_filename - CHARACTER(LEN=*), INTENT(IN) :: basedir - CHARACTER(LEN=*), INTENT(IN) :: name - INTEGER, INTENT(IN) :: ik - INTEGER, OPTIONAL, INTENT(IN) :: ipol - CHARACTER(*), OPTIONAL, INTENT(IN) :: tag - CHARACTER(*), OPTIONAL, INTENT(IN) :: extension - LOGICAL, OPTIONAL, INTENT(IN) :: dir - ! - CHARACTER(LEN=256) :: filename, tag_, ext_ - LOGICAL :: dir_true - ! - ! - filename = '' - tag_ = '' - ext_ = '.dat' - dir_true = .true. - ! - IF ( PRESENT( tag ) ) tag_ = '_'//TRIM(tag) - IF ( PRESENT( extension ) ) ext_ = '.'//TRIM(extension) - ! - IF ( PRESENT( ipol ) ) THEN - ! - WRITE( filename, FMT = '( I1 )' ) ipol - ! - END IF - IF ( PRESENT( dir )) dir_true=dir - ! - IF (dir_true) THEN - filename = TRIM( kpoint_dir( basedir, ik ) ) // '/' // & - & TRIM( name ) // TRIM( filename ) // TRIM( tag_ ) // TRIM( ext_) - ELSE - filename = TRIM( kpoint_dir( basedir, ik ) ) // '_' // & - & TRIM( name ) // TRIM( filename ) // TRIM( tag_ ) // TRIM( ext_) - ENDIF - ! - wfc_filename = TRIM( filename ) - ! - RETURN - ! - END FUNCTION - ! - !------------------------------------------------------------------------ - SUBROUTINE copy_file( file_in, file_out ) - !------------------------------------------------------------------------ - ! - CHARACTER(LEN=*), INTENT(IN) :: file_in, file_out - ! - CHARACTER(LEN=256) :: string - INTEGER :: iun_in, iun_out, ierr - ! - ! - IF ( .NOT. ionode ) RETURN - ! - CALL iotk_free_unit( iun_in, ierr ) - CALL iotk_free_unit( iun_out, ierr ) - ! - CALL errore( 'copy_file', 'no free units available', ierr ) - ! - OPEN( UNIT = iun_in, FILE = file_in, STATUS = "OLD" ) - OPEN( UNIT = iun_out, FILE = file_out, STATUS = "UNKNOWN" ) - ! - copy_loop: DO - ! - READ( UNIT = iun_in, FMT = '(A256)', IOSTAT = ierr ) string - ! - IF ( ierr < 0 ) EXIT copy_loop - ! - WRITE( UNIT = iun_out, FMT = '(A)' ) TRIM( string ) - ! - END DO copy_loop - ! - CLOSE( UNIT = iun_in ) - CLOSE( UNIT = iun_out ) - ! - RETURN - ! - END SUBROUTINE - ! - !------------------------------------------------------------------------ - FUNCTION restart_dir( outdir, runit ) - !------------------------------------------------------------------------ - ! - ! KNK_nimage - ! USE mp_global, ONLY: my_image_id - CHARACTER(LEN=256) :: restart_dir - CHARACTER(LEN=*), INTENT(IN) :: outdir - INTEGER, INTENT(IN) :: runit - ! - CHARACTER(LEN=256) :: dirname - INTEGER :: strlen - CHARACTER(LEN=6), EXTERNAL :: int_to_char - ! - ! ... main restart directory - ! - ! ... keep the line below ( this is the old style RESTARTXX ) !!! - ! - ! dirname = 'RESTART' // int_to_char( runit ) - ! the next line is to have seperate RESTART for each image - ! KNK_nimage - ! if (my_image_id > 0) dirname = trim(dirname) // '_' // trim(int_to_char( my_image_id )) - ! - dirname = TRIM( prefix ) // '_' // TRIM( int_to_char( runit ) )// '.save' - ! - IF ( LEN( outdir ) > 1 ) THEN - ! - strlen = INDEX( outdir, ' ' ) - 1 - ! - dirname = outdir(1:strlen) // '/' // dirname - ! - END IF - ! - restart_dir = TRIM( dirname ) - ! - RETURN - ! - END FUNCTION restart_dir - ! - !------------------------------------------------------------------------ - FUNCTION check_restartfile( outdir, ndr ) - !------------------------------------------------------------------------ - ! - USE io_global, ONLY : ionode, ionode_id - USE mp_global, ONLY : intra_image_comm - ! - IMPLICIT NONE - ! - LOGICAL :: check_restartfile - INTEGER, INTENT(IN) :: ndr - CHARACTER(LEN=*), INTENT(IN) :: outdir - CHARACTER(LEN=256) :: filename - LOGICAL :: lval - ! - ! - filename = restart_dir( outdir, ndr ) - ! - IF ( ionode ) THEN - ! - filename = TRIM( filename ) // '/' // TRIM( xmlpun ) - ! - INQUIRE( FILE = TRIM( filename ), EXIST = lval ) - ! - END IF - ! - CALL mp_bcast( lval, ionode_id, intra_image_comm ) - ! - check_restartfile = lval - ! - RETURN - ! - END FUNCTION check_restartfile - ! - !------------------------------------------------------------------------ - FUNCTION check_file_exst( filename ) - !------------------------------------------------------------------------ - ! - USE io_global, ONLY : ionode, ionode_id - USE mp_global, ONLY : intra_image_comm - ! - IMPLICIT NONE - ! - LOGICAL :: check_file_exst - CHARACTER(LEN=*) :: filename - ! - LOGICAL :: lexists - ! - IF ( ionode ) THEN - ! - INQUIRE( FILE = TRIM( filename ), EXIST = lexists ) - ! - ENDIF - ! - CALL mp_bcast ( lexists, ionode_id, intra_image_comm ) - ! - check_file_exst = lexists - RETURN - ! - END FUNCTION check_file_exst - ! - !------------------------------------------------------------------------ - FUNCTION pp_check_file() - !------------------------------------------------------------------------ - ! - USE io_global, ONLY : ionode, ionode_id - USE mp_global, ONLY : intra_image_comm - USE control_flags, ONLY : lkpoint_dir, tqr - ! - IMPLICIT NONE - ! - LOGICAL :: pp_check_file - CHARACTER(LEN=256) :: dirname, filename - INTEGER :: ierr - LOGICAL :: lval, found, back_compat - ! - ! - dirname = TRIM( tmp_dir ) // TRIM( prefix ) // '.save' - filename = TRIM( dirname ) // '/' // TRIM( xmlpun ) - ! - IF ( ionode ) & - CALL iotk_open_read( iunpun, FILE = filename, IERR = ierr ) - ! - CALL mp_bcast ( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'pp_check_file', 'file ' // & - & TRIM( dirname ) // ' not found', ierr ) - - ! - ! set a flag for back compatibility (before fmt v1.4.0) - ! - back_compat = .FALSE. - ! - IF ( TRIM( version_compare( current_fmt_version, "1.4.0" )) == "older") & - back_compat = .TRUE. - ! - IF ( ionode ) THEN - ! - IF ( .NOT. back_compat ) THEN - ! - CALL iotk_scan_begin( iunpun, "CONTROL" ) - ! - ENDIF - ! - CALL iotk_scan_dat( iunpun, "PP_CHECK_FLAG", lval, FOUND = found) - ! - IF ( .NOT. found ) lval = .FALSE. - ! - CALL iotk_scan_dat( iunpun, "LKPOINT_DIR", lkpoint_dir, FOUND = found) - ! - IF ( .NOT. found ) lkpoint_dir = .TRUE. - ! - CALL iotk_scan_dat( iunpun, "Q_REAL_SPACE", tqr, FOUND = found) - ! - IF ( .NOT. found ) tqr = .FALSE. - ! - ! - IF ( .NOT. back_compat ) THEN - ! - CALL iotk_scan_end( iunpun, "CONTROL" ) - ! - ENDIF - ! - CALL iotk_close_read( iunpun ) - ! - END IF - ! - CALL mp_bcast( lval, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( lkpoint_dir, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( tqr, ionode_id, intra_image_comm ) - ! - pp_check_file = lval - ! - RETURN - ! - END FUNCTION pp_check_file - ! - !------------------------------------------------------------------------ - SUBROUTINE save_history( dirname, iter ) - !------------------------------------------------------------------------ - ! - ! ... a copy of the xml descriptor (data-file.xml) is saved in the - ! ... history subdir - ! - USE io_files, ONLY : xmlpun_base - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(IN) :: dirname - INTEGER, INTENT(IN) :: iter - ! -#if defined (__VERBOSE_SAVE) - ! - CHARACTER(LEN=256) :: filename - CHARACTER(LEN=6) :: hindex - ! - CALL create_directory( TRIM( dirname ) // '/history' ) - ! - WRITE( hindex, FMT = '(I6.6)' ) iter - ! - IF ( ionode ) THEN - ! - filename = TRIM( dirname ) // '/history/' // & - & TRIM( xmlpun_base ) // hindex // '.xml' - ! - CALL copy_file( TRIM( dirname ) // "/" // TRIM( xmlpun ), & - TRIM( filename ) ) - ! - END IF - ! -#endif - ! - RETURN - ! - END SUBROUTINE save_history - ! - !------------------------------------------------------------------------ - SUBROUTINE save_print_counter( iter, outdir, wunit ) - !------------------------------------------------------------------------ - ! - ! ... a counter indicating the last successful printout iteration is saved - ! - USE io_global, ONLY : ionode, ionode_id - USE mp_global, ONLY : intra_image_comm - USE mp, ONLY : mp_bcast - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: iter - CHARACTER(LEN=*), INTENT(IN) :: outdir - INTEGER, INTENT(IN) :: wunit - ! - INTEGER :: ierr - CHARACTER(LEN=256) :: filename, dirname - ! - ! - dirname = restart_dir( outdir, wunit ) - ! - CALL create_directory( TRIM( dirname ) ) - ! - IF ( ionode ) THEN - ! - filename = TRIM( dirname ) // '/print_counter.xml' - ! - CALL iotk_open_write( iunpun, FILE = filename, & - & ROOT = "PRINT_COUNTER", IERR = ierr ) - ! - END IF - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'save_print_counter', & - 'cannot open restart file for writing', ierr ) - ! - IF ( ionode ) THEN - ! - CALL iotk_write_begin( iunpun, "LAST_SUCCESSFUL_PRINTOUT" ) - CALL iotk_write_dat( iunpun, "STEP", iter ) - CALL iotk_write_end( iunpun, "LAST_SUCCESSFUL_PRINTOUT" ) - ! - CALL iotk_close_write( iunpun ) - ! - END IF - ! - RETURN - ! - END SUBROUTINE save_print_counter - ! - !------------------------------------------------------------------------ - SUBROUTINE read_print_counter( nprint_nfi, outdir, runit ) - !------------------------------------------------------------------------ - ! - ! ... the counter indicating the last successful printout iteration - ! ... is read here - ! - USE io_global, ONLY : ionode, ionode_id - USE mp_global, ONLY : intra_image_comm - USE mp, ONLY : mp_bcast - ! - IMPLICIT NONE - ! - INTEGER, INTENT(OUT) :: nprint_nfi - CHARACTER(LEN=*), INTENT(IN) :: outdir - INTEGER, INTENT(IN) :: runit - ! - INTEGER :: ierr - CHARACTER(LEN=256) :: filename, dirname - ! - ! - dirname = restart_dir( outdir, runit ) - ! - IF ( ionode ) THEN - ! - filename = TRIM( dirname ) // '/print_counter.xml' - ! - CALL iotk_open_read( iunpun, FILE = filename, IERR = ierr ) - ! - IF ( ierr > 0 ) THEN - ! - nprint_nfi = -1 - ! - ELSE - ! - CALL iotk_scan_begin( iunpun, "LAST_SUCCESSFUL_PRINTOUT" ) - CALL iotk_scan_dat( iunpun, "STEP", nprint_nfi ) - CALL iotk_scan_end( iunpun, "LAST_SUCCESSFUL_PRINTOUT" ) - ! - CALL iotk_close_read( iunpun ) - ! - END IF - ! - END IF - ! - CALL mp_bcast( nprint_nfi, ionode_id, intra_image_comm ) - ! - RETURN - ! - END SUBROUTINE read_print_counter - ! - !------------------------------------------------------------------------ - SUBROUTINE set_kpoints_vars( ik, nk, kunit, ngwl, igl, & - npool, ikt, iks, ike, igwx, ipmask, ipsour ) - !------------------------------------------------------------------------ - ! - ! ... set working variables for k-point index (ikt) and - ! ... k-points number (nkt) - ! - USE mp, ONLY : mp_sum, mp_get, mp_max - USE mp_global, ONLY : me_image, nproc_image, me_pool, my_pool_id, & - nproc_pool, intra_pool_comm, root_pool, & - intra_image_comm - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ik, nk, kunit - INTEGER, INTENT(IN) :: ngwl, igl(:) - INTEGER, INTENT(OUT) :: npool - INTEGER, INTENT(OUT) :: ikt, iks, ike, igwx - INTEGER, INTENT(OUT) :: ipmask(:), ipsour - ! - INTEGER :: ierr, i - INTEGER :: nkl, nkr, nkbl, nkt - ! - ! - ikt = ik - nkt = nk - ! - ! ... find out the number of pools - ! - npool = nproc_image / nproc_pool - ! - ! ... find out number of k points blocks - ! - nkbl = nkt / kunit - ! - ! ... k points per pool - ! - nkl = kunit * ( nkbl / npool ) - ! - ! ... find out the reminder - ! - nkr = ( nkt - nkl * npool ) / kunit - ! - ! ... Assign the reminder to the first nkr pools - ! - IF ( my_pool_id < nkr ) nkl = nkl + kunit - ! - ! ... find out the index of the first k point in this pool - ! - iks = nkl * my_pool_id + 1 - ! - IF ( my_pool_id >= nkr ) iks = iks + nkr * kunit - ! - ! ... find out the index of the last k point in this pool - ! - ike = iks + nkl - 1 - ! - ipmask = 0 - ipsour = ionode_id - ! - ! ... find out the index of the processor which collect the data - ! ... in the pool of ik - ! - IF ( npool > 1 ) THEN - ! - IF ( ( ikt >= iks ) .AND. ( ikt <= ike ) ) THEN - ! - IF ( me_pool == root_pool ) ipmask( me_image + 1 ) = 1 - ! - END IF - ! - ! ... Collect the mask for all proc in the image - ! - CALL mp_sum( ipmask, intra_image_comm ) - ! - DO i = 1, nproc_image - ! - IF( ipmask(i) == 1 ) ipsour = ( i - 1 ) - ! - END DO - ! - END IF - ! - igwx = 0 - ierr = 0 - ! - IF ( ( ikt >= iks ) .AND. ( ikt <= ike ) ) THEN - ! - IF ( ngwl > SIZE( igl ) ) THEN - ! - ierr = 1 - ! - ELSE - ! - igwx = MAXVAL( igl(1:ngwl) ) - ! - END IF - ! - END IF - ! - ! ... get the maximum index within the pool - ! - CALL mp_max( igwx, intra_pool_comm ) - ! - ! ... now notify all procs if an error has been found - ! - CALL mp_max( ierr, intra_image_comm ) - ! - CALL errore( 'set_kpoint_vars ', 'wrong size ngl', ierr ) - ! - IF ( ipsour /= ionode_id ) & - CALL mp_get( igwx, igwx, me_image, ionode_id, ipsour, 1, intra_image_comm ) - ! - RETURN - ! - END SUBROUTINE set_kpoints_vars - ! - ! - ! ... writing subroutines - ! - ! - !------------------------------------------------------------------------ - SUBROUTINE write_header( creator_name, creator_version ) - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: creator_name, creator_version - - - CALL iotk_write_begin( iunpun, "HEADER" ) - ! - CALL iotk_write_attr(attr, "NAME",TRIM(fmt_name), FIRST=.TRUE.) - CALL iotk_write_attr(attr, "VERSION",TRIM(fmt_version) ) - CALL iotk_write_empty( iunpun, "FORMAT", ATTR=attr ) - ! - CALL iotk_write_attr(attr, "NAME",TRIM(creator_name), FIRST=.TRUE.) - CALL iotk_write_attr(attr, "VERSION",TRIM(creator_version) ) - CALL iotk_write_empty( iunpun, "CREATOR", ATTR=attr ) - ! - CALL iotk_write_end( iunpun, "HEADER" ) - ! - END SUBROUTINE write_header - ! - ! - !------------------------------------------------------------------------ - SUBROUTINE write_control( pp_check_flag, lkpoint_dir, q_real_space, beta_real_space) - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - LOGICAL, OPTIONAL, INTENT(IN) :: pp_check_flag, lkpoint_dir, q_real_space, beta_real_space - - - CALL iotk_write_begin( iunpun, "CONTROL" ) - ! - ! This flag is used to check if the file can be used for post-processing - IF ( PRESENT( pp_check_flag ) ) & - CALL iotk_write_dat( iunpun, "PP_CHECK_FLAG", pp_check_flag ) - ! - ! This flag says how eigenvalues are saved - IF ( PRESENT( lkpoint_dir ) ) & - CALL iotk_write_dat( iunpun, "LKPOINT_DIR", lkpoint_dir ) - ! - ! This flag says if Q in real space has to be used - IF ( PRESENT( q_real_space ) ) & - CALL iotk_write_dat( iunpun, "Q_REAL_SPACE", q_real_space ) - ! This flag says if Beta functions were treated in real space - IF ( PRESENT( beta_real_space ) ) & - CALL iotk_write_dat( iunpun, "BETA_REAL_SPACE", beta_real_space ) - ! - CALL iotk_write_end( iunpun, "CONTROL" ) - ! - END SUBROUTINE write_control - ! - - SUBROUTINE write_control_ph( ldisp, epsil, trans, elph, zue, & - lraman, elop ) - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - LOGICAL, INTENT(IN) :: ldisp, epsil, trans, elph, zue, & - lraman, elop - - - CALL iotk_write_begin( iunpun, "CONTROL" ) - ! - CALL iotk_write_dat( iunpun, "DISPERSION_RUN", ldisp ) - CALL iotk_write_dat( iunpun, "ELECTRIC_FIELD", epsil ) - CALL iotk_write_dat( iunpun, "PHONON_RUN", trans ) - CALL iotk_write_dat( iunpun, "ELECTRON_PHONON", elph ) - CALL iotk_write_dat( iunpun, "EFFECTIVE_CHARGE_PH", zue ) - CALL iotk_write_dat( iunpun, "RAMAN_TENSOR", lraman ) - CALL iotk_write_dat( iunpun, "ELECTRO_OPTIC", elop ) - ! - CALL iotk_write_end( iunpun, "CONTROL" ) - ! - RETURN - END SUBROUTINE write_control_ph - - SUBROUTINE write_status_ph(current_iq, done_bands) - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - INTEGER, INTENT(IN) :: current_iq - LOGICAL, INTENT(IN) :: done_bands - - CALL iotk_write_begin( iunpun, "STATUS_PH" ) - ! - CALL iotk_write_dat( iunpun, "DONE_BANDS", done_bands ) - CALL iotk_write_dat( iunpun, "CURRENT_Q", current_iq ) - ! - CALL iotk_write_end( iunpun, "STATUS_PH" ) - ! - RETURN - END SUBROUTINE write_status_ph - ! - !------------------------------------------------------------------------ - SUBROUTINE write_cell( ibrav, symm_type, & - celldm, alat, a1, a2, a3, b1, b2, b3 ) - !------------------------------------------------------------------------ - ! - INTEGER, INTENT(IN) :: ibrav - CHARACTER(LEN=*), INTENT(IN) :: symm_type - REAL(DP), INTENT(IN) :: celldm(6), alat - REAL(DP), INTENT(IN) :: a1(3), a2(3), a3(3) - REAL(DP), INTENT(IN) :: b1(3), b2(3), b3(3) - ! - CHARACTER(LEN=256) :: bravais_lattice - ! - CALL iotk_write_begin( iunpun, "CELL" ) - ! - SELECT CASE ( ibrav ) - CASE( 0 ) - bravais_lattice = "free" - CASE( 1 ) - bravais_lattice = "cubic P (sc)" - CASE( 2 ) - bravais_lattice = "cubic F (fcc)" - CASE( 3 ) - bravais_lattice = "cubic I (bcc)" - CASE( 4 ) - bravais_lattice = "Hexagonal and Trigonal P" - CASE( 5 ) - bravais_lattice = "Trigonal R" - CASE( 6 ) - bravais_lattice = "Tetragonal P (st)" - CASE( 7 ) - bravais_lattice = "Tetragonal I (bct)" - CASE( 8 ) - bravais_lattice = "Orthorhombic P" - CASE( 9 ) - bravais_lattice = "Orthorhombic base-centered(bco)" - CASE( 10 ) - bravais_lattice = "Orthorhombic face-centered" - CASE( 11 ) - bravais_lattice = "Orthorhombic body-centered" - CASE( 12 ) - bravais_lattice = "Monoclinic P" - CASE( 13 ) - bravais_lattice = "Monoclinic base-centered" - CASE( 14 ) - bravais_lattice = "Triclinic P" - END SELECT - ! - CALL iotk_write_dat( iunpun, & - "BRAVAIS_LATTICE", TRIM( bravais_lattice ) ) - ! - CALL iotk_write_dat( iunpun, "CELL_SYMMETRY", symm_type ) - ! - CALL iotk_write_attr( attr, "UNITS", "Bohr", FIRST = .TRUE. ) - CALL iotk_write_dat( iunpun, "LATTICE_PARAMETER", alat, ATTR = attr ) - ! - CALL iotk_write_dat( iunpun, "CELL_DIMENSIONS", celldm(1:6) ) - ! - CALL iotk_write_begin( iunpun, "DIRECT_LATTICE_VECTORS" ) - CALL iotk_write_empty( iunpun, "UNITS_FOR_DIRECT_LATTICE_VECTORS", ATTR=attr ) - CALL iotk_write_dat( iunpun, "a1", a1(:) * alat, COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "a2", a2(:) * alat, COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "a3", a3(:) * alat, COLUMNS=3 ) - CALL iotk_write_end( iunpun, "DIRECT_LATTICE_VECTORS" ) - ! - CALL iotk_write_attr( attr, "UNITS", "2 pi / a", FIRST = .TRUE. ) - CALL iotk_write_begin( iunpun, "RECIPROCAL_LATTICE_VECTORS" ) - CALL iotk_write_empty( iunpun, "UNITS_FOR_RECIPROCAL_LATTICE_VECTORS", ATTR=attr ) - CALL iotk_write_dat( iunpun, "b1", b1(:), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "b2", b2(:), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "b3", b3(:), COLUMNS=3 ) - CALL iotk_write_end( iunpun, "RECIPROCAL_LATTICE_VECTORS" ) - ! - CALL iotk_write_end( iunpun, "CELL" ) - ! - END SUBROUTINE write_cell - ! - !------------------------------------------------------------------------ - SUBROUTINE write_ions( nsp, nat, atm, ityp, psfile, & - pseudo_dir, amass, tau, if_pos, dirname, pos_unit ) - !------------------------------------------------------------------------ - ! - INTEGER, INTENT(IN) :: nsp, nat - INTEGER, INTENT(IN) :: ityp(:) - CHARACTER(LEN=*), INTENT(IN) :: atm(:) - CHARACTER(LEN=*), INTENT(IN) :: psfile(:) - CHARACTER(LEN=*), INTENT(IN) :: pseudo_dir - CHARACTER(LEN=*), INTENT(IN) :: dirname - REAL(DP), INTENT(IN) :: amass(:) - REAL(DP), INTENT(IN) :: tau(:,:) - INTEGER, INTENT(IN) :: if_pos(:,:) - REAL(DP), INTENT(IN) :: pos_unit - ! - INTEGER :: i, flen - CHARACTER(LEN=256) :: file_pseudo - ! - ! - CALL iotk_write_begin( iunpun, "IONS" ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_ATOMS", nat ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_SPECIES", nsp ) - ! - flen = LEN_TRIM( pseudo_dir ) - ! - CALL iotk_write_attr ( attr, "UNITS", "a.m.u.", FIRST = .TRUE. ) - CALL iotk_write_empty( iunpun, "UNITS_FOR_ATOMIC_MASSES", ATTR = attr ) - ! - DO i = 1, nsp - ! - CALL iotk_write_begin( iunpun, "SPECIE"//TRIM(iotk_index(i)) ) - ! - CALL iotk_write_dat( iunpun, "ATOM_TYPE", atm(i) ) - ! - IF ( pseudo_dir(flen:flen) /= '/' ) THEN - ! - file_pseudo = pseudo_dir(1:flen) // '/' // psfile(i) - ! - ELSE - ! - file_pseudo = pseudo_dir(1:flen) // psfile(i) - ! - END IF - ! - IF (TRIM( file_pseudo ).ne. TRIM( dirname ) // "/" // & - TRIM(psfile(i))) & - CALL copy_file( TRIM( file_pseudo ), & - TRIM( dirname ) // "/" // TRIM( psfile(i) ) ) - ! - CALL iotk_write_dat( iunpun, "MASS", amass(i) ) - ! - CALL iotk_write_dat( iunpun, "PSEUDO", TRIM( psfile(i) ) ) - ! - CALL iotk_write_end( iunpun, "SPECIE"//TRIM(iotk_index(i)) ) - ! - ENDDO - ! - ! BEWARE: the following instruction is part of a ugly hack to allow - ! restarting in parallel execution in machines without a - ! parallel file system - See read_ions in pw_restart.f90 - ! - CALL iotk_write_dat( iunpun, "PSEUDO_DIR", TRIM( pseudo_dir) ) - ! - CALL iotk_write_attr( attr, "UNITS", "Bohr", FIRST = .TRUE. ) - CALL iotk_write_empty( iunpun, "UNITS_FOR_ATOMIC_POSITIONS", ATTR = attr ) - ! - DO i = 1, nat - ! - CALL iotk_write_attr( attr, "SPECIES", & - & atm( ityp(i) ), FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "INDEX", ityp(i) ) - CALL iotk_write_attr( attr, "tau", tau(:,i)*pos_unit ) - CALL iotk_write_attr( attr, "if_pos", if_pos(:,i) ) - CALL iotk_write_empty( iunpun, & - & "ATOM" // TRIM( iotk_index( i ) ), attr ) - ! - END DO - ! - CALL iotk_write_end( iunpun, "IONS" ) - ! - END SUBROUTINE write_ions - ! - !------------------------------------------------------------------------ - SUBROUTINE write_symmetry( ibrav, symm_type, nrot, nsym, invsym, noinv, & - nr1, nr2, nr3, ftau, s, sname, irt, nat, t_rev ) - !------------------------------------------------------------------------ - ! - INTEGER, INTENT(IN) :: ibrav, nrot, nsym, nr1, nr2, nr3 - CHARACTER(LEN=*), INTENT(IN) :: symm_type - LOGICAL, INTENT(IN) :: invsym, noinv - INTEGER, INTENT(IN) :: s(:,:,:), ftau(:,:) - CHARACTER(LEN=*), INTENT(IN) :: sname(:) - INTEGER, INTENT(IN) :: irt(:,:), nat, t_rev(:) - ! - INTEGER :: i - REAL(DP) :: tmp(3) - ! - ! - CALL iotk_write_begin( iunpun, "SYMMETRIES" ) - ! - IF ( ibrav == 0 ) & - CALL iotk_write_dat( iunpun, "CELL_SYMMETRY", symm_type ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_SYMMETRIES", nsym ) - CALL iotk_write_dat( iunpun, "NUMBER_OF_BRAVAIS_SYMMETRIES", nrot ) - ! - CALL iotk_write_dat( iunpun, "INVERSION_SYMMETRY", invsym ) - ! - CALL iotk_write_dat( iunpun, "DO_NOT_USE_TIME_REVERSAL", noinv ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_ATOMS", nat ) - ! - CALL iotk_write_attr( attr, "UNITS", "Crystal", FIRST = .TRUE. ) - CALL iotk_write_empty( iunpun, "UNITS_FOR_SYMMETRIES", ATTR = attr ) - ! - DO i = 1, nsym - ! - CALL iotk_write_begin( iunpun, "SYMM" // TRIM( iotk_index( i ) ) ) - ! - CALL iotk_write_attr ( attr, "NAME", TRIM( sname(i) ), FIRST=.TRUE. ) - CALL iotk_write_attr ( attr, "T_REV", t_rev(i) ) - CALL iotk_write_empty( iunpun, "INFO", ATTR = attr ) - ! - tmp(1) = ftau(1,i) / DBLE( nr1 ) - tmp(2) = ftau(2,i) / DBLE( nr2 ) - tmp(3) = ftau(3,i) / DBLE( nr3 ) - ! - CALL iotk_write_dat( iunpun, "ROTATION", s(:,:,i), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "FRACTIONAL_TRANSLATION", tmp(1:3), COLUMNS=3 ) - CALL iotk_write_dat( iunpun, "EQUIVALENT_IONS", irt(i,1:nat), COLUMNS=8 ) - ! - CALL iotk_write_end( iunpun, "SYMM" // TRIM( iotk_index( i ) ) ) - ! - ENDDO - ! - ! ... the following are the symmetries of the Bravais lattice alone - ! ... (they may be more than crystal, i.e. basis+lattice, symmetries) - ! - DO i = nsym+1, nrot - ! - CALL iotk_write_begin( iunpun, "SYMM" // TRIM( iotk_index( i ) ) ) - ! - CALL iotk_write_attr ( attr, "NAME", TRIM( sname(i) ), FIRST=.TRUE. ) - CALL iotk_write_empty( iunpun, "INFO", ATTR = attr ) - CALL iotk_write_dat( iunpun, "ROTATION", s(:,:,i), COLUMNS=3 ) - ! - CALL iotk_write_end( iunpun, "SYMM" // TRIM( iotk_index( i ) ) ) - ! - ENDDO - ! - CALL iotk_write_end( iunpun, "SYMMETRIES" ) - ! - END SUBROUTINE write_symmetry - ! - !------------------------------------------------------------------------ - SUBROUTINE write_efield( tefield, dipfield, edir, emaxpos, eopreg, eamp ) - !------------------------------------------------------------------------ - ! - LOGICAL, INTENT(IN) :: & - tefield, &! if .TRUE. a finite electric field is added to the - ! local potential - dipfield ! if .TRUE. the dipole field is subtracted - INTEGER, INTENT(IN) :: & - edir ! direction of the field - REAL(DP), INTENT(IN) :: & - emaxpos, &! position of the maximum of the field (00) CALL iotk_write_dat(iunpun,"LAMBDA",lambda) - ! - CALL iotk_write_end( iunpun, "MAGNETIZATION_INIT" ) - ! - RETURN - ! - END SUBROUTINE write_magnetization - ! - !------------------------------------------------------------------------ - SUBROUTINE write_xc( dft, nsp, lda_plus_u, & - Hubbard_lmax, Hubbard_l, Hubbard_U, Hubbard_alpha ) - !------------------------------------------------------------------------ - ! - CHARACTER(LEN=*), INTENT(IN) :: dft - LOGICAL, INTENT(IN) :: lda_plus_u - INTEGER, OPTIONAL, INTENT(IN) :: nsp - INTEGER, OPTIONAL, INTENT(IN) :: Hubbard_lmax - INTEGER, OPTIONAL, INTENT(IN) :: Hubbard_l(:) - REAL(DP), OPTIONAL, INTENT(IN) :: Hubbard_U(:), Hubbard_alpha(:) - ! - ! - CALL iotk_write_begin( iunpun, "EXCHANGE_CORRELATION" ) - ! - CALL iotk_write_dat( iunpun, "DFT", dft ) - ! - CALL iotk_write_dat( iunpun, "LDA_PLUS_U_CALCULATION", lda_plus_u ) - ! - IF ( lda_plus_u ) THEN - ! - IF ( .NOT. PRESENT( Hubbard_lmax ) .OR. & - .NOT. PRESENT( Hubbard_l ) .OR. & - .NOT. PRESENT( Hubbard_U ) .OR. & - .NOT. PRESENT( nsp ) .OR. & - .NOT. PRESENT( Hubbard_alpha ) ) & - CALL errore( 'write_exchange_correlation', & - ' variables for LDA+U not present', 1 ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_SPECIES", nsp ) - ! - CALL iotk_write_dat( iunpun, "HUBBARD_LMAX", Hubbard_lmax ) - ! - CALL iotk_write_dat( iunpun, "HUBBARD_L", & - Hubbard_l(1:nsp) ) - ! - CALL iotk_write_dat( iunpun, "HUBBARD_U", Hubbard_U(1:nsp) ) - ! - CALL iotk_write_dat( iunpun, "HUBBARD_ALPHA", Hubbard_alpha(1:nsp) ) - ! - END IF - ! - CALL iotk_write_end( iunpun, "EXCHANGE_CORRELATION" ) - ! - END SUBROUTINE write_xc - ! - !------------------------------------------------------------------------ - SUBROUTINE write_occ( lgauss, ngauss, degauss, ltetra, ntetra, & - tetra, tfixed_occ, lsda, nstates_up, nstates_down, f_inp ) - !------------------------------------------------------------------------ - ! - USE constants, ONLY : e2 - ! - LOGICAL, INTENT(IN) :: lgauss, ltetra, tfixed_occ, lsda - INTEGER, OPTIONAL, INTENT(IN) :: ngauss, ntetra, nstates_up, nstates_down - INTEGER, OPTIONAL, INTENT(IN) :: tetra(:,:) - REAL(DP), OPTIONAL, INTENT(IN) :: degauss, f_inp(:,:) - ! - INTEGER :: i - ! - ! - CALL iotk_write_begin( iunpun, "OCCUPATIONS" ) - ! - CALL iotk_write_dat( iunpun, "SMEARING_METHOD", lgauss ) - ! - IF ( lgauss ) THEN - ! - CALL iotk_write_dat( iunpun, "SMEARING_TYPE", ngauss ) - ! - CALL iotk_write_attr( attr, "UNITS", "Hartree", FIRST = .TRUE. ) - ! - CALL iotk_write_dat( iunpun, "SMEARING_PARAMETER", & - degauss / e2, ATTR = attr ) - ! - END IF - ! - CALL iotk_write_dat( iunpun, "TETRAHEDRON_METHOD", ltetra ) - ! - IF ( ltetra ) THEN - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_TETRAHEDRA", ntetra ) - ! - DO i = 1, ntetra - ! - CALL iotk_write_dat( iunpun, "TETRAHEDRON" // & - & iotk_index( i ), tetra(1:4,i) ) - ! - END DO - ! - END IF - ! - CALL iotk_write_dat( iunpun, "FIXED_OCCUPATIONS", tfixed_occ ) - ! - IF ( tfixed_occ ) THEN - ! - CALL iotk_write_attr( attr, "lsda" , lsda, FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "nstates_up", nstates_up ) - CALL iotk_write_attr( attr, "nstates_down", nstates_down ) - ! - CALL iotk_write_empty( iunpun, 'INFO', ATTR = attr ) - ! - CALL iotk_write_dat( iunpun, "INPUT_OCC_UP", f_inp(1:nstates_up,1) ) - ! - IF ( lsda ) & - CALL iotk_write_dat( iunpun, "INPUT_OCC_DOWN", f_inp(1:nstates_down,2) ) - ! - END IF - ! - CALL iotk_write_end( iunpun, "OCCUPATIONS" ) - ! - END SUBROUTINE write_occ - ! - !------------------------------------------------------------------------ - SUBROUTINE write_bz( num_k_points, xk, wk, k1, k2, k3, nk1, nk2, nk3, & - qnorm, nks_start, xk_start, wk_start ) - !------------------------------------------------------------------------ - ! - INTEGER, INTENT(IN) :: num_k_points, k1, k2, k3, nk1, nk2, nk3 - REAL(DP), INTENT(IN) :: xk(:,:), wk(:) - REAL(DP), INTENT(IN) :: qnorm - INTEGER, INTENT(IN), OPTIONAL :: nks_start - REAL(DP), INTENT(IN), OPTIONAL :: xk_start(:,:), wk_start(:) - ! - INTEGER :: ik, i - ! - ! - CALL iotk_write_begin( iunpun, "BRILLOUIN_ZONE" ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_K-POINTS", num_k_points ) - ! - CALL iotk_write_attr( attr, "UNITS", "2 pi / a", FIRST = .TRUE. ) - CALL iotk_write_empty( iunpun, "UNITS_FOR_K-POINTS", attr ) - ! - CALL iotk_write_attr( attr, "nk1", nk1, FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "nk2", nk2 ) - CALL iotk_write_attr( attr, "nk3", nk3 ) - CALL iotk_write_empty( iunpun, "MONKHORST_PACK_GRID", attr ) - CALL iotk_write_attr( attr, "k1", k1, FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "k2", k2 ) - CALL iotk_write_attr( attr, "k3", k3 ) - CALL iotk_write_empty( iunpun, "MONKHORST_PACK_OFFSET", attr ) - ! - DO ik = 1, num_k_points - ! - CALL iotk_write_attr( attr, "XYZ", xk(:,ik), FIRST = .TRUE. ) - ! - CALL iotk_write_attr( attr, "WEIGHT", wk(ik) ) - ! - CALL iotk_write_empty( iunpun, "K-POINT" // & - & TRIM( iotk_index(ik) ), attr ) - ! - END DO - ! - ! ... these are k-points and weights in the Irreducible BZ - ! - IF (present(nks_start).and.present(xk_start).and.present(wk_start)) THEN - CALL iotk_write_dat( iunpun, "STARTING_K-POINTS", nks_start ) - ! - DO ik = 1, nks_start - ! - CALL iotk_write_attr( attr, "XYZ", xk_start(:,ik), FIRST = .TRUE. ) - ! - CALL iotk_write_attr( attr, "WEIGHT", wk_start(ik) ) - ! - CALL iotk_write_empty( iunpun, "K-POINT_START" // & - & TRIM( iotk_index(ik) ), attr ) - ! - END DO - ENDIF - ! - CALL iotk_write_dat( iunpun, "NORM-OF-Q", qnorm ) - ! - CALL iotk_write_end( iunpun, "BRILLOUIN_ZONE" ) - ! - END SUBROUTINE write_bz - ! - !------------------------------------------------------------------------ - SUBROUTINE write_phonon( modenum, xqq ) - !------------------------------------------------------------------------ - ! - INTEGER, INTENT(IN) :: modenum - REAL(DP), INTENT(IN) :: xqq(:) - ! - ! - CALL iotk_write_begin( iunpun, "PHONON" ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_MODES", modenum ) - ! - CALL iotk_write_attr( attr, "UNITS", "2 pi / a", FIRST = .TRUE. ) - CALL iotk_write_empty( iunpun, "UNITS_FOR_Q-POINT", attr ) - ! - CALL iotk_write_dat( iunpun, "Q-POINT", xqq(:), COLUMNS=3 ) - ! - CALL iotk_write_end( iunpun, "PHONON" ) - ! - END SUBROUTINE write_phonon - - SUBROUTINE write_q( nqs, x_q, done_iq ) - !------------------------------------------------------------------------ - ! - INTEGER, INTENT(IN) :: nqs - REAL(DP), INTENT(IN) :: x_q(3,nqs) - INTEGER, INTENT(IN) :: done_iq(nqs) - ! - CALL iotk_write_begin( iunpun, "Q_POINTS" ) - ! - CALL iotk_write_dat( iunpun, "NUMBER_OF_Q_POINTS", nqs ) - ! - CALL iotk_write_attr( attr, "UNITS", "2 pi / a", FIRST = .TRUE. ) - ! - CALL iotk_write_empty( iunpun, "UNITS_FOR_Q-POINT", attr ) - ! - CALL iotk_write_dat( iunpun, "Q-POINT_COORDINATES", x_q(:,:), COLUMNS=3 ) - ! - CALL iotk_write_dat( iunpun, "Q-POINT_DONE", done_iq(:) ) - ! - CALL iotk_write_end( iunpun, "Q_POINTS" ) - ! - RETURN - END SUBROUTINE write_q - ! - ! ... methods to write and read effective_potential - ! - !------------------------------------------------------------------------ - SUBROUTINE write_pot_xml( pot_file_base, pot, & - nr1, nr2, nr3, nr1x, nr2x, ipp, npp, & - ionode, intra_group_comm, inter_group_comm ) - !------------------------------------------------------------------------ - ! - ! ... Writes effective-potential pot, one plane at a time. - ! ... If ipp and npp are specified, planes are collected one by one from - ! ... all processors, avoiding an overall collect of the effective-potential - ! ... on a single proc. - ! - USE mp, ONLY : mp_get, mp_sum, mp_rank, mp_size - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(IN) :: pot_file_base - REAL(DP), INTENT(IN) :: pot(:) - INTEGER, INTENT(IN) :: nr1, nr2, nr3 - INTEGER, INTENT(IN) :: nr1x, nr2x - INTEGER, INTENT(IN) :: ipp(:) - INTEGER, INTENT(IN) :: npp(:) - LOGICAL, INTENT(IN) :: ionode - INTEGER, INTENT(IN) :: intra_group_comm, inter_group_comm - ! - INTEGER :: ierr, i, j, k, kk, ldr, ip - CHARACTER(LEN=256) :: pot_file - CHARACTER(LEN=10) :: pot_extension - REAL(DP), ALLOCATABLE :: pot_plane(:) - INTEGER, ALLOCATABLE :: kowner(:) - INTEGER :: my_group_id, me_group, nproc_group, io_group_id, io_group - ! - INTEGER, PARAMETER :: potunit = 19 - ! - me_group = mp_rank( intra_group_comm ) - nproc_group = mp_size( intra_group_comm ) - my_group_id = mp_rank( inter_group_comm ) - ! - pot_extension = '.dat' - IF ( .NOT. pot_binary ) pot_extension = '.xml' - ! - pot_file = TRIM( pot_file_base ) // TRIM( pot_extension ) - ! - IF ( ionode ) THEN - CALL iotk_open_write( potunit, FILE = pot_file, BINARY = pot_binary, IERR = ierr ) - CALL errore( 'write_pot_xml', 'cannot open' // TRIM( pot_file ) // ' file for writing', ierr ) - END IF - ! - IF ( ionode ) THEN - ! - CALL iotk_write_begin( potunit, "EFFECTIVE-POTENTIAL" ) - ! - CALL iotk_write_attr( attr, "nr1", nr1, FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "nr2", nr2 ) - CALL iotk_write_attr( attr, "nr3", nr3 ) - ! - CALL iotk_write_empty( potunit, "INFO", attr ) - ! - END IF - ! - ALLOCATE( pot_plane( nr1*nr2 ) ) - ALLOCATE( kowner( nr3 ) ) - ! - ! ... find the index of the group (pool) that will write potential - ! - io_group_id = 0 - ! - IF ( ionode ) io_group_id = my_group_id - ! - CALL mp_sum( io_group_id, intra_group_comm ) - CALL mp_sum( io_group_id, inter_group_comm ) - ! - ! ... find the index of the ionode within its own group (pool) - ! - io_group = 0 - ! - IF ( ionode ) io_group = me_group - ! - CALL mp_sum( io_group, intra_group_comm ) - ! - ! ... find out the owner of each "z" plane - ! - DO ip = 1, nproc_group - ! - kowner( (ipp(ip)+1):(ipp(ip)+npp(ip)) ) = ip - 1 - ! - END DO - ! - ldr = nr1x*nr2x - ! - DO k = 1, nr3 - ! - ! Only one subgroup write the effective-potential - ! - IF( ( kowner(k) == me_group ) .AND. ( my_group_id == io_group_id ) ) THEN - ! - kk = k - ipp( me_group + 1 ) - ! - DO j = 1, nr2 - ! - DO i = 1, nr1 - ! - pot_plane(i+(j-1)*nr1) = pot(i+(j-1)*nr1x+(kk-1)*ldr) - ! - END DO - ! - END DO - ! - END IF - ! - IF ( kowner(k) /= io_group .AND. my_group_id == io_group_id ) & - CALL mp_get( pot_plane, pot_plane, me_group, io_group, kowner(k), k, intra_group_comm ) - ! - IF ( ionode ) & - CALL iotk_write_dat( potunit, "z" // iotk_index( k ), pot_plane ) - ! - END DO - ! - DEALLOCATE( pot_plane ) - DEALLOCATE( kowner ) - ! - IF ( ionode ) THEN - ! - CALL iotk_write_end( potunit, "EFFECTIVE-POTENTIAL" ) - ! - CALL iotk_close_write( potunit ) - ! - END IF - ! - RETURN - ! - END SUBROUTINE write_pot_xml - ! - !------------------------------------------------------------------------ - SUBROUTINE read_pot_xml( pot_file_base, pot, & - nr1, nr2, nr3, nr1x, nr2x, ipp, npp, & - ionode, intra_group_comm, inter_group_comm ) - !------------------------------------------------------------------------ - ! - ! ... Reads effective-potential pot, one plane at a time. - ! ... If ipp and npp are specified, planes are collected one by one from - ! ... all processors, avoiding an overall collect of the effective-potential - ! ... on a single proc. - ! - USE mp, ONLY : mp_put, mp_sum, mp_rank, mp_size - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(IN) :: pot_file_base - INTEGER, INTENT(IN) :: nr1, nr2, nr3 - INTEGER, INTENT(IN) :: nr1x, nr2x - REAL(DP), INTENT(OUT) :: pot(:) - INTEGER, OPTIONAL, INTENT(IN) :: ipp(:) - INTEGER, OPTIONAL, INTENT(IN) :: npp(:) - LOGICAL, INTENT(IN) :: ionode - INTEGER, INTENT(IN) :: intra_group_comm, inter_group_comm - ! - INTEGER :: ierr, i, j, k, kk, ldr, ip - INTEGER :: nr( 3 ) - CHARACTER(LEN=256) :: pot_file - REAL(DP), ALLOCATABLE :: pot_plane(:) - INTEGER, ALLOCATABLE :: kowner(:) - LOGICAL :: exst - INTEGER :: ngroup, my_group_id, me_group, nproc_group, io_group_id, io_group - ! - INTEGER, PARAMETER :: potunit = 19 - ! - me_group = mp_rank( intra_group_comm ) - nproc_group = mp_size( intra_group_comm ) - my_group_id = mp_rank( inter_group_comm ) - ngroup = mp_size( inter_group_comm ) - ! - pot_file = TRIM( pot_file_base ) // ".dat" - exst = check_file_exst( TRIM(pot_file) ) - ! - IF ( .NOT. exst ) THEN - ! - pot_file = TRIM( pot_file_base ) // ".xml" - exst = check_file_exst( TRIM(pot_file) ) - ! - ENDIF - ! - IF ( .NOT. exst ) CALL errore('read_pot_xml', 'searching for '//TRIM(pot_file), 10) - ! - IF ( ionode ) THEN - CALL iotk_open_read( potunit, FILE = pot_file, IERR = ierr ) - CALL errore( 'read_pot_xml', 'cannot open ' // TRIM( pot_file ) // ' file for reading', ierr ) - END IF - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( potunit, "EFFECTIVE-POTENTIAL" ) - ! - CALL iotk_scan_empty( potunit, "INFO", attr ) - ! - CALL iotk_scan_attr( attr, "nr1", nr(1) ) - CALL iotk_scan_attr( attr, "nr2", nr(2) ) - CALL iotk_scan_attr( attr, "nr3", nr(3) ) - ! - IF ( nr1 /= nr(1) .OR. nr2 /= nr(2) .OR. nr3 /= nr(3) ) & - CALL errore( 'read_pot_xml', 'dimensions do not match', 1 ) - ! - END IF - ! - ALLOCATE( pot_plane( nr1*nr2 ) ) - ALLOCATE( kowner( nr3 ) ) - ! - ! ... find the index of the pool that will write pot - ! - io_group_id = 0 - ! - IF ( ionode ) io_group_id = my_group_id - ! - CALL mp_sum( io_group_id, intra_group_comm ) - CALL mp_sum( io_group_id, inter_group_comm ) - ! - ! ... find the index of the ionode within its own pool - ! - io_group = 0 - ! - IF ( ionode ) io_group = me_group - ! - CALL mp_sum( io_group, intra_group_comm ) - CALL mp_sum( io_group, inter_group_comm ) - ! - ! ... find out the owner of each "z" plane - ! - DO ip = 1, nproc_group - ! - kowner((ipp(ip)+1):(ipp(ip)+npp(ip))) = ip - 1 - ! - END DO - ! - ldr = nr1x*nr2x - ! - ! ... explicit initialization to zero is needed because the physical - ! ... dimensions pot may exceed the true size of the FFT grid - ! - pot(:) = 0.0_DP - ! - DO k = 1, nr3 - ! - ! ... only ionode reads the potential planes - ! - IF ( ionode ) & - CALL iotk_scan_dat( potunit, "z" // iotk_index( k ), pot_plane ) - ! - ! ... planes are sent to the destination processor - ! - IF( ngroup > 1 ) THEN - ! - ! send to all proc/pools - ! - IF( io_group_id == my_group_id ) THEN - CALL mp_bcast( pot_plane, io_group, intra_group_comm ) - END IF - CALL mp_bcast( pot_plane, io_group_id, inter_group_comm ) - ! - ELSE - ! - ! send to the destination proc - ! - IF ( kowner(k) /= io_group ) & - CALL mp_put( pot_plane, pot_plane, me_group, io_group, kowner(k), k, intra_group_comm ) - ! - END IF - ! - IF( kowner(k) == me_group ) THEN - ! - kk = k - ipp( me_group + 1 ) - ! - DO j = 1, nr2 - ! - DO i = 1, nr1 - ! - pot(i+(j-1)*nr1x+(kk-1)*ldr) = pot_plane(i+(j-1)*nr1) - ! - END DO - ! - END DO - ! - END IF - ! - END DO - ! - DEALLOCATE( pot_plane ) - DEALLOCATE( kowner ) - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_end( potunit, "EFFECTIVE-POTENTIAL" ) - ! - CALL iotk_close_read( potunit ) - ! - END IF - ! - RETURN - ! - END SUBROUTINE read_pot_xml - ! - ! ... methods to write and read charge_density - ! - !------------------------------------------------------------------------ - SUBROUTINE write_rho_xml( rho_file_base, rho, & - nr1, nr2, nr3, nr1x, nr2x, ipp, npp ) - !------------------------------------------------------------------------ - ! - ! ... Writes charge density rho, one plane at a time. - ! ... If ipp and npp are specified, planes are collected one by one from - ! ... all processors, avoiding an overall collect of the charge density - ! ... on a single proc. - ! - USE io_files, ONLY : rhounit - USE io_global, ONLY : ionode - USE mp_global, ONLY : me_image, intra_image_comm, me_pool, nproc_pool, & - intra_pool_comm, my_pool_id - USE mp, ONLY : mp_get - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(IN) :: rho_file_base - INTEGER, INTENT(IN) :: nr1, nr2, nr3 - INTEGER, INTENT(IN) :: nr1x, nr2x - REAL(DP), INTENT(IN) :: rho(:) - INTEGER, OPTIONAL, INTENT(IN) :: ipp(:) - INTEGER, OPTIONAL, INTENT(IN) :: npp(:) - ! - INTEGER :: ierr, i, j, k, kk, ldr, ip - CHARACTER(LEN=256) :: rho_file - CHARACTER(LEN=10) :: rho_extension - REAL(DP), ALLOCATABLE :: rho_plane(:) - INTEGER, ALLOCATABLE :: kowner(:) - INTEGER :: iopool_id, ionode_pool - ! - ! - rho_extension = '.dat' - IF ( .NOT. rho_binary ) rho_extension = '.xml' - ! - rho_file = TRIM( rho_file_base ) // TRIM( rho_extension ) - ! - IF ( ionode ) & - CALL iotk_open_write( rhounit, FILE = rho_file, & - BINARY = rho_binary, IERR = ierr ) - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'write_rho_xml', 'cannot open' // & - & TRIM( rho_file ) // ' file for writing', ierr ) - ! - IF ( ionode ) THEN - ! - CALL iotk_write_begin( rhounit, "CHARGE-DENSITY" ) - ! - CALL iotk_write_attr( attr, "nr1", nr1, FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "nr2", nr2 ) - CALL iotk_write_attr( attr, "nr3", nr3 ) - ! - CALL iotk_write_empty( rhounit, "INFO", attr ) - ! - END IF - ! - ALLOCATE( rho_plane( nr1*nr2 ) ) - ALLOCATE( kowner( nr3 ) ) - ! - ! ... find the index of the pool that will write rho - ! - IF ( ionode ) iopool_id = my_pool_id - ! - CALL mp_bcast( iopool_id, ionode_id, intra_image_comm ) - ! - ! ... find the index of the ionode within its own pool - ! - IF ( ionode ) ionode_pool = me_pool - ! - CALL mp_bcast( ionode_pool, ionode_id, intra_image_comm ) - ! - ! ... find out the owner of each "z" plane - ! - IF ( PRESENT( ipp ) .AND. PRESENT( npp ) ) THEN - ! - DO ip = 1, nproc_pool - ! - kowner( (ipp(ip)+1):(ipp(ip)+npp(ip)) ) = ip - 1 - ! - END DO - ! - ELSE - ! - kowner = ionode_id - ! - END IF - ! - ldr = nr1x*nr2x - ! - DO k = 1, nr3 - ! - IF( kowner(k) == me_pool ) THEN - ! - kk = k - ! - IF ( PRESENT( ipp ) ) kk = k - ipp(me_pool+1) - ! - DO j = 1, nr2 - ! - DO i = 1, nr1 - ! - rho_plane(i+(j-1)*nr1) = rho(i+(j-1)*nr1x+(kk-1)*ldr) - ! - END DO - ! - END DO - ! - END IF - ! - IF ( kowner(k) /= ionode_pool .AND. my_pool_id == iopool_id ) & - CALL mp_get( rho_plane, rho_plane, & - me_pool, ionode_pool, kowner(k), k, intra_pool_comm ) - ! - IF ( ionode ) & - CALL iotk_write_dat( rhounit, "z" // iotk_index( k ), rho_plane ) - ! - END DO - ! - DEALLOCATE( rho_plane ) - DEALLOCATE( kowner ) - ! - IF ( ionode ) THEN - ! - CALL iotk_write_end( rhounit, "CHARGE-DENSITY" ) - ! - CALL iotk_close_write( rhounit ) - ! - END IF - ! - RETURN - ! - END SUBROUTINE write_rho_xml - ! - !------------------------------------------------------------------------ - SUBROUTINE read_rho_xml( rho_file_base, rho, & - nr1, nr2, nr3, nr1x, nr2x, ipp, npp ) - !------------------------------------------------------------------------ - ! - ! ... Reads charge density rho, one plane at a time. - ! ... If ipp and npp are specified, planes are collected one by one from - ! ... all processors, avoiding an overall collect of the charge density - ! ... on a single proc. - ! - USE io_files, ONLY : rhounit - USE io_global, ONLY : ionode, ionode_id - USE mp_global, ONLY : me_image, intra_image_comm, me_pool, nproc_pool, & - intra_pool_comm, my_pool_id, npool - USE mp, ONLY : mp_put - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(IN) :: rho_file_base - INTEGER, INTENT(IN) :: nr1, nr2, nr3 - INTEGER, INTENT(IN) :: nr1x, nr2x - REAL(DP), INTENT(OUT) :: rho(:) - INTEGER, OPTIONAL, INTENT(IN) :: ipp(:) - INTEGER, OPTIONAL, INTENT(IN) :: npp(:) - ! - INTEGER :: ierr, i, j, k, kk, ldr, ip - INTEGER :: nr( 3 ) - CHARACTER(LEN=256) :: rho_file - REAL(DP), ALLOCATABLE :: rho_plane(:) - INTEGER, ALLOCATABLE :: kowner(:) - INTEGER :: iopool_id, ionode_pool - LOGICAL :: exst - ! - ! - rho_file = TRIM( rho_file_base ) // ".dat" - exst = check_file_exst( TRIM(rho_file) ) - ! - IF ( .NOT. exst ) THEN - ! - rho_file = TRIM( rho_file_base ) // ".xml" - exst = check_file_exst( TRIM(rho_file) ) - ! - ENDIF - ! - IF ( .NOT. exst ) CALL errore('read_rho_xml', 'searching for '//TRIM(rho_file), 10) - ! - IF ( ionode ) & - CALL iotk_open_read( rhounit, FILE = rho_file, IERR = ierr ) - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'read_rho_xml', 'cannot open ' // & - & TRIM( rho_file ) // ' file for reading', ierr ) - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_begin( rhounit, "CHARGE-DENSITY" ) - ! - CALL iotk_scan_empty( rhounit, "INFO", attr ) - ! - CALL iotk_scan_attr( attr, "nr1", nr(1) ) - CALL iotk_scan_attr( attr, "nr2", nr(2) ) - CALL iotk_scan_attr( attr, "nr3", nr(3) ) - ! - END IF - ! - CALL mp_bcast( nr, ionode_id, intra_image_comm ) - ! - IF ( nr1 /= nr(1) .OR. nr2 /= nr(2) .OR. nr3 /= nr(3) ) & - CALL errore( 'read_rho_xml', 'dimensions do not match', 1 ) - ! - ALLOCATE( rho_plane( nr1*nr2 ) ) - ALLOCATE( kowner( nr3 ) ) - ! - ! ... find the index of the pool that will write rho - ! - IF ( ionode ) iopool_id = my_pool_id - ! - CALL mp_bcast( iopool_id, ionode_id, intra_image_comm ) - ! - ! ... find the index of the ionode within its own pool - ! - IF ( ionode ) ionode_pool = me_pool - ! - CALL mp_bcast( ionode_pool, ionode_id, intra_image_comm ) - ! - ! ... find out the owner of each "z" plane - ! - IF ( PRESENT( ipp ) .AND. PRESENT( npp ) ) THEN - ! - DO ip = 1, nproc_pool - ! - kowner((ipp(ip)+1):(ipp(ip)+npp(ip))) = ip - 1 - ! - END DO - ! - ELSE - ! - kowner = ionode_id - ! - END IF - ! - ldr = nr1x*nr2x - ! - ! ... explicit initialization to zero is needed because the physical - ! ... dimensions rho may exceed the true size of the FFT grid - ! - rho(:) = 0.0_DP - ! - DO k = 1, nr3 - ! - ! ... only ionode reads the charge planes - ! - IF ( ionode ) & - CALL iotk_scan_dat( rhounit, "z" // iotk_index( k ), rho_plane ) - ! - ! ... planes are sent to the destination processor - ! - IF( npool > 1 ) THEN - ! - ! send to all proc/pools - ! - CALL mp_bcast( rho_plane, ionode_id, intra_image_comm ) - ! - ELSE - ! - ! send to the destination proc - ! - IF ( kowner(k) /= ionode_id ) & - CALL mp_put( rho_plane, rho_plane, me_image, & - ionode_id, kowner(k), k, intra_image_comm ) - ! - END IF - ! - IF( kowner(k) == me_pool ) THEN - ! - kk = k - ! - IF ( PRESENT( ipp ) ) kk = k - ipp(me_pool+1) - ! - DO j = 1, nr2 - ! - DO i = 1, nr1 - ! - rho(i+(j-1)*nr1x+(kk-1)*ldr) = rho_plane(i+(j-1)*nr1) - ! - END DO - ! - END DO - ! - END IF - ! - END DO - ! - DEALLOCATE( rho_plane ) - DEALLOCATE( kowner ) - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_end( rhounit, "CHARGE-DENSITY" ) - ! - CALL iotk_close_read( rhounit ) - ! - END IF - ! - RETURN - ! - END SUBROUTINE read_rho_xml - ! - ! ... methods to write and read wavefunctions - ! - !------------------------------------------------------------------------ - SUBROUTINE write_wfc_real( iuni, ik, nk, kunit, ispin, & - nspin, wf0, ngw, gamma_only, nbnd, igl, ngwl, filename, scalef ) - !------------------------------------------------------------------------ - ! - USE mp_wave, ONLY : mergewf - USE mp, ONLY : mp_get - USE mp_global, ONLY : me_pool, nproc_image, nproc_pool, & - root_pool, intra_pool_comm, me_image, & - intra_image_comm - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: iuni - INTEGER, INTENT(IN) :: ik, nk, kunit, ispin, nspin - COMPLEX(DP), INTENT(IN) :: wf0(:,:) - INTEGER, INTENT(IN) :: ngw - LOGICAL, INTENT(IN) :: gamma_only - INTEGER, INTENT(IN) :: nbnd - INTEGER, INTENT(IN) :: ngwl - INTEGER, INTENT(IN) :: igl(:) - CHARACTER(LEN=256), INTENT(IN) :: filename - REAL(DP), INTENT(IN) :: scalef - ! scale factor, usually 1.0 for pw and 1/SQRT( omega ) for CP - ! - INTEGER :: j - INTEGER :: iks, ike, ikt, igwx - INTEGER :: npool, ipmask(nproc_image), ipsour - COMPLEX(DP), ALLOCATABLE :: wtmp(:) - ! - ! - CALL set_kpoints_vars( ik, nk, kunit, ngwl, igl, & - npool, ikt, iks, ike, igwx, ipmask, ipsour ) - ! - IF ( ionode ) THEN - ! - CALL iotk_open_write( iuni, FILE = TRIM( filename ), ROOT="WFC", BINARY = .TRUE. ) - ! - CALL iotk_write_attr( attr, "ngw", ngw, FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "igwx", igwx ) - CALL iotk_write_attr( attr, "gamma_only", gamma_only ) - CALL iotk_write_attr( attr, "nbnd", nbnd ) - CALL iotk_write_attr( attr, "ik", ik ) - CALL iotk_write_attr( attr, "nk", nk ) - CALL iotk_write_attr( attr, "ispin", ispin ) - CALL iotk_write_attr( attr, "nspin", nspin ) - CALL iotk_write_attr( attr, "scale_factor", scalef ) - ! - CALL iotk_write_empty( iuni, "INFO", attr ) - ! - END IF - ! - ALLOCATE( wtmp( MAX( igwx, 1 ) ) ) - ! - wtmp = 0.0_DP - ! - DO j = 1, nbnd - ! - IF ( npool > 1 ) THEN - ! - IF ( ikt >= iks .AND. ikt <= ike ) & - CALL mergewf( wf0(:,j), wtmp, ngwl, igl, me_pool, & - nproc_pool, root_pool, intra_pool_comm ) - ! - IF ( ipsour /= ionode_id ) & - CALL mp_get( wtmp, wtmp, me_image, & - ionode_id, ipsour, j, intra_image_comm ) - ! - ELSE - ! - CALL mergewf( wf0(:,j), wtmp, ngwl, igl, & - me_image, nproc_image, ionode_id, intra_image_comm ) - ! - END IF - ! - IF ( ionode ) & - CALL iotk_write_dat( iuni, "evc" // iotk_index( j ), wtmp(1:igwx) ) - ! - END DO - ! - IF ( ionode ) CALL iotk_close_write( iuni ) - ! - DEALLOCATE( wtmp ) - ! - RETURN - ! - END SUBROUTINE write_wfc_real - ! -!------------------------------------------------------------------------ - SUBROUTINE write_wfc_cmplx( iuni, ik, nk, kunit, ispin, & - nspin, wf0, ngw, do_wf_cmplx, gamma_only, nbnd, igl, ngwl, filename, scalef ) !added:giovanni do_wf_cmplx - !------------------------------------------------------------------------ - ! - USE mp_wave, ONLY : mergewf - USE mp, ONLY : mp_get - USE mp_global, ONLY : me_pool, nproc_image, nproc_pool, & - root_pool, intra_pool_comm, me_image, & - intra_image_comm - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: iuni - INTEGER, INTENT(IN) :: ik, nk, kunit, ispin, nspin - COMPLEX(DP), INTENT(IN) :: wf0(:,:) - INTEGER, INTENT(IN) :: ngw - LOGICAL, INTENT(IN) :: do_wf_cmplx ! added:giovanni - LOGICAL, INTENT(IN) :: gamma_only - INTEGER, INTENT(IN) :: nbnd - INTEGER, INTENT(IN) :: ngwl - INTEGER, INTENT(IN) :: igl(:) - CHARACTER(LEN=256), INTENT(IN) :: filename - REAL(DP), INTENT(IN) :: scalef - ! scale factor, usually 1.0 for pw and 1/SQRT( omega ) for CP - ! - INTEGER :: j - INTEGER :: iks, ike, ikt, igwx - INTEGER :: npool, ipmask(nproc_image), ipsour - COMPLEX(DP), ALLOCATABLE :: wtmp(:) - ! - ! - CALL set_kpoints_vars( ik, nk, kunit, ngwl, igl, & - npool, ikt, iks, ike, igwx, ipmask, ipsour ) - ! - IF ( ionode ) THEN - ! - CALL iotk_open_write( iuni, FILE = TRIM( filename ), ROOT="WFC", BINARY = .TRUE. ) - ! - CALL iotk_write_attr( attr, "ngw", ngw, FIRST = .TRUE. ) - CALL iotk_write_attr( attr, "igwx", igwx ) - CALL iotk_write_attr( attr, "do_wf_cmplx", do_wf_cmplx ) !added:giovanni - CALL iotk_write_attr( attr, "gamma_only", gamma_only.and..not.do_wf_cmplx ) - CALL iotk_write_attr( attr, "nbnd", nbnd ) - CALL iotk_write_attr( attr, "ik", ik ) - CALL iotk_write_attr( attr, "nk", nk ) - CALL iotk_write_attr( attr, "ispin", ispin ) - CALL iotk_write_attr( attr, "nspin", nspin ) - CALL iotk_write_attr( attr, "scale_factor", scalef ) - ! - CALL iotk_write_empty( iuni, "INFO", attr ) - ! - END IF - ! - ALLOCATE( wtmp( MAX( igwx, 1 ) ) ) - ! - wtmp = 0.0_DP - ! - DO j = 1, nbnd - ! - IF ( npool > 1 ) THEN - ! - IF ( ikt >= iks .AND. ikt <= ike ) & - CALL mergewf( wf0(:,j), wtmp, ngwl, igl, me_pool, & - nproc_pool, root_pool, intra_pool_comm ) - ! - IF ( ipsour /= ionode_id ) & - CALL mp_get( wtmp, wtmp, me_image, & - ionode_id, ipsour, j, intra_image_comm ) - ! - ELSE - ! - CALL mergewf( wf0(:,j), wtmp, ngwl, igl, & - me_image, nproc_image, ionode_id, intra_image_comm ) - ! - END IF - ! - IF ( ionode ) & - CALL iotk_write_dat( iuni, "evc" // iotk_index( j ), wtmp(1:igwx) ) - ! - END DO - ! - IF ( ionode ) CALL iotk_close_write( iuni ) - ! - DEALLOCATE( wtmp ) - ! - RETURN - ! - END SUBROUTINE write_wfc_cmplx - - !------------------------------------------------------------------------ - SUBROUTINE read_wfc( iuni, ik, nk, kunit, ispin, & - nspin, wf, ngw, nbnd, igl, ngwl, filename, scalef, & - flink ) - !------------------------------------------------------------------------ - ! - USE mp_wave, ONLY : splitwf - USE mp, ONLY : mp_put - USE mp_global, ONLY : me_image, nproc_image, root_image, me_pool, my_pool_id, & - nproc_pool, intra_pool_comm, root_pool, my_image_id, & - intra_image_comm - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: iuni - COMPLEX(DP), INTENT(OUT) :: wf(:,:) - INTEGER, INTENT(IN) :: ik, nk - INTEGER, INTENT(IN) :: kunit - INTEGER, INTENT(INOUT) :: ngw, nbnd, ispin, nspin - INTEGER, INTENT(IN) :: ngwl - INTEGER, INTENT(IN) :: igl(:) - CHARACTER(LEN=256), INTENT(IN) :: filename - REAL(DP), INTENT(OUT) :: scalef - LOGICAL, OPTIONAL, INTENT(IN) :: flink - ! - INTEGER :: j - COMPLEX(DP), ALLOCATABLE :: wtmp(:) - INTEGER :: ierr - INTEGER :: iks, ike, ikt - INTEGER :: igwx, igwx_, ik_, nk_ - INTEGER :: npool, ipmask(nproc_image), ipdest - LOGICAL :: flink_ - ! - flink_ = .FALSE. - IF( PRESENT( flink ) ) flink_ = flink - ! - CALL set_kpoints_vars( ik, nk, kunit, ngwl, igl, & - npool, ikt, iks, ike, igwx, ipmask, ipdest ) - ! - ! if flink = .true. we are following a link and the file is - ! already opened for read - ! - ierr = 0 - ! - IF ( ionode .AND. .NOT. flink_ ) & - CALL iotk_open_read( iuni, FILE = filename, & - BINARY = .TRUE., IERR = ierr ) - ! - CALL mp_bcast( ierr, ionode_id, intra_image_comm ) - ! - CALL errore( 'read_wfc ', & - 'cannot open restart file for reading', ierr ) - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_empty( iuni, "INFO", attr ) - ! - CALL iotk_scan_attr( attr, "ngw", ngw ) - CALL iotk_scan_attr( attr, "nbnd", nbnd ) - CALL iotk_scan_attr( attr, "ik", ik_ ) - CALL iotk_scan_attr( attr, "nk", nk_ ) - CALL iotk_scan_attr( attr, "ispin", ispin ) - CALL iotk_scan_attr( attr, "nspin", nspin ) - CALL iotk_scan_attr( attr, "igwx", igwx_ ) - CALL iotk_scan_attr( attr, "scale_factor", scalef ) - ! - END IF - ! - CALL mp_bcast( ngw, ionode_id, intra_image_comm ) - CALL mp_bcast( nbnd, ionode_id, intra_image_comm ) - CALL mp_bcast( ik_, ionode_id, intra_image_comm ) - CALL mp_bcast( nk_, ionode_id, intra_image_comm ) - CALL mp_bcast( ispin, ionode_id, intra_image_comm ) - CALL mp_bcast( nspin, ionode_id, intra_image_comm ) - CALL mp_bcast( igwx_, ionode_id, intra_image_comm ) - CALL mp_bcast( scalef, ionode_id, intra_image_comm ) - ! - ALLOCATE( wtmp( MAX( igwx_, igwx ) ) ) - ! - DO j = 1, nbnd - ! - IF ( j <= SIZE( wf, 2 ) ) THEN - ! - IF ( ionode ) THEN - ! - CALL iotk_scan_dat( iuni, & - "evc" // iotk_index( j ), wtmp(1:igwx_) ) - ! - IF ( igwx > igwx_ ) wtmp((igwx_+1):igwx) = 0.0_DP - ! - END IF - ! - IF ( npool > 1 ) THEN - ! - IF ( ipdest /= ionode_id ) & - CALL mp_put( wtmp, wtmp, me_image, & - ionode_id, ipdest, j, intra_image_comm ) - ! - IF ( ( ikt >= iks ) .AND. ( ikt <= ike ) ) & - CALL splitwf( wf(:,j), wtmp, ngwl, igl, me_pool, & - nproc_pool, root_pool, intra_pool_comm ) - ! - ELSE - ! - CALL splitwf( wf(:,j), wtmp, ngwl, igl, & - me_image, nproc_image, ionode_id, intra_image_comm ) - ! - END IF - ! - END IF - ! - END DO - ! - IF ( ionode .AND. .NOT. flink_ ) CALL iotk_close_read( iuni ) - ! - DEALLOCATE( wtmp ) - ! - RETURN - ! - END SUBROUTINE read_wfc - ! - ! - !------------------------------------------------------------------------ - SUBROUTINE write_eig( iuni, filename, nbnd, eig, energy_units, & - occ, ik, ispin, lkpoint_dir ) - !------------------------------------------------------------------------ - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: iuni - INTEGER, INTENT(IN) :: nbnd - REAL(DP), INTENT(IN) :: eig(:) - CHARACTER(*), INTENT(IN) :: energy_units - REAL(DP), OPTIONAL, INTENT(IN) :: occ(:) - INTEGER, OPTIONAL, INTENT(IN) :: ik, ispin - LOGICAL, OPTIONAL, INTENT(IN) :: lkpoint_dir - CHARACTER(LEN=256), INTENT(IN) :: filename - LOGICAL :: lkpoint_dir0 - ! - lkpoint_dir0=.TRUE. - IF (present(lkpoint_dir)) lkpoint_dir0=lkpoint_dir - IF ( ionode ) THEN - ! - if (lkpoint_dir0) CALL iotk_open_write ( iuni, & - FILE = TRIM( filename ), BINARY = .FALSE. ) - ! - CALL iotk_write_attr ( attr, "nbnd", nbnd, FIRST=.TRUE. ) - IF ( PRESENT( ik) ) CALL iotk_write_attr ( attr, "ik", ik ) - IF ( PRESENT( ispin) ) CALL iotk_write_attr ( attr, "ispin", ispin ) - CALL iotk_write_empty( iuni, "INFO", ATTR = attr ) - ! - CALL iotk_write_attr ( attr, "UNITS", TRIM(energy_units), FIRST = .TRUE. ) - CALL iotk_write_empty( iuni, "UNITS_FOR_ENERGIES", ATTR=attr) - ! - CALL iotk_write_dat( iuni, "EIGENVALUES", eig(:) ) - ! - IF ( PRESENT( occ ) ) THEN - ! - CALL iotk_write_dat( iuni, "OCCUPATIONS", occ(:) ) - ! - ENDIF - ! - IF (lkpoint_dir0) CALL iotk_close_write ( iuni ) - ! - ENDIF - ! - END SUBROUTINE write_eig - ! -END MODULE xml_io_base diff --git a/quantum_espresso/kcp/Modules/zhpev_drv.f90 b/quantum_espresso/kcp/Modules/zhpev_drv.f90 deleted file mode 100644 index 649c235e3..000000000 --- a/quantum_espresso/kcp/Modules/zhpev_drv.f90 +++ /dev/null @@ -1,1575 +0,0 @@ -! -! Copyright (C) 2001-2006 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -MODULE zhpev_module - - IMPLICIT NONE - SAVE - - PRIVATE - - PUBLIC :: pzhpev_drv, zhpev_drv, zgeev_drv -#if defined __SCALAPACK - PUBLIC :: pzheevd_drv -#endif - - -CONTAINS - ! - !------------------------------------------------------------------------- - SUBROUTINE pzhptrd( n, nrl, ap, lda, d, e, tau, nproc, me, comm ) - !------------------------------------------------------------------------- - ! - ! Parallel MPI version of the LAPACK routine ZHPTRD - ! - ! Carlo Cavazzoni (carlo.cavazzoni@cineca.it) -- CINECA - ! Dicember 12, 1999 - ! - ! REFERENCES : - ! - ! NUMERICAL RECIPES, THE ART OF SCIENTIFIC COMPUTING. - ! W.H. PRESS, B.P. FLANNERY, S.A. TEUKOLSKY, AND W.T. VETTERLING, - ! CAMBRIDGE UNIVERSITY PRESS, CAMBRIDGE. - ! - ! PARALLEL NUMERICAL ALGORITHMS, - ! T.L. FREEMAN AND C.PHILLIPS, - ! PRENTICE HALL INTERNATIONAL (1992). - ! - ! LAPACK routine (version 2.0) -- - ! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - ! Courant Institute, Argonne National Lab, and Rice University - ! - - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - - IMPLICIT NONE - -! .. __SCALAR Arguments .. - INTEGER LDA, N, NRL, NPROC, ME, comm -! .. -! .. Array Arguments .. - REAL(DP) D( * ), E( * ) - COMPLEX(DP) AP(LDA, * ), TAU( * ) -! .. -! -! Purpose -! ======= -! -! PZHPTRD reduces a complex Hermitian distributed matrix AP to -! real symmetric tridiagonal form T by a unitary similarity -! transformation: Q**H * A * Q = T. -! -! Arguments -! ========= -! -! N (input) INTEGER -! The order of the mglobal atrix AP. N >= 0. -! -! NRL (input) INTEGER -! The number of local rows of the matrix AP. NRL >= 0. -! -! AP (input/output) COMPLEX(DP) array, dimension (LDA,N) -! On entry, the Hermitian matrix AP. -! The rows of the matrix are distributed among processors -! with blocking factor 1. -! Example for NPROC = 4 : -! ROW | PE -! 1 | 0 -! 2 | 1 -! 3 | 2 -! 4 | 3 -! 5 | 0 -! 6 | 1 -! .. | .. - -! On exit, the diagonal and first subdiagonal -! of A are overwritten by the corresponding elements of the -! tridiagonal matrix T, and the elements below the first -! subdiagonal, with the array TAU, represent the unitary -! matrix Q as a product of elementary reflectors; -! -! LDA (input) INTEGER -! Leading dimension of the local matrix AP, LDA > NRL -! -! D (output) DOUBLE PRECISION array, dimension (N) -! The diagonal elements of the tridiagonal matrix T: -! D(i) = AP(i,i). -! -! E (output) DOUBLE PRECISION array, dimension (N-1) -! The off-diagonal elements of the tridiagonal matrix T: -! E(i) = A(i+1,i) -! -! TAU (output) COMPLEX(DP) array, dimension (N-1) -! The __SCALAR factors of the elementary reflectors (see Further -! Details). -! -! NPROC (input) INTEGER -! Number of processors -! -! ME (input) INTEGER -! Index of the local processor ( 0, 1, 2, ..., NPROC-1 ) - -! -! Further Details -! =============== -! -! the matrix Q is represented as a product of elementary -! reflectors -! -! Q = H(1) H(2) . . . H(n-1). -! -! Each H(i) has the form -! -! H(i) = I - tau * v * v' -! -! where tau is a complex __SCALAR, and v is a complex vector with -! v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, -! overwriting A(i+2:n,i), and tau is stored in TAU(i). -! -! ===================================================================== -! -! .. Parameters .. - - COMPLEX(DP) ONE, ZERO, HALF - PARAMETER ( ONE = ( 1.0_DP, 0.0_DP ),ZERO = ( 0.0_DP, 0.0_DP ), & - & HALF = ( 0.5_DP, 0.0_DP ) ) - REAL(DP) RONE, RZERO - PARAMETER ( RONE = 1.0_DP, RZERO = 0.0_DP ) - - INTEGER QI - INTEGER IL(N+1) - INTEGER OW(N+1) - COMPLEX(DP) CTMP - COMPLEX(DP) CTMPV(N+1) - COMPLEX(DP) TAUL(N+1) - COMPLEX(DP) APKI(N+1) - REAL(DP) TMP - REAL(DP) TMPV(N+1) - -! .. -! .. Local __SCALARs .. - INTEGER J, I, I1, K, I2, NI1, JL - INTEGER KL, J1 - COMPLEX(DP) ALPHA, TAUI - INTEGER KNT, IERR - REAL(DP) ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM -! .. -! .. External Subroutines .. - EXTERNAL ZAXPY - EXTERNAL ZDSCAL, ZSCAL -! .. -! .. External Functions .. - COMPLEX(DP) ZDOTC - EXTERNAL ZDOTC - REAL(DP) DLAMCH, DLAPY3, DZNRM2 - COMPLEX(DP) ZLADIV - EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV -! .. -! .. Intrinsic Functions .. - INTRINSIC DABS, DBLE, AIMAG, SIGN -! cmplx removed because preprocessed -! -! .. Executable Statements .. -! -! Quick return if possible -! - IF(N.LE.0) THEN - RETURN - END IF - - DO I = 1,N+1 - QI = (I-1)/NPROC - OW(I) = MOD((I-1),NPROC) - IF(ME .le. OW(I) ) then - IL(I) = QI + 1 - ELSE - IL(I) = QI - END IF - END DO -! -! Reduce the lower triangle of A. -! - IF (OW(1).EQ.ME) THEN - AP( IL(1), 1 ) = DBLE( AP( IL(1), 1 ) ) - END IF - - DO I = 1, N - 1 -! -! Generate elementary reflector H(i) = I - tau * v * v' -! to annihilate A(i+2:n,i) -! - IF (OW(I+1).EQ.ME) THEN - ALPHA = AP( IL(I+1), I ) - END IF - -#if defined (__PARA) - CALL BCAST_REAL( ALPHA, 2, OW(I+1), comm ) -#endif - - IF( (N-I).LE.0 ) THEN - TAUI = RZERO - ELSE - IF(OW(I+2).EQ.ME) THEN - I2 = IL(I+2) - ELSE - I2 = IL(I+2) + 1 ! I+2 - ENDIF - NI1 = NRL - I2 + 1 ! N-I-1 - - IF((N-I-1).GT.0) THEN - IF( NI1 .GT. 0 ) THEN - XNORM = DZNRM2( NI1, AP( I2, I ), 1 ) - ELSE - XNORM = 0.0_DP - END IF -#if defined __PARA - XNORM = XNORM ** 2 - CALL reduce_base_real( 1, xnorm, comm, -1 ) - XNORM = SQRT( xnorm ) -#endif - ELSE - XNORM = 0.0_DP - ENDIF - - ALPHR = DBLE( ALPHA ) - ALPHI = AIMAG( ALPHA ) - IF( XNORM.EQ.RZERO .AND. ALPHI.EQ.RZERO ) THEN - TAUI = RZERO - ELSE - BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) - SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) - RSAFMN = RONE / SAFMIN - IF( DABS( BETA ).LT.SAFMIN ) THEN - KNT = 0 - 10 CONTINUE - KNT = KNT + 1 - - IF(NI1.GT.0) THEN - CALL ZDSCAL( NI1, RSAFMN, AP( I2, I ), 1 ) - ENDIF - - BETA = BETA*RSAFMN - ALPHI = ALPHI*RSAFMN - ALPHR = ALPHR*RSAFMN - IF( DABS( BETA ).LT.SAFMIN ) GO TO 10 - - IF((N-I-1).GT.0) THEN - XNORM = DZNRM2( NI1, AP( I2, I ), 1 ) -#if defined __PARA - XNORM = XNORM ** 2 - CALL reduce_base_real( 1, xnorm, comm, -1 ) - XNORM = SQRT( XNORM ) -#endif - ELSE - XNORM = 0.0_DP - ENDIF - - ALPHA = CMPLX( ALPHR, ALPHI ) - BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) - TAUI = CMPLX( (BETA-ALPHR)/BETA, -ALPHI/BETA ) - ALPHA = ZLADIV( ONE, ALPHA-BETA ) - - IF(NI1.GT.0) THEN - CALL ZSCAL( NI1, ALPHA, AP( I2, I ), 1 ) - ENDIF - - ALPHA = BETA - DO J = 1, KNT - ALPHA = ALPHA*SAFMIN - END DO - - ELSE - - TAUI = CMPLX( (BETA-ALPHR)/BETA, -ALPHI/BETA ) - ALPHA = ZLADIV( ONE, ALPHA-BETA ) - - IF(NI1.GT.0) THEN - CALL ZSCAL( NI1, ALPHA, AP( I2, I ), 1 ) - ENDIF - - ALPHA = BETA - END IF - END IF - ENDIF -! - E( I ) = ALPHA -! - IF( TAUI.NE.ZERO ) THEN -! -! Apply H(i) from both sides to A(i+1:n,i+1:n) -! - ! ... AP( I+1, I ) = ONE - IF (OW(I+1).EQ.ME) THEN - AP( IL(I+1), I ) = ONE - END IF -! -! Compute y := tau * A * v storing y in TAU(i:n-1) -! - - ! ... broadcast A(K,I) - IF(OW(I+1).EQ.ME) THEN - I1 = IL(I+1) - ELSE - I1 = IL(I+1) + 1 ! I+2 - ENDIF - -#if defined __PARA - DO J = I+1, N - CTMPV(J) = ZERO - END DO - DO JL = I1, NRL - J = ME + (JL-1)*NPROC + 1 - CTMPV(J) = AP(JL,I) - END DO - CALL reduce_base_real_to( 2*(n - i) , ctmpv( i + 1 ), apki( i + 1 ), comm, -1 ) -#else - DO J = I+1,N - APKI(J) = AP(J,I) - ENDDO -#endif - DO J = I+1, N+1 - TAU(J-1) = ZERO - END DO - DO JL = I1, NRL - J = ME + (JL-1)*NPROC + 1 - TAU(J-1) = ZERO - DO K = I+1, J - TAU(J-1) = TAU(J-1) + TAUI * AP(JL,K) * APKI(K) - END DO - END DO - DO J = I+1, N - IF(OW(J+1).EQ.ME) THEN - J1 = IL(J+1) - ELSE - J1 = IL(J+1) + 1 ! I+2 - ENDIF - DO KL = J1, NRL - K = ME + (KL-1)*NPROC + 1 - TAU(J-1) = TAU(J-1) + TAUI * CONJG(AP(KL,J)) * APKI(K) - END DO - END DO - - -#if defined __PARA - ! ... parallel sum TAU - CALL reduce_base_real( 2*(n - i + 1), tau( i ), comm, -1 ) -#endif -! -! Compute w := y - 1/2 * tau * (y'*v) * v -! - ! ... ALPHA = -HALF*TAUI*ZDOTC(N-I,TAU(I),1,AP(I+1,I),1) - - JL = 1 - DO J = I, N - IF(OW(J+1).EQ.ME) THEN - TAUL(JL) = TAU(J) - JL = JL + 1 - END IF - END DO - IF(OW(I+1).EQ.ME) THEN - I1 = IL(I+1) - ELSE - I1 = IL(I+1) + 1 ! I+1 - ENDIF - NI1 = NRL - I1 + 1 ! N-I - IF ( NI1 > 0 ) THEN - ALPHA = -HALF*TAUI*ZDOTC(NI1,TAUL(1),1,AP(I1,I),1) - ELSE - ALPHA = 0.0_DP - END IF - -#if defined __PARA - CALL reduce_base_real( 2, alpha, comm, -1 ) -#endif - - -#if defined __PARA - IF ( NI1 > 0 ) CALL ZAXPY(NI1,ALPHA,AP(I1,I),1,TAUL(1),1) - - JL = 1 - DO J = I, N - CTMPV(J) = ZERO - IF(OW(J+1).EQ.ME) THEN - CTMPV(J) = TAUL(JL) - JL = JL + 1 - END IF - END DO - CALL reduce_base_real_to( 2*(n - i + 1) , ctmpv( i ), tau( i ), comm, -1 ) -#else - CALL ZAXPY(N-I,ALPHA,AP(I+1,I),1,TAU(I),1) -#endif - -! -! Apply the transformation as a rank-2 update: -! A := A - v * w' - w * v' -! - ! ... broadcast A(K,I) - IF(OW(I+1).EQ.ME) THEN - I1 = IL(I+1) - ELSE - I1 = IL(I+1) + 1 ! I+2 - ENDIF - -#if defined __PARA - DO J = I+1, N - CTMPV(J) = ZERO - END DO - DO JL = I1, NRL - J = ME + (JL-1)*NPROC + 1 - CTMPV(J) = AP(JL,I) - END DO - CALL reduce_base_real_to( 2*(n - i) , ctmpv( i + 1 ), apki( i + 1 ), comm, -1 ) -#else - DO J = I+1, N - APKI(J) = AP(J,I) - END DO -#endif - - DO K = I+1,N - DO JL = I1,NRL - J = ME + (JL-1)*NPROC + 1 - AP(JL,K) = AP(JL,K) - ONE * AP(JL,I) * CONJG(TAU(K-1)) - & - & CONJG(ONE) * TAU(J-1) * CONJG(APKI(K)) - END DO - END DO -! - END IF - IF(OW(I+1).EQ.ME) THEN - AP(IL(I+1),I) = E( I ) - END IF - IF(OW(I).EQ.ME) THEN - D( I ) = DBLE(AP( IL(I),I )) - END IF -#if defined __PARA - CALL BCAST_REAL(D(I),1,OW(I),comm) -#endif - TAU( I ) = TAUI - END DO - IF(OW(I).EQ.ME) THEN - D( N ) = DBLE(AP( IL(I),I )) - END IF -#if defined __PARA - CALL BCAST_REAL(D(N),1,OW(I),comm) -#endif -! - RETURN - -! -! End of ZHPTRD -! - END SUBROUTINE pzhptrd - -!==----------------------------------------------==! - - SUBROUTINE pzupgtr( n, nrl, ap, lda, tau, q, ldq, nproc, me, comm) - - USE kinds, ONLY : DP - USE io_global, ONLY : stdout -! -! Parallel MPI version of the LAPACK routine ZUPGTR -! -! Carlo Cavazzoni (carlo.cavazzoni@cineca.it) -- CINECA -! Dicember 12, 1999 -! -! REFERENCES : -! -! NUMERICAL RECIPES, THE ART OF SCIENTIFIC COMPUTING. -! W.H. PRESS, B.P. FLANNERY, S.A. TEUKOLSKY, AND W.T. VETTERLING, -! CAMBRIDGE UNIVERSITY PRESS, CAMBRIDGE. -! -! PARALLEL NUMERICAL ALGORITHMS, -! T.L. FREEMAN AND C.PHILLIPS, -! PRENTICE HALL INTERNATIONAL (1992). -! -! LAPACK routine (version 2.0) -- -! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -! Courant Institute, Argonne National Lab, and Rice University - - IMPLICIT NONE - -! -! .. __SCALAR Arguments .. - - INTEGER INFO, LDQ, N, LDA, NRL, NPROC, ME, comm -! .. -! .. Array Arguments .. - COMPLEX(DP) AP(LDA, * ), Q( LDQ, * ), TAU( * ) -! .. -! -! Purpose -! ======= -! -! PZUPGTR generates a complex unitary matrix Q which is defined as the -! product of n-1 elementary reflectors H(i) of order n, as returned by -! PZHPTRD : -! -! Q = H(1) H(2) . . . H(n-1). -! -! Arguments -! ========= -! -! N (input) INTEGER -! The order of the mglobal atrix AP. N >= 0. -! -! NRL (input) INTEGER -! The number of local rows of the matrix AP. NRL >= 0. -! -! AP (input) COMPLEX(DP) array, dimension (LDA,N) -! The vectors which define the elementary reflectors, as -! returned by PZHPTRD. -! The rows of the matrix are distributed among processors -! with blocking factor 1. -! Example for NPROC = 4 : -! ROW | PE -! 1 | 0 -! 2 | 1 -! 3 | 2 -! 4 | 3 -! 5 | 0 -! 6 | 1 -! .. | .. -! -! LDA (input) INTEGER -! Leading dimension of the local matrix AP, LDA > NRL -! -! TAU (input) COMPLEX(DP) array, dimension (N-1) -! TAU(i) must contain the __SCALAR factor of the elementary -! reflector H(i), as returned by PZHPTRD. -! -! Q (output) COMPLEX(DP) array, dimension (LDQ,N) -! The N-by-N unitary matrix Q. -! The rows of the matrix are distributed among processors -! in the same way of the matrix AP -! -! LDQ (input) INTEGER -! The leading dimension of the array Q. LDQ >= max(1,NRL). -! -! NPROC (input) INTEGER -! Number of processors -! -! ME (input) INTEGER -! Index of the local processor ( 0, 1, 2, ..., NPROC-1 ) -! -! ===================================================================== -! -! .. Parameters .. - - COMPLEX(DP) ONE, ZERO - PARAMETER ( ONE = (1.0_DP,0.0_DP), ZERO = (0.0_DP,0.0_DP) ) - - ! change the following parameters to tune the performances - ! - INTEGER, PARAMETER :: opt_zgemv = 40 - INTEGER, PARAMETER :: opt_zgerc = 40 - - INTEGER QI - INTEGER IL(N+1) - INTEGER OW(N+1) - COMPLEX(DP) CTMP - COMPLEX(DP) WORK(N+1) - -! .. -! .. Local __SCALARs .. - INTEGER :: I, IINFO, J, K, JL, KL, J1, I1, I2, NI1, L, IERR - INTEGER :: ibeg, iend, nr - INTEGER, EXTERNAL :: ldim_cyclic, lind_cyclic -! .. - -! .. Executable Statements .. -! -! Test the input arguments -! -! Quick return if possible -! - IF( N == 0 ) THEN - RETURN - END IF - - nr = ldim_cyclic( n, nproc, me ) - ! - IF( nr /= nrl ) & - CALL errore( " pzupgtr ", " inconsistent dimensions ", nrl ) - ! - ibeg = lind_cyclic( 1, n, nproc, me ) - iend = lind_cyclic( nr, n, nproc, me ) -! - DO I = 1,N+1 - QI = (I-1)/NPROC - OW(I) = MOD((I-1),NPROC) - IF(ME .le. OW(I) ) then - IL(I) = QI + 1 - ELSE - IL(I) = QI - END IF - END DO -! -! Unpack the vectors which define the elementary reflectors and -! set the first row and column of Q equal to those of the unit -! matrix -! - IF(OW(1).EQ.ME) THEN - Q( IL(1), 1 ) = ONE - DO KL = 2, NRL - Q( KL, 1 ) = ZERO - END DO - DO J = 2, N - Q( IL(1), J ) = ZERO - END DO - ELSE - DO KL = 1, NRL - Q( KL, 1 ) = ZERO - END DO - ENDIF - - DO J = 2, N - IF(OW(J+1).EQ.ME) THEN - J1 = IL(J+1) - ELSE - J1 = IL(J+1) + 1 - ENDIF - DO KL = J1, NRL - Q( KL, J ) = AP( KL, J-1 ) - END DO - END DO - - IF( N.GT.1 ) THEN -! -! Generate Q(2:n,2:n) -! - DO I = N-1, 1, -1 -! -! Apply H(i) to A(i:m,i:n) from the left -! - IF( I.LT.(N-1) ) THEN - - IF(OW(I+1).EQ.ME) THEN - Q( IL(I+1), I+1 ) = ONE - END IF -! -! Form H * C -! - IF( TAU(I).NE.ZERO ) THEN -! -! w := C' * v -! - IF(OW(I+1).EQ.ME) THEN - I1 = IL(I+1) - ELSE - I1 = IL(I+1) + 1 - ENDIF - ! - IF( N-1-I > OPT_ZGEMV ) THEN - IF( NRL-I1+1 > 0 ) THEN - CALL zgemv( 'C', NRL-I1+1, N-1-I, one, Q( I1, I+1+1 ), ldq, Q( I1, I+1 ), 1, zero, work, 1 ) - ELSE - work( 1 : N-1-I ) = 0.0_DP - END IF - ELSE - DO J = 1, N-1-I - CTMP = ZERO - DO KL = I1, NRL - CTMP = CTMP + CONJG( Q( KL, J+I+1 ) ) * Q( KL,I+1 ) - END DO - WORK(J) = CTMP - END DO - END IF - -#if defined __PARA - CALL reduce_base_real( 2*(n - 1 - i), work, comm, -1 ) -#endif - ! - ! C := C - v * w' - ! - IF( N-1-I > opt_zgerc ) THEN - IF( NRL-I1+1 > 0 ) THEN - CALL zgerc( NRL-I1+1, N-1-I, -TAU(I), Q(I1, I+1), 1, work, 1, Q( I1, 1+I+1 ), ldq ) - END IF - ELSE - DO J = 1, N-1-I - CTMP = -TAU(I) * CONJG( WORK( J ) ) - DO KL = I1, NRL - Q( KL, J+I+1 ) = Q( KL, J+I+1 ) + CTMP * Q(KL, I+1) - END DO - END DO - END IF - END IF - END IF - - IF( I.LT.(N-1) ) THEN - IF(OW(I+2).EQ.ME) THEN - I2 = IL(I+2) ! I+2 - ELSE - I2 = IL(I+2) + 1 ! local ind. of the first element > I+2 - ENDIF - NI1 = NRL - I2 + 1 ! N-I-1 - IF ( NI1 > 0 ) CALL ZSCAL( NI1, -TAU( I ), Q( I2, I+1 ), 1 ) - END IF - - IF(OW(I+1).EQ.ME) THEN - Q( IL(I+1), I+1 ) = ONE - TAU( I ) - END IF -! -! Set A(1:i-1,i) to zero -! - DO L = 1, I - 1 - IF(OW(L+1).EQ.ME) THEN - Q( IL(L+1), I+1 ) = ZERO - END IF - END DO - END DO - END IF - - - RETURN - -! -! End of ZUPGTR -! - END SUBROUTINE pzupgtr - -!==----------------------------------------------==! - - SUBROUTINE pzsteqr( compz, n, nrl, d, e, z, ldz, nproc, me, comm ) -! -! Parallel MPI version of the LAPACK routine ZHPTRD -! -! Carlo Cavazzoni (carlo.cavazzoni@cineca.it) -- CINECA -! Dicember 12, 1999 -! -! REFERENCES : -! -! NUMERICAL RECIPES, THE ART OF SCIENTIFIC COMPUTING. -! W.H. PRESS, B.P. FLANNERY, S.A. TEUKOLSKY, AND W.T. VETTERLING, -! CAMBRIDGE UNIVERSITY PRESS, CAMBRIDGE. -! -! PARALLEL NUMERICAL ALGORITHMS, -! T.L. FREEMAN AND C.PHILLIPS, -! PRENTICE HALL INTERNATIONAL (1992). -! -! LAPACK routine (version 2.0) -- -! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -! Courant Institute, Argonne National Lab, and Rice University -! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - - IMPLICIT NONE - -! .. __SCALAR Arguments .. - CHARACTER COMPZ - INTEGER LDZ, N, NRL, NPROC, ME, comm -! .. -! .. Array Arguments .. - REAL(DP) D( * ), E( * ) - COMPLEX(DP) Z( LDZ, * ) -! .. -! -! Purpose -! ======= -! -! PZSTEQR computes all eigenvalues and, optionally, eigenvectors of a -! symmetric tridiagonal matrix using the implicit QL or QR method. -! The eigenvectors of a full or band complex Hermitian matrix can also -! be found if PZHPTRD has been used to reduce this -! matrix to tridiagonal form. -! -! Arguments -! ========= -! -! COMPZ (input) CHARACTER*1 -! = 'N': Compute eigenvalues only. -! = 'V': Compute eigenvalues and eigenvectors of the original -! Hermitian matrix. On entry, Z must contain the -! unitary matrix used to reduce the original matrix -! to tridiagonal form. -! = 'I': Compute eigenvalues and eigenvectors of the -! tridiagonal matrix. Z is initialized to the identity -! matrix. -! -! N (input) INTEGER -! The order of the mglobal atrix AP. N >= 0. -! -! NRL (input) INTEGER -! The number of local rows of the matrix AP. NRL >= 0. -! -! D (input/output) DOUBLE PRECISION array, dimension (N) -! On entry, the diagonal elements of the tridiagonal matrix. -! On exit, if INFO = 0, the eigenvalues in ascending order. -! -! E (input/output) DOUBLE PRECISION array, dimension (N-1) -! On entry, the (n-1) subdiagonal elements of the tridiagonal -! matrix. -! On exit, E has been destroyed. -! -! Z (input/output) COMPLEX(DP) array, dimension (LDZ, N) -! On entry, if COMPZ = 'V', then Z contains the unitary -! matrix used in the reduction to tridiagonal form. -! On exit if COMPZ = 'V', Z contains the -! orthonormal eigenvectors of the original Hermitian matrix, -! and if COMPZ = 'I', Z contains the orthonormal eigenvectors -! of the symmetric tridiagonal matrix. -! If COMPZ = 'N', then Z is not referenced. -! The rows of the matrix are distributed among processors -! with blocking factor 1, i.e. for NPROC = 4 : -! ROW Index | Processor index owning the row -! 1 | 0 -! 2 | 1 -! 3 | 2 -! 4 | 3 -! 5 | 0 -! 6 | 1 -! .. | .. -! -! LDZ (input) INTEGER -! The leading dimension of the array Z. LDZ >= 1, and if -! eigenvectors are desired, then LDZ >= max(1,NRL). -! -! NPROC (input) INTEGER -! Number of processors -! -! ME (input) INTEGER -! Index of the local processor ( 0, 1, 2, ..., NPROC-1 ) -! -! ===================================================================== -! -! .. Parameters .. - REAL(DP) RZERO, RONE, TWO, THREE, CTEMP, STEMP - PARAMETER ( RZERO = 0.0_DP, RONE = 1.0_DP, TWO = 2.0_DP, & - & THREE = 3.0_DP ) - COMPLEX(DP) ZERO, ONE,ZTEMP - PARAMETER ( ZERO = ( 0.0_DP, 0.0_DP ), ONE = ( 1.0_DP, 0.0_DP ) ) - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) -! .. - - INTEGER :: QI, KL, INFO - INTEGER :: IL(N+1) - INTEGER :: OW(N+1) - REAL(DP) :: WORK(2*N) - REAL(DP) :: dvar(6) - - REAL(DP) t2, cclock - -! .. Local __SCALARs .. - INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, & - & LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, & - & NM1, NMAXIT, IERR - REAL(DP) ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, & - & S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST -! .. -! .. External Functions .. - LOGICAL LSAME - REAL(DP) DLAMCH, DLANST, DLAPY2 - EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 -! .. -! .. External Subroutines .. - EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA, & - & ZLASET, ZLASR, ZSWAP -! .. -! .. Intrinsic Functions .. - INTRINSIC DABS, MAX, SIGN, SQRT -! .. -! .. Executable Statements .. -! -! Test the input parameters. -! - INFO = 0 - - t2 = cclock() - -! DEBUG START -! if( n > 400 ) then -! write( 4000 + me, * ) LDZ, N, NRL, NPROC, ME, comm -! do i = 1, n -! write( 4000 + me, * ) d( i ) -! end do -! do i = 1, n -! write( 4000 + me, * ) e( i ) -! end do -! do j = 1, n -! do i = 1, nrl -! write( 4000 + me, * ) z( i, j ) -! end do -! end do -! close( 4000 + me ) -! call mpi_barrier( comm, i ) -! stop 'qui' -! end if -! DEBUG END - -! - IF( LSAME( COMPZ, 'N' ) ) THEN - ICOMPZ = 0 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ICOMPZ = 2 - ELSE - ICOMPZ = -1 - END IF - IF( ICOMPZ.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( (LDZ.LT.1) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX(1,NRL) ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZSTEQR', -INFO ) - RETURN - END IF -! -! Quick return if possible -! - IF(N.LE.0) THEN - RETURN - END IF -! - DO I = 1,N+1 - QI = (I-1)/NPROC - OW(I) = MOD((I-1),NPROC) - IF(ME .le. OW(I) ) then - IL(I) = QI + 1 - ELSE - IL(I) = QI - END IF - END DO - - IF( N.EQ.1 ) THEN - IF( ICOMPZ.EQ.2 .AND. OW(1).EQ.ME ) Z( IL(1), 1 ) = ONE - RETURN - END IF -! -! Determine the unit roundoff and over/underflow thresholds. -! We ensure that all procs have the same data! -! - EPS = DLAMCH( 'E' ) - EPS2 = EPS**2 - SAFMIN = DLAMCH( 'S' ) - SAFMAX = RONE / SAFMIN - SSFMAX = SQRT( SAFMAX ) / THREE - SSFMIN = SQRT( SAFMIN ) / EPS2 - ! - dvar(1) = EPS - dvar(2) = EPS2 - dvar(3) = SAFMIN - dvar(4) = SAFMAX - dvar(5) = SSFMAX - dvar(6) = SSFMIN - ! - CALL BCAST_REAL( dvar, 6, 0, comm ) - ! - EPS = dvar(1) - EPS2 = dvar(2) - SAFMIN = dvar(3) - SAFMAX = dvar(4) - SSFMAX = dvar(5) - SSFMIN = dvar(6) -! -! Compute the eigenvalues and eigenvectors of the tridiagonal -! matrix. -! - IF( ICOMPZ.EQ.2 ) THEN - CALL ZLASET( 'Full', NRL, N, ZERO, ZERO, Z, LDZ ) - DO J = 1, N - IF(OW(J).EQ.ME) THEN - Z( IL(J), J ) = ONE - END IF - END DO - END IF -! - NMAXIT = N*MAXIT - JTOT = 0 -! -! Determine where the matrix splits and choose QL or QR iteration -! for each block, according to whether top or bottom diagonal -! element is smaller. -! - L1 = 1 - NM1 = N - 1 -! - 10 CONTINUE - - IF( L1 .GT. N ) GO TO 160 - - IF( L1 .GT. 1 ) E( L1-1 ) = RZERO - - IF( me == 0 ) THEN - - IF( L1.LE.NM1 ) THEN - DO M = L1, NM1 - TST = DABS( E( M ) ) - IF( TST .EQ. RZERO ) GO TO 30 - IF( TST .LE. ( SQRT(DABS(D(M)))*SQRT(DABS(D(M+1))) ) * EPS ) THEN - E( M ) = RZERO - GO TO 30 - END IF - END DO - END IF - M = N -! - 30 CONTINUE - - END IF - - CALL BCAST_REAL( e( l1 ), nm1-l1+1, 0, comm ) - CALL BCAST_INTEGER( m, 1, 0, comm ) - - - L = L1 - LSV = L - LEND = M - LENDSV = LEND - L1 = M + 1 - IF( LEND.EQ.L ) GO TO 10 -! -! Scale submatrix in rows and columns L to LEND -! - ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) - ISCALE = 0 - IF( ANORM.EQ.RZERO ) GO TO 10 - IF( ANORM.GT.SSFMAX ) THEN - ISCALE = 1 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, INFO ) - ELSE IF( ANORM.LT.SSFMIN ) THEN - ISCALE = 2 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, INFO ) - END IF -! -! Choose between QL and QR iteration -! - IF( DABS( D( LEND ) ).LT.DABS( D( L ) ) ) THEN - LEND = LSV - L = LENDSV - END IF -! - IF( LEND.GT.L ) THEN -! -! QL Iteration -! -! Look for small subdiagonal element. -! - 40 CONTINUE - - IF( me == 0 ) THEN - - IF( L.NE.LEND ) THEN - LENDM1 = LEND - 1 - DO M = L, LENDM1 - TST = DABS( E( M ) )**2 - IF( TST.LE.( EPS2*DABS(D(M)) )*DABS(D(M+1))+ SAFMIN )GO TO 60 - END DO - END IF -! - M = LEND -! - 60 CONTINUE - - END IF - - CALL BCAST_INTEGER( m, 1, 0, comm ) - - IF( M.LT.LEND ) E( M ) = RZERO - P = D( L ) - IF( M.EQ.L ) THEN -! -! Eigenvalue found. -! - D( L ) = P - L = L + 1 - IF( L.LE.LEND ) GO TO 40 - GO TO 140 - END IF -! -! If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -! to compute its eigensystem. -! - IF( M.EQ.L+1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) - WORK( L ) = C - WORK( N-1+L ) = S - CTEMP = WORK( L ) - STEMP = WORK( N-1+L ) - IF( ( CTEMP.NE.RONE ) .OR. ( STEMP.NE.RZERO ) ) THEN - DO KL = 1, NRL - ZTEMP = Z( KL, 1+L ) - Z( KL, 1+L ) = CTEMP*ZTEMP - STEMP*Z( KL, L ) - Z( KL, L ) = STEMP*ZTEMP + CTEMP*Z( KL, L ) - END DO - END IF - ELSE - CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) - END IF - D( L ) = RT1 - D( L+1 ) = RT2 - E( L ) = RZERO - L = L + 2 - IF( L.LE.LEND ) GO TO 40 - GO TO 140 - END IF -! - IF( JTOT.EQ.NMAXIT ) GO TO 140 - JTOT = JTOT + 1 -! -! Form shift. -! - ! - ! iteration is performed on one processor and results broadcast - ! to all others to prevent potential problems if all processors - ! do not behave in exactly the same way (even with the same data!) - ! - if ( me == 0 ) then - - G = ( D( L+1 )-P ) / ( TWO*E( L ) ) - R = DLAPY2( G, RONE ) - G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) -! - S = RONE - C = RONE - P = RZERO -! -! Inner loop -! - MM1 = M - 1 - DO I = MM1, L, -1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M-1 ) E( I+1 ) = R - G = D( I+1 ) - P - R = ( D( I )-G )*S + TWO*C*B - P = S*R - D( I+1 ) = G + P - G = C*R - B -! -! If eigenvectors are desired, then save rotations. -! - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = -S - END IF - END DO - D( L ) = D( L ) - P - E( L ) = G - END IF -#if defined __PARA - CALL BCAST_REAL( d( L ), m - l + 1, 0, comm ) - CALL BCAST_REAL( e( L ), m - l + 1, 0, comm ) -#endif -! -! If eigenvectors are desired, then apply saved rotations. -! - IF( ICOMPZ.GT.0 ) THEN -#if defined __PARA - CALL BCAST_REAL( work, 2*n, 0, comm ) -#endif - DO J = M - L + 1 - 1, 1, -1 - CTEMP = WORK( L + J -1) - STEMP = WORK( N-1+L + J-1) - IF( ( CTEMP.NE.RONE ) .OR. ( STEMP.NE.RZERO ) ) THEN - DO KL = 1, NRL - ZTEMP = Z( KL, J+1+L-1 ) - Z( KL, J+1+L-1 ) = CTEMP*ZTEMP - STEMP*Z( KL, J+L-1 ) - Z( KL, J+L-1 ) = STEMP*ZTEMP + CTEMP*Z( KL, J+L-1 ) - END DO - END IF - END DO - END IF -! - GO TO 40 -! - ELSE -! -! QR Iteration -! -! Look for small superdiagonal element. -! - 90 CONTINUE - - IF( me == 0 ) THEN - - IF( L.NE.LEND ) THEN - LENDP1 = LEND + 1 - DO 100 M = L, LENDP1, -1 - TST = DABS( E( M-1 ) )**2 - IF( TST.LE.(EPS2*DABS(D(M)))*DABS(D(M-1))+ SAFMIN )GO TO 110 - 100 CONTINUE - END IF -! - M = LEND -! - 110 CONTINUE - - END IF - - CALL BCAST_INTEGER( m, 1, 0, comm ) - - IF( M.GT.LEND ) E( M-1 ) = RZERO - P = D( L ) - IF( M.EQ.L ) THEN -! -! Eigenvalue found. -! - D( L ) = P - L = L - 1 - IF( L.GE.LEND ) GO TO 90 - GO TO 140 - END IF -! -! If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -! to compute its eigensystem. -! - IF( M.EQ.L-1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) - WORK( M ) = C - WORK( N-1+M ) = S - CTEMP = WORK( M ) - STEMP = WORK( N-1+M ) - IF( ( CTEMP.NE.RONE ) .OR. ( STEMP.NE.RZERO ) ) THEN - DO KL = 1, NRL - ZTEMP = Z( KL, L) - Z( KL, L ) = CTEMP*ZTEMP - STEMP*Z( KL, L-1 ) - Z( KL, L-1 ) = STEMP*ZTEMP + CTEMP*Z( KL, L-1 ) - END DO - END IF - ELSE - CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) - END IF - D( L-1 ) = RT1 - D( L ) = RT2 - E( L-1 ) = RZERO - L = L - 2 - IF( L.GE.LEND ) GO TO 90 - GO TO 140 - END IF -! - IF( JTOT.EQ.NMAXIT ) GO TO 140 - JTOT = JTOT + 1 -! -! Form shift. -! - ! - ! iteration is performed on one processor and results broadcast - ! to all others to prevent potential problems if all processors - ! do not behave in exactly the same way (even with the same data!) - ! - if ( me == 0 ) then - - G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) - R = DLAPY2( G, RONE ) - G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) -! - S = RONE - C = RONE - P = RZERO -! -! Inner loop -! - LM1 = L - 1 - DO I = M, LM1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M ) E( I-1 ) = R - G = D( I ) - P - R = ( D( I+1 )-G )*S + TWO*C*B - P = S*R - D( I ) = G + P - G = C*R - B -! -! If eigenvectors are desired, then save rotations. -! - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = S - END IF - END DO - D( L ) = D( L ) - P - E( LM1 ) = G - END IF -#if defined __PARA - CALL BCAST_REAL( d(M), L - M + 1, 0, comm) - CALL BCAST_REAL( e(M), L - M + 1, 0, comm ) -#endif -! -! If eigenvectors are desired, then apply saved rotations. -! - IF( ICOMPZ.GT.0 ) THEN -#if defined __PARA - CALL BCAST_REAL(work,2*n,0,comm) -#endif - DO J = 1, L - M - CTEMP = WORK( M+J-1 ) - STEMP = WORK( N-1+M+J-1 ) - IF( ( CTEMP.NE.RONE ) .OR. ( STEMP.NE.RZERO ) ) THEN - DO KL = 1, NRL - ZTEMP = Z( KL, J+M ) - Z( KL, J+M ) = CTEMP*ZTEMP - STEMP*Z(KL, J+M-1) - Z( KL, J+M-1 ) = STEMP*ZTEMP + CTEMP*Z(KL, J+M-1) - END DO - END IF - END DO - END IF -! - GO TO 90 -! - END IF -! -! Undo scaling if necessary -! - 140 CONTINUE - - IF( ISCALE.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, & - & D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), & - & N, INFO ) - ELSE IF( ISCALE.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, & - & D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), & - & N, INFO ) - END IF -! -! Check for no convergence to an eigenvalue after a total -! of N*MAXIT iterations. -! - IF( JTOT .EQ. NMAXIT ) THEN - DO 150 I = 1, N - 1 - IF( E( I ) .NE. RZERO ) INFO = INFO + 1 - 150 CONTINUE - WRITE(6,*) 'WARNING pzsteqr, convergence not achieved INFO = ', INFO - RETURN - END IF - GO TO 10 -! -! Order eigenvalues and eigenvectors. -! - 160 CONTINUE - - IF( ICOMPZ.EQ.0 ) THEN -! -! Use Quick Sort -! - CALL DLASRT( 'I', N, D, INFO ) -! - ELSE -! -! Use Selection Sort to minimize swaps of eigenvectors -! - DO 180 II = 2, N - I = II - 1 - K = I - P = D( I ) - DO 170 J = II, N - IF( D( J ).LT.P ) THEN - K = J - P = D( J ) - END IF - 170 CONTINUE - IF( K.NE.I ) THEN - D( K ) = D( I ) - D( I ) = P - CALL ZSWAP( NRL, Z( 1, I ), 1, Z( 1, K ), 1 ) - END IF - 180 CONTINUE - END IF - - RETURN -! -! End of ZSTEQR -! - END SUBROUTINE pzsteqr - -!==----------------------------------------------==! - - SUBROUTINE zhpev_drv( JOBZ, UPLO, N, AP, W, Z, LDZ ) - - USE kinds, ONLY : DP - USE io_global, ONLY : stdout - - IMPLICIT NONE - - CHARACTER :: JOBZ, UPLO - INTEGER :: IOPT, INFO, LDZ, N - COMPLEX(DP) :: AP( * ), Z( LDZ, * ) - REAL(DP) :: W( * ) - REAL(DP), ALLOCATABLE :: RWORK(:) - COMPLEX(DP), ALLOCATABLE :: ZWORK(:) - -#if defined __ESSL - IOPT = 0 - IF((JOBZ .EQ. 'V') .OR. (JOBZ .EQ. 'v') ) iopt = iopt + 1 - IF((UPLO .EQ. 'U') .OR. (UPLO .EQ. 'u') ) iopt = iopt + 20 - ALLOCATE( rwork( 4*n ) ) - CALL ZHPEV(IOPT, ap, w, z, ldz, n, rwork, 4*n) - DEALLOCATE( rwork ) -#else - ALLOCATE( rwork( MAX(1, 3*n-2) ), zwork( MAX(1, 2*n-1)) ) - CALL ZHPEV(jobz, uplo, n, ap, w, z, ldz, zwork, rwork, INFO) - DEALLOCATE( rwork, zwork ) - IF( info .NE. 0 ) THEN - CALL errore( ' dspev_drv ', ' diagonalization failed ',info ) - END IF -#endif - RETURN - END SUBROUTINE zhpev_drv - -!==----------------------------------------------==! - - SUBROUTINE zgeev_drv( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR ) - ! - USE kinds, ONLY : DP - IMPLICIT NONE - CHARACTER :: JOBVL, JOBVR - INTEGER :: IOPT, INFO, LDA, LDVR, LDVL, N - COMPLEX(DP) :: VR( LDVR, * ), VL( LDVL , * ), A( LDA, * ) - REAL(DP) :: WI( * ), WR( * ) - ! - COMPLEX(DP), ALLOCATABLE :: WORK(:), WW(:) - REAL(DP), ALLOCATABLE :: RWORK(:) - INTEGER :: LWORK, i - - IF( n < 1 ) RETURN - - LWORK=3*n - ALLOCATE( work( LWORK ), rwork(2*n), ww(n) ) - - CALL ZGEEV(jobvl, jobvr, n, a, lda, ww, vl, ldvl, vr, ldvr, work, lwork, rwork, info) - IF( info .NE. 0 ) THEN - CALL errore( ' dgeev_drv ', ' diagonalization failed ',info ) - END IF - - DO i=1,n - wr(i) = DBLE(ww(i)) - wi(i) = AIMAG(ww(i)) - ENDDO - - DEALLOCATE( work, rwork, ww ) - - RETURN - ! - END SUBROUTINE zgeev_drv - -!==----------------------------------------------==! - - SUBROUTINE pzhpev_drv( jobz, ap, lda, w, z, ldz, & - nrl, n, nproc, mpime, comm ) - - USE kinds, ONLY : DP - - IMPLICIT NONE - CHARACTER :: JOBZ - INTEGER, INTENT(IN) :: lda, ldz, nrl, n, nproc, mpime - INTEGER, INTENT(IN) :: comm - COMPLEX(DP) :: ap( lda, * ), z( ldz, * ) - REAL(DP) :: w( * ) - REAL(DP), ALLOCATABLE :: rwork( : ) - COMPLEX(DP), ALLOCATABLE :: cwork( : ) - REAL(DP) :: t1, t2, cclock - ! - ALLOCATE( rwork( n ) ) - ALLOCATE( cwork( n ) ) - ! - CALL pzhptrd( n, nrl, ap, lda, w, rwork, cwork, nproc, mpime, comm) - - IF( jobz == 'V' .OR. jobz == 'v' ) THEN - CALL pzupgtr( n, nrl, ap, lda, cwork, z, ldz, nproc, mpime, comm) - END IF - - CALL pzsteqr( jobz, n, nrl, w, rwork, z, ldz, nproc, mpime, comm) - - DEALLOCATE( cwork ) - DEALLOCATE( rwork ) - - RETURN - END SUBROUTINE pzhpev_drv - - -!==----------------------------------------------==! - - -#if defined __SCALAPACK - - - SUBROUTINE pzheevd_drv( tv, n, nb, h, w, ortho_cntx ) - - USE kinds, ONLY : DP - - IMPLICIT NONE - - LOGICAL, INTENT(IN) :: tv - ! if tv is true compute eigenvalues and eigenvectors (not used) - INTEGER, INTENT(IN) :: nb, n, ortho_cntx - ! nb = block size, n = matrix size, ortho_cntx = BLACS context - COMPLEX(DP) :: h(:,:) - ! input: h = matrix to be diagonalized - ! output: h = eigenvectors - REAL(DP) :: w(:) - ! output: w = eigenvalues - - COMPLEX(DP) :: ztmp( 4 ) - REAL(DP) :: rtmp( 4 ) - INTEGER :: itmp( 4 ) - COMPLEX(DP), ALLOCATABLE :: work(:) - COMPLEX(DP), ALLOCATABLE :: v(:,:) - REAL(DP), ALLOCATABLE :: rwork(:) - INTEGER, ALLOCATABLE :: iwork(:) - INTEGER :: LWORK, LRWORK, LIWORK - INTEGER :: desch( 10 ), info - CHARACTER :: jobv - ! - IF( tv ) THEN - ALLOCATE( v( SIZE( h, 1 ), SIZE( h, 2 ) ) ) - jobv = 'V' - ELSE - CALL errore( ' pzheevd_drv ', ' pzheevd does not compute eigenvalue only ', ABS( info ) ) - END IF - - CALL descinit( desch, n, n, nb, nb, 0, 0, ortho_cntx, SIZE( h, 1 ) , info ) - - lwork = -1 - lrwork = -1 - liwork = -1 - CALL PZHEEVD( 'V', 'L', n, h, 1, 1, desch, w, v, 1, 1, & - desch, ztmp, LWORK, rtmp, LRWORK, itmp, LIWORK, INFO ) - - IF( info /= 0 ) CALL errore( ' cdiaghg ', ' PZHEEVD ', ABS( info ) ) - - lwork = INT( REAL(ztmp(1)) ) + 1 - lrwork = INT( rtmp(1) ) + 1 - liwork = itmp(1) + 1 - - ALLOCATE( work( lwork ) ) - ALLOCATE( rwork( lrwork ) ) - ALLOCATE( iwork( liwork ) ) - - CALL PZHEEVD( 'V', 'L', n, h, 1, 1, desch, w, v, 1, 1, & - desch, work, LWORK, rwork, LRWORK, iwork, LIWORK, INFO ) - - IF( info /= 0 ) CALL errore( ' cdiaghg ', ' PZHEEVD ', ABS( info ) ) - - IF( tv ) h = v - - DEALLOCATE( work ) - DEALLOCATE( rwork ) - DEALLOCATE( iwork ) - IF( ALLOCATED( v ) ) DEALLOCATE( v ) - RETURN - END SUBROUTINE pzheevd_drv - - -#endif - -END MODULE zhpev_module diff --git a/quantum_espresso/kcp/clib/Makefile b/quantum_espresso/kcp/clib/Makefile deleted file mode 100644 index 61d18406b..000000000 --- a/quantum_espresso/kcp/clib/Makefile +++ /dev/null @@ -1,27 +0,0 @@ -# Makefile for clib - -include ../make.sys - -OBJS = \ -stack.o \ -c_mkdir.o \ -cptimer.o \ -eval_infix.o \ -fft_stick.o \ -indici.o \ -memstat.o \ -qsort.o - -all : clib.a - -clib.a : $(OBJS) - $(AR) $(ARFLAGS) $@ $? - $(RANLIB) $@ - -source : - co -l $(OBJS:.o=.c) - -clean : - - rm -f clib.a *.o *.mod *.i core* - -include make.depend diff --git a/quantum_espresso/kcp/clib/c_mkdir.c b/quantum_espresso/kcp/clib/c_mkdir.c deleted file mode 100644 index 7e2761bab..000000000 --- a/quantum_espresso/kcp/clib/c_mkdir.c +++ /dev/null @@ -1,100 +0,0 @@ -/* - Copyright (C) 2003-2007 Quantum-Espresso group - This file is distributed under the terms of the - GNU General Public License. See the file `License' - in the root directory of the present distribution, - or http://www.gnu.org/copyleft/gpl.txt . -*/ - -#include -#include -#include -#include -#include -#include -#include -#include "c_defs.h" - -static void fatal ( const char * msg ) -{ - - fprintf( stderr , "fatal: %s" , *msg ? msg : "Oops!" ) ; - exit( -1 ) ; - -} /* fatal */ - - -static void * xcmalloc ( size_t size ) -{ - - register void * ptr = malloc( size ) ; - - if ( ptr == NULL ) - fatal( "c_mkdir: virtual memory exhausted" ) ; - else - memset( ptr , 0 , size ) ; - - return ptr ; - -} /* xcmalloc */ - - -int F77_FUNC_(c_mkdir_int,C_MKDIR_INT)( const int * dirname , const int * length ) -{ - - int i, retval = -1 ; - - mode_t mode = 0777 ; - - char * ldir = ( char * ) xcmalloc( (*length) + 1 ) ; - - for( i = 0; i < * length; i++ ) ldir[ i ] = (char)dirname[ i ]; - - ldir[*length] = '\0' ; /* memset() in xcmalloc() already do this */ - - retval = mkdir( ldir , mode ) ; - - if ( retval == -1 && errno != EEXIST ) - fprintf( stderr , "mkdir fail: [%d] %s\n" , errno , strerror( errno ) ) ; - - free( ldir ) ; - - return retval ; - -} /* c_mkdir */ - -/* call from fortran as - ios = c_remame ( integer old-file-name(:), integer old-file-name, & - integer new-file-name(:), integer new-file-name ) - renames file old-file-name into new-file-name (don't try this on open files!) - ios should return 0 if everything is ok, -1 otherwise. - Written by PG by imitating "c_mkdir" without really understanding it */ - -int F77_FUNC_(c_rename_int,C_RENAME_INT)( const int * oldname, const int * oldlength , - const int * newname, const int * newlength ) -{ - - int i, retval = -1 ; - - char * oldname_ = ( char * ) xcmalloc( (*oldlength) + 1 ) ; - char * newname_ = ( char * ) xcmalloc( (*newlength) + 1 ) ; - - for( i = 0; i < * oldlength; i++ ) oldname_[ i ] = (char)oldname[ i ]; - for( i = 0; i < * newlength; i++ ) newname_[ i ] = (char)newname[ i ]; - - oldname_[*oldlength] = '\0' ; - newname_[*newlength] = '\0' ; - - retval = rename( oldname_, newname_ ) ; - - if ( retval == -1 ) - fprintf( stderr , "mv fail: [%d] %s\n" , errno , strerror( errno ) ) ; - - free( oldname_ ) ; - free( newname_ ) ; - - return retval ; - -} /* c_rename */ - -/* EOF */ diff --git a/quantum_espresso/kcp/clib/cptimer.c b/quantum_espresso/kcp/clib/cptimer.c deleted file mode 100644 index 49fd21005..000000000 --- a/quantum_espresso/kcp/clib/cptimer.c +++ /dev/null @@ -1,42 +0,0 @@ -/* - Copyright (C) 2002-2006 Quantum-Espresso group - This file is distributed under the terms of the - GNU General Public License. See the file `License' - in the root directory of the present distribution, - or http://www.gnu.org/copyleft/gpl.txt . -*/ - -#include -#include -#include - -#include "c_defs.h" - -double F77_FUNC(cclock,CCLOCK)() - -/* Return the second elapsed since Epoch (00:00:00 UTC, January 1, 1970) -*/ - -{ - - struct timeval tmp; - double sec; - gettimeofday( &tmp, (struct timezone *)0 ); - sec = tmp.tv_sec + ((double)tmp.tv_usec)/1000000.0; - return sec; - -} - -double F77_FUNC(scnds,SCNDS) ( ) - -/* Return the cpu time associated to the current process -*/ - -{ - static struct rusage T; - - getrusage(RUSAGE_SELF, &T); - - return ((double)T.ru_utime.tv_sec + ((double)T.ru_utime.tv_usec)/1000000.0); -} - diff --git a/quantum_espresso/kcp/clib/eval_infix.c b/quantum_espresso/kcp/clib/eval_infix.c deleted file mode 100644 index fdbcd0643..000000000 --- a/quantum_espresso/kcp/clib/eval_infix.c +++ /dev/null @@ -1,730 +0,0 @@ -// Copyright (C) 2008 by www.guidealgoritmi.it -// Author: Vincenzo Lo Cicero. -// e-mail: vincenzolocicero@guidealgoritmi.it -// http://www.guidealgoritmi.it - -/* - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License along - with this program; if not, write to the Free Software Foundation, Inc., - 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -*/ - - -/* - -This version of EvalInfix includes a wrapper to allow calls from -fortran code (written by Lorenzo Paulatto, 2008). - -An example F90 program follows: - -PROGRAM use_ex - implicit none - character(len=256) :: expr - integer :: ierr - real(8) :: result - real(8),external :: eval_infix - - expr = "3 * 3" - result = eval_infix(ierr, expr) - if (ierr == 0) then - write(*,*) result, expr - else - stop - endif -END PROGRAM - -*/ - -#include -#include -#include -#include -#include - -#include "c_defs.h" - -/* #pragma warning( disable : 4996 ) */ - -#define MAXOP 100 /* dimensione massima di un operando o operatore */ -#define MAXSTACK 100 /* dimensione massima dello stack */ - - -typedef int BOOL; - -#ifndef FALSE -#define FALSE 0 -#endif - -#ifndef TRUE -#define TRUE 1 -#endif - - -typedef enum tagTokenType -{ - EOL, UNKNOWN, VALUE, OPAREN, CPAREN, EXP, UPLUS, UMINUS, MULT, DIV, PLUS, MINUS -}TokenTypeEnum; - -typedef struct tagToken -{ - TokenTypeEnum Type; - char str[54]; - double Value; -}Token; - -struct Precedence -{ - int inputSymbol; - int topOfStack; -} PREC_TABLE [ ] = -{ - { 0, -1 }, {-1, -1}, { 0, 0 }, // EOL, UNKNOWN, VALUE - { 100, 0 }, { 0, 99 }, // OPAREN, CPAREN - { 6, 5 }, {6, 5}, {6, 5}, // EXP, UPLUS, UMINUS - { 3, 4 }, { 3, 4 }, // MULT, DIV - { 1, 2 }, { 1, 2 } // PLUS, MINUS -}; - -int nNextPos = 0; -TokenTypeEnum PreviousTokenType = EOL; - -int sp_op = 0; -Token stack_op[MAXSTACK]; /* stack degli operatori */ - -/* Operazioni sullo stack degli operatori */ -void push_op(Token, char *); -Token pop_op(char *); -Token top_op(char *); -BOOL is_empty_op(); - -int sp_val = 0; -double stack_val[MAXSTACK]; /* stack degli operandi */ - -/* Operazioni sullo stack degli operandi */ -void push_val(double, char *); -double pop_val(char *); -double top_val(char *); -BOOL is_empty_val(); - -TokenTypeEnum GetNextToken(const char *str, Token *token, BOOL bIsInfix); - -double BinaryOperation(double left, double right, char op, char *strError); -//BOOL InfixToPostfix(const char *strInfix, char *strPostfix, char *strError); -//double EvalPostfix(const char *strExpression, char *strError); -double EvalInfix(const char *strExpression, char *strError); - -/* inserisce un elemento nello stack degli operatori */ -/* In caso di errore viene riportato un messaggio nel parametro strError */ -/* In assenza di errori, il parametro strError è impostato ala stringa vuota = "" */ -void push_op(Token Tok, char *strError) -{ - strcpy(strError, ""); - - if (sp_op < MAXSTACK) - stack_op[sp_op++] = Tok; - else - sprintf(strError, "Error: operators stack is full, cannot add more elements %c\n", Tok.str[0]); -} - -/* Estrae e ritorna un elemento dallo stack degli operatori */ -/* In caso di errore viene riportato un messaggio nel parametro strError */ -/* In assenza di errori, il parametro strError è impostato ala stringa vuota = "" */ -Token pop_op(char *strError) -{ - Token tok_temp; - - strcpy(strError, ""); - - if (sp_op > 0) - return stack_op[--sp_op]; - else - { - sprintf(strError, "Error: missing operator\n"); - strcpy(tok_temp.str, ""); - tok_temp.Type = UNKNOWN; - return tok_temp; - } -} - -/* Ritorna il valore in cima allo stack degli operatori senza estrarlo */ -/* In caso di errore viene riportato un messaggio nel parametro strError */ -/* In assenza di errori, il parametro strError è impostato ala stringa vuota = "" */ -Token top_op(char *strError) -{ - Token tok_temp; - - strcpy(strError, ""); - - if (sp_op >= 0) - return stack_op[sp_op - 1]; - else - { - sprintf(strError, "Error: missing operator\n"); - strcpy(tok_temp.str, ""); - tok_temp.Type = UNKNOWN; - return tok_temp; - } -} - -/* Ritorna un valore diverso da zero se lo stack degli operatori è vuoto */ -BOOL is_empty_op() -{ - if ( sp_op > 0 ) - return FALSE; - else - return TRUE; -} - -/* Inserisce un elemento nello stack degli operandi */ -/* In caso di errore viene riportato un messaggio nel parametro strError */ -/* In assenza di errori, il parametro strError è impostato ala stringa vuota = "" */ -void push_val(double c, char *strError) -{ - strcpy(strError, ""); - - if (sp_val < MAXSTACK) - stack_val[sp_val++] = c; - else - sprintf(strError, "Error: values stack is full: cannot add more elements %g\n", c); -} - -/* Estrae e ritorna un elemento dallo stack degli operandi */ -/* In caso di errore viene riportato un messaggio nel parametro strError */ -/* In assenza di errori, il parametro strError è impostato ala stringa vuota = "" */ -double pop_val(char *strError) -{ - strcpy(strError, ""); - - if (sp_val > 0) - return stack_val[--sp_val]; - else - { - sprintf(strError, "Error: missing operand\n"); - return 0; - } -} - -/* ritorna il valore in cima allo stack degli operandi senza estrarlo */ -/* In caso di errore viene riportato un messaggio nel parametro strError */ -/* In assenza di errori, il parametro strError è impostato ala stringa vuota = "" */ -double top_val(char *strError) -{ - strcpy(strError, ""); - - if (sp_val > 0) - return stack_val[sp_val - 1]; - else - { - sprintf(strError, "Error top: values stack is empty\n"); - return 0; - } -} - -/* ritorna un valore diverso da zero se lo stack degli operandi è vuoto */ -BOOL is_empty_val() -{ - if ( sp_val > 0 ) - return FALSE; - else - return TRUE; -} -/* ritorna un valore diverso da zero per "e", "E", "d o "D", o se il carattere prima lo era */ -BOOL is_scientific(char strChar) -{ - BOOL static was_scientific = FALSE; - - if (was_scientific) - { - was_scientific = FALSE; - return TRUE; - } - else if (strChar == 'e' || strChar == 'E'|| - strChar == 'd' || strChar == 'D') - { - was_scientific = TRUE; - return TRUE; - } - else if ( isdigit(strChar) ){ - was_scientific = FALSE; - return TRUE; - } - else - { - was_scientific = FALSE; - return FALSE; - } -} - - -/* Analizzatore lessicale */ -TokenTypeEnum GetNextToken(const char *str, Token *token, BOOL bIsInfix) -{ - int i; - char strToken[MAXOP]; - - while ( 1 ) - { - while ( str[nNextPos++] == ' ' ) - ; - --nNextPos; - - if ( str[nNextPos] == '\0' ) - { - token->Type = EOL; - strcpy(token->str, "\n"); - nNextPos = 0; - PreviousTokenType = EOL; - return EOL; - } - else if ( is_scientific(str[nNextPos]) ) - { - i = 0; - while ( is_scientific(strToken[i++] = str[nNextPos++]) ) - if (strToken[i-1] == 'd' || strToken[i-1] == 'D') strToken[i-1] = 'e'; - if ( str[nNextPos - 1] == '.' ) - { - while ( is_scientific(strToken[i++] = str[nNextPos++]) ) - if (strToken[i-1] == 'd' || strToken[i-1] == 'D') strToken[i-1] = 'e'; - strToken[i - 1] = '\0'; - --nNextPos; - token->Type = VALUE; - strcpy(token->str, strToken); - token->Value = atof(strToken); - return VALUE; - } - else - { - strToken[i - 1] = '\0'; - --nNextPos; - token->Type = VALUE; - strcpy(token->str, strToken); - token->Value = atof(strToken); - return VALUE; - } - } - else if ( str[nNextPos] == '.' ) - { - i = 0; - strToken[i++] = str[nNextPos++]; - while ( is_scientific(strToken[i++] = str[nNextPos++]) ) - if (strToken[i-1] == 'd' || strToken[i-1] == 'D') strToken[i-1] = 'e'; - strToken[i - 1] = '\0'; - --nNextPos; - token->Type = VALUE; - strcpy(token->str, strToken); - token->Value = atof(strToken); - return VALUE; - } - else if ( str[nNextPos] == '(' ) - { - token->Type = OPAREN; - strcpy(token->str, "("); - ++nNextPos; - return OPAREN; - } - else if ( str[nNextPos] == ')' ) - { - token->Type = CPAREN; - strcpy(token->str, ")"); - ++nNextPos; - return CPAREN; - } - else if ( str[nNextPos] == '+' ) - { - strcpy(token->str, "+"); - ++nNextPos; - if ( !bIsInfix ) - { - token->Type = PLUS; - return PLUS; - } - else - { - if ( PreviousTokenType == CPAREN || PreviousTokenType == VALUE ) - { - token->Type = PLUS; - return PLUS; - } - else - { - token->Type = UPLUS; - return UPLUS; - } - } - } - else if ( str[nNextPos] == '-' ) - { - strcpy(token->str, "-"); - ++nNextPos; - if ( !bIsInfix ) - { - token->Type = MINUS; - return MINUS; - } - else - { - if ( PreviousTokenType == CPAREN || PreviousTokenType == VALUE ) - { - token->Type = MINUS; - return MINUS; - } - else - { - token->Type = UMINUS; - return UMINUS; - } - } - } - else if ( str[nNextPos] == '~' ) - { - strcpy(token->str, "~"); - ++nNextPos; - if ( !bIsInfix ) - { - token->Type = UMINUS; - return UMINUS; - } - else - { - token->Type = UNKNOWN; - return UNKNOWN; - } - } - else if ( str[nNextPos] == '*' ) - { - token->Type = MULT; - strcpy(token->str, "*"); - ++nNextPos; - return MULT; - } - else if ( str[nNextPos] == '/' ) - { - token->Type = DIV; - strcpy(token->str, "/"); - ++nNextPos; - return DIV; - } - else if ( str[nNextPos] == '^' ) - { - token->Type = EXP; - strcpy(token->str, "^"); - ++nNextPos; - return EXP; - } - else - { - token->Type = UNKNOWN; - token->str[0] = str[nNextPos]; - token->str[1] = '\0'; - ++nNextPos; - return UNKNOWN; - } - } - - return EOL; -} - -/* Ritorna il risultato di un'operazione binaria */ -/* In caso di errore viene riportato un messaggio nel parametro strError */ -/* In assenza di errori, il parametro strError è impostato ala stringa vuota = "" */ -double BinaryOperation(double left, double right, char op, char* strError) -{ - strcpy(strError, ""); - - switch ( op ) - { - case '-': - return left - right; - case '+': - return left + right; - case '*': - return left * right; - case '/': - if ( right == 0 ) - { - sprintf(strError, "Error: division by zero!\n"); - return 0.0; - } - else - return left / right; - case '^': - return pow(left, right); - default: - if ( op == '(' ) - sprintf(strError, "Error: unbalanced brackets.\n"); - else - sprintf(strError, "Error: unknown operator: %c\n", op); - return 0.0; - } -} - -/* Calcola e restituisce il risultato di un'espressione in forma infissa */ -double EvalInfix(const char *strExpression, char * strError) -{ - int i = 0; - Token tok; - Token tok_temp; - double left, right; - double dblRet; - - strcpy(strError, ""); - - tok_temp.Type = EOL; - tok_temp.str[0] = '@'; - tok_temp.str[1] = '\0'; - push_op(tok_temp, strError); - if ( strError[0] != '\0' ) - return 0.0; - - while ( (PreviousTokenType = GetNextToken(strExpression, &tok, TRUE)) != EOL ) - { - if ( tok.Type == UNKNOWN ) - { - sprintf(strError, "Error: invalid token: %s\n", tok.str); - return 0.0; - } - else if ( tok.Type == VALUE ) - { - push_val(tok.Value, strError); - if ( strError[0] != '\0' ) - return 0.0; - } - else if ( tok.Type == OPAREN || tok.Type == UMINUS || tok.Type == UPLUS ) - { - push_op(tok, strError); - if ( strError[0] != '\0' ) - return 0.0; - } - else if ( tok.Type == CPAREN ) - { - while ( top_op(strError).Type != OPAREN ) - { - if ( strError[0] != '\0' ) - return 0.0; - - tok_temp = pop_op(strError); - if ( strError[0] != '\0' ) - return 0.0; - - if ( (tok_temp.Type == EOL) || (is_empty_op()) ) - { - sprintf(strError, "Error: unbalanced brackets.\n"); - return 0.0; - } - - right = pop_val(strError); - if ( strError[0] != '\0' ) - return 0.0; - - if ( tok_temp.Type != UMINUS ) - { - left = pop_val(strError); - if ( strError[0] != '\0' ) - return 0.0; - - dblRet = BinaryOperation(left, right, tok_temp.str[0], strError); - if ( strError[0] != '\0' ) - return 0.0; - - push_val(dblRet, strError); - if ( strError[0] != '\0' ) - return 0.0; - } - else - { - push_val( -1 * right, strError ); - if ( strError[0] != '\0' ) - return 0.0; - } - } - pop_op(strError); - if ( strError[0] != '\0' ) - return 0.0; - } - else - { - while ( PREC_TABLE[ top_op(strError).Type ].topOfStack >= PREC_TABLE[ tok.Type ].inputSymbol ) - { - if ( strError[0] != '\0' ) - return 0.0; - - if ( top_op(strError).Type != UMINUS && top_op(strError).Type != UPLUS ) - { - if ( strError[0] != '\0' ) - return 0.0; - - right = pop_val(strError); - if ( strError[0] != '\0' ) - return 0.0; - - left = pop_val(strError); - if ( strError[0] != '\0' ) - return 0.0; - - tok_temp = pop_op(strError); - if ( strError[0] != '\0' ) - return 0.0; - - dblRet = BinaryOperation(left, right, tok_temp.str[0], strError); - if ( strError[0] != '\0' ) - return 0.0; - - push_val(dblRet, strError); - if ( strError[0] != '\0' ) - return 0.0; - } - else - { - if ( top_op(strError).Type == UMINUS ) - { - if ( strError[0] != '\0' ) - return 0.0; - - right = pop_val(strError); - if ( strError[0] != '\0' ) - return 0.0; - - pop_op(strError); - if ( strError[0] != '\0' ) - return 0.0; - - push_val(-1 * right, strError); - if ( strError[0] != '\0' ) - return 0.0; - } - else - { - pop_op(strError); - if ( strError[0] != '\0' ) - return 0.0; - } - } - } - - if ( tok.Type != EOL ) - { - push_op(tok, strError); - if ( strError[0] != '\0' ) - return 0.0; - } - } - } - - while ( 1 ) - { - tok_temp = pop_op(strError); - if ( strError[0] != '\0' ) - return 0.0; - - if ( tok_temp.Type == EOL ) - break; - - if ( tok_temp.Type != UPLUS ) - { - right = pop_val(strError); - if ( strError[0] != '\0' ) - return 0.0; - } - - if ( tok_temp.Type != UMINUS && tok_temp.Type != UPLUS ) - { - left = pop_val(strError); - if ( strError[0] != '\0' ) - return 0.0; - - dblRet = BinaryOperation(left, right, tok_temp.str[0], strError); - if ( strError[0] != '\0' ) - return 0.0; - - push_val(dblRet, strError); - if ( strError[0] != '\0' ) - return 0.0; - } - else - { - push_val( -1 * right, strError ); - if ( strError[0] != '\0' ) - return 0.0; - } - } - - dblRet = pop_val(strError); - if ( strError[0] != '\0' ) - return 0.0; - - if ( is_empty_val() ) - { - return dblRet; - } - else - { - sprintf(strError, "Error: malformed expression.\n"); - return 0.0; - } -} - -double eval_infix( int *ierr, const char *strExpression, int len ) -{ - double result = 0.0; - char strHelper[257]; - char strError[257]; - int i; - - /* maximum length of strExpression is 256 chars */ - if (len>256) { - printf("[eval_infix.c] expression longer than 256 characters\n"); - ierr[0] = 1; - return result; - } - - // it's safer to reformat strings for C, with null terminator '\0' - for(i=0;i 256 ) { - *ierr = 3; - } else { - for( i = 0; i < *len; i ++ ) { - tmp[i] = (char)strExpression[i]; - } - result = eval_infix( ierr, tmp, *len ); - } - return result; -} diff --git a/quantum_espresso/kcp/clib/fft_stick.c b/quantum_espresso/kcp/clib/fft_stick.c deleted file mode 100644 index 7d743cff4..000000000 --- a/quantum_espresso/kcp/clib/fft_stick.c +++ /dev/null @@ -1,214 +0,0 @@ -/* - Copyright (C) 2002 FPMD group - This file is distributed under the terms of the - GNU General Public License. See the file `License' - in the root directory of the present distribution, - or http://www.gnu.org/copyleft/gpl.txt . -*/ - -#include "c_defs.h" - -#if defined __FFTW -# include "fftw.c" - -int F77_FUNC_ (create_plan_1d, CREATE_PLAN_1D)(fftw_plan *p, int *n, int *idir) -{ - fftw_direction dir = ( (*idir < 0) ? FFTW_FORWARD : FFTW_BACKWARD ); - *p = fftw_create_plan(*n, dir, FFTW_ESTIMATE | FFTW_IN_PLACE); - if( *p == NULL ) fprintf(stderr," *** CREATE_PLAN: warning empty plan ***\n"); -/* printf(" pointer size = %d, value = %d\n", sizeof ( *p ), *p ); */ - return 0; -} - - -int F77_FUNC_ (destroy_plan_1d, DESTROY_PLAN_1D)(fftw_plan *p) -{ - if ( *p != NULL ) fftw_destroy_plan(*p); - else fprintf(stderr," *** DESTROY_PLAN: warning empty plan ***\n"); - return 0; -} - -int F77_FUNC_ (create_plan_2d, CREATE_PLAN_2D) - (fftwnd_plan *p, int *n, int *m, int *idir) -{ - fftw_direction dir = ( (*idir < 0) ? FFTW_FORWARD : FFTW_BACKWARD ); - *p = fftw2d_create_plan(*m, *n, dir, FFTW_ESTIMATE | FFTW_IN_PLACE); - if( *p == NULL ) fprintf(stderr," *** CREATE_PLAN_2D: warning empty plan ***\n"); -/* printf(" pointer size = %d, value = %d\n", sizeof ( *p ), *p ); */ - return 0; -} - -int F77_FUNC_ (destroy_plan_2d, DESTROY_PLAN_2D)(fftwnd_plan *p) -{ - if ( *p != NULL ) fftwnd_destroy_plan(*p); - else fprintf(stderr," *** DESTROY_PLAN_2D: warning empty plan ***\n"); - return 0; -} - -int F77_FUNC_ (create_plan_3d, CREATE_PLAN_3D) - (fftwnd_plan *p, int *n, int *m, int *l, int *idir) -{ - fftw_direction dir = ( (*idir < 0) ? FFTW_FORWARD : FFTW_BACKWARD ); - *p = fftw3d_create_plan(*l, *m, *n, dir, FFTW_ESTIMATE | FFTW_IN_PLACE); - if( *p == NULL ) { - fprintf(stderr," *** CREATE_PLAN_3D: warning empty plan ***\n"); - fprintf(stderr," *** input was (n,m,l,dir): %d %d %d %d ***\n", *l, *m, *n, *idir); - } -/* printf(" pointer size = %d, value = %d\n", sizeof ( *p ), *p ); */ - return 0; -} - -int F77_FUNC_ (destroy_plan_3d, DESTROY_PLAN_3D)(fftwnd_plan *p) - -{ - if ( *p != NULL ) fftwnd_destroy_plan(*p); - else fprintf(stderr," *** DESTROY_PLAN_3D: warning empty plan ***\n"); - return 0; -} - - -int F77_FUNC_ (fft_x_stick, FFT_X_STICK) -(fftw_plan *p, FFTW_COMPLEX *a, int *nx, int *ny, int *nz, int *ldx, int *ldy ) -{ - - int i, j, ind; - int xstride, bigstride; - int xhowmany, xidist; - double * ptr; - -/* trasform along x and y */ - bigstride = (*ldx) * (*ldy); - - xhowmany = (*ny); - xstride = 1; - xidist = (*ldx); - - /* ptr = (double *)a; */ - - for(i = 0; i < *nz ; i++) { - /* trasform along x */ - fftw(*p,xhowmany,&a[i*bigstride],xstride,xidist,0,0,0); - } - return 0; -} - -int F77_FUNC_ (fft_y_stick, FFT_Y_STICK) - (fftw_plan *p, FFTW_COMPLEX *a, int *ny, int *ldx ) -{ - fftw(*p, 1, a, (*ldx), 1, 0, 0, 0); - return 0; -} - - -int F77_FUNC_ (fft_z_stick, FFT_Z_STICK) - (fftw_plan *p, FFTW_COMPLEX *zstick, int *ldz, int *nstick_l) -{ - int howmany, idist; - howmany = (*nstick_l) ; - idist = (*ldz); - fftw(*p, howmany, zstick, 1, idist, 0, 0, 0); - return 0; -} - -int F77_FUNC_ ( fftw_inplace_drv_1d, FFTW_INPLACE_DRV_1D ) - (fftw_plan *p, int *nfft, FFTW_COMPLEX *a, int *inca, int *idist) -{ - fftw(*p, (*nfft), a, (*inca), (*idist), 0, 0, 0); - return 0; -} - -int F77_FUNC_ ( fftw_inplace_drv_2d, FFTW_INPLACE_DRV_2D ) - ( fftwnd_plan *p, int *nfft, FFTW_COMPLEX *a, int *inca, int *idist) -{ - fftwnd( *p, (*nfft), a, (*inca), (*idist), 0, 0, 0 ); - return 0; -} - -int F77_FUNC_ ( fftw_inplace_drv_3d, FFTW_INPLACE_DRV_3D ) - ( fftwnd_plan *p, int *nfft, FFTW_COMPLEX *a, int *inca, int *idist) -{ - fftwnd( *p, (*nfft), a, (*inca), (*idist), 0, 0, 0 ); - return 0; -} - -int F77_FUNC_ (fft_x_stick_single, FFT_X_STICK_SINGLE) -(fftw_plan *p, FFTW_COMPLEX *a, int *nx, int *ny, int *nz, int *ldx, int *ldy ) -{ - - int i, j, ind; - int xstride, bigstride; - int xhowmany, xidist; - double * ptr; - -/* trasform along x and y */ - bigstride = (*ldx) * (*ldy); - - xhowmany = (*ny); - xstride = 1; - xidist = (*ldx); - - fftw(*p,xhowmany,a,xstride,xidist,0,0,0); - - return 0; -} - - -int F77_FUNC_ (fft_z_stick_single, FFT_Z_STICK_SINGLE) - (fftw_plan *p, FFTW_COMPLEX *a, int *ldz) -{ - fftw(*p, 1,a, 1, 0, 0, 0, 0); - - return 0; -} - -/* Computing the N-Dimensional FFT -void fftwnd(fftwnd_plan plan, int howmany, - FFTW_COMPLEX *in, int istride, int idist, - FFTW_COMPLEX *out, int ostride, int odist); -*/ - - -/* -void fftw(fftw_plan plan, int howmany, - fftw_complex *in, int istride, int idist, - fftw_complex *out, int ostride, int odist); - -The function fftw computes the one-dimensional Fourier transform, -using a plan created by fftw_create_plan (See Section Plan Creation for -One-dimensional Transforms.) The function fftw_one provides a simplified -interface for the common case of single input array of stride 1. - -Arguments -plan is the plan created by fftw_create_plan -howmany is the number of transforms fftw will compute. It is faster to - tell FFTW to compute many transforms, instead of simply calling fftw - many times. -in, istride and idist describe the input array(s). - There are howmany input arrays; the first one is pointed to by in, - the second one is pointed to by in + idist, and so on, up to - in + (howmany - 1) * idist. Each input array consists of complex numbers, - which are not necessarily contiguous in memory. Specifically, in[0] is - the first element of the first array, in[istride] is the second element - of the first array, and so on. In general, the i-th element of the j-th - input array will be in position in[i * istride + j * idist]. -out, ostride and odist describe the output array(s). - The format is the same as for the input array. - -In-place transforms: If the plan specifies an in-place transform, ostride -and odist are always ignored. If out is NULL, out is ignored, too. Otherwise, -out is interpreted as a pointer to an array of n complex numbers, that FFTW -will use as temporary space to perform the in-place computation. out is used -as scratch space and its contents destroyed. In this case, out must be an -ordinary array whose elements are contiguous in memory (no striding). - -*/ - -#else - -/* This dummy subroutine is there for compilers that dislike empty files */ - -int dumfftwdrv() { - return 0; -} - -#endif diff --git a/quantum_espresso/kcp/clib/fftw.c b/quantum_espresso/kcp/clib/fftw.c deleted file mode 100644 index 51e08fcdd..000000000 --- a/quantum_espresso/kcp/clib/fftw.c +++ /dev/null @@ -1,27463 +0,0 @@ -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -#include -#include - -#if defined(__QK_USER__) -#include -#endif - -#include "fftw.h" - -/**************** import/export using file ***************/ - -static void file_emitter(char c, void *data) -{ - putc(c,(FILE *) data); -} - -void fftw_export_wisdom_to_file(FILE *output_file) -{ - if (output_file) - fftw_export_wisdom(file_emitter,(void *) output_file); -} - -static int file_get_input(void *data) -{ - return getc((FILE *) data); -} - -fftw_status fftw_import_wisdom_from_file(FILE *input_file) -{ - if (!input_file) - return FFTW_FAILURE; - return fftw_import_wisdom(file_get_input, (void *) input_file); -} - -/*************** import/export using string **************/ - -static void emission_counter(char c, void *data) -{ - int *counter = (int *) data; - - ++*counter; -} - -static void string_emitter(char c, void *data) -{ - char **output_string = (char **) data; - - *((*output_string)++) = c; - **output_string = 0; -} - -char *fftw_export_wisdom_to_string(void) -{ - int string_length = 0; - char *s, *s2; - - fftw_export_wisdom(emission_counter, (void *) &string_length); - - s = fftw_malloc(sizeof(char) * (string_length + 1)); - if (!s) - return 0; - s2 = s; - - fftw_export_wisdom(string_emitter, (void *) &s2); - - if (s + string_length != s2) - fftw_die("Unexpected output string length!"); - - return s; -} - -static int string_get_input(void *data) -{ - char **input_string = (char **) data; - - if (**input_string) - return *((*input_string)++); - else - return 0; -} - -fftw_status fftw_import_wisdom_from_string(const char *input_string) -{ - const char *s = input_string; - - if (!input_string) - return FFTW_FAILURE; - return fftw_import_wisdom(string_get_input, (void *) &s); -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* config.c -- this file contains all the codelets the system knows about */ - -/* $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -#if defined FFTW_USING_CILK -#include -#include -#endif - -#include "fftw.h" - -/* the signature is the same as the size, for now */ -#define NOTW_CODELET(x) { x, x, fftw_no_twiddle_##x } -#define NOTWI_CODELET(x) { x, x, fftwi_no_twiddle_##x } - -extern notw_codelet fftw_no_twiddle_1; -extern notw_codelet fftw_no_twiddle_2; -extern notw_codelet fftw_no_twiddle_3; -extern notw_codelet fftw_no_twiddle_4; -extern notw_codelet fftw_no_twiddle_5; -extern notw_codelet fftw_no_twiddle_6; -extern notw_codelet fftw_no_twiddle_7; -extern notw_codelet fftw_no_twiddle_8; -extern notw_codelet fftw_no_twiddle_9; -extern notw_codelet fftw_no_twiddle_10; -extern notw_codelet fftw_no_twiddle_11; -extern notw_codelet fftw_no_twiddle_12; -extern notw_codelet fftw_no_twiddle_13; -extern notw_codelet fftw_no_twiddle_14; -extern notw_codelet fftw_no_twiddle_15; -extern notw_codelet fftw_no_twiddle_16; -extern notw_codelet fftw_no_twiddle_32; -extern notw_codelet fftw_no_twiddle_64; - -extern notw_codelet fftwi_no_twiddle_1; -extern notw_codelet fftwi_no_twiddle_2; -extern notw_codelet fftwi_no_twiddle_3; -extern notw_codelet fftwi_no_twiddle_4; -extern notw_codelet fftwi_no_twiddle_5; -extern notw_codelet fftwi_no_twiddle_6; -extern notw_codelet fftwi_no_twiddle_7; -extern notw_codelet fftwi_no_twiddle_8; -extern notw_codelet fftwi_no_twiddle_9; -extern notw_codelet fftwi_no_twiddle_10; -extern notw_codelet fftwi_no_twiddle_11; -extern notw_codelet fftwi_no_twiddle_12; -extern notw_codelet fftwi_no_twiddle_13; -extern notw_codelet fftwi_no_twiddle_14; -extern notw_codelet fftwi_no_twiddle_15; -extern notw_codelet fftwi_no_twiddle_16; -extern notw_codelet fftwi_no_twiddle_32; -extern notw_codelet fftwi_no_twiddle_64; - -config_notw fftw_config_notw[] = -{ - NOTW_CODELET(1), - NOTW_CODELET(2), - NOTW_CODELET(3), - NOTW_CODELET(4), - NOTW_CODELET(5), - NOTW_CODELET(6), - NOTW_CODELET(7), - NOTW_CODELET(8), - NOTW_CODELET(9), - NOTW_CODELET(10), - NOTW_CODELET(11), - NOTW_CODELET(12), - NOTW_CODELET(13), - NOTW_CODELET(14), - NOTW_CODELET(15), - NOTW_CODELET(16), - NOTW_CODELET(32), - NOTW_CODELET(64), - {0, 0, (notw_codelet *) 0} -}; - -config_notw fftwi_config_notw[] = -{ - NOTWI_CODELET(1), - NOTWI_CODELET(2), - NOTWI_CODELET(3), - NOTWI_CODELET(4), - NOTWI_CODELET(5), - NOTWI_CODELET(6), - NOTWI_CODELET(7), - NOTWI_CODELET(8), - NOTWI_CODELET(9), - NOTWI_CODELET(10), - NOTWI_CODELET(11), - NOTWI_CODELET(12), - NOTWI_CODELET(13), - NOTWI_CODELET(14), - NOTWI_CODELET(15), - NOTWI_CODELET(16), - NOTWI_CODELET(32), - NOTWI_CODELET(64), - {0, 0, (notw_codelet *) 0} -}; - -/* the signature is the same as the size, for now */ -#define TWIDDLE_CODELET(x) { x, x, fftw_twiddle_##x } -#define TWIDDLEI_CODELET(x) { x, x, fftwi_twiddle_##x } - -extern twiddle_codelet fftw_twiddle_2; -extern twiddle_codelet fftw_twiddle_3; -extern twiddle_codelet fftw_twiddle_4; -extern twiddle_codelet fftw_twiddle_5; -extern twiddle_codelet fftw_twiddle_6; -extern twiddle_codelet fftw_twiddle_7; -extern twiddle_codelet fftw_twiddle_8; -extern twiddle_codelet fftw_twiddle_9; -extern twiddle_codelet fftw_twiddle_10; -extern twiddle_codelet fftw_twiddle_16; -extern twiddle_codelet fftw_twiddle_32; -extern twiddle_codelet fftw_twiddle_64; - -extern twiddle_codelet fftwi_twiddle_2; -extern twiddle_codelet fftwi_twiddle_3; -extern twiddle_codelet fftwi_twiddle_4; -extern twiddle_codelet fftwi_twiddle_5; -extern twiddle_codelet fftwi_twiddle_6; -extern twiddle_codelet fftwi_twiddle_7; -extern twiddle_codelet fftwi_twiddle_8; -extern twiddle_codelet fftwi_twiddle_9; -extern twiddle_codelet fftwi_twiddle_10; -extern twiddle_codelet fftwi_twiddle_16; -extern twiddle_codelet fftwi_twiddle_32; -extern twiddle_codelet fftwi_twiddle_64; - -config_twiddle fftw_config_twiddle[] = -{ - TWIDDLE_CODELET(2), - TWIDDLE_CODELET(3), - TWIDDLE_CODELET(4), - TWIDDLE_CODELET(5), - TWIDDLE_CODELET(6), - TWIDDLE_CODELET(7), - TWIDDLE_CODELET(8), - TWIDDLE_CODELET(9), - TWIDDLE_CODELET(10), - TWIDDLE_CODELET(16), - TWIDDLE_CODELET(32), - TWIDDLE_CODELET(64), - {0, 0, (twiddle_codelet *) 0} -}; - -config_twiddle fftwi_config_twiddle[] = -{ - TWIDDLEI_CODELET(2), - TWIDDLEI_CODELET(3), - TWIDDLEI_CODELET(4), - TWIDDLEI_CODELET(5), - TWIDDLEI_CODELET(6), - TWIDDLEI_CODELET(7), - TWIDDLEI_CODELET(8), - TWIDDLEI_CODELET(9), - TWIDDLEI_CODELET(10), - TWIDDLEI_CODELET(16), - TWIDDLEI_CODELET(32), - TWIDDLEI_CODELET(64), - {0, 0, (twiddle_codelet *) 0} -}; -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* - * executor.c -- execute the fft - */ - -/* $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ -#include "fftw.h" -#include -#include - -char *fftw_version = "FFTW V1.1 ($Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $)"; - -/* - * This function is called in other files, so we cannot declare - * it as static. - */ - -void fftw_strided_copy(int n, FFTW_COMPLEX *in, int ostride, - FFTW_COMPLEX *out) -{ - int i; - FFTW_REAL r0, r1, i0, i1; - FFTW_REAL r2, r3, i2, i3; - - i = 0; - if (n & 3) - for (; i < (n & 3); ++i) { - out[i * ostride] = in[i]; - } - for (; i < n; i += 4) { - r0 = c_re(in[i]); - i0 = c_im(in[i]); - r1 = c_re(in[i + 1]); - i1 = c_im(in[i + 1]); - r2 = c_re(in[i + 2]); - i2 = c_im(in[i + 2]); - r3 = c_re(in[i + 3]); - i3 = c_im(in[i + 3]); - c_re(out[i * ostride]) = r0; - c_im(out[i * ostride]) = i0; - c_re(out[(i + 1) * ostride]) = r1; - c_im(out[(i + 1) * ostride]) = i1; - c_re(out[(i + 2) * ostride]) = r2; - c_im(out[(i + 2) * ostride]) = i2; - c_re(out[(i + 3) * ostride]) = r3; - c_im(out[(i + 3) * ostride]) = i3; - } -} - -/* - * Do *not* declare simple executor as static--we need to call it - * from executor_cilk.cilk...also, preface its name with "fftw_" - * to avoid any possible name collisions. - */ -void fftw_executor_simple(int n, const FFTW_COMPLEX *in, - FFTW_COMPLEX *out, - fftw_plan_node *p, - int istride, - int ostride) -{ - switch (p->type) { - case FFTW_NOTW: - (p->nodeu.notw.codelet) (in, out, istride, ostride); - break; - - case FFTW_TWIDDLE: - { - int r = p->nodeu.twiddle.size; - int m = n / r; - int i; - twiddle_codelet *codelet; - FFTW_COMPLEX *W; - - for (i = 0; i < r; ++i) { - fftw_executor_simple(m, in + i * istride, - out + i * (m * ostride), - p->nodeu.twiddle.recurse, - istride * r, ostride); - } - - codelet = p->nodeu.twiddle.codelet; - W = p->nodeu.twiddle.tw->twarray; - codelet(out, W, m * ostride, m, ostride); - - break; - } - - case FFTW_GENERIC: - { - int r = p->nodeu.generic.size; - int m = n / r; - int i; - generic_codelet *codelet; - FFTW_COMPLEX *W; - - for (i = 0; i < r; ++i) { - fftw_executor_simple(m, in + i * istride, - out + i * (m * ostride), - p->nodeu.generic.recurse, - istride * r, ostride); - } - - codelet = p->nodeu.generic.codelet; - W = p->nodeu.generic.tw->twarray; - codelet(out, W, m, r, n, ostride); - - break; - } - - default: - fftw_die("BUG in executor: illegal plan\n"); - break; - } -} - -static void executor_simple_inplace(int n, FFTW_COMPLEX *in, - FFTW_COMPLEX *out, - fftw_plan_node *p, - int istride) -{ - switch (p->type) { - case FFTW_NOTW: - (p->nodeu.notw.codelet) (in, in, istride, istride); - break; - - default: - { - FFTW_COMPLEX *tmp; - - if (out) - tmp = out; - else - tmp = (FFTW_COMPLEX *) - fftw_malloc(n * sizeof(FFTW_COMPLEX)); - - fftw_executor_simple(n, in, tmp, p, istride, 1); - fftw_strided_copy(n, tmp, istride, in); - - if (!out) - fftw_free(tmp); - } - } -} - -static void executor_many(int n, const FFTW_COMPLEX *in, - FFTW_COMPLEX *out, - fftw_plan_node *p, - int istride, - int ostride, - int howmany, int idist, int odist) -{ - switch (p->type) { - case FFTW_NOTW: - { - int s; - notw_codelet *codelet = p->nodeu.notw.codelet; - for (s = 0; s < howmany; ++s) - codelet(in + s * idist, - out + s * odist, - istride, ostride); - break; - } - - default: - { - int s; - for (s = 0; s < howmany; ++s) { - fftw_executor_simple(n, in + s * idist, - out + s * odist, - p, istride, ostride); - } - } - } -} - -static void executor_many_inplace(int n, FFTW_COMPLEX *in, - FFTW_COMPLEX *out, - fftw_plan_node *p, - int istride, - int howmany, int idist) -{ - switch (p->type) { - case FFTW_NOTW: - { - int s; - notw_codelet *codelet = p->nodeu.notw.codelet; - for (s = 0; s < howmany; ++s) - codelet(in + s * idist, - in + s * idist, - istride, istride); - break; - } - - default: - { - int s; - FFTW_COMPLEX *tmp; - if (out) - tmp = out; - else - tmp = (FFTW_COMPLEX *) - fftw_malloc(n * sizeof(FFTW_COMPLEX)); - - for (s = 0; s < howmany; ++s) { - fftw_executor_simple(n, - in + s * idist, - tmp, - p, istride, 1); - fftw_strided_copy(n, tmp, istride, in + s * idist); - } - - if (!out) - fftw_free(tmp); - } - } -} - -/* user interface */ -void fftw(fftw_plan plan, int howmany, FFTW_COMPLEX *in, int istride, - int idist, FFTW_COMPLEX *out, int ostride, int odist) -{ - int n = plan->n; - - if (plan->flags & FFTW_IN_PLACE) { - if (howmany == 1) { - executor_simple_inplace(n, in, out, plan->root, istride); - } else { - executor_many_inplace(n, in, out, plan->root, istride, howmany, - idist); - } - } else { - if (howmany == 1) { - fftw_executor_simple(n, in, out, plan->root, istride, ostride); - } else { - executor_many(n, in, out, plan->root, istride, ostride, - howmany, idist, odist); - } - } -} - -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -#include - -#include "fftw.h" - -/* Prototypes for functions used internally in this file: */ - -static void fftw2d_out_of_place_aux(fftwnd_plan p, int howmany, - FFTW_COMPLEX *in, int istride, int idist, - FFTW_COMPLEX *out, int ostride, int odist); -static void fftw3d_out_of_place_aux(fftwnd_plan p, int howmany, - FFTW_COMPLEX *in, int istride, int idist, - FFTW_COMPLEX *out, int ostride, int odist); -static void fftwnd_out_of_place_aux(fftwnd_plan p, int howmany, - FFTW_COMPLEX *in, int istride, int idist, - FFTW_COMPLEX *out, int ostride, int odist); - -static void fftw2d_in_place_aux(fftwnd_plan p, int howmany, - FFTW_COMPLEX *in_out, int istride, int idist); -static void fftw3d_in_place_aux(fftwnd_plan p, int howmany, - FFTW_COMPLEX *in_out, int istride, int idist); -static void fftwnd_in_place_aux(fftwnd_plan p, int howmany, - FFTW_COMPLEX *in_out, int istride, int idist); - -/*********** Initializing the FFTWND Auxiliary Data **********/ - -fftwnd_plan fftw2d_create_plan(int nx, int ny, fftw_direction dir, int flags) -{ - int n[2]; - - n[0] = nx; - n[1] = ny; - - return fftwnd_create_plan(2, n, dir, flags); -} - -fftwnd_plan fftw3d_create_plan(int nx, int ny, int nz, fftw_direction dir, - int flags) -{ - int n[3]; - - n[0] = nx; - n[1] = ny; - n[2] = nz; - - return fftwnd_create_plan(3, n, dir, flags); -} - -fftwnd_plan fftwnd_create_plan(int rank, const int *n, - fftw_direction dir, int flags) -{ - int i, j, max_dim = 0; - fftwnd_plan p; - int cur_flags; - - if (rank < 0) - return 0; - - for (i = 0; i < rank; ++i) - if (n[i] <= 0) - return 0; - - p = (fftwnd_plan) fftw_malloc(sizeof(fftwnd_aux_data)); - p->n = 0; - p->n_before = 0; - p->n_after = 0; - p->plans = 0; - p->work = 0; - - p->rank = rank; - p->is_in_place = flags & FFTW_IN_PLACE; - - if (rank == 0) - return 0; - - p->n = (int *) fftw_malloc(sizeof(int) * rank); - p->n_before = (int *) fftw_malloc(sizeof(int) * rank); - p->n_after = (int *) fftw_malloc(sizeof(int) * rank); - p->plans = (fftw_plan *) fftw_malloc(rank * sizeof(fftw_plan)); - p->n_before[0] = 1; - p->n_after[rank - 1] = 1; - - for (i = 0; i < rank; ++i) { - p->n[i] = n[i]; - - if (i) { - p->n_before[i] = p->n_before[i - 1] * n[i - 1]; - p->n_after[rank - 1 - i] = p->n_after[rank - i] * n[rank - i]; - } - if (i < rank - 1 || (flags & FFTW_IN_PLACE)) { - /* fft's except the last dimension are always in-place */ - cur_flags = flags | FFTW_IN_PLACE; - for (j = i - 1; j >= 0 && n[i] != n[j]; --j); - - if (n[i] > max_dim) - max_dim = n[i]; - } else { - cur_flags = flags; - /* we must create a separate plan for the last dimension */ - j = -1; - } - - if (j >= 0) { - /* - * If a plan already exists for this size - * array, reuse it: - */ - p->plans[i] = p->plans[j]; - } else { - /* generate a new plan: */ - p->plans[i] = fftw_create_plan(n[i], dir, cur_flags); - if (!p->plans[i]) { - fftwnd_destroy_plan(p); - return 0; - } - } - } - - /* Create work array for in-place FFTs: */ - if (max_dim > 0) - p->work = (FFTW_COMPLEX *) - fftw_malloc(sizeof(FFTW_COMPLEX) * max_dim); - - return p; -} - -/************* Freeing the FFTWND Auxiliary Data *************/ - -void fftwnd_destroy_plan(fftwnd_plan plan) -{ - if (plan) { - if (plan->plans) { - int i, j; - - for (i = 0; i < plan->rank; ++i) { - for (j = i - 1; - j >= 0 && plan->plans[i] != plan->plans[j]; - --j); - if (j < 0 && plan->plans[i]) - fftw_destroy_plan(plan->plans[i]); - } - fftw_free(plan->plans); - } - if (plan->n) - fftw_free(plan->n); - - if (plan->n_before) - fftw_free(plan->n_before); - - if (plan->n_after) - fftw_free(plan->n_after); - - if (plan->work) - fftw_free(plan->work); - - fftw_free(plan); - } -} - -/************** Computing the N-Dimensional FFT **************/ - -void fftwnd(fftwnd_plan plan, int howmany, - FFTW_COMPLEX *in, int istride, int idist, - FFTW_COMPLEX *out, int ostride, int odist) -{ - if (plan->is_in_place) /* fft is in-place */ - switch (plan->rank) { - case 0: - break; - case 1: - fftw(plan->plans[0], howmany, in, istride, idist, - plan->work, 1, 0); - break; - case 2: - fftw2d_in_place_aux(plan, howmany, in, istride, idist); - break; - case 3: - fftw3d_in_place_aux(plan, howmany, in, istride, idist); - break; - default: - fftwnd_in_place_aux(plan, howmany, in, istride, idist); - } else { - if (in == out || out == 0) - fftw_die("Illegal attempt to perform in-place FFT!\n"); - switch (plan->rank) { - case 0: - break; - case 1: - fftw(plan->plans[0], howmany, in, istride, idist, - out, ostride, odist); - break; - case 2: - fftw2d_out_of_place_aux(plan, howmany, in, istride, - idist, out, ostride, odist); - break; - case 3: - fftw3d_out_of_place_aux(plan, howmany, in, istride, - idist, out, ostride, odist); - break; - default: - fftwnd_out_of_place_aux(plan, howmany, in, istride, - idist, out, ostride, odist); - } - } -} - -static void fftw2d_out_of_place_aux(fftwnd_plan p, int howmany, - FFTW_COMPLEX *in, int istride, int idist, - FFTW_COMPLEX *out, int ostride, int odist) -{ - int fft_iter; - fftw_plan p0, p1; - int n0, n1; - - p0 = p->plans[0]; - p1 = p->plans[1]; - n0 = p->n[0]; - n1 = p->n[1]; - - for (fft_iter = 0; fft_iter < howmany; ++fft_iter) { - /* FFT y dimension (out-of-place): */ - fftw(p1, n0, - in + fft_iter * idist, istride, n1 * istride, - out + fft_iter * odist, ostride, n1 * ostride); - /* FFT x dimension (in-place): */ - fftw(p0, n1, - out + fft_iter * odist, n1 * ostride, ostride, - p->work, 1, 1); - } -} - -static void fftw3d_out_of_place_aux(fftwnd_plan p, int howmany, - FFTW_COMPLEX *in, int istride, int idist, - FFTW_COMPLEX *out, int ostride, int odist) -{ - int fft_iter; - int i; - fftw_plan p0, p1, p2; - int n0, n1, n2; - - p0 = p->plans[0]; - p1 = p->plans[1]; - p2 = p->plans[2]; - n0 = p->n[0]; - n1 = p->n[1]; - n2 = p->n[2]; - - for (fft_iter = 0; fft_iter < howmany; ++fft_iter) { - /* FFT z dimension (out-of-place): */ - fftw(p2, n0 * n1, - in + fft_iter * idist, istride, n2 * istride, - out + fft_iter * odist, ostride, n2 * ostride); - /* FFT y dimension (in-place): */ - for (i = 0; i < n0; ++i) - fftw(p1, n2, - out + fft_iter * odist + i * n1 * n2 * ostride, - n2 * ostride, ostride, p->work, 1, 0); - /* FFT x dimension (in-place): */ - fftw(p0, n1 * n2, - out + fft_iter * odist, n1 * n2 * ostride, ostride, - p->work, 1, 0); - } -} - -static void fftwnd_out_of_place_aux(fftwnd_plan p, int howmany, - FFTW_COMPLEX *in, int istride, int idist, - FFTW_COMPLEX *out, int ostride, int odist) -{ - int fft_iter; - int j, i; - - /* Do FFT for rank > 3: */ - - for (fft_iter = 0; fft_iter < howmany; ++fft_iter) { - /* do last dimension (out-of-place): */ - fftw(p->plans[p->rank - 1], p->n_before[p->rank - 1], - in + fft_iter * idist, istride, p->n[p->rank - 1] * istride, - out + fft_iter * odist, ostride, p->n[p->rank - 1] * ostride); - - /* do first dimension (in-place): */ - fftw(p->plans[0], p->n_after[0], - out + fft_iter * odist, p->n_after[0] * ostride, ostride, - p->work, 1, 0); - - /* do other dimensions (in-place): */ - for (j = 1; j < p->rank - 1; ++j) - for (i = 0; i < p->n_before[j]; ++i) - fftw(p->plans[j], p->n_after[j], - out + fft_iter * odist + i * ostride * p->n[j] * - p->n_after[j], p->n_after[j] * ostride, - ostride, p->work, 1, 0); - } -} - -static void fftw2d_in_place_aux(fftwnd_plan p, int howmany, - FFTW_COMPLEX *in_out, int istride, int idist) -{ - int fft_iter; - fftw_plan p0, p1; - int n0, n1; - - p0 = p->plans[0]; - p1 = p->plans[1]; - n0 = p->n[0]; - n1 = p->n[1]; - - for (fft_iter = 0; fft_iter < howmany; ++fft_iter) { - /* FFT y dimension: */ - fftw(p1, n0, - in_out + fft_iter * idist, istride, istride * n1, - p->work, 1, 0); - /* FFT x dimension: */ - fftw(p0, n1, - in_out + fft_iter * idist, istride * n1, istride, - p->work, 1, 0); - } -} - -static void fftw3d_in_place_aux(fftwnd_plan p, int howmany, - FFTW_COMPLEX *in_out, int istride, int idist) -{ - int i; - int fft_iter; - fftw_plan p0, p1, p2; - int n0, n1, n2; - - p0 = p->plans[0]; - p1 = p->plans[1]; - p2 = p->plans[2]; - n0 = p->n[0]; - n1 = p->n[1]; - n2 = p->n[2]; - - for (fft_iter = 0; fft_iter < howmany; ++fft_iter) { - /* FFT z dimension: */ - fftw(p2, n0 * n1, - in_out + fft_iter * idist, istride, n2 * istride, - p->work, 1, 0); - /* FFT y dimension: */ - for (i = 0; i < n0; ++i) - fftw(p1, n2, - in_out + fft_iter * idist + i * n1 * - n2 * istride, n2 * istride, istride, p->work, 1, 0); - /* FFT x dimension: */ - fftw(p0, n1 * n2, - in_out + fft_iter * idist, n1 * n2 * istride, istride, - p->work, 1, 0); - } -} - -static void fftwnd_in_place_aux(fftwnd_plan p, int howmany, - FFTW_COMPLEX *in_out, int istride, int idist) -/* Do FFT for rank > 3: */ -{ - int fft_iter; - int j, i; - - for (fft_iter = 0; fft_iter < howmany; ++fft_iter) { - /* do last dimension: */ - fftw(p->plans[p->rank - 1], p->n_before[p->rank - 1], - in_out + fft_iter * idist, istride, p->n[p->rank - 1] * istride, - p->work, 1, 0); - - /* do first dimension: */ - fftw(p->plans[0], p->n_after[0], - in_out + fft_iter * idist, p->n_after[0] * istride, istride, - p->work, 1, 0); - - /* do other dimensions: */ - for (j = 1; j < p->rank - 1; ++j) - for (i = 0; i < p->n_before[j]; ++i) - fftw(p->plans[j], p->n_after[j], - in_out + fft_iter * idist + i * istride * p->n[j] * - p->n_after[j], p->n_after[j] * istride, istride, - p->work, 1, 0); - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 0 FP additions and 0 FP multiplications */ - -void fftw_no_twiddle_1(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - tre0_0_0 = c_re(in[0]); - tim0_0_0 = c_im(in[0]); - c_re(out[0]) = tre0_0_0; - c_im(out[0]) = tim0_0_0; -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 108 FP additions and 32 FP multiplications */ - -void fftw_no_twiddle_10(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[5 * istride]); - tim1_1_0 = c_im(in[5 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[2 * istride]); - tim1_0_0 = c_im(in[2 * istride]); - tre1_1_0 = c_re(in[7 * istride]); - tim1_1_0 = c_im(in[7 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[4 * istride]); - tim1_0_0 = c_im(in[4 * istride]); - tre1_1_0 = c_re(in[9 * istride]); - tim1_1_0 = c_im(in[9 * istride]); - tre0_0_2 = tre1_0_0 + tre1_1_0; - tim0_0_2 = tim1_0_0 + tim1_1_0; - tre0_1_2 = tre1_0_0 - tre1_1_0; - tim0_1_2 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[6 * istride]); - tim1_0_0 = c_im(in[6 * istride]); - tre1_1_0 = c_re(in[istride]); - tim1_1_0 = c_im(in[istride]); - tre0_0_3 = tre1_0_0 + tre1_1_0; - tim0_0_3 = tim1_0_0 + tim1_1_0; - tre0_1_3 = tre1_0_0 - tre1_1_0; - tim0_1_3 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[8 * istride]); - tim1_0_0 = c_im(in[8 * istride]); - tre1_1_0 = c_re(in[3 * istride]); - tim1_1_0 = c_im(in[3 * istride]); - tre0_0_4 = tre1_0_0 + tre1_1_0; - tim0_0_4 = tim1_0_0 + tim1_1_0; - tre0_1_4 = tre1_0_0 - tre1_1_0; - tim0_1_4 = tim1_0_0 - tim1_1_0; - } - c_re(out[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2 + tre0_0_3 + tre0_0_4; - c_im(out[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2 + tim0_0_3 + tim0_0_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_0_1 + tre0_0_4)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_0_2 + tre0_0_3)); - tre2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_0_1 - tim0_0_4)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_0_2 - tim0_0_3)); - c_re(out[6 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[4 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_0_1 + tim0_0_4)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_0_2 + tim0_0_3)); - tim2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_0_4 - tre0_0_1)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_0_3 - tre0_0_2)); - c_im(out[6 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[4 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_0_2 + tre0_0_3)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_0_1 + tre0_0_4)); - tre2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_0_1 - tim0_0_4)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_0_3 - tim0_0_2)); - c_re(out[2 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[8 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_0_2 + tim0_0_3)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_0_1 + tim0_0_4)); - tim2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_0_4 - tre0_0_1)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_0_2 - tre0_0_3)); - c_im(out[2 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[8 * ostride]) = tim2_0_0 - tim2_1_0; - } - c_re(out[5 * ostride]) = tre0_1_0 + tre0_1_1 + tre0_1_2 + tre0_1_3 + tre0_1_4; - c_im(out[5 * ostride]) = tim0_1_0 + tim0_1_1 + tim0_1_2 + tim0_1_3 + tim0_1_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_1 + tre0_1_4)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_2 + tre0_1_3)); - tre2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_1_1 - tim0_1_4)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_1_2 - tim0_1_3)); - c_re(out[ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[9 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_1 + tim0_1_4)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_2 + tim0_1_3)); - tim2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_1_4 - tre0_1_1)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_1_3 - tre0_1_2)); - c_im(out[ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[9 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_2 + tre0_1_3)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_1 + tre0_1_4)); - tre2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_1_1 - tim0_1_4)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_1_3 - tim0_1_2)); - c_re(out[7 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[3 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_2 + tim0_1_3)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_1 + tim0_1_4)); - tim2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_1_4 - tre0_1_1)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_1_2 - tre0_1_3)); - c_im(out[7 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[3 * ostride]) = tim2_0_0 - tim2_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 230 FP additions and 100 FP multiplications */ - -void fftw_no_twiddle_11(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - FFTW_REAL tre0_5_0; - FFTW_REAL tim0_5_0; - FFTW_REAL tre0_6_0; - FFTW_REAL tim0_6_0; - FFTW_REAL tre0_7_0; - FFTW_REAL tim0_7_0; - FFTW_REAL tre0_8_0; - FFTW_REAL tim0_8_0; - FFTW_REAL tre0_9_0; - FFTW_REAL tim0_9_0; - FFTW_REAL tre0_10_0; - FFTW_REAL tim0_10_0; - tre0_0_0 = c_re(in[0]); - tim0_0_0 = c_im(in[0]); - tre0_1_0 = c_re(in[istride]); - tim0_1_0 = c_im(in[istride]); - tre0_2_0 = c_re(in[2 * istride]); - tim0_2_0 = c_im(in[2 * istride]); - tre0_3_0 = c_re(in[3 * istride]); - tim0_3_0 = c_im(in[3 * istride]); - tre0_4_0 = c_re(in[4 * istride]); - tim0_4_0 = c_im(in[4 * istride]); - tre0_5_0 = c_re(in[5 * istride]); - tim0_5_0 = c_im(in[5 * istride]); - tre0_6_0 = c_re(in[6 * istride]); - tim0_6_0 = c_im(in[6 * istride]); - tre0_7_0 = c_re(in[7 * istride]); - tim0_7_0 = c_im(in[7 * istride]); - tre0_8_0 = c_re(in[8 * istride]); - tim0_8_0 = c_im(in[8 * istride]); - tre0_9_0 = c_re(in[9 * istride]); - tim0_9_0 = c_im(in[9 * istride]); - tre0_10_0 = c_re(in[10 * istride]); - tim0_10_0 = c_im(in[10 * istride]); - c_re(out[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0 + tre0_3_0 + tre0_4_0 + tre0_5_0 + tre0_6_0 + tre0_7_0 + tre0_8_0 + tre0_9_0 + tre0_10_0; - c_im(out[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0 + tim0_3_0 + tim0_4_0 + tim0_5_0 + tim0_6_0 + tim0_7_0 + tim0_8_0 + tim0_9_0 + tim0_10_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K841253532) * (tre0_1_0 + tre0_10_0)) + (((FFTW_REAL) FFTW_K415415013) * (tre0_2_0 + tre0_9_0)) - (((FFTW_REAL) FFTW_K959492973) * (tre0_5_0 + tre0_6_0)) - (((FFTW_REAL) FFTW_K654860733) * (tre0_4_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K142314838) * (tre0_3_0 + tre0_8_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K540640817) * (tim0_1_0 - tim0_10_0)) + (((FFTW_REAL) FFTW_K909631995) * (tim0_2_0 - tim0_9_0)) + (((FFTW_REAL) FFTW_K989821441) * (tim0_3_0 - tim0_8_0)) + (((FFTW_REAL) FFTW_K755749574) * (tim0_4_0 - tim0_7_0)) + (((FFTW_REAL) FFTW_K281732556) * (tim0_5_0 - tim0_6_0)); - c_re(out[ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[10 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K841253532) * (tim0_1_0 + tim0_10_0)) + (((FFTW_REAL) FFTW_K415415013) * (tim0_2_0 + tim0_9_0)) - (((FFTW_REAL) FFTW_K959492973) * (tim0_5_0 + tim0_6_0)) - (((FFTW_REAL) FFTW_K654860733) * (tim0_4_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K142314838) * (tim0_3_0 + tim0_8_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K540640817) * (tre0_10_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K909631995) * (tre0_9_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K989821441) * (tre0_8_0 - tre0_3_0)) + (((FFTW_REAL) FFTW_K755749574) * (tre0_7_0 - tre0_4_0)) + (((FFTW_REAL) FFTW_K281732556) * (tre0_6_0 - tre0_5_0)); - c_im(out[ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[10 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K415415013) * (tre0_1_0 + tre0_10_0)) + (((FFTW_REAL) FFTW_K841253532) * (tre0_5_0 + tre0_6_0)) - (((FFTW_REAL) FFTW_K142314838) * (tre0_4_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K959492973) * (tre0_3_0 + tre0_8_0)) - (((FFTW_REAL) FFTW_K654860733) * (tre0_2_0 + tre0_9_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K909631995) * (tim0_1_0 - tim0_10_0)) + (((FFTW_REAL) FFTW_K755749574) * (tim0_2_0 - tim0_9_0)) + (((FFTW_REAL) FFTW_K281732556) * (tim0_8_0 - tim0_3_0)) + (((FFTW_REAL) FFTW_K989821441) * (tim0_7_0 - tim0_4_0)) + (((FFTW_REAL) FFTW_K540640817) * (tim0_6_0 - tim0_5_0)); - c_re(out[2 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[9 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K415415013) * (tim0_1_0 + tim0_10_0)) + (((FFTW_REAL) FFTW_K841253532) * (tim0_5_0 + tim0_6_0)) - (((FFTW_REAL) FFTW_K142314838) * (tim0_4_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K959492973) * (tim0_3_0 + tim0_8_0)) - (((FFTW_REAL) FFTW_K654860733) * (tim0_2_0 + tim0_9_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K909631995) * (tre0_10_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K755749574) * (tre0_9_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K281732556) * (tre0_3_0 - tre0_8_0)) + (((FFTW_REAL) FFTW_K989821441) * (tre0_4_0 - tre0_7_0)) + (((FFTW_REAL) FFTW_K540640817) * (tre0_5_0 - tre0_6_0)); - c_im(out[2 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[9 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K415415013) * (tre0_3_0 + tre0_8_0)) + (((FFTW_REAL) FFTW_K841253532) * (tre0_4_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K654860733) * (tre0_5_0 + tre0_6_0)) - (((FFTW_REAL) FFTW_K959492973) * (tre0_2_0 + tre0_9_0)) - (((FFTW_REAL) FFTW_K142314838) * (tre0_1_0 + tre0_10_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K989821441) * (tim0_1_0 - tim0_10_0)) + (((FFTW_REAL) FFTW_K281732556) * (tim0_9_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K909631995) * (tim0_8_0 - tim0_3_0)) + (((FFTW_REAL) FFTW_K540640817) * (tim0_4_0 - tim0_7_0)) + (((FFTW_REAL) FFTW_K755749574) * (tim0_5_0 - tim0_6_0)); - c_re(out[3 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[8 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K415415013) * (tim0_3_0 + tim0_8_0)) + (((FFTW_REAL) FFTW_K841253532) * (tim0_4_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K654860733) * (tim0_5_0 + tim0_6_0)) - (((FFTW_REAL) FFTW_K959492973) * (tim0_2_0 + tim0_9_0)) - (((FFTW_REAL) FFTW_K142314838) * (tim0_1_0 + tim0_10_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K989821441) * (tre0_10_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K281732556) * (tre0_2_0 - tre0_9_0)) + (((FFTW_REAL) FFTW_K909631995) * (tre0_3_0 - tre0_8_0)) + (((FFTW_REAL) FFTW_K540640817) * (tre0_7_0 - tre0_4_0)) + (((FFTW_REAL) FFTW_K755749574) * (tre0_6_0 - tre0_5_0)); - c_im(out[3 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[8 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K841253532) * (tre0_3_0 + tre0_8_0)) + (((FFTW_REAL) FFTW_K415415013) * (tre0_5_0 + tre0_6_0)) - (((FFTW_REAL) FFTW_K959492973) * (tre0_4_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K142314838) * (tre0_2_0 + tre0_9_0)) - (((FFTW_REAL) FFTW_K654860733) * (tre0_1_0 + tre0_10_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K755749574) * (tim0_1_0 - tim0_10_0)) + (((FFTW_REAL) FFTW_K989821441) * (tim0_9_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K540640817) * (tim0_3_0 - tim0_8_0)) + (((FFTW_REAL) FFTW_K281732556) * (tim0_4_0 - tim0_7_0)) + (((FFTW_REAL) FFTW_K909631995) * (tim0_6_0 - tim0_5_0)); - c_re(out[4 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[7 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K841253532) * (tim0_3_0 + tim0_8_0)) + (((FFTW_REAL) FFTW_K415415013) * (tim0_5_0 + tim0_6_0)) - (((FFTW_REAL) FFTW_K959492973) * (tim0_4_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K142314838) * (tim0_2_0 + tim0_9_0)) - (((FFTW_REAL) FFTW_K654860733) * (tim0_1_0 + tim0_10_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K755749574) * (tre0_10_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K989821441) * (tre0_2_0 - tre0_9_0)) + (((FFTW_REAL) FFTW_K540640817) * (tre0_8_0 - tre0_3_0)) + (((FFTW_REAL) FFTW_K281732556) * (tre0_7_0 - tre0_4_0)) + (((FFTW_REAL) FFTW_K909631995) * (tre0_5_0 - tre0_6_0)); - c_im(out[4 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[7 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K841253532) * (tre0_2_0 + tre0_9_0)) + (((FFTW_REAL) FFTW_K415415013) * (tre0_4_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K142314838) * (tre0_5_0 + tre0_6_0)) - (((FFTW_REAL) FFTW_K654860733) * (tre0_3_0 + tre0_8_0)) - (((FFTW_REAL) FFTW_K959492973) * (tre0_1_0 + tre0_10_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K281732556) * (tim0_1_0 - tim0_10_0)) + (((FFTW_REAL) FFTW_K540640817) * (tim0_9_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K755749574) * (tim0_3_0 - tim0_8_0)) + (((FFTW_REAL) FFTW_K909631995) * (tim0_7_0 - tim0_4_0)) + (((FFTW_REAL) FFTW_K989821441) * (tim0_5_0 - tim0_6_0)); - c_re(out[5 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[6 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K841253532) * (tim0_2_0 + tim0_9_0)) + (((FFTW_REAL) FFTW_K415415013) * (tim0_4_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K142314838) * (tim0_5_0 + tim0_6_0)) - (((FFTW_REAL) FFTW_K654860733) * (tim0_3_0 + tim0_8_0)) - (((FFTW_REAL) FFTW_K959492973) * (tim0_1_0 + tim0_10_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K281732556) * (tre0_10_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K540640817) * (tre0_2_0 - tre0_9_0)) + (((FFTW_REAL) FFTW_K755749574) * (tre0_8_0 - tre0_3_0)) + (((FFTW_REAL) FFTW_K909631995) * (tre0_4_0 - tre0_7_0)) + (((FFTW_REAL) FFTW_K989821441) * (tre0_6_0 - tre0_5_0)); - c_im(out[5 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[6 * ostride]) = tim1_0_0 - tim1_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 104 FP additions and 16 FP multiplications */ - -void fftw_no_twiddle_12(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[4 * istride]); - tim1_1_0 = c_im(in[4 * istride]); - tre1_2_0 = c_re(in[8 * istride]); - tim1_2_0 = c_im(in[8 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_0 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - tre0_1_0 = tre2_0_0 + tre2_1_0; - tre0_2_0 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - tim0_1_0 = tim2_0_0 + tim2_1_0; - tim0_2_0 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[3 * istride]); - tim1_0_0 = c_im(in[3 * istride]); - tre1_1_0 = c_re(in[7 * istride]); - tim1_1_0 = c_im(in[7 * istride]); - tre1_2_0 = c_re(in[11 * istride]); - tim1_2_0 = c_im(in[11 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_1 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - tre0_1_1 = tre2_0_0 + tre2_1_0; - tre0_2_1 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - tim0_1_1 = tim2_0_0 + tim2_1_0; - tim0_2_1 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[6 * istride]); - tim1_0_0 = c_im(in[6 * istride]); - tre1_1_0 = c_re(in[10 * istride]); - tim1_1_0 = c_im(in[10 * istride]); - tre1_2_0 = c_re(in[2 * istride]); - tim1_2_0 = c_im(in[2 * istride]); - tre0_0_2 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_2 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - tre0_1_2 = tre2_0_0 + tre2_1_0; - tre0_2_2 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - tim0_1_2 = tim2_0_0 + tim2_1_0; - tim0_2_2 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[9 * istride]); - tim1_0_0 = c_im(in[9 * istride]); - tre1_1_0 = c_re(in[istride]); - tim1_1_0 = c_im(in[istride]); - tre1_2_0 = c_re(in[5 * istride]); - tim1_2_0 = c_im(in[5 * istride]); - tre0_0_3 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_3 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - tre0_1_3 = tre2_0_0 + tre2_1_0; - tre0_2_3 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - tim0_1_3 = tim2_0_0 + tim2_1_0; - tim0_2_3 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_0_0 + tre0_0_2; - tim1_0_0 = tim0_0_0 + tim0_0_2; - tre1_1_0 = tre0_0_0 - tre0_0_2; - tim1_1_0 = tim0_0_0 - tim0_0_2; - tre1_0_1 = tre0_0_1 + tre0_0_3; - tim1_0_1 = tim0_0_1 + tim0_0_3; - tre1_1_1 = tre0_0_1 - tre0_0_3; - tim1_1_1 = tim0_0_1 - tim0_0_3; - c_re(out[0]) = tre1_0_0 + tre1_0_1; - c_im(out[0]) = tim1_0_0 + tim1_0_1; - c_re(out[6 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[6 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[9 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[9 * ostride]) = tim1_1_0 - tre1_1_1; - c_re(out[3 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[3 * ostride]) = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_1_0 + tre0_1_2; - tim1_0_0 = tim0_1_0 + tim0_1_2; - tre1_1_0 = tre0_1_0 - tre0_1_2; - tim1_1_0 = tim0_1_0 - tim0_1_2; - tre1_0_1 = tre0_1_1 + tre0_1_3; - tim1_0_1 = tim0_1_1 + tim0_1_3; - tre1_1_1 = tre0_1_1 - tre0_1_3; - tim1_1_1 = tim0_1_1 - tim0_1_3; - c_re(out[4 * ostride]) = tre1_0_0 + tre1_0_1; - c_im(out[4 * ostride]) = tim1_0_0 + tim1_0_1; - c_re(out[10 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[10 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[ostride]) = tim1_1_0 - tre1_1_1; - c_re(out[7 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[7 * ostride]) = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_2_0 + tre0_2_2; - tim1_0_0 = tim0_2_0 + tim0_2_2; - tre1_1_0 = tre0_2_0 - tre0_2_2; - tim1_1_0 = tim0_2_0 - tim0_2_2; - tre1_0_1 = tre0_2_1 + tre0_2_3; - tim1_0_1 = tim0_2_1 + tim0_2_3; - tre1_1_1 = tre0_2_1 - tre0_2_3; - tim1_1_1 = tim0_2_1 - tim0_2_3; - c_re(out[8 * ostride]) = tre1_0_0 + tre1_0_1; - c_im(out[8 * ostride]) = tim1_0_0 + tim1_0_1; - c_re(out[2 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[2 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[5 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[5 * ostride]) = tim1_1_0 - tre1_1_1; - c_re(out[11 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[11 * ostride]) = tim1_1_0 + tre1_1_1; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 324 FP additions and 144 FP multiplications */ - -void fftw_no_twiddle_13(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - FFTW_REAL tre0_5_0; - FFTW_REAL tim0_5_0; - FFTW_REAL tre0_6_0; - FFTW_REAL tim0_6_0; - FFTW_REAL tre0_7_0; - FFTW_REAL tim0_7_0; - FFTW_REAL tre0_8_0; - FFTW_REAL tim0_8_0; - FFTW_REAL tre0_9_0; - FFTW_REAL tim0_9_0; - FFTW_REAL tre0_10_0; - FFTW_REAL tim0_10_0; - FFTW_REAL tre0_11_0; - FFTW_REAL tim0_11_0; - FFTW_REAL tre0_12_0; - FFTW_REAL tim0_12_0; - tre0_0_0 = c_re(in[0]); - tim0_0_0 = c_im(in[0]); - tre0_1_0 = c_re(in[istride]); - tim0_1_0 = c_im(in[istride]); - tre0_2_0 = c_re(in[2 * istride]); - tim0_2_0 = c_im(in[2 * istride]); - tre0_3_0 = c_re(in[3 * istride]); - tim0_3_0 = c_im(in[3 * istride]); - tre0_4_0 = c_re(in[4 * istride]); - tim0_4_0 = c_im(in[4 * istride]); - tre0_5_0 = c_re(in[5 * istride]); - tim0_5_0 = c_im(in[5 * istride]); - tre0_6_0 = c_re(in[6 * istride]); - tim0_6_0 = c_im(in[6 * istride]); - tre0_7_0 = c_re(in[7 * istride]); - tim0_7_0 = c_im(in[7 * istride]); - tre0_8_0 = c_re(in[8 * istride]); - tim0_8_0 = c_im(in[8 * istride]); - tre0_9_0 = c_re(in[9 * istride]); - tim0_9_0 = c_im(in[9 * istride]); - tre0_10_0 = c_re(in[10 * istride]); - tim0_10_0 = c_im(in[10 * istride]); - tre0_11_0 = c_re(in[11 * istride]); - tim0_11_0 = c_im(in[11 * istride]); - tre0_12_0 = c_re(in[12 * istride]); - tim0_12_0 = c_im(in[12 * istride]); - c_re(out[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0 + tre0_3_0 + tre0_4_0 + tre0_5_0 + tre0_6_0 + tre0_7_0 + tre0_8_0 + tre0_9_0 + tre0_10_0 + tre0_11_0 + tre0_12_0; - c_im(out[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0 + tim0_3_0 + tim0_4_0 + tim0_5_0 + tim0_6_0 + tim0_7_0 + tim0_8_0 + tim0_9_0 + tim0_10_0 + tim0_11_0 + tim0_12_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K885456025) * (tre0_1_0 + tre0_12_0)) + (((FFTW_REAL) FFTW_K568064746) * (tre0_2_0 + tre0_11_0)) + (((FFTW_REAL) FFTW_K120536680) * (tre0_3_0 + tre0_10_0)) - (((FFTW_REAL) FFTW_K970941817) * (tre0_6_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K748510748) * (tre0_5_0 + tre0_8_0)) - (((FFTW_REAL) FFTW_K354604887) * (tre0_4_0 + tre0_9_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K464723172) * (tim0_1_0 - tim0_12_0)) + (((FFTW_REAL) FFTW_K822983865) * (tim0_2_0 - tim0_11_0)) + (((FFTW_REAL) FFTW_K992708874) * (tim0_3_0 - tim0_10_0)) + (((FFTW_REAL) FFTW_K935016242) * (tim0_4_0 - tim0_9_0)) + (((FFTW_REAL) FFTW_K663122658) * (tim0_5_0 - tim0_8_0)) + (((FFTW_REAL) FFTW_K239315664) * (tim0_6_0 - tim0_7_0)); - c_re(out[ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[12 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K885456025) * (tim0_1_0 + tim0_12_0)) + (((FFTW_REAL) FFTW_K568064746) * (tim0_2_0 + tim0_11_0)) + (((FFTW_REAL) FFTW_K120536680) * (tim0_3_0 + tim0_10_0)) - (((FFTW_REAL) FFTW_K970941817) * (tim0_6_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K748510748) * (tim0_5_0 + tim0_8_0)) - (((FFTW_REAL) FFTW_K354604887) * (tim0_4_0 + tim0_9_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K464723172) * (tre0_12_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K822983865) * (tre0_11_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K992708874) * (tre0_10_0 - tre0_3_0)) + (((FFTW_REAL) FFTW_K935016242) * (tre0_9_0 - tre0_4_0)) + (((FFTW_REAL) FFTW_K663122658) * (tre0_8_0 - tre0_5_0)) + (((FFTW_REAL) FFTW_K239315664) * (tre0_7_0 - tre0_6_0)); - c_im(out[ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[12 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K568064746) * (tre0_1_0 + tre0_12_0)) + (((FFTW_REAL) FFTW_K120536680) * (tre0_5_0 + tre0_8_0)) + (((FFTW_REAL) FFTW_K885456025) * (tre0_6_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K748510748) * (tre0_4_0 + tre0_9_0)) - (((FFTW_REAL) FFTW_K970941817) * (tre0_3_0 + tre0_10_0)) - (((FFTW_REAL) FFTW_K354604887) * (tre0_2_0 + tre0_11_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K822983865) * (tim0_1_0 - tim0_12_0)) + (((FFTW_REAL) FFTW_K935016242) * (tim0_2_0 - tim0_11_0)) + (((FFTW_REAL) FFTW_K239315664) * (tim0_3_0 - tim0_10_0)) + (((FFTW_REAL) FFTW_K663122658) * (tim0_9_0 - tim0_4_0)) + (((FFTW_REAL) FFTW_K992708874) * (tim0_8_0 - tim0_5_0)) + (((FFTW_REAL) FFTW_K464723172) * (tim0_7_0 - tim0_6_0)); - c_re(out[2 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[11 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K568064746) * (tim0_1_0 + tim0_12_0)) + (((FFTW_REAL) FFTW_K120536680) * (tim0_5_0 + tim0_8_0)) + (((FFTW_REAL) FFTW_K885456025) * (tim0_6_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K748510748) * (tim0_4_0 + tim0_9_0)) - (((FFTW_REAL) FFTW_K970941817) * (tim0_3_0 + tim0_10_0)) - (((FFTW_REAL) FFTW_K354604887) * (tim0_2_0 + tim0_11_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K822983865) * (tre0_12_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K935016242) * (tre0_11_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K239315664) * (tre0_10_0 - tre0_3_0)) + (((FFTW_REAL) FFTW_K663122658) * (tre0_4_0 - tre0_9_0)) + (((FFTW_REAL) FFTW_K992708874) * (tre0_5_0 - tre0_8_0)) + (((FFTW_REAL) FFTW_K464723172) * (tre0_6_0 - tre0_7_0)); - c_im(out[2 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[11 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K120536680) * (tre0_1_0 + tre0_12_0)) + (((FFTW_REAL) FFTW_K885456025) * (tre0_4_0 + tre0_9_0)) + (((FFTW_REAL) FFTW_K568064746) * (tre0_5_0 + tre0_8_0)) - (((FFTW_REAL) FFTW_K748510748) * (tre0_6_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K354604887) * (tre0_3_0 + tre0_10_0)) - (((FFTW_REAL) FFTW_K970941817) * (tre0_2_0 + tre0_11_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K992708874) * (tim0_1_0 - tim0_12_0)) + (((FFTW_REAL) FFTW_K239315664) * (tim0_2_0 - tim0_11_0)) + (((FFTW_REAL) FFTW_K935016242) * (tim0_10_0 - tim0_3_0)) + (((FFTW_REAL) FFTW_K464723172) * (tim0_9_0 - tim0_4_0)) + (((FFTW_REAL) FFTW_K822983865) * (tim0_5_0 - tim0_8_0)) + (((FFTW_REAL) FFTW_K663122658) * (tim0_6_0 - tim0_7_0)); - c_re(out[3 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[10 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K120536680) * (tim0_1_0 + tim0_12_0)) + (((FFTW_REAL) FFTW_K885456025) * (tim0_4_0 + tim0_9_0)) + (((FFTW_REAL) FFTW_K568064746) * (tim0_5_0 + tim0_8_0)) - (((FFTW_REAL) FFTW_K748510748) * (tim0_6_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K354604887) * (tim0_3_0 + tim0_10_0)) - (((FFTW_REAL) FFTW_K970941817) * (tim0_2_0 + tim0_11_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K992708874) * (tre0_12_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K239315664) * (tre0_11_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K935016242) * (tre0_3_0 - tre0_10_0)) + (((FFTW_REAL) FFTW_K464723172) * (tre0_4_0 - tre0_9_0)) + (((FFTW_REAL) FFTW_K822983865) * (tre0_8_0 - tre0_5_0)) + (((FFTW_REAL) FFTW_K663122658) * (tre0_7_0 - tre0_6_0)); - c_im(out[3 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[10 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K885456025) * (tre0_3_0 + tre0_10_0)) + (((FFTW_REAL) FFTW_K120536680) * (tre0_4_0 + tre0_9_0)) + (((FFTW_REAL) FFTW_K568064746) * (tre0_6_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K970941817) * (tre0_5_0 + tre0_8_0)) - (((FFTW_REAL) FFTW_K748510748) * (tre0_2_0 + tre0_11_0)) - (((FFTW_REAL) FFTW_K354604887) * (tre0_1_0 + tre0_12_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K935016242) * (tim0_1_0 - tim0_12_0)) + (((FFTW_REAL) FFTW_K663122658) * (tim0_11_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K464723172) * (tim0_10_0 - tim0_3_0)) + (((FFTW_REAL) FFTW_K992708874) * (tim0_4_0 - tim0_9_0)) + (((FFTW_REAL) FFTW_K239315664) * (tim0_8_0 - tim0_5_0)) + (((FFTW_REAL) FFTW_K822983865) * (tim0_7_0 - tim0_6_0)); - c_re(out[4 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[9 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K885456025) * (tim0_3_0 + tim0_10_0)) + (((FFTW_REAL) FFTW_K120536680) * (tim0_4_0 + tim0_9_0)) + (((FFTW_REAL) FFTW_K568064746) * (tim0_6_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K970941817) * (tim0_5_0 + tim0_8_0)) - (((FFTW_REAL) FFTW_K748510748) * (tim0_2_0 + tim0_11_0)) - (((FFTW_REAL) FFTW_K354604887) * (tim0_1_0 + tim0_12_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K935016242) * (tre0_12_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K663122658) * (tre0_2_0 - tre0_11_0)) + (((FFTW_REAL) FFTW_K464723172) * (tre0_3_0 - tre0_10_0)) + (((FFTW_REAL) FFTW_K992708874) * (tre0_9_0 - tre0_4_0)) + (((FFTW_REAL) FFTW_K239315664) * (tre0_5_0 - tre0_8_0)) + (((FFTW_REAL) FFTW_K822983865) * (tre0_6_0 - tre0_7_0)); - c_im(out[4 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[9 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K120536680) * (tre0_2_0 + tre0_11_0)) + (((FFTW_REAL) FFTW_K568064746) * (tre0_3_0 + tre0_10_0)) + (((FFTW_REAL) FFTW_K885456025) * (tre0_5_0 + tre0_8_0)) - (((FFTW_REAL) FFTW_K354604887) * (tre0_6_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K970941817) * (tre0_4_0 + tre0_9_0)) - (((FFTW_REAL) FFTW_K748510748) * (tre0_1_0 + tre0_12_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K663122658) * (tim0_1_0 - tim0_12_0)) + (((FFTW_REAL) FFTW_K992708874) * (tim0_11_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K822983865) * (tim0_3_0 - tim0_10_0)) + (((FFTW_REAL) FFTW_K239315664) * (tim0_9_0 - tim0_4_0)) + (((FFTW_REAL) FFTW_K464723172) * (tim0_8_0 - tim0_5_0)) + (((FFTW_REAL) FFTW_K935016242) * (tim0_6_0 - tim0_7_0)); - c_re(out[5 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[8 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K120536680) * (tim0_2_0 + tim0_11_0)) + (((FFTW_REAL) FFTW_K568064746) * (tim0_3_0 + tim0_10_0)) + (((FFTW_REAL) FFTW_K885456025) * (tim0_5_0 + tim0_8_0)) - (((FFTW_REAL) FFTW_K354604887) * (tim0_6_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K970941817) * (tim0_4_0 + tim0_9_0)) - (((FFTW_REAL) FFTW_K748510748) * (tim0_1_0 + tim0_12_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K663122658) * (tre0_12_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K992708874) * (tre0_2_0 - tre0_11_0)) + (((FFTW_REAL) FFTW_K822983865) * (tre0_10_0 - tre0_3_0)) + (((FFTW_REAL) FFTW_K239315664) * (tre0_4_0 - tre0_9_0)) + (((FFTW_REAL) FFTW_K464723172) * (tre0_5_0 - tre0_8_0)) + (((FFTW_REAL) FFTW_K935016242) * (tre0_7_0 - tre0_6_0)); - c_im(out[5 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[8 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K885456025) * (tre0_2_0 + tre0_11_0)) + (((FFTW_REAL) FFTW_K568064746) * (tre0_4_0 + tre0_9_0)) + (((FFTW_REAL) FFTW_K120536680) * (tre0_6_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K354604887) * (tre0_5_0 + tre0_8_0)) - (((FFTW_REAL) FFTW_K748510748) * (tre0_3_0 + tre0_10_0)) - (((FFTW_REAL) FFTW_K970941817) * (tre0_1_0 + tre0_12_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K239315664) * (tim0_1_0 - tim0_12_0)) + (((FFTW_REAL) FFTW_K464723172) * (tim0_11_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K663122658) * (tim0_3_0 - tim0_10_0)) + (((FFTW_REAL) FFTW_K822983865) * (tim0_9_0 - tim0_4_0)) + (((FFTW_REAL) FFTW_K935016242) * (tim0_5_0 - tim0_8_0)) + (((FFTW_REAL) FFTW_K992708874) * (tim0_7_0 - tim0_6_0)); - c_re(out[6 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[7 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K885456025) * (tim0_2_0 + tim0_11_0)) + (((FFTW_REAL) FFTW_K568064746) * (tim0_4_0 + tim0_9_0)) + (((FFTW_REAL) FFTW_K120536680) * (tim0_6_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K354604887) * (tim0_5_0 + tim0_8_0)) - (((FFTW_REAL) FFTW_K748510748) * (tim0_3_0 + tim0_10_0)) - (((FFTW_REAL) FFTW_K970941817) * (tim0_1_0 + tim0_12_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K239315664) * (tre0_12_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K464723172) * (tre0_2_0 - tre0_11_0)) + (((FFTW_REAL) FFTW_K663122658) * (tre0_10_0 - tre0_3_0)) + (((FFTW_REAL) FFTW_K822983865) * (tre0_4_0 - tre0_9_0)) + (((FFTW_REAL) FFTW_K935016242) * (tre0_8_0 - tre0_5_0)) + (((FFTW_REAL) FFTW_K992708874) * (tre0_6_0 - tre0_7_0)); - c_im(out[6 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[7 * ostride]) = tim1_0_0 - tim1_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 208 FP additions and 72 FP multiplications */ - -void fftw_no_twiddle_14(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_0_5; - FFTW_REAL tim0_0_5; - FFTW_REAL tre0_0_6; - FFTW_REAL tim0_0_6; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - FFTW_REAL tre0_1_5; - FFTW_REAL tim0_1_5; - FFTW_REAL tre0_1_6; - FFTW_REAL tim0_1_6; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[7 * istride]); - tim1_1_0 = c_im(in[7 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[2 * istride]); - tim1_0_0 = c_im(in[2 * istride]); - tre1_1_0 = c_re(in[9 * istride]); - tim1_1_0 = c_im(in[9 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[4 * istride]); - tim1_0_0 = c_im(in[4 * istride]); - tre1_1_0 = c_re(in[11 * istride]); - tim1_1_0 = c_im(in[11 * istride]); - tre0_0_2 = tre1_0_0 + tre1_1_0; - tim0_0_2 = tim1_0_0 + tim1_1_0; - tre0_1_2 = tre1_0_0 - tre1_1_0; - tim0_1_2 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[6 * istride]); - tim1_0_0 = c_im(in[6 * istride]); - tre1_1_0 = c_re(in[13 * istride]); - tim1_1_0 = c_im(in[13 * istride]); - tre0_0_3 = tre1_0_0 + tre1_1_0; - tim0_0_3 = tim1_0_0 + tim1_1_0; - tre0_1_3 = tre1_0_0 - tre1_1_0; - tim0_1_3 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[8 * istride]); - tim1_0_0 = c_im(in[8 * istride]); - tre1_1_0 = c_re(in[istride]); - tim1_1_0 = c_im(in[istride]); - tre0_0_4 = tre1_0_0 + tre1_1_0; - tim0_0_4 = tim1_0_0 + tim1_1_0; - tre0_1_4 = tre1_0_0 - tre1_1_0; - tim0_1_4 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[10 * istride]); - tim1_0_0 = c_im(in[10 * istride]); - tre1_1_0 = c_re(in[3 * istride]); - tim1_1_0 = c_im(in[3 * istride]); - tre0_0_5 = tre1_0_0 + tre1_1_0; - tim0_0_5 = tim1_0_0 + tim1_1_0; - tre0_1_5 = tre1_0_0 - tre1_1_0; - tim0_1_5 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[12 * istride]); - tim1_0_0 = c_im(in[12 * istride]); - tre1_1_0 = c_re(in[5 * istride]); - tim1_1_0 = c_im(in[5 * istride]); - tre0_0_6 = tre1_0_0 + tre1_1_0; - tim0_0_6 = tim1_0_0 + tim1_1_0; - tre0_1_6 = tre1_0_0 - tre1_1_0; - tim0_1_6 = tim1_0_0 - tim1_1_0; - } - c_re(out[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2 + tre0_0_3 + tre0_0_4 + tre0_0_5 + tre0_0_6; - c_im(out[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2 + tim0_0_3 + tim0_0_4 + tim0_0_5 + tim0_0_6; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_0_1 + tre0_0_6)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_0_3 + tre0_0_4)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_0_2 + tre0_0_5)); - tre2_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tim0_0_1 - tim0_0_6)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_0_2 - tim0_0_5)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_0_3 - tim0_0_4)); - c_re(out[8 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[6 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_0_1 + tim0_0_6)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_0_3 + tim0_0_4)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_0_2 + tim0_0_5)); - tim2_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tre0_0_6 - tre0_0_1)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_0_5 - tre0_0_2)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_0_4 - tre0_0_3)); - c_im(out[8 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[6 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_0_3 + tre0_0_4)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_0_2 + tre0_0_5)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_0_1 + tre0_0_6)); - tre2_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tim0_0_1 - tim0_0_6)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_0_5 - tim0_0_2)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_0_4 - tim0_0_3)); - c_re(out[2 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[12 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_0_3 + tim0_0_4)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_0_2 + tim0_0_5)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_0_1 + tim0_0_6)); - tim2_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tre0_0_6 - tre0_0_1)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_0_2 - tre0_0_5)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_0_3 - tre0_0_4)); - c_im(out[2 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[12 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_0_2 + tre0_0_5)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_0_3 + tre0_0_4)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_0_1 + tre0_0_6)); - tre2_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tim0_0_1 - tim0_0_6)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_0_5 - tim0_0_2)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_0_3 - tim0_0_4)); - c_re(out[10 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[4 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_0_2 + tim0_0_5)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_0_3 + tim0_0_4)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_0_1 + tim0_0_6)); - tim2_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tre0_0_6 - tre0_0_1)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_0_2 - tre0_0_5)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_0_4 - tre0_0_3)); - c_im(out[10 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[4 * ostride]) = tim2_0_0 - tim2_1_0; - } - c_re(out[7 * ostride]) = tre0_1_0 + tre0_1_1 + tre0_1_2 + tre0_1_3 + tre0_1_4 + tre0_1_5 + tre0_1_6; - c_im(out[7 * ostride]) = tim0_1_0 + tim0_1_1 + tim0_1_2 + tim0_1_3 + tim0_1_4 + tim0_1_5 + tim0_1_6; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_1_1 + tre0_1_6)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_1_3 + tre0_1_4)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_1_2 + tre0_1_5)); - tre2_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tim0_1_1 - tim0_1_6)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_1_2 - tim0_1_5)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_1_3 - tim0_1_4)); - c_re(out[ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[13 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_1_1 + tim0_1_6)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_1_3 + tim0_1_4)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_1_2 + tim0_1_5)); - tim2_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tre0_1_6 - tre0_1_1)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_1_5 - tre0_1_2)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_1_4 - tre0_1_3)); - c_im(out[ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[13 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_1_3 + tre0_1_4)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_1_2 + tre0_1_5)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_1_1 + tre0_1_6)); - tre2_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tim0_1_1 - tim0_1_6)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_1_5 - tim0_1_2)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_1_4 - tim0_1_3)); - c_re(out[9 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[5 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_1_3 + tim0_1_4)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_1_2 + tim0_1_5)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_1_1 + tim0_1_6)); - tim2_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tre0_1_6 - tre0_1_1)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_1_2 - tre0_1_5)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_1_3 - tre0_1_4)); - c_im(out[9 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[5 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_1_2 + tre0_1_5)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_1_3 + tre0_1_4)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_1_1 + tre0_1_6)); - tre2_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tim0_1_1 - tim0_1_6)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_1_5 - tim0_1_2)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_1_3 - tim0_1_4)); - c_re(out[3 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[11 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_1_2 + tim0_1_5)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_1_3 + tim0_1_4)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_1_1 + tim0_1_6)); - tim2_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tre0_1_6 - tre0_1_1)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_1_2 - tre0_1_5)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_1_4 - tre0_1_3)); - c_im(out[3 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[11 * ostride]) = tim2_0_0 - tim2_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 202 FP additions and 68 FP multiplications */ - -void fftw_no_twiddle_15(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - FFTW_REAL tre0_2_4; - FFTW_REAL tim0_2_4; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[5 * istride]); - tim1_1_0 = c_im(in[5 * istride]); - tre1_2_0 = c_re(in[10 * istride]); - tim1_2_0 = c_im(in[10 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_0 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - tre0_1_0 = tre2_0_0 + tre2_1_0; - tre0_2_0 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - tim0_1_0 = tim2_0_0 + tim2_1_0; - tim0_2_0 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[3 * istride]); - tim1_0_0 = c_im(in[3 * istride]); - tre1_1_0 = c_re(in[8 * istride]); - tim1_1_0 = c_im(in[8 * istride]); - tre1_2_0 = c_re(in[13 * istride]); - tim1_2_0 = c_im(in[13 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_1 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - tre0_1_1 = tre2_0_0 + tre2_1_0; - tre0_2_1 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - tim0_1_1 = tim2_0_0 + tim2_1_0; - tim0_2_1 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[6 * istride]); - tim1_0_0 = c_im(in[6 * istride]); - tre1_1_0 = c_re(in[11 * istride]); - tim1_1_0 = c_im(in[11 * istride]); - tre1_2_0 = c_re(in[istride]); - tim1_2_0 = c_im(in[istride]); - tre0_0_2 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_2 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - tre0_1_2 = tre2_0_0 + tre2_1_0; - tre0_2_2 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - tim0_1_2 = tim2_0_0 + tim2_1_0; - tim0_2_2 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[9 * istride]); - tim1_0_0 = c_im(in[9 * istride]); - tre1_1_0 = c_re(in[14 * istride]); - tim1_1_0 = c_im(in[14 * istride]); - tre1_2_0 = c_re(in[4 * istride]); - tim1_2_0 = c_im(in[4 * istride]); - tre0_0_3 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_3 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - tre0_1_3 = tre2_0_0 + tre2_1_0; - tre0_2_3 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - tim0_1_3 = tim2_0_0 + tim2_1_0; - tim0_2_3 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[12 * istride]); - tim1_0_0 = c_im(in[12 * istride]); - tre1_1_0 = c_re(in[2 * istride]); - tim1_1_0 = c_im(in[2 * istride]); - tre1_2_0 = c_re(in[7 * istride]); - tim1_2_0 = c_im(in[7 * istride]); - tre0_0_4 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_4 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - tre0_1_4 = tre2_0_0 + tre2_1_0; - tre0_2_4 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - tim0_1_4 = tim2_0_0 + tim2_1_0; - tim0_2_4 = tim2_0_0 - tim2_1_0; - } - } - c_re(out[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2 + tre0_0_3 + tre0_0_4; - c_im(out[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2 + tim0_0_3 + tim0_0_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_0_1 + tre0_0_4)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_0_2 + tre0_0_3)); - tre2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_0_1 - tim0_0_4)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_0_2 - tim0_0_3)); - c_re(out[6 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[9 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_0_1 + tim0_0_4)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_0_2 + tim0_0_3)); - tim2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_0_4 - tre0_0_1)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_0_3 - tre0_0_2)); - c_im(out[6 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[9 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_0_2 + tre0_0_3)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_0_1 + tre0_0_4)); - tre2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_0_1 - tim0_0_4)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_0_3 - tim0_0_2)); - c_re(out[12 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[3 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_0_2 + tim0_0_3)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_0_1 + tim0_0_4)); - tim2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_0_4 - tre0_0_1)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_0_2 - tre0_0_3)); - c_im(out[12 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[3 * ostride]) = tim2_0_0 - tim2_1_0; - } - c_re(out[10 * ostride]) = tre0_1_0 + tre0_1_1 + tre0_1_2 + tre0_1_3 + tre0_1_4; - c_im(out[10 * ostride]) = tim0_1_0 + tim0_1_1 + tim0_1_2 + tim0_1_3 + tim0_1_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_1 + tre0_1_4)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_2 + tre0_1_3)); - tre2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_1_1 - tim0_1_4)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_1_2 - tim0_1_3)); - c_re(out[ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[4 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_1 + tim0_1_4)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_2 + tim0_1_3)); - tim2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_1_4 - tre0_1_1)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_1_3 - tre0_1_2)); - c_im(out[ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[4 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_2 + tre0_1_3)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_1 + tre0_1_4)); - tre2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_1_1 - tim0_1_4)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_1_3 - tim0_1_2)); - c_re(out[7 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[13 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_2 + tim0_1_3)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_1 + tim0_1_4)); - tim2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_1_4 - tre0_1_1)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_1_2 - tre0_1_3)); - c_im(out[7 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[13 * ostride]) = tim2_0_0 - tim2_1_0; - } - c_re(out[5 * ostride]) = tre0_2_0 + tre0_2_1 + tre0_2_2 + tre0_2_3 + tre0_2_4; - c_im(out[5 * ostride]) = tim0_2_0 + tim0_2_1 + tim0_2_2 + tim0_2_3 + tim0_2_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_2_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_2_1 + tre0_2_4)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_2_2 + tre0_2_3)); - tre2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_2_1 - tim0_2_4)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_2_2 - tim0_2_3)); - c_re(out[11 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[14 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_2_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_2_1 + tim0_2_4)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_2_2 + tim0_2_3)); - tim2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_2_4 - tre0_2_1)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_2_3 - tre0_2_2)); - c_im(out[11 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[14 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_2_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_2_2 + tre0_2_3)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_2_1 + tre0_2_4)); - tre2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_2_1 - tim0_2_4)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_2_3 - tim0_2_2)); - c_re(out[2 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[8 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_2_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_2_2 + tim0_2_3)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_2_1 + tim0_2_4)); - tim2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_2_4 - tre0_2_1)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_2_2 - tre0_2_3)); - c_im(out[2 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[8 * ostride]) = tim2_0_0 - tim2_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 144 FP additions and 24 FP multiplications */ - -void fftw_no_twiddle_16(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_3_1; - FFTW_REAL tim0_3_1; - FFTW_REAL tre0_3_2; - FFTW_REAL tim0_3_2; - FFTW_REAL tre0_3_3; - FFTW_REAL tim0_3_3; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[0]); - tim2_0_0 = c_im(in[0]); - tre2_1_0 = c_re(in[8 * istride]); - tim2_1_0 = c_im(in[8 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[4 * istride]); - tim2_0_0 = c_im(in[4 * istride]); - tre2_1_0 = c_re(in[12 * istride]); - tim2_1_0 = c_im(in[12 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_0 = tre1_0_0 + tre1_0_1; - tim0_0_0 = tim1_0_0 + tim1_0_1; - tre0_2_0 = tre1_0_0 - tre1_0_1; - tim0_2_0 = tim1_0_0 - tim1_0_1; - tre0_1_0 = tre1_1_0 + tim1_1_1; - tim0_1_0 = tim1_1_0 - tre1_1_1; - tre0_3_0 = tre1_1_0 - tim1_1_1; - tim0_3_0 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[istride]); - tim2_0_0 = c_im(in[istride]); - tre2_1_0 = c_re(in[9 * istride]); - tim2_1_0 = c_im(in[9 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[5 * istride]); - tim2_0_0 = c_im(in[5 * istride]); - tre2_1_0 = c_re(in[13 * istride]); - tim2_1_0 = c_im(in[13 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_1 = tre1_0_0 + tre1_0_1; - tim0_0_1 = tim1_0_0 + tim1_0_1; - tre0_2_1 = tre1_0_0 - tre1_0_1; - tim0_2_1 = tim1_0_0 - tim1_0_1; - tre0_1_1 = tre1_1_0 + tim1_1_1; - tim0_1_1 = tim1_1_0 - tre1_1_1; - tre0_3_1 = tre1_1_0 - tim1_1_1; - tim0_3_1 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[2 * istride]); - tim2_0_0 = c_im(in[2 * istride]); - tre2_1_0 = c_re(in[10 * istride]); - tim2_1_0 = c_im(in[10 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[6 * istride]); - tim2_0_0 = c_im(in[6 * istride]); - tre2_1_0 = c_re(in[14 * istride]); - tim2_1_0 = c_im(in[14 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_2 = tre1_0_0 + tre1_0_1; - tim0_0_2 = tim1_0_0 + tim1_0_1; - tre0_2_2 = tre1_0_0 - tre1_0_1; - tim0_2_2 = tim1_0_0 - tim1_0_1; - tre0_1_2 = tre1_1_0 + tim1_1_1; - tim0_1_2 = tim1_1_0 - tre1_1_1; - tre0_3_2 = tre1_1_0 - tim1_1_1; - tim0_3_2 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[3 * istride]); - tim2_0_0 = c_im(in[3 * istride]); - tre2_1_0 = c_re(in[11 * istride]); - tim2_1_0 = c_im(in[11 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[7 * istride]); - tim2_0_0 = c_im(in[7 * istride]); - tre2_1_0 = c_re(in[15 * istride]); - tim2_1_0 = c_im(in[15 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_3 = tre1_0_0 + tre1_0_1; - tim0_0_3 = tim1_0_0 + tim1_0_1; - tre0_2_3 = tre1_0_0 - tre1_0_1; - tim0_2_3 = tim1_0_0 - tim1_0_1; - tre0_1_3 = tre1_1_0 + tim1_1_1; - tim0_1_3 = tim1_1_0 - tre1_1_1; - tre0_3_3 = tre1_1_0 - tim1_1_1; - tim0_3_3 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_0_0 + tre0_0_2; - tim1_0_0 = tim0_0_0 + tim0_0_2; - tre1_1_0 = tre0_0_0 - tre0_0_2; - tim1_1_0 = tim0_0_0 - tim0_0_2; - tre1_0_1 = tre0_0_1 + tre0_0_3; - tim1_0_1 = tim0_0_1 + tim0_0_3; - tre1_1_1 = tre0_0_1 - tre0_0_3; - tim1_1_1 = tim0_0_1 - tim0_0_3; - c_re(out[0]) = tre1_0_0 + tre1_0_1; - c_im(out[0]) = tim1_0_0 + tim1_0_1; - c_re(out[8 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[8 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[4 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[4 * ostride]) = tim1_1_0 - tre1_1_1; - c_re(out[12 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[12 * ostride]) = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_2 + tim0_1_2); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_2 - tre0_1_2); - tre1_0_0 = tre0_1_0 + tre2_1_0; - tim1_0_0 = tim0_1_0 + tim2_1_0; - tre1_1_0 = tre0_1_0 - tre2_1_0; - tim1_1_0 = tim0_1_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_1_1) + (((FFTW_REAL) FFTW_K382683432) * tim0_1_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_1_1) - (((FFTW_REAL) FFTW_K382683432) * tre0_1_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_1_3) + (((FFTW_REAL) FFTW_K923879532) * tim0_1_3); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_1_3) - (((FFTW_REAL) FFTW_K923879532) * tre0_1_3); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - c_re(out[ostride]) = tre1_0_0 + tre1_0_1; - c_im(out[ostride]) = tim1_0_0 + tim1_0_1; - c_re(out[9 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[9 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[5 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[5 * ostride]) = tim1_1_0 - tre1_1_1; - c_re(out[13 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[13 * ostride]) = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_2_0 + tim0_2_2; - tim1_0_0 = tim0_2_0 - tre0_2_2; - tre1_1_0 = tre0_2_0 - tim0_2_2; - tim1_1_0 = tim0_2_0 + tre0_2_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_1 + tim0_2_1); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_1 - tre0_2_1); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_3 - tre0_2_3); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_3 + tre0_2_3); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - c_re(out[2 * ostride]) = tre1_0_0 + tre1_0_1; - c_im(out[2 * ostride]) = tim1_0_0 + tim1_0_1; - c_re(out[10 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[10 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[6 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[6 * ostride]) = tim1_1_0 - tre1_1_1; - c_re(out[14 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[14 * ostride]) = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_3_2 - tre0_3_2); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_3_2 + tre0_3_2); - tre1_0_0 = tre0_3_0 + tre2_1_0; - tim1_0_0 = tim0_3_0 - tim2_1_0; - tre1_1_0 = tre0_3_0 - tre2_1_0; - tim1_1_0 = tim0_3_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_1) + (((FFTW_REAL) FFTW_K923879532) * tim0_3_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_1) - (((FFTW_REAL) FFTW_K923879532) * tre0_3_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_3_3) + (((FFTW_REAL) FFTW_K382683432) * tim0_3_3); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_3) - (((FFTW_REAL) FFTW_K923879532) * tim0_3_3); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - c_re(out[3 * ostride]) = tre1_0_0 + tre1_0_1; - c_im(out[3 * ostride]) = tim1_0_0 + tim1_0_1; - c_re(out[11 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[11 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[7 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[7 * ostride]) = tim1_1_0 - tre1_1_1; - c_re(out[15 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[15 * ostride]) = tim1_1_0 + tre1_1_1; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 4 FP additions and 0 FP multiplications */ - -void fftw_no_twiddle_2(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - tre0_0_0 = c_re(in[0]); - tim0_0_0 = c_im(in[0]); - tre0_1_0 = c_re(in[istride]); - tim0_1_0 = c_im(in[istride]); - c_re(out[0]) = tre0_0_0 + tre0_1_0; - c_im(out[0]) = tim0_0_0 + tim0_1_0; - c_re(out[ostride]) = tre0_0_0 - tre0_1_0; - c_im(out[ostride]) = tim0_0_0 - tim0_1_0; -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 14 FP additions and 4 FP multiplications */ - -void fftw_no_twiddle_3(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - tre0_0_0 = c_re(in[0]); - tim0_0_0 = c_im(in[0]); - tre0_1_0 = c_re(in[istride]); - tim0_1_0 = c_im(in[istride]); - tre0_2_0 = c_re(in[2 * istride]); - tim0_2_0 = c_im(in[2 * istride]); - c_re(out[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0; - c_im(out[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_1_0 + tre0_2_0)); - tre1_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_1_0 - tim0_2_0); - c_re(out[ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[2 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_1_0 + tim0_2_0)); - tim1_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_2_0 - tre0_1_0); - c_im(out[ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[2 * ostride]) = tim1_0_0 - tim1_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 376 FP additions and 88 FP multiplications */ - -void fftw_no_twiddle_32(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_0_5; - FFTW_REAL tim0_0_5; - FFTW_REAL tre0_0_6; - FFTW_REAL tim0_0_6; - FFTW_REAL tre0_0_7; - FFTW_REAL tim0_0_7; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - FFTW_REAL tre0_1_5; - FFTW_REAL tim0_1_5; - FFTW_REAL tre0_1_6; - FFTW_REAL tim0_1_6; - FFTW_REAL tre0_1_7; - FFTW_REAL tim0_1_7; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - FFTW_REAL tre0_2_4; - FFTW_REAL tim0_2_4; - FFTW_REAL tre0_2_5; - FFTW_REAL tim0_2_5; - FFTW_REAL tre0_2_6; - FFTW_REAL tim0_2_6; - FFTW_REAL tre0_2_7; - FFTW_REAL tim0_2_7; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_3_1; - FFTW_REAL tim0_3_1; - FFTW_REAL tre0_3_2; - FFTW_REAL tim0_3_2; - FFTW_REAL tre0_3_3; - FFTW_REAL tim0_3_3; - FFTW_REAL tre0_3_4; - FFTW_REAL tim0_3_4; - FFTW_REAL tre0_3_5; - FFTW_REAL tim0_3_5; - FFTW_REAL tre0_3_6; - FFTW_REAL tim0_3_6; - FFTW_REAL tre0_3_7; - FFTW_REAL tim0_3_7; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[0]); - tim2_0_0 = c_im(in[0]); - tre2_1_0 = c_re(in[16 * istride]); - tim2_1_0 = c_im(in[16 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[8 * istride]); - tim2_0_0 = c_im(in[8 * istride]); - tre2_1_0 = c_re(in[24 * istride]); - tim2_1_0 = c_im(in[24 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_0 = tre1_0_0 + tre1_0_1; - tim0_0_0 = tim1_0_0 + tim1_0_1; - tre0_2_0 = tre1_0_0 - tre1_0_1; - tim0_2_0 = tim1_0_0 - tim1_0_1; - tre0_1_0 = tre1_1_0 + tim1_1_1; - tim0_1_0 = tim1_1_0 - tre1_1_1; - tre0_3_0 = tre1_1_0 - tim1_1_1; - tim0_3_0 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[istride]); - tim2_0_0 = c_im(in[istride]); - tre2_1_0 = c_re(in[17 * istride]); - tim2_1_0 = c_im(in[17 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[9 * istride]); - tim2_0_0 = c_im(in[9 * istride]); - tre2_1_0 = c_re(in[25 * istride]); - tim2_1_0 = c_im(in[25 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_1 = tre1_0_0 + tre1_0_1; - tim0_0_1 = tim1_0_0 + tim1_0_1; - tre0_2_1 = tre1_0_0 - tre1_0_1; - tim0_2_1 = tim1_0_0 - tim1_0_1; - tre0_1_1 = tre1_1_0 + tim1_1_1; - tim0_1_1 = tim1_1_0 - tre1_1_1; - tre0_3_1 = tre1_1_0 - tim1_1_1; - tim0_3_1 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[2 * istride]); - tim2_0_0 = c_im(in[2 * istride]); - tre2_1_0 = c_re(in[18 * istride]); - tim2_1_0 = c_im(in[18 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[10 * istride]); - tim2_0_0 = c_im(in[10 * istride]); - tre2_1_0 = c_re(in[26 * istride]); - tim2_1_0 = c_im(in[26 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_2 = tre1_0_0 + tre1_0_1; - tim0_0_2 = tim1_0_0 + tim1_0_1; - tre0_2_2 = tre1_0_0 - tre1_0_1; - tim0_2_2 = tim1_0_0 - tim1_0_1; - tre0_1_2 = tre1_1_0 + tim1_1_1; - tim0_1_2 = tim1_1_0 - tre1_1_1; - tre0_3_2 = tre1_1_0 - tim1_1_1; - tim0_3_2 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[3 * istride]); - tim2_0_0 = c_im(in[3 * istride]); - tre2_1_0 = c_re(in[19 * istride]); - tim2_1_0 = c_im(in[19 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[11 * istride]); - tim2_0_0 = c_im(in[11 * istride]); - tre2_1_0 = c_re(in[27 * istride]); - tim2_1_0 = c_im(in[27 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_3 = tre1_0_0 + tre1_0_1; - tim0_0_3 = tim1_0_0 + tim1_0_1; - tre0_2_3 = tre1_0_0 - tre1_0_1; - tim0_2_3 = tim1_0_0 - tim1_0_1; - tre0_1_3 = tre1_1_0 + tim1_1_1; - tim0_1_3 = tim1_1_0 - tre1_1_1; - tre0_3_3 = tre1_1_0 - tim1_1_1; - tim0_3_3 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[4 * istride]); - tim2_0_0 = c_im(in[4 * istride]); - tre2_1_0 = c_re(in[20 * istride]); - tim2_1_0 = c_im(in[20 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[12 * istride]); - tim2_0_0 = c_im(in[12 * istride]); - tre2_1_0 = c_re(in[28 * istride]); - tim2_1_0 = c_im(in[28 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_4 = tre1_0_0 + tre1_0_1; - tim0_0_4 = tim1_0_0 + tim1_0_1; - tre0_2_4 = tre1_0_0 - tre1_0_1; - tim0_2_4 = tim1_0_0 - tim1_0_1; - tre0_1_4 = tre1_1_0 + tim1_1_1; - tim0_1_4 = tim1_1_0 - tre1_1_1; - tre0_3_4 = tre1_1_0 - tim1_1_1; - tim0_3_4 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[5 * istride]); - tim2_0_0 = c_im(in[5 * istride]); - tre2_1_0 = c_re(in[21 * istride]); - tim2_1_0 = c_im(in[21 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[13 * istride]); - tim2_0_0 = c_im(in[13 * istride]); - tre2_1_0 = c_re(in[29 * istride]); - tim2_1_0 = c_im(in[29 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_5 = tre1_0_0 + tre1_0_1; - tim0_0_5 = tim1_0_0 + tim1_0_1; - tre0_2_5 = tre1_0_0 - tre1_0_1; - tim0_2_5 = tim1_0_0 - tim1_0_1; - tre0_1_5 = tre1_1_0 + tim1_1_1; - tim0_1_5 = tim1_1_0 - tre1_1_1; - tre0_3_5 = tre1_1_0 - tim1_1_1; - tim0_3_5 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[6 * istride]); - tim2_0_0 = c_im(in[6 * istride]); - tre2_1_0 = c_re(in[22 * istride]); - tim2_1_0 = c_im(in[22 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[14 * istride]); - tim2_0_0 = c_im(in[14 * istride]); - tre2_1_0 = c_re(in[30 * istride]); - tim2_1_0 = c_im(in[30 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_6 = tre1_0_0 + tre1_0_1; - tim0_0_6 = tim1_0_0 + tim1_0_1; - tre0_2_6 = tre1_0_0 - tre1_0_1; - tim0_2_6 = tim1_0_0 - tim1_0_1; - tre0_1_6 = tre1_1_0 + tim1_1_1; - tim0_1_6 = tim1_1_0 - tre1_1_1; - tre0_3_6 = tre1_1_0 - tim1_1_1; - tim0_3_6 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[7 * istride]); - tim2_0_0 = c_im(in[7 * istride]); - tre2_1_0 = c_re(in[23 * istride]); - tim2_1_0 = c_im(in[23 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[15 * istride]); - tim2_0_0 = c_im(in[15 * istride]); - tre2_1_0 = c_re(in[31 * istride]); - tim2_1_0 = c_im(in[31 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_7 = tre1_0_0 + tre1_0_1; - tim0_0_7 = tim1_0_0 + tim1_0_1; - tre0_2_7 = tre1_0_0 - tre1_0_1; - tim0_2_7 = tim1_0_0 - tim1_0_1; - tre0_1_7 = tre1_1_0 + tim1_1_1; - tim0_1_7 = tim1_1_0 - tre1_1_1; - tre0_3_7 = tre1_1_0 - tim1_1_1; - tim0_3_7 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_0_0 + tre0_0_4; - tim1_0_0 = tim0_0_0 + tim0_0_4; - tre1_1_0 = tre0_0_0 - tre0_0_4; - tim1_1_0 = tim0_0_0 - tim0_0_4; - tre1_0_1 = tre0_0_1 + tre0_0_5; - tim1_0_1 = tim0_0_1 + tim0_0_5; - tre1_1_1 = tre0_0_1 - tre0_0_5; - tim1_1_1 = tim0_0_1 - tim0_0_5; - tre1_0_2 = tre0_0_2 + tre0_0_6; - tim1_0_2 = tim0_0_2 + tim0_0_6; - tre1_1_2 = tre0_0_2 - tre0_0_6; - tim1_1_2 = tim0_0_2 - tim0_0_6; - tre1_0_3 = tre0_0_3 + tre0_0_7; - tim1_0_3 = tim0_0_3 + tim0_0_7; - tre1_1_3 = tre0_0_3 - tre0_0_7; - tim1_1_3 = tim0_0_3 - tim0_0_7; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[0]) = tre2_0_0 + tre2_0_1; - c_im(out[0]) = tim2_0_0 + tim2_0_1; - c_re(out[16 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[16 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[8 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[8 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[24 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[24 * ostride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(out[4 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[4 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[20 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[20 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[12 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[12 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[28 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[28 * ostride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_4 + tim0_1_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_4 - tre0_1_4); - tre1_0_0 = tre0_1_0 + tre2_1_0; - tim1_0_0 = tim0_1_0 + tim2_1_0; - tre1_1_0 = tre0_1_0 - tre2_1_0; - tim1_1_0 = tim0_1_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_1_1) + (((FFTW_REAL) FFTW_K195090322) * tim0_1_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_1_1) - (((FFTW_REAL) FFTW_K195090322) * tre0_1_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_1_5) + (((FFTW_REAL) FFTW_K831469612) * tim0_1_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_1_5) - (((FFTW_REAL) FFTW_K831469612) * tre0_1_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_1_2) + (((FFTW_REAL) FFTW_K382683432) * tim0_1_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_1_2) - (((FFTW_REAL) FFTW_K382683432) * tre0_1_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_1_6) + (((FFTW_REAL) FFTW_K923879532) * tim0_1_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_1_6) - (((FFTW_REAL) FFTW_K923879532) * tre0_1_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_1_3) + (((FFTW_REAL) FFTW_K555570233) * tim0_1_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_1_3) - (((FFTW_REAL) FFTW_K555570233) * tre0_1_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_1_7) + (((FFTW_REAL) FFTW_K980785280) * tim0_1_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_1_7) - (((FFTW_REAL) FFTW_K980785280) * tre0_1_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[17 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[17 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[9 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[9 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[25 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[25 * ostride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(out[5 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[5 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[21 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[21 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[13 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[13 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[29 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[29 * ostride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_2_0 + tim0_2_4; - tim1_0_0 = tim0_2_0 - tre0_2_4; - tre1_1_0 = tre0_2_0 - tim0_2_4; - tim1_1_0 = tim0_2_0 + tre0_2_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_2_1) + (((FFTW_REAL) FFTW_K382683432) * tim0_2_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_2_1) - (((FFTW_REAL) FFTW_K382683432) * tre0_2_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_2_5) - (((FFTW_REAL) FFTW_K382683432) * tre0_2_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_2_5) + (((FFTW_REAL) FFTW_K923879532) * tre0_2_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_2 + tim0_2_2); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_2 - tre0_2_2); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_6 - tre0_2_6); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_6 + tre0_2_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 - tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_2_3) + (((FFTW_REAL) FFTW_K923879532) * tim0_2_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_2_3) - (((FFTW_REAL) FFTW_K923879532) * tre0_2_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_2_7) - (((FFTW_REAL) FFTW_K923879532) * tre0_2_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_2_7) + (((FFTW_REAL) FFTW_K382683432) * tre0_2_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 - tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[2 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[2 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[18 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[18 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[10 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[10 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[26 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[26 * ostride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(out[6 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[6 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[22 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[22 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[14 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[14 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[30 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[30 * ostride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_3_4 - tre0_3_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_3_4 + tre0_3_4); - tre1_0_0 = tre0_3_0 + tre2_1_0; - tim1_0_0 = tim0_3_0 - tim2_1_0; - tre1_1_0 = tre0_3_0 - tre2_1_0; - tim1_1_0 = tim0_3_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_3_1) + (((FFTW_REAL) FFTW_K555570233) * tim0_3_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_3_1) - (((FFTW_REAL) FFTW_K555570233) * tre0_3_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_3_5) - (((FFTW_REAL) FFTW_K980785280) * tre0_3_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_3_5) + (((FFTW_REAL) FFTW_K195090322) * tre0_3_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_2) + (((FFTW_REAL) FFTW_K923879532) * tim0_3_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_2) - (((FFTW_REAL) FFTW_K923879532) * tre0_3_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_3_6) + (((FFTW_REAL) FFTW_K382683432) * tim0_3_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_6) - (((FFTW_REAL) FFTW_K923879532) * tim0_3_6); - tre1_0_2 = tre2_0_0 - tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 + tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_3_3) - (((FFTW_REAL) FFTW_K195090322) * tre0_3_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_3_3) + (((FFTW_REAL) FFTW_K980785280) * tre0_3_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_3_7) + (((FFTW_REAL) FFTW_K831469612) * tim0_3_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_3_7) - (((FFTW_REAL) FFTW_K555570233) * tim0_3_7); - tre1_0_3 = tre2_0_0 - tre2_1_0; - tim1_0_3 = tim2_1_0 - tim2_0_0; - tre1_1_3 = tre2_0_0 + tre2_1_0; - tim1_1_3 = (-(tim2_0_0 + tim2_1_0)); - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[3 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[3 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[19 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[19 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[11 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[11 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[27 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[27 * ostride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(out[7 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[7 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[23 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[23 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[15 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[15 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[31 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[31 * ostride]) = tim2_1_0 + tre2_1_1; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 16 FP additions and 0 FP multiplications */ - -void fftw_no_twiddle_4(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[2 * istride]); - tim1_1_0 = c_im(in[2 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[istride]); - tim1_0_0 = c_im(in[istride]); - tre1_1_0 = c_re(in[3 * istride]); - tim1_1_0 = c_im(in[3 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - c_re(out[0]) = tre0_0_0 + tre0_0_1; - c_im(out[0]) = tim0_0_0 + tim0_0_1; - c_re(out[2 * ostride]) = tre0_0_0 - tre0_0_1; - c_im(out[2 * ostride]) = tim0_0_0 - tim0_0_1; - c_re(out[ostride]) = tre0_1_0 + tim0_1_1; - c_im(out[ostride]) = tim0_1_0 - tre0_1_1; - c_re(out[3 * ostride]) = tre0_1_0 - tim0_1_1; - c_im(out[3 * ostride]) = tim0_1_0 + tre0_1_1; -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 44 FP additions and 16 FP multiplications */ - -void fftw_no_twiddle_5(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - tre0_0_0 = c_re(in[0]); - tim0_0_0 = c_im(in[0]); - tre0_1_0 = c_re(in[istride]); - tim0_1_0 = c_im(in[istride]); - tre0_2_0 = c_re(in[2 * istride]); - tim0_2_0 = c_im(in[2 * istride]); - tre0_3_0 = c_re(in[3 * istride]); - tim0_3_0 = c_im(in[3 * istride]); - tre0_4_0 = c_re(in[4 * istride]); - tim0_4_0 = c_im(in[4 * istride]); - c_re(out[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0 + tre0_3_0 + tre0_4_0; - c_im(out[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0 + tim0_3_0 + tim0_4_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_2_0 + tre0_3_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_1_0 - tim0_4_0)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_2_0 - tim0_3_0)); - c_re(out[ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[4 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_2_0 + tim0_3_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_4_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_3_0 - tre0_2_0)); - c_im(out[ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[4 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_2_0 + tre0_3_0)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_0 + tre0_4_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_1_0 - tim0_4_0)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_3_0 - tim0_2_0)); - c_re(out[2 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[3 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_2_0 + tim0_3_0)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_0 + tim0_4_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_4_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_2_0 - tre0_3_0)); - c_im(out[2 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[3 * ostride]) = tim1_0_0 - tim1_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 40 FP additions and 8 FP multiplications */ - -void fftw_no_twiddle_6(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[3 * istride]); - tim1_1_0 = c_im(in[3 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[2 * istride]); - tim1_0_0 = c_im(in[2 * istride]); - tre1_1_0 = c_re(in[5 * istride]); - tim1_1_0 = c_im(in[5 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[4 * istride]); - tim1_0_0 = c_im(in[4 * istride]); - tre1_1_0 = c_re(in[istride]); - tim1_1_0 = c_im(in[istride]); - tre0_0_2 = tre1_0_0 + tre1_1_0; - tim0_0_2 = tim1_0_0 + tim1_1_0; - tre0_1_2 = tre1_0_0 - tre1_1_0; - tim0_1_2 = tim1_0_0 - tim1_1_0; - } - c_re(out[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2; - c_im(out[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_0_1 + tre0_0_2)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_0_1 - tim0_0_2); - c_re(out[4 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[2 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_0_1 + tim0_0_2)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_0_2 - tre0_0_1); - c_im(out[4 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[2 * ostride]) = tim2_0_0 - tim2_1_0; - } - c_re(out[3 * ostride]) = tre0_1_0 + tre0_1_1 + tre0_1_2; - c_im(out[3 * ostride]) = tim0_1_0 + tim0_1_1 + tim0_1_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_1_1 + tre0_1_2)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_1_1 - tim0_1_2); - c_re(out[ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[5 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_1_1 + tim0_1_2)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_1_2 - tre0_1_1); - c_im(out[ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[5 * ostride]) = tim2_0_0 - tim2_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 928 FP additions and 248 FP multiplications */ - -void fftw_no_twiddle_64(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_0_5; - FFTW_REAL tim0_0_5; - FFTW_REAL tre0_0_6; - FFTW_REAL tim0_0_6; - FFTW_REAL tre0_0_7; - FFTW_REAL tim0_0_7; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - FFTW_REAL tre0_1_5; - FFTW_REAL tim0_1_5; - FFTW_REAL tre0_1_6; - FFTW_REAL tim0_1_6; - FFTW_REAL tre0_1_7; - FFTW_REAL tim0_1_7; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - FFTW_REAL tre0_2_4; - FFTW_REAL tim0_2_4; - FFTW_REAL tre0_2_5; - FFTW_REAL tim0_2_5; - FFTW_REAL tre0_2_6; - FFTW_REAL tim0_2_6; - FFTW_REAL tre0_2_7; - FFTW_REAL tim0_2_7; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_3_1; - FFTW_REAL tim0_3_1; - FFTW_REAL tre0_3_2; - FFTW_REAL tim0_3_2; - FFTW_REAL tre0_3_3; - FFTW_REAL tim0_3_3; - FFTW_REAL tre0_3_4; - FFTW_REAL tim0_3_4; - FFTW_REAL tre0_3_5; - FFTW_REAL tim0_3_5; - FFTW_REAL tre0_3_6; - FFTW_REAL tim0_3_6; - FFTW_REAL tre0_3_7; - FFTW_REAL tim0_3_7; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - FFTW_REAL tre0_4_1; - FFTW_REAL tim0_4_1; - FFTW_REAL tre0_4_2; - FFTW_REAL tim0_4_2; - FFTW_REAL tre0_4_3; - FFTW_REAL tim0_4_3; - FFTW_REAL tre0_4_4; - FFTW_REAL tim0_4_4; - FFTW_REAL tre0_4_5; - FFTW_REAL tim0_4_5; - FFTW_REAL tre0_4_6; - FFTW_REAL tim0_4_6; - FFTW_REAL tre0_4_7; - FFTW_REAL tim0_4_7; - FFTW_REAL tre0_5_0; - FFTW_REAL tim0_5_0; - FFTW_REAL tre0_5_1; - FFTW_REAL tim0_5_1; - FFTW_REAL tre0_5_2; - FFTW_REAL tim0_5_2; - FFTW_REAL tre0_5_3; - FFTW_REAL tim0_5_3; - FFTW_REAL tre0_5_4; - FFTW_REAL tim0_5_4; - FFTW_REAL tre0_5_5; - FFTW_REAL tim0_5_5; - FFTW_REAL tre0_5_6; - FFTW_REAL tim0_5_6; - FFTW_REAL tre0_5_7; - FFTW_REAL tim0_5_7; - FFTW_REAL tre0_6_0; - FFTW_REAL tim0_6_0; - FFTW_REAL tre0_6_1; - FFTW_REAL tim0_6_1; - FFTW_REAL tre0_6_2; - FFTW_REAL tim0_6_2; - FFTW_REAL tre0_6_3; - FFTW_REAL tim0_6_3; - FFTW_REAL tre0_6_4; - FFTW_REAL tim0_6_4; - FFTW_REAL tre0_6_5; - FFTW_REAL tim0_6_5; - FFTW_REAL tre0_6_6; - FFTW_REAL tim0_6_6; - FFTW_REAL tre0_6_7; - FFTW_REAL tim0_6_7; - FFTW_REAL tre0_7_0; - FFTW_REAL tim0_7_0; - FFTW_REAL tre0_7_1; - FFTW_REAL tim0_7_1; - FFTW_REAL tre0_7_2; - FFTW_REAL tim0_7_2; - FFTW_REAL tre0_7_3; - FFTW_REAL tim0_7_3; - FFTW_REAL tre0_7_4; - FFTW_REAL tim0_7_4; - FFTW_REAL tre0_7_5; - FFTW_REAL tim0_7_5; - FFTW_REAL tre0_7_6; - FFTW_REAL tim0_7_6; - FFTW_REAL tre0_7_7; - FFTW_REAL tim0_7_7; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[0]); - tim2_0_0 = c_im(in[0]); - tre2_1_0 = c_re(in[32 * istride]); - tim2_1_0 = c_im(in[32 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[8 * istride]); - tim2_0_0 = c_im(in[8 * istride]); - tre2_1_0 = c_re(in[40 * istride]); - tim2_1_0 = c_im(in[40 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[16 * istride]); - tim2_0_0 = c_im(in[16 * istride]); - tre2_1_0 = c_re(in[48 * istride]); - tim2_1_0 = c_im(in[48 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[24 * istride]); - tim2_0_0 = c_im(in[24 * istride]); - tre2_1_0 = c_re(in[56 * istride]); - tim2_1_0 = c_im(in[56 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_0 = tre2_0_0 + tre2_0_1; - tim0_0_0 = tim2_0_0 + tim2_0_1; - tre0_4_0 = tre2_0_0 - tre2_0_1; - tim0_4_0 = tim2_0_0 - tim2_0_1; - tre0_2_0 = tre2_1_0 + tim2_1_1; - tim0_2_0 = tim2_1_0 - tre2_1_1; - tre0_6_0 = tre2_1_0 - tim2_1_1; - tim0_6_0 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_0 = tre2_0_0 + tre2_0_1; - tim0_1_0 = tim2_0_0 + tim2_0_1; - tre0_5_0 = tre2_0_0 - tre2_0_1; - tim0_5_0 = tim2_0_0 - tim2_0_1; - tre0_3_0 = tre2_1_0 + tim2_1_1; - tim0_3_0 = tim2_1_0 - tre2_1_1; - tre0_7_0 = tre2_1_0 - tim2_1_1; - tim0_7_0 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[istride]); - tim2_0_0 = c_im(in[istride]); - tre2_1_0 = c_re(in[33 * istride]); - tim2_1_0 = c_im(in[33 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[9 * istride]); - tim2_0_0 = c_im(in[9 * istride]); - tre2_1_0 = c_re(in[41 * istride]); - tim2_1_0 = c_im(in[41 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[17 * istride]); - tim2_0_0 = c_im(in[17 * istride]); - tre2_1_0 = c_re(in[49 * istride]); - tim2_1_0 = c_im(in[49 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[25 * istride]); - tim2_0_0 = c_im(in[25 * istride]); - tre2_1_0 = c_re(in[57 * istride]); - tim2_1_0 = c_im(in[57 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_1 = tre2_0_0 + tre2_0_1; - tim0_0_1 = tim2_0_0 + tim2_0_1; - tre0_4_1 = tre2_0_0 - tre2_0_1; - tim0_4_1 = tim2_0_0 - tim2_0_1; - tre0_2_1 = tre2_1_0 + tim2_1_1; - tim0_2_1 = tim2_1_0 - tre2_1_1; - tre0_6_1 = tre2_1_0 - tim2_1_1; - tim0_6_1 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_1 = tre2_0_0 + tre2_0_1; - tim0_1_1 = tim2_0_0 + tim2_0_1; - tre0_5_1 = tre2_0_0 - tre2_0_1; - tim0_5_1 = tim2_0_0 - tim2_0_1; - tre0_3_1 = tre2_1_0 + tim2_1_1; - tim0_3_1 = tim2_1_0 - tre2_1_1; - tre0_7_1 = tre2_1_0 - tim2_1_1; - tim0_7_1 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[2 * istride]); - tim2_0_0 = c_im(in[2 * istride]); - tre2_1_0 = c_re(in[34 * istride]); - tim2_1_0 = c_im(in[34 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[10 * istride]); - tim2_0_0 = c_im(in[10 * istride]); - tre2_1_0 = c_re(in[42 * istride]); - tim2_1_0 = c_im(in[42 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[18 * istride]); - tim2_0_0 = c_im(in[18 * istride]); - tre2_1_0 = c_re(in[50 * istride]); - tim2_1_0 = c_im(in[50 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[26 * istride]); - tim2_0_0 = c_im(in[26 * istride]); - tre2_1_0 = c_re(in[58 * istride]); - tim2_1_0 = c_im(in[58 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_2 = tre2_0_0 + tre2_0_1; - tim0_0_2 = tim2_0_0 + tim2_0_1; - tre0_4_2 = tre2_0_0 - tre2_0_1; - tim0_4_2 = tim2_0_0 - tim2_0_1; - tre0_2_2 = tre2_1_0 + tim2_1_1; - tim0_2_2 = tim2_1_0 - tre2_1_1; - tre0_6_2 = tre2_1_0 - tim2_1_1; - tim0_6_2 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_2 = tre2_0_0 + tre2_0_1; - tim0_1_2 = tim2_0_0 + tim2_0_1; - tre0_5_2 = tre2_0_0 - tre2_0_1; - tim0_5_2 = tim2_0_0 - tim2_0_1; - tre0_3_2 = tre2_1_0 + tim2_1_1; - tim0_3_2 = tim2_1_0 - tre2_1_1; - tre0_7_2 = tre2_1_0 - tim2_1_1; - tim0_7_2 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[3 * istride]); - tim2_0_0 = c_im(in[3 * istride]); - tre2_1_0 = c_re(in[35 * istride]); - tim2_1_0 = c_im(in[35 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[11 * istride]); - tim2_0_0 = c_im(in[11 * istride]); - tre2_1_0 = c_re(in[43 * istride]); - tim2_1_0 = c_im(in[43 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[19 * istride]); - tim2_0_0 = c_im(in[19 * istride]); - tre2_1_0 = c_re(in[51 * istride]); - tim2_1_0 = c_im(in[51 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[27 * istride]); - tim2_0_0 = c_im(in[27 * istride]); - tre2_1_0 = c_re(in[59 * istride]); - tim2_1_0 = c_im(in[59 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_3 = tre2_0_0 + tre2_0_1; - tim0_0_3 = tim2_0_0 + tim2_0_1; - tre0_4_3 = tre2_0_0 - tre2_0_1; - tim0_4_3 = tim2_0_0 - tim2_0_1; - tre0_2_3 = tre2_1_0 + tim2_1_1; - tim0_2_3 = tim2_1_0 - tre2_1_1; - tre0_6_3 = tre2_1_0 - tim2_1_1; - tim0_6_3 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_3 = tre2_0_0 + tre2_0_1; - tim0_1_3 = tim2_0_0 + tim2_0_1; - tre0_5_3 = tre2_0_0 - tre2_0_1; - tim0_5_3 = tim2_0_0 - tim2_0_1; - tre0_3_3 = tre2_1_0 + tim2_1_1; - tim0_3_3 = tim2_1_0 - tre2_1_1; - tre0_7_3 = tre2_1_0 - tim2_1_1; - tim0_7_3 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[4 * istride]); - tim2_0_0 = c_im(in[4 * istride]); - tre2_1_0 = c_re(in[36 * istride]); - tim2_1_0 = c_im(in[36 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[12 * istride]); - tim2_0_0 = c_im(in[12 * istride]); - tre2_1_0 = c_re(in[44 * istride]); - tim2_1_0 = c_im(in[44 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[20 * istride]); - tim2_0_0 = c_im(in[20 * istride]); - tre2_1_0 = c_re(in[52 * istride]); - tim2_1_0 = c_im(in[52 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[28 * istride]); - tim2_0_0 = c_im(in[28 * istride]); - tre2_1_0 = c_re(in[60 * istride]); - tim2_1_0 = c_im(in[60 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_4 = tre2_0_0 + tre2_0_1; - tim0_0_4 = tim2_0_0 + tim2_0_1; - tre0_4_4 = tre2_0_0 - tre2_0_1; - tim0_4_4 = tim2_0_0 - tim2_0_1; - tre0_2_4 = tre2_1_0 + tim2_1_1; - tim0_2_4 = tim2_1_0 - tre2_1_1; - tre0_6_4 = tre2_1_0 - tim2_1_1; - tim0_6_4 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_4 = tre2_0_0 + tre2_0_1; - tim0_1_4 = tim2_0_0 + tim2_0_1; - tre0_5_4 = tre2_0_0 - tre2_0_1; - tim0_5_4 = tim2_0_0 - tim2_0_1; - tre0_3_4 = tre2_1_0 + tim2_1_1; - tim0_3_4 = tim2_1_0 - tre2_1_1; - tre0_7_4 = tre2_1_0 - tim2_1_1; - tim0_7_4 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[5 * istride]); - tim2_0_0 = c_im(in[5 * istride]); - tre2_1_0 = c_re(in[37 * istride]); - tim2_1_0 = c_im(in[37 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[13 * istride]); - tim2_0_0 = c_im(in[13 * istride]); - tre2_1_0 = c_re(in[45 * istride]); - tim2_1_0 = c_im(in[45 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[21 * istride]); - tim2_0_0 = c_im(in[21 * istride]); - tre2_1_0 = c_re(in[53 * istride]); - tim2_1_0 = c_im(in[53 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[29 * istride]); - tim2_0_0 = c_im(in[29 * istride]); - tre2_1_0 = c_re(in[61 * istride]); - tim2_1_0 = c_im(in[61 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_5 = tre2_0_0 + tre2_0_1; - tim0_0_5 = tim2_0_0 + tim2_0_1; - tre0_4_5 = tre2_0_0 - tre2_0_1; - tim0_4_5 = tim2_0_0 - tim2_0_1; - tre0_2_5 = tre2_1_0 + tim2_1_1; - tim0_2_5 = tim2_1_0 - tre2_1_1; - tre0_6_5 = tre2_1_0 - tim2_1_1; - tim0_6_5 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_5 = tre2_0_0 + tre2_0_1; - tim0_1_5 = tim2_0_0 + tim2_0_1; - tre0_5_5 = tre2_0_0 - tre2_0_1; - tim0_5_5 = tim2_0_0 - tim2_0_1; - tre0_3_5 = tre2_1_0 + tim2_1_1; - tim0_3_5 = tim2_1_0 - tre2_1_1; - tre0_7_5 = tre2_1_0 - tim2_1_1; - tim0_7_5 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[6 * istride]); - tim2_0_0 = c_im(in[6 * istride]); - tre2_1_0 = c_re(in[38 * istride]); - tim2_1_0 = c_im(in[38 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[14 * istride]); - tim2_0_0 = c_im(in[14 * istride]); - tre2_1_0 = c_re(in[46 * istride]); - tim2_1_0 = c_im(in[46 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[22 * istride]); - tim2_0_0 = c_im(in[22 * istride]); - tre2_1_0 = c_re(in[54 * istride]); - tim2_1_0 = c_im(in[54 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[30 * istride]); - tim2_0_0 = c_im(in[30 * istride]); - tre2_1_0 = c_re(in[62 * istride]); - tim2_1_0 = c_im(in[62 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_6 = tre2_0_0 + tre2_0_1; - tim0_0_6 = tim2_0_0 + tim2_0_1; - tre0_4_6 = tre2_0_0 - tre2_0_1; - tim0_4_6 = tim2_0_0 - tim2_0_1; - tre0_2_6 = tre2_1_0 + tim2_1_1; - tim0_2_6 = tim2_1_0 - tre2_1_1; - tre0_6_6 = tre2_1_0 - tim2_1_1; - tim0_6_6 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_6 = tre2_0_0 + tre2_0_1; - tim0_1_6 = tim2_0_0 + tim2_0_1; - tre0_5_6 = tre2_0_0 - tre2_0_1; - tim0_5_6 = tim2_0_0 - tim2_0_1; - tre0_3_6 = tre2_1_0 + tim2_1_1; - tim0_3_6 = tim2_1_0 - tre2_1_1; - tre0_7_6 = tre2_1_0 - tim2_1_1; - tim0_7_6 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[7 * istride]); - tim2_0_0 = c_im(in[7 * istride]); - tre2_1_0 = c_re(in[39 * istride]); - tim2_1_0 = c_im(in[39 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[15 * istride]); - tim2_0_0 = c_im(in[15 * istride]); - tre2_1_0 = c_re(in[47 * istride]); - tim2_1_0 = c_im(in[47 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[23 * istride]); - tim2_0_0 = c_im(in[23 * istride]); - tre2_1_0 = c_re(in[55 * istride]); - tim2_1_0 = c_im(in[55 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[31 * istride]); - tim2_0_0 = c_im(in[31 * istride]); - tre2_1_0 = c_re(in[63 * istride]); - tim2_1_0 = c_im(in[63 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_7 = tre2_0_0 + tre2_0_1; - tim0_0_7 = tim2_0_0 + tim2_0_1; - tre0_4_7 = tre2_0_0 - tre2_0_1; - tim0_4_7 = tim2_0_0 - tim2_0_1; - tre0_2_7 = tre2_1_0 + tim2_1_1; - tim0_2_7 = tim2_1_0 - tre2_1_1; - tre0_6_7 = tre2_1_0 - tim2_1_1; - tim0_6_7 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_7 = tre2_0_0 + tre2_0_1; - tim0_1_7 = tim2_0_0 + tim2_0_1; - tre0_5_7 = tre2_0_0 - tre2_0_1; - tim0_5_7 = tim2_0_0 - tim2_0_1; - tre0_3_7 = tre2_1_0 + tim2_1_1; - tim0_3_7 = tim2_1_0 - tre2_1_1; - tre0_7_7 = tre2_1_0 - tim2_1_1; - tim0_7_7 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_0_0 + tre0_0_4; - tim1_0_0 = tim0_0_0 + tim0_0_4; - tre1_1_0 = tre0_0_0 - tre0_0_4; - tim1_1_0 = tim0_0_0 - tim0_0_4; - tre1_0_1 = tre0_0_1 + tre0_0_5; - tim1_0_1 = tim0_0_1 + tim0_0_5; - tre1_1_1 = tre0_0_1 - tre0_0_5; - tim1_1_1 = tim0_0_1 - tim0_0_5; - tre1_0_2 = tre0_0_2 + tre0_0_6; - tim1_0_2 = tim0_0_2 + tim0_0_6; - tre1_1_2 = tre0_0_2 - tre0_0_6; - tim1_1_2 = tim0_0_2 - tim0_0_6; - tre1_0_3 = tre0_0_3 + tre0_0_7; - tim1_0_3 = tim0_0_3 + tim0_0_7; - tre1_1_3 = tre0_0_3 - tre0_0_7; - tim1_1_3 = tim0_0_3 - tim0_0_7; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[0]) = tre2_0_0 + tre2_0_1; - c_im(out[0]) = tim2_0_0 + tim2_0_1; - c_re(out[32 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[32 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[16 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[16 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[48 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[48 * ostride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(out[8 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[8 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[40 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[40 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[24 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[24 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[56 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[56 * ostride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_1_4) + (((FFTW_REAL) FFTW_K382683432) * tim0_1_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_1_4) - (((FFTW_REAL) FFTW_K382683432) * tre0_1_4); - tre1_0_0 = tre0_1_0 + tre2_1_0; - tim1_0_0 = tim0_1_0 + tim2_1_0; - tre1_1_0 = tre0_1_0 - tre2_1_0; - tim1_1_0 = tim0_1_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K995184726) * tre0_1_1) + (((FFTW_REAL) FFTW_K098017140) * tim0_1_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K995184726) * tim0_1_1) - (((FFTW_REAL) FFTW_K098017140) * tre0_1_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K881921264) * tre0_1_5) + (((FFTW_REAL) FFTW_K471396736) * tim0_1_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K881921264) * tim0_1_5) - (((FFTW_REAL) FFTW_K471396736) * tre0_1_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_1_2) + (((FFTW_REAL) FFTW_K195090322) * tim0_1_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_1_2) - (((FFTW_REAL) FFTW_K195090322) * tre0_1_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_1_6) + (((FFTW_REAL) FFTW_K555570233) * tim0_1_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_1_6) - (((FFTW_REAL) FFTW_K555570233) * tre0_1_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tre0_1_3) + (((FFTW_REAL) FFTW_K290284677) * tim0_1_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tim0_1_3) - (((FFTW_REAL) FFTW_K290284677) * tre0_1_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K773010453) * tre0_1_7) + (((FFTW_REAL) FFTW_K634393284) * tim0_1_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K773010453) * tim0_1_7) - (((FFTW_REAL) FFTW_K634393284) * tre0_1_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[33 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[33 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[17 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[17 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[49 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[49 * ostride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(out[9 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[9 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[41 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[41 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[25 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[25 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[57 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[57 * ostride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_4 + tim0_2_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_4 - tre0_2_4); - tre1_0_0 = tre0_2_0 + tre2_1_0; - tim1_0_0 = tim0_2_0 + tim2_1_0; - tre1_1_0 = tre0_2_0 - tre2_1_0; - tim1_1_0 = tim0_2_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_2_1) + (((FFTW_REAL) FFTW_K195090322) * tim0_2_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_2_1) - (((FFTW_REAL) FFTW_K195090322) * tre0_2_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_2_5) + (((FFTW_REAL) FFTW_K831469612) * tim0_2_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_2_5) - (((FFTW_REAL) FFTW_K831469612) * tre0_2_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_2_2) + (((FFTW_REAL) FFTW_K382683432) * tim0_2_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_2_2) - (((FFTW_REAL) FFTW_K382683432) * tre0_2_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_2_6) + (((FFTW_REAL) FFTW_K923879532) * tim0_2_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_2_6) - (((FFTW_REAL) FFTW_K923879532) * tre0_2_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_2_3) + (((FFTW_REAL) FFTW_K555570233) * tim0_2_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_2_3) - (((FFTW_REAL) FFTW_K555570233) * tre0_2_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_2_7) + (((FFTW_REAL) FFTW_K980785280) * tim0_2_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_2_7) - (((FFTW_REAL) FFTW_K980785280) * tre0_2_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[2 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[2 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[34 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[34 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[18 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[18 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[50 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[50 * ostride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(out[10 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[10 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[42 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[42 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[26 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[26 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[58 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[58 * ostride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_4) + (((FFTW_REAL) FFTW_K923879532) * tim0_3_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_4) - (((FFTW_REAL) FFTW_K923879532) * tre0_3_4); - tre1_0_0 = tre0_3_0 + tre2_1_0; - tim1_0_0 = tim0_3_0 + tim2_1_0; - tre1_1_0 = tre0_3_0 - tre2_1_0; - tim1_1_0 = tim0_3_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tre0_3_1) + (((FFTW_REAL) FFTW_K290284677) * tim0_3_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tim0_3_1) - (((FFTW_REAL) FFTW_K290284677) * tre0_3_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tre0_3_5) + (((FFTW_REAL) FFTW_K995184726) * tim0_3_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tim0_3_5) - (((FFTW_REAL) FFTW_K995184726) * tre0_3_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_3_2) + (((FFTW_REAL) FFTW_K555570233) * tim0_3_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_3_2) - (((FFTW_REAL) FFTW_K555570233) * tre0_3_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_3_6) - (((FFTW_REAL) FFTW_K195090322) * tre0_3_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_3_6) + (((FFTW_REAL) FFTW_K980785280) * tre0_3_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 - tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K634393284) * tre0_3_3) + (((FFTW_REAL) FFTW_K773010453) * tim0_3_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K634393284) * tim0_3_3) - (((FFTW_REAL) FFTW_K773010453) * tre0_3_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K881921264) * tim0_3_7) - (((FFTW_REAL) FFTW_K471396736) * tre0_3_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K471396736) * tim0_3_7) + (((FFTW_REAL) FFTW_K881921264) * tre0_3_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 - tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[3 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[3 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[35 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[35 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[19 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[19 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[51 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[51 * ostride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(out[11 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[11 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[43 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[43 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[27 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[27 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[59 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[59 * ostride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_4_0 + tim0_4_4; - tim1_0_0 = tim0_4_0 - tre0_4_4; - tre1_1_0 = tre0_4_0 - tim0_4_4; - tim1_1_0 = tim0_4_0 + tre0_4_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_4_1) + (((FFTW_REAL) FFTW_K382683432) * tim0_4_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_4_1) - (((FFTW_REAL) FFTW_K382683432) * tre0_4_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_4_5) - (((FFTW_REAL) FFTW_K382683432) * tre0_4_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_4_5) + (((FFTW_REAL) FFTW_K923879532) * tre0_4_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_4_2 + tim0_4_2); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_4_2 - tre0_4_2); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_4_6 - tre0_4_6); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_4_6 + tre0_4_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 - tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_4_3) + (((FFTW_REAL) FFTW_K923879532) * tim0_4_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_4_3) - (((FFTW_REAL) FFTW_K923879532) * tre0_4_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_4_7) - (((FFTW_REAL) FFTW_K923879532) * tre0_4_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_4_7) + (((FFTW_REAL) FFTW_K382683432) * tre0_4_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 - tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[4 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[4 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[36 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[36 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[20 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[20 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[52 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[52 * ostride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(out[12 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[12 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[44 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[44 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[28 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[28 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[60 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[60 * ostride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_5_4) - (((FFTW_REAL) FFTW_K382683432) * tre0_5_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_5_4) + (((FFTW_REAL) FFTW_K923879532) * tre0_5_4); - tre1_0_0 = tre0_5_0 + tre2_1_0; - tim1_0_0 = tim0_5_0 - tim2_1_0; - tre1_1_0 = tre0_5_0 - tre2_1_0; - tim1_1_0 = tim0_5_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K881921264) * tre0_5_1) + (((FFTW_REAL) FFTW_K471396736) * tim0_5_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K881921264) * tim0_5_1) - (((FFTW_REAL) FFTW_K471396736) * tre0_5_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K634393284) * tim0_5_5) - (((FFTW_REAL) FFTW_K773010453) * tre0_5_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K773010453) * tim0_5_5) + (((FFTW_REAL) FFTW_K634393284) * tre0_5_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_5_2) + (((FFTW_REAL) FFTW_K831469612) * tim0_5_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_5_2) - (((FFTW_REAL) FFTW_K831469612) * tre0_5_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_5_6) - (((FFTW_REAL) FFTW_K980785280) * tre0_5_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_5_6) + (((FFTW_REAL) FFTW_K195090322) * tre0_5_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 - tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K098017140) * tre0_5_3) + (((FFTW_REAL) FFTW_K995184726) * tim0_5_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K098017140) * tim0_5_3) - (((FFTW_REAL) FFTW_K995184726) * tre0_5_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K956940335) * tre0_5_7) + (((FFTW_REAL) FFTW_K290284677) * tim0_5_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K290284677) * tre0_5_7) - (((FFTW_REAL) FFTW_K956940335) * tim0_5_7); - tre1_0_3 = tre2_0_0 - tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 + tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[5 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[5 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[37 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[37 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[21 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[21 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[53 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[53 * ostride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(out[13 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[13 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[45 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[45 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[29 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[29 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[61 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[61 * ostride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_6_4 - tre0_6_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_6_4 + tre0_6_4); - tre1_0_0 = tre0_6_0 + tre2_1_0; - tim1_0_0 = tim0_6_0 - tim2_1_0; - tre1_1_0 = tre0_6_0 - tre2_1_0; - tim1_1_0 = tim0_6_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_6_1) + (((FFTW_REAL) FFTW_K555570233) * tim0_6_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_6_1) - (((FFTW_REAL) FFTW_K555570233) * tre0_6_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_6_5) - (((FFTW_REAL) FFTW_K980785280) * tre0_6_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_6_5) + (((FFTW_REAL) FFTW_K195090322) * tre0_6_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_6_2) + (((FFTW_REAL) FFTW_K923879532) * tim0_6_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_6_2) - (((FFTW_REAL) FFTW_K923879532) * tre0_6_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_6_6) + (((FFTW_REAL) FFTW_K382683432) * tim0_6_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_6_6) - (((FFTW_REAL) FFTW_K923879532) * tim0_6_6); - tre1_0_2 = tre2_0_0 - tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 + tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_6_3) - (((FFTW_REAL) FFTW_K195090322) * tre0_6_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_6_3) + (((FFTW_REAL) FFTW_K980785280) * tre0_6_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_6_7) + (((FFTW_REAL) FFTW_K831469612) * tim0_6_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_6_7) - (((FFTW_REAL) FFTW_K555570233) * tim0_6_7); - tre1_0_3 = tre2_0_0 - tre2_1_0; - tim1_0_3 = tim2_1_0 - tim2_0_0; - tre1_1_3 = tre2_0_0 + tre2_1_0; - tim1_1_3 = (-(tim2_0_0 + tim2_1_0)); - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[6 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[6 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[38 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[38 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[22 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[22 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[54 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[54 * ostride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(out[14 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[14 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[46 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[46 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[30 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[30 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[62 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[62 * ostride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_7_4) - (((FFTW_REAL) FFTW_K923879532) * tre0_7_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_7_4) + (((FFTW_REAL) FFTW_K382683432) * tre0_7_4); - tre1_0_0 = tre0_7_0 + tre2_1_0; - tim1_0_0 = tim0_7_0 - tim2_1_0; - tre1_1_0 = tre0_7_0 - tre2_1_0; - tim1_1_0 = tim0_7_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K773010453) * tre0_7_1) + (((FFTW_REAL) FFTW_K634393284) * tim0_7_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K773010453) * tim0_7_1) - (((FFTW_REAL) FFTW_K634393284) * tre0_7_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K956940335) * tre0_7_5) + (((FFTW_REAL) FFTW_K290284677) * tim0_7_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K290284677) * tre0_7_5) - (((FFTW_REAL) FFTW_K956940335) * tim0_7_5); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_7_2) + (((FFTW_REAL) FFTW_K980785280) * tim0_7_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_7_2) - (((FFTW_REAL) FFTW_K980785280) * tre0_7_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_7_6) + (((FFTW_REAL) FFTW_K831469612) * tim0_7_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_7_6) - (((FFTW_REAL) FFTW_K555570233) * tim0_7_6); - tre1_0_2 = tre2_0_0 - tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 + tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K881921264) * tim0_7_3) - (((FFTW_REAL) FFTW_K471396736) * tre0_7_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K471396736) * tim0_7_3) + (((FFTW_REAL) FFTW_K881921264) * tre0_7_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tre0_7_7) - (((FFTW_REAL) FFTW_K995184726) * tim0_7_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tim0_7_7) + (((FFTW_REAL) FFTW_K995184726) * tre0_7_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_1_0 - tim2_0_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = (-(tim2_0_0 + tim2_1_0)); - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[7 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[7 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[39 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[39 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[23 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[23 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[55 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[55 * ostride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(out[15 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[15 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[47 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[47 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[31 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[31 * ostride]) = tim2_1_0 - tre2_1_1; - c_re(out[63 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[63 * ostride]) = tim2_1_0 + tre2_1_1; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 90 FP additions and 36 FP multiplications */ - -void fftw_no_twiddle_7(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - FFTW_REAL tre0_5_0; - FFTW_REAL tim0_5_0; - FFTW_REAL tre0_6_0; - FFTW_REAL tim0_6_0; - tre0_0_0 = c_re(in[0]); - tim0_0_0 = c_im(in[0]); - tre0_1_0 = c_re(in[istride]); - tim0_1_0 = c_im(in[istride]); - tre0_2_0 = c_re(in[2 * istride]); - tim0_2_0 = c_im(in[2 * istride]); - tre0_3_0 = c_re(in[3 * istride]); - tim0_3_0 = c_im(in[3 * istride]); - tre0_4_0 = c_re(in[4 * istride]); - tim0_4_0 = c_im(in[4 * istride]); - tre0_5_0 = c_re(in[5 * istride]); - tim0_5_0 = c_im(in[5 * istride]); - tre0_6_0 = c_re(in[6 * istride]); - tim0_6_0 = c_im(in[6 * istride]); - c_re(out[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0 + tre0_3_0 + tre0_4_0 + tre0_5_0 + tre0_6_0; - c_im(out[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0 + tim0_3_0 + tim0_4_0 + tim0_5_0 + tim0_6_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_1_0 + tre0_6_0)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_3_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_2_0 + tre0_5_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tim0_1_0 - tim0_6_0)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_2_0 - tim0_5_0)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_3_0 - tim0_4_0)); - c_re(out[ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[6 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_1_0 + tim0_6_0)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_3_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_2_0 + tim0_5_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tre0_6_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_5_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_4_0 - tre0_3_0)); - c_im(out[ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[6 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_3_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_2_0 + tre0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_1_0 + tre0_6_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tim0_1_0 - tim0_6_0)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_5_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_4_0 - tim0_3_0)); - c_re(out[2 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[5 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_3_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_2_0 + tim0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_1_0 + tim0_6_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tre0_6_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_2_0 - tre0_5_0)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_3_0 - tre0_4_0)); - c_im(out[2 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[5 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_2_0 + tre0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_3_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_1_0 + tre0_6_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tim0_1_0 - tim0_6_0)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_5_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_3_0 - tim0_4_0)); - c_re(out[3 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[4 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_2_0 + tim0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_3_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_1_0 + tim0_6_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tre0_6_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_2_0 - tre0_5_0)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_4_0 - tre0_3_0)); - c_im(out[3 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[4 * ostride]) = tim1_0_0 - tim1_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 52 FP additions and 4 FP multiplications */ - -void fftw_no_twiddle_8(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[4 * istride]); - tim1_1_0 = c_im(in[4 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[istride]); - tim1_0_0 = c_im(in[istride]); - tre1_1_0 = c_re(in[5 * istride]); - tim1_1_0 = c_im(in[5 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[2 * istride]); - tim1_0_0 = c_im(in[2 * istride]); - tre1_1_0 = c_re(in[6 * istride]); - tim1_1_0 = c_im(in[6 * istride]); - tre0_0_2 = tre1_0_0 + tre1_1_0; - tim0_0_2 = tim1_0_0 + tim1_1_0; - tre0_1_2 = tre1_0_0 - tre1_1_0; - tim0_1_2 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[3 * istride]); - tim1_0_0 = c_im(in[3 * istride]); - tre1_1_0 = c_re(in[7 * istride]); - tim1_1_0 = c_im(in[7 * istride]); - tre0_0_3 = tre1_0_0 + tre1_1_0; - tim0_0_3 = tim1_0_0 + tim1_1_0; - tre0_1_3 = tre1_0_0 - tre1_1_0; - tim0_1_3 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_0_0 + tre0_0_2; - tim1_0_0 = tim0_0_0 + tim0_0_2; - tre1_1_0 = tre0_0_0 - tre0_0_2; - tim1_1_0 = tim0_0_0 - tim0_0_2; - tre1_0_1 = tre0_0_1 + tre0_0_3; - tim1_0_1 = tim0_0_1 + tim0_0_3; - tre1_1_1 = tre0_0_1 - tre0_0_3; - tim1_1_1 = tim0_0_1 - tim0_0_3; - c_re(out[0]) = tre1_0_0 + tre1_0_1; - c_im(out[0]) = tim1_0_0 + tim1_0_1; - c_re(out[4 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[4 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[2 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[2 * ostride]) = tim1_1_0 - tre1_1_1; - c_re(out[6 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[6 * ostride]) = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_1_0 + tim0_1_2; - tim1_0_0 = tim0_1_0 - tre0_1_2; - tre1_1_0 = tre0_1_0 - tim0_1_2; - tim1_1_0 = tim0_1_0 + tre0_1_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_1 + tim0_1_1); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_1 - tre0_1_1); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_3 - tre0_1_3); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_3 + tre0_1_3); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - c_re(out[ostride]) = tre1_0_0 + tre1_0_1; - c_im(out[ostride]) = tim1_0_0 + tim1_0_1; - c_re(out[5 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[5 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[3 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[3 * ostride]) = tim1_1_0 - tre1_1_1; - c_re(out[7 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[7 * ostride]) = tim1_1_0 + tre1_1_1; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 92 FP additions and 40 FP multiplications */ - -void fftw_no_twiddle_9(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[3 * istride]); - tim1_1_0 = c_im(in[3 * istride]); - tre1_2_0 = c_re(in[6 * istride]); - tim1_2_0 = c_im(in[6 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_0 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - tre0_1_0 = tre2_0_0 + tre2_1_0; - tre0_2_0 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - tim0_1_0 = tim2_0_0 + tim2_1_0; - tim0_2_0 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[istride]); - tim1_0_0 = c_im(in[istride]); - tre1_1_0 = c_re(in[4 * istride]); - tim1_1_0 = c_im(in[4 * istride]); - tre1_2_0 = c_re(in[7 * istride]); - tim1_2_0 = c_im(in[7 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_1 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - tre0_1_1 = tre2_0_0 + tre2_1_0; - tre0_2_1 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - tim0_1_1 = tim2_0_0 + tim2_1_0; - tim0_2_1 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[2 * istride]); - tim1_0_0 = c_im(in[2 * istride]); - tre1_1_0 = c_re(in[5 * istride]); - tim1_1_0 = c_im(in[5 * istride]); - tre1_2_0 = c_re(in[8 * istride]); - tim1_2_0 = c_im(in[8 * istride]); - tre0_0_2 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_2 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - tre0_1_2 = tre2_0_0 + tre2_1_0; - tre0_2_2 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - tim0_1_2 = tim2_0_0 + tim2_1_0; - tim0_2_2 = tim2_0_0 - tim2_1_0; - } - } - c_re(out[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2; - c_im(out[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_0_1 + tre0_0_2)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_0_1 - tim0_0_2); - c_re(out[3 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[6 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_0_1 + tim0_0_2)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_0_2 - tre0_0_1); - c_im(out[3 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[6 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_1_0 = (((FFTW_REAL) FFTW_K766044443) * tre0_1_1) + (((FFTW_REAL) FFTW_K642787609) * tim0_1_1); - tim1_1_0 = (((FFTW_REAL) FFTW_K766044443) * tim0_1_1) - (((FFTW_REAL) FFTW_K642787609) * tre0_1_1); - tre1_2_0 = (((FFTW_REAL) FFTW_K173648177) * tre0_1_2) + (((FFTW_REAL) FFTW_K984807753) * tim0_1_2); - tim1_2_0 = (((FFTW_REAL) FFTW_K173648177) * tim0_1_2) - (((FFTW_REAL) FFTW_K984807753) * tre0_1_2); - c_re(out[ostride]) = tre0_1_0 + tre1_1_0 + tre1_2_0; - c_im(out[ostride]) = tim0_1_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - c_re(out[4 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[7 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - c_im(out[4 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[7 * ostride]) = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_1_0 = (((FFTW_REAL) FFTW_K173648177) * tre0_2_1) + (((FFTW_REAL) FFTW_K984807753) * tim0_2_1); - tim1_1_0 = (((FFTW_REAL) FFTW_K173648177) * tim0_2_1) - (((FFTW_REAL) FFTW_K984807753) * tre0_2_1); - tre1_2_0 = (((FFTW_REAL) FFTW_K342020143) * tim0_2_2) - (((FFTW_REAL) FFTW_K939692620) * tre0_2_2); - tim1_2_0 = (((FFTW_REAL) FFTW_K939692620) * tim0_2_2) + (((FFTW_REAL) FFTW_K342020143) * tre0_2_2); - c_re(out[2 * ostride]) = tre0_2_0 + tre1_1_0 + tre1_2_0; - c_im(out[2 * ostride]) = tim0_2_0 + tim1_1_0 - tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_2_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 + tim1_2_0); - c_re(out[5 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[8 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_2_0 + (((FFTW_REAL) FFTW_K499999999) * (tim1_2_0 - tim1_1_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - c_im(out[5 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[8 * ostride]) = tim2_0_0 - tim2_1_0; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 0 FP additions and 0 FP multiplications */ - -void fftwi_no_twiddle_1(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - tre0_0_0 = c_re(in[0]); - tim0_0_0 = c_im(in[0]); - c_re(out[0]) = tre0_0_0; - c_im(out[0]) = tim0_0_0; -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 108 FP additions and 32 FP multiplications */ - -void fftwi_no_twiddle_10(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[5 * istride]); - tim1_1_0 = c_im(in[5 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[2 * istride]); - tim1_0_0 = c_im(in[2 * istride]); - tre1_1_0 = c_re(in[7 * istride]); - tim1_1_0 = c_im(in[7 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[4 * istride]); - tim1_0_0 = c_im(in[4 * istride]); - tre1_1_0 = c_re(in[9 * istride]); - tim1_1_0 = c_im(in[9 * istride]); - tre0_0_2 = tre1_0_0 + tre1_1_0; - tim0_0_2 = tim1_0_0 + tim1_1_0; - tre0_1_2 = tre1_0_0 - tre1_1_0; - tim0_1_2 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[6 * istride]); - tim1_0_0 = c_im(in[6 * istride]); - tre1_1_0 = c_re(in[istride]); - tim1_1_0 = c_im(in[istride]); - tre0_0_3 = tre1_0_0 + tre1_1_0; - tim0_0_3 = tim1_0_0 + tim1_1_0; - tre0_1_3 = tre1_0_0 - tre1_1_0; - tim0_1_3 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[8 * istride]); - tim1_0_0 = c_im(in[8 * istride]); - tre1_1_0 = c_re(in[3 * istride]); - tim1_1_0 = c_im(in[3 * istride]); - tre0_0_4 = tre1_0_0 + tre1_1_0; - tim0_0_4 = tim1_0_0 + tim1_1_0; - tre0_1_4 = tre1_0_0 - tre1_1_0; - tim0_1_4 = tim1_0_0 - tim1_1_0; - } - c_re(out[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2 + tre0_0_3 + tre0_0_4; - c_im(out[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2 + tim0_0_3 + tim0_0_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_0_1 + tre0_0_4)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_0_2 + tre0_0_3)); - tre2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_0_4 - tim0_0_1)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_0_3 - tim0_0_2)); - c_re(out[6 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[4 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_0_1 + tim0_0_4)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_0_2 + tim0_0_3)); - tim2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_0_1 - tre0_0_4)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_0_2 - tre0_0_3)); - c_im(out[6 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[4 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_0_2 + tre0_0_3)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_0_1 + tre0_0_4)); - tre2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_0_4 - tim0_0_1)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_0_2 - tim0_0_3)); - c_re(out[2 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[8 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_0_2 + tim0_0_3)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_0_1 + tim0_0_4)); - tim2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_0_1 - tre0_0_4)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_0_3 - tre0_0_2)); - c_im(out[2 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[8 * ostride]) = tim2_0_0 - tim2_1_0; - } - c_re(out[5 * ostride]) = tre0_1_0 + tre0_1_1 + tre0_1_2 + tre0_1_3 + tre0_1_4; - c_im(out[5 * ostride]) = tim0_1_0 + tim0_1_1 + tim0_1_2 + tim0_1_3 + tim0_1_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_1 + tre0_1_4)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_2 + tre0_1_3)); - tre2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_1_4 - tim0_1_1)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_1_3 - tim0_1_2)); - c_re(out[ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[9 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_1 + tim0_1_4)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_2 + tim0_1_3)); - tim2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_1_1 - tre0_1_4)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_1_2 - tre0_1_3)); - c_im(out[ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[9 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_2 + tre0_1_3)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_1 + tre0_1_4)); - tre2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_1_4 - tim0_1_1)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_1_2 - tim0_1_3)); - c_re(out[7 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[3 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_2 + tim0_1_3)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_1 + tim0_1_4)); - tim2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_1_1 - tre0_1_4)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_1_3 - tre0_1_2)); - c_im(out[7 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[3 * ostride]) = tim2_0_0 - tim2_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 230 FP additions and 100 FP multiplications */ - -void fftwi_no_twiddle_11(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - FFTW_REAL tre0_5_0; - FFTW_REAL tim0_5_0; - FFTW_REAL tre0_6_0; - FFTW_REAL tim0_6_0; - FFTW_REAL tre0_7_0; - FFTW_REAL tim0_7_0; - FFTW_REAL tre0_8_0; - FFTW_REAL tim0_8_0; - FFTW_REAL tre0_9_0; - FFTW_REAL tim0_9_0; - FFTW_REAL tre0_10_0; - FFTW_REAL tim0_10_0; - tre0_0_0 = c_re(in[0]); - tim0_0_0 = c_im(in[0]); - tre0_1_0 = c_re(in[istride]); - tim0_1_0 = c_im(in[istride]); - tre0_2_0 = c_re(in[2 * istride]); - tim0_2_0 = c_im(in[2 * istride]); - tre0_3_0 = c_re(in[3 * istride]); - tim0_3_0 = c_im(in[3 * istride]); - tre0_4_0 = c_re(in[4 * istride]); - tim0_4_0 = c_im(in[4 * istride]); - tre0_5_0 = c_re(in[5 * istride]); - tim0_5_0 = c_im(in[5 * istride]); - tre0_6_0 = c_re(in[6 * istride]); - tim0_6_0 = c_im(in[6 * istride]); - tre0_7_0 = c_re(in[7 * istride]); - tim0_7_0 = c_im(in[7 * istride]); - tre0_8_0 = c_re(in[8 * istride]); - tim0_8_0 = c_im(in[8 * istride]); - tre0_9_0 = c_re(in[9 * istride]); - tim0_9_0 = c_im(in[9 * istride]); - tre0_10_0 = c_re(in[10 * istride]); - tim0_10_0 = c_im(in[10 * istride]); - c_re(out[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0 + tre0_3_0 + tre0_4_0 + tre0_5_0 + tre0_6_0 + tre0_7_0 + tre0_8_0 + tre0_9_0 + tre0_10_0; - c_im(out[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0 + tim0_3_0 + tim0_4_0 + tim0_5_0 + tim0_6_0 + tim0_7_0 + tim0_8_0 + tim0_9_0 + tim0_10_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K841253532) * (tre0_1_0 + tre0_10_0)) + (((FFTW_REAL) FFTW_K415415013) * (tre0_2_0 + tre0_9_0)) - (((FFTW_REAL) FFTW_K959492973) * (tre0_5_0 + tre0_6_0)) - (((FFTW_REAL) FFTW_K654860733) * (tre0_4_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K142314838) * (tre0_3_0 + tre0_8_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K540640817) * (tim0_10_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K909631995) * (tim0_9_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K989821441) * (tim0_8_0 - tim0_3_0)) + (((FFTW_REAL) FFTW_K755749574) * (tim0_7_0 - tim0_4_0)) + (((FFTW_REAL) FFTW_K281732556) * (tim0_6_0 - tim0_5_0)); - c_re(out[ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[10 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K841253532) * (tim0_1_0 + tim0_10_0)) + (((FFTW_REAL) FFTW_K415415013) * (tim0_2_0 + tim0_9_0)) - (((FFTW_REAL) FFTW_K959492973) * (tim0_5_0 + tim0_6_0)) - (((FFTW_REAL) FFTW_K654860733) * (tim0_4_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K142314838) * (tim0_3_0 + tim0_8_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K540640817) * (tre0_1_0 - tre0_10_0)) + (((FFTW_REAL) FFTW_K909631995) * (tre0_2_0 - tre0_9_0)) + (((FFTW_REAL) FFTW_K989821441) * (tre0_3_0 - tre0_8_0)) + (((FFTW_REAL) FFTW_K755749574) * (tre0_4_0 - tre0_7_0)) + (((FFTW_REAL) FFTW_K281732556) * (tre0_5_0 - tre0_6_0)); - c_im(out[ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[10 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K415415013) * (tre0_1_0 + tre0_10_0)) + (((FFTW_REAL) FFTW_K841253532) * (tre0_5_0 + tre0_6_0)) - (((FFTW_REAL) FFTW_K142314838) * (tre0_4_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K959492973) * (tre0_3_0 + tre0_8_0)) - (((FFTW_REAL) FFTW_K654860733) * (tre0_2_0 + tre0_9_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K909631995) * (tim0_10_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K755749574) * (tim0_9_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K281732556) * (tim0_3_0 - tim0_8_0)) + (((FFTW_REAL) FFTW_K989821441) * (tim0_4_0 - tim0_7_0)) + (((FFTW_REAL) FFTW_K540640817) * (tim0_5_0 - tim0_6_0)); - c_re(out[2 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[9 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K415415013) * (tim0_1_0 + tim0_10_0)) + (((FFTW_REAL) FFTW_K841253532) * (tim0_5_0 + tim0_6_0)) - (((FFTW_REAL) FFTW_K142314838) * (tim0_4_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K959492973) * (tim0_3_0 + tim0_8_0)) - (((FFTW_REAL) FFTW_K654860733) * (tim0_2_0 + tim0_9_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K909631995) * (tre0_1_0 - tre0_10_0)) + (((FFTW_REAL) FFTW_K755749574) * (tre0_2_0 - tre0_9_0)) + (((FFTW_REAL) FFTW_K281732556) * (tre0_8_0 - tre0_3_0)) + (((FFTW_REAL) FFTW_K989821441) * (tre0_7_0 - tre0_4_0)) + (((FFTW_REAL) FFTW_K540640817) * (tre0_6_0 - tre0_5_0)); - c_im(out[2 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[9 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K415415013) * (tre0_3_0 + tre0_8_0)) + (((FFTW_REAL) FFTW_K841253532) * (tre0_4_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K654860733) * (tre0_5_0 + tre0_6_0)) - (((FFTW_REAL) FFTW_K959492973) * (tre0_2_0 + tre0_9_0)) - (((FFTW_REAL) FFTW_K142314838) * (tre0_1_0 + tre0_10_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K989821441) * (tim0_10_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K281732556) * (tim0_2_0 - tim0_9_0)) + (((FFTW_REAL) FFTW_K909631995) * (tim0_3_0 - tim0_8_0)) + (((FFTW_REAL) FFTW_K540640817) * (tim0_7_0 - tim0_4_0)) + (((FFTW_REAL) FFTW_K755749574) * (tim0_6_0 - tim0_5_0)); - c_re(out[3 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[8 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K415415013) * (tim0_3_0 + tim0_8_0)) + (((FFTW_REAL) FFTW_K841253532) * (tim0_4_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K654860733) * (tim0_5_0 + tim0_6_0)) - (((FFTW_REAL) FFTW_K959492973) * (tim0_2_0 + tim0_9_0)) - (((FFTW_REAL) FFTW_K142314838) * (tim0_1_0 + tim0_10_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K989821441) * (tre0_1_0 - tre0_10_0)) + (((FFTW_REAL) FFTW_K281732556) * (tre0_9_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K909631995) * (tre0_8_0 - tre0_3_0)) + (((FFTW_REAL) FFTW_K540640817) * (tre0_4_0 - tre0_7_0)) + (((FFTW_REAL) FFTW_K755749574) * (tre0_5_0 - tre0_6_0)); - c_im(out[3 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[8 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K841253532) * (tre0_3_0 + tre0_8_0)) + (((FFTW_REAL) FFTW_K415415013) * (tre0_5_0 + tre0_6_0)) - (((FFTW_REAL) FFTW_K959492973) * (tre0_4_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K142314838) * (tre0_2_0 + tre0_9_0)) - (((FFTW_REAL) FFTW_K654860733) * (tre0_1_0 + tre0_10_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K755749574) * (tim0_10_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K989821441) * (tim0_2_0 - tim0_9_0)) + (((FFTW_REAL) FFTW_K540640817) * (tim0_8_0 - tim0_3_0)) + (((FFTW_REAL) FFTW_K281732556) * (tim0_7_0 - tim0_4_0)) + (((FFTW_REAL) FFTW_K909631995) * (tim0_5_0 - tim0_6_0)); - c_re(out[4 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[7 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K841253532) * (tim0_3_0 + tim0_8_0)) + (((FFTW_REAL) FFTW_K415415013) * (tim0_5_0 + tim0_6_0)) - (((FFTW_REAL) FFTW_K959492973) * (tim0_4_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K142314838) * (tim0_2_0 + tim0_9_0)) - (((FFTW_REAL) FFTW_K654860733) * (tim0_1_0 + tim0_10_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K755749574) * (tre0_1_0 - tre0_10_0)) + (((FFTW_REAL) FFTW_K989821441) * (tre0_9_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K540640817) * (tre0_3_0 - tre0_8_0)) + (((FFTW_REAL) FFTW_K281732556) * (tre0_4_0 - tre0_7_0)) + (((FFTW_REAL) FFTW_K909631995) * (tre0_6_0 - tre0_5_0)); - c_im(out[4 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[7 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K841253532) * (tre0_2_0 + tre0_9_0)) + (((FFTW_REAL) FFTW_K415415013) * (tre0_4_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K142314838) * (tre0_5_0 + tre0_6_0)) - (((FFTW_REAL) FFTW_K654860733) * (tre0_3_0 + tre0_8_0)) - (((FFTW_REAL) FFTW_K959492973) * (tre0_1_0 + tre0_10_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K281732556) * (tim0_10_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K540640817) * (tim0_2_0 - tim0_9_0)) + (((FFTW_REAL) FFTW_K755749574) * (tim0_8_0 - tim0_3_0)) + (((FFTW_REAL) FFTW_K909631995) * (tim0_4_0 - tim0_7_0)) + (((FFTW_REAL) FFTW_K989821441) * (tim0_6_0 - tim0_5_0)); - c_re(out[5 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[6 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K841253532) * (tim0_2_0 + tim0_9_0)) + (((FFTW_REAL) FFTW_K415415013) * (tim0_4_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K142314838) * (tim0_5_0 + tim0_6_0)) - (((FFTW_REAL) FFTW_K654860733) * (tim0_3_0 + tim0_8_0)) - (((FFTW_REAL) FFTW_K959492973) * (tim0_1_0 + tim0_10_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K281732556) * (tre0_1_0 - tre0_10_0)) + (((FFTW_REAL) FFTW_K540640817) * (tre0_9_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K755749574) * (tre0_3_0 - tre0_8_0)) + (((FFTW_REAL) FFTW_K909631995) * (tre0_7_0 - tre0_4_0)) + (((FFTW_REAL) FFTW_K989821441) * (tre0_5_0 - tre0_6_0)); - c_im(out[5 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[6 * ostride]) = tim1_0_0 - tim1_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 104 FP additions and 16 FP multiplications */ - -void fftwi_no_twiddle_12(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[4 * istride]); - tim1_1_0 = c_im(in[4 * istride]); - tre1_2_0 = c_re(in[8 * istride]); - tim1_2_0 = c_im(in[8 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_0 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - tre0_1_0 = tre2_0_0 + tre2_1_0; - tre0_2_0 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - tim0_1_0 = tim2_0_0 + tim2_1_0; - tim0_2_0 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[3 * istride]); - tim1_0_0 = c_im(in[3 * istride]); - tre1_1_0 = c_re(in[7 * istride]); - tim1_1_0 = c_im(in[7 * istride]); - tre1_2_0 = c_re(in[11 * istride]); - tim1_2_0 = c_im(in[11 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_1 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - tre0_1_1 = tre2_0_0 + tre2_1_0; - tre0_2_1 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - tim0_1_1 = tim2_0_0 + tim2_1_0; - tim0_2_1 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[6 * istride]); - tim1_0_0 = c_im(in[6 * istride]); - tre1_1_0 = c_re(in[10 * istride]); - tim1_1_0 = c_im(in[10 * istride]); - tre1_2_0 = c_re(in[2 * istride]); - tim1_2_0 = c_im(in[2 * istride]); - tre0_0_2 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_2 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - tre0_1_2 = tre2_0_0 + tre2_1_0; - tre0_2_2 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - tim0_1_2 = tim2_0_0 + tim2_1_0; - tim0_2_2 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[9 * istride]); - tim1_0_0 = c_im(in[9 * istride]); - tre1_1_0 = c_re(in[istride]); - tim1_1_0 = c_im(in[istride]); - tre1_2_0 = c_re(in[5 * istride]); - tim1_2_0 = c_im(in[5 * istride]); - tre0_0_3 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_3 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - tre0_1_3 = tre2_0_0 + tre2_1_0; - tre0_2_3 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - tim0_1_3 = tim2_0_0 + tim2_1_0; - tim0_2_3 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_0_0 + tre0_0_2; - tim1_0_0 = tim0_0_0 + tim0_0_2; - tre1_1_0 = tre0_0_0 - tre0_0_2; - tim1_1_0 = tim0_0_0 - tim0_0_2; - tre1_0_1 = tre0_0_1 + tre0_0_3; - tim1_0_1 = tim0_0_1 + tim0_0_3; - tre1_1_1 = tre0_0_1 - tre0_0_3; - tim1_1_1 = tim0_0_1 - tim0_0_3; - c_re(out[0]) = tre1_0_0 + tre1_0_1; - c_im(out[0]) = tim1_0_0 + tim1_0_1; - c_re(out[6 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[6 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[9 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[9 * ostride]) = tim1_1_0 + tre1_1_1; - c_re(out[3 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[3 * ostride]) = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_1_0 + tre0_1_2; - tim1_0_0 = tim0_1_0 + tim0_1_2; - tre1_1_0 = tre0_1_0 - tre0_1_2; - tim1_1_0 = tim0_1_0 - tim0_1_2; - tre1_0_1 = tre0_1_1 + tre0_1_3; - tim1_0_1 = tim0_1_1 + tim0_1_3; - tre1_1_1 = tre0_1_1 - tre0_1_3; - tim1_1_1 = tim0_1_1 - tim0_1_3; - c_re(out[4 * ostride]) = tre1_0_0 + tre1_0_1; - c_im(out[4 * ostride]) = tim1_0_0 + tim1_0_1; - c_re(out[10 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[10 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[ostride]) = tim1_1_0 + tre1_1_1; - c_re(out[7 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[7 * ostride]) = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_2_0 + tre0_2_2; - tim1_0_0 = tim0_2_0 + tim0_2_2; - tre1_1_0 = tre0_2_0 - tre0_2_2; - tim1_1_0 = tim0_2_0 - tim0_2_2; - tre1_0_1 = tre0_2_1 + tre0_2_3; - tim1_0_1 = tim0_2_1 + tim0_2_3; - tre1_1_1 = tre0_2_1 - tre0_2_3; - tim1_1_1 = tim0_2_1 - tim0_2_3; - c_re(out[8 * ostride]) = tre1_0_0 + tre1_0_1; - c_im(out[8 * ostride]) = tim1_0_0 + tim1_0_1; - c_re(out[2 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[2 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[5 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[5 * ostride]) = tim1_1_0 + tre1_1_1; - c_re(out[11 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[11 * ostride]) = tim1_1_0 - tre1_1_1; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 324 FP additions and 144 FP multiplications */ - -void fftwi_no_twiddle_13(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - FFTW_REAL tre0_5_0; - FFTW_REAL tim0_5_0; - FFTW_REAL tre0_6_0; - FFTW_REAL tim0_6_0; - FFTW_REAL tre0_7_0; - FFTW_REAL tim0_7_0; - FFTW_REAL tre0_8_0; - FFTW_REAL tim0_8_0; - FFTW_REAL tre0_9_0; - FFTW_REAL tim0_9_0; - FFTW_REAL tre0_10_0; - FFTW_REAL tim0_10_0; - FFTW_REAL tre0_11_0; - FFTW_REAL tim0_11_0; - FFTW_REAL tre0_12_0; - FFTW_REAL tim0_12_0; - tre0_0_0 = c_re(in[0]); - tim0_0_0 = c_im(in[0]); - tre0_1_0 = c_re(in[istride]); - tim0_1_0 = c_im(in[istride]); - tre0_2_0 = c_re(in[2 * istride]); - tim0_2_0 = c_im(in[2 * istride]); - tre0_3_0 = c_re(in[3 * istride]); - tim0_3_0 = c_im(in[3 * istride]); - tre0_4_0 = c_re(in[4 * istride]); - tim0_4_0 = c_im(in[4 * istride]); - tre0_5_0 = c_re(in[5 * istride]); - tim0_5_0 = c_im(in[5 * istride]); - tre0_6_0 = c_re(in[6 * istride]); - tim0_6_0 = c_im(in[6 * istride]); - tre0_7_0 = c_re(in[7 * istride]); - tim0_7_0 = c_im(in[7 * istride]); - tre0_8_0 = c_re(in[8 * istride]); - tim0_8_0 = c_im(in[8 * istride]); - tre0_9_0 = c_re(in[9 * istride]); - tim0_9_0 = c_im(in[9 * istride]); - tre0_10_0 = c_re(in[10 * istride]); - tim0_10_0 = c_im(in[10 * istride]); - tre0_11_0 = c_re(in[11 * istride]); - tim0_11_0 = c_im(in[11 * istride]); - tre0_12_0 = c_re(in[12 * istride]); - tim0_12_0 = c_im(in[12 * istride]); - c_re(out[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0 + tre0_3_0 + tre0_4_0 + tre0_5_0 + tre0_6_0 + tre0_7_0 + tre0_8_0 + tre0_9_0 + tre0_10_0 + tre0_11_0 + tre0_12_0; - c_im(out[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0 + tim0_3_0 + tim0_4_0 + tim0_5_0 + tim0_6_0 + tim0_7_0 + tim0_8_0 + tim0_9_0 + tim0_10_0 + tim0_11_0 + tim0_12_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K885456025) * (tre0_1_0 + tre0_12_0)) + (((FFTW_REAL) FFTW_K568064746) * (tre0_2_0 + tre0_11_0)) + (((FFTW_REAL) FFTW_K120536680) * (tre0_3_0 + tre0_10_0)) - (((FFTW_REAL) FFTW_K970941817) * (tre0_6_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K748510748) * (tre0_5_0 + tre0_8_0)) - (((FFTW_REAL) FFTW_K354604887) * (tre0_4_0 + tre0_9_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K464723172) * (tim0_12_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K822983865) * (tim0_11_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K992708874) * (tim0_10_0 - tim0_3_0)) + (((FFTW_REAL) FFTW_K935016242) * (tim0_9_0 - tim0_4_0)) + (((FFTW_REAL) FFTW_K663122658) * (tim0_8_0 - tim0_5_0)) + (((FFTW_REAL) FFTW_K239315664) * (tim0_7_0 - tim0_6_0)); - c_re(out[ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[12 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K885456025) * (tim0_1_0 + tim0_12_0)) + (((FFTW_REAL) FFTW_K568064746) * (tim0_2_0 + tim0_11_0)) + (((FFTW_REAL) FFTW_K120536680) * (tim0_3_0 + tim0_10_0)) - (((FFTW_REAL) FFTW_K970941817) * (tim0_6_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K748510748) * (tim0_5_0 + tim0_8_0)) - (((FFTW_REAL) FFTW_K354604887) * (tim0_4_0 + tim0_9_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K464723172) * (tre0_1_0 - tre0_12_0)) + (((FFTW_REAL) FFTW_K822983865) * (tre0_2_0 - tre0_11_0)) + (((FFTW_REAL) FFTW_K992708874) * (tre0_3_0 - tre0_10_0)) + (((FFTW_REAL) FFTW_K935016242) * (tre0_4_0 - tre0_9_0)) + (((FFTW_REAL) FFTW_K663122658) * (tre0_5_0 - tre0_8_0)) + (((FFTW_REAL) FFTW_K239315664) * (tre0_6_0 - tre0_7_0)); - c_im(out[ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[12 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K568064746) * (tre0_1_0 + tre0_12_0)) + (((FFTW_REAL) FFTW_K120536680) * (tre0_5_0 + tre0_8_0)) + (((FFTW_REAL) FFTW_K885456025) * (tre0_6_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K748510748) * (tre0_4_0 + tre0_9_0)) - (((FFTW_REAL) FFTW_K970941817) * (tre0_3_0 + tre0_10_0)) - (((FFTW_REAL) FFTW_K354604887) * (tre0_2_0 + tre0_11_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K822983865) * (tim0_12_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K935016242) * (tim0_11_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K239315664) * (tim0_10_0 - tim0_3_0)) + (((FFTW_REAL) FFTW_K663122658) * (tim0_4_0 - tim0_9_0)) + (((FFTW_REAL) FFTW_K992708874) * (tim0_5_0 - tim0_8_0)) + (((FFTW_REAL) FFTW_K464723172) * (tim0_6_0 - tim0_7_0)); - c_re(out[2 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[11 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K568064746) * (tim0_1_0 + tim0_12_0)) + (((FFTW_REAL) FFTW_K120536680) * (tim0_5_0 + tim0_8_0)) + (((FFTW_REAL) FFTW_K885456025) * (tim0_6_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K748510748) * (tim0_4_0 + tim0_9_0)) - (((FFTW_REAL) FFTW_K970941817) * (tim0_3_0 + tim0_10_0)) - (((FFTW_REAL) FFTW_K354604887) * (tim0_2_0 + tim0_11_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K822983865) * (tre0_1_0 - tre0_12_0)) + (((FFTW_REAL) FFTW_K935016242) * (tre0_2_0 - tre0_11_0)) + (((FFTW_REAL) FFTW_K239315664) * (tre0_3_0 - tre0_10_0)) + (((FFTW_REAL) FFTW_K663122658) * (tre0_9_0 - tre0_4_0)) + (((FFTW_REAL) FFTW_K992708874) * (tre0_8_0 - tre0_5_0)) + (((FFTW_REAL) FFTW_K464723172) * (tre0_7_0 - tre0_6_0)); - c_im(out[2 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[11 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K120536680) * (tre0_1_0 + tre0_12_0)) + (((FFTW_REAL) FFTW_K885456025) * (tre0_4_0 + tre0_9_0)) + (((FFTW_REAL) FFTW_K568064746) * (tre0_5_0 + tre0_8_0)) - (((FFTW_REAL) FFTW_K748510748) * (tre0_6_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K354604887) * (tre0_3_0 + tre0_10_0)) - (((FFTW_REAL) FFTW_K970941817) * (tre0_2_0 + tre0_11_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K992708874) * (tim0_12_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K239315664) * (tim0_11_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K935016242) * (tim0_3_0 - tim0_10_0)) + (((FFTW_REAL) FFTW_K464723172) * (tim0_4_0 - tim0_9_0)) + (((FFTW_REAL) FFTW_K822983865) * (tim0_8_0 - tim0_5_0)) + (((FFTW_REAL) FFTW_K663122658) * (tim0_7_0 - tim0_6_0)); - c_re(out[3 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[10 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K120536680) * (tim0_1_0 + tim0_12_0)) + (((FFTW_REAL) FFTW_K885456025) * (tim0_4_0 + tim0_9_0)) + (((FFTW_REAL) FFTW_K568064746) * (tim0_5_0 + tim0_8_0)) - (((FFTW_REAL) FFTW_K748510748) * (tim0_6_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K354604887) * (tim0_3_0 + tim0_10_0)) - (((FFTW_REAL) FFTW_K970941817) * (tim0_2_0 + tim0_11_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K992708874) * (tre0_1_0 - tre0_12_0)) + (((FFTW_REAL) FFTW_K239315664) * (tre0_2_0 - tre0_11_0)) + (((FFTW_REAL) FFTW_K935016242) * (tre0_10_0 - tre0_3_0)) + (((FFTW_REAL) FFTW_K464723172) * (tre0_9_0 - tre0_4_0)) + (((FFTW_REAL) FFTW_K822983865) * (tre0_5_0 - tre0_8_0)) + (((FFTW_REAL) FFTW_K663122658) * (tre0_6_0 - tre0_7_0)); - c_im(out[3 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[10 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K885456025) * (tre0_3_0 + tre0_10_0)) + (((FFTW_REAL) FFTW_K120536680) * (tre0_4_0 + tre0_9_0)) + (((FFTW_REAL) FFTW_K568064746) * (tre0_6_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K970941817) * (tre0_5_0 + tre0_8_0)) - (((FFTW_REAL) FFTW_K748510748) * (tre0_2_0 + tre0_11_0)) - (((FFTW_REAL) FFTW_K354604887) * (tre0_1_0 + tre0_12_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K935016242) * (tim0_12_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K663122658) * (tim0_2_0 - tim0_11_0)) + (((FFTW_REAL) FFTW_K464723172) * (tim0_3_0 - tim0_10_0)) + (((FFTW_REAL) FFTW_K992708874) * (tim0_9_0 - tim0_4_0)) + (((FFTW_REAL) FFTW_K239315664) * (tim0_5_0 - tim0_8_0)) + (((FFTW_REAL) FFTW_K822983865) * (tim0_6_0 - tim0_7_0)); - c_re(out[4 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[9 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K885456025) * (tim0_3_0 + tim0_10_0)) + (((FFTW_REAL) FFTW_K120536680) * (tim0_4_0 + tim0_9_0)) + (((FFTW_REAL) FFTW_K568064746) * (tim0_6_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K970941817) * (tim0_5_0 + tim0_8_0)) - (((FFTW_REAL) FFTW_K748510748) * (tim0_2_0 + tim0_11_0)) - (((FFTW_REAL) FFTW_K354604887) * (tim0_1_0 + tim0_12_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K935016242) * (tre0_1_0 - tre0_12_0)) + (((FFTW_REAL) FFTW_K663122658) * (tre0_11_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K464723172) * (tre0_10_0 - tre0_3_0)) + (((FFTW_REAL) FFTW_K992708874) * (tre0_4_0 - tre0_9_0)) + (((FFTW_REAL) FFTW_K239315664) * (tre0_8_0 - tre0_5_0)) + (((FFTW_REAL) FFTW_K822983865) * (tre0_7_0 - tre0_6_0)); - c_im(out[4 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[9 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K120536680) * (tre0_2_0 + tre0_11_0)) + (((FFTW_REAL) FFTW_K568064746) * (tre0_3_0 + tre0_10_0)) + (((FFTW_REAL) FFTW_K885456025) * (tre0_5_0 + tre0_8_0)) - (((FFTW_REAL) FFTW_K354604887) * (tre0_6_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K970941817) * (tre0_4_0 + tre0_9_0)) - (((FFTW_REAL) FFTW_K748510748) * (tre0_1_0 + tre0_12_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K663122658) * (tim0_12_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K992708874) * (tim0_2_0 - tim0_11_0)) + (((FFTW_REAL) FFTW_K822983865) * (tim0_10_0 - tim0_3_0)) + (((FFTW_REAL) FFTW_K239315664) * (tim0_4_0 - tim0_9_0)) + (((FFTW_REAL) FFTW_K464723172) * (tim0_5_0 - tim0_8_0)) + (((FFTW_REAL) FFTW_K935016242) * (tim0_7_0 - tim0_6_0)); - c_re(out[5 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[8 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K120536680) * (tim0_2_0 + tim0_11_0)) + (((FFTW_REAL) FFTW_K568064746) * (tim0_3_0 + tim0_10_0)) + (((FFTW_REAL) FFTW_K885456025) * (tim0_5_0 + tim0_8_0)) - (((FFTW_REAL) FFTW_K354604887) * (tim0_6_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K970941817) * (tim0_4_0 + tim0_9_0)) - (((FFTW_REAL) FFTW_K748510748) * (tim0_1_0 + tim0_12_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K663122658) * (tre0_1_0 - tre0_12_0)) + (((FFTW_REAL) FFTW_K992708874) * (tre0_11_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K822983865) * (tre0_3_0 - tre0_10_0)) + (((FFTW_REAL) FFTW_K239315664) * (tre0_9_0 - tre0_4_0)) + (((FFTW_REAL) FFTW_K464723172) * (tre0_8_0 - tre0_5_0)) + (((FFTW_REAL) FFTW_K935016242) * (tre0_6_0 - tre0_7_0)); - c_im(out[5 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[8 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K885456025) * (tre0_2_0 + tre0_11_0)) + (((FFTW_REAL) FFTW_K568064746) * (tre0_4_0 + tre0_9_0)) + (((FFTW_REAL) FFTW_K120536680) * (tre0_6_0 + tre0_7_0)) - (((FFTW_REAL) FFTW_K354604887) * (tre0_5_0 + tre0_8_0)) - (((FFTW_REAL) FFTW_K748510748) * (tre0_3_0 + tre0_10_0)) - (((FFTW_REAL) FFTW_K970941817) * (tre0_1_0 + tre0_12_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K239315664) * (tim0_12_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K464723172) * (tim0_2_0 - tim0_11_0)) + (((FFTW_REAL) FFTW_K663122658) * (tim0_10_0 - tim0_3_0)) + (((FFTW_REAL) FFTW_K822983865) * (tim0_4_0 - tim0_9_0)) + (((FFTW_REAL) FFTW_K935016242) * (tim0_8_0 - tim0_5_0)) + (((FFTW_REAL) FFTW_K992708874) * (tim0_6_0 - tim0_7_0)); - c_re(out[6 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[7 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K885456025) * (tim0_2_0 + tim0_11_0)) + (((FFTW_REAL) FFTW_K568064746) * (tim0_4_0 + tim0_9_0)) + (((FFTW_REAL) FFTW_K120536680) * (tim0_6_0 + tim0_7_0)) - (((FFTW_REAL) FFTW_K354604887) * (tim0_5_0 + tim0_8_0)) - (((FFTW_REAL) FFTW_K748510748) * (tim0_3_0 + tim0_10_0)) - (((FFTW_REAL) FFTW_K970941817) * (tim0_1_0 + tim0_12_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K239315664) * (tre0_1_0 - tre0_12_0)) + (((FFTW_REAL) FFTW_K464723172) * (tre0_11_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K663122658) * (tre0_3_0 - tre0_10_0)) + (((FFTW_REAL) FFTW_K822983865) * (tre0_9_0 - tre0_4_0)) + (((FFTW_REAL) FFTW_K935016242) * (tre0_5_0 - tre0_8_0)) + (((FFTW_REAL) FFTW_K992708874) * (tre0_7_0 - tre0_6_0)); - c_im(out[6 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[7 * ostride]) = tim1_0_0 - tim1_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 208 FP additions and 72 FP multiplications */ - -void fftwi_no_twiddle_14(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_0_5; - FFTW_REAL tim0_0_5; - FFTW_REAL tre0_0_6; - FFTW_REAL tim0_0_6; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - FFTW_REAL tre0_1_5; - FFTW_REAL tim0_1_5; - FFTW_REAL tre0_1_6; - FFTW_REAL tim0_1_6; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[7 * istride]); - tim1_1_0 = c_im(in[7 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[2 * istride]); - tim1_0_0 = c_im(in[2 * istride]); - tre1_1_0 = c_re(in[9 * istride]); - tim1_1_0 = c_im(in[9 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[4 * istride]); - tim1_0_0 = c_im(in[4 * istride]); - tre1_1_0 = c_re(in[11 * istride]); - tim1_1_0 = c_im(in[11 * istride]); - tre0_0_2 = tre1_0_0 + tre1_1_0; - tim0_0_2 = tim1_0_0 + tim1_1_0; - tre0_1_2 = tre1_0_0 - tre1_1_0; - tim0_1_2 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[6 * istride]); - tim1_0_0 = c_im(in[6 * istride]); - tre1_1_0 = c_re(in[13 * istride]); - tim1_1_0 = c_im(in[13 * istride]); - tre0_0_3 = tre1_0_0 + tre1_1_0; - tim0_0_3 = tim1_0_0 + tim1_1_0; - tre0_1_3 = tre1_0_0 - tre1_1_0; - tim0_1_3 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[8 * istride]); - tim1_0_0 = c_im(in[8 * istride]); - tre1_1_0 = c_re(in[istride]); - tim1_1_0 = c_im(in[istride]); - tre0_0_4 = tre1_0_0 + tre1_1_0; - tim0_0_4 = tim1_0_0 + tim1_1_0; - tre0_1_4 = tre1_0_0 - tre1_1_0; - tim0_1_4 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[10 * istride]); - tim1_0_0 = c_im(in[10 * istride]); - tre1_1_0 = c_re(in[3 * istride]); - tim1_1_0 = c_im(in[3 * istride]); - tre0_0_5 = tre1_0_0 + tre1_1_0; - tim0_0_5 = tim1_0_0 + tim1_1_0; - tre0_1_5 = tre1_0_0 - tre1_1_0; - tim0_1_5 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[12 * istride]); - tim1_0_0 = c_im(in[12 * istride]); - tre1_1_0 = c_re(in[5 * istride]); - tim1_1_0 = c_im(in[5 * istride]); - tre0_0_6 = tre1_0_0 + tre1_1_0; - tim0_0_6 = tim1_0_0 + tim1_1_0; - tre0_1_6 = tre1_0_0 - tre1_1_0; - tim0_1_6 = tim1_0_0 - tim1_1_0; - } - c_re(out[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2 + tre0_0_3 + tre0_0_4 + tre0_0_5 + tre0_0_6; - c_im(out[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2 + tim0_0_3 + tim0_0_4 + tim0_0_5 + tim0_0_6; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_0_1 + tre0_0_6)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_0_3 + tre0_0_4)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_0_2 + tre0_0_5)); - tre2_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tim0_0_6 - tim0_0_1)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_0_5 - tim0_0_2)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_0_4 - tim0_0_3)); - c_re(out[8 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[6 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_0_1 + tim0_0_6)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_0_3 + tim0_0_4)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_0_2 + tim0_0_5)); - tim2_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tre0_0_1 - tre0_0_6)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_0_2 - tre0_0_5)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_0_3 - tre0_0_4)); - c_im(out[8 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[6 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_0_3 + tre0_0_4)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_0_2 + tre0_0_5)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_0_1 + tre0_0_6)); - tre2_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tim0_0_6 - tim0_0_1)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_0_2 - tim0_0_5)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_0_3 - tim0_0_4)); - c_re(out[2 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[12 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_0_3 + tim0_0_4)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_0_2 + tim0_0_5)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_0_1 + tim0_0_6)); - tim2_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tre0_0_1 - tre0_0_6)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_0_5 - tre0_0_2)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_0_4 - tre0_0_3)); - c_im(out[2 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[12 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_0_2 + tre0_0_5)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_0_3 + tre0_0_4)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_0_1 + tre0_0_6)); - tre2_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tim0_0_6 - tim0_0_1)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_0_2 - tim0_0_5)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_0_4 - tim0_0_3)); - c_re(out[10 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[4 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_0_2 + tim0_0_5)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_0_3 + tim0_0_4)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_0_1 + tim0_0_6)); - tim2_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tre0_0_1 - tre0_0_6)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_0_5 - tre0_0_2)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_0_3 - tre0_0_4)); - c_im(out[10 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[4 * ostride]) = tim2_0_0 - tim2_1_0; - } - c_re(out[7 * ostride]) = tre0_1_0 + tre0_1_1 + tre0_1_2 + tre0_1_3 + tre0_1_4 + tre0_1_5 + tre0_1_6; - c_im(out[7 * ostride]) = tim0_1_0 + tim0_1_1 + tim0_1_2 + tim0_1_3 + tim0_1_4 + tim0_1_5 + tim0_1_6; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_1_1 + tre0_1_6)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_1_3 + tre0_1_4)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_1_2 + tre0_1_5)); - tre2_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tim0_1_6 - tim0_1_1)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_1_5 - tim0_1_2)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_1_4 - tim0_1_3)); - c_re(out[ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[13 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_1_1 + tim0_1_6)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_1_3 + tim0_1_4)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_1_2 + tim0_1_5)); - tim2_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tre0_1_1 - tre0_1_6)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_1_2 - tre0_1_5)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_1_3 - tre0_1_4)); - c_im(out[ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[13 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_1_3 + tre0_1_4)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_1_2 + tre0_1_5)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_1_1 + tre0_1_6)); - tre2_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tim0_1_6 - tim0_1_1)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_1_2 - tim0_1_5)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_1_3 - tim0_1_4)); - c_re(out[9 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[5 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_1_3 + tim0_1_4)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_1_2 + tim0_1_5)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_1_1 + tim0_1_6)); - tim2_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tre0_1_1 - tre0_1_6)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_1_5 - tre0_1_2)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_1_4 - tre0_1_3)); - c_im(out[9 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[5 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_1_2 + tre0_1_5)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_1_3 + tre0_1_4)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_1_1 + tre0_1_6)); - tre2_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tim0_1_6 - tim0_1_1)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_1_2 - tim0_1_5)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_1_4 - tim0_1_3)); - c_re(out[3 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[11 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_1_2 + tim0_1_5)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_1_3 + tim0_1_4)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_1_1 + tim0_1_6)); - tim2_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tre0_1_1 - tre0_1_6)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_1_5 - tre0_1_2)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_1_3 - tre0_1_4)); - c_im(out[3 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[11 * ostride]) = tim2_0_0 - tim2_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 202 FP additions and 68 FP multiplications */ - -void fftwi_no_twiddle_15(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - FFTW_REAL tre0_2_4; - FFTW_REAL tim0_2_4; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[5 * istride]); - tim1_1_0 = c_im(in[5 * istride]); - tre1_2_0 = c_re(in[10 * istride]); - tim1_2_0 = c_im(in[10 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_0 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - tre0_1_0 = tre2_0_0 + tre2_1_0; - tre0_2_0 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - tim0_1_0 = tim2_0_0 + tim2_1_0; - tim0_2_0 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[3 * istride]); - tim1_0_0 = c_im(in[3 * istride]); - tre1_1_0 = c_re(in[8 * istride]); - tim1_1_0 = c_im(in[8 * istride]); - tre1_2_0 = c_re(in[13 * istride]); - tim1_2_0 = c_im(in[13 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_1 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - tre0_1_1 = tre2_0_0 + tre2_1_0; - tre0_2_1 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - tim0_1_1 = tim2_0_0 + tim2_1_0; - tim0_2_1 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[6 * istride]); - tim1_0_0 = c_im(in[6 * istride]); - tre1_1_0 = c_re(in[11 * istride]); - tim1_1_0 = c_im(in[11 * istride]); - tre1_2_0 = c_re(in[istride]); - tim1_2_0 = c_im(in[istride]); - tre0_0_2 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_2 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - tre0_1_2 = tre2_0_0 + tre2_1_0; - tre0_2_2 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - tim0_1_2 = tim2_0_0 + tim2_1_0; - tim0_2_2 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[9 * istride]); - tim1_0_0 = c_im(in[9 * istride]); - tre1_1_0 = c_re(in[14 * istride]); - tim1_1_0 = c_im(in[14 * istride]); - tre1_2_0 = c_re(in[4 * istride]); - tim1_2_0 = c_im(in[4 * istride]); - tre0_0_3 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_3 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - tre0_1_3 = tre2_0_0 + tre2_1_0; - tre0_2_3 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - tim0_1_3 = tim2_0_0 + tim2_1_0; - tim0_2_3 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[12 * istride]); - tim1_0_0 = c_im(in[12 * istride]); - tre1_1_0 = c_re(in[2 * istride]); - tim1_1_0 = c_im(in[2 * istride]); - tre1_2_0 = c_re(in[7 * istride]); - tim1_2_0 = c_im(in[7 * istride]); - tre0_0_4 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_4 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - tre0_1_4 = tre2_0_0 + tre2_1_0; - tre0_2_4 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - tim0_1_4 = tim2_0_0 + tim2_1_0; - tim0_2_4 = tim2_0_0 - tim2_1_0; - } - } - c_re(out[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2 + tre0_0_3 + tre0_0_4; - c_im(out[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2 + tim0_0_3 + tim0_0_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_0_1 + tre0_0_4)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_0_2 + tre0_0_3)); - tre2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_0_4 - tim0_0_1)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_0_3 - tim0_0_2)); - c_re(out[6 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[9 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_0_1 + tim0_0_4)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_0_2 + tim0_0_3)); - tim2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_0_1 - tre0_0_4)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_0_2 - tre0_0_3)); - c_im(out[6 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[9 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_0_2 + tre0_0_3)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_0_1 + tre0_0_4)); - tre2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_0_4 - tim0_0_1)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_0_2 - tim0_0_3)); - c_re(out[12 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[3 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_0_2 + tim0_0_3)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_0_1 + tim0_0_4)); - tim2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_0_1 - tre0_0_4)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_0_3 - tre0_0_2)); - c_im(out[12 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[3 * ostride]) = tim2_0_0 - tim2_1_0; - } - c_re(out[10 * ostride]) = tre0_1_0 + tre0_1_1 + tre0_1_2 + tre0_1_3 + tre0_1_4; - c_im(out[10 * ostride]) = tim0_1_0 + tim0_1_1 + tim0_1_2 + tim0_1_3 + tim0_1_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_1 + tre0_1_4)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_2 + tre0_1_3)); - tre2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_1_4 - tim0_1_1)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_1_3 - tim0_1_2)); - c_re(out[ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[4 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_1 + tim0_1_4)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_2 + tim0_1_3)); - tim2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_1_1 - tre0_1_4)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_1_2 - tre0_1_3)); - c_im(out[ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[4 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_2 + tre0_1_3)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_1 + tre0_1_4)); - tre2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_1_4 - tim0_1_1)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_1_2 - tim0_1_3)); - c_re(out[7 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[13 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_2 + tim0_1_3)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_1 + tim0_1_4)); - tim2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_1_1 - tre0_1_4)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_1_3 - tre0_1_2)); - c_im(out[7 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[13 * ostride]) = tim2_0_0 - tim2_1_0; - } - c_re(out[5 * ostride]) = tre0_2_0 + tre0_2_1 + tre0_2_2 + tre0_2_3 + tre0_2_4; - c_im(out[5 * ostride]) = tim0_2_0 + tim0_2_1 + tim0_2_2 + tim0_2_3 + tim0_2_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_2_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_2_1 + tre0_2_4)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_2_2 + tre0_2_3)); - tre2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_2_4 - tim0_2_1)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_2_3 - tim0_2_2)); - c_re(out[11 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[14 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_2_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_2_1 + tim0_2_4)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_2_2 + tim0_2_3)); - tim2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_2_1 - tre0_2_4)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_2_2 - tre0_2_3)); - c_im(out[11 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[14 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_2_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_2_2 + tre0_2_3)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_2_1 + tre0_2_4)); - tre2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_2_4 - tim0_2_1)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_2_2 - tim0_2_3)); - c_re(out[2 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[8 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_2_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_2_2 + tim0_2_3)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_2_1 + tim0_2_4)); - tim2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_2_1 - tre0_2_4)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_2_3 - tre0_2_2)); - c_im(out[2 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[8 * ostride]) = tim2_0_0 - tim2_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 144 FP additions and 24 FP multiplications */ - -void fftwi_no_twiddle_16(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_3_1; - FFTW_REAL tim0_3_1; - FFTW_REAL tre0_3_2; - FFTW_REAL tim0_3_2; - FFTW_REAL tre0_3_3; - FFTW_REAL tim0_3_3; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[0]); - tim2_0_0 = c_im(in[0]); - tre2_1_0 = c_re(in[8 * istride]); - tim2_1_0 = c_im(in[8 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[4 * istride]); - tim2_0_0 = c_im(in[4 * istride]); - tre2_1_0 = c_re(in[12 * istride]); - tim2_1_0 = c_im(in[12 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_0 = tre1_0_0 + tre1_0_1; - tim0_0_0 = tim1_0_0 + tim1_0_1; - tre0_2_0 = tre1_0_0 - tre1_0_1; - tim0_2_0 = tim1_0_0 - tim1_0_1; - tre0_1_0 = tre1_1_0 - tim1_1_1; - tim0_1_0 = tim1_1_0 + tre1_1_1; - tre0_3_0 = tre1_1_0 + tim1_1_1; - tim0_3_0 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[istride]); - tim2_0_0 = c_im(in[istride]); - tre2_1_0 = c_re(in[9 * istride]); - tim2_1_0 = c_im(in[9 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[5 * istride]); - tim2_0_0 = c_im(in[5 * istride]); - tre2_1_0 = c_re(in[13 * istride]); - tim2_1_0 = c_im(in[13 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_1 = tre1_0_0 + tre1_0_1; - tim0_0_1 = tim1_0_0 + tim1_0_1; - tre0_2_1 = tre1_0_0 - tre1_0_1; - tim0_2_1 = tim1_0_0 - tim1_0_1; - tre0_1_1 = tre1_1_0 - tim1_1_1; - tim0_1_1 = tim1_1_0 + tre1_1_1; - tre0_3_1 = tre1_1_0 + tim1_1_1; - tim0_3_1 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[2 * istride]); - tim2_0_0 = c_im(in[2 * istride]); - tre2_1_0 = c_re(in[10 * istride]); - tim2_1_0 = c_im(in[10 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[6 * istride]); - tim2_0_0 = c_im(in[6 * istride]); - tre2_1_0 = c_re(in[14 * istride]); - tim2_1_0 = c_im(in[14 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_2 = tre1_0_0 + tre1_0_1; - tim0_0_2 = tim1_0_0 + tim1_0_1; - tre0_2_2 = tre1_0_0 - tre1_0_1; - tim0_2_2 = tim1_0_0 - tim1_0_1; - tre0_1_2 = tre1_1_0 - tim1_1_1; - tim0_1_2 = tim1_1_0 + tre1_1_1; - tre0_3_2 = tre1_1_0 + tim1_1_1; - tim0_3_2 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[3 * istride]); - tim2_0_0 = c_im(in[3 * istride]); - tre2_1_0 = c_re(in[11 * istride]); - tim2_1_0 = c_im(in[11 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[7 * istride]); - tim2_0_0 = c_im(in[7 * istride]); - tre2_1_0 = c_re(in[15 * istride]); - tim2_1_0 = c_im(in[15 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_3 = tre1_0_0 + tre1_0_1; - tim0_0_3 = tim1_0_0 + tim1_0_1; - tre0_2_3 = tre1_0_0 - tre1_0_1; - tim0_2_3 = tim1_0_0 - tim1_0_1; - tre0_1_3 = tre1_1_0 - tim1_1_1; - tim0_1_3 = tim1_1_0 + tre1_1_1; - tre0_3_3 = tre1_1_0 + tim1_1_1; - tim0_3_3 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_0_0 + tre0_0_2; - tim1_0_0 = tim0_0_0 + tim0_0_2; - tre1_1_0 = tre0_0_0 - tre0_0_2; - tim1_1_0 = tim0_0_0 - tim0_0_2; - tre1_0_1 = tre0_0_1 + tre0_0_3; - tim1_0_1 = tim0_0_1 + tim0_0_3; - tre1_1_1 = tre0_0_1 - tre0_0_3; - tim1_1_1 = tim0_0_1 - tim0_0_3; - c_re(out[0]) = tre1_0_0 + tre1_0_1; - c_im(out[0]) = tim1_0_0 + tim1_0_1; - c_re(out[8 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[8 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[4 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[4 * ostride]) = tim1_1_0 + tre1_1_1; - c_re(out[12 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[12 * ostride]) = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_2 - tim0_1_2); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_2 + tre0_1_2); - tre1_0_0 = tre0_1_0 + tre2_1_0; - tim1_0_0 = tim0_1_0 + tim2_1_0; - tre1_1_0 = tre0_1_0 - tre2_1_0; - tim1_1_0 = tim0_1_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_1_1) - (((FFTW_REAL) FFTW_K382683432) * tim0_1_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_1_1) + (((FFTW_REAL) FFTW_K382683432) * tre0_1_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_1_3) - (((FFTW_REAL) FFTW_K923879532) * tim0_1_3); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_1_3) + (((FFTW_REAL) FFTW_K923879532) * tre0_1_3); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - c_re(out[ostride]) = tre1_0_0 + tre1_0_1; - c_im(out[ostride]) = tim1_0_0 + tim1_0_1; - c_re(out[9 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[9 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[5 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[5 * ostride]) = tim1_1_0 + tre1_1_1; - c_re(out[13 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[13 * ostride]) = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_2_0 - tim0_2_2; - tim1_0_0 = tim0_2_0 + tre0_2_2; - tre1_1_0 = tre0_2_0 + tim0_2_2; - tim1_1_0 = tim0_2_0 - tre0_2_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_1 - tim0_2_1); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_1 + tre0_2_1); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_3 + tim0_2_3); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_3 - tim0_2_3); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - c_re(out[2 * ostride]) = tre1_0_0 + tre1_0_1; - c_im(out[2 * ostride]) = tim1_0_0 + tim1_0_1; - c_re(out[10 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[10 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[6 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[6 * ostride]) = tim1_1_0 + tre1_1_1; - c_re(out[14 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[14 * ostride]) = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_3_2 + tim0_3_2); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_3_2 - tim0_3_2); - tre1_0_0 = tre0_3_0 - tre2_1_0; - tim1_0_0 = tim0_3_0 + tim2_1_0; - tre1_1_0 = tre0_3_0 + tre2_1_0; - tim1_1_0 = tim0_3_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_1) - (((FFTW_REAL) FFTW_K923879532) * tim0_3_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_1) + (((FFTW_REAL) FFTW_K923879532) * tre0_3_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_3) - (((FFTW_REAL) FFTW_K923879532) * tre0_3_3); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_3_3) + (((FFTW_REAL) FFTW_K382683432) * tre0_3_3); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - c_re(out[3 * ostride]) = tre1_0_0 + tre1_0_1; - c_im(out[3 * ostride]) = tim1_0_0 + tim1_0_1; - c_re(out[11 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[11 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[7 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[7 * ostride]) = tim1_1_0 + tre1_1_1; - c_re(out[15 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[15 * ostride]) = tim1_1_0 - tre1_1_1; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 4 FP additions and 0 FP multiplications */ - -void fftwi_no_twiddle_2(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - tre0_0_0 = c_re(in[0]); - tim0_0_0 = c_im(in[0]); - tre0_1_0 = c_re(in[istride]); - tim0_1_0 = c_im(in[istride]); - c_re(out[0]) = tre0_0_0 + tre0_1_0; - c_im(out[0]) = tim0_0_0 + tim0_1_0; - c_re(out[ostride]) = tre0_0_0 - tre0_1_0; - c_im(out[ostride]) = tim0_0_0 - tim0_1_0; -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 14 FP additions and 4 FP multiplications */ - -void fftwi_no_twiddle_3(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - tre0_0_0 = c_re(in[0]); - tim0_0_0 = c_im(in[0]); - tre0_1_0 = c_re(in[istride]); - tim0_1_0 = c_im(in[istride]); - tre0_2_0 = c_re(in[2 * istride]); - tim0_2_0 = c_im(in[2 * istride]); - c_re(out[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0; - c_im(out[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_1_0 + tre0_2_0)); - tre1_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_2_0 - tim0_1_0); - c_re(out[ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[2 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_1_0 + tim0_2_0)); - tim1_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_1_0 - tre0_2_0); - c_im(out[ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[2 * ostride]) = tim1_0_0 - tim1_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 376 FP additions and 88 FP multiplications */ - -void fftwi_no_twiddle_32(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_0_5; - FFTW_REAL tim0_0_5; - FFTW_REAL tre0_0_6; - FFTW_REAL tim0_0_6; - FFTW_REAL tre0_0_7; - FFTW_REAL tim0_0_7; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - FFTW_REAL tre0_1_5; - FFTW_REAL tim0_1_5; - FFTW_REAL tre0_1_6; - FFTW_REAL tim0_1_6; - FFTW_REAL tre0_1_7; - FFTW_REAL tim0_1_7; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - FFTW_REAL tre0_2_4; - FFTW_REAL tim0_2_4; - FFTW_REAL tre0_2_5; - FFTW_REAL tim0_2_5; - FFTW_REAL tre0_2_6; - FFTW_REAL tim0_2_6; - FFTW_REAL tre0_2_7; - FFTW_REAL tim0_2_7; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_3_1; - FFTW_REAL tim0_3_1; - FFTW_REAL tre0_3_2; - FFTW_REAL tim0_3_2; - FFTW_REAL tre0_3_3; - FFTW_REAL tim0_3_3; - FFTW_REAL tre0_3_4; - FFTW_REAL tim0_3_4; - FFTW_REAL tre0_3_5; - FFTW_REAL tim0_3_5; - FFTW_REAL tre0_3_6; - FFTW_REAL tim0_3_6; - FFTW_REAL tre0_3_7; - FFTW_REAL tim0_3_7; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[0]); - tim2_0_0 = c_im(in[0]); - tre2_1_0 = c_re(in[16 * istride]); - tim2_1_0 = c_im(in[16 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[8 * istride]); - tim2_0_0 = c_im(in[8 * istride]); - tre2_1_0 = c_re(in[24 * istride]); - tim2_1_0 = c_im(in[24 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_0 = tre1_0_0 + tre1_0_1; - tim0_0_0 = tim1_0_0 + tim1_0_1; - tre0_2_0 = tre1_0_0 - tre1_0_1; - tim0_2_0 = tim1_0_0 - tim1_0_1; - tre0_1_0 = tre1_1_0 - tim1_1_1; - tim0_1_0 = tim1_1_0 + tre1_1_1; - tre0_3_0 = tre1_1_0 + tim1_1_1; - tim0_3_0 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[istride]); - tim2_0_0 = c_im(in[istride]); - tre2_1_0 = c_re(in[17 * istride]); - tim2_1_0 = c_im(in[17 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[9 * istride]); - tim2_0_0 = c_im(in[9 * istride]); - tre2_1_0 = c_re(in[25 * istride]); - tim2_1_0 = c_im(in[25 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_1 = tre1_0_0 + tre1_0_1; - tim0_0_1 = tim1_0_0 + tim1_0_1; - tre0_2_1 = tre1_0_0 - tre1_0_1; - tim0_2_1 = tim1_0_0 - tim1_0_1; - tre0_1_1 = tre1_1_0 - tim1_1_1; - tim0_1_1 = tim1_1_0 + tre1_1_1; - tre0_3_1 = tre1_1_0 + tim1_1_1; - tim0_3_1 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[2 * istride]); - tim2_0_0 = c_im(in[2 * istride]); - tre2_1_0 = c_re(in[18 * istride]); - tim2_1_0 = c_im(in[18 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[10 * istride]); - tim2_0_0 = c_im(in[10 * istride]); - tre2_1_0 = c_re(in[26 * istride]); - tim2_1_0 = c_im(in[26 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_2 = tre1_0_0 + tre1_0_1; - tim0_0_2 = tim1_0_0 + tim1_0_1; - tre0_2_2 = tre1_0_0 - tre1_0_1; - tim0_2_2 = tim1_0_0 - tim1_0_1; - tre0_1_2 = tre1_1_0 - tim1_1_1; - tim0_1_2 = tim1_1_0 + tre1_1_1; - tre0_3_2 = tre1_1_0 + tim1_1_1; - tim0_3_2 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[3 * istride]); - tim2_0_0 = c_im(in[3 * istride]); - tre2_1_0 = c_re(in[19 * istride]); - tim2_1_0 = c_im(in[19 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[11 * istride]); - tim2_0_0 = c_im(in[11 * istride]); - tre2_1_0 = c_re(in[27 * istride]); - tim2_1_0 = c_im(in[27 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_3 = tre1_0_0 + tre1_0_1; - tim0_0_3 = tim1_0_0 + tim1_0_1; - tre0_2_3 = tre1_0_0 - tre1_0_1; - tim0_2_3 = tim1_0_0 - tim1_0_1; - tre0_1_3 = tre1_1_0 - tim1_1_1; - tim0_1_3 = tim1_1_0 + tre1_1_1; - tre0_3_3 = tre1_1_0 + tim1_1_1; - tim0_3_3 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[4 * istride]); - tim2_0_0 = c_im(in[4 * istride]); - tre2_1_0 = c_re(in[20 * istride]); - tim2_1_0 = c_im(in[20 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[12 * istride]); - tim2_0_0 = c_im(in[12 * istride]); - tre2_1_0 = c_re(in[28 * istride]); - tim2_1_0 = c_im(in[28 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_4 = tre1_0_0 + tre1_0_1; - tim0_0_4 = tim1_0_0 + tim1_0_1; - tre0_2_4 = tre1_0_0 - tre1_0_1; - tim0_2_4 = tim1_0_0 - tim1_0_1; - tre0_1_4 = tre1_1_0 - tim1_1_1; - tim0_1_4 = tim1_1_0 + tre1_1_1; - tre0_3_4 = tre1_1_0 + tim1_1_1; - tim0_3_4 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[5 * istride]); - tim2_0_0 = c_im(in[5 * istride]); - tre2_1_0 = c_re(in[21 * istride]); - tim2_1_0 = c_im(in[21 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[13 * istride]); - tim2_0_0 = c_im(in[13 * istride]); - tre2_1_0 = c_re(in[29 * istride]); - tim2_1_0 = c_im(in[29 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_5 = tre1_0_0 + tre1_0_1; - tim0_0_5 = tim1_0_0 + tim1_0_1; - tre0_2_5 = tre1_0_0 - tre1_0_1; - tim0_2_5 = tim1_0_0 - tim1_0_1; - tre0_1_5 = tre1_1_0 - tim1_1_1; - tim0_1_5 = tim1_1_0 + tre1_1_1; - tre0_3_5 = tre1_1_0 + tim1_1_1; - tim0_3_5 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[6 * istride]); - tim2_0_0 = c_im(in[6 * istride]); - tre2_1_0 = c_re(in[22 * istride]); - tim2_1_0 = c_im(in[22 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[14 * istride]); - tim2_0_0 = c_im(in[14 * istride]); - tre2_1_0 = c_re(in[30 * istride]); - tim2_1_0 = c_im(in[30 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_6 = tre1_0_0 + tre1_0_1; - tim0_0_6 = tim1_0_0 + tim1_0_1; - tre0_2_6 = tre1_0_0 - tre1_0_1; - tim0_2_6 = tim1_0_0 - tim1_0_1; - tre0_1_6 = tre1_1_0 - tim1_1_1; - tim0_1_6 = tim1_1_0 + tre1_1_1; - tre0_3_6 = tre1_1_0 + tim1_1_1; - tim0_3_6 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[7 * istride]); - tim2_0_0 = c_im(in[7 * istride]); - tre2_1_0 = c_re(in[23 * istride]); - tim2_1_0 = c_im(in[23 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[15 * istride]); - tim2_0_0 = c_im(in[15 * istride]); - tre2_1_0 = c_re(in[31 * istride]); - tim2_1_0 = c_im(in[31 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_7 = tre1_0_0 + tre1_0_1; - tim0_0_7 = tim1_0_0 + tim1_0_1; - tre0_2_7 = tre1_0_0 - tre1_0_1; - tim0_2_7 = tim1_0_0 - tim1_0_1; - tre0_1_7 = tre1_1_0 - tim1_1_1; - tim0_1_7 = tim1_1_0 + tre1_1_1; - tre0_3_7 = tre1_1_0 + tim1_1_1; - tim0_3_7 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_0_0 + tre0_0_4; - tim1_0_0 = tim0_0_0 + tim0_0_4; - tre1_1_0 = tre0_0_0 - tre0_0_4; - tim1_1_0 = tim0_0_0 - tim0_0_4; - tre1_0_1 = tre0_0_1 + tre0_0_5; - tim1_0_1 = tim0_0_1 + tim0_0_5; - tre1_1_1 = tre0_0_1 - tre0_0_5; - tim1_1_1 = tim0_0_1 - tim0_0_5; - tre1_0_2 = tre0_0_2 + tre0_0_6; - tim1_0_2 = tim0_0_2 + tim0_0_6; - tre1_1_2 = tre0_0_2 - tre0_0_6; - tim1_1_2 = tim0_0_2 - tim0_0_6; - tre1_0_3 = tre0_0_3 + tre0_0_7; - tim1_0_3 = tim0_0_3 + tim0_0_7; - tre1_1_3 = tre0_0_3 - tre0_0_7; - tim1_1_3 = tim0_0_3 - tim0_0_7; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[0]) = tre2_0_0 + tre2_0_1; - c_im(out[0]) = tim2_0_0 + tim2_0_1; - c_re(out[16 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[16 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[8 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[8 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[24 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[24 * ostride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(out[4 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[4 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[20 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[20 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[12 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[12 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[28 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[28 * ostride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_4 - tim0_1_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_4 + tre0_1_4); - tre1_0_0 = tre0_1_0 + tre2_1_0; - tim1_0_0 = tim0_1_0 + tim2_1_0; - tre1_1_0 = tre0_1_0 - tre2_1_0; - tim1_1_0 = tim0_1_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_1_1) - (((FFTW_REAL) FFTW_K195090322) * tim0_1_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_1_1) + (((FFTW_REAL) FFTW_K195090322) * tre0_1_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_1_5) - (((FFTW_REAL) FFTW_K831469612) * tim0_1_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_1_5) + (((FFTW_REAL) FFTW_K831469612) * tre0_1_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_1_2) - (((FFTW_REAL) FFTW_K382683432) * tim0_1_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_1_2) + (((FFTW_REAL) FFTW_K382683432) * tre0_1_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_1_6) - (((FFTW_REAL) FFTW_K923879532) * tim0_1_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_1_6) + (((FFTW_REAL) FFTW_K923879532) * tre0_1_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_1_3) - (((FFTW_REAL) FFTW_K555570233) * tim0_1_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_1_3) + (((FFTW_REAL) FFTW_K555570233) * tre0_1_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_1_7) - (((FFTW_REAL) FFTW_K980785280) * tim0_1_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_1_7) + (((FFTW_REAL) FFTW_K980785280) * tre0_1_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[17 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[17 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[9 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[9 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[25 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[25 * ostride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(out[5 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[5 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[21 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[21 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[13 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[13 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[29 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[29 * ostride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_2_0 - tim0_2_4; - tim1_0_0 = tim0_2_0 + tre0_2_4; - tre1_1_0 = tre0_2_0 + tim0_2_4; - tim1_1_0 = tim0_2_0 - tre0_2_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_2_1) - (((FFTW_REAL) FFTW_K382683432) * tim0_2_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_2_1) + (((FFTW_REAL) FFTW_K382683432) * tre0_2_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_2_5) + (((FFTW_REAL) FFTW_K923879532) * tim0_2_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_2_5) - (((FFTW_REAL) FFTW_K382683432) * tim0_2_5); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_2 - tim0_2_2); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_2 + tre0_2_2); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_6 + tim0_2_6); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_6 - tim0_2_6); - tre1_0_2 = tre2_0_0 - tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 + tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_2_3) - (((FFTW_REAL) FFTW_K923879532) * tim0_2_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_2_3) + (((FFTW_REAL) FFTW_K923879532) * tre0_2_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_2_7) + (((FFTW_REAL) FFTW_K382683432) * tim0_2_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_2_7) - (((FFTW_REAL) FFTW_K923879532) * tim0_2_7); - tre1_0_3 = tre2_0_0 - tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 + tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[2 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[2 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[18 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[18 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[10 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[10 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[26 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[26 * ostride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(out[6 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[6 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[22 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[22 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[14 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[14 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[30 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[30 * ostride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_3_4 + tim0_3_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_3_4 - tim0_3_4); - tre1_0_0 = tre0_3_0 - tre2_1_0; - tim1_0_0 = tim0_3_0 + tim2_1_0; - tre1_1_0 = tre0_3_0 + tre2_1_0; - tim1_1_0 = tim0_3_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_3_1) - (((FFTW_REAL) FFTW_K555570233) * tim0_3_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_3_1) + (((FFTW_REAL) FFTW_K555570233) * tre0_3_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_3_5) + (((FFTW_REAL) FFTW_K195090322) * tim0_3_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_3_5) - (((FFTW_REAL) FFTW_K980785280) * tim0_3_5); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_2) - (((FFTW_REAL) FFTW_K923879532) * tim0_3_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_2) + (((FFTW_REAL) FFTW_K923879532) * tre0_3_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_6) - (((FFTW_REAL) FFTW_K923879532) * tre0_3_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_3_6) + (((FFTW_REAL) FFTW_K382683432) * tre0_3_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 - tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_3_3) + (((FFTW_REAL) FFTW_K980785280) * tim0_3_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_3_3) - (((FFTW_REAL) FFTW_K195090322) * tim0_3_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_3_7) - (((FFTW_REAL) FFTW_K555570233) * tre0_3_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_3_7) + (((FFTW_REAL) FFTW_K831469612) * tre0_3_7); - tre1_0_3 = tre2_1_0 - tre2_0_0; - tim1_0_3 = tim2_0_0 - tim2_1_0; - tre1_1_3 = (-(tre2_0_0 + tre2_1_0)); - tim1_1_3 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[3 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[3 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[19 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[19 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[11 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[11 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[27 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[27 * ostride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(out[7 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[7 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[23 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[23 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[15 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[15 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[31 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[31 * ostride]) = tim2_1_0 - tre2_1_1; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 16 FP additions and 0 FP multiplications */ - -void fftwi_no_twiddle_4(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[2 * istride]); - tim1_1_0 = c_im(in[2 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[istride]); - tim1_0_0 = c_im(in[istride]); - tre1_1_0 = c_re(in[3 * istride]); - tim1_1_0 = c_im(in[3 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - c_re(out[0]) = tre0_0_0 + tre0_0_1; - c_im(out[0]) = tim0_0_0 + tim0_0_1; - c_re(out[2 * ostride]) = tre0_0_0 - tre0_0_1; - c_im(out[2 * ostride]) = tim0_0_0 - tim0_0_1; - c_re(out[ostride]) = tre0_1_0 - tim0_1_1; - c_im(out[ostride]) = tim0_1_0 + tre0_1_1; - c_re(out[3 * ostride]) = tre0_1_0 + tim0_1_1; - c_im(out[3 * ostride]) = tim0_1_0 - tre0_1_1; -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 44 FP additions and 16 FP multiplications */ - -void fftwi_no_twiddle_5(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - tre0_0_0 = c_re(in[0]); - tim0_0_0 = c_im(in[0]); - tre0_1_0 = c_re(in[istride]); - tim0_1_0 = c_im(in[istride]); - tre0_2_0 = c_re(in[2 * istride]); - tim0_2_0 = c_im(in[2 * istride]); - tre0_3_0 = c_re(in[3 * istride]); - tim0_3_0 = c_im(in[3 * istride]); - tre0_4_0 = c_re(in[4 * istride]); - tim0_4_0 = c_im(in[4 * istride]); - c_re(out[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0 + tre0_3_0 + tre0_4_0; - c_im(out[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0 + tim0_3_0 + tim0_4_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_2_0 + tre0_3_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_4_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_3_0 - tim0_2_0)); - c_re(out[ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[4 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_2_0 + tim0_3_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_1_0 - tre0_4_0)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_2_0 - tre0_3_0)); - c_im(out[ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[4 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_2_0 + tre0_3_0)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_0 + tre0_4_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_4_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_2_0 - tim0_3_0)); - c_re(out[2 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[3 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_2_0 + tim0_3_0)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_0 + tim0_4_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_1_0 - tre0_4_0)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_3_0 - tre0_2_0)); - c_im(out[2 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[3 * ostride]) = tim1_0_0 - tim1_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 40 FP additions and 8 FP multiplications */ - -void fftwi_no_twiddle_6(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[3 * istride]); - tim1_1_0 = c_im(in[3 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[2 * istride]); - tim1_0_0 = c_im(in[2 * istride]); - tre1_1_0 = c_re(in[5 * istride]); - tim1_1_0 = c_im(in[5 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[4 * istride]); - tim1_0_0 = c_im(in[4 * istride]); - tre1_1_0 = c_re(in[istride]); - tim1_1_0 = c_im(in[istride]); - tre0_0_2 = tre1_0_0 + tre1_1_0; - tim0_0_2 = tim1_0_0 + tim1_1_0; - tre0_1_2 = tre1_0_0 - tre1_1_0; - tim0_1_2 = tim1_0_0 - tim1_1_0; - } - c_re(out[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2; - c_im(out[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_0_1 + tre0_0_2)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_0_2 - tim0_0_1); - c_re(out[4 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[2 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_0_1 + tim0_0_2)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_0_1 - tre0_0_2); - c_im(out[4 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[2 * ostride]) = tim2_0_0 - tim2_1_0; - } - c_re(out[3 * ostride]) = tre0_1_0 + tre0_1_1 + tre0_1_2; - c_im(out[3 * ostride]) = tim0_1_0 + tim0_1_1 + tim0_1_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_1_1 + tre0_1_2)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_1_2 - tim0_1_1); - c_re(out[ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[5 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_1_1 + tim0_1_2)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_1_1 - tre0_1_2); - c_im(out[ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[5 * ostride]) = tim2_0_0 - tim2_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 928 FP additions and 248 FP multiplications */ - -void fftwi_no_twiddle_64(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_0_5; - FFTW_REAL tim0_0_5; - FFTW_REAL tre0_0_6; - FFTW_REAL tim0_0_6; - FFTW_REAL tre0_0_7; - FFTW_REAL tim0_0_7; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - FFTW_REAL tre0_1_5; - FFTW_REAL tim0_1_5; - FFTW_REAL tre0_1_6; - FFTW_REAL tim0_1_6; - FFTW_REAL tre0_1_7; - FFTW_REAL tim0_1_7; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - FFTW_REAL tre0_2_4; - FFTW_REAL tim0_2_4; - FFTW_REAL tre0_2_5; - FFTW_REAL tim0_2_5; - FFTW_REAL tre0_2_6; - FFTW_REAL tim0_2_6; - FFTW_REAL tre0_2_7; - FFTW_REAL tim0_2_7; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_3_1; - FFTW_REAL tim0_3_1; - FFTW_REAL tre0_3_2; - FFTW_REAL tim0_3_2; - FFTW_REAL tre0_3_3; - FFTW_REAL tim0_3_3; - FFTW_REAL tre0_3_4; - FFTW_REAL tim0_3_4; - FFTW_REAL tre0_3_5; - FFTW_REAL tim0_3_5; - FFTW_REAL tre0_3_6; - FFTW_REAL tim0_3_6; - FFTW_REAL tre0_3_7; - FFTW_REAL tim0_3_7; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - FFTW_REAL tre0_4_1; - FFTW_REAL tim0_4_1; - FFTW_REAL tre0_4_2; - FFTW_REAL tim0_4_2; - FFTW_REAL tre0_4_3; - FFTW_REAL tim0_4_3; - FFTW_REAL tre0_4_4; - FFTW_REAL tim0_4_4; - FFTW_REAL tre0_4_5; - FFTW_REAL tim0_4_5; - FFTW_REAL tre0_4_6; - FFTW_REAL tim0_4_6; - FFTW_REAL tre0_4_7; - FFTW_REAL tim0_4_7; - FFTW_REAL tre0_5_0; - FFTW_REAL tim0_5_0; - FFTW_REAL tre0_5_1; - FFTW_REAL tim0_5_1; - FFTW_REAL tre0_5_2; - FFTW_REAL tim0_5_2; - FFTW_REAL tre0_5_3; - FFTW_REAL tim0_5_3; - FFTW_REAL tre0_5_4; - FFTW_REAL tim0_5_4; - FFTW_REAL tre0_5_5; - FFTW_REAL tim0_5_5; - FFTW_REAL tre0_5_6; - FFTW_REAL tim0_5_6; - FFTW_REAL tre0_5_7; - FFTW_REAL tim0_5_7; - FFTW_REAL tre0_6_0; - FFTW_REAL tim0_6_0; - FFTW_REAL tre0_6_1; - FFTW_REAL tim0_6_1; - FFTW_REAL tre0_6_2; - FFTW_REAL tim0_6_2; - FFTW_REAL tre0_6_3; - FFTW_REAL tim0_6_3; - FFTW_REAL tre0_6_4; - FFTW_REAL tim0_6_4; - FFTW_REAL tre0_6_5; - FFTW_REAL tim0_6_5; - FFTW_REAL tre0_6_6; - FFTW_REAL tim0_6_6; - FFTW_REAL tre0_6_7; - FFTW_REAL tim0_6_7; - FFTW_REAL tre0_7_0; - FFTW_REAL tim0_7_0; - FFTW_REAL tre0_7_1; - FFTW_REAL tim0_7_1; - FFTW_REAL tre0_7_2; - FFTW_REAL tim0_7_2; - FFTW_REAL tre0_7_3; - FFTW_REAL tim0_7_3; - FFTW_REAL tre0_7_4; - FFTW_REAL tim0_7_4; - FFTW_REAL tre0_7_5; - FFTW_REAL tim0_7_5; - FFTW_REAL tre0_7_6; - FFTW_REAL tim0_7_6; - FFTW_REAL tre0_7_7; - FFTW_REAL tim0_7_7; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[0]); - tim2_0_0 = c_im(in[0]); - tre2_1_0 = c_re(in[32 * istride]); - tim2_1_0 = c_im(in[32 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[8 * istride]); - tim2_0_0 = c_im(in[8 * istride]); - tre2_1_0 = c_re(in[40 * istride]); - tim2_1_0 = c_im(in[40 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[16 * istride]); - tim2_0_0 = c_im(in[16 * istride]); - tre2_1_0 = c_re(in[48 * istride]); - tim2_1_0 = c_im(in[48 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[24 * istride]); - tim2_0_0 = c_im(in[24 * istride]); - tre2_1_0 = c_re(in[56 * istride]); - tim2_1_0 = c_im(in[56 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_0 = tre2_0_0 + tre2_0_1; - tim0_0_0 = tim2_0_0 + tim2_0_1; - tre0_4_0 = tre2_0_0 - tre2_0_1; - tim0_4_0 = tim2_0_0 - tim2_0_1; - tre0_2_0 = tre2_1_0 - tim2_1_1; - tim0_2_0 = tim2_1_0 + tre2_1_1; - tre0_6_0 = tre2_1_0 + tim2_1_1; - tim0_6_0 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_0 = tre2_0_0 + tre2_0_1; - tim0_1_0 = tim2_0_0 + tim2_0_1; - tre0_5_0 = tre2_0_0 - tre2_0_1; - tim0_5_0 = tim2_0_0 - tim2_0_1; - tre0_3_0 = tre2_1_0 - tim2_1_1; - tim0_3_0 = tim2_1_0 + tre2_1_1; - tre0_7_0 = tre2_1_0 + tim2_1_1; - tim0_7_0 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[istride]); - tim2_0_0 = c_im(in[istride]); - tre2_1_0 = c_re(in[33 * istride]); - tim2_1_0 = c_im(in[33 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[9 * istride]); - tim2_0_0 = c_im(in[9 * istride]); - tre2_1_0 = c_re(in[41 * istride]); - tim2_1_0 = c_im(in[41 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[17 * istride]); - tim2_0_0 = c_im(in[17 * istride]); - tre2_1_0 = c_re(in[49 * istride]); - tim2_1_0 = c_im(in[49 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[25 * istride]); - tim2_0_0 = c_im(in[25 * istride]); - tre2_1_0 = c_re(in[57 * istride]); - tim2_1_0 = c_im(in[57 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_1 = tre2_0_0 + tre2_0_1; - tim0_0_1 = tim2_0_0 + tim2_0_1; - tre0_4_1 = tre2_0_0 - tre2_0_1; - tim0_4_1 = tim2_0_0 - tim2_0_1; - tre0_2_1 = tre2_1_0 - tim2_1_1; - tim0_2_1 = tim2_1_0 + tre2_1_1; - tre0_6_1 = tre2_1_0 + tim2_1_1; - tim0_6_1 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_1 = tre2_0_0 + tre2_0_1; - tim0_1_1 = tim2_0_0 + tim2_0_1; - tre0_5_1 = tre2_0_0 - tre2_0_1; - tim0_5_1 = tim2_0_0 - tim2_0_1; - tre0_3_1 = tre2_1_0 - tim2_1_1; - tim0_3_1 = tim2_1_0 + tre2_1_1; - tre0_7_1 = tre2_1_0 + tim2_1_1; - tim0_7_1 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[2 * istride]); - tim2_0_0 = c_im(in[2 * istride]); - tre2_1_0 = c_re(in[34 * istride]); - tim2_1_0 = c_im(in[34 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[10 * istride]); - tim2_0_0 = c_im(in[10 * istride]); - tre2_1_0 = c_re(in[42 * istride]); - tim2_1_0 = c_im(in[42 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[18 * istride]); - tim2_0_0 = c_im(in[18 * istride]); - tre2_1_0 = c_re(in[50 * istride]); - tim2_1_0 = c_im(in[50 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[26 * istride]); - tim2_0_0 = c_im(in[26 * istride]); - tre2_1_0 = c_re(in[58 * istride]); - tim2_1_0 = c_im(in[58 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_2 = tre2_0_0 + tre2_0_1; - tim0_0_2 = tim2_0_0 + tim2_0_1; - tre0_4_2 = tre2_0_0 - tre2_0_1; - tim0_4_2 = tim2_0_0 - tim2_0_1; - tre0_2_2 = tre2_1_0 - tim2_1_1; - tim0_2_2 = tim2_1_0 + tre2_1_1; - tre0_6_2 = tre2_1_0 + tim2_1_1; - tim0_6_2 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_2 = tre2_0_0 + tre2_0_1; - tim0_1_2 = tim2_0_0 + tim2_0_1; - tre0_5_2 = tre2_0_0 - tre2_0_1; - tim0_5_2 = tim2_0_0 - tim2_0_1; - tre0_3_2 = tre2_1_0 - tim2_1_1; - tim0_3_2 = tim2_1_0 + tre2_1_1; - tre0_7_2 = tre2_1_0 + tim2_1_1; - tim0_7_2 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[3 * istride]); - tim2_0_0 = c_im(in[3 * istride]); - tre2_1_0 = c_re(in[35 * istride]); - tim2_1_0 = c_im(in[35 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[11 * istride]); - tim2_0_0 = c_im(in[11 * istride]); - tre2_1_0 = c_re(in[43 * istride]); - tim2_1_0 = c_im(in[43 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[19 * istride]); - tim2_0_0 = c_im(in[19 * istride]); - tre2_1_0 = c_re(in[51 * istride]); - tim2_1_0 = c_im(in[51 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[27 * istride]); - tim2_0_0 = c_im(in[27 * istride]); - tre2_1_0 = c_re(in[59 * istride]); - tim2_1_0 = c_im(in[59 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_3 = tre2_0_0 + tre2_0_1; - tim0_0_3 = tim2_0_0 + tim2_0_1; - tre0_4_3 = tre2_0_0 - tre2_0_1; - tim0_4_3 = tim2_0_0 - tim2_0_1; - tre0_2_3 = tre2_1_0 - tim2_1_1; - tim0_2_3 = tim2_1_0 + tre2_1_1; - tre0_6_3 = tre2_1_0 + tim2_1_1; - tim0_6_3 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_3 = tre2_0_0 + tre2_0_1; - tim0_1_3 = tim2_0_0 + tim2_0_1; - tre0_5_3 = tre2_0_0 - tre2_0_1; - tim0_5_3 = tim2_0_0 - tim2_0_1; - tre0_3_3 = tre2_1_0 - tim2_1_1; - tim0_3_3 = tim2_1_0 + tre2_1_1; - tre0_7_3 = tre2_1_0 + tim2_1_1; - tim0_7_3 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[4 * istride]); - tim2_0_0 = c_im(in[4 * istride]); - tre2_1_0 = c_re(in[36 * istride]); - tim2_1_0 = c_im(in[36 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[12 * istride]); - tim2_0_0 = c_im(in[12 * istride]); - tre2_1_0 = c_re(in[44 * istride]); - tim2_1_0 = c_im(in[44 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[20 * istride]); - tim2_0_0 = c_im(in[20 * istride]); - tre2_1_0 = c_re(in[52 * istride]); - tim2_1_0 = c_im(in[52 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[28 * istride]); - tim2_0_0 = c_im(in[28 * istride]); - tre2_1_0 = c_re(in[60 * istride]); - tim2_1_0 = c_im(in[60 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_4 = tre2_0_0 + tre2_0_1; - tim0_0_4 = tim2_0_0 + tim2_0_1; - tre0_4_4 = tre2_0_0 - tre2_0_1; - tim0_4_4 = tim2_0_0 - tim2_0_1; - tre0_2_4 = tre2_1_0 - tim2_1_1; - tim0_2_4 = tim2_1_0 + tre2_1_1; - tre0_6_4 = tre2_1_0 + tim2_1_1; - tim0_6_4 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_4 = tre2_0_0 + tre2_0_1; - tim0_1_4 = tim2_0_0 + tim2_0_1; - tre0_5_4 = tre2_0_0 - tre2_0_1; - tim0_5_4 = tim2_0_0 - tim2_0_1; - tre0_3_4 = tre2_1_0 - tim2_1_1; - tim0_3_4 = tim2_1_0 + tre2_1_1; - tre0_7_4 = tre2_1_0 + tim2_1_1; - tim0_7_4 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[5 * istride]); - tim2_0_0 = c_im(in[5 * istride]); - tre2_1_0 = c_re(in[37 * istride]); - tim2_1_0 = c_im(in[37 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[13 * istride]); - tim2_0_0 = c_im(in[13 * istride]); - tre2_1_0 = c_re(in[45 * istride]); - tim2_1_0 = c_im(in[45 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[21 * istride]); - tim2_0_0 = c_im(in[21 * istride]); - tre2_1_0 = c_re(in[53 * istride]); - tim2_1_0 = c_im(in[53 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[29 * istride]); - tim2_0_0 = c_im(in[29 * istride]); - tre2_1_0 = c_re(in[61 * istride]); - tim2_1_0 = c_im(in[61 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_5 = tre2_0_0 + tre2_0_1; - tim0_0_5 = tim2_0_0 + tim2_0_1; - tre0_4_5 = tre2_0_0 - tre2_0_1; - tim0_4_5 = tim2_0_0 - tim2_0_1; - tre0_2_5 = tre2_1_0 - tim2_1_1; - tim0_2_5 = tim2_1_0 + tre2_1_1; - tre0_6_5 = tre2_1_0 + tim2_1_1; - tim0_6_5 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_5 = tre2_0_0 + tre2_0_1; - tim0_1_5 = tim2_0_0 + tim2_0_1; - tre0_5_5 = tre2_0_0 - tre2_0_1; - tim0_5_5 = tim2_0_0 - tim2_0_1; - tre0_3_5 = tre2_1_0 - tim2_1_1; - tim0_3_5 = tim2_1_0 + tre2_1_1; - tre0_7_5 = tre2_1_0 + tim2_1_1; - tim0_7_5 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[6 * istride]); - tim2_0_0 = c_im(in[6 * istride]); - tre2_1_0 = c_re(in[38 * istride]); - tim2_1_0 = c_im(in[38 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[14 * istride]); - tim2_0_0 = c_im(in[14 * istride]); - tre2_1_0 = c_re(in[46 * istride]); - tim2_1_0 = c_im(in[46 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[22 * istride]); - tim2_0_0 = c_im(in[22 * istride]); - tre2_1_0 = c_re(in[54 * istride]); - tim2_1_0 = c_im(in[54 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[30 * istride]); - tim2_0_0 = c_im(in[30 * istride]); - tre2_1_0 = c_re(in[62 * istride]); - tim2_1_0 = c_im(in[62 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_6 = tre2_0_0 + tre2_0_1; - tim0_0_6 = tim2_0_0 + tim2_0_1; - tre0_4_6 = tre2_0_0 - tre2_0_1; - tim0_4_6 = tim2_0_0 - tim2_0_1; - tre0_2_6 = tre2_1_0 - tim2_1_1; - tim0_2_6 = tim2_1_0 + tre2_1_1; - tre0_6_6 = tre2_1_0 + tim2_1_1; - tim0_6_6 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_6 = tre2_0_0 + tre2_0_1; - tim0_1_6 = tim2_0_0 + tim2_0_1; - tre0_5_6 = tre2_0_0 - tre2_0_1; - tim0_5_6 = tim2_0_0 - tim2_0_1; - tre0_3_6 = tre2_1_0 - tim2_1_1; - tim0_3_6 = tim2_1_0 + tre2_1_1; - tre0_7_6 = tre2_1_0 + tim2_1_1; - tim0_7_6 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[7 * istride]); - tim2_0_0 = c_im(in[7 * istride]); - tre2_1_0 = c_re(in[39 * istride]); - tim2_1_0 = c_im(in[39 * istride]); - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[15 * istride]); - tim2_0_0 = c_im(in[15 * istride]); - tre2_1_0 = c_re(in[47 * istride]); - tim2_1_0 = c_im(in[47 * istride]); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[23 * istride]); - tim2_0_0 = c_im(in[23 * istride]); - tre2_1_0 = c_re(in[55 * istride]); - tim2_1_0 = c_im(in[55 * istride]); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(in[31 * istride]); - tim2_0_0 = c_im(in[31 * istride]); - tre2_1_0 = c_re(in[63 * istride]); - tim2_1_0 = c_im(in[63 * istride]); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_7 = tre2_0_0 + tre2_0_1; - tim0_0_7 = tim2_0_0 + tim2_0_1; - tre0_4_7 = tre2_0_0 - tre2_0_1; - tim0_4_7 = tim2_0_0 - tim2_0_1; - tre0_2_7 = tre2_1_0 - tim2_1_1; - tim0_2_7 = tim2_1_0 + tre2_1_1; - tre0_6_7 = tre2_1_0 + tim2_1_1; - tim0_6_7 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_7 = tre2_0_0 + tre2_0_1; - tim0_1_7 = tim2_0_0 + tim2_0_1; - tre0_5_7 = tre2_0_0 - tre2_0_1; - tim0_5_7 = tim2_0_0 - tim2_0_1; - tre0_3_7 = tre2_1_0 - tim2_1_1; - tim0_3_7 = tim2_1_0 + tre2_1_1; - tre0_7_7 = tre2_1_0 + tim2_1_1; - tim0_7_7 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_0_0 + tre0_0_4; - tim1_0_0 = tim0_0_0 + tim0_0_4; - tre1_1_0 = tre0_0_0 - tre0_0_4; - tim1_1_0 = tim0_0_0 - tim0_0_4; - tre1_0_1 = tre0_0_1 + tre0_0_5; - tim1_0_1 = tim0_0_1 + tim0_0_5; - tre1_1_1 = tre0_0_1 - tre0_0_5; - tim1_1_1 = tim0_0_1 - tim0_0_5; - tre1_0_2 = tre0_0_2 + tre0_0_6; - tim1_0_2 = tim0_0_2 + tim0_0_6; - tre1_1_2 = tre0_0_2 - tre0_0_6; - tim1_1_2 = tim0_0_2 - tim0_0_6; - tre1_0_3 = tre0_0_3 + tre0_0_7; - tim1_0_3 = tim0_0_3 + tim0_0_7; - tre1_1_3 = tre0_0_3 - tre0_0_7; - tim1_1_3 = tim0_0_3 - tim0_0_7; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[0]) = tre2_0_0 + tre2_0_1; - c_im(out[0]) = tim2_0_0 + tim2_0_1; - c_re(out[32 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[32 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[16 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[16 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[48 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[48 * ostride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(out[8 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[8 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[40 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[40 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[24 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[24 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[56 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[56 * ostride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_1_4) - (((FFTW_REAL) FFTW_K382683432) * tim0_1_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_1_4) + (((FFTW_REAL) FFTW_K382683432) * tre0_1_4); - tre1_0_0 = tre0_1_0 + tre2_1_0; - tim1_0_0 = tim0_1_0 + tim2_1_0; - tre1_1_0 = tre0_1_0 - tre2_1_0; - tim1_1_0 = tim0_1_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K995184726) * tre0_1_1) - (((FFTW_REAL) FFTW_K098017140) * tim0_1_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K995184726) * tim0_1_1) + (((FFTW_REAL) FFTW_K098017140) * tre0_1_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K881921264) * tre0_1_5) - (((FFTW_REAL) FFTW_K471396736) * tim0_1_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K881921264) * tim0_1_5) + (((FFTW_REAL) FFTW_K471396736) * tre0_1_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_1_2) - (((FFTW_REAL) FFTW_K195090322) * tim0_1_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_1_2) + (((FFTW_REAL) FFTW_K195090322) * tre0_1_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_1_6) - (((FFTW_REAL) FFTW_K555570233) * tim0_1_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_1_6) + (((FFTW_REAL) FFTW_K555570233) * tre0_1_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tre0_1_3) - (((FFTW_REAL) FFTW_K290284677) * tim0_1_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tim0_1_3) + (((FFTW_REAL) FFTW_K290284677) * tre0_1_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K773010453) * tre0_1_7) - (((FFTW_REAL) FFTW_K634393284) * tim0_1_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K773010453) * tim0_1_7) + (((FFTW_REAL) FFTW_K634393284) * tre0_1_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[33 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[33 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[17 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[17 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[49 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[49 * ostride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(out[9 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[9 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[41 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[41 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[25 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[25 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[57 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[57 * ostride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_4 - tim0_2_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_4 + tre0_2_4); - tre1_0_0 = tre0_2_0 + tre2_1_0; - tim1_0_0 = tim0_2_0 + tim2_1_0; - tre1_1_0 = tre0_2_0 - tre2_1_0; - tim1_1_0 = tim0_2_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_2_1) - (((FFTW_REAL) FFTW_K195090322) * tim0_2_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_2_1) + (((FFTW_REAL) FFTW_K195090322) * tre0_2_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_2_5) - (((FFTW_REAL) FFTW_K831469612) * tim0_2_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_2_5) + (((FFTW_REAL) FFTW_K831469612) * tre0_2_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_2_2) - (((FFTW_REAL) FFTW_K382683432) * tim0_2_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_2_2) + (((FFTW_REAL) FFTW_K382683432) * tre0_2_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_2_6) - (((FFTW_REAL) FFTW_K923879532) * tim0_2_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_2_6) + (((FFTW_REAL) FFTW_K923879532) * tre0_2_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_2_3) - (((FFTW_REAL) FFTW_K555570233) * tim0_2_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_2_3) + (((FFTW_REAL) FFTW_K555570233) * tre0_2_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_2_7) - (((FFTW_REAL) FFTW_K980785280) * tim0_2_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_2_7) + (((FFTW_REAL) FFTW_K980785280) * tre0_2_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[2 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[2 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[34 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[34 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[18 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[18 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[50 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[50 * ostride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(out[10 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[10 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[42 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[42 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[26 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[26 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[58 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[58 * ostride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_4) - (((FFTW_REAL) FFTW_K923879532) * tim0_3_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_4) + (((FFTW_REAL) FFTW_K923879532) * tre0_3_4); - tre1_0_0 = tre0_3_0 + tre2_1_0; - tim1_0_0 = tim0_3_0 + tim2_1_0; - tre1_1_0 = tre0_3_0 - tre2_1_0; - tim1_1_0 = tim0_3_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tre0_3_1) - (((FFTW_REAL) FFTW_K290284677) * tim0_3_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tim0_3_1) + (((FFTW_REAL) FFTW_K290284677) * tre0_3_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tre0_3_5) - (((FFTW_REAL) FFTW_K995184726) * tim0_3_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tim0_3_5) + (((FFTW_REAL) FFTW_K995184726) * tre0_3_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_3_2) - (((FFTW_REAL) FFTW_K555570233) * tim0_3_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_3_2) + (((FFTW_REAL) FFTW_K555570233) * tre0_3_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_3_6) + (((FFTW_REAL) FFTW_K980785280) * tim0_3_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_3_6) - (((FFTW_REAL) FFTW_K195090322) * tim0_3_6); - tre1_0_2 = tre2_0_0 - tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 + tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K634393284) * tre0_3_3) - (((FFTW_REAL) FFTW_K773010453) * tim0_3_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K634393284) * tim0_3_3) + (((FFTW_REAL) FFTW_K773010453) * tre0_3_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K471396736) * tre0_3_7) + (((FFTW_REAL) FFTW_K881921264) * tim0_3_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K881921264) * tre0_3_7) - (((FFTW_REAL) FFTW_K471396736) * tim0_3_7); - tre1_0_3 = tre2_0_0 - tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 + tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[3 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[3 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[35 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[35 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[19 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[19 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[51 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[51 * ostride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(out[11 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[11 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[43 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[43 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[27 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[27 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[59 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[59 * ostride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_4_0 - tim0_4_4; - tim1_0_0 = tim0_4_0 + tre0_4_4; - tre1_1_0 = tre0_4_0 + tim0_4_4; - tim1_1_0 = tim0_4_0 - tre0_4_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_4_1) - (((FFTW_REAL) FFTW_K382683432) * tim0_4_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_4_1) + (((FFTW_REAL) FFTW_K382683432) * tre0_4_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_4_5) + (((FFTW_REAL) FFTW_K923879532) * tim0_4_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_4_5) - (((FFTW_REAL) FFTW_K382683432) * tim0_4_5); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_4_2 - tim0_4_2); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_4_2 + tre0_4_2); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_4_6 + tim0_4_6); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_4_6 - tim0_4_6); - tre1_0_2 = tre2_0_0 - tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 + tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_4_3) - (((FFTW_REAL) FFTW_K923879532) * tim0_4_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_4_3) + (((FFTW_REAL) FFTW_K923879532) * tre0_4_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_4_7) + (((FFTW_REAL) FFTW_K382683432) * tim0_4_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_4_7) - (((FFTW_REAL) FFTW_K923879532) * tim0_4_7); - tre1_0_3 = tre2_0_0 - tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 + tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[4 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[4 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[36 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[36 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[20 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[20 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[52 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[52 * ostride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(out[12 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[12 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[44 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[44 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[28 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[28 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[60 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[60 * ostride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_5_4) + (((FFTW_REAL) FFTW_K923879532) * tim0_5_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_5_4) - (((FFTW_REAL) FFTW_K382683432) * tim0_5_4); - tre1_0_0 = tre0_5_0 - tre2_1_0; - tim1_0_0 = tim0_5_0 + tim2_1_0; - tre1_1_0 = tre0_5_0 + tre2_1_0; - tim1_1_0 = tim0_5_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K881921264) * tre0_5_1) - (((FFTW_REAL) FFTW_K471396736) * tim0_5_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K881921264) * tim0_5_1) + (((FFTW_REAL) FFTW_K471396736) * tre0_5_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K773010453) * tre0_5_5) + (((FFTW_REAL) FFTW_K634393284) * tim0_5_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K634393284) * tre0_5_5) - (((FFTW_REAL) FFTW_K773010453) * tim0_5_5); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_5_2) - (((FFTW_REAL) FFTW_K831469612) * tim0_5_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_5_2) + (((FFTW_REAL) FFTW_K831469612) * tre0_5_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_5_6) + (((FFTW_REAL) FFTW_K195090322) * tim0_5_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_5_6) - (((FFTW_REAL) FFTW_K980785280) * tim0_5_6); - tre1_0_2 = tre2_0_0 - tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 + tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K098017140) * tre0_5_3) - (((FFTW_REAL) FFTW_K995184726) * tim0_5_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K098017140) * tim0_5_3) + (((FFTW_REAL) FFTW_K995184726) * tre0_5_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K290284677) * tim0_5_7) - (((FFTW_REAL) FFTW_K956940335) * tre0_5_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K956940335) * tim0_5_7) + (((FFTW_REAL) FFTW_K290284677) * tre0_5_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 - tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[5 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[5 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[37 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[37 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[21 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[21 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[53 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[53 * ostride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(out[13 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[13 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[45 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[45 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[29 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[29 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[61 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[61 * ostride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_6_4 + tim0_6_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_6_4 - tim0_6_4); - tre1_0_0 = tre0_6_0 - tre2_1_0; - tim1_0_0 = tim0_6_0 + tim2_1_0; - tre1_1_0 = tre0_6_0 + tre2_1_0; - tim1_1_0 = tim0_6_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_6_1) - (((FFTW_REAL) FFTW_K555570233) * tim0_6_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_6_1) + (((FFTW_REAL) FFTW_K555570233) * tre0_6_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_6_5) + (((FFTW_REAL) FFTW_K195090322) * tim0_6_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_6_5) - (((FFTW_REAL) FFTW_K980785280) * tim0_6_5); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_6_2) - (((FFTW_REAL) FFTW_K923879532) * tim0_6_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_6_2) + (((FFTW_REAL) FFTW_K923879532) * tre0_6_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_6_6) - (((FFTW_REAL) FFTW_K923879532) * tre0_6_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_6_6) + (((FFTW_REAL) FFTW_K382683432) * tre0_6_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 - tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_6_3) + (((FFTW_REAL) FFTW_K980785280) * tim0_6_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_6_3) - (((FFTW_REAL) FFTW_K195090322) * tim0_6_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_6_7) - (((FFTW_REAL) FFTW_K555570233) * tre0_6_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_6_7) + (((FFTW_REAL) FFTW_K831469612) * tre0_6_7); - tre1_0_3 = tre2_1_0 - tre2_0_0; - tim1_0_3 = tim2_0_0 - tim2_1_0; - tre1_1_3 = (-(tre2_0_0 + tre2_1_0)); - tim1_1_3 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[6 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[6 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[38 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[38 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[22 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[22 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[54 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[54 * ostride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(out[14 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[14 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[46 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[46 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[30 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[30 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[62 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[62 * ostride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_7_4) + (((FFTW_REAL) FFTW_K382683432) * tim0_7_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_7_4) - (((FFTW_REAL) FFTW_K923879532) * tim0_7_4); - tre1_0_0 = tre0_7_0 - tre2_1_0; - tim1_0_0 = tim0_7_0 + tim2_1_0; - tre1_1_0 = tre0_7_0 + tre2_1_0; - tim1_1_0 = tim0_7_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K773010453) * tre0_7_1) - (((FFTW_REAL) FFTW_K634393284) * tim0_7_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K773010453) * tim0_7_1) + (((FFTW_REAL) FFTW_K634393284) * tre0_7_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K290284677) * tim0_7_5) - (((FFTW_REAL) FFTW_K956940335) * tre0_7_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K956940335) * tim0_7_5) + (((FFTW_REAL) FFTW_K290284677) * tre0_7_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_7_2) - (((FFTW_REAL) FFTW_K980785280) * tim0_7_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_7_2) + (((FFTW_REAL) FFTW_K980785280) * tre0_7_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_7_6) - (((FFTW_REAL) FFTW_K555570233) * tre0_7_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_7_6) + (((FFTW_REAL) FFTW_K831469612) * tre0_7_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 - tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K471396736) * tre0_7_3) + (((FFTW_REAL) FFTW_K881921264) * tim0_7_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K881921264) * tre0_7_3) - (((FFTW_REAL) FFTW_K471396736) * tim0_7_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tre0_7_7) + (((FFTW_REAL) FFTW_K995184726) * tim0_7_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tim0_7_7) - (((FFTW_REAL) FFTW_K995184726) * tre0_7_7); - tre1_0_3 = tre2_1_0 - tre2_0_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = (-(tre2_0_0 + tre2_1_0)); - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(out[7 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[7 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[39 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[39 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[23 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[23 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[55 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[55 * ostride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(out[15 * ostride]) = tre2_0_0 + tre2_0_1; - c_im(out[15 * ostride]) = tim2_0_0 + tim2_0_1; - c_re(out[47 * ostride]) = tre2_0_0 - tre2_0_1; - c_im(out[47 * ostride]) = tim2_0_0 - tim2_0_1; - c_re(out[31 * ostride]) = tre2_1_0 - tim2_1_1; - c_im(out[31 * ostride]) = tim2_1_0 + tre2_1_1; - c_re(out[63 * ostride]) = tre2_1_0 + tim2_1_1; - c_im(out[63 * ostride]) = tim2_1_0 - tre2_1_1; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 90 FP additions and 36 FP multiplications */ - -void fftwi_no_twiddle_7(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - FFTW_REAL tre0_5_0; - FFTW_REAL tim0_5_0; - FFTW_REAL tre0_6_0; - FFTW_REAL tim0_6_0; - tre0_0_0 = c_re(in[0]); - tim0_0_0 = c_im(in[0]); - tre0_1_0 = c_re(in[istride]); - tim0_1_0 = c_im(in[istride]); - tre0_2_0 = c_re(in[2 * istride]); - tim0_2_0 = c_im(in[2 * istride]); - tre0_3_0 = c_re(in[3 * istride]); - tim0_3_0 = c_im(in[3 * istride]); - tre0_4_0 = c_re(in[4 * istride]); - tim0_4_0 = c_im(in[4 * istride]); - tre0_5_0 = c_re(in[5 * istride]); - tim0_5_0 = c_im(in[5 * istride]); - tre0_6_0 = c_re(in[6 * istride]); - tim0_6_0 = c_im(in[6 * istride]); - c_re(out[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0 + tre0_3_0 + tre0_4_0 + tre0_5_0 + tre0_6_0; - c_im(out[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0 + tim0_3_0 + tim0_4_0 + tim0_5_0 + tim0_6_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_1_0 + tre0_6_0)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_3_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_2_0 + tre0_5_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tim0_6_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_5_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_4_0 - tim0_3_0)); - c_re(out[ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[6 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_1_0 + tim0_6_0)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_3_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_2_0 + tim0_5_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tre0_1_0 - tre0_6_0)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_2_0 - tre0_5_0)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_3_0 - tre0_4_0)); - c_im(out[ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[6 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_3_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_2_0 + tre0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_1_0 + tre0_6_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tim0_6_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_2_0 - tim0_5_0)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_3_0 - tim0_4_0)); - c_re(out[2 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[5 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_3_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_2_0 + tim0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_1_0 + tim0_6_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tre0_1_0 - tre0_6_0)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_5_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_4_0 - tre0_3_0)); - c_im(out[2 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[5 * ostride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_2_0 + tre0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_3_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_1_0 + tre0_6_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tim0_6_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_2_0 - tim0_5_0)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_4_0 - tim0_3_0)); - c_re(out[3 * ostride]) = tre1_0_0 + tre1_1_0; - c_re(out[4 * ostride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_2_0 + tim0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_3_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_1_0 + tim0_6_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tre0_1_0 - tre0_6_0)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_5_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_3_0 - tre0_4_0)); - c_im(out[3 * ostride]) = tim1_0_0 + tim1_1_0; - c_im(out[4 * ostride]) = tim1_0_0 - tim1_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 52 FP additions and 4 FP multiplications */ - -void fftwi_no_twiddle_8(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[4 * istride]); - tim1_1_0 = c_im(in[4 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[istride]); - tim1_0_0 = c_im(in[istride]); - tre1_1_0 = c_re(in[5 * istride]); - tim1_1_0 = c_im(in[5 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[2 * istride]); - tim1_0_0 = c_im(in[2 * istride]); - tre1_1_0 = c_re(in[6 * istride]); - tim1_1_0 = c_im(in[6 * istride]); - tre0_0_2 = tre1_0_0 + tre1_1_0; - tim0_0_2 = tim1_0_0 + tim1_1_0; - tre0_1_2 = tre1_0_0 - tre1_1_0; - tim0_1_2 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(in[3 * istride]); - tim1_0_0 = c_im(in[3 * istride]); - tre1_1_0 = c_re(in[7 * istride]); - tim1_1_0 = c_im(in[7 * istride]); - tre0_0_3 = tre1_0_0 + tre1_1_0; - tim0_0_3 = tim1_0_0 + tim1_1_0; - tre0_1_3 = tre1_0_0 - tre1_1_0; - tim0_1_3 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_0_0 + tre0_0_2; - tim1_0_0 = tim0_0_0 + tim0_0_2; - tre1_1_0 = tre0_0_0 - tre0_0_2; - tim1_1_0 = tim0_0_0 - tim0_0_2; - tre1_0_1 = tre0_0_1 + tre0_0_3; - tim1_0_1 = tim0_0_1 + tim0_0_3; - tre1_1_1 = tre0_0_1 - tre0_0_3; - tim1_1_1 = tim0_0_1 - tim0_0_3; - c_re(out[0]) = tre1_0_0 + tre1_0_1; - c_im(out[0]) = tim1_0_0 + tim1_0_1; - c_re(out[4 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[4 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[2 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[2 * ostride]) = tim1_1_0 + tre1_1_1; - c_re(out[6 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[6 * ostride]) = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_1_0 - tim0_1_2; - tim1_0_0 = tim0_1_0 + tre0_1_2; - tre1_1_0 = tre0_1_0 + tim0_1_2; - tim1_1_0 = tim0_1_0 - tre0_1_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_1 - tim0_1_1); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_1 + tre0_1_1); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_3 + tim0_1_3); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_3 - tim0_1_3); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - c_re(out[ostride]) = tre1_0_0 + tre1_0_1; - c_im(out[ostride]) = tim1_0_0 + tim1_0_1; - c_re(out[5 * ostride]) = tre1_0_0 - tre1_0_1; - c_im(out[5 * ostride]) = tim1_0_0 - tim1_0_1; - c_re(out[3 * ostride]) = tre1_1_0 - tim1_1_1; - c_im(out[3 * ostride]) = tim1_1_0 + tre1_1_1; - c_re(out[7 * ostride]) = tre1_1_0 + tim1_1_1; - c_im(out[7 * ostride]) = tim1_1_0 - tre1_1_1; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 92 FP additions and 40 FP multiplications */ - -void fftwi_no_twiddle_9(const FFTW_COMPLEX *in, FFTW_COMPLEX *out, int istride, int ostride) -{ - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[0]); - tim1_0_0 = c_im(in[0]); - tre1_1_0 = c_re(in[3 * istride]); - tim1_1_0 = c_im(in[3 * istride]); - tre1_2_0 = c_re(in[6 * istride]); - tim1_2_0 = c_im(in[6 * istride]); - tre0_0_0 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_0 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - tre0_1_0 = tre2_0_0 + tre2_1_0; - tre0_2_0 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - tim0_1_0 = tim2_0_0 + tim2_1_0; - tim0_2_0 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[istride]); - tim1_0_0 = c_im(in[istride]); - tre1_1_0 = c_re(in[4 * istride]); - tim1_1_0 = c_im(in[4 * istride]); - tre1_2_0 = c_re(in[7 * istride]); - tim1_2_0 = c_im(in[7 * istride]); - tre0_0_1 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_1 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - tre0_1_1 = tre2_0_0 + tre2_1_0; - tre0_2_1 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - tim0_1_1 = tim2_0_0 + tim2_1_0; - tim0_2_1 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(in[2 * istride]); - tim1_0_0 = c_im(in[2 * istride]); - tre1_1_0 = c_re(in[5 * istride]); - tim1_1_0 = c_im(in[5 * istride]); - tre1_2_0 = c_re(in[8 * istride]); - tim1_2_0 = c_im(in[8 * istride]); - tre0_0_2 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_2 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - tre0_1_2 = tre2_0_0 + tre2_1_0; - tre0_2_2 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - tim0_1_2 = tim2_0_0 + tim2_1_0; - tim0_2_2 = tim2_0_0 - tim2_1_0; - } - } - c_re(out[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2; - c_im(out[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_0_1 + tre0_0_2)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_0_2 - tim0_0_1); - c_re(out[3 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[6 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_0_1 + tim0_0_2)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_0_1 - tre0_0_2); - c_im(out[3 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[6 * ostride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_1_0 = (((FFTW_REAL) FFTW_K766044443) * tre0_1_1) - (((FFTW_REAL) FFTW_K642787609) * tim0_1_1); - tim1_1_0 = (((FFTW_REAL) FFTW_K766044443) * tim0_1_1) + (((FFTW_REAL) FFTW_K642787609) * tre0_1_1); - tre1_2_0 = (((FFTW_REAL) FFTW_K173648177) * tre0_1_2) - (((FFTW_REAL) FFTW_K984807753) * tim0_1_2); - tim1_2_0 = (((FFTW_REAL) FFTW_K173648177) * tim0_1_2) + (((FFTW_REAL) FFTW_K984807753) * tre0_1_2); - c_re(out[ostride]) = tre0_1_0 + tre1_1_0 + tre1_2_0; - c_im(out[ostride]) = tim0_1_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - c_re(out[4 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[7 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - c_im(out[4 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[7 * ostride]) = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_1_0 = (((FFTW_REAL) FFTW_K173648177) * tre0_2_1) - (((FFTW_REAL) FFTW_K984807753) * tim0_2_1); - tim1_1_0 = (((FFTW_REAL) FFTW_K173648177) * tim0_2_1) + (((FFTW_REAL) FFTW_K984807753) * tre0_2_1); - tre1_2_0 = (((FFTW_REAL) FFTW_K939692620) * tre0_2_2) + (((FFTW_REAL) FFTW_K342020143) * tim0_2_2); - tim1_2_0 = (((FFTW_REAL) FFTW_K342020143) * tre0_2_2) - (((FFTW_REAL) FFTW_K939692620) * tim0_2_2); - c_re(out[2 * ostride]) = tre0_2_0 + tre1_1_0 - tre1_2_0; - c_im(out[2 * ostride]) = tim0_2_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_2_0 + (((FFTW_REAL) FFTW_K499999999) * (tre1_2_0 - tre1_1_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - c_re(out[5 * ostride]) = tre2_0_0 + tre2_1_0; - c_re(out[8 * ostride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_2_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 + tre1_2_0); - c_im(out[5 * ostride]) = tim2_0_0 + tim2_1_0; - c_im(out[8 * ostride]) = tim2_0_0 - tim2_1_0; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 126 FP additions and 68 FP multiplications */ - -void fftw_twiddle_10(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 9) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(inout[0]); - tim1_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre1_0_0 = (tr * twr) - (ti * twi); - tim1_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[7 * stride]); - ti = c_im(inout[7 * stride]); - twr = c_re(W[6]); - twi = c_im(W[6]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre1_0_0 = (tr * twr) - (ti * twi); - tim1_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[9 * stride]); - ti = c_im(inout[9 * stride]); - twr = c_re(W[8]); - twi = c_im(W[8]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - tre0_0_2 = tre1_0_0 + tre1_1_0; - tim0_0_2 = tim1_0_0 + tim1_1_0; - tre0_1_2 = tre1_0_0 - tre1_1_0; - tim0_1_2 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[6 * stride]); - ti = c_im(inout[6 * stride]); - twr = c_re(W[5]); - twi = c_im(W[5]); - tre1_0_0 = (tr * twr) - (ti * twi); - tim1_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - tre0_0_3 = tre1_0_0 + tre1_1_0; - tim0_0_3 = tim1_0_0 + tim1_1_0; - tre0_1_3 = tre1_0_0 - tre1_1_0; - tim0_1_3 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[8 * stride]); - ti = c_im(inout[8 * stride]); - twr = c_re(W[7]); - twi = c_im(W[7]); - tre1_0_0 = (tr * twr) - (ti * twi); - tim1_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - tre0_0_4 = tre1_0_0 + tre1_1_0; - tim0_0_4 = tim1_0_0 + tim1_1_0; - tre0_1_4 = tre1_0_0 - tre1_1_0; - tim0_1_4 = tim1_0_0 - tim1_1_0; - } - c_re(inout[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2 + tre0_0_3 + tre0_0_4; - c_im(inout[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2 + tim0_0_3 + tim0_0_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_0_1 + tre0_0_4)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_0_2 + tre0_0_3)); - tre2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_0_1 - tim0_0_4)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_0_2 - tim0_0_3)); - c_re(inout[6 * stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[4 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_0_1 + tim0_0_4)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_0_2 + tim0_0_3)); - tim2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_0_4 - tre0_0_1)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_0_3 - tre0_0_2)); - c_im(inout[6 * stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[4 * stride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_0_2 + tre0_0_3)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_0_1 + tre0_0_4)); - tre2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_0_1 - tim0_0_4)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_0_3 - tim0_0_2)); - c_re(inout[2 * stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[8 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_0_2 + tim0_0_3)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_0_1 + tim0_0_4)); - tim2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_0_4 - tre0_0_1)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_0_2 - tre0_0_3)); - c_im(inout[2 * stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[8 * stride]) = tim2_0_0 - tim2_1_0; - } - c_re(inout[5 * stride]) = tre0_1_0 + tre0_1_1 + tre0_1_2 + tre0_1_3 + tre0_1_4; - c_im(inout[5 * stride]) = tim0_1_0 + tim0_1_1 + tim0_1_2 + tim0_1_3 + tim0_1_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_1 + tre0_1_4)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_2 + tre0_1_3)); - tre2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_1_1 - tim0_1_4)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_1_2 - tim0_1_3)); - c_re(inout[stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[9 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_1 + tim0_1_4)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_2 + tim0_1_3)); - tim2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_1_4 - tre0_1_1)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_1_3 - tre0_1_2)); - c_im(inout[stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[9 * stride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_2 + tre0_1_3)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_1 + tre0_1_4)); - tre2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_1_1 - tim0_1_4)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_1_3 - tim0_1_2)); - c_re(inout[7 * stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[3 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_2 + tim0_1_3)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_1 + tim0_1_4)); - tim2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_1_4 - tre0_1_1)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_1_2 - tre0_1_3)); - c_im(inout[7 * stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[3 * stride]) = tim2_0_0 - tim2_1_0; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 174 FP additions and 84 FP multiplications */ - -void fftw_twiddle_16(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 15) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_3_1; - FFTW_REAL tim0_3_1; - FFTW_REAL tre0_3_2; - FFTW_REAL tim0_3_2; - FFTW_REAL tre0_3_3; - FFTW_REAL tim0_3_3; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(inout[0]); - tim2_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[8 * stride]); - ti = c_im(inout[8 * stride]); - twr = c_re(W[7]); - twi = c_im(W[7]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[12 * stride]); - ti = c_im(inout[12 * stride]); - twr = c_re(W[11]); - twi = c_im(W[11]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_0 = tre1_0_0 + tre1_0_1; - tim0_0_0 = tim1_0_0 + tim1_0_1; - tre0_2_0 = tre1_0_0 - tre1_0_1; - tim0_2_0 = tim1_0_0 - tim1_0_1; - tre0_1_0 = tre1_1_0 + tim1_1_1; - tim0_1_0 = tim1_1_0 - tre1_1_1; - tre0_3_0 = tre1_1_0 - tim1_1_1; - tim0_3_0 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[9 * stride]); - ti = c_im(inout[9 * stride]); - twr = c_re(W[8]); - twi = c_im(W[8]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[13 * stride]); - ti = c_im(inout[13 * stride]); - twr = c_re(W[12]); - twi = c_im(W[12]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_1 = tre1_0_0 + tre1_0_1; - tim0_0_1 = tim1_0_0 + tim1_0_1; - tre0_2_1 = tre1_0_0 - tre1_0_1; - tim0_2_1 = tim1_0_0 - tim1_0_1; - tre0_1_1 = tre1_1_0 + tim1_1_1; - tim0_1_1 = tim1_1_0 - tre1_1_1; - tre0_3_1 = tre1_1_0 - tim1_1_1; - tim0_3_1 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[10 * stride]); - ti = c_im(inout[10 * stride]); - twr = c_re(W[9]); - twi = c_im(W[9]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[6 * stride]); - ti = c_im(inout[6 * stride]); - twr = c_re(W[5]); - twi = c_im(W[5]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[14 * stride]); - ti = c_im(inout[14 * stride]); - twr = c_re(W[13]); - twi = c_im(W[13]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_2 = tre1_0_0 + tre1_0_1; - tim0_0_2 = tim1_0_0 + tim1_0_1; - tre0_2_2 = tre1_0_0 - tre1_0_1; - tim0_2_2 = tim1_0_0 - tim1_0_1; - tre0_1_2 = tre1_1_0 + tim1_1_1; - tim0_1_2 = tim1_1_0 - tre1_1_1; - tre0_3_2 = tre1_1_0 - tim1_1_1; - tim0_3_2 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[11 * stride]); - ti = c_im(inout[11 * stride]); - twr = c_re(W[10]); - twi = c_im(W[10]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[7 * stride]); - ti = c_im(inout[7 * stride]); - twr = c_re(W[6]); - twi = c_im(W[6]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[15 * stride]); - ti = c_im(inout[15 * stride]); - twr = c_re(W[14]); - twi = c_im(W[14]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_3 = tre1_0_0 + tre1_0_1; - tim0_0_3 = tim1_0_0 + tim1_0_1; - tre0_2_3 = tre1_0_0 - tre1_0_1; - tim0_2_3 = tim1_0_0 - tim1_0_1; - tre0_1_3 = tre1_1_0 + tim1_1_1; - tim0_1_3 = tim1_1_0 - tre1_1_1; - tre0_3_3 = tre1_1_0 - tim1_1_1; - tim0_3_3 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_0_0 + tre0_0_2; - tim1_0_0 = tim0_0_0 + tim0_0_2; - tre1_1_0 = tre0_0_0 - tre0_0_2; - tim1_1_0 = tim0_0_0 - tim0_0_2; - tre1_0_1 = tre0_0_1 + tre0_0_3; - tim1_0_1 = tim0_0_1 + tim0_0_3; - tre1_1_1 = tre0_0_1 - tre0_0_3; - tim1_1_1 = tim0_0_1 - tim0_0_3; - c_re(inout[0]) = tre1_0_0 + tre1_0_1; - c_im(inout[0]) = tim1_0_0 + tim1_0_1; - c_re(inout[8 * stride]) = tre1_0_0 - tre1_0_1; - c_im(inout[8 * stride]) = tim1_0_0 - tim1_0_1; - c_re(inout[4 * stride]) = tre1_1_0 + tim1_1_1; - c_im(inout[4 * stride]) = tim1_1_0 - tre1_1_1; - c_re(inout[12 * stride]) = tre1_1_0 - tim1_1_1; - c_im(inout[12 * stride]) = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_2 + tim0_1_2); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_2 - tre0_1_2); - tre1_0_0 = tre0_1_0 + tre2_1_0; - tim1_0_0 = tim0_1_0 + tim2_1_0; - tre1_1_0 = tre0_1_0 - tre2_1_0; - tim1_1_0 = tim0_1_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_1_1) + (((FFTW_REAL) FFTW_K382683432) * tim0_1_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_1_1) - (((FFTW_REAL) FFTW_K382683432) * tre0_1_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_1_3) + (((FFTW_REAL) FFTW_K923879532) * tim0_1_3); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_1_3) - (((FFTW_REAL) FFTW_K923879532) * tre0_1_3); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - c_re(inout[stride]) = tre1_0_0 + tre1_0_1; - c_im(inout[stride]) = tim1_0_0 + tim1_0_1; - c_re(inout[9 * stride]) = tre1_0_0 - tre1_0_1; - c_im(inout[9 * stride]) = tim1_0_0 - tim1_0_1; - c_re(inout[5 * stride]) = tre1_1_0 + tim1_1_1; - c_im(inout[5 * stride]) = tim1_1_0 - tre1_1_1; - c_re(inout[13 * stride]) = tre1_1_0 - tim1_1_1; - c_im(inout[13 * stride]) = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_2_0 + tim0_2_2; - tim1_0_0 = tim0_2_0 - tre0_2_2; - tre1_1_0 = tre0_2_0 - tim0_2_2; - tim1_1_0 = tim0_2_0 + tre0_2_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_1 + tim0_2_1); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_1 - tre0_2_1); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_3 - tre0_2_3); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_3 + tre0_2_3); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - c_re(inout[2 * stride]) = tre1_0_0 + tre1_0_1; - c_im(inout[2 * stride]) = tim1_0_0 + tim1_0_1; - c_re(inout[10 * stride]) = tre1_0_0 - tre1_0_1; - c_im(inout[10 * stride]) = tim1_0_0 - tim1_0_1; - c_re(inout[6 * stride]) = tre1_1_0 + tim1_1_1; - c_im(inout[6 * stride]) = tim1_1_0 - tre1_1_1; - c_re(inout[14 * stride]) = tre1_1_0 - tim1_1_1; - c_im(inout[14 * stride]) = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_3_2 - tre0_3_2); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_3_2 + tre0_3_2); - tre1_0_0 = tre0_3_0 + tre2_1_0; - tim1_0_0 = tim0_3_0 - tim2_1_0; - tre1_1_0 = tre0_3_0 - tre2_1_0; - tim1_1_0 = tim0_3_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_1) + (((FFTW_REAL) FFTW_K923879532) * tim0_3_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_1) - (((FFTW_REAL) FFTW_K923879532) * tre0_3_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_3_3) + (((FFTW_REAL) FFTW_K382683432) * tim0_3_3); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_3) - (((FFTW_REAL) FFTW_K923879532) * tim0_3_3); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - c_re(inout[3 * stride]) = tre1_0_0 + tre1_0_1; - c_im(inout[3 * stride]) = tim1_0_0 + tim1_0_1; - c_re(inout[11 * stride]) = tre1_0_0 - tre1_0_1; - c_im(inout[11 * stride]) = tim1_0_0 - tim1_0_1; - c_re(inout[7 * stride]) = tre1_1_0 + tim1_1_1; - c_im(inout[7 * stride]) = tim1_1_0 - tre1_1_1; - c_re(inout[15 * stride]) = tre1_1_0 - tim1_1_1; - c_im(inout[15 * stride]) = tim1_1_0 + tre1_1_1; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 6 FP additions and 4 FP multiplications */ - -void fftw_twiddle_2(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 1) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - tre0_0_0 = c_re(inout[0]); - tim0_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre0_1_0 = (tr * twr) - (ti * twi); - tim0_1_0 = (tr * twi) + (ti * twr); - } - c_re(inout[0]) = tre0_0_0 + tre0_1_0; - c_im(inout[0]) = tim0_0_0 + tim0_1_0; - c_re(inout[stride]) = tre0_0_0 - tre0_1_0; - c_im(inout[stride]) = tim0_0_0 - tim0_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 18 FP additions and 12 FP multiplications */ - -void fftw_twiddle_3(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 2) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - tre0_0_0 = c_re(inout[0]); - tim0_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre0_1_0 = (tr * twr) - (ti * twi); - tim0_1_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre0_2_0 = (tr * twr) - (ti * twi); - tim0_2_0 = (tr * twi) + (ti * twr); - } - c_re(inout[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0; - c_im(inout[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_1_0 + tre0_2_0)); - tre1_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_1_0 - tim0_2_0); - c_re(inout[stride]) = tre1_0_0 + tre1_1_0; - c_re(inout[2 * stride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_1_0 + tim0_2_0)); - tim1_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_2_0 - tre0_1_0); - c_im(inout[stride]) = tim1_0_0 + tim1_1_0; - c_im(inout[2 * stride]) = tim1_0_0 - tim1_1_0; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 438 FP additions and 212 FP multiplications */ - -void fftw_twiddle_32(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 31) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_0_5; - FFTW_REAL tim0_0_5; - FFTW_REAL tre0_0_6; - FFTW_REAL tim0_0_6; - FFTW_REAL tre0_0_7; - FFTW_REAL tim0_0_7; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - FFTW_REAL tre0_1_5; - FFTW_REAL tim0_1_5; - FFTW_REAL tre0_1_6; - FFTW_REAL tim0_1_6; - FFTW_REAL tre0_1_7; - FFTW_REAL tim0_1_7; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - FFTW_REAL tre0_2_4; - FFTW_REAL tim0_2_4; - FFTW_REAL tre0_2_5; - FFTW_REAL tim0_2_5; - FFTW_REAL tre0_2_6; - FFTW_REAL tim0_2_6; - FFTW_REAL tre0_2_7; - FFTW_REAL tim0_2_7; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_3_1; - FFTW_REAL tim0_3_1; - FFTW_REAL tre0_3_2; - FFTW_REAL tim0_3_2; - FFTW_REAL tre0_3_3; - FFTW_REAL tim0_3_3; - FFTW_REAL tre0_3_4; - FFTW_REAL tim0_3_4; - FFTW_REAL tre0_3_5; - FFTW_REAL tim0_3_5; - FFTW_REAL tre0_3_6; - FFTW_REAL tim0_3_6; - FFTW_REAL tre0_3_7; - FFTW_REAL tim0_3_7; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(inout[0]); - tim2_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[16 * stride]); - ti = c_im(inout[16 * stride]); - twr = c_re(W[15]); - twi = c_im(W[15]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[8 * stride]); - ti = c_im(inout[8 * stride]); - twr = c_re(W[7]); - twi = c_im(W[7]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[24 * stride]); - ti = c_im(inout[24 * stride]); - twr = c_re(W[23]); - twi = c_im(W[23]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_0 = tre1_0_0 + tre1_0_1; - tim0_0_0 = tim1_0_0 + tim1_0_1; - tre0_2_0 = tre1_0_0 - tre1_0_1; - tim0_2_0 = tim1_0_0 - tim1_0_1; - tre0_1_0 = tre1_1_0 + tim1_1_1; - tim0_1_0 = tim1_1_0 - tre1_1_1; - tre0_3_0 = tre1_1_0 - tim1_1_1; - tim0_3_0 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[17 * stride]); - ti = c_im(inout[17 * stride]); - twr = c_re(W[16]); - twi = c_im(W[16]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[9 * stride]); - ti = c_im(inout[9 * stride]); - twr = c_re(W[8]); - twi = c_im(W[8]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[25 * stride]); - ti = c_im(inout[25 * stride]); - twr = c_re(W[24]); - twi = c_im(W[24]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_1 = tre1_0_0 + tre1_0_1; - tim0_0_1 = tim1_0_0 + tim1_0_1; - tre0_2_1 = tre1_0_0 - tre1_0_1; - tim0_2_1 = tim1_0_0 - tim1_0_1; - tre0_1_1 = tre1_1_0 + tim1_1_1; - tim0_1_1 = tim1_1_0 - tre1_1_1; - tre0_3_1 = tre1_1_0 - tim1_1_1; - tim0_3_1 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[18 * stride]); - ti = c_im(inout[18 * stride]); - twr = c_re(W[17]); - twi = c_im(W[17]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[10 * stride]); - ti = c_im(inout[10 * stride]); - twr = c_re(W[9]); - twi = c_im(W[9]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[26 * stride]); - ti = c_im(inout[26 * stride]); - twr = c_re(W[25]); - twi = c_im(W[25]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_2 = tre1_0_0 + tre1_0_1; - tim0_0_2 = tim1_0_0 + tim1_0_1; - tre0_2_2 = tre1_0_0 - tre1_0_1; - tim0_2_2 = tim1_0_0 - tim1_0_1; - tre0_1_2 = tre1_1_0 + tim1_1_1; - tim0_1_2 = tim1_1_0 - tre1_1_1; - tre0_3_2 = tre1_1_0 - tim1_1_1; - tim0_3_2 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[19 * stride]); - ti = c_im(inout[19 * stride]); - twr = c_re(W[18]); - twi = c_im(W[18]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[11 * stride]); - ti = c_im(inout[11 * stride]); - twr = c_re(W[10]); - twi = c_im(W[10]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[27 * stride]); - ti = c_im(inout[27 * stride]); - twr = c_re(W[26]); - twi = c_im(W[26]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_3 = tre1_0_0 + tre1_0_1; - tim0_0_3 = tim1_0_0 + tim1_0_1; - tre0_2_3 = tre1_0_0 - tre1_0_1; - tim0_2_3 = tim1_0_0 - tim1_0_1; - tre0_1_3 = tre1_1_0 + tim1_1_1; - tim0_1_3 = tim1_1_0 - tre1_1_1; - tre0_3_3 = tre1_1_0 - tim1_1_1; - tim0_3_3 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[20 * stride]); - ti = c_im(inout[20 * stride]); - twr = c_re(W[19]); - twi = c_im(W[19]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[12 * stride]); - ti = c_im(inout[12 * stride]); - twr = c_re(W[11]); - twi = c_im(W[11]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[28 * stride]); - ti = c_im(inout[28 * stride]); - twr = c_re(W[27]); - twi = c_im(W[27]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_4 = tre1_0_0 + tre1_0_1; - tim0_0_4 = tim1_0_0 + tim1_0_1; - tre0_2_4 = tre1_0_0 - tre1_0_1; - tim0_2_4 = tim1_0_0 - tim1_0_1; - tre0_1_4 = tre1_1_0 + tim1_1_1; - tim0_1_4 = tim1_1_0 - tre1_1_1; - tre0_3_4 = tre1_1_0 - tim1_1_1; - tim0_3_4 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[21 * stride]); - ti = c_im(inout[21 * stride]); - twr = c_re(W[20]); - twi = c_im(W[20]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[13 * stride]); - ti = c_im(inout[13 * stride]); - twr = c_re(W[12]); - twi = c_im(W[12]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[29 * stride]); - ti = c_im(inout[29 * stride]); - twr = c_re(W[28]); - twi = c_im(W[28]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_5 = tre1_0_0 + tre1_0_1; - tim0_0_5 = tim1_0_0 + tim1_0_1; - tre0_2_5 = tre1_0_0 - tre1_0_1; - tim0_2_5 = tim1_0_0 - tim1_0_1; - tre0_1_5 = tre1_1_0 + tim1_1_1; - tim0_1_5 = tim1_1_0 - tre1_1_1; - tre0_3_5 = tre1_1_0 - tim1_1_1; - tim0_3_5 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[6 * stride]); - ti = c_im(inout[6 * stride]); - twr = c_re(W[5]); - twi = c_im(W[5]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[22 * stride]); - ti = c_im(inout[22 * stride]); - twr = c_re(W[21]); - twi = c_im(W[21]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[14 * stride]); - ti = c_im(inout[14 * stride]); - twr = c_re(W[13]); - twi = c_im(W[13]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[30 * stride]); - ti = c_im(inout[30 * stride]); - twr = c_re(W[29]); - twi = c_im(W[29]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_6 = tre1_0_0 + tre1_0_1; - tim0_0_6 = tim1_0_0 + tim1_0_1; - tre0_2_6 = tre1_0_0 - tre1_0_1; - tim0_2_6 = tim1_0_0 - tim1_0_1; - tre0_1_6 = tre1_1_0 + tim1_1_1; - tim0_1_6 = tim1_1_0 - tre1_1_1; - tre0_3_6 = tre1_1_0 - tim1_1_1; - tim0_3_6 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[7 * stride]); - ti = c_im(inout[7 * stride]); - twr = c_re(W[6]); - twi = c_im(W[6]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[23 * stride]); - ti = c_im(inout[23 * stride]); - twr = c_re(W[22]); - twi = c_im(W[22]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[15 * stride]); - ti = c_im(inout[15 * stride]); - twr = c_re(W[14]); - twi = c_im(W[14]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[31 * stride]); - ti = c_im(inout[31 * stride]); - twr = c_re(W[30]); - twi = c_im(W[30]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_7 = tre1_0_0 + tre1_0_1; - tim0_0_7 = tim1_0_0 + tim1_0_1; - tre0_2_7 = tre1_0_0 - tre1_0_1; - tim0_2_7 = tim1_0_0 - tim1_0_1; - tre0_1_7 = tre1_1_0 + tim1_1_1; - tim0_1_7 = tim1_1_0 - tre1_1_1; - tre0_3_7 = tre1_1_0 - tim1_1_1; - tim0_3_7 = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_0_0 + tre0_0_4; - tim1_0_0 = tim0_0_0 + tim0_0_4; - tre1_1_0 = tre0_0_0 - tre0_0_4; - tim1_1_0 = tim0_0_0 - tim0_0_4; - tre1_0_1 = tre0_0_1 + tre0_0_5; - tim1_0_1 = tim0_0_1 + tim0_0_5; - tre1_1_1 = tre0_0_1 - tre0_0_5; - tim1_1_1 = tim0_0_1 - tim0_0_5; - tre1_0_2 = tre0_0_2 + tre0_0_6; - tim1_0_2 = tim0_0_2 + tim0_0_6; - tre1_1_2 = tre0_0_2 - tre0_0_6; - tim1_1_2 = tim0_0_2 - tim0_0_6; - tre1_0_3 = tre0_0_3 + tre0_0_7; - tim1_0_3 = tim0_0_3 + tim0_0_7; - tre1_1_3 = tre0_0_3 - tre0_0_7; - tim1_1_3 = tim0_0_3 - tim0_0_7; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[0]) = tre2_0_0 + tre2_0_1; - c_im(inout[0]) = tim2_0_0 + tim2_0_1; - c_re(inout[16 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[16 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[8 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[8 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[24 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[24 * stride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(inout[4 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[4 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[20 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[20 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[12 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[12 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[28 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[28 * stride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_4 + tim0_1_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_4 - tre0_1_4); - tre1_0_0 = tre0_1_0 + tre2_1_0; - tim1_0_0 = tim0_1_0 + tim2_1_0; - tre1_1_0 = tre0_1_0 - tre2_1_0; - tim1_1_0 = tim0_1_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_1_1) + (((FFTW_REAL) FFTW_K195090322) * tim0_1_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_1_1) - (((FFTW_REAL) FFTW_K195090322) * tre0_1_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_1_5) + (((FFTW_REAL) FFTW_K831469612) * tim0_1_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_1_5) - (((FFTW_REAL) FFTW_K831469612) * tre0_1_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_1_2) + (((FFTW_REAL) FFTW_K382683432) * tim0_1_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_1_2) - (((FFTW_REAL) FFTW_K382683432) * tre0_1_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_1_6) + (((FFTW_REAL) FFTW_K923879532) * tim0_1_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_1_6) - (((FFTW_REAL) FFTW_K923879532) * tre0_1_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_1_3) + (((FFTW_REAL) FFTW_K555570233) * tim0_1_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_1_3) - (((FFTW_REAL) FFTW_K555570233) * tre0_1_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_1_7) + (((FFTW_REAL) FFTW_K980785280) * tim0_1_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_1_7) - (((FFTW_REAL) FFTW_K980785280) * tre0_1_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[17 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[17 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[9 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[9 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[25 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[25 * stride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(inout[5 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[5 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[21 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[21 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[13 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[13 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[29 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[29 * stride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_2_0 + tim0_2_4; - tim1_0_0 = tim0_2_0 - tre0_2_4; - tre1_1_0 = tre0_2_0 - tim0_2_4; - tim1_1_0 = tim0_2_0 + tre0_2_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_2_1) + (((FFTW_REAL) FFTW_K382683432) * tim0_2_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_2_1) - (((FFTW_REAL) FFTW_K382683432) * tre0_2_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_2_5) - (((FFTW_REAL) FFTW_K382683432) * tre0_2_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_2_5) + (((FFTW_REAL) FFTW_K923879532) * tre0_2_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_2 + tim0_2_2); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_2 - tre0_2_2); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_6 - tre0_2_6); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_6 + tre0_2_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 - tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_2_3) + (((FFTW_REAL) FFTW_K923879532) * tim0_2_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_2_3) - (((FFTW_REAL) FFTW_K923879532) * tre0_2_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_2_7) - (((FFTW_REAL) FFTW_K923879532) * tre0_2_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_2_7) + (((FFTW_REAL) FFTW_K382683432) * tre0_2_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 - tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[2 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[2 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[18 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[18 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[10 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[10 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[26 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[26 * stride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(inout[6 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[6 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[22 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[22 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[14 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[14 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[30 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[30 * stride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_3_4 - tre0_3_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_3_4 + tre0_3_4); - tre1_0_0 = tre0_3_0 + tre2_1_0; - tim1_0_0 = tim0_3_0 - tim2_1_0; - tre1_1_0 = tre0_3_0 - tre2_1_0; - tim1_1_0 = tim0_3_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_3_1) + (((FFTW_REAL) FFTW_K555570233) * tim0_3_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_3_1) - (((FFTW_REAL) FFTW_K555570233) * tre0_3_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_3_5) - (((FFTW_REAL) FFTW_K980785280) * tre0_3_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_3_5) + (((FFTW_REAL) FFTW_K195090322) * tre0_3_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_2) + (((FFTW_REAL) FFTW_K923879532) * tim0_3_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_2) - (((FFTW_REAL) FFTW_K923879532) * tre0_3_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_3_6) + (((FFTW_REAL) FFTW_K382683432) * tim0_3_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_6) - (((FFTW_REAL) FFTW_K923879532) * tim0_3_6); - tre1_0_2 = tre2_0_0 - tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 + tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_3_3) - (((FFTW_REAL) FFTW_K195090322) * tre0_3_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_3_3) + (((FFTW_REAL) FFTW_K980785280) * tre0_3_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_3_7) + (((FFTW_REAL) FFTW_K831469612) * tim0_3_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_3_7) - (((FFTW_REAL) FFTW_K555570233) * tim0_3_7); - tre1_0_3 = tre2_0_0 - tre2_1_0; - tim1_0_3 = tim2_1_0 - tim2_0_0; - tre1_1_3 = tre2_0_0 + tre2_1_0; - tim1_1_3 = (-(tim2_0_0 + tim2_1_0)); - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[3 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[3 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[19 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[19 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[11 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[11 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[27 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[27 * stride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(inout[7 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[7 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[23 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[23 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[15 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[15 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[31 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[31 * stride]) = tim2_1_0 + tre2_1_1; - } - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 22 FP additions and 12 FP multiplications */ - -void fftw_twiddle_4(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 3) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(inout[0]); - tim1_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre1_0_0 = (tr * twr) - (ti * twi); - tim1_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - c_re(inout[0]) = tre0_0_0 + tre0_0_1; - c_im(inout[0]) = tim0_0_0 + tim0_0_1; - c_re(inout[2 * stride]) = tre0_0_0 - tre0_0_1; - c_im(inout[2 * stride]) = tim0_0_0 - tim0_0_1; - c_re(inout[stride]) = tre0_1_0 + tim0_1_1; - c_im(inout[stride]) = tim0_1_0 - tre0_1_1; - c_re(inout[3 * stride]) = tre0_1_0 - tim0_1_1; - c_im(inout[3 * stride]) = tim0_1_0 + tre0_1_1; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 52 FP additions and 32 FP multiplications */ - -void fftw_twiddle_5(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 4) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - tre0_0_0 = c_re(inout[0]); - tim0_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre0_1_0 = (tr * twr) - (ti * twi); - tim0_1_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre0_2_0 = (tr * twr) - (ti * twi); - tim0_2_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre0_3_0 = (tr * twr) - (ti * twi); - tim0_3_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre0_4_0 = (tr * twr) - (ti * twi); - tim0_4_0 = (tr * twi) + (ti * twr); - } - c_re(inout[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0 + tre0_3_0 + tre0_4_0; - c_im(inout[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0 + tim0_3_0 + tim0_4_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_2_0 + tre0_3_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_1_0 - tim0_4_0)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_2_0 - tim0_3_0)); - c_re(inout[stride]) = tre1_0_0 + tre1_1_0; - c_re(inout[4 * stride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_2_0 + tim0_3_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_4_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_3_0 - tre0_2_0)); - c_im(inout[stride]) = tim1_0_0 + tim1_1_0; - c_im(inout[4 * stride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_2_0 + tre0_3_0)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_0 + tre0_4_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_1_0 - tim0_4_0)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_3_0 - tim0_2_0)); - c_re(inout[2 * stride]) = tre1_0_0 + tre1_1_0; - c_re(inout[3 * stride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_2_0 + tim0_3_0)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_0 + tim0_4_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_4_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_2_0 - tre0_3_0)); - c_im(inout[2 * stride]) = tim1_0_0 + tim1_1_0; - c_im(inout[3 * stride]) = tim1_0_0 - tim1_1_0; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 50 FP additions and 28 FP multiplications */ - -void fftw_twiddle_6(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 5) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(inout[0]); - tim1_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre1_0_0 = (tr * twr) - (ti * twi); - tim1_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre1_0_0 = (tr * twr) - (ti * twi); - tim1_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - tre0_0_2 = tre1_0_0 + tre1_1_0; - tim0_0_2 = tim1_0_0 + tim1_1_0; - tre0_1_2 = tre1_0_0 - tre1_1_0; - tim0_1_2 = tim1_0_0 - tim1_1_0; - } - c_re(inout[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2; - c_im(inout[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_0_1 + tre0_0_2)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_0_1 - tim0_0_2); - c_re(inout[4 * stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[2 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_0_1 + tim0_0_2)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_0_2 - tre0_0_1); - c_im(inout[4 * stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[2 * stride]) = tim2_0_0 - tim2_1_0; - } - c_re(inout[3 * stride]) = tre0_1_0 + tre0_1_1 + tre0_1_2; - c_im(inout[3 * stride]) = tim0_1_0 + tim0_1_1 + tim0_1_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_1_1 + tre0_1_2)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_1_1 - tim0_1_2); - c_re(inout[stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[5 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_1_1 + tim0_1_2)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_1_2 - tre0_1_1); - c_im(inout[stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[5 * stride]) = tim2_0_0 - tim2_1_0; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 1054 FP additions and 500 FP multiplications */ - -void fftw_twiddle_64(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 63) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_0_5; - FFTW_REAL tim0_0_5; - FFTW_REAL tre0_0_6; - FFTW_REAL tim0_0_6; - FFTW_REAL tre0_0_7; - FFTW_REAL tim0_0_7; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - FFTW_REAL tre0_1_5; - FFTW_REAL tim0_1_5; - FFTW_REAL tre0_1_6; - FFTW_REAL tim0_1_6; - FFTW_REAL tre0_1_7; - FFTW_REAL tim0_1_7; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - FFTW_REAL tre0_2_4; - FFTW_REAL tim0_2_4; - FFTW_REAL tre0_2_5; - FFTW_REAL tim0_2_5; - FFTW_REAL tre0_2_6; - FFTW_REAL tim0_2_6; - FFTW_REAL tre0_2_7; - FFTW_REAL tim0_2_7; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_3_1; - FFTW_REAL tim0_3_1; - FFTW_REAL tre0_3_2; - FFTW_REAL tim0_3_2; - FFTW_REAL tre0_3_3; - FFTW_REAL tim0_3_3; - FFTW_REAL tre0_3_4; - FFTW_REAL tim0_3_4; - FFTW_REAL tre0_3_5; - FFTW_REAL tim0_3_5; - FFTW_REAL tre0_3_6; - FFTW_REAL tim0_3_6; - FFTW_REAL tre0_3_7; - FFTW_REAL tim0_3_7; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - FFTW_REAL tre0_4_1; - FFTW_REAL tim0_4_1; - FFTW_REAL tre0_4_2; - FFTW_REAL tim0_4_2; - FFTW_REAL tre0_4_3; - FFTW_REAL tim0_4_3; - FFTW_REAL tre0_4_4; - FFTW_REAL tim0_4_4; - FFTW_REAL tre0_4_5; - FFTW_REAL tim0_4_5; - FFTW_REAL tre0_4_6; - FFTW_REAL tim0_4_6; - FFTW_REAL tre0_4_7; - FFTW_REAL tim0_4_7; - FFTW_REAL tre0_5_0; - FFTW_REAL tim0_5_0; - FFTW_REAL tre0_5_1; - FFTW_REAL tim0_5_1; - FFTW_REAL tre0_5_2; - FFTW_REAL tim0_5_2; - FFTW_REAL tre0_5_3; - FFTW_REAL tim0_5_3; - FFTW_REAL tre0_5_4; - FFTW_REAL tim0_5_4; - FFTW_REAL tre0_5_5; - FFTW_REAL tim0_5_5; - FFTW_REAL tre0_5_6; - FFTW_REAL tim0_5_6; - FFTW_REAL tre0_5_7; - FFTW_REAL tim0_5_7; - FFTW_REAL tre0_6_0; - FFTW_REAL tim0_6_0; - FFTW_REAL tre0_6_1; - FFTW_REAL tim0_6_1; - FFTW_REAL tre0_6_2; - FFTW_REAL tim0_6_2; - FFTW_REAL tre0_6_3; - FFTW_REAL tim0_6_3; - FFTW_REAL tre0_6_4; - FFTW_REAL tim0_6_4; - FFTW_REAL tre0_6_5; - FFTW_REAL tim0_6_5; - FFTW_REAL tre0_6_6; - FFTW_REAL tim0_6_6; - FFTW_REAL tre0_6_7; - FFTW_REAL tim0_6_7; - FFTW_REAL tre0_7_0; - FFTW_REAL tim0_7_0; - FFTW_REAL tre0_7_1; - FFTW_REAL tim0_7_1; - FFTW_REAL tre0_7_2; - FFTW_REAL tim0_7_2; - FFTW_REAL tre0_7_3; - FFTW_REAL tim0_7_3; - FFTW_REAL tre0_7_4; - FFTW_REAL tim0_7_4; - FFTW_REAL tre0_7_5; - FFTW_REAL tim0_7_5; - FFTW_REAL tre0_7_6; - FFTW_REAL tim0_7_6; - FFTW_REAL tre0_7_7; - FFTW_REAL tim0_7_7; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(inout[0]); - tim2_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[32 * stride]); - ti = c_im(inout[32 * stride]); - twr = c_re(W[31]); - twi = c_im(W[31]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[8 * stride]); - ti = c_im(inout[8 * stride]); - twr = c_re(W[7]); - twi = c_im(W[7]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[40 * stride]); - ti = c_im(inout[40 * stride]); - twr = c_re(W[39]); - twi = c_im(W[39]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[16 * stride]); - ti = c_im(inout[16 * stride]); - twr = c_re(W[15]); - twi = c_im(W[15]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[48 * stride]); - ti = c_im(inout[48 * stride]); - twr = c_re(W[47]); - twi = c_im(W[47]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[24 * stride]); - ti = c_im(inout[24 * stride]); - twr = c_re(W[23]); - twi = c_im(W[23]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[56 * stride]); - ti = c_im(inout[56 * stride]); - twr = c_re(W[55]); - twi = c_im(W[55]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_0 = tre2_0_0 + tre2_0_1; - tim0_0_0 = tim2_0_0 + tim2_0_1; - tre0_4_0 = tre2_0_0 - tre2_0_1; - tim0_4_0 = tim2_0_0 - tim2_0_1; - tre0_2_0 = tre2_1_0 + tim2_1_1; - tim0_2_0 = tim2_1_0 - tre2_1_1; - tre0_6_0 = tre2_1_0 - tim2_1_1; - tim0_6_0 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_0 = tre2_0_0 + tre2_0_1; - tim0_1_0 = tim2_0_0 + tim2_0_1; - tre0_5_0 = tre2_0_0 - tre2_0_1; - tim0_5_0 = tim2_0_0 - tim2_0_1; - tre0_3_0 = tre2_1_0 + tim2_1_1; - tim0_3_0 = tim2_1_0 - tre2_1_1; - tre0_7_0 = tre2_1_0 - tim2_1_1; - tim0_7_0 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[33 * stride]); - ti = c_im(inout[33 * stride]); - twr = c_re(W[32]); - twi = c_im(W[32]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[9 * stride]); - ti = c_im(inout[9 * stride]); - twr = c_re(W[8]); - twi = c_im(W[8]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[41 * stride]); - ti = c_im(inout[41 * stride]); - twr = c_re(W[40]); - twi = c_im(W[40]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[17 * stride]); - ti = c_im(inout[17 * stride]); - twr = c_re(W[16]); - twi = c_im(W[16]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[49 * stride]); - ti = c_im(inout[49 * stride]); - twr = c_re(W[48]); - twi = c_im(W[48]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[25 * stride]); - ti = c_im(inout[25 * stride]); - twr = c_re(W[24]); - twi = c_im(W[24]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[57 * stride]); - ti = c_im(inout[57 * stride]); - twr = c_re(W[56]); - twi = c_im(W[56]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_1 = tre2_0_0 + tre2_0_1; - tim0_0_1 = tim2_0_0 + tim2_0_1; - tre0_4_1 = tre2_0_0 - tre2_0_1; - tim0_4_1 = tim2_0_0 - tim2_0_1; - tre0_2_1 = tre2_1_0 + tim2_1_1; - tim0_2_1 = tim2_1_0 - tre2_1_1; - tre0_6_1 = tre2_1_0 - tim2_1_1; - tim0_6_1 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_1 = tre2_0_0 + tre2_0_1; - tim0_1_1 = tim2_0_0 + tim2_0_1; - tre0_5_1 = tre2_0_0 - tre2_0_1; - tim0_5_1 = tim2_0_0 - tim2_0_1; - tre0_3_1 = tre2_1_0 + tim2_1_1; - tim0_3_1 = tim2_1_0 - tre2_1_1; - tre0_7_1 = tre2_1_0 - tim2_1_1; - tim0_7_1 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[34 * stride]); - ti = c_im(inout[34 * stride]); - twr = c_re(W[33]); - twi = c_im(W[33]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[10 * stride]); - ti = c_im(inout[10 * stride]); - twr = c_re(W[9]); - twi = c_im(W[9]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[42 * stride]); - ti = c_im(inout[42 * stride]); - twr = c_re(W[41]); - twi = c_im(W[41]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[18 * stride]); - ti = c_im(inout[18 * stride]); - twr = c_re(W[17]); - twi = c_im(W[17]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[50 * stride]); - ti = c_im(inout[50 * stride]); - twr = c_re(W[49]); - twi = c_im(W[49]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[26 * stride]); - ti = c_im(inout[26 * stride]); - twr = c_re(W[25]); - twi = c_im(W[25]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[58 * stride]); - ti = c_im(inout[58 * stride]); - twr = c_re(W[57]); - twi = c_im(W[57]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_2 = tre2_0_0 + tre2_0_1; - tim0_0_2 = tim2_0_0 + tim2_0_1; - tre0_4_2 = tre2_0_0 - tre2_0_1; - tim0_4_2 = tim2_0_0 - tim2_0_1; - tre0_2_2 = tre2_1_0 + tim2_1_1; - tim0_2_2 = tim2_1_0 - tre2_1_1; - tre0_6_2 = tre2_1_0 - tim2_1_1; - tim0_6_2 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_2 = tre2_0_0 + tre2_0_1; - tim0_1_2 = tim2_0_0 + tim2_0_1; - tre0_5_2 = tre2_0_0 - tre2_0_1; - tim0_5_2 = tim2_0_0 - tim2_0_1; - tre0_3_2 = tre2_1_0 + tim2_1_1; - tim0_3_2 = tim2_1_0 - tre2_1_1; - tre0_7_2 = tre2_1_0 - tim2_1_1; - tim0_7_2 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[35 * stride]); - ti = c_im(inout[35 * stride]); - twr = c_re(W[34]); - twi = c_im(W[34]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[11 * stride]); - ti = c_im(inout[11 * stride]); - twr = c_re(W[10]); - twi = c_im(W[10]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[43 * stride]); - ti = c_im(inout[43 * stride]); - twr = c_re(W[42]); - twi = c_im(W[42]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[19 * stride]); - ti = c_im(inout[19 * stride]); - twr = c_re(W[18]); - twi = c_im(W[18]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[51 * stride]); - ti = c_im(inout[51 * stride]); - twr = c_re(W[50]); - twi = c_im(W[50]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[27 * stride]); - ti = c_im(inout[27 * stride]); - twr = c_re(W[26]); - twi = c_im(W[26]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[59 * stride]); - ti = c_im(inout[59 * stride]); - twr = c_re(W[58]); - twi = c_im(W[58]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_3 = tre2_0_0 + tre2_0_1; - tim0_0_3 = tim2_0_0 + tim2_0_1; - tre0_4_3 = tre2_0_0 - tre2_0_1; - tim0_4_3 = tim2_0_0 - tim2_0_1; - tre0_2_3 = tre2_1_0 + tim2_1_1; - tim0_2_3 = tim2_1_0 - tre2_1_1; - tre0_6_3 = tre2_1_0 - tim2_1_1; - tim0_6_3 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_3 = tre2_0_0 + tre2_0_1; - tim0_1_3 = tim2_0_0 + tim2_0_1; - tre0_5_3 = tre2_0_0 - tre2_0_1; - tim0_5_3 = tim2_0_0 - tim2_0_1; - tre0_3_3 = tre2_1_0 + tim2_1_1; - tim0_3_3 = tim2_1_0 - tre2_1_1; - tre0_7_3 = tre2_1_0 - tim2_1_1; - tim0_7_3 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[36 * stride]); - ti = c_im(inout[36 * stride]); - twr = c_re(W[35]); - twi = c_im(W[35]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[12 * stride]); - ti = c_im(inout[12 * stride]); - twr = c_re(W[11]); - twi = c_im(W[11]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[44 * stride]); - ti = c_im(inout[44 * stride]); - twr = c_re(W[43]); - twi = c_im(W[43]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[20 * stride]); - ti = c_im(inout[20 * stride]); - twr = c_re(W[19]); - twi = c_im(W[19]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[52 * stride]); - ti = c_im(inout[52 * stride]); - twr = c_re(W[51]); - twi = c_im(W[51]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[28 * stride]); - ti = c_im(inout[28 * stride]); - twr = c_re(W[27]); - twi = c_im(W[27]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[60 * stride]); - ti = c_im(inout[60 * stride]); - twr = c_re(W[59]); - twi = c_im(W[59]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_4 = tre2_0_0 + tre2_0_1; - tim0_0_4 = tim2_0_0 + tim2_0_1; - tre0_4_4 = tre2_0_0 - tre2_0_1; - tim0_4_4 = tim2_0_0 - tim2_0_1; - tre0_2_4 = tre2_1_0 + tim2_1_1; - tim0_2_4 = tim2_1_0 - tre2_1_1; - tre0_6_4 = tre2_1_0 - tim2_1_1; - tim0_6_4 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_4 = tre2_0_0 + tre2_0_1; - tim0_1_4 = tim2_0_0 + tim2_0_1; - tre0_5_4 = tre2_0_0 - tre2_0_1; - tim0_5_4 = tim2_0_0 - tim2_0_1; - tre0_3_4 = tre2_1_0 + tim2_1_1; - tim0_3_4 = tim2_1_0 - tre2_1_1; - tre0_7_4 = tre2_1_0 - tim2_1_1; - tim0_7_4 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[37 * stride]); - ti = c_im(inout[37 * stride]); - twr = c_re(W[36]); - twi = c_im(W[36]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[13 * stride]); - ti = c_im(inout[13 * stride]); - twr = c_re(W[12]); - twi = c_im(W[12]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[45 * stride]); - ti = c_im(inout[45 * stride]); - twr = c_re(W[44]); - twi = c_im(W[44]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[21 * stride]); - ti = c_im(inout[21 * stride]); - twr = c_re(W[20]); - twi = c_im(W[20]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[53 * stride]); - ti = c_im(inout[53 * stride]); - twr = c_re(W[52]); - twi = c_im(W[52]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[29 * stride]); - ti = c_im(inout[29 * stride]); - twr = c_re(W[28]); - twi = c_im(W[28]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[61 * stride]); - ti = c_im(inout[61 * stride]); - twr = c_re(W[60]); - twi = c_im(W[60]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_5 = tre2_0_0 + tre2_0_1; - tim0_0_5 = tim2_0_0 + tim2_0_1; - tre0_4_5 = tre2_0_0 - tre2_0_1; - tim0_4_5 = tim2_0_0 - tim2_0_1; - tre0_2_5 = tre2_1_0 + tim2_1_1; - tim0_2_5 = tim2_1_0 - tre2_1_1; - tre0_6_5 = tre2_1_0 - tim2_1_1; - tim0_6_5 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_5 = tre2_0_0 + tre2_0_1; - tim0_1_5 = tim2_0_0 + tim2_0_1; - tre0_5_5 = tre2_0_0 - tre2_0_1; - tim0_5_5 = tim2_0_0 - tim2_0_1; - tre0_3_5 = tre2_1_0 + tim2_1_1; - tim0_3_5 = tim2_1_0 - tre2_1_1; - tre0_7_5 = tre2_1_0 - tim2_1_1; - tim0_7_5 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[6 * stride]); - ti = c_im(inout[6 * stride]); - twr = c_re(W[5]); - twi = c_im(W[5]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[38 * stride]); - ti = c_im(inout[38 * stride]); - twr = c_re(W[37]); - twi = c_im(W[37]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[14 * stride]); - ti = c_im(inout[14 * stride]); - twr = c_re(W[13]); - twi = c_im(W[13]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[46 * stride]); - ti = c_im(inout[46 * stride]); - twr = c_re(W[45]); - twi = c_im(W[45]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[22 * stride]); - ti = c_im(inout[22 * stride]); - twr = c_re(W[21]); - twi = c_im(W[21]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[54 * stride]); - ti = c_im(inout[54 * stride]); - twr = c_re(W[53]); - twi = c_im(W[53]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[30 * stride]); - ti = c_im(inout[30 * stride]); - twr = c_re(W[29]); - twi = c_im(W[29]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[62 * stride]); - ti = c_im(inout[62 * stride]); - twr = c_re(W[61]); - twi = c_im(W[61]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_6 = tre2_0_0 + tre2_0_1; - tim0_0_6 = tim2_0_0 + tim2_0_1; - tre0_4_6 = tre2_0_0 - tre2_0_1; - tim0_4_6 = tim2_0_0 - tim2_0_1; - tre0_2_6 = tre2_1_0 + tim2_1_1; - tim0_2_6 = tim2_1_0 - tre2_1_1; - tre0_6_6 = tre2_1_0 - tim2_1_1; - tim0_6_6 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_6 = tre2_0_0 + tre2_0_1; - tim0_1_6 = tim2_0_0 + tim2_0_1; - tre0_5_6 = tre2_0_0 - tre2_0_1; - tim0_5_6 = tim2_0_0 - tim2_0_1; - tre0_3_6 = tre2_1_0 + tim2_1_1; - tim0_3_6 = tim2_1_0 - tre2_1_1; - tre0_7_6 = tre2_1_0 - tim2_1_1; - tim0_7_6 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[7 * stride]); - ti = c_im(inout[7 * stride]); - twr = c_re(W[6]); - twi = c_im(W[6]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[39 * stride]); - ti = c_im(inout[39 * stride]); - twr = c_re(W[38]); - twi = c_im(W[38]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[15 * stride]); - ti = c_im(inout[15 * stride]); - twr = c_re(W[14]); - twi = c_im(W[14]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[47 * stride]); - ti = c_im(inout[47 * stride]); - twr = c_re(W[46]); - twi = c_im(W[46]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[23 * stride]); - ti = c_im(inout[23 * stride]); - twr = c_re(W[22]); - twi = c_im(W[22]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[55 * stride]); - ti = c_im(inout[55 * stride]); - twr = c_re(W[54]); - twi = c_im(W[54]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[31 * stride]); - ti = c_im(inout[31 * stride]); - twr = c_re(W[30]); - twi = c_im(W[30]); - tre2_0_0 = (tr * twr) - (ti * twi); - tim2_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[63 * stride]); - ti = c_im(inout[63 * stride]); - twr = c_re(W[62]); - twi = c_im(W[62]); - tre2_1_0 = (tr * twr) - (ti * twi); - tim2_1_0 = (tr * twi) + (ti * twr); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_7 = tre2_0_0 + tre2_0_1; - tim0_0_7 = tim2_0_0 + tim2_0_1; - tre0_4_7 = tre2_0_0 - tre2_0_1; - tim0_4_7 = tim2_0_0 - tim2_0_1; - tre0_2_7 = tre2_1_0 + tim2_1_1; - tim0_2_7 = tim2_1_0 - tre2_1_1; - tre0_6_7 = tre2_1_0 - tim2_1_1; - tim0_6_7 = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - tre0_1_7 = tre2_0_0 + tre2_0_1; - tim0_1_7 = tim2_0_0 + tim2_0_1; - tre0_5_7 = tre2_0_0 - tre2_0_1; - tim0_5_7 = tim2_0_0 - tim2_0_1; - tre0_3_7 = tre2_1_0 + tim2_1_1; - tim0_3_7 = tim2_1_0 - tre2_1_1; - tre0_7_7 = tre2_1_0 - tim2_1_1; - tim0_7_7 = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_0_0 + tre0_0_4; - tim1_0_0 = tim0_0_0 + tim0_0_4; - tre1_1_0 = tre0_0_0 - tre0_0_4; - tim1_1_0 = tim0_0_0 - tim0_0_4; - tre1_0_1 = tre0_0_1 + tre0_0_5; - tim1_0_1 = tim0_0_1 + tim0_0_5; - tre1_1_1 = tre0_0_1 - tre0_0_5; - tim1_1_1 = tim0_0_1 - tim0_0_5; - tre1_0_2 = tre0_0_2 + tre0_0_6; - tim1_0_2 = tim0_0_2 + tim0_0_6; - tre1_1_2 = tre0_0_2 - tre0_0_6; - tim1_1_2 = tim0_0_2 - tim0_0_6; - tre1_0_3 = tre0_0_3 + tre0_0_7; - tim1_0_3 = tim0_0_3 + tim0_0_7; - tre1_1_3 = tre0_0_3 - tre0_0_7; - tim1_1_3 = tim0_0_3 - tim0_0_7; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[0]) = tre2_0_0 + tre2_0_1; - c_im(inout[0]) = tim2_0_0 + tim2_0_1; - c_re(inout[32 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[32 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[16 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[16 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[48 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[48 * stride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(inout[8 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[8 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[40 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[40 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[24 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[24 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[56 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[56 * stride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_1_4) + (((FFTW_REAL) FFTW_K382683432) * tim0_1_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_1_4) - (((FFTW_REAL) FFTW_K382683432) * tre0_1_4); - tre1_0_0 = tre0_1_0 + tre2_1_0; - tim1_0_0 = tim0_1_0 + tim2_1_0; - tre1_1_0 = tre0_1_0 - tre2_1_0; - tim1_1_0 = tim0_1_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K995184726) * tre0_1_1) + (((FFTW_REAL) FFTW_K098017140) * tim0_1_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K995184726) * tim0_1_1) - (((FFTW_REAL) FFTW_K098017140) * tre0_1_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K881921264) * tre0_1_5) + (((FFTW_REAL) FFTW_K471396736) * tim0_1_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K881921264) * tim0_1_5) - (((FFTW_REAL) FFTW_K471396736) * tre0_1_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_1_2) + (((FFTW_REAL) FFTW_K195090322) * tim0_1_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_1_2) - (((FFTW_REAL) FFTW_K195090322) * tre0_1_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_1_6) + (((FFTW_REAL) FFTW_K555570233) * tim0_1_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_1_6) - (((FFTW_REAL) FFTW_K555570233) * tre0_1_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tre0_1_3) + (((FFTW_REAL) FFTW_K290284677) * tim0_1_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tim0_1_3) - (((FFTW_REAL) FFTW_K290284677) * tre0_1_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K773010453) * tre0_1_7) + (((FFTW_REAL) FFTW_K634393284) * tim0_1_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K773010453) * tim0_1_7) - (((FFTW_REAL) FFTW_K634393284) * tre0_1_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[33 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[33 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[17 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[17 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[49 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[49 * stride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(inout[9 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[9 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[41 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[41 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[25 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[25 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[57 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[57 * stride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_4 + tim0_2_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_4 - tre0_2_4); - tre1_0_0 = tre0_2_0 + tre2_1_0; - tim1_0_0 = tim0_2_0 + tim2_1_0; - tre1_1_0 = tre0_2_0 - tre2_1_0; - tim1_1_0 = tim0_2_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_2_1) + (((FFTW_REAL) FFTW_K195090322) * tim0_2_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_2_1) - (((FFTW_REAL) FFTW_K195090322) * tre0_2_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_2_5) + (((FFTW_REAL) FFTW_K831469612) * tim0_2_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_2_5) - (((FFTW_REAL) FFTW_K831469612) * tre0_2_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_2_2) + (((FFTW_REAL) FFTW_K382683432) * tim0_2_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_2_2) - (((FFTW_REAL) FFTW_K382683432) * tre0_2_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_2_6) + (((FFTW_REAL) FFTW_K923879532) * tim0_2_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_2_6) - (((FFTW_REAL) FFTW_K923879532) * tre0_2_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_2_3) + (((FFTW_REAL) FFTW_K555570233) * tim0_2_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_2_3) - (((FFTW_REAL) FFTW_K555570233) * tre0_2_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_2_7) + (((FFTW_REAL) FFTW_K980785280) * tim0_2_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_2_7) - (((FFTW_REAL) FFTW_K980785280) * tre0_2_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[2 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[2 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[34 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[34 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[18 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[18 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[50 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[50 * stride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(inout[10 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[10 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[42 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[42 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[26 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[26 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[58 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[58 * stride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_4) + (((FFTW_REAL) FFTW_K923879532) * tim0_3_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_4) - (((FFTW_REAL) FFTW_K923879532) * tre0_3_4); - tre1_0_0 = tre0_3_0 + tre2_1_0; - tim1_0_0 = tim0_3_0 + tim2_1_0; - tre1_1_0 = tre0_3_0 - tre2_1_0; - tim1_1_0 = tim0_3_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tre0_3_1) + (((FFTW_REAL) FFTW_K290284677) * tim0_3_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tim0_3_1) - (((FFTW_REAL) FFTW_K290284677) * tre0_3_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tre0_3_5) + (((FFTW_REAL) FFTW_K995184726) * tim0_3_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tim0_3_5) - (((FFTW_REAL) FFTW_K995184726) * tre0_3_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_3_2) + (((FFTW_REAL) FFTW_K555570233) * tim0_3_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_3_2) - (((FFTW_REAL) FFTW_K555570233) * tre0_3_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_3_6) - (((FFTW_REAL) FFTW_K195090322) * tre0_3_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_3_6) + (((FFTW_REAL) FFTW_K980785280) * tre0_3_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 - tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K634393284) * tre0_3_3) + (((FFTW_REAL) FFTW_K773010453) * tim0_3_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K634393284) * tim0_3_3) - (((FFTW_REAL) FFTW_K773010453) * tre0_3_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K881921264) * tim0_3_7) - (((FFTW_REAL) FFTW_K471396736) * tre0_3_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K471396736) * tim0_3_7) + (((FFTW_REAL) FFTW_K881921264) * tre0_3_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 - tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[3 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[3 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[35 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[35 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[19 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[19 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[51 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[51 * stride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(inout[11 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[11 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[43 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[43 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[27 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[27 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[59 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[59 * stride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_4_0 + tim0_4_4; - tim1_0_0 = tim0_4_0 - tre0_4_4; - tre1_1_0 = tre0_4_0 - tim0_4_4; - tim1_1_0 = tim0_4_0 + tre0_4_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_4_1) + (((FFTW_REAL) FFTW_K382683432) * tim0_4_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_4_1) - (((FFTW_REAL) FFTW_K382683432) * tre0_4_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_4_5) - (((FFTW_REAL) FFTW_K382683432) * tre0_4_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_4_5) + (((FFTW_REAL) FFTW_K923879532) * tre0_4_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_4_2 + tim0_4_2); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_4_2 - tre0_4_2); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_4_6 - tre0_4_6); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_4_6 + tre0_4_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 - tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_4_3) + (((FFTW_REAL) FFTW_K923879532) * tim0_4_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_4_3) - (((FFTW_REAL) FFTW_K923879532) * tre0_4_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_4_7) - (((FFTW_REAL) FFTW_K923879532) * tre0_4_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_4_7) + (((FFTW_REAL) FFTW_K382683432) * tre0_4_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 - tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[4 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[4 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[36 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[36 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[20 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[20 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[52 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[52 * stride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(inout[12 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[12 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[44 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[44 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[28 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[28 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[60 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[60 * stride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_5_4) - (((FFTW_REAL) FFTW_K382683432) * tre0_5_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_5_4) + (((FFTW_REAL) FFTW_K923879532) * tre0_5_4); - tre1_0_0 = tre0_5_0 + tre2_1_0; - tim1_0_0 = tim0_5_0 - tim2_1_0; - tre1_1_0 = tre0_5_0 - tre2_1_0; - tim1_1_0 = tim0_5_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K881921264) * tre0_5_1) + (((FFTW_REAL) FFTW_K471396736) * tim0_5_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K881921264) * tim0_5_1) - (((FFTW_REAL) FFTW_K471396736) * tre0_5_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K634393284) * tim0_5_5) - (((FFTW_REAL) FFTW_K773010453) * tre0_5_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K773010453) * tim0_5_5) + (((FFTW_REAL) FFTW_K634393284) * tre0_5_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_5_2) + (((FFTW_REAL) FFTW_K831469612) * tim0_5_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_5_2) - (((FFTW_REAL) FFTW_K831469612) * tre0_5_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_5_6) - (((FFTW_REAL) FFTW_K980785280) * tre0_5_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_5_6) + (((FFTW_REAL) FFTW_K195090322) * tre0_5_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 - tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K098017140) * tre0_5_3) + (((FFTW_REAL) FFTW_K995184726) * tim0_5_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K098017140) * tim0_5_3) - (((FFTW_REAL) FFTW_K995184726) * tre0_5_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K956940335) * tre0_5_7) + (((FFTW_REAL) FFTW_K290284677) * tim0_5_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K290284677) * tre0_5_7) - (((FFTW_REAL) FFTW_K956940335) * tim0_5_7); - tre1_0_3 = tre2_0_0 - tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 + tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[5 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[5 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[37 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[37 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[21 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[21 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[53 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[53 * stride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(inout[13 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[13 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[45 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[45 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[29 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[29 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[61 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[61 * stride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_6_4 - tre0_6_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_6_4 + tre0_6_4); - tre1_0_0 = tre0_6_0 + tre2_1_0; - tim1_0_0 = tim0_6_0 - tim2_1_0; - tre1_1_0 = tre0_6_0 - tre2_1_0; - tim1_1_0 = tim0_6_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_6_1) + (((FFTW_REAL) FFTW_K555570233) * tim0_6_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_6_1) - (((FFTW_REAL) FFTW_K555570233) * tre0_6_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_6_5) - (((FFTW_REAL) FFTW_K980785280) * tre0_6_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_6_5) + (((FFTW_REAL) FFTW_K195090322) * tre0_6_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_6_2) + (((FFTW_REAL) FFTW_K923879532) * tim0_6_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_6_2) - (((FFTW_REAL) FFTW_K923879532) * tre0_6_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_6_6) + (((FFTW_REAL) FFTW_K382683432) * tim0_6_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_6_6) - (((FFTW_REAL) FFTW_K923879532) * tim0_6_6); - tre1_0_2 = tre2_0_0 - tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 + tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_6_3) - (((FFTW_REAL) FFTW_K195090322) * tre0_6_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_6_3) + (((FFTW_REAL) FFTW_K980785280) * tre0_6_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_6_7) + (((FFTW_REAL) FFTW_K831469612) * tim0_6_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_6_7) - (((FFTW_REAL) FFTW_K555570233) * tim0_6_7); - tre1_0_3 = tre2_0_0 - tre2_1_0; - tim1_0_3 = tim2_1_0 - tim2_0_0; - tre1_1_3 = tre2_0_0 + tre2_1_0; - tim1_1_3 = (-(tim2_0_0 + tim2_1_0)); - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[6 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[6 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[38 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[38 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[22 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[22 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[54 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[54 * stride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(inout[14 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[14 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[46 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[46 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[30 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[30 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[62 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[62 * stride]) = tim2_1_0 + tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_7_4) - (((FFTW_REAL) FFTW_K923879532) * tre0_7_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_7_4) + (((FFTW_REAL) FFTW_K382683432) * tre0_7_4); - tre1_0_0 = tre0_7_0 + tre2_1_0; - tim1_0_0 = tim0_7_0 - tim2_1_0; - tre1_1_0 = tre0_7_0 - tre2_1_0; - tim1_1_0 = tim0_7_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K773010453) * tre0_7_1) + (((FFTW_REAL) FFTW_K634393284) * tim0_7_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K773010453) * tim0_7_1) - (((FFTW_REAL) FFTW_K634393284) * tre0_7_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K956940335) * tre0_7_5) + (((FFTW_REAL) FFTW_K290284677) * tim0_7_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K290284677) * tre0_7_5) - (((FFTW_REAL) FFTW_K956940335) * tim0_7_5); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_7_2) + (((FFTW_REAL) FFTW_K980785280) * tim0_7_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_7_2) - (((FFTW_REAL) FFTW_K980785280) * tre0_7_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_7_6) + (((FFTW_REAL) FFTW_K831469612) * tim0_7_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_7_6) - (((FFTW_REAL) FFTW_K555570233) * tim0_7_6); - tre1_0_2 = tre2_0_0 - tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 + tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K881921264) * tim0_7_3) - (((FFTW_REAL) FFTW_K471396736) * tre0_7_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K471396736) * tim0_7_3) + (((FFTW_REAL) FFTW_K881921264) * tre0_7_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tre0_7_7) - (((FFTW_REAL) FFTW_K995184726) * tim0_7_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tim0_7_7) + (((FFTW_REAL) FFTW_K995184726) * tre0_7_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_1_0 - tim2_0_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = (-(tim2_0_0 + tim2_1_0)); - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[7 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[7 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[39 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[39 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[23 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[23 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[55 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[55 * stride]) = tim2_1_0 + tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 + tim1_1_2; - tim2_0_0 = tim1_1_0 - tre1_1_2; - tre2_1_0 = tre1_1_0 - tim1_1_2; - tim2_1_0 = tim1_1_0 + tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 + tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 - tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 - tre1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_3 + tre1_1_3); - tre2_0_1 = tre3_0_0 + tre3_1_0; - tim2_0_1 = tim3_0_0 - tim3_1_0; - tre2_1_1 = tre3_0_0 - tre3_1_0; - tim2_1_1 = tim3_0_0 + tim3_1_0; - } - c_re(inout[15 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[15 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[47 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[47 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[31 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[31 * stride]) = tim2_1_0 - tre2_1_1; - c_re(inout[63 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[63 * stride]) = tim2_1_0 + tre2_1_1; - } - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 102 FP additions and 60 FP multiplications */ - -void fftw_twiddle_7(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 6) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - FFTW_REAL tre0_5_0; - FFTW_REAL tim0_5_0; - FFTW_REAL tre0_6_0; - FFTW_REAL tim0_6_0; - tre0_0_0 = c_re(inout[0]); - tim0_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre0_1_0 = (tr * twr) - (ti * twi); - tim0_1_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre0_2_0 = (tr * twr) - (ti * twi); - tim0_2_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre0_3_0 = (tr * twr) - (ti * twi); - tim0_3_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre0_4_0 = (tr * twr) - (ti * twi); - tim0_4_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre0_5_0 = (tr * twr) - (ti * twi); - tim0_5_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[6 * stride]); - ti = c_im(inout[6 * stride]); - twr = c_re(W[5]); - twi = c_im(W[5]); - tre0_6_0 = (tr * twr) - (ti * twi); - tim0_6_0 = (tr * twi) + (ti * twr); - } - c_re(inout[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0 + tre0_3_0 + tre0_4_0 + tre0_5_0 + tre0_6_0; - c_im(inout[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0 + tim0_3_0 + tim0_4_0 + tim0_5_0 + tim0_6_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_1_0 + tre0_6_0)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_3_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_2_0 + tre0_5_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tim0_1_0 - tim0_6_0)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_2_0 - tim0_5_0)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_3_0 - tim0_4_0)); - c_re(inout[stride]) = tre1_0_0 + tre1_1_0; - c_re(inout[6 * stride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_1_0 + tim0_6_0)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_3_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_2_0 + tim0_5_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tre0_6_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_5_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_4_0 - tre0_3_0)); - c_im(inout[stride]) = tim1_0_0 + tim1_1_0; - c_im(inout[6 * stride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_3_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_2_0 + tre0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_1_0 + tre0_6_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tim0_1_0 - tim0_6_0)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_5_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_4_0 - tim0_3_0)); - c_re(inout[2 * stride]) = tre1_0_0 + tre1_1_0; - c_re(inout[5 * stride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_3_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_2_0 + tim0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_1_0 + tim0_6_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tre0_6_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_2_0 - tre0_5_0)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_3_0 - tre0_4_0)); - c_im(inout[2 * stride]) = tim1_0_0 + tim1_1_0; - c_im(inout[5 * stride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_2_0 + tre0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_3_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_1_0 + tre0_6_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tim0_1_0 - tim0_6_0)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_5_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_3_0 - tim0_4_0)); - c_re(inout[3 * stride]) = tre1_0_0 + tre1_1_0; - c_re(inout[4 * stride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_2_0 + tim0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_3_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_1_0 + tim0_6_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tre0_6_0 - tre0_1_0)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_2_0 - tre0_5_0)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_4_0 - tre0_3_0)); - c_im(inout[3 * stride]) = tim1_0_0 + tim1_1_0; - c_im(inout[4 * stride]) = tim1_0_0 - tim1_1_0; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 66 FP additions and 32 FP multiplications */ - -void fftw_twiddle_8(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 7) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(inout[0]); - tim1_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre1_0_0 = (tr * twr) - (ti * twi); - tim1_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre1_0_0 = (tr * twr) - (ti * twi); - tim1_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[6 * stride]); - ti = c_im(inout[6 * stride]); - twr = c_re(W[5]); - twi = c_im(W[5]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - tre0_0_2 = tre1_0_0 + tre1_1_0; - tim0_0_2 = tim1_0_0 + tim1_1_0; - tre0_1_2 = tre1_0_0 - tre1_1_0; - tim0_1_2 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre1_0_0 = (tr * twr) - (ti * twi); - tim1_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[7 * stride]); - ti = c_im(inout[7 * stride]); - twr = c_re(W[6]); - twi = c_im(W[6]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - tre0_0_3 = tre1_0_0 + tre1_1_0; - tim0_0_3 = tim1_0_0 + tim1_1_0; - tre0_1_3 = tre1_0_0 - tre1_1_0; - tim0_1_3 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_0_0 + tre0_0_2; - tim1_0_0 = tim0_0_0 + tim0_0_2; - tre1_1_0 = tre0_0_0 - tre0_0_2; - tim1_1_0 = tim0_0_0 - tim0_0_2; - tre1_0_1 = tre0_0_1 + tre0_0_3; - tim1_0_1 = tim0_0_1 + tim0_0_3; - tre1_1_1 = tre0_0_1 - tre0_0_3; - tim1_1_1 = tim0_0_1 - tim0_0_3; - c_re(inout[0]) = tre1_0_0 + tre1_0_1; - c_im(inout[0]) = tim1_0_0 + tim1_0_1; - c_re(inout[4 * stride]) = tre1_0_0 - tre1_0_1; - c_im(inout[4 * stride]) = tim1_0_0 - tim1_0_1; - c_re(inout[2 * stride]) = tre1_1_0 + tim1_1_1; - c_im(inout[2 * stride]) = tim1_1_0 - tre1_1_1; - c_re(inout[6 * stride]) = tre1_1_0 - tim1_1_1; - c_im(inout[6 * stride]) = tim1_1_0 + tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_1_0 + tim0_1_2; - tim1_0_0 = tim0_1_0 - tre0_1_2; - tre1_1_0 = tre0_1_0 - tim0_1_2; - tim1_1_0 = tim0_1_0 + tre0_1_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_1 + tim0_1_1); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_1 - tre0_1_1); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_3 - tre0_1_3); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_3 + tre0_1_3); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - c_re(inout[stride]) = tre1_0_0 + tre1_0_1; - c_im(inout[stride]) = tim1_0_0 + tim1_0_1; - c_re(inout[5 * stride]) = tre1_0_0 - tre1_0_1; - c_im(inout[5 * stride]) = tim1_0_0 - tim1_0_1; - c_re(inout[3 * stride]) = tre1_1_0 + tim1_1_1; - c_im(inout[3 * stride]) = tim1_1_0 - tre1_1_1; - c_re(inout[7 * stride]) = tre1_1_0 - tim1_1_1; - c_im(inout[7 * stride]) = tim1_1_0 + tre1_1_1; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 108 FP additions and 72 FP multiplications */ - -void fftw_twiddle_9(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 8) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(inout[0]); - tim1_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[6 * stride]); - ti = c_im(inout[6 * stride]); - twr = c_re(W[5]); - twi = c_im(W[5]); - tre1_2_0 = (tr * twr) - (ti * twi); - tim1_2_0 = (tr * twi) + (ti * twr); - } - tre0_0_0 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_0 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - tre0_1_0 = tre2_0_0 + tre2_1_0; - tre0_2_0 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - tim0_1_0 = tim2_0_0 + tim2_1_0; - tim0_2_0 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre1_0_0 = (tr * twr) - (ti * twi); - tim1_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[7 * stride]); - ti = c_im(inout[7 * stride]); - twr = c_re(W[6]); - twi = c_im(W[6]); - tre1_2_0 = (tr * twr) - (ti * twi); - tim1_2_0 = (tr * twi) + (ti * twr); - } - tre0_0_1 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_1 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - tre0_1_1 = tre2_0_0 + tre2_1_0; - tre0_2_1 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - tim0_1_1 = tim2_0_0 + tim2_1_0; - tim0_2_1 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre1_0_0 = (tr * twr) - (ti * twi); - tim1_0_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre1_1_0 = (tr * twr) - (ti * twi); - tim1_1_0 = (tr * twi) + (ti * twr); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[8 * stride]); - ti = c_im(inout[8 * stride]); - twr = c_re(W[7]); - twi = c_im(W[7]); - tre1_2_0 = (tr * twr) - (ti * twi); - tim1_2_0 = (tr * twi) + (ti * twr); - } - tre0_0_2 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_2 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - tre0_1_2 = tre2_0_0 + tre2_1_0; - tre0_2_2 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - tim0_1_2 = tim2_0_0 + tim2_1_0; - tim0_2_2 = tim2_0_0 - tim2_1_0; - } - } - c_re(inout[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2; - c_im(inout[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_0_1 + tre0_0_2)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_0_1 - tim0_0_2); - c_re(inout[3 * stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[6 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_0_1 + tim0_0_2)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_0_2 - tre0_0_1); - c_im(inout[3 * stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[6 * stride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_1_0 = (((FFTW_REAL) FFTW_K766044443) * tre0_1_1) + (((FFTW_REAL) FFTW_K642787609) * tim0_1_1); - tim1_1_0 = (((FFTW_REAL) FFTW_K766044443) * tim0_1_1) - (((FFTW_REAL) FFTW_K642787609) * tre0_1_1); - tre1_2_0 = (((FFTW_REAL) FFTW_K173648177) * tre0_1_2) + (((FFTW_REAL) FFTW_K984807753) * tim0_1_2); - tim1_2_0 = (((FFTW_REAL) FFTW_K173648177) * tim0_1_2) - (((FFTW_REAL) FFTW_K984807753) * tre0_1_2); - c_re(inout[stride]) = tre0_1_0 + tre1_1_0 + tre1_2_0; - c_im(inout[stride]) = tim0_1_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 - tim1_2_0); - c_re(inout[4 * stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[7 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - c_im(inout[4 * stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[7 * stride]) = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_1_0 = (((FFTW_REAL) FFTW_K173648177) * tre0_2_1) + (((FFTW_REAL) FFTW_K984807753) * tim0_2_1); - tim1_1_0 = (((FFTW_REAL) FFTW_K173648177) * tim0_2_1) - (((FFTW_REAL) FFTW_K984807753) * tre0_2_1); - tre1_2_0 = (((FFTW_REAL) FFTW_K342020143) * tim0_2_2) - (((FFTW_REAL) FFTW_K939692620) * tre0_2_2); - tim1_2_0 = (((FFTW_REAL) FFTW_K939692620) * tim0_2_2) + (((FFTW_REAL) FFTW_K342020143) * tre0_2_2); - c_re(inout[2 * stride]) = tre0_2_0 + tre1_1_0 + tre1_2_0; - c_im(inout[2 * stride]) = tim0_2_0 + tim1_1_0 - tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_2_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_1_0 + tim1_2_0); - c_re(inout[5 * stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[8 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_2_0 + (((FFTW_REAL) FFTW_K499999999) * (tim1_2_0 - tim1_1_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_2_0 - tre1_1_0); - c_im(inout[5 * stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[8 * stride]) = tim2_0_0 - tim2_1_0; - } - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 126 FP additions and 68 FP multiplications */ - -void fftwi_twiddle_10(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 9) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(inout[0]); - tim1_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre1_0_0 = (tr * twr) + (ti * twi); - tim1_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[7 * stride]); - ti = c_im(inout[7 * stride]); - twr = c_re(W[6]); - twi = c_im(W[6]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre1_0_0 = (tr * twr) + (ti * twi); - tim1_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[9 * stride]); - ti = c_im(inout[9 * stride]); - twr = c_re(W[8]); - twi = c_im(W[8]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - tre0_0_2 = tre1_0_0 + tre1_1_0; - tim0_0_2 = tim1_0_0 + tim1_1_0; - tre0_1_2 = tre1_0_0 - tre1_1_0; - tim0_1_2 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[6 * stride]); - ti = c_im(inout[6 * stride]); - twr = c_re(W[5]); - twi = c_im(W[5]); - tre1_0_0 = (tr * twr) + (ti * twi); - tim1_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - tre0_0_3 = tre1_0_0 + tre1_1_0; - tim0_0_3 = tim1_0_0 + tim1_1_0; - tre0_1_3 = tre1_0_0 - tre1_1_0; - tim0_1_3 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[8 * stride]); - ti = c_im(inout[8 * stride]); - twr = c_re(W[7]); - twi = c_im(W[7]); - tre1_0_0 = (tr * twr) + (ti * twi); - tim1_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - tre0_0_4 = tre1_0_0 + tre1_1_0; - tim0_0_4 = tim1_0_0 + tim1_1_0; - tre0_1_4 = tre1_0_0 - tre1_1_0; - tim0_1_4 = tim1_0_0 - tim1_1_0; - } - c_re(inout[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2 + tre0_0_3 + tre0_0_4; - c_im(inout[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2 + tim0_0_3 + tim0_0_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_0_1 + tre0_0_4)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_0_2 + tre0_0_3)); - tre2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_0_4 - tim0_0_1)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_0_3 - tim0_0_2)); - c_re(inout[6 * stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[4 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_0_1 + tim0_0_4)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_0_2 + tim0_0_3)); - tim2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_0_1 - tre0_0_4)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_0_2 - tre0_0_3)); - c_im(inout[6 * stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[4 * stride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_0_2 + tre0_0_3)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_0_1 + tre0_0_4)); - tre2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_0_4 - tim0_0_1)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_0_2 - tim0_0_3)); - c_re(inout[2 * stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[8 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_0_2 + tim0_0_3)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_0_1 + tim0_0_4)); - tim2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_0_1 - tre0_0_4)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_0_3 - tre0_0_2)); - c_im(inout[2 * stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[8 * stride]) = tim2_0_0 - tim2_1_0; - } - c_re(inout[5 * stride]) = tre0_1_0 + tre0_1_1 + tre0_1_2 + tre0_1_3 + tre0_1_4; - c_im(inout[5 * stride]) = tim0_1_0 + tim0_1_1 + tim0_1_2 + tim0_1_3 + tim0_1_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_1 + tre0_1_4)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_2 + tre0_1_3)); - tre2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_1_4 - tim0_1_1)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_1_3 - tim0_1_2)); - c_re(inout[stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[9 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_1 + tim0_1_4)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_2 + tim0_1_3)); - tim2_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_1_1 - tre0_1_4)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_1_2 - tre0_1_3)); - c_im(inout[stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[9 * stride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_2 + tre0_1_3)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_1 + tre0_1_4)); - tre2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_1_4 - tim0_1_1)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_1_2 - tim0_1_3)); - c_re(inout[7 * stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[3 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_2 + tim0_1_3)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_1 + tim0_1_4)); - tim2_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_1_1 - tre0_1_4)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_1_3 - tre0_1_2)); - c_im(inout[7 * stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[3 * stride]) = tim2_0_0 - tim2_1_0; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 174 FP additions and 84 FP multiplications */ - -void fftwi_twiddle_16(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 15) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_3_1; - FFTW_REAL tim0_3_1; - FFTW_REAL tre0_3_2; - FFTW_REAL tim0_3_2; - FFTW_REAL tre0_3_3; - FFTW_REAL tim0_3_3; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(inout[0]); - tim2_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[8 * stride]); - ti = c_im(inout[8 * stride]); - twr = c_re(W[7]); - twi = c_im(W[7]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[12 * stride]); - ti = c_im(inout[12 * stride]); - twr = c_re(W[11]); - twi = c_im(W[11]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_0 = tre1_0_0 + tre1_0_1; - tim0_0_0 = tim1_0_0 + tim1_0_1; - tre0_2_0 = tre1_0_0 - tre1_0_1; - tim0_2_0 = tim1_0_0 - tim1_0_1; - tre0_1_0 = tre1_1_0 - tim1_1_1; - tim0_1_0 = tim1_1_0 + tre1_1_1; - tre0_3_0 = tre1_1_0 + tim1_1_1; - tim0_3_0 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[9 * stride]); - ti = c_im(inout[9 * stride]); - twr = c_re(W[8]); - twi = c_im(W[8]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[13 * stride]); - ti = c_im(inout[13 * stride]); - twr = c_re(W[12]); - twi = c_im(W[12]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_1 = tre1_0_0 + tre1_0_1; - tim0_0_1 = tim1_0_0 + tim1_0_1; - tre0_2_1 = tre1_0_0 - tre1_0_1; - tim0_2_1 = tim1_0_0 - tim1_0_1; - tre0_1_1 = tre1_1_0 - tim1_1_1; - tim0_1_1 = tim1_1_0 + tre1_1_1; - tre0_3_1 = tre1_1_0 + tim1_1_1; - tim0_3_1 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[10 * stride]); - ti = c_im(inout[10 * stride]); - twr = c_re(W[9]); - twi = c_im(W[9]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[6 * stride]); - ti = c_im(inout[6 * stride]); - twr = c_re(W[5]); - twi = c_im(W[5]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[14 * stride]); - ti = c_im(inout[14 * stride]); - twr = c_re(W[13]); - twi = c_im(W[13]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_2 = tre1_0_0 + tre1_0_1; - tim0_0_2 = tim1_0_0 + tim1_0_1; - tre0_2_2 = tre1_0_0 - tre1_0_1; - tim0_2_2 = tim1_0_0 - tim1_0_1; - tre0_1_2 = tre1_1_0 - tim1_1_1; - tim0_1_2 = tim1_1_0 + tre1_1_1; - tre0_3_2 = tre1_1_0 + tim1_1_1; - tim0_3_2 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[11 * stride]); - ti = c_im(inout[11 * stride]); - twr = c_re(W[10]); - twi = c_im(W[10]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[7 * stride]); - ti = c_im(inout[7 * stride]); - twr = c_re(W[6]); - twi = c_im(W[6]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[15 * stride]); - ti = c_im(inout[15 * stride]); - twr = c_re(W[14]); - twi = c_im(W[14]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_3 = tre1_0_0 + tre1_0_1; - tim0_0_3 = tim1_0_0 + tim1_0_1; - tre0_2_3 = tre1_0_0 - tre1_0_1; - tim0_2_3 = tim1_0_0 - tim1_0_1; - tre0_1_3 = tre1_1_0 - tim1_1_1; - tim0_1_3 = tim1_1_0 + tre1_1_1; - tre0_3_3 = tre1_1_0 + tim1_1_1; - tim0_3_3 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_0_0 + tre0_0_2; - tim1_0_0 = tim0_0_0 + tim0_0_2; - tre1_1_0 = tre0_0_0 - tre0_0_2; - tim1_1_0 = tim0_0_0 - tim0_0_2; - tre1_0_1 = tre0_0_1 + tre0_0_3; - tim1_0_1 = tim0_0_1 + tim0_0_3; - tre1_1_1 = tre0_0_1 - tre0_0_3; - tim1_1_1 = tim0_0_1 - tim0_0_3; - c_re(inout[0]) = tre1_0_0 + tre1_0_1; - c_im(inout[0]) = tim1_0_0 + tim1_0_1; - c_re(inout[8 * stride]) = tre1_0_0 - tre1_0_1; - c_im(inout[8 * stride]) = tim1_0_0 - tim1_0_1; - c_re(inout[4 * stride]) = tre1_1_0 - tim1_1_1; - c_im(inout[4 * stride]) = tim1_1_0 + tre1_1_1; - c_re(inout[12 * stride]) = tre1_1_0 + tim1_1_1; - c_im(inout[12 * stride]) = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_2 - tim0_1_2); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_2 + tre0_1_2); - tre1_0_0 = tre0_1_0 + tre2_1_0; - tim1_0_0 = tim0_1_0 + tim2_1_0; - tre1_1_0 = tre0_1_0 - tre2_1_0; - tim1_1_0 = tim0_1_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_1_1) - (((FFTW_REAL) FFTW_K382683432) * tim0_1_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_1_1) + (((FFTW_REAL) FFTW_K382683432) * tre0_1_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_1_3) - (((FFTW_REAL) FFTW_K923879532) * tim0_1_3); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_1_3) + (((FFTW_REAL) FFTW_K923879532) * tre0_1_3); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - c_re(inout[stride]) = tre1_0_0 + tre1_0_1; - c_im(inout[stride]) = tim1_0_0 + tim1_0_1; - c_re(inout[9 * stride]) = tre1_0_0 - tre1_0_1; - c_im(inout[9 * stride]) = tim1_0_0 - tim1_0_1; - c_re(inout[5 * stride]) = tre1_1_0 - tim1_1_1; - c_im(inout[5 * stride]) = tim1_1_0 + tre1_1_1; - c_re(inout[13 * stride]) = tre1_1_0 + tim1_1_1; - c_im(inout[13 * stride]) = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_2_0 - tim0_2_2; - tim1_0_0 = tim0_2_0 + tre0_2_2; - tre1_1_0 = tre0_2_0 + tim0_2_2; - tim1_1_0 = tim0_2_0 - tre0_2_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_1 - tim0_2_1); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_1 + tre0_2_1); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_3 + tim0_2_3); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_3 - tim0_2_3); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - c_re(inout[2 * stride]) = tre1_0_0 + tre1_0_1; - c_im(inout[2 * stride]) = tim1_0_0 + tim1_0_1; - c_re(inout[10 * stride]) = tre1_0_0 - tre1_0_1; - c_im(inout[10 * stride]) = tim1_0_0 - tim1_0_1; - c_re(inout[6 * stride]) = tre1_1_0 - tim1_1_1; - c_im(inout[6 * stride]) = tim1_1_0 + tre1_1_1; - c_re(inout[14 * stride]) = tre1_1_0 + tim1_1_1; - c_im(inout[14 * stride]) = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_3_2 + tim0_3_2); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_3_2 - tim0_3_2); - tre1_0_0 = tre0_3_0 - tre2_1_0; - tim1_0_0 = tim0_3_0 + tim2_1_0; - tre1_1_0 = tre0_3_0 + tre2_1_0; - tim1_1_0 = tim0_3_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_1) - (((FFTW_REAL) FFTW_K923879532) * tim0_3_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_1) + (((FFTW_REAL) FFTW_K923879532) * tre0_3_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_3) - (((FFTW_REAL) FFTW_K923879532) * tre0_3_3); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_3_3) + (((FFTW_REAL) FFTW_K382683432) * tre0_3_3); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - c_re(inout[3 * stride]) = tre1_0_0 + tre1_0_1; - c_im(inout[3 * stride]) = tim1_0_0 + tim1_0_1; - c_re(inout[11 * stride]) = tre1_0_0 - tre1_0_1; - c_im(inout[11 * stride]) = tim1_0_0 - tim1_0_1; - c_re(inout[7 * stride]) = tre1_1_0 - tim1_1_1; - c_im(inout[7 * stride]) = tim1_1_0 + tre1_1_1; - c_re(inout[15 * stride]) = tre1_1_0 + tim1_1_1; - c_im(inout[15 * stride]) = tim1_1_0 - tre1_1_1; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 6 FP additions and 4 FP multiplications */ - -void fftwi_twiddle_2(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 1) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - tre0_0_0 = c_re(inout[0]); - tim0_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre0_1_0 = (tr * twr) + (ti * twi); - tim0_1_0 = (ti * twr) - (tr * twi); - } - c_re(inout[0]) = tre0_0_0 + tre0_1_0; - c_im(inout[0]) = tim0_0_0 + tim0_1_0; - c_re(inout[stride]) = tre0_0_0 - tre0_1_0; - c_im(inout[stride]) = tim0_0_0 - tim0_1_0; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 18 FP additions and 12 FP multiplications */ - -void fftwi_twiddle_3(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 2) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - tre0_0_0 = c_re(inout[0]); - tim0_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre0_1_0 = (tr * twr) + (ti * twi); - tim0_1_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre0_2_0 = (tr * twr) + (ti * twi); - tim0_2_0 = (ti * twr) - (tr * twi); - } - c_re(inout[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0; - c_im(inout[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_1_0 + tre0_2_0)); - tre1_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_2_0 - tim0_1_0); - c_re(inout[stride]) = tre1_0_0 + tre1_1_0; - c_re(inout[2 * stride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_1_0 + tim0_2_0)); - tim1_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_1_0 - tre0_2_0); - c_im(inout[stride]) = tim1_0_0 + tim1_1_0; - c_im(inout[2 * stride]) = tim1_0_0 - tim1_1_0; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 438 FP additions and 212 FP multiplications */ - -void fftwi_twiddle_32(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 31) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_0_5; - FFTW_REAL tim0_0_5; - FFTW_REAL tre0_0_6; - FFTW_REAL tim0_0_6; - FFTW_REAL tre0_0_7; - FFTW_REAL tim0_0_7; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - FFTW_REAL tre0_1_5; - FFTW_REAL tim0_1_5; - FFTW_REAL tre0_1_6; - FFTW_REAL tim0_1_6; - FFTW_REAL tre0_1_7; - FFTW_REAL tim0_1_7; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - FFTW_REAL tre0_2_4; - FFTW_REAL tim0_2_4; - FFTW_REAL tre0_2_5; - FFTW_REAL tim0_2_5; - FFTW_REAL tre0_2_6; - FFTW_REAL tim0_2_6; - FFTW_REAL tre0_2_7; - FFTW_REAL tim0_2_7; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_3_1; - FFTW_REAL tim0_3_1; - FFTW_REAL tre0_3_2; - FFTW_REAL tim0_3_2; - FFTW_REAL tre0_3_3; - FFTW_REAL tim0_3_3; - FFTW_REAL tre0_3_4; - FFTW_REAL tim0_3_4; - FFTW_REAL tre0_3_5; - FFTW_REAL tim0_3_5; - FFTW_REAL tre0_3_6; - FFTW_REAL tim0_3_6; - FFTW_REAL tre0_3_7; - FFTW_REAL tim0_3_7; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(inout[0]); - tim2_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[16 * stride]); - ti = c_im(inout[16 * stride]); - twr = c_re(W[15]); - twi = c_im(W[15]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[8 * stride]); - ti = c_im(inout[8 * stride]); - twr = c_re(W[7]); - twi = c_im(W[7]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[24 * stride]); - ti = c_im(inout[24 * stride]); - twr = c_re(W[23]); - twi = c_im(W[23]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_0 = tre1_0_0 + tre1_0_1; - tim0_0_0 = tim1_0_0 + tim1_0_1; - tre0_2_0 = tre1_0_0 - tre1_0_1; - tim0_2_0 = tim1_0_0 - tim1_0_1; - tre0_1_0 = tre1_1_0 - tim1_1_1; - tim0_1_0 = tim1_1_0 + tre1_1_1; - tre0_3_0 = tre1_1_0 + tim1_1_1; - tim0_3_0 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[17 * stride]); - ti = c_im(inout[17 * stride]); - twr = c_re(W[16]); - twi = c_im(W[16]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[9 * stride]); - ti = c_im(inout[9 * stride]); - twr = c_re(W[8]); - twi = c_im(W[8]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[25 * stride]); - ti = c_im(inout[25 * stride]); - twr = c_re(W[24]); - twi = c_im(W[24]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_1 = tre1_0_0 + tre1_0_1; - tim0_0_1 = tim1_0_0 + tim1_0_1; - tre0_2_1 = tre1_0_0 - tre1_0_1; - tim0_2_1 = tim1_0_0 - tim1_0_1; - tre0_1_1 = tre1_1_0 - tim1_1_1; - tim0_1_1 = tim1_1_0 + tre1_1_1; - tre0_3_1 = tre1_1_0 + tim1_1_1; - tim0_3_1 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[18 * stride]); - ti = c_im(inout[18 * stride]); - twr = c_re(W[17]); - twi = c_im(W[17]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[10 * stride]); - ti = c_im(inout[10 * stride]); - twr = c_re(W[9]); - twi = c_im(W[9]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[26 * stride]); - ti = c_im(inout[26 * stride]); - twr = c_re(W[25]); - twi = c_im(W[25]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_2 = tre1_0_0 + tre1_0_1; - tim0_0_2 = tim1_0_0 + tim1_0_1; - tre0_2_2 = tre1_0_0 - tre1_0_1; - tim0_2_2 = tim1_0_0 - tim1_0_1; - tre0_1_2 = tre1_1_0 - tim1_1_1; - tim0_1_2 = tim1_1_0 + tre1_1_1; - tre0_3_2 = tre1_1_0 + tim1_1_1; - tim0_3_2 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[19 * stride]); - ti = c_im(inout[19 * stride]); - twr = c_re(W[18]); - twi = c_im(W[18]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[11 * stride]); - ti = c_im(inout[11 * stride]); - twr = c_re(W[10]); - twi = c_im(W[10]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[27 * stride]); - ti = c_im(inout[27 * stride]); - twr = c_re(W[26]); - twi = c_im(W[26]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_3 = tre1_0_0 + tre1_0_1; - tim0_0_3 = tim1_0_0 + tim1_0_1; - tre0_2_3 = tre1_0_0 - tre1_0_1; - tim0_2_3 = tim1_0_0 - tim1_0_1; - tre0_1_3 = tre1_1_0 - tim1_1_1; - tim0_1_3 = tim1_1_0 + tre1_1_1; - tre0_3_3 = tre1_1_0 + tim1_1_1; - tim0_3_3 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[20 * stride]); - ti = c_im(inout[20 * stride]); - twr = c_re(W[19]); - twi = c_im(W[19]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[12 * stride]); - ti = c_im(inout[12 * stride]); - twr = c_re(W[11]); - twi = c_im(W[11]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[28 * stride]); - ti = c_im(inout[28 * stride]); - twr = c_re(W[27]); - twi = c_im(W[27]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_4 = tre1_0_0 + tre1_0_1; - tim0_0_4 = tim1_0_0 + tim1_0_1; - tre0_2_4 = tre1_0_0 - tre1_0_1; - tim0_2_4 = tim1_0_0 - tim1_0_1; - tre0_1_4 = tre1_1_0 - tim1_1_1; - tim0_1_4 = tim1_1_0 + tre1_1_1; - tre0_3_4 = tre1_1_0 + tim1_1_1; - tim0_3_4 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[21 * stride]); - ti = c_im(inout[21 * stride]); - twr = c_re(W[20]); - twi = c_im(W[20]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[13 * stride]); - ti = c_im(inout[13 * stride]); - twr = c_re(W[12]); - twi = c_im(W[12]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[29 * stride]); - ti = c_im(inout[29 * stride]); - twr = c_re(W[28]); - twi = c_im(W[28]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_5 = tre1_0_0 + tre1_0_1; - tim0_0_5 = tim1_0_0 + tim1_0_1; - tre0_2_5 = tre1_0_0 - tre1_0_1; - tim0_2_5 = tim1_0_0 - tim1_0_1; - tre0_1_5 = tre1_1_0 - tim1_1_1; - tim0_1_5 = tim1_1_0 + tre1_1_1; - tre0_3_5 = tre1_1_0 + tim1_1_1; - tim0_3_5 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[6 * stride]); - ti = c_im(inout[6 * stride]); - twr = c_re(W[5]); - twi = c_im(W[5]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[22 * stride]); - ti = c_im(inout[22 * stride]); - twr = c_re(W[21]); - twi = c_im(W[21]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[14 * stride]); - ti = c_im(inout[14 * stride]); - twr = c_re(W[13]); - twi = c_im(W[13]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[30 * stride]); - ti = c_im(inout[30 * stride]); - twr = c_re(W[29]); - twi = c_im(W[29]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_6 = tre1_0_0 + tre1_0_1; - tim0_0_6 = tim1_0_0 + tim1_0_1; - tre0_2_6 = tre1_0_0 - tre1_0_1; - tim0_2_6 = tim1_0_0 - tim1_0_1; - tre0_1_6 = tre1_1_0 - tim1_1_1; - tim0_1_6 = tim1_1_0 + tre1_1_1; - tre0_3_6 = tre1_1_0 + tim1_1_1; - tim0_3_6 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[7 * stride]); - ti = c_im(inout[7 * stride]); - twr = c_re(W[6]); - twi = c_im(W[6]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[23 * stride]); - ti = c_im(inout[23 * stride]); - twr = c_re(W[22]); - twi = c_im(W[22]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[15 * stride]); - ti = c_im(inout[15 * stride]); - twr = c_re(W[14]); - twi = c_im(W[14]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[31 * stride]); - ti = c_im(inout[31 * stride]); - twr = c_re(W[30]); - twi = c_im(W[30]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - tre0_0_7 = tre1_0_0 + tre1_0_1; - tim0_0_7 = tim1_0_0 + tim1_0_1; - tre0_2_7 = tre1_0_0 - tre1_0_1; - tim0_2_7 = tim1_0_0 - tim1_0_1; - tre0_1_7 = tre1_1_0 - tim1_1_1; - tim0_1_7 = tim1_1_0 + tre1_1_1; - tre0_3_7 = tre1_1_0 + tim1_1_1; - tim0_3_7 = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_0_0 + tre0_0_4; - tim1_0_0 = tim0_0_0 + tim0_0_4; - tre1_1_0 = tre0_0_0 - tre0_0_4; - tim1_1_0 = tim0_0_0 - tim0_0_4; - tre1_0_1 = tre0_0_1 + tre0_0_5; - tim1_0_1 = tim0_0_1 + tim0_0_5; - tre1_1_1 = tre0_0_1 - tre0_0_5; - tim1_1_1 = tim0_0_1 - tim0_0_5; - tre1_0_2 = tre0_0_2 + tre0_0_6; - tim1_0_2 = tim0_0_2 + tim0_0_6; - tre1_1_2 = tre0_0_2 - tre0_0_6; - tim1_1_2 = tim0_0_2 - tim0_0_6; - tre1_0_3 = tre0_0_3 + tre0_0_7; - tim1_0_3 = tim0_0_3 + tim0_0_7; - tre1_1_3 = tre0_0_3 - tre0_0_7; - tim1_1_3 = tim0_0_3 - tim0_0_7; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[0]) = tre2_0_0 + tre2_0_1; - c_im(inout[0]) = tim2_0_0 + tim2_0_1; - c_re(inout[16 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[16 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[8 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[8 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[24 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[24 * stride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(inout[4 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[4 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[20 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[20 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[12 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[12 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[28 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[28 * stride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_4 - tim0_1_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_4 + tre0_1_4); - tre1_0_0 = tre0_1_0 + tre2_1_0; - tim1_0_0 = tim0_1_0 + tim2_1_0; - tre1_1_0 = tre0_1_0 - tre2_1_0; - tim1_1_0 = tim0_1_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_1_1) - (((FFTW_REAL) FFTW_K195090322) * tim0_1_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_1_1) + (((FFTW_REAL) FFTW_K195090322) * tre0_1_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_1_5) - (((FFTW_REAL) FFTW_K831469612) * tim0_1_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_1_5) + (((FFTW_REAL) FFTW_K831469612) * tre0_1_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_1_2) - (((FFTW_REAL) FFTW_K382683432) * tim0_1_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_1_2) + (((FFTW_REAL) FFTW_K382683432) * tre0_1_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_1_6) - (((FFTW_REAL) FFTW_K923879532) * tim0_1_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_1_6) + (((FFTW_REAL) FFTW_K923879532) * tre0_1_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_1_3) - (((FFTW_REAL) FFTW_K555570233) * tim0_1_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_1_3) + (((FFTW_REAL) FFTW_K555570233) * tre0_1_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_1_7) - (((FFTW_REAL) FFTW_K980785280) * tim0_1_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_1_7) + (((FFTW_REAL) FFTW_K980785280) * tre0_1_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[17 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[17 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[9 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[9 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[25 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[25 * stride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(inout[5 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[5 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[21 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[21 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[13 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[13 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[29 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[29 * stride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_2_0 - tim0_2_4; - tim1_0_0 = tim0_2_0 + tre0_2_4; - tre1_1_0 = tre0_2_0 + tim0_2_4; - tim1_1_0 = tim0_2_0 - tre0_2_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_2_1) - (((FFTW_REAL) FFTW_K382683432) * tim0_2_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_2_1) + (((FFTW_REAL) FFTW_K382683432) * tre0_2_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_2_5) + (((FFTW_REAL) FFTW_K923879532) * tim0_2_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_2_5) - (((FFTW_REAL) FFTW_K382683432) * tim0_2_5); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_2 - tim0_2_2); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_2 + tre0_2_2); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_6 + tim0_2_6); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_6 - tim0_2_6); - tre1_0_2 = tre2_0_0 - tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 + tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_2_3) - (((FFTW_REAL) FFTW_K923879532) * tim0_2_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_2_3) + (((FFTW_REAL) FFTW_K923879532) * tre0_2_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_2_7) + (((FFTW_REAL) FFTW_K382683432) * tim0_2_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_2_7) - (((FFTW_REAL) FFTW_K923879532) * tim0_2_7); - tre1_0_3 = tre2_0_0 - tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 + tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[2 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[2 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[18 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[18 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[10 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[10 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[26 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[26 * stride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(inout[6 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[6 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[22 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[22 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[14 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[14 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[30 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[30 * stride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_3_4 + tim0_3_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_3_4 - tim0_3_4); - tre1_0_0 = tre0_3_0 - tre2_1_0; - tim1_0_0 = tim0_3_0 + tim2_1_0; - tre1_1_0 = tre0_3_0 + tre2_1_0; - tim1_1_0 = tim0_3_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_3_1) - (((FFTW_REAL) FFTW_K555570233) * tim0_3_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_3_1) + (((FFTW_REAL) FFTW_K555570233) * tre0_3_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_3_5) + (((FFTW_REAL) FFTW_K195090322) * tim0_3_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_3_5) - (((FFTW_REAL) FFTW_K980785280) * tim0_3_5); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_2) - (((FFTW_REAL) FFTW_K923879532) * tim0_3_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_2) + (((FFTW_REAL) FFTW_K923879532) * tre0_3_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_6) - (((FFTW_REAL) FFTW_K923879532) * tre0_3_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_3_6) + (((FFTW_REAL) FFTW_K382683432) * tre0_3_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 - tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_3_3) + (((FFTW_REAL) FFTW_K980785280) * tim0_3_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_3_3) - (((FFTW_REAL) FFTW_K195090322) * tim0_3_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_3_7) - (((FFTW_REAL) FFTW_K555570233) * tre0_3_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_3_7) + (((FFTW_REAL) FFTW_K831469612) * tre0_3_7); - tre1_0_3 = tre2_1_0 - tre2_0_0; - tim1_0_3 = tim2_0_0 - tim2_1_0; - tre1_1_3 = (-(tre2_0_0 + tre2_1_0)); - tim1_1_3 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[3 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[3 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[19 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[19 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[11 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[11 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[27 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[27 * stride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(inout[7 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[7 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[23 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[23 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[15 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[15 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[31 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[31 * stride]) = tim2_1_0 - tre2_1_1; - } - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 22 FP additions and 12 FP multiplications */ - -void fftwi_twiddle_4(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 3) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(inout[0]); - tim1_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre1_0_0 = (tr * twr) + (ti * twi); - tim1_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - c_re(inout[0]) = tre0_0_0 + tre0_0_1; - c_im(inout[0]) = tim0_0_0 + tim0_0_1; - c_re(inout[2 * stride]) = tre0_0_0 - tre0_0_1; - c_im(inout[2 * stride]) = tim0_0_0 - tim0_0_1; - c_re(inout[stride]) = tre0_1_0 - tim0_1_1; - c_im(inout[stride]) = tim0_1_0 + tre0_1_1; - c_re(inout[3 * stride]) = tre0_1_0 + tim0_1_1; - c_im(inout[3 * stride]) = tim0_1_0 - tre0_1_1; - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 52 FP additions and 32 FP multiplications */ - -void fftwi_twiddle_5(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 4) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - tre0_0_0 = c_re(inout[0]); - tim0_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre0_1_0 = (tr * twr) + (ti * twi); - tim0_1_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre0_2_0 = (tr * twr) + (ti * twi); - tim0_2_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre0_3_0 = (tr * twr) + (ti * twi); - tim0_3_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre0_4_0 = (tr * twr) + (ti * twi); - tim0_4_0 = (ti * twr) - (tr * twi); - } - c_re(inout[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0 + tre0_3_0 + tre0_4_0; - c_im(inout[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0 + tim0_3_0 + tim0_4_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_1_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_2_0 + tre0_3_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tim0_4_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K587785252) * (tim0_3_0 - tim0_2_0)); - c_re(inout[stride]) = tre1_0_0 + tre1_1_0; - c_re(inout[4 * stride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_1_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_2_0 + tim0_3_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K951056516) * (tre0_1_0 - tre0_4_0)) + (((FFTW_REAL) FFTW_K587785252) * (tre0_2_0 - tre0_3_0)); - c_im(inout[stride]) = tim1_0_0 + tim1_1_0; - c_im(inout[4 * stride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tre0_2_0 + tre0_3_0)) - (((FFTW_REAL) FFTW_K809016994) * (tre0_1_0 + tre0_4_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tim0_4_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K951056516) * (tim0_2_0 - tim0_3_0)); - c_re(inout[2 * stride]) = tre1_0_0 + tre1_1_0; - c_re(inout[3 * stride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K309016994) * (tim0_2_0 + tim0_3_0)) - (((FFTW_REAL) FFTW_K809016994) * (tim0_1_0 + tim0_4_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K587785252) * (tre0_1_0 - tre0_4_0)) + (((FFTW_REAL) FFTW_K951056516) * (tre0_3_0 - tre0_2_0)); - c_im(inout[2 * stride]) = tim1_0_0 + tim1_1_0; - c_im(inout[3 * stride]) = tim1_0_0 - tim1_1_0; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 50 FP additions and 28 FP multiplications */ - -void fftwi_twiddle_6(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 5) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(inout[0]); - tim1_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre1_0_0 = (tr * twr) + (ti * twi); - tim1_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre1_0_0 = (tr * twr) + (ti * twi); - tim1_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - tre0_0_2 = tre1_0_0 + tre1_1_0; - tim0_0_2 = tim1_0_0 + tim1_1_0; - tre0_1_2 = tre1_0_0 - tre1_1_0; - tim0_1_2 = tim1_0_0 - tim1_1_0; - } - c_re(inout[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2; - c_im(inout[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_0_1 + tre0_0_2)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_0_2 - tim0_0_1); - c_re(inout[4 * stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[2 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_0_1 + tim0_0_2)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_0_1 - tre0_0_2); - c_im(inout[4 * stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[2 * stride]) = tim2_0_0 - tim2_1_0; - } - c_re(inout[3 * stride]) = tre0_1_0 + tre0_1_1 + tre0_1_2; - c_im(inout[3 * stride]) = tim0_1_0 + tim0_1_1 + tim0_1_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_1_1 + tre0_1_2)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_1_2 - tim0_1_1); - c_re(inout[stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[5 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_1_1 + tim0_1_2)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_1_1 - tre0_1_2); - c_im(inout[stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[5 * stride]) = tim2_0_0 - tim2_1_0; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 1054 FP additions and 500 FP multiplications */ - -void fftwi_twiddle_64(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 63) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_0_4; - FFTW_REAL tim0_0_4; - FFTW_REAL tre0_0_5; - FFTW_REAL tim0_0_5; - FFTW_REAL tre0_0_6; - FFTW_REAL tim0_0_6; - FFTW_REAL tre0_0_7; - FFTW_REAL tim0_0_7; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - FFTW_REAL tre0_1_4; - FFTW_REAL tim0_1_4; - FFTW_REAL tre0_1_5; - FFTW_REAL tim0_1_5; - FFTW_REAL tre0_1_6; - FFTW_REAL tim0_1_6; - FFTW_REAL tre0_1_7; - FFTW_REAL tim0_1_7; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - FFTW_REAL tre0_2_3; - FFTW_REAL tim0_2_3; - FFTW_REAL tre0_2_4; - FFTW_REAL tim0_2_4; - FFTW_REAL tre0_2_5; - FFTW_REAL tim0_2_5; - FFTW_REAL tre0_2_6; - FFTW_REAL tim0_2_6; - FFTW_REAL tre0_2_7; - FFTW_REAL tim0_2_7; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_3_1; - FFTW_REAL tim0_3_1; - FFTW_REAL tre0_3_2; - FFTW_REAL tim0_3_2; - FFTW_REAL tre0_3_3; - FFTW_REAL tim0_3_3; - FFTW_REAL tre0_3_4; - FFTW_REAL tim0_3_4; - FFTW_REAL tre0_3_5; - FFTW_REAL tim0_3_5; - FFTW_REAL tre0_3_6; - FFTW_REAL tim0_3_6; - FFTW_REAL tre0_3_7; - FFTW_REAL tim0_3_7; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - FFTW_REAL tre0_4_1; - FFTW_REAL tim0_4_1; - FFTW_REAL tre0_4_2; - FFTW_REAL tim0_4_2; - FFTW_REAL tre0_4_3; - FFTW_REAL tim0_4_3; - FFTW_REAL tre0_4_4; - FFTW_REAL tim0_4_4; - FFTW_REAL tre0_4_5; - FFTW_REAL tim0_4_5; - FFTW_REAL tre0_4_6; - FFTW_REAL tim0_4_6; - FFTW_REAL tre0_4_7; - FFTW_REAL tim0_4_7; - FFTW_REAL tre0_5_0; - FFTW_REAL tim0_5_0; - FFTW_REAL tre0_5_1; - FFTW_REAL tim0_5_1; - FFTW_REAL tre0_5_2; - FFTW_REAL tim0_5_2; - FFTW_REAL tre0_5_3; - FFTW_REAL tim0_5_3; - FFTW_REAL tre0_5_4; - FFTW_REAL tim0_5_4; - FFTW_REAL tre0_5_5; - FFTW_REAL tim0_5_5; - FFTW_REAL tre0_5_6; - FFTW_REAL tim0_5_6; - FFTW_REAL tre0_5_7; - FFTW_REAL tim0_5_7; - FFTW_REAL tre0_6_0; - FFTW_REAL tim0_6_0; - FFTW_REAL tre0_6_1; - FFTW_REAL tim0_6_1; - FFTW_REAL tre0_6_2; - FFTW_REAL tim0_6_2; - FFTW_REAL tre0_6_3; - FFTW_REAL tim0_6_3; - FFTW_REAL tre0_6_4; - FFTW_REAL tim0_6_4; - FFTW_REAL tre0_6_5; - FFTW_REAL tim0_6_5; - FFTW_REAL tre0_6_6; - FFTW_REAL tim0_6_6; - FFTW_REAL tre0_6_7; - FFTW_REAL tim0_6_7; - FFTW_REAL tre0_7_0; - FFTW_REAL tim0_7_0; - FFTW_REAL tre0_7_1; - FFTW_REAL tim0_7_1; - FFTW_REAL tre0_7_2; - FFTW_REAL tim0_7_2; - FFTW_REAL tre0_7_3; - FFTW_REAL tim0_7_3; - FFTW_REAL tre0_7_4; - FFTW_REAL tim0_7_4; - FFTW_REAL tre0_7_5; - FFTW_REAL tim0_7_5; - FFTW_REAL tre0_7_6; - FFTW_REAL tim0_7_6; - FFTW_REAL tre0_7_7; - FFTW_REAL tim0_7_7; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = c_re(inout[0]); - tim2_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[32 * stride]); - ti = c_im(inout[32 * stride]); - twr = c_re(W[31]); - twi = c_im(W[31]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[8 * stride]); - ti = c_im(inout[8 * stride]); - twr = c_re(W[7]); - twi = c_im(W[7]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[40 * stride]); - ti = c_im(inout[40 * stride]); - twr = c_re(W[39]); - twi = c_im(W[39]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[16 * stride]); - ti = c_im(inout[16 * stride]); - twr = c_re(W[15]); - twi = c_im(W[15]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[48 * stride]); - ti = c_im(inout[48 * stride]); - twr = c_re(W[47]); - twi = c_im(W[47]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[24 * stride]); - ti = c_im(inout[24 * stride]); - twr = c_re(W[23]); - twi = c_im(W[23]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[56 * stride]); - ti = c_im(inout[56 * stride]); - twr = c_re(W[55]); - twi = c_im(W[55]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_0 = tre2_0_0 + tre2_0_1; - tim0_0_0 = tim2_0_0 + tim2_0_1; - tre0_4_0 = tre2_0_0 - tre2_0_1; - tim0_4_0 = tim2_0_0 - tim2_0_1; - tre0_2_0 = tre2_1_0 - tim2_1_1; - tim0_2_0 = tim2_1_0 + tre2_1_1; - tre0_6_0 = tre2_1_0 + tim2_1_1; - tim0_6_0 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_0 = tre2_0_0 + tre2_0_1; - tim0_1_0 = tim2_0_0 + tim2_0_1; - tre0_5_0 = tre2_0_0 - tre2_0_1; - tim0_5_0 = tim2_0_0 - tim2_0_1; - tre0_3_0 = tre2_1_0 - tim2_1_1; - tim0_3_0 = tim2_1_0 + tre2_1_1; - tre0_7_0 = tre2_1_0 + tim2_1_1; - tim0_7_0 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[33 * stride]); - ti = c_im(inout[33 * stride]); - twr = c_re(W[32]); - twi = c_im(W[32]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[9 * stride]); - ti = c_im(inout[9 * stride]); - twr = c_re(W[8]); - twi = c_im(W[8]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[41 * stride]); - ti = c_im(inout[41 * stride]); - twr = c_re(W[40]); - twi = c_im(W[40]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[17 * stride]); - ti = c_im(inout[17 * stride]); - twr = c_re(W[16]); - twi = c_im(W[16]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[49 * stride]); - ti = c_im(inout[49 * stride]); - twr = c_re(W[48]); - twi = c_im(W[48]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[25 * stride]); - ti = c_im(inout[25 * stride]); - twr = c_re(W[24]); - twi = c_im(W[24]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[57 * stride]); - ti = c_im(inout[57 * stride]); - twr = c_re(W[56]); - twi = c_im(W[56]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_1 = tre2_0_0 + tre2_0_1; - tim0_0_1 = tim2_0_0 + tim2_0_1; - tre0_4_1 = tre2_0_0 - tre2_0_1; - tim0_4_1 = tim2_0_0 - tim2_0_1; - tre0_2_1 = tre2_1_0 - tim2_1_1; - tim0_2_1 = tim2_1_0 + tre2_1_1; - tre0_6_1 = tre2_1_0 + tim2_1_1; - tim0_6_1 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_1 = tre2_0_0 + tre2_0_1; - tim0_1_1 = tim2_0_0 + tim2_0_1; - tre0_5_1 = tre2_0_0 - tre2_0_1; - tim0_5_1 = tim2_0_0 - tim2_0_1; - tre0_3_1 = tre2_1_0 - tim2_1_1; - tim0_3_1 = tim2_1_0 + tre2_1_1; - tre0_7_1 = tre2_1_0 + tim2_1_1; - tim0_7_1 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[34 * stride]); - ti = c_im(inout[34 * stride]); - twr = c_re(W[33]); - twi = c_im(W[33]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[10 * stride]); - ti = c_im(inout[10 * stride]); - twr = c_re(W[9]); - twi = c_im(W[9]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[42 * stride]); - ti = c_im(inout[42 * stride]); - twr = c_re(W[41]); - twi = c_im(W[41]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[18 * stride]); - ti = c_im(inout[18 * stride]); - twr = c_re(W[17]); - twi = c_im(W[17]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[50 * stride]); - ti = c_im(inout[50 * stride]); - twr = c_re(W[49]); - twi = c_im(W[49]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[26 * stride]); - ti = c_im(inout[26 * stride]); - twr = c_re(W[25]); - twi = c_im(W[25]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[58 * stride]); - ti = c_im(inout[58 * stride]); - twr = c_re(W[57]); - twi = c_im(W[57]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_2 = tre2_0_0 + tre2_0_1; - tim0_0_2 = tim2_0_0 + tim2_0_1; - tre0_4_2 = tre2_0_0 - tre2_0_1; - tim0_4_2 = tim2_0_0 - tim2_0_1; - tre0_2_2 = tre2_1_0 - tim2_1_1; - tim0_2_2 = tim2_1_0 + tre2_1_1; - tre0_6_2 = tre2_1_0 + tim2_1_1; - tim0_6_2 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_2 = tre2_0_0 + tre2_0_1; - tim0_1_2 = tim2_0_0 + tim2_0_1; - tre0_5_2 = tre2_0_0 - tre2_0_1; - tim0_5_2 = tim2_0_0 - tim2_0_1; - tre0_3_2 = tre2_1_0 - tim2_1_1; - tim0_3_2 = tim2_1_0 + tre2_1_1; - tre0_7_2 = tre2_1_0 + tim2_1_1; - tim0_7_2 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[35 * stride]); - ti = c_im(inout[35 * stride]); - twr = c_re(W[34]); - twi = c_im(W[34]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[11 * stride]); - ti = c_im(inout[11 * stride]); - twr = c_re(W[10]); - twi = c_im(W[10]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[43 * stride]); - ti = c_im(inout[43 * stride]); - twr = c_re(W[42]); - twi = c_im(W[42]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[19 * stride]); - ti = c_im(inout[19 * stride]); - twr = c_re(W[18]); - twi = c_im(W[18]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[51 * stride]); - ti = c_im(inout[51 * stride]); - twr = c_re(W[50]); - twi = c_im(W[50]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[27 * stride]); - ti = c_im(inout[27 * stride]); - twr = c_re(W[26]); - twi = c_im(W[26]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[59 * stride]); - ti = c_im(inout[59 * stride]); - twr = c_re(W[58]); - twi = c_im(W[58]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_3 = tre2_0_0 + tre2_0_1; - tim0_0_3 = tim2_0_0 + tim2_0_1; - tre0_4_3 = tre2_0_0 - tre2_0_1; - tim0_4_3 = tim2_0_0 - tim2_0_1; - tre0_2_3 = tre2_1_0 - tim2_1_1; - tim0_2_3 = tim2_1_0 + tre2_1_1; - tre0_6_3 = tre2_1_0 + tim2_1_1; - tim0_6_3 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_3 = tre2_0_0 + tre2_0_1; - tim0_1_3 = tim2_0_0 + tim2_0_1; - tre0_5_3 = tre2_0_0 - tre2_0_1; - tim0_5_3 = tim2_0_0 - tim2_0_1; - tre0_3_3 = tre2_1_0 - tim2_1_1; - tim0_3_3 = tim2_1_0 + tre2_1_1; - tre0_7_3 = tre2_1_0 + tim2_1_1; - tim0_7_3 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[36 * stride]); - ti = c_im(inout[36 * stride]); - twr = c_re(W[35]); - twi = c_im(W[35]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[12 * stride]); - ti = c_im(inout[12 * stride]); - twr = c_re(W[11]); - twi = c_im(W[11]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[44 * stride]); - ti = c_im(inout[44 * stride]); - twr = c_re(W[43]); - twi = c_im(W[43]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[20 * stride]); - ti = c_im(inout[20 * stride]); - twr = c_re(W[19]); - twi = c_im(W[19]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[52 * stride]); - ti = c_im(inout[52 * stride]); - twr = c_re(W[51]); - twi = c_im(W[51]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[28 * stride]); - ti = c_im(inout[28 * stride]); - twr = c_re(W[27]); - twi = c_im(W[27]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[60 * stride]); - ti = c_im(inout[60 * stride]); - twr = c_re(W[59]); - twi = c_im(W[59]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_4 = tre2_0_0 + tre2_0_1; - tim0_0_4 = tim2_0_0 + tim2_0_1; - tre0_4_4 = tre2_0_0 - tre2_0_1; - tim0_4_4 = tim2_0_0 - tim2_0_1; - tre0_2_4 = tre2_1_0 - tim2_1_1; - tim0_2_4 = tim2_1_0 + tre2_1_1; - tre0_6_4 = tre2_1_0 + tim2_1_1; - tim0_6_4 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_4 = tre2_0_0 + tre2_0_1; - tim0_1_4 = tim2_0_0 + tim2_0_1; - tre0_5_4 = tre2_0_0 - tre2_0_1; - tim0_5_4 = tim2_0_0 - tim2_0_1; - tre0_3_4 = tre2_1_0 - tim2_1_1; - tim0_3_4 = tim2_1_0 + tre2_1_1; - tre0_7_4 = tre2_1_0 + tim2_1_1; - tim0_7_4 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[37 * stride]); - ti = c_im(inout[37 * stride]); - twr = c_re(W[36]); - twi = c_im(W[36]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[13 * stride]); - ti = c_im(inout[13 * stride]); - twr = c_re(W[12]); - twi = c_im(W[12]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[45 * stride]); - ti = c_im(inout[45 * stride]); - twr = c_re(W[44]); - twi = c_im(W[44]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[21 * stride]); - ti = c_im(inout[21 * stride]); - twr = c_re(W[20]); - twi = c_im(W[20]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[53 * stride]); - ti = c_im(inout[53 * stride]); - twr = c_re(W[52]); - twi = c_im(W[52]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[29 * stride]); - ti = c_im(inout[29 * stride]); - twr = c_re(W[28]); - twi = c_im(W[28]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[61 * stride]); - ti = c_im(inout[61 * stride]); - twr = c_re(W[60]); - twi = c_im(W[60]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_5 = tre2_0_0 + tre2_0_1; - tim0_0_5 = tim2_0_0 + tim2_0_1; - tre0_4_5 = tre2_0_0 - tre2_0_1; - tim0_4_5 = tim2_0_0 - tim2_0_1; - tre0_2_5 = tre2_1_0 - tim2_1_1; - tim0_2_5 = tim2_1_0 + tre2_1_1; - tre0_6_5 = tre2_1_0 + tim2_1_1; - tim0_6_5 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_5 = tre2_0_0 + tre2_0_1; - tim0_1_5 = tim2_0_0 + tim2_0_1; - tre0_5_5 = tre2_0_0 - tre2_0_1; - tim0_5_5 = tim2_0_0 - tim2_0_1; - tre0_3_5 = tre2_1_0 - tim2_1_1; - tim0_3_5 = tim2_1_0 + tre2_1_1; - tre0_7_5 = tre2_1_0 + tim2_1_1; - tim0_7_5 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[6 * stride]); - ti = c_im(inout[6 * stride]); - twr = c_re(W[5]); - twi = c_im(W[5]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[38 * stride]); - ti = c_im(inout[38 * stride]); - twr = c_re(W[37]); - twi = c_im(W[37]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[14 * stride]); - ti = c_im(inout[14 * stride]); - twr = c_re(W[13]); - twi = c_im(W[13]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[46 * stride]); - ti = c_im(inout[46 * stride]); - twr = c_re(W[45]); - twi = c_im(W[45]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[22 * stride]); - ti = c_im(inout[22 * stride]); - twr = c_re(W[21]); - twi = c_im(W[21]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[54 * stride]); - ti = c_im(inout[54 * stride]); - twr = c_re(W[53]); - twi = c_im(W[53]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[30 * stride]); - ti = c_im(inout[30 * stride]); - twr = c_re(W[29]); - twi = c_im(W[29]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[62 * stride]); - ti = c_im(inout[62 * stride]); - twr = c_re(W[61]); - twi = c_im(W[61]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_6 = tre2_0_0 + tre2_0_1; - tim0_0_6 = tim2_0_0 + tim2_0_1; - tre0_4_6 = tre2_0_0 - tre2_0_1; - tim0_4_6 = tim2_0_0 - tim2_0_1; - tre0_2_6 = tre2_1_0 - tim2_1_1; - tim0_2_6 = tim2_1_0 + tre2_1_1; - tre0_6_6 = tre2_1_0 + tim2_1_1; - tim0_6_6 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_6 = tre2_0_0 + tre2_0_1; - tim0_1_6 = tim2_0_0 + tim2_0_1; - tre0_5_6 = tre2_0_0 - tre2_0_1; - tim0_5_6 = tim2_0_0 - tim2_0_1; - tre0_3_6 = tre2_1_0 - tim2_1_1; - tim0_3_6 = tim2_1_0 + tre2_1_1; - tre0_7_6 = tre2_1_0 + tim2_1_1; - tim0_7_6 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[7 * stride]); - ti = c_im(inout[7 * stride]); - twr = c_re(W[6]); - twi = c_im(W[6]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[39 * stride]); - ti = c_im(inout[39 * stride]); - twr = c_re(W[38]); - twi = c_im(W[38]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_0 = tre2_0_0 + tre2_1_0; - tim1_0_0 = tim2_0_0 + tim2_1_0; - tre1_1_0 = tre2_0_0 - tre2_1_0; - tim1_1_0 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[15 * stride]); - ti = c_im(inout[15 * stride]); - twr = c_re(W[14]); - twi = c_im(W[14]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[47 * stride]); - ti = c_im(inout[47 * stride]); - twr = c_re(W[46]); - twi = c_im(W[46]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[23 * stride]); - ti = c_im(inout[23 * stride]); - twr = c_re(W[22]); - twi = c_im(W[22]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[55 * stride]); - ti = c_im(inout[55 * stride]); - twr = c_re(W[54]); - twi = c_im(W[54]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[31 * stride]); - ti = c_im(inout[31 * stride]); - twr = c_re(W[30]); - twi = c_im(W[30]); - tre2_0_0 = (tr * twr) + (ti * twi); - tim2_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[63 * stride]); - ti = c_im(inout[63 * stride]); - twr = c_re(W[62]); - twi = c_im(W[62]); - tre2_1_0 = (tr * twr) + (ti * twi); - tim2_1_0 = (ti * twr) - (tr * twi); - } - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - tre0_0_7 = tre2_0_0 + tre2_0_1; - tim0_0_7 = tim2_0_0 + tim2_0_1; - tre0_4_7 = tre2_0_0 - tre2_0_1; - tim0_4_7 = tim2_0_0 - tim2_0_1; - tre0_2_7 = tre2_1_0 - tim2_1_1; - tim0_2_7 = tim2_1_0 + tre2_1_1; - tre0_6_7 = tre2_1_0 + tim2_1_1; - tim0_6_7 = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - tre0_1_7 = tre2_0_0 + tre2_0_1; - tim0_1_7 = tim2_0_0 + tim2_0_1; - tre0_5_7 = tre2_0_0 - tre2_0_1; - tim0_5_7 = tim2_0_0 - tim2_0_1; - tre0_3_7 = tre2_1_0 - tim2_1_1; - tim0_3_7 = tim2_1_0 + tre2_1_1; - tre0_7_7 = tre2_1_0 + tim2_1_1; - tim0_7_7 = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_0_0 + tre0_0_4; - tim1_0_0 = tim0_0_0 + tim0_0_4; - tre1_1_0 = tre0_0_0 - tre0_0_4; - tim1_1_0 = tim0_0_0 - tim0_0_4; - tre1_0_1 = tre0_0_1 + tre0_0_5; - tim1_0_1 = tim0_0_1 + tim0_0_5; - tre1_1_1 = tre0_0_1 - tre0_0_5; - tim1_1_1 = tim0_0_1 - tim0_0_5; - tre1_0_2 = tre0_0_2 + tre0_0_6; - tim1_0_2 = tim0_0_2 + tim0_0_6; - tre1_1_2 = tre0_0_2 - tre0_0_6; - tim1_1_2 = tim0_0_2 - tim0_0_6; - tre1_0_3 = tre0_0_3 + tre0_0_7; - tim1_0_3 = tim0_0_3 + tim0_0_7; - tre1_1_3 = tre0_0_3 - tre0_0_7; - tim1_1_3 = tim0_0_3 - tim0_0_7; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[0]) = tre2_0_0 + tre2_0_1; - c_im(inout[0]) = tim2_0_0 + tim2_0_1; - c_re(inout[32 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[32 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[16 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[16 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[48 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[48 * stride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(inout[8 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[8 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[40 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[40 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[24 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[24 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[56 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[56 * stride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_1_4) - (((FFTW_REAL) FFTW_K382683432) * tim0_1_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_1_4) + (((FFTW_REAL) FFTW_K382683432) * tre0_1_4); - tre1_0_0 = tre0_1_0 + tre2_1_0; - tim1_0_0 = tim0_1_0 + tim2_1_0; - tre1_1_0 = tre0_1_0 - tre2_1_0; - tim1_1_0 = tim0_1_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K995184726) * tre0_1_1) - (((FFTW_REAL) FFTW_K098017140) * tim0_1_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K995184726) * tim0_1_1) + (((FFTW_REAL) FFTW_K098017140) * tre0_1_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K881921264) * tre0_1_5) - (((FFTW_REAL) FFTW_K471396736) * tim0_1_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K881921264) * tim0_1_5) + (((FFTW_REAL) FFTW_K471396736) * tre0_1_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_1_2) - (((FFTW_REAL) FFTW_K195090322) * tim0_1_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_1_2) + (((FFTW_REAL) FFTW_K195090322) * tre0_1_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_1_6) - (((FFTW_REAL) FFTW_K555570233) * tim0_1_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_1_6) + (((FFTW_REAL) FFTW_K555570233) * tre0_1_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tre0_1_3) - (((FFTW_REAL) FFTW_K290284677) * tim0_1_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tim0_1_3) + (((FFTW_REAL) FFTW_K290284677) * tre0_1_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K773010453) * tre0_1_7) - (((FFTW_REAL) FFTW_K634393284) * tim0_1_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K773010453) * tim0_1_7) + (((FFTW_REAL) FFTW_K634393284) * tre0_1_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[33 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[33 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[17 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[17 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[49 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[49 * stride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(inout[9 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[9 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[41 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[41 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[25 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[25 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[57 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[57 * stride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_2_4 - tim0_2_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_2_4 + tre0_2_4); - tre1_0_0 = tre0_2_0 + tre2_1_0; - tim1_0_0 = tim0_2_0 + tim2_1_0; - tre1_1_0 = tre0_2_0 - tre2_1_0; - tim1_1_0 = tim0_2_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_2_1) - (((FFTW_REAL) FFTW_K195090322) * tim0_2_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tim0_2_1) + (((FFTW_REAL) FFTW_K195090322) * tre0_2_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_2_5) - (((FFTW_REAL) FFTW_K831469612) * tim0_2_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_2_5) + (((FFTW_REAL) FFTW_K831469612) * tre0_2_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_2_2) - (((FFTW_REAL) FFTW_K382683432) * tim0_2_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_2_2) + (((FFTW_REAL) FFTW_K382683432) * tre0_2_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_2_6) - (((FFTW_REAL) FFTW_K923879532) * tim0_2_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_2_6) + (((FFTW_REAL) FFTW_K923879532) * tre0_2_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_2_3) - (((FFTW_REAL) FFTW_K555570233) * tim0_2_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_2_3) + (((FFTW_REAL) FFTW_K555570233) * tre0_2_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_2_7) - (((FFTW_REAL) FFTW_K980785280) * tim0_2_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_2_7) + (((FFTW_REAL) FFTW_K980785280) * tre0_2_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[2 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[2 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[34 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[34 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[18 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[18 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[50 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[50 * stride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(inout[10 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[10 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[42 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[42 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[26 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[26 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[58 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[58 * stride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_3_4) - (((FFTW_REAL) FFTW_K923879532) * tim0_3_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_3_4) + (((FFTW_REAL) FFTW_K923879532) * tre0_3_4); - tre1_0_0 = tre0_3_0 + tre2_1_0; - tim1_0_0 = tim0_3_0 + tim2_1_0; - tre1_1_0 = tre0_3_0 - tre2_1_0; - tim1_1_0 = tim0_3_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tre0_3_1) - (((FFTW_REAL) FFTW_K290284677) * tim0_3_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K956940335) * tim0_3_1) + (((FFTW_REAL) FFTW_K290284677) * tre0_3_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tre0_3_5) - (((FFTW_REAL) FFTW_K995184726) * tim0_3_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tim0_3_5) + (((FFTW_REAL) FFTW_K995184726) * tre0_3_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_3_2) - (((FFTW_REAL) FFTW_K555570233) * tim0_3_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_3_2) + (((FFTW_REAL) FFTW_K555570233) * tre0_3_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_3_6) + (((FFTW_REAL) FFTW_K980785280) * tim0_3_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_3_6) - (((FFTW_REAL) FFTW_K195090322) * tim0_3_6); - tre1_0_2 = tre2_0_0 - tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 + tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K634393284) * tre0_3_3) - (((FFTW_REAL) FFTW_K773010453) * tim0_3_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K634393284) * tim0_3_3) + (((FFTW_REAL) FFTW_K773010453) * tre0_3_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K471396736) * tre0_3_7) + (((FFTW_REAL) FFTW_K881921264) * tim0_3_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K881921264) * tre0_3_7) - (((FFTW_REAL) FFTW_K471396736) * tim0_3_7); - tre1_0_3 = tre2_0_0 - tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 + tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[3 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[3 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[35 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[35 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[19 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[19 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[51 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[51 * stride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(inout[11 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[11 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[43 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[43 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[27 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[27 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[59 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[59 * stride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - tre1_0_0 = tre0_4_0 - tim0_4_4; - tim1_0_0 = tim0_4_0 + tre0_4_4; - tre1_1_0 = tre0_4_0 + tim0_4_4; - tim1_1_0 = tim0_4_0 - tre0_4_4; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_4_1) - (((FFTW_REAL) FFTW_K382683432) * tim0_4_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_4_1) + (((FFTW_REAL) FFTW_K382683432) * tre0_4_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_4_5) + (((FFTW_REAL) FFTW_K923879532) * tim0_4_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_4_5) - (((FFTW_REAL) FFTW_K382683432) * tim0_4_5); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_4_2 - tim0_4_2); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_4_2 + tre0_4_2); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_4_6 + tim0_4_6); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_4_6 - tim0_4_6); - tre1_0_2 = tre2_0_0 - tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 + tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_4_3) - (((FFTW_REAL) FFTW_K923879532) * tim0_4_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_4_3) + (((FFTW_REAL) FFTW_K923879532) * tre0_4_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_4_7) + (((FFTW_REAL) FFTW_K382683432) * tim0_4_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_4_7) - (((FFTW_REAL) FFTW_K923879532) * tim0_4_7); - tre1_0_3 = tre2_0_0 - tre2_1_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = tre2_0_0 + tre2_1_0; - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[4 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[4 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[36 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[36 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[20 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[20 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[52 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[52 * stride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(inout[12 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[12 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[44 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[44 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[28 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[28 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[60 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[60 * stride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_5_4) + (((FFTW_REAL) FFTW_K923879532) * tim0_5_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_5_4) - (((FFTW_REAL) FFTW_K382683432) * tim0_5_4); - tre1_0_0 = tre0_5_0 - tre2_1_0; - tim1_0_0 = tim0_5_0 + tim2_1_0; - tre1_1_0 = tre0_5_0 + tre2_1_0; - tim1_1_0 = tim0_5_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K881921264) * tre0_5_1) - (((FFTW_REAL) FFTW_K471396736) * tim0_5_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K881921264) * tim0_5_1) + (((FFTW_REAL) FFTW_K471396736) * tre0_5_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K773010453) * tre0_5_5) + (((FFTW_REAL) FFTW_K634393284) * tim0_5_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K634393284) * tre0_5_5) - (((FFTW_REAL) FFTW_K773010453) * tim0_5_5); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K555570233) * tre0_5_2) - (((FFTW_REAL) FFTW_K831469612) * tim0_5_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_5_2) + (((FFTW_REAL) FFTW_K831469612) * tre0_5_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_5_6) + (((FFTW_REAL) FFTW_K195090322) * tim0_5_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_5_6) - (((FFTW_REAL) FFTW_K980785280) * tim0_5_6); - tre1_0_2 = tre2_0_0 - tre2_1_0; - tim1_0_2 = tim2_0_0 + tim2_1_0; - tre1_1_2 = tre2_0_0 + tre2_1_0; - tim1_1_2 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K098017140) * tre0_5_3) - (((FFTW_REAL) FFTW_K995184726) * tim0_5_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K098017140) * tim0_5_3) + (((FFTW_REAL) FFTW_K995184726) * tre0_5_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K290284677) * tim0_5_7) - (((FFTW_REAL) FFTW_K956940335) * tre0_5_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K956940335) * tim0_5_7) + (((FFTW_REAL) FFTW_K290284677) * tre0_5_7); - tre1_0_3 = tre2_0_0 + tre2_1_0; - tim1_0_3 = tim2_0_0 - tim2_1_0; - tre1_1_3 = tre2_0_0 - tre2_1_0; - tim1_1_3 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[5 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[5 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[37 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[37 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[21 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[21 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[53 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[53 * stride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(inout[13 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[13 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[45 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[45 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[29 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[29 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[61 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[61 * stride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_6_4 + tim0_6_4); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_6_4 - tim0_6_4); - tre1_0_0 = tre0_6_0 - tre2_1_0; - tim1_0_0 = tim0_6_0 + tim2_1_0; - tre1_1_0 = tre0_6_0 + tre2_1_0; - tim1_1_0 = tim0_6_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tre0_6_1) - (((FFTW_REAL) FFTW_K555570233) * tim0_6_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_6_1) + (((FFTW_REAL) FFTW_K555570233) * tre0_6_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_6_5) + (((FFTW_REAL) FFTW_K195090322) * tim0_6_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_6_5) - (((FFTW_REAL) FFTW_K980785280) * tim0_6_5); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_6_2) - (((FFTW_REAL) FFTW_K923879532) * tim0_6_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_6_2) + (((FFTW_REAL) FFTW_K923879532) * tre0_6_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tim0_6_6) - (((FFTW_REAL) FFTW_K923879532) * tre0_6_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tim0_6_6) + (((FFTW_REAL) FFTW_K382683432) * tre0_6_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 - tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_6_3) + (((FFTW_REAL) FFTW_K980785280) * tim0_6_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K980785280) * tre0_6_3) - (((FFTW_REAL) FFTW_K195090322) * tim0_6_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_6_7) - (((FFTW_REAL) FFTW_K555570233) * tre0_6_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_6_7) + (((FFTW_REAL) FFTW_K831469612) * tre0_6_7); - tre1_0_3 = tre2_1_0 - tre2_0_0; - tim1_0_3 = tim2_0_0 - tim2_1_0; - tre1_1_3 = (-(tre2_0_0 + tre2_1_0)); - tim1_1_3 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[6 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[6 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[38 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[38 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[22 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[22 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[54 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[54 * stride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(inout[14 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[14 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[46 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[46 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[30 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[30 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[62 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[62 * stride]) = tim2_1_0 - tre2_1_1; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_0_2; - FFTW_REAL tim1_0_2; - FFTW_REAL tre1_0_3; - FFTW_REAL tim1_0_3; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - FFTW_REAL tre1_1_2; - FFTW_REAL tim1_1_2; - FFTW_REAL tre1_1_3; - FFTW_REAL tim1_1_3; - { - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_1_0 = (((FFTW_REAL) FFTW_K923879532) * tre0_7_4) + (((FFTW_REAL) FFTW_K382683432) * tim0_7_4); - tim2_1_0 = (((FFTW_REAL) FFTW_K382683432) * tre0_7_4) - (((FFTW_REAL) FFTW_K923879532) * tim0_7_4); - tre1_0_0 = tre0_7_0 - tre2_1_0; - tim1_0_0 = tim0_7_0 + tim2_1_0; - tre1_1_0 = tre0_7_0 + tre2_1_0; - tim1_1_0 = tim0_7_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K773010453) * tre0_7_1) - (((FFTW_REAL) FFTW_K634393284) * tim0_7_1); - tim2_0_0 = (((FFTW_REAL) FFTW_K773010453) * tim0_7_1) + (((FFTW_REAL) FFTW_K634393284) * tre0_7_1); - tre2_1_0 = (((FFTW_REAL) FFTW_K290284677) * tim0_7_5) - (((FFTW_REAL) FFTW_K956940335) * tre0_7_5); - tim2_1_0 = (((FFTW_REAL) FFTW_K956940335) * tim0_7_5) + (((FFTW_REAL) FFTW_K290284677) * tre0_7_5); - tre1_0_1 = tre2_0_0 + tre2_1_0; - tim1_0_1 = tim2_0_0 - tim2_1_0; - tre1_1_1 = tre2_0_0 - tre2_1_0; - tim1_1_1 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tre0_7_2) - (((FFTW_REAL) FFTW_K980785280) * tim0_7_2); - tim2_0_0 = (((FFTW_REAL) FFTW_K195090322) * tim0_7_2) + (((FFTW_REAL) FFTW_K980785280) * tre0_7_2); - tre2_1_0 = (((FFTW_REAL) FFTW_K831469612) * tim0_7_6) - (((FFTW_REAL) FFTW_K555570233) * tre0_7_6); - tim2_1_0 = (((FFTW_REAL) FFTW_K555570233) * tim0_7_6) + (((FFTW_REAL) FFTW_K831469612) * tre0_7_6); - tre1_0_2 = tre2_0_0 + tre2_1_0; - tim1_0_2 = tim2_0_0 - tim2_1_0; - tre1_1_2 = tre2_0_0 - tre2_1_0; - tim1_1_2 = tim2_0_0 + tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = (((FFTW_REAL) FFTW_K471396736) * tre0_7_3) + (((FFTW_REAL) FFTW_K881921264) * tim0_7_3); - tim2_0_0 = (((FFTW_REAL) FFTW_K881921264) * tre0_7_3) - (((FFTW_REAL) FFTW_K471396736) * tim0_7_3); - tre2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tre0_7_7) + (((FFTW_REAL) FFTW_K995184726) * tim0_7_7); - tim2_1_0 = (((FFTW_REAL) FFTW_K098017140) * tim0_7_7) - (((FFTW_REAL) FFTW_K995184726) * tre0_7_7); - tre1_0_3 = tre2_1_0 - tre2_0_0; - tim1_0_3 = tim2_0_0 + tim2_1_0; - tre1_1_3 = (-(tre2_0_0 + tre2_1_0)); - tim1_1_3 = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_0_0 + tre1_0_2; - tim2_0_0 = tim1_0_0 + tim1_0_2; - tre2_1_0 = tre1_0_0 - tre1_0_2; - tim2_1_0 = tim1_0_0 - tim1_0_2; - tre2_0_1 = tre1_0_1 + tre1_0_3; - tim2_0_1 = tim1_0_1 + tim1_0_3; - tre2_1_1 = tre1_0_1 - tre1_0_3; - tim2_1_1 = tim1_0_1 - tim1_0_3; - c_re(inout[7 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[7 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[39 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[39 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[23 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[23 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[55 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[55 * stride]) = tim2_1_0 - tre2_1_1; - } - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_0_1; - FFTW_REAL tim2_0_1; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - FFTW_REAL tre2_1_1; - FFTW_REAL tim2_1_1; - tre2_0_0 = tre1_1_0 - tim1_1_2; - tim2_0_0 = tim1_1_0 + tre1_1_2; - tre2_1_0 = tre1_1_0 + tim1_1_2; - tim2_1_0 = tim1_1_0 - tre1_1_2; - { - FFTW_REAL tre3_0_0; - FFTW_REAL tim3_0_0; - FFTW_REAL tre3_1_0; - FFTW_REAL tim3_1_0; - tre3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_1 - tim1_1_1); - tim3_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim1_1_1 + tre1_1_1); - tre3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 + tim1_1_3); - tim3_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre1_1_3 - tim1_1_3); - tre2_0_1 = tre3_0_0 - tre3_1_0; - tim2_0_1 = tim3_0_0 + tim3_1_0; - tre2_1_1 = tre3_0_0 + tre3_1_0; - tim2_1_1 = tim3_0_0 - tim3_1_0; - } - c_re(inout[15 * stride]) = tre2_0_0 + tre2_0_1; - c_im(inout[15 * stride]) = tim2_0_0 + tim2_0_1; - c_re(inout[47 * stride]) = tre2_0_0 - tre2_0_1; - c_im(inout[47 * stride]) = tim2_0_0 - tim2_0_1; - c_re(inout[31 * stride]) = tre2_1_0 - tim2_1_1; - c_im(inout[31 * stride]) = tim2_1_0 + tre2_1_1; - c_re(inout[63 * stride]) = tre2_1_0 + tim2_1_1; - c_im(inout[63 * stride]) = tim2_1_0 - tre2_1_1; - } - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 102 FP additions and 60 FP multiplications */ - -void fftwi_twiddle_7(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 6) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_3_0; - FFTW_REAL tim0_3_0; - FFTW_REAL tre0_4_0; - FFTW_REAL tim0_4_0; - FFTW_REAL tre0_5_0; - FFTW_REAL tim0_5_0; - FFTW_REAL tre0_6_0; - FFTW_REAL tim0_6_0; - tre0_0_0 = c_re(inout[0]); - tim0_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre0_1_0 = (tr * twr) + (ti * twi); - tim0_1_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre0_2_0 = (tr * twr) + (ti * twi); - tim0_2_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre0_3_0 = (tr * twr) + (ti * twi); - tim0_3_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre0_4_0 = (tr * twr) + (ti * twi); - tim0_4_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre0_5_0 = (tr * twr) + (ti * twi); - tim0_5_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[6 * stride]); - ti = c_im(inout[6 * stride]); - twr = c_re(W[5]); - twi = c_im(W[5]); - tre0_6_0 = (tr * twr) + (ti * twi); - tim0_6_0 = (ti * twr) - (tr * twi); - } - c_re(inout[0]) = tre0_0_0 + tre0_1_0 + tre0_2_0 + tre0_3_0 + tre0_4_0 + tre0_5_0 + tre0_6_0; - c_im(inout[0]) = tim0_0_0 + tim0_1_0 + tim0_2_0 + tim0_3_0 + tim0_4_0 + tim0_5_0 + tim0_6_0; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_1_0 + tre0_6_0)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_3_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_2_0 + tre0_5_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tim0_6_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_5_0 - tim0_2_0)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_4_0 - tim0_3_0)); - c_re(inout[stride]) = tre1_0_0 + tre1_1_0; - c_re(inout[6 * stride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_1_0 + tim0_6_0)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_3_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_2_0 + tim0_5_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K781831482) * (tre0_1_0 - tre0_6_0)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_2_0 - tre0_5_0)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_3_0 - tre0_4_0)); - c_im(inout[stride]) = tim1_0_0 + tim1_1_0; - c_im(inout[6 * stride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_3_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_2_0 + tre0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_1_0 + tre0_6_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tim0_6_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K433883739) * (tim0_2_0 - tim0_5_0)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_3_0 - tim0_4_0)); - c_re(inout[2 * stride]) = tre1_0_0 + tre1_1_0; - c_re(inout[5 * stride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_3_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_2_0 + tim0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_1_0 + tim0_6_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K974927912) * (tre0_1_0 - tre0_6_0)) + (((FFTW_REAL) FFTW_K433883739) * (tre0_5_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_4_0 - tre0_3_0)); - c_im(inout[2 * stride]) = tim1_0_0 + tim1_1_0; - c_im(inout[5 * stride]) = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tre1_1_0; - tre1_0_0 = tre0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tre0_2_0 + tre0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tre0_3_0 + tre0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tre0_1_0 + tre0_6_0)); - tre1_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tim0_6_0 - tim0_1_0)) + (((FFTW_REAL) FFTW_K781831482) * (tim0_2_0 - tim0_5_0)) + (((FFTW_REAL) FFTW_K974927912) * (tim0_4_0 - tim0_3_0)); - c_re(inout[3 * stride]) = tre1_0_0 + tre1_1_0; - c_re(inout[4 * stride]) = tre1_0_0 - tre1_1_0; - } - { - FFTW_REAL tim1_0_0; - FFTW_REAL tim1_1_0; - tim1_0_0 = tim0_0_0 + (((FFTW_REAL) FFTW_K623489801) * (tim0_2_0 + tim0_5_0)) - (((FFTW_REAL) FFTW_K222520933) * (tim0_3_0 + tim0_4_0)) - (((FFTW_REAL) FFTW_K900968867) * (tim0_1_0 + tim0_6_0)); - tim1_1_0 = (((FFTW_REAL) FFTW_K433883739) * (tre0_1_0 - tre0_6_0)) + (((FFTW_REAL) FFTW_K781831482) * (tre0_5_0 - tre0_2_0)) + (((FFTW_REAL) FFTW_K974927912) * (tre0_3_0 - tre0_4_0)); - c_im(inout[3 * stride]) = tim1_0_0 + tim1_1_0; - c_im(inout[4 * stride]) = tim1_0_0 - tim1_1_0; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 66 FP additions and 32 FP multiplications */ - -void fftwi_twiddle_8(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 7) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_0_3; - FFTW_REAL tim0_0_3; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_1_3; - FFTW_REAL tim0_1_3; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - tre1_0_0 = c_re(inout[0]); - tim1_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - tre0_0_0 = tre1_0_0 + tre1_1_0; - tim0_0_0 = tim1_0_0 + tim1_1_0; - tre0_1_0 = tre1_0_0 - tre1_1_0; - tim0_1_0 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre1_0_0 = (tr * twr) + (ti * twi); - tim1_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - tre0_0_1 = tre1_0_0 + tre1_1_0; - tim0_0_1 = tim1_0_0 + tim1_1_0; - tre0_1_1 = tre1_0_0 - tre1_1_0; - tim0_1_1 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre1_0_0 = (tr * twr) + (ti * twi); - tim1_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[6 * stride]); - ti = c_im(inout[6 * stride]); - twr = c_re(W[5]); - twi = c_im(W[5]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - tre0_0_2 = tre1_0_0 + tre1_1_0; - tim0_0_2 = tim1_0_0 + tim1_1_0; - tre0_1_2 = tre1_0_0 - tre1_1_0; - tim0_1_2 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre1_0_0 = (tr * twr) + (ti * twi); - tim1_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[7 * stride]); - ti = c_im(inout[7 * stride]); - twr = c_re(W[6]); - twi = c_im(W[6]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - tre0_0_3 = tre1_0_0 + tre1_1_0; - tim0_0_3 = tim1_0_0 + tim1_1_0; - tre0_1_3 = tre1_0_0 - tre1_1_0; - tim0_1_3 = tim1_0_0 - tim1_1_0; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_0_0 + tre0_0_2; - tim1_0_0 = tim0_0_0 + tim0_0_2; - tre1_1_0 = tre0_0_0 - tre0_0_2; - tim1_1_0 = tim0_0_0 - tim0_0_2; - tre1_0_1 = tre0_0_1 + tre0_0_3; - tim1_0_1 = tim0_0_1 + tim0_0_3; - tre1_1_1 = tre0_0_1 - tre0_0_3; - tim1_1_1 = tim0_0_1 - tim0_0_3; - c_re(inout[0]) = tre1_0_0 + tre1_0_1; - c_im(inout[0]) = tim1_0_0 + tim1_0_1; - c_re(inout[4 * stride]) = tre1_0_0 - tre1_0_1; - c_im(inout[4 * stride]) = tim1_0_0 - tim1_0_1; - c_re(inout[2 * stride]) = tre1_1_0 - tim1_1_1; - c_im(inout[2 * stride]) = tim1_1_0 + tre1_1_1; - c_re(inout[6 * stride]) = tre1_1_0 + tim1_1_1; - c_im(inout[6 * stride]) = tim1_1_0 - tre1_1_1; - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_0_1; - FFTW_REAL tim1_0_1; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_1_1; - FFTW_REAL tim1_1_1; - tre1_0_0 = tre0_1_0 - tim0_1_2; - tim1_0_0 = tim0_1_0 + tre0_1_2; - tre1_1_0 = tre0_1_0 + tim0_1_2; - tim1_1_0 = tim0_1_0 - tre0_1_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tim2_0_0; - FFTW_REAL tre2_1_0; - FFTW_REAL tim2_1_0; - tre2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_1 - tim0_1_1); - tim2_0_0 = ((FFTW_REAL) FFTW_K707106781) * (tim0_1_1 + tre0_1_1); - tre2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_3 + tim0_1_3); - tim2_1_0 = ((FFTW_REAL) FFTW_K707106781) * (tre0_1_3 - tim0_1_3); - tre1_0_1 = tre2_0_0 - tre2_1_0; - tim1_0_1 = tim2_0_0 + tim2_1_0; - tre1_1_1 = tre2_0_0 + tre2_1_0; - tim1_1_1 = tim2_0_0 - tim2_1_0; - } - c_re(inout[stride]) = tre1_0_0 + tre1_0_1; - c_im(inout[stride]) = tim1_0_0 + tim1_0_1; - c_re(inout[5 * stride]) = tre1_0_0 - tre1_0_1; - c_im(inout[5 * stride]) = tim1_0_0 - tim1_0_1; - c_re(inout[3 * stride]) = tre1_1_0 - tim1_1_1; - c_im(inout[3 * stride]) = tim1_1_0 + tre1_1_1; - c_re(inout[7 * stride]) = tre1_1_0 + tim1_1_1; - c_im(inout[7 * stride]) = tim1_1_0 - tre1_1_1; - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* This file has been automatically generated --- DO NOT EDIT */ - -#include "fftw.h" -#include "konst.h" - -/* Generated by $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* This function contains 108 FP additions and 72 FP multiplications */ - -void fftwi_twiddle_9(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, int stride, int m, int dist) -{ - int i; - COMPLEX *inout; - inout = A; - for (i = 0; i < m; i = i + 1, inout = inout + dist, W = W + 8) { - FFTW_REAL tre0_0_0; - FFTW_REAL tim0_0_0; - FFTW_REAL tre0_0_1; - FFTW_REAL tim0_0_1; - FFTW_REAL tre0_0_2; - FFTW_REAL tim0_0_2; - FFTW_REAL tre0_1_0; - FFTW_REAL tim0_1_0; - FFTW_REAL tre0_1_1; - FFTW_REAL tim0_1_1; - FFTW_REAL tre0_1_2; - FFTW_REAL tim0_1_2; - FFTW_REAL tre0_2_0; - FFTW_REAL tim0_2_0; - FFTW_REAL tre0_2_1; - FFTW_REAL tim0_2_1; - FFTW_REAL tre0_2_2; - FFTW_REAL tim0_2_2; - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_0_0 = c_re(inout[0]); - tim1_0_0 = c_im(inout[0]); - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[3 * stride]); - ti = c_im(inout[3 * stride]); - twr = c_re(W[2]); - twi = c_im(W[2]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[6 * stride]); - ti = c_im(inout[6 * stride]); - twr = c_re(W[5]); - twi = c_im(W[5]); - tre1_2_0 = (tr * twr) + (ti * twi); - tim1_2_0 = (ti * twr) - (tr * twi); - } - tre0_0_0 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_0 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - tre0_1_0 = tre2_0_0 + tre2_1_0; - tre0_2_0 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - tim0_1_0 = tim2_0_0 + tim2_1_0; - tim0_2_0 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[stride]); - ti = c_im(inout[stride]); - twr = c_re(W[0]); - twi = c_im(W[0]); - tre1_0_0 = (tr * twr) + (ti * twi); - tim1_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[4 * stride]); - ti = c_im(inout[4 * stride]); - twr = c_re(W[3]); - twi = c_im(W[3]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[7 * stride]); - ti = c_im(inout[7 * stride]); - twr = c_re(W[6]); - twi = c_im(W[6]); - tre1_2_0 = (tr * twr) + (ti * twi); - tim1_2_0 = (ti * twr) - (tr * twi); - } - tre0_0_1 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_1 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - tre0_1_1 = tre2_0_0 + tre2_1_0; - tre0_2_1 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - tim0_1_1 = tim2_0_0 + tim2_1_0; - tim0_2_1 = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_0_0; - FFTW_REAL tim1_0_0; - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[2 * stride]); - ti = c_im(inout[2 * stride]); - twr = c_re(W[1]); - twi = c_im(W[1]); - tre1_0_0 = (tr * twr) + (ti * twi); - tim1_0_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[5 * stride]); - ti = c_im(inout[5 * stride]); - twr = c_re(W[4]); - twi = c_im(W[4]); - tre1_1_0 = (tr * twr) + (ti * twi); - tim1_1_0 = (ti * twr) - (tr * twi); - } - { - FFTW_REAL tr; - FFTW_REAL ti; - FFTW_REAL twr; - FFTW_REAL twi; - tr = c_re(inout[8 * stride]); - ti = c_im(inout[8 * stride]); - twr = c_re(W[7]); - twi = c_im(W[7]); - tre1_2_0 = (tr * twr) + (ti * twi); - tim1_2_0 = (ti * twr) - (tr * twi); - } - tre0_0_2 = tre1_0_0 + tre1_1_0 + tre1_2_0; - tim0_0_2 = tim1_0_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - tre0_1_2 = tre2_0_0 + tre2_1_0; - tre0_2_2 = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim1_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - tim0_1_2 = tim2_0_0 + tim2_1_0; - tim0_2_2 = tim2_0_0 - tim2_1_0; - } - } - c_re(inout[0]) = tre0_0_0 + tre0_0_1 + tre0_0_2; - c_im(inout[0]) = tim0_0_0 + tim0_0_1 + tim0_0_2; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tre0_0_1 + tre0_0_2)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim0_0_2 - tim0_0_1); - c_re(inout[3 * stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[6 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_0_0 - (((FFTW_REAL) FFTW_K499999999) * (tim0_0_1 + tim0_0_2)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre0_0_1 - tre0_0_2); - c_im(inout[3 * stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[6 * stride]) = tim2_0_0 - tim2_1_0; - } - { - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_1_0 = (((FFTW_REAL) FFTW_K766044443) * tre0_1_1) - (((FFTW_REAL) FFTW_K642787609) * tim0_1_1); - tim1_1_0 = (((FFTW_REAL) FFTW_K766044443) * tim0_1_1) + (((FFTW_REAL) FFTW_K642787609) * tre0_1_1); - tre1_2_0 = (((FFTW_REAL) FFTW_K173648177) * tre0_1_2) - (((FFTW_REAL) FFTW_K984807753) * tim0_1_2); - tim1_2_0 = (((FFTW_REAL) FFTW_K173648177) * tim0_1_2) + (((FFTW_REAL) FFTW_K984807753) * tre0_1_2); - c_re(inout[stride]) = tre0_1_0 + tre1_1_0 + tre1_2_0; - c_im(inout[stride]) = tim0_1_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tre1_1_0 + tre1_2_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - c_re(inout[4 * stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[7 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_1_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 - tre1_2_0); - c_im(inout[4 * stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[7 * stride]) = tim2_0_0 - tim2_1_0; - } - } - { - FFTW_REAL tre1_1_0; - FFTW_REAL tim1_1_0; - FFTW_REAL tre1_2_0; - FFTW_REAL tim1_2_0; - tre1_1_0 = (((FFTW_REAL) FFTW_K173648177) * tre0_2_1) - (((FFTW_REAL) FFTW_K984807753) * tim0_2_1); - tim1_1_0 = (((FFTW_REAL) FFTW_K173648177) * tim0_2_1) + (((FFTW_REAL) FFTW_K984807753) * tre0_2_1); - tre1_2_0 = (((FFTW_REAL) FFTW_K939692620) * tre0_2_2) + (((FFTW_REAL) FFTW_K342020143) * tim0_2_2); - tim1_2_0 = (((FFTW_REAL) FFTW_K342020143) * tre0_2_2) - (((FFTW_REAL) FFTW_K939692620) * tim0_2_2); - c_re(inout[2 * stride]) = tre0_2_0 + tre1_1_0 - tre1_2_0; - c_im(inout[2 * stride]) = tim0_2_0 + tim1_1_0 + tim1_2_0; - { - FFTW_REAL tre2_0_0; - FFTW_REAL tre2_1_0; - tre2_0_0 = tre0_2_0 + (((FFTW_REAL) FFTW_K499999999) * (tre1_2_0 - tre1_1_0)); - tre2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tim1_2_0 - tim1_1_0); - c_re(inout[5 * stride]) = tre2_0_0 + tre2_1_0; - c_re(inout[8 * stride]) = tre2_0_0 - tre2_1_0; - } - { - FFTW_REAL tim2_0_0; - FFTW_REAL tim2_1_0; - tim2_0_0 = tim0_2_0 - (((FFTW_REAL) FFTW_K499999999) * (tim1_1_0 + tim1_2_0)); - tim2_1_0 = ((FFTW_REAL) FFTW_K866025403) * (tre1_1_0 + tre1_2_0); - c_im(inout[5 * stride]) = tim2_0_0 + tim2_1_0; - c_im(inout[8 * stride]) = tim2_0_0 - tim2_1_0; - } - } - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* - * generic.c -- "generic" solvers. They work for all - * n (and are slow) - */ -#include "fftw.h" -#include -#include - -void fftw_twiddle_generic(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, - int m, int r, int n, int stride) -{ - int i, j, k; - const FFTW_COMPLEX *jp; - FFTW_COMPLEX *kp; - FFTW_COMPLEX *tmp = (FFTW_COMPLEX *) - fftw_malloc(r * sizeof(FFTW_COMPLEX)); - - for (i = 0; i < m; ++i) { - for (k = 0, kp = tmp; k < r; ++k, kp++) { - FFTW_REAL r0, i0, rt, it, rw, iw; - int l1 = i + m * k; - int l0; - - r0 = i0 = 0.0; - for (j = 0, jp = A + i * stride, l0 = 0; j < r; ++j, - jp += m * stride) { - rw = c_re(W[l0]); - iw = c_im(W[l0]); - rt = c_re(*jp); - it = c_im(*jp); - r0 += rt * rw - it * iw; - i0 += rt * iw + it * rw; - l0 += l1; - if (l0 > n) - l0 -= n; - } - c_re(*kp) = r0; - c_im(*kp) = i0; - } - for (k = 0, kp = A + i * stride; k < r; ++k, kp += m * stride) - *kp = tmp[k]; - } - - fftw_free(tmp); -} - -void fftwi_twiddle_generic(FFTW_COMPLEX *A, const FFTW_COMPLEX *W, - int m, int r, int n, int stride) -{ - int i, j, k; - const FFTW_COMPLEX *jp; - FFTW_COMPLEX *kp; - FFTW_COMPLEX *tmp = (FFTW_COMPLEX *) - fftw_malloc(r * sizeof(FFTW_COMPLEX)); - - for (i = 0; i < m; ++i) { - for (k = 0, kp = tmp; k < r; ++k, kp++) { - FFTW_REAL r0, i0, rt, it, rw, iw; - int l1 = i + m * k; - int l0; - - r0 = i0 = 0.0; - for (j = 0, jp = A + i * stride, l0 = 0; j < r; ++j, - jp += m * stride) { - rw = c_re(W[l0]); - iw = c_im(W[l0]); - rt = c_re(*jp); - it = c_im(*jp); - r0 += rt * rw + it * iw; - i0 += it * rw - rt * iw; - l0 += l1; - if (l0 > n) - l0 -= n; - } - c_re(*kp) = r0; - c_im(*kp) = i0; - } - for (k = 0, kp = A + i * stride; k < r; ++k, kp += m * stride) - *kp = tmp[k]; - } - - fftw_free(tmp); -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* - * malloc.c -- memory allocation related functions - */ - -/* $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ -#if defined FFTW_USING_CILK -#include -#include -#endif - -#include "fftw.h" -#include -#include - -int fftw_malloc_cnt = 0; -void *(*fftw_malloc_hook) (size_t n) = (void *(*)(size_t n)) 0; -void (*fftw_free_hook) (void *p) = (void (*)(void *p)) 0; - -#define FFTW_MALLOC_DEBUG 0 -/* sorry for this debugging hack ... */ -#define COMMA , - -#if FFTW_MALLOC_DEBUG -#define WHEN_DEBUG(a) a - -/* - * debugging malloc/free. Initialize every malloced and freed area to - * random values, just to make sure we are not using uninitialized - * pointers. Also check for writes past the ends of allocated blocks, - * and a couple of other things. - * - * This code is a quick and dirty hack -- use at your own risk. - */ - -int fftw_malloc_total = 0; - -#define MAGIC 0xABadCafe -#define PAD_FACTOR 2 -#define TWOINTS (2 * sizeof(int)) - -#define VERBOSE_ALLOCATION 0 - -#if VERBOSE_ALLOCATION -#define WHEN_VERBOSE(a) a -#else -#define WHEN_VERBOSE(a) -#endif - -void *fftw_malloc(size_t n) -{ - char *p; - int i; - - WHEN_VERBOSE({ - printf("FFTW_MALLOC %d\n",n); - fflush(stdout); - }) - - if (n == 0) - fftw_die("Tried to allocate a block of zero size!\n"); - - fftw_malloc_total += n; - - p = (char *) malloc(PAD_FACTOR*n + TWOINTS); - if (!p) - fftw_die("fftw_malloc: out of memory\n"); - - /* store the size in a known position */ - ((int *) p)[0] = n; - ((int *) p)[1] = MAGIC; - for (i = 0; i < PAD_FACTOR*n; ++i) - p[i + TWOINTS] = (char) (i ^ 0xDEADBEEF); - - ++fftw_malloc_cnt; - - /* skip the size we stored previously */ - return (void *) (p + TWOINTS); -} - -void fftw_free(void *p) -{ - char *q = ((char *) p) - TWOINTS; - - if (!p) - fftw_die("fftw_free: tried to free NULL pointer!\n"); - - if (!q) - fftw_die("fftw_free: tried to free NULL+TWOINTS pointer!\n"); - - { - int n = ((int *) q)[0]; - int magic = ((int *) q)[1]; - int i; - - WHEN_VERBOSE({ - printf("FFTW_FREE %d\n",n); - fflush(stdout); - }) - - if (n == 0) - fftw_die("Tried to free a freed pointer!\n"); - *((int *) q) = 0; /* set to zero to detect duplicate free's */ - - if (magic != MAGIC) - fftw_die("Wrong magic in fftw_free()!\n"); - ((int *) q)[1] = ~MAGIC; - - if (n < 0) - fftw_die("Tried to free block with corrupt size descriptor!\n"); - - fftw_malloc_total -= n; - - if (fftw_malloc_total < 0) - fftw_die("fftw_malloc_total went negative!\n"); - - /* check for writing past end of array: */ - for (i = n; i < PAD_FACTOR*n; ++i) - if (q[i+TWOINTS] != (char) (i ^ 0xDEADBEEF)) { - fprintf(stderr, "Byte %d past end of array has changed!\n", - i - n + 1); - fftw_die("Array bounds overwritten!\n"); - } - - for (i = 0; i < PAD_FACTOR*n; ++i) - q[i + TWOINTS] = (char) (i ^ 0xBEEFDEAD); - - --fftw_malloc_cnt; - free(q); - } -} - -#else /* production version, no hacks */ -#define WHEN_DEBUG(a) - -void *fftw_malloc(size_t n) -{ - void *p; - - if (fftw_malloc_hook) - return fftw_malloc_hook(n); - - if (n == 0) - n = 1; - - p = malloc(n); - - if (!p) - fftw_die("fftw_malloc: out of memory\n"); - - return p; -} - -void fftw_free(void *p) -{ - if (p) { - if (fftw_free_hook) { - fftw_free_hook(p); - return; - } - free(p); - } -} - -#endif - -/* die when fatal errors occur */ -void fftw_die(char *s) -{ - fprintf(stderr, "%s", s); - exit(1); -} - -/* check for memory leaks when debugging */ -void fftw_check_memory_leaks(void) -{ - extern int fftw_node_cnt, fftw_plan_cnt, fftw_twiddle_size; - - if (WHEN_DEBUG(fftw_malloc_cnt ||) - WHEN_DEBUG(fftw_malloc_total ||) - fftw_node_cnt || fftw_plan_cnt || fftw_twiddle_size) { - fprintf(stderr, - "MEMORY LEAK!!!\n" - WHEN_DEBUG("fftw_malloc = %d") - " node=%d plan=%d twiddle=%d\n" - WHEN_DEBUG("fftw_malloc_total = %d\n"), - WHEN_DEBUG(fftw_malloc_cnt COMMA) - fftw_node_cnt, fftw_plan_cnt, fftw_twiddle_size - WHEN_DEBUG(COMMA fftw_malloc_total)); - exit(1); - } -} - -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ -#include "fftw.h" -#include - -/* - * Naive O(n^2) algorithm, used for testing purposes - */ -void fftw_naive(int n, FFTW_COMPLEX *in, FFTW_COMPLEX *out) -{ - int i, j; - FFTW_COMPLEX sum; - FFTW_COMPLEX w; - FFTW_REAL pi = 3.1415926535897932384626434; - - for (j = 0; j < n; ++j) { - c_re(sum) = c_im(sum) = 0.0; - for (i = 0; i < n; ++i) { - c_re(w) = cos((2.0 * pi * (i * j % n)) / n); - c_im(w) = -sin((2.0 * pi * (i * j % n)) / n); - c_re(sum) += c_re(in[i]) * c_re(w) - c_im(in[i]) * c_im(w); - c_im(sum) += c_im(in[i]) * c_re(w) + c_re(in[i]) * c_im(w); - } - out[j] = sum; - } - return; -} - -/* - * Naive O(n^2) algorithm, for the inverse. - */ -void fftwi_naive(int n, FFTW_COMPLEX *in, FFTW_COMPLEX *out) -{ - int i, j; - FFTW_COMPLEX sum; - FFTW_COMPLEX w; - FFTW_REAL pi = 3.1415926535897932384626434; - - for (j = 0; j < n; ++j) { - c_re(sum) = c_im(sum) = 0.0; - for (i = 0; i < n; ++i) { - c_re(w) = cos((2.0 * pi * (i * j % n)) / n); - c_im(w) = sin((2.0 * pi * (i * j % n)) / n); - c_re(sum) += c_re(in[i]) * c_re(w) - c_im(in[i]) * c_im(w); - c_im(sum) += c_im(in[i]) * c_re(w) + c_re(in[i]) * c_im(w); - } - out[j] = sum; - } - return; -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* - * planner.c -- find the optimal plan - */ - -/* $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ -#if defined FFTW_USING_CILK -#include -#include -#endif - -#include "fftw.h" -#include -#include - -int fftw_node_cnt = 0; -int fftw_plan_cnt = 0; - -#define NOTW_OPTIMAL_SIZE 32 -#define TWIDDLE_OPTIMAL_SIZE 12 - -/* wisdom prototypes */ -extern int fftw_wisdom_lookup(int n, int flags, fftw_direction dir, - enum fftw_node_type *type, - int *signature, int replace_p); -extern void fftw_wisdom_add(int n, int flags, fftw_direction dir, - enum fftw_node_type type, - int signature); - -/* constructors --- I wish I had ML */ -static fftw_plan_node *make_node(void) -{ - fftw_plan_node *p = (fftw_plan_node *) - fftw_malloc(sizeof(fftw_plan_node)); - p->refcnt = 0; - fftw_node_cnt++; - return p; -} - -static void use_node(fftw_plan_node *p) -{ - ++p->refcnt; -} - -static fftw_plan_node *make_node_notw(int size, notw_codelet *codelet) -{ - fftw_plan_node *p = make_node(); - - p->type = FFTW_NOTW; - p->nodeu.notw.size = size; - p->nodeu.notw.codelet = codelet; - return p; -} - -static fftw_plan_node *make_node_twiddle(int n, int size, twiddle_codelet *codelet, - fftw_plan_node *recurse, - int flags) -{ - fftw_plan_node *p = make_node(); - - p->type = FFTW_TWIDDLE; - p->nodeu.twiddle.size = size; - p->nodeu.twiddle.codelet = codelet; - p->nodeu.twiddle.recurse = recurse; - use_node(recurse); - if (flags & FFTW_MEASURE) - p->nodeu.twiddle.tw = fftw_create_twiddle(n, size, n / size); - else - p->nodeu.twiddle.tw = 0; - return p; -} - -static fftw_plan_node *make_node_generic(int n, int size, - generic_codelet *codelet, - fftw_plan_node *recurse, - int flags) -{ - fftw_plan_node *p = make_node(); - - p->type = FFTW_GENERIC; - p->nodeu.generic.size = size; - p->nodeu.generic.codelet = codelet; - p->nodeu.generic.recurse = recurse; - use_node(recurse); - - if (flags & FFTW_MEASURE) - p->nodeu.generic.tw = fftw_create_twiddle(n, 2, n); - else - p->nodeu.generic.tw = 0; - return p; -} - -static void destroy_tree(fftw_plan_node *p) -{ - if (p) { - --p->refcnt; - if (p->refcnt == 0) { - switch (p->type) { - case FFTW_NOTW: - break; - - case FFTW_TWIDDLE: - if (p->nodeu.twiddle.tw) - fftw_destroy_twiddle(p->nodeu.twiddle.tw); - destroy_tree(p->nodeu.twiddle.recurse); - break; - - case FFTW_GENERIC: - if (p->nodeu.generic.tw) - fftw_destroy_twiddle(p->nodeu.generic.tw); - destroy_tree(p->nodeu.generic.recurse); - break; - } - - fftw_free(p); - fftw_node_cnt--; - } - } -} - -/* create a plan with twiddle factors, and other bells and whistles */ -static fftw_plan make_plan(int n, fftw_direction dir, - fftw_plan_node *root, int flags, - enum fftw_node_type wisdom_type, - int wisdom_signature) -{ - fftw_plan p = (fftw_plan) fftw_malloc(sizeof(struct fftw_plan_struct)); - - p->n = n; - p->dir = dir; - p->flags = flags; - use_node(root); - p->root = root; - p->cost = 0.0; - p->wisdom_type = wisdom_type; - p->wisdom_signature = wisdom_signature; - p->next = (fftw_plan) 0; - p->refcnt = 0; - fftw_plan_cnt++; - return p; -} - -/* - * complete with twiddle factors (because nodes don't have - * them when FFTW_ESTIMATE is set) - */ -static void complete_twiddle(fftw_plan_node *p, int n) -{ - int r; - switch (p->type) { - case FFTW_NOTW: - break; - - case FFTW_TWIDDLE: - r = p->nodeu.twiddle.size; - if (!p->nodeu.twiddle.tw) - p->nodeu.twiddle.tw = fftw_create_twiddle(n, r, n / r); - complete_twiddle(p->nodeu.twiddle.recurse, n / r); - break; - - case FFTW_GENERIC: - r = p->nodeu.generic.size; - if (!p->nodeu.generic.tw) - p->nodeu.generic.tw = fftw_create_twiddle(n, 2, n); - complete_twiddle(p->nodeu.generic.recurse, n / r); - break; - } -} - -static void use_plan(fftw_plan p) -{ - ++p->refcnt; -} - -static void destroy_plan(fftw_plan p) -{ - --p->refcnt; - - if (p->refcnt == 0) { - destroy_tree(p->root); - fftw_plan_cnt--; - fftw_free(p); - } -} - -/* end of constructors */ - -/* management of plan tables */ -static void make_empty_table(fftw_plan *table) -{ - *table = (fftw_plan) 0; -} - -static void insert(fftw_plan *table, fftw_plan this_plan, int n) -{ - use_plan(this_plan); - this_plan->n = n; - this_plan->next = *table; - *table = this_plan; -} - -static fftw_plan lookup(fftw_plan *table, int n, int flags) -{ - fftw_plan p; - - for (p = *table; p && - ((p->n != n) || (p->flags != flags)); p = p->next); - - return p; -} - -static void destroy_table(fftw_plan *table) -{ - fftw_plan p, q; - - for (p = *table; p; p = q) { - q = p->next; - destroy_plan(p); - } -} - -static double estimate_node(fftw_plan_node *p) -{ - int k; - - switch (p->type) { - case FFTW_NOTW: - k = p->nodeu.notw.size; - return 1.0 + 0.1 * (k - NOTW_OPTIMAL_SIZE) * - (k - NOTW_OPTIMAL_SIZE); - - case FFTW_TWIDDLE: - k = p->nodeu.twiddle.size; - return 1.0 + 0.1 * (k - TWIDDLE_OPTIMAL_SIZE) * - (k - TWIDDLE_OPTIMAL_SIZE) - + estimate_node(p->nodeu.twiddle.recurse); - - case FFTW_GENERIC: - k = p->nodeu.generic.size; - return 10.0 + k * k - + estimate_node(p->nodeu.generic.recurse); - } - return 1.0E20; -} - -/* auxiliary functions */ -static void compute_cost(fftw_plan plan) -{ - if (plan->flags & FFTW_MEASURE) - plan->cost = fftw_measure_runtime(plan); - else { - double c; - c = plan->n * estimate_node(plan->root); - plan->cost = c; - } -} - -/* pick the better of two plans and destroy the other one. */ -static fftw_plan pick_better(fftw_plan p1, fftw_plan p2) -{ - if (!p1) - return p2; - - if (!p2) - return p1; - - if (p1->cost > p2->cost) { - destroy_plan(p1); - return p2; - } else { - destroy_plan(p2); - return p1; - } -} - -/* find the smallest prime factor of n */ -static int factor(int n) -{ - int r; - - /* try 2 */ - if ((n & 1) == 0) - return 2; - - /* try odd numbers up to sqrt(n) */ - for (r = 3; r * r <= n; r += 2) - if (n % r == 0) - return r; - - /* n is prime */ - return n; -} - -/* - * Some macrology for the planner. If you have to write - * the same line of code twice, there must be some bug. - */ -#define NOTW_ITERATOR(p, dir) \ - config_notw *p = \ - p = (dir == FFTW_FORWARD ? \ - fftw_config_notw : fftwi_config_notw) - -#define TWIDDLE_ITERATOR(p, dir) \ - config_twiddle *p = \ - p = (dir == FFTW_FORWARD ? \ - fftw_config_twiddle : fftwi_config_twiddle); - -#define FORALL_NOTW(p) \ - for (; p->size; ++p) - -#define FORALL_TWIDDLE(p) \ - for (; p->size; ++p) - -/****************************************** - * Recursive planner * - ******************************************/ -fftw_plan planner(fftw_plan *table, int n, fftw_direction dir, int flags); - -/* - * the planner consists of two parts: one that tries to - * use accumulated wisdom, and one that does not. - * A small driver invokes both parts in sequence - */ - -/* planner with wisdom: look up the codelet suggested by the wisdom */ -fftw_plan planner_wisdom(fftw_plan *table, int n, - fftw_direction dir, int flags) -{ - fftw_plan best = (fftw_plan) 0; - fftw_plan_node *node; - int have_wisdom; - enum fftw_node_type wisdom_type; - int wisdom_signature; - - /* see if we remember any wisdom for this case */ - have_wisdom = fftw_wisdom_lookup(n, flags, dir, - &wisdom_type, &wisdom_signature, 0); - - if (!have_wisdom) - return best; - - if (wisdom_type == FFTW_NOTW) { - NOTW_ITERATOR(p, dir); - - FORALL_NOTW(p) { - /* see if wisdom applies */ - if (wisdom_signature == p->signature && - p->size == n) { - node = make_node_notw(n, p->codelet); - best = make_plan(n, dir, node, flags, - FFTW_NOTW, p->signature); - use_plan(best); - return best; - } - } - } - - if (wisdom_type == FFTW_TWIDDLE) { - TWIDDLE_ITERATOR(p, dir); - - FORALL_TWIDDLE(p) { - /* see if wisdom applies */ - if (wisdom_signature == p->signature && - (n % p->size) == 0) { - fftw_plan r = planner(table, n / p->size, dir, flags); - node = make_node_twiddle(n, p->size, p->codelet, - r->root, flags); - best = make_plan(n, dir, node, flags, - FFTW_TWIDDLE, p->signature); - use_plan(best); - destroy_plan(r); - return best; - } - } - } - - /* - * BUG (or: TODO) Can we have generic wisdom? This is probably - * an academic question - */ - - return best; -} - -/* - * planner with no wisdom: try all combinations and pick - * the best - */ -fftw_plan planner_normal(fftw_plan *table, int n, fftw_direction dir, - int flags) -{ - fftw_plan best = (fftw_plan) 0; - fftw_plan newplan; - fftw_plan_node *node; - - /* see if we have any codelet that solves the problem */ - { - NOTW_ITERATOR(p, dir); - - FORALL_NOTW(p) { - if (p->size == n) { - node = make_node_notw(n, p->codelet); - newplan = make_plan(n, dir, node, flags, - FFTW_NOTW, p->signature); - use_plan(newplan); - compute_cost(newplan); - best = pick_better(newplan, best); - } - } - } - - /* Then, try all available twiddle codelets */ - { - TWIDDLE_ITERATOR(p, dir); - - FORALL_TWIDDLE(p) { - if ((n % p->size) == 0 && - (!best || n != p->size)) { - fftw_plan r = planner(table, n / p->size, dir, flags); - node = make_node_twiddle(n, p->size, p->codelet, - r->root, flags); - newplan = make_plan(n, dir, node, flags, - FFTW_TWIDDLE, p->signature); - use_plan(newplan); - destroy_plan(r); - compute_cost(newplan); - best = pick_better(newplan, best); - } - } - } - - /* - * if no plan has been found so far, resort to generic codelets - */ - if (!best) { - generic_codelet *codelet = (dir == FFTW_FORWARD ? - fftw_twiddle_generic : fftwi_twiddle_generic); - int size = factor(n); - fftw_plan r = planner(table, n / size, dir, flags); - - node = make_node_generic(n, size, codelet, r->root, flags); - newplan = make_plan(n, dir, node, flags, FFTW_GENERIC, 0); - use_plan(newplan); - destroy_plan(r); - compute_cost(newplan); - best = pick_better(newplan, best); - } - - return best; -} - -fftw_plan planner(fftw_plan *table, int n, fftw_direction dir, - int flags) -{ - fftw_plan best = (fftw_plan) 0; - - /* see if plan has already been computed */ - best = lookup(table, n, flags); - if (best) { - use_plan(best); - return best; - } - - /* try a wise plan */ - best = planner_wisdom(table, n, dir, flags); - - if (!best) { - /* No wisdom. Plan normally. */ - best = planner_normal(table, n, dir, flags); - } - - if (best) { - insert(table, best, n); - - /* remember the wisdom */ - fftw_wisdom_add(n, flags, dir, best->wisdom_type, - best->wisdom_signature); - } - - return best; -} - -fftw_plan fftw_create_plan(int n, fftw_direction dir, int flags) -{ - fftw_plan table; - fftw_plan p1; - - /* validate parameters */ - if (n <= 0) - return (fftw_plan) 0; - - if ((dir != FFTW_FORWARD) && (dir != FFTW_BACKWARD)) - return (fftw_plan) 0; - - make_empty_table(&table); - p1 = planner(&table, n, dir, flags); - destroy_table(&table); - - complete_twiddle(p1->root, n); - return p1; -} - -void fftw_destroy_plan(fftw_plan plan) -{ - destroy_plan(plan); -} - -static void print_node(FILE * f, fftw_plan_node *p, int indent) -{ - if (p) { - switch (p->type) { - case FFTW_NOTW: - fprintf(f, "%*sFFTW_NOTW %d\n", indent, "", - p->nodeu.notw.size); - break; - case FFTW_TWIDDLE: - fprintf(f, "%*sFFTW_TWIDDLE %d\n", indent, "", - p->nodeu.twiddle.size); - print_node(f, p->nodeu.twiddle.recurse, indent); - break; - case FFTW_GENERIC: - fprintf(f, "%*sFFTW_GENERIC %d\n", indent, "", - p->nodeu.generic.size); - print_node(f, p->nodeu.generic.recurse, indent); - break; - } - } -} - -void fftw_fprint_plan(FILE * f, fftw_plan p) -{ - fprintf(f, "plan: (cost = %e)\n", p->cost); - print_node(f, p->root, 0); -} - -void fftw_print_plan(fftw_plan p) -{ - fftw_fprint_plan(stdout, p); -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* - * timer.c -- this file measures the execution time of - * ffts. This information is used by the planner. - */ - -/* $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -#include -#include "fftw.h" -#include -#include - -/* - * The timer keeps doubling the number of iterations - * until the program runs for more than FFTW_TIME_MIN - */ -double fftw_measure_runtime(fftw_plan plan) -{ - FFTW_COMPLEX *in, *out; - fftw_time begin, end; - double t; - int i, iter; - int n; - - n = plan->n; - - iter = 1; - -retry: - in = (FFTW_COMPLEX *) fftw_malloc(n * sizeof(FFTW_COMPLEX)); - out = (FFTW_COMPLEX *) fftw_malloc(n * sizeof(FFTW_COMPLEX)); - - begin = fftw_get_time(); - for (i = 0; i < iter; ++i) { - int j; - - /* generate random inputs */ - for (j = 0; j < n; ++j) { - c_re(in[j]) = 1.0; - c_im(in[j]) = 32.432; - } - - fftw(plan, 1, in, 1, 0, out, 1, 0); - } - end = fftw_get_time(); - - t = fftw_time_to_sec(fftw_time_diff(end,begin)); - - fftw_free(in); - fftw_free(out); - - if (t < FFTW_TIME_MIN) { - iter *= 2; - /* - * See D. E. Knuth, Structured Programming with GOTO Statements, - * Computing Surveys (6), December 1974, for a justification - * of this `goto' in the `n + 1/2' loop. - */ - goto retry; - } - - return t / (double)iter; -} - -#if defined(MAC) || defined(macintosh) - -/* Use Macintosh Time Manager to get the time: */ - -#pragma only_std_keywords off /* make sure compiler (CW) recognizes the pascal - keywords that are in Timer.h */ - -#include - -#pragma only_std_keywords reset - -fftw_time get_Mac_microseconds(void) -{ - fftw_time t; - UnsignedWide microsec; /* - * microsec.lo and microsec.hi are - * unsigned long's, and are the two parts - * of a 64 bit unsigned integer - */ - - Microseconds(µsec); /* get time in microseconds */ - - /* store lo and hi words into our structure: */ - t.lo = microsec.lo; t.hi = microsec.hi; - - return t; -} - -fftw_time fftw_time_diff(fftw_time t1, fftw_time t2) -/* This function takes the difference t1 - t2 of two 64 bit - integers, represented by the 32 bit lo and hi words. - if t1 < t2, returns 0. */ -{ - fftw_time diff; - - if (t1.hi < t2.hi) { /* something is wrong...t1 < t2! */ - diff.hi = diff.lo = 0; - return diff; - } - else - diff.hi = t1.hi - t2.hi; - - if (t1.lo < t2.lo) { - if (diff.hi > 0) - diff.hi -= 1; /* carry */ - else { /* something is wrong...t1 < t2! */ - diff.hi = diff.lo = 0; - return diff; - } - } - - diff.lo = t1.lo - t2.lo; - - return diff; -} - -#endif - -#if defined __WIN32__ -#include - -static LARGE_INTEGER gFreq; -static int gHaveHiResTimer = 0; -static int gFirstTime = 1; - -unsigned long GetPerfTime(void) -{ - LARGE_INTEGER lCounter; - - if (gFirstTime) { - gFirstTime = 0; - - if (QueryPerformanceFrequency(&gFreq)) { - gHaveHiResTimer = 1; - } - } - if (gHaveHiResTimer) { - QueryPerformanceCounter(&lCounter); - return lCounter.u.LowPart; - } else { -#if defined(__QK_USER__) - return (unsigned long) (dclock() * 1000000.0L) -#else - return (unsigned long) clock(); -#endif - } -} - -double GetPerfSec(double pTime) -{ - if (gHaveHiResTimer) { - return pTime / gFreq.u.LowPart; // assumes HighPart==0 - - } else { - return pTime / CLOCKS_PER_SEC; - } -} - -#endif /* __WIN32__ */ - -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* - * twiddle.c -- compute twiddle factors - * These are the twiddle factors for *direct* fft. Flip sign to get - * the inverse - */ - -/* $Id: fftw.c,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ -#if defined FFTW_USING_CILK -#include -#include -#endif - -#include "fftw.h" -#include -#include - -#define FFTW_K2PI 6.2831853071795864769252867665590057683943387987502 - -/* - * compute the W coefficients (that is, powers of the root of 1) - * and store them into an array. - */ -static void fftw_compute_twiddle(int n, int r, int m, FFTW_COMPLEX *W) -{ - double twoPiOverN; - int i, j; - - twoPiOverN = FFTW_K2PI / (double) n; - for (i = 0; i < m; ++i) - for (j = 1; j < r; ++j) { - int k = i * (r - 1) + (j - 1); - c_re(W[k]) = cos(twoPiOverN * (double) i * (double) j); - c_im(W[k]) = -sin(twoPiOverN * (double) i * (double) j); - } -} - -/* - * these routines implement a simple reference-count-based - * management of twiddle structures - */ -static fftw_twiddle *twlist = (fftw_twiddle *) 0; -int fftw_twiddle_size = 0; /* total allocated size, for debugging */ - -fftw_twiddle *fftw_create_twiddle(int n, int r, int m) -{ - fftw_twiddle *tw; - FFTW_COMPLEX *W; - - /* lookup for this n in the twiddle list */ - for (tw = twlist; tw; tw = tw->next) - if (tw->n == n && tw->r == r && tw->m == m) { - ++tw->refcnt; - return tw; - } - /* not found --- allocate a new struct twiddle */ - tw = (fftw_twiddle *) fftw_malloc(sizeof(fftw_twiddle)); - W = (FFTW_COMPLEX *) fftw_malloc(m * (r - 1) * sizeof(FFTW_COMPLEX)); - fftw_twiddle_size += n; - - tw->n = n; - tw->r = r; - tw->m = m; - tw->twarray = W; - tw->refcnt = 1; - fftw_compute_twiddle(n, r, m, W); - - /* enqueue the new struct */ - tw->next = twlist; - twlist = tw; - - return tw; -} - -void fftw_destroy_twiddle(fftw_twiddle * tw) -{ - fftw_twiddle **p; - --tw->refcnt; - - if (tw->refcnt == 0) { - /* remove from the list of known twiddle factors */ - for (p = &twlist; p; p = &((*p)->next)) - if (*p == tw) { - *p = tw->next; - fftw_twiddle_size -= tw->n; - fftw_free(tw->twarray); - fftw_free(tw); - return; - } - fftw_die("BUG in fftw_destroy_twiddle\n"); - } -} -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* - * wisdom.c -- manage the wisdom - */ - -#include "fftw.h" -#include -#include -#include - -struct wisdom { - int n; - int flags; - fftw_direction dir; - enum fftw_node_type type; /* this is the wisdom */ - int signature; /* this is the wisdom */ - struct wisdom *next; -}; - -/* list of wisdom */ -static struct wisdom *wisdom_list = (struct wisdom *) 0; - -int fftw_wisdom_lookup(int n, int flags, fftw_direction dir, - enum fftw_node_type *type, - int *signature, int replacep) -{ - struct wisdom *p; - - if (!(flags & FFTW_USE_WISDOM)) - return 0; /* simply ignore if wisdom is disabled */ - - flags |= FFTW_MEASURE; /* always use (only) wisdom from measurements */ - - for (p = wisdom_list; p; p = p->next) { - if (p->n == n && p->flags == flags && p->dir == dir) { - /* found wisdom */ - if (replacep) { - /* replace old wisdom with new */ - p->type = *type; - p->signature = *signature; - } else { - *type = p->type; - *signature = p->signature; - } - return 1; - } - } - - return 0; -} - -void fftw_wisdom_add(int n, int flags, fftw_direction dir, - enum fftw_node_type type, - int signature) -{ - struct wisdom *p; - - if (!(flags & FFTW_USE_WISDOM)) - return; /* simply ignore if wisdom is disabled */ - - if (!(flags & FFTW_MEASURE)) - return; /* only measurements produce wisdom */ - - if (fftw_wisdom_lookup(n, flags, dir, &type, &signature, 1)) - return; /* wisdom overwrote old wisdom */ - - p = (struct wisdom *) fftw_malloc(sizeof(struct wisdom)); - - p->n = n; - p->flags = flags; - p->dir = dir; - p->type = type; - p->signature = signature; - - /* remember this wisdom */ - p->next = wisdom_list; - wisdom_list = p; -} - -void fftw_forget_wisdom(void) -{ - while (wisdom_list) { - struct wisdom *p; - - p = wisdom_list; - wisdom_list = wisdom_list->next; - fftw_free(p); - } -} - -/* - * user-visible routines, to convert wisdom into strings etc. - */ -#define WISDOM_FORMAT_VERSION "FFTW-1.2" - -static void (*emit)(char c, void *data); - -static void emit_string(char *s, void *data) -{ - while (*s) - emit(*s++, data); -} - -static void emit_int(int n, void *data) -{ - char buf[128]; - - sprintf(buf, "%d", n); - emit_string(buf, data); -} - -/* dump wisdom in lisp-like format */ -void fftw_export_wisdom(void (*emitter)(char c, void *), void *data) -{ - struct wisdom *p; - - /* install the output handler */ - emit = emitter; - - emit('(',data); - emit_string(WISDOM_FORMAT_VERSION,data); - - for (p = wisdom_list; p; p = p->next) { - emit(' ',data); /* separator to make the output nicer */ - emit('(',data); - emit_int((int) p->n, data); - emit(' ',data); - emit_int((int) p->flags, data); - emit(' ',data); - emit_int((int) p->dir, data); - emit(' ',data); - emit_int((int) p->type, data); - emit(' ',data); - emit_int((int) p->signature, data); - emit(')',data); - } - emit(')',data); -} - -/* input part */ -static int next_char; -static int (*get_input)(void *data); -static fftw_status input_error; - -static void read_char(void *data) -{ - next_char = get_input(data); - if (next_char == 0 || - next_char == EOF) - input_error = FFTW_FAILURE; -} - -/* skip blanks, newlines, tabs, etc */ -static void eat_blanks(void *data) -{ - while (isspace(next_char)) - read_char(data); -} - -static int read_int(void *data) -{ - int sign = 1; - int n = 0; - - eat_blanks(data); - if (next_char == '-') { - sign = -1; - read_char(data); - eat_blanks(data); - } - - if (!isdigit(next_char)) { - /* error, no digit */ - input_error = FFTW_FAILURE; - return 0; - } - - while (isdigit(next_char)) { - n = n * 10 + (next_char - '0'); - read_char(data); - } - - return sign * n; -} - -#define EXPECT(c) \ -{ \ - eat_blanks(data); \ - if (input_error == FFTW_FAILURE || \ - next_char != c) \ - return FFTW_FAILURE; \ - read_char(data); \ -} - -#define EXPECT_INT(n) \ -{ \ - n = read_int(data); \ - if (input_error == FFTW_FAILURE) \ - return FFTW_FAILURE; \ -} - -#define EXPECT_STRING(s) \ -{ \ - char *s1 = s; \ - while (*s1) { \ - EXPECT(*s1); \ - ++s1; \ - } \ -} - -fftw_status fftw_import_wisdom(int (*g)(void *), void *data) -{ - int n; - int flags; - fftw_direction dir; - enum fftw_node_type type; - int signature; - - get_input = g; - input_error = FFTW_SUCCESS; - - read_char(data); - - eat_blanks(data); - EXPECT('('); - eat_blanks(data); - EXPECT_STRING(WISDOM_FORMAT_VERSION); - eat_blanks(data); - - while (next_char != ')') { - EXPECT('('); - EXPECT_INT(n); - EXPECT_INT(flags); - EXPECT_INT(dir); - EXPECT_INT(type); - EXPECT_INT(signature); - eat_blanks(data); - EXPECT(')'); - - /* the wisdom has been read properly. Add it */ - fftw_wisdom_add(n, flags, dir, type, signature); - - /* prepare for next morsel of wisdom */ - eat_blanks(data); - } - - return FFTW_SUCCESS; -} diff --git a/quantum_espresso/kcp/clib/fftw.h b/quantum_espresso/kcp/clib/fftw.h deleted file mode 100644 index fca5bafdc..000000000 --- a/quantum_espresso/kcp/clib/fftw.h +++ /dev/null @@ -1,460 +0,0 @@ - -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* fftw.h -- system-wide definitions */ -/* $Id: fftw.h,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -#ifndef FFTW_H -#define FFTW_H - -#include -#include - -#ifdef __cplusplus -extern "C" { -#endif /* __cplusplus */ - -/* our real numbers */ -typedef double FFTW_REAL; - -/********************************************* - * Complex numbers and operations - *********************************************/ -typedef struct { - FFTW_REAL re, im; -} FFTW_COMPLEX; - -#define c_re(c) ((c).re) -#define c_im(c) ((c).im) - -typedef enum { - FFTW_FORWARD = -1, FFTW_BACKWARD = 1 -} fftw_direction; - -#ifndef FFTW_1_0_COMPATIBILITY -#define FFTW_1_0_COMPATIBILITY 1 -#endif - -#if FFTW_1_0_COMPATIBILITY -/* backward compatibility with FFTW-1.0 */ -#define REAL FFTW_REAL -#define COMPLEX FFTW_COMPLEX -#endif - -/********************************************* - * Success or failure status - *********************************************/ - -typedef enum { - FFTW_SUCCESS = 0, FFTW_FAILURE = -1 -} fftw_status; - -/********************************************* - * Codelets - *********************************************/ -/* - * There are two kinds of codelets: - * - * NO_TWIDDLE computes the FFT of a certain size, operating - * out-of-place (i.e., take an input and produce a - * separate output) - * - * TWIDDLE like no_twiddle, but operating in place. Moreover, - * multiplies the input by twiddle factors. - */ - -typedef void (notw_codelet) (const FFTW_COMPLEX *, FFTW_COMPLEX *, int, int); -typedef void (twiddle_codelet) (FFTW_COMPLEX *, const FFTW_COMPLEX *, int, - int, int); -typedef void (generic_codelet) (FFTW_COMPLEX *, const FFTW_COMPLEX *, int, - int, int, int); - -/********************************************* - * Configurations - *********************************************/ -/* - * A configuration is a database of all known codelets - */ - -typedef struct { - int size; /* size of the problem */ - int signature; /* unique codelet id */ - notw_codelet *codelet; /* - * pointer to the codelet that solves - * the problem - */ -} config_notw; - -extern config_notw fftw_config_notw[]; -extern config_notw fftwi_config_notw[]; - -typedef struct { - int size; /* size of the problem */ - int signature; /* unique codelet id */ - twiddle_codelet *codelet; -} config_twiddle; - -extern config_twiddle fftw_config_twiddle[]; -extern config_twiddle fftwi_config_twiddle[]; - -extern generic_codelet fftw_twiddle_generic; -extern generic_codelet fftwi_twiddle_generic; -extern char *fftw_version; - -/***************************** - * Plans - *****************************/ -/* - * A plan is a sequence of reductions to compute a FFT of - * a given size. At each step, the FFT algorithm can: - * - * 1) apply a notw codelet, or - * 2) recurse and apply a twiddle codelet, or - * 3) apply the generic codelet. - */ - -enum fftw_node_type { - FFTW_NOTW, FFTW_TWIDDLE, FFTW_GENERIC -}; - -/* structure that contains twiddle factors */ -typedef struct fftw_twiddle_struct { - int n; - int r; - int m; - FFTW_COMPLEX *twarray; - struct fftw_twiddle_struct *next; - int refcnt; -} fftw_twiddle; - -/* structure that holds all the data needed for a given step */ -typedef struct fftw_plan_node_struct { - enum fftw_node_type type; - - union { - /* nodes of type FFTW_NOTW */ - struct { - int size; - notw_codelet *codelet; - } notw; - - /* nodes of type FFTW_TWIDDLE */ - struct { - int size; - twiddle_codelet *codelet; - fftw_twiddle *tw; - struct fftw_plan_node_struct *recurse; - } twiddle; - - /* nodes of type FFTW_GENERIC */ - struct { - int size; - generic_codelet *codelet; - fftw_twiddle *tw; - struct fftw_plan_node_struct *recurse; - } generic; - - } nodeu; - - int refcnt; -} fftw_plan_node; - -struct fftw_plan_struct { - int n; - fftw_direction dir; - fftw_plan_node *root; - - double cost; - int flags; - - enum fftw_node_type wisdom_type; - int wisdom_signature; - - struct fftw_plan_struct *next; - int refcnt; -}; - -/* a plan is just an array of instructions */ -typedef struct fftw_plan_struct *fftw_plan; - -/* flags for the planner */ -#define FFTW_ESTIMATE (0) -#define FFTW_MEASURE (1) - -#define FFTW_IN_PLACE (8) -#define FFTW_USE_WISDOM (16) - -extern fftw_plan fftw_create_plan(int n, fftw_direction dir, int flags); -extern fftw_twiddle *fftw_create_twiddle(int n, int r, int m); -extern void fftw_destroy_twiddle(fftw_twiddle * tw); -extern void fftw_print_plan(fftw_plan plan); -extern void fftw_destroy_plan(fftw_plan plan); -extern void fftw_naive(int n, FFTW_COMPLEX *in, FFTW_COMPLEX *out); -extern void fftwi_naive(int n, FFTW_COMPLEX *in, FFTW_COMPLEX *out); -void fftw(fftw_plan plan, int howmany, FFTW_COMPLEX *in, int istride, - int idist, FFTW_COMPLEX *out, int ostride, int odist); -extern double fftw_measure_runtime(fftw_plan plan); -extern void fftw_die(char *s); -extern void *fftw_malloc(size_t n); -extern void fftw_free(void *p); -extern void fftw_check_memory_leaks(void); -extern void fftw_strided_copy(int, FFTW_COMPLEX *, int, FFTW_COMPLEX *); -extern void fftw_executor_simple(int, const FFTW_COMPLEX *, FFTW_COMPLEX *, - fftw_plan_node *, int, int); -extern void *(*fftw_malloc_hook) (size_t n); -extern void (*fftw_free_hook) (void *p); - -/* Wisdom: */ -#define FFTW_HAS_WISDOM /* define this symbol so that we know we are using - a version of FFTW with wisdom */ -extern void fftw_forget_wisdom(void); -extern void fftw_export_wisdom(void (*emitter)(char c, void *), void *data); -extern fftw_status fftw_import_wisdom(int (*g)(void *), void *data); -extern void fftw_export_wisdom_to_file(FILE *output_file); -extern fftw_status fftw_import_wisdom_from_file(FILE *input_file); -extern char *fftw_export_wisdom_to_string(void); -extern fftw_status fftw_import_wisdom_from_string(const char *input_string); - -/* - * define symbol so we know this function is available (it is not in - * older FFTWs) - */ -#define FFTW_HAS_FPRINT_PLAN -extern void fftw_fprint_plan(FILE * f, fftw_plan plan); - -/* Returns 1 if FFTW is working. Otherwise, its value is undefined: */ -#define is_fftw_working() 1 - -/***************************** - * N-dimensional code - *****************************/ -typedef struct { - int is_in_place; /* 1 if for in-place FFT's, 0 otherwise */ - int rank; /* - * the rank (number of dimensions) of the - * array to be FFT'ed - */ - int *n; /* - * the dimensions of the array to the - * FFT'ed - */ - int *n_before; /* - * n_before[i] = product of n[j] for j < i - */ - int *n_after; /* n_after[i] = product of n[j] for j > i */ - fftw_plan *plans; /* fftw plans for each dimension */ - FFTW_COMPLEX *work; /* - * work array for FFT when doing - * "in-place" FFT - */ -} fftwnd_aux_data; - -typedef fftwnd_aux_data *fftwnd_plan; - -/* Initializing the FFTWND Auxiliary Data */ -fftwnd_plan fftw2d_create_plan(int nx, int ny, fftw_direction dir, int flags); -fftwnd_plan fftw3d_create_plan(int nx, int ny, int nz, - fftw_direction dir, int flags); -fftwnd_plan fftwnd_create_plan(int rank, const int *n, fftw_direction dir, - int flags); - -/* Freeing the FFTWND Auxiliary Data */ -void fftwnd_destroy_plan(fftwnd_plan plan); - -/* Computing the N-Dimensional FFT */ -void fftwnd(fftwnd_plan plan, int howmany, - FFTW_COMPLEX *in, int istride, int idist, - FFTW_COMPLEX *out, int ostride, int odist); - -/****************************************************************************/ -/********************************** Timers **********************************/ -/****************************************************************************/ - -/* - * Here, you can use all the nice timers available in your machine. - */ - -/* - * - Things you should define to include your own clock: - - fftw_time -- the data type used to store a time - - extern fftw_time fftw_get_time(void); - -- a function returning the current time. (We have - implemented this as a macro in most cases.) - - extern fftw_time fftw_time_diff(fftw_time t1, fftw_time t2); - -- returns the time difference (t1 - t2). - If t1 < t2, it may simply return zero (although this - is not required). (We have implemented this as a macro - in most cases.) - - extern double fftw_time_to_sec(fftw_time t); - -- returns the time t expressed in seconds, as a double. - (Implemented as a macro in most cases.) - - FFTW_TIME_MIN -- a double-precision macro holding the minimum - time interval (in seconds) for accurate time measurements. - This should probably be at least 100 times the precision of - your clock (we use even longer intervals, to be conservative). - This will determine how long the planner takes to measure - the speeds of different possible plans. - - Bracket all of your definitions with an appropriate #ifdef so that - they will be enabled on your machine. If you do add your own - high-precision timer code, let us know (at fftw@theory.lcs.mit.edu). - - Only declarations should go in this file. Any function definitions - that you need should go into timer.c. -*/ - -/* define a symbol so that we know that we have the fftw_time_diff - function/macro (it did not exist prior to FFTW 1.2) */ -#define FFTW_HAS_TIME_DIFF - -#ifdef SOLARIS - -/* we use the nanosecond virtual timer */ -#include - -typedef hrtime_t fftw_time; - -#define fftw_get_time() gethrtime() -#define fftw_time_diff(t1,t2) ((t1) - (t2)) -#define fftw_time_to_sec(t) ((double) t / 1.0e9) - -/* - * a measurement is valid if it runs for at least - * FFTW_TIME_MIN seconds. - */ -#define FFTW_TIME_MIN (1.0e-4) /* for Solaris nanosecond timer */ - -#endif /* SOLARIS */ - -#if defined(MAC) || defined(macintosh) - -/* Use Macintosh Time Manager routines (maximum resolution is about 20 - microseconds). */ - -typedef struct fftw_time_struct { - unsigned long hi,lo; -} fftw_time; - -extern fftw_time get_Mac_microseconds(void); - -#define fftw_get_time() get_Mac_microseconds() - -/* define as a function instead of a macro: */ -extern fftw_time fftw_time_diff(fftw_time t1, fftw_time t2); - -#define fftw_time_to_sec(t) ((t).lo * 1.0e-6 + 4294967295.0e-6 * (t).hi) - -/* very conservative, since timer should be accurate to 20e-6: */ -/* (although this seems not to be the case in practice) */ -#define FFTW_TIME_MIN (5.0e-2) /* for MacOS Time Manager timer */ - -#endif /* Macintosh */ - -#ifdef __WIN32__ - -#include - -typedef unsigned long fftw_time; -extern unsigned long GetPerfTime(void); -extern double GetPerfSec(double ticks); - -#define fftw_get_time() GetPerfTime() -#define fftw_time_diff(t1,t2) ((t1) - (t2)) -#define fftw_time_to_sec(t) GetPerfSec(t) - -#define FFTW_TIME_MIN (5.0e-2) /* for Win32 timer */ -#endif /* __WIN32__ */ - -#if defined(_CRAYMPP) /* Cray MPP system */ - -double SECONDR(void); /* - * I think you have to link with -lsci to - * get this - */ - -typedef double fftw_time; -#define fftw_get_time() SECONDR() -#define fftw_time_diff(t1,t2) ((t1) - (t2)) -#define fftw_time_to_sec(t) (t) - -#define FFTW_TIME_MIN (1.0e-1) /* for Cray MPP SECONDR timer */ - -#endif /* _CRAYMPP */ - -/*********************************************** - * last resort: good old Unix clock() - ***********************************************/ -#ifndef FFTW_TIME_MIN -#include - -typedef clock_t fftw_time; - -#ifndef CLOCKS_PER_SEC -#ifdef sun - /* stupid sunos4 prototypes */ -#define CLOCKS_PER_SEC 1000000 -extern long clock(void); -#else /* not sun, we don't know CLOCKS_PER_SEC */ -#error Please define CLOCKS_PER_SEC -#endif -#endif - -#if defined(__QK_USER__) -#define fftw_get_time() ((long) (dclock() * 1000000.0L)) -#else -#define fftw_get_time() clock() -#endif -#define fftw_time_diff(t1,t2) ((t1) - (t2)) -#define fftw_time_to_sec(t) (((double) (t)) / CLOCKS_PER_SEC) - -/* - * ***VERY*** conservative constant: this says that a - * measurement must run for 200ms in order to be valid. - * You had better check the manual of your machine - * to discover if it can do better than this - */ -#define FFTW_TIME_MIN (2.0e-1) /* for default clock() timer */ - -#endif /* UNIX clock() */ - -/****************************************************************************/ - -#ifdef __cplusplus -} /* extern "C" */ -#endif /* __cplusplus */ - -#endif /* FFTW_H */ - diff --git a/quantum_espresso/kcp/clib/indici.c b/quantum_espresso/kcp/clib/indici.c deleted file mode 100644 index c55074bee..000000000 --- a/quantum_espresso/kcp/clib/indici.c +++ /dev/null @@ -1,182 +0,0 @@ -/* - Copyright (C) 2002 FPMD group - This file is distributed under the terms of the - GNU General Public License. See the file `License' - in the root directory of the present distribution, - or http://www.gnu.org/copyleft/gpl.txt . -*/ - -#include -#include - -#include "c_defs.h" - -#define MAX_INDEX 32768 - -struct Index { unsigned char i[8]; } ; - -static struct Index * P_Index; -static int * P_IndexIndex; - -static struct Index * LN; -static int * IG; -static int LN_SIZE; - -int IndexCmp( struct Index * A, struct Index * B) -{ - int i; - - for(i = 7; i>=0 ; i--) { - if(A->i[i] > B->i[i] ) { - return +1; - } - else if(A->i[i] < B->i[i]) { - return -1; - } - } - - return 0; -} - - -int index_comp(unsigned i,unsigned j) -{ -int cmp; -cmp = IndexCmp(P_Index + i, P_Index + j); -if ( cmp > 0 ) return 1; -else if ( cmp == 0 ) return 0; -return -1; -} - -int index_swap(unsigned i,unsigned j) -{ -static struct Index tmp; -static int itmp; - -tmp = P_Index[j] ; -P_Index[j] = P_Index[i] ; -P_Index[i] = tmp ; - -itmp = P_IndexIndex[j] ; -P_IndexIndex[j] = P_IndexIndex[i] ; -P_IndexIndex[i] = itmp ; - -return 1; -} - - -int IndexSort(struct Index * A, int * IndexIndex, int n) -{ - void Qsort(unsigned n,int (*comp)(),int (*swap)()); - P_Index = A; - P_IndexIndex = IndexIndex; - Qsort((unsigned)n,index_comp,index_swap); - return 1; -} - - -int IndexSet( struct Index * A, int I1, int I2, int I3 ) -{ - unsigned int himask = 0xFF00; - unsigned int lomask = 0x00FF; - - if(abs(I1)>=MAX_INDEX || abs(I2)>=MAX_INDEX || abs(I3)>=MAX_INDEX ) { - return -1; - } - - if(I1<0) I1 += MAX_INDEX; - if(I2<0) I2 += MAX_INDEX; - if(I3<0) I3 += MAX_INDEX; - - - A->i[7] = (unsigned char ) 0; - A->i[6] = (unsigned char ) 0; - A->i[5] = (unsigned char ) ((himask & (unsigned int) I1)>>8); - A->i[4] = (unsigned char ) ( lomask & (unsigned int) I1); - A->i[3] = (unsigned char ) ((himask & (unsigned int) I2)>>8); - A->i[2] = (unsigned char ) ( lomask & (unsigned int) I2); - A->i[1] = (unsigned char ) ((himask & (unsigned int) I3)>>8); - A->i[0] = (unsigned char ) ( lomask & (unsigned int) I3); - return 0; -} - -int IndexShow(struct Index A) -{ - int i; - for(i=7;i>=0;i--) printf("%2x",A.i[i]); - printf("\n"); - return 0; -} - -int IndexFind(struct Index * A, int n, struct Index * B) -{ - int lb, ub, i, cmp; - - lb = 0; - ub = n-1; - i = lb; - - while(lb<(ub-1)) { - i = lb + (ub - lb)/2; - cmp = IndexCmp(B,&A[i]); - if(cmp>0) { - lb = i; - } else if(cmp<0) { - ub = i; - } else { - ub = lb = i; - } - } - if(lb LN_SIZE) { - exit(*ig); - } - IndexSet( &LN[*ig-1], *IRI1, *IRI2, *IRI3 ); - IG[*ig-1] = *ig; - -} - -int F77_FUNC_(ln_activate,LN_ACTIVATE)() -{ - IndexSort(LN,IG,LN_SIZE); - return 0; -} - -int F77_FUNC_(ln_ind,LN_IND)(int * IRI1, int * IRI2, int * IRI3) -{ - static struct Index B; - static int ib; - - IndexSet(&B,*IRI1,*IRI2,*IRI3); - ib = IndexFind(LN,LN_SIZE,&B); - if(ib>=0) return IG[ib]; - return -1; -} diff --git a/quantum_espresso/kcp/clib/konst.h b/quantum_espresso/kcp/clib/konst.h deleted file mode 100644 index 4275127ad..000000000 --- a/quantum_espresso/kcp/clib/konst.h +++ /dev/null @@ -1,1325 +0,0 @@ -/* - Copyright (C) 2002 FPMD group - This file is distributed under the terms of the - GNU General Public License. See the file `License' - in the root directory of the present distribution, - or http://www.gnu.org/copyleft/gpl.txt . -*/ - -/* - * Copyright (c) 1997 Massachusetts Institute of Technology - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to use, copy, modify, and distribute the Software without - * restriction, provided the Software, including any modified copies made - * under this license, is not distributed for a fee, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY BE LIABLE - * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - * Except as contained in this notice, the name of the Massachusetts - * Institute of Technology shall not be used in advertising or otherwise - * to promote the sale, use or other dealings in this Software without - * prior written authorization from the Massachusetts Institute of - * Technology. - * - */ - -/* $Id: konst.h,v 1.1.1.1 2010/04/21 09:20:38 daboi Exp $ */ - -/* - * this file contains many floating-point constants in with 40 digits - * of precision. - * - * The constants are sin(pi/2 * i / j) for all relatively prime i and - * j, i < j, 1 <= i,j <= 64. - * - * These constants should be enough to compute any FFT of radix up to - * 64. - * - * The name of the constant is FFTW_K + the first nine digits - * of the constant. - */ - -/* First, a few hand-added constants for the hard-coded - small-prime routines from Nussbaumer: */ - -#define FFTW_K1_499999999 1.5 -#define FFTW_K1_500000000 1.5 -#define FFTW_K1_538841768 1.538841768587626701285145288018454912004 -#define FFTW_K363271264 0.3632712640026804429477333787403093748078 -#define FFTW_K559016994 0.5590169943749474241022934171828190588601 -#define FFTW_K1_250000000 1.25 - -/* Now, the sin(pi/2 * i / j) constants: */ - -#define FFTW_K024541228 0.02454122852291228803173452945928292506546 -#define FFTW_K024930691 0.02493069173807287528153113172264899347886 -#define FFTW_K025332714 0.02533271431318792626715014547444662011749 -#define FFTW_K025747913 0.02574791365498855709400812038783297868791 -#define FFTW_K026176948 0.02617694830787315261061168555411266379339 -#define FFTW_K026620521 0.02662052143777476692526640921682759077404 -#define FFTW_K027079384 0.02707938467613449510053273360969360284220 -#define FFTW_K027554342 0.02755434236816199651390270841655868519675 -#define FFTW_K028046256 0.02804625627586895837690032595826009306718 -#define FFTW_K028556050 0.02855605079369625384817304701047898542810 -#define FFTW_K029084718 0.02908471874311140688857775001359604786349 -#define FFTW_K029633327 0.02963332782255974048476287916054822494737 -#define FFTW_K030203027 0.03020302780088884696469629411308802751337 -#define FFTW_K030795058 0.03079505855617035387456489497623829357293 -#define FFTW_K031410759 0.03141075907812829383918367381782938975792 -#define FFTW_K032051577 0.03205157757165517423355052534564389799926 -#define FFTW_K032719082 0.03271908282177614206365992631728812611496 -#define FFTW_K033414977 0.03341497700767457087526435763745330726371 -#define FFTW_K034141110 0.03414111018596789528264900547320423176481 -#define FFTW_K034899496 0.03489949670250097164599518162533293735482 -#define FFTW_K035692333 0.03569233383898045576004959432178492172990 -#define FFTW_K036522023 0.03652202305765883496849494009839034350519 -#define FFTW_K037391194 0.03739119427632562109582828094423927302680 -#define FFTW_K038302733 0.03830273369003534880305423883905735073019 -#define FFTW_K039259815 0.03925981575906860902080336379833358968018 -#define FFTW_K040265940 0.04026594010941514336195447585729928046597 -#define FFTW_K041324974 0.04132497424881321193833038091793631399735 -#define FFTW_K042441203 0.04244120319614830587806918753450720196596 -#define FFTW_K043619387 0.04361938736533599978175307720994442711267 -#define FFTW_K044864830 0.04486483035051492545809033680196091713385 -#define FFTW_K046183458 0.04618345864573959194897001797523264272366 -#define FFTW_K047581915 0.04758191582374229744978724403148683485453 -#define FFTW_K049067674 0.04906767432741801425495497694268265831474 -#define FFTW_K049845885 0.04984588566069716295040714449394960588257 -#define FFTW_K050649168 0.05064916883871271227875185748519952674658 -#define FFTW_K051478754 0.05147875477034653381895970590186645379975 -#define FFTW_K052335956 0.05233595624294383272211862960907841873101 -#define FFTW_K053222174 0.05322217484217865465892175510110189963137 -#define FFTW_K054138908 0.05413890858541752614990832597459869261258 -#define FFTW_K055087760 0.05508776035586544311472166247114340920868 -#define FFTW_K056070447 0.05607044723719178819071956605945621966287 -#define FFTW_K057088810 0.05708881086276798374853641012211283431406 -#define FFTW_K058144828 0.05814482891047582853874801684707152363411 -#define FFTW_K059240627 0.05924062789371428721946459254200354944517 -#define FFTW_K060378497 0.06037849742228605343802003158079274972614 -#define FFTW_K061560906 0.06156090613394283745053467245960896573106 -#define FFTW_K062790519 0.06279051952931337607617822456563113312248 -#define FFTW_K064070219 0.06407021998071292342141653382538247166027 -#define FFTW_K065403129 0.06540312923014306681531555877517544144063 -#define FFTW_K066792633 0.06679263374512155398142808167595869283750 -#define FFTW_K068242413 0.06824241336467097592118847902245902393309 -#define FFTW_K069756473 0.06975647374412530077595883519414332860090 -#define FFTW_K071339183 0.07133918319923234032733775265783793276596 -#define FFTW_K072995314 0.07299531466090752529007863065550023575340 -#define FFTW_K073564563 0.07356456359966742352946562157523432181330 -#define FFTW_K074730093 0.07473009358642425429093974573476665337355 -#define FFTW_K075933114 0.07593311422524628957116630520938078420417 -#define FFTW_K076549252 0.07654925283649564686667574398250835581272 -#define FFTW_K077175462 0.07717546212664635123484042864263765610620 -#define FFTW_K078459095 0.07845909572784494503296024599345969868195 -#define FFTW_K079786105 0.07978610555308308193969075555986694480713 -#define FFTW_K080466568 0.08046656871672588043623283523605058814445 -#define FFTW_K081158725 0.08115872552743127025162162134332521448309 -#define FFTW_K082579345 0.08257934547233232460034393423744022769858 -#define FFTW_K084050524 0.08405052492924754505111842927022800243161 -#define FFTW_K084805924 0.08480592447550919108850144833189828879530 -#define FFTW_K085575008 0.08557500847883974285443620323245675643992 -#define FFTW_K087155742 0.08715574274765817355806427083747355137770 -#define FFTW_K088795895 0.08879589532293479712937356569797262395585 -#define FFTW_K089639308 0.08963930890343349976547043684523300801112 -#define FFTW_K090498875 0.09049887582963782754801984544037132033177 -#define FFTW_K092268359 0.09226835946330199523965110715450648036301 -#define FFTW_K094108313 0.09410831331851431847326684888547588974551 -#define FFTW_K095056043 0.09505604330418266363210430415931109734405 -#define FFTW_K096023025 0.09602302590768176305366495784331455593243 -#define FFTW_K098017140 0.09801714032956060199419556388864184586113 -#define FFTW_K099567846 0.09956784659581665718622086379104323229043 -#define FFTW_K100095691 0.1000956916240983451177672842105318430707 -#define FFTW_K101168321 0.1011683219874321777860407155854228233862 -#define FFTW_K102264148 0.1022641489420342371412709255326958104552 -#define FFTW_K102820997 0.1028209971373604031806320868342052679487 -#define FFTW_K104528463 0.1045284632676534713998341548024981190806 -#define FFTW_K106293485 0.1062934856473654067394496659573273763461 -#define FFTW_K106895121 0.1068951215651127844145864534883570813393 -#define FFTW_K108119018 0.1081190184239417630308083269836870058627 -#define FFTW_K109371208 0.1093712083778743869853209878362391474250 -#define FFTW_K110008220 0.1100082209940792950410059556544367917515 -#define FFTW_K111964476 0.1119644761033078584687059352720242032581 -#define FFTW_K113991409 0.1139914098905406252992389774304161634389 -#define FFTW_K114683425 0.1146834253984004343275380130470373859191 -#define FFTW_K116092914 0.1160929141252302296756665233807114688534 -#define FFTW_K117537397 0.1175373974578376441055682668404856236723 -#define FFTW_K118273170 0.1182731709213658039500508663092468403330 -#define FFTW_K120536680 0.1205366802553230533490676874525435822736 -#define FFTW_K122410675 0.1224106751992161984987044741509457875752 -#define FFTW_K122888290 0.1228882906647141222666013492105836037724 -#define FFTW_K123692631 0.1236926312693476160249117865542554850472 -#define FFTW_K124343704 0.1243437046474851743089045920543714991045 -#define FFTW_K125333233 0.1253332335643042453731187598165087939429 -#define FFTW_K126338594 0.1263385949221291894904811173099765440334 -#define FFTW_K127017819 0.1270178197468787473745739656594515054988 -#define FFTW_K127877161 0.1278771616845060105905627222310365268112 -#define FFTW_K128398355 0.1283983551465509444517094699699360502290 -#define FFTW_K130526192 0.1305261922200515915484062278954890101937 -#define FFTW_K132725527 0.1327255272837219725719487965069416073282 -#define FFTW_K133286955 0.1332869553737788428006966907749246477199 -#define FFTW_K134233265 0.1342332658176554760370186415106700491221 -#define FFTW_K135000013 0.1350000138532901039432785388369663768285 -#define FFTW_K136166649 0.1361666490962465907607258333878729914503 -#define FFTW_K137353557 0.1373535578184081750962293169450719150194 -#define FFTW_K138156354 0.1381563549518821982285452297396081025637 -#define FFTW_K139173100 0.1391731009600654441124966633011052754559 -#define FFTW_K139790339 0.1397903395354994779261757065854075728448 -#define FFTW_K142314838 0.1423148382732851404437926686163696687910 -#define FFTW_K144931859 0.1449318593072467375406813031778968151579 -#define FFTW_K145601167 0.1456011677350048723993394166411729066078 -#define FFTW_K146730474 0.1467304744553617516588501296467178197062 -#define FFTW_K147646564 0.1476465640024812314941125712317733092252 -#define FFTW_K149042266 0.1490422661761744469293547152772175569096 -#define FFTW_K150464503 0.1504645032747830094280823110511156957377 -#define FFTW_K151427777 0.1514277775045766636574676467272196523057 -#define FFTW_K152649284 0.1526492842188744985382798067894893515166 -#define FFTW_K153391654 0.1533916548786853726487552712140729945838 -#define FFTW_K153890576 0.1538905767040617933823856197344647265033 -#define FFTW_K156434465 0.1564344650402308690101053194671668923139 -#define FFTW_K159063496 0.1590634960190720532010083008860924909668 -#define FFTW_K159599895 0.1595998950333792234665111684813029413298 -#define FFTW_K160411280 0.1604112808577602403702298186769163785229 -#define FFTW_K161781996 0.1617819965527647265442600643364213138441 -#define FFTW_K162895473 0.1628954733945887394808006397082655595151 -#define FFTW_K164594590 0.1645945902807338941436520590879384195121 -#define FFTW_K166329354 0.1663293545831300328593301814704603689804 -#define FFTW_K167506223 0.1675062233047364080900562064755421518657 -#define FFTW_K169000820 0.1690008203218490740930355553844306062607 -#define FFTW_K169910385 0.1699103850286666621064277790456711366916 -#define FFTW_K170522192 0.1705221926326237844029624838779488814032 -#define FFTW_K170961888 0.1709618887603012263636423572082635319663 -#define FFTW_K173648177 0.1736481776669303488517166267693147960003 -#define FFTW_K176419766 0.1764197662578084553148843684896065607169 -#define FFTW_K176890275 0.1768902751225729626566607665047223570045 -#define FFTW_K177553196 0.1775531962543032681443899399620956620757 -#define FFTW_K178556894 0.1785568947986366480137183675903137598662 -#define FFTW_K179280758 0.1792807588107356641700983494684076980694 -#define FFTW_K180255037 0.1802550378139057401698714976814164183253 -#define FFTW_K181636850 0.1816368509794364397019702088022006165809 -#define FFTW_K182235525 0.1822355254921474566025733714374098829561 -#define FFTW_K183749517 0.1837495178165703315744088396207275824891 -#define FFTW_K185288724 0.1852887240871143248809536106633607262036 -#define FFTW_K185911607 0.1859116071629145811067063130899319181384 -#define FFTW_K187381314 0.1873813145857246305425507344472914693386 -#define FFTW_K188445323 0.1884453238783182943037067928415765684352 -#define FFTW_K189251244 0.1892512443604102036174993987003794963886 -#define FFTW_K190391109 0.1903911091646683687060801363670975059804 -#define FFTW_K191158628 0.1911586287013723021585445882022354575073 -#define FFTW_K191710631 0.1917106319237384206124231501600573332271 -#define FFTW_K195090322 0.1950903220161282678482848684770222409276 -#define FFTW_K198146143 0.1981461431993975833714472747416084106726 -#define FFTW_K198590466 0.1985904666457454649825982338832459220562 -#define FFTW_K199185985 0.1991859851038360988453201397948964743053 -#define FFTW_K200025693 0.2000256937760444275302791839461314924582 -#define FFTW_K201298520 0.2012985200886600791415289683390134818534 -#define FFTW_K202217572 0.2022175723320379311800611091313733641995 -#define FFTW_K203456013 0.2034560130526337898780287220615784267778 -#define FFTW_K204552066 0.2045520661262008192326881916211885127837 -#define FFTW_K205215342 0.2052153421956342913242144590999144259414 -#define FFTW_K205978618 0.2059786187410983794560099523629392761584 -#define FFTW_K207911690 0.2079116908177593371017422844051251662165 -#define FFTW_K209881102 0.2098811020648475664288490675128024697633 -#define FFTW_K210679269 0.2106792699957263203605157515044546621513 -#define FFTW_K211382623 0.2113826236296243207085529083770849382000 -#define FFTW_K212565289 0.2125652895529766738829101740168861225007 -#define FFTW_K213933083 0.2139330832064974399064939935426070792397 -#define FFTW_K214970440 0.2149704402110240671819534770820757537978 -#define FFTW_K216439613 0.2164396139381028797595536696179407286733 -#define FFTW_K217430175 0.2174301755815569683483334697013744130646 -#define FFTW_K218143241 0.2181432413965425520241529749432464294629 -#define FFTW_K218681091 0.2186810912063758065815451063216740840845 -#define FFTW_K219101240 0.2191012401568697972277375474973577988483 -#define FFTW_K222520933 0.2225209339563144042889025644967947594663 -#define FFTW_K226048070 0.2260480705837348469528011887515101798955 -#define FFTW_K226496767 0.2264967674257643803937744783433568234439 -#define FFTW_K227076263 0.2270762630343732075856966925770880866157 -#define FFTW_K227853508 0.2278535089031375755972602599574454122751 -#define FFTW_K228950549 0.2289505499501340769087585503449667718434 -#define FFTW_K229687742 0.2296877421317955508629587031855238968422 -#define FFTW_K230615870 0.2306158707424401784501983492929391024576 -#define FFTW_K231820150 0.2318201502675282692634378233857375282786 -#define FFTW_K233445363 0.2334453638559054117677444302028708487857 -#define FFTW_K234886045 0.2348860457809836794344735309665486913327 -#define FFTW_K235758935 0.2357589355094272282505103203014875844263 -#define FFTW_K236764420 0.2367644204664467369934485993258031509443 -#define FFTW_K237326699 0.2373266998711148178062315108453953280872 -#define FFTW_K239315664 0.2393156642875577671487537262602118952031 -#define FFTW_K241337891 0.2413378912997056469191530270185379193926 -#define FFTW_K241921895 0.2419218955996677225604423741003529652950 -#define FFTW_K242980179 0.2429801799032638899482741620774711183209 -#define FFTW_K243913720 0.2439137201083771486571152797107074577474 -#define FFTW_K245485487 0.2454854871407991489222909177963705562718 -#define FFTW_K246757397 0.2467573976902936383701134811922532799265 -#define FFTW_K247306500 0.2473065005542155019896448542641991067685 -#define FFTW_K248689887 0.2486898871648547882422837460064479684175 -#define FFTW_K249776478 0.2497764781672268499591643699129970495240 -#define FFTW_K250652532 0.2506525322587205393148020352659594949328 -#define FFTW_K251978061 0.2519780613851251944452590335089271028724 -#define FFTW_K252933382 0.2529333823916807465585823300480383661425 -#define FFTW_K253654583 0.2536545839095073878469674038123833536072 -#define FFTW_K254218334 0.2542183341934869302181946799708040944181 -#define FFTW_K254671120 0.2546711202412287479786428236449119383343 -#define FFTW_K258819045 0.2588190451025207623488988376240483283490 -#define FFTW_K263102564 0.2631025642275212511495477637383127381948 -#define FFTW_K263587166 0.2635871660690676452850324043464993370036 -#define FFTW_K264195401 0.2641954018712860094526428604782256719351 -#define FFTW_K264981502 0.2649815021966616823313383138368166609255 -#define FFTW_K266036845 0.2660368455666751073822760245929750947101 -#define FFTW_K266712757 0.2667127574748983863252865151164363940421 -#define FFTW_K267528338 0.2675283385292208211946262052833413401837 -#define FFTW_K268531867 0.2685318674743767514444181482437582231209 -#define FFTW_K269796771 0.2697967711570242712453285226025705364752 -#define FFTW_K270840468 0.2708404681430051173825276728313745513853 -#define FFTW_K271440449 0.2714404498650742533437874012956754728913 -#define FFTW_K272103464 0.2721034648453350043477078027786879151380 -#define FFTW_K273662990 0.2736629900720828635390779354368134316248 -#define FFTW_K275096112 0.2750961127544780934575888098987339713079 -#define FFTW_K275637355 0.2756373558169991856499715746113041477124 -#define FFTW_K276835511 0.2768355114248493876262772692158242788007 -#define FFTW_K278217463 0.2782174639164526345546182439651524382026 -#define FFTW_K278991106 0.2789911060392292518532508950584493874953 -#define FFTW_K279485634 0.2794856348516094581371390778942150551101 -#define FFTW_K281732556 0.2817325568414296977114179153466168990357 -#define FFTW_K284015344 0.2840153447039226174443896906991853505161 -#define FFTW_K284527586 0.2845275866310324418705029934626948723724 -#define FFTW_K285336224 0.2853362242491053090667449649265463487414 -#define FFTW_K286803232 0.2868032327110902531032801731671579370202 -#define FFTW_K288099099 0.2880990993652375689266931264899107353051 -#define FFTW_K288691947 0.2886919473396210094452906211327828963305 -#define FFTW_K290284677 0.2902846772544623676361923758173952746914 -#define FFTW_K292056770 0.2920567706369758204437390072356032915605 -#define FFTW_K292822771 0.2928227712765503799533928156354034200205 -#define FFTW_K293522573 0.2935225731039347541446271583891850734356 -#define FFTW_K294755174 0.2947551744109042168307729819601909732057 -#define FFTW_K296275580 0.2962755808856339773191629695178234257829 -#define FFTW_K297503053 0.2975030538552029766545272343836168141915 -#define FFTW_K298514811 0.2985148110016945481161981570821534393776 -#define FFTW_K299363122 0.2993631229733579540081126169766754622404 -#define FFTW_K300705799 0.3007057995042731216225471359310733948570 -#define FFTW_K301720598 0.3017205985951923159681622307862467380143 -#define FFTW_K302514550 0.3025145508810757874902189631473865052465 -#define FFTW_K303152674 0.3031526741130434999087207406797943019405 -#define FFTW_K303676745 0.3036767451096147308106077254328536766584 -#define FFTW_K304114832 0.3041148323275178942148291736201549317983 -#define FFTW_K309016994 0.3090169943749474241022934171828190588601 -#define FFTW_K313681740 0.3136817403988914766564788459941003099933 -#define FFTW_K314076712 0.3140767120219488154165234158283970375988 -#define FFTW_K314544756 0.3145447561516136728017265820394227561963 -#define FFTW_K315108218 0.3151082180236206884739997772913635477845 -#define FFTW_K315799587 0.3157995876150249155281530748686182849130 -#define FFTW_K316667993 0.3166679938014724990938464926070593078727 -#define FFTW_K317791419 0.3177914195819016261653495764591287854944 -#define FFTW_K318486650 0.3184866502516844273818275725699376031734 -#define FFTW_K319301530 0.3193015301359799731972335422795273269786 -#define FFTW_K320269853 0.3202698538628376311280745853886316208567 -#define FFTW_K321439465 0.3214394653031615807010576240789015860584 -#define FFTW_K322880404 0.3228804047714462166317487451277830603309 -#define FFTW_K323437987 0.3234379871492380979025474833971787876719 -#define FFTW_K324699469 0.3246994692046834874075727165465870379355 -#define FFTW_K326202789 0.3262027892208693378961868432839339339875 -#define FFTW_K327067963 0.3270679633174216363417493701584524078072 -#define FFTW_K328024857 0.3280248578395690989840510558626828114495 -#define FFTW_K328542381 0.3285423819108347330233652537686684647414 -#define FFTW_K330279061 0.3302790619551670817748776125965723703131 -#define FFTW_K332354799 0.3323547994796596645618863109731018350510 -#define FFTW_K333139794 0.3331397947420575668009190940208649269071 -#define FFTW_K333806859 0.3338068592337709288283112855367461082971 -#define FFTW_K334879612 0.3348796121709861519581150708478901575074 -#define FFTW_K336049393 0.3360493932154301264002038813057431950992 -#define FFTW_K336889853 0.3368898533922200506892532126191475704777 -#define FFTW_K338016878 0.3380168784085027582801184913755462388755 -#define FFTW_K338737920 0.3387379202452913812222843549667764425455 -#define FFTW_K339238866 0.3392388661180302873463200874425587375464 -#define FFTW_K342020143 0.3420201433256687330440996146822595807630 -#define FFTW_K344846302 0.3448463026279704341701015644183431449540 -#define FFTW_K345365054 0.3453650544213076319521147752559623304845 -#define FFTW_K346117057 0.3461170570774929764682149949282125051507 -#define FFTW_K347305252 0.3473052528448202855418543554810122464619 -#define FFTW_K348201635 0.3482016354343987872360551297332894837702 -#define FFTW_K349464179 0.3494641795990983367054385007091167841299 -#define FFTW_K350637555 0.3506375551927543753252906248597856202531 -#define FFTW_K351374824 0.3513748240813427048873232705101784160143 -#define FFTW_K352250047 0.3522500479212335065317523197587126718279 -#define FFTW_K352752086 0.3527520865490947802113466208444908167556 -#define FFTW_K354604887 0.3546048870425356259696378926000184743163 -#define FFTW_K356621532 0.3566215326623130243556992802935517782847 -#define FFTW_K357230889 0.3572308898011327811970544491665739772808 -#define FFTW_K358367949 0.3583679495453002734841377894134668341915 -#define FFTW_K359407772 0.3594077728375128365978369922382092764921 -#define FFTW_K359895036 0.3598950365349881487751045723267564202023 -#define FFTW_K361241666 0.3612416661871529487447145961837001637245 -#define FFTW_K362807705 0.3628077053506410086067015071723732383626 -#define FFTW_K363507970 0.3635079705638298484830911630066710945698 -#define FFTW_K364160575 0.3641605752528221783209334379434903294574 -#define FFTW_K365341024 0.3653410243663950145447379989297688024329 -#define FFTW_K366854218 0.3668542188130565156995449132831306900092 -#define FFTW_K368124552 0.3681245526846779591569471474929608308988 -#define FFTW_K369206147 0.3692061473126844511998878300716878438711 -#define FFTW_K370138155 0.3701381553399143568639806676151644570979 -#define FFTW_K370949600 0.3709496008697677795187832504613714657766 -#define FFTW_K371662455 0.3716624556603275191518049611285091938479 -#define FFTW_K372856477 0.3728564777803086108306500487961622518678 -#define FFTW_K373817071 0.3738170718407687913912982304163231070236 -#define FFTW_K374606593 0.3746065934159120354149637745011951310001 -#define FFTW_K375267004 0.3752670048793741338875592256739963144508 -#define FFTW_K375827582 0.3758275821142381678666440272552022706104 -#define FFTW_K376309371 0.3763093719478354580854128826607312195378 -#define FFTW_K376727893 0.3767278936351850994385423912048126363986 -#define FFTW_K382683432 0.3826834323650897717284599840303988667613 -#define FFTW_K388434796 0.3884347962746947118923318303095684709959 -#define FFTW_K388824175 0.3888241754733206472331483352233858759953 -#define FFTW_K389270106 0.3892701063173914903895747264449321369261 -#define FFTW_K389785873 0.3897858732926793690828678991204515658461 -#define FFTW_K390389275 0.3903892751634948132202383101205617972359 -#define FFTW_K391104720 0.3911047204901560157361797932002389820702 -#define FFTW_K391966609 0.3919666098600750758836817751475364086730 -#define FFTW_K393025031 0.3930250316539236181879675098179335770069 -#define FFTW_K394355855 0.3943558551133185801016261030214455736355 -#define FFTW_K395158538 0.3951585385301554551973223050248713719112 -#define FFTW_K396079766 0.3960797660391568236960433916097445675084 -#define FFTW_K397147890 0.3971478906347806137543773600194770636112 -#define FFTW_K398401089 0.3984010898462414579978803999696789656499 -#define FFTW_K399892024 0.3998920243197409718830580631715817256097 -#define FFTW_K400453905 0.4004539056512664881900757918031049168799 -#define FFTW_K401695424 0.4016954246529694575168416597426171522567 -#define FFTW_K403123429 0.4031234292879722141928847864308575941774 -#define FFTW_K403921004 0.4039210048718949626390971462228293575194 -#define FFTW_K404783343 0.4047833431223938171559229929865110885458 -#define FFTW_K405241314 0.4052413140049898709084813055050524665119 -#define FFTW_K406736643 0.4067366430758002077539859903414976129231 -#define FFTW_K408444256 0.4084442569359961354585130645868912825289 -#define FFTW_K409068637 0.4090686371713398883621478572702527811569 -#define FFTW_K410412805 0.4104128054527567964242959438829223418615 -#define FFTW_K411287103 0.4112871031306115394563645794677849305108 -#define FFTW_K411901248 0.4119012482439926753830399595163634298154 -#define FFTW_K412707029 0.4127070298043947370477021860733674718905 -#define FFTW_K413212185 0.4132121857683781796177459756612098495079 -#define FFTW_K415415013 0.4154150130018864255292741492296232035240 -#define FFTW_K417508992 0.4175089922850631204988983925715332880857 -#define FFTW_K417960344 0.4179603448867834197609712699154881891189 -#define FFTW_K418659737 0.4186597375374280866755652051218860503788 -#define FFTW_K419889101 0.4198891015602645769737108950291563357023 -#define FFTW_K420934762 0.4209347624283349696253509429280529945866 -#define FFTW_K422618261 0.4226182617406994361869784896477301815631 -#define FFTW_K423914390 0.4239143907098606887419042651814927925410 -#define FFTW_K424456698 0.4244566988758150853990378624175550294483 -#define FFTW_K425779291 0.4257792915650726488625024457442517039799 -#define FFTW_K426776435 0.4267764354964036681347859720543011341509 -#define FFTW_K427555093 0.4275550934302820943209668568887985343045 -#define FFTW_K428692561 0.4286925614030541830734336648482434287056 -#define FFTW_K429483443 0.4294834430300819004044761443765364092055 -#define FFTW_K430065202 0.4300652022765204603469796350767522768615 -#define FFTW_K430511096 0.4305110968082951443761483565082794876402 -#define FFTW_K433883739 0.4338837391175581204757683328483587546100 -#define FFTW_K437307320 0.4373073204588553906127706057564501702361 -#define FFTW_K437767705 0.4377677051653404809109457323247945767254 -#define FFTW_K438371146 0.4383711467890774174527345406582657390627 -#define FFTW_K439196588 0.4391965888473703654544278324316179454814 -#define FFTW_K440394151 0.4403941515576343095161715337137760630174 -#define FFTW_K441221101 0.4412211012432212932561177149092889833885 -#define FFTW_K442288690 0.4422886902190012819952389773242447301569 -#define FFTW_K443719837 0.4437198378669596859957300716487510074805 -#define FFTW_K444311706 0.4443117063539035508920534834793903341199 -#define FFTW_K445738355 0.4457383557765382673964575493794868554276 -#define FFTW_K447093792 0.4470937929851139085878077015499424448310 -#define FFTW_K447617210 0.4476172100627125493354635123469121632099 -#define FFTW_K448799180 0.4487991802004621727850403347331436164243 -#define FFTW_K449611329 0.4496113296546066000462945794242270758831 -#define FFTW_K450203744 0.4502037448176732924559998305063153741703 -#define FFTW_K451010119 0.4510101192161018402829405689831741061912 -#define FFTW_K451533358 0.4515333583108893507637632100198611342712 -#define FFTW_K453990499 0.4539904997395467915604083663578711989830 -#define FFTW_K456210657 0.4562106573531629639774980773788514351385 -#define FFTW_K456629237 0.4566292373937130644452233125091948196962 -#define FFTW_K457242323 0.4572423233046385228159706386386358177793 -#define FFTW_K458226521 0.4582265217274103945550366255897399668032 -#define FFTW_K458981864 0.4589818644675376813624520888264711922214 -#define FFTW_K460065037 0.4600650377311521260415757598109517955579 -#define FFTW_K461092501 0.4610925014493258460911917550660284882441 -#define FFTW_K461748613 0.4617486132350339305629306731356229872678 -#define FFTW_K462538290 0.4625382902408352776971056464298681702475 -#define FFTW_K462996644 0.4629966441051207667179520124020620021145 -#define FFTW_K464723172 0.4647231720437685456560153351331047775577 -#define FFTW_K466667323 0.4666673232256736976711189168781572674051 -#define FFTW_K467268628 0.4672686282730619891421497069463566255380 -#define FFTW_K468408440 0.4684084406997901392162396741494573562814 -#define FFTW_K469471562 0.4694715627858907759594622882278432957232 -#define FFTW_K469976743 0.4699767430273200448803201882849598306672 -#define FFTW_K471396736 0.4713967368259976485563876259052543776574 -#define FFTW_K473093556 0.4730935568360100744212386756923100796709 -#define FFTW_K473868662 0.4738686624729986707083830096659750872704 -#define FFTW_K474600369 0.4746003697476404014444030521845052424142 -#define FFTW_K475947393 0.4759473930370735444313529194551153377644 -#define FFTW_K477158760 0.4771587602596084150488630081893860525344 -#define FFTW_K477719818 0.4777198185122629226714738291795566445794 -#define FFTW_K478253978 0.4782539786213182117281992257619655845446 -#define FFTW_K479248986 0.4792489867200568311976566004526127683333 -#define FFTW_K480581755 0.4805817551866837805188145730989093322125 -#define FFTW_K481753674 0.4817536741017152749871915028721296535285 -#define FFTW_K482792202 0.4827922027307448748732654364456006331007 -#define FFTW_K483718887 0.4837188871052397910711613404089728511353 -#define FFTW_K484550870 0.4845508703326501661482589827850659897206 -#define FFTW_K485301962 0.4853019625310810252145722292597299794313 -#define FFTW_K486604478 0.4866044785668562872908560142642961120006 -#define FFTW_K487694943 0.4876949438136345453546358573087530741093 -#define FFTW_K488621241 0.4886212414969549474201908878388776372536 -#define FFTW_K489417847 0.4894178478110855091620714559474840496853 -#define FFTW_K490110217 0.4901102171780172253599534345284315254418 -#define FFTW_K490717552 0.4907175520039378866875617032247567784897 -#define FFTW_K491254611 0.4912546110838773740027218272702905763288 -#define FFTW_K491732924 0.4917329246456037728350634796082138236387 -#define FFTW_K492161631 0.4921616313890073350656423325950721684747 -#define FFTW_K492548067 0.4925480679538644138390568320545344677720 -#define FFTW_K492898192 0.4928981922297840368730266887588092682396 -#define FFTW_K500000000 0.5000000000000000000000000000000000000000 -#define FFTW_K499999999 0.5000000000000000000000000000000000000000 -#define FFTW_K507295790 0.5072957901801073367475366123379857519655 -#define FFTW_K507665800 0.5076658003388399581093093048575938349538 -#define FFTW_K508075345 0.5080753452465294585428491475669648936485 -#define FFTW_K508531118 0.5085311186492204850105948124297554981888 -#define FFTW_K509041415 0.5090414157503713002834427138653056527808 -#define FFTW_K509616642 0.5096166425919174293666674157223672698804 -#define FFTW_K510270033 0.5102700330608996133204856818145824161513 -#define FFTW_K511018679 0.5110186794471103662576250033662606123172 -#define FFTW_K511885049 0.5118850490896010021737274853303109596843 -#define FFTW_K512899277 0.5128992774059061439084936529403118044651 -#define FFTW_K514102744 0.5141027441932217265936938389688157726080 -#define FFTW_K514792801 0.5147928015098307273142233930965266875226 -#define FFTW_K515553857 0.5155538571770217397098664966397134305304 -#define FFTW_K516397461 0.5163974616389619233199213987888180697670 -#define FFTW_K517337814 0.5173378141776567710362946754733118933788 -#define FFTW_K518392568 0.5183925683105250315384743146752592400898 -#define FFTW_K519583950 0.5195839500354335781330010113237876331492 -#define FFTW_K520940340 0.5209403404879302861762814495347146459259 -#define FFTW_K521435203 0.5214352033794980724261075391331443334846 -#define FFTW_K522498564 0.5224985647159488649878978801782938234153 -#define FFTW_K523672913 0.5236729139878778613113179353244932106015 -#define FFTW_K524307283 0.5243072835572316877977574563473161566248 -#define FFTW_K524976580 0.5249765803345601755182577112207755871671 -#define FFTW_K526432162 0.5264321628773558002446077991406995661709 -#define FFTW_K528067850 0.5280678506503679958734488203376055682261 -#define FFTW_K528964010 0.5289640103269624573654923939122347256678 -#define FFTW_K529919264 0.5299192642332049540467811518160866687720 -#define FFTW_K530420908 0.5304209081197424901275539775477963937120 -#define FFTW_K532032076 0.5320320765153365635576303672303707301645 -#define FFTW_K533823377 0.5338233779647906819709106917246609497097 -#define FFTW_K534465826 0.5344658261278010920448916115059631779908 -#define FFTW_K534997619 0.5349976198870972106630769046370179155602 -#define FFTW_K535826794 0.5358267949789966182713087678676399780635 -#define FFTW_K536696193 0.5366961939916004804283904754877204814678 -#define FFTW_K537299608 0.5372996083468238318407855462677067680826 -#define FFTW_K538082353 0.5380823531633726744432314599446075951185 -#define FFTW_K538567961 0.5385679615609043184417452731084601648522 -#define FFTW_K540640817 0.5406408174555975821076359543186916954317 -#define FFTW_K542546263 0.5425462638657594057764972215610247085012 -#define FFTW_K542948982 0.5429489822014786701886277535350098429865 -#define FFTW_K543567550 0.5435675500012211507281151902424756896932 -#define FFTW_K544639035 0.5446390350150270822240836920815653816079 -#define FFTW_K545534901 0.5455349012105486651327077633824745393135 -#define FFTW_K546948158 0.5469481581224268747117627466961884997788 -#define FFTW_K548451871 0.5484518712493187136368616554921198282836 -#define FFTW_K549508978 0.5495089780708060352627803740501339165127 -#define FFTW_K550292715 0.5502927152373913716928201431260802030025 -#define FFTW_K550896981 0.5508969814521025226871043191204105871852 -#define FFTW_K551767740 0.5517677407704459049547942137195885263307 -#define FFTW_K552364972 0.5523649729605058107631005229003669921116 -#define FFTW_K552800065 0.5528000653611933830479607237660836570846 -#define FFTW_K555570233 0.5555702330196022247428308139485328743749 -#define FFTW_K558243722 0.5582437220268647591526404027462258729266 -#define FFTW_K558646765 0.5586467658036524568622720968872277915579 -#define FFTW_K559192903 0.5591929034707468301604281399859892873066 -#define FFTW_K559974786 0.5599747861375953903804362399881110256799 -#define FFTW_K561187065 0.5611870653623823692699409283736092029758 -#define FFTW_K562083377 0.5620833778521306000972520013088883538429 -#define FFTW_K563320058 0.5633200580636220277492615380297605110458 -#define FFTW_K564443218 0.5644432188667691804433731669421321560933 -#define FFTW_K565136414 0.5651364144225918889815679062534626407621 -#define FFTW_K565947094 0.5659470943305951647768230619336659850687 -#define FFTW_K566406236 0.5664062369248328318216250522337649325187 -#define FFTW_K568064746 0.5680647467311558025118075591275166245335 -#define FFTW_K569808057 0.5698080575102661816845660286961865846296 -#define FFTW_K570322636 0.5703226369349640602140881497060451205684 -#define FFTW_K571268215 0.5712682150947922791574245436284554823534 -#define FFTW_K572116660 0.5721166601221696498132192034370527016364 -#define FFTW_K573576436 0.5735764363510460961080319128261578646204 -#define FFTW_K574787410 0.5747874102144068850436978464129713348833 -#define FFTW_K575318660 0.5753186602186205995927072726495191736474 -#define FFTW_K575808191 0.5758081914178453007459724538157308417760 -#define FFTW_K576680322 0.5766803221148671412510482752668528239788 -#define FFTW_K577773831 0.5777738314082511021102199089899935947837 -#define FFTW_K578671296 0.5786712961798057416349117556513751600107 -#define FFTW_K579421098 0.5794210982045636845678607582146469698519 -#define FFTW_K580056909 0.5800569095711981791969811319003074122335 -#define FFTW_K581076815 0.5810768154019382799971629059056750994902 -#define FFTW_K581858915 0.5818589155579528384237390755893130777775 -#define FFTW_K582477696 0.5824776968678021491971347670361124496849 -#define FFTW_K582979479 0.5829794791144720768317634478275581254656 -#define FFTW_K583394579 0.5833945791074939474110439755476610699679 -#define FFTW_K583743672 0.5837436722347898704535849173602861862334 -#define FFTW_K587785252 0.5877852522924731291687059546390727685976 -#define FFTW_K591877046 0.5918770467870172636974905748868801823425 -#define FFTW_K592235252 0.5922352526649800217394881554148630285607 -#define FFTW_K592662191 0.5926621913640168354692868591503568120595 -#define FFTW_K593179744 0.5931797447293552110980879105045366390442 -#define FFTW_K593820185 0.5938201855735016116500901787757969715429 -#define FFTW_K594633176 0.5946331763042866161328284577790955529530 -#define FFTW_K595699304 0.5956993044924333434670365288299698895119 -#define FFTW_K596367358 0.5963673585385014139115331297600029152330 -#define FFTW_K597158591 0.5971585917027861648518521605839597728406 -#define FFTW_K598110530 0.5981105304912159620592663549050390073657 -#define FFTW_K599277666 0.5992776665113469345300241464975926115075 -#define FFTW_K600214280 0.6002142805483682182892439332026327230385 -#define FFTW_K600742264 0.6007422642379789169170698743449837706706 -#define FFTW_K601317091 0.6013170912984058082408764754369813163847 -#define FFTW_K602634636 0.6026346363792563891785881549868406216189 -#define FFTW_K603804410 0.6038044103254773687416432135874339982464 -#define FFTW_K604236389 0.6042363895210945207619697322884734664490 -#define FFTW_K605174215 0.6051742151937651659242801329801084792646 -#define FFTW_K606225410 0.6062254109666380182743756853644417577991 -#define FFTW_K606800145 0.6068001458185933703817660523085167627397 -#define FFTW_K608761429 0.6087614290087206394160975428981640045164 -#define FFTW_K610647879 0.6106478796354381306932542723821207732355 -#define FFTW_K611173714 0.6111737140978492922481400688827063108551 -#define FFTW_K612105982 0.6121059825476628441467056202598600662486 -#define FFTW_K612907053 0.6129070536529764933643860565186920014861 -#define FFTW_K614212712 0.6142127126896678174443358335144494567519 -#define FFTW_K615231590 0.6152315905806268454849135634139842776594 -#define FFTW_K615661475 0.6156614753256582796688110928436556282509 -#define FFTW_K616718872 0.6167188726285430584574009602667958339961 -#define FFTW_K617524614 0.6175246149461919150332079754986842314714 -#define FFTW_K618158986 0.6181589862206052132242870766482095935286 -#define FFTW_K619093949 0.6190939493098339869415608562461182062175 -#define FFTW_K619749888 0.6197498889602448854708069331948698244808 -#define FFTW_K620235491 0.6202354912682600677739492348652510534689 -#define FFTW_K620609481 0.6206094818274227951118685588824422384550 -#define FFTW_K623489801 0.6234898018587335305250048840042398106322 -#define FFTW_K626509999 0.6265099998359866294090460453355545190924 -#define FFTW_K626923805 0.6269238058941064650171695366099533004747 -#define FFTW_K627469007 0.6274690073808519692459461113376089475503 -#define FFTW_K628219997 0.6282199972956423167888571244982907776990 -#define FFTW_K629320391 0.6293203910498374527059024582799704265668 -#define FFTW_K630087843 0.6300878435817110813020457226223099127413 -#define FFTW_K631087944 0.6310879443260527893674001301433105742008 -#define FFTW_K631942038 0.6319420384463039980812672705334167368491 -#define FFTW_K632445375 0.6324453755953772378210421356243774316157 -#define FFTW_K633012453 0.6330124538088703887271152762762650288323 -#define FFTW_K634393284 0.6343932841636454982151716132254933706757 -#define FFTW_K635723748 0.6357237482099679982772185699592814904753 -#define FFTW_K636242442 0.6362424423265598332563914426192972085437 -#define FFTW_K637423989 0.6374239897486897101767128116760161954349 -#define FFTW_K638244183 0.6382441836448200939919339938994422817340 -#define FFTW_K638846805 0.6388468056519613170701714797131712501021 -#define FFTW_K639673021 0.6396730215588912736376413785400172119839 -#define FFTW_K640212840 0.6402128404624880139089127673149144443273 -#define FFTW_K640593178 0.6405931786981751555801787491064955966940 -#define FFTW_K642787609 0.6427876096865393263226434099072634329075 -#define FFTW_K645171983 0.6451719835420876332916589890067163479062 -#define FFTW_K645627851 0.6456278515588023976509609942805170886061 -#define FFTW_K646299237 0.6462992378609408919872782945589183784725 -#define FFTW_K647386284 0.6473862847818276391816601341861462687573 -#define FFTW_K648228395 0.6482283953077884016265676818920522589008 -#define FFTW_K649448048 0.6494480483301836557263207708937628792775 -#define FFTW_K650618300 0.6506183002042421137200625338820968810477 -#define FFTW_K651372482 0.6513724827222222074539996146910164660920 -#define FFTW_K652287411 0.6522874112781211543709918892277518756944 -#define FFTW_K652822118 0.6528221181905216240058867193362104152324 -#define FFTW_K653172842 0.6531728429537767640842030136563054150768 -#define FFTW_K654860733 0.6548607339452850640569250724662935531838 -#define FFTW_K656752024 0.6567520240477344067154384346008419370839 -#define FFTW_K657203678 0.6572036788179724611572838276890770109395 -#define FFTW_K657938725 0.6579387259397126123701191819931188157209 -#define FFTW_K658511379 0.6585113790650386427945048286629364391494 -#define FFTW_K659345815 0.6593458151000688684251246120553374509154 -#define FFTW_K660152120 0.6601521206712317513451242124324233897176 -#define FFTW_K660674723 0.6606747233900814419084029992842146796392 -#define FFTW_K661311865 0.6613118653236518765686217371023240621957 -#define FFTW_K661685837 0.6616858375968594152403677203172028537185 -#define FFTW_K663122658 0.6631226582407952023767854926667662795247 -#define FFTW_K664795865 0.6647958656139378287087022425974990458408 -#define FFTW_K665325700 0.6653257001655653635571413398480420351878 -#define FFTW_K666346577 0.6663465779520039455829121186875666953965 -#define FFTW_K667318811 0.6673188112222394158299466460967518615170 -#define FFTW_K667787758 0.6677877587886956156678714244522237437632 -#define FFTW_K669130606 0.6691306063588582138262733306867804735995 -#define FFTW_K670384843 0.6703848439562785276102304567161121618440 -#define FFTW_K670784730 0.6707847301392234490950123366082160122035 -#define FFTW_K671558954 0.6715589548470184006253768504274218032287 -#define FFTW_K672300890 0.6723008902613167880864184616374229315599 -#define FFTW_K673695643 0.6736956436465572117126919124256946158624 -#define FFTW_K674983001 0.6749830015182105320655112776739346328419 -#define FFTW_K675590207 0.6755902076156602443483393536743541823082 -#define FFTW_K676174900 0.6761749002740194352804986161659714461903 -#define FFTW_K677281571 0.6772815716257410747621509844956257184155 -#define FFTW_K678311836 0.6783118362696160847748068699856585450415 -#define FFTW_K678800745 0.6788007455329417413938555542417347670587 -#define FFTW_K679273338 0.6792733388972931155862949904270503180450 -#define FFTW_K680172737 0.6801727377709193901873587010337402440270 -#define FFTW_K681417939 0.6814179395938911071752870865417535631154 -#define FFTW_K682553143 0.6825531432186540828745375453725405780987 -#define FFTW_K683592302 0.6835923020228712805134975943161551170438 -#define FFTW_K684547105 0.6845471059286886737322833576212092698895 -#define FFTW_K685427422 0.6854274223350397681993662181891218368258 -#define FFTW_K686241637 0.6862416378687335857296049996175379830146 -#define FFTW_K686996926 0.6869969260349016335361463414661483035462 -#define FFTW_K687699458 0.6876994588534232930838768523753670644636 -#define FFTW_K688354575 0.6883545756937539843892561434196122934864 -#define FFTW_K688966919 0.6889669190756865678008668038181416871299 -#define FFTW_K689540544 0.6895405447370669246167306299574847028455 -#define FFTW_K690079011 0.6900790114821119896680022393860466831042 -#define FFTW_K691062648 0.6910626489868646759049354256591699817466 -#define FFTW_K691938868 0.6919388689775462000100916668541419889185 -#define FFTW_K692724353 0.6927243535095993926023640323286367890472 -#define FFTW_K693432500 0.6934325007922417286259483972875805939519 -#define FFTW_K694074195 0.6940741952206338743562373929183182498191 -#define FFTW_K694658370 0.6946583704589972866564062994226862299198 -#define FFTW_K695192427 0.6951924276746422635493018952393936461260 -#define FFTW_K695682550 0.6956825506034863980123038192788602156570 -#define FFTW_K696133945 0.6961339459629266082804580802171441972963 -#define FFTW_K696551029 0.6965510290629970275685644956080105169444 -#define FFTW_K696937568 0.6969375686552934513687343434240100437094 -#define FFTW_K697296801 0.6972968010939954123883995190174803108192 -#define FFTW_K697631521 0.6976315211349847088683553934221612826295 -#define FFTW_K697944154 0.6979441547663435525141697077142117061923 -#define FFTW_K698236818 0.6982368180860728303443788766343622359181 -#define FFTW_K707106781 0.7071067811865475244008443621048490392848 -#define FFTW_K715866849 0.7158668492597184358325495667351529571818 -#define FFTW_K716152188 0.7161521883143933244871695467834148450420 -#define FFTW_K716456740 0.7164567402983151385899735430616918149233 -#define FFTW_K716782513 0.7167825131684512560287415441946047504647 -#define FFTW_K717131804 0.7171318047589634877970500299385526785307 -#define FFTW_K717507257 0.7175072570443311343681755891326858548995 -#define FFTW_K717911923 0.7179119230644419217516810110208110922839 -#define FFTW_K718349350 0.7183493500977275799770853713340482116475 -#define FFTW_K718823683 0.7188236838779293347704518118723688496542 -#define FFTW_K719339800 0.7193398003386511393560546744567119082307 -#define FFTW_K719903473 0.7199034737579958486390645343470509553063 -#define FFTW_K720521593 0.7205215936007870086417952013179792194347 -#define FFTW_K721202447 0.7212024473438145312912178776909015417372 -#define FFTW_K721956093 0.7219560939545244623539160604710216653225 -#define FFTW_K722794863 0.7227948638273915285452633514998522610902 -#define FFTW_K723734038 0.7237340381050701616398577367648401146360 -#define FFTW_K724247082 0.7242470829514669209410692432905531674831 -#define FFTW_K724792787 0.7247927872291199588654846624405482525919 -#define FFTW_K725374371 0.7253743710122876379932841111897274422634 -#define FFTW_K725995491 0.7259954919231308581383348989285119089043 -#define FFTW_K726660322 0.7266603220340270471615222876385396255744 -#define FFTW_K727373641 0.7273736415730486959871764176638155218003 -#define FFTW_K728140953 0.7281409538757884113627136381609143278784 -#define FFTW_K728968627 0.7289686274214115231467303190552591113725 -#define FFTW_K729864072 0.7298640726978356573501011944031818828671 -#define FFTW_K730835964 0.7308359642781241016508331160835884644009 -#define FFTW_K731894522 0.7318945221817254249995908196165164482138 -#define FFTW_K733051871 0.7330518718298263285224314892706719069732 -#define FFTW_K733885366 0.7338853664321991204758701610226706020529 -#define FFTW_K734322509 0.7343225094356855356361262221870633391234 -#define FFTW_K734774150 0.7347741508630672705517472711052032451697 -#define FFTW_K735723910 0.7357239106731316247742076119610924993214 -#define FFTW_K736741137 0.7367411378764049113081712804175510630885 -#define FFTW_K737277336 0.7372773368101240413842933949823167074783 -#define FFTW_K737833279 0.7378332790417272840054057907426797687494 -#define FFTW_K739008917 0.7390089172206591159245343098726481057599 -#define FFTW_K740277997 0.7402779970753155388739455189600782362008 -#define FFTW_K740951125 0.7409511253549590911756168974951627297289 -#define FFTW_K741652105 0.7416521056479575401050298834696252306095 -#define FFTW_K742013585 0.7420135854509107900562897491988128499895 -#define FFTW_K743144825 0.7431448254773942350146970489742569771891 -#define FFTW_K744351737 0.7443517375622702753223079406751082310911 -#define FFTW_K744772182 0.7447721827437818541801075535542228384922 -#define FFTW_K745642164 0.7456421648831656094855517544592784043106 -#define FFTW_K746553221 0.7465532216119626505430821259987599991059 -#define FFTW_K747025071 0.7470250712409959770813061511833665718690 -#define FFTW_K748510748 0.7485107481711010986346305997013513838464 -#define FFTW_K749781202 0.7497812029677341725472752431791603229768 -#define FFTW_K750111069 0.7501110696304595415116318903602243084582 -#define FFTW_K750672305 0.7506723052527243552853714132129325824726 -#define FFTW_K751131930 0.7511319308705198908719336792015250259316 -#define FFTW_K751839807 0.7518398074789773964075194063769614427711 -#define FFTW_K752570769 0.7525707698561385039345058991616619849640 -#define FFTW_K753071466 0.7530714660036109335328981126967543453011 -#define FFTW_K753713025 0.7537130253273611135174409504536276492985 -#define FFTW_K754106609 0.7541066097768962584072425641248841945967 -#define FFTW_K755749574 0.7557495743542582837740358439723444201797 -#define FFTW_K757208846 0.7572088465064845475754640536057844730404 -#define FFTW_K757511242 0.7575112421616200777921492788026149650951 -#define FFTW_K757971723 0.7579717231454529817885572940611047033822 -#define FFTW_K758758122 0.7587581226927909019132546363634371874187 -#define FFTW_K759404916 0.7594049166547071324830192475886597898185 -#define FFTW_K760405965 0.7604059656000309381745943648449019998887 -#define FFTW_K761445958 0.7614459583691344354059827794359096182151 -#define FFTW_K762162055 0.7621620551276364632557304138001066169968 -#define FFTW_K763084068 0.7630840681998065061370822576584453862969 -#define FFTW_K763652196 0.7636521965473320213761899200454104141096 -#define FFTW_K764037375 0.7640373758216074366584418224732236328521 -#define FFTW_K766044443 0.7660444431189780352023926505554166739358 -#define FFTW_K767880446 0.7678804460366000439108131759354179442125 -#define FFTW_K768197578 0.7681975780402805136696963323797498461191 -#define FFTW_K768647139 0.7686471397785320711672309487157031840488 -#define FFTW_K769333970 0.7693339709828789081165579311348793444580 -#define FFTW_K769833983 0.7698339834299062446400585995897523594467 -#define FFTW_K770513242 0.7705132427757892308030096363961778472716 -#define FFTW_K771489179 0.7714891798219429236333137852557419058307 -#define FFTW_K771916650 0.7719166509163208938857372713158033849885 -#define FFTW_K773010453 0.7730104533627369608109066097584698009710 -#define FFTW_K774141610 0.7741416106390824490643725637222281648702 -#define FFTW_K774604961 0.7746049618276545830695547811609143505275 -#define FFTW_K775015651 0.7750156514834587774905671515508743070762 -#define FFTW_K775711290 0.7757112907044198070411010109695368955877 -#define FFTW_K776523862 0.7765238627180424194178981071015438682470 -#define FFTW_K777145961 0.7771459614569708799799377436724038490920 -#define FFTW_K778035754 0.7780357543184395071379034311358886990222 -#define FFTW_K778641538 0.7786415380497551756216347075406753784977 -#define FFTW_K779080574 0.7790805745256704319243606206074903916787 -#define FFTW_K779413382 0.7794133820415916066406766395486940072562 -#define FFTW_K781831482 0.7818314824680298087084445266740577502323 -#define FFTW_K784119806 0.7841198065767104288007771818131996408643 -#define FFTW_K784415664 0.7844156649195757164147347243863789879656 -#define FFTW_K784799385 0.7847993852786609660467986845419951971886 -#define FFTW_K785316930 0.7853169308807449274703402789474438465742 -#define FFTW_K786053094 0.7860530947427874697567960561472203660398 -#define FFTW_K786551555 0.7865515558026424811142105001200600923644 -#define FFTW_K787183480 0.7871834806090501817971553081772994121428 -#define FFTW_K788010753 0.7880107536067219566939777878358516666417 -#define FFTW_K788346427 0.7883464276266062620091647053596892826565 -#define FFTW_K789140509 0.7891405093963935992189811493990907424327 -#define FFTW_K790155012 0.7901550123756903651583739005191500716562 -#define FFTW_K790775736 0.7907757369376985820782204594612615906186 -#define FFTW_K791496488 0.7914964884292541024484192534757154670595 -#define FFTW_K791902245 0.7919022459222750967567379392185911277200 -#define FFTW_K793353340 0.7933533402912351645797769615012992766286 -#define FFTW_K794854441 0.7948544414133532553739957580767734022432 -#define FFTW_K795292871 0.7952928712734264419747999587861323112984 -#define FFTW_K796093065 0.7960930657056437459980762465098682421823 -#define FFTW_K796805111 0.7968051114159045953017786484229447858314 -#define FFTW_K797132507 0.7971325072229224793372837601652378546732 -#define FFTW_K798017227 0.7980172272802395033328051127962613693613 -#define FFTW_K799010485 0.7990104853582490339189956088648939776689 -#define FFTW_K799442763 0.7994427634035011497843129165366612315496 -#define FFTW_K799839244 0.7998392447397193882383350307398838367966 -#define FFTW_K800541240 0.8005412409243604039694861948940174149851 -#define FFTW_K801413621 0.8014136218679566597869832895333147708145 -#define FFTW_K802123192 0.8021231927550437850832948919339251336279 -#define FFTW_K802711637 0.8027116379309636648857701593460559768659 -#define FFTW_K803207531 0.8032075314806449098066765129631419238795 -#define FFTW_K803997130 0.8039971303669405448263546938160337037246 -#define FFTW_K804597779 0.8045977797666683273479469589870672086575 -#define FFTW_K805070053 0.8050700531275629237964644458284235283226 -#define FFTW_K805451132 0.8054511325509459412018817468525086560274 -#define FFTW_K805765105 0.8057651056609781448783432800395721783251 -#define FFTW_K806028263 0.8060282634540050525485951357692559600329 -#define FFTW_K809016994 0.8090169943749474241022934171828190588601 -#define FFTW_K811938005 0.8119380057158564945968154707997246072052 -#define FFTW_K812188872 0.8121888727802111341842463443864419315001 -#define FFTW_K812486878 0.8124868780056812804083249549706806424640 -#define FFTW_K812846684 0.8128466845916152165790961432719088000368 -#define FFTW_K813289740 0.8132897407355653520077715387689353346970 -#define FFTW_K813848717 0.8138487172701949671014723968817952735703 -#define FFTW_K814575952 0.8145759520503357077796110789197173627162 -#define FFTW_K815028337 0.8150283375168113542809178737613989382610 -#define FFTW_K815560868 0.8155608689592601713495029594534251284932 -#define FFTW_K816196912 0.8161969123562216908718525404314132261743 -#define FFTW_K816969893 0.8169698930104420169734140372449881772467 -#define FFTW_K817584813 0.8175848131515836965049208841306338094710 -#define FFTW_K817929360 0.8179293607667176652958167850895491664995 -#define FFTW_K818302775 0.8183027759081690562813923055156721567774 -#define FFTW_K819152044 0.8191520442889917896844883859168434318900 -#define FFTW_K820172254 0.8201722545969558802093426246966592359901 -#define FFTW_K820763441 0.8207634412072763263635445613553707767234 -#define FFTW_K821420775 0.8214207751204915613062020704361611380444 -#define FFTW_K821777815 0.8217778152252451671574450614136543968389 -#define FFTW_K822983865 0.8229838658936563945796174234393819906550 -#define FFTW_K824126188 0.8241261886220156617296849031023120581344 -#define FFTW_K824441560 0.8244415603417603172395375008020188385297 -#define FFTW_K824997474 0.8249974745983023155379937789444219618160 -#define FFTW_K825471896 0.8254718969627739569806123728687672821516 -#define FFTW_K826238774 0.8262387743159948719451625737726783977923 -#define FFTW_K827080574 0.8270805742745618249178521862153294255631 -#define FFTW_K827688998 0.8276889981568905561357816231375032629304 -#define FFTW_K828509649 0.8285096492438421235308184341918643175695 -#define FFTW_K829037572 0.8290375725550416920063368415016420263290 -#define FFTW_K829405685 0.8294056854502017964409300836351034222685 -#define FFTW_K829677013 0.8296770135526188902704259673870759766830 -#define FFTW_K831469612 0.8314696123025452370787883776179057567385 -#define FFTW_K833313919 0.8333139190825149799338497823040738779341 -#define FFTW_K833602385 0.8336023852211194846164818272941764912595 -#define FFTW_K833997817 0.8339978178898779396182802893240929133492 -#define FFTW_K834573253 0.8345732537213026509332106768737349045847 -#define FFTW_K834971812 0.8349718124324073791989500778051524105744 -#define FFTW_K835487811 0.8354878114129364196538261700195835937419 -#define FFTW_K836182124 0.8361821242547108702206976219550553416196 -#define FFTW_K837166478 0.8371664782625285748060612009369102474987 -#define FFTW_K838088104 0.8380881048918406577111979492710431086713 -#define FFTW_K838670567 0.8386705679454240296375909418045478940395 -#define FFTW_K839365426 0.8393654261319499596375221301924238843327 -#define FFTW_K839765683 0.8397656832273979021124385277222164103972 -#define FFTW_K840025923 0.8400259231507714427435891533712282132058 -#define FFTW_K841253532 0.8412535328311811688618116489193677175133 -#define FFTW_K842582073 0.8425820736166491030403155344809671036641 -#define FFTW_K842892271 0.8428922714167970616253021027431752417750 -#define FFTW_K843391445 0.8433914458128857012728568058275720937337 -#define FFTW_K843775559 0.8437755598231856492381035650969764103387 -#define FFTW_K844327925 0.8443279255020150785485580639666815053816 -#define FFTW_K844853565 0.8448535652497070732595712051049570977198 -#define FFTW_K845190085 0.8451900855437947525384210461577995981395 -#define FFTW_K845596003 0.8455960035018260599096401021741480733078 -#define FFTW_K846724199 0.8467241992282841683527758162629652715100 -#define FFTW_K847734427 0.8477344278896709378979078108963493518662 -#define FFTW_K848048096 0.8480480961564259703861761786903864487287 -#define FFTW_K848644257 0.8486442574947509504641043389938084539825 -#define FFTW_K849202181 0.8492021815265788876490969373431002233934 -#define FFTW_K850217135 0.8502171357296141521341439229493520584706 -#define FFTW_K851116672 0.8511166724369997244053230155948839997322 -#define FFTW_K851529137 0.8515291377333112998870022534009853476003 -#define FFTW_K851919408 0.8519194088383270748769520464652824320111 -#define FFTW_K852640164 0.8526401643540922215193834581304121358172 -#define FFTW_K853290881 0.8532908816321556602859841530744174889494 -#define FFTW_K853593089 0.8535930890373464483418460304073336603452 -#define FFTW_K854419404 0.8544194045464885525482156195502508000478 -#define FFTW_K855142763 0.8551427630053461657188369620377883134776 -#define FFTW_K855781272 0.8557812723014475226428751870717647816026 -#define FFTW_K856349030 0.8563490302515889746335454168038935447319 -#define FFTW_K856857176 0.8568571761675892445230765519053744460274 -#define FFTW_K857314628 0.8573146280763323254728913071983536155226 -#define FFTW_K857728610 0.8577286100002720699022699842847701370425 -#define FFTW_K858448793 0.8584487936018661185256909553391418597076 -#define FFTW_K859053954 0.8590539543698851819025917736107901459966 -#define FFTW_K859569606 0.8595696069872011600426288131227073044970 -#define FFTW_K860014240 0.8600142402077005233981293105137709830115 -#define FFTW_K860401579 0.8604015792601393698695982953288507392950 -#define FFTW_K860742027 0.8607420270039436371645764888171186033396 -#define FFTW_K861043611 0.8610436117673555084585595060301225131232 -#define FFTW_K861312628 0.8613126282324089409969539854169889092899 -#define FFTW_K861554081 0.8615540813938061097287323042306235949835 -#define FFTW_K861772000 0.8617720007435496349698180347969737605395 -#define FFTW_K866025403 0.8660254037844386467637231707529361834714 -#define FFTW_K870086991 0.8700869911087114186522924044838488439108 -#define FFTW_K870285241 0.8702852410301552181879425663868640291029 -#define FFTW_K870503836 0.8705038360561720522112540977190092812503 -#define FFTW_K870746077 0.8707460771197771877217507835501149827317 -#define FFTW_K871016019 0.8710160199955155735930822648109600128714 -#define FFTW_K871318704 0.8713187041233893515466254843890811801214 -#define FFTW_K871660470 0.8716604700327512208196316756206218352705 -#define FFTW_K872049408 0.8720494081438076081277840260926609267766 -#define FFTW_K872496007 0.8724960070727971145251610992220606750668 -#define FFTW_K873014113 0.8730141131611881587490998015817489306733 -#define FFTW_K873622390 0.8736223906463695371317751603403871753524 -#define FFTW_K874346616 0.8743466161445821188274846642006517855751 -#define FFTW_K874763084 0.8747630845319612851774127792561794433059 -#define FFTW_K875223421 0.8752234219087536975047322807456399773275 -#define FFTW_K875734942 0.8757349421956368077335331364008557877370 -#define FFTW_K876306680 0.8763066800438635873081159039220625833990 -#define FFTW_K876949928 0.8769499282066715222872466054001294856266 -#define FFTW_K877678989 0.8776789895672556152144819341043752955765 -#define FFTW_K878221573 0.8782215733702285355675152847970664824282 -#define FFTW_K878512250 0.8785122509109423770324441012904022125743 -#define FFTW_K878817112 0.8788171126619653741299951436845247996106 -#define FFTW_K879473751 0.8794737512064890713908547548818411172079 -#define FFTW_K880201391 0.8802013911801111312939007656084800475957 -#define FFTW_K880595531 0.8805955318567379951929100621071846598466 -#define FFTW_K881012194 0.8810121942857845060087088179255903520436 -#define FFTW_K881921264 0.8819212643483550297127568636603883495084 -#define FFTW_K882678798 0.8826787983255474000126255959521373235657 -#define FFTW_K882947592 0.8829475928589269420321713603157193860835 -#define FFTW_K883512044 0.8835120444460229228273168942218641218895 -#define FFTW_K884115393 0.8841153935046097894486040972072045445368 -#define FFTW_K884432930 0.8844329309978143222381222066254039736375 -#define FFTW_K885456025 0.8854560256532098959003755220150988786055 -#define FFTW_K886360032 0.8863600326884082489319680620575687435341 -#define FFTW_K886599306 0.8865993063730000600561492865169439780362 -#define FFTW_K887010833 0.8870108331782217010546098830375165208464 -#define FFTW_K887352075 0.8873520750565715798425605640019506703212 -#define FFTW_K887885218 0.8878852184023752349842692774195844835989 -#define FFTW_K888445635 0.8884456359788723003064024832079566539738 -#define FFTW_K888835448 0.8888354486549234663115988929508545523678 -#define FFTW_K889342148 0.8893421488825189034181645031537721365929 -#define FFTW_K889657090 0.8896570909947472780924836875303123734246 -#define FFTW_K889871808 0.8898718088114686056939962978651778190884 -#define FFTW_K891006524 0.8910065241883678623597095714136263127705 -#define FFTW_K892254238 0.8922542386183940179207828634080536567074 -#define FFTW_K892518835 0.8925188358598812258172950673579982916784 -#define FFTW_K892925858 0.8929258581495684897301089783029903371682 -#define FFTW_K893224301 0.8932243011955153203424164474933979780006 -#define FFTW_K893632640 0.8936326403234122481925741868666551173761 -#define FFTW_K894225269 0.8942252698597112823960628785193238212484 -#define FFTW_K894487082 0.8944870822287955820318233216497337670451 -#define FFTW_K895163291 0.8951632913550623220670164997537854569905 -#define FFTW_K895872260 0.8958722607586879531165149908123770853627 -#define FFTW_K896165556 0.8961655569610556111428812574074225463776 -#define FFTW_K896872741 0.8968727415326883038941039363930811981792 -#define FFTW_K897398428 0.8973984286913583989856569596882832674134 -#define FFTW_K897804539 0.8978045395707416571368028976620412024434 -#define FFTW_K898390981 0.8983909818919788715724772004503877322352 -#define FFTW_K898794046 0.8987940462991669927822956766957853549299 -#define FFTW_K899088113 0.8990881137654259575573009403311324039869 -#define FFTW_K899312130 0.8993121301712192281267728278439957438859 -#define FFTW_K900968867 0.9009688679024191262361023195074450511659 -#define FFTW_K902585284 0.9025852843498606067626451490957717568164 -#define FFTW_K902797829 0.9027978299657435157159434879211280035795 -#define FFTW_K903074732 0.9030747323245327046634600051435581145958 -#define FFTW_K903450434 0.9034504346103822750158502586754325787995 -#define FFTW_K903989293 0.9039892931234433315862002972305370487101 -#define FFTW_K904357160 0.9043571606975774917577889956510946245375 -#define FFTW_K904827052 0.9048270524660195277136686479326975939704 -#define FFTW_K905448237 0.9054482374931466157217925560288827802948 -#define FFTW_K905702263 0.9057022630804714831454571042369241665150 -#define FFTW_K906307787 0.9063077870366499632425526567543169832677 -#define FFTW_K907090913 0.9070909137343407425834416725781145590933 -#define FFTW_K907575419 0.9075754196709570536201612900285178073502 -#define FFTW_K908143173 0.9081431738250812992580858365718675308412 -#define FFTW_K908465271 0.9084652718195236861115036475859197065373 -#define FFTW_K908672791 0.9086727911416249200241224067716522862116 -#define FFTW_K909631995 0.9096319953545183714117153830790284600602 -#define FFTW_K910634772 0.9106347728549131795432779003164790771901 -#define FFTW_K910863824 0.9108638249211758185732917071605506458979 -#define FFTW_K911228490 0.9112284903881357028266050899228384756870 -#define FFTW_K911505852 0.9115058523116731517830363345907678394956 -#define FFTW_K911899845 0.9118998459920900771751693987314744889449 -#define FFTW_K912503616 0.9125036164765500159680850800074193201110 -#define FFTW_K912783265 0.9127832650613189089239580059304432421433 -#define FFTW_K913545457 0.9135454576426008955021275719853171779408 -#define FFTW_K914209755 0.9142097557035306546350148293935774010447 -#define FFTW_K914412623 0.9144126230158124813216621552768982013708 -#define FFTW_K914793868 0.9147938684880209699974625808573866803804 -#define FFTW_K915145617 0.9151456172430184708919922968074955054838 -#define FFTW_K915773326 0.9157733266550574399193492356940089700766 -#define FFTW_K916316904 0.9163169044870047347483910891303247178132 -#define FFTW_K916562255 0.9165622558699761858166528942590914119157 -#define FFTW_K917211301 0.9172113015054530178438054479656154936903 -#define FFTW_K917754625 0.9177546256839811411456038575494850645302 -#define FFTW_K918216106 0.9182161068802740147589614153146366024813 -#define FFTW_K918612937 0.9186129377636217717227839432978941276582 -#define FFTW_K918957811 0.9189578116202306291271881732781545512765 -#define FFTW_K919527772 0.9195277725514506383219765907863572139881 -#define FFTW_K919979443 0.9199794436588242031333806039892048138233 -#define FFTW_K920346183 0.9203461835691594463070513006835656710894 -#define FFTW_K920649886 0.9206498866764287674701863104116332022322 -#define FFTW_K920905517 0.9209055179449536255994064620068449731338 -#define FFTW_K921123653 0.9211236531148501159329021282782128071959 -#define FFTW_K921311977 0.9213119778704129896905480715839225965944 -#define FFTW_K921476211 0.9214762118704076536461883522196093537778 -#define FFTW_K923879532 0.9238795325112867561281831893967882868224 -#define FFTW_K926323968 0.9263239682514949705912905047270639912213 -#define FFTW_K926494067 0.9264940672148017743152104663441626574522 -#define FFTW_K926689607 0.9266896074318334380530112475652589383520 -#define FFTW_K926916757 0.9269167573460217630248384996993891944013 -#define FFTW_K927183854 0.9271838545667874008064744511369569420976 -#define FFTW_K927502451 0.9275024511020946646050826878721451949727 -#define FFTW_K927889027 0.9278890272965093271272407498585829086596 -#define FFTW_K928367933 0.9283679330160726102005887247635900348309 -#define FFTW_K928652999 0.9286529995722621793338215070602379216189 -#define FFTW_K928976719 0.9289767198167914417896296010855542620841 -#define FFTW_K929347524 0.9293475242268224539554160275642758031236 -#define FFTW_K929776485 0.9297764858882514036609425562219907295871 -#define FFTW_K930278443 0.9302784433378331543856301730081308574415 -#define FFTW_K930873748 0.9308737486442042556377992419512753071420 -#define FFTW_K931336177 0.9313361774523384395875688031090437233347 -#define FFTW_K931591088 0.9315910880512789729395061972269616864428 -#define FFTW_K931864029 0.9318640292114523161883811474964361005778 -#define FFTW_K932472229 0.9324722294043558045731158918215633862626 -#define FFTW_K932992798 0.9329927988347388877116602555433024982950 -#define FFTW_K933180611 0.9331806110416025837525594317989553113908 -#define FFTW_K933580426 0.9335804264972017489900430631395707414059 -#define FFTW_K934016108 0.9340161087325479993506852910851617783859 -#define FFTW_K934248940 0.9342489402945998550750225109270206586844 -#define FFTW_K935016242 0.9350162426854148234397845998378307290505 -#define FFTW_K935716819 0.9357168190404936530452206735763588980841 -#define FFTW_K935905926 0.9359059267573257002917072494667353604862 -#define FFTW_K936234870 0.9362348706397372095087557244681174697775 -#define FFTW_K936511241 0.9365112411970547880293893304037418045007 -#define FFTW_K936949724 0.9369497249997617358215340023800922029264 -#define FFTW_K937419661 0.9374196611341208896823459233762131843021 -#define FFTW_K937752132 0.9377521321470804584291761743123298881308 -#define FFTW_K938191335 0.9381913359224841344523397266860115488320 -#define FFTW_K938468422 0.9384684220497604029667155343105113540832 -#define FFTW_K938659164 0.9386591647471505040724405750138456370676 -#define FFTW_K939692620 0.9396926207859083840541092773247314699362 -#define FFTW_K940700266 0.9407002666710332778144147138258163847213 -#define FFTW_K940880768 0.9408807689542254723241184190970210354205 -#define FFTW_K941140047 0.9411400479795615741432348245881724850480 -#define FFTW_K941544065 0.9415440651830207784125094025995023571856 -#define FFTW_K941844363 0.9418443636395246934886599986368180673483 -#define FFTW_K942260922 0.9422609221188204956176842253179721336254 -#define FFTW_K942641491 0.9426414910921783947771677362823118828448 -#define FFTW_K942877445 0.9428774454610841700409712864144146678198 -#define FFTW_K943154434 0.9431544344712774640574280872093873723077 -#define FFTW_K943883330 0.9438833303083675628952636071510366215206 -#define FFTW_K944489228 0.9444892287836612562119467742722171807155 -#define FFTW_K944669091 0.9446690916079188006659540817282152326248 -#define FFTW_K945000818 0.9450008187146684873915352426727239165683 -#define FFTW_K945299815 0.9452998150346402616705143998997016607838 -#define FFTW_K945817241 0.9458172417006346790196657142849415278238 -#define FFTW_K946249369 0.9462493690718368405241967976805762668189 -#define FFTW_K946439773 0.9464397731576093538703011154574776795266 -#define FFTW_K946930129 0.9469301294951056642558042748539836836988 -#define FFTW_K947326353 0.9473263538541913844327283048776780232015 -#define FFTW_K947653171 0.9476531711828024442740040119711601634623 -#define FFTW_K947927346 0.9479273461671317559187225179207687336495 -#define FFTW_K948160647 0.9481606475909658589306343094708234149340 -#define FFTW_K948536441 0.9485364419471455261649097836474828763046 -#define FFTW_K948825916 0.9488259168373196381387831532597734947289 -#define FFTW_K949055747 0.9490557470106686677560247808577723846680 -#define FFTW_K949242643 0.9492426435730339082613672603147399360686 -#define FFTW_K949397608 0.9493976084683812981670710293175487404773 -#define FFTW_K949528180 0.9495281805930366671959360741893450282522 -#define FFTW_K951056516 0.9510565162951535721164393333793821434057 -#define FFTW_K952635380 0.9526353808033825473157607370981429062638 -#define FFTW_K952775122 0.9527751227228962896620281580565795070492 -#define FFTW_K952942000 0.9529420004271565558310283034152551849996 -#define FFTW_K953144766 0.9531447668141608217276037452354468061606 -#define FFTW_K953396392 0.9533963920549305459532780713869375485036 -#define FFTW_K953716950 0.9537169507482269211438470646002574361517 -#define FFTW_K954139256 0.9541392564000488514758967202113007469136 -#define FFTW_K954405001 0.9544050018795074313557527182827665834059 -#define FFTW_K954720866 0.9547208665085456260632257187577027324935 -#define FFTW_K955102497 0.9551024972069124260581615872080246655679 -#define FFTW_K955572805 0.9555728057861407328113340537674666664396 -#define FFTW_K955952142 0.9559521426716116096201124770282868790124 -#define FFTW_K956166734 0.9561667347392509355062530712604052072035 -#define FFTW_K956400984 0.9564009842765224267816104574942389408587 -#define FFTW_K956940335 0.9569403357322088649357978869802699694828 -#define FFTW_K957422038 0.9574220383620054784219814066701634108048 -#define FFTW_K957600599 0.9576005999084059522314160387302455826259 -#define FFTW_K957989512 0.9579895123154888744373747669567546242580 -#define FFTW_K958427482 0.9584274824582527002251773197822330882206 -#define FFTW_K958667853 0.9586678530366606221509833883096862227102 -#define FFTW_K958819734 0.9588197348681930497610285413925982910492 -#define FFTW_K959492973 0.9594929736144973898903680570663276990624 -#define FFTW_K960149873 0.9601498736716017631384943454019255716108 -#define FFTW_K960293685 0.9602936856769430717520688004889952933058 -#define FFTW_K960518111 0.9605181116313722984399716039511134369404 -#define FFTW_K960917321 0.9609173219450995432119881422930318860934 -#define FFTW_K961261695 0.9612616959383188619164970485570648735257 -#define FFTW_K961416730 0.9614167300122124852309898043387424113665 -#define FFTW_K961825643 0.9618256431728190704087962907315185500314 -#define FFTW_K962268000 0.9622680003092504049510324619909753067365 -#define FFTW_K962455236 0.9624552364536472876302664051852632909944 -#define FFTW_K962624246 0.9626242469500120742026630479274062371083 -#define FFTW_K962917287 0.9629172873477992950152235973732387993550 -#define FFTW_K963270801 0.9632708010475163164004074245844491050914 -#define FFTW_K963549992 0.9635499925192229600433361810024919509632 -#define FFTW_K963776065 0.9637760657954398666864643555078351536631 -#define FFTW_K963962860 0.9639628606958532918885659525499857760906 -#define FFTW_K964253495 0.9642534954531409838529948264870398702492 -#define FFTW_K964469175 0.9644691750543765745192646181812789566372 -#define FFTW_K964635581 0.9646355819083586729132710036114158221655 -#define FFTW_K964767868 0.9647678688145159485146378868261663336703 -#define FFTW_K965925826 0.9659258262890682867497431997288973676339 -#define FFTW_K967027724 0.9670277247913203491918621498323771774221 -#define FFTW_K967146854 0.9671468547019571390593240593318965996643 -#define FFTW_K967294863 0.9672948630390294157758746656854387201623 -#define FFTW_K967483697 0.9674836970574252545056551754955779856175 -#define FFTW_K967732946 0.9677329469334988386884628287513969373382 -#define FFTW_K968077118 0.9680771188662043051530076728012907428347 -#define FFTW_K968303522 0.9683035221222614393926671480238885087824 -#define FFTW_K968583161 0.9685831611286311194901683754647358138360 -#define FFTW_K968937301 0.9689373017815073299549272178752194446760 -#define FFTW_K969077286 0.9690772862290779477269065494657367873034 -#define FFTW_K969400265 0.9694002659393304167361073217961682259573 -#define FFTW_K969796936 0.9697969360350094718195360156539576289212 -#define FFTW_K970031253 0.9700312531945439926039842072861002514568 -#define FFTW_K970295726 0.9702957262759964723063778740339903776322 -#define FFTW_K970441148 0.9704411482532114174890399562715796811572 -#define FFTW_K970941817 0.9709418174260520271569822762937892272498 -#define FFTW_K971429893 0.9714298932647099623746131301214786871614 -#define FFTW_K971567089 0.9715670893979414829343695558577052136741 -#define FFTW_K971811568 0.9718115683235416873794201547326635821400 -#define FFTW_K972022914 0.9720229140804107808510859601443895664086 -#define FFTW_K972369920 0.9723699203976766018336458341187976440025 -#define FFTW_K972758663 0.9727586637650371566638855431106228008872 -#define FFTW_K973044870 0.9730448705798238388328851727846959200348 -#define FFTW_K973264373 0.9732643737003824959312345137172719428005 -#define FFTW_K973438054 0.9734380543606928258135514267061557560963 -#define FFTW_K973695423 0.9736954238777790443618756632395424075067 -#define FFTW_K973876979 0.9738769792773336481496899701335503917353 -#define FFTW_K974011916 0.9740119169423335138154695987232315341728 -#define FFTW_K974116147 0.9741161479953870616712023593468831967519 -#define FFTW_K974927912 0.9749279121818236070181316829939312172328 -#define FFTW_K975702130 0.9757021300385285444603957664195279716440 -#define FFTW_K975796382 0.9757963826274356228783491415777791577932 -#define FFTW_K975916761 0.9759167619387473989575160319010275841997 -#define FFTW_K976075877 0.9760758775559271590070457564913246259691 -#define FFTW_K976296007 0.9762960071199333659708864896054275771653 -#define FFTW_K976620555 0.9766205557100866832082279628778633517990 -#define FFTW_K976848317 0.9768483177596007116214126531054889178029 -#define FFTW_K977146865 0.9771468659711595194867185493399910586943 -#define FFTW_K977403389 0.9774033898178666485587216924073730415593 -#define FFTW_K977555238 0.9775552389476861943402493547982576354464 -#define FFTW_K977726916 0.9777269163708468952746194417086665766233 -#define FFTW_K978147600 0.9781476007338056379285667478695995324597 -#define FFTW_K978556492 0.9785564922995040021441569982979483175857 -#define FFTW_K978716845 0.9787168453273544836415447921951226189869 -#define FFTW_K978855685 0.9788556850953578475488459902421741595530 -#define FFTW_K979084087 0.9790840876823228756328148847602371349846 -#define FFTW_K979340621 0.9793406217655515015104288246369218020372 -#define FFTW_K979529941 0.9795299412524944939380064428117707242914 -#define FFTW_K979790652 0.9797906520422677014706319852738255873975 -#define FFTW_K979961705 0.9799617050365868167949249404815421840498 -#define FFTW_K980082561 0.9800825610923934085579115422063699191729 -#define FFTW_K980172487 0.9801724878485438426221952928871404568919 -#define FFTW_K980785280 0.9807852804032304491261822361342390369739 -#define FFTW_K981451493 0.9814514932524178941230111511474289750195 -#define FFTW_K981559156 0.9815591569910653538492430476851306890594 -#define FFTW_K981708319 0.9817083199968549376776858998806597451093 -#define FFTW_K981928697 0.9819286972627067003986744426247459609910 -#define FFTW_K982083682 0.9820836827421560010932038226168804103451 -#define FFTW_K982287250 0.9822872507286886810856417428652684163884 -#define FFTW_K982566473 0.9825664732332882361458695018243242460076 -#define FFTW_K982684124 0.9826841245925209408606988628810258780288 -#define FFTW_K982973099 0.9829730996839017782819488448551987160987 -#define FFTW_K983254907 0.9832549075639545845546320564305089875746 -#define FFTW_K983365676 0.9833656768294661196753671326297494335829 -#define FFTW_K983619906 0.9836199069471435884212429322426942302141 -#define FFTW_K983797951 0.9837979515735163526446952978240676138119 -#define FFTW_K983929588 0.9839295885986296553956360939899698965200 -#define FFTW_K984111204 0.9841112043361161061416962408560232630074 -#define FFTW_K984230577 0.9842305779475968124404416073840495619445 -#define FFTW_K984315023 0.9843150237975341546618492275637931110120 -#define FFTW_K984807753 0.9848077530122080593667430245895230136706 -#define FFTW_K985277642 0.9852776423889412447740184331785477871601 -#define FFTW_K985353835 0.9853538358476930122394797176177663749267 -#define FFTW_K985459517 0.9854595177171968680142498259365517811271 -#define FFTW_K985615910 0.9856159103477084622647702939762184573686 -#define FFTW_K985871018 0.9858710185182358739239575569680608455649 -#define FFTW_K986070253 0.9860702539900285422933352225912048513788 -#define FFTW_K986361303 0.9863613034027223736025091948190671107285 -#define FFTW_K986643332 0.9866433320848790047469239329842060425036 -#define FFTW_K986826522 0.9868265225415261517686243504388935079839 -#define FFTW_K987050262 0.9870502626379128637906800282243959059321 -#define FFTW_K987181783 0.9871817834144501341077945503208892301209 -#define FFTW_K987268354 0.9872683547213445699907431277816711317672 -#define FFTW_K987688340 0.9876883405951377261900402476934372607584 -#define FFTW_K988087896 0.9880878960910771492992690811307084884358 -#define FFTW_K988165472 0.9881654720812594137618841327936534641992 -#define FFTW_K988280423 0.9882804237803485263249493778325853582721 -#define FFTW_K988468324 0.9884683243281113991621906894031537749210 -#define FFTW_K988615412 0.9886154122075342261549440645140983788437 -#define FFTW_K988830826 0.9888308262251285450697428829340086130652 -#define FFTW_K989040187 0.9890401873221639791098880794573835995058 -#define FFTW_K989176509 0.9891765099647809734516737380162430639837 -#define FFTW_K989343368 0.9893433680751101977923535631123350883204 -#define FFTW_K989441638 0.9894416385809445189738370649369388973400 -#define FFTW_K989821441 0.9898214418809327323760920377767187873765 -#define FFTW_K990181125 0.9901811253364455904432628100327605252812 -#define FFTW_K990268068 0.9902680687415703150837748673448507592511 -#define FFTW_K990410430 0.9904104308752051583495612400629094294845 -#define FFTW_K990522084 0.9905220846375032755297487161751806762898 -#define FFTW_K990685946 0.9906859460363307523423229600962060051400 -#define FFTW_K990845596 0.9908455965788067627878172563691414037669 -#define FFTW_K990949761 0.9909497617679347552486867131683644064606 -#define FFTW_K991077488 0.9910774881547800989077028808834981789933 -#define FFTW_K991152831 0.9911528310040071586383345991233567829241 -#define FFTW_K991444861 0.9914448613738104111445575269285628712777 -#define FFTW_K991722674 0.9917226741361015058214790070582345607756 -#define FFTW_K991790013 0.9917900138232461089574427772187849280190 -#define FFTW_K991900435 0.9919004352588768873144078072665135340842 -#define FFTW_K991987177 0.9919871770507430065166704184575838095046 -#define FFTW_K992114701 0.9921147013144778310497930427857785214530 -#define FFTW_K992239206 0.9922392066001720806339750438970024692424 -#define FFTW_K992320579 0.9923205797370450627452009318759713711174 -#define FFTW_K992420509 0.9924205096719357582614560541072921874651 -#define FFTW_K992479534 0.9924795345987099981567672516611178200108 -#define FFTW_K992708874 0.9927088740980539928007516494925201793436 -#define FFTW_K992981096 0.9929810960135169614675928693736574381005 -#define FFTW_K993068456 0.9930684569549262956374372478102157228837 -#define FFTW_K993238357 0.9932383577419429885478955521937043403491 -#define FFTW_K993402089 0.9934020897596750687947423983479637156807 -#define FFTW_K993481735 0.9934817353485502085180496808547969202400 -#define FFTW_K993712209 0.9937122098932425835331482419473786971526 -#define FFTW_K993930677 0.9939306773179494792563298151574801808174 -#define FFTW_K994000975 0.9940009752399459187884342036497682765393 -#define FFTW_K994137957 0.9941379571543596089553027158795515668545 -#define FFTW_K994270301 0.9942703017718973183669165054181572463000 -#define FFTW_K994334800 0.9943348002101371309920980500642722883465 -#define FFTW_K994521895 0.9945218953682733369226919449805703815208 -#define FFTW_K994699875 0.9946998756145890479762568067220906149617 -#define FFTW_K994757278 0.9947572788580948291790636723123688992574 -#define FFTW_K994869323 0.9948693233918951463213533098837194930039 -#define FFTW_K994977815 0.9949778150885040755354075401441960635882 -#define FFTW_K995030775 0.9950307753654014099099494968280711167442 -#define FFTW_K995184726 0.9951847266721968862448369531094799215754 -#define FFTW_K995379112 0.9953791129491982046051034132093649871861 -#define FFTW_K995471922 0.9954719225730846047262552811299306157575 -#define FFTW_K995561964 0.9955619646030800128976780442146194187237 -#define FFTW_K995734176 0.9957341762950345218711911789054817839027 -#define FFTW_K995896557 0.9958965576170909700362686366938831171748 -#define FFTW_K995974293 0.9959742939952390295817189937211678685354 -#define FFTW_K996049842 0.9960498426152169249788048954440014509192 -#define FFTW_K996194698 0.9961946980917455322950104024738880461835 -#define FFTW_K996331730 0.9963317308626913876242320559879490045416 -#define FFTW_K996397488 0.9963974885425265016515427736575384585731 -#define FFTW_K996461494 0.9964614941176191465297827729475896395564 -#define FFTW_K996584493 0.9965844930066698498193520007504877187805 -#define FFTW_K996701189 0.9967011895602227462429879020699209472138 -#define FFTW_K996757308 0.9967573081342099855852412239757600532391 -#define FFTW_K996812007 0.9968120070307501492577958043253480021674 -#define FFTW_K996917333 0.9969173337331279761977734087420444201589 -#define FFTW_K997017526 0.9970175264485266683508923434628785416228 -#define FFTW_K997065801 0.9970658011837404621446414104254119713626 -#define FFTW_K997112913 0.9971129134476474623595146912637885801501 -#define FFTW_K997203797 0.9972037971811801482250298708781192656558 -#define FFTW_K997290456 0.9972904566786902161355971401825678211717 -#define FFTW_K997332283 0.9973322836635516728058606115895235926462 -#define FFTW_K997452114 0.9974521146102535413623057568371267046549 -#define FFTW_K997564050 0.9975640502598242476131626806442550263694 -#define FFTW_K997668769 0.9976687691905391984535782806992783166368 -#define FFTW_K997766878 0.9977668786231531595627548884062599817399 -#define FFTW_K997858923 0.9978589232386035067380697912727776045318 -#define FFTW_K997945392 0.9979453927503363420088404809579925550286 -#define FFTW_K998026728 0.9980267284282715619523368068634505533369 -#define FFTW_K998103328 0.9981033287370440781595580722798538475393 -#define FFTW_K998175554 0.9981755542233174708416597487435284042144 -#define FFTW_K998243731 0.9982437317643214135795104790047750439576 -#define FFTW_K998308158 0.9983081582712682080478207087832775329371 -#define FFTW_K998369103 0.9983691039261356791012880254984185496026 -#define FFTW_K998426815 0.9984268150178165621314250714948528394090 -#define FFTW_K998481516 0.9984815164333162254755259567160496340501 -#define FFTW_K998533413 0.9985334138511238645717905110783489569243 -#define FFTW_K998582695 0.9985826956767619481118898673784527334232 -#define FFTW_K998629534 0.9986295347545738737844920584394365805909 -#define FFTW_K998674089 0.9986740898848305076057717645316607303307 -#define FFTW_K998716507 0.9987165071710528071463114367595140457475 -#define FFTW_K998756921 0.9987569212189223697539952989398761436398 -#define FFTW_K998795456 0.9987954562051723927147716047591006944432 -#define FFTW_K998867339 0.9988673391830079766626725799084316622350 -#define FFTW_K998932974 0.9989329748023724444057615270546990770867 -#define FFTW_K998993066 0.9989930665413146473720559084446391440926 -#define FFTW_K999048221 0.9990482215818577624037162194033297553505 -#define FFTW_K999098966 0.9990989662046814723577027912279173440084 -#define FFTW_K999145758 0.9991457583873010291856105308946378568012 -#define FFTW_K999188998 0.9991889981715696377009069466390679555486 -#define FFTW_K999229036 0.9992290362407229347371262603414616252706 -#define FFTW_K999266181 0.9992661810508100203932244590995250044712 -#define FFTW_K999300704 0.9993007047883985526997800741767273557026 -#define FFTW_K999332848 0.9993328483702393720704821228710461134067 -#define FFTW_K999362825 0.9993628256569916913056650851375650424587 -#define FFTW_K999390827 0.9993908270190957300062434400439299644952 -#define FFTW_K999417022 0.9994170223661740289494017247549951505277 -#define FFTW_K999441563 0.9994415637302546063156399140856621311902 -#define FFTW_K999464587 0.9994645874763656444298364462428599458836 -#define FFTW_K999486216 0.9994862162006878676974893970113697242550 -#define FFTW_K999506560 0.9995065603657315570006908367092536671784 -#define FFTW_K999525719 0.9995257197133658746658464748330096458419 -#define FFTW_K999543784 0.9995437844895333725476836898291665684873 -#define FFTW_K999560836 0.9995608365087943494271135836565668351702 -#define FFTW_K999576950 0.9995769500822005769626607634052808295813 -#define FFTW_K999592192 0.9995921928281892296257285154349983157366 -#define FFTW_K999606626 0.9996066263830528855052742630847215222778 -#define FFTW_K999620307 0.9996203070249514057426708547796085483660 -#define FFTW_K999633286 0.9996332862232839494682650720821574004171 -#define FFTW_K999645611 0.9996456111234525767555760293242736879144 -#define FFTW_K999657324 0.9996573249755572800367608883676798759498 -#define FFTW_K999668467 0.9996684675143130940321877350828094000117 -#define FFTW_K999679075 0.9996790752964305212076609008127490933988 -#define FFTW_K999689182 0.9996891820008162841543067648951099180292 -#define FFTW_K999698818 0.9996988186962042201157656496661721968500 diff --git a/quantum_espresso/kcp/clib/make.depend b/quantum_espresso/kcp/clib/make.depend deleted file mode 100644 index 96b23b187..000000000 --- a/quantum_espresso/kcp/clib/make.depend +++ /dev/null @@ -1,10 +0,0 @@ -c_mkdir.o : ../include/c_defs.h -cptimer.o : ../include/c_defs.h -eval_infix.o : ../include/c_defs.h -fft_stick.o : ../include/c_defs.h -fft_stick.o : fftw.c -fftw.o : -fftw.o : -indici.o : ../include/c_defs.h -memstat.o : ../include/c_defs.h -stack.o : ../include/c_defs.h diff --git a/quantum_espresso/kcp/clib/memstat.c b/quantum_espresso/kcp/clib/memstat.c deleted file mode 100644 index 55c39c308..000000000 --- a/quantum_espresso/kcp/clib/memstat.c +++ /dev/null @@ -1,41 +0,0 @@ -/* - Copyright (C) 2002 FPMD group - This file is distributed under the terms of the - GNU General Public License. See the file `License' - in the root directory of the present distribution, - or http://www.gnu.org/copyleft/gpl.txt . -*/ - -#include "c_defs.h" - -/* - This function return the numer of kilobytes allocated - by the calling process. - Auhor: Carlo Cavazzoni. -*/ - -#if defined (__SVR4) && defined (__sun) -#define SUN_MALLINFO -#endif - -#if defined(HAVE_MALLINFO) && !defined(__QK_USER__) && !defined(SUN__MALLINFO) -#include - -void F77_FUNC(memstat,MEMSTAT)(int *kilobytes) -{ - - struct mallinfo info; - info = mallinfo(); - -#if defined(__AIX) - *kilobytes = (info.arena) / 1024 ; -#else - *kilobytes = (info.arena + info.hblkhd) / 1024 ; -#endif - -#else -void F77_FUNC(memstat,MEMSTAT)(int *kilobytes) -{ - *kilobytes = -1; -#endif -} diff --git a/quantum_espresso/kcp/clib/qsort.c b/quantum_espresso/kcp/clib/qsort.c deleted file mode 100644 index 3d09fc12c..000000000 --- a/quantum_espresso/kcp/clib/qsort.c +++ /dev/null @@ -1,63 +0,0 @@ -/* - Copyright (C) 2002 FPMD group - This file is distributed under the terms of the - GNU General Public License. See the file `License' - in the root directory of the present distribution, - or http://www.gnu.org/copyleft/gpl.txt . -*/ - -#include -#include - -/* qsort - quick sort - - qsort(n,comp,swap) - unsigned n; - int (*comp)(); - int (*swap)(); - ***** see bsort for parameters - -*/ - -static unsigned _rearr(unsigned lb,unsigned ub); -static void _quick(unsigned lb,unsigned ub); -static int (*_comp)(unsigned,unsigned), (*_swap)(unsigned,unsigned); - -void Qsort(unsigned n,int (*comp)(),int (*swap)()) -{ - _comp = comp; - _swap = swap; - _quick(0,n-1); -} - - -static void _quick(unsigned lb,unsigned ub) -{ -unsigned j; - -if(lb lb && (*_comp)(ub,lb) >=0) ub--; - - if(ub != lb) - { - (*_swap)(ub,lb); - while(lb -#include -#ifdef __INTEL - -#include - -void F77_FUNC_(remove_stack_limit,REMOVE_STACK_LIMIT) (void) { - - struct rlimit rlim = { RLIM_INFINITY, RLIM_INFINITY }; - - /* Modified according to Cesar Da Silva suggestions */ - if ( setrlimit(RLIMIT_STACK, &rlim) == -1 ) { - if ( getrlimit(RLIMIT_STACK, &rlim) == 0 ) { - rlim.rlim_cur = rlim.rlim_max; - if ( setrlimit(RLIMIT_STACK, &rlim) == 0 ) { - getrlimit(RLIMIT_STACK, &rlim); - } else { - perror(" Cannot set stack size to new value"); - } - } - } -} - -#else -void F77_FUNC_(remove_stack_limit,REMOVE_STACK_LIMIT) (void) { -} -#endif diff --git a/quantum_espresso/kcp/config.guess b/quantum_espresso/kcp/config.guess deleted file mode 100755 index fc98ea0b4..000000000 --- a/quantum_espresso/kcp/config.guess +++ /dev/null @@ -1,1415 +0,0 @@ -#! /bin/sh -# Attempt to guess a canonical system name. -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -# 2000, 2001, 2002, 2003 Free Software Foundation, Inc. - -timestamp='2003-07-02' - -# This file is free software; you can redistribute it and/or modify it -# under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that program. - -# Originally written by Per Bothner . -# Please send patches to . Submit a context -# diff and a properly formatted ChangeLog entry. -# -# This script attempts to guess a canonical system name similar to -# config.sub. If it succeeds, it prints the system name on stdout, and -# exits with 0. Otherwise, it exits with 1. -# -# The plan is that this can be called by configure scripts if you -# don't specify an explicit build system type. - -me=`echo "$0" | sed -e 's,.*/,,'` - -usage="\ -Usage: $0 [OPTION] - -Output the configuration name of the system \`$me' is run on. - -Operation modes: - -h, --help print this help, then exit - -t, --time-stamp print date of last modification, then exit - -v, --version print version number, then exit - -Report bugs and patches to ." - -version="\ -GNU config.guess ($timestamp) - -Originally written by Per Bothner. -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 -Free Software Foundation, Inc. - -This is free software; see the source for copying conditions. There is NO -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." - -help=" -Try \`$me --help' for more information." - -# Parse command line -while test $# -gt 0 ; do - case $1 in - --time-stamp | --time* | -t ) - echo "$timestamp" ; exit 0 ;; - --version | -v ) - echo "$version" ; exit 0 ;; - --help | --h* | -h ) - echo "$usage"; exit 0 ;; - -- ) # Stop option processing - shift; break ;; - - ) # Use stdin as input. - break ;; - -* ) - echo "$me: invalid option $1$help" >&2 - exit 1 ;; - * ) - break ;; - esac -done - -if test $# != 0; then - echo "$me: too many arguments$help" >&2 - exit 1 -fi - -trap 'exit 1' 1 2 15 - -# CC_FOR_BUILD -- compiler used by this script. Note that the use of a -# compiler to aid in system detection is discouraged as it requires -# temporary files to be created and, as you can see below, it is a -# headache to deal with in a portable fashion. - -# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still -# use `HOST_CC' if defined, but it is deprecated. - -# Portable tmp directory creation inspired by the Autoconf team. - -set_cc_for_build=' -trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; -trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; -: ${TMPDIR=/tmp} ; - { tmp=`(umask 077 && mktemp -d -q "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || - { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || - { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || - { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; -dummy=$tmp/dummy ; -tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; -case $CC_FOR_BUILD,$HOST_CC,$CC in - ,,) echo "int x;" > $dummy.c ; - for c in cc gcc c89 c99 ; do - if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then - CC_FOR_BUILD="$c"; break ; - fi ; - done ; - if test x"$CC_FOR_BUILD" = x ; then - CC_FOR_BUILD=no_compiler_found ; - fi - ;; - ,,*) CC_FOR_BUILD=$CC ;; - ,*,*) CC_FOR_BUILD=$HOST_CC ;; -esac ;' - -# This is needed to find uname on a Pyramid OSx when run in the BSD universe. -# (ghazi@noc.rutgers.edu 1994-08-24) -if (test -f /.attbin/uname) >/dev/null 2>&1 ; then - PATH=$PATH:/.attbin ; export PATH -fi - -UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown -UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown -UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown -UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown - -# Note: order is significant - the case branches are not exclusive. - -case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in - *:NetBSD:*:*) - # NetBSD (nbsd) targets should (where applicable) match one or - # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, - # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently - # switched to ELF, *-*-netbsd* would select the old - # object file format. This provides both forward - # compatibility and a consistent mechanism for selecting the - # object file format. - # - # Note: NetBSD doesn't particularly care about the vendor - # portion of the name. We always set it to "unknown". - sysctl="sysctl -n hw.machine_arch" - UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ - /usr/sbin/$sysctl 2>/dev/null || echo unknown)` - case "${UNAME_MACHINE_ARCH}" in - armeb) machine=armeb-unknown ;; - arm*) machine=arm-unknown ;; - sh3el) machine=shl-unknown ;; - sh3eb) machine=sh-unknown ;; - *) machine=${UNAME_MACHINE_ARCH}-unknown ;; - esac - # The Operating System including object format, if it has switched - # to ELF recently, or will in the future. - case "${UNAME_MACHINE_ARCH}" in - arm*|i386|m68k|ns32k|sh3*|sparc|vax) - eval $set_cc_for_build - if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep __ELF__ >/dev/null - then - # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). - # Return netbsd for either. FIX? - os=netbsd - else - os=netbsdelf - fi - ;; - *) - os=netbsd - ;; - esac - # The OS release - # Debian GNU/NetBSD machines have a different userland, and - # thus, need a distinct triplet. However, they do not need - # kernel version information, so it can be replaced with a - # suitable tag, in the style of linux-gnu. - case "${UNAME_VERSION}" in - Debian*) - release='-gnu' - ;; - *) - release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` - ;; - esac - # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: - # contains redundant information, the shorter form: - # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. - echo "${machine}-${os}${release}" - exit 0 ;; - amiga:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - arc:OpenBSD:*:*) - echo mipsel-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - hp300:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - mac68k:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - macppc:OpenBSD:*:*) - echo powerpc-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - mvme68k:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - mvme88k:OpenBSD:*:*) - echo m88k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - mvmeppc:OpenBSD:*:*) - echo powerpc-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - pmax:OpenBSD:*:*) - echo mipsel-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - sgi:OpenBSD:*:*) - echo mipseb-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - sun3:OpenBSD:*:*) - echo m68k-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - wgrisc:OpenBSD:*:*) - echo mipsel-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - *:OpenBSD:*:*) - echo ${UNAME_MACHINE}-unknown-openbsd${UNAME_RELEASE} - exit 0 ;; - alpha:OSF1:*:*) - if test $UNAME_RELEASE = "V4.0"; then - UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` - fi - # According to Compaq, /usr/sbin/psrinfo has been available on - # OSF/1 and Tru64 systems produced since 1995. I hope that - # covers most systems running today. This code pipes the CPU - # types through head -n 1, so we only detect the type of CPU 0. - ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` - case "$ALPHA_CPU_TYPE" in - "EV4 (21064)") - UNAME_MACHINE="alpha" ;; - "EV4.5 (21064)") - UNAME_MACHINE="alpha" ;; - "LCA4 (21066/21068)") - UNAME_MACHINE="alpha" ;; - "EV5 (21164)") - UNAME_MACHINE="alphaev5" ;; - "EV5.6 (21164A)") - UNAME_MACHINE="alphaev56" ;; - "EV5.6 (21164PC)") - UNAME_MACHINE="alphapca56" ;; - "EV5.7 (21164PC)") - UNAME_MACHINE="alphapca57" ;; - "EV6 (21264)") - UNAME_MACHINE="alphaev6" ;; - "EV6.7 (21264A)") - UNAME_MACHINE="alphaev67" ;; - "EV6.8CB (21264C)") - UNAME_MACHINE="alphaev68" ;; - "EV6.8AL (21264B)") - UNAME_MACHINE="alphaev68" ;; - "EV6.8CX (21264D)") - UNAME_MACHINE="alphaev68" ;; - "EV6.9A (21264/EV69A)") - UNAME_MACHINE="alphaev69" ;; - "EV7 (21364)") - UNAME_MACHINE="alphaev7" ;; - "EV7.9 (21364A)") - UNAME_MACHINE="alphaev79" ;; - esac - # A Vn.n version is a released version. - # A Tn.n version is a released field test version. - # A Xn.n version is an unreleased experimental baselevel. - # 1.2 uses "1.2" for uname -r. - echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[VTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - exit 0 ;; - Alpha*:OpenVMS:*:*) - echo alpha-hp-vms - exit 0 ;; - Alpha\ *:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # Should we change UNAME_MACHINE based on the output of uname instead - # of the specific Alpha model? - echo alpha-pc-interix - exit 0 ;; - 21064:Windows_NT:50:3) - echo alpha-dec-winnt3.5 - exit 0 ;; - Amiga*:UNIX_System_V:4.0:*) - echo m68k-unknown-sysv4 - exit 0;; - *:[Aa]miga[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-unknown-amigaos - exit 0 ;; - *:[Mm]orph[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-unknown-morphos - exit 0 ;; - *:OS/390:*:*) - echo i370-ibm-openedition - exit 0 ;; - arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) - echo arm-acorn-riscix${UNAME_RELEASE} - exit 0;; - SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) - echo hppa1.1-hitachi-hiuxmpp - exit 0;; - Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) - # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. - if test "`(/bin/universe) 2>/dev/null`" = att ; then - echo pyramid-pyramid-sysv3 - else - echo pyramid-pyramid-bsd - fi - exit 0 ;; - NILE*:*:*:dcosx) - echo pyramid-pyramid-svr4 - exit 0 ;; - DRS?6000:unix:4.0:6*) - echo sparc-icl-nx6 - exit 0 ;; - DRS?6000:UNIX_SV:4.2*:7*) - case `/usr/bin/uname -p` in - sparc) echo sparc-icl-nx7 && exit 0 ;; - esac ;; - sun4H:SunOS:5.*:*) - echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) - echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - i86pc:SunOS:5.*:*) - echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - sun4*:SunOS:6*:*) - # According to config.sub, this is the proper way to canonicalize - # SunOS6. Hard to guess exactly what SunOS6 will be like, but - # it's likely to be more like Solaris than SunOS4. - echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - sun4*:SunOS:*:*) - case "`/usr/bin/arch -k`" in - Series*|S4*) - UNAME_RELEASE=`uname -v` - ;; - esac - # Japanese Language versions have a version number like `4.1.3-JL'. - echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` - exit 0 ;; - sun3*:SunOS:*:*) - echo m68k-sun-sunos${UNAME_RELEASE} - exit 0 ;; - sun*:*:4.2BSD:*) - UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` - test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 - case "`/bin/arch`" in - sun3) - echo m68k-sun-sunos${UNAME_RELEASE} - ;; - sun4) - echo sparc-sun-sunos${UNAME_RELEASE} - ;; - esac - exit 0 ;; - aushp:SunOS:*:*) - echo sparc-auspex-sunos${UNAME_RELEASE} - exit 0 ;; - # The situation for MiNT is a little confusing. The machine name - # can be virtually everything (everything which is not - # "atarist" or "atariste" at least should have a processor - # > m68000). The system name ranges from "MiNT" over "FreeMiNT" - # to the lowercase version "mint" (or "freemint"). Finally - # the system name "TOS" denotes a system which is actually not - # MiNT. But MiNT is downward compatible to TOS, so this should - # be no problem. - atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit 0 ;; - atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit 0 ;; - *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit 0 ;; - milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) - echo m68k-milan-mint${UNAME_RELEASE} - exit 0 ;; - hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) - echo m68k-hades-mint${UNAME_RELEASE} - exit 0 ;; - *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) - echo m68k-unknown-mint${UNAME_RELEASE} - exit 0 ;; - powerpc:machten:*:*) - echo powerpc-apple-machten${UNAME_RELEASE} - exit 0 ;; - RISC*:Mach:*:*) - echo mips-dec-mach_bsd4.3 - exit 0 ;; - RISC*:ULTRIX:*:*) - echo mips-dec-ultrix${UNAME_RELEASE} - exit 0 ;; - VAX*:ULTRIX*:*:*) - echo vax-dec-ultrix${UNAME_RELEASE} - exit 0 ;; - 2020:CLIX:*:* | 2430:CLIX:*:*) - echo clipper-intergraph-clix${UNAME_RELEASE} - exit 0 ;; - mips:*:*:UMIPS | mips:*:*:RISCos) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c -#ifdef __cplusplus -#include /* for printf() prototype */ - int main (int argc, char *argv[]) { -#else - int main (argc, argv) int argc; char *argv[]; { -#endif - #if defined (host_mips) && defined (MIPSEB) - #if defined (SYSTYPE_SYSV) - printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); - #endif - #if defined (SYSTYPE_SVR4) - printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); - #endif - #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) - printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); - #endif - #endif - exit (-1); - } -EOF - $CC_FOR_BUILD -o $dummy $dummy.c \ - && $dummy `echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` \ - && exit 0 - echo mips-mips-riscos${UNAME_RELEASE} - exit 0 ;; - Motorola:PowerMAX_OS:*:*) - echo powerpc-motorola-powermax - exit 0 ;; - Motorola:*:4.3:PL8-*) - echo powerpc-harris-powermax - exit 0 ;; - Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) - echo powerpc-harris-powermax - exit 0 ;; - Night_Hawk:Power_UNIX:*:*) - echo powerpc-harris-powerunix - exit 0 ;; - m88k:CX/UX:7*:*) - echo m88k-harris-cxux7 - exit 0 ;; - m88k:*:4*:R4*) - echo m88k-motorola-sysv4 - exit 0 ;; - m88k:*:3*:R3*) - echo m88k-motorola-sysv3 - exit 0 ;; - AViiON:dgux:*:*) - # DG/UX returns AViiON for all architectures - UNAME_PROCESSOR=`/usr/bin/uname -p` - if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] - then - if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ - [ ${TARGET_BINARY_INTERFACE}x = x ] - then - echo m88k-dg-dgux${UNAME_RELEASE} - else - echo m88k-dg-dguxbcs${UNAME_RELEASE} - fi - else - echo i586-dg-dgux${UNAME_RELEASE} - fi - exit 0 ;; - M88*:DolphinOS:*:*) # DolphinOS (SVR3) - echo m88k-dolphin-sysv3 - exit 0 ;; - M88*:*:R3*:*) - # Delta 88k system running SVR3 - echo m88k-motorola-sysv3 - exit 0 ;; - XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) - echo m88k-tektronix-sysv3 - exit 0 ;; - Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) - echo m68k-tektronix-bsd - exit 0 ;; - *:IRIX*:*:*) - echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` - exit 0 ;; - ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. - echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id - exit 0 ;; # Note that: echo "'`uname -s`'" gives 'AIX ' - i*86:AIX:*:*) - echo i386-ibm-aix - exit 0 ;; - ia64:AIX:*:*) - # - # depending on system configuration, on some aix machines - # /usr/bin/oslevel may crash this script and configure - # - #if [ -x /usr/bin/oslevel ] ; then - # IBM_REV=`/usr/bin/oslevel` - #else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} - #fi - echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} - exit 0 ;; - *:AIX:2:3) - if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - - main() - { - if (!__power_pc()) - exit(1); - puts("powerpc-ibm-aix3.2.5"); - exit(0); - } -EOF - $CC_FOR_BUILD -o $dummy $dummy.c && $dummy && exit 0 - echo rs6000-ibm-aix3.2.5 - elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then - echo rs6000-ibm-aix3.2.4 - else - echo rs6000-ibm-aix3.2 - fi - exit 0 ;; - *:AIX:*:[45]) - IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` - if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then - IBM_ARCH=rs6000 - else - IBM_ARCH=powerpc - fi - # - # depending on system configuration, on some aix machines - # /usr/bin/oslevel may crash this script and configure - # - #if [ -x /usr/bin/oslevel ] ; then - # IBM_REV=`/usr/bin/oslevel` - #else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} - #fi - echo ${IBM_ARCH}-ibm-aix${IBM_REV} - exit 0 ;; - *:AIX:*:*) - echo rs6000-ibm-aix - exit 0 ;; - ibmrt:4.4BSD:*|romp-ibm:BSD:*) - echo romp-ibm-bsd4.4 - exit 0 ;; - ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and - echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to - exit 0 ;; # report: romp-ibm BSD 4.3 - *:BOSX:*:*) - echo rs6000-bull-bosx - exit 0 ;; - DPX/2?00:B.O.S.:*:*) - echo m68k-bull-sysv3 - exit 0 ;; - 9000/[34]??:4.3bsd:1.*:*) - echo m68k-hp-bsd - exit 0 ;; - hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) - echo m68k-hp-bsd4.4 - exit 0 ;; - 9000/[34678]??:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - case "${UNAME_MACHINE}" in - 9000/31? ) HP_ARCH=m68000 ;; - 9000/[34]?? ) HP_ARCH=m68k ;; - 9000/[678][0-9][0-9]) - if [ -x /usr/bin/getconf ]; then - sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` - sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` - case "${sc_cpu_version}" in - 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 - 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 - 532) # CPU_PA_RISC2_0 - case "${sc_kernel_bits}" in - 32) HP_ARCH="hppa2.0n" ;; - 64) HP_ARCH="hppa2.0w" ;; - '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 - esac ;; - esac - fi - if [ "${HP_ARCH}" = "" ]; then - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - - #define _HPUX_SOURCE - #include - #include - - int main () - { - #if defined(_SC_KERNEL_BITS) - long bits = sysconf(_SC_KERNEL_BITS); - #endif - long cpu = sysconf (_SC_CPU_VERSION); - - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1"); break; - case CPU_PA_RISC2_0: - #if defined(_SC_KERNEL_BITS) - switch (bits) - { - case 64: puts ("hppa2.0w"); break; - case 32: puts ("hppa2.0n"); break; - default: puts ("hppa2.0"); break; - } break; - #else /* !defined(_SC_KERNEL_BITS) */ - puts ("hppa2.0"); break; - #endif - default: puts ("hppa1.0"); break; - } - exit (0); - } -EOF - (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` - test -z "$HP_ARCH" && HP_ARCH=hppa - fi ;; - esac - if [ ${HP_ARCH} = "hppa2.0w" ] - then - # avoid double evaluation of $set_cc_for_build - test -n "$CC_FOR_BUILD" || eval $set_cc_for_build - if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E -) | grep __LP64__ >/dev/null - then - HP_ARCH="hppa2.0w" - else - HP_ARCH="hppa64" - fi - fi - echo ${HP_ARCH}-hp-hpux${HPUX_REV} - exit 0 ;; - ia64:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - echo ia64-hp-hpux${HPUX_REV} - exit 0 ;; - 3050*:HI-UX:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - int - main () - { - long cpu = sysconf (_SC_CPU_VERSION); - /* The order matters, because CPU_IS_HP_MC68K erroneously returns - true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct - results, however. */ - if (CPU_IS_PA_RISC (cpu)) - { - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; - case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; - default: puts ("hppa-hitachi-hiuxwe2"); break; - } - } - else if (CPU_IS_HP_MC68K (cpu)) - puts ("m68k-hitachi-hiuxwe2"); - else puts ("unknown-hitachi-hiuxwe2"); - exit (0); - } -EOF - $CC_FOR_BUILD -o $dummy $dummy.c && $dummy && exit 0 - echo unknown-hitachi-hiuxwe2 - exit 0 ;; - 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) - echo hppa1.1-hp-bsd - exit 0 ;; - 9000/8??:4.3bsd:*:*) - echo hppa1.0-hp-bsd - exit 0 ;; - *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) - echo hppa1.0-hp-mpeix - exit 0 ;; - hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) - echo hppa1.1-hp-osf - exit 0 ;; - hp8??:OSF1:*:*) - echo hppa1.0-hp-osf - exit 0 ;; - i*86:OSF1:*:*) - if [ -x /usr/sbin/sysversion ] ; then - echo ${UNAME_MACHINE}-unknown-osf1mk - else - echo ${UNAME_MACHINE}-unknown-osf1 - fi - exit 0 ;; - parisc*:Lites*:*:*) - echo hppa1.1-hp-lites - exit 0 ;; - C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) - echo c1-convex-bsd - exit 0 ;; - C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit 0 ;; - C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) - echo c34-convex-bsd - exit 0 ;; - C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) - echo c38-convex-bsd - exit 0 ;; - C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) - echo c4-convex-bsd - exit 0 ;; - CRAY*Y-MP:*:*:*) - echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit 0 ;; - CRAY*[A-Z]90:*:*:*) - echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ - | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ - -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ - -e 's/\.[^.]*$/.X/' - exit 0 ;; - CRAY*TS:*:*:*) - echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit 0 ;; - CRAY*T3E:*:*:*) - echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit 0 ;; - CRAY*SV1:*:*:*) - echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit 0 ;; - *:UNICOS/mp:*:*) - echo nv1-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit 0 ;; - F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) - FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` - echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" - exit 0 ;; - i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) - echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} - exit 0 ;; - sparc*:BSD/OS:*:*) - echo sparc-unknown-bsdi${UNAME_RELEASE} - exit 0 ;; - *:BSD/OS:*:*) - echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} - exit 0 ;; - *:FreeBSD:*:*|*:GNU/FreeBSD:*:*) - # Determine whether the default compiler uses glibc. - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - #if __GLIBC__ >= 2 - LIBC=gnu - #else - LIBC= - #endif -EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=` - # GNU/FreeBSD systems have a "k" prefix to indicate we are using - # FreeBSD's kernel, but not the complete OS. - case ${LIBC} in gnu) kernel_only='k' ;; esac - echo ${UNAME_MACHINE}-unknown-${kernel_only}freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`${LIBC:+-$LIBC} - exit 0 ;; - i*:CYGWIN*:*) - echo ${UNAME_MACHINE}-pc-cygwin - exit 0 ;; - i*:MINGW*:*) - echo ${UNAME_MACHINE}-pc-mingw32 - exit 0 ;; - i*:PW*:*) - echo ${UNAME_MACHINE}-pc-pw32 - exit 0 ;; - x86:Interix*:[34]*) - echo i586-pc-interix${UNAME_RELEASE}|sed -e 's/\..*//' - exit 0 ;; - [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) - echo i${UNAME_MACHINE}-pc-mks - exit 0 ;; - i*:Windows_NT*:* | Pentium*:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we - # UNAME_MACHINE based on the output of uname instead of i386? - echo i586-pc-interix - exit 0 ;; - i*:UWIN*:*) - echo ${UNAME_MACHINE}-pc-uwin - exit 0 ;; - p*:CYGWIN*:*) - echo powerpcle-unknown-cygwin - exit 0 ;; - prep*:SunOS:5.*:*) - echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - *:GNU:*:*) - echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` - exit 0 ;; - i*86:Minix:*:*) - echo ${UNAME_MACHINE}-pc-minix - exit 0 ;; - arm*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; - cris:Linux:*:*) - echo cris-axis-linux-gnu - exit 0 ;; - ia64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; - m68*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; - mips:Linux:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #undef CPU - #undef mips - #undef mipsel - #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) - CPU=mipsel - #else - #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) - CPU=mips - #else - CPU= - #endif - #endif -EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^CPU=` - test x"${CPU}" != x && echo "${CPU}-unknown-linux-gnu" && exit 0 - ;; - mips64:Linux:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #undef CPU - #undef mips64 - #undef mips64el - #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) - CPU=mips64el - #else - #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) - CPU=mips64 - #else - CPU= - #endif - #endif -EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^CPU=` - test x"${CPU}" != x && echo "${CPU}-unknown-linux-gnu" && exit 0 - ;; - ppc:Linux:*:*) - echo powerpc-unknown-linux-gnu - exit 0 ;; - ppc64:Linux:*:*) - echo powerpc64-unknown-linux-gnu - exit 0 ;; - alpha:Linux:*:*) - case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in - EV5) UNAME_MACHINE=alphaev5 ;; - EV56) UNAME_MACHINE=alphaev56 ;; - PCA56) UNAME_MACHINE=alphapca56 ;; - PCA57) UNAME_MACHINE=alphapca56 ;; - EV6) UNAME_MACHINE=alphaev6 ;; - EV67) UNAME_MACHINE=alphaev67 ;; - EV68*) UNAME_MACHINE=alphaev68 ;; - esac - objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null - if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi - echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} - exit 0 ;; - parisc:Linux:*:* | hppa:Linux:*:*) - # Look for CPU level - case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in - PA7*) echo hppa1.1-unknown-linux-gnu ;; - PA8*) echo hppa2.0-unknown-linux-gnu ;; - *) echo hppa-unknown-linux-gnu ;; - esac - exit 0 ;; - parisc64:Linux:*:* | hppa64:Linux:*:*) - echo hppa64-unknown-linux-gnu - exit 0 ;; - s390:Linux:*:* | s390x:Linux:*:*) - echo ${UNAME_MACHINE}-ibm-linux - exit 0 ;; - sh64*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; - sh*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; - sparc:Linux:*:* | sparc64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit 0 ;; - x86_64:Linux:*:*) - echo x86_64-unknown-linux-gnu - exit 0 ;; - i*86:Linux:*:*) - # The BFD linker knows what the default object file format is, so - # first see if it will tell us. cd to the root directory to prevent - # problems with other programs or directories called `ld' in the path. - # Set LC_ALL=C to ensure ld outputs messages in English. - ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \ - | sed -ne '/supported targets:/!d - s/[ ][ ]*/ /g - s/.*supported targets: *// - s/ .*// - p'` - case "$ld_supported_targets" in - elf32-i386) - TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu" - ;; - a.out-i386-linux) - echo "${UNAME_MACHINE}-pc-linux-gnuaout" - exit 0 ;; - coff-i386) - echo "${UNAME_MACHINE}-pc-linux-gnucoff" - exit 0 ;; - "") - # Either a pre-BFD a.out linker (linux-gnuoldld) or - # one that does not give us useful --help. - echo "${UNAME_MACHINE}-pc-linux-gnuoldld" - exit 0 ;; - esac - # Determine whether the default compiler is a.out or elf - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - #ifdef __ELF__ - # ifdef __GLIBC__ - # if __GLIBC__ >= 2 - LIBC=gnu - # else - LIBC=gnulibc1 - # endif - # else - LIBC=gnulibc1 - # endif - #else - #ifdef __INTEL_COMPILER - LIBC=gnu - #else - LIBC=gnuaout - #endif - #endif -EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=` - test x"${LIBC}" != x && echo "${UNAME_MACHINE}-pc-linux-${LIBC}" && exit 0 - test x"${TENTATIVE}" != x && echo "${TENTATIVE}" && exit 0 - ;; - i*86:DYNIX/ptx:4*:*) - # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. - # earlier versions are messed up and put the nodename in both - # sysname and nodename. - echo i386-sequent-sysv4 - exit 0 ;; - i*86:UNIX_SV:4.2MP:2.*) - # Unixware is an offshoot of SVR4, but it has its own version - # number series starting with 2... - # I am not positive that other SVR4 systems won't match this, - # I just have to hope. -- rms. - # Use sysv4.2uw... so that sysv4* matches it. - echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} - exit 0 ;; - i*86:OS/2:*:*) - # If we were able to find `uname', then EMX Unix compatibility - # is probably installed. - echo ${UNAME_MACHINE}-pc-os2-emx - exit 0 ;; - i*86:XTS-300:*:STOP) - echo ${UNAME_MACHINE}-unknown-stop - exit 0 ;; - i*86:atheos:*:*) - echo ${UNAME_MACHINE}-unknown-atheos - exit 0 ;; - i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*) - echo i386-unknown-lynxos${UNAME_RELEASE} - exit 0 ;; - i*86:*DOS:*:*) - echo ${UNAME_MACHINE}-pc-msdosdjgpp - exit 0 ;; - i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) - UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` - if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then - echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} - else - echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} - fi - exit 0 ;; - i*86:*:5:[78]*) - case `/bin/uname -X | grep "^Machine"` in - *486*) UNAME_MACHINE=i486 ;; - *Pentium) UNAME_MACHINE=i586 ;; - *Pent*|*Celeron) UNAME_MACHINE=i686 ;; - esac - echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} - exit 0 ;; - i*86:*:3.2:*) - if test -f /usr/options/cb.name; then - UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then - UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` - (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 - (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ - && UNAME_MACHINE=i586 - (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ - && UNAME_MACHINE=i686 - (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ - && UNAME_MACHINE=i686 - echo ${UNAME_MACHINE}-pc-sco$UNAME_REL - else - echo ${UNAME_MACHINE}-pc-sysv32 - fi - exit 0 ;; - pc:*:*:*) - # Left here for compatibility: - # uname -m prints for DJGPP always 'pc', but it prints nothing about - # the processor, so we play safe by assuming i386. - echo i386-pc-msdosdjgpp - exit 0 ;; - Intel:Mach:3*:*) - echo i386-pc-mach3 - exit 0 ;; - paragon:*:*:*) - echo i860-intel-osf1 - exit 0 ;; - i860:*:4.*:*) # i860-SVR4 - if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then - echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 - else # Add other i860-SVR4 vendors below as they are discovered. - echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 - fi - exit 0 ;; - mini*:CTIX:SYS*5:*) - # "miniframe" - echo m68010-convergent-sysv - exit 0 ;; - mc68k:UNIX:SYSTEM5:3.51m) - echo m68k-convergent-sysv - exit 0 ;; - M680?0:D-NIX:5.3:*) - echo m68k-diab-dnix - exit 0 ;; - M68*:*:R3V[567]*:*) - test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;; - 3[34]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0) - OS_REL='' - test -r /etc/.relid \ - && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && echo i486-ncr-sysv4.3${OS_REL} && exit 0 - /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ - && echo i586-ncr-sysv4.3${OS_REL} && exit 0 ;; - 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && echo i486-ncr-sysv4 && exit 0 ;; - m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) - echo m68k-unknown-lynxos${UNAME_RELEASE} - exit 0 ;; - mc68030:UNIX_System_V:4.*:*) - echo m68k-atari-sysv4 - exit 0 ;; - TSUNAMI:LynxOS:2.*:*) - echo sparc-unknown-lynxos${UNAME_RELEASE} - exit 0 ;; - rs6000:LynxOS:2.*:*) - echo rs6000-unknown-lynxos${UNAME_RELEASE} - exit 0 ;; - PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*) - echo powerpc-unknown-lynxos${UNAME_RELEASE} - exit 0 ;; - SM[BE]S:UNIX_SV:*:*) - echo mips-dde-sysv${UNAME_RELEASE} - exit 0 ;; - RM*:ReliantUNIX-*:*:*) - echo mips-sni-sysv4 - exit 0 ;; - RM*:SINIX-*:*:*) - echo mips-sni-sysv4 - exit 0 ;; - *:SINIX-*:*:*) - if uname -p 2>/dev/null >/dev/null ; then - UNAME_MACHINE=`(uname -p) 2>/dev/null` - echo ${UNAME_MACHINE}-sni-sysv4 - else - echo ns32k-sni-sysv - fi - exit 0 ;; - PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort - # says - echo i586-unisys-sysv4 - exit 0 ;; - *:UNIX_System_V:4*:FTX*) - # From Gerald Hewes . - # How about differentiating between stratus architectures? -djm - echo hppa1.1-stratus-sysv4 - exit 0 ;; - *:*:*:FTX*) - # From seanf@swdc.stratus.com. - echo i860-stratus-sysv4 - exit 0 ;; - *:VOS:*:*) - # From Paul.Green@stratus.com. - echo hppa1.1-stratus-vos - exit 0 ;; - mc68*:A/UX:*:*) - echo m68k-apple-aux${UNAME_RELEASE} - exit 0 ;; - news*:NEWS-OS:6*:*) - echo mips-sony-newsos6 - exit 0 ;; - R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) - if [ -d /usr/nec ]; then - echo mips-nec-sysv${UNAME_RELEASE} - else - echo mips-unknown-sysv${UNAME_RELEASE} - fi - exit 0 ;; - BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. - echo powerpc-be-beos - exit 0 ;; - BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. - echo powerpc-apple-beos - exit 0 ;; - BePC:BeOS:*:*) # BeOS running on Intel PC compatible. - echo i586-pc-beos - exit 0 ;; - SX-4:SUPER-UX:*:*) - echo sx4-nec-superux${UNAME_RELEASE} - exit 0 ;; - SX-5:SUPER-UX:*:*) - echo sx5-nec-superux${UNAME_RELEASE} - exit 0 ;; - SX-6:SUPER-UX:*:*) - echo sx6-nec-superux${UNAME_RELEASE} - exit 0 ;; - Power*:Rhapsody:*:*) - echo powerpc-apple-rhapsody${UNAME_RELEASE} - exit 0 ;; - *:Rhapsody:*:*) - echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} - exit 0 ;; - *:Darwin:*:*) - case `uname -p` in - *86) UNAME_PROCESSOR=i686 ;; - powerpc) UNAME_PROCESSOR=powerpc ;; - esac - echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} - exit 0 ;; - *:procnto*:*:* | *:QNX:[0123456789]*:*) - UNAME_PROCESSOR=`uname -p` - if test "$UNAME_PROCESSOR" = "x86"; then - UNAME_PROCESSOR=i386 - UNAME_MACHINE=pc - fi - echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} - exit 0 ;; - *:QNX:*:4*) - echo i386-pc-qnx - exit 0 ;; - NSR-[DGKLNPTVW]:NONSTOP_KERNEL:*:*) - echo nsr-tandem-nsk${UNAME_RELEASE} - exit 0 ;; - *:NonStop-UX:*:*) - echo mips-compaq-nonstopux - exit 0 ;; - BS2000:POSIX*:*:*) - echo bs2000-siemens-sysv - exit 0 ;; - DS/*:UNIX_System_V:*:*) - echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} - exit 0 ;; - *:Plan9:*:*) - # "uname -m" is not consistent, so use $cputype instead. 386 - # is converted to i386 for consistency with other x86 - # operating systems. - if test "$cputype" = "386"; then - UNAME_MACHINE=i386 - else - UNAME_MACHINE="$cputype" - fi - echo ${UNAME_MACHINE}-unknown-plan9 - exit 0 ;; - *:TOPS-10:*:*) - echo pdp10-unknown-tops10 - exit 0 ;; - *:TENEX:*:*) - echo pdp10-unknown-tenex - exit 0 ;; - KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) - echo pdp10-dec-tops20 - exit 0 ;; - XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) - echo pdp10-xkl-tops20 - exit 0 ;; - *:TOPS-20:*:*) - echo pdp10-unknown-tops20 - exit 0 ;; - *:ITS:*:*) - echo pdp10-unknown-its - exit 0 ;; - SEI:*:*:SEIUX) - echo mips-sei-seiux${UNAME_RELEASE} - exit 0 ;; -esac - -#echo '(No uname command or uname output not recognized.)' 1>&2 -#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 - -eval $set_cc_for_build -cat >$dummy.c < -# include -#endif -main () -{ -#if defined (sony) -#if defined (MIPSEB) - /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, - I don't know.... */ - printf ("mips-sony-bsd\n"); exit (0); -#else -#include - printf ("m68k-sony-newsos%s\n", -#ifdef NEWSOS4 - "4" -#else - "" -#endif - ); exit (0); -#endif -#endif - -#if defined (__arm) && defined (__acorn) && defined (__unix) - printf ("arm-acorn-riscix"); exit (0); -#endif - -#if defined (hp300) && !defined (hpux) - printf ("m68k-hp-bsd\n"); exit (0); -#endif - -#if defined (NeXT) -#if !defined (__ARCHITECTURE__) -#define __ARCHITECTURE__ "m68k" -#endif - int version; - version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; - if (version < 4) - printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); - else - printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); - exit (0); -#endif - -#if defined (MULTIMAX) || defined (n16) -#if defined (UMAXV) - printf ("ns32k-encore-sysv\n"); exit (0); -#else -#if defined (CMU) - printf ("ns32k-encore-mach\n"); exit (0); -#else - printf ("ns32k-encore-bsd\n"); exit (0); -#endif -#endif -#endif - -#if defined (__386BSD__) - printf ("i386-pc-bsd\n"); exit (0); -#endif - -#if defined (sequent) -#if defined (i386) - printf ("i386-sequent-dynix\n"); exit (0); -#endif -#if defined (ns32000) - printf ("ns32k-sequent-dynix\n"); exit (0); -#endif -#endif - -#if defined (_SEQUENT_) - struct utsname un; - - uname(&un); - - if (strncmp(un.version, "V2", 2) == 0) { - printf ("i386-sequent-ptx2\n"); exit (0); - } - if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ - printf ("i386-sequent-ptx1\n"); exit (0); - } - printf ("i386-sequent-ptx\n"); exit (0); - -#endif - -#if defined (vax) -# if !defined (ultrix) -# include -# if defined (BSD) -# if BSD == 43 - printf ("vax-dec-bsd4.3\n"); exit (0); -# else -# if BSD == 199006 - printf ("vax-dec-bsd4.3reno\n"); exit (0); -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# endif -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# else - printf ("vax-dec-ultrix\n"); exit (0); -# endif -#endif - -#if defined (alliant) && defined (i860) - printf ("i860-alliant-bsd\n"); exit (0); -#endif - - exit (1); -} -EOF - -$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && $dummy && exit 0 - -# Apollos put the system type in the environment. - -test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; } - -# Convex versions that predate uname can use getsysinfo(1) - -if [ -x /usr/convex/getsysinfo ] -then - case `getsysinfo -f cpu_type` in - c1*) - echo c1-convex-bsd - exit 0 ;; - c2*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit 0 ;; - c34*) - echo c34-convex-bsd - exit 0 ;; - c38*) - echo c38-convex-bsd - exit 0 ;; - c4*) - echo c4-convex-bsd - exit 0 ;; - esac -fi - -cat >&2 < in order to provide the needed -information to handle your system. - -config.guess timestamp = $timestamp - -uname -m = `(uname -m) 2>/dev/null || echo unknown` -uname -r = `(uname -r) 2>/dev/null || echo unknown` -uname -s = `(uname -s) 2>/dev/null || echo unknown` -uname -v = `(uname -v) 2>/dev/null || echo unknown` - -/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` -/bin/uname -X = `(/bin/uname -X) 2>/dev/null` - -hostinfo = `(hostinfo) 2>/dev/null` -/bin/universe = `(/bin/universe) 2>/dev/null` -/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` -/bin/arch = `(/bin/arch) 2>/dev/null` -/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` -/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` - -UNAME_MACHINE = ${UNAME_MACHINE} -UNAME_RELEASE = ${UNAME_RELEASE} -UNAME_SYSTEM = ${UNAME_SYSTEM} -UNAME_VERSION = ${UNAME_VERSION} -EOF - -exit 1 - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "timestamp='" -# time-stamp-format: "%:y-%02m-%02d" -# time-stamp-end: "'" -# End: diff --git a/quantum_espresso/kcp/config.sub b/quantum_espresso/kcp/config.sub deleted file mode 100644 index c8a01bed9..000000000 --- a/quantum_espresso/kcp/config.sub +++ /dev/null @@ -1,1504 +0,0 @@ -#! /bin/sh -# Configuration validation subroutine script. -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -# 2000, 2001, 2002, 2003 Free Software Foundation, Inc. - -timestamp='2003-07-04' - -# This file is (in principle) common to ALL GNU software. -# The presence of a machine in this file suggests that SOME GNU software -# can handle that machine. It does not imply ALL GNU software can. -# -# This file is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. - -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that program. - -# Please send patches to . Submit a context -# diff and a properly formatted ChangeLog entry. -# -# Configuration subroutine to validate and canonicalize a configuration type. -# Supply the specified configuration type as an argument. -# If it is invalid, we print an error message on stderr and exit with code 1. -# Otherwise, we print the canonical config type on stdout and succeed. - -# This file is supposed to be the same for all GNU packages -# and recognize all the CPU types, system types and aliases -# that are meaningful with *any* GNU software. -# Each package is responsible for reporting which valid configurations -# it does not support. The user should be able to distinguish -# a failure to support a valid configuration from a meaningless -# configuration. - -# The goal of this file is to map all the various variations of a given -# machine specification into a single specification in the form: -# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM -# or in some cases, the newer four-part form: -# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM -# It is wrong to echo any other type of specification. - -me=`echo "$0" | sed -e 's,.*/,,'` - -usage="\ -Usage: $0 [OPTION] CPU-MFR-OPSYS - $0 [OPTION] ALIAS - -Canonicalize a configuration name. - -Operation modes: - -h, --help print this help, then exit - -t, --time-stamp print date of last modification, then exit - -v, --version print version number, then exit - -Report bugs and patches to ." - -version="\ -GNU config.sub ($timestamp) - -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 -Free Software Foundation, Inc. - -This is free software; see the source for copying conditions. There is NO -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." - -help=" -Try \`$me --help' for more information." - -# Parse command line -while test $# -gt 0 ; do - case $1 in - --time-stamp | --time* | -t ) - echo "$timestamp" ; exit 0 ;; - --version | -v ) - echo "$version" ; exit 0 ;; - --help | --h* | -h ) - echo "$usage"; exit 0 ;; - -- ) # Stop option processing - shift; break ;; - - ) # Use stdin as input. - break ;; - -* ) - echo "$me: invalid option $1$help" - exit 1 ;; - - *local*) - # First pass through any local machine types. - echo $1 - exit 0;; - - * ) - break ;; - esac -done - -case $# in - 0) echo "$me: missing argument$help" >&2 - exit 1;; - 1) ;; - *) echo "$me: too many arguments$help" >&2 - exit 1;; -esac - -# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). -# Here we must recognize all the valid KERNEL-OS combinations. -maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` -case $maybe_os in - nto-qnx* | linux-gnu* | kfreebsd*-gnu* | netbsd*-gnu* | storm-chaos* | os2-emx* | rtmk-nova*) - os=-$maybe_os - basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` - ;; - *) - basic_machine=`echo $1 | sed 's/-[^-]*$//'` - if [ $basic_machine != $1 ] - then os=`echo $1 | sed 's/.*-/-/'` - else os=; fi - ;; -esac - -### Let's recognize common machines as not being operating systems so -### that things like config.sub decstation-3100 work. We also -### recognize some manufacturers as not being operating systems, so we -### can provide default operating systems below. -case $os in - -sun*os*) - # Prevent following clause from handling this invalid input. - ;; - -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ - -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ - -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ - -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ - -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ - -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ - -apple | -axis) - os= - basic_machine=$1 - ;; - -sim | -cisco | -oki | -wec | -winbond) - os= - basic_machine=$1 - ;; - -scout) - ;; - -wrs) - os=-vxworks - basic_machine=$1 - ;; - -chorusos*) - os=-chorusos - basic_machine=$1 - ;; - -chorusrdb) - os=-chorusrdb - basic_machine=$1 - ;; - -hiux*) - os=-hiuxwe2 - ;; - -sco5) - os=-sco3.2v5 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco4) - os=-sco3.2v4 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco3.2.[4-9]*) - os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco3.2v[4-9]*) - # Don't forget version if it is 3.2v4 or newer. - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco*) - os=-sco3.2v2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -udk*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -isc) - os=-isc2.2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -clix*) - basic_machine=clipper-intergraph - ;; - -isc*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -lynx*) - os=-lynxos - ;; - -ptx*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` - ;; - -windowsnt*) - os=`echo $os | sed -e 's/windowsnt/winnt/'` - ;; - -psos*) - os=-psos - ;; - -mint | -mint[0-9]*) - basic_machine=m68k-atari - os=-mint - ;; -esac - -# Decode aliases for certain CPU-COMPANY combinations. -case $basic_machine in - # Recognize the basic CPU types without company name. - # Some are omitted here because they have special meanings below. - 1750a | 580 \ - | a29k \ - | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ - | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ - | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \ - | c4x | clipper \ - | d10v | d30v | dlx | dsp16xx \ - | fr30 | frv \ - | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ - | i370 | i860 | i960 | ia64 \ - | ip2k \ - | m32r | m68000 | m68k | m88k | mcore \ - | mips | mipsbe | mipseb | mipsel | mipsle \ - | mips16 \ - | mips64 | mips64el \ - | mips64vr | mips64vrel \ - | mips64orion | mips64orionel \ - | mips64vr4100 | mips64vr4100el \ - | mips64vr4300 | mips64vr4300el \ - | mips64vr5000 | mips64vr5000el \ - | mipsisa32 | mipsisa32el \ - | mipsisa32r2 | mipsisa32r2el \ - | mipsisa64 | mipsisa64el \ - | mipsisa64sb1 | mipsisa64sb1el \ - | mipsisa64sr71k | mipsisa64sr71kel \ - | mipstx39 | mipstx39el \ - | mn10200 | mn10300 \ - | msp430 \ - | ns16k | ns32k \ - | openrisc | or32 \ - | pdp10 | pdp11 | pj | pjl \ - | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \ - | pyramid \ - | sh | sh[1234] | sh[23]e | sh[34]eb | shbe | shle | sh[1234]le | sh3ele \ - | sh64 | sh64le \ - | sparc | sparc64 | sparc86x | sparclet | sparclite | sparcv9 | sparcv9b \ - | strongarm \ - | tahoe | thumb | tic4x | tic80 | tron \ - | v850 | v850e \ - | we32k \ - | x86 | xscale | xstormy16 | xtensa \ - | z8k) - basic_machine=$basic_machine-unknown - ;; - m6811 | m68hc11 | m6812 | m68hc12) - # Motorola 68HC11/12. - basic_machine=$basic_machine-unknown - os=-none - ;; - m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) - ;; - - # We use `pc' rather than `unknown' - # because (1) that's what they normally are, and - # (2) the word "unknown" tends to confuse beginning users. - i*86 | x86_64) - basic_machine=$basic_machine-pc - ;; - # Object if more than one company name word. - *-*-*) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; - # Recognize the basic CPU types with company name. - 580-* \ - | a29k-* \ - | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ - | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ - | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ - | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ - | avr-* \ - | bs2000-* \ - | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \ - | clipper-* | cydra-* \ - | d10v-* | d30v-* | dlx-* \ - | elxsi-* \ - | f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \ - | h8300-* | h8500-* \ - | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ - | i*86-* | i860-* | i960-* | ia64-* \ - | ip2k-* \ - | m32r-* \ - | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ - | m88110-* | m88k-* | mcore-* \ - | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ - | mips16-* \ - | mips64-* | mips64el-* \ - | mips64vr-* | mips64vrel-* \ - | mips64orion-* | mips64orionel-* \ - | mips64vr4100-* | mips64vr4100el-* \ - | mips64vr4300-* | mips64vr4300el-* \ - | mips64vr5000-* | mips64vr5000el-* \ - | mipsisa32-* | mipsisa32el-* \ - | mipsisa32r2-* | mipsisa32r2el-* \ - | mipsisa64-* | mipsisa64el-* \ - | mipsisa64sb1-* | mipsisa64sb1el-* \ - | mipsisa64sr71k-* | mipsisa64sr71kel-* \ - | mipstx39-* | mipstx39el-* \ - | msp430-* \ - | none-* | np1-* | nv1-* | ns16k-* | ns32k-* \ - | orion-* \ - | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ - | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \ - | pyramid-* \ - | romp-* | rs6000-* \ - | sh-* | sh[1234]-* | sh[23]e-* | sh[34]eb-* | shbe-* \ - | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ - | sparc-* | sparc64-* | sparc86x-* | sparclet-* | sparclite-* \ - | sparcv9-* | sparcv9b-* | strongarm-* | sv1-* | sx?-* \ - | tahoe-* | thumb-* \ - | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ - | tron-* \ - | v850-* | v850e-* | vax-* \ - | we32k-* \ - | x86-* | x86_64-* | xps100-* | xscale-* | xstormy16-* \ - | xtensa-* \ - | ymp-* \ - | z8k-*) - ;; - # Recognize the various machine names and aliases which stand - # for a CPU type and a company and sometimes even an OS. - 386bsd) - basic_machine=i386-unknown - os=-bsd - ;; - 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) - basic_machine=m68000-att - ;; - 3b*) - basic_machine=we32k-att - ;; - a29khif) - basic_machine=a29k-amd - os=-udi - ;; - adobe68k) - basic_machine=m68010-adobe - os=-scout - ;; - alliant | fx80) - basic_machine=fx80-alliant - ;; - altos | altos3068) - basic_machine=m68k-altos - ;; - am29k) - basic_machine=a29k-none - os=-bsd - ;; - amd64) - basic_machine=x86_64-pc - ;; - amdahl) - basic_machine=580-amdahl - os=-sysv - ;; - amiga | amiga-*) - basic_machine=m68k-unknown - ;; - amigaos | amigados) - basic_machine=m68k-unknown - os=-amigaos - ;; - amigaunix | amix) - basic_machine=m68k-unknown - os=-sysv4 - ;; - apollo68) - basic_machine=m68k-apollo - os=-sysv - ;; - apollo68bsd) - basic_machine=m68k-apollo - os=-bsd - ;; - aux) - basic_machine=m68k-apple - os=-aux - ;; - balance) - basic_machine=ns32k-sequent - os=-dynix - ;; - c90) - basic_machine=c90-cray - os=-unicos - ;; - convex-c1) - basic_machine=c1-convex - os=-bsd - ;; - convex-c2) - basic_machine=c2-convex - os=-bsd - ;; - convex-c32) - basic_machine=c32-convex - os=-bsd - ;; - convex-c34) - basic_machine=c34-convex - os=-bsd - ;; - convex-c38) - basic_machine=c38-convex - os=-bsd - ;; - cray | j90) - basic_machine=j90-cray - os=-unicos - ;; - crds | unos) - basic_machine=m68k-crds - ;; - cris | cris-* | etrax*) - basic_machine=cris-axis - ;; - da30 | da30-*) - basic_machine=m68k-da30 - ;; - decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) - basic_machine=mips-dec - ;; - decsystem10* | dec10*) - basic_machine=pdp10-dec - os=-tops10 - ;; - decsystem20* | dec20*) - basic_machine=pdp10-dec - os=-tops20 - ;; - delta | 3300 | motorola-3300 | motorola-delta \ - | 3300-motorola | delta-motorola) - basic_machine=m68k-motorola - ;; - delta88) - basic_machine=m88k-motorola - os=-sysv3 - ;; - dpx20 | dpx20-*) - basic_machine=rs6000-bull - os=-bosx - ;; - dpx2* | dpx2*-bull) - basic_machine=m68k-bull - os=-sysv3 - ;; - ebmon29k) - basic_machine=a29k-amd - os=-ebmon - ;; - elxsi) - basic_machine=elxsi-elxsi - os=-bsd - ;; - encore | umax | mmax) - basic_machine=ns32k-encore - ;; - es1800 | OSE68k | ose68k | ose | OSE) - basic_machine=m68k-ericsson - os=-ose - ;; - fx2800) - basic_machine=i860-alliant - ;; - genix) - basic_machine=ns32k-ns - ;; - gmicro) - basic_machine=tron-gmicro - os=-sysv - ;; - go32) - basic_machine=i386-pc - os=-go32 - ;; - h3050r* | hiux*) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - h8300hms) - basic_machine=h8300-hitachi - os=-hms - ;; - h8300xray) - basic_machine=h8300-hitachi - os=-xray - ;; - h8500hms) - basic_machine=h8500-hitachi - os=-hms - ;; - harris) - basic_machine=m88k-harris - os=-sysv3 - ;; - hp300-*) - basic_machine=m68k-hp - ;; - hp300bsd) - basic_machine=m68k-hp - os=-bsd - ;; - hp300hpux) - basic_machine=m68k-hp - os=-hpux - ;; - hp3k9[0-9][0-9] | hp9[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hp9k2[0-9][0-9] | hp9k31[0-9]) - basic_machine=m68000-hp - ;; - hp9k3[2-9][0-9]) - basic_machine=m68k-hp - ;; - hp9k6[0-9][0-9] | hp6[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hp9k7[0-79][0-9] | hp7[0-79][0-9]) - basic_machine=hppa1.1-hp - ;; - hp9k78[0-9] | hp78[0-9]) - # FIXME: really hppa2.0-hp - basic_machine=hppa1.1-hp - ;; - hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) - # FIXME: really hppa2.0-hp - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][13679] | hp8[0-9][13679]) - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][0-9] | hp8[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hppa-next) - os=-nextstep3 - ;; - hppaosf) - basic_machine=hppa1.1-hp - os=-osf - ;; - hppro) - basic_machine=hppa1.1-hp - os=-proelf - ;; - i370-ibm* | ibm*) - basic_machine=i370-ibm - ;; -# I'm not sure what "Sysv32" means. Should this be sysv3.2? - i*86v32) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv32 - ;; - i*86v4*) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv4 - ;; - i*86v) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv - ;; - i*86sol2) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-solaris2 - ;; - i386mach) - basic_machine=i386-mach - os=-mach - ;; - i386-vsta | vsta) - basic_machine=i386-unknown - os=-vsta - ;; - iris | iris4d) - basic_machine=mips-sgi - case $os in - -irix*) - ;; - *) - os=-irix4 - ;; - esac - ;; - isi68 | isi) - basic_machine=m68k-isi - os=-sysv - ;; - m88k-omron*) - basic_machine=m88k-omron - ;; - magnum | m3230) - basic_machine=mips-mips - os=-sysv - ;; - merlin) - basic_machine=ns32k-utek - os=-sysv - ;; - mingw32) - basic_machine=i386-pc - os=-mingw32 - ;; - miniframe) - basic_machine=m68000-convergent - ;; - *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) - basic_machine=m68k-atari - os=-mint - ;; - mips3*-*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` - ;; - mips3*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown - ;; - mmix*) - basic_machine=mmix-knuth - os=-mmixware - ;; - monitor) - basic_machine=m68k-rom68k - os=-coff - ;; - morphos) - basic_machine=powerpc-unknown - os=-morphos - ;; - msdos) - basic_machine=i386-pc - os=-msdos - ;; - mvs) - basic_machine=i370-ibm - os=-mvs - ;; - ncr3000) - basic_machine=i486-ncr - os=-sysv4 - ;; - netbsd386) - basic_machine=i386-unknown - os=-netbsd - ;; - netwinder) - basic_machine=armv4l-rebel - os=-linux - ;; - news | news700 | news800 | news900) - basic_machine=m68k-sony - os=-newsos - ;; - news1000) - basic_machine=m68030-sony - os=-newsos - ;; - news-3600 | risc-news) - basic_machine=mips-sony - os=-newsos - ;; - necv70) - basic_machine=v70-nec - os=-sysv - ;; - next | m*-next ) - basic_machine=m68k-next - case $os in - -nextstep* ) - ;; - -ns2*) - os=-nextstep2 - ;; - *) - os=-nextstep3 - ;; - esac - ;; - nh3000) - basic_machine=m68k-harris - os=-cxux - ;; - nh[45]000) - basic_machine=m88k-harris - os=-cxux - ;; - nindy960) - basic_machine=i960-intel - os=-nindy - ;; - mon960) - basic_machine=i960-intel - os=-mon960 - ;; - nonstopux) - basic_machine=mips-compaq - os=-nonstopux - ;; - np1) - basic_machine=np1-gould - ;; - nv1) - basic_machine=nv1-cray - os=-unicosmp - ;; - nsr-tandem) - basic_machine=nsr-tandem - ;; - op50n-* | op60c-*) - basic_machine=hppa1.1-oki - os=-proelf - ;; - or32 | or32-*) - basic_machine=or32-unknown - os=-coff - ;; - OSE68000 | ose68000) - basic_machine=m68000-ericsson - os=-ose - ;; - os68k) - basic_machine=m68k-none - os=-os68k - ;; - pa-hitachi) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - paragon) - basic_machine=i860-intel - os=-osf - ;; - pbd) - basic_machine=sparc-tti - ;; - pbb) - basic_machine=m68k-tti - ;; - pc532 | pc532-*) - basic_machine=ns32k-pc532 - ;; - pentium | p5 | k5 | k6 | nexgen | viac3) - basic_machine=i586-pc - ;; - pentiumpro | p6 | 6x86 | athlon | athlon_*) - basic_machine=i686-pc - ;; - pentiumii | pentium2 | pentiumiii | pentium3) - basic_machine=i686-pc - ;; - pentium4) - basic_machine=i786-pc - ;; - pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) - basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentiumpro-* | p6-* | 6x86-* | athlon-*) - basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) - basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentium4-*) - basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pn) - basic_machine=pn-gould - ;; - power) basic_machine=power-ibm - ;; - ppc) basic_machine=powerpc-unknown - ;; - ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppcle | powerpclittle | ppc-le | powerpc-little) - basic_machine=powerpcle-unknown - ;; - ppcle-* | powerpclittle-*) - basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppc64) basic_machine=powerpc64-unknown - ;; - ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppc64le | powerpc64little | ppc64-le | powerpc64-little) - basic_machine=powerpc64le-unknown - ;; - ppc64le-* | powerpc64little-*) - basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ps2) - basic_machine=i386-ibm - ;; - pw32) - basic_machine=i586-unknown - os=-pw32 - ;; - rom68k) - basic_machine=m68k-rom68k - os=-coff - ;; - rm[46]00) - basic_machine=mips-siemens - ;; - rtpc | rtpc-*) - basic_machine=romp-ibm - ;; - s390 | s390-*) - basic_machine=s390-ibm - ;; - s390x | s390x-*) - basic_machine=s390x-ibm - ;; - sa29200) - basic_machine=a29k-amd - os=-udi - ;; - sb1) - basic_machine=mipsisa64sb1-unknown - ;; - sb1el) - basic_machine=mipsisa64sb1el-unknown - ;; - sei) - basic_machine=mips-sei - os=-seiux - ;; - sequent) - basic_machine=i386-sequent - ;; - sh) - basic_machine=sh-hitachi - os=-hms - ;; - sh64) - basic_machine=sh64-unknown - ;; - sparclite-wrs | simso-wrs) - basic_machine=sparclite-wrs - os=-vxworks - ;; - sps7) - basic_machine=m68k-bull - os=-sysv2 - ;; - spur) - basic_machine=spur-unknown - ;; - st2000) - basic_machine=m68k-tandem - ;; - stratus) - basic_machine=i860-stratus - os=-sysv4 - ;; - sun2) - basic_machine=m68000-sun - ;; - sun2os3) - basic_machine=m68000-sun - os=-sunos3 - ;; - sun2os4) - basic_machine=m68000-sun - os=-sunos4 - ;; - sun3os3) - basic_machine=m68k-sun - os=-sunos3 - ;; - sun3os4) - basic_machine=m68k-sun - os=-sunos4 - ;; - sun4os3) - basic_machine=sparc-sun - os=-sunos3 - ;; - sun4os4) - basic_machine=sparc-sun - os=-sunos4 - ;; - sun4sol2) - basic_machine=sparc-sun - os=-solaris2 - ;; - sun3 | sun3-*) - basic_machine=m68k-sun - ;; - sun4) - basic_machine=sparc-sun - ;; - sun386 | sun386i | roadrunner) - basic_machine=i386-sun - ;; - sv1) - basic_machine=sv1-cray - os=-unicos - ;; - symmetry) - basic_machine=i386-sequent - os=-dynix - ;; - t3e) - basic_machine=alphaev5-cray - os=-unicos - ;; - t90) - basic_machine=t90-cray - os=-unicos - ;; - tic54x | c54x*) - basic_machine=tic54x-unknown - os=-coff - ;; - tic55x | c55x*) - basic_machine=tic55x-unknown - os=-coff - ;; - tic6x | c6x*) - basic_machine=tic6x-unknown - os=-coff - ;; - tx39) - basic_machine=mipstx39-unknown - ;; - tx39el) - basic_machine=mipstx39el-unknown - ;; - toad1) - basic_machine=pdp10-xkl - os=-tops20 - ;; - tower | tower-32) - basic_machine=m68k-ncr - ;; - udi29k) - basic_machine=a29k-amd - os=-udi - ;; - ultra3) - basic_machine=a29k-nyu - os=-sym1 - ;; - v810 | necv810) - basic_machine=v810-nec - os=-none - ;; - vaxv) - basic_machine=vax-dec - os=-sysv - ;; - vms) - basic_machine=vax-dec - os=-vms - ;; - vpp*|vx|vx-*) - basic_machine=f301-fujitsu - ;; - vxworks960) - basic_machine=i960-wrs - os=-vxworks - ;; - vxworks68) - basic_machine=m68k-wrs - os=-vxworks - ;; - vxworks29k) - basic_machine=a29k-wrs - os=-vxworks - ;; - w65*) - basic_machine=w65-wdc - os=-none - ;; - w89k-*) - basic_machine=hppa1.1-winbond - os=-proelf - ;; - xps | xps100) - basic_machine=xps100-honeywell - ;; - ymp) - basic_machine=ymp-cray - os=-unicos - ;; - z8k-*-coff) - basic_machine=z8k-unknown - os=-sim - ;; - none) - basic_machine=none-none - os=-none - ;; - -# Here we handle the default manufacturer of certain CPU types. It is in -# some cases the only manufacturer, in others, it is the most popular. - w89k) - basic_machine=hppa1.1-winbond - ;; - op50n) - basic_machine=hppa1.1-oki - ;; - op60c) - basic_machine=hppa1.1-oki - ;; - romp) - basic_machine=romp-ibm - ;; - rs6000) - basic_machine=rs6000-ibm - ;; - vax) - basic_machine=vax-dec - ;; - pdp10) - # there are many clones, so DEC is not a safe bet - basic_machine=pdp10-unknown - ;; - pdp11) - basic_machine=pdp11-dec - ;; - we32k) - basic_machine=we32k-att - ;; - sh3 | sh4 | sh[34]eb | sh[1234]le | sh[23]ele) - basic_machine=sh-unknown - ;; - sh64) - basic_machine=sh64-unknown - ;; - sparc | sparcv9 | sparcv9b) - basic_machine=sparc-sun - ;; - cydra) - basic_machine=cydra-cydrome - ;; - orion) - basic_machine=orion-highlevel - ;; - orion105) - basic_machine=clipper-highlevel - ;; - mac | mpw | mac-mpw) - basic_machine=m68k-apple - ;; - pmac | pmac-mpw) - basic_machine=powerpc-apple - ;; - *-unknown) - # Make sure to match an already-canonicalized machine name. - ;; - *) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; -esac - -# Here we canonicalize certain aliases for manufacturers. -case $basic_machine in - *-digital*) - basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` - ;; - *-commodore*) - basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` - ;; - *) - ;; -esac - -# Decode manufacturer-specific aliases for certain operating systems. - -if [ x"$os" != x"" ] -then -case $os in - # First match some system type aliases - # that might get confused with valid system types. - # -solaris* is a basic system type, with this one exception. - -solaris1 | -solaris1.*) - os=`echo $os | sed -e 's|solaris1|sunos4|'` - ;; - -solaris) - os=-solaris2 - ;; - -svr4*) - os=-sysv4 - ;; - -unixware*) - os=-sysv4.2uw - ;; - -gnu/linux*) - os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` - ;; - # First accept the basic system types. - # The portable systems comes first. - # Each alternative MUST END IN A *, to match a version number. - # -sysv* is not here because it comes later, after sysvr4. - -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ - | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\ - | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ - | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ - | -aos* \ - | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ - | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ - | -hiux* | -386bsd* | -netbsd* | -openbsd* | -kfreebsd* | -freebsd* | -riscix* \ - | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ - | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ - | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ - | -chorusos* | -chorusrdb* \ - | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ - | -mingw32* | -linux-gnu* | -uxpv* | -beos* | -mpeix* | -udk* \ - | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ - | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ - | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ - | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ - | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ - | -powermax* | -dnix* | -nx6 | -nx7 | -sei*) - # Remember, each alternative MUST END IN *, to match a version number. - ;; - -qnx*) - case $basic_machine in - x86-* | i*86-*) - ;; - *) - os=-nto$os - ;; - esac - ;; - -nto-qnx*) - ;; - -nto*) - os=`echo $os | sed -e 's|nto|nto-qnx|'` - ;; - -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ - | -windows* | -osx | -abug | -netware* | -os9* | -beos* \ - | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) - ;; - -mac*) - os=`echo $os | sed -e 's|mac|macos|'` - ;; - -linux*) - os=`echo $os | sed -e 's|linux|linux-gnu|'` - ;; - -sunos5*) - os=`echo $os | sed -e 's|sunos5|solaris2|'` - ;; - -sunos6*) - os=`echo $os | sed -e 's|sunos6|solaris3|'` - ;; - -opened*) - os=-openedition - ;; - -wince*) - os=-wince - ;; - -osfrose*) - os=-osfrose - ;; - -osf*) - os=-osf - ;; - -utek*) - os=-bsd - ;; - -dynix*) - os=-bsd - ;; - -acis*) - os=-aos - ;; - -atheos*) - os=-atheos - ;; - -386bsd) - os=-bsd - ;; - -ctix* | -uts*) - os=-sysv - ;; - -nova*) - os=-rtmk-nova - ;; - -ns2 ) - os=-nextstep2 - ;; - -nsk*) - os=-nsk - ;; - # Preserve the version number of sinix5. - -sinix5.*) - os=`echo $os | sed -e 's|sinix|sysv|'` - ;; - -sinix*) - os=-sysv4 - ;; - -triton*) - os=-sysv3 - ;; - -oss*) - os=-sysv3 - ;; - -svr4) - os=-sysv4 - ;; - -svr3) - os=-sysv3 - ;; - -sysvr4) - os=-sysv4 - ;; - # This must come after -sysvr4. - -sysv*) - ;; - -ose*) - os=-ose - ;; - -es1800*) - os=-ose - ;; - -xenix) - os=-xenix - ;; - -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) - os=-mint - ;; - -aros*) - os=-aros - ;; - -kaos*) - os=-kaos - ;; - -none) - ;; - *) - # Get rid of the `-' at the beginning of $os. - os=`echo $os | sed 's/[^-]*-//'` - echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 - exit 1 - ;; -esac -else - -# Here we handle the default operating systems that come with various machines. -# The value should be what the vendor currently ships out the door with their -# machine or put another way, the most popular os provided with the machine. - -# Note that if you're going to try to match "-MANUFACTURER" here (say, -# "-sun"), then you have to tell the case statement up towards the top -# that MANUFACTURER isn't an operating system. Otherwise, code above -# will signal an error saying that MANUFACTURER isn't an operating -# system, and we'll never get to this point. - -case $basic_machine in - *-acorn) - os=-riscix1.2 - ;; - arm*-rebel) - os=-linux - ;; - arm*-semi) - os=-aout - ;; - c4x-* | tic4x-*) - os=-coff - ;; - # This must come before the *-dec entry. - pdp10-*) - os=-tops20 - ;; - pdp11-*) - os=-none - ;; - *-dec | vax-*) - os=-ultrix4.2 - ;; - m68*-apollo) - os=-domain - ;; - i386-sun) - os=-sunos4.0.2 - ;; - m68000-sun) - os=-sunos3 - # This also exists in the configure program, but was not the - # default. - # os=-sunos4 - ;; - m68*-cisco) - os=-aout - ;; - mips*-cisco) - os=-elf - ;; - mips*-*) - os=-elf - ;; - or32-*) - os=-coff - ;; - *-tti) # must be before sparc entry or we get the wrong os. - os=-sysv3 - ;; - sparc-* | *-sun) - os=-sunos4.1.1 - ;; - *-be) - os=-beos - ;; - *-ibm) - os=-aix - ;; - *-wec) - os=-proelf - ;; - *-winbond) - os=-proelf - ;; - *-oki) - os=-proelf - ;; - *-hp) - os=-hpux - ;; - *-hitachi) - os=-hiux - ;; - i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) - os=-sysv - ;; - *-cbm) - os=-amigaos - ;; - *-dg) - os=-dgux - ;; - *-dolphin) - os=-sysv3 - ;; - m68k-ccur) - os=-rtu - ;; - m88k-omron*) - os=-luna - ;; - *-next ) - os=-nextstep - ;; - *-sequent) - os=-ptx - ;; - *-crds) - os=-unos - ;; - *-ns) - os=-genix - ;; - i370-*) - os=-mvs - ;; - *-next) - os=-nextstep3 - ;; - *-gould) - os=-sysv - ;; - *-highlevel) - os=-bsd - ;; - *-encore) - os=-bsd - ;; - *-sgi) - os=-irix - ;; - *-siemens) - os=-sysv4 - ;; - *-masscomp) - os=-rtu - ;; - f30[01]-fujitsu | f700-fujitsu) - os=-uxpv - ;; - *-rom68k) - os=-coff - ;; - *-*bug) - os=-coff - ;; - *-apple) - os=-macos - ;; - *-atari*) - os=-mint - ;; - *) - os=-none - ;; -esac -fi - -# Here we handle the case where we know the os, and the CPU type, but not the -# manufacturer. We pick the logical manufacturer. -vendor=unknown -case $basic_machine in - *-unknown) - case $os in - -riscix*) - vendor=acorn - ;; - -sunos*) - vendor=sun - ;; - -aix*) - vendor=ibm - ;; - -beos*) - vendor=be - ;; - -hpux*) - vendor=hp - ;; - -mpeix*) - vendor=hp - ;; - -hiux*) - vendor=hitachi - ;; - -unos*) - vendor=crds - ;; - -dgux*) - vendor=dg - ;; - -luna*) - vendor=omron - ;; - -genix*) - vendor=ns - ;; - -mvs* | -opened*) - vendor=ibm - ;; - -ptx*) - vendor=sequent - ;; - -vxsim* | -vxworks* | -windiss*) - vendor=wrs - ;; - -aux*) - vendor=apple - ;; - -hms*) - vendor=hitachi - ;; - -mpw* | -macos*) - vendor=apple - ;; - -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) - vendor=atari - ;; - -vos*) - vendor=stratus - ;; - esac - basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` - ;; -esac - -echo $basic_machine$os -exit 0 - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "timestamp='" -# time-stamp-format: "%:y-%02m-%02d" -# time-stamp-end: "'" -# End: diff --git a/quantum_espresso/kcp/configure b/quantum_espresso/kcp/configure deleted file mode 100755 index d006a02c6..000000000 --- a/quantum_espresso/kcp/configure +++ /dev/null @@ -1,80 +0,0 @@ -#!/bin/bash -# -# Copyright (C) 2001-2016 Quantum ESPRESSO group -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License. See the file `License' in the root directory -# of the present distribution. -# -# -# This script is a simple wrapper calling the autoconf configuration -# script (configure) in install/ -# Dependencies may be also directly generated -# -# Courtesy of A. Ferretti and G. Bussi -# Modified by F. Spiga and P. Giannozzi -# -#================================================================ -# -MANUAL=" Usage - configure [-h, --help] [--save] [] - - -h, --help print this manual - --save do not make clean - these flags will be passed to - the autoconf configure - - After configuration, the make.inc file will be created in the - QE home (current) directory - NOTE: CUDA Fortran code available only as a separate package - - --------------------------------------------------------------- - Manual from autoconf configure : - --------------------------------------------------------------- -" -# -#================================================================ -# - -# run from directory where this script is -auxdir=`echo $0 | sed 's/\(.*\)\/.*/\1/'` # extract pathname -if [ "$auxdir" != "configure" ] ; then cd $auxdir ; fi - -# -# detect the simplest cases -# -case $1 in - ("-h" | "--help" ) echo "$MANUAL" ; ./install/configure --help ; exit 0 ;; -esac - - -# run the autoconf configure with the -# given cong_flags -# -test -e ./install/make.inc && rm ./install/make.inc -test -e ./install/configure.msg && rm ./install/configure.msg -#test -e ./install/Makefile && rm ./install/Makefile - -# SAFEGUARD: if you run configure without clean everything first there -# are chances that something goes wrong. Forcing veryclean then. - -if [[ ($1 =~ "--save") ]] ; then - shift; -elif [[ (-e make.inc) && (-e Makefile) ]] ; then - make -f Makefile veryclean -fi - -./install/configure "$@" - -# copy make.inc in the home dir -# and final clean up -# -test -e ./install/make.inc && mv ./install/make.inc . -test -e make.inc && mv make.inc make.sys -test -e config.log && mv config.log ./install/ -test -e config.status && mv config.status ./install/ -test -e configure.msg && mv configure.msg ./install/ - -exit 0 diff --git a/quantum_espresso/kcp/configure.msg.in b/quantum_espresso/kcp/configure.msg.in deleted file mode 100644 index 6dcf2a450..000000000 --- a/quantum_espresso/kcp/configure.msg.in +++ /dev/null @@ -1,22 +0,0 @@ --------------------------------------------------------------------- -ESPRESSO can take advantage of several optimized numerical libraries -(essl, fftw, mkl...). This configure script attempts to find them, -but may fail if they have been installed in non-standard locations. -If a required library is not found, the local copy will be compiled. - -The following libraries have been found: - @blas_line@ - @lapack_line@ - @fft_line@ - @mpi_line@ - @mass_line@ -Please check if this is what you expect. - -If any libraries are missing, you may specify a list of directories -to search and retry, as follows: - ./configure LIBDIRS="list of directories, separated by spaces" - -@parallel_report@ - -For more info, read the ESPRESSO User's Guide (Doc/users-guide.tex). --------------------------------------------------------------------- diff --git a/quantum_espresso/kcp/flib/Makefile b/quantum_espresso/kcp/flib/Makefile deleted file mode 100644 index 93e63e84c..000000000 --- a/quantum_espresso/kcp/flib/Makefile +++ /dev/null @@ -1,70 +0,0 @@ -# Makefile for flib - -include ../make.sys - -OBJS = \ -avrec.o \ -atomic_number.o \ -bachel.o \ -capital.o \ -dost.o \ -erf.o \ -functionals.o \ -lsda_functionals.o \ -more_functionals.o \ -iglocal.o \ -inpfile.o \ -int_to_char.o \ -invmat.o \ -invmat_complex.o \ -latgen.o \ -linpack.o \ -matches.o \ -recips.o \ -remove_tot_torque.o \ -simpsn.o \ -sort.o \ -sph_bes.o \ -sph_dbes.o \ -transto.o \ -date_and_tim.o \ -sort_gvec.o \ -volume.o \ -dylmr2.o \ -ylmr2.o \ -cryst_to_car.o - -POBJS = \ -flush_unit.o \ -gridsetup.o \ -localdim.o \ -localindex.o - -all: blas.a flib.a lapack_atlas.a lapack.a ptools.a - -flib.a : $(OBJS) - $(AR) $(ARFLAGS) $@ $? - $(RANLIB) $@ - -blas.a : blas.o - $(AR) $(ARFLAGS) $@ $? - $(RANLIB) $@ - -lapack_atlas.a : lapack_atlas.o dlamch.o - $(AR) $(ARFLAGS) $@ $? - $(RANLIB) $@ - -lapack.a : lapack_atlas.o lapack_all.o dlamch.o - $(AR) $(ARFLAGS) $@ $? - -dlamch.o : dlamch.f - $(F77) $(FFLAGS_NOOPT) -c $< - -ptools.a : $(POBJS) - $(AR) $(ARFLAGS) $@ $? - $(RANLIB) $@ - -clean : - - /bin/rm -f *.a *.o *.mod *.i *.F90 core* *.L - -include make.depend diff --git a/quantum_espresso/kcp/flib/atomic_number.f90 b/quantum_espresso/kcp/flib/atomic_number.f90 deleted file mode 100644 index 2ec053c36..000000000 --- a/quantum_espresso/kcp/flib/atomic_number.f90 +++ /dev/null @@ -1,152 +0,0 @@ -! -! Copyright (C) 2004-2007 QUANTUM-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! ------------------------------------------------------------------ -function atomic_number(atm) - ! ------------------------------------------------------------------ - ! - implicit none - character(len=*) :: atm - integer :: atomic_number - - character(len=2) :: elements(103), atom - data elements/' H', 'He', & - 'Li','Be',' B',' C',' N',' O',' F','Ne', & - 'Na','Mg','Al','Si',' P',' S','Cl','Ar', & - ' K','Ca','Sc','Ti',' V','Cr','Mn', & - 'Fe','Co','Ni','Cu','Zn', & - 'Ga','Ge','As','Se','Br','Kr', & - 'Rb','Sr',' Y','Zr','Nb','Mo','Tc', & - 'Ru','Rh','Pd','Ag','Cd', & - 'In','Sn','Sb','Te',' I','Xe', & - 'Cs','Ba','La','Ce','Pr','Nd','Pm','Sm','Eu','Gd', & - 'Tb','Dy','Ho','Er','Tm','Yb','Lu', & - 'Hf','Ta',' W','Re','Os', & - 'Ir','Pt','Au','Hg', & - 'Tl','Pb','Bi','Po','At','Rn', & - 'Fr','Ra','Ac','Th','Pa',' U','Np','Pu', & - 'Am','Cm','Bk','Cf','Es','Fm','Md','No', 'Lr' / - character(len=1), external :: capital, lowercase - logical, external :: isnumeric - integer :: n - - atom=' ' - if ( len(atm) == 1 ) then -! -! Case : atm='X' -! - atom(2:2)=capital(atm(1:1)) - else if ( ( len_trim(atm) == 1 ) .or. ( isnumeric(atm(2:2)) ) .or. & - ( atm(2:2) == '-' ) .or. ( atm(2:2) == '_' ) ) then -! -! Case : atm='X ', 'X_*', 'X-*', 'X[0-9]* ' -! - atom(2:2)=capital(atm(1:1)) - else if (atm(1:1) == ' ') then -! -! Case : atm=' X*' -! - atom(2:2)=capital(atm(2:2)) - else -! -! Case : atm='XY*' -! - atom(1:1)=capital(atm(1:1)) - atom(2:2)=lowercase(atm(2:2)) - end if - - do n=1, 103 - if ( atom == elements(n) ) then - atomic_number=n - return - end if - end do - - atomic_number = 0 - print '(''Atom '',a2,'' not found'')', atom - stop - -end function atomic_number -! ------------------------------------------------------------------ -function atom_name(atomic_number) - ! ------------------------------------------------------------------ - ! - integer :: atomic_number - character(len=2) :: atom_name - - character(len=2) :: elements(103) - data elements/' H', 'He', & - 'Li','Be',' B',' C',' N',' O',' F','Ne', & - 'Na','Mg','Al','Si',' P',' S','Cl','Ar', & - ' K','Ca','Sc','Ti',' V','Cr','Mn', & - 'Fe','Co','Ni','Cu','Zn', & - 'Ga','Ge','As','Se','Br','Kr', & - 'Rb','Sr',' Y','Zr','Nb','Mo','Tc', & - 'Ru','Rh','Pd','Ag','Cd', & - 'In','Sn','Sb','Te',' I','Xe', & - 'Cs','Ba','La','Ce','Pr','Nd','Pm','Sm','Eu','Gd', & - 'Tb','Dy','Ho','Er','Tm','Yb','Lu', & - 'Hf','Ta',' W','Re','Os', & - 'Ir','Pt','Au','Hg', & - 'Tl','Pb','Bi','Po','At','Rn', & - 'Fr','Ra','Ac','Th','Pa',' U','Np','Pu', & - 'Am','Cm','Bk','Cf','Es','Fm','Md','No', 'Lr' / - - if (atomic_number < 1 .or. atomic_number > 103) then - call errore('atom_name','invalid atomic number',1000+atomic_number) - else - atom_name=elements(atomic_number) - end if - return - -end function atom_name - -! ------------------------------------------------------------------ -function atom_weight(atomic_number) - ! ------------------------------------------------------------------ - ! - USE kinds, ONLY : DP - implicit none - integer :: atomic_number - real(DP) :: atom_weight - - real(DP) :: weights(103) - data weights/ 1.00794_DP, 4.00260_DP, & - 6.941_DP,9.01218_DP,10.811_DP,12.0107_DP,14.00674_DP, & - 15.9994_DP,18.99840_DP,20.1797_DP, & - 22.98977_DP,24.3050_DP,26.98154_DP,28.0855_DP,30.97376_DP, & - 32.066_DP,35.4527_DP,39.948_DP, & - 39.0983_DP,40.078_DP,44.95591_DP,47.867_DP,50.9415_DP, & - 51.9961_DP,54.93805_DP, 55.845_DP, & - 58.93320_DP,58.6934_DP,63.546_DP,65.39_DP, & - 69.723_DP,72.61_DP,74.92160_DP,78.96_DP,79.904_DP,83.80_DP, & - 85.4678_DP,87.62_DP,88.90585_DP,91.224_DP,92.90638_DP, & - 95.94_DP,98._DP, & - 101.07_DP,102.90550_DP,106.42_DP,107.8682_DP,112.411_DP, & - 114.818_DP,118.710_DP,121.760_DP,127.60_DP,126.90447_DP, & - 131.29_DP, & - 132.90545_DP,137.327_DP,138.9055_DP,140.116_DP,140.90765_DP, & - 144.24_DP,145._DP,150.36_DP,151.964_DP,157.25_DP, & - 158.92534_DP,162.50_DP,164.93032_DP,167.26_DP, & - 168.93421_DP,173.04_DP,174.967_DP, & - 178.49_DP,180.9479_DP,183.84_DP,186.207_DP,190.23_DP, & - 192.217_DP,195.078_DP,196.96655_DP,200.59_DP, & - 204.3833_DP,207.2_DP,208.98038_DP,209._DP,210._DP,222._DP, & - 223._DP,226._DP,227._DP,232.0381_DP,231.03588_DP, & - 238.0289_DP,237._DP,244._DP, & - 243._DP,247._DP,247._DP,251._DP,252._DP,257._DP, & - 258._DP,259._DP, 262._DP / - - if (atomic_number < 1 .or. atomic_number > 103) then - call errore('atom_name','invalid atomic number',1000+atomic_number) - else - atom_weight=weights(atomic_number) - end if - return - -end function atom_weight -! diff --git a/quantum_espresso/kcp/flib/avrec.f90 b/quantum_espresso/kcp/flib/avrec.f90 deleted file mode 100644 index 27abd6709..000000000 --- a/quantum_espresso/kcp/flib/avrec.f90 +++ /dev/null @@ -1,47 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - - SUBROUTINE avrec( n, alpha, v, av ) - -! ... This subroutine try to use fast library to -! ... calculate -! ... av(i) = alpha / v(i) -! ... - - USE kinds - IMPLICIT NONE - INTEGER, INTENT(IN) :: n - INTEGER :: i - REAL(DP), INTENT(IN) :: alpha - REAL(DP), INTENT(IN) :: v(*) - REAL(DP), INTENT(OUT) :: av(*) - -#if defined __BENCHLIB - - CALL oneover_v( n, v, av ) - IF( alpha /= 1.0d0 ) THEN - CALL DSCAL( n, alpha, av, 1 ) - END IF - -#elif defined __MASS - - CALL vrec( av, v, n ) - IF( alpha /= 1.0d0 ) THEN - CALL DSCAL( n, alpha, av, 1 ) - END IF - -#else - - DO i = 1, n - av(i) = alpha / v(i) - END DO - -#endif - - RETURN - END SUBROUTINE avrec diff --git a/quantum_espresso/kcp/flib/bachel.f90 b/quantum_espresso/kcp/flib/bachel.f90 deleted file mode 100644 index 571ab093c..000000000 --- a/quantum_espresso/kcp/flib/bachel.f90 +++ /dev/null @@ -1,82 +0,0 @@ -! -! Copyright (C) 2001 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!---------------------------------------------------------------------- -subroutine bachel (alps, aps, npseu, lmax) - !---------------------------------------------------------------------- - ! - USE kinds - USE constants , ONLY : pi - implicit none - ! - ! First I/O variables - ! - integer :: npseu, lmax (npseu) - ! input: number of pseudopotential - ! input: max. angul. momentum of the ps - real(DP) :: alps (3, 0:3, npseu), aps (6, 0:3, npseu) - ! input: the b_l coefficient - ! in/out: the a_l coefficient - ! - ! Here local variables - ! - integer :: np, lmx, l, i, j, k, ia, ka, nik - ! counter on number of pseudopot. - ! aux. var. (max. ang. mom. of a fix. ps - ! counter on angular momentum - - real(DP) :: s (6, 6), alpl, alpi, ail - ! auxiliary array - ! first real aux. var. (fix. value of al - ! second real aux. var. (fix. value of a - ! third real aux. var. - ! - do np = 1, npseu - lmx = lmax (np) - do l = 0, lmx - do k = 1, 6 - ka = mod (k - 1, 3) + 1 - alpl = alps (ka, l, np) - do i = 1, k - ia = mod (i - 1, 3) + 1 - alpi = alps (ia, l, np) - ail = alpi + alpl - s (i, k) = sqrt (pi / ail) / 4.d0 / ail - nik = int ( (k - 1) / 3) + int ( (i - 1) / 3) + 1 - do j = 2, nik - s (i, k) = s (i, k) / 2.d0 / ail * (2 * j - 1) - enddo - enddo - enddo - ! - do i = 1, 6 - do j = i, 6 - do k = 1, i - 1 - s (i, j) = s (i, j) - s (k, i) * s (k, j) - enddo - if (i.eq.j) then - s (i, i) = sqrt (s (i, i) ) - else - s (i, j) = s (i, j) / s (i, i) - endif - enddo - enddo - ! - aps (6, l, np) = - aps (6, l, np) / s (6, 6) - do i = 5, 1, - 1 - aps (i, l, np) = - aps (i, l, np) - do k = i + 1, 6 - aps (i, l, np) = aps (i, l, np) - aps (k, l, np) * s (i, k) - enddo - aps (i, l, np) = aps (i, l, np) / s (i, i) - enddo - enddo - - enddo - return -end subroutine bachel diff --git a/quantum_espresso/kcp/flib/blas.f b/quantum_espresso/kcp/flib/blas.f deleted file mode 100644 index f70e283af..000000000 --- a/quantum_espresso/kcp/flib/blas.f +++ /dev/null @@ -1,10849 +0,0 @@ -C -C This file contains several Blas subroutines (levels 1,2,3) -C from the netlib repository: http://www.netlib.org -C See there for copyright information -C - SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -C -C CONSTANT TIMES A VECTOR PLUS A VECTOR. -C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DOUBLE PRECISION DX(1),DY(1),DA - INTEGER I,INCX,INCY,IX,IY,M,MP1,N -C - IF(N.LE.0)RETURN - IF (DA .EQ. 0.0D0) RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -C NOT EQUAL TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DY(IY) = DY(IY) + DA*DX(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,4) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DY(I) = DY(I) + DA*DX(I) - 30 CONTINUE - IF( N .LT. 4 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,4 - DY(I) = DY(I) + DA*DX(I) - DY(I + 1) = DY(I + 1) + DA*DX(I + 1) - DY(I + 2) = DY(I + 2) + DA*DX(I + 2) - DY(I + 3) = DY(I + 3) + DA*DX(I + 3) - 50 CONTINUE - RETURN - END - DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) -C -C FORMS THE DOT PRODUCT OF TWO VECTORS. -C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DOUBLE PRECISION DX(1),DY(1),DTEMP - INTEGER I,INCX,INCY,IX,IY,M,MP1,N -C - DDOT = 0.0D0 - DTEMP = 0.0D0 - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -C NOT EQUAL TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DTEMP = DTEMP + DX(IX)*DY(IY) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - DDOT = DTEMP - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,5) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DTEMP = DTEMP + DX(I)*DY(I) - 30 CONTINUE - IF( N .LT. 5 ) GO TO 60 - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + - * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) - 50 CONTINUE - 60 DDOT = DTEMP - RETURN - END - SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. SCALAR ARGUMENTS .. - CHARACTER*1 TRANSA, TRANSB - INTEGER M, N, K, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -* .. ARRAY ARGUMENTS .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* PURPOSE -* ======= -* -* DGEMM PERFORMS ONE OF THE MATRIX-MATRIX OPERATIONS -* -* C := ALPHA*OP( A )*OP( B ) + BETA*C, -* -* WHERE OP( X ) IS ONE OF -* -* OP( X ) = X OR OP( X ) = X', -* -* ALPHA AND BETA ARE SCALARS, AND A, B AND C ARE MATRICES, WITH OP( A ) -* AN M BY K MATRIX, OP( B ) A K BY N MATRIX AND C AN M BY N MATRIX. -* -* PARAMETERS -* ========== -* -* TRANSA - CHARACTER*1. -* ON ENTRY, TRANSA SPECIFIES THE FORM OF OP( A ) TO BE USED IN -* THE MATRIX MULTIPLICATION AS FOLLOWS: -* -* TRANSA = 'N' OR 'N', OP( A ) = A. -* -* TRANSA = 'T' OR 'T', OP( A ) = A'. -* -* TRANSA = 'C' OR 'C', OP( A ) = A'. -* -* UNCHANGED ON EXIT. -* -* TRANSB - CHARACTER*1. -* ON ENTRY, TRANSB SPECIFIES THE FORM OF OP( B ) TO BE USED IN -* THE MATRIX MULTIPLICATION AS FOLLOWS: -* -* TRANSB = 'N' OR 'N', OP( B ) = B. -* -* TRANSB = 'T' OR 'T', OP( B ) = B'. -* -* TRANSB = 'C' OR 'C', OP( B ) = B'. -* -* UNCHANGED ON EXIT. -* -* M - INTEGER. -* ON ENTRY, M SPECIFIES THE NUMBER OF ROWS OF THE MATRIX -* OP( A ) AND OF THE MATRIX C. M MUST BE AT LEAST ZERO. -* UNCHANGED ON EXIT. -* -* N - INTEGER. -* ON ENTRY, N SPECIFIES THE NUMBER OF COLUMNS OF THE MATRIX -* OP( B ) AND THE NUMBER OF COLUMNS OF THE MATRIX C. N MUST BE -* AT LEAST ZERO. -* UNCHANGED ON EXIT. -* -* K - INTEGER. -* ON ENTRY, K SPECIFIES THE NUMBER OF COLUMNS OF THE MATRIX -* OP( A ) AND THE NUMBER OF ROWS OF THE MATRIX OP( B ). K MUST -* BE AT LEAST ZERO. -* UNCHANGED ON EXIT. -* -* ALPHA - DOUBLE PRECISION. -* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. -* UNCHANGED ON EXIT. -* -* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, KA ), WHERE KA IS -* K WHEN TRANSA = 'N' OR 'N', AND IS M OTHERWISE. -* BEFORE ENTRY WITH TRANSA = 'N' OR 'N', THE LEADING M BY K -* PART OF THE ARRAY A MUST CONTAIN THE MATRIX A, OTHERWISE -* THE LEADING K BY M PART OF THE ARRAY A MUST CONTAIN THE -* MATRIX A. -* UNCHANGED ON EXIT. -* -* LDA - INTEGER. -* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED -* IN THE CALLING (SUB) PROGRAM. WHEN TRANSA = 'N' OR 'N' THEN -* LDA MUST BE AT LEAST MAX( 1, M ), OTHERWISE LDA MUST BE AT -* LEAST MAX( 1, K ). -* UNCHANGED ON EXIT. -* -* B - DOUBLE PRECISION ARRAY OF DIMENSION ( LDB, KB ), WHERE KB IS -* N WHEN TRANSB = 'N' OR 'N', AND IS K OTHERWISE. -* BEFORE ENTRY WITH TRANSB = 'N' OR 'N', THE LEADING K BY N -* PART OF THE ARRAY B MUST CONTAIN THE MATRIX B, OTHERWISE -* THE LEADING N BY K PART OF THE ARRAY B MUST CONTAIN THE -* MATRIX B. -* UNCHANGED ON EXIT. -* -* LDB - INTEGER. -* ON ENTRY, LDB SPECIFIES THE FIRST DIMENSION OF B AS DECLARED -* IN THE CALLING (SUB) PROGRAM. WHEN TRANSB = 'N' OR 'N' THEN -* LDB MUST BE AT LEAST MAX( 1, K ), OTHERWISE LDB MUST BE AT -* LEAST MAX( 1, N ). -* UNCHANGED ON EXIT. -* -* BETA - DOUBLE PRECISION. -* ON ENTRY, BETA SPECIFIES THE SCALAR BETA. WHEN BETA IS -* SUPPLIED AS ZERO THEN C NEED NOT BE SET ON INPUT. -* UNCHANGED ON EXIT. -* -* C - DOUBLE PRECISION ARRAY OF DIMENSION ( LDC, N ). -* BEFORE ENTRY, THE LEADING M BY N PART OF THE ARRAY C MUST -* CONTAIN THE MATRIX C, EXCEPT WHEN BETA IS ZERO, IN WHICH -* CASE C NEED NOT BE SET ON ENTRY. -* ON EXIT, THE ARRAY C IS OVERWRITTEN BY THE M BY N MATRIX -* ( ALPHA*OP( A )*OP( B ) + BETA*C ). -* -* LDC - INTEGER. -* ON ENTRY, LDC SPECIFIES THE FIRST DIMENSION OF C AS DECLARED -* IN THE CALLING (SUB) PROGRAM. LDC MUST BE AT LEAST -* MAX( 1, M ). -* UNCHANGED ON EXIT. -* -* -* LEVEL 3 BLAS ROUTINE. -* -* -- WRITTEN ON 8-FEBRUARY-1989. -* JACK DONGARRA, ARGONNE NATIONAL LABORATORY. -* IAIN DUFF, AERE HARWELL. -* JEREMY DU CROZ, NUMERICAL ALGORITHMS GROUP LTD. -* SVEN HAMMARLING, NUMERICAL ALGORITHMS GROUP LTD. -* -* -* .. EXTERNAL FUNCTIONS .. - LOGICAL LSAME - EXTERNAL LSAME -* .. EXTERNAL SUBROUTINES .. - EXTERNAL XERBLA -* .. INTRINSIC FUNCTIONS .. - INTRINSIC MAX -* .. LOCAL SCALARS .. - LOGICAL NOTA, NOTB - INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB - DOUBLE PRECISION TEMP -* .. PARAMETERS .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. EXECUTABLE STATEMENTS .. -* -* SET NOTA AND NOTB AS TRUE IF A AND B RESPECTIVELY ARE NOT -* TRANSPOSED AND SET NROWA, NCOLA AND NROWB AS THE NUMBER OF ROWS -* AND COLUMNS OF A AND THE NUMBER OF ROWS OF B RESPECTIVELY. -* - NOTA = LSAME( TRANSA, 'N' ) - NOTB = LSAME( TRANSB, 'N' ) - IF( NOTA )THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF( NOTB )THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* TEST THE INPUT PARAMETERS. -* - INFO = 0 - IF( ( .NOT.NOTA ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.NOTB ).AND. - $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. - $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( K .LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 8 - ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN - INFO = 10 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGEMM ', INFO ) - RETURN - END IF -* -* QUICK RETURN IF POSSIBLE. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* AND IF ALPHA.EQ.ZERO. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* START THE OPERATIONS. -* - IF( NOTB )THEN - IF( NOTA )THEN -* -* FORM C := ALPHA*A*B + BETA*C. -* - DO 90, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 50, I = 1, M - C( I, J ) = ZERO - 50 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 60, I = 1, M - C( I, J ) = BETA*C( I, J ) - 60 CONTINUE - END IF - DO 80, L = 1, K - IF( B( L, J ).NE.ZERO )THEN - TEMP = ALPHA*B( L, J ) - DO 70, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE -* -* FORM C := ALPHA*A'*B + BETA*C -* - DO 120, J = 1, N - DO 110, I = 1, M - TEMP = ZERO - DO 100, L = 1, K - TEMP = TEMP + A( L, I )*B( L, J ) - 100 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 110 CONTINUE - 120 CONTINUE - END IF - ELSE - IF( NOTA )THEN -* -* FORM C := ALPHA*A*B' + BETA*C -* - DO 170, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 130, I = 1, M - C( I, J ) = ZERO - 130 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 140, I = 1, M - C( I, J ) = BETA*C( I, J ) - 140 CONTINUE - END IF - DO 160, L = 1, K - IF( B( J, L ).NE.ZERO )THEN - TEMP = ALPHA*B( J, L ) - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 150 CONTINUE - END IF - 160 CONTINUE - 170 CONTINUE - ELSE -* -* FORM C := ALPHA*A'*B' + BETA*C -* - DO 200, J = 1, N - DO 190, I = 1, M - TEMP = ZERO - DO 180, L = 1, K - TEMP = TEMP + A( L, I )*B( J, L ) - 180 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 190 CONTINUE - 200 CONTINUE - END IF - END IF -* - RETURN -* -* END OF DGEMM . -* - END - SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. SCALAR ARGUMENTS .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, LDA, M, N - CHARACTER*1 TRANS -* .. ARRAY ARGUMENTS .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* PURPOSE -* ======= -* -* DGEMV PERFORMS ONE OF THE MATRIX-VECTOR OPERATIONS -* -* Y := ALPHA*A*X + BETA*Y, OR Y := ALPHA*A'*X + BETA*Y, -* -* WHERE ALPHA AND BETA ARE SCALARS, X AND Y ARE VECTORS AND A IS AN -* M BY N MATRIX. -* -* PARAMETERS -* ========== -* -* TRANS - CHARACTER*1. -* ON ENTRY, TRANS SPECIFIES THE OPERATION TO BE PERFORMED AS -* FOLLOWS: -* -* TRANS = 'N' OR 'N' Y := ALPHA*A*X + BETA*Y. -* -* TRANS = 'T' OR 'T' Y := ALPHA*A'*X + BETA*Y. -* -* TRANS = 'C' OR 'C' Y := ALPHA*A'*X + BETA*Y. -* -* UNCHANGED ON EXIT. -* -* M - INTEGER. -* ON ENTRY, M SPECIFIES THE NUMBER OF ROWS OF THE MATRIX A. -* M MUST BE AT LEAST ZERO. -* UNCHANGED ON EXIT. -* -* N - INTEGER. -* ON ENTRY, N SPECIFIES THE NUMBER OF COLUMNS OF THE MATRIX A. -* N MUST BE AT LEAST ZERO. -* UNCHANGED ON EXIT. -* -* ALPHA - DOUBLE PRECISION. -* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. -* UNCHANGED ON EXIT. -* -* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, N ). -* BEFORE ENTRY, THE LEADING M BY N PART OF THE ARRAY A MUST -* CONTAIN THE MATRIX OF COEFFICIENTS. -* UNCHANGED ON EXIT. -* -* LDA - INTEGER. -* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED -* IN THE CALLING (SUB) PROGRAM. LDA MUST BE AT LEAST -* MAX( 1, M ). -* UNCHANGED ON EXIT. -* -* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST -* ( 1 + ( N - 1 )*ABS( INCX ) ) WHEN TRANS = 'N' OR 'N' -* AND AT LEAST -* ( 1 + ( M - 1 )*ABS( INCX ) ) OTHERWISE. -* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE -* VECTOR X. -* UNCHANGED ON EXIT. -* -* INCX - INTEGER. -* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF -* X. INCX MUST NOT BE ZERO. -* UNCHANGED ON EXIT. -* -* BETA - DOUBLE PRECISION. -* ON ENTRY, BETA SPECIFIES THE SCALAR BETA. WHEN BETA IS -* SUPPLIED AS ZERO THEN Y NEED NOT BE SET ON INPUT. -* UNCHANGED ON EXIT. -* -* Y - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST -* ( 1 + ( M - 1 )*ABS( INCY ) ) WHEN TRANS = 'N' OR 'N' -* AND AT LEAST -* ( 1 + ( N - 1 )*ABS( INCY ) ) OTHERWISE. -* BEFORE ENTRY WITH BETA NON-ZERO, THE INCREMENTED ARRAY Y -* MUST CONTAIN THE VECTOR Y. ON EXIT, Y IS OVERWRITTEN BY THE -* UPDATED VECTOR Y. -* -* INCY - INTEGER. -* ON ENTRY, INCY SPECIFIES THE INCREMENT FOR THE ELEMENTS OF -* Y. INCY MUST NOT BE ZERO. -* UNCHANGED ON EXIT. -* -* -* LEVEL 2 BLAS ROUTINE. -* -* -- WRITTEN ON 22-OCTOBER-1986. -* JACK DONGARRA, ARGONNE NATIONAL LAB. -* JEREMY DU CROZ, NAG CENTRAL OFFICE. -* SVEN HAMMARLING, NAG CENTRAL OFFICE. -* RICHARD HANSON, SANDIA NATIONAL LABS. -* -* -* .. PARAMETERS .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. LOCAL SCALARS .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY -* .. EXTERNAL FUNCTIONS .. - LOGICAL LSAME - EXTERNAL LSAME -* .. EXTERNAL SUBROUTINES .. - EXTERNAL XERBLA -* .. INTRINSIC FUNCTIONS .. - INTRINSIC MAX -* .. -* .. EXECUTABLE STATEMENTS .. -* -* TEST THE INPUT PARAMETERS. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGEMV ', INFO ) - RETURN - END IF -* -* QUICK RETURN IF POSSIBLE. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* SET LENX AND LENY, THE LENGTHS OF THE VECTORS X AND Y, AND SET -* UP THE START POINTS IN X AND Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF A ARE -* ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH A. -* -* FIRST FORM Y := BETA*Y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( TRANS, 'N' ) )THEN -* -* FORM Y := ALPHA*A*X + Y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - DO 50, I = 1, M - Y( I ) = Y( I ) + TEMP*A( I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - DO 70, I = 1, M - Y( IY ) = Y( IY ) + TEMP*A( I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* FORM Y := ALPHA*A'*X + Y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = ZERO - DO 90, I = 1, M - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120, J = 1, N - TEMP = ZERO - IX = KX - DO 110, I = 1, M - TEMP = TEMP + A( I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* END OF DGEMV . -* - END - SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. SCALAR ARGUMENTS .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. ARRAY ARGUMENTS .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* PURPOSE -* ======= -* -* DGER PERFORMS THE RANK 1 OPERATION -* -* A := ALPHA*X*Y' + A, -* -* WHERE ALPHA IS A SCALAR, X IS AN M ELEMENT VECTOR, Y IS AN N ELEMENT -* VECTOR AND A IS AN M BY N MATRIX. -* -* PARAMETERS -* ========== -* -* M - INTEGER. -* ON ENTRY, M SPECIFIES THE NUMBER OF ROWS OF THE MATRIX A. -* M MUST BE AT LEAST ZERO. -* UNCHANGED ON EXIT. -* -* N - INTEGER. -* ON ENTRY, N SPECIFIES THE NUMBER OF COLUMNS OF THE MATRIX A. -* N MUST BE AT LEAST ZERO. -* UNCHANGED ON EXIT. -* -* ALPHA - DOUBLE PRECISION. -* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. -* UNCHANGED ON EXIT. -* -* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST -* ( 1 + ( M - 1 )*ABS( INCX ) ). -* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE M -* ELEMENT VECTOR X. -* UNCHANGED ON EXIT. -* -* INCX - INTEGER. -* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF -* X. INCX MUST NOT BE ZERO. -* UNCHANGED ON EXIT. -* -* Y - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST -* ( 1 + ( N - 1 )*ABS( INCY ) ). -* BEFORE ENTRY, THE INCREMENTED ARRAY Y MUST CONTAIN THE N -* ELEMENT VECTOR Y. -* UNCHANGED ON EXIT. -* -* INCY - INTEGER. -* ON ENTRY, INCY SPECIFIES THE INCREMENT FOR THE ELEMENTS OF -* Y. INCY MUST NOT BE ZERO. -* UNCHANGED ON EXIT. -* -* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, N ). -* BEFORE ENTRY, THE LEADING M BY N PART OF THE ARRAY A MUST -* CONTAIN THE MATRIX OF COEFFICIENTS. ON EXIT, A IS -* OVERWRITTEN BY THE UPDATED MATRIX. -* -* LDA - INTEGER. -* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED -* IN THE CALLING (SUB) PROGRAM. LDA MUST BE AT LEAST -* MAX( 1, M ). -* UNCHANGED ON EXIT. -* -* -* LEVEL 2 BLAS ROUTINE. -* -* -- WRITTEN ON 22-OCTOBER-1986. -* JACK DONGARRA, ARGONNE NATIONAL LAB. -* JEREMY DU CROZ, NAG CENTRAL OFFICE. -* SVEN HAMMARLING, NAG CENTRAL OFFICE. -* RICHARD HANSON, SANDIA NATIONAL LABS. -* -* -* .. PARAMETERS .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. LOCAL SCALARS .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. EXTERNAL SUBROUTINES .. - EXTERNAL XERBLA -* .. INTRINSIC FUNCTIONS .. - INTRINSIC MAX -* .. -* .. EXECUTABLE STATEMENTS .. -* -* TEST THE INPUT PARAMETERS. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGER ', INFO ) - RETURN - END IF -* -* QUICK RETURN IF POSSIBLE. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF A ARE -* ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* END OF DGER . -* - END - subroutine dscal(n,da,dx,incx) -c -c scales a vector by a constant. -c uses unrolled loops for increment equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision da,dx(*) - integer i,incx,m,mp1,n,nincx -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - dx(i) = da*dx(i) - 10 continue - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dx(i) = da*dx(i) - 30 continue - if( n .lt. 5 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,5 - dx(i) = da*dx(i) - dx(i + 1) = da*dx(i + 1) - dx(i + 2) = da*dx(i + 2) - dx(i + 3) = da*dx(i + 3) - dx(i + 4) = da*dx(i + 4) - 50 continue - return - end - SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSPMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 6 - ELSE IF( INCY.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSPMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when AP contains the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - K = KK - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 - KK = KK + J - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, K = KK, KK + J - 2 - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 80 CONTINUE - END IF - ELSE -* -* Form y when AP contains the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*AP( KK ) - K = KK + 1 - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - KK = KK + ( N - J + 1 ) - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*AP( KK ) - IX = JX - IY = JY - DO 110, K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + ( N - J + 1 ) - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSPMV . -* - END - SUBROUTINE DSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSPR2 performs the symmetric rank 2 operation -* -* A := alpha*x*y' + alpha*y*x' + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an -* n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSPR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - K = KK - DO 10, I = 1, J - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 10 CONTINUE - END IF - KK = KK + J - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = KX - IY = KY - DO 30, K = KK, KK + J - 1 - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - K = KK - DO 50, I = J, N - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 50 CONTINUE - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = JX - IY = JY - DO 70, K = KK, KK + N - J - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSPR2 . -* - END - subroutine dswap (n,dx,incx,dy,incy) -c -c interchanges two vectors. -c uses unrolled loops for increments equal one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),dtemp - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = dx(ix) - dx(ix) = dy(iy) - dy(iy) = dtemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,3) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dx(i) - dx(i) = dy(i) - dy(i) = dtemp - 30 continue - if( n .lt. 3 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,3 - dtemp = dx(i) - dx(i) = dy(i) - dy(i) = dtemp - dtemp = dx(i + 1) - dx(i + 1) = dy(i + 1) - dy(i + 1) = dtemp - dtemp = dx(i + 2) - dx(i + 2) = dy(i + 2) - dy(i + 2) = dtemp - 50 continue - return - end - subroutine zscal(n,za,zx,incx) -c -c scales a vector by a constant. -c jack dongarra, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex za,zx(*) - integer i,incx,ix,n -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - do 10 i = 1,n - zx(ix) = za*zx(ix) - ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 do 30 i = 1,n - zx(i) = za*zx(i) - 30 continue - return - end - integer function idamax(n,dx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dmax - integer i,incx,ix,n -c - idamax = 0 - if( n.lt.1 .or. incx.le.0 ) return - idamax = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmax = dabs(dx(1)) - ix = ix + incx - do 10 i = 2,n - if(dabs(dx(ix)).le.dmax) go to 5 - idamax = i - dmax = dabs(dx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmax = dabs(dx(1)) - do 30 i = 2,n - if(dabs(dx(i)).le.dmax) go to 30 - idamax = i - dmax = dabs(dx(i)) - 30 continue - return - end - SUBROUTINE ZGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 TRANSA, TRANSB - INTEGER M, N, K, LDA, LDB, LDC - COMPLEX*16 ALPHA, BETA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZGEMM performs one of the matrix-matrix operations -* -* C := alpha*op( A )*op( B ) + beta*C, -* -* where op( X ) is one of -* -* op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ), -* -* alpha and beta are scalars, and A, B and C are matrices, with op( A ) -* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -* -* Parameters -* ========== -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n', op( A ) = A. -* -* TRANSA = 'T' or 't', op( A ) = A'. -* -* TRANSA = 'C' or 'c', op( A ) = conjg( A' ). -* -* Unchanged on exit. -* -* TRANSB - CHARACTER*1. -* On entry, TRANSB specifies the form of op( B ) to be used in -* the matrix multiplication as follows: -* -* TRANSB = 'N' or 'n', op( B ) = B. -* -* TRANSB = 'T' or 't', op( B ) = B'. -* -* TRANSB = 'C' or 'c', op( B ) = conjg( B' ). -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix -* op( A ) and of the matrix C. M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix -* op( B ) and the number of columns of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry, K specifies the number of columns of the matrix -* op( A ) and the number of rows of the matrix op( B ). K must -* be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRANSA = 'N' or 'n', and is m otherwise. -* Before entry with TRANSA = 'N' or 'n', the leading m by k -* part of the array A must contain the matrix A, otherwise -* the leading k by m part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANSA = 'N' or 'n' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, k ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is -* n when TRANSB = 'N' or 'n', and is k otherwise. -* Before entry with TRANSB = 'N' or 'n', the leading k by n -* part of the array B must contain the matrix B, otherwise -* the leading n by k part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANSB = 'N' or 'n' then -* LDB must be at least max( 1, k ), otherwise LDB must be at -* least max( 1, n ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry, the leading m by n part of the array C must -* contain the matrix C, except when beta is zero, in which -* case C need not be set on entry. -* On exit, the array C is overwritten by the m by n matrix -* ( alpha*op( A )*op( B ) + beta*C ). -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. Local Scalars .. - LOGICAL CONJA, CONJB, NOTA, NOTB - INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB - COMPLEX*16 TEMP -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* conjugated or transposed, set CONJA and CONJB as true if A and -* B respectively are to be transposed but not conjugated and set -* NROWA, NCOLA and NROWB as the number of rows and columns of A -* and the number of rows of B respectively. -* - NOTA = LSAME( TRANSA, 'N' ) - NOTB = LSAME( TRANSB, 'N' ) - CONJA = LSAME( TRANSA, 'C' ) - CONJB = LSAME( TRANSB, 'C' ) - IF( NOTA )THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF( NOTB )THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.NOTA ).AND. - $ ( .NOT.CONJA ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.NOTB ).AND. - $ ( .NOT.CONJB ).AND. - $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( K .LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 8 - ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN - INFO = 10 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZGEMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF( NOTB )THEN - IF( NOTA )THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 50, I = 1, M - C( I, J ) = ZERO - 50 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 60, I = 1, M - C( I, J ) = BETA*C( I, J ) - 60 CONTINUE - END IF - DO 80, L = 1, K - IF( B( L, J ).NE.ZERO )THEN - TEMP = ALPHA*B( L, J ) - DO 70, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE IF( CONJA )THEN -* -* Form C := alpha*conjg( A' )*B + beta*C. -* - DO 120, J = 1, N - DO 110, I = 1, M - TEMP = ZERO - DO 100, L = 1, K - TEMP = TEMP + DCONJG( A( L, I ) )*B( L, J ) - 100 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 110 CONTINUE - 120 CONTINUE - ELSE -* -* Form C := alpha*A'*B + beta*C -* - DO 150, J = 1, N - DO 140, I = 1, M - TEMP = ZERO - DO 130, L = 1, K - TEMP = TEMP + A( L, I )*B( L, J ) - 130 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 140 CONTINUE - 150 CONTINUE - END IF - ELSE IF( NOTA )THEN - IF( CONJB )THEN -* -* Form C := alpha*A*conjg( B' ) + beta*C. -* - DO 200, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 160, I = 1, M - C( I, J ) = ZERO - 160 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 170, I = 1, M - C( I, J ) = BETA*C( I, J ) - 170 CONTINUE - END IF - DO 190, L = 1, K - IF( B( J, L ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( B( J, L ) ) - DO 180, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 180 CONTINUE - END IF - 190 CONTINUE - 200 CONTINUE - ELSE -* -* Form C := alpha*A*B' + beta*C -* - DO 250, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 210, I = 1, M - C( I, J ) = ZERO - 210 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 220, I = 1, M - C( I, J ) = BETA*C( I, J ) - 220 CONTINUE - END IF - DO 240, L = 1, K - IF( B( J, L ).NE.ZERO )THEN - TEMP = ALPHA*B( J, L ) - DO 230, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 230 CONTINUE - END IF - 240 CONTINUE - 250 CONTINUE - END IF - ELSE IF( CONJA )THEN - IF( CONJB )THEN -* -* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. -* - DO 280, J = 1, N - DO 270, I = 1, M - TEMP = ZERO - DO 260, L = 1, K - TEMP = TEMP + - $ DCONJG( A( L, I ) )*DCONJG( B( J, L ) ) - 260 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 270 CONTINUE - 280 CONTINUE - ELSE -* -* Form C := alpha*conjg( A' )*B' + beta*C -* - DO 310, J = 1, N - DO 300, I = 1, M - TEMP = ZERO - DO 290, L = 1, K - TEMP = TEMP + DCONJG( A( L, I ) )*B( J, L ) - 290 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 300 CONTINUE - 310 CONTINUE - END IF - ELSE - IF( CONJB )THEN -* -* Form C := alpha*A'*conjg( B' ) + beta*C -* - DO 340, J = 1, N - DO 330, I = 1, M - TEMP = ZERO - DO 320, L = 1, K - TEMP = TEMP + A( L, I )*DCONJG( B( J, L ) ) - 320 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 330 CONTINUE - 340 CONTINUE - ELSE -* -* Form C := alpha*A'*B' + beta*C -* - DO 370, J = 1, N - DO 360, I = 1, M - TEMP = ZERO - DO 350, L = 1, K - TEMP = TEMP + A( L, I )*B( J, L ) - 350 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 360 CONTINUE - 370 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZGEMM . -* - END - subroutine zswap (n,zx,incx,zy,incy) -c -c interchanges two vectors. -c jack dongarra, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*),zy(*),ztemp - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - ztemp = zx(ix) - zx(ix) = zy(iy) - zy(iy) = ztemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 - 20 do 30 i = 1,n - ztemp = zx(i) - zx(i) = zy(i) - zy(i) = ztemp - 30 continue - return - end - subroutine zaxpy(n,za,zx,incx,zy,incy) -c -c constant times a vector plus a vector. -c jack dongarra, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*),zy(*),za - integer i,incx,incy,ix,iy,n - double precision dcabs1 - if(n.le.0)return - if (dcabs1(za) .eq. 0.0d0) return - if (incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - zy(iy) = zy(iy) + za*zx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - zy(i) = zy(i) + za*zx(i) - 30 continue - return - end - subroutine zdscal(n,da,zx,incx) -c -c scales a vector by a constant. -c jack dongarra, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*) - double precision da - integer i,incx,ix,n -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - do 10 i = 1,n - zx(ix) = dcmplx(da,0.0d0)*zx(ix) - ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 do 30 i = 1,n - zx(i) = dcmplx(da,0.0d0)*zx(i) - 30 continue - return - end - DOUBLE PRECISION FUNCTION DZNRM2( N, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N -* .. Array Arguments .. - COMPLEX*16 X( * ) -* .. -* -* DZNRM2 returns the euclidean norm of a vector via the function -* name, so that -* -* DZNRM2 := sqrt( conjg( x' )*x ) -* -* -* -* -- This version written on 25-October-1982. -* Modified on 14-October-1993 to inline the call to ZLASSQ. -* Sven Hammarling, Nag Ltd. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION NORM, SCALE, SSQ, TEMP -* .. Intrinsic Functions .. - INTRINSIC ABS, DIMAG, DBLE, SQRT -* .. -* .. Executable Statements .. - IF( N.LT.1 .OR. INCX.LT.1 )THEN - NORM = ZERO - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - IF( DBLE( X( IX ) ).NE.ZERO )THEN - TEMP = ABS( DBLE( X( IX ) ) ) - IF( SCALE.LT.TEMP )THEN - SSQ = ONE + SSQ*( SCALE/TEMP )**2 - SCALE = TEMP - ELSE - SSQ = SSQ + ( TEMP/SCALE )**2 - END IF - END IF - IF( DIMAG( X( IX ) ).NE.ZERO )THEN - TEMP = ABS( DIMAG( X( IX ) ) ) - IF( SCALE.LT.TEMP )THEN - SSQ = ONE + SSQ*( SCALE/TEMP )**2 - SCALE = TEMP - ELSE - SSQ = SSQ + ( TEMP/SCALE )**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE * SQRT( SSQ ) - END IF -* - DZNRM2 = NORM - RETURN -* -* End of DZNRM2. -* - END - SUBROUTINE ZGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - INTEGER INCX, INCY, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZGEMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or -* -* y := alpha*conjg( A' )*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n matrix. -* -* Parameters -* ========== -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry with BETA non-zero, the incremented array Y -* must contain the vector y. On exit, Y is overwritten by the -* updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY - LOGICAL NOCONJ -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZGEMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'T' ) -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - DO 50, I = 1, M - Y( I ) = Y( I ) + TEMP*A( I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - DO 70, I = 1, M - Y( IY ) = Y( IY ) + TEMP*A( I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = ZERO - IF( NOCONJ )THEN - DO 90, I = 1, M - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - ELSE - DO 100, I = 1, M - TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) - 100 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 110 CONTINUE - ELSE - DO 140, J = 1, N - TEMP = ZERO - IX = KX - IF( NOCONJ )THEN - DO 120, I = 1, M - TEMP = TEMP + A( I, J )*X( IX ) - IX = IX + INCX - 120 CONTINUE - ELSE - DO 130, I = 1, M - TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 140 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZGEMV . -* - END - subroutine zcopy(n,zx,incx,zy,incy) -c -c copies a vector, x, to a vector, y. -c jack dongarra, linpack, 4/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*),zy(*) - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - zy(iy) = zx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - zy(i) = zx(i) - 30 continue - return - end - subroutine dcopy(n,dx,incx,dy,incy) -c -c copies a vector, x, to a vector, y. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*) - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dy(iy) = dx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,7) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dy(i) = dx(i) - 30 continue - if( n .lt. 7 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,7 - dy(i) = dx(i) - dy(i + 1) = dx(i + 1) - dy(i + 2) = dx(i + 2) - dy(i + 3) = dx(i + 3) - dy(i + 4) = dx(i + 4) - dy(i + 5) = dx(i + 5) - dy(i + 6) = dx(i + 6) - 50 continue - return - end - DOUBLE COMPLEX FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY) -C -C FORMS THE DOT PRODUCT OF A VECTOR. -C JACK DONGARRA, 3/11/78. -C - DOUBLE COMPLEX ZX(1),ZY(1),ZTEMP - INTEGER I,INCX,INCY,IX,IY,N - ZTEMP = (0.0D0,0.0D0) - ZDOTC = (0.0D0,0.0D0) - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -C NOT EQUAL TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - ZTEMP = ZTEMP + DCONJG(ZX(IX))*ZY(IY) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - ZDOTC = ZTEMP - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C - 20 DO 30 I = 1,N - ZTEMP = ZTEMP + DCONJG(ZX(I))*ZY(I) - 30 CONTINUE - ZDOTC = ZTEMP - RETURN - END - double complex function zdotu(n,zx,incx,zy,incy) -c -c forms the dot product of two vectors. -c jack dongarra, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*),zy(*),ztemp - integer i,incx,incy,ix,iy,n - ztemp = (0.0d0,0.0d0) - zdotu = (0.0d0,0.0d0) - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - ztemp = ztemp + zx(ix)*zy(iy) - ix = ix + incx - iy = iy + incy - 10 continue - zdotu = ztemp - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - ztemp = ztemp + zx(i)*zy(i) - 30 continue - zdotu = ztemp - return - end - double precision function dcabs1(z) - double complex z,zz - double precision t(2) - equivalence (zz,t(1)) - zz = z - dcabs1 = dabs(t(1)) + dabs(t(2)) - return - end - integer function izamax(n,zx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, 1/15/85. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*) - double precision smax - integer i,incx,ix,n - double precision dcabs1 -c - izamax = 0 - if( n.lt.1 .or. incx.le.0 )return - izamax = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smax = dcabs1(zx(1)) - ix = ix + incx - do 10 i = 2,n - if(dcabs1(zx(ix)).le.smax) go to 5 - izamax = i - smax = dcabs1(zx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smax = dcabs1(zx(1)) - do 30 i = 2,n - if(dcabs1(zx(i)).le.smax) go to 30 - izamax = i - smax = dcabs1(zx(i)) - 30 continue - return - end - SUBROUTINE ZGERU ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZGERU performs the rank 1 operation -* -* A := alpha*x*y' + A, -* -* where alpha is a scalar, x is an m element vector, y is an n element -* vector and A is an m by n matrix. -* -* Parameters -* ========== -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( m - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the m -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. On exit, A is -* overwritten by the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZGERU ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of ZGERU . -* - END - SUBROUTINE DSPR ( UPLO, N, ALPHA, X, INCX, AP ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DSPR performs the symmetric rank 1 operation -* -* A := alpha*x*x' + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSPR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - K = KK - DO 10, I = 1, J - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 10 CONTINUE - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30, K = KK, KK + J - 1 - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - K = KK - DO 50, I = J, N - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 50 CONTINUE - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = JX - DO 70, K = KK, KK + N - J - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSPR . -* - END - SUBROUTINE ZHPR ( UPLO, N, ALPHA, X, INCX, AP ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZHPR performs the hermitian rank 1 operation -* -* A := alpha*x*conjg( x' ) + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n hermitian matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* AP - COMPLEX*16 array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHPR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.DBLE( ZERO ) ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( J ) ) - K = KK - DO 10, I = 1, J - 1 - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 10 CONTINUE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - $ + DBLE( X( J )*TEMP ) - ELSE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( JX ) ) - IX = KX - DO 30, K = KK, KK + J - 2 - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - $ + DBLE( X( JX )*TEMP ) - ELSE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( J ) ) - AP( KK ) = DBLE( AP( KK ) ) + DBLE( TEMP*X( J ) ) - K = KK + 1 - DO 50, I = J + 1, N - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 50 CONTINUE - ELSE - AP( KK ) = DBLE( AP( KK ) ) - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( JX ) ) - AP( KK ) = DBLE( AP( KK ) ) + DBLE( TEMP*X( JX ) ) - IX = JX - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - AP( K ) = AP( K ) + X( IX )*TEMP - 70 CONTINUE - ELSE - AP( KK ) = DBLE( AP( KK ) ) - END IF - JX = JX + INCX - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHPR . -* - END - SUBROUTINE ZHPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZHPR2 performs the hermitian rank 2 operation -* -* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an -* n by n hermitian matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* AP - COMPLEX*16 array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHPR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( J ) ) - TEMP2 = DCONJG( ALPHA*X( J ) ) - K = KK - DO 10, I = 1, J - 1 - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 10 CONTINUE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + - $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) - ELSE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - END IF - KK = KK + J - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( JY ) ) - TEMP2 = DCONJG( ALPHA*X( JX ) ) - IX = KX - IY = KY - DO 30, K = KK, KK + J - 2 - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + - $ DBLE( X( JX )*TEMP1 + - $ Y( JY )*TEMP2 ) - ELSE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( J ) ) - TEMP2 = DCONJG( ALPHA*X( J ) ) - AP( KK ) = DBLE( AP( KK ) ) + - $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) - K = KK + 1 - DO 50, I = J + 1, N - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 50 CONTINUE - ELSE - AP( KK ) = DBLE( AP( KK ) ) - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( JY ) ) - TEMP2 = DCONJG( ALPHA*X( JX ) ) - AP( KK ) = DBLE( AP( KK ) ) + - $ DBLE( X( JX )*TEMP1 + Y( JY )*TEMP2 ) - IX = JX - IY = JY - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - 70 CONTINUE - ELSE - AP( KK ) = DBLE( AP( KK ) ) - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHPR2 . -* - END - SUBROUTINE ZHPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZHPMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n hermitian matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* AP - COMPLEX*16 array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. -* Note that the imaginary parts of the diagonal elements need -* not be set and are assumed to be zero. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 6 - ELSE IF( INCY.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHPMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when AP contains the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - K = KK - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( I ) - K = K + 1 - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*DBLE( AP( KK + J - 1 ) ) - $ + ALPHA*TEMP2 - KK = KK + J - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, K = KK, KK + J - 2 - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*DBLE( AP( KK + J - 1 ) ) - $ + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 80 CONTINUE - END IF - ELSE -* -* Form y when AP contains the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*DBLE( AP( KK ) ) - K = KK + 1 - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( I ) - K = K + 1 - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - KK = KK + ( N - J + 1 ) - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*DBLE( AP( KK ) ) - IX = JX - IY = JY - DO 110, K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + ( N - J + 1 ) - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHPMV . -* - END - SUBROUTINE ZGERC ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZGERC performs the rank 1 operation -* -* A := alpha*x*conjg( y' ) + A, -* -* where alpha is a scalar, x is an m element vector, y is an n element -* vector and A is an m by n matrix. -* -* Parameters -* ========== -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( m - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the m -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. On exit, A is -* overwritten by the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZGERC ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( Y( JY ) ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( Y( JY ) ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of ZGERC . -* - END - subroutine drotg(da,db,c,s) -c -c construct givens plane rotation. -c jack dongarra, linpack, 3/11/78. -c - double precision da,db,c,s,roe,scale,r,z -c - roe = db - if( dabs(da) .gt. dabs(db) ) roe = da - scale = dabs(da) + dabs(db) - if( scale .ne. 0.0d0 ) go to 10 - c = 1.0d0 - s = 0.0d0 - r = 0.0d0 - z = 0.0d0 - go to 20 - 10 r = scale*dsqrt((da/scale)**2 + (db/scale)**2) - r = dsign(1.0d0,roe)*r - c = da/r - s = db/r - z = 1.0d0 - if( dabs(da) .gt. dabs(db) ) z = s - if( dabs(db) .ge. dabs(da) .and. c .ne. 0.0d0 ) z = 1.0d0/c - 20 da = r - db = z - return - end - subroutine drot (n,dx,incx,dy,incy,c,s) -c -c applies a plane rotation. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),dtemp,c,s - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = c*dx(ix) + s*dy(iy) - dy(iy) = c*dy(iy) - s*dx(ix) - dx(ix) = dtemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - dtemp = c*dx(i) + s*dy(i) - dy(i) = c*dy(i) - s*dx(i) - dx(i) = dtemp - 30 continue - return - end - double precision function dasum(n,dx,incx) -c -c takes the sum of the absolute values. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dtemp - integer i,incx,m,mp1,n,nincx -c - dasum = 0.0d0 - dtemp = 0.0d0 - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - dtemp = dtemp + dabs(dx(i)) - 10 continue - dasum = dtemp - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,6) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dtemp + dabs(dx(i)) - 30 continue - if( n .lt. 6 ) go to 60 - 40 mp1 = m + 1 - do 50 i = mp1,n,6 - dtemp = dtemp + dabs(dx(i)) + dabs(dx(i + 1)) + dabs(dx(i + 2)) - * + dabs(dx(i + 3)) + dabs(dx(i + 4)) + dabs(dx(i + 5)) - 50 continue - 60 dasum = dtemp - return - end - SUBROUTINE ZHEMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - COMPLEX*16 ALPHA, BETA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZHEMM performs one of the matrix-matrix operations -* -* C := alpha*A*B + beta*C, -* -* or -* -* C := alpha*B*A + beta*C, -* -* where alpha and beta are scalars, A is an hermitian matrix and B and -* C are m by n matrices. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether the hermitian matrix A -* appears on the left or right in the operation as follows: -* -* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -* -* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the hermitian matrix A is to be -* referenced as follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of the -* hermitian matrix is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of the -* hermitian matrix is to be referenced. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix C. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix C. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* m when SIDE = 'L' or 'l' and is n otherwise. -* Before entry with SIDE = 'L' or 'l', the m by m part of -* the array A must contain the hermitian matrix, such that -* when UPLO = 'U' or 'u', the leading m by m upper triangular -* part of the array A must contain the upper triangular part -* of the hermitian matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading m by m lower triangular part of the array A -* must contain the lower triangular part of the hermitian -* matrix and the strictly upper triangular part of A is not -* referenced. -* Before entry with SIDE = 'R' or 'r', the n by n part of -* the array A must contain the hermitian matrix, such that -* when UPLO = 'U' or 'u', the leading n by n upper triangular -* part of the array A must contain the upper triangular part -* of the hermitian matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading n by n lower triangular part of the array A -* must contain the lower triangular part of the hermitian -* matrix and the strictly upper triangular part of A is not -* referenced. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry, the leading m by n part of the array C must -* contain the matrix C, except when beta is zero, in which -* case C need not be set on entry. -* On exit, the array C is overwritten by the m by n updated -* matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, DBLE -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX*16 TEMP1, TEMP2 -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHEMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1*A( K, I ) - TEMP2 = TEMP2 + - $ B( K, J )*DCONJG( A( K, I ) ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1*A( K, I ) - TEMP2 = TEMP2 + - $ B( K, J )*DCONJG( A( K, I ) ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*DBLE( A( J, J ) ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*DCONJG( A( J, K ) ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*DCONJG( A( J, K ) ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of ZHEMM . -* - END - SUBROUTINE ZHER2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZHER2 performs the hermitian rank 2 operation -* -* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an n -* by n hermitian matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHER2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( J ) ) - TEMP2 = DCONJG( ALPHA*X( J ) ) - DO 10, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 10 CONTINUE - A( J, J ) = DBLE( A( J, J ) ) + - $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( JY ) ) - TEMP2 = DCONJG( ALPHA*X( JX ) ) - IX = KX - IY = KY - DO 30, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - A( J, J ) = DBLE( A( J, J ) ) + - $ DBLE( X( JX )*TEMP1 + Y( JY )*TEMP2 ) - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( J ) ) - TEMP2 = DCONJG( ALPHA*X( J ) ) - A( J, J ) = DBLE( A( J, J ) ) + - $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) - DO 50, I = J + 1, N - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 50 CONTINUE - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( JY ) ) - TEMP2 = DCONJG( ALPHA*X( JX ) ) - A( J, J ) = DBLE( A( J, J ) ) + - $ DBLE( X( JX )*TEMP1 + Y( JY )*TEMP2 ) - IX = JX - IY = JY - DO 70, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - 70 CONTINUE - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHER2 . -* - END - SUBROUTINE ZHER2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, - $ C, LDC ) -* .. Scalar Arguments .. - CHARACTER TRANS, UPLO - INTEGER K, LDA, LDB, LDC, N - DOUBLE PRECISION BETA - COMPLEX*16 ALPHA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZHER2K performs one of the hermitian rank 2k operations -* -* C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, -* -* or -* -* C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, -* -* where alpha and beta are scalars with beta real, C is an n by n -* hermitian matrix and A and B are n by k matrices in the first case -* and k by n matrices in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + -* conjg( alpha )*B*conjg( A' ) + -* beta*C. -* -* TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + -* conjg( alpha )*conjg( B' )*A + -* beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrices A and B, and on entry with -* TRANS = 'C' or 'c', K specifies the number of rows of the -* matrices A and B. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array B must contain the matrix B, otherwise -* the leading k by n part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDB must be at least max( 1, n ), otherwise LDB must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. -* Ed Anderson, Cray Research Inc. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCONJG, MAX -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - COMPLEX*16 TEMP1, TEMP2 -* .. -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) ) THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ) .AND. ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ) .AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) ) THEN - INFO = 2 - ELSE IF( N.LT.0 ) THEN - INFO = 3 - ELSE IF( K.LT.0 ) THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, NROWA ) ) THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = 12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHER2K', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. - $ ( BETA.EQ.ONE ) ) )RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO ) THEN - IF( UPPER ) THEN - IF( BETA.EQ.DBLE( ZERO ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - C( J, J ) = BETA*DBLE( C( J, J ) ) - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.DBLE( ZERO ) ) THEN - DO 60 J = 1, N - DO 50 I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1, N - C( J, J ) = BETA*DBLE( C( J, J ) ) - DO 70 I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) ) THEN -* -* Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + -* C. -* - IF( UPPER ) THEN - DO 130 J = 1, N - IF( BETA.EQ.DBLE( ZERO ) ) THEN - DO 90 I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE ) THEN - DO 100 I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - C( J, J ) = BETA*DBLE( C( J, J ) ) - ELSE - C( J, J ) = DBLE( C( J, J ) ) - END IF - DO 120 L = 1, K - IF( ( A( J, L ).NE.ZERO ) .OR. ( B( J, L ).NE.ZERO ) ) - $ THEN - TEMP1 = ALPHA*DCONJG( B( J, L ) ) - TEMP2 = DCONJG( ALPHA*A( J, L ) ) - DO 110 I = 1, J - 1 - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 110 CONTINUE - C( J, J ) = DBLE( C( J, J ) ) + - $ DBLE( A( J, L )*TEMP1+B( J, L )*TEMP2 ) - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180 J = 1, N - IF( BETA.EQ.DBLE( ZERO ) ) THEN - DO 140 I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE ) THEN - DO 150 I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - C( J, J ) = BETA*DBLE( C( J, J ) ) - ELSE - C( J, J ) = DBLE( C( J, J ) ) - END IF - DO 170 L = 1, K - IF( ( A( J, L ).NE.ZERO ) .OR. ( B( J, L ).NE.ZERO ) ) - $ THEN - TEMP1 = ALPHA*DCONJG( B( J, L ) ) - TEMP2 = DCONJG( ALPHA*A( J, L ) ) - DO 160 I = J + 1, N - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 160 CONTINUE - C( J, J ) = DBLE( C( J, J ) ) + - $ DBLE( A( J, L )*TEMP1+B( J, L )*TEMP2 ) - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + -* C. -* - IF( UPPER ) THEN - DO 210 J = 1, N - DO 200 I = 1, J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190 L = 1, K - TEMP1 = TEMP1 + DCONJG( A( L, I ) )*B( L, J ) - TEMP2 = TEMP2 + DCONJG( B( L, I ) )*A( L, J ) - 190 CONTINUE - IF( I.EQ.J ) THEN - IF( BETA.EQ.DBLE( ZERO ) ) THEN - C( J, J ) = DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* - $ TEMP2 ) - ELSE - C( J, J ) = BETA*DBLE( C( J, J ) ) + - $ DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* - $ TEMP2 ) - END IF - ELSE - IF( BETA.EQ.DBLE( ZERO ) ) THEN - C( I, J ) = ALPHA*TEMP1 + DCONJG( ALPHA )*TEMP2 - ELSE - C( I, J ) = BETA*C( I, J ) + ALPHA*TEMP1 + - $ DCONJG( ALPHA )*TEMP2 - END IF - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240 J = 1, N - DO 230 I = J, N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220 L = 1, K - TEMP1 = TEMP1 + DCONJG( A( L, I ) )*B( L, J ) - TEMP2 = TEMP2 + DCONJG( B( L, I ) )*A( L, J ) - 220 CONTINUE - IF( I.EQ.J ) THEN - IF( BETA.EQ.DBLE( ZERO ) ) THEN - C( J, J ) = DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* - $ TEMP2 ) - ELSE - C( J, J ) = BETA*DBLE( C( J, J ) ) + - $ DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* - $ TEMP2 ) - END IF - ELSE - IF( BETA.EQ.DBLE( ZERO ) ) THEN - C( I, J ) = ALPHA*TEMP1 + DCONJG( ALPHA )*TEMP2 - ELSE - C( I, J ) = BETA*C( I, J ) + ALPHA*TEMP1 + - $ DCONJG( ALPHA )*TEMP2 - END IF - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHER2K. -* - END - SUBROUTINE ZTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - COMPLEX*16 ALPHA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZTRMM performs one of the matrix-matrix operations -* -* B := alpha*op( A )*B, or B := alpha*B*op( A ) -* -* where alpha is a scalar, B is an m by n matrix, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) multiplies B from -* the left or right as follows: -* -* SIDE = 'L' or 'l' B := alpha*op( A )*B. -* -* SIDE = 'R' or 'r' B := alpha*B*op( A ). -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A'. -* -* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B, and on exit is overwritten by the -* transformed matrix. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX*16 TEMP -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOCONJ = LSAME( TRANSA, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTRMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*A*B. -* - IF( UPPER )THEN - DO 50, J = 1, N - DO 40, K = 1, M - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - DO 30, I = 1, K - 1 - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 30 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - B( K, J ) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80, J = 1, N - DO 70 K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - B( K, J ) = TEMP - IF( NOUNIT ) - $ B( K, J ) = B( K, J )*A( K, K ) - DO 60, I = K + 1, M - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A'*B or B := alpha*conjg( A' )*B. -* - IF( UPPER )THEN - DO 120, J = 1, N - DO 110, I = M, 1, -1 - TEMP = B( I, J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 90, K = 1, I - 1 - TEMP = TEMP + A( K, I )*B( K, J ) - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( I, I ) ) - DO 100, K = 1, I - 1 - TEMP = TEMP + DCONJG( A( K, I ) )*B( K, J ) - 100 CONTINUE - END IF - B( I, J ) = ALPHA*TEMP - 110 CONTINUE - 120 CONTINUE - ELSE - DO 160, J = 1, N - DO 150, I = 1, M - TEMP = B( I, J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 130, K = I + 1, M - TEMP = TEMP + A( K, I )*B( K, J ) - 130 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( I, I ) ) - DO 140, K = I + 1, M - TEMP = TEMP + DCONJG( A( K, I ) )*B( K, J ) - 140 CONTINUE - END IF - B( I, J ) = ALPHA*TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*A. -* - IF( UPPER )THEN - DO 200, J = N, 1, -1 - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 170, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 170 CONTINUE - DO 190, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 180, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 180 CONTINUE - END IF - 190 CONTINUE - 200 CONTINUE - ELSE - DO 240, J = 1, N - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 210, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 210 CONTINUE - DO 230, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 220, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 220 CONTINUE - END IF - 230 CONTINUE - 240 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A' or B := alpha*B*conjg( A' ). -* - IF( UPPER )THEN - DO 280, K = 1, N - DO 260, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = ALPHA*A( J, K ) - ELSE - TEMP = ALPHA*DCONJG( A( J, K ) ) - END IF - DO 250, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 250 CONTINUE - END IF - 260 CONTINUE - TEMP = ALPHA - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = TEMP*A( K, K ) - ELSE - TEMP = TEMP*DCONJG( A( K, K ) ) - END IF - END IF - IF( TEMP.NE.ONE )THEN - DO 270, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 270 CONTINUE - END IF - 280 CONTINUE - ELSE - DO 320, K = N, 1, -1 - DO 300, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = ALPHA*A( J, K ) - ELSE - TEMP = ALPHA*DCONJG( A( J, K ) ) - END IF - DO 290, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 290 CONTINUE - END IF - 300 CONTINUE - TEMP = ALPHA - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = TEMP*A( K, K ) - ELSE - TEMP = TEMP*DCONJG( A( K, K ) ) - END IF - END IF - IF( TEMP.NE.ONE )THEN - DO 310, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 310 CONTINUE - END IF - 320 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRMM . -* - END - SUBROUTINE ZTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZTRMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, or x := conjg( A' )*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := conjg( A' )*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTRMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 10, I = 1, J - 1 - X( I ) = X( I ) + TEMP*A( I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, I = 1, J - 1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 50, I = N, J + 1, -1 - X( I ) = X( I ) + TEMP*A( I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, I = N, J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x or x := conjg( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 110, J = N, 1, -1 - TEMP = X( J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( J, J ) ) - DO 100, I = J - 1, 1, -1 - TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) - 100 CONTINUE - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 140, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 120, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + A( I, J )*X( IX ) - 120 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( J, J ) ) - DO 130, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) - 130 CONTINUE - END IF - X( JX ) = TEMP - JX = JX - INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = 1, N - TEMP = X( J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = J + 1, N - TEMP = TEMP + A( I, J )*X( I ) - 150 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( J, J ) ) - DO 160, I = J + 1, N - TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) - 160 CONTINUE - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - JX = KX - DO 200, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 180, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + A( I, J )*X( IX ) - 180 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( J, J ) ) - DO 190, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) - 190 CONTINUE - END IF - X( JX ) = TEMP - JX = JX + INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRMV . -* - END - SUBROUTINE ZTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - COMPLEX*16 ALPHA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZTRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). -* -* The matrix X is overwritten on B. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) appears on the left -* or right of X as follows: -* -* SIDE = 'L' or 'l' op( A )*X = alpha*B. -* -* SIDE = 'R' or 'r' X*op( A ) = alpha*B. -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A'. -* -* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX*16 TEMP -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOCONJ = LSAME( TRANSA, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTRSM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*inv( A )*B. -* - IF( UPPER )THEN - DO 60, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 30, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 30 CONTINUE - END IF - DO 50, K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 40, I = 1, K - 1 - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 70, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 70 CONTINUE - END IF - DO 90 K = 1, M - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 80, I = K + 1, M - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A' )*B -* or B := alpha*inv( conjg( A' ) )*B. -* - IF( UPPER )THEN - DO 140, J = 1, N - DO 130, I = 1, M - TEMP = ALPHA*B( I, J ) - IF( NOCONJ )THEN - DO 110, K = 1, I - 1 - TEMP = TEMP - A( K, I )*B( K, J ) - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - ELSE - DO 120, K = 1, I - 1 - TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J ) - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( I, I ) ) - END IF - B( I, J ) = TEMP - 130 CONTINUE - 140 CONTINUE - ELSE - DO 180, J = 1, N - DO 170, I = M, 1, -1 - TEMP = ALPHA*B( I, J ) - IF( NOCONJ )THEN - DO 150, K = I + 1, M - TEMP = TEMP - A( K, I )*B( K, J ) - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - ELSE - DO 160, K = I + 1, M - TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J ) - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( I, I ) ) - END IF - B( I, J ) = TEMP - 170 CONTINUE - 180 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*inv( A ). -* - IF( UPPER )THEN - DO 230, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 190, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 190 CONTINUE - END IF - DO 210, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - DO 200, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 200 CONTINUE - END IF - 210 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 220, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 220 CONTINUE - END IF - 230 CONTINUE - ELSE - DO 280, J = N, 1, -1 - IF( ALPHA.NE.ONE )THEN - DO 240, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 240 CONTINUE - END IF - DO 260, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - DO 250, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 250 CONTINUE - END IF - 260 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 270, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 270 CONTINUE - END IF - 280 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A' ) -* or B := alpha*B*inv( conjg( A' ) ). -* - IF( UPPER )THEN - DO 330, K = N, 1, -1 - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = ONE/A( K, K ) - ELSE - TEMP = ONE/DCONJG( A( K, K ) ) - END IF - DO 290, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 290 CONTINUE - END IF - DO 310, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = A( J, K ) - ELSE - TEMP = DCONJG( A( J, K ) ) - END IF - DO 300, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 300 CONTINUE - END IF - 310 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 320, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 320 CONTINUE - END IF - 330 CONTINUE - ELSE - DO 380, K = 1, N - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = ONE/A( K, K ) - ELSE - TEMP = ONE/DCONJG( A( K, K ) ) - END IF - DO 340, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 340 CONTINUE - END IF - DO 360, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = A( J, K ) - ELSE - TEMP = DCONJG( A( J, K ) ) - END IF - DO 350, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 350 CONTINUE - END IF - 360 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 370, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 370 CONTINUE - END IF - 380 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRSM . -* - END - SUBROUTINE ZTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZTRSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, or conjg( A' )*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular matrix. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' conjg( A' )*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTRSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 10, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*A( I, J ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - TEMP = X( JX ) - IX = JX - DO 30, I = J - 1, 1, -1 - IX = IX - INCX - X( IX ) = X( IX ) - TEMP*A( I, J ) - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 50, I = J + 1, N - X( I ) = X( I ) - TEMP*A( I, J ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - TEMP = X( JX ) - IX = JX - DO 70, I = J + 1, N - IX = IX + INCX - X( IX ) = X( IX ) - TEMP*A( I, J ) - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = X( J ) - IF( NOCONJ )THEN - DO 90, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( I ) - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 100, I = 1, J - 1 - TEMP = TEMP - DCONJG( A( I, J ) )*X( I ) - 100 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( J, J ) ) - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - JX = KX - DO 140, J = 1, N - IX = KX - TEMP = X( JX ) - IF( NOCONJ )THEN - DO 120, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX + INCX - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 130, I = 1, J - 1 - TEMP = TEMP - DCONJG( A( I, J ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( J, J ) ) - END IF - X( JX ) = TEMP - JX = JX + INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = N, 1, -1 - TEMP = X( J ) - IF( NOCONJ )THEN - DO 150, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( I ) - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 160, I = N, J + 1, -1 - TEMP = TEMP - DCONJG( A( I, J ) )*X( I ) - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( J, J ) ) - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 200, J = N, 1, -1 - IX = KX - TEMP = X( JX ) - IF( NOCONJ )THEN - DO 180, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX - INCX - 180 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 190, I = N, J + 1, -1 - TEMP = TEMP - DCONJG( A( I, J ) )*X( IX ) - IX = IX - INCX - 190 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( J, J ) ) - END IF - X( JX ) = TEMP - JX = JX - INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRSV . -* - END - SUBROUTINE DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSYMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 5 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - ELSE IF( INCY.EQ.0 )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when A is stored in upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, I = 1, J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y when A is stored in lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*A( J, J ) - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) - IX = JX - IY = JY - DO 110, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYMV . -* - END - SUBROUTINE ZHEMV ( UPLO, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZHEMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n hermitian matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of A is not referenced. -* Note that the imaginary parts of the diagonal elements need -* not be set and are assumed to be zero. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 5 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - ELSE IF( INCY.EQ.0 )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHEMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when A is stored in upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*DBLE( A( J, J ) ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, I = 1, J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*DBLE( A( J, J ) ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y when A is stored in lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*DBLE( A( J, J ) ) - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*DBLE( A( J, J ) ) - IX = JX - IY = JY - DO 110, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHEMV . -* - END - SUBROUTINE DSYR ( UPLO, N, ALPHA, X, INCX, A, LDA ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DSYR performs the symmetric rank 1 operation -* -* A := alpha*x*x' + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in upper triangle. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - DO 10, I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30, I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in lower triangle. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - DO 50, I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = JX - DO 70, I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR . -* - END - SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - DOUBLE PRECISION ALPHA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DTRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A'. -* -* The matrix X is overwritten on B. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) appears on the left -* or right of X as follows: -* -* SIDE = 'L' or 'l' op( A )*X = alpha*B. -* -* SIDE = 'R' or 'r' X*op( A ) = alpha*B. -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A'. -* -* TRANSA = 'C' or 'c' op( A ) = A'. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRSM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*inv( A )*B. -* - IF( UPPER )THEN - DO 60, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 30, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 30 CONTINUE - END IF - DO 50, K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 40, I = 1, K - 1 - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 70, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 70 CONTINUE - END IF - DO 90 K = 1, M - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 80, I = K + 1, M - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A' )*B. -* - IF( UPPER )THEN - DO 130, J = 1, N - DO 120, I = 1, M - TEMP = ALPHA*B( I, J ) - DO 110, K = 1, I - 1 - TEMP = TEMP - A( K, I )*B( K, J ) - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE - DO 160, J = 1, N - DO 150, I = M, 1, -1 - TEMP = ALPHA*B( I, J ) - DO 140, K = I + 1, M - TEMP = TEMP - A( K, I )*B( K, J ) - 140 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*inv( A ). -* - IF( UPPER )THEN - DO 210, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 170, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 170 CONTINUE - END IF - DO 190, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - DO 180, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 180 CONTINUE - END IF - 190 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 200, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 200 CONTINUE - END IF - 210 CONTINUE - ELSE - DO 260, J = N, 1, -1 - IF( ALPHA.NE.ONE )THEN - DO 220, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 220 CONTINUE - END IF - DO 240, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - DO 230, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 250, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 250 CONTINUE - END IF - 260 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A' ). -* - IF( UPPER )THEN - DO 310, K = N, 1, -1 - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 270, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 270 CONTINUE - END IF - DO 290, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 280, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 280 CONTINUE - END IF - 290 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 300, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 300 CONTINUE - END IF - 310 CONTINUE - ELSE - DO 360, K = 1, N - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 320, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 320 CONTINUE - END IF - DO 340, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 330, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 330 CONTINUE - END IF - 340 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 350, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 350 CONTINUE - END IF - 360 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSM . -* - END - SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - DOUBLE PRECISION ALPHA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DTRMM performs one of the matrix-matrix operations -* -* B := alpha*op( A )*B, or B := alpha*B*op( A ), -* -* where alpha is a scalar, B is an m by n matrix, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A'. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) multiplies B from -* the left or right as follows: -* -* SIDE = 'L' or 'l' B := alpha*op( A )*B. -* -* SIDE = 'R' or 'r' B := alpha*B*op( A ). -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A'. -* -* TRANSA = 'C' or 'c' op( A ) = A'. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B, and on exit is overwritten by the -* transformed matrix. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*A*B. -* - IF( UPPER )THEN - DO 50, J = 1, N - DO 40, K = 1, M - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - DO 30, I = 1, K - 1 - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 30 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - B( K, J ) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80, J = 1, N - DO 70 K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - B( K, J ) = TEMP - IF( NOUNIT ) - $ B( K, J ) = B( K, J )*A( K, K ) - DO 60, I = K + 1, M - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A'*B. -* - IF( UPPER )THEN - DO 110, J = 1, N - DO 100, I = M, 1, -1 - TEMP = B( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 90, K = 1, I - 1 - TEMP = TEMP + A( K, I )*B( K, J ) - 90 CONTINUE - B( I, J ) = ALPHA*TEMP - 100 CONTINUE - 110 CONTINUE - ELSE - DO 140, J = 1, N - DO 130, I = 1, M - TEMP = B( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 120, K = I + 1, M - TEMP = TEMP + A( K, I )*B( K, J ) - 120 CONTINUE - B( I, J ) = ALPHA*TEMP - 130 CONTINUE - 140 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*A. -* - IF( UPPER )THEN - DO 180, J = N, 1, -1 - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 150 CONTINUE - DO 170, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 160, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - ELSE - DO 220, J = 1, N - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 190, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 190 CONTINUE - DO 210, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 200, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 200 CONTINUE - END IF - 210 CONTINUE - 220 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A'. -* - IF( UPPER )THEN - DO 260, K = 1, N - DO 240, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = ALPHA*A( J, K ) - DO 230, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - IF( TEMP.NE.ONE )THEN - DO 250, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 250 CONTINUE - END IF - 260 CONTINUE - ELSE - DO 300, K = N, 1, -1 - DO 280, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = ALPHA*A( J, K ) - DO 270, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 270 CONTINUE - END IF - 280 CONTINUE - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - IF( TEMP.NE.ONE )THEN - DO 290, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 290 CONTINUE - END IF - 300 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMM . -* - END - SUBROUTINE ZHERK( UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER TRANS, UPLO - INTEGER K, LDA, LDC, N - DOUBLE PRECISION ALPHA, BETA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZHERK performs one of the hermitian rank k operations -* -* C := alpha*A*conjg( A' ) + beta*C, -* -* or -* -* C := alpha*conjg( A' )*A + beta*C, -* -* where alpha and beta are real scalars, C is an n by n hermitian -* matrix and A is an n by k matrix in the first case and a k by n -* matrix in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. -* -* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrix A, and on entry with -* TRANS = 'C' or 'c', K specifies the number of rows of the -* matrix A. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. -* Ed Anderson, Cray Research Inc. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DCONJG, MAX -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - DOUBLE PRECISION RTEMP - COMPLEX*16 TEMP -* .. -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) ) THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ) .AND. ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ) .AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) ) THEN - INFO = 2 - ELSE IF( N.LT.0 ) THEN - INFO = 3 - ELSE IF( K.LT.0 ) THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN - INFO = 7 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = 10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHERK ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. - $ ( BETA.EQ.ONE ) ) )RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO ) THEN - IF( UPPER ) THEN - IF( BETA.EQ.ZERO ) THEN - DO 20 J = 1, N - DO 10 I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - C( J, J ) = BETA*DBLE( C( J, J ) ) - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO ) THEN - DO 60 J = 1, N - DO 50 I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1, N - C( J, J ) = BETA*DBLE( C( J, J ) ) - DO 70 I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) ) THEN -* -* Form C := alpha*A*conjg( A' ) + beta*C. -* - IF( UPPER ) THEN - DO 130 J = 1, N - IF( BETA.EQ.ZERO ) THEN - DO 90 I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE ) THEN - DO 100 I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - C( J, J ) = BETA*DBLE( C( J, J ) ) - ELSE - C( J, J ) = DBLE( C( J, J ) ) - END IF - DO 120 L = 1, K - IF( A( J, L ).NE.DCMPLX( ZERO ) ) THEN - TEMP = ALPHA*DCONJG( A( J, L ) ) - DO 110 I = 1, J - 1 - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - C( J, J ) = DBLE( C( J, J ) ) + - $ DBLE( TEMP*A( I, L ) ) - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180 J = 1, N - IF( BETA.EQ.ZERO ) THEN - DO 140 I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE ) THEN - C( J, J ) = BETA*DBLE( C( J, J ) ) - DO 150 I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - ELSE - C( J, J ) = DBLE( C( J, J ) ) - END IF - DO 170 L = 1, K - IF( A( J, L ).NE.DCMPLX( ZERO ) ) THEN - TEMP = ALPHA*DCONJG( A( J, L ) ) - C( J, J ) = DBLE( C( J, J ) ) + - $ DBLE( TEMP*A( J, L ) ) - DO 160 I = J + 1, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*conjg( A' )*A + beta*C. -* - IF( UPPER ) THEN - DO 220 J = 1, N - DO 200 I = 1, J - 1 - TEMP = ZERO - DO 190 L = 1, K - TEMP = TEMP + DCONJG( A( L, I ) )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO ) THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 200 CONTINUE - RTEMP = ZERO - DO 210 L = 1, K - RTEMP = RTEMP + DCONJG( A( L, J ) )*A( L, J ) - 210 CONTINUE - IF( BETA.EQ.ZERO ) THEN - C( J, J ) = ALPHA*RTEMP - ELSE - C( J, J ) = ALPHA*RTEMP + BETA*DBLE( C( J, J ) ) - END IF - 220 CONTINUE - ELSE - DO 260 J = 1, N - RTEMP = ZERO - DO 230 L = 1, K - RTEMP = RTEMP + DCONJG( A( L, J ) )*A( L, J ) - 230 CONTINUE - IF( BETA.EQ.ZERO ) THEN - C( J, J ) = ALPHA*RTEMP - ELSE - C( J, J ) = ALPHA*RTEMP + BETA*DBLE( C( J, J ) ) - END IF - DO 250 I = J + 1, N - TEMP = ZERO - DO 240 L = 1, K - TEMP = TEMP + DCONJG( A( L, I ) )*A( L, J ) - 240 CONTINUE - IF( BETA.EQ.ZERO ) THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 250 CONTINUE - 260 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHERK . -* - END - SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTRMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := A'*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 10, I = 1, J - 1 - X( I ) = X( I ) + TEMP*A( I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, I = 1, J - 1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 50, I = N, J + 1, -1 - X( I ) = X( I ) + TEMP*A( I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, I = N, J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 100, J = N, 1, -1 - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - X( J ) = TEMP - 100 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 120, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 110, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + A( I, J )*X( IX ) - 110 CONTINUE - X( JX ) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = 1, N - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 130, I = J + 1, N - TEMP = TEMP + A( I, J )*X( I ) - 130 CONTINUE - X( J ) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + A( I, J )*X( IX ) - 150 CONTINUE - X( JX ) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMV . -* - END - SUBROUTINE DSYMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DSYMM performs one of the matrix-matrix operations -* -* C := alpha*A*B + beta*C, -* -* or -* -* C := alpha*B*A + beta*C, -* -* where alpha and beta are scalars, A is a symmetric matrix and B and -* C are m by n matrices. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether the symmetric matrix A -* appears on the left or right in the operation as follows: -* -* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -* -* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the symmetric matrix A is to be -* referenced as follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of the -* symmetric matrix is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of the -* symmetric matrix is to be referenced. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix C. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix C. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -* m when SIDE = 'L' or 'l' and is n otherwise. -* Before entry with SIDE = 'L' or 'l', the m by m part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading m by m upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading m by m lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Before entry with SIDE = 'R' or 'r', the n by n part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading n by n upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading n by n lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, n ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -* Before entry, the leading m by n part of the array C must -* contain the matrix C, except when beta is zero, in which -* case C need not be set on entry. -* On exit, the array C is overwritten by the m by n updated -* matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP1, TEMP2 -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*A( J, J ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*A( J, K ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*A( J, K ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of DSYMM . -* - END - SUBROUTINE DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSYR2 performs the symmetric rank 2 operation -* -* A := alpha*x*y' + alpha*y*x' + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an n -* by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 10, I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = KX - IY = KY - DO 30, I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 50, I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = JX - IY = JY - DO 70, I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR2 . -* - END - SUBROUTINE DSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DSYRK performs one of the symmetric rank k operations -* -* C := alpha*A*A' + beta*C, -* -* or -* -* C := alpha*A'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A is an n by k matrix in the first case and a k by n matrix -* in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. -* -* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrix A, and on entry with -* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -* of rows of the matrix A. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYRK ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*A' + beta*C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*A + beta*C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP = ZERO - DO 190, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP = ZERO - DO 220, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYRK . -* - END - SUBROUTINE DSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DSYR2K performs one of the symmetric rank 2k operations -* -* C := alpha*A*B' + alpha*B*A' + beta*C, -* -* or -* -* C := alpha*A'*B + alpha*B'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A and B are n by k matrices in the first case and k by n -* matrices in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + -* beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + -* beta*C. -* -* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + -* beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrices A and B, and on entry with -* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -* of rows of the matrices A and B. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array B must contain the matrix B, otherwise -* the leading k by n part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDB must be at least max( 1, n ), otherwise LDB must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - DOUBLE PRECISION TEMP1, TEMP2 -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR2K', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*B' + alpha*B*A' + C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + - $ A( I, L )*TEMP1 + B( I, L )*TEMP2 - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + - $ A( I, L )*TEMP1 + B( I, L )*TEMP2 - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*B + alpha*B'*A + C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR2K. -* - END - SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTRSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular matrix. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' A'*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 10, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*A( I, J ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - TEMP = X( JX ) - IX = JX - DO 30, I = J - 1, 1, -1 - IX = IX - INCX - X( IX ) = X( IX ) - TEMP*A( I, J ) - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 50, I = J + 1, N - X( I ) = X( I ) - TEMP*A( I, J ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - TEMP = X( JX ) - IX = JX - DO 70, I = J + 1, N - IX = IX + INCX - X( IX ) = X( IX ) - TEMP*A( I, J ) - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = X( J ) - DO 90, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( I ) - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( J ) = TEMP - 100 CONTINUE - ELSE - JX = KX - DO 120, J = 1, N - TEMP = X( JX ) - IX = KX - DO 110, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( JX ) = TEMP - JX = JX + INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = N, 1, -1 - TEMP = X( J ) - DO 130, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( I ) - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( J ) = TEMP - 140 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 160, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - DO 150, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX - INCX - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( JX ) = TEMP - JX = JX - INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSV . -* - END - - DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* DNRM2 returns the euclidean norm of a vector via the function -* name, so that -* -* DNRM2 := sqrt( x'*x ) -* -* -* -* -- This version written on 25-October-1982. -* Modified on 14-October-1993 to inline the call to DLASSQ. -* Sven Hammarling, Nag Ltd. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION ABSXI, NORM, SCALE, SSQ -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. - IF( N.LT.1 .OR. INCX.LT.1 )THEN - NORM = ZERO - ELSE IF( N.EQ.1 )THEN - NORM = ABS( X( 1 ) ) - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - IF( X( IX ).NE.ZERO )THEN - ABSXI = ABS( X( IX ) ) - IF( SCALE.LT.ABSXI )THEN - SSQ = ONE + SSQ*( SCALE/ABSXI )**2 - SCALE = ABSXI - ELSE - SSQ = SSQ + ( ABSXI/SCALE )**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE * SQRT( SSQ ) - END IF -* - DNRM2 = NORM - RETURN -* -* End of DNRM2. -* - END - - SUBROUTINE ZSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDB, LDC - COMPLEX*16 ALPHA, BETA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZSYR2K performs one of the symmetric rank 2k operations -* -* C := alpha*A*B' + alpha*B*A' + beta*C, -* -* or -* -* C := alpha*A'*B + alpha*B'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A and B are n by k matrices in the first case and k by n -* matrices in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + -* beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + -* beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrices A and B, and on entry with -* TRANS = 'T' or 't', K specifies the number of rows of the -* matrices A and B. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array B must contain the matrix B, otherwise -* the leading k by n part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDB must be at least max( 1, n ), otherwise LDB must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - COMPLEX*16 TEMP1, TEMP2 -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZSYR2K', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*B' + alpha*B*A' + C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*B + alpha*B'*A + C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZSYR2K. -* - END - - SUBROUTINE ZSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - COMPLEX*16 ALPHA, BETA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZSYRK performs one of the symmetric rank k operations -* -* C := alpha*A*A' + beta*C, -* -* or -* -* C := alpha*A'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A is an n by k matrix in the first case and a k by n matrix -* in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrix A, and on entry with -* TRANS = 'T' or 't', K specifies the number of rows of the -* matrix A. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - COMPLEX*16 TEMP -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZSYRK ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*A' + beta*C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*A + beta*C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP = ZERO - DO 190, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP = ZERO - DO 220, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZSYRK . -* - END - -* start w90 - - SUBROUTINE ZTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* .. Scalar Arguments .. - INTEGER INCX,K,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE COMPLEX A(LDA,*),X(*) -* .. -* -* Purpose -* ======= -* -* ZTBSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, or conjg( A' )*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular band matrix, with ( k + 1 ) -* diagonals. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Arguments -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' conjg( A' )*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with UPLO = 'U' or 'u', K specifies the number of -* super-diagonals of the matrix A. -* On entry with UPLO = 'L' or 'l', K specifies the number of -* sub-diagonals of the matrix A. -* K must satisfy 0 .le. K. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer an upper -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer a lower -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that when DIAG = 'U' or 'u' the elements of the array A -* corresponding to the diagonal elements of the matrix are not -* referenced, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE COMPLEX ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - DOUBLE COMPLEX TEMP - INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L - LOGICAL NOCONJ,NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX,MIN -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT. (K+1)) THEN - INFO = 7 - ELSE IF (INCX.EQ.0) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZTBSV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOCONJ = LSAME(TRANS,'T') - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed by sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := inv( A )*x. -* - IF (LSAME(UPLO,'U')) THEN - KPLUS1 = K + 1 - IF (INCX.EQ.1) THEN - DO 20 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - L = KPLUS1 - J - IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J) - TEMP = X(J) - DO 10 I = J - 1,MAX(1,J-K),-1 - X(I) = X(I) - TEMP*A(L+I,J) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 40 J = N,1,-1 - KX = KX - INCX - IF (X(JX).NE.ZERO) THEN - IX = KX - L = KPLUS1 - J - IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J) - TEMP = X(JX) - DO 30 I = J - 1,MAX(1,J-K),-1 - X(IX) = X(IX) - TEMP*A(L+I,J) - IX = IX - INCX - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = 1,N - IF (X(J).NE.ZERO) THEN - L = 1 - J - IF (NOUNIT) X(J) = X(J)/A(1,J) - TEMP = X(J) - DO 50 I = J + 1,MIN(N,J+K) - X(I) = X(I) - TEMP*A(L+I,J) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1,N - KX = KX + INCX - IF (X(JX).NE.ZERO) THEN - IX = KX - L = 1 - J - IF (NOUNIT) X(JX) = X(JX)/A(1,J) - TEMP = X(JX) - DO 70 I = J + 1,MIN(N,J+K) - X(IX) = X(IX) - TEMP*A(L+I,J) - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x or x := inv( conjg( A') )*x. -* - IF (LSAME(UPLO,'U')) THEN - KPLUS1 = K + 1 - IF (INCX.EQ.1) THEN - DO 110 J = 1,N - TEMP = X(J) - L = KPLUS1 - J - IF (NOCONJ) THEN - DO 90 I = MAX(1,J-K),J - 1 - TEMP = TEMP - A(L+I,J)*X(I) - 90 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) - ELSE - DO 100 I = MAX(1,J-K),J - 1 - TEMP = TEMP - DCONJG(A(L+I,J))*X(I) - 100 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(KPLUS1,J)) - END IF - X(J) = TEMP - 110 CONTINUE - ELSE - JX = KX - DO 140 J = 1,N - TEMP = X(JX) - IX = KX - L = KPLUS1 - J - IF (NOCONJ) THEN - DO 120 I = MAX(1,J-K),J - 1 - TEMP = TEMP - A(L+I,J)*X(IX) - IX = IX + INCX - 120 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) - ELSE - DO 130 I = MAX(1,J-K),J - 1 - TEMP = TEMP - DCONJG(A(L+I,J))*X(IX) - IX = IX + INCX - 130 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(KPLUS1,J)) - END IF - X(JX) = TEMP - JX = JX + INCX - IF (J.GT.K) KX = KX + INCX - 140 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 170 J = N,1,-1 - TEMP = X(J) - L = 1 - J - IF (NOCONJ) THEN - DO 150 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - A(L+I,J)*X(I) - 150 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(1,J) - ELSE - DO 160 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - DCONJG(A(L+I,J))*X(I) - 160 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(1,J)) - END IF - X(J) = TEMP - 170 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 200 J = N,1,-1 - TEMP = X(JX) - IX = KX - L = 1 - J - IF (NOCONJ) THEN - DO 180 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - A(L+I,J)*X(IX) - IX = IX - INCX - 180 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(1,J) - ELSE - DO 190 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - DCONJG(A(L+I,J))*X(IX) - IX = IX - INCX - 190 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(1,J)) - END IF - X(JX) = TEMP - JX = JX - INCX - IF ((N-J).GE.K) KX = KX - INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTBSV . - -* end w90 -* - END - diff --git a/quantum_espresso/kcp/flib/blas_mac.f b/quantum_espresso/kcp/flib/blas_mac.f deleted file mode 100644 index f8fb9f484..000000000 --- a/quantum_espresso/kcp/flib/blas_mac.f +++ /dev/null @@ -1,45 +0,0 @@ - -! these four routines fix a bug of the Accelerate.framework implementation -! of BLAS on Mac OS X . Copied from: -! http://developer.apple.com/hardware/ve/errata.html#fortran_conventions -! by Stefano Baroni, December 10, 2005 - - double complex function zdotc(n, zx, incx, zy, incy) - double complex zx(*), zy(*), z - integer n, incx, incy - - call cblas_zdotc_sub(%val(n), zx, %val(incx), zy, %val(incy), z) - - zdotc = z - return - end - - double complex function zdotu(n, zx, incx, zy, incy) - double complex zx(*), zy(*), z - integer n, incx, incy - - call cblas_zdotu_sub(%val(n), zx, %val(incx), zy, %val(incy), z) - - zdotu = z - return - end - - complex function cdotc(n, cx, incx, cy, incy) - complex cx(*), cy(*), c - integer n, incx, incy - - call cblas_cdotc_sub(%val(n), cx, %val(incx), cy, %val(incy), c) - - cdotc = c - return - end - - complex function cdotu(n, cx, incx, cy, incy) - complex cx(*), cy(*), c - integer n, incx, incy - - call cblas_cdotu_sub(%val(n), cx, %val(incx), cy, %val(incy), c) - - cdotu = c - return - end diff --git a/quantum_espresso/kcp/flib/capital.f90 b/quantum_espresso/kcp/flib/capital.f90 deleted file mode 100644 index 42f1e384e..000000000 --- a/quantum_espresso/kcp/flib/capital.f90 +++ /dev/null @@ -1,97 +0,0 @@ -! -! Copyright (C) 2001-2008 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!----------------------------------------------------------------------- -FUNCTION capital( in_char ) - !----------------------------------------------------------------------- - ! - ! ... converts character to capital if lowercase - ! ... copy character to output in all other cases - ! - IMPLICIT NONE - ! - CHARACTER(LEN=1), INTENT(IN) :: in_char - CHARACTER(LEN=1) :: capital - CHARACTER(LEN=26), PARAMETER :: lower = 'abcdefghijklmnopqrstuvwxyz', & - upper = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - INTEGER :: i - ! - ! - DO i=1, 26 - ! - IF ( in_char == lower(i:i) ) THEN - ! - capital = upper(i:i) - ! - RETURN - ! - END IF - ! - END DO - ! - capital = in_char - ! - RETURN - ! -END FUNCTION capital -! -!----------------------------------------------------------------------- -FUNCTION lowercase( in_char ) - !----------------------------------------------------------------------- - ! - ! ... converts character to lowercase if capital - ! ... copy character to output in all other cases - ! - IMPLICIT NONE - ! - CHARACTER(LEN=1), INTENT(IN) :: in_char - CHARACTER(LEN=1) :: lowercase - CHARACTER(LEN=26), PARAMETER :: lower = 'abcdefghijklmnopqrstuvwxyz', & - upper = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - INTEGER :: i - ! - ! - DO i=1, 26 - ! - IF ( in_char == upper(i:i) ) THEN - ! - lowercase = lower(i:i) - ! - RETURN - ! - END IF - ! - END DO - ! - lowercase = in_char - ! - RETURN - ! -END FUNCTION lowercase -! -!----------------------------------------------------------------------- -LOGICAL FUNCTION isnumeric ( in_char ) - !----------------------------------------------------------------------- - ! - ! ... check if a character is a number - ! - IMPLICIT NONE - ! - CHARACTER(LEN=1), INTENT(IN) :: in_char - CHARACTER(LEN=10), PARAMETER :: numbers = '0123456789' - INTEGER :: i - ! - ! - DO i=1, 10 - ! - isnumeric = ( in_char == numbers(i:i) ) - IF ( isnumeric ) RETURN - ! - END DO - RETURN - ! -END FUNCTION isnumeric diff --git a/quantum_espresso/kcp/flib/cryst_to_car.f90 b/quantum_espresso/kcp/flib/cryst_to_car.f90 deleted file mode 100644 index 109386848..000000000 --- a/quantum_espresso/kcp/flib/cryst_to_car.f90 +++ /dev/null @@ -1,66 +0,0 @@ -! -! Copyright (C) 2001-2003 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!----------------------------------------------------------------------- -subroutine cryst_to_cart (nvec, vec, trmat, iflag) - !----------------------------------------------------------------------- - ! - ! This routine transforms the atomic positions or the k-point - ! components from crystallographic to cartesian coordinates - ! ( iflag=1 ) and viceversa ( iflag=-1 ). - ! Output cartesian coordinates are stored in the input ('vec') array - ! - ! - USE kinds, ONLY : DP - implicit none - ! - integer, intent(in) :: nvec, iflag - ! nvec: number of vectors (atomic positions or k-points) - ! to be transformed from crystal to cartesian and vice versa - ! iflag: gives the direction of the transformation - real(DP), intent(in) :: trmat (3, 3) - ! trmat: transformation matrix - ! if iflag=1: - ! trmat = at , basis of the real-space lattice, for atoms or - ! = bg , basis of the reciprocal-space lattice, for k-points - ! if iflag=-1: the opposite - real(DP), intent(inout) :: vec (3, nvec) - ! coordinates of the vector (atomic positions or k-points) to be - ! transformed - overwritten on output - ! - ! local variables - ! - integer :: nv, kpol - ! counter on vectors - ! counter on polarizations - real(DP) :: vau (3) - ! workspace - ! - ! Compute the cartesian coordinates of each vectors - ! (atomic positions or k-points components) - ! - do nv = 1, nvec - if (iflag.eq.1) then - do kpol = 1, 3 - vau (kpol) = trmat (kpol, 1) * vec (1, nv) + trmat (kpol, 2) & - * vec (2, nv) + trmat (kpol, 3) * vec (3, nv) - enddo - else - do kpol = 1, 3 - vau (kpol) = trmat (1, kpol) * vec (1, nv) + trmat (2, kpol) & - * vec (2, nv) + trmat (3, kpol) * vec (3, nv) - enddo - endif - do kpol = 1, 3 - vec (kpol, nv) = vau (kpol) - enddo - enddo - ! - return -end subroutine cryst_to_cart - diff --git a/quantum_espresso/kcp/flib/date_and_tim.f90 b/quantum_espresso/kcp/flib/date_and_tim.f90 deleted file mode 100644 index c8ccd3d8e..000000000 --- a/quantum_espresso/kcp/flib/date_and_tim.f90 +++ /dev/null @@ -1,26 +0,0 @@ -! -! Copyright (C) 2001 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -subroutine date_and_tim (cdate, ctime) - ! - ! Returns two strings containing the date and the time - ! in human-readable format. Uses a standard f90 call. - ! - implicit none - character (len=9) :: cdate, ctime - ! - character(len=3), dimension(12) :: months - data months /'Jan','Feb','Mar','Apr','May','Jun', & - 'Jul','Aug','Sep','Oct','Nov','Dec'/ - INTEGER date_time(8) - ! - call date_and_time(values=date_time) - ! - write (cdate,'(i2,a3,i4)') date_time(3), months(date_time(2)), date_time(1) - write (ctime,'(i2,":",i2,":",i2)') date_time(5), date_time(6), date_time(7) - -end subroutine date_and_tim diff --git a/quantum_espresso/kcp/flib/dlamch.f b/quantum_espresso/kcp/flib/dlamch.f deleted file mode 100644 index 64ac3becd..000000000 --- a/quantum_espresso/kcp/flib/dlamch.f +++ /dev/null @@ -1,857 +0,0 @@ - DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER CMACH -* .. -* -* Purpose -* ======= -* -* DLAMCH determines double precision machine parameters. -* -* Arguments -* ========= -* -* CMACH (input) CHARACTER*1 -* Specifies the value to be returned by DLAMCH: -* = 'E' or 'e', DLAMCH := eps -* = 'S' or 's , DLAMCH := sfmin -* = 'B' or 'b', DLAMCH := base -* = 'P' or 'p', DLAMCH := eps*base -* = 'N' or 'n', DLAMCH := t -* = 'R' or 'r', DLAMCH := rnd -* = 'M' or 'm', DLAMCH := emin -* = 'U' or 'u', DLAMCH := rmin -* = 'L' or 'l', DLAMCH := emax -* = 'O' or 'o', DLAMCH := rmax -* -* where -* -* eps = relative machine precision -* sfmin = safe minimum, such that 1/sfmin does not overflow -* base = base of the machine -* prec = eps*base -* t = number of (base) digits in the mantissa -* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise -* emin = minimum exponent before (gradual) underflow -* rmin = underflow threshold - base**(emin-1) -* emax = largest exponent before overflow -* rmax = overflow threshold - (base**emax)*(1-eps) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL FIRST, LRND - INTEGER BETA, IMAX, IMIN, IT - DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, - $ RND, SFMIN, SMALL, T -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLAMC2 -* .. -* .. Save statement .. - SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, - $ EMAX, RMAX, PREC -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) - BASE = BETA - T = IT - IF( LRND ) THEN - RND = ONE - EPS = ( BASE**( 1-IT ) ) / 2 - ELSE - RND = ZERO - EPS = BASE**( 1-IT ) - END IF - PREC = EPS*BASE - EMIN = IMIN - EMAX = IMAX - SFMIN = RMIN - SMALL = ONE / RMAX - IF( SMALL.GE.SFMIN ) THEN -* -* Use SMALL plus a bit, to avoid the possibility of rounding -* causing overflow when computing 1/sfmin. -* - SFMIN = SMALL*( ONE+EPS ) - END IF - END IF -* - IF( LSAME( CMACH, 'E' ) ) THEN - RMACH = EPS - ELSE IF( LSAME( CMACH, 'S' ) ) THEN - RMACH = SFMIN - ELSE IF( LSAME( CMACH, 'B' ) ) THEN - RMACH = BASE - ELSE IF( LSAME( CMACH, 'P' ) ) THEN - RMACH = PREC - ELSE IF( LSAME( CMACH, 'N' ) ) THEN - RMACH = T - ELSE IF( LSAME( CMACH, 'R' ) ) THEN - RMACH = RND - ELSE IF( LSAME( CMACH, 'M' ) ) THEN - RMACH = EMIN - ELSE IF( LSAME( CMACH, 'U' ) ) THEN - RMACH = RMIN - ELSE IF( LSAME( CMACH, 'L' ) ) THEN - RMACH = EMAX - ELSE IF( LSAME( CMACH, 'O' ) ) THEN - RMACH = RMAX - END IF -* - DLAMCH = RMACH - RETURN -* -* End of DLAMCH -* - END -* -************************************************************************ -* - SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - LOGICAL IEEE1, RND - INTEGER BETA, T -* .. -* -* Purpose -* ======= -* -* DLAMC1 determines the machine parameters given by BETA, T, RND, and -* IEEE1. -* -* Arguments -* ========= -* -* BETA (output) INTEGER -* The base of the machine. -* -* T (output) INTEGER -* The number of ( BETA ) digits in the mantissa. -* -* RND (output) LOGICAL -* Specifies whether proper rounding ( RND = .TRUE. ) or -* chopping ( RND = .FALSE. ) occurs in addition. This may not -* be a reliable guide to the way in which the machine performs -* its arithmetic. -* -* IEEE1 (output) LOGICAL -* Specifies whether rounding appears to be done in the IEEE -* 'round to nearest' style. -* -* Further Details -* =============== -* -* The routine is based on the routine ENVRON by Malcolm and -* incorporates suggestions by Gentleman and Marovich. See -* -* Malcolm M. A. (1972) Algorithms to reveal properties of -* floating-point arithmetic. Comms. of the ACM, 15, 949-951. -* -* Gentleman W. M. and Marovich S. B. (1974) More on algorithms -* that reveal properties of floating point arithmetic units. -* Comms. of the ACM, 17, 276-277. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL FIRST, LIEEE1, LRND - INTEGER LBETA, LT - DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. Save statement .. - SAVE FIRST, LIEEE1, LBETA, LRND, LT -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - ONE = 1 -* -* LBETA, LIEEE1, LT and LRND are the local values of BETA, -* IEEE1, T and RND. -* -* Throughout this routine we use the function DLAMC3 to ensure -* that relevant values are stored and not held in registers, or -* are not affected by optimizers. -* -* Compute a = 2.0**m with the smallest positive integer m such -* that -* -* fl( a + 1.0 ) = a. -* - A = 1 - C = 1 -* -*+ WHILE( C.EQ.ONE )LOOP - 10 CONTINUE - IF( C.EQ.ONE ) THEN - A = 2*A - C = DLAMC3( A, ONE ) - C = DLAMC3( C, -A ) - GO TO 10 - END IF -*+ END WHILE -* -* Now compute b = 2.0**m with the smallest positive integer m -* such that -* -* fl( a + b ) .gt. a. -* - B = 1 - C = DLAMC3( A, B ) -* -*+ WHILE( C.EQ.A )LOOP - 20 CONTINUE - IF( C.EQ.A ) THEN - B = 2*B - C = DLAMC3( A, B ) - GO TO 20 - END IF -*+ END WHILE -* -* Now compute the base. a and c are neighbouring floating point -* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so -* their difference is beta. Adding 0.25 to c is to ensure that it -* is truncated to beta and not ( beta - 1 ). -* - QTR = ONE / 4 - SAVEC = C - C = DLAMC3( C, -A ) - LBETA = C + QTR -* -* Now determine whether rounding or chopping occurs, by adding a -* bit less than beta/2 and a bit more than beta/2 to a. -* - B = LBETA - F = DLAMC3( B / 2, -B / 100 ) - C = DLAMC3( F, A ) - IF( C.EQ.A ) THEN - LRND = .TRUE. - ELSE - LRND = .FALSE. - END IF - F = DLAMC3( B / 2, B / 100 ) - C = DLAMC3( F, A ) - IF( ( LRND ) .AND. ( C.EQ.A ) ) - $ LRND = .FALSE. -* -* Try and decide whether rounding is done in the IEEE 'round to -* nearest' style. B/2 is half a unit in the last place of the two -* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit -* zero, and SAVEC is odd. Thus adding B/2 to A should not change -* A, but adding B/2 to SAVEC should change SAVEC. -* - T1 = DLAMC3( B / 2, A ) - T2 = DLAMC3( B / 2, SAVEC ) - LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND -* -* Now find the mantissa, t. It should be the integer part of -* log to the base beta of a, however it is safer to determine t -* by powering. So we find t as the smallest positive integer for -* which -* -* fl( beta**t + 1.0 ) = 1.0. -* - LT = 0 - A = 1 - C = 1 -* -*+ WHILE( C.EQ.ONE )LOOP - 30 CONTINUE - IF( C.EQ.ONE ) THEN - LT = LT + 1 - A = A*LBETA - C = DLAMC3( A, ONE ) - C = DLAMC3( C, -A ) - GO TO 30 - END IF -*+ END WHILE -* - END IF -* - BETA = LBETA - T = LT - RND = LRND - IEEE1 = LIEEE1 - RETURN -* -* End of DLAMC1 -* - END -* -************************************************************************ -* - SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - LOGICAL RND - INTEGER BETA, EMAX, EMIN, T - DOUBLE PRECISION EPS, RMAX, RMIN -* .. -* -* Purpose -* ======= -* -* DLAMC2 determines the machine parameters specified in its argument -* list. -* -* Arguments -* ========= -* -* BETA (output) INTEGER -* The base of the machine. -* -* T (output) INTEGER -* The number of ( BETA ) digits in the mantissa. -* -* RND (output) LOGICAL -* Specifies whether proper rounding ( RND = .TRUE. ) or -* chopping ( RND = .FALSE. ) occurs in addition. This may not -* be a reliable guide to the way in which the machine performs -* its arithmetic. -* -* EPS (output) DOUBLE PRECISION -* The smallest positive number such that -* -* fl( 1.0 - EPS ) .LT. 1.0, -* -* where fl denotes the computed value. -* -* EMIN (output) INTEGER -* The minimum exponent before (gradual) underflow occurs. -* -* RMIN (output) DOUBLE PRECISION -* The smallest normalized number for the machine, given by -* BASE**( EMIN - 1 ), where BASE is the floating point value -* of BETA. -* -* EMAX (output) INTEGER -* The maximum exponent before overflow occurs. -* -* RMAX (output) DOUBLE PRECISION -* The largest positive number for the machine, given by -* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point -* value of BETA. -* -* Further Details -* =============== -* -* The computation of EPS is based on a routine PARANOIA by -* W. Kahan of the University of California at Berkeley. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND - INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, - $ NGNMIN, NGPMIN - DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, - $ SIXTH, SMALL, THIRD, TWO, ZERO -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. External Subroutines .. - EXTERNAL DLAMC1, DLAMC4, DLAMC5 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Save statement .. - SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, - $ LRMIN, LT -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / , IWARN / .FALSE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - ZERO = 0 - ONE = 1 - TWO = 2 -* -* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of -* BETA, T, RND, EPS, EMIN and RMIN. -* -* Throughout this routine we use the function DLAMC3 to ensure -* that relevant values are stored and not held in registers, or -* are not affected by optimizers. -* -* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. -* - CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) -* -* Start to find EPS. -* - B = LBETA - A = B**( -LT ) - LEPS = A -* -* Try some tricks to see whether or not this is the correct EPS. -* - B = TWO / 3 - HALF = ONE / 2 - SIXTH = DLAMC3( B, -HALF ) - THIRD = DLAMC3( SIXTH, SIXTH ) - B = DLAMC3( THIRD, -HALF ) - B = DLAMC3( B, SIXTH ) - B = ABS( B ) - IF( B.LT.LEPS ) - $ B = LEPS -* - LEPS = 1 -* -*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP - 10 CONTINUE - IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN - LEPS = B - C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) - C = DLAMC3( HALF, -C ) - B = DLAMC3( HALF, C ) - C = DLAMC3( HALF, -B ) - B = DLAMC3( HALF, C ) - GO TO 10 - END IF -*+ END WHILE -* - IF( A.LT.LEPS ) - $ LEPS = A -* -* Computation of EPS complete. -* -* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). -* Keep dividing A by BETA until (gradual) underflow occurs. This -* is detected when we cannot recover the previous A. -* - RBASE = ONE / LBETA - SMALL = ONE - DO 20 I = 1, 3 - SMALL = DLAMC3( SMALL*RBASE, ZERO ) - 20 CONTINUE - A = DLAMC3( ONE, SMALL ) - CALL DLAMC4( NGPMIN, ONE, LBETA ) - CALL DLAMC4( NGNMIN, -ONE, LBETA ) - CALL DLAMC4( GPMIN, A, LBETA ) - CALL DLAMC4( GNMIN, -A, LBETA ) - IEEE = .FALSE. -* - IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN - IF( NGPMIN.EQ.GPMIN ) THEN - LEMIN = NGPMIN -* ( Non twos-complement machines, no gradual underflow; -* e.g., VAX ) - ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN - LEMIN = NGPMIN - 1 + LT - IEEE = .TRUE. -* ( Non twos-complement machines, with gradual underflow; -* e.g., IEEE standard followers ) - ELSE - LEMIN = MIN( NGPMIN, GPMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN - IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN - LEMIN = MAX( NGPMIN, NGNMIN ) -* ( Twos-complement machines, no gradual underflow; -* e.g., CYBER 205 ) - ELSE - LEMIN = MIN( NGPMIN, NGNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. - $ ( GPMIN.EQ.GNMIN ) ) THEN - IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN - LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT -* ( Twos-complement machines with gradual underflow; -* no known machine ) - ELSE - LEMIN = MIN( NGPMIN, NGNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE - LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -*** -* Comment out this if block if EMIN is ok - IF( IWARN ) THEN - FIRST = .TRUE. - WRITE( 6, FMT = 9999 )LEMIN - END IF -*** -* -* Assume IEEE arithmetic if we found denormalised numbers above, -* or if arithmetic seems to round in the IEEE style, determined -* in routine DLAMC1. A true IEEE machine should have both things -* true; however, faulty machines may have one or the other. -* - IEEE = IEEE .OR. LIEEE1 -* -* Compute RMIN by successive division by BETA. We could compute -* RMIN as BASE**( EMIN - 1 ), but some machines underflow during -* this computation. -* - LRMIN = 1 - DO 30 I = 1, 1 - LEMIN - LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) - 30 CONTINUE -* -* Finally, call DLAMC5 to compute EMAX and RMAX. -* - CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) - END IF -* - BETA = LBETA - T = LT - RND = LRND - EPS = LEPS - EMIN = LEMIN - RMIN = LRMIN - EMAX = LEMAX - RMAX = LRMAX -* - RETURN -* - 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', - $ ' EMIN = ', I8, / - $ ' If, after inspection, the value EMIN looks', - $ ' acceptable please comment out ', - $ / ' the IF block as marked within the code of routine', - $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) -* -* End of DLAMC2 -* - END -* -************************************************************************ -* - DOUBLE PRECISION FUNCTION DLAMC3( A, B ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B -* .. -* -* Purpose -* ======= -* -* DLAMC3 is intended to force A and B to be stored prior to doing -* the addition of A and B , for use in situations where optimizers -* might hold one of these in a register. -* -* Arguments -* ========= -* -* A, B (input) DOUBLE PRECISION -* The values A and B. -* -* ===================================================================== -* -* .. Executable Statements .. -* - DLAMC3 = A + B -* - RETURN -* -* End of DLAMC3 -* - END -* -************************************************************************ -* - SUBROUTINE DLAMC4( EMIN, START, BASE ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - INTEGER BASE, EMIN - DOUBLE PRECISION START -* .. -* -* Purpose -* ======= -* -* DLAMC4 is a service routine for DLAMC2. -* -* Arguments -* ========= -* -* EMIN (output) EMIN -* The minimum exponent before (gradual) underflow, computed by -* setting A = START and dividing by BASE until the previous A -* can not be recovered. -* -* START (input) DOUBLE PRECISION -* The starting point for determining EMIN. -* -* BASE (input) INTEGER -* The base of the machine. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I - DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. Executable Statements .. -* - A = START - ONE = 1 - RBASE = ONE / BASE - ZERO = 0 - EMIN = 1 - B1 = DLAMC3( A*RBASE, ZERO ) - C1 = A - C2 = A - D1 = A - D2 = A -*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. -* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP - 10 CONTINUE - IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. - $ ( D2.EQ.A ) ) THEN - EMIN = EMIN - 1 - A = B1 - B1 = DLAMC3( A / BASE, ZERO ) - C1 = DLAMC3( B1*BASE, ZERO ) - D1 = ZERO - DO 20 I = 1, BASE - D1 = D1 + B1 - 20 CONTINUE - B2 = DLAMC3( A*RBASE, ZERO ) - C2 = DLAMC3( B2 / RBASE, ZERO ) - D2 = ZERO - DO 30 I = 1, BASE - D2 = D2 + B2 - 30 CONTINUE - GO TO 10 - END IF -*+ END WHILE -* - RETURN -* -* End of DLAMC4 -* - END -* -************************************************************************ -* - SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - LOGICAL IEEE - INTEGER BETA, EMAX, EMIN, P - DOUBLE PRECISION RMAX -* .. -* -* Purpose -* ======= -* -* DLAMC5 attempts to compute RMAX, the largest machine floating-point -* number, without overflow. It assumes that EMAX + abs(EMIN) sum -* approximately to a power of 2. It will fail on machines where this -* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, -* EMAX = 28718). It will also fail if the value supplied for EMIN is -* too large (i.e. too close to zero), probably with overflow. -* -* Arguments -* ========= -* -* BETA (input) INTEGER -* The base of floating-point arithmetic. -* -* P (input) INTEGER -* The number of base BETA digits in the mantissa of a -* floating-point value. -* -* EMIN (input) INTEGER -* The minimum exponent before (gradual) underflow. -* -* IEEE (input) LOGICAL -* A logical flag specifying whether or not the arithmetic -* system is thought to comply with the IEEE standard. -* -* EMAX (output) INTEGER -* The largest exponent before overflow -* -* RMAX (output) DOUBLE PRECISION -* The largest machine floating-point number. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP - DOUBLE PRECISION OLDY, RECBAS, Y, Z -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. -* .. Executable Statements .. -* -* First compute LEXP and UEXP, two powers of 2 that bound -* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum -* approximately to the bound that is closest to abs(EMIN). -* (EMAX is the exponent of the required number RMAX). -* - LEXP = 1 - EXBITS = 1 - 10 CONTINUE - TRY = LEXP*2 - IF( TRY.LE.( -EMIN ) ) THEN - LEXP = TRY - EXBITS = EXBITS + 1 - GO TO 10 - END IF - IF( LEXP.EQ.-EMIN ) THEN - UEXP = LEXP - ELSE - UEXP = TRY - EXBITS = EXBITS + 1 - END IF -* -* Now -LEXP is less than or equal to EMIN, and -UEXP is greater -* than or equal to EMIN. EXBITS is the number of bits needed to -* store the exponent. -* - IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN - EXPSUM = 2*LEXP - ELSE - EXPSUM = 2*UEXP - END IF -* -* EXPSUM is the exponent range, approximately equal to -* EMAX - EMIN + 1 . -* - EMAX = EXPSUM + EMIN - 1 - NBITS = 1 + EXBITS + P -* -* NBITS is the total number of bits needed to store a -* floating-point number. -* - IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN -* -* Either there are an odd number of bits used to store a -* floating-point number, which is unlikely, or some bits are -* not used in the representation of numbers, which is possible, -* (e.g. Cray machines) or the mantissa has an implicit bit, -* (e.g. IEEE machines, Dec Vax machines), which is perhaps the -* most likely. We have to assume the last alternative. -* If this is true, then we need to reduce EMAX by one because -* there must be some way of representing zero in an implicit-bit -* system. On machines like Cray, we are reducing EMAX by one -* unnecessarily. -* - EMAX = EMAX - 1 - END IF -* - IF( IEEE ) THEN -* -* Assume we are on an IEEE machine which reserves one exponent -* for infinity and NaN. -* - EMAX = EMAX - 1 - END IF -* -* Now create RMAX, the largest machine number, which should -* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . -* -* First compute 1.0 - BETA**(-P), being careful that the -* result is less than 1.0 . -* - RECBAS = ONE / BETA - Z = BETA - ONE - Y = ZERO - DO 20 I = 1, P - Z = Z*RECBAS - IF( Y.LT.ONE ) - $ OLDY = Y - Y = DLAMC3( Y, Z ) - 20 CONTINUE - IF( Y.GE.ONE ) - $ Y = OLDY -* -* Now multiply by BETA**EMAX to get RMAX. -* - DO 30 I = 1, EMAX - Y = DLAMC3( Y*BETA, ZERO ) - 30 CONTINUE -* - RMAX = Y - RETURN -* -* End of DLAMC5 -* - END diff --git a/quantum_espresso/kcp/flib/dost.f90 b/quantum_espresso/kcp/flib/dost.f90 deleted file mode 100644 index 972b5a94b..000000000 --- a/quantum_espresso/kcp/flib/dost.f90 +++ /dev/null @@ -1,72 +0,0 @@ -! -! Copyright (C) 2001-2003 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!-------------------------------------------------------------------- -subroutine dos_t (et, nspin, nbnd, nks, ntetra, tetra, e, dost) - !------------------------------------------------------------------ - ! - USE kinds, only : DP - implicit none - integer :: nspin, nbnd, nks, ntetra, tetra (4, ntetra) - - real(DP) :: et (nbnd, nks), e, dost (2) - integer :: itetra (4), nk, ns, nt, ibnd, i - - real(DP) :: etetra (4), e1, e2, e3, e4 - integer :: nspin0 - - if (nspin==4) then - nspin0=1 - else - nspin0=nspin - endif - do ns = 1, nspin0 - dost (ns) = 0.d0 - ! - ! nk is used to select k-points with up (ns=1) or down (ns=2) spin - ! - if (ns.eq.1) then - nk = 0 - else - nk = nks / 2 - endif - do nt = 1, ntetra - do ibnd = 1, nbnd - ! these are the energies at the vertexes of the nt-th tetrahedron - do i = 1, 4 - etetra (i) = et (ibnd, tetra (i, nt) + nk) - enddo - itetra (1) = 0 - call hpsort (4, etetra, itetra) - e1 = etetra (1) - e2 = etetra (2) - e3 = etetra (3) - e4 = etetra (4) - if (e.lt.e4.and.e.ge.e3) then - dost (ns) = dost (ns) + 1.d0 / ntetra * (3.0d0 * (e4 - e) **2 / & - (e4 - e1) / (e4 - e2) / (e4 - e3) ) - elseif (e.lt.e3.and.e.ge.e2) then - dost (ns) = dost (ns) + 1.d0 / ntetra / (e3 - e1) / (e4 - e1) & - * (3.0d0 * (e2 - e1) + 6.0d0 * (e-e2) - 3.0d0 * (e3 - e1 + e4 - e2) & - / (e3 - e2) / (e4 - e2) * (e-e2) **2) - elseif (e.lt.e2.and.e.gt.e1) then - dost (ns) = dost (ns) + 1.d0 / ntetra * 3.0d0 * (e-e1) **2 / & - (e2 - e1) / (e3 - e1) / (e4 - e1) - endif - enddo - - enddo - - ! add correct spin normalization : 2 for LDA, 1 for LSDA or - ! noncollinear calculations - - if ( nspin == 1 ) dost (ns) = dost (ns) * 2.d0 - - enddo - return -end subroutine dos_t diff --git a/quantum_espresso/kcp/flib/dylmr2.f90 b/quantum_espresso/kcp/flib/dylmr2.f90 deleted file mode 100644 index 31c2291b2..000000000 --- a/quantum_espresso/kcp/flib/dylmr2.f90 +++ /dev/null @@ -1,85 +0,0 @@ -! -! Copyright (C) 2001 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!----------------------------------------------------------------------- -subroutine dylmr2 (nylm, ngy, g, gg, dylm, ipol) - !----------------------------------------------------------------------- - ! - ! compute \partial Y_lm(G) \over \partial (G)_ipol - ! using simple numerical derivation (SdG) - ! The spherical harmonics are calculated in ylmr2 - ! -#include "f_defs.h" - USE kinds - implicit none - ! - ! here the I/O variables - ! - integer :: nylm, ngy, ipol - ! input: number of spherical harmonics - ! input: the number of g vectors to compute - ! input: desired polarization - real(DP) :: g (3, ngy), gg (ngy), dylm (ngy, nylm) - ! input: the coordinates of g vectors - ! input: the moduli of g vectors - ! output: the spherical harmonics derivatives - ! - ! and here the local variables - ! - integer :: ig, lm - ! counter on g vectors - ! counter on l,m component - - real(DP), parameter :: delta = 1.d-6 - real(DP), allocatable :: dg (:), dgi (:), gx (:,:), ggx (:), ylmaux (:,:) - ! dg is the finite increment for numerical derivation: - ! dg = delta |G| = delta * sqrt(gg) - ! dgi= 1 /(delta * sqrt(gg)) - ! gx = g +/- dg - ! ggx = gx^2 - ! - allocate ( gx(3,ngy), ggx(ngy), dg(ngy), dgi(ngy), ylmaux(ngy,nylm) ) - - do ig = 1, ngy - dg (ig) = delta * sqrt (gg (ig) ) - if (gg (ig) .gt.1.d-9) then - dgi (ig) = 1.d0 / dg (ig) - else - dgi (ig) = 0.d0 - endif - enddo - - call DCOPY (3 * ngy, g, 1, gx, 1) - do ig = 1, ngy - gx (ipol, ig) = g (ipol, ig) + dg (ig) - ggx (ig) = gx (1, ig) * gx (1, ig) + & - gx (2, ig) * gx (2, ig) + & - gx (3, ig) * gx (3, ig) - enddo - - call ylmr2 (nylm, ngy, gx, ggx, dylm) - do ig = 1, ngy - gx (ipol, ig) = g (ipol, ig) - dg (ig) - ggx (ig) = gx (1, ig) * gx (1, ig) + & - gx (2, ig) * gx (2, ig) + & - gx (3, ig) * gx (3, ig) - enddo - - call ylmr2 (nylm, ngy, gx, ggx, ylmaux) - - call DAXPY (ngy * nylm, - 1.d0, ylmaux, 1, dylm, 1) - do lm = 1, nylm - do ig = 1, ngy - dylm (ig, lm) = dylm (ig, lm) * 0.5d0 * dgi (ig) - enddo - enddo - - deallocate ( gx, ggx, dg, dgi, ylmaux ) - - return -end subroutine dylmr2 - diff --git a/quantum_espresso/kcp/flib/erf.f90 b/quantum_espresso/kcp/flib/erf.f90 deleted file mode 100644 index 4154ee5e0..000000000 --- a/quantum_espresso/kcp/flib/erf.f90 +++ /dev/null @@ -1,127 +0,0 @@ -! -! Copyright (C) 2002-2009 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!--------------------------------------------------------------------- -function qe_erf (x) - !--------------------------------------------------------------------- - ! - ! Error function - computed from the rational approximations of - ! W. J. Cody, Math. Comp. 22 (1969), pages 631-637. - ! - ! for abs(x) le 0.47 erf is calculated directly - ! for abs(x) gt 0.47 erf is calculated via erf(x)=1-erfc(x) - ! - use kinds, only : DP - implicit none - real(DP), intent(in) :: x - real(DP) :: x2, p1 (4), q1 (4) - real(DP), external :: qe_erfc - real(DP) :: qe_erf - data p1 / 2.426679552305318E2_DP, 2.197926161829415E1_DP, & - 6.996383488619136_DP, -3.560984370181538E-2_DP / - data q1 / 2.150588758698612E2_DP, 9.116490540451490E1_DP, & - 1.508279763040779E1_DP, 1.000000000000000_DP / - ! - if (abs (x) > 6.0_DP) then - ! - ! erf(6)=1-10^(-17) cannot be distinguished from 1 - ! - qe_erf = sign (1.0_DP, x) - else - if (abs (x) <= 0.47_DP) then - x2 = x**2 - qe_erf=x *(p1 (1) + x2 * (p1 (2) + x2 * (p1 (3) + x2 * p1 (4) ) ) ) & - / (q1 (1) + x2 * (q1 (2) + x2 * (q1 (3) + x2 * q1 (4) ) ) ) - else - qe_erf = 1.0_DP - qe_erfc (x) - endif - endif - ! - return -end function qe_erf -! -!--------------------------------------------------------------------- -function qe_erfc (x) - !--------------------------------------------------------------------- - ! - ! erfc(x) = 1-erf(x) - See comments in erf - ! - use kinds, only : DP - implicit none - real(DP),intent(in) :: x - real(DP) :: qe_erfc - real(DP) :: ax, x2, xm2, p2 (8), q2 (8), p3 (5), q3 (5), pim1 - real(DP), external :: qe_erf - data p2 / 3.004592610201616E2_DP, 4.519189537118719E2_DP, & - 3.393208167343437E2_DP, 1.529892850469404E2_DP, & - 4.316222722205674E1_DP, 7.211758250883094_DP, & - 5.641955174789740E-1_DP,-1.368648573827167E-7_DP / - data q2 / 3.004592609569833E2_DP, 7.909509253278980E2_DP, & - 9.313540948506096E2_DP, 6.389802644656312E2_DP, & - 2.775854447439876E2_DP, 7.700015293522947E1_DP, & - 1.278272731962942E1_DP, 1.000000000000000_DP / - data p3 /-2.996107077035422E-3_DP,-4.947309106232507E-2_DP, & - -2.269565935396869E-1_DP,-2.786613086096478E-1_DP, & - -2.231924597341847E-2_DP / - data q3 / 1.062092305284679E-2_DP, 1.913089261078298E-1_DP, & - 1.051675107067932_DP, 1.987332018171353_DP, & - 1.000000000000000_DP / - - data pim1 / 0.56418958354775629_DP / - ! ( pim1= sqrt(1/pi) ) - ax = abs (x) - if (ax > 26.0_DP) then - ! - ! erfc(26.0)=10^(-296); erfc( 9.0)=10^(-37); - ! - qe_erfc = 0.0_DP - elseif (ax > 4.0_DP) then - x2 = x**2 - xm2 = (1.0_DP / ax) **2 - qe_erfc = (1.0_DP / ax) * exp ( - x2) * (pim1 + xm2 * (p3 (1) & - + xm2 * (p3 (2) + xm2 * (p3 (3) + xm2 * (p3 (4) + xm2 * p3 (5) & - ) ) ) ) / (q3 (1) + xm2 * (q3 (2) + xm2 * (q3 (3) + xm2 * & - (q3 (4) + xm2 * q3 (5) ) ) ) ) ) - elseif (ax > 0.47_DP) then - x2 = x**2 - qe_erfc = exp ( - x2) * (p2 (1) + ax * (p2 (2) + ax * (p2 (3) & - + ax * (p2 (4) + ax * (p2 (5) + ax * (p2 (6) + ax * (p2 (7) & - + ax * p2 (8) ) ) ) ) ) ) ) / (q2 (1) + ax * (q2 (2) + ax * & - (q2 (3) + ax * (q2 (4) + ax * (q2 (5) + ax * (q2 (6) + ax * & - (q2 (7) + ax * q2 (8) ) ) ) ) ) ) ) - else - qe_erfc = 1.0_DP - qe_erf (ax) - endif - ! - ! erf(-x)=-erf(x) => erfc(-x) = 2-erfc(x) - ! - if (x < 0.0_DP) qe_erfc = 2.0_DP - qe_erfc - ! - return -end function qe_erfc -! -!--------------------------------------------------------------------- -function gauss_freq (x) - !--------------------------------------------------------------------- - ! - ! gauss_freq(x) = (1+erf(x/sqrt(2)))/2 = erfc(-x/sqrt(2))/2 - ! - See comments in erf - ! - use kinds, only : DP - implicit none - real(DP),intent(in) :: x - real(DP) :: gauss_freq - real(DP), parameter :: c = 0.7071067811865475_DP - ! ( c= sqrt(1/2) ) - real(DP), external :: qe_erfc - ! - gauss_freq = 0.5_DP * qe_erfc ( - x * c) - ! - return -end function gauss_freq - - diff --git a/quantum_espresso/kcp/flib/flush_unit.f90 b/quantum_espresso/kcp/flib/flush_unit.f90 deleted file mode 100644 index 12596983f..000000000 --- a/quantum_espresso/kcp/flib/flush_unit.f90 +++ /dev/null @@ -1,28 +0,0 @@ -! -! Copyright (C) 2005 PWSCF-FPMD-CPV groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#if defined(__XLF) || defined(__ABSOFT) - #define flush flush_ -#endif -! -!---------------------------------------------------------------------------- -SUBROUTINE flush_unit( unit_tobeflushed ) - !---------------------------------------------------------------------------- - ! - ! ... this is a wrapper to the standard flush routine - ! - INTEGER, INTENT(IN) :: unit_tobeflushed - LOGICAL :: opnd - ! - ! - INQUIRE( UNIT = unit_tobeflushed, OPENED = opnd ) - ! - IF ( opnd ) CALL flush( unit_tobeflushed ) - ! - RETURN - ! -END SUBROUTINE diff --git a/quantum_espresso/kcp/flib/functionals.f90 b/quantum_espresso/kcp/flib/functionals.f90 deleted file mode 100644 index 5283430c7..000000000 --- a/quantum_espresso/kcp/flib/functionals.f90 +++ /dev/null @@ -1,1014 +0,0 @@ -! -! Copyright (C) 2001-2009 Quantum ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -subroutine slater (rs, ex, vx) - !----------------------------------------------------------------------- - ! Slater exchange with alpha=2/3 - ! - USE kinds - implicit none - real(DP) :: rs, ex, vx - real(DP), parameter :: f= -0.687247939924714d0, alpha = 2.0d0/3.0d0 - ! f = -9/8*(3/2pi)^(2/3) - ! - ex = f * alpha / rs - vx = 4.d0 / 3.d0 * f * alpha / rs - ! - return -end subroutine slater -! -!----------------------------------------------------------------------- -subroutine slater1(rs, ex, vx) - !----------------------------------------------------------------------- - ! Slater exchange with alpha=1, corresponding to -1.374/r_s Ry - ! used to recover old results - ! - USE kinds - implicit none - real(DP) :: rs, ex, vx - real(DP), parameter :: f= -0.687247939924714d0, alpha = 1.0d0 - ! - ex = f * alpha / rs - vx = 4.d0 / 3.d0 * f * alpha / rs - ! - return -end subroutine slater1 -! -!----------------------------------------------------------------------- -subroutine slater_rxc (rs, ex, vx) - !----------------------------------------------------------------------- - ! Slater exchange with alpha=2/3 and Relativistic exchange - ! - USE kinds - USE constants, ONLY : pi, c_au - IMPLICIT none - real (DP):: rs, ex, vx - ! - real(DP), PARAMETER :: ZERO=0.D0, ONE=1.D0, PFIVE=.5D0, & - OPF=1.5D0 !, C014=0.014D0 - real (DP):: trd, ftrd, tftm, a0, alp, z, fz, fzp, vxp, xp, & - beta, sb, alb, c014 - ! - TRD = ONE/3.d0 - FTRD = 4.d0*TRD - TFTM = 2**FTRD-2.d0 - A0 = (4.d0/(9.d0*PI))**TRD - C014= 1.0_DP/a0/c_au - - ! X-alpha parameter: - ALP = 2.d0 * TRD - - Z = ZERO - FZ = ZERO - FZP = ZERO - - VXP = -3.d0*ALP/(2.d0*PI*A0*RS) - XP = 3.d0*VXP/4.d0 - BETA = C014/RS - SB = SQRT(1.d0+BETA*BETA) - ALB = LOG(BETA+SB) - VXP = VXP * (-PFIVE + OPF * ALB / (BETA*SB)) - XP = XP * (ONE-OPF*((BETA*SB-ALB)/BETA**2)**2) - ! VXF = 2**TRD*VXP - ! EXF = 2**TRD*XP - VX = VXP - EX = XP -END SUBROUTINE slater_rxc - -! -!----------------------------------------------------------------------- - subroutine slaterKZK (rs, ex, vx, vol) - !----------------------------------------------------------------------- - ! Slater exchange with alpha=2/3, Kwee, Zhang and Krakauer KE - ! correction - ! - USE kinds - implicit none - real(DP) :: rs, ex, vx, dL, vol, ga, pi, a0 - real(DP), parameter :: a1 = -2.2037d0, & - a2 = 0.4710d0, a3 = -0.015d0, ry2h = 0.5d0 - real(DP), parameter :: f= -0.687247939924714d0, alpha = 2.0d0/3.0d0 - ! f = -9/8*(3/2pi)^(2/3) - ! - pi = 4.d0 * atan(1.d0) - a0 = f * alpha * 2.d0 - - dL = vol**(1.d0/3.d0) - ga = 0.5d0 * dL *(3.d0 /pi)**(1.d0/3.d0) - ! - if ( rs .le. ga) then - ex = a0 / rs + a1 * rs / dL**2.d0 + a2 * rs**2.d0 / dL**3.d0 - vx = (4.d0 * a0 / rs + 2.d0 * a1 * rs / dL**2.d0 + & - a2 * rs**2.d0 / dL**3.d0 ) / 3.d0 - else - ex = a0 / ga + a1 * ga / dL**2.d0 + a2 * ga**2.d0 / dL**3.d0 ! solids - vx = ex -! ex = a3 * dL**5.d0 / rs**6.d0 ! molecules -! vx = 3.d0 * ex - endif - - ex = ry2h * ex ! Ry to Hartree - vx = ry2h * vx - ! - return -end subroutine slaterKZK -! -!----------------------------------------------------------------------- -subroutine pz (rs, iflag, ec, vc) - !----------------------------------------------------------------------- - ! LDA parameterization from Monte Carlo data - ! iflag=1: J.P. Perdew and A. Zunger, PRB 23, 5048 (1981) - ! iflag=2: G. Ortiz and P. Ballone, PRB 50, 1391 (1994) - ! - USE kinds - implicit none - real(DP) :: rs, ec, vc - integer :: iflag - ! - real(DP) :: a (2), b (2), c (2), d (2), gc (2), b1 (2), b2 (2) - real(DP) :: lnrs, rs12, ox, dox - ! - data a / 0.0311d0, 0.031091d0 /, b / -0.048d0, -0.046644d0 /, & - c / 0.0020d0, 0.00419d0 /, d / -0.0116d0, -0.00983d0 / - data gc / -0.1423d0, -0.103756d0 /, b1 / 1.0529d0, 0.56371d0 /, & - b2 / 0.3334d0, 0.27358d0 / - ! - if (rs.lt.1.0d0) then - ! high density formula - lnrs = log (rs) - ec = a (iflag) * lnrs + b (iflag) + c (iflag) * rs * lnrs + d ( & - iflag) * rs - vc = a (iflag) * lnrs + (b (iflag) - a (iflag) / 3.d0) + 2.d0 / & - 3.d0 * c (iflag) * rs * lnrs + (2.d0 * d (iflag) - c (iflag) ) & - / 3.d0 * rs - else - ! interpolation formula - rs12 = sqrt (rs) - ox = 1.d0 + b1 (iflag) * rs12 + b2 (iflag) * rs - dox = 1.d0 + 7.d0 / 6.d0 * b1 (iflag) * rs12 + 4.d0 / 3.d0 * & - b2 (iflag) * rs - ec = gc (iflag) / ox - vc = ec * dox / ox - endif - ! - return -end subroutine pz -! -!----------------------------------------------------------------------- -subroutine pzKZK (rs, ec, vc, vol) - !----------------------------------------------------------------------- - ! LDA parameterization from Monte Carlo data - ! iflag=1: J.P. Perdew and A. Zunger, PRB 23, 5048 (1981) - ! iflag=2: G. Ortiz and P. Ballone, PRB 50, 1391 (1994) - ! - USE kinds - implicit none - real(DP) :: rs, ec, vc, ec0 (2), vc0(2), ec0p - integer :: iflag, kr - ! - real(DP) :: a (2), b (2), c (2), d (2), gc (2), b1 (2), b2 (2) - real(DP) :: lnrs, rs12, ox, dox, lnrsk, rsk - real(DP) :: a1, grs, g1, g2, g3, g4, dL, vol, gh, gl, grsp - real(DP) :: f3, f2, f1, f0, pi - real(DP) :: D1, D2, D3, P1, P2, ry2h - ! - data a / 0.0311d0, 0.031091d0 /, b / -0.048d0, -0.046644d0 /, & - c / 0.0020d0, 0.00419d0 /, d / -0.0116d0, -0.00983d0 / - data gc / -0.1423d0, -0.103756d0 /, b1 / 1.0529d0, 0.56371d0 /, & - b2 / 0.3334d0, 0.27358d0 / - data a1 / -2.2037 /, g1 / 0.1182 /, g2 / 1.1656 /, g3 / -5.2884 /, & - g4 / -1.1233 / - data ry2h / 0.5d0 / - ! - iflag = 1 - pi = 4.d0 * atan(1.d0) - dL = vol**(1.d0/3.d0) - gh = 0.5d0 * dL / (2.d0 * pi)**(1.d0/3.d0) - gl = dL * (3.d0 / 2.d0 / pi)**(1.d0/3.d0) - - rsk = gh - do kr = 1, 2 - lnrsk = log (rsk) - if (rsk.lt.1.0d0) then - ! high density formula - ec0(kr) = a(iflag) *lnrsk + b(iflag) + c(iflag) * rsk * lnrsk + d( & - iflag) * rsk - vc0(kr) = a(iflag) * lnrsk + (b(iflag) - a(iflag) / 3.d0) + 2.d0 / & - 3.d0 * c (iflag) * rsk * lnrsk + (2.d0 * d (iflag) - c (iflag) ) & - / 3.d0 * rsk - else - ! interpolation formula - rs12 = sqrt (rsk) - ox = 1.d0 + b1 (iflag) * rs12 + b2 (iflag) * rsk - dox = 1.d0 + 7.d0 / 6.d0 * b1 (iflag) * rs12 + 4.d0 / 3.d0 * & - b2 (iflag) * rsk - ec0(kr) = gc (iflag) / ox - vc0(kr) = ec0(kr) * dox / ox - endif - ! - grs = g1 * rsk * lnrsk + g2 * rsk + g3 * rsk**1.5d0 + g4 * rsk**2.d0 - grsp = g1 * lnrsk + g1 + g2 + 1.5d0 * g3 * rsk**0.5d0 + & - 2.d0 * g4 * rsk - ec0(kr) = ec0(kr) + (-a1 * rsk / dL**2.d0 + grs / dL**3.d0) * ry2h - vc0(kr) = vc0(kr) + (-2.d0 * a1 * rsk / dL**2.d0 / 3.d0 + & - grs / dL**3.d0 - grsp * rsk / 3.d0 / dL**3.d0) * ry2h - ! - rsk = rs - enddo - - lnrs = log (rs) - if (rs .le. gh) then - ec = ec0(2) - vc = vc0(2) - else - if ( rs .le. gl) then - ec0p = 3.d0 * (ec0(1) - vc0(1)) / gh - P1 = 3.d0 * ec0(1) - gh * ec0p - P2 = ec0p - D1 = gl - gh - D2 = gl**2.d0 - gh**2.d0 - D3 = gl**3.d0 - gh**3.d0 - f2 = 2.d0 * gl**2.d0 * P2 * D1 + D2 * P1 - f2 = f2 / (-(2.d0*gl*D1)**2.d0 + 4.d0*gl*D1*D2 - D2**2.d0 ) - f3 = - (P2 + 2.d0*D1*f2) / (3.d0 * D2) - f1 = - (P1 + D2 * f2) / (2.d0 * D1) - f0 = - gl * (gl * f2 + 2.d0 * f1) / 3.d0 - ! - ec = f3 * rs**3.d0 + f2 * rs**2.d0 + f1 * rs + f0 - vc = f2 * rs**2.d0 / 3.d0 + f1 * 2.d0 * rs / 3.d0 + f0 - else - ec = 0.d0 - vc = 0.d0 - endif - endif - ! - return -end subroutine pzKZK -! -!----------------------------------------------------------------------- -subroutine vwn (rs, ec, vc) - !----------------------------------------------------------------------- - ! S.H. Vosko, L. Wilk, and M. Nusair, Can. J. Phys. 58, 1200 (1980) - ! - USE kinds - implicit none - real(DP) :: rs, ec, vc - real(DP) :: a, b, c, x0 - parameter (a = 0.0310907d0, b = 3.72744d0, c = 12.9352d0, x0 = -0.10498d0) - real(DP) :: q, f1, f2, f3, rs12, fx, qx, tx, tt - ! - q = sqrt (4.d0 * c - b * b) - f1 = 2.d0 * b / q - f2 = b * x0 / (x0 * x0 + b * x0 + c) - f3 = 2.d0 * (2.d0 * x0 + b) / q - rs12 = sqrt (rs) - fx = rs + b * rs12 + c - qx = atan (q / (2.d0 * rs12 + b) ) - ec = a * (log (rs / fx) + f1 * qx - f2 * (log ( (rs12 - x0) **2 / & - fx) + f3 * qx) ) - tx = 2.d0 * rs12 + b - tt = tx * tx + q * q - vc = ec - rs12 * a / 6.d0 * (2.d0 / rs12 - tx / fx - 4.d0 * b / & - tt - f2 * (2.d0 / (rs12 - x0) - tx / fx - 4.d0 * (2.d0 * x0 + b) & - / tt) ) - ! - return -end subroutine vwn -!----------------------------------------------------------------------- -subroutine lyp (rs, ec, vc) - !----------------------------------------------------------------------- - ! C. Lee, W. Yang, and R.G. Parr, PRB 37, 785 (1988) - ! LDA part only - ! - USE kinds - implicit none - real(DP) :: rs, ec, vc - real(DP) :: a, b, c, d, pi43 - parameter (a = 0.04918d0, b = 0.132d0 * 2.87123400018819108d0) - ! pi43 = (4pi/3)^(1/3) - parameter (pi43 = 1.61199195401647d0, c = 0.2533d0 * pi43, d = & - 0.349d0 * pi43) - real(DP) :: ecrs, ox - ! - ecrs = b * exp ( - c * rs) - ox = 1.d0 / (1.d0 + d * rs) - ec = - a * ox * (1.d0 + ecrs) - vc = ec - rs / 3.d0 * a * ox * (d * ox + ecrs * (d * ox + c) ) - ! - return -end subroutine lyp -! -!----------------------------------------------------------------------- -subroutine pw (rs, iflag, ec, vc) - !----------------------------------------------------------------------- - ! iflag=1: J.P. Perdew and Y. Wang, PRB 45, 13244 (1992) - ! iflag=2: G. Ortiz and P. Ballone, PRB 50, 1391 (1994) - ! - USE kinds - implicit none - real(DP) :: rs, ec, vc - integer :: iflag - ! - real(DP) :: a, b1, b2, c0, c1, c2, c3, d0, d1 - parameter (a = 0.031091d0, b1 = 7.5957d0, b2 = 3.5876d0, c0 = a, & - c1 = 0.046644d0, c2 = 0.00664d0, c3 = 0.01043d0, d0 = 0.4335d0, & - d1 = 1.4408d0) - real(DP) :: lnrs, rs12, rs32, rs2, om, dom, olog - real(DP) :: a1 (2), b3 (2), b4 (2) - data a1 / 0.21370d0, 0.026481d0 /, b3 / 1.6382d0, -0.46647d0 /, & - b4 / 0.49294d0, 0.13354d0 / - ! - ! high- and low-density formulae implemented but not used in PW case - ! (reason: inconsistencies in PBE/PW91 functionals) - ! - if (rs.lt.1d0.and.iflag.eq.2) then - ! high density formula - lnrs = log (rs) - ec = c0 * lnrs - c1 + c2 * rs * lnrs - c3 * rs - vc = c0 * lnrs - (c1 + c0 / 3.d0) + 2.d0 / 3.d0 * c2 * rs * & - lnrs - (2.d0 * c3 + c2) / 3.d0 * rs - elseif (rs.gt.100.d0.and.iflag.eq.2) then - ! low density formula - ec = - d0 / rs + d1 / rs**1.5d0 - vc = - 4.d0 / 3.d0 * d0 / rs + 1.5d0 * d1 / rs**1.5d0 - else - ! interpolation formula - rs12 = sqrt (rs) - rs32 = rs * rs12 - rs2 = rs**2 - om = 2.d0 * a * (b1 * rs12 + b2 * rs + b3 (iflag) * rs32 + b4 ( & - iflag) * rs2) - dom = 2.d0 * a * (0.5d0 * b1 * rs12 + b2 * rs + 1.5d0 * b3 ( & - iflag) * rs32 + 2.d0 * b4 (iflag) * rs2) - olog = log (1.d0 + 1.0d0 / om) - ec = - 2.d0 * a * (1.d0 + a1 (iflag) * rs) * olog - vc = - 2.d0 * a * (1.d0 + 2.d0 / 3.d0 * a1 (iflag) * rs) & - * olog - 2.d0 / 3.d0 * a * (1.d0 + a1 (iflag) * rs) * dom / & - (om * (om + 1.d0) ) - endif - ! - return -end subroutine pw -! -!----------------------------------------------------------------------- -subroutine wigner (rs, ec, vc) - !----------------------------------------------------------------------- - ! Wigner correlation - ! - USE kinds - implicit none - real(DP) :: rs, ec, vc - real(DP) :: pi34, rho13 - parameter (pi34 = 0.6203504908994d0) - ! pi34=(3/4pi)^(1/3), rho13=rho^(1/3) - ! - rho13 = pi34 / rs - vc = - rho13 * ( (0.943656d0 + 8.8963d0 * rho13) / (1.d0 + & - 12.57d0 * rho13) **2) - ec = - 0.738d0 * rho13 * (0.959d0 / (1.d0 + 12.57d0 * rho13) ) - ! - return -end subroutine wigner -! -!----------------------------------------------------------------------- -subroutine hl (rs, ec, vc) - !----------------------------------------------------------------------- - ! L. Hedin and B.I. Lundqvist, J. Phys. C 4, 2064 (1971) - ! - USE kinds - implicit none - real(DP) :: rs, ec, vc - real(DP) :: a, x - ! - a = log (1.0d0 + 21.d0 / rs) - x = rs / 21.0d0 - ec = a + (x**3 * a - x * x) + x / 2.d0 - 1.0d0 / 3.0d0 - ec = - 0.0225d0 * ec - vc = - 0.0225d0 * a - ! - return -end subroutine hl -! -!----------------------------------------------------------------------- -subroutine gl (rs, ec, vc) - !----------------------------------------------------------------------- - ! O. Gunnarsson and B. I. Lundqvist, PRB 13, 4274 (1976) - ! - USE kinds - implicit none - real(DP) :: rs, vc, ec - real(DP) :: c, r, x - parameter (c = 0.0333d0, r = 11.4d0) - ! c=0.0203, r=15.9 for the paramagnetic case - ! - x = rs / r - vc = - c * log (1.d0 + 1.d0 / x) - ec = - c * ( (1.d0 + x**3) * log (1.d0 + 1.d0 / x) - 1.0d0 / & - 3.0d0 + x * (0.5d0 - x) ) - ! - return -end subroutine gl -! -!----------------------------------------------------------------------- -subroutine becke88 (rho, grho, sx, v1x, v2x) - !----------------------------------------------------------------------- - ! Becke exchange: A.D. Becke, PRA 38, 3098 (1988) - ! only gradient-corrected part, no Slater term included - ! - USE kinds - implicit none - real(DP) :: rho, grho, sx, v1x, v2x - real(DP) :: beta, third, two13 - parameter (beta = 0.0042d0) - parameter (third = 1.d0 / 3.d0, two13 = 1.259921049894873d0) - ! two13 = 2^(1/3) - real(DP) :: rho13, rho43, xs, xs2, sa2b8, shm1, dd, dd2, ee - ! - rho13 = rho**third - rho43 = rho13**4 - xs = two13 * sqrt (grho) / rho43 - xs2 = xs * xs - sa2b8 = sqrt (1.0d0 + xs2) - shm1 = log (xs + sa2b8) - dd = 1.0d0 + 6.0d0 * beta * xs * shm1 - dd2 = dd * dd - ee = 6.0d0 * beta * xs2 / sa2b8 - 1.d0 - sx = two13 * grho / rho43 * ( - beta / dd) - v1x = - (4.d0 / 3.d0) / two13 * xs2 * beta * rho13 * ee / dd2 - v2x = two13 * beta * (ee-dd) / (rho43 * dd2) - ! - return -end subroutine becke88 -! -!----------------------------------------------------------------------- -subroutine ggax (rho, grho, sx, v1x, v2x) - !----------------------------------------------------------------------- - ! Perdew-Wang GGA (PW91), exchange part: - ! J.P. Perdew et al.,PRB 46, 6671 (1992) - ! - USE kinds - implicit none - real(DP) :: rho, grho, sx, v1x, v2x - real(DP) :: f1, f2, f3, f4, f5 - parameter (f1 = 0.19645d0, f2 = 7.7956d0, f3 = 0.2743d0, f4 = & - 0.1508d0, f5 = 0.004d0) - real(DP) :: fp1, fp2 - parameter (fp1 = -0.019292021296426d0, fp2 = 0.161620459673995d0) - ! fp1 = -3/(16 pi)*(3 pi^2)^(-1/3) - ! fp2 = (1/2)(3 pi^2)**(-1/3) - real(DP) :: rhom43, s, s2, s3, s4, exps, as, sa2b8, shm1, bs, das, & - dbs, dls - ! - rhom43 = rho** ( - 4.d0 / 3.d0) - s = fp2 * sqrt (grho) * rhom43 - s2 = s * s - s3 = s2 * s - s4 = s2 * s2 - exps = f4 * exp ( - 100.d0 * s2) - as = f3 - exps - f5 * s2 - sa2b8 = sqrt (1.0d0 + f2 * f2 * s2) - shm1 = log (f2 * s + sa2b8) - bs = 1.d0 + f1 * s * shm1 + f5 * s4 - das = (200.d0 * exps - 2.d0 * f5) * s - dbs = f1 * (shm1 + f2 * s / sa2b8) + 4.d0 * f5 * s3 - dls = (das / as - dbs / bs) - sx = fp1 * grho * rhom43 * as / bs - v1x = - 4.d0 / 3.d0 * sx / rho * (1.d0 + s * dls) - v2x = fp1 * rhom43 * as / bs * (2.d0 + s * dls) - ! - return -end subroutine ggax -! -!----------------------------------------------------------------------- -subroutine perdew86 (rho, grho, sc, v1c, v2c) - !----------------------------------------------------------------------- - ! Perdew gradient correction on correlation: PRB 33, 8822 (1986) - ! - USE kinds - implicit none - real(DP) :: rho, grho, sc, v1c, v2c - real(DP) :: p1, p2, p3, p4, pc1, pc2, pci - parameter (p1 = 0.023266d0, p2 = 7.389d-6, p3 = 8.723d0, p4 = & - 0.472d0) - parameter (pc1 = 0.001667d0, pc2 = 0.002568d0, pci = pc1 + pc2) - real(DP) :: third, pi34 - parameter (third = 1.d0 / 3.d0, pi34 = 0.6203504908994d0) - ! pi34=(3/4pi)^(1/3) - real(DP) :: rho13, rho43, rs, rs2, rs3, cna, cnb, cn, drs - real(DP) :: dcna, dcnb, dcn, phi, ephi - ! - rho13 = rho**third - rho43 = rho13**4 - rs = pi34 / rho13 - rs2 = rs * rs - rs3 = rs * rs2 - cna = pc2 + p1 * rs + p2 * rs2 - cnb = 1.d0 + p3 * rs + p4 * rs2 + 1.d4 * p2 * rs3 - cn = pc1 + cna / cnb - drs = - third * pi34 / rho43 - dcna = (p1 + 2.d0 * p2 * rs) * drs - dcnb = (p3 + 2.d0 * p4 * rs + 3.d4 * p2 * rs2) * drs - dcn = dcna / cnb - cna / (cnb * cnb) * dcnb - phi = 0.192d0 * pci / cn * sqrt (grho) * rho** ( - 7.d0 / 6.d0) - ! SdG: in the original paper 1.745*0.11=0.19195 is used - ephi = exp ( - phi) - sc = grho / rho43 * cn * ephi - v1c = sc * ( (1.d0 + phi) * dcn / cn - ( (4.d0 / 3.d0) - (7.d0 / & - 6.d0) * phi) / rho) - v2c = cn * ephi / rho43 * (2.d0 - phi) - ! - return -end subroutine perdew86 -! -!----------------------------------------------------------------------- -subroutine glyp (rho, grho, sc, v1c, v2c) - !----------------------------------------------------------------------- - ! Lee Yang Parr: gradient correction part - ! - USE kinds - implicit none - real(DP) :: rho, grho, sc, v1c, v2c - real(DP) :: a, b, c, d - parameter (a = 0.04918d0, b = 0.132d0, c = 0.2533d0, d = 0.349d0) - real(DP) :: rhom13, rhom43, rhom53, om, xl, ff, dom, dxl - ! - rhom13 = rho** ( - 1.d0 / 3.d0) - om = exp ( - c * rhom13) / (1.d0 + d * rhom13) - xl = 1.d0 + (7.d0 / 3.d0) * (c * rhom13 + d * rhom13 / (1.d0 + d * & - rhom13) ) - ff = a * b * grho / 24.d0 - rhom53 = rhom13**5 - sc = ff * rhom53 * om * xl - dom = - om * (c + d+c * d * rhom13) / (1.d0 + d * rhom13) - dxl = (7.d0 / 3.d0) * (c + d+2.d0 * c * d * rhom13 + c * d * d * & - rhom13**2) / (1.d0 + d * rhom13) **2 - rhom43 = rhom13**4 - v1c = - ff * rhom43 / 3.d0 * (5.d0 * rhom43 * om * xl + rhom53 * & - dom * xl + rhom53 * om * dxl) - v2c = 2.d0 * sc / grho - ! - return -end subroutine glyp -! -!----------------------------------------------------------------------- -subroutine ggac (rho, grho, sc, v1c, v2c) - !----------------------------------------------------------------------- - ! Perdew-Wang GGA (PW91) correlation part - ! - USE kinds - implicit none - real(DP) :: rho, grho, sc, v1c, v2c - real(DP) :: al, pa, pb, pc, pd, cx, cxc0, cc0 - parameter (al = 0.09d0, pa = 0.023266d0, pb = 7.389d-6, pc = & - 8.723d0, pd = 0.472d0) - parameter (cx = -0.001667d0, cxc0 = 0.002568d0, cc0 = - cx + cxc0) - real(DP) :: third, pi34, nu, be, xkf, xks - parameter (third = 1.d0 / 3.d0, pi34 = 0.6203504908994d0) - parameter (nu = 15.755920349483144d0, be = nu * cc0) - parameter (xkf = 1.919158292677513d0, xks = 1.128379167095513d0) - ! pi34=(3/4pi)^(1/3), nu=(16/pi)*(3 pi^2)^(1/3) - ! xkf=(9 pi/4)^(1/3), xks= sqrt(4/pi) - real(DP) :: kf, ks, rs, rs2, rs3, ec, vc, t, expe, af, bf, y, xy, & - qy, s1 - real(DP) :: h0, dh0, ddh0, ee, cn, dcn, cna, dcna, cnb, dcnb, h1, & - dh1, ddh1 - ! - rs = pi34 / rho**third - rs2 = rs * rs - rs3 = rs * rs2 - call pw (rs, 1, ec, vc) - kf = xkf / rs - ks = xks * sqrt (kf) - t = sqrt (grho) / (2.d0 * ks * rho) - expe = exp ( - 2.d0 * al * ec / (be * be) ) - af = 2.d0 * al / be * (1.d0 / (expe-1.d0) ) - bf = expe * (vc - ec) - y = af * t * t - xy = (1.d0 + y) / (1.d0 + y + y * y) - qy = y * y * (2.d0 + y) / (1.d0 + y + y * y) **2 - s1 = 1.d0 + 2.d0 * al / be * t * t * xy - h0 = be * be / (2.d0 * al) * log (s1) - dh0 = be * t * t / s1 * ( - 7.d0 / 3.d0 * xy - qy * (af * bf / & - be-7.d0 / 3.d0) ) - ddh0 = be / (2.d0 * ks * ks * rho) * (xy - qy) / s1 - ee = - 100.d0 * (ks / kf * t) **2 - cna = cxc0 + pa * rs + pb * rs2 - dcna = pa * rs + 2.d0 * pb * rs2 - cnb = 1.d0 + pc * rs + pd * rs2 + 1.d4 * pb * rs3 - dcnb = pc * rs + 2.d0 * pd * rs2 + 3.d4 * pb * rs3 - cn = cna / cnb - cx - dcn = dcna / cnb - cna * dcnb / (cnb * cnb) - h1 = nu * (cn - cc0 - 3.d0 / 7.d0 * cx) * t * t * exp (ee) - dh1 = - third * (h1 * (7.d0 + 8.d0 * ee) + nu * t * t * exp (ee) & - * dcn) - ddh1 = 2.d0 * h1 * (1.d0 + ee) * rho / grho - sc = rho * (h0 + h1) - v1c = h0 + h1 + dh0 + dh1 - v2c = ddh0 + ddh1 - ! - return -end subroutine ggac -! -!--------------------------------------------------------------- -subroutine pbex (rho, grho, iflag, sx, v1x, v2x) - !--------------------------------------------------------------- - ! - ! PBE exchange (without Slater exchange): - ! iflag=1 J.P.Perdew, K.Burke, M.Ernzerhof, PRL 77, 3865 (1996) - ! iflag=2 "revised' PBE: Y. Zhang et al., PRL 80, 890 (1998) - ! iflag=3 PBEsol: J.P.Perdew et al., PRL 100, 136406 (2008) - ! - USE kinds - USE constants, ONLY : pi - implicit none - real(DP) :: rho, grho, sx, v1x, v2x - ! input: charge and squared gradient - ! output: energy - ! output: potential - integer :: iflag - ! local variables - real(DP) :: kf, agrho, s1, s2, ds, dsg, exunif, fx - ! (3*pi2*|rho|)^(1/3) - ! |grho| - ! |grho|/(2*kf*|rho|) - ! s^2 - ! n*ds/dn - ! n*ds/d(gn) - ! exchange energy LDA part - ! exchange energy gradient part - real(DP) :: dxunif, dfx, f1, f2, f3, dfx1 - ! numerical coefficients (NB: c2=(3 pi^2)^(1/3) ) - real(DP) :: third, c1, c2, c5 - parameter (third = 1.d0 / 3.d0, c1 = 0.75d0 / pi , & - c2 = 3.093667726280136d0, c5 = 4.d0 * third) - ! parameters of the functional - real(DP) :: k (3), mu(3) - data k / 0.804d0, 1.2450D0, 0.804d0 /, & - mu/ 0.21951d0, 0.21951d0, 0.12345679012345679012d0 / - ! - agrho = sqrt (grho) - kf = c2 * rho**third - dsg = 0.5d0 / kf - s1 = agrho * dsg / rho - s2 = s1 * s1 - ds = - c5 * s1 - ! - ! Energy - ! - f1 = s2 * mu(iflag) / k (iflag) - f2 = 1.d0 + f1 - f3 = k (iflag) / f2 - fx = k (iflag) - f3 - exunif = - c1 * kf - sx = exunif * fx - ! - ! Potential - ! - dxunif = exunif * third - dfx1 = f2 * f2 - dfx = 2.d0 * mu(iflag) * s1 / dfx1 - v1x = sx + dxunif * fx + exunif * dfx * ds - v2x = exunif * dfx * dsg / agrho - - sx = sx * rho - return -end subroutine pbex -! -!--------------------------------------------------------------- -subroutine pbec (rho, grho, iflag, sc, v1c, v2c) - !--------------------------------------------------------------- - ! - ! PBE correlation (without LDA part) - ! iflag=1: J.P.Perdew, K.Burke, M.Ernzerhof, PRL 77, 3865 (1996). - ! iflag=2: J.P.Perdew et al., PRL 100, 136406 (2008). - ! - USE kinds - implicit none - integer, intent(in) :: iflag - real(DP) :: rho, grho, sc, v1c, v2c - real(DP) :: ga, be (2) - parameter (ga = 0.031091d0) - data be / 0.066725d0, 0.046d0 / - real(DP) :: third, pi34, xkf, xks - parameter (third = 1.d0 / 3.d0, pi34 = 0.6203504908994d0) - parameter (xkf = 1.919158292677513d0, xks = 1.128379167095513d0) - ! pi34=(3/4pi)^(1/3), xkf=(9 pi/4)^(1/3), xks= sqrt(4/pi) - real(DP) :: kf, ks, rs, ec, vc, t, expe, af, bf, y, xy, qy - real(DP) :: s1, h0, dh0, ddh0 - ! - rs = pi34 / rho**third - call pw (rs, 1, ec, vc) - kf = xkf / rs - ks = xks * sqrt (kf) - t = sqrt (grho) / (2.d0 * ks * rho) - expe = exp ( - ec / ga) - af = be(iflag) / ga * (1.d0 / (expe-1.d0) ) - bf = expe * (vc - ec) - y = af * t * t - xy = (1.d0 + y) / (1.d0 + y + y * y) - qy = y * y * (2.d0 + y) / (1.d0 + y + y * y) **2 - s1 = 1.d0 + be(iflag) / ga * t * t * xy - h0 = ga * log (s1) - dh0 = be(iflag) * t * t / s1 * ( - 7.d0 / 3.d0 * xy - qy * (af * bf / & - be(iflag)-7.d0 / 3.d0) ) - ddh0 = be(iflag) / (2.d0 * ks * ks * rho) * (xy - qy) / s1 - sc = rho * h0 - v1c = h0 + dh0 - v2c = ddh0 - ! - return -end subroutine pbec - -! ================================================================== -subroutine hcth(rho,grho,sx,v1x,v2x) - ! ================================================================== - ! HCTH/120, JCP 109, p. 6264 (1998) - ! Parameters set-up after N.L. Doltsisnis & M. Sprik (1999) - ! Present release: Mauro Boero, Tsukuba, 11/05/2004 - !-------------------------------------------------------------------------- - ! rhoa = rhob = 0.5 * rho - ! grho is the SQUARE of the gradient of rho! --> gr=sqrt(grho) - ! sx : total exchange correlation energy at point r - ! v1x : d(sx)/drho (eq. dfdra = dfdrb in original) - ! v2x : 1/gr*d(sx)/d(gr) (eq. 0.5 * dfdza = 0.5 * dfdzb in original) - !-------------------------------------------------------------------------- - USE kinds - USE constants, ONLY: pi - implicit none - real(DP) :: rho, grho, sx, v1x, v2x - - real(DP), parameter :: o3=1.0d0/3.0d0, o34=4.0d0/3.0d0, fr83=8.d0/3.d0 - real(DP) :: cg0(6), cg1(6), caa(6), cab(6), cx(6) - real(DP) :: r3q2, r3pi, gr, rho_o3, rho_o34, xa, xa2, ra, rab, & - dra_drho, drab_drho, g, dg, era1, dera1_dra, erab0, derab0_drab, & - ex, dex_drho, uaa, uab, ux, ffaa, ffab, dffaa_drho, dffab_drho,& - denaa, denab, denx, f83rho, bygr, gaa, gab, gx, taa, tab, txx, & - dgaa_drho, dgab_drho, dgx_drho, dgaa_dgr, dgab_dgr, dgx_dgr - ! - r3q2=2.d0**(-o3) - r3pi=(3.d0/pi)**o3 - !.....coefficients for pw correlation...................................... - cg0(1)= 0.031091d0 - cg0(2)= 0.213700d0 - cg0(3)= 7.595700d0 - cg0(4)= 3.587600d0 - cg0(5)= 1.638200d0 - cg0(6)= 0.492940d0 - cg1(1)= 0.015545d0 - cg1(2)= 0.205480d0 - cg1(3)=14.118900d0 - cg1(4)= 6.197700d0 - cg1(5)= 3.366200d0 - cg1(6)= 0.625170d0 - !......hcth-19-4..................................... - caa(1)= 0.489508d+00 - caa(2)= -0.260699d+00 - caa(3)= 0.432917d+00 - caa(4)= -0.199247d+01 - caa(5)= 0.248531d+01 - caa(6)= 0.200000d+00 - cab(1)= 0.514730d+00 - cab(2)= 0.692982d+01 - cab(3)= -0.247073d+02 - cab(4)= 0.231098d+02 - cab(5)= -0.113234d+02 - cab(6)= 0.006000d+00 - cx(1) = 0.109163d+01 - cx(2) = -0.747215d+00 - cx(3) = 0.507833d+01 - cx(4) = -0.410746d+01 - cx(5) = 0.117173d+01 - cx(6)= 0.004000d+00 - !........................................................................... - gr=DSQRT(grho) - rho_o3=rho**(o3) - rho_o34=rho**(o34) - xa=1.25992105d0*gr/rho_o34 - xa2=xa*xa - ra=0.781592642d0/rho_o3 - rab=r3q2*ra - dra_drho=-0.260530881d0/rho_o34 - drab_drho=r3q2*dra_drho - call pwcorr(ra,cg1,g,dg) - era1=g - dera1_dra=dg - call pwcorr(rab,cg0,g,dg) - erab0=g - derab0_drab=dg - ex=-0.75d0*r3pi*rho_o34 - dex_drho=-r3pi*rho_o3 - uaa=caa(6)*xa2 - uaa=uaa/(1.0d0+uaa) - uab=cab(6)*xa2 - uab=uab/(1.0d0+uab) - ux=cx(6)*xa2 - ux=ux/(1.0d0+ux) - ffaa=rho*era1 - ffab=rho*erab0-ffaa - dffaa_drho=era1+rho*dera1_dra*dra_drho - dffab_drho=erab0+rho*derab0_drab*drab_drho-dffaa_drho - ! mb-> i-loop removed - denaa=1.d0/(1.0d0+caa(6)*xa2) - denab=1.d0/(1.0d0+cab(6)*xa2) - denx =1.d0/(1.0d0+cx(6)*xa2) - f83rho=fr83/rho - bygr=2.0d0/gr - gaa=caa(1)+uaa*(caa(2)+uaa*(caa(3)+uaa*(caa(4)+uaa*caa(5)))) - gab=cab(1)+uab*(cab(2)+uab*(cab(3)+uab*(cab(4)+uab*cab(5)))) - gx=cx(1)+ux*(cx(2)+ux*(cx(3)+ux*(cx(4)+ux*cx(5)))) - taa=denaa*uaa*(caa(2)+uaa*(2.d0*caa(3)+uaa & - *(3.d0*caa(4)+uaa*4.d0*caa(5)))) - tab=denab*uab*(cab(2)+uab*(2.d0*cab(3)+uab & - *(3.d0*cab(4)+uab*4.d0*cab(5)))) - txx=denx*ux*(cx(2)+ux*(2.d0*cx(3)+ux & - *(3.d0*cx(4)+ux*4.d0*cx(5)))) - dgaa_drho=-f83rho*taa - dgab_drho=-f83rho*tab - dgx_drho=-f83rho*txx - dgaa_dgr=bygr*taa - dgab_dgr=bygr*tab - dgx_dgr=bygr*txx - ! mb - sx=ex*gx+ffaa*gaa+ffab*gab - v1x=dex_drho*gx+ex*dgx_drho & - +dffaa_drho*gaa+ffaa*dgaa_drho & - +dffab_drho*gab+ffab*dgab_drho - v2x=(ex*dgx_dgr+ffaa*dgaa_dgr+ffab*dgab_dgr)/gr - return -end subroutine hcth -!-------------------------------------------------------------------= -subroutine pwcorr(r,c,g,dg) - USE kinds - implicit none - real(DP) :: r, g, dg, c(6) - real(DP) :: r12, r32, r2, rb, drb, sb - - r12=dsqrt(r) - r32=r*r12 - r2=r*r - rb=c(3)*r12+c(4)*r+c(5)*r32+c(6)*r2 - sb=1.0d0+1.0d0/(2.0d0*c(1)*rb) - g=-2.0d0*c(1)*(1.0d0+c(2)*r)*dlog(sb) - drb=c(3)/(2.0d0*r12)+c(4)+1.5d0*c(5)*r12+2.0d0*c(6)*r - dg=(1.0d0+c(2)*r)*drb/(rb*rb*sb)-2.0d0*c(1)*c(2)*dlog(sb) - - return -end subroutine pwcorr -!----------------------------------------------------------------------------- -! ================================================================== -subroutine optx(rho,grho,sx,v1x,v2x) -! OPTX, Handy et al. JCP 116, p. 5411 (2002) and refs. therein -! Present release: Mauro Boero, Tsukuba, 10/9/2002 -!-------------------------------------------------------------------------- -! rhoa = rhob = 0.5 * rho in LDA implementation -! grho is the SQUARE of the gradient of rho! --> gr=sqrt(grho) -! sx : total exchange correlation energy at point r -! v1x : d(sx)/drho -! v2x : 1/gr*d(sx)/d(gr) -!-------------------------------------------------------------------------- - use kinds, only: DP - implicit none - real(DP) :: rho, grho, sx, v1x, v2x - - real(DP), parameter :: small=1.D-30, smal2=1.D-10 -!.......coefficients and exponents.................... - real(DP), parameter :: o43=4.0d0/3.0d0, two13=1.259921049894873D0, & - two53=3.174802103936399D0, gam=0.006D0, a1cx=0.9784571170284421D0,& - a2=1.43169D0 - real(DP) :: gr, rho43, xa, gamx2, uden, uu - !.......OPTX in compact form.......................... - if(rho <= small) then - sx=0.0D0 - v1x=0.0D0 - v2x=0.0D0 - else - gr = max(grho,SMAL2) - rho43=rho**o43 - xa=two13*DSQRT(gr)/rho43 - gamx2=gam*xa*xa - uden=1.d+00/(1.d+00+gamx2) - uu=a2*gamx2*gamx2*uden*uden - uden=rho43*uu*uden - sx=-rho43*(a1cx+uu)/two13 - v1x=o43*(sx+two53*uden)/rho - v2x=-two53*uden/gr - endif - return -end subroutine optx -! -!--------------------------------------------------------------- -subroutine wcx (rho, grho, sx, v1x, v2x) - !--------------------------------------------------------------- - ! - ! Wu-Cohen exchange (without Slater exchange): - ! Z. Wu and R. E. Cohen, PRB 73, 235116 (2006) - ! - USE kinds - USE constants, ONLY : pi - implicit none - real(DP) :: rho, grho, sx, v1x, v2x - ! input: charge and squared gradient - ! output: energy - ! output: potential - ! local variables - real(DP) :: kf, agrho, s1, s2, es2, ds, dsg, exunif, fx - ! (3*pi2*|rho|)^(1/3) - ! |grho| - ! |grho|/(2*kf*|rho|) - ! s^2 - ! n*ds/dn - ! n*ds/d(gn) - ! exchange energy LDA part - ! exchange energy gradient part - real(DP) :: dxunif, dfx, f1, f2, f3, dfx1, x1, x2, x3, & - dxds1, dxds2, dxds3 - ! numerical coefficients (NB: c2=(3 pi^2)^(1/3) ) - real(DP) :: third, c1, c2, c5, c6, teneightyone - parameter (third = 1.d0 / 3.d0, c1 = 0.75d0 / pi , & - c2 = 3.093667726280136d0, c5 = 4.d0 * third, & - teneightyone = 0.123456790123d0) - ! parameters of the functional - real(DP) :: k, mu, cwc - parameter (k = 0.804d0, mu = 0.2195149727645171d0, cwc = 0.00793746933516d0) - ! - agrho = sqrt (grho) - kf = c2 * rho**third - dsg = 0.5d0 / kf - s1 = agrho * dsg / rho - s2 = s1 * s1 - es2 = exp(-s2) - ds = - c5 * s1 - ! - ! Energy - ! - ! x = 10/81 s^2 + (mu - 10/81) s^2 e^-s^2 + ln (1 + c s^4) - x1 = teneightyone * s2 - x2 = (mu - teneightyone) * s2 * es2 - x3 = log(1.d0 + cwc * s2 * s2) - f1 = (x1 + x2 + x3) / k - f2 = 1.d0 + f1 - f3 = k / f2 - fx = k - f3 - exunif = - c1 * kf - sx = exunif * fx - ! - ! Potential - ! - dxunif = exunif * third - dfx1 = f2 * f2 - dxds1 = teneightyone - dxds2 = (mu - teneightyone) * es2 * (1.d0 - s2) - dxds3 = 2.d0 * cwc * s2 / (1.d0 + cwc * s2 *s2) - dfx = 2.d0 * s1 * (dxds1 + dxds2 + dxds3) / dfx1 - v1x = sx + dxunif * fx + exunif * dfx * ds - v2x = exunif * dfx * dsg / agrho - - sx = sx * rho - return -end subroutine wcx -! -!----------------------------------------------------------------------- -function dpz (rs, iflg) - !----------------------------------------------------------------------- - ! derivative of the correlation potential with respect to local density - ! Perdew and Zunger parameterization of the Ceperley-Alder functional - ! - use kinds, only: DP - USE constants, ONLY: pi, fpi - ! - implicit none - ! - real(DP), intent (in) :: rs - integer, intent(in) :: iflg - real(DP) :: dpz - ! - ! local variables - ! a,b,c,d,gc,b1,b2 are the parameters defining the functional - ! - real(DP), parameter :: a = 0.0311d0, b = -0.048d0, c = 0.0020d0, & - d = -0.0116d0, gc = -0.1423d0, b1 = 1.0529d0, b2 = 0.3334d0,& - a1 = 7.0d0 * b1 / 6.d0, a2 = 4.d0 * b2 / 3.d0 - real(DP) :: x, den, dmx, dmrs - ! - ! - if (iflg == 1) then - dmrs = a / rs + 2.d0 / 3.d0 * c * (log (rs) + 1.d0) + & - (2.d0 * d-c) / 3.d0 - else - x = sqrt (rs) - den = 1.d0 + x * (b1 + x * b2) - dmx = gc * ( (a1 + 2.d0 * a2 * x) * den - 2.d0 * (b1 + 2.d0 * & - b2 * x) * (1.d0 + x * (a1 + x * a2) ) ) / den**3 - dmrs = 0.5d0 * dmx / x - endif - ! - dpz = - fpi * rs**4.d0 / 9.d0 * dmrs - return - ! -end function dpz diff --git a/quantum_espresso/kcp/flib/gridsetup.f90 b/quantum_espresso/kcp/flib/gridsetup.f90 deleted file mode 100644 index 9fc978882..000000000 --- a/quantum_espresso/kcp/flib/gridsetup.f90 +++ /dev/null @@ -1,93 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -! -!----------------------------------------------------------------------- -! - -SUBROUTINE GRID2D_DIMS( grid_shape, nproc, nprow, npcol ) - ! - ! This subroutine factorizes the number of processors (NPROC) - ! into NPROW and NPCOL according to the shape - ! - ! Written by Carlo Cavazzoni - ! - IMPLICIT NONE - CHARACTER, INTENT(IN) :: grid_shape - INTEGER, INTENT(IN) :: nproc - INTEGER, INTENT(OUT) :: nprow, npcol - INTEGER :: sqrtnp, i - ! - sqrtnp = INT( SQRT( REAL( nproc ) + 0.1 ) ) - ! - IF( grid_shape == 'S' ) THEN - ! Square grid - nprow = sqrtnp - npcol = sqrtnp - ELSE - ! Rectangular grid - DO i = 1, sqrtnp + 1 - IF( MOD( nproc, i ) == 0 ) nprow = i - end do - npcol = nproc / nprow - END IF - RETURN -END SUBROUTINE - -SUBROUTINE GRID2D_COORDS( order, rank, nprow, npcol, row, col ) - ! - ! this subroutine compute the cartesian coordinetes "row" and "col" - ! of the processor whose MPI task id is "rank". - ! Note that if the rank is larger that the grid size - ! all processors whose MPI task id is greather or equal - ! than nprow * npcol are placed on the diagonal extension of the grid itself - ! - IMPLICIT NONE - CHARACTER, INTENT(IN) :: order - INTEGER, INTENT(IN) :: rank ! process index starting from 0 - INTEGER, INTENT(IN) :: nprow, npcol ! dimensions of the processor grid - INTEGER, INTENT(OUT) :: row, col - IF( rank >= 0 .AND. rank < nprow * npcol ) THEN - IF( order == 'C' .OR. order == 'c' ) THEN - ! grid in COLUMN MAJOR ORDER - row = MOD( rank, nprow ) - col = rank / nprow - ELSE - ! grid in ROW MAJOR ORDER - row = rank / npcol - col = MOD( rank, npcol ) - END IF - ELSE - row = rank - col = rank - END IF - RETURN -END SUBROUTINE - -SUBROUTINE GRID2D_RANK( order, nprow, npcol, row, col, rank ) - ! - ! this subroutine compute the processor MPI task id "rank" of the processor - ! whose cartesian coordinate are "row" and "col". - ! Note that the subroutine assume cyclic indexing ( row = nprow = 0 ) - ! - IMPLICIT NONE - CHARACTER, INTENT(IN) :: order - INTEGER, INTENT(OUT) :: rank ! process index starting from 0 - INTEGER, INTENT(IN) :: nprow, npcol ! dimensions of the processor grid - INTEGER, INTENT(IN) :: row, col - - IF( order == 'C' .OR. order == 'c' ) THEN - ! grid in COLUMN MAJOR ORDER - rank = MOD( row + nprow, nprow ) + MOD( col + npcol, npcol ) * nprow - ELSE - ! grid in ROW MAJOR ORDER - rank = MOD( col + npcol, npcol ) + MOD( row + nprow, nprow ) * npcol - END IF - ! - RETURN -END SUBROUTINE diff --git a/quantum_espresso/kcp/flib/iglocal.f90 b/quantum_espresso/kcp/flib/iglocal.f90 deleted file mode 100644 index fc0dda8c2..000000000 --- a/quantum_espresso/kcp/flib/iglocal.f90 +++ /dev/null @@ -1,55 +0,0 @@ -! -! Copyright (C) 2001-2004 Carlo Cavazzoni -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------- - - INTEGER FUNCTION ig_local( ig, ig_l2g, sortedig_l2g, ng ) -! -! This function computes the local index of the G vector whose -! global index is ig. If the G vector is not local to the current -! processor, then the function returns -1 -! - IMPLICIT NONE - INTEGER, INTENT(IN) :: ig - INTEGER, INTENT(IN) :: ng - INTEGER, INTENT(IN) :: ig_l2g( ng ), sortedig_l2g( ng ) - INTEGER :: lb, ub, i - - lb = 1 ! initialize search interval lower bound - ub = ng ! initialize search interval upper bound - - IF( ig < ig_l2g( sortedig_l2g(lb) ) .OR. ig > ig_l2g( sortedig_l2g(ub) ) )THEN - ig_local = -1 - RETURN - END IF - - BINARY_SEARCH: DO - i = lb + (ub - lb)/2 - IF( ig >= ig_l2g( sortedig_l2g(i) ) )THEN - lb = i - ELSE IF( ig < ig_l2g( sortedig_l2g(i) ) )THEN - ub = i - ELSE - lb = ub - END IF - IF( lb >= (ub-1) ) EXIT BINARY_SEARCH - END DO BINARY_SEARCH - - IF( .NOT. ( (lb==ub) .OR. (lb==(ub-1)) ) )THEN - CALL errore(' ig_local ',' algorithmic error ', 5) - END IF - IF( ig == ig_l2g( sortedig_l2g(lb) ) )THEN - ig_local = sortedig_l2g(lb) - ELSE IF( ig == ig_l2g( sortedig_l2g(ub) ) )THEN - ig_local = sortedig_l2g(ub) - ELSE - ig_local = -1 - END IF - - RETURN - END FUNCTION ig_local - diff --git a/quantum_espresso/kcp/flib/inpfile.f90 b/quantum_espresso/kcp/flib/inpfile.f90 deleted file mode 100644 index 99b755c0c..000000000 --- a/quantum_espresso/kcp/flib/inpfile.f90 +++ /dev/null @@ -1,198 +0,0 @@ -! -! Copyright (C) 2002-2005 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#if defined(__ABSOFT) -# define getenv getenv_ -# define getarg getarg_ -# define iargc iargc_ -#endif -! -!---------------------------------------------------------------------------- -SUBROUTINE input_from_file( ) - ! - ! This subroutine checks program arguments and, if input file is present, - ! attach input unit ( 5 ) to the specified file - ! - ! - IMPLICIT NONE - ! - INTEGER :: unit = 5, & - ilen, iiarg, nargs, ierr - ! do not define iargc as external: g95 does not like it - INTEGER :: iargc - CHARACTER (LEN=80) :: input_file - ! - ! ... Input from file ? - ! - nargs = iargc() - ! - DO iiarg = 1, ( nargs - 1 ) - ! - CALL getarg( iiarg, input_file ) - ! - IF ( TRIM( input_file ) == '-input' .OR. & - TRIM( input_file ) == '-inp' .OR. & - TRIM( input_file ) == '-in' ) THEN - ! - CALL getarg( ( iiarg + 1 ) , input_file ) - ! - OPEN ( UNIT = unit, FILE = input_file, FORM = 'FORMATTED', & - STATUS = 'OLD', IOSTAT = ierr ) - ! - ! TODO: return error code instead - !CALL errore( 'input_from_file', 'input file ' // TRIM( input_file ) & - ! & // ' not found' , ierr ) - ! - END IF - ! - END DO - -END SUBROUTINE input_from_file -! -!---------------------------------------------------------------------------- -! -SUBROUTINE get_file( input_file ) - ! - ! This subroutine reads, either from command line or from terminal, - ! the name of a file to be opened - ! TODO: return error code if an error occurs - ! - IMPLICIT NONE - ! - CHARACTER (LEN=*) :: input_file - ! - CHARACTER (LEN=256) :: prgname - ! do not define iargc as external: g95 does not like it - INTEGER :: nargs, iargc - LOGICAL :: exst - ! - nargs = iargc() - CALL getarg (0,prgname) - ! - IF ( nargs == 0 ) THEN -10 PRINT '("Input file > ",$)' - READ (5,'(a)', end = 20, err=20) input_file - IF ( input_file == ' ') GO TO 10 - INQUIRE ( FILE = input_file, EXIST = exst ) - IF ( .NOT. exst) THEN - PRINT '(A,": file not found")', TRIM(input_file) - GO TO 10 - END IF - ELSE IF ( nargs == 1 ) then - CALL getarg (1,input_file) - ELSE - PRINT '(A,": too many arguments ",i4)', TRIM(prgname), nargs - END IF - RETURN -20 PRINT '(A,": reading file name ",A)', TRIM(prgname), TRIM(input_file) - ! -END SUBROUTINE get_file -! -!---------------------------------------------------------------------------- -! -SUBROUTINE get_arg_nimage( nimage ) - ! - IMPLICIT NONE - ! - INTEGER :: nimage - ! - INTEGER :: nargs, iiarg - CHARACTER(LEN=10) :: np - INTEGER :: iargc - ! - nimage = 1 - nargs = iargc() - ! - DO iiarg = 1, ( nargs - 1 ) - ! - CALL getarg( iiarg, np ) - ! - IF ( TRIM( np ) == '-nimage' .OR. TRIM( np ) == '-nimages' ) THEN - ! - CALL getarg( ( iiarg + 1 ), np ) - READ( np, * ) nimage - ! - END IF - ! - END DO - ! - RETURN -END SUBROUTINE get_arg_nimage -! -!---------------------------------------------------------------------------- -! -SUBROUTINE get_arg_ntg( ntask_groups ) - ! - IMPLICIT NONE - ! - INTEGER :: ntask_groups - ! - INTEGER :: nargs, iiarg - CHARACTER(LEN=20) :: np - INTEGER :: iargc - ! - ntask_groups = 0 - nargs = iargc() - ! - DO iiarg = 1, ( nargs - 1 ) - ! - CALL getarg( iiarg, np ) - ! - IF ( TRIM( np ) == '-ntg' .OR. TRIM( np ) == '-ntask_groups' ) THEN - ! - CALL getarg( ( iiarg + 1 ), np ) - READ( np, * ) ntask_groups - ! - END IF - ! - END DO - ! - RETURN -END SUBROUTINE get_arg_ntg -! -!---------------------------------------------------------------------------- -! -SUBROUTINE get_arg_northo( nproc_ortho ) - ! - IMPLICIT NONE - ! - INTEGER :: nproc_ortho - ! - INTEGER :: nargs, iiarg - CHARACTER(LEN=20) :: np - INTEGER :: iargc - ! - nproc_ortho = 0 - nargs = iargc() - ! - DO iiarg = 1, ( nargs - 1 ) - ! - CALL getarg( iiarg, np ) - ! - IF ( TRIM( np ) == '-nproc_ortho' .OR. TRIM( np ) == '-nproc_diag' .OR. & - TRIM( np ) == '-northo' .OR. TRIM( np ) == '-ndiag' ) THEN - ! - CALL getarg( ( iiarg + 1 ), np ) - READ( np, * ) nproc_ortho - ! - END IF - ! - END DO - ! - RETURN -END SUBROUTINE get_arg_northo - - -SUBROUTINE get_env ( variable_name, variable_value ) - ! - ! Wrapper for intrinsic getenv - all machine-dependent stuff here - ! - CHARACTER (LEN=*) :: variable_name, variable_value - ! - CALL getenv ( variable_name, variable_value) - ! -END SUBROUTINE get_env diff --git a/quantum_espresso/kcp/flib/int_to_char.f90 b/quantum_espresso/kcp/flib/int_to_char.f90 deleted file mode 100644 index d217928fc..000000000 --- a/quantum_espresso/kcp/flib/int_to_char.f90 +++ /dev/null @@ -1,53 +0,0 @@ - - !----------------------------------------------------------------------- - FUNCTION int_to_char( i ) - !----------------------------------------------------------------------- - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: i - CHARACTER (LEN=6) :: int_to_char - CHARACTER :: c - INTEGER :: n, j, nc - LOGICAL :: neg - ! - nc = 6 - ! - IF( i < 0 ) then - nc = nc - 1 - n = -i - neg = .true. - ELSE - n = i - neg = .false. - END IF - ! - j = 1 - DO WHILE( j <= nc ) - int_to_char(j:j) = CHAR( MOD( n, 10 ) + ICHAR( '0' ) ) - n = n / 10 - IF( n == 0 ) EXIT - j = j + 1 - END DO - ! - IF( j <= nc ) THEN - DO n = 1, j/2 - c = int_to_char( n : n ) - int_to_char( n : n ) = int_to_char( j-n+1 : j-n+1 ) - int_to_char( j-n+1 : j-n+1 ) = c - END DO - IF( j < nc ) int_to_char(j+1:nc) = ' ' - ELSE - int_to_char(:) = '*' - END IF - ! - IF( neg ) THEN - DO n = nc+1, 2, -1 - int_to_char(n:n) = int_to_char(n-1:n-1) - END DO - int_to_char(1:1) = '-' - END IF - ! - RETURN - ! - END FUNCTION int_to_char diff --git a/quantum_espresso/kcp/flib/invmat.f90 b/quantum_espresso/kcp/flib/invmat.f90 deleted file mode 100644 index a749652a1..000000000 --- a/quantum_espresso/kcp/flib/invmat.f90 +++ /dev/null @@ -1,50 +0,0 @@ -! -! Copyright (C) 2004 PWSCF-CP-FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -subroutine invmat (n, a, a_inv, da) - !----------------------------------------------------------------------- - ! computes the inverse "a_inv" of matrix "a", both dimensioned (n,n) - ! if the matrix is dimensioned 3x3, it also computes determinant "da" - ! matrix "a" is unchanged on output - LAPACK - ! - USE kinds - implicit none - integer :: n - real(DP), DIMENSION (n,n) :: a, a_inv - real(DP) :: da - ! - integer :: info, lda, lwork, ipiv (n) - ! info=0: inversion was successful - ! lda : leading dimension (the same as n) - ! ipiv : work space for pivoting (assumed of length lwork=n) - real(DP) :: work (n) - ! more work space - ! - lda = n - lwork=n - ! - a_inv(:,:) = a(:,:) - ! - call DGETRF (n, n, a_inv, lda, ipiv, info) - call errore ('invmat', 'error in DGETRF', abs (info) ) - call DGETRI (n, a_inv, lda, ipiv, work, lwork, info) - call errore ('invmat', 'error in DGETRI', abs (info) ) - ! - if (n == 3) then - da = a(1,1)*(a(2,2)*a(3,3)-a(2,3)*a(3,2)) + & - a(1,2)*(a(2,3)*a(3,1)-a(2,1)*a(3,3)) + & - a(1,3)*(a(2,1)*a(3,2)-a(3,1)*a(2,2)) - IF (ABS(da) < 1.d-10) CALL errore(' invmat ',' singular matrix ', 1) - else - da = 0.d0 - end if - - return -end subroutine invmat - diff --git a/quantum_espresso/kcp/flib/invmat_complex.f90 b/quantum_espresso/kcp/flib/invmat_complex.f90 deleted file mode 100644 index a27b21b1d..000000000 --- a/quantum_espresso/kcp/flib/invmat_complex.f90 +++ /dev/null @@ -1,50 +0,0 @@ -! -! Copyright (C) 2004 PWSCF-CP-FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -SUBROUTINE invmat_complex (n, a, a_inv, da) - !----------------------------------------------------------------------- - ! computes the inverse "a_inv" of a complex matrix "a", both - ! dimensioned (n,n). If the matrix is dimensioned 3x3, it also computes - ! determinant "da". Matrix "a" is unchanged on output - LAPACK - ! - USE kinds - IMPLICIT NONE - INTEGER :: n - COMPLEX (DP), DIMENSION (n,n) :: a, a_inv - COMPLEX (DP) :: da - ! - INTEGER :: info, lda, lwork, ipiv (n) - ! info=0: inversion was successful - ! lda : leading dimension (the same as n) - ! ipiv : work space for pivoting (assumed of length lwork=n) - COMPLEX (DP) :: work (n) - ! more work space - ! - lda = n - lwork=n - ! - a_inv(:,:) = a(:,:) - ! - CALL ZGETRF (n, n, a_inv, lda, ipiv, info) - CALL errore ('invmat', 'error in ZGETRF', abs (info) ) - CALL ZGETRI (n, a_inv, lda, ipiv, work, lwork, info) - CALL errore ('invmat', 'error in ZGETRI', abs (info) ) - ! - IF (n == 3) THEN - da = a(1,1)*(a(2,2)*a(3,3)-a(2,3)*a(3,2)) + & - a(1,2)*(a(2,3)*a(3,1)-a(2,1)*a(3,3)) + & - a(1,3)*(a(2,1)*a(3,2)-a(3,1)*a(2,2)) - IF (ABS(da) < 1.d-10) CALL errore(' invmat ',' singular matrix ', 1) - ELSE - da = (0.d0,0.d0) - END IF - ! - RETURN - ! -END SUBROUTINE invmat_complex diff --git a/quantum_espresso/kcp/flib/lapack_all.f b/quantum_espresso/kcp/flib/lapack_all.f deleted file mode 100644 index 0e4dbaa92..000000000 --- a/quantum_espresso/kcp/flib/lapack_all.f +++ /dev/null @@ -1,7340 +0,0 @@ -c -c This file contains LAPACK routines used in quantum-espresso -c that are part of ATLAS - from www.netlib.org -c These are: -* [S,D,C,Z]GESV -* [S,D,C,Z]GETRF -* [S,D,C,Z]GETRS -* [S,D,C,Z]GETRI -* [S,D,C,Z]TRTRI -* [S,D,C,Z]POSV -* [S,D,C,Z]POTRF -* [S,D,C,Z]POTRS -* [S,D,C,Z]POTRI -* [S,D,C,Z]LAUUM -c - SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGESV computes the solution to a real system of linear equations -* A * X = B, -* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. -* -* The LU decomposition with partial pivoting and row interchanges is -* used to factor A as -* A = P * L * U, -* where P is a permutation matrix, L is unit lower triangular, and U is -* upper triangular. The factored form of A is then used to solve the -* system of equations A * X = B. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of linear equations, i.e., the order of the -* matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the N-by-N coefficient matrix A. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (output) INTEGER array, dimension (N) -* The pivot indices that define the permutation matrix P; -* row i of the matrix was interchanged with row IPIV(i). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the N-by-NRHS matrix of right hand side matrix B. -* On exit, if INFO = 0, the N-by-NRHS solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, so the solution could not be computed. -* -* ===================================================================== -* -* .. External Subroutines .. - EXTERNAL DGETRF, DGETRS, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGESV ', -INFO ) - RETURN - END IF -* -* Compute the LU factorization of A. -* - CALL DGETRF( N, N, A, LDA, IPIV, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, - $ INFO ) - END IF - RETURN -* -* End of DGESV -* - END - SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETF2 computes an LU factorization of a general m-by-n matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, U(k,k) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, JP -* .. -* .. External Functions .. - INTEGER IDAMAX - EXTERNAL IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DGER, DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) - $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, - $ A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of DGETF2 -* - END - SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETRF computes an LU factorization of a general M-by-N matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL DGETF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGETRF -* - END - SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGETRI computes the inverse of a matrix using the LU factorization -* computed by DGETRF. -* -* This method inverts U and then computes inv(A) by solving the system -* inv(A)*L = inv(U) for inv(A). -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the factors L and U from the factorization -* A = P*L*U as computed by DGETRF. -* On exit, if INFO = 0, the inverse of the original matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO=0, then WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimal performance LWORK >= N*NB, where NB is -* the optimal blocksize returned by ILAENV. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is -* singular and its inverse could not be computed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB, - $ NBMIN, NN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRI', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, -* and the inverse is not computed. -* - CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) - IF( INFO.GT.0 ) - $ RETURN -* - NBMIN = 2 - LDWORK = N - IF( NB.GT.1 .AND. NB.LT.N ) THEN - IWS = MAX( LDWORK*NB, 1 ) - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) ) - END IF - ELSE - IWS = N - END IF -* -* Solve the equation inv(A)*L = inv(U) for inv(A). -* - IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - DO 20 J = N, 1, -1 -* -* Copy current column of L to WORK and replace with zeros. -* - DO 10 I = J + 1, N - WORK( I ) = A( I, J ) - A( I, J ) = ZERO - 10 CONTINUE -* -* Compute current column of inv(A). -* - IF( J.LT.N ) - $ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), - $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) - 20 CONTINUE - ELSE -* -* Use blocked code. -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 50 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) -* -* Copy current block column of L to WORK and replace with -* zeros. -* - DO 40 JJ = J, J + JB - 1 - DO 30 I = JJ + 1, N - WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) - A( I, JJ ) = ZERO - 30 CONTINUE - 40 CONTINUE -* -* Compute current block column of inv(A). -* - IF( J+JB.LE.N ) - $ CALL DGEMM( 'No transpose', 'No transpose', N, JB, - $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA, - $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, - $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) - 50 CONTINUE - END IF -* -* Apply column interchanges. -* - DO 60 J = N - 1, 1, -1 - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) - 60 CONTINUE -* - WORK( 1 ) = IWS - RETURN -* -* End of DGETRI -* - END - SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGETRS solves a system of linear equations -* A * X = B or A' * X = B -* with a general N-by-N matrix A using the LU factorization computed -* by DGETRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A'* X = B (Transpose) -* = 'C': A'* X = B (Conjugate transpose = Transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The factors L and U from the factorization A = P*L*U -* as computed by DGETRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLASWP, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A' * X = B. -* -* Solve U'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve L'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of DGETRS -* - END - - SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASWP performs a series of row interchanges on the matrix A. -* One row interchange is initiated for each of rows K1 through K2 of A. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the matrix of column dimension N to which the row -* interchanges will be applied. -* On exit, the permuted matrix. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* -* K1 (input) INTEGER -* The first element of IPIV for which a row interchange will -* be done. -* -* K2 (input) INTEGER -* The last element of IPIV for which a row interchange will -* be done. -* -* IPIV (input) INTEGER array, dimension (M*abs(INCX)) -* The vector of pivot indices. Only the elements in positions -* K1 through K2 of IPIV are accessed. -* IPIV(K) = L implies rows K and L are to be interchanged. -* -* INCX (input) INTEGER -* The increment between successive values of IPIV. If IPIV -* is negative, the pivots are applied in reverse order. -* -* Further Details -* =============== -* -* Modified by -* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - DOUBLE PRECISION TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) for each of rows K1 through K2. -* - IF( INCX.GT.0 ) THEN - IX0 = K1 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of DLASWP -* - END - SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DPOTF2 computes the Cholesky factorization of a real symmetric -* positive definite matrix A. -* -* The factorization has the form -* A = U' * U , if UPLO = 'U', or -* A = L * L', if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the unblocked version of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* n by n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U'*U or A = L*L'. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, the leading minor of order k is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N -* -* Compute U(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of row J. -* - IF( J.LT.N ) THEN - CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ), - $ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA ) - CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N -* -* Compute L(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ), - $ LDA ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of column J. -* - IF( J.LT.N ) THEN - CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ), - $ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 ) - CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF - GO TO 40 -* - 30 CONTINUE - INFO = J -* - 40 CONTINUE - RETURN -* -* End of DPOTF2 -* - END - SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DPOTRF computes the Cholesky factorization of a real symmetric -* positive definite matrix A. -* -* The factorization has the form -* A = U**T * U, if UPLO = 'U', or -* A = L * L**T, if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the block version of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* N-by-N upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U**T*U or A = L*L**T. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the leading minor of order i is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, JB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DPOTF2, DSYRK, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - CALL DPOTF2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code. -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, - $ A( 1, J ), LDA, ONE, A( J, J ), LDA ) - CALL DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block row. -* - CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1, - $ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ), - $ LDA, ONE, A( J, J+JB ), LDA ) - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', - $ JB, N-J-JB+1, ONE, A( J, J ), LDA, - $ A( J, J+JB ), LDA ) - END IF - 10 CONTINUE -* - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE, - $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) - CALL DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block column. -* - CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, - $ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ), - $ LDA, ONE, A( J+JB, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit', - $ N-J-JB+1, JB, ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF - 20 CONTINUE - END IF - END IF - GO TO 40 -* - 30 CONTINUE - INFO = INFO + J - 1 -* - 40 CONTINUE - RETURN -* -* End of DPOTRF -* - END - SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DPOTRS solves a system of linear equations A*X = B with a symmetric -* positive definite matrix A using the Cholesky factorization -* A = U**T*U or A = L*L**T computed by DPOTRF. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The triangular factor U or L from the Cholesky factorization -* A = U**T*U or A = L*L**T, as computed by DPOTRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Solve A*X = B where A = U'*U. -* -* Solve U'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A*X = B where A = L*L'. -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) -* -* Solve L'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) - END IF -* - RETURN -* -* End of DPOTRS -* - END - - SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DTRTI2 computes the inverse of a real upper or lower triangular -* matrix. -* -* This is the Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the matrix A is upper or lower triangular. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* DIAG (input) CHARACTER*1 -* Specifies whether or not the matrix A is unit triangular. -* = 'N': Non-unit triangular -* = 'U': Unit triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading n by n upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DTRMV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTI2', -INFO ) - RETURN - END IF -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix. -* - DO 10 J = 1, N - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF -* -* Compute elements 1:j-1 of j-th column. -* - CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, - $ A( 1, J ), 1 ) - CALL DSCAL( J-1, AJJ, A( 1, J ), 1 ) - 10 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix. -* - DO 20 J = N, 1, -1 - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF - IF( J.LT.N ) THEN -* -* Compute elements j+1:n of j-th column. -* - CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J, - $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) - CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of DTRTI2 -* - END - SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DTRTRI computes the inverse of a real upper or lower triangular -* matrix A. -* -* This is the Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': A is upper triangular; -* = 'L': A is lower triangular. -* -* DIAG (input) CHARACTER*1 -* = 'N': A is non-unit triangular; -* = 'U': A is unit triangular. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, A(i,i) is exactly zero. The triangular -* matrix is singular and its inverse can not be computed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J, JB, NB, NN -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check for singularity if non-unit. -* - IF( NOUNIT ) THEN - DO 10 INFO = 1, N - IF( A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - INFO = 0 - END IF -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix -* - DO 20 J = 1, N, NB - JB = MIN( NB, N-J+1 ) -* -* Compute rows 1:j-1 of current block column -* - CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, - $ JB, ONE, A, LDA, A( 1, J ), LDA ) - CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, - $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) - 20 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 30 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) - IF( J+JB.LE.N ) THEN -* -* Compute rows j+jb:n of current block column -* - CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, - $ A( J+JB, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) - 30 CONTINUE - END IF - END IF -* - RETURN -* -* End of DTRTRI -* - END - LOGICAL FUNCTION LSAME( CA, CB ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER CA, CB -* .. -* -* Purpose -* ======= -* -* LSAME returns .TRUE. if CA is the same letter as CB regardless of -* case. -* -* Arguments -* ========= -* -* CA (input) CHARACTER*1 -* CB (input) CHARACTER*1 -* CA and CB specify the single characters to be compared. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ICHAR -* .. -* .. Local Scalars .. - INTEGER INTA, INTB, ZCODE -* .. -* .. Executable Statements .. -* -* Test if the characters are equal -* - LSAME = CA.EQ.CB - IF( LSAME ) - $ RETURN -* -* Now test for equivalence if both characters are alphabetic. -* - ZCODE = ICHAR( 'Z' ) -* -* Use 'Z' rather than 'A' so that ASCII can be detected on Prime -* machines, on which ICHAR returns a value with bit 8 set. -* ICHAR('A') on Prime machines returns 193 which is the same as -* ICHAR('A') on an EBCDIC machine. -* - INTA = ICHAR( CA ) - INTB = ICHAR( CB ) -* - IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN -* -* ASCII is assumed - ZCODE is the ASCII code of either lower or -* upper case 'Z'. -* - IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 - IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 -* - ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN -* -* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or -* upper case 'Z'. -* - IF( INTA.GE.129 .AND. INTA.LE.137 .OR. - $ INTA.GE.145 .AND. INTA.LE.153 .OR. - $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 - IF( INTB.GE.129 .AND. INTB.LE.137 .OR. - $ INTB.GE.145 .AND. INTB.LE.153 .OR. - $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 -* - ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN -* -* ASCII is assumed, on Prime machines - ZCODE is the ASCII code -* plus 128 of either lower or upper case 'Z'. -* - IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 - IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 - END IF - LSAME = INTA.EQ.INTB -* -* RETURN -* -* End of LSAME -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER*6 SRNAME - INTEGER INFO -* .. -* -* Purpose -* ======= -* -* XERBLA is an error handler for the LAPACK routines. -* It is called by an LAPACK routine if an input parameter has an -* invalid value. A message is printed and execution stops. -* -* Installers may consider modifying the STOP statement in order to -* call system-specific exception-handling facilities. -* -* Arguments -* ========= -* -* SRNAME (input) CHARACTER*6 -* The name of the routine which called XERBLA. -* -* INFO (input) INTEGER -* The position of the invalid parameter in the parameter list -* of the calling routine. -* -* ===================================================================== -* -* .. Executable Statements .. -* - WRITE( *, FMT = 9999 )SRNAME, INFO -* - STOP -* - 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', - $ 'an illegal value' ) -* -* End of XERBLA -* - END - SUBROUTINE ZDROT( N, CX, INCX, CY, INCY, C, S ) -* -* applies a plane rotation, where the cos and sin (c and s) are real -* and the vectors cx and cy are complex. -* jack dongarra, linpack, 3/11/78. -* -* .. Scalar Arguments .. - INTEGER INCX, INCY, N - DOUBLE PRECISION C, S -* .. -* .. Array Arguments .. - COMPLEX*16 CX( * ), CY( * ) -* -* ===================================================================== -* .. -* .. Local Scalars .. - INTEGER I, IX, IY - COMPLEX*16 CTEMP -* .. -* .. Executable Statements .. -* - IF( N.LE.0 ) - $ RETURN - IF( INCX.EQ.1 .AND. INCY.EQ.1 ) - $ GO TO 20 -* -* code for unequal increments or equal increments not equal -* to 1 -* - IX = 1 - IY = 1 - IF( INCX.LT.0 ) - $ IX = ( -N+1 )*INCX + 1 - IF( INCY.LT.0 ) - $ IY = ( -N+1 )*INCY + 1 - DO 10 I = 1, N - CTEMP = C*CX( IX ) + S*CY( IY ) - CY( IY ) = C*CY( IY ) - S*CX( IX ) - CX( IX ) = CTEMP - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -* -* code for both increments equal to 1 -* - 20 CONTINUE - DO 30 I = 1, N - CTEMP = C*CX( I ) + S*CY( I ) - CY( I ) = C*CY( I ) - S*CX( I ) - CX( I ) = CTEMP - 30 CONTINUE - RETURN - END - SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZGETF2 computes an LU factorization of a general m-by-n matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the m by n matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, U(k,k) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER J, JP -* .. -* .. External Functions .. - INTEGER IZAMAX - EXTERNAL IZAMAX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + IZAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL ZSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) - $ CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), - $ LDA, A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of ZGETF2 -* - END - SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZGETRF computes an LU factorization of a general M-by-N matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the M-by-N matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGEMM, ZGETF2, ZLASWP, ZTRSM -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'ZGETRF', ' ', M, N, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL ZGETF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL ZGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of ZGETRF -* - END - - SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 A( LDA, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZGETRI computes the inverse of a matrix using the LU factorization -* computed by ZGETRF. -* -* This method inverts U and then computes inv(A) by solving the system -* inv(A)*L = inv(U) for inv(A). -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the factors L and U from the factorization -* A = P*L*U as computed by ZGETRF. -* On exit, if INFO = 0, the inverse of the original matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from ZGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO=0, then WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimal performance LWORK >= N*NB, where NB is -* the optimal blocksize returned by ILAENV. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is -* singular and its inverse could not be computed. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB, - $ NBMIN, NN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGEMM, ZGEMV, ZSWAP, ZTRSM, ZTRTRI -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NB = ILAENV( 1, 'ZGETRI', ' ', N, -1, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGETRI', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Form inv(U). If INFO > 0 from ZTRTRI, then U is singular, -* and the inverse is not computed. -* - CALL ZTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) - IF( INFO.GT.0 ) - $ RETURN -* - NBMIN = 2 - LDWORK = N - IF( NB.GT.1 .AND. NB.LT.N ) THEN - IWS = MAX( LDWORK*NB, 1 ) - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZGETRI', ' ', N, -1, -1, -1 ) ) - END IF - ELSE - IWS = N - END IF -* -* Solve the equation inv(A)*L = inv(U) for inv(A). -* - IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - DO 20 J = N, 1, -1 -* -* Copy current column of L to WORK and replace with zeros. -* - DO 10 I = J + 1, N - WORK( I ) = A( I, J ) - A( I, J ) = ZERO - 10 CONTINUE -* -* Compute current column of inv(A). -* - IF( J.LT.N ) - $ CALL ZGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), - $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) - 20 CONTINUE - ELSE -* -* Use blocked code. -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 50 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) -* -* Copy current block column of L to WORK and replace with -* zeros. -* - DO 40 JJ = J, J + JB - 1 - DO 30 I = JJ + 1, N - WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) - A( I, JJ ) = ZERO - 30 CONTINUE - 40 CONTINUE -* -* Compute current block column of inv(A). -* - IF( J+JB.LE.N ) - $ CALL ZGEMM( 'No transpose', 'No transpose', N, JB, - $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA, - $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) - CALL ZTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, - $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) - 50 CONTINUE - END IF -* -* Apply column interchanges. -* - DO 60 J = N - 1, 1, -1 - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL ZSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) - 60 CONTINUE -* - WORK( 1 ) = IWS - RETURN -* -* End of ZGETRI -* - END - SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZGETRS solves a system of linear equations -* A * X = B, A**T * X = B, or A**H * X = B -* with a general N-by-N matrix A using the LU factorization computed -* by ZGETRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A**T * X = B (Transpose) -* = 'C': A**H * X = B (Conjugate transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) COMPLEX*16 array, dimension (LDA,N) -* The factors L and U from the factorization A = P*L*U -* as computed by ZGETRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from ZGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLASWP, ZTRSM -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A**T * X = B or A**H * X = B. -* -* Solve U'*X = B, overwriting B with X. -* - CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Solve L'*X = B, overwriting B with X. -* - CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A, - $ LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of ZGETRS -* - END - - - SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZPOTF2 computes the Cholesky factorization of a complex Hermitian -* positive definite matrix A. -* -* The factorization has the form -* A = U' * U , if UPLO = 'U', or -* A = L * L', if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the unblocked version of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* Hermitian matrix A is stored. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the Hermitian matrix A. If UPLO = 'U', the leading -* n by n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U'*U or A = L*L'. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, the leading minor of order k is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL, ZGEMV, ZLACGV -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZPOTF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N -* -* Compute U(J,J) and test for non-positive-definiteness. -* - AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( 1, J ), 1, - $ A( 1, J ), 1 ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of row J. -* - IF( J.LT.N ) THEN - CALL ZLACGV( J-1, A( 1, J ), 1 ) - CALL ZGEMV( 'Transpose', J-1, N-J, -CONE, A( 1, J+1 ), - $ LDA, A( 1, J ), 1, CONE, A( J, J+1 ), LDA ) - CALL ZLACGV( J-1, A( 1, J ), 1 ) - CALL ZDSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N -* -* Compute L(J,J) and test for non-positive-definiteness. -* - AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( J, 1 ), LDA, - $ A( J, 1 ), LDA ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of column J. -* - IF( J.LT.N ) THEN - CALL ZLACGV( J-1, A( J, 1 ), LDA ) - CALL ZGEMV( 'No transpose', N-J, J-1, -CONE, A( J+1, 1 ), - $ LDA, A( J, 1 ), LDA, CONE, A( J+1, J ), 1 ) - CALL ZLACGV( J-1, A( J, 1 ), LDA ) - CALL ZDSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF - GO TO 40 -* - 30 CONTINUE - INFO = J -* - 40 CONTINUE - RETURN -* -* End of ZPOTF2 -* - END - SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZPOTRF computes the Cholesky factorization of a complex Hermitian -* positive definite matrix A. -* -* The factorization has the form -* A = U**H * U, if UPLO = 'U', or -* A = L * L**H, if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the block version of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the Hermitian matrix A. If UPLO = 'U', the leading -* N-by-N upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U**H*U or A = L*L**H. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the leading minor of order i is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - COMPLEX*16 CONE - PARAMETER ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, JB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGEMM, ZHERK, ZPOTF2, ZTRSM -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZPOTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'ZPOTRF', UPLO, N, -1, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - CALL ZPOTF2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code. -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL ZHERK( 'Upper', 'Conjugate transpose', JB, J-1, - $ -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA ) - CALL ZPOTF2( 'Upper', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block row. -* - CALL ZGEMM( 'Conjugate transpose', 'No transpose', JB, - $ N-J-JB+1, J-1, -CONE, A( 1, J ), LDA, - $ A( 1, J+JB ), LDA, CONE, A( J, J+JB ), - $ LDA ) - CALL ZTRSM( 'Left', 'Upper', 'Conjugate transpose', - $ 'Non-unit', JB, N-J-JB+1, CONE, A( J, J ), - $ LDA, A( J, J+JB ), LDA ) - END IF - 10 CONTINUE -* - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL ZHERK( 'Lower', 'No transpose', JB, J-1, -ONE, - $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) - CALL ZPOTF2( 'Lower', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block column. -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ N-J-JB+1, JB, J-1, -CONE, A( J+JB, 1 ), - $ LDA, A( J, 1 ), LDA, CONE, A( J+JB, J ), - $ LDA ) - CALL ZTRSM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Non-unit', N-J-JB+1, JB, CONE, A( J, J ), - $ LDA, A( J+JB, J ), LDA ) - END IF - 20 CONTINUE - END IF - END IF - GO TO 40 -* - 30 CONTINUE - INFO = INFO + J - 1 -* - 40 CONTINUE - RETURN -* -* End of ZPOTRF -* - END - - SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZTRTI2 computes the inverse of a complex upper or lower triangular -* matrix. -* -* This is the Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the matrix A is upper or lower triangular. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* DIAG (input) CHARACTER*1 -* Specifies whether or not the matrix A is unit triangular. -* = 'N': Non-unit triangular -* = 'U': Unit triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading n by n upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J - COMPLEX*16 AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZSCAL, ZTRMV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZTRTI2', -INFO ) - RETURN - END IF -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix. -* - DO 10 J = 1, N - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF -* -* Compute elements 1:j-1 of j-th column. -* - CALL ZTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, - $ A( 1, J ), 1 ) - CALL ZSCAL( J-1, AJJ, A( 1, J ), 1 ) - 10 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix. -* - DO 20 J = N, 1, -1 - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF - IF( J.LT.N ) THEN -* -* Compute elements j+1:n of j-th column. -* - CALL ZTRMV( 'Lower', 'No transpose', DIAG, N-J, - $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) - CALL ZSCAL( N-J, AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of ZTRTI2 -* - END - - SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZTRTRI computes the inverse of a complex upper or lower triangular -* matrix A. -* -* This is the Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': A is upper triangular; -* = 'L': A is lower triangular. -* -* DIAG (input) CHARACTER*1 -* = 'N': A is non-unit triangular; -* = 'U': A is unit triangular. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, A(i,i) is exactly zero. The triangular -* matrix is singular and its inverse can not be computed. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J, JB, NB, NN -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZTRMM, ZTRSM, ZTRTI2 -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZTRTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check for singularity if non-unit. -* - IF( NOUNIT ) THEN - DO 10 INFO = 1, N - IF( A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - INFO = 0 - END IF -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'ZTRTRI', UPLO // DIAG, N, -1, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix -* - DO 20 J = 1, N, NB - JB = MIN( NB, N-J+1 ) -* -* Compute rows 1:j-1 of current block column -* - CALL ZTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, - $ JB, ONE, A, LDA, A( 1, J ), LDA ) - CALL ZTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, - $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) -* -* Compute inverse of current diagonal block -* - CALL ZTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) - 20 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 30 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) - IF( J+JB.LE.N ) THEN -* -* Compute rows j+jb:n of current block column -* - CALL ZTRMM( 'Left', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, - $ A( J+JB, J ), LDA ) - CALL ZTRSM( 'Right', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF -* -* Compute inverse of current diagonal block -* - CALL ZTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) - 30 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZTRTRI -* - END - SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, - $ LIWORK, INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER COMPZ - INTEGER INFO, LDZ, LIWORK, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* DSTEDC computes all eigenvalues and, optionally, eigenvectors of a -* symmetric tridiagonal matrix using the divide and conquer method. -* The eigenvectors of a full or band real symmetric matrix can also be -* found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this -* matrix to tridiagonal form. -* -* This code makes very mild assumptions about floating point -* arithmetic. It will work on machines with a guard digit in -* add/subtract, or on those binary machines without guard digits -* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. -* It could conceivably fail on hexadecimal or decimal machines -* without guard digits, but we know of none. See DLAED3 for details. -* -* Arguments -* ========= -* -* COMPZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only. -* = 'I': Compute eigenvectors of tridiagonal matrix also. -* = 'V': Compute eigenvectors of original dense symmetric -* matrix also. On entry, Z contains the orthogonal -* matrix used to reduce the original matrix to -* tridiagonal form. -* -* N (input) INTEGER -* The dimension of the symmetric tridiagonal matrix. N >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the diagonal elements of the tridiagonal matrix. -* On exit, if INFO = 0, the eigenvalues in ascending order. -* -* E (input/output) DOUBLE PRECISION array, dimension (N-1) -* On entry, the subdiagonal elements of the tridiagonal matrix. -* On exit, E has been destroyed. -* -* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -* On entry, if COMPZ = 'V', then Z contains the orthogonal -* matrix used in the reduction to tridiagonal form. -* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the -* orthonormal eigenvectors of the original symmetric matrix, -* and if COMPZ = 'I', Z contains the orthonormal eigenvectors -* of the symmetric tridiagonal matrix. -* If COMPZ = 'N', then Z is not referenced. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= 1. -* If eigenvectors are desired, then LDZ >= max(1,N). -* -* WORK (workspace/output) DOUBLE PRECISION array, -* dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1. -* If COMPZ = 'V' and N > 1 then LWORK must be at least -* ( 1 + 3*N + 2*N*lg N + 3*N**2 ), -* where lg( N ) = smallest integer k such -* that 2**k >= N. -* If COMPZ = 'I' and N > 1 then LWORK must be at least -* ( 1 + 4*N + N**2 ). -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* IWORK (workspace/output) INTEGER array, dimension (LIWORK) -* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. -* -* LIWORK (input) INTEGER -* The dimension of the array IWORK. -* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. -* If COMPZ = 'V' and N > 1 then LIWORK must be at least -* ( 6 + 6*N + 5*N*lg N ). -* If COMPZ = 'I' and N > 1 then LIWORK must be at least -* ( 3 + 5*N ). -* -* If LIWORK = -1, then a workspace query is assumed; the -* routine only calculates the optimal size of the IWORK array, -* returns this value as the first entry of the IWORK array, and -* no error message related to LIWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* > 0: The algorithm failed to compute an eigenvalue while -* working on the submatrix lying in rows and columns -* INFO/(N+1) through mod(INFO,N+1). -* -* Further Details -* =============== -* -* Based on contributions by -* Jeff Rutter, Computer Science Division, University of California -* at Berkeley, USA -* Modified by Francoise Tisseur, University of Tennessee. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER DTRTRW, END, I, ICOMPZ, II, J, K, LGN, LIWMIN, - $ LWMIN, M, SMLSIZ, START, STOREZ - DOUBLE PRECISION EPS, ORGNRM, P, TINY -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANST - EXTERNAL LSAME, ILAENV, DLAMCH, DLANST -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLAED0, DLASCL, DLASET, DLASRT, - $ DSTEQR, DSTERF, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) -* - IF( LSAME( COMPZ, 'N' ) ) THEN - ICOMPZ = 0 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ICOMPZ = 2 - ELSE - ICOMPZ = -1 - END IF - IF( N.LE.1 .OR. ICOMPZ.LE.0 ) THEN - LIWMIN = 1 - LWMIN = 1 - ELSE - LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) ) - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IF( ICOMPZ.EQ.1 ) THEN - LWMIN = 1 + 3*N + 2*N*LGN + 3*N**2 - LIWMIN = 6 + 6*N + 5*N*LGN - ELSE IF( ICOMPZ.EQ.2 ) THEN - LWMIN = 1 + 4*N + N**2 - LIWMIN = 3 + 5*N - END IF - END IF - IF( ICOMPZ.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, - $ N ) ) ) THEN - INFO = -6 - ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN - INFO = -8 - ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN - INFO = -10 - END IF -* - IF( INFO.EQ.0 ) THEN - WORK( 1 ) = LWMIN - IWORK( 1 ) = LIWMIN - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSTEDC', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN - IF( N.EQ.1 ) THEN - IF( ICOMPZ.NE.0 ) - $ Z( 1, 1 ) = ONE - RETURN - END IF -* - SMLSIZ = ILAENV( 9, 'DSTEDC', ' ', 0, 0, 0, 0 ) -* -* If the following conditional clause is removed, then the routine -* will use the Divide and Conquer routine to compute only the -* eigenvalues, which requires (3N + 3N**2) real workspace and -* (2 + 5N + 2N lg(N)) integer workspace. -* Since on many architectures DSTERF is much faster than any other -* algorithm for finding eigenvalues only, it is used here -* as the default. -* -* If COMPZ = 'N', use DSTERF to compute the eigenvalues. -* - IF( ICOMPZ.EQ.0 ) THEN - CALL DSTERF( N, D, E, INFO ) - RETURN - END IF -* -* If N is smaller than the minimum divide size (SMLSIZ+1), then -* solve the problem with another solver. -* - IF( N.LE.SMLSIZ ) THEN - IF( ICOMPZ.EQ.0 ) THEN - CALL DSTERF( N, D, E, INFO ) - RETURN - ELSE IF( ICOMPZ.EQ.2 ) THEN - CALL DSTEQR( 'I', N, D, E, Z, LDZ, WORK, INFO ) - RETURN - ELSE - CALL DSTEQR( 'V', N, D, E, Z, LDZ, WORK, INFO ) - RETURN - END IF - END IF -* -* If COMPZ = 'V', the Z matrix must be stored elsewhere for later -* use. -* - IF( ICOMPZ.EQ.1 ) THEN - STOREZ = 1 + N*N - ELSE - STOREZ = 1 - END IF -* - IF( ICOMPZ.EQ.2 ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) - END IF -* -* Scale. -* - ORGNRM = DLANST( 'M', N, D, E ) - IF( ORGNRM.EQ.ZERO ) - $ RETURN -* - EPS = DLAMCH( 'Epsilon' ) -* - START = 1 -* -* while ( START <= N ) -* - 10 CONTINUE - IF( START.LE.N ) THEN -* -* Let END be the position of the next subdiagonal entry such that -* E( END ) <= TINY or END = N if no such subdiagonal exists. The -* matrix identified by the elements between START and END -* constitutes an independent sub-problem. -* - END = START - 20 CONTINUE - IF( END.LT.N ) THEN - TINY = EPS*SQRT( ABS( D( END ) ) )*SQRT( ABS( D( END+1 ) ) ) - IF( ABS( E( END ) ).GT.TINY ) THEN - END = END + 1 - GO TO 20 - END IF - END IF -* -* (Sub) Problem determined. Compute its size and solve it. -* - M = END - START + 1 - IF( M.EQ.1 ) THEN - START = END + 1 - GO TO 10 - END IF - IF( M.GT.SMLSIZ ) THEN - INFO = SMLSIZ -* -* Scale. -* - ORGNRM = DLANST( 'M', M, D( START ), E( START ) ) - CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ), - $ M-1, INFO ) -* - IF( ICOMPZ.EQ.1 ) THEN - DTRTRW = 1 - ELSE - DTRTRW = START - END IF - CALL DLAED0( ICOMPZ, N, M, D( START ), E( START ), - $ Z( DTRTRW, START ), LDZ, WORK( 1 ), N, - $ WORK( STOREZ ), IWORK, INFO ) - IF( INFO.NE.0 ) THEN - INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) + - $ MOD( INFO, ( M+1 ) ) + START - 1 - RETURN - END IF -* -* Scale back. -* - CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M, - $ INFO ) -* - ELSE - IF( ICOMPZ.EQ.1 ) THEN -* -* Since QR won't update a Z matrix which is larger than the -* length of D, we must solve the sub-problem in a workspace and -* then multiply back into Z. -* - CALL DSTEQR( 'I', M, D( START ), E( START ), WORK, M, - $ WORK( M*M+1 ), INFO ) - CALL DLACPY( 'A', N, M, Z( 1, START ), LDZ, - $ WORK( STOREZ ), N ) - CALL DGEMM( 'N', 'N', N, M, M, ONE, WORK( STOREZ ), LDZ, - $ WORK, M, ZERO, Z( 1, START ), LDZ ) - ELSE IF( ICOMPZ.EQ.2 ) THEN - CALL DSTEQR( 'I', M, D( START ), E( START ), - $ Z( START, START ), LDZ, WORK, INFO ) - ELSE - CALL DSTERF( M, D( START ), E( START ), INFO ) - END IF - IF( INFO.NE.0 ) THEN - INFO = START*( N+1 ) + END - RETURN - END IF - END IF -* - START = END + 1 - GO TO 10 - END IF -* -* endwhile -* -* If the problem split any number of times, then the eigenvalues -* will not be properly ordered. Here we permute the eigenvalues -* (and the associated eigenvectors) into ascending order. -* - IF( M.NE.N ) THEN - IF( ICOMPZ.EQ.0 ) THEN -* -* Use Quick Sort -* - CALL DLASRT( 'I', N, D, INFO ) -* - ELSE -* -* Use Selection Sort to minimize swaps of eigenvectors -* - DO 40 II = 2, N - I = II - 1 - K = I - P = D( I ) - DO 30 J = II, N - IF( D( J ).LT.P ) THEN - K = J - P = D( J ) - END IF - 30 CONTINUE - IF( K.NE.I ) THEN - D( K ) = D( I ) - D( I ) = P - CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) - END IF - 40 CONTINUE - END IF - END IF -* - WORK( 1 ) = LWMIN - IWORK( 1 ) = LIWMIN -* - RETURN -* -* End of DSTEDC -* - END - SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, - $ WORK, IWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), - $ WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLAED0 computes all eigenvalues and corresponding eigenvectors of a -* symmetric tridiagonal matrix using the divide and conquer method. -* -* Arguments -* ========= -* -* ICOMPQ (input) INTEGER -* = 0: Compute eigenvalues only. -* = 1: Compute eigenvectors of original dense symmetric matrix -* also. On entry, Q contains the orthogonal matrix used -* to reduce the original matrix to tridiagonal form. -* = 2: Compute eigenvalues and eigenvectors of tridiagonal -* matrix. -* -* QSIZ (input) INTEGER -* The dimension of the orthogonal matrix used to reduce -* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. -* -* N (input) INTEGER -* The dimension of the symmetric tridiagonal matrix. N >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the main diagonal of the tridiagonal matrix. -* On exit, its eigenvalues. -* -* E (input) DOUBLE PRECISION array, dimension (N-1) -* The off-diagonal elements of the tridiagonal matrix. -* On exit, E has been destroyed. -* -* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) -* On entry, Q must contain an N-by-N orthogonal matrix. -* If ICOMPQ = 0 Q is not referenced. -* If ICOMPQ = 1 On entry, Q is a subset of the columns of the -* orthogonal matrix used to reduce the full -* matrix to tridiagonal form corresponding to -* the subset of the full matrix which is being -* decomposed at this time. -* If ICOMPQ = 2 On entry, Q will be the identity matrix. -* On exit, Q contains the eigenvectors of the -* tridiagonal matrix. -* -* LDQ (input) INTEGER -* The leading dimension of the array Q. If eigenvectors are -* desired, then LDQ >= max(1,N). In any case, LDQ >= 1. -* -* QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N) -* Referenced only when ICOMPQ = 1. Used to store parts of -* the eigenvector matrix when the updating matrix multiplies -* take place. -* -* LDQS (input) INTEGER -* The leading dimension of the array QSTORE. If ICOMPQ = 1, -* then LDQS >= max(1,N). In any case, LDQS >= 1. -* -* WORK (workspace) DOUBLE PRECISION array, -* If ICOMPQ = 0 or 1, the dimension of WORK must be at least -* 1 + 3*N + 2*N*lg N + 2*N**2 -* ( lg( N ) = smallest integer k -* such that 2^k >= N ) -* If ICOMPQ = 2, the dimension of WORK must be at least -* 4*N + N**2. -* -* IWORK (workspace) INTEGER array, -* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least -* 6 + 6*N + 5*N*lg N. -* ( lg( N ) = smallest integer k -* such that 2^k >= N ) -* If ICOMPQ = 2, the dimension of IWORK must be at least -* 3 + 5*N. -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* > 0: The algorithm failed to compute an eigenvalue while -* working on the submatrix lying in rows and columns -* INFO/(N+1) through mod(INFO,N+1). -* -* Further Details -* =============== -* -* Based on contributions by -* Jeff Rutter, Computer Science Division, University of California -* at Berkeley, USA -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0 ) -* .. -* .. Local Scalars .. - INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM, - $ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM, - $ J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1, - $ SPM2, SUBMAT, SUBPBS, TLVLS - DOUBLE PRECISION TEMP -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLACPY, DLAED1, DLAED7, DSTEQR, - $ XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, LOG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN - INFO = -1 - ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED0', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - SMLSIZ = ILAENV( 9, 'DLAED0', ' ', 0, 0, 0, 0 ) -* -* Determine the size and placement of the submatrices, and save in -* the leading elements of IWORK. -* - IWORK( 1 ) = N - SUBPBS = 1 - TLVLS = 0 - 10 CONTINUE - IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN - DO 20 J = SUBPBS, 1, -1 - IWORK( 2*J ) = ( IWORK( J )+1 ) / 2 - IWORK( 2*J-1 ) = IWORK( J ) / 2 - 20 CONTINUE - TLVLS = TLVLS + 1 - SUBPBS = 2*SUBPBS - GO TO 10 - END IF - DO 30 J = 2, SUBPBS - IWORK( J ) = IWORK( J ) + IWORK( J-1 ) - 30 CONTINUE -* -* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 -* using rank-1 modifications (cuts). -* - SPM1 = SUBPBS - 1 - DO 40 I = 1, SPM1 - SUBMAT = IWORK( I ) + 1 - SMM1 = SUBMAT - 1 - D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) ) - D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) ) - 40 CONTINUE -* - INDXQ = 4*N + 3 - IF( ICOMPQ.NE.2 ) THEN -* -* Set up workspaces for eigenvalues only/accumulate new vectors -* routine -* - TEMP = LOG( DBLE( N ) ) / LOG( TWO ) - LGN = INT( TEMP ) - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IPRMPT = INDXQ + N + 1 - IPERM = IPRMPT + N*LGN - IQPTR = IPERM + N*LGN - IGIVPT = IQPTR + N + 2 - IGIVCL = IGIVPT + N*LGN -* - IGIVNM = 1 - IQ = IGIVNM + 2*N*LGN - IWREM = IQ + N**2 + 1 -* -* Initialize pointers -* - DO 50 I = 0, SUBPBS - IWORK( IPRMPT+I ) = 1 - IWORK( IGIVPT+I ) = 1 - 50 CONTINUE - IWORK( IQPTR ) = 1 - END IF -* -* Solve each submatrix eigenproblem at the bottom of the divide and -* conquer tree. -* - CURR = 0 - DO 70 I = 0, SPM1 - IF( I.EQ.0 ) THEN - SUBMAT = 1 - MATSIZ = IWORK( 1 ) - ELSE - SUBMAT = IWORK( I ) + 1 - MATSIZ = IWORK( I+1 ) - IWORK( I ) - END IF - IF( ICOMPQ.EQ.2 ) THEN - CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ), - $ Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO ) - IF( INFO.NE.0 ) - $ GO TO 130 - ELSE - CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ), - $ WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK, - $ INFO ) - IF( INFO.NE.0 ) - $ GO TO 130 - IF( ICOMPQ.EQ.1 ) THEN - CALL DGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE, - $ Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+ - $ CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ), - $ LDQS ) - END IF - IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2 - CURR = CURR + 1 - END IF - K = 1 - DO 60 J = SUBMAT, IWORK( I+1 ) - IWORK( INDXQ+J ) = K - K = K + 1 - 60 CONTINUE - 70 CONTINUE -* -* Successively merge eigensystems of adjacent submatrices -* into eigensystem for the corresponding larger matrix. -* -* while ( SUBPBS > 1 ) -* - CURLVL = 1 - 80 CONTINUE - IF( SUBPBS.GT.1 ) THEN - SPM2 = SUBPBS - 2 - DO 90 I = 0, SPM2, 2 - IF( I.EQ.0 ) THEN - SUBMAT = 1 - MATSIZ = IWORK( 2 ) - MSD2 = IWORK( 1 ) - CURPRB = 0 - ELSE - SUBMAT = IWORK( I ) + 1 - MATSIZ = IWORK( I+2 ) - IWORK( I ) - MSD2 = MATSIZ / 2 - CURPRB = CURPRB + 1 - END IF -* -* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) -* into an eigensystem of size MATSIZ. -* DLAED1 is used only for the full eigensystem of a tridiagonal -* matrix. -* DLAED7 handles the cases in which eigenvalues only or eigenvalues -* and eigenvectors of a full symmetric matrix (which was reduced to -* tridiagonal form) are desired. -* - IF( ICOMPQ.EQ.2 ) THEN - CALL DLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ), - $ LDQ, IWORK( INDXQ+SUBMAT ), - $ E( SUBMAT+MSD2-1 ), MSD2, WORK, - $ IWORK( SUBPBS+1 ), INFO ) - ELSE - CALL DLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB, - $ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS, - $ IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ), - $ MSD2, WORK( IQ ), IWORK( IQPTR ), - $ IWORK( IPRMPT ), IWORK( IPERM ), - $ IWORK( IGIVPT ), IWORK( IGIVCL ), - $ WORK( IGIVNM ), WORK( IWREM ), - $ IWORK( SUBPBS+1 ), INFO ) - END IF - IF( INFO.NE.0 ) - $ GO TO 130 - IWORK( I / 2+1 ) = IWORK( I+2 ) - 90 CONTINUE - SUBPBS = SUBPBS / 2 - CURLVL = CURLVL + 1 - GO TO 80 - END IF -* -* end while -* -* Re-merge the eigenvalues/vectors which were deflated at the final -* merge step. -* - IF( ICOMPQ.EQ.1 ) THEN - DO 100 I = 1, N - J = IWORK( INDXQ+I ) - WORK( I ) = D( J ) - CALL DCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 ) - 100 CONTINUE - CALL DCOPY( N, WORK, 1, D, 1 ) - ELSE IF( ICOMPQ.EQ.2 ) THEN - DO 110 I = 1, N - J = IWORK( INDXQ+I ) - WORK( I ) = D( J ) - CALL DCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 ) - 110 CONTINUE - CALL DCOPY( N, WORK, 1, D, 1 ) - CALL DLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ ) - ELSE - DO 120 I = 1, N - J = IWORK( INDXQ+I ) - WORK( I ) = D( J ) - 120 CONTINUE - CALL DCOPY( N, WORK, 1, D, 1 ) - END IF - GO TO 140 -* - 130 CONTINUE - INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1 -* - 140 CONTINUE - RETURN -* -* End of DLAED0 -* - END - SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, -* Courant Institute, NAG Ltd., and Rice University -* December 23, 1999 -* -* .. Scalar Arguments .. - INTEGER I, INFO, N - DOUBLE PRECISION DLAM, RHO -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), DELTA( * ), Z( * ) -* .. -* -* Purpose -* ======= -* -* This subroutine computes the I-th updated eigenvalue of a symmetric -* rank-one modification to a diagonal matrix whose elements are -* given in the array d, and that -* -* D(i) < D(j) for i < j -* -* and that RHO > 0. This is arranged by the calling routine, and is -* no loss in generality. The rank-one modified system is thus -* -* diag( D ) + RHO * Z * Z_transpose. -* -* where we assume the Euclidean norm of Z is 1. -* -* The method consists of approximating the rational functions in the -* secular equation by simpler interpolating rational functions. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The length of all arrays. -* -* I (input) INTEGER -* The index of the eigenvalue to be computed. 1 <= I <= N. -* -* D (input) DOUBLE PRECISION array, dimension (N) -* The original eigenvalues. It is assumed that they are in -* order, D(I) < D(J) for I < J. -* -* Z (input) DOUBLE PRECISION array, dimension (N) -* The components of the updating vector. -* -* DELTA (output) DOUBLE PRECISION array, dimension (N) -* If N .ne. 1, DELTA contains (D(j) - lambda_I) in its j-th -* component. If N = 1, then DELTA(1) = 1. The vector DELTA -* contains the information necessary to construct the -* eigenvectors. -* -* RHO (input) DOUBLE PRECISION -* The scalar in the symmetric updating formula. -* -* DLAM (output) DOUBLE PRECISION -* The computed lambda_I, the I-th updated eigenvalue. -* -* INFO (output) INTEGER -* = 0: successful exit -* > 0: if INFO = 1, the updating process failed. -* -* Internal Parameters -* =================== -* -* Logical variable ORGATI (origin-at-i?) is used for distinguishing -* whether D(i) or D(i+1) is treated as the origin. -* -* ORGATI = .true. origin at i -* ORGATI = .false. origin at i+1 -* -* Logical variable SWTCH3 (switch-for-3-poles?) is for noting -* if we are working with THREE poles! -* -* MAXIT is the maximum number of iterations allowed for each -* eigenvalue. -* -* Further Details -* =============== -* -* Based on contributions by -* Ren-Cang Li, Computer Science Division, University of California -* at Berkeley, USA -* -* ===================================================================== -* -* .. Parameters .. - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0, - $ TEN = 10.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL ORGATI, SWTCH, SWTCH3 - INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER - DOUBLE PRECISION A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW, - $ EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI, - $ RHOINV, TAU, TEMP, TEMP1, W -* .. -* .. Local Arrays .. - DOUBLE PRECISION ZZ( 3 ) -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLAED5, DLAED6 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Since this routine is called in an inner loop, we do no argument -* checking. -* -* Quick return for N=1 and 2. -* - INFO = 0 - IF( N.EQ.1 ) THEN -* -* Presumably, I=1 upon entry -* - DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 ) - DELTA( 1 ) = ONE - RETURN - END IF - IF( N.EQ.2 ) THEN - CALL DLAED5( I, D, Z, DELTA, RHO, DLAM ) - RETURN - END IF -* -* Compute machine epsilon -* - EPS = DLAMCH( 'Epsilon' ) - RHOINV = ONE / RHO -* -* The case I = N -* - IF( I.EQ.N ) THEN -* -* Initialize some basic variables -* - II = N - 1 - NITER = 1 -* -* Calculate initial guess -* - MIDPT = RHO / TWO -* -* If ||Z||_2 is not one, then TEMP should be set to -* RHO * ||Z||_2^2 / TWO -* - DO 10 J = 1, N - DELTA( J ) = ( D( J )-D( I ) ) - MIDPT - 10 CONTINUE -* - PSI = ZERO - DO 20 J = 1, N - 2 - PSI = PSI + Z( J )*Z( J ) / DELTA( J ) - 20 CONTINUE -* - C = RHOINV + PSI - W = C + Z( II )*Z( II ) / DELTA( II ) + - $ Z( N )*Z( N ) / DELTA( N ) -* - IF( W.LE.ZERO ) THEN - TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) + - $ Z( N )*Z( N ) / RHO - IF( C.LE.TEMP ) THEN - TAU = RHO - ELSE - DEL = D( N ) - D( N-1 ) - A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) - B = Z( N )*Z( N )*DEL - IF( A.LT.ZERO ) THEN - TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) - ELSE - TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) - END IF - END IF -* -* It can be proved that -* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO -* - DLTLB = MIDPT - DLTUB = RHO - ELSE - DEL = D( N ) - D( N-1 ) - A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) - B = Z( N )*Z( N )*DEL - IF( A.LT.ZERO ) THEN - TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) - ELSE - TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) - END IF -* -* It can be proved that -* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 -* - DLTLB = ZERO - DLTUB = MIDPT - END IF -* - DO 30 J = 1, N - DELTA( J ) = ( D( J )-D( I ) ) - TAU - 30 CONTINUE -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 40 J = 1, II - TEMP = Z( J ) / DELTA( J ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 40 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - TEMP = Z( N ) / DELTA( N ) - PHI = Z( N )*TEMP - DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + - $ ABS( TAU )*( DPSI+DPHI ) -* - W = RHOINV + PHI + PSI -* -* Test for convergence -* - IF( ABS( W ).LE.EPS*ERRETM ) THEN - DLAM = D( I ) + TAU - GO TO 250 - END IF -* - IF( W.LE.ZERO ) THEN - DLTLB = MAX( DLTLB, TAU ) - ELSE - DLTUB = MIN( DLTUB, TAU ) - END IF -* -* Calculate the new step -* - NITER = NITER + 1 - C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI - A = ( DELTA( N-1 )+DELTA( N ) )*W - - $ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI ) - B = DELTA( N-1 )*DELTA( N )*W - IF( C.LT.ZERO ) - $ C = ABS( C ) - IF( C.EQ.ZERO ) THEN -* ETA = B/A -* ETA = RHO - TAU - ETA = DLTUB - TAU - ELSE IF( A.GE.ZERO ) THEN - ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF -* -* Note, eta should be positive if w is negative, and -* eta should be negative otherwise. However, -* if for some reason caused by roundoff, eta*w > 0, -* we simply use one Newton step instead. This way -* will guarantee eta*w < 0. -* - IF( W*ETA.GT.ZERO ) - $ ETA = -W / ( DPSI+DPHI ) - TEMP = TAU + ETA - IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN - IF( W.LT.ZERO ) THEN - ETA = ( DLTUB-TAU ) / TWO - ELSE - ETA = ( DLTLB-TAU ) / TWO - END IF - END IF - DO 50 J = 1, N - DELTA( J ) = DELTA( J ) - ETA - 50 CONTINUE -* - TAU = TAU + ETA -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 60 J = 1, II - TEMP = Z( J ) / DELTA( J ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 60 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - TEMP = Z( N ) / DELTA( N ) - PHI = Z( N )*TEMP - DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + - $ ABS( TAU )*( DPSI+DPHI ) -* - W = RHOINV + PHI + PSI -* -* Main loop to update the values of the array DELTA -* - ITER = NITER + 1 -* - DO 90 NITER = ITER, MAXIT -* -* Test for convergence -* - IF( ABS( W ).LE.EPS*ERRETM ) THEN - DLAM = D( I ) + TAU - GO TO 250 - END IF -* - IF( W.LE.ZERO ) THEN - DLTLB = MAX( DLTLB, TAU ) - ELSE - DLTUB = MIN( DLTUB, TAU ) - END IF -* -* Calculate the new step -* - C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI - A = ( DELTA( N-1 )+DELTA( N ) )*W - - $ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI ) - B = DELTA( N-1 )*DELTA( N )*W - IF( A.GE.ZERO ) THEN - ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF -* -* Note, eta should be positive if w is negative, and -* eta should be negative otherwise. However, -* if for some reason caused by roundoff, eta*w > 0, -* we simply use one Newton step instead. This way -* will guarantee eta*w < 0. -* - IF( W*ETA.GT.ZERO ) - $ ETA = -W / ( DPSI+DPHI ) - TEMP = TAU + ETA - IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN - IF( W.LT.ZERO ) THEN - ETA = ( DLTUB-TAU ) / TWO - ELSE - ETA = ( DLTLB-TAU ) / TWO - END IF - END IF - DO 70 J = 1, N - DELTA( J ) = DELTA( J ) - ETA - 70 CONTINUE -* - TAU = TAU + ETA -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 80 J = 1, II - TEMP = Z( J ) / DELTA( J ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 80 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - TEMP = Z( N ) / DELTA( N ) - PHI = Z( N )*TEMP - DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + - $ ABS( TAU )*( DPSI+DPHI ) -* - W = RHOINV + PHI + PSI - 90 CONTINUE -* -* Return with INFO = 1, NITER = MAXIT and not converged -* - INFO = 1 - DLAM = D( I ) + TAU - GO TO 250 -* -* End for the case I = N -* - ELSE -* -* The case for I < N -* - NITER = 1 - IP1 = I + 1 -* -* Calculate initial guess -* - DEL = D( IP1 ) - D( I ) - MIDPT = DEL / TWO - DO 100 J = 1, N - DELTA( J ) = ( D( J )-D( I ) ) - MIDPT - 100 CONTINUE -* - PSI = ZERO - DO 110 J = 1, I - 1 - PSI = PSI + Z( J )*Z( J ) / DELTA( J ) - 110 CONTINUE -* - PHI = ZERO - DO 120 J = N, I + 2, -1 - PHI = PHI + Z( J )*Z( J ) / DELTA( J ) - 120 CONTINUE - C = RHOINV + PSI + PHI - W = C + Z( I )*Z( I ) / DELTA( I ) + - $ Z( IP1 )*Z( IP1 ) / DELTA( IP1 ) -* - IF( W.GT.ZERO ) THEN -* -* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2 -* -* We choose d(i) as origin. -* - ORGATI = .TRUE. - A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 ) - B = Z( I )*Z( I )*DEL - IF( A.GT.ZERO ) THEN - TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - ELSE - TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - END IF - DLTLB = ZERO - DLTUB = MIDPT - ELSE -* -* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1) -* -* We choose d(i+1) as origin. -* - ORGATI = .FALSE. - A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 ) - B = Z( IP1 )*Z( IP1 )*DEL - IF( A.LT.ZERO ) THEN - TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) ) - ELSE - TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C ) - END IF - DLTLB = -MIDPT - DLTUB = ZERO - END IF -* - IF( ORGATI ) THEN - DO 130 J = 1, N - DELTA( J ) = ( D( J )-D( I ) ) - TAU - 130 CONTINUE - ELSE - DO 140 J = 1, N - DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU - 140 CONTINUE - END IF - IF( ORGATI ) THEN - II = I - ELSE - II = I + 1 - END IF - IIM1 = II - 1 - IIP1 = II + 1 -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 150 J = 1, IIM1 - TEMP = Z( J ) / DELTA( J ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 150 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - DPHI = ZERO - PHI = ZERO - DO 160 J = N, IIP1, -1 - TEMP = Z( J ) / DELTA( J ) - PHI = PHI + Z( J )*TEMP - DPHI = DPHI + TEMP*TEMP - ERRETM = ERRETM + PHI - 160 CONTINUE -* - W = RHOINV + PHI + PSI -* -* W is the value of the secular function with -* its ii-th element removed. -* - SWTCH3 = .FALSE. - IF( ORGATI ) THEN - IF( W.LT.ZERO ) - $ SWTCH3 = .TRUE. - ELSE - IF( W.GT.ZERO ) - $ SWTCH3 = .TRUE. - END IF - IF( II.EQ.1 .OR. II.EQ.N ) - $ SWTCH3 = .FALSE. -* - TEMP = Z( II ) / DELTA( II ) - DW = DPSI + DPHI + TEMP*TEMP - TEMP = Z( II )*TEMP - W = W + TEMP - ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + - $ THREE*ABS( TEMP ) + ABS( TAU )*DW -* -* Test for convergence -* - IF( ABS( W ).LE.EPS*ERRETM ) THEN - IF( ORGATI ) THEN - DLAM = D( I ) + TAU - ELSE - DLAM = D( IP1 ) + TAU - END IF - GO TO 250 - END IF -* - IF( W.LE.ZERO ) THEN - DLTLB = MAX( DLTLB, TAU ) - ELSE - DLTUB = MIN( DLTUB, TAU ) - END IF -* -* Calculate the new step -* - NITER = NITER + 1 - IF( .NOT.SWTCH3 ) THEN - IF( ORGATI ) THEN - C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )* - $ ( Z( I ) / DELTA( I ) )**2 - ELSE - C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )* - $ ( Z( IP1 ) / DELTA( IP1 ) )**2 - END IF - A = ( DELTA( I )+DELTA( IP1 ) )*W - - $ DELTA( I )*DELTA( IP1 )*DW - B = DELTA( I )*DELTA( IP1 )*W - IF( C.EQ.ZERO ) THEN - IF( A.EQ.ZERO ) THEN - IF( ORGATI ) THEN - A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )* - $ ( DPSI+DPHI ) - ELSE - A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )* - $ ( DPSI+DPHI ) - END IF - END IF - ETA = B / A - ELSE IF( A.LE.ZERO ) THEN - ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF - ELSE -* -* Interpolation using THREE most relevant poles -* - TEMP = RHOINV + PSI + PHI - IF( ORGATI ) THEN - TEMP1 = Z( IIM1 ) / DELTA( IIM1 ) - TEMP1 = TEMP1*TEMP1 - C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) - - $ ( D( IIM1 )-D( IIP1 ) )*TEMP1 - ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) - ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )* - $ ( ( DPSI-TEMP1 )+DPHI ) - ELSE - TEMP1 = Z( IIP1 ) / DELTA( IIP1 ) - TEMP1 = TEMP1*TEMP1 - C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) - - $ ( D( IIP1 )-D( IIM1 ) )*TEMP1 - ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )* - $ ( DPSI+( DPHI-TEMP1 ) ) - ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) - END IF - ZZ( 2 ) = Z( II )*Z( II ) - CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA, - $ INFO ) - IF( INFO.NE.0 ) - $ GO TO 250 - END IF -* -* Note, eta should be positive if w is negative, and -* eta should be negative otherwise. However, -* if for some reason caused by roundoff, eta*w > 0, -* we simply use one Newton step instead. This way -* will guarantee eta*w < 0. -* - IF( W*ETA.GE.ZERO ) - $ ETA = -W / DW - TEMP = TAU + ETA - IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN - IF( W.LT.ZERO ) THEN - ETA = ( DLTUB-TAU ) / TWO - ELSE - ETA = ( DLTLB-TAU ) / TWO - END IF - END IF -* - PREW = W -* - 170 CONTINUE - DO 180 J = 1, N - DELTA( J ) = DELTA( J ) - ETA - 180 CONTINUE -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 190 J = 1, IIM1 - TEMP = Z( J ) / DELTA( J ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 190 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - DPHI = ZERO - PHI = ZERO - DO 200 J = N, IIP1, -1 - TEMP = Z( J ) / DELTA( J ) - PHI = PHI + Z( J )*TEMP - DPHI = DPHI + TEMP*TEMP - ERRETM = ERRETM + PHI - 200 CONTINUE -* - TEMP = Z( II ) / DELTA( II ) - DW = DPSI + DPHI + TEMP*TEMP - TEMP = Z( II )*TEMP - W = RHOINV + PHI + PSI + TEMP - ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + - $ THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW -* - SWTCH = .FALSE. - IF( ORGATI ) THEN - IF( -W.GT.ABS( PREW ) / TEN ) - $ SWTCH = .TRUE. - ELSE - IF( W.GT.ABS( PREW ) / TEN ) - $ SWTCH = .TRUE. - END IF -* - TAU = TAU + ETA -* -* Main loop to update the values of the array DELTA -* - ITER = NITER + 1 -* - DO 240 NITER = ITER, MAXIT -* -* Test for convergence -* - IF( ABS( W ).LE.EPS*ERRETM ) THEN - IF( ORGATI ) THEN - DLAM = D( I ) + TAU - ELSE - DLAM = D( IP1 ) + TAU - END IF - GO TO 250 - END IF -* - IF( W.LE.ZERO ) THEN - DLTLB = MAX( DLTLB, TAU ) - ELSE - DLTUB = MIN( DLTUB, TAU ) - END IF -* -* Calculate the new step -* - IF( .NOT.SWTCH3 ) THEN - IF( .NOT.SWTCH ) THEN - IF( ORGATI ) THEN - C = W - DELTA( IP1 )*DW - - $ ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2 - ELSE - C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )* - $ ( Z( IP1 ) / DELTA( IP1 ) )**2 - END IF - ELSE - TEMP = Z( II ) / DELTA( II ) - IF( ORGATI ) THEN - DPSI = DPSI + TEMP*TEMP - ELSE - DPHI = DPHI + TEMP*TEMP - END IF - C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI - END IF - A = ( DELTA( I )+DELTA( IP1 ) )*W - - $ DELTA( I )*DELTA( IP1 )*DW - B = DELTA( I )*DELTA( IP1 )*W - IF( C.EQ.ZERO ) THEN - IF( A.EQ.ZERO ) THEN - IF( .NOT.SWTCH ) THEN - IF( ORGATI ) THEN - A = Z( I )*Z( I ) + DELTA( IP1 )* - $ DELTA( IP1 )*( DPSI+DPHI ) - ELSE - A = Z( IP1 )*Z( IP1 ) + - $ DELTA( I )*DELTA( I )*( DPSI+DPHI ) - END IF - ELSE - A = DELTA( I )*DELTA( I )*DPSI + - $ DELTA( IP1 )*DELTA( IP1 )*DPHI - END IF - END IF - ETA = B / A - ELSE IF( A.LE.ZERO ) THEN - ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF - ELSE -* -* Interpolation using THREE most relevant poles -* - TEMP = RHOINV + PSI + PHI - IF( SWTCH ) THEN - C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI - ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI - ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI - ELSE - IF( ORGATI ) THEN - TEMP1 = Z( IIM1 ) / DELTA( IIM1 ) - TEMP1 = TEMP1*TEMP1 - C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) - - $ ( D( IIM1 )-D( IIP1 ) )*TEMP1 - ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) - ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )* - $ ( ( DPSI-TEMP1 )+DPHI ) - ELSE - TEMP1 = Z( IIP1 ) / DELTA( IIP1 ) - TEMP1 = TEMP1*TEMP1 - C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) - - $ ( D( IIP1 )-D( IIM1 ) )*TEMP1 - ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )* - $ ( DPSI+( DPHI-TEMP1 ) ) - ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) - END IF - END IF - CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA, - $ INFO ) - IF( INFO.NE.0 ) - $ GO TO 250 - END IF -* -* Note, eta should be positive if w is negative, and -* eta should be negative otherwise. However, -* if for some reason caused by roundoff, eta*w > 0, -* we simply use one Newton step instead. This way -* will guarantee eta*w < 0. -* - IF( W*ETA.GE.ZERO ) - $ ETA = -W / DW - TEMP = TAU + ETA - IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN - IF( W.LT.ZERO ) THEN - ETA = ( DLTUB-TAU ) / TWO - ELSE - ETA = ( DLTLB-TAU ) / TWO - END IF - END IF -* - DO 210 J = 1, N - DELTA( J ) = DELTA( J ) - ETA - 210 CONTINUE -* - TAU = TAU + ETA - PREW = W -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 220 J = 1, IIM1 - TEMP = Z( J ) / DELTA( J ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 220 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - DPHI = ZERO - PHI = ZERO - DO 230 J = N, IIP1, -1 - TEMP = Z( J ) / DELTA( J ) - PHI = PHI + Z( J )*TEMP - DPHI = DPHI + TEMP*TEMP - ERRETM = ERRETM + PHI - 230 CONTINUE -* - TEMP = Z( II ) / DELTA( II ) - DW = DPSI + DPHI + TEMP*TEMP - TEMP = Z( II )*TEMP - W = RHOINV + PHI + PSI + TEMP - ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + - $ THREE*ABS( TEMP ) + ABS( TAU )*DW - IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) - $ SWTCH = .NOT.SWTCH -* - 240 CONTINUE -* -* Return with INFO = 1, NITER = MAXIT and not converged -* - INFO = 1 - IF( ORGATI ) THEN - DLAM = D( I ) + TAU - ELSE - DLAM = D( IP1 ) + TAU - END IF -* - END IF -* - 250 CONTINUE -* - RETURN -* -* End of DLAED4 -* - END - SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, - $ INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER CUTPNT, INFO, LDQ, N - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER INDXQ( * ), IWORK( * ) - DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLAED1 computes the updated eigensystem of a diagonal -* matrix after modification by a rank-one symmetric matrix. This -* routine is used only for the eigenproblem which requires all -* eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles -* the case in which eigenvalues only or eigenvalues and eigenvectors -* of a full symmetric matrix (which was reduced to tridiagonal form) -* are desired. -* -* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) -* -* where Z = Q'u, u is a vector of length N with ones in the -* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. -* -* The eigenvectors of the original matrix are stored in Q, and the -* eigenvalues are in D. The algorithm consists of three stages: -* -* The first stage consists of deflating the size of the problem -* when there are multiple eigenvalues or if there is a zero in -* the Z vector. For each such occurence the dimension of the -* secular equation problem is reduced by one. This stage is -* performed by the routine DLAED2. -* -* The second stage consists of calculating the updated -* eigenvalues. This is done by finding the roots of the secular -* equation via the routine DLAED4 (as called by DLAED3). -* This routine also calculates the eigenvectors of the current -* problem. -* -* The final stage consists of computing the updated eigenvectors -* directly using the updated eigenvalues. The eigenvectors for -* the current problem are multiplied with the eigenvectors from -* the overall problem. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The dimension of the symmetric tridiagonal matrix. N >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the eigenvalues of the rank-1-perturbed matrix. -* On exit, the eigenvalues of the repaired matrix. -* -* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -* On entry, the eigenvectors of the rank-1-perturbed matrix. -* On exit, the eigenvectors of the repaired tridiagonal matrix. -* -* LDQ (input) INTEGER -* The leading dimension of the array Q. LDQ >= max(1,N). -* -* INDXQ (input/output) INTEGER array, dimension (N) -* On entry, the permutation which separately sorts the two -* subproblems in D into ascending order. -* On exit, the permutation which will reintegrate the -* subproblems back into sorted order, -* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order. -* -* RHO (input) DOUBLE PRECISION -* The subdiagonal entry used to create the rank-1 modification. -* -* CUTPNT (input) INTEGER -* The location of the last eigenvalue in the leading sub-matrix. -* min(1,N) <= CUTPNT <= N/2. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (4*N + N**2) -* -* IWORK (workspace) INTEGER array, dimension (4*N) -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* > 0: if INFO = 1, an eigenvalue did not converge -* -* Further Details -* =============== -* -* Based on contributions by -* Jeff Rutter, Computer Science Division, University of California -* at Berkeley, USA -* Modified by Francoise Tisseur, University of Tennessee. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS, - $ IW, IZ, K, N1, N2, ZPP1 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED1', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* The following values are integer pointers which indicate -* the portion of the workspace -* used by a particular array in DLAED2 and DLAED3. -* - IZ = 1 - IDLMDA = IZ + N - IW = IDLMDA + N - IQ2 = IW + N -* - INDX = 1 - INDXC = INDX + N - COLTYP = INDXC + N - INDXP = COLTYP + N -* -* -* Form the z-vector which consists of the last row of Q_1 and the -* first row of Q_2. -* - CALL DCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 ) - ZPP1 = CUTPNT + 1 - CALL DCOPY( N-CUTPNT, Q( ZPP1, ZPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 ) -* -* Deflate eigenvalues. -* - CALL DLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ), - $ WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ), - $ IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ), - $ IWORK( COLTYP ), INFO ) -* - IF( INFO.NE.0 ) - $ GO TO 20 -* -* Solve Secular Equation. -* - IF( K.NE.0 ) THEN - IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT + - $ ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2 - CALL DLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ), - $ WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ), - $ WORK( IW ), WORK( IS ), INFO ) - IF( INFO.NE.0 ) - $ GO TO 20 -* -* Prepare the INDXQ sorting permutation. -* - N1 = K - N2 = N - K - CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) - ELSE - DO 10 I = 1, N - INDXQ( I ) = I - 10 CONTINUE - END IF -* - 20 CONTINUE - RETURN -* -* End of DLAED1 -* - END - SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, - $ LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, - $ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, - $ INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, - $ QSIZ, TLVLS - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), - $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) - DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ), - $ QSTORE( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLAED7 computes the updated eigensystem of a diagonal -* matrix after modification by a rank-one symmetric matrix. This -* routine is used only for the eigenproblem which requires all -* eigenvalues and optionally eigenvectors of a dense symmetric matrix -* that has been reduced to tridiagonal form. DLAED1 handles -* the case in which all eigenvalues and eigenvectors of a symmetric -* tridiagonal matrix are desired. -* -* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) -* -* where Z = Q'u, u is a vector of length N with ones in the -* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. -* -* The eigenvectors of the original matrix are stored in Q, and the -* eigenvalues are in D. The algorithm consists of three stages: -* -* The first stage consists of deflating the size of the problem -* when there are multiple eigenvalues or if there is a zero in -* the Z vector. For each such occurence the dimension of the -* secular equation problem is reduced by one. This stage is -* performed by the routine DLAED8. -* -* The second stage consists of calculating the updated -* eigenvalues. This is done by finding the roots of the secular -* equation via the routine DLAED4 (as called by DLAED9). -* This routine also calculates the eigenvectors of the current -* problem. -* -* The final stage consists of computing the updated eigenvectors -* directly using the updated eigenvalues. The eigenvectors for -* the current problem are multiplied with the eigenvectors from -* the overall problem. -* -* Arguments -* ========= -* -* ICOMPQ (input) INTEGER -* = 0: Compute eigenvalues only. -* = 1: Compute eigenvectors of original dense symmetric matrix -* also. On entry, Q contains the orthogonal matrix used -* to reduce the original matrix to tridiagonal form. -* -* N (input) INTEGER -* The dimension of the symmetric tridiagonal matrix. N >= 0. -* -* QSIZ (input) INTEGER -* The dimension of the orthogonal matrix used to reduce -* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. -* -* TLVLS (input) INTEGER -* The total number of merging levels in the overall divide and -* conquer tree. -* -* CURLVL (input) INTEGER -* The current level in the overall merge routine, -* 0 <= CURLVL <= TLVLS. -* -* CURPBM (input) INTEGER -* The current problem in the current level in the overall -* merge routine (counting from upper left to lower right). -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the eigenvalues of the rank-1-perturbed matrix. -* On exit, the eigenvalues of the repaired matrix. -* -* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) -* On entry, the eigenvectors of the rank-1-perturbed matrix. -* On exit, the eigenvectors of the repaired tridiagonal matrix. -* -* LDQ (input) INTEGER -* The leading dimension of the array Q. LDQ >= max(1,N). -* -* INDXQ (output) INTEGER array, dimension (N) -* The permutation which will reintegrate the subproblem just -* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) ) -* will be in ascending order. -* -* RHO (input) DOUBLE PRECISION -* The subdiagonal element used to create the rank-1 -* modification. -* -* CUTPNT (input) INTEGER -* Contains the location of the last eigenvalue in the leading -* sub-matrix. min(1,N) <= CUTPNT <= N. -* -* QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1) -* Stores eigenvectors of submatrices encountered during -* divide and conquer, packed together. QPTR points to -* beginning of the submatrices. -* -* QPTR (input/output) INTEGER array, dimension (N+2) -* List of indices pointing to beginning of submatrices stored -* in QSTORE. The submatrices are numbered starting at the -* bottom left of the divide and conquer tree, from left to -* right and bottom to top. -* -* PRMPTR (input) INTEGER array, dimension (N lg N) -* Contains a list of pointers which indicate where in PERM a -* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) -* indicates the size of the permutation and also the size of -* the full, non-deflated problem. -* -* PERM (input) INTEGER array, dimension (N lg N) -* Contains the permutations (from deflation and sorting) to be -* applied to each eigenblock. -* -* GIVPTR (input) INTEGER array, dimension (N lg N) -* Contains a list of pointers which indicate where in GIVCOL a -* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) -* indicates the number of Givens rotations. -* -* GIVCOL (input) INTEGER array, dimension (2, N lg N) -* Each pair of numbers indicates a pair of columns to take place -* in a Givens rotation. -* -* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N) -* Each number indicates the S value to be used in the -* corresponding Givens rotation. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N) -* -* IWORK (workspace) INTEGER array, dimension (4*N) -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* > 0: if INFO = 1, an eigenvalue did not converge -* -* Further Details -* =============== -* -* Based on contributions by -* Jeff Rutter, Computer Science Division, University of California -* at Berkeley, USA -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP, - $ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DLAED8, DLAED9, DLAEDA, DLAMRG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN - INFO = -4 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED7', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* The following values are for bookkeeping purposes only. They are -* integer pointers which indicate the portion of the workspace -* used by a particular array in DLAED8 and DLAED9. -* - IF( ICOMPQ.EQ.1 ) THEN - LDQ2 = QSIZ - ELSE - LDQ2 = N - END IF -* - IZ = 1 - IDLMDA = IZ + N - IW = IDLMDA + N - IQ2 = IW + N - IS = IQ2 + N*LDQ2 -* - INDX = 1 - INDXC = INDX + N - COLTYP = INDXC + N - INDXP = COLTYP + N -* -* Form the z-vector which consists of the last row of Q_1 and the -* first row of Q_2. -* - PTR = 1 + 2**TLVLS - DO 10 I = 1, CURLVL - 1 - PTR = PTR + 2**( TLVLS-I ) - 10 CONTINUE - CURR = PTR + CURPBM - CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, - $ GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ), - $ WORK( IZ+N ), INFO ) -* -* When solving the final problem, we no longer need the stored data, -* so we will overwrite the data from this level onto the previously -* used storage space. -* - IF( CURLVL.EQ.TLVLS ) THEN - QPTR( CURR ) = 1 - PRMPTR( CURR ) = 1 - GIVPTR( CURR ) = 1 - END IF -* -* Sort and Deflate eigenvalues. -* - CALL DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT, - $ WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2, - $ WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ), - $ GIVCOL( 1, GIVPTR( CURR ) ), - $ GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ), - $ IWORK( INDX ), INFO ) - PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N - GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR ) -* -* Solve Secular Equation. -* - IF( K.NE.0 ) THEN - CALL DLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ), - $ WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( ICOMPQ.EQ.1 ) THEN - CALL DGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2, - $ QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ ) - END IF - QPTR( CURR+1 ) = QPTR( CURR ) + K**2 -* -* Prepare the INDXQ sorting permutation. -* - N1 = K - N2 = N - K - CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) - ELSE - QPTR( CURR+1 ) = QPTR( CURR ) - DO 20 I = 1, N - INDXQ( I ) = I - 20 CONTINUE - END IF -* - 30 CONTINUE - RETURN -* -* End of DLAED7 -* - END - SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, -* Courant Institute, NAG Ltd., and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER I - DOUBLE PRECISION DLAM, RHO -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 ) -* .. -* -* Purpose -* ======= -* -* This subroutine computes the I-th eigenvalue of a symmetric rank-one -* modification of a 2-by-2 diagonal matrix -* -* diag( D ) + RHO * Z * transpose(Z) . -* -* The diagonal elements in the array D are assumed to satisfy -* -* D(i) < D(j) for i < j . -* -* We also assume RHO > 0 and that the Euclidean norm of the vector -* Z is one. -* -* Arguments -* ========= -* -* I (input) INTEGER -* The index of the eigenvalue to be computed. I = 1 or I = 2. -* -* D (input) DOUBLE PRECISION array, dimension (2) -* The original eigenvalues. We assume D(1) < D(2). -* -* Z (input) DOUBLE PRECISION array, dimension (2) -* The components of the updating vector. -* -* DELTA (output) DOUBLE PRECISION array, dimension (2) -* The vector DELTA contains the information necessary -* to construct the eigenvectors. -* -* RHO (input) DOUBLE PRECISION -* The scalar in the symmetric updating formula. -* -* DLAM (output) DOUBLE PRECISION -* The computed lambda_I, the I-th updated eigenvalue. -* -* Further Details -* =============== -* -* Based on contributions by -* Ren-Cang Li, Computer Science Division, University of California -* at Berkeley, USA -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ FOUR = 4.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION B, C, DEL, TAU, TEMP, W -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* - DEL = D( 2 ) - D( 1 ) - IF( I.EQ.1 ) THEN - W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL - IF( W.GT.ZERO ) THEN - B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) - C = RHO*Z( 1 )*Z( 1 )*DEL -* -* B > ZERO, always -* - TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) ) - DLAM = D( 1 ) + TAU - DELTA( 1 ) = -Z( 1 ) / TAU - DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) - ELSE - B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) - C = RHO*Z( 2 )*Z( 2 )*DEL - IF( B.GT.ZERO ) THEN - TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) ) - ELSE - TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO - END IF - DLAM = D( 2 ) + TAU - DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) - DELTA( 2 ) = -Z( 2 ) / TAU - END IF - TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) - DELTA( 1 ) = DELTA( 1 ) / TEMP - DELTA( 2 ) = DELTA( 2 ) / TEMP - ELSE -* -* Now I=2 -* - B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) - C = RHO*Z( 2 )*Z( 2 )*DEL - IF( B.GT.ZERO ) THEN - TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO - ELSE - TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) ) - END IF - DLAM = D( 2 ) + TAU - DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) - DELTA( 2 ) = -Z( 2 ) / TAU - TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) - DELTA( 1 ) = DELTA( 1 ) / TEMP - DELTA( 2 ) = DELTA( 2 ) / TEMP - END IF - RETURN -* -* End OF DLAED5 -* - END - SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, -* Courant Institute, NAG Ltd., and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - LOGICAL ORGATI - INTEGER INFO, KNITER - DOUBLE PRECISION FINIT, RHO, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( 3 ), Z( 3 ) -* .. -* -* Purpose -* ======= -* -* DLAED6 computes the positive or negative root (closest to the origin) -* of -* z(1) z(2) z(3) -* f(x) = rho + --------- + ---------- + --------- -* d(1)-x d(2)-x d(3)-x -* -* It is assumed that -* -* if ORGATI = .true. the root is between d(2) and d(3); -* otherwise it is between d(1) and d(2) -* -* This routine will be called by DLAED4 when necessary. In most cases, -* the root sought is the smallest in magnitude, though it might not be -* in some extremely rare situations. -* -* Arguments -* ========= -* -* KNITER (input) INTEGER -* Refer to DLAED4 for its significance. -* -* ORGATI (input) LOGICAL -* If ORGATI is true, the needed root is between d(2) and -* d(3); otherwise it is between d(1) and d(2). See -* DLAED4 for further details. -* -* RHO (input) DOUBLE PRECISION -* Refer to the equation f(x) above. -* -* D (input) DOUBLE PRECISION array, dimension (3) -* D satisfies d(1) < d(2) < d(3). -* -* Z (input) DOUBLE PRECISION array, dimension (3) -* Each of the elements in z must be positive. -* -* FINIT (input) DOUBLE PRECISION -* The value of f at 0. It is more accurate than the one -* evaluated inside this routine (if someone wants to do -* so). -* -* TAU (output) DOUBLE PRECISION -* The root of the equation f(x). -* -* INFO (output) INTEGER -* = 0: successful exit -* > 0: if INFO = 1, failure to converge -* -* Further Details -* =============== -* -* Based on contributions by -* Ren-Cang Li, Computer Science Division, University of California -* at Berkeley, USA -* -* ===================================================================== -* -* .. Parameters .. - INTEGER MAXIT - PARAMETER ( MAXIT = 20 ) - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 ) -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Local Arrays .. - DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 ) -* .. -* .. Local Scalars .. - LOGICAL FIRST, SCALE - INTEGER I, ITER, NITER - DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F, - $ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1, - $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4 -* .. -* .. Save statement .. - SAVE FIRST, SMALL1, SMINV1, SMALL2, SMINV2, EPS -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* - INFO = 0 -* - NITER = 1 - TAU = ZERO - IF( KNITER.EQ.2 ) THEN - IF( ORGATI ) THEN - TEMP = ( D( 3 )-D( 2 ) ) / TWO - C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP ) - A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 ) - B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 ) - ELSE - TEMP = ( D( 1 )-D( 2 ) ) / TWO - C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP ) - A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 ) - B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 ) - END IF - TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) - A = A / TEMP - B = B / TEMP - C = C / TEMP - IF( C.EQ.ZERO ) THEN - TAU = B / A - ELSE IF( A.LE.ZERO ) THEN - TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF - TEMP = RHO + Z( 1 ) / ( D( 1 )-TAU ) + - $ Z( 2 ) / ( D( 2 )-TAU ) + Z( 3 ) / ( D( 3 )-TAU ) - IF( ABS( FINIT ).LE.ABS( TEMP ) ) - $ TAU = ZERO - END IF -* -* On first call to routine, get machine parameters for -* possible scaling to avoid overflow -* - IF( FIRST ) THEN - EPS = DLAMCH( 'Epsilon' ) - BASE = DLAMCH( 'Base' ) - SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) / - $ THREE ) ) - SMINV1 = ONE / SMALL1 - SMALL2 = SMALL1*SMALL1 - SMINV2 = SMINV1*SMINV1 - FIRST = .FALSE. - END IF -* -* Determine if scaling of inputs necessary to avoid overflow -* when computing 1/TEMP**3 -* - IF( ORGATI ) THEN - TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) ) - ELSE - TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) ) - END IF - SCALE = .FALSE. - IF( TEMP.LE.SMALL1 ) THEN - SCALE = .TRUE. - IF( TEMP.LE.SMALL2 ) THEN -* -* Scale up by power of radix nearest 1/SAFMIN**(2/3) -* - SCLFAC = SMINV2 - SCLINV = SMALL2 - ELSE -* -* Scale up by power of radix nearest 1/SAFMIN**(1/3) -* - SCLFAC = SMINV1 - SCLINV = SMALL1 - END IF -* -* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) -* - DO 10 I = 1, 3 - DSCALE( I ) = D( I )*SCLFAC - ZSCALE( I ) = Z( I )*SCLFAC - 10 CONTINUE - TAU = TAU*SCLFAC - ELSE -* -* Copy D and Z to DSCALE and ZSCALE -* - DO 20 I = 1, 3 - DSCALE( I ) = D( I ) - ZSCALE( I ) = Z( I ) - 20 CONTINUE - END IF -* - FC = ZERO - DF = ZERO - DDF = ZERO - DO 30 I = 1, 3 - TEMP = ONE / ( DSCALE( I )-TAU ) - TEMP1 = ZSCALE( I )*TEMP - TEMP2 = TEMP1*TEMP - TEMP3 = TEMP2*TEMP - FC = FC + TEMP1 / DSCALE( I ) - DF = DF + TEMP2 - DDF = DDF + TEMP3 - 30 CONTINUE - F = FINIT + TAU*FC -* - IF( ABS( F ).LE.ZERO ) - $ GO TO 60 -* -* Iteration begins -* -* It is not hard to see that -* -* 1) Iterations will go up monotonically -* if FINIT < 0; -* -* 2) Iterations will go down monotonically -* if FINIT > 0. -* - ITER = NITER + 1 -* - DO 50 NITER = ITER, MAXIT -* - IF( ORGATI ) THEN - TEMP1 = DSCALE( 2 ) - TAU - TEMP2 = DSCALE( 3 ) - TAU - ELSE - TEMP1 = DSCALE( 1 ) - TAU - TEMP2 = DSCALE( 2 ) - TAU - END IF - A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF - B = TEMP1*TEMP2*F - C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF - TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) - A = A / TEMP - B = B / TEMP - C = C / TEMP - IF( C.EQ.ZERO ) THEN - ETA = B / A - ELSE IF( A.LE.ZERO ) THEN - ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF - IF( F*ETA.GE.ZERO ) THEN - ETA = -F / DF - END IF -* - TEMP = ETA + TAU - IF( ORGATI ) THEN - IF( ETA.GT.ZERO .AND. TEMP.GE.DSCALE( 3 ) ) - $ ETA = ( DSCALE( 3 )-TAU ) / TWO - IF( ETA.LT.ZERO .AND. TEMP.LE.DSCALE( 2 ) ) - $ ETA = ( DSCALE( 2 )-TAU ) / TWO - ELSE - IF( ETA.GT.ZERO .AND. TEMP.GE.DSCALE( 2 ) ) - $ ETA = ( DSCALE( 2 )-TAU ) / TWO - IF( ETA.LT.ZERO .AND. TEMP.LE.DSCALE( 1 ) ) - $ ETA = ( DSCALE( 1 )-TAU ) / TWO - END IF - TAU = TAU + ETA -* - FC = ZERO - ERRETM = ZERO - DF = ZERO - DDF = ZERO - DO 40 I = 1, 3 - TEMP = ONE / ( DSCALE( I )-TAU ) - TEMP1 = ZSCALE( I )*TEMP - TEMP2 = TEMP1*TEMP - TEMP3 = TEMP2*TEMP - TEMP4 = TEMP1 / DSCALE( I ) - FC = FC + TEMP4 - ERRETM = ERRETM + ABS( TEMP4 ) - DF = DF + TEMP2 - DDF = DDF + TEMP3 - 40 CONTINUE - F = FINIT + TAU*FC - ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) + - $ ABS( TAU )*DF - IF( ABS( F ).LE.EPS*ERRETM ) - $ GO TO 60 - 50 CONTINUE - INFO = 1 - 60 CONTINUE -* -* Undo scaling -* - IF( SCALE ) - $ TAU = TAU*SCLINV - RETURN -* -* End of DLAED6 -* - END - SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, - $ Q2, INDX, INDXC, INDXP, COLTYP, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDQ, N, N1 - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ), - $ INDXQ( * ) - DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), - $ W( * ), Z( * ) -* .. -* -* Purpose -* ======= -* -* DLAED2 merges the two sets of eigenvalues together into a single -* sorted set. Then it tries to deflate the size of the problem. -* There are two ways in which deflation can occur: when two or more -* eigenvalues are close together or if there is a tiny entry in the -* Z vector. For each such occurrence the order of the related secular -* equation problem is reduced by one. -* -* Arguments -* ========= -* -* K (output) INTEGER -* The number of non-deflated eigenvalues, and the order of the -* related secular equation. 0 <= K <=N. -* -* N (input) INTEGER -* The dimension of the symmetric tridiagonal matrix. N >= 0. -* -* N1 (input) INTEGER -* The location of the last eigenvalue in the leading sub-matrix. -* min(1,N) <= N1 <= N/2. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, D contains the eigenvalues of the two submatrices to -* be combined. -* On exit, D contains the trailing (N-K) updated eigenvalues -* (those which were deflated) sorted into increasing order. -* -* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) -* On entry, Q contains the eigenvectors of two submatrices in -* the two square blocks with corners at (1,1), (N1,N1) -* and (N1+1, N1+1), (N,N). -* On exit, Q contains the trailing (N-K) updated eigenvectors -* (those which were deflated) in its last N-K columns. -* -* LDQ (input) INTEGER -* The leading dimension of the array Q. LDQ >= max(1,N). -* -* INDXQ (input/output) INTEGER array, dimension (N) -* The permutation which separately sorts the two sub-problems -* in D into ascending order. Note that elements in the second -* half of this permutation must first have N1 added to their -* values. Destroyed on exit. -* -* RHO (input/output) DOUBLE PRECISION -* On entry, the off-diagonal element associated with the rank-1 -* cut which originally split the two submatrices which are now -* being recombined. -* On exit, RHO has been modified to the value required by -* DLAED3. -* -* Z (input) DOUBLE PRECISION array, dimension (N) -* On entry, Z contains the updating vector (the last -* row of the first sub-eigenvector matrix and the first row of -* the second sub-eigenvector matrix). -* On exit, the contents of Z have been destroyed by the updating -* process. -* -* DLAMDA (output) DOUBLE PRECISION array, dimension (N) -* A copy of the first K eigenvalues which will be used by -* DLAED3 to form the secular equation. -* -* W (output) DOUBLE PRECISION array, dimension (N) -* The first k values of the final deflation-altered z-vector -* which will be passed to DLAED3. -* -* Q2 (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2) -* A copy of the first K eigenvectors which will be used by -* DLAED3 in a matrix multiply (DGEMM) to solve for the new -* eigenvectors. -* -* INDX (workspace) INTEGER array, dimension (N) -* The permutation used to sort the contents of DLAMDA into -* ascending order. -* -* INDXC (output) INTEGER array, dimension (N) -* The permutation used to arrange the columns of the deflated -* Q matrix into three groups: the first group contains non-zero -* elements only at and above N1, the second contains -* non-zero elements only below N1, and the third is dense. -* -* INDXP (workspace) INTEGER array, dimension (N) -* The permutation used to place deflated values of D at the end -* of the array. INDXP(1:K) points to the nondeflated D-values -* and INDXP(K+1:N) points to the deflated eigenvalues. -* -* COLTYP (workspace/output) INTEGER array, dimension (N) -* During execution, a label which will indicate which of the -* following types a column in the Q2 matrix is: -* 1 : non-zero in the upper half only; -* 2 : dense; -* 3 : non-zero in the lower half only; -* 4 : deflated. -* On exit, COLTYP(i) is the number of columns of type i, -* for i=1 to 4 only. -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* Based on contributions by -* Jeff Rutter, Computer Science Division, University of California -* at Berkeley, USA -* Modified by Francoise Tisseur, University of Tennessee. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT - PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, - $ TWO = 2.0D0, EIGHT = 8.0D0 ) -* .. -* .. Local Arrays .. - INTEGER CTOT( 4 ), PSM( 4 ) -* .. -* .. Local Scalars .. - INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1, - $ N2, NJ, PJ - DOUBLE PRECISION C, EPS, S, T, TAU, TOL -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL IDAMAX, DLAMCH, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN - INFO = -3 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - N2 = N - N1 - N1P1 = N1 + 1 -* - IF( RHO.LT.ZERO ) THEN - CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) - END IF -* -* Normalize z so that norm(z) = 1. Since z is the concatenation of -* two normalized vectors, norm2(z) = sqrt(2). -* - T = ONE / SQRT( TWO ) - CALL DSCAL( N, T, Z, 1 ) -* -* RHO = ABS( norm(z)**2 * RHO ) -* - RHO = ABS( TWO*RHO ) -* -* Sort the eigenvalues into increasing order -* - DO 10 I = N1P1, N - INDXQ( I ) = INDXQ( I ) + N1 - 10 CONTINUE -* -* re-integrate the deflated parts from the last pass -* - DO 20 I = 1, N - DLAMDA( I ) = D( INDXQ( I ) ) - 20 CONTINUE - CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDXC ) - DO 30 I = 1, N - INDX( I ) = INDXQ( INDXC( I ) ) - 30 CONTINUE -* -* Calculate the allowable deflation tolerance -* - IMAX = IDAMAX( N, Z, 1 ) - JMAX = IDAMAX( N, D, 1 ) - EPS = DLAMCH( 'Epsilon' ) - TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) ) -* -* If the rank-1 modifier is small enough, no more needs to be done -* except to reorganize Q so that its columns correspond with the -* elements in D. -* - IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN - K = 0 - IQ2 = 1 - DO 40 J = 1, N - I = INDX( J ) - CALL DCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 ) - DLAMDA( J ) = D( I ) - IQ2 = IQ2 + N - 40 CONTINUE - CALL DLACPY( 'A', N, N, Q2, N, Q, LDQ ) - CALL DCOPY( N, DLAMDA, 1, D, 1 ) - GO TO 190 - END IF -* -* If there are multiple eigenvalues then the problem deflates. Here -* the number of equal eigenvalues are found. As each equal -* eigenvalue is found, an elementary reflector is computed to rotate -* the corresponding eigensubspace so that the corresponding -* components of Z are zero in this new basis. -* - DO 50 I = 1, N1 - COLTYP( I ) = 1 - 50 CONTINUE - DO 60 I = N1P1, N - COLTYP( I ) = 3 - 60 CONTINUE -* -* - K = 0 - K2 = N + 1 - DO 70 J = 1, N - NJ = INDX( J ) - IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - COLTYP( NJ ) = 4 - INDXP( K2 ) = NJ - IF( J.EQ.N ) - $ GO TO 100 - ELSE - PJ = NJ - GO TO 80 - END IF - 70 CONTINUE - 80 CONTINUE - J = J + 1 - NJ = INDX( J ) - IF( J.GT.N ) - $ GO TO 100 - IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - COLTYP( NJ ) = 4 - INDXP( K2 ) = NJ - ELSE -* -* Check if eigenvalues are close enough to allow deflation. -* - S = Z( PJ ) - C = Z( NJ ) -* -* Find sqrt(a**2+b**2) without overflow or -* destructive underflow. -* - TAU = DLAPY2( C, S ) - T = D( NJ ) - D( PJ ) - C = C / TAU - S = -S / TAU - IF( ABS( T*C*S ).LE.TOL ) THEN -* -* Deflation is possible. -* - Z( NJ ) = TAU - Z( PJ ) = ZERO - IF( COLTYP( NJ ).NE.COLTYP( PJ ) ) - $ COLTYP( NJ ) = 2 - COLTYP( PJ ) = 4 - CALL DROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S ) - T = D( PJ )*C**2 + D( NJ )*S**2 - D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2 - D( PJ ) = T - K2 = K2 - 1 - I = 1 - 90 CONTINUE - IF( K2+I.LE.N ) THEN - IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN - INDXP( K2+I-1 ) = INDXP( K2+I ) - INDXP( K2+I ) = PJ - I = I + 1 - GO TO 90 - ELSE - INDXP( K2+I-1 ) = PJ - END IF - ELSE - INDXP( K2+I-1 ) = PJ - END IF - PJ = NJ - ELSE - K = K + 1 - DLAMDA( K ) = D( PJ ) - W( K ) = Z( PJ ) - INDXP( K ) = PJ - PJ = NJ - END IF - END IF - GO TO 80 - 100 CONTINUE -* -* Record the last eigenvalue. -* - K = K + 1 - DLAMDA( K ) = D( PJ ) - W( K ) = Z( PJ ) - INDXP( K ) = PJ -* -* Count up the total number of the various types of columns, then -* form a permutation which positions the four column types into -* four uniform groups (although one or more of these groups may be -* empty). -* - DO 110 J = 1, 4 - CTOT( J ) = 0 - 110 CONTINUE - DO 120 J = 1, N - CT = COLTYP( J ) - CTOT( CT ) = CTOT( CT ) + 1 - 120 CONTINUE -* -* PSM(*) = Position in SubMatrix (of types 1 through 4) -* - PSM( 1 ) = 1 - PSM( 2 ) = 1 + CTOT( 1 ) - PSM( 3 ) = PSM( 2 ) + CTOT( 2 ) - PSM( 4 ) = PSM( 3 ) + CTOT( 3 ) - K = N - CTOT( 4 ) -* -* Fill out the INDXC array so that the permutation which it induces -* will place all type-1 columns first, all type-2 columns next, -* then all type-3's, and finally all type-4's. -* - DO 130 J = 1, N - JS = INDXP( J ) - CT = COLTYP( JS ) - INDX( PSM( CT ) ) = JS - INDXC( PSM( CT ) ) = J - PSM( CT ) = PSM( CT ) + 1 - 130 CONTINUE -* -* Sort the eigenvalues and corresponding eigenvectors into DLAMDA -* and Q2 respectively. The eigenvalues/vectors which were not -* deflated go into the first K slots of DLAMDA and Q2 respectively, -* while those which were deflated go into the last N - K slots. -* - I = 1 - IQ1 = 1 - IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1 - DO 140 J = 1, CTOT( 1 ) - JS = INDX( I ) - CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 ) - Z( I ) = D( JS ) - I = I + 1 - IQ1 = IQ1 + N1 - 140 CONTINUE -* - DO 150 J = 1, CTOT( 2 ) - JS = INDX( I ) - CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 ) - CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 ) - Z( I ) = D( JS ) - I = I + 1 - IQ1 = IQ1 + N1 - IQ2 = IQ2 + N2 - 150 CONTINUE -* - DO 160 J = 1, CTOT( 3 ) - JS = INDX( I ) - CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 ) - Z( I ) = D( JS ) - I = I + 1 - IQ2 = IQ2 + N2 - 160 CONTINUE -* - IQ1 = IQ2 - DO 170 J = 1, CTOT( 4 ) - JS = INDX( I ) - CALL DCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 ) - IQ2 = IQ2 + N - Z( I ) = D( JS ) - I = I + 1 - 170 CONTINUE -* -* The deflated eigenvalues and their corresponding vectors go back -* into the last N - K slots of D and Q respectively. -* - CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, Q( 1, K+1 ), LDQ ) - CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 ) -* -* Copy CTOT into COLTYP for referencing in DLAED3. -* - DO 180 J = 1, 4 - COLTYP( J ) = CTOT( J ) - 180 CONTINUE -* - 190 CONTINUE - RETURN -* -* End of DLAED2 -* - END - SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, - $ CTOT, W, S, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, -* Courant Institute, NAG Ltd., and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDQ, N, N1 - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER CTOT( * ), INDX( * ) - DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), - $ S( * ), W( * ) -* .. -* -* Purpose -* ======= -* -* DLAED3 finds the roots of the secular equation, as defined by the -* values in D, W, and RHO, between 1 and K. It makes the -* appropriate calls to DLAED4 and then updates the eigenvectors by -* multiplying the matrix of eigenvectors of the pair of eigensystems -* being combined by the matrix of eigenvectors of the K-by-K system -* which is solved here. -* -* This code makes very mild assumptions about floating point -* arithmetic. It will work on machines with a guard digit in -* add/subtract, or on those binary machines without guard digits -* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. -* It could conceivably fail on hexadecimal or decimal machines -* without guard digits, but we know of none. -* -* Arguments -* ========= -* -* K (input) INTEGER -* The number of terms in the rational function to be solved by -* DLAED4. K >= 0. -* -* N (input) INTEGER -* The number of rows and columns in the Q matrix. -* N >= K (deflation may result in N>K). -* -* N1 (input) INTEGER -* The location of the last eigenvalue in the leading submatrix. -* min(1,N) <= N1 <= N/2. -* -* D (output) DOUBLE PRECISION array, dimension (N) -* D(I) contains the updated eigenvalues for -* 1 <= I <= K. -* -* Q (output) DOUBLE PRECISION array, dimension (LDQ,N) -* Initially the first K columns are used as workspace. -* On output the columns 1 to K contain -* the updated eigenvectors. -* -* LDQ (input) INTEGER -* The leading dimension of the array Q. LDQ >= max(1,N). -* -* RHO (input) DOUBLE PRECISION -* The value of the parameter in the rank one update equation. -* RHO >= 0 required. -* -* DLAMDA (input/output) DOUBLE PRECISION array, dimension (K) -* The first K elements of this array contain the old roots -* of the deflated updating problem. These are the poles -* of the secular equation. May be changed on output by -* having lowest order bit set to zero on Cray X-MP, Cray Y-MP, -* Cray-2, or Cray C-90, as described above. -* -* Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N) -* The first K columns of this matrix contain the non-deflated -* eigenvectors for the split problem. -* -* INDX (input) INTEGER array, dimension (N) -* The permutation used to arrange the columns of the deflated -* Q matrix into three groups (see DLAED2). -* The rows of the eigenvectors found by DLAED4 must be likewise -* permuted before the matrix multiply can take place. -* -* CTOT (input) INTEGER array, dimension (4) -* A count of the total number of the various types of columns -* in Q, as described in INDX. The fourth column type is any -* column which has been deflated. -* -* W (input/output) DOUBLE PRECISION array, dimension (K) -* The first K elements of this array contain the components -* of the deflation-adjusted updating vector. Destroyed on -* output. -* -* S (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K -* Will contain the eigenvectors of the repaired matrix which -* will be multiplied by the previously accumulated eigenvectors -* to update the system. -* -* LDS (input) INTEGER -* The leading dimension of S. LDS >= max(1,K). -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* > 0: if INFO = 1, an eigenvalue did not converge -* -* Further Details -* =============== -* -* Based on contributions by -* Jeff Rutter, Computer Science Division, University of California -* at Berkeley, USA -* Modified by Francoise Tisseur, University of Tennessee. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I, II, IQ2, J, N12, N2, N23 - DOUBLE PRECISION TEMP -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3, DNRM2 - EXTERNAL DLAMC3, DNRM2 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLACPY, DLAED4, DLASET, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( K.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.K ) THEN - INFO = -2 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED3', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( K.EQ.0 ) - $ RETURN -* -* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can -* be computed with high relative accuracy (barring over/underflow). -* This is a problem on machines without a guard digit in -* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). -* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), -* which on any of these machines zeros out the bottommost -* bit of DLAMDA(I) if it is 1; this makes the subsequent -* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation -* occurs. On binary machines with a guard digit (almost all -* machines) it does not change DLAMDA(I) at all. On hexadecimal -* and decimal machines with a guard digit, it slightly -* changes the bottommost bits of DLAMDA(I). It does not account -* for hexadecimal or decimal machines without guard digits -* (we know of none). We use a subroutine call to compute -* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating -* this code. -* - DO 10 I = 1, K - DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I ) - 10 CONTINUE -* - DO 20 J = 1, K - CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO ) -* -* If the zero finder fails, the computation is terminated. -* - IF( INFO.NE.0 ) - $ GO TO 120 - 20 CONTINUE -* - IF( K.EQ.1 ) - $ GO TO 110 - IF( K.EQ.2 ) THEN - DO 30 J = 1, K - W( 1 ) = Q( 1, J ) - W( 2 ) = Q( 2, J ) - II = INDX( 1 ) - Q( 1, J ) = W( II ) - II = INDX( 2 ) - Q( 2, J ) = W( II ) - 30 CONTINUE - GO TO 110 - END IF -* -* Compute updated W. -* - CALL DCOPY( K, W, 1, S, 1 ) -* -* Initialize W(I) = Q(I,I) -* - CALL DCOPY( K, Q, LDQ+1, W, 1 ) - DO 60 J = 1, K - DO 40 I = 1, J - 1 - W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) - 40 CONTINUE - DO 50 I = J + 1, K - W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) - 50 CONTINUE - 60 CONTINUE - DO 70 I = 1, K - W( I ) = SIGN( SQRT( -W( I ) ), S( I ) ) - 70 CONTINUE -* -* Compute eigenvectors of the modified rank-1 modification. -* - DO 100 J = 1, K - DO 80 I = 1, K - S( I ) = W( I ) / Q( I, J ) - 80 CONTINUE - TEMP = DNRM2( K, S, 1 ) - DO 90 I = 1, K - II = INDX( I ) - Q( I, J ) = S( II ) / TEMP - 90 CONTINUE - 100 CONTINUE -* -* Compute the updated eigenvectors. -* - 110 CONTINUE -* - N2 = N - N1 - N12 = CTOT( 1 ) + CTOT( 2 ) - N23 = CTOT( 2 ) + CTOT( 3 ) -* - CALL DLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 ) - IQ2 = N1*N12 + 1 - IF( N23.NE.0 ) THEN - CALL DGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23, - $ ZERO, Q( N1+1, 1 ), LDQ ) - ELSE - CALL DLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ ) - END IF -* - CALL DLACPY( 'A', N12, K, Q, LDQ, S, N12 ) - IF( N12.NE.0 ) THEN - CALL DGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q, - $ LDQ ) - ELSE - CALL DLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ ) - END IF -* -* - 120 CONTINUE - RETURN -* -* End of DLAED3 -* - END - SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER DTRD1, DTRD2, N1, N2 -* .. -* .. Array Arguments .. - INTEGER INDEX( * ) - DOUBLE PRECISION A( * ) -* .. -* -* Purpose -* ======= -* -* DLAMRG will create a permutation list which will merge the elements -* of A (which is composed of two independently sorted sets) into a -* single set which is sorted in ascending order. -* -* Arguments -* ========= -* -* N1 (input) INTEGER -* N2 (input) INTEGER -* These arguements contain the respective lengths of the two -* sorted lists to be merged. -* -* A (input) DOUBLE PRECISION array, dimension (N1+N2) -* The first N1 elements of A contain a list of numbers which -* are sorted in either ascending or descending order. Likewise -* for the final N2 elements. -* -* DTRD1 (input) INTEGER -* DTRD2 (input) INTEGER -* These are the strides to be taken through the array A. -* Allowable strides are 1 and -1. They indicate whether a -* subset of A is sorted in ascending (DTRDx = 1) or descending -* (DTRDx = -1) order. -* -* INDEX (output) INTEGER array, dimension (N1+N2) -* On exit this array will contain a permutation such that -* if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be -* sorted in ascending order. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IND1, IND2, N1SV, N2SV -* .. -* .. Executable Statements .. -* - N1SV = N1 - N2SV = N2 - IF( DTRD1.GT.0 ) THEN - IND1 = 1 - ELSE - IND1 = N1 - END IF - IF( DTRD2.GT.0 ) THEN - IND2 = 1 + N1 - ELSE - IND2 = N1 + N2 - END IF - I = 1 -* while ( (N1SV > 0) & (N2SV > 0) ) - 10 CONTINUE - IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN - IF( A( IND1 ).LE.A( IND2 ) ) THEN - INDEX( I ) = IND1 - I = I + 1 - IND1 = IND1 + DTRD1 - N1SV = N1SV - 1 - ELSE - INDEX( I ) = IND2 - I = I + 1 - IND2 = IND2 + DTRD2 - N2SV = N2SV - 1 - END IF - GO TO 10 - END IF -* end while - IF( N1SV.EQ.0 ) THEN - DO 20 N1SV = 1, N2SV - INDEX( I ) = IND2 - I = I + 1 - IND2 = IND2 + DTRD2 - 20 CONTINUE - ELSE -* N2SV .EQ. 0 - DO 30 N2SV = 1, N1SV - INDEX( I ) = IND1 - I = I + 1 - IND1 = IND1 + DTRD1 - 30 CONTINUE - END IF -* - RETURN -* -* End of DLAMRG -* - END - SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, - $ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, - $ GIVCOL, GIVNUM, INDXP, INDX, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, -* Courant Institute, NAG Ltd., and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, - $ QSIZ - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), - $ INDXQ( * ), PERM( * ) - DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), - $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) -* .. -* -* Purpose -* ======= -* -* DLAED8 merges the two sets of eigenvalues together into a single -* sorted set. Then it tries to deflate the size of the problem. -* There are two ways in which deflation can occur: when two or more -* eigenvalues are close together or if there is a tiny element in the -* Z vector. For each such occurrence the order of the related secular -* equation problem is reduced by one. -* -* Arguments -* ========= -* -* ICOMPQ (input) INTEGER -* = 0: Compute eigenvalues only. -* = 1: Compute eigenvectors of original dense symmetric matrix -* also. On entry, Q contains the orthogonal matrix used -* to reduce the original matrix to tridiagonal form. -* -* K (output) INTEGER -* The number of non-deflated eigenvalues, and the order of the -* related secular equation. -* -* N (input) INTEGER -* The dimension of the symmetric tridiagonal matrix. N >= 0. -* -* QSIZ (input) INTEGER -* The dimension of the orthogonal matrix used to reduce -* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the eigenvalues of the two submatrices to be -* combined. On exit, the trailing (N-K) updated eigenvalues -* (those which were deflated) sorted into increasing order. -* -* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -* If ICOMPQ = 0, Q is not referenced. Otherwise, -* on entry, Q contains the eigenvectors of the partially solved -* system which has been previously updated in matrix -* multiplies with other partially solved eigensystems. -* On exit, Q contains the trailing (N-K) updated eigenvectors -* (those which were deflated) in its last N-K columns. -* -* LDQ (input) INTEGER -* The leading dimension of the array Q. LDQ >= max(1,N). -* -* INDXQ (input) INTEGER array, dimension (N) -* The permutation which separately sorts the two sub-problems -* in D into ascending order. Note that elements in the second -* half of this permutation must first have CUTPNT added to -* their values in order to be accurate. -* -* RHO (input/output) DOUBLE PRECISION -* On entry, the off-diagonal element associated with the rank-1 -* cut which originally split the two submatrices which are now -* being recombined. -* On exit, RHO has been modified to the value required by -* DLAED3. -* -* CUTPNT (input) INTEGER -* The location of the last eigenvalue in the leading -* sub-matrix. min(1,N) <= CUTPNT <= N. -* -* Z (input) DOUBLE PRECISION array, dimension (N) -* On entry, Z contains the updating vector (the last row of -* the first sub-eigenvector matrix and the first row of the -* second sub-eigenvector matrix). -* On exit, the contents of Z are destroyed by the updating -* process. -* -* DLAMDA (output) DOUBLE PRECISION array, dimension (N) -* A copy of the first K eigenvalues which will be used by -* DLAED3 to form the secular equation. -* -* Q2 (output) DOUBLE PRECISION array, dimension (LDQ2,N) -* If ICOMPQ = 0, Q2 is not referenced. Otherwise, -* a copy of the first K eigenvectors which will be used by -* DLAED7 in a matrix multiply (DGEMM) to update the new -* eigenvectors. -* -* LDQ2 (input) INTEGER -* The leading dimension of the array Q2. LDQ2 >= max(1,N). -* -* W (output) DOUBLE PRECISION array, dimension (N) -* The first k values of the final deflation-altered z-vector and -* will be passed to DLAED3. -* -* PERM (output) INTEGER array, dimension (N) -* The permutations (from deflation and sorting) to be applied -* to each eigenblock. -* -* GIVPTR (output) INTEGER -* The number of Givens rotations which took place in this -* subproblem. -* -* GIVCOL (output) INTEGER array, dimension (2, N) -* Each pair of numbers indicates a pair of columns to take place -* in a Givens rotation. -* -* GIVNUM (output) DOUBLE PRECISION array, dimension (2, N) -* Each number indicates the S value to be used in the -* corresponding Givens rotation. -* -* INDXP (workspace) INTEGER array, dimension (N) -* The permutation used to place deflated values of D at the end -* of the array. INDXP(1:K) points to the nondeflated D-values -* and INDXP(K+1:N) points to the deflated eigenvalues. -* -* INDX (workspace) INTEGER array, dimension (N) -* The permutation used to sort the contents of D into ascending -* order. -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* Based on contributions by -* Jeff Rutter, Computer Science Division, University of California -* at Berkeley, USA -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT - PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, - $ TWO = 2.0D0, EIGHT = 8.0D0 ) -* .. -* .. Local Scalars .. -* - INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2 - DOUBLE PRECISION C, EPS, S, T, TAU, TOL -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL IDAMAX, DLAMCH, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN - INFO = -4 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN - INFO = -10 - ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN - INFO = -14 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED8', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - N1 = CUTPNT - N2 = N - N1 - N1P1 = N1 + 1 -* - IF( RHO.LT.ZERO ) THEN - CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) - END IF -* -* Normalize z so that norm(z) = 1 -* - T = ONE / SQRT( TWO ) - DO 10 J = 1, N - INDX( J ) = J - 10 CONTINUE - CALL DSCAL( N, T, Z, 1 ) - RHO = ABS( TWO*RHO ) -* -* Sort the eigenvalues into increasing order -* - DO 20 I = CUTPNT + 1, N - INDXQ( I ) = INDXQ( I ) + CUTPNT - 20 CONTINUE - DO 30 I = 1, N - DLAMDA( I ) = D( INDXQ( I ) ) - W( I ) = Z( INDXQ( I ) ) - 30 CONTINUE - I = 1 - J = CUTPNT + 1 - CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX ) - DO 40 I = 1, N - D( I ) = DLAMDA( INDX( I ) ) - Z( I ) = W( INDX( I ) ) - 40 CONTINUE -* -* Calculate the allowable deflation tolerence -* - IMAX = IDAMAX( N, Z, 1 ) - JMAX = IDAMAX( N, D, 1 ) - EPS = DLAMCH( 'Epsilon' ) - TOL = EIGHT*EPS*ABS( D( JMAX ) ) -* -* If the rank-1 modifier is small enough, no more needs to be done -* except to reorganize Q so that its columns correspond with the -* elements in D. -* - IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN - K = 0 - IF( ICOMPQ.EQ.0 ) THEN - DO 50 J = 1, N - PERM( J ) = INDXQ( INDX( J ) ) - 50 CONTINUE - ELSE - DO 60 J = 1, N - PERM( J ) = INDXQ( INDX( J ) ) - CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) - 60 CONTINUE - CALL DLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), - $ LDQ ) - END IF - RETURN - END IF -* -* If there are multiple eigenvalues then the problem deflates. Here -* the number of equal eigenvalues are found. As each equal -* eigenvalue is found, an elementary reflector is computed to rotate -* the corresponding eigensubspace so that the corresponding -* components of Z are zero in this new basis. -* - K = 0 - GIVPTR = 0 - K2 = N + 1 - DO 70 J = 1, N - IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - INDXP( K2 ) = J - IF( J.EQ.N ) - $ GO TO 110 - ELSE - JLAM = J - GO TO 80 - END IF - 70 CONTINUE - 80 CONTINUE - J = J + 1 - IF( J.GT.N ) - $ GO TO 100 - IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - INDXP( K2 ) = J - ELSE -* -* Check if eigenvalues are close enough to allow deflation. -* - S = Z( JLAM ) - C = Z( J ) -* -* Find sqrt(a**2+b**2) without overflow or -* destructive underflow. -* - TAU = DLAPY2( C, S ) - T = D( J ) - D( JLAM ) - C = C / TAU - S = -S / TAU - IF( ABS( T*C*S ).LE.TOL ) THEN -* -* Deflation is possible. -* - Z( J ) = TAU - Z( JLAM ) = ZERO -* -* Record the appropriate Givens rotation -* - GIVPTR = GIVPTR + 1 - GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) ) - GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) ) - GIVNUM( 1, GIVPTR ) = C - GIVNUM( 2, GIVPTR ) = S - IF( ICOMPQ.EQ.1 ) THEN - CALL DROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1, - $ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S ) - END IF - T = D( JLAM )*C*C + D( J )*S*S - D( J ) = D( JLAM )*S*S + D( J )*C*C - D( JLAM ) = T - K2 = K2 - 1 - I = 1 - 90 CONTINUE - IF( K2+I.LE.N ) THEN - IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN - INDXP( K2+I-1 ) = INDXP( K2+I ) - INDXP( K2+I ) = JLAM - I = I + 1 - GO TO 90 - ELSE - INDXP( K2+I-1 ) = JLAM - END IF - ELSE - INDXP( K2+I-1 ) = JLAM - END IF - JLAM = J - ELSE - K = K + 1 - W( K ) = Z( JLAM ) - DLAMDA( K ) = D( JLAM ) - INDXP( K ) = JLAM - JLAM = J - END IF - END IF - GO TO 80 - 100 CONTINUE -* -* Record the last eigenvalue. -* - K = K + 1 - W( K ) = Z( JLAM ) - DLAMDA( K ) = D( JLAM ) - INDXP( K ) = JLAM -* - 110 CONTINUE -* -* Sort the eigenvalues and corresponding eigenvectors into DLAMDA -* and Q2 respectively. The eigenvalues/vectors which were not -* deflated go into the first K slots of DLAMDA and Q2 respectively, -* while those which were deflated go into the last N - K slots. -* - IF( ICOMPQ.EQ.0 ) THEN - DO 120 J = 1, N - JP = INDXP( J ) - DLAMDA( J ) = D( JP ) - PERM( J ) = INDXQ( INDX( JP ) ) - 120 CONTINUE - ELSE - DO 130 J = 1, N - JP = INDXP( J ) - DLAMDA( J ) = D( JP ) - PERM( J ) = INDXQ( INDX( JP ) ) - CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) - 130 CONTINUE - END IF -* -* The deflated eigenvalues and their corresponding vectors go back -* into the last N - K slots of D and Q respectively. -* - IF( K.LT.N ) THEN - IF( ICOMPQ.EQ.0 ) THEN - CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) - ELSE - CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) - CALL DLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, - $ Q( 1, K+1 ), LDQ ) - END IF - END IF -* - RETURN -* -* End of DLAED8 -* - END - SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, - $ S, LDS, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, -* Courant Institute, NAG Ltd., and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), - $ W( * ) -* .. -* -* Purpose -* ======= -* -* DLAED9 finds the roots of the secular equation, as defined by the -* values in D, Z, and RHO, between KSTART and KSTOP. It makes the -* appropriate calls to DLAED4 and then stores the new matrix of -* eigenvectors for use in calculating the next level of Z vectors. -* -* Arguments -* ========= -* -* K (input) INTEGER -* The number of terms in the rational function to be solved by -* DLAED4. K >= 0. -* -* KSTART (input) INTEGER -* KSTOP (input) INTEGER -* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP -* are to be computed. 1 <= KSTART <= KSTOP <= K. -* -* N (input) INTEGER -* The number of rows and columns in the Q matrix. -* N >= K (delation may result in N > K). -* -* D (output) DOUBLE PRECISION array, dimension (N) -* D(I) contains the updated eigenvalues -* for KSTART <= I <= KSTOP. -* -* Q (workspace) DOUBLE PRECISION array, dimension (LDQ,N) -* -* LDQ (input) INTEGER -* The leading dimension of the array Q. LDQ >= max( 1, N ). -* -* RHO (input) DOUBLE PRECISION -* The value of the parameter in the rank one update equation. -* RHO >= 0 required. -* -* DLAMDA (input) DOUBLE PRECISION array, dimension (K) -* The first K elements of this array contain the old roots -* of the deflated updating problem. These are the poles -* of the secular equation. -* -* W (input) DOUBLE PRECISION array, dimension (K) -* The first K elements of this array contain the components -* of the deflation-adjusted updating vector. -* -* S (output) DOUBLE PRECISION array, dimension (LDS, K) -* Will contain the eigenvectors of the repaired matrix which -* will be stored for subsequent Z vector calculation and -* multiplied by the previously accumulated eigenvectors -* to update the system. -* -* LDS (input) INTEGER -* The leading dimension of S. LDS >= max( 1, K ). -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* > 0: if INFO = 1, an eigenvalue did not converge -* -* Further Details -* =============== -* -* Based on contributions by -* Jeff Rutter, Computer Science Division, University of California -* at Berkeley, USA -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION TEMP -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3, DNRM2 - EXTERNAL DLAMC3, DNRM2 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAED4, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( K.LT.0 ) THEN - INFO = -1 - ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN - INFO = -2 - ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) ) - $ THEN - INFO = -3 - ELSE IF( N.LT.K ) THEN - INFO = -4 - ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDS.LT.MAX( 1, K ) ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED9', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( K.EQ.0 ) - $ RETURN -* -* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can -* be computed with high relative accuracy (barring over/underflow). -* This is a problem on machines without a guard digit in -* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). -* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), -* which on any of these machines zeros out the bottommost -* bit of DLAMDA(I) if it is 1; this makes the subsequent -* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation -* occurs. On binary machines with a guard digit (almost all -* machines) it does not change DLAMDA(I) at all. On hexadecimal -* and decimal machines with a guard digit, it slightly -* changes the bottommost bits of DLAMDA(I). It does not account -* for hexadecimal or decimal machines without guard digits -* (we know of none). We use a subroutine call to compute -* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating -* this code. -* - DO 10 I = 1, N - DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I ) - 10 CONTINUE -* - DO 20 J = KSTART, KSTOP - CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO ) -* -* If the zero finder fails, the computation is terminated. -* - IF( INFO.NE.0 ) - $ GO TO 120 - 20 CONTINUE -* - IF( K.EQ.1 .OR. K.EQ.2 ) THEN - DO 40 I = 1, K - DO 30 J = 1, K - S( J, I ) = Q( J, I ) - 30 CONTINUE - 40 CONTINUE - GO TO 120 - END IF -* -* Compute updated W. -* - CALL DCOPY( K, W, 1, S, 1 ) -* -* Initialize W(I) = Q(I,I) -* - CALL DCOPY( K, Q, LDQ+1, W, 1 ) - DO 70 J = 1, K - DO 50 I = 1, J - 1 - W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) - 50 CONTINUE - DO 60 I = J + 1, K - W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) - 60 CONTINUE - 70 CONTINUE - DO 80 I = 1, K - W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) ) - 80 CONTINUE -* -* Compute eigenvectors of the modified rank-1 modification. -* - DO 110 J = 1, K - DO 90 I = 1, K - Q( I, J ) = W( I ) / Q( I, J ) - 90 CONTINUE - TEMP = DNRM2( K, Q( 1, J ), 1 ) - DO 100 I = 1, K - S( I, J ) = Q( I, J ) / TEMP - 100 CONTINUE - 110 CONTINUE -* - 120 CONTINUE - RETURN -* -* End of DLAED9 -* - END - SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, - $ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER CURLVL, CURPBM, INFO, N, TLVLS -* .. -* .. Array Arguments .. - INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ), - $ PRMPTR( * ), QPTR( * ) - DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) -* .. -* -* Purpose -* ======= -* -* DLAEDA computes the Z vector corresponding to the merge step in the -* CURLVLth step of the merge process with TLVLS steps for the CURPBMth -* problem. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The dimension of the symmetric tridiagonal matrix. N >= 0. -* -* TLVLS (input) INTEGER -* The total number of merging levels in the overall divide and -* conquer tree. -* -* CURLVL (input) INTEGER -* The current level in the overall merge routine, -* 0 <= curlvl <= tlvls. -* -* CURPBM (input) INTEGER -* The current problem in the current level in the overall -* merge routine (counting from upper left to lower right). -* -* PRMPTR (input) INTEGER array, dimension (N lg N) -* Contains a list of pointers which indicate where in PERM a -* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) -* indicates the size of the permutation and incidentally the -* size of the full, non-deflated problem. -* -* PERM (input) INTEGER array, dimension (N lg N) -* Contains the permutations (from deflation and sorting) to be -* applied to each eigenblock. -* -* GIVPTR (input) INTEGER array, dimension (N lg N) -* Contains a list of pointers which indicate where in GIVCOL a -* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) -* indicates the number of Givens rotations. -* -* GIVCOL (input) INTEGER array, dimension (2, N lg N) -* Each pair of numbers indicates a pair of columns to take place -* in a Givens rotation. -* -* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N) -* Each number indicates the S value to be used in the -* corresponding Givens rotation. -* -* Q (input) DOUBLE PRECISION array, dimension (N**2) -* Contains the square eigenblocks from previous levels, the -* starting positions for blocks are given by QPTR. -* -* QPTR (input) INTEGER array, dimension (N+2) -* Contains a list of pointers which indicate where in Q an -* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates -* the size of the block. -* -* Z (output) DOUBLE PRECISION array, dimension (N) -* On output this vector contains the updating vector (the last -* row of the first sub-eigenvector matrix and the first row of -* the second sub-eigenvector matrix). -* -* ZTEMP (workspace) DOUBLE PRECISION array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* Based on contributions by -* Jeff Rutter, Computer Science Division, University of California -* at Berkeley, USA -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2, - $ PTR, ZPTR1 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DROT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, INT, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( N.LT.0 ) THEN - INFO = -1 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAEDA', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine location of first number in second half. -* - MID = N / 2 + 1 -* -* Gather last/first rows of appropriate eigenblocks into center of Z -* - PTR = 1 -* -* Determine location of lowest level subproblem in the full storage -* scheme -* - CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1 -* -* Determine size of these matrices. We add HALF to the value of -* the SQRT in case the machine underestimates one of these square -* roots. -* - BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) ) - BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) ) - DO 10 K = 1, MID - BSIZ1 - 1 - Z( K ) = ZERO - 10 CONTINUE - CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1, - $ Z( MID-BSIZ1 ), 1 ) - CALL DCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 ) - DO 20 K = MID + BSIZ2, N - Z( K ) = ZERO - 20 CONTINUE -* -* Loop thru remaining levels 1 -> CURLVL applying the Givens -* rotations and permutation and then multiplying the center matrices -* against the current Z. -* - PTR = 2**TLVLS + 1 - DO 70 K = 1, CURLVL - 1 - CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1 - PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR ) - PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 ) - ZPTR1 = MID - PSIZ1 -* -* Apply Givens at CURR and CURR+1 -* - DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1 - CALL DROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1, - $ Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ), - $ GIVNUM( 2, I ) ) - 30 CONTINUE - DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1 - CALL DROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1, - $ Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ), - $ GIVNUM( 2, I ) ) - 40 CONTINUE - PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR ) - PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 ) - DO 50 I = 0, PSIZ1 - 1 - ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 ) - 50 CONTINUE - DO 60 I = 0, PSIZ2 - 1 - ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 ) - 60 CONTINUE -* -* Multiply Blocks at CURR and CURR+1 -* -* Determine size of these matrices. We add HALF to the value of -* the SQRT in case the machine underestimates one of these -* square roots. -* - BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) ) - BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+ - $ 1 ) ) ) ) - IF( BSIZ1.GT.0 ) THEN - CALL DGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ), - $ BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 ) - END IF - CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ), - $ 1 ) - IF( BSIZ2.GT.0 ) THEN - CALL DGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ), - $ BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 ) - END IF - CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1, - $ Z( MID+BSIZ2 ), 1 ) -* - PTR = PTR + 2**( TLVLS-K ) - 70 CONTINUE -* - RETURN -* -* End of DLAEDA -* - END diff --git a/quantum_espresso/kcp/flib/lapack_atlas.f b/quantum_espresso/kcp/flib/lapack_atlas.f deleted file mode 100644 index 16969fe58..000000000 --- a/quantum_espresso/kcp/flib/lapack_atlas.f +++ /dev/null @@ -1,53436 +0,0 @@ -c -c This file contains LAPACK routines used in quantum-espresso -c that are not part of ATLAS - from www.netlib.org -c - SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION AP( * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DSPTRS solves a system of linear equations A*X = B with a real -* symmetric matrix A stored in packed format using the factorization -* A = U*D*U**T or A = L*D*L**T computed by DSPTRF. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the details of the factorization are stored -* as an upper or lower triangular matrix. -* = 'U': Upper triangular, form is A = U*D*U**T; -* = 'L': Lower triangular, form is A = L*D*L**T. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) -* The block diagonal matrix D and the multipliers used to -* obtain the factor U or L as computed by DSPTRF, stored as a -* packed triangular matrix. -* -* IPIV (input) INTEGER array, dimension (N) -* Details of the interchanges and the block structure of D -* as determined by DSPTRF. -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, K, KC, KP - DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSPTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Solve A*X = B, where A = U*D*U'. -* -* First solve U*D*X = B, overwriting B with X. -* -* K is the main loop index, decreasing from N to 1 in steps of -* 1 or 2, depending on the size of the diagonal blocks. -* - K = N - KC = N*( N+1 ) / 2 + 1 - 10 CONTINUE -* -* If K < 1, exit from loop. -* - IF( K.LT.1 ) - $ GO TO 30 -* - KC = KC - K - IF( IPIV( K ).GT.0 ) THEN -* -* 1 x 1 diagonal block -* -* Interchange rows K and IPIV(K). -* - KP = IPIV( K ) - IF( KP.NE.K ) - $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) -* -* Multiply by inv(U(K)), where U(K) is the transformation -* stored in column K of A. -* - CALL DGER( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB, - $ B( 1, 1 ), LDB ) -* -* Multiply by the inverse of the diagonal block. -* - CALL DSCAL( NRHS, ONE / AP( KC+K-1 ), B( K, 1 ), LDB ) - K = K - 1 - ELSE -* -* 2 x 2 diagonal block -* -* Interchange rows K-1 and -IPIV(K). -* - KP = -IPIV( K ) - IF( KP.NE.K-1 ) - $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) -* -* Multiply by inv(U(K)), where U(K) is the transformation -* stored in columns K-1 and K of A. -* - CALL DGER( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB, - $ B( 1, 1 ), LDB ) - CALL DGER( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1, - $ B( K-1, 1 ), LDB, B( 1, 1 ), LDB ) -* -* Multiply by the inverse of the diagonal block. -* - AKM1K = AP( KC+K-2 ) - AKM1 = AP( KC-1 ) / AKM1K - AK = AP( KC+K-1 ) / AKM1K - DENOM = AKM1*AK - ONE - DO 20 J = 1, NRHS - BKM1 = B( K-1, J ) / AKM1K - BK = B( K, J ) / AKM1K - B( K-1, J ) = ( AK*BKM1-BK ) / DENOM - B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM - 20 CONTINUE - KC = KC - K + 1 - K = K - 2 - END IF -* - GO TO 10 - 30 CONTINUE -* -* Next solve U'*X = B, overwriting B with X. -* -* K is the main loop index, increasing from 1 to N in steps of -* 1 or 2, depending on the size of the diagonal blocks. -* - K = 1 - KC = 1 - 40 CONTINUE -* -* If K > N, exit from loop. -* - IF( K.GT.N ) - $ GO TO 50 -* - IF( IPIV( K ).GT.0 ) THEN -* -* 1 x 1 diagonal block -* -* Multiply by inv(U'(K)), where U(K) is the transformation -* stored in column K of A. -* - CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ), - $ 1, ONE, B( K, 1 ), LDB ) -* -* Interchange rows K and IPIV(K). -* - KP = IPIV( K ) - IF( KP.NE.K ) - $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) - KC = KC + K - K = K + 1 - ELSE -* -* 2 x 2 diagonal block -* -* Multiply by inv(U'(K+1)), where U(K+1) is the transformation -* stored in columns K and K+1 of A. -* - CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ), - $ 1, ONE, B( K, 1 ), LDB ) - CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, - $ AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB ) -* -* Interchange rows K and -IPIV(K). -* - KP = -IPIV( K ) - IF( KP.NE.K ) - $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) - KC = KC + 2*K + 1 - K = K + 2 - END IF -* - GO TO 40 - 50 CONTINUE -* - ELSE -* -* Solve A*X = B, where A = L*D*L'. -* -* First solve L*D*X = B, overwriting B with X. -* -* K is the main loop index, increasing from 1 to N in steps of -* 1 or 2, depending on the size of the diagonal blocks. -* - K = 1 - KC = 1 - 60 CONTINUE -* -* If K > N, exit from loop. -* - IF( K.GT.N ) - $ GO TO 80 -* - IF( IPIV( K ).GT.0 ) THEN -* -* 1 x 1 diagonal block -* -* Interchange rows K and IPIV(K). -* - KP = IPIV( K ) - IF( KP.NE.K ) - $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) -* -* Multiply by inv(L(K)), where L(K) is the transformation -* stored in column K of A. -* - IF( K.LT.N ) - $ CALL DGER( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ), - $ LDB, B( K+1, 1 ), LDB ) -* -* Multiply by the inverse of the diagonal block. -* - CALL DSCAL( NRHS, ONE / AP( KC ), B( K, 1 ), LDB ) - KC = KC + N - K + 1 - K = K + 1 - ELSE -* -* 2 x 2 diagonal block -* -* Interchange rows K+1 and -IPIV(K). -* - KP = -IPIV( K ) - IF( KP.NE.K+1 ) - $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) -* -* Multiply by inv(L(K)), where L(K) is the transformation -* stored in columns K and K+1 of A. -* - IF( K.LT.N-1 ) THEN - CALL DGER( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ), - $ LDB, B( K+2, 1 ), LDB ) - CALL DGER( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1, - $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) - END IF -* -* Multiply by the inverse of the diagonal block. -* - AKM1K = AP( KC+1 ) - AKM1 = AP( KC ) / AKM1K - AK = AP( KC+N-K+1 ) / AKM1K - DENOM = AKM1*AK - ONE - DO 70 J = 1, NRHS - BKM1 = B( K, J ) / AKM1K - BK = B( K+1, J ) / AKM1K - B( K, J ) = ( AK*BKM1-BK ) / DENOM - B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM - 70 CONTINUE - KC = KC + 2*( N-K ) + 1 - K = K + 2 - END IF -* - GO TO 60 - 80 CONTINUE -* -* Next solve L'*X = B, overwriting B with X. -* -* K is the main loop index, decreasing from N to 1 in steps of -* 1 or 2, depending on the size of the diagonal blocks. -* - K = N - KC = N*( N+1 ) / 2 + 1 - 90 CONTINUE -* -* If K < 1, exit from loop. -* - IF( K.LT.1 ) - $ GO TO 100 -* - KC = KC - ( N-K+1 ) - IF( IPIV( K ).GT.0 ) THEN -* -* 1 x 1 diagonal block -* -* Multiply by inv(L'(K)), where L(K) is the transformation -* stored in column K of A. -* - IF( K.LT.N ) - $ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), - $ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB ) -* -* Interchange rows K and IPIV(K). -* - KP = IPIV( K ) - IF( KP.NE.K ) - $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) - K = K - 1 - ELSE -* -* 2 x 2 diagonal block -* -* Multiply by inv(L'(K-1)), where L(K-1) is the transformation -* stored in columns K-1 and K of A. -* - IF( K.LT.N ) THEN - CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), - $ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB ) - CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), - $ LDB, AP( KC-( N-K ) ), 1, ONE, B( K-1, 1 ), - $ LDB ) - END IF -* -* Interchange rows K and -IPIV(K). -* - KP = -IPIV( K ) - IF( KP.NE.K ) - $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) - KC = KC - ( N-K+2 ) - K = K - 2 - END IF -* - GO TO 90 - 100 CONTINUE - END IF -* - RETURN -* -* End of DSPTRS -* - END - SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION AP( * ) -* .. -* -* Purpose -* ======= -* -* DSPTRF computes the factorization of a real symmetric matrix A stored -* in packed format using the Bunch-Kaufman diagonal pivoting method: -* -* A = U*D*U**T or A = L*D*L**T -* -* where U (or L) is a product of permutation and unit upper (lower) -* triangular matrices, and D is symmetric and block diagonal with -* 1-by-1 and 2-by-2 diagonal blocks. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) -* On entry, the upper or lower triangle of the symmetric matrix -* A, packed columnwise in a linear array. The j-th column of A -* is stored in the array AP as follows: -* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; -* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. -* -* On exit, the block diagonal matrix D and the multipliers used -* to obtain the factor U or L, stored as a packed triangular -* matrix overwriting A (see below for further details). -* -* IPIV (output) INTEGER array, dimension (N) -* Details of the interchanges and the block structure of D. -* If IPIV(k) > 0, then rows and columns k and IPIV(k) were -* interchanged and D(k,k) is a 1-by-1 diagonal block. -* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, D(i,i) is exactly zero. The factorization -* has been completed, but the block diagonal matrix D is -* exactly singular, and division by zero will occur if it -* is used to solve a system of equations. -* -* Further Details -* =============== -* -* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services -* Company -* -* If UPLO = 'U', then A = U*D*U', where -* U = P(n)*U(n)* ... *P(k)U(k)* ..., -* i.e., U is a product of terms P(k)*U(k), where k decreases from n to -* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 -* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as -* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such -* that if the diagonal block D(k) is of order s (s = 1 or 2), then -* -* ( I v 0 ) k-s -* U(k) = ( 0 I 0 ) s -* ( 0 0 I ) n-k -* k-s s n-k -* -* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). -* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), -* and A(k,k), and v overwrites A(1:k-2,k-1:k). -* -* If UPLO = 'L', then A = L*D*L', where -* L = P(1)*L(1)* ... *P(k)*L(k)* ..., -* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to -* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 -* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as -* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such -* that if the diagonal block D(k) is of order s (s = 1 or 2), then -* -* ( I 0 0 ) k-1 -* L(k) = ( 0 I 0 ) s -* ( 0 v I ) n-k-s+1 -* k-1 s n-k-s+1 -* -* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). -* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), -* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION EIGHT, SEVTEN - PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC, - $ KSTEP, KX, NPP - DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, - $ ROWMAX, T, WK, WKM1, WKP1 -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - EXTERNAL LSAME, IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DSPR, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSPTRF', -INFO ) - RETURN - END IF -* -* Initialize ALPHA for use in choosing pivot block size. -* - ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT -* - IF( UPPER ) THEN -* -* Factorize A as U*D*U' using the upper triangle of A -* -* K is the main loop index, decreasing from N to 1 in steps of -* 1 or 2 -* - K = N - KC = ( N-1 )*N / 2 + 1 - 10 CONTINUE - KNC = KC -* -* If K < 1, exit from loop -* - IF( K.LT.1 ) - $ GO TO 110 - KSTEP = 1 -* -* Determine rows and columns to be interchanged and whether -* a 1-by-1 or 2-by-2 pivot block will be used -* - ABSAKK = ABS( AP( KC+K-1 ) ) -* -* IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value -* - IF( K.GT.1 ) THEN - IMAX = IDAMAX( K-1, AP( KC ), 1 ) - COLMAX = ABS( AP( KC+IMAX-1 ) ) - ELSE - COLMAX = ZERO - END IF -* - IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN -* -* Column K is zero: set INFO and continue -* - IF( INFO.EQ.0 ) - $ INFO = K - KP = K - ELSE - IF( ABSAKK.GE.ALPHA*COLMAX ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE -* -* JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value -* - ROWMAX = ZERO - JMAX = IMAX - KX = IMAX*( IMAX+1 ) / 2 + IMAX - DO 20 J = IMAX + 1, K - IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN - ROWMAX = ABS( AP( KX ) ) - JMAX = J - END IF - KX = KX + J - 20 CONTINUE - KPC = ( IMAX-1 )*IMAX / 2 + 1 - IF( IMAX.GT.1 ) THEN - JMAX = IDAMAX( IMAX-1, AP( KPC ), 1 ) - ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-1 ) ) ) - END IF -* - IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE IF( ABS( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN -* -* interchange rows and columns K and IMAX, use 1-by-1 -* pivot block -* - KP = IMAX - ELSE -* -* interchange rows and columns K-1 and IMAX, use 2-by-2 -* pivot block -* - KP = IMAX - KSTEP = 2 - END IF - END IF -* - KK = K - KSTEP + 1 - IF( KSTEP.EQ.2 ) - $ KNC = KNC - K + 1 - IF( KP.NE.KK ) THEN -* -* Interchange rows and columns KK and KP in the leading -* submatrix A(1:k,1:k) -* - CALL DSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 ) - KX = KPC + KP - 1 - DO 30 J = KP + 1, KK - 1 - KX = KX + J - 1 - T = AP( KNC+J-1 ) - AP( KNC+J-1 ) = AP( KX ) - AP( KX ) = T - 30 CONTINUE - T = AP( KNC+KK-1 ) - AP( KNC+KK-1 ) = AP( KPC+KP-1 ) - AP( KPC+KP-1 ) = T - IF( KSTEP.EQ.2 ) THEN - T = AP( KC+K-2 ) - AP( KC+K-2 ) = AP( KC+KP-1 ) - AP( KC+KP-1 ) = T - END IF - END IF -* -* Update the leading submatrix -* - IF( KSTEP.EQ.1 ) THEN -* -* 1-by-1 pivot block D(k): column k now holds -* -* W(k) = U(k)*D(k) -* -* where U(k) is the k-th column of U -* -* Perform a rank-1 update of A(1:k-1,1:k-1) as -* -* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' -* - R1 = ONE / AP( KC+K-1 ) - CALL DSPR( UPLO, K-1, -R1, AP( KC ), 1, AP ) -* -* Store U(k) in column k -* - CALL DSCAL( K-1, R1, AP( KC ), 1 ) - ELSE -* -* 2-by-2 pivot block D(k): columns k and k-1 now hold -* -* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) -* -* where U(k) and U(k-1) are the k-th and (k-1)-th columns -* of U -* -* Perform a rank-2 update of A(1:k-2,1:k-2) as -* -* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' -* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' -* - IF( K.GT.2 ) THEN -* - D12 = AP( K-1+( K-1 )*K / 2 ) - D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 - D11 = AP( K+( K-1 )*K / 2 ) / D12 - T = ONE / ( D11*D22-ONE ) - D12 = T / D12 -* - DO 50 J = K - 2, 1, -1 - WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ AP( J+( K-1 )*K / 2 ) ) - WK = D12*( D22*AP( J+( K-1 )*K / 2 )- - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) - DO 40 I = J, 1, -1 - AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - - $ AP( I+( K-1 )*K / 2 )*WK - - $ AP( I+( K-2 )*( K-1 ) / 2 )*WKM1 - 40 CONTINUE - AP( J+( K-1 )*K / 2 ) = WK - AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1 - 50 CONTINUE -* - END IF -* - END IF - END IF -* -* Store details of the interchanges in IPIV -* - IF( KSTEP.EQ.1 ) THEN - IPIV( K ) = KP - ELSE - IPIV( K ) = -KP - IPIV( K-1 ) = -KP - END IF -* -* Decrease K and return to the start of the main loop -* - K = K - KSTEP - KC = KNC - K - GO TO 10 -* - ELSE -* -* Factorize A as L*D*L' using the lower triangle of A -* -* K is the main loop index, increasing from 1 to N in steps of -* 1 or 2 -* - K = 1 - KC = 1 - NPP = N*( N+1 ) / 2 - 60 CONTINUE - KNC = KC -* -* If K > N, exit from loop -* - IF( K.GT.N ) - $ GO TO 110 - KSTEP = 1 -* -* Determine rows and columns to be interchanged and whether -* a 1-by-1 or 2-by-2 pivot block will be used -* - ABSAKK = ABS( AP( KC ) ) -* -* IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value -* - IF( K.LT.N ) THEN - IMAX = K + IDAMAX( N-K, AP( KC+1 ), 1 ) - COLMAX = ABS( AP( KC+IMAX-K ) ) - ELSE - COLMAX = ZERO - END IF -* - IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN -* -* Column K is zero: set INFO and continue -* - IF( INFO.EQ.0 ) - $ INFO = K - KP = K - ELSE - IF( ABSAKK.GE.ALPHA*COLMAX ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE -* -* JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value -* - ROWMAX = ZERO - KX = KC + IMAX - K - DO 70 J = K, IMAX - 1 - IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN - ROWMAX = ABS( AP( KX ) ) - JMAX = J - END IF - KX = KX + N - J - 70 CONTINUE - KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1 - IF( IMAX.LT.N ) THEN - JMAX = IMAX + IDAMAX( N-IMAX, AP( KPC+1 ), 1 ) - ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-IMAX ) ) ) - END IF -* - IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE IF( ABS( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN -* -* interchange rows and columns K and IMAX, use 1-by-1 -* pivot block -* - KP = IMAX - ELSE -* -* interchange rows and columns K+1 and IMAX, use 2-by-2 -* pivot block -* - KP = IMAX - KSTEP = 2 - END IF - END IF -* - KK = K + KSTEP - 1 - IF( KSTEP.EQ.2 ) - $ KNC = KNC + N - K + 1 - IF( KP.NE.KK ) THEN -* -* Interchange rows and columns KK and KP in the trailing -* submatrix A(k:n,k:n) -* - IF( KP.LT.N ) - $ CALL DSWAP( N-KP, AP( KNC+KP-KK+1 ), 1, AP( KPC+1 ), - $ 1 ) - KX = KNC + KP - KK - DO 80 J = KK + 1, KP - 1 - KX = KX + N - J + 1 - T = AP( KNC+J-KK ) - AP( KNC+J-KK ) = AP( KX ) - AP( KX ) = T - 80 CONTINUE - T = AP( KNC ) - AP( KNC ) = AP( KPC ) - AP( KPC ) = T - IF( KSTEP.EQ.2 ) THEN - T = AP( KC+1 ) - AP( KC+1 ) = AP( KC+KP-K ) - AP( KC+KP-K ) = T - END IF - END IF -* -* Update the trailing submatrix -* - IF( KSTEP.EQ.1 ) THEN -* -* 1-by-1 pivot block D(k): column k now holds -* -* W(k) = L(k)*D(k) -* -* where L(k) is the k-th column of L -* - IF( K.LT.N ) THEN -* -* Perform a rank-1 update of A(k+1:n,k+1:n) as -* -* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' -* - R1 = ONE / AP( KC ) - CALL DSPR( UPLO, N-K, -R1, AP( KC+1 ), 1, - $ AP( KC+N-K+1 ) ) -* -* Store L(k) in column K -* - CALL DSCAL( N-K, R1, AP( KC+1 ), 1 ) - END IF - ELSE -* -* 2-by-2 pivot block D(k): columns K and K+1 now hold -* -* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) -* -* where L(k) and L(k+1) are the k-th and (k+1)-th columns -* of L -* - IF( K.LT.N-1 ) THEN -* -* Perform a rank-2 update of A(k+2:n,k+2:n) as -* -* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' -* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' -* - D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 ) - D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 - D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 - T = ONE / ( D11*D22-ONE ) - D21 = T / D21 -* - DO 100 J = K + 2, N - WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) - WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) -* - DO 90 I = J, N - AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* - $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / - $ 2 )*WK - AP( I+K*( 2*N-K-1 ) / 2 )*WKP1 - 90 CONTINUE -* - AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK - AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1 -* - 100 CONTINUE - END IF - END IF - END IF -* -* Store details of the interchanges in IPIV -* - IF( KSTEP.EQ.1 ) THEN - IPIV( K ) = KP - ELSE - IPIV( K ) = -KP - IPIV( K+1 ) = -KP - END IF -* -* Increase K and return to the start of the main loop -* - K = K + KSTEP - KC = KNC + N - K + 2 - GO TO 60 -* - END IF -* - 110 CONTINUE - RETURN -* -* End of DSPTRF -* - END - SUBROUTINE DLASRT( ID, N, D, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER ID - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ) -* .. -* -* Purpose -* ======= -* -* Sort the numbers in D in increasing order (if ID = 'I') or -* in decreasing order (if ID = 'D' ). -* -* Use Quick Sort, reverting to Insertion sort on arrays of -* size <= 20. Dimension of STACK limits N to about 2**32. -* -* Arguments -* ========= -* -* ID (input) CHARACTER*1 -* = 'I': sort D in increasing order; -* = 'D': sort D in decreasing order. -* -* N (input) INTEGER -* The length of the array D. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the array to be sorted. -* On exit, D has been sorted into increasing order -* (D(1) <= ... <= D(N) ) or into decreasing order -* (D(1) >= ... >= D(N) ), depending on ID. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER SELECT - PARAMETER ( SELECT = 20 ) -* .. -* .. Local Scalars .. - INTEGER DIR, ENDD, I, J, START, STKPNT - DOUBLE PRECISION D1, D2, D3, DMNMX, TMP -* .. -* .. Local Arrays .. - INTEGER STACK( 2, 32 ) -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input paramters. -* - INFO = 0 - DIR = -1 - IF( LSAME( ID, 'D' ) ) THEN - DIR = 0 - ELSE IF( LSAME( ID, 'I' ) ) THEN - DIR = 1 - END IF - IF( DIR.EQ.-1 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASRT', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.1 ) - $ RETURN -* - STKPNT = 1 - STACK( 1, 1 ) = 1 - STACK( 2, 1 ) = N - 10 CONTINUE - START = STACK( 1, STKPNT ) - ENDD = STACK( 2, STKPNT ) - STKPNT = STKPNT - 1 - IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN -* -* Do Insertion sort on D( START:ENDD ) -* - IF( DIR.EQ.0 ) THEN -* -* Sort into decreasing order -* - DO 30 I = START + 1, ENDD - DO 20 J = I, START + 1, -1 - IF( D( J ).GT.D( J-1 ) ) THEN - DMNMX = D( J ) - D( J ) = D( J-1 ) - D( J-1 ) = DMNMX - ELSE - GO TO 30 - END IF - 20 CONTINUE - 30 CONTINUE -* - ELSE -* -* Sort into increasing order -* - DO 50 I = START + 1, ENDD - DO 40 J = I, START + 1, -1 - IF( D( J ).LT.D( J-1 ) ) THEN - DMNMX = D( J ) - D( J ) = D( J-1 ) - D( J-1 ) = DMNMX - ELSE - GO TO 50 - END IF - 40 CONTINUE - 50 CONTINUE -* - END IF -* - ELSE IF( ENDD-START.GT.SELECT ) THEN -* -* Partition D( START:ENDD ) and stack parts, largest one first -* -* Choose partition entry as median of 3 -* - D1 = D( START ) - D2 = D( ENDD ) - I = ( START+ENDD ) / 2 - D3 = D( I ) - IF( D1.LT.D2 ) THEN - IF( D3.LT.D1 ) THEN - DMNMX = D1 - ELSE IF( D3.LT.D2 ) THEN - DMNMX = D3 - ELSE - DMNMX = D2 - END IF - ELSE - IF( D3.LT.D2 ) THEN - DMNMX = D2 - ELSE IF( D3.LT.D1 ) THEN - DMNMX = D3 - ELSE - DMNMX = D1 - END IF - END IF -* - IF( DIR.EQ.0 ) THEN -* -* Sort into decreasing order -* - I = START - 1 - J = ENDD + 1 - 60 CONTINUE - 70 CONTINUE - J = J - 1 - IF( D( J ).LT.DMNMX ) - $ GO TO 70 - 80 CONTINUE - I = I + 1 - IF( D( I ).GT.DMNMX ) - $ GO TO 80 - IF( I.LT.J ) THEN - TMP = D( I ) - D( I ) = D( J ) - D( J ) = TMP - GO TO 60 - END IF - IF( J-START.GT.ENDD-J-1 ) THEN - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - ELSE - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - END IF - ELSE -* -* Sort into increasing order -* - I = START - 1 - J = ENDD + 1 - 90 CONTINUE - 100 CONTINUE - J = J - 1 - IF( D( J ).GT.DMNMX ) - $ GO TO 100 - 110 CONTINUE - I = I + 1 - IF( D( I ).LT.DMNMX ) - $ GO TO 110 - IF( I.LT.J ) THEN - TMP = D( I ) - D( I ) = D( J ) - D( J ) = TMP - GO TO 90 - END IF - IF( J-START.GT.ENDD-J-1 ) THEN - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - ELSE - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - END IF - END IF - END IF - IF( STKPNT.GT.0 ) - $ GO TO 10 - RETURN -* -* End of DLASRT -* - END - SUBROUTINE DLARTG( F, G, CS, SN, R ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - DOUBLE PRECISION CS, F, G, R, SN -* .. -* -* Purpose -* ======= -* -* DLARTG generate a plane rotation so that -* -* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. -* [ -SN CS ] [ G ] [ 0 ] -* -* This is a slower, more accurate version of the BLAS1 routine DROTG, -* with the following other differences: -* F and G are unchanged on return. -* If G=0, then CS=1 and SN=0. -* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any -* floating point operations (saves work in DBDSQR when -* there are zeros on the diagonal). -* -* If F exceeds G in magnitude, CS will be positive. -* -* Arguments -* ========= -* -* F (input) DOUBLE PRECISION -* The first component of vector to be rotated. -* -* G (input) DOUBLE PRECISION -* The second component of vector to be rotated. -* -* CS (output) DOUBLE PRECISION -* The cosine of the rotation. -* -* SN (output) DOUBLE PRECISION -* The sine of the rotation. -* -* R (output) DOUBLE PRECISION -* The nonzero component of the rotated vector. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL FIRST - INTEGER COUNT, I - DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, INT, LOG, MAX, SQRT -* .. -* .. Save statement .. - SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - SAFMIN = DLAMCH( 'S' ) - EPS = DLAMCH( 'E' ) - SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / - $ LOG( DLAMCH( 'B' ) ) / TWO ) - SAFMX2 = ONE / SAFMN2 - END IF - IF( G.EQ.ZERO ) THEN - CS = ONE - SN = ZERO - R = F - ELSE IF( F.EQ.ZERO ) THEN - CS = ZERO - SN = ONE - R = G - ELSE - F1 = F - G1 = G - SCALE = MAX( ABS( F1 ), ABS( G1 ) ) - IF( SCALE.GE.SAFMX2 ) THEN - COUNT = 0 - 10 CONTINUE - COUNT = COUNT + 1 - F1 = F1*SAFMN2 - G1 = G1*SAFMN2 - SCALE = MAX( ABS( F1 ), ABS( G1 ) ) - IF( SCALE.GE.SAFMX2 ) - $ GO TO 10 - R = SQRT( F1**2+G1**2 ) - CS = F1 / R - SN = G1 / R - DO 20 I = 1, COUNT - R = R*SAFMX2 - 20 CONTINUE - ELSE IF( SCALE.LE.SAFMN2 ) THEN - COUNT = 0 - 30 CONTINUE - COUNT = COUNT + 1 - F1 = F1*SAFMX2 - G1 = G1*SAFMX2 - SCALE = MAX( ABS( F1 ), ABS( G1 ) ) - IF( SCALE.LE.SAFMN2 ) - $ GO TO 30 - R = SQRT( F1**2+G1**2 ) - CS = F1 / R - SN = G1 / R - DO 40 I = 1, COUNT - R = R*SAFMN2 - 40 CONTINUE - ELSE - R = SQRT( F1**2+G1**2 ) - CS = F1 / R - SN = G1 / R - END IF - IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN - CS = -CS - SN = -SN - R = -R - END IF - END IF - RETURN -* -* End of DLARTG -* - END - DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. -* -* Purpose -* ======= -* -* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary -* overflow. -* -* Arguments -* ========= -* -* X (input) DOUBLE PRECISION -* Y (input) DOUBLE PRECISION -* X and Y specify the values x and y. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION W, XABS, YABS, Z -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - XABS = ABS( X ) - YABS = ABS( Y ) - W = MAX( XABS, YABS ) - Z = MIN( XABS, YABS ) - IF( Z.EQ.ZERO ) THEN - DLAPY2 = W - ELSE - DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) - END IF - RETURN -* -* End of DLAPY2 -* - END - SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B, C, RT1, RT2 -* .. -* -* Purpose -* ======= -* -* DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix -* [ A B ] -* [ B C ]. -* On return, RT1 is the eigenvalue of larger absolute value, and RT2 -* is the eigenvalue of smaller absolute value. -* -* Arguments -* ========= -* -* A (input) DOUBLE PRECISION -* The (1,1) element of the 2-by-2 matrix. -* -* B (input) DOUBLE PRECISION -* The (1,2) and (2,1) elements of the 2-by-2 matrix. -* -* C (input) DOUBLE PRECISION -* The (2,2) element of the 2-by-2 matrix. -* -* RT1 (output) DOUBLE PRECISION -* The eigenvalue of larger absolute value. -* -* RT2 (output) DOUBLE PRECISION -* The eigenvalue of smaller absolute value. -* -* Further Details -* =============== -* -* RT1 is accurate to a few ulps barring over/underflow. -* -* RT2 may be inaccurate if there is massive cancellation in the -* determinant A*C-B*B; higher precision or correctly rounded or -* correctly truncated arithmetic would be needed to compute RT2 -* accurately in all cases. -* -* Overflow is possible only if RT1 is within a factor of 5 of overflow. -* Underflow is harmless if the input data is 0 or exceeds -* underflow_threshold / macheps. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION HALF - PARAMETER ( HALF = 0.5D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* -* Compute the eigenvalues -* - SM = A + C - DF = A - C - ADF = ABS( DF ) - TB = B + B - AB = ABS( TB ) - IF( ABS( A ).GT.ABS( C ) ) THEN - ACMX = A - ACMN = C - ELSE - ACMX = C - ACMN = A - END IF - IF( ADF.GT.AB ) THEN - RT = ADF*SQRT( ONE+( AB / ADF )**2 ) - ELSE IF( ADF.LT.AB ) THEN - RT = AB*SQRT( ONE+( ADF / AB )**2 ) - ELSE -* -* Includes case AB=ADF=0 -* - RT = AB*SQRT( TWO ) - END IF - IF( SM.LT.ZERO ) THEN - RT1 = HALF*( SM-RT ) -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE IF( SM.GT.ZERO ) THEN - RT1 = HALF*( SM+RT ) -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE -* -* Includes case RT1 = RT2 = 0 -* - RT1 = HALF*RT - RT2 = -HALF*RT - END IF - RETURN -* -* End of DLAE2 -* - END - SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 -* .. -* -* Purpose -* ======= -* -* DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix -* [ A B ] -* [ B C ]. -* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the -* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right -* eigenvector for RT1, giving the decomposition -* -* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] -* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. -* -* Arguments -* ========= -* -* A (input) DOUBLE PRECISION -* The (1,1) element of the 2-by-2 matrix. -* -* B (input) DOUBLE PRECISION -* The (1,2) element and the conjugate of the (2,1) element of -* the 2-by-2 matrix. -* -* C (input) DOUBLE PRECISION -* The (2,2) element of the 2-by-2 matrix. -* -* RT1 (output) DOUBLE PRECISION -* The eigenvalue of larger absolute value. -* -* RT2 (output) DOUBLE PRECISION -* The eigenvalue of smaller absolute value. -* -* CS1 (output) DOUBLE PRECISION -* SN1 (output) DOUBLE PRECISION -* The vector (CS1, SN1) is a unit right eigenvector for RT1. -* -* Further Details -* =============== -* -* RT1 is accurate to a few ulps barring over/underflow. -* -* RT2 may be inaccurate if there is massive cancellation in the -* determinant A*C-B*B; higher precision or correctly rounded or -* correctly truncated arithmetic would be needed to compute RT2 -* accurately in all cases. -* -* CS1 and SN1 are accurate to a few ulps barring over/underflow. -* -* Overflow is possible only if RT1 is within a factor of 5 of overflow. -* Underflow is harmless if the input data is 0 or exceeds -* underflow_threshold / macheps. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION HALF - PARAMETER ( HALF = 0.5D0 ) -* .. -* .. Local Scalars .. - INTEGER SGN1, SGN2 - DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, - $ TB, TN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* -* Compute the eigenvalues -* - SM = A + C - DF = A - C - ADF = ABS( DF ) - TB = B + B - AB = ABS( TB ) - IF( ABS( A ).GT.ABS( C ) ) THEN - ACMX = A - ACMN = C - ELSE - ACMX = C - ACMN = A - END IF - IF( ADF.GT.AB ) THEN - RT = ADF*SQRT( ONE+( AB / ADF )**2 ) - ELSE IF( ADF.LT.AB ) THEN - RT = AB*SQRT( ONE+( ADF / AB )**2 ) - ELSE -* -* Includes case AB=ADF=0 -* - RT = AB*SQRT( TWO ) - END IF - IF( SM.LT.ZERO ) THEN - RT1 = HALF*( SM-RT ) - SGN1 = -1 -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE IF( SM.GT.ZERO ) THEN - RT1 = HALF*( SM+RT ) - SGN1 = 1 -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE -* -* Includes case RT1 = RT2 = 0 -* - RT1 = HALF*RT - RT2 = -HALF*RT - SGN1 = 1 - END IF -* -* Compute the eigenvector -* - IF( DF.GE.ZERO ) THEN - CS = DF + RT - SGN2 = 1 - ELSE - CS = DF - RT - SGN2 = -1 - END IF - ACS = ABS( CS ) - IF( ACS.GT.AB ) THEN - CT = -TB / CS - SN1 = ONE / SQRT( ONE+CT*CT ) - CS1 = CT*SN1 - ELSE - IF( AB.EQ.ZERO ) THEN - CS1 = ONE - SN1 = ZERO - ELSE - TN = -CS / TB - CS1 = ONE / SQRT( ONE+TN*TN ) - SN1 = TN*CS1 - END IF - END IF - IF( SGN1.EQ.SGN2 ) THEN - TN = CS1 - CS1 = -SN1 - SN1 = TN - END IF - RETURN -* -* End of DLAEV2 -* - END - SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER TYPE - INTEGER INFO, KL, KU, LDA, M, N - DOUBLE PRECISION CFROM, CTO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASCL multiplies the M by N real matrix A by the real scalar -* CTO/CFROM. This is done without over/underflow as long as the final -* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that -* A may be full, upper triangular, lower triangular, upper Hessenberg, -* or banded. -* -* Arguments -* ========= -* -* TYPE (input) CHARACTER*1 -* TYPE indices the storage type of the input matrix. -* = 'G': A is a full matrix. -* = 'L': A is a lower triangular matrix. -* = 'U': A is an upper triangular matrix. -* = 'H': A is an upper Hessenberg matrix. -* = 'B': A is a symmetric band matrix with lower bandwidth KL -* and upper bandwidth KU and with the only the lower -* half stored. -* = 'Q': A is a symmetric band matrix with lower bandwidth KL -* and upper bandwidth KU and with the only the upper -* half stored. -* = 'Z': A is a band matrix with lower bandwidth KL and upper -* bandwidth KU. -* -* KL (input) INTEGER -* The lower bandwidth of A. Referenced only if TYPE = 'B', -* 'Q' or 'Z'. -* -* KU (input) INTEGER -* The upper bandwidth of A. Referenced only if TYPE = 'B', -* 'Q' or 'Z'. -* -* CFROM (input) DOUBLE PRECISION -* CTO (input) DOUBLE PRECISION -* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed -* without over/underflow if the final result CTO*A(I,J)/CFROM -* can be represented without over/underflow. CFROM must be -* nonzero. -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,M) -* The matrix to be multiplied by CTO/CFROM. See TYPE for the -* storage type. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* INFO (output) INTEGER -* 0 - successful exit -* <0 - if INFO = -i, the i-th argument had an illegal value. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL DONE - INTEGER I, ITYPE, J, K1, K2, K3, K4 - DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 -* - IF( LSAME( TYPE, 'G' ) ) THEN - ITYPE = 0 - ELSE IF( LSAME( TYPE, 'L' ) ) THEN - ITYPE = 1 - ELSE IF( LSAME( TYPE, 'U' ) ) THEN - ITYPE = 2 - ELSE IF( LSAME( TYPE, 'H' ) ) THEN - ITYPE = 3 - ELSE IF( LSAME( TYPE, 'B' ) ) THEN - ITYPE = 4 - ELSE IF( LSAME( TYPE, 'Q' ) ) THEN - ITYPE = 5 - ELSE IF( LSAME( TYPE, 'Z' ) ) THEN - ITYPE = 6 - ELSE - ITYPE = -1 - END IF -* - IF( ITYPE.EQ.-1 ) THEN - INFO = -1 - ELSE IF( CFROM.EQ.ZERO ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. - $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN - INFO = -7 - ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( ITYPE.GE.4 ) THEN - IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN - INFO = -2 - ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. - $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) - $ THEN - INFO = -3 - ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. - $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. - $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN - INFO = -9 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASCL', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -* -* Get machine parameters -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM -* - CFROMC = CFROM - CTOC = CTO -* - 10 CONTINUE - CFROM1 = CFROMC*SMLNUM - CTO1 = CTOC / BIGNUM - IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN - MUL = SMLNUM - DONE = .FALSE. - CFROMC = CFROM1 - ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN - MUL = BIGNUM - DONE = .FALSE. - CTOC = CTO1 - ELSE - MUL = CTOC / CFROMC - DONE = .TRUE. - END IF -* - IF( ITYPE.EQ.0 ) THEN -* -* Full matrix -* - DO 30 J = 1, N - DO 20 I = 1, M - A( I, J ) = A( I, J )*MUL - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( ITYPE.EQ.1 ) THEN -* -* Lower triangular matrix -* - DO 50 J = 1, N - DO 40 I = J, M - A( I, J ) = A( I, J )*MUL - 40 CONTINUE - 50 CONTINUE -* - ELSE IF( ITYPE.EQ.2 ) THEN -* -* Upper triangular matrix -* - DO 70 J = 1, N - DO 60 I = 1, MIN( J, M ) - A( I, J ) = A( I, J )*MUL - 60 CONTINUE - 70 CONTINUE -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* Upper Hessenberg matrix -* - DO 90 J = 1, N - DO 80 I = 1, MIN( J+1, M ) - A( I, J ) = A( I, J )*MUL - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( ITYPE.EQ.4 ) THEN -* -* Lower half of a symmetric band matrix -* - K3 = KL + 1 - K4 = N + 1 - DO 110 J = 1, N - DO 100 I = 1, MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 100 CONTINUE - 110 CONTINUE -* - ELSE IF( ITYPE.EQ.5 ) THEN -* -* Upper half of a symmetric band matrix -* - K1 = KU + 2 - K3 = KU + 1 - DO 130 J = 1, N - DO 120 I = MAX( K1-J, 1 ), K3 - A( I, J ) = A( I, J )*MUL - 120 CONTINUE - 130 CONTINUE -* - ELSE IF( ITYPE.EQ.6 ) THEN -* -* Band matrix -* - K1 = KL + KU + 2 - K2 = KL + 1 - K3 = 2*KL + KU + 1 - K4 = KL + KU + 1 + M - DO 150 J = 1, N - DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 140 CONTINUE - 150 CONTINUE -* - END IF -* - IF( .NOT.DONE ) - $ GO TO 10 -* - RETURN -* -* End of DLASCL -* - END - DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) -* .. -* -* Purpose -* ======= -* -* DLANST returns the value of the one norm, or the Frobenius norm, or -* the infinity norm, or the element of largest absolute value of a -* real symmetric tridiagonal matrix A. -* -* Description -* =========== -* -* DLANST returns the value -* -* DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' -* ( -* ( norm1(A), NORM = '1', 'O' or 'o' -* ( -* ( normI(A), NORM = 'I' or 'i' -* ( -* ( normF(A), NORM = 'F', 'f', 'E' or 'e' -* -* where norm1 denotes the one norm of a matrix (maximum column sum), -* normI denotes the infinity norm of a matrix (maximum row sum) and -* normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies the value to be returned in DLANST as described -* above. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. When N = 0, DLANST is -* set to zero. -* -* D (input) DOUBLE PRECISION array, dimension (N) -* The diagonal elements of A. -* -* E (input) DOUBLE PRECISION array, dimension (N-1) -* The (n-1) sub-diagonal or super-diagonal elements of A. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I - DOUBLE PRECISION ANORM, SCALE, SUM -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* - IF( N.LE.0 ) THEN - ANORM = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - ANORM = ABS( D( N ) ) - DO 10 I = 1, N - 1 - ANORM = MAX( ANORM, ABS( D( I ) ) ) - ANORM = MAX( ANORM, ABS( E( I ) ) ) - 10 CONTINUE - ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. - $ LSAME( NORM, 'I' ) ) THEN -* -* Find norm1(A). -* - IF( N.EQ.1 ) THEN - ANORM = ABS( D( 1 ) ) - ELSE - ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), - $ ABS( E( N-1 ) )+ABS( D( N ) ) ) - DO 20 I = 2, N - 1 - ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+ - $ ABS( E( I-1 ) ) ) - 20 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - IF( N.GT.1 ) THEN - CALL DLASSQ( N-1, E, 1, SCALE, SUM ) - SUM = 2*SUM - END IF - CALL DLASSQ( N, D, 1, SCALE, SUM ) - ANORM = SCALE*SQRT( SUM ) - END IF -* - DLANST = ANORM - RETURN -* -* End of DLANST -* - END - SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, M, N - COMPLEX*16 ALPHA, BETA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZLASET initializes a 2-D array A to BETA on the diagonal and -* ALPHA on the offdiagonals. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies the part of the matrix A to be set. -* = 'U': Upper triangular part is set. The lower triangle -* is unchanged. -* = 'L': Lower triangular part is set. The upper triangle -* is unchanged. -* Otherwise: All of the matrix A is set. -* -* M (input) INTEGER -* On entry, M specifies the number of rows of A. -* -* N (input) INTEGER -* On entry, N specifies the number of columns of A. -* -* ALPHA (input) COMPLEX*16 -* All the offdiagonal array elements are set to ALPHA. -* -* BETA (input) COMPLEX*16 -* All the diagonal array elements are set to BETA. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the m by n matrix A. -* On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; -* A(i,i) = BETA , 1 <= i <= min(m,n) -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Set the diagonal to BETA and the strictly upper triangular -* part of the array to ALPHA. -* - DO 20 J = 2, N - DO 10 I = 1, MIN( J-1, M ) - A( I, J ) = ALPHA - 10 CONTINUE - 20 CONTINUE - DO 30 I = 1, MIN( N, M ) - A( I, I ) = BETA - 30 CONTINUE -* - ELSE IF( LSAME( UPLO, 'L' ) ) THEN -* -* Set the diagonal to BETA and the strictly lower triangular -* part of the array to ALPHA. -* - DO 50 J = 1, MIN( M, N ) - DO 40 I = J + 1, M - A( I, J ) = ALPHA - 40 CONTINUE - 50 CONTINUE - DO 60 I = 1, MIN( N, M ) - A( I, I ) = BETA - 60 CONTINUE -* - ELSE -* -* Set the array to BETA on the diagonal and ALPHA on the -* offdiagonal. -* - DO 80 J = 1, N - DO 70 I = 1, M - A( I, J ) = ALPHA - 70 CONTINUE - 80 CONTINUE - DO 90 I = 1, MIN( M, N ) - A( I, I ) = BETA - 90 CONTINUE - END IF -* - RETURN -* -* End of ZLASET -* - END - DOUBLE COMPLEX FUNCTION ZLADIV( X, Y ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - COMPLEX*16 X, Y -* .. -* -* Purpose -* ======= -* -* ZLADIV := X / Y, where X and Y are complex. The computation of X / Y -* will not overflow on an intermediary step unless the results -* overflows. -* -* Arguments -* ========= -* -* X (input) COMPLEX*16 -* Y (input) COMPLEX*16 -* The complex scalars X and Y. -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION ZI, ZR -* .. -* .. External Subroutines .. - EXTERNAL DLADIV -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DIMAG -* .. -* .. Executable Statements .. -* - CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR, - $ ZI ) - ZLADIV = DCMPLX( ZR, ZI ) -* - RETURN -* -* End of ZLADIV -* - END - DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y, Z -* .. -* -* Purpose -* ======= -* -* DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause -* unnecessary overflow. -* -* Arguments -* ========= -* -* X (input) DOUBLE PRECISION -* Y (input) DOUBLE PRECISION -* Z (input) DOUBLE PRECISION -* X, Y and Z specify the values x, y and z. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION W, XABS, YABS, ZABS -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* - XABS = ABS( X ) - YABS = ABS( Y ) - ZABS = ABS( Z ) - W = MAX( XABS, YABS, ZABS ) - IF( W.EQ.ZERO ) THEN - DLAPY3 = ZERO - ELSE - DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ - $ ( ZABS / W )**2 ) - END IF - RETURN -* -* End of DLAPY3 -* - END - SUBROUTINE DLADIV( A, B, C, D, P, Q ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B, C, D, P, Q -* .. -* -* Purpose -* ======= -* -* DLADIV performs complex division in real arithmetic -* -* a + i*b -* p + i*q = --------- -* c + i*d -* -* The algorithm is due to Robert L. Smith and can be found -* in D. Knuth, The art of Computer Programming, Vol.2, p.195 -* -* Arguments -* ========= -* -* A (input) DOUBLE PRECISION -* B (input) DOUBLE PRECISION -* C (input) DOUBLE PRECISION -* D (input) DOUBLE PRECISION -* The scalars a, b, c, and d in the above expression. -* -* P (output) DOUBLE PRECISION -* Q (output) DOUBLE PRECISION -* The scalars p and q in the above expression. -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION E, F -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* - IF( ABS( D ).LT.ABS( C ) ) THEN - E = D / C - F = C + D*E - P = ( A+B*E ) / F - Q = ( B-A*E ) / F - ELSE - E = C / D - F = D + C*E - P = ( B+A*E ) / F - Q = ( -A+B*E ) / F - END IF -* - RETURN -* -* End of DLADIV -* - END - SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION SCALE, SUMSQ -* .. -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* Purpose -* ======= -* -* DLASSQ returns the values scl and smsq such that -* -* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, -* -* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is -* assumed to be non-negative and scl returns the value -* -* scl = max( scale, abs( x( i ) ) ). -* -* scale and sumsq must be supplied in SCALE and SUMSQ and -* scl and smsq are overwritten on SCALE and SUMSQ respectively. -* -* The routine makes only one pass through the vector x. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of elements to be used from the vector X. -* -* X (input) DOUBLE PRECISION array, dimension (N) -* The vector for which a scaled sum of squares is computed. -* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. -* -* INCX (input) INTEGER -* The increment between successive values of the vector X. -* INCX > 0. -* -* SCALE (input/output) DOUBLE PRECISION -* On entry, the value scale in the equation above. -* On exit, SCALE is overwritten with scl , the scaling factor -* for the sum of squares. -* -* SUMSQ (input/output) DOUBLE PRECISION -* On entry, the value sumsq in the equation above. -* On exit, SUMSQ is overwritten with smsq , the basic sum of -* squares from which scl has been factored out. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION ABSXI -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* - IF( N.GT.0 ) THEN - DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX - IF( X( IX ).NE.ZERO ) THEN - ABSXI = ABS( X( IX ) ) - IF( SCALE.LT.ABSXI ) THEN - SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 - SCALE = ABSXI - ELSE - SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 - END IF - END IF - 10 CONTINUE - END IF - RETURN -* -* End of DLASSQ -* - END - SUBROUTINE ZLACGV( N, X, INCX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - INTEGER INCX, N -* .. -* .. Array Arguments .. - COMPLEX*16 X( * ) -* .. -* -* Purpose -* ======= -* -* ZLACGV conjugates a complex vector of length N. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The length of the vector X. N >= 0. -* -* X (input/output) COMPLEX*16 array, dimension -* (1+(N-1)*abs(INCX)) -* On entry, the vector of length N to be conjugated. -* On exit, X is overwritten with conjg(X). -* -* INCX (input) INTEGER -* The spacing between successive elements of X. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IOFF -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* .. Executable Statements .. -* - IF( INCX.EQ.1 ) THEN - DO 10 I = 1, N - X( I ) = DCONJG( X( I ) ) - 10 CONTINUE - ELSE - IOFF = 1 - IF( INCX.LT.0 ) - $ IOFF = 1 - ( N-1 )*INCX - DO 20 I = 1, N - X( IOFF ) = DCONJG( X( IOFF ) ) - IOFF = IOFF + INCX - 20 CONTINUE - END IF - RETURN -* -* End of ZLACGV -* - END - INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, - $ N4 ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER*( * ) NAME, OPTS - INTEGER ISPEC, N1, N2, N3, N4 -* .. -* -* Purpose -* ======= -* -* ILAENV is called from the LAPACK routines to choose problem-dependent -* parameters for the local environment. See ISPEC for a description of -* the parameters. -* -* This version provides a set of parameters which should give good, -* but not optimal, performance on many of the currently available -* computers. Users are encouraged to modify this subroutine to set -* the tuning parameters for their particular machine using the option -* and problem size information in the arguments. -* -* This routine will not function correctly if it is converted to all -* lower case. Converting it to all upper case is allowed. -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies the parameter to be returned as the value of -* ILAENV. -* = 1: the optimal blocksize; if this value is 1, an unblocked -* algorithm will give the best performance. -* = 2: the minimum block size for which the block routine -* should be used; if the usable block size is less than -* this value, an unblocked routine should be used. -* = 3: the crossover point (in a block routine, for N less -* than this value, an unblocked routine should be used) -* = 4: the number of shifts, used in the nonsymmetric -* eigenvalue routines -* = 5: the minimum column dimension for blocking to be used; -* rectangular blocks must have dimension at least k by m, -* where k is given by ILAENV(2,...) and m by ILAENV(5,...) -* = 6: the crossover point for the SVD (when reducing an m by n -* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds -* this value, a QR factorization is used first to reduce -* the matrix to a triangular form.) -* = 7: the number of processors -* = 8: the crossover point for the multishift QR and QZ methods -* for nonsymmetric eigenvalue problems. -* = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* =10: ieee NaN arithmetic can be trusted not to trap -* =11: infinity arithmetic can be trusted not to trap -* -* NAME (input) CHARACTER*(*) -* The name of the calling subroutine, in either upper case or -* lower case. -* -* OPTS (input) CHARACTER*(*) -* The character options to the subroutine NAME, concatenated -* into a single character string. For example, UPLO = 'U', -* TRANS = 'T', and DIAG = 'N' for a triangular routine would -* be specified as OPTS = 'UTN'. -* -* N1 (input) INTEGER -* N2 (input) INTEGER -* N3 (input) INTEGER -* N4 (input) INTEGER -* Problem dimensions for the subroutine NAME; these may not all -* be required. -* -* (ILAENV) (output) INTEGER -* >= 0: the value of the parameter specified by ISPEC -* < 0: if ILAENV = -k, the k-th argument had an illegal value. -* -* Further Details -* =============== -* -* The following conventions have been used when calling ILAENV from the -* LAPACK routines: -* 1) OPTS is a concatenation of all of the character options to -* subroutine NAME, in the same order that they appear in the -* argument list for NAME, even if they are not used in determining -* the value of the parameter specified by ISPEC. -* 2) The problem dimensions N1, N2, N3, N4 are specified in the order -* that they appear in the argument list for NAME. N1 is used -* first, N2 second, and so on, and unused problem dimensions are -* passed a value of -1. -* 3) The parameter value returned by ILAENV is checked for validity in -* the calling subroutine. For example, ILAENV is used to retrieve -* the optimal blocksize for STRTRI as follows: -* -* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) -* IF( NB.LE.1 ) NB = MAX( 1, N ) -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL CNAME, SNAME - CHARACTER*1 C1 - CHARACTER*2 C2, C4 - CHARACTER*3 C3 - CHARACTER*6 SUBNAM - INTEGER I, IC, IZ, NB, NBMIN, NX -* .. -* .. Intrinsic Functions .. - INTRINSIC CHAR, ICHAR, INT, MIN, REAL -* .. -* .. External Functions .. - INTEGER IEEECK - EXTERNAL IEEECK -* .. -* .. Executable Statements .. -* - GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000, - $ 1100 ) ISPEC -* -* Invalid value for ISPEC -* - ILAENV = -1 - RETURN -* - 100 CONTINUE -* -* Convert NAME to upper case if the first character is lower case. -* - ILAENV = 1 - SUBNAM = NAME - IC = ICHAR( SUBNAM( 1:1 ) ) - IZ = ICHAR( 'Z' ) - IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN -* -* ASCII character set -* - IF( IC.GE.97 .AND. IC.LE.122 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 10 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 10 CONTINUE - END IF -* - ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN -* -* EBCDIC character set -* - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN - SUBNAM( 1:1 ) = CHAR( IC+64 ) - DO 20 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) - $ SUBNAM( I:I ) = CHAR( IC+64 ) - 20 CONTINUE - END IF -* - ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN -* -* Prime machines: ASCII+128 -* - IF( IC.GE.225 .AND. IC.LE.250 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 30 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 30 CONTINUE - END IF - END IF -* - C1 = SUBNAM( 1:1 ) - SNAME = C1.EQ.'S' .OR. C1.EQ.'D' - CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' - IF( .NOT.( CNAME .OR. SNAME ) ) - $ RETURN - C2 = SUBNAM( 2:3 ) - C3 = SUBNAM( 4:6 ) - C4 = C3( 2:3 ) -* - GO TO ( 110, 200, 300 ) ISPEC -* - 110 CONTINUE -* -* ISPEC = 1: block size -* -* In these examples, separate code is provided for setting NB for -* real and complex. We assume that NB will take the same value in -* single or double precision. -* - NB = 1 -* - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'PO' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRF' ) THEN - NB = 64 - ELSE IF( C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - END IF - ELSE IF( C2.EQ.'GB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'PB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'TR' ) THEN - IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'LA' ) THEN - IF( C3.EQ.'UUM' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN - IF( C3.EQ.'EBZ' ) THEN - NB = 1 - END IF - END IF - ILAENV = NB - RETURN -* - 200 CONTINUE -* -* ISPEC = 2: minimum block size -* - NBMIN = 2 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NBMIN = 8 - ELSE - NBMIN = 8 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - END IF - END IF - ILAENV = NBMIN - RETURN -* - 300 CONTINUE -* -* ISPEC = 3: crossover point -* - NX = 0 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NX = 128 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NX = 128 - END IF - END IF - END IF - ILAENV = NX - RETURN -* - 400 CONTINUE -* -* ISPEC = 4: number of shifts (used by xHSEQR) -* - ILAENV = 6 - RETURN -* - 500 CONTINUE -* -* ISPEC = 5: minimum column dimension (not used) -* - ILAENV = 2 - RETURN -* - 600 CONTINUE -* -* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) -* - ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) - RETURN -* - 700 CONTINUE -* -* ISPEC = 7: number of processors (not used) -* - ILAENV = 1 - RETURN -* - 800 CONTINUE -* -* ISPEC = 8: crossover point for multishift (used by xHSEQR) -* - ILAENV = 50 - RETURN -* - 900 CONTINUE -* -* ISPEC = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* - ILAENV = 25 - RETURN -* - 1000 CONTINUE -* -* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap -* -C ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 0, 0.0, 1.0 ) - END IF - RETURN -* - 1100 CONTINUE -* -* ISPEC = 11: infinity arithmetic can be trusted not to trap -* -C ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 1, 0.0, 1.0 ) - END IF - RETURN -* -* End of ILAENV -* - END - SUBROUTINE ZHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, - $ LWORK, RWORK, INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, ITYPE, LDA, LDB, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION RWORK( * ), W( * ) - COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZHEGV computes all the eigenvalues, and optionally, the eigenvectors -* of a complex generalized Hermitian-definite eigenproblem, of the form -* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. -* Here A and B are assumed to be Hermitian and B is also -* positive definite. -* -* Arguments -* ========= -* -* ITYPE (input) INTEGER -* Specifies the problem type to be solved: -* = 1: A*x = (lambda)*B*x -* = 2: A*B*x = (lambda)*x -* = 3: B*A*x = (lambda)*x -* -* JOBZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only; -* = 'V': Compute eigenvalues and eigenvectors. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangles of A and B are stored; -* = 'L': Lower triangles of A and B are stored. -* -* N (input) INTEGER -* The order of the matrices A and B. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA, N) -* On entry, the Hermitian matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of A contains the -* upper triangular part of the matrix A. If UPLO = 'L', -* the leading N-by-N lower triangular part of A contains -* the lower triangular part of the matrix A. -* -* On exit, if JOBZ = 'V', then if INFO = 0, A contains the -* matrix Z of eigenvectors. The eigenvectors are normalized -* as follows: -* if ITYPE = 1 or 2, Z**H*B*Z = I; -* if ITYPE = 3, Z**H*inv(B)*Z = I. -* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') -* or the lower triangle (if UPLO='L') of A, including the -* diagonal, is destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* B (input/output) COMPLEX*16 array, dimension (LDB, N) -* On entry, the Hermitian positive definite matrix B. -* If UPLO = 'U', the leading N-by-N upper triangular part of B -* contains the upper triangular part of the matrix B. -* If UPLO = 'L', the leading N-by-N lower triangular part of B -* contains the lower triangular part of the matrix B. -* -* On exit, if INFO <= N, the part of B containing the matrix is -* overwritten by the triangular factor U or L from the Cholesky -* factorization B = U**H*U or B = L*L**H. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* W (output) DOUBLE PRECISION array, dimension (N) -* If INFO = 0, the eigenvalues in ascending order. -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The length of the array WORK. LWORK >= max(1,2*N-1). -* For optimal efficiency, LWORK >= (NB+1)*N, -* where NB is the blocksize for ZHETRD returned by ILAENV. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2)) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: ZPOTRF or ZHEEV returned an error code: -* <= N: if INFO = i, ZHEEV failed to converge; -* i off-diagonal elements of an intermediate -* tridiagonal form did not converge to zero; -* > N: if INFO = N + i, for 1 <= i <= N, then the leading -* minor of order i of B is not positive definite. -* The factorization of B could not be completed and -* no eigenvalues or eigenvectors were computed. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER, WANTZ - CHARACTER TRANS - INTEGER LWKOPT, NB, NEIG -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZHEEV, ZHEGST, ZPOTRF, ZTRMM, ZTRSM -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) -* - INFO = 0 - IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -11 - END IF -* - IF( INFO.EQ.0 ) THEN - NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) - LWKOPT = ( NB+1 )*N - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHEGV ', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Form a Cholesky factorization of B. -* - CALL ZPOTRF( UPLO, N, B, LDB, INFO ) - IF( INFO.NE.0 ) THEN - INFO = N + INFO - RETURN - END IF -* -* Transform problem to standard eigenvalue problem and solve. -* - CALL ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) - CALL ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO ) -* - IF( WANTZ ) THEN -* -* Backtransform eigenvectors to the original problem. -* - NEIG = N - IF( INFO.GT.0 ) - $ NEIG = INFO - 1 - IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN -* -* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; -* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y -* - IF( UPPER ) THEN - TRANS = 'N' - ELSE - TRANS = 'C' - END IF -* - CALL ZTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, - $ B, LDB, A, LDA ) -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* For B*A*x=(lambda)*x; -* backtransform eigenvectors: x = L*y or U'*y -* - IF( UPPER ) THEN - TRANS = 'C' - ELSE - TRANS = 'N' - END IF -* - CALL ZTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, - $ B, LDB, A, LDA ) - END IF - END IF -* - WORK( 1 ) = LWKOPT -* - RETURN -* -* End of ZHEGV -* - END - SUBROUTINE ZHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, - $ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, - $ LWORK, RWORK, IWORK, IFAIL, INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER JOBZ, RANGE, UPLO - INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N - DOUBLE PRECISION ABSTOL, VL, VU -* .. -* .. Array Arguments .. - INTEGER IFAIL( * ), IWORK( * ) - DOUBLE PRECISION RWORK( * ), W( * ) - COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ), - $ Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* ZHEGVX computes selected eigenvalues, and optionally, eigenvectors -* of a complex generalized Hermitian-definite eigenproblem, of the form -* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and -* B are assumed to be Hermitian and B is also positive definite. -* Eigenvalues and eigenvectors can be selected by specifying either a -* range of values or a range of indices for the desired eigenvalues. -* -* Arguments -* ========= -* -* ITYPE (input) INTEGER -* Specifies the problem type to be solved: -* = 1: A*x = (lambda)*B*x -* = 2: A*B*x = (lambda)*x -* = 3: B*A*x = (lambda)*x -* -* JOBZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only; -* = 'V': Compute eigenvalues and eigenvectors. -* -* RANGE (input) CHARACTER*1 -* = 'A': all eigenvalues will be found. -* = 'V': all eigenvalues in the half-open interval (VL,VU] -* will be found. -* = 'I': the IL-th through IU-th eigenvalues will be found. -** -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangles of A and B are stored; -* = 'L': Lower triangles of A and B are stored. -* -* N (input) INTEGER -* The order of the matrices A and B. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA, N) -* On entry, the Hermitian matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of A contains the -* upper triangular part of the matrix A. If UPLO = 'L', -* the leading N-by-N lower triangular part of A contains -* the lower triangular part of the matrix A. -* -* On exit, the lower triangle (if UPLO='L') or the upper -* triangle (if UPLO='U') of A, including the diagonal, is -* destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* B (input/output) COMPLEX*16 array, dimension (LDB, N) -* On entry, the Hermitian matrix B. If UPLO = 'U', the -* leading N-by-N upper triangular part of B contains the -* upper triangular part of the matrix B. If UPLO = 'L', -* the leading N-by-N lower triangular part of B contains -* the lower triangular part of the matrix B. -* -* On exit, if INFO <= N, the part of B containing the matrix is -* overwritten by the triangular factor U or L from the Cholesky -* factorization B = U**H*U or B = L*L**H. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* VL (input) DOUBLE PRECISION -* VU (input) DOUBLE PRECISION -* If RANGE='V', the lower and upper bounds of the interval to -* be searched for eigenvalues. VL < VU. -* Not referenced if RANGE = 'A' or 'I'. -* -* IL (input) INTEGER -* IU (input) INTEGER -* If RANGE='I', the indices (in ascending order) of the -* smallest and largest eigenvalues to be returned. -* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. -* Not referenced if RANGE = 'A' or 'V'. -* -* ABSTOL (input) DOUBLE PRECISION -* The absolute error tolerance for the eigenvalues. -* An approximate eigenvalue is accepted as converged -* when it is determined to lie in an interval [a,b] -* of width less than or equal to -* -* ABSTOL + EPS * max( |a|,|b| ) , -* -* where EPS is the machine precision. If ABSTOL is less than -* or equal to zero, then EPS*|T| will be used in its place, -* where |T| is the 1-norm of the tridiagonal matrix obtained -* by reducing A to tridiagonal form. -* -* Eigenvalues will be computed most accurately when ABSTOL is -* set to twice the underflow threshold 2*DLAMCH('S'), not zero. -* If this routine returns with INFO>0, indicating that some -* eigenvectors did not converge, try setting ABSTOL to -* 2*DLAMCH('S'). -* -* M (output) INTEGER -* The total number of eigenvalues found. 0 <= M <= N. -* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. -* -* W (output) DOUBLE PRECISION array, dimension (N) -* The first M elements contain the selected -* eigenvalues in ascending order. -* -* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M)) -* If JOBZ = 'N', then Z is not referenced. -* If JOBZ = 'V', then if INFO = 0, the first M columns of Z -* contain the orthonormal eigenvectors of the matrix A -* corresponding to the selected eigenvalues, with the i-th -* column of Z holding the eigenvector associated with W(i). -* The eigenvectors are normalized as follows: -* if ITYPE = 1 or 2, Z**T*B*Z = I; -* if ITYPE = 3, Z**T*inv(B)*Z = I. -* -* If an eigenvector fails to converge, then that column of Z -* contains the latest approximation to the eigenvector, and the -* index of the eigenvector is returned in IFAIL. -* Note: the user must ensure that at least max(1,M) columns are -* supplied in the array Z; if RANGE = 'V', the exact value of M -* is not known in advance and an upper bound must be used. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= 1, and if -* JOBZ = 'V', LDZ >= max(1,N). -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The length of the array WORK. LWORK >= max(1,2*N-1). -* For optimal efficiency, LWORK >= (NB+1)*N, -* where NB is the blocksize for ZHETRD returned by ILAENV. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N) -* -* IWORK (workspace) INTEGER array, dimension (5*N) -* -* IFAIL (output) INTEGER array, dimension (N) -* If JOBZ = 'V', then if INFO = 0, the first M elements of -* IFAIL are zero. If INFO > 0, then IFAIL contains the -* indices of the eigenvectors that failed to converge. -* If JOBZ = 'N', then IFAIL is not referenced. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: ZPOTRF or ZHEEVX returned an error code: -* <= N: if INFO = i, ZHEEVX failed to converge; -* i eigenvectors failed to converge. Their indices -* are stored in array IFAIL. -* > N: if INFO = N + i, for 1 <= i <= N, then the leading -* minor of order i of B is not positive definite. -* The factorization of B could not be completed and -* no eigenvalues or eigenvectors were computed. -* -* Further Details -* =============== -* -* Based on contributions by -* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ - CHARACTER TRANS - INTEGER LOPT, LWKOPT, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZHEEVX, ZHEGST, ZPOTRF, ZTRMM, ZTRSM -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - UPPER = LSAME( UPLO, 'U' ) - ALLEIG = LSAME( RANGE, 'A' ) - VALEIG = LSAME( RANGE, 'V' ) - INDEIG = LSAME( RANGE, 'I' ) - LQUERY = ( LWORK.EQ.-1 ) -* - INFO = 0 - IF( ITYPE.LT.0 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN - INFO = -3 - ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( VALEIG .AND. N.GT.0 ) THEN - IF( VU.LE.VL ) - $ INFO = -11 - ELSE IF( INDEIG .AND. IL.LT.1 ) THEN - INFO = -12 - ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN - INFO = -13 - ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN - INFO = -18 - ELSE IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -20 - END IF -* - IF( INFO.EQ.0 ) THEN - NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) - LWKOPT = ( NB+1 )*N - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHEGVX', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - M = 0 - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Form a Cholesky factorization of B. -* - CALL ZPOTRF( UPLO, N, B, LDB, INFO ) - IF( INFO.NE.0 ) THEN - INFO = N + INFO - RETURN - END IF -* -* Transform problem to standard eigenvalue problem and solve. -* - CALL ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) - CALL ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, - $ M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, - $ INFO ) - LOPT = WORK( 1 ) -* - IF( WANTZ ) THEN -* -* Backtransform eigenvectors to the original problem. -* - IF( INFO.GT.0 ) - $ M = INFO - 1 - IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN -* -* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; -* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y -* - IF( UPPER ) THEN - TRANS = 'N' - ELSE - TRANS = 'C' - END IF -* - CALL ZTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, CONE, B, - $ LDB, Z, LDZ ) -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* For B*A*x=(lambda)*x; -* backtransform eigenvectors: x = L*y or U'*y -* - IF( UPPER ) THEN - TRANS = 'C' - ELSE - TRANS = 'N' - END IF -* - CALL ZTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, CONE, B, - $ LDB, Z, LDZ ) - END IF - END IF -* -* Set WORK(1) to optimal complex workspace size. -* - WORK( 1 ) = LWKOPT -* - RETURN -* -* End of ZHEGVX -* - END - SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DSYTRF computes the factorization of a real symmetric matrix A using -* the Bunch-Kaufman diagonal pivoting method. The form of the -* factorization is -* -* A = U*D*U**T or A = L*D*L**T -* -* where U (or L) is a product of permutation and unit upper (lower) -* triangular matrices, and D is symmetric and block diagonal with -* 1-by-1 and 2-by-2 diagonal blocks. -* -* This is the blocked version of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* N-by-N upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, the block diagonal matrix D and the multipliers used -* to obtain the factor U or L (see below for further details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (output) INTEGER array, dimension (N) -* Details of the interchanges and the block structure of D. -* If IPIV(k) > 0, then rows and columns k and IPIV(k) were -* interchanged and D(k,k) is a 1-by-1 diagonal block. -* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The length of WORK. LWORK >=1. For best performance -* LWORK >= N*NB, where NB is the block size returned by ILAENV. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, D(i,i) is exactly zero. The factorization -* has been completed, but the block diagonal matrix D is -* exactly singular, and division by zero will occur if it -* is used to solve a system of equations. -* -* Further Details -* =============== -* -* If UPLO = 'U', then A = U*D*U', where -* U = P(n)*U(n)* ... *P(k)U(k)* ..., -* i.e., U is a product of terms P(k)*U(k), where k decreases from n to -* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 -* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as -* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such -* that if the diagonal block D(k) is of order s (s = 1 or 2), then -* -* ( I v 0 ) k-s -* U(k) = ( 0 I 0 ) s -* ( 0 0 I ) n-k -* k-s s n-k -* -* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). -* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), -* and A(k,k), and v overwrites A(1:k-2,k-1:k). -* -* If UPLO = 'L', then A = L*D*L', where -* L = P(1)*L(1)* ... *P(k)*L(k)* ..., -* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to -* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 -* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as -* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such -* that if the diagonal block D(k) is of order s (s = 1 or 2), then -* -* ( I 0 0 ) k-1 -* L(k) = ( 0 I 0 ) s -* ( 0 v I ) n-k-s+1 -* k-1 s n-k-s+1 -* -* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). -* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), -* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LQUERY, UPPER - INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLASYF, DSYTF2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size -* - NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYTRF', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* - NBMIN = 2 - LDWORK = N - IF( NB.GT.1 .AND. NB.LT.N ) THEN - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN - NB = MAX( LWORK / LDWORK, 1 ) - NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF', UPLO, N, -1, -1, -1 ) ) - END IF - ELSE - IWS = 1 - END IF - IF( NB.LT.NBMIN ) - $ NB = N -* - IF( UPPER ) THEN -* -* Factorize A as U*D*U' using the upper triangle of A -* -* K is the main loop index, decreasing from N to 1 in steps of -* KB, where KB is the number of columns factorized by DLASYF; -* KB is either NB or NB-1, or K for the last block -* - K = N - 10 CONTINUE -* -* If K < 1, exit from loop -* - IF( K.LT.1 ) - $ GO TO 40 -* - IF( K.GT.NB ) THEN -* -* Factorize columns k-kb+1:k of A and use blocked code to -* update columns 1:k-kb -* - CALL DLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK, - $ IINFO ) - ELSE -* -* Use unblocked code to factorize columns 1:k of A -* - CALL DSYTF2( UPLO, K, A, LDA, IPIV, IINFO ) - KB = K - END IF -* -* Set INFO on the first occurrence of a zero pivot -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO -* -* Decrease K and return to the start of the main loop -* - K = K - KB - GO TO 10 -* - ELSE -* -* Factorize A as L*D*L' using the lower triangle of A -* -* K is the main loop index, increasing from 1 to N in steps of -* KB, where KB is the number of columns factorized by DLASYF; -* KB is either NB or NB-1, or N-K+1 for the last block -* - K = 1 - 20 CONTINUE -* -* If K > N, exit from loop -* - IF( K.GT.N ) - $ GO TO 40 -* - IF( K.LE.N-NB ) THEN -* -* Factorize columns k:k+kb-1 of A and use blocked code to -* update columns k+kb:n -* - CALL DLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ), - $ WORK, LDWORK, IINFO ) - ELSE -* -* Use unblocked code to factorize columns k:n of A -* - CALL DSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO ) - KB = N - K + 1 - END IF -* -* Set INFO on the first occurrence of a zero pivot -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + K - 1 -* -* Adjust IPIV -* - DO 30 J = K, K + KB - 1 - IF( IPIV( J ).GT.0 ) THEN - IPIV( J ) = IPIV( J ) + K - 1 - ELSE - IPIV( J ) = IPIV( J ) - K + 1 - END IF - 30 CONTINUE -* -* Increase K and return to the start of the main loop -* - K = K + KB - GO TO 20 -* - END IF -* - 40 CONTINUE - WORK( 1 ) = LWKOPT - RETURN -* -* End of DSYTRF -* - END - SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DSYTRI computes the inverse of a real symmetric indefinite matrix -* A using the factorization A = U*D*U**T or A = L*D*L**T computed by -* DSYTRF. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the details of the factorization are stored -* as an upper or lower triangular matrix. -* = 'U': Upper triangular, form is A = U*D*U**T; -* = 'L': Lower triangular, form is A = L*D*L**T. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the block diagonal matrix D and the multipliers -* used to obtain the factor U or L as computed by DSYTRF. -* -* On exit, if INFO = 0, the (symmetric) inverse of the original -* matrix. If UPLO = 'U', the upper triangular part of the -* inverse is formed and the part of A below the diagonal is not -* referenced; if UPLO = 'L' the lower triangular part of the -* inverse is formed and the part of A above the diagonal is -* not referenced. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* Details of the interchanges and the block structure of D -* as determined by DSYTRF. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its -* inverse could not be computed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER K, KP, KSTEP - DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DSWAP, DSYMV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check that the diagonal matrix D is nonsingular. -* - IF( UPPER ) THEN -* -* Upper triangular storage: examine D from bottom to top -* - DO 10 INFO = N, 1, -1 - IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - ELSE -* -* Lower triangular storage: examine D from top to bottom. -* - DO 20 INFO = 1, N - IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 20 CONTINUE - END IF - INFO = 0 -* - IF( UPPER ) THEN -* -* Compute inv(A) from the factorization A = U*D*U'. -* -* K is the main loop index, increasing from 1 to N in steps of -* 1 or 2, depending on the size of the diagonal blocks. -* - K = 1 - 30 CONTINUE -* -* If K > N, exit from loop. -* - IF( K.GT.N ) - $ GO TO 40 -* - IF( IPIV( K ).GT.0 ) THEN -* -* 1 x 1 diagonal block -* -* Invert the diagonal block. -* - A( K, K ) = ONE / A( K, K ) -* -* Compute column K of the inverse. -* - IF( K.GT.1 ) THEN - CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) - CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, - $ A( 1, K ), 1 ) - A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), - $ 1 ) - END IF - KSTEP = 1 - ELSE -* -* 2 x 2 diagonal block -* -* Invert the diagonal block. -* - T = ABS( A( K, K+1 ) ) - AK = A( K, K ) / T - AKP1 = A( K+1, K+1 ) / T - AKKP1 = A( K, K+1 ) / T - D = T*( AK*AKP1-ONE ) - A( K, K ) = AKP1 / D - A( K+1, K+1 ) = AK / D - A( K, K+1 ) = -AKKP1 / D -* -* Compute columns K and K+1 of the inverse. -* - IF( K.GT.1 ) THEN - CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) - CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, - $ A( 1, K ), 1 ) - A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), - $ 1 ) - A( K, K+1 ) = A( K, K+1 ) - - $ DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) - CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) - CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, - $ A( 1, K+1 ), 1 ) - A( K+1, K+1 ) = A( K+1, K+1 ) - - $ DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 ) - END IF - KSTEP = 2 - END IF -* - KP = ABS( IPIV( K ) ) - IF( KP.NE.K ) THEN -* -* Interchange rows and columns K and KP in the leading -* submatrix A(1:k+1,1:k+1) -* - CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) - CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) - TEMP = A( K, K ) - A( K, K ) = A( KP, KP ) - A( KP, KP ) = TEMP - IF( KSTEP.EQ.2 ) THEN - TEMP = A( K, K+1 ) - A( K, K+1 ) = A( KP, K+1 ) - A( KP, K+1 ) = TEMP - END IF - END IF -* - K = K + KSTEP - GO TO 30 - 40 CONTINUE -* - ELSE -* -* Compute inv(A) from the factorization A = L*D*L'. -* -* K is the main loop index, increasing from 1 to N in steps of -* 1 or 2, depending on the size of the diagonal blocks. -* - K = N - 50 CONTINUE -* -* If K < 1, exit from loop. -* - IF( K.LT.1 ) - $ GO TO 60 -* - IF( IPIV( K ).GT.0 ) THEN -* -* 1 x 1 diagonal block -* -* Invert the diagonal block. -* - A( K, K ) = ONE / A( K, K ) -* -* Compute column K of the inverse. -* - IF( K.LT.N ) THEN - CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) - CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, - $ ZERO, A( K+1, K ), 1 ) - A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), - $ 1 ) - END IF - KSTEP = 1 - ELSE -* -* 2 x 2 diagonal block -* -* Invert the diagonal block. -* - T = ABS( A( K, K-1 ) ) - AK = A( K-1, K-1 ) / T - AKP1 = A( K, K ) / T - AKKP1 = A( K, K-1 ) / T - D = T*( AK*AKP1-ONE ) - A( K-1, K-1 ) = AKP1 / D - A( K, K ) = AK / D - A( K, K-1 ) = -AKKP1 / D -* -* Compute columns K-1 and K of the inverse. -* - IF( K.LT.N ) THEN - CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) - CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, - $ ZERO, A( K+1, K ), 1 ) - A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), - $ 1 ) - A( K, K-1 ) = A( K, K-1 ) - - $ DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ), - $ 1 ) - CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) - CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, - $ ZERO, A( K+1, K-1 ), 1 ) - A( K-1, K-1 ) = A( K-1, K-1 ) - - $ DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 ) - END IF - KSTEP = 2 - END IF -* - KP = ABS( IPIV( K ) ) - IF( KP.NE.K ) THEN -* -* Interchange rows and columns K and KP in the trailing -* submatrix A(k-1:n,k-1:n) -* - IF( KP.LT.N ) - $ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) - CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) - TEMP = A( K, K ) - A( K, K ) = A( KP, KP ) - A( KP, KP ) = TEMP - IF( KSTEP.EQ.2 ) THEN - TEMP = A( K, K-1 ) - A( K, K-1 ) = A( KP, K-1 ) - A( KP, K-1 ) = TEMP - END IF - END IF -* - K = K - KSTEP - GO TO 50 - 60 CONTINUE - END IF -* - RETURN -* -* End of DSYTRI -* - END - INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1998 -* -* .. Scalar Arguments .. - INTEGER ISPEC - REAL ONE, ZERO -* .. -* -* Purpose -* ======= -* -* IEEECK is called from the ILAENV to verify that Infinity and -* possibly NaN arithmetic is safe (i.e. will not trap). -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies whether to test just for inifinity arithmetic -* or whether to test for infinity and NaN arithmetic. -* = 0: Verify infinity arithmetic only. -* = 1: Verify infinity and NaN arithmetic. -* -* ZERO (input) REAL -* Must contain the value 0.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* ONE (input) REAL -* Must contain the value 1.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* RETURN VALUE: INTEGER -* = 0: Arithmetic failed to produce the correct answers -* = 1: Arithmetic produced the correct answers -* -* .. Local Scalars .. - REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, - $ NEGZRO, NEWZRO, POSINF -* .. -* .. Executable Statements .. - IEEECK = 1 -* - POSINF = ONE / ZERO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = -ONE / ZERO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGZRO = ONE / ( NEGINF+ONE ) - IF( NEGZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = ONE / NEGZRO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEWZRO = NEGZRO + ZERO - IF( NEWZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = ONE / NEWZRO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = NEGINF*POSINF - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = POSINF*POSINF - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* -* -* -* -* Return if we were only asked to check infinity arithmetic -* - IF( ISPEC.EQ.0 ) - $ RETURN -* - NAN1 = POSINF + NEGINF -* - NAN2 = POSINF / NEGINF -* - NAN3 = POSINF / POSINF -* - NAN4 = POSINF*ZERO -* - NAN5 = NEGINF*NEGZRO -* - NAN6 = NAN5*0.0 -* - IF( NAN1.EQ.NAN1 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN2.EQ.NAN2 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN3.EQ.NAN3 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN4.EQ.NAN4 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN5.EQ.NAN5 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN6.EQ.NAN6 ) THEN - IEEECK = 0 - RETURN - END IF -* - RETURN - END - SUBROUTINE ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, ITYPE, LDA, LDB, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZHEGST reduces a complex Hermitian-definite generalized -* eigenproblem to standard form. -* -* If ITYPE = 1, the problem is A*x = lambda*B*x, -* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) -* -* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or -* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. -* -* B must have been previously factorized as U**H*U or L*L**H by ZPOTRF. -* -* Arguments -* ========= -* -* ITYPE (input) INTEGER -* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); -* = 2 or 3: compute U*A*U**H or L**H*A*L. -* -* UPLO (input) CHARACTER -* = 'U': Upper triangle of A is stored and B is factored as -* U**H*U; -* = 'L': Lower triangle of A is stored and B is factored as -* L*L**H. -* -* N (input) INTEGER -* The order of the matrices A and B. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the Hermitian matrix A. If UPLO = 'U', the leading -* N-by-N upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the transformed matrix, stored in the -* same format as A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* B (input) COMPLEX*16 array, dimension (LDB,N) -* The triangular factor from the Cholesky factorization of B, -* as returned by ZPOTRF. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) - COMPLEX*16 CONE, HALF - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), - $ HALF = ( 0.5D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER K, KB, NB -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZHEGS2, ZHEMM, ZHER2K, ZTRMM, ZTRSM -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHEGST', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'ZHEGST', UPLO, N, -1, -1, -1 ) -* - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) - ELSE -* -* Use blocked code -* - IF( ITYPE.EQ.1 ) THEN - IF( UPPER ) THEN -* -* Compute inv(U')*A*inv(U) -* - DO 10 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the upper triangle of A(k:n,k:n) -* - CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - IF( K+KB.LE.N ) THEN - CALL ZTRSM( 'Left', UPLO, 'Conjugate transpose', - $ 'Non-unit', KB, N-K-KB+1, CONE, - $ B( K, K ), LDB, A( K, K+KB ), LDA ) - CALL ZHEMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, - $ A( K, K ), LDA, B( K, K+KB ), LDB, - $ CONE, A( K, K+KB ), LDA ) - CALL ZHER2K( UPLO, 'Conjugate transpose', N-K-KB+1, - $ KB, -CONE, A( K, K+KB ), LDA, - $ B( K, K+KB ), LDB, ONE, - $ A( K+KB, K+KB ), LDA ) - CALL ZHEMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, - $ A( K, K ), LDA, B( K, K+KB ), LDB, - $ CONE, A( K, K+KB ), LDA ) - CALL ZTRSM( 'Right', UPLO, 'No transpose', - $ 'Non-unit', KB, N-K-KB+1, CONE, - $ B( K+KB, K+KB ), LDB, A( K, K+KB ), - $ LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute inv(L)*A*inv(L') -* - DO 20 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the lower triangle of A(k:n,k:n) -* - CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - IF( K+KB.LE.N ) THEN - CALL ZTRSM( 'Right', UPLO, 'Conjugate transpose', - $ 'Non-unit', N-K-KB+1, KB, CONE, - $ B( K, K ), LDB, A( K+KB, K ), LDA ) - CALL ZHEMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, - $ A( K, K ), LDA, B( K+KB, K ), LDB, - $ CONE, A( K+KB, K ), LDA ) - CALL ZHER2K( UPLO, 'No transpose', N-K-KB+1, KB, - $ -CONE, A( K+KB, K ), LDA, - $ B( K+KB, K ), LDB, ONE, - $ A( K+KB, K+KB ), LDA ) - CALL ZHEMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, - $ A( K, K ), LDA, B( K+KB, K ), LDB, - $ CONE, A( K+KB, K ), LDA ) - CALL ZTRSM( 'Left', UPLO, 'No transpose', - $ 'Non-unit', N-K-KB+1, KB, CONE, - $ B( K+KB, K+KB ), LDB, A( K+KB, K ), - $ LDA ) - END IF - 20 CONTINUE - END IF - ELSE - IF( UPPER ) THEN -* -* Compute U*A*U' -* - DO 30 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) -* - CALL ZTRMM( 'Left', UPLO, 'No transpose', 'Non-unit', - $ K-1, KB, CONE, B, LDB, A( 1, K ), LDA ) - CALL ZHEMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), - $ LDA, B( 1, K ), LDB, CONE, A( 1, K ), - $ LDA ) - CALL ZHER2K( UPLO, 'No transpose', K-1, KB, CONE, - $ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A, - $ LDA ) - CALL ZHEMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), - $ LDA, B( 1, K ), LDB, CONE, A( 1, K ), - $ LDA ) - CALL ZTRMM( 'Right', UPLO, 'Conjugate transpose', - $ 'Non-unit', K-1, KB, CONE, B( K, K ), LDB, - $ A( 1, K ), LDA ) - CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - 30 CONTINUE - ELSE -* -* Compute L'*A*L -* - DO 40 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) -* - CALL ZTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', - $ KB, K-1, CONE, B, LDB, A( K, 1 ), LDA ) - CALL ZHEMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), - $ LDA, B( K, 1 ), LDB, CONE, A( K, 1 ), - $ LDA ) - CALL ZHER2K( UPLO, 'Conjugate transpose', K-1, KB, - $ CONE, A( K, 1 ), LDA, B( K, 1 ), LDB, - $ ONE, A, LDA ) - CALL ZHEMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), - $ LDA, B( K, 1 ), LDB, CONE, A( K, 1 ), - $ LDA ) - CALL ZTRMM( 'Left', UPLO, 'Conjugate transpose', - $ 'Non-unit', KB, K-1, CONE, B( K, K ), LDB, - $ A( K, 1 ), LDA ) - CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - 40 CONTINUE - END IF - END IF - END IF - RETURN -* -* End of ZHEGST -* - END - SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, - $ INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION RWORK( * ), W( * ) - COMPLEX*16 A( LDA, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZHEEV computes all eigenvalues and, optionally, eigenvectors of a -* complex Hermitian matrix A. -* -* Arguments -* ========= -* -* JOBZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only; -* = 'V': Compute eigenvalues and eigenvectors. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA, N) -* On entry, the Hermitian matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of A contains the -* upper triangular part of the matrix A. If UPLO = 'L', -* the leading N-by-N lower triangular part of A contains -* the lower triangular part of the matrix A. -* On exit, if JOBZ = 'V', then if INFO = 0, A contains the -* orthonormal eigenvectors of the matrix A. -* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') -* or the upper triangle (if UPLO='U') of A, including the -* diagonal, is destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* W (output) DOUBLE PRECISION array, dimension (N) -* If INFO = 0, the eigenvalues in ascending order. -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The length of the array WORK. LWORK >= max(1,2*N-1). -* For optimal efficiency, LWORK >= (NB+1)*N, -* where NB is the blocksize for ZHETRD returned by ILAENV. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2)) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the algorithm failed to converge; i -* off-diagonal elements of an intermediate tridiagonal -* form did not converge to zero. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LOWER, LQUERY, WANTZ - INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, - $ LLWORK, LOPT, LWKOPT, NB - DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, - $ SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, ZLANHE - EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLASCL, ZSTEQR, - $ ZUNGTR -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - LOWER = LSAME( UPLO, 'L' ) - LQUERY = ( LWORK.EQ.-1 ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF -* - IF( INFO.EQ.0 ) THEN - NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) - LWKOPT = MAX( 1, ( NB+1 )*N ) - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHEEV ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( N.EQ.1 ) THEN - W( 1 ) = A( 1, 1 ) - WORK( 1 ) = 3 - IF( WANTZ ) - $ A( 1, 1 ) = CONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = SQRT( BIGNUM ) -* -* Scale matrix to allowable range, if necessary. -* - ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) - ISCALE = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) - $ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) -* -* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. -* - INDE = 1 - INDTAU = 1 - INDWRK = INDTAU + N - LLWORK = LWORK - INDWRK + 1 - CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ), - $ WORK( INDWRK ), LLWORK, IINFO ) - LOPT = N + WORK( INDWRK ) -* -* For eigenvalues only, call DSTERF. For eigenvectors, first call -* ZUNGTR to generate the unitary matrix, then call ZSTEQR. -* - IF( .NOT.WANTZ ) THEN - CALL DSTERF( N, W, RWORK( INDE ), INFO ) - ELSE - CALL ZUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), - $ LLWORK, IINFO ) - INDWRK = INDE + N - CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), A, LDA, - $ RWORK( INDWRK ), INFO ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = N - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF -* -* Set WORK(1) to optimal complex workspace size. -* - WORK( 1 ) = LWKOPT -* - RETURN -* -* End of ZHEEV -* - END - SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, - $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, - $ IWORK, IFAIL, INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER JOBZ, RANGE, UPLO - INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N - DOUBLE PRECISION ABSTOL, VL, VU -* .. -* .. Array Arguments .. - INTEGER IFAIL( * ), IWORK( * ) - DOUBLE PRECISION RWORK( * ), W( * ) - COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* ZHEEVX computes selected eigenvalues and, optionally, eigenvectors -* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can -* be selected by specifying either a range of values or a range of -* indices for the desired eigenvalues. -* -* Arguments -* ========= -* -* JOBZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only; -* = 'V': Compute eigenvalues and eigenvectors. -* -* RANGE (input) CHARACTER*1 -* = 'A': all eigenvalues will be found. -* = 'V': all eigenvalues in the half-open interval (VL,VU] -* will be found. -* = 'I': the IL-th through IU-th eigenvalues will be found. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA, N) -* On entry, the Hermitian matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of A contains the -* upper triangular part of the matrix A. If UPLO = 'L', -* the leading N-by-N lower triangular part of A contains -* the lower triangular part of the matrix A. -* On exit, the lower triangle (if UPLO='L') or the upper -* triangle (if UPLO='U') of A, including the diagonal, is -* destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* VL (input) DOUBLE PRECISION -* VU (input) DOUBLE PRECISION -* If RANGE='V', the lower and upper bounds of the interval to -* be searched for eigenvalues. VL < VU. -* Not referenced if RANGE = 'A' or 'I'. -* -* IL (input) INTEGER -* IU (input) INTEGER -* If RANGE='I', the indices (in ascending order) of the -* smallest and largest eigenvalues to be returned. -* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. -* Not referenced if RANGE = 'A' or 'V'. -* -* ABSTOL (input) DOUBLE PRECISION -* The absolute error tolerance for the eigenvalues. -* An approximate eigenvalue is accepted as converged -* when it is determined to lie in an interval [a,b] -* of width less than or equal to -* -* ABSTOL + EPS * max( |a|,|b| ) , -* -* where EPS is the machine precision. If ABSTOL is less than -* or equal to zero, then EPS*|T| will be used in its place, -* where |T| is the 1-norm of the tridiagonal matrix obtained -* by reducing A to tridiagonal form. -* -* Eigenvalues will be computed most accurately when ABSTOL is -* set to twice the underflow threshold 2*DLAMCH('S'), not zero. -* If this routine returns with INFO>0, indicating that some -* eigenvectors did not converge, try setting ABSTOL to -* 2*DLAMCH('S'). -* -* See "Computing Small Singular Values of Bidiagonal Matrices -* with Guaranteed High Relative Accuracy," by Demmel and -* Kahan, LAPACK Working Note #3. -* -* M (output) INTEGER -* The total number of eigenvalues found. 0 <= M <= N. -* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. -* -* W (output) DOUBLE PRECISION array, dimension (N) -* On normal exit, the first M elements contain the selected -* eigenvalues in ascending order. -* -* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M)) -* If JOBZ = 'V', then if INFO = 0, the first M columns of Z -* contain the orthonormal eigenvectors of the matrix A -* corresponding to the selected eigenvalues, with the i-th -* column of Z holding the eigenvector associated with W(i). -* If an eigenvector fails to converge, then that column of Z -* contains the latest approximation to the eigenvector, and the -* index of the eigenvector is returned in IFAIL. -* If JOBZ = 'N', then Z is not referenced. -* Note: the user must ensure that at least max(1,M) columns are -* supplied in the array Z; if RANGE = 'V', the exact value of M -* is not known in advance and an upper bound must be used. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= 1, and if -* JOBZ = 'V', LDZ >= max(1,N). -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The length of the array WORK. LWORK >= max(1,2*N-1). -* For optimal efficiency, LWORK >= (NB+1)*N, -* where NB is the max of the blocksize for ZHETRD and for -* ZUNMTR as returned by ILAENV. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N) -* -* IWORK (workspace) INTEGER array, dimension (5*N) -* -* IFAIL (output) INTEGER array, dimension (N) -* If JOBZ = 'V', then if INFO = 0, the first M elements of -* IFAIL are zero. If INFO > 0, then IFAIL contains the -* indices of the eigenvectors that failed to converge. -* If JOBZ = 'N', then IFAIL is not referenced. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, then i eigenvectors failed to converge. -* Their indices are stored in array IFAIL. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ - CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, - $ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE, - $ ITMP1, J, JJ, LLWORK, LOPT, LWKOPT, NB, NSPLIT - DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, - $ SIGMA, SMLNUM, TMP1, VLL, VUU -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, ZLANHE - EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL, - $ ZHETRD, ZLACPY, ZSTEIN, ZSTEQR, ZSWAP, ZUNGTR, - $ ZUNMTR -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LOWER = LSAME( UPLO, 'L' ) - WANTZ = LSAME( JOBZ, 'V' ) - ALLEIG = LSAME( RANGE, 'A' ) - VALEIG = LSAME( RANGE, 'V' ) - INDEIG = LSAME( RANGE, 'I' ) - LQUERY = ( LWORK.EQ.-1 ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN - INFO = -2 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE - IF( VALEIG ) THEN - IF( N.GT.0 .AND. VU.LE.VL ) - $ INFO = -8 - ELSE IF( INDEIG ) THEN - IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN - INFO = -10 - END IF - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN - INFO = -15 - ELSE IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -17 - END IF - END IF -* - IF( INFO.EQ.0 ) THEN - NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) - NB = MAX( NB, ILAENV( 1, 'ZUNMTR', UPLO, N, -1, -1, -1 ) ) - LWKOPT = ( NB+1 )*N - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHEEVX', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - M = 0 - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( N.EQ.1 ) THEN - WORK( 1 ) = 1 - IF( ALLEIG .OR. INDEIG ) THEN - M = 1 - W( 1 ) = A( 1, 1 ) - ELSE IF( VALEIG ) THEN - IF( VL.LT.DBLE( A( 1, 1 ) ) .AND. VU.GE.DBLE( A( 1, 1 ) ) ) - $ THEN - M = 1 - W( 1 ) = A( 1, 1 ) - END IF - END IF - IF( WANTZ ) - $ Z( 1, 1 ) = CONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) -* -* Scale matrix to allowable range, if necessary. -* - ISCALE = 0 - ABSTLL = ABSTOL - VLL = VL - VUU = VU - ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) THEN - IF( LOWER ) THEN - DO 10 J = 1, N - CALL ZDSCAL( N-J+1, SIGMA, A( J, J ), 1 ) - 10 CONTINUE - ELSE - DO 20 J = 1, N - CALL ZDSCAL( J, SIGMA, A( 1, J ), 1 ) - 20 CONTINUE - END IF - IF( ABSTOL.GT.0 ) - $ ABSTLL = ABSTOL*SIGMA - IF( VALEIG ) THEN - VLL = VL*SIGMA - VUU = VU*SIGMA - END IF - END IF -* -* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. -* - INDD = 1 - INDE = INDD + N - INDRWK = INDE + N - INDTAU = 1 - INDWRK = INDTAU + N - LLWORK = LWORK - INDWRK + 1 - CALL ZHETRD( UPLO, N, A, LDA, RWORK( INDD ), RWORK( INDE ), - $ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO ) - LOPT = N + WORK( INDWRK ) -* -* If all eigenvalues are desired and ABSTOL is less than or equal to -* zero, then call DSTERF or ZUNGTR and ZSTEQR. If this fails for -* some eigenvalue, then try DSTEBZ. -* - IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. - $ ( ABSTOL.LE.ZERO ) ) THEN - CALL DCOPY( N, RWORK( INDD ), 1, W, 1 ) - INDEE = INDRWK + 2*N - IF( .NOT.WANTZ ) THEN - CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) - CALL DSTERF( N, W, RWORK( INDEE ), INFO ) - ELSE - CALL ZLACPY( 'A', N, N, A, LDA, Z, LDZ ) - CALL ZUNGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), - $ WORK( INDWRK ), LLWORK, IINFO ) - CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) - CALL ZSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ, - $ RWORK( INDRWK ), INFO ) - IF( INFO.EQ.0 ) THEN - DO 30 I = 1, N - IFAIL( I ) = 0 - 30 CONTINUE - END IF - END IF - IF( INFO.EQ.0 ) THEN - M = N - GO TO 40 - END IF - INFO = 0 - END IF -* -* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. -* - IF( WANTZ ) THEN - ORDER = 'B' - ELSE - ORDER = 'E' - END IF - INDIBL = 1 - INDISP = INDIBL + N - INDIWK = INDISP + N - CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, - $ RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W, - $ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ), - $ IWORK( INDIWK ), INFO ) -* - IF( WANTZ ) THEN - CALL ZSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W, - $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, - $ RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO ) -* -* Apply unitary matrix used in reduction to tridiagonal -* form to eigenvectors returned by ZSTEIN. -* - CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, - $ LDZ, WORK( INDWRK ), LLWORK, IINFO ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - 40 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF -* -* If eigenvalues are not in order, then sort them, along with -* eigenvectors. -* - IF( WANTZ ) THEN - DO 60 J = 1, M - 1 - I = 0 - TMP1 = W( J ) - DO 50 JJ = J + 1, M - IF( W( JJ ).LT.TMP1 ) THEN - I = JJ - TMP1 = W( JJ ) - END IF - 50 CONTINUE -* - IF( I.NE.0 ) THEN - ITMP1 = IWORK( INDIBL+I-1 ) - W( I ) = W( J ) - IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) - W( J ) = TMP1 - IWORK( INDIBL+J-1 ) = ITMP1 - CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) - IF( INFO.NE.0 ) THEN - ITMP1 = IFAIL( I ) - IFAIL( I ) = IFAIL( J ) - IFAIL( J ) = ITMP1 - END IF - END IF - 60 CONTINUE - END IF -* -* Set WORK(1) to optimal complex workspace size. -* - WORK( 1 ) = LWKOPT -* - RETURN -* -* End of ZHEEVX -* - END - SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, KB, LDA, LDW, N, NB -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), W( LDW, * ) -* .. -* -* Purpose -* ======= -* -* DLASYF computes a partial factorization of a real symmetric matrix A -* using the Bunch-Kaufman diagonal pivoting method. The partial -* factorization has the form: -* -* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: -* ( 0 U22 ) ( 0 D ) ( U12' U22' ) -* -* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L' -* ( L21 I ) ( 0 A22 ) ( 0 I ) -* -* where the order of D is at most NB. The actual order is returned in -* the argument KB, and is either NB or NB-1, or N if N <= NB. -* -* DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code -* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or -* A22 (if UPLO = 'L'). -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NB (input) INTEGER -* The maximum number of columns of the matrix A that should be -* factored. NB should be at least 2 to allow for 2-by-2 pivot -* blocks. -* -* KB (output) INTEGER -* The number of columns of A that were actually factored. -* KB is either NB-1 or NB, or N if N <= NB. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* n-by-n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n-by-n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* On exit, A contains details of the partial factorization. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (output) INTEGER array, dimension (N) -* Details of the interchanges and the block structure of D. -* If UPLO = 'U', only the last KB elements of IPIV are set; -* if UPLO = 'L', only the first KB elements are set. -* -* If IPIV(k) > 0, then rows and columns k and IPIV(k) were -* interchanged and D(k,k) is a 1-by-1 diagonal block. -* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. -* -* W (workspace) DOUBLE PRECISION array, dimension (LDW,NB) -* -* LDW (input) INTEGER -* The leading dimension of the array W. LDW >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* > 0: if INFO = k, D(k,k) is exactly zero. The factorization -* has been completed, but the block diagonal matrix D is -* exactly singular. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION EIGHT, SEVTEN - PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, - $ KSTEP, KW - DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1, - $ ROWMAX, T -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - EXTERNAL LSAME, IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - INFO = 0 -* -* Initialize ALPHA for use in choosing pivot block size. -* - ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Factorize the trailing columns of A using the upper triangle -* of A and working backwards, and compute the matrix W = U12*D -* for use in updating A11 -* -* K is the main loop index, decreasing from N in steps of 1 or 2 -* -* KW is the column of W which corresponds to column K of A -* - K = N - 10 CONTINUE - KW = NB + K - N -* -* Exit from loop -* - IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) - $ GO TO 30 -* -* Copy column K of A to column KW of W and update it -* - CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) - IF( K.LT.N ) - $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA, - $ W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) -* - KSTEP = 1 -* -* Determine rows and columns to be interchanged and whether -* a 1-by-1 or 2-by-2 pivot block will be used -* - ABSAKK = ABS( W( K, KW ) ) -* -* IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value -* - IF( K.GT.1 ) THEN - IMAX = IDAMAX( K-1, W( 1, KW ), 1 ) - COLMAX = ABS( W( IMAX, KW ) ) - ELSE - COLMAX = ZERO - END IF -* - IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN -* -* Column K is zero: set INFO and continue -* - IF( INFO.EQ.0 ) - $ INFO = K - KP = K - ELSE - IF( ABSAKK.GE.ALPHA*COLMAX ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE -* -* Copy column IMAX to column KW-1 of W and update it -* - CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) - CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, - $ W( IMAX+1, KW-1 ), 1 ) - IF( K.LT.N ) - $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), - $ LDA, W( IMAX, KW+1 ), LDW, ONE, - $ W( 1, KW-1 ), 1 ) -* -* JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value -* - JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 ) - ROWMAX = ABS( W( JMAX, KW-1 ) ) - IF( IMAX.GT.1 ) THEN - JMAX = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 ) - ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) ) - END IF -* - IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN -* -* interchange rows and columns K and IMAX, use 1-by-1 -* pivot block -* - KP = IMAX -* -* copy column KW-1 of W to column KW -* - CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) - ELSE -* -* interchange rows and columns K-1 and IMAX, use 2-by-2 -* pivot block -* - KP = IMAX - KSTEP = 2 - END IF - END IF -* - KK = K - KSTEP + 1 - KKW = NB + KK - N -* -* Updated column KP is already stored in column KKW of W -* - IF( KP.NE.KK ) THEN -* -* Copy non-updated column KK to column KP -* - A( KP, K ) = A( KK, K ) - CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), - $ LDA ) - CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) -* -* Interchange rows KK and KP in last KK columns of A and W -* - CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) - CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), - $ LDW ) - END IF -* - IF( KSTEP.EQ.1 ) THEN -* -* 1-by-1 pivot block D(k): column KW of W now holds -* -* W(k) = U(k)*D(k) -* -* where U(k) is the k-th column of U -* -* Store U(k) in column k of A -* - CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) - R1 = ONE / A( K, K ) - CALL DSCAL( K-1, R1, A( 1, K ), 1 ) - ELSE -* -* 2-by-2 pivot block D(k): columns KW and KW-1 of W now -* hold -* -* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) -* -* where U(k) and U(k-1) are the k-th and (k-1)-th columns -* of U -* - IF( K.GT.2 ) THEN -* -* Store U(k) and U(k-1) in columns k and k-1 of A -* - D21 = W( K-1, KW ) - D11 = W( K, KW ) / D21 - D22 = W( K-1, KW-1 ) / D21 - T = ONE / ( D11*D22-ONE ) - D21 = T / D21 - DO 20 J = 1, K - 2 - A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) - A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) - 20 CONTINUE - END IF -* -* Copy D(k) to A -* - A( K-1, K-1 ) = W( K-1, KW-1 ) - A( K-1, K ) = W( K-1, KW ) - A( K, K ) = W( K, KW ) - END IF - END IF -* -* Store details of the interchanges in IPIV -* - IF( KSTEP.EQ.1 ) THEN - IPIV( K ) = KP - ELSE - IPIV( K ) = -KP - IPIV( K-1 ) = -KP - END IF -* -* Decrease K and return to the start of the main loop -* - K = K - KSTEP - GO TO 10 -* - 30 CONTINUE -* -* Update the upper triangle of A11 (= A(1:k,1:k)) as -* -* A11 := A11 - U12*D*U12' = A11 - U12*W' -* -* computing blocks of NB columns at a time -* - DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB - JB = MIN( NB, K-J+1 ) -* -* Update the upper triangle of the diagonal block -* - DO 40 JJ = J, J + JB - 1 - CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE, - $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, - $ A( J, JJ ), 1 ) - 40 CONTINUE -* -* Update the rectangular superdiagonal block -* - CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE, - $ A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE, - $ A( 1, J ), LDA ) - 50 CONTINUE -* -* Put U12 in standard form by partially undoing the interchanges -* in columns k+1:n -* - J = K + 1 - 60 CONTINUE - JJ = J - JP = IPIV( J ) - IF( JP.LT.0 ) THEN - JP = -JP - J = J + 1 - END IF - J = J + 1 - IF( JP.NE.JJ .AND. J.LE.N ) - $ CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) - IF( J.LE.N ) - $ GO TO 60 -* -* Set KB to the number of columns factorized -* - KB = N - K -* - ELSE -* -* Factorize the leading columns of A using the lower triangle -* of A and working forwards, and compute the matrix W = L21*D -* for use in updating A22 -* -* K is the main loop index, increasing from 1 in steps of 1 or 2 -* - K = 1 - 70 CONTINUE -* -* Exit from loop -* - IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) - $ GO TO 90 -* -* Copy column K of A to column K of W and update it -* - CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) - CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA, - $ W( K, 1 ), LDW, ONE, W( K, K ), 1 ) -* - KSTEP = 1 -* -* Determine rows and columns to be interchanged and whether -* a 1-by-1 or 2-by-2 pivot block will be used -* - ABSAKK = ABS( W( K, K ) ) -* -* IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value -* - IF( K.LT.N ) THEN - IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 ) - COLMAX = ABS( W( IMAX, K ) ) - ELSE - COLMAX = ZERO - END IF -* - IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN -* -* Column K is zero: set INFO and continue -* - IF( INFO.EQ.0 ) - $ INFO = K - KP = K - ELSE - IF( ABSAKK.GE.ALPHA*COLMAX ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE -* -* Copy column IMAX to column K+1 of W and update it -* - CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) - CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ), - $ 1 ) - CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), - $ LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 ) -* -* JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value -* - JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 ) - ROWMAX = ABS( W( JMAX, K+1 ) ) - IF( IMAX.LT.N ) THEN - JMAX = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 ) - ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) ) - END IF -* - IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN -* -* interchange rows and columns K and IMAX, use 1-by-1 -* pivot block -* - KP = IMAX -* -* copy column K+1 of W to column K -* - CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) - ELSE -* -* interchange rows and columns K+1 and IMAX, use 2-by-2 -* pivot block -* - KP = IMAX - KSTEP = 2 - END IF - END IF -* - KK = K + KSTEP - 1 -* -* Updated column KP is already stored in column KK of W -* - IF( KP.NE.KK ) THEN -* -* Copy non-updated column KK to column KP -* - A( KP, K ) = A( KK, K ) - CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) - CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) -* -* Interchange rows KK and KP in first KK columns of A and W -* - CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) - CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) - END IF -* - IF( KSTEP.EQ.1 ) THEN -* -* 1-by-1 pivot block D(k): column k of W now holds -* -* W(k) = L(k)*D(k) -* -* where L(k) is the k-th column of L -* -* Store L(k) in column k of A -* - CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) - IF( K.LT.N ) THEN - R1 = ONE / A( K, K ) - CALL DSCAL( N-K, R1, A( K+1, K ), 1 ) - END IF - ELSE -* -* 2-by-2 pivot block D(k): columns k and k+1 of W now hold -* -* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) -* -* where L(k) and L(k+1) are the k-th and (k+1)-th columns -* of L -* - IF( K.LT.N-1 ) THEN -* -* Store L(k) and L(k+1) in columns k and k+1 of A -* - D21 = W( K+1, K ) - D11 = W( K+1, K+1 ) / D21 - D22 = W( K, K ) / D21 - T = ONE / ( D11*D22-ONE ) - D21 = T / D21 - DO 80 J = K + 2, N - A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) - A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) - 80 CONTINUE - END IF -* -* Copy D(k) to A -* - A( K, K ) = W( K, K ) - A( K+1, K ) = W( K+1, K ) - A( K+1, K+1 ) = W( K+1, K+1 ) - END IF - END IF -* -* Store details of the interchanges in IPIV -* - IF( KSTEP.EQ.1 ) THEN - IPIV( K ) = KP - ELSE - IPIV( K ) = -KP - IPIV( K+1 ) = -KP - END IF -* -* Increase K and return to the start of the main loop -* - K = K + KSTEP - GO TO 70 -* - 90 CONTINUE -* -* Update the lower triangle of A22 (= A(k:n,k:n)) as -* -* A22 := A22 - L21*D*L21' = A22 - L21*W' -* -* computing blocks of NB columns at a time -* - DO 110 J = K, N, NB - JB = MIN( NB, N-J+1 ) -* -* Update the lower triangle of the diagonal block -* - DO 100 JJ = J, J + JB - 1 - CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, - $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, - $ A( JJ, JJ ), 1 ) - 100 CONTINUE -* -* Update the rectangular subdiagonal block -* - IF( J+JB.LE.N ) - $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, - $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, - $ ONE, A( J+JB, J ), LDA ) - 110 CONTINUE -* -* Put L21 in standard form by partially undoing the interchanges -* in columns 1:k-1 -* - J = K - 1 - 120 CONTINUE - JJ = J - JP = IPIV( J ) - IF( JP.LT.0 ) THEN - JP = -JP - J = J - 1 - END IF - J = J - 1 - IF( JP.NE.JJ .AND. J.GE.1 ) - $ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) - IF( J.GE.1 ) - $ GO TO 120 -* -* Set KB to the number of columns factorized -* - KB = K - 1 -* - END IF - RETURN -* -* End of DLASYF -* - END - SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DSYTF2 computes the factorization of a real symmetric matrix A using -* the Bunch-Kaufman diagonal pivoting method: -* -* A = U*D*U' or A = L*D*L' -* -* where U (or L) is a product of permutation and unit upper (lower) -* triangular matrices, U' is the transpose of U, and D is symmetric and -* block diagonal with 1-by-1 and 2-by-2 diagonal blocks. -* -* This is the unblocked version of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* n-by-n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n-by-n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, the block diagonal matrix D and the multipliers used -* to obtain the factor U or L (see below for further details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (output) INTEGER array, dimension (N) -* Details of the interchanges and the block structure of D. -* If IPIV(k) > 0, then rows and columns k and IPIV(k) were -* interchanged and D(k,k) is a 1-by-1 diagonal block. -* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, D(k,k) is exactly zero. The factorization -* has been completed, but the block diagonal matrix D is -* exactly singular, and division by zero will occur if it -* is used to solve a system of equations. -* -* Further Details -* =============== -* -* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services -* Company -* -* If UPLO = 'U', then A = U*D*U', where -* U = P(n)*U(n)* ... *P(k)U(k)* ..., -* i.e., U is a product of terms P(k)*U(k), where k decreases from n to -* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 -* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as -* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such -* that if the diagonal block D(k) is of order s (s = 1 or 2), then -* -* ( I v 0 ) k-s -* U(k) = ( 0 I 0 ) s -* ( 0 0 I ) n-k -* k-s s n-k -* -* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). -* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), -* and A(k,k), and v overwrites A(1:k-2,k-1:k). -* -* If UPLO = 'L', then A = L*D*L', where -* L = P(1)*L(1)* ... *P(k)*L(k)* ..., -* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to -* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 -* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as -* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such -* that if the diagonal block D(k) is of order s (s = 1 or 2), then -* -* ( I 0 0 ) k-1 -* L(k) = ( 0 I 0 ) s -* ( 0 v I ) n-k-s+1 -* k-1 s n-k-s+1 -* -* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). -* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), -* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION EIGHT, SEVTEN - PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP - DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, - $ ROWMAX, T, WK, WKM1, WKP1 -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - EXTERNAL LSAME, IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DSWAP, DSYR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYTF2', -INFO ) - RETURN - END IF -* -* Initialize ALPHA for use in choosing pivot block size. -* - ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT -* - IF( UPPER ) THEN -* -* Factorize A as U*D*U' using the upper triangle of A -* -* K is the main loop index, decreasing from N to 1 in steps of -* 1 or 2 -* - K = N - 10 CONTINUE -* -* If K < 1, exit from loop -* - IF( K.LT.1 ) - $ GO TO 70 - KSTEP = 1 -* -* Determine rows and columns to be interchanged and whether -* a 1-by-1 or 2-by-2 pivot block will be used -* - ABSAKK = ABS( A( K, K ) ) -* -* IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value -* - IF( K.GT.1 ) THEN - IMAX = IDAMAX( K-1, A( 1, K ), 1 ) - COLMAX = ABS( A( IMAX, K ) ) - ELSE - COLMAX = ZERO - END IF -* - IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN -* -* Column K is zero: set INFO and continue -* - IF( INFO.EQ.0 ) - $ INFO = K - KP = K - ELSE - IF( ABSAKK.GE.ALPHA*COLMAX ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE -* -* JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value -* - JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA ) - ROWMAX = ABS( A( IMAX, JMAX ) ) - IF( IMAX.GT.1 ) THEN - JMAX = IDAMAX( IMAX-1, A( 1, IMAX ), 1 ) - ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) - END IF -* - IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN -* -* interchange rows and columns K and IMAX, use 1-by-1 -* pivot block -* - KP = IMAX - ELSE -* -* interchange rows and columns K-1 and IMAX, use 2-by-2 -* pivot block -* - KP = IMAX - KSTEP = 2 - END IF - END IF -* - KK = K - KSTEP + 1 - IF( KP.NE.KK ) THEN -* -* Interchange rows and columns KK and KP in the leading -* submatrix A(1:k,1:k) -* - CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) - CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), - $ LDA ) - T = A( KK, KK ) - A( KK, KK ) = A( KP, KP ) - A( KP, KP ) = T - IF( KSTEP.EQ.2 ) THEN - T = A( K-1, K ) - A( K-1, K ) = A( KP, K ) - A( KP, K ) = T - END IF - END IF -* -* Update the leading submatrix -* - IF( KSTEP.EQ.1 ) THEN -* -* 1-by-1 pivot block D(k): column k now holds -* -* W(k) = U(k)*D(k) -* -* where U(k) is the k-th column of U -* -* Perform a rank-1 update of A(1:k-1,1:k-1) as -* -* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' -* - R1 = ONE / A( K, K ) - CALL DSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA ) -* -* Store U(k) in column k -* - CALL DSCAL( K-1, R1, A( 1, K ), 1 ) - ELSE -* -* 2-by-2 pivot block D(k): columns k and k-1 now hold -* -* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) -* -* where U(k) and U(k-1) are the k-th and (k-1)-th columns -* of U -* -* Perform a rank-2 update of A(1:k-2,1:k-2) as -* -* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' -* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' -* - IF( K.GT.2 ) THEN -* - D12 = A( K-1, K ) - D22 = A( K-1, K-1 ) / D12 - D11 = A( K, K ) / D12 - T = ONE / ( D11*D22-ONE ) - D12 = T / D12 -* - DO 30 J = K - 2, 1, -1 - WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) ) - WK = D12*( D22*A( J, K )-A( J, K-1 ) ) - DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - A( I, K )*WK - - $ A( I, K-1 )*WKM1 - 20 CONTINUE - A( J, K ) = WK - A( J, K-1 ) = WKM1 - 30 CONTINUE -* - END IF -* - END IF - END IF -* -* Store details of the interchanges in IPIV -* - IF( KSTEP.EQ.1 ) THEN - IPIV( K ) = KP - ELSE - IPIV( K ) = -KP - IPIV( K-1 ) = -KP - END IF -* -* Decrease K and return to the start of the main loop -* - K = K - KSTEP - GO TO 10 -* - ELSE -* -* Factorize A as L*D*L' using the lower triangle of A -* -* K is the main loop index, increasing from 1 to N in steps of -* 1 or 2 -* - K = 1 - 40 CONTINUE -* -* If K > N, exit from loop -* - IF( K.GT.N ) - $ GO TO 70 - KSTEP = 1 -* -* Determine rows and columns to be interchanged and whether -* a 1-by-1 or 2-by-2 pivot block will be used -* - ABSAKK = ABS( A( K, K ) ) -* -* IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value -* - IF( K.LT.N ) THEN - IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 ) - COLMAX = ABS( A( IMAX, K ) ) - ELSE - COLMAX = ZERO - END IF -* - IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN -* -* Column K is zero: set INFO and continue -* - IF( INFO.EQ.0 ) - $ INFO = K - KP = K - ELSE - IF( ABSAKK.GE.ALPHA*COLMAX ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE -* -* JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value -* - JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA ) - ROWMAX = ABS( A( IMAX, JMAX ) ) - IF( IMAX.LT.N ) THEN - JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 ) - ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) - END IF -* - IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN -* -* interchange rows and columns K and IMAX, use 1-by-1 -* pivot block -* - KP = IMAX - ELSE -* -* interchange rows and columns K+1 and IMAX, use 2-by-2 -* pivot block -* - KP = IMAX - KSTEP = 2 - END IF - END IF -* - KK = K + KSTEP - 1 - IF( KP.NE.KK ) THEN -* -* Interchange rows and columns KK and KP in the trailing -* submatrix A(k:n,k:n) -* - IF( KP.LT.N ) - $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) - CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), - $ LDA ) - T = A( KK, KK ) - A( KK, KK ) = A( KP, KP ) - A( KP, KP ) = T - IF( KSTEP.EQ.2 ) THEN - T = A( K+1, K ) - A( K+1, K ) = A( KP, K ) - A( KP, K ) = T - END IF - END IF -* -* Update the trailing submatrix -* - IF( KSTEP.EQ.1 ) THEN -* -* 1-by-1 pivot block D(k): column k now holds -* -* W(k) = L(k)*D(k) -* -* where L(k) is the k-th column of L -* - IF( K.LT.N ) THEN -* -* Perform a rank-1 update of A(k+1:n,k+1:n) as -* -* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' -* - D11 = ONE / A( K, K ) - CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, - $ A( K+1, K+1 ), LDA ) -* -* Store L(k) in column K -* - CALL DSCAL( N-K, D11, A( K+1, K ), 1 ) - END IF - ELSE -* -* 2-by-2 pivot block D(k) -* - IF( K.LT.N-1 ) THEN -* -* Perform a rank-2 update of A(k+2:n,k+2:n) as -* -* A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))' -* -* where L(k) and L(k+1) are the k-th and (k+1)-th -* columns of L -* - D21 = A( K+1, K ) - D11 = A( K+1, K+1 ) / D21 - D22 = A( K, K ) / D21 - T = ONE / ( D11*D22-ONE ) - D21 = T / D21 -* - DO 60 J = K + 2, N -* - WK = D21*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) ) -* - DO 50 I = J, N - A( I, J ) = A( I, J ) - A( I, K )*WK - - $ A( I, K+1 )*WKP1 - 50 CONTINUE -* - A( J, K ) = WK - A( J, K+1 ) = WKP1 -* - 60 CONTINUE - END IF - END IF - END IF -* -* Store details of the interchanges in IPIV -* - IF( KSTEP.EQ.1 ) THEN - IPIV( K ) = KP - ELSE - IPIV( K ) = -KP - IPIV( K+1 ) = -KP - END IF -* -* Increase K and return to the start of the main loop -* - K = K + KSTEP - GO TO 40 -* - END IF -* - 70 CONTINUE -* - RETURN -* -* End of DSYTF2 -* - END - SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, ITYPE, LDA, LDB, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZHEGS2 reduces a complex Hermitian-definite generalized -* eigenproblem to standard form. -* -* If ITYPE = 1, the problem is A*x = lambda*B*x, -* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') -* -* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or -* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. -* -* B must have been previously factorized as U'*U or L*L' by ZPOTRF. -* -* Arguments -* ========= -* -* ITYPE (input) INTEGER -* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); -* = 2 or 3: compute U*A*U' or L'*A*L. -* -* UPLO (input) CHARACTER -* Specifies whether the upper or lower triangular part of the -* Hermitian matrix A is stored, and how B has been factorized. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrices A and B. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the Hermitian matrix A. If UPLO = 'U', the leading -* n by n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the transformed matrix, stored in the -* same format as A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* B (input) COMPLEX*16 array, dimension (LDB,N) -* The triangular factor from the Cholesky factorization of B, -* as returned by ZPOTRF. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, HALF - PARAMETER ( ONE = 1.0D+0, HALF = 0.5D+0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER K - DOUBLE PRECISION AKK, BKK - COMPLEX*16 CT -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZAXPY, ZDSCAL, ZHER2, ZLACGV, ZTRMV, - $ ZTRSV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHEGS2', -INFO ) - RETURN - END IF -* - IF( ITYPE.EQ.1 ) THEN - IF( UPPER ) THEN -* -* Compute inv(U')*A*inv(U) -* - DO 10 K = 1, N -* -* Update the upper triangle of A(k:n,k:n) -* - AKK = A( K, K ) - BKK = B( K, K ) - AKK = AKK / BKK**2 - A( K, K ) = AKK - IF( K.LT.N ) THEN - CALL ZDSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA ) - CT = -HALF*AKK - CALL ZLACGV( N-K, A( K, K+1 ), LDA ) - CALL ZLACGV( N-K, B( K, K+1 ), LDB ) - CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), - $ LDA ) - CALL ZHER2( UPLO, N-K, -CONE, A( K, K+1 ), LDA, - $ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA ) - CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), - $ LDA ) - CALL ZLACGV( N-K, B( K, K+1 ), LDB ) - CALL ZTRSV( UPLO, 'Conjugate transpose', 'Non-unit', - $ N-K, B( K+1, K+1 ), LDB, A( K, K+1 ), - $ LDA ) - CALL ZLACGV( N-K, A( K, K+1 ), LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute inv(L)*A*inv(L') -* - DO 20 K = 1, N -* -* Update the lower triangle of A(k:n,k:n) -* - AKK = A( K, K ) - BKK = B( K, K ) - AKK = AKK / BKK**2 - A( K, K ) = AKK - IF( K.LT.N ) THEN - CALL ZDSCAL( N-K, ONE / BKK, A( K+1, K ), 1 ) - CT = -HALF*AKK - CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) - CALL ZHER2( UPLO, N-K, -CONE, A( K+1, K ), 1, - $ B( K+1, K ), 1, A( K+1, K+1 ), LDA ) - CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) - CALL ZTRSV( UPLO, 'No transpose', 'Non-unit', N-K, - $ B( K+1, K+1 ), LDB, A( K+1, K ), 1 ) - END IF - 20 CONTINUE - END IF - ELSE - IF( UPPER ) THEN -* -* Compute U*A*U' -* - DO 30 K = 1, N -* -* Update the upper triangle of A(1:k,1:k) -* - AKK = A( K, K ) - BKK = B( K, K ) - CALL ZTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B, - $ LDB, A( 1, K ), 1 ) - CT = HALF*AKK - CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) - CALL ZHER2( UPLO, K-1, CONE, A( 1, K ), 1, B( 1, K ), 1, - $ A, LDA ) - CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) - CALL ZDSCAL( K-1, BKK, A( 1, K ), 1 ) - A( K, K ) = AKK*BKK**2 - 30 CONTINUE - ELSE -* -* Compute L'*A*L -* - DO 40 K = 1, N -* -* Update the lower triangle of A(1:k,1:k) -* - AKK = A( K, K ) - BKK = B( K, K ) - CALL ZLACGV( K-1, A( K, 1 ), LDA ) - CALL ZTRMV( UPLO, 'Conjugate transpose', 'Non-unit', K-1, - $ B, LDB, A( K, 1 ), LDA ) - CT = HALF*AKK - CALL ZLACGV( K-1, B( K, 1 ), LDB ) - CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) - CALL ZHER2( UPLO, K-1, CONE, A( K, 1 ), LDA, B( K, 1 ), - $ LDB, A, LDA ) - CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) - CALL ZLACGV( K-1, B( K, 1 ), LDB ) - CALL ZDSCAL( K-1, BKK, A( K, 1 ), LDA ) - CALL ZLACGV( K-1, A( K, 1 ), LDA ) - A( K, K ) = AKK*BKK**2 - 40 CONTINUE - END IF - END IF - RETURN -* -* End of ZHEGS2 -* - END - DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER NORM, UPLO - INTEGER LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION WORK( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZLANHE returns the value of the one norm, or the Frobenius norm, or -* the infinity norm, or the element of largest absolute value of a -* complex hermitian matrix A. -* -* Description -* =========== -* -* ZLANHE returns the value -* -* ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm' -* ( -* ( norm1(A), NORM = '1', 'O' or 'o' -* ( -* ( normI(A), NORM = 'I' or 'i' -* ( -* ( normF(A), NORM = 'F', 'f', 'E' or 'e' -* -* where norm1 denotes the one norm of a matrix (maximum column sum), -* normI denotes the infinity norm of a matrix (maximum row sum) and -* normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies the value to be returned in ZLANHE as described -* above. -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* hermitian matrix A is to be referenced. -* = 'U': Upper triangular part of A is referenced -* = 'L': Lower triangular part of A is referenced -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. When N = 0, ZLANHE is -* set to zero. -* -* A (input) COMPLEX*16 array, dimension (LDA,N) -* The hermitian matrix A. If UPLO = 'U', the leading n by n -* upper triangular part of A contains the upper triangular part -* of the matrix A, and the strictly lower triangular part of A -* is not referenced. If UPLO = 'L', the leading n by n lower -* triangular part of A contains the lower triangular part of -* the matrix A, and the strictly upper triangular part of A is -* not referenced. Note that the imaginary parts of the diagonal -* elements need not be set and are assumed to be zero. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(N,1). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), -* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, -* WORK is not referenced. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION ABSA, SCALE, SUM, VALUE -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL ZLASSQ -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, SQRT -* .. -* .. Executable Statements .. -* - IF( N.EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, J - 1 - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 10 CONTINUE - VALUE = MAX( VALUE, ABS( DBLE( A( J, J ) ) ) ) - 20 CONTINUE - ELSE - DO 40 J = 1, N - VALUE = MAX( VALUE, ABS( DBLE( A( J, J ) ) ) ) - DO 30 I = J + 1, N - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. - $ ( NORM.EQ.'1' ) ) THEN -* -* Find normI(A) ( = norm1(A), since A is hermitian). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 60 J = 1, N - SUM = ZERO - DO 50 I = 1, J - 1 - ABSA = ABS( A( I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 50 CONTINUE - WORK( J ) = SUM + ABS( DBLE( A( J, J ) ) ) - 60 CONTINUE - DO 70 I = 1, N - VALUE = MAX( VALUE, WORK( I ) ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - WORK( I ) = ZERO - 80 CONTINUE - DO 100 J = 1, N - SUM = WORK( J ) + ABS( DBLE( A( J, J ) ) ) - DO 90 I = J + 1, N - ABSA = ABS( A( I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 90 CONTINUE - VALUE = MAX( VALUE, SUM ) - 100 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - IF( LSAME( UPLO, 'U' ) ) THEN - DO 110 J = 2, N - CALL ZLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) - 110 CONTINUE - ELSE - DO 120 J = 1, N - 1 - CALL ZLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) - 120 CONTINUE - END IF - SUM = 2*SUM - DO 130 I = 1, N - IF( DBLE( A( I, I ) ).NE.ZERO ) THEN - ABSA = ABS( DBLE( A( I, I ) ) ) - IF( SCALE.LT.ABSA ) THEN - SUM = ONE + SUM*( SCALE / ABSA )**2 - SCALE = ABSA - ELSE - SUM = SUM + ( ABSA / SCALE )**2 - END IF - END IF - 130 CONTINUE - VALUE = SCALE*SQRT( SUM ) - END IF -* - ZLANHE = VALUE - RETURN -* -* End of ZLANHE -* - END - SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER TYPE - INTEGER INFO, KL, KU, LDA, M, N - DOUBLE PRECISION CFROM, CTO -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZLASCL multiplies the M by N complex matrix A by the real scalar -* CTO/CFROM. This is done without over/underflow as long as the final -* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that -* A may be full, upper triangular, lower triangular, upper Hessenberg, -* or banded. -* -* Arguments -* ========= -* -* TYPE (input) CHARACTER*1 -* TYPE indices the storage type of the input matrix. -* = 'G': A is a full matrix. -* = 'L': A is a lower triangular matrix. -* = 'U': A is an upper triangular matrix. -* = 'H': A is an upper Hessenberg matrix. -* = 'B': A is a symmetric band matrix with lower bandwidth KL -* and upper bandwidth KU and with the only the lower -* half stored. -* = 'Q': A is a symmetric band matrix with lower bandwidth KL -* and upper bandwidth KU and with the only the upper -* half stored. -* = 'Z': A is a band matrix with lower bandwidth KL and upper -* bandwidth KU. -* -* KL (input) INTEGER -* The lower bandwidth of A. Referenced only if TYPE = 'B', -* 'Q' or 'Z'. -* -* KU (input) INTEGER -* The upper bandwidth of A. Referenced only if TYPE = 'B', -* 'Q' or 'Z'. -* -* CFROM (input) DOUBLE PRECISION -* CTO (input) DOUBLE PRECISION -* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed -* without over/underflow if the final result CTO*A(I,J)/CFROM -* can be represented without over/underflow. CFROM must be -* nonzero. -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,M) -* The matrix to be multiplied by CTO/CFROM. See TYPE for the -* storage type. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* INFO (output) INTEGER -* 0 - successful exit -* <0 - if INFO = -i, the i-th argument had an illegal value. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL DONE - INTEGER I, ITYPE, J, K1, K2, K3, K4 - DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 -* - IF( LSAME( TYPE, 'G' ) ) THEN - ITYPE = 0 - ELSE IF( LSAME( TYPE, 'L' ) ) THEN - ITYPE = 1 - ELSE IF( LSAME( TYPE, 'U' ) ) THEN - ITYPE = 2 - ELSE IF( LSAME( TYPE, 'H' ) ) THEN - ITYPE = 3 - ELSE IF( LSAME( TYPE, 'B' ) ) THEN - ITYPE = 4 - ELSE IF( LSAME( TYPE, 'Q' ) ) THEN - ITYPE = 5 - ELSE IF( LSAME( TYPE, 'Z' ) ) THEN - ITYPE = 6 - ELSE - ITYPE = -1 - END IF -* - IF( ITYPE.EQ.-1 ) THEN - INFO = -1 - ELSE IF( CFROM.EQ.ZERO ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. - $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN - INFO = -7 - ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( ITYPE.GE.4 ) THEN - IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN - INFO = -2 - ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. - $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) - $ THEN - INFO = -3 - ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. - $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. - $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN - INFO = -9 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZLASCL', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -* -* Get machine parameters -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM -* - CFROMC = CFROM - CTOC = CTO -* - 10 CONTINUE - CFROM1 = CFROMC*SMLNUM - CTO1 = CTOC / BIGNUM - IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN - MUL = SMLNUM - DONE = .FALSE. - CFROMC = CFROM1 - ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN - MUL = BIGNUM - DONE = .FALSE. - CTOC = CTO1 - ELSE - MUL = CTOC / CFROMC - DONE = .TRUE. - END IF -* - IF( ITYPE.EQ.0 ) THEN -* -* Full matrix -* - DO 30 J = 1, N - DO 20 I = 1, M - A( I, J ) = A( I, J )*MUL - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( ITYPE.EQ.1 ) THEN -* -* Lower triangular matrix -* - DO 50 J = 1, N - DO 40 I = J, M - A( I, J ) = A( I, J )*MUL - 40 CONTINUE - 50 CONTINUE -* - ELSE IF( ITYPE.EQ.2 ) THEN -* -* Upper triangular matrix -* - DO 70 J = 1, N - DO 60 I = 1, MIN( J, M ) - A( I, J ) = A( I, J )*MUL - 60 CONTINUE - 70 CONTINUE -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* Upper Hessenberg matrix -* - DO 90 J = 1, N - DO 80 I = 1, MIN( J+1, M ) - A( I, J ) = A( I, J )*MUL - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( ITYPE.EQ.4 ) THEN -* -* Lower half of a symmetric band matrix -* - K3 = KL + 1 - K4 = N + 1 - DO 110 J = 1, N - DO 100 I = 1, MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 100 CONTINUE - 110 CONTINUE -* - ELSE IF( ITYPE.EQ.5 ) THEN -* -* Upper half of a symmetric band matrix -* - K1 = KU + 2 - K3 = KU + 1 - DO 130 J = 1, N - DO 120 I = MAX( K1-J, 1 ), K3 - A( I, J ) = A( I, J )*MUL - 120 CONTINUE - 130 CONTINUE -* - ELSE IF( ITYPE.EQ.6 ) THEN -* -* Band matrix -* - K1 = KL + KU + 2 - K2 = KL + 1 - K3 = 2*KL + KU + 1 - K4 = KL + KU + 1 + M - DO 150 J = 1, N - DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 140 CONTINUE - 150 CONTINUE -* - END IF -* - IF( .NOT.DONE ) - $ GO TO 10 -* - RETURN -* -* End of ZLASCL -* - END - SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZHETRD reduces a complex Hermitian matrix A to real symmetric -* tridiagonal form T by a unitary similarity transformation: -* Q**H * A * Q = T. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the Hermitian matrix A. If UPLO = 'U', the leading -* N-by-N upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* On exit, if UPLO = 'U', the diagonal and first superdiagonal -* of A are overwritten by the corresponding elements of the -* tridiagonal matrix T, and the elements above the first -* superdiagonal, with the array TAU, represent the unitary -* matrix Q as a product of elementary reflectors; if UPLO -* = 'L', the diagonal and first subdiagonal of A are over- -* written by the corresponding elements of the tridiagonal -* matrix T, and the elements below the first subdiagonal, with -* the array TAU, represent the unitary matrix Q as a product -* of elementary reflectors. See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* D (output) DOUBLE PRECISION array, dimension (N) -* The diagonal elements of the tridiagonal matrix T: -* D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (N-1) -* The off-diagonal elements of the tridiagonal matrix T: -* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. -* -* TAU (output) COMPLEX*16 array, dimension (N-1) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= 1. -* For optimum performance LWORK >= N*NB, where NB is the -* optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* If UPLO = 'U', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(n-1) . . . H(2) H(1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a complex scalar, and v is a complex vector with -* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in -* A(1:i-1,i+1), and tau in TAU(i). -* -* If UPLO = 'L', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(1) H(2) . . . H(n-1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a complex scalar, and v is a complex vector with -* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), -* and tau in TAU(i). -* -* The contents of A on exit are illustrated by the following examples -* with n = 5: -* -* if UPLO = 'U': if UPLO = 'L': -* -* ( d e v2 v3 v4 ) ( d ) -* ( d e v3 v4 ) ( e d ) -* ( d e v4 ) ( v1 e d ) -* ( d e ) ( v1 v2 e d ) -* ( d ) ( v1 v2 v3 e d ) -* -* where d and e denote diagonal and off-diagonal elements of T, and vi -* denotes an element of the vector defining H(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER - INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZHER2K, ZHETD2, ZLATRD -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN - INFO = -9 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. -* - NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHETRD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NX = N - IWS = 1 - IF( NB.GT.1 .AND. NB.LT.N ) THEN -* -* Determine when to cross over from blocked to unblocked code -* (last block is always handled by unblocked code). -* - NX = MAX( NB, ILAENV( 3, 'ZHETRD', UPLO, N, -1, -1, -1 ) ) - IF( NX.LT.N ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: determine the -* minimum value of NB, and reduce NB or force use of -* unblocked code by setting NX = N. -* - NB = MAX( LWORK / LDWORK, 1 ) - NBMIN = ILAENV( 2, 'ZHETRD', UPLO, N, -1, -1, -1 ) - IF( NB.LT.NBMIN ) - $ NX = N - END IF - ELSE - NX = N - END IF - ELSE - NB = 1 - END IF -* - IF( UPPER ) THEN -* -* Reduce the upper triangle of A. -* Columns 1:kk are handled by the unblocked method. -* - KK = N - ( ( N-NX+NB-1 ) / NB )*NB - DO 20 I = N - NB + 1, KK + 1, -NB -* -* Reduce columns i:i+nb-1 to tridiagonal form and form the -* matrix W which is needed to update the unreduced part of -* the matrix -* - CALL ZLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, - $ LDWORK ) -* -* Update the unreduced submatrix A(1:i-1,1:i-1), using an -* update of the form: A := A - V*W' - W*V' -* - CALL ZHER2K( UPLO, 'No transpose', I-1, NB, -CONE, - $ A( 1, I ), LDA, WORK, LDWORK, ONE, A, LDA ) -* -* Copy superdiagonal elements back into A, and diagonal -* elements into D -* - DO 10 J = I, I + NB - 1 - A( J-1, J ) = E( J-1 ) - D( J ) = A( J, J ) - 10 CONTINUE - 20 CONTINUE -* -* Use unblocked code to reduce the last or only block -* - CALL ZHETD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) - ELSE -* -* Reduce the lower triangle of A -* - DO 40 I = 1, N - NX, NB -* -* Reduce columns i:i+nb-1 to tridiagonal form and form the -* matrix W which is needed to update the unreduced part of -* the matrix -* - CALL ZLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), - $ TAU( I ), WORK, LDWORK ) -* -* Update the unreduced submatrix A(i+nb:n,i+nb:n), using -* an update of the form: A := A - V*W' - W*V' -* - CALL ZHER2K( UPLO, 'No transpose', N-I-NB+1, NB, -CONE, - $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, - $ A( I+NB, I+NB ), LDA ) -* -* Copy subdiagonal elements back into A, and diagonal -* elements into D -* - DO 30 J = I, I + NB - 1 - A( J+1, J ) = E( J ) - D( J ) = A( J, J ) - 30 CONTINUE - 40 CONTINUE -* -* Use unblocked code to reduce the last or only block -* - CALL ZHETD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), - $ TAU( I ), IINFO ) - END IF -* - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZHETRD -* - END - SUBROUTINE DSTERF( N, D, E, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) -* .. -* -* Purpose -* ======= -* -* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix -* using the Pal-Walker-Kahan variant of the QL or QR algorithm. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix. N >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the n diagonal elements of the tridiagonal matrix. -* On exit, if INFO = 0, the eigenvalues in ascending order. -* -* E (input/output) DOUBLE PRECISION array, dimension (N-1) -* On entry, the (n-1) subdiagonal elements of the tridiagonal -* matrix. -* On exit, E has been destroyed. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: the algorithm failed to find all of the eigenvalues in -* a total of 30*N iterations; if INFO = i, then i -* elements of E have not converged to zero. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) -* .. -* .. Local Scalars .. - INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M, - $ NMAXIT - DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC, - $ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN, - $ SIGMA, SSFMAX, SSFMIN -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 - EXTERNAL DLAMCH, DLANST, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DLAE2, DLASCL, DLASRT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* -* Quick return if possible -* - IF( N.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'DSTERF', -INFO ) - RETURN - END IF - IF( N.LE.1 ) - $ RETURN -* -* Determine the unit roundoff for this environment. -* - EPS = DLAMCH( 'E' ) - EPS2 = EPS**2 - SAFMIN = DLAMCH( 'S' ) - SAFMAX = ONE / SAFMIN - SSFMAX = SQRT( SAFMAX ) / THREE - SSFMIN = SQRT( SAFMIN ) / EPS2 -* -* Compute the eigenvalues of the tridiagonal matrix. -* - NMAXIT = N*MAXIT - SIGMA = ZERO - JTOT = 0 -* -* Determine where the matrix splits and choose QL or QR iteration -* for each block, according to whether top or bottom diagonal -* element is smaller. -* - L1 = 1 -* - 10 CONTINUE - IF( L1.GT.N ) - $ GO TO 170 - IF( L1.GT.1 ) - $ E( L1-1 ) = ZERO - DO 20 M = L1, N - 1 - IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ - $ 1 ) ) ) )*EPS ) THEN - E( M ) = ZERO - GO TO 30 - END IF - 20 CONTINUE - M = N -* - 30 CONTINUE - L = L1 - LSV = L - LEND = M - LENDSV = LEND - L1 = M + 1 - IF( LEND.EQ.L ) - $ GO TO 10 -* -* Scale submatrix in rows and columns L to LEND -* - ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) - ISCALE = 0 - IF( ANORM.GT.SSFMAX ) THEN - ISCALE = 1 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, - $ INFO ) - ELSE IF( ANORM.LT.SSFMIN ) THEN - ISCALE = 2 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, - $ INFO ) - END IF -* - DO 40 I = L, LEND - 1 - E( I ) = E( I )**2 - 40 CONTINUE -* -* Choose between QL and QR iteration -* - IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN - LEND = LSV - L = LENDSV - END IF -* - IF( LEND.GE.L ) THEN -* -* QL Iteration -* -* Look for small subdiagonal element. -* - 50 CONTINUE - IF( L.NE.LEND ) THEN - DO 60 M = L, LEND - 1 - IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) ) - $ GO TO 70 - 60 CONTINUE - END IF - M = LEND -* - 70 CONTINUE - IF( M.LT.LEND ) - $ E( M ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 90 -* -* If remaining matrix is 2 by 2, use DLAE2 to compute its -* eigenvalues. -* - IF( M.EQ.L+1 ) THEN - RTE = SQRT( E( L ) ) - CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 ) - D( L ) = RT1 - D( L+1 ) = RT2 - E( L ) = ZERO - L = L + 2 - IF( L.LE.LEND ) - $ GO TO 50 - GO TO 150 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 150 - JTOT = JTOT + 1 -* -* Form shift. -* - RTE = SQRT( E( L ) ) - SIGMA = ( D( L+1 )-P ) / ( TWO*RTE ) - R = DLAPY2( SIGMA, ONE ) - SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) -* - C = ONE - S = ZERO - GAMMA = D( M ) - SIGMA - P = GAMMA*GAMMA -* -* Inner loop -* - DO 80 I = M - 1, L, -1 - BB = E( I ) - R = P + BB - IF( I.NE.M-1 ) - $ E( I+1 ) = S*R - OLDC = C - C = P / R - S = BB / R - OLDGAM = GAMMA - ALPHA = D( I ) - GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM - D( I+1 ) = OLDGAM + ( ALPHA-GAMMA ) - IF( C.NE.ZERO ) THEN - P = ( GAMMA*GAMMA ) / C - ELSE - P = OLDC*BB - END IF - 80 CONTINUE -* - E( L ) = S*P - D( L ) = SIGMA + GAMMA - GO TO 50 -* -* Eigenvalue found. -* - 90 CONTINUE - D( L ) = P -* - L = L + 1 - IF( L.LE.LEND ) - $ GO TO 50 - GO TO 150 -* - ELSE -* -* QR Iteration -* -* Look for small superdiagonal element. -* - 100 CONTINUE - DO 110 M = L, LEND + 1, -1 - IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) ) - $ GO TO 120 - 110 CONTINUE - M = LEND -* - 120 CONTINUE - IF( M.GT.LEND ) - $ E( M-1 ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 140 -* -* If remaining matrix is 2 by 2, use DLAE2 to compute its -* eigenvalues. -* - IF( M.EQ.L-1 ) THEN - RTE = SQRT( E( L-1 ) ) - CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 ) - D( L ) = RT1 - D( L-1 ) = RT2 - E( L-1 ) = ZERO - L = L - 2 - IF( L.GE.LEND ) - $ GO TO 100 - GO TO 150 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 150 - JTOT = JTOT + 1 -* -* Form shift. -* - RTE = SQRT( E( L-1 ) ) - SIGMA = ( D( L-1 )-P ) / ( TWO*RTE ) - R = DLAPY2( SIGMA, ONE ) - SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) -* - C = ONE - S = ZERO - GAMMA = D( M ) - SIGMA - P = GAMMA*GAMMA -* -* Inner loop -* - DO 130 I = M, L - 1 - BB = E( I ) - R = P + BB - IF( I.NE.M ) - $ E( I-1 ) = S*R - OLDC = C - C = P / R - S = BB / R - OLDGAM = GAMMA - ALPHA = D( I+1 ) - GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM - D( I ) = OLDGAM + ( ALPHA-GAMMA ) - IF( C.NE.ZERO ) THEN - P = ( GAMMA*GAMMA ) / C - ELSE - P = OLDC*BB - END IF - 130 CONTINUE -* - E( L-1 ) = S*P - D( L ) = SIGMA + GAMMA - GO TO 100 -* -* Eigenvalue found. -* - 140 CONTINUE - D( L ) = P -* - L = L - 1 - IF( L.GE.LEND ) - $ GO TO 100 - GO TO 150 -* - END IF -* -* Undo scaling if necessary -* - 150 CONTINUE - IF( ISCALE.EQ.1 ) - $ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - IF( ISCALE.EQ.2 ) - $ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) -* -* Check for no convergence to an eigenvalue after a total -* of N*MAXIT iterations. -* - IF( JTOT.LT.NMAXIT ) - $ GO TO 10 - DO 160 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 160 CONTINUE - GO TO 180 -* -* Sort eigenvalues in increasing order. -* - 170 CONTINUE - CALL DLASRT( 'I', N, D, INFO ) -* - 180 CONTINUE - RETURN -* -* End of DSTERF -* - END - SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNGTR generates a complex unitary matrix Q which is defined as the -* product of n-1 elementary reflectors of order N, as returned by -* ZHETRD: -* -* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), -* -* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A contains elementary reflectors -* from ZHETRD; -* = 'L': Lower triangle of A contains elementary reflectors -* from ZHETRD. -* -* N (input) INTEGER -* The order of the matrix Q. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the vectors which define the elementary reflectors, -* as returned by ZHETRD. -* On exit, the N-by-N unitary matrix Q. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= N. -* -* TAU (input) COMPLEX*16 array, dimension (N-1) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZHETRD. -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= N-1. -* For optimum performance LWORK >= (N-1)*NB, where NB is -* the optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER - INTEGER I, IINFO, J, LWKOPT, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZUNGQL, ZUNGQR -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( UPPER ) THEN - NB = ILAENV( 1, 'ZUNGQL', ' ', N-1, N-1, N-1, -1 ) - ELSE - NB = ILAENV( 1, 'ZUNGQR', ' ', N-1, N-1, N-1, -1 ) - END IF - LWKOPT = MAX( 1, N-1 )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNGTR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( UPPER ) THEN -* -* Q was determined by a call to ZHETRD with UPLO = 'U' -* -* Shift the vectors which define the elementary reflectors one -* column to the left, and set the last row and column of Q to -* those of the unit matrix -* - DO 20 J = 1, N - 1 - DO 10 I = 1, J - 1 - A( I, J ) = A( I, J+1 ) - 10 CONTINUE - A( N, J ) = ZERO - 20 CONTINUE - DO 30 I = 1, N - 1 - A( I, N ) = ZERO - 30 CONTINUE - A( N, N ) = ONE -* -* Generate Q(1:n-1,1:n-1) -* - CALL ZUNGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* Q was determined by a call to ZHETRD with UPLO = 'L'. -* -* Shift the vectors which define the elementary reflectors one -* column to the right, and set the first row and column of Q to -* those of the unit matrix -* - DO 50 J = N, 2, -1 - A( 1, J ) = ZERO - DO 40 I = J + 1, N - A( I, J ) = A( I, J-1 ) - 40 CONTINUE - 50 CONTINUE - A( 1, 1 ) = ONE - DO 60 I = 2, N - A( I, 1 ) = ZERO - 60 CONTINUE - IF( N.GT.1 ) THEN -* -* Generate Q(2:n,2:n) -* - CALL ZUNGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNGTR -* - END - SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER COMPZ - INTEGER INFO, LDZ, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ), WORK( * ) - COMPLEX*16 Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a -* symmetric tridiagonal matrix using the implicit QL or QR method. -* The eigenvectors of a full or band complex Hermitian matrix can also -* be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this -* matrix to tridiagonal form. -* -* Arguments -* ========= -* -* COMPZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only. -* = 'V': Compute eigenvalues and eigenvectors of the original -* Hermitian matrix. On entry, Z must contain the -* unitary matrix used to reduce the original matrix -* to tridiagonal form. -* = 'I': Compute eigenvalues and eigenvectors of the -* tridiagonal matrix. Z is initialized to the identity -* matrix. -* -* N (input) INTEGER -* The order of the matrix. N >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the diagonal elements of the tridiagonal matrix. -* On exit, if INFO = 0, the eigenvalues in ascending order. -* -* E (input/output) DOUBLE PRECISION array, dimension (N-1) -* On entry, the (n-1) subdiagonal elements of the tridiagonal -* matrix. -* On exit, E has been destroyed. -* -* Z (input/output) COMPLEX*16 array, dimension (LDZ, N) -* On entry, if COMPZ = 'V', then Z contains the unitary -* matrix used in the reduction to tridiagonal form. -* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the -* orthonormal eigenvectors of the original Hermitian matrix, -* and if COMPZ = 'I', Z contains the orthonormal eigenvectors -* of the symmetric tridiagonal matrix. -* If COMPZ = 'N', then Z is not referenced. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= 1, and if -* eigenvectors are desired, then LDZ >= max(1,N). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) -* If COMPZ = 'N', then WORK is not referenced. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: the algorithm has failed to find all the eigenvalues in -* a total of 30*N iterations; if INFO = i, then i -* elements of E have not converged to zero; on exit, D -* and E contain the elements of a symmetric tridiagonal -* matrix which is unitarily similar to the original -* matrix. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) - COMPLEX*16 CZERO, CONE - PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), - $ CONE = ( 1.0D0, 0.0D0 ) ) - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) -* .. -* .. Local Scalars .. - INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, - $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, - $ NM1, NMAXIT - DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, - $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 - EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA, - $ ZLASET, ZLASR, ZSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( LSAME( COMPZ, 'N' ) ) THEN - ICOMPZ = 0 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ICOMPZ = 2 - ELSE - ICOMPZ = -1 - END IF - IF( ICOMPZ.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, - $ N ) ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZSTEQR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - IF( ICOMPZ.EQ.2 ) - $ Z( 1, 1 ) = CONE - RETURN - END IF -* -* Determine the unit roundoff and over/underflow thresholds. -* - EPS = DLAMCH( 'E' ) - EPS2 = EPS**2 - SAFMIN = DLAMCH( 'S' ) - SAFMAX = ONE / SAFMIN - SSFMAX = SQRT( SAFMAX ) / THREE - SSFMIN = SQRT( SAFMIN ) / EPS2 -* -* Compute the eigenvalues and eigenvectors of the tridiagonal -* matrix. -* - IF( ICOMPZ.EQ.2 ) - $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) -* - NMAXIT = N*MAXIT - JTOT = 0 -* -* Determine where the matrix splits and choose QL or QR iteration -* for each block, according to whether top or bottom diagonal -* element is smaller. -* - L1 = 1 - NM1 = N - 1 -* - 10 CONTINUE - IF( L1.GT.N ) - $ GO TO 160 - IF( L1.GT.1 ) - $ E( L1-1 ) = ZERO - IF( L1.LE.NM1 ) THEN - DO 20 M = L1, NM1 - TST = ABS( E( M ) ) - IF( TST.EQ.ZERO ) - $ GO TO 30 - IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ - $ 1 ) ) ) )*EPS ) THEN - E( M ) = ZERO - GO TO 30 - END IF - 20 CONTINUE - END IF - M = N -* - 30 CONTINUE - L = L1 - LSV = L - LEND = M - LENDSV = LEND - L1 = M + 1 - IF( LEND.EQ.L ) - $ GO TO 10 -* -* Scale submatrix in rows and columns L to LEND -* - ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) - ISCALE = 0 - IF( ANORM.EQ.ZERO ) - $ GO TO 10 - IF( ANORM.GT.SSFMAX ) THEN - ISCALE = 1 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, - $ INFO ) - ELSE IF( ANORM.LT.SSFMIN ) THEN - ISCALE = 2 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, - $ INFO ) - END IF -* -* Choose between QL and QR iteration -* - IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN - LEND = LSV - L = LENDSV - END IF -* - IF( LEND.GT.L ) THEN -* -* QL Iteration -* -* Look for small subdiagonal element. -* - 40 CONTINUE - IF( L.NE.LEND ) THEN - LENDM1 = LEND - 1 - DO 50 M = L, LENDM1 - TST = ABS( E( M ) )**2 - IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ - $ SAFMIN )GO TO 60 - 50 CONTINUE - END IF -* - M = LEND -* - 60 CONTINUE - IF( M.LT.LEND ) - $ E( M ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 80 -* -* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -* to compute its eigensystem. -* - IF( M.EQ.L+1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) - WORK( L ) = C - WORK( N-1+L ) = S - CALL ZLASR( 'R', 'V', 'B', N, 2, WORK( L ), - $ WORK( N-1+L ), Z( 1, L ), LDZ ) - ELSE - CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) - END IF - D( L ) = RT1 - D( L+1 ) = RT2 - E( L ) = ZERO - L = L + 2 - IF( L.LE.LEND ) - $ GO TO 40 - GO TO 140 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 140 - JTOT = JTOT + 1 -* -* Form shift. -* - G = ( D( L+1 )-P ) / ( TWO*E( L ) ) - R = DLAPY2( G, ONE ) - G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) -* - S = ONE - C = ONE - P = ZERO -* -* Inner loop -* - MM1 = M - 1 - DO 70 I = MM1, L, -1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M-1 ) - $ E( I+1 ) = R - G = D( I+1 ) - P - R = ( D( I )-G )*S + TWO*C*B - P = S*R - D( I+1 ) = G + P - G = C*R - B -* -* If eigenvectors are desired, then save rotations. -* - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = -S - END IF -* - 70 CONTINUE -* -* If eigenvectors are desired, then apply saved rotations. -* - IF( ICOMPZ.GT.0 ) THEN - MM = M - L + 1 - CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), - $ Z( 1, L ), LDZ ) - END IF -* - D( L ) = D( L ) - P - E( L ) = G - GO TO 40 -* -* Eigenvalue found. -* - 80 CONTINUE - D( L ) = P -* - L = L + 1 - IF( L.LE.LEND ) - $ GO TO 40 - GO TO 140 -* - ELSE -* -* QR Iteration -* -* Look for small superdiagonal element. -* - 90 CONTINUE - IF( L.NE.LEND ) THEN - LENDP1 = LEND + 1 - DO 100 M = L, LENDP1, -1 - TST = ABS( E( M-1 ) )**2 - IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ - $ SAFMIN )GO TO 110 - 100 CONTINUE - END IF -* - M = LEND -* - 110 CONTINUE - IF( M.GT.LEND ) - $ E( M-1 ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 130 -* -* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -* to compute its eigensystem. -* - IF( M.EQ.L-1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) - WORK( M ) = C - WORK( N-1+M ) = S - CALL ZLASR( 'R', 'V', 'F', N, 2, WORK( M ), - $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) - ELSE - CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) - END IF - D( L-1 ) = RT1 - D( L ) = RT2 - E( L-1 ) = ZERO - L = L - 2 - IF( L.GE.LEND ) - $ GO TO 90 - GO TO 140 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 140 - JTOT = JTOT + 1 -* -* Form shift. -* - G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) - R = DLAPY2( G, ONE ) - G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) -* - S = ONE - C = ONE - P = ZERO -* -* Inner loop -* - LM1 = L - 1 - DO 120 I = M, LM1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M ) - $ E( I-1 ) = R - G = D( I ) - P - R = ( D( I+1 )-G )*S + TWO*C*B - P = S*R - D( I ) = G + P - G = C*R - B -* -* If eigenvectors are desired, then save rotations. -* - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = S - END IF -* - 120 CONTINUE -* -* If eigenvectors are desired, then apply saved rotations. -* - IF( ICOMPZ.GT.0 ) THEN - MM = L - M + 1 - CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), - $ Z( 1, M ), LDZ ) - END IF -* - D( L ) = D( L ) - P - E( LM1 ) = G - GO TO 90 -* -* Eigenvalue found. -* - 130 CONTINUE - D( L ) = P -* - L = L - 1 - IF( L.GE.LEND ) - $ GO TO 90 - GO TO 140 -* - END IF -* -* Undo scaling if necessary -* - 140 CONTINUE - IF( ISCALE.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), - $ N, INFO ) - ELSE IF( ISCALE.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), - $ N, INFO ) - END IF -* -* Check for no convergence to an eigenvalue after a total -* of N*MAXIT iterations. -* - IF( JTOT.EQ.NMAXIT ) THEN - DO 150 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 150 CONTINUE - RETURN - END IF - GO TO 10 -* -* Order eigenvalues and eigenvectors. -* - 160 CONTINUE - IF( ICOMPZ.EQ.0 ) THEN -* -* Use Quick Sort -* - CALL DLASRT( 'I', N, D, INFO ) -* - ELSE -* -* Use Selection Sort to minimize swaps of eigenvectors -* - DO 180 II = 2, N - I = II - 1 - K = I - P = D( I ) - DO 170 J = II, N - IF( D( J ).LT.P ) THEN - K = J - P = D( J ) - END IF - 170 CONTINUE - IF( K.NE.I ) THEN - D( K ) = D( I ) - D( I ) = P - CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) - END IF - 180 CONTINUE - END IF - RETURN -* -* End of ZSTEQR -* - END - SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZLACPY copies all or part of a two-dimensional matrix A to another -* matrix B. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies the part of the matrix A to be copied to B. -* = 'U': Upper triangular part -* = 'L': Lower triangular part -* Otherwise: All of the matrix A -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input) COMPLEX*16 array, dimension (LDA,N) -* The m by n matrix A. If UPLO = 'U', only the upper trapezium -* is accessed; if UPLO = 'L', only the lower trapezium is -* accessed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* B (output) COMPLEX*16 array, dimension (LDB,N) -* On exit, B = A in the locations specified by UPLO. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,M). -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) - B( I, J ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE -* - ELSE IF( LSAME( UPLO, 'L' ) ) THEN - DO 40 J = 1, N - DO 30 I = J, M - B( I, J ) = A( I, J ) - 30 CONTINUE - 40 CONTINUE -* - ELSE - DO 60 J = 1, N - DO 50 I = 1, M - B( I, J ) = A( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - RETURN -* -* End of ZLACPY -* - END - SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, - $ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, - $ INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER ORDER, RANGE - INTEGER IL, INFO, IU, M, N, NSPLIT - DOUBLE PRECISION ABSTOL, VL, VU -* .. -* .. Array Arguments .. - INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ) - DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DSTEBZ computes the eigenvalues of a symmetric tridiagonal -* matrix T. The user may ask for all eigenvalues, all eigenvalues -* in the half-open interval (VL, VU], or the IL-th through IU-th -* eigenvalues. -* -* To avoid overflow, the matrix must be scaled so that its -* largest element is no greater than overflow**(1/2) * -* underflow**(1/4) in absolute value, and for greatest -* accuracy, it should not be much smaller than that. -* -* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal -* Matrix", Report CS41, Computer Science Dept., Stanford -* University, July 21, 1966. -* -* Arguments -* ========= -* -* RANGE (input) CHARACTER -* = 'A': ("All") all eigenvalues will be found. -* = 'V': ("Value") all eigenvalues in the half-open interval -* (VL, VU] will be found. -* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the -* entire matrix) will be found. -* -* ORDER (input) CHARACTER -* = 'B': ("By Block") the eigenvalues will be grouped by -* split-off block (see IBLOCK, ISPLIT) and -* ordered from smallest to largest within -* the block. -* = 'E': ("Entire matrix") -* the eigenvalues for the entire matrix -* will be ordered from smallest to -* largest. -* -* N (input) INTEGER -* The order of the tridiagonal matrix T. N >= 0. -* -* VL (input) DOUBLE PRECISION -* VU (input) DOUBLE PRECISION -* If RANGE='V', the lower and upper bounds of the interval to -* be searched for eigenvalues. Eigenvalues less than or equal -* to VL, or greater than VU, will not be returned. VL < VU. -* Not referenced if RANGE = 'A' or 'I'. -* -* IL (input) INTEGER -* IU (input) INTEGER -* If RANGE='I', the indices (in ascending order) of the -* smallest and largest eigenvalues to be returned. -* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. -* Not referenced if RANGE = 'A' or 'V'. -* -* ABSTOL (input) DOUBLE PRECISION -* The absolute tolerance for the eigenvalues. An eigenvalue -* (or cluster) is considered to be located if it has been -* determined to lie in an interval whose width is ABSTOL or -* less. If ABSTOL is less than or equal to zero, then ULP*|T| -* will be used, where |T| means the 1-norm of T. -* -* Eigenvalues will be computed most accurately when ABSTOL is -* set to twice the underflow threshold 2*DLAMCH('S'), not zero. -* -* D (input) DOUBLE PRECISION array, dimension (N) -* The n diagonal elements of the tridiagonal matrix T. -* -* E (input) DOUBLE PRECISION array, dimension (N-1) -* The (n-1) off-diagonal elements of the tridiagonal matrix T. -* -* M (output) INTEGER -* The actual number of eigenvalues found. 0 <= M <= N. -* (See also the description of INFO=2,3.) -* -* NSPLIT (output) INTEGER -* The number of diagonal blocks in the matrix T. -* 1 <= NSPLIT <= N. -* -* W (output) DOUBLE PRECISION array, dimension (N) -* On exit, the first M elements of W will contain the -* eigenvalues. (DSTEBZ may use the remaining N-M elements as -* workspace.) -* -* IBLOCK (output) INTEGER array, dimension (N) -* At each row/column j where E(j) is zero or small, the -* matrix T is considered to split into a block diagonal -* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which -* block (from 1 to the number of blocks) the eigenvalue W(i) -* belongs. (DSTEBZ may use the remaining N-M elements as -* workspace.) -* -* ISPLIT (output) INTEGER array, dimension (N) -* The splitting points, at which T breaks up into submatrices. -* The first submatrix consists of rows/columns 1 to ISPLIT(1), -* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), -* etc., and the NSPLIT-th consists of rows/columns -* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. -* (Only the first NSPLIT elements will actually be used, but -* since the user cannot know a priori what value NSPLIT will -* have, N words must be reserved for ISPLIT.) -* -* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) -* -* IWORK (workspace) INTEGER array, dimension (3*N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: some or all of the eigenvalues failed to converge or -* were not computed: -* =1 or 3: Bisection failed to converge for some -* eigenvalues; these eigenvalues are flagged by a -* negative block number. The effect is that the -* eigenvalues may not be as accurate as the -* absolute and relative tolerances. This is -* generally caused by unexpectedly inaccurate -* arithmetic. -* =2 or 3: RANGE='I' only: Not all of the eigenvalues -* IL:IU were found. -* Effect: M < IU+1-IL -* Cause: non-monotonic arithmetic, causing the -* Sturm sequence to be non-monotonic. -* Cure: recalculate, using RANGE='A', and pick -* out eigenvalues IL:IU. In some cases, -* increasing the PARAMETER "FUDGE" may -* make things work. -* = 4: RANGE='I', and the Gershgorin interval -* initially used was too small. No eigenvalues -* were computed. -* Probable cause: your machine has sloppy -* floating-point arithmetic. -* Cure: Increase the PARAMETER "FUDGE", -* recompile, and try again. -* -* Internal Parameters -* =================== -* -* RELFAC DOUBLE PRECISION, default = 2.0e0 -* The relative tolerance. An interval (a,b] lies within -* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|), -* where "ulp" is the machine precision (distance from 1 to -* the next larger floating point number.) -* -* FUDGE DOUBLE PRECISION, default = 2 -* A "fudge factor" to widen the Gershgorin intervals. Ideally, -* a value of 1 should work, but on machines with sloppy -* arithmetic, this needs to be larger. The default for -* publicly released versions should be large enough to handle -* the worst machine around. Note that this has no effect -* on accuracy of the solution. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, HALF - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ HALF = 1.0D0 / TWO ) - DOUBLE PRECISION FUDGE, RELFAC - PARAMETER ( FUDGE = 2.0D0, RELFAC = 2.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL NCNVRG, TOOFEW - INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO, - $ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX, - $ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL, - $ NWU - DOUBLE PRECISION ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN, - $ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL -* .. -* .. Local Arrays .. - INTEGER IDUMMA( 1 ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, ILAENV, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLAEBZ, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - INFO = 0 -* -* Decode RANGE -* - IF( LSAME( RANGE, 'A' ) ) THEN - IRANGE = 1 - ELSE IF( LSAME( RANGE, 'V' ) ) THEN - IRANGE = 2 - ELSE IF( LSAME( RANGE, 'I' ) ) THEN - IRANGE = 3 - ELSE - IRANGE = 0 - END IF -* -* Decode ORDER -* - IF( LSAME( ORDER, 'B' ) ) THEN - IORDER = 2 - ELSE IF( LSAME( ORDER, 'E' ) ) THEN - IORDER = 1 - ELSE - IORDER = 0 - END IF -* -* Check for Errors -* - IF( IRANGE.LE.0 ) THEN - INFO = -1 - ELSE IF( IORDER.LE.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( IRANGE.EQ.2 ) THEN - IF( VL.GE.VU ) - $ INFO = -5 - ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) - $ THEN - INFO = -6 - ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) - $ THEN - INFO = -7 - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSTEBZ', -INFO ) - RETURN - END IF -* -* Initialize error flags -* - INFO = 0 - NCNVRG = .FALSE. - TOOFEW = .FALSE. -* -* Quick return if possible -* - M = 0 - IF( N.EQ.0 ) - $ RETURN -* -* Simplifications: -* - IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N ) - $ IRANGE = 1 -* -* Get machine constants -* NB is the minimum vector length for vector bisection, or 0 -* if only scalar is to be done. -* - SAFEMN = DLAMCH( 'S' ) - ULP = DLAMCH( 'P' ) - RTOLI = ULP*RELFAC - NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 ) - IF( NB.LE.1 ) - $ NB = 0 -* -* Special Case when N=1 -* - IF( N.EQ.1 ) THEN - NSPLIT = 1 - ISPLIT( 1 ) = 1 - IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN - M = 0 - ELSE - W( 1 ) = D( 1 ) - IBLOCK( 1 ) = 1 - M = 1 - END IF - RETURN - END IF -* -* Compute Splitting Points -* - NSPLIT = 1 - WORK( N ) = ZERO - PIVMIN = ONE -* -*DIR$ NOVECTOR - DO 10 J = 2, N - TMP1 = E( J-1 )**2 - IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN - ISPLIT( NSPLIT ) = J - 1 - NSPLIT = NSPLIT + 1 - WORK( J-1 ) = ZERO - ELSE - WORK( J-1 ) = TMP1 - PIVMIN = MAX( PIVMIN, TMP1 ) - END IF - 10 CONTINUE - ISPLIT( NSPLIT ) = N - PIVMIN = PIVMIN*SAFEMN -* -* Compute Interval and ATOLI -* - IF( IRANGE.EQ.3 ) THEN -* -* RANGE='I': Compute the interval containing eigenvalues -* IL through IU. -* -* Compute Gershgorin interval for entire (split) matrix -* and use it as the initial interval -* - GU = D( 1 ) - GL = D( 1 ) - TMP1 = ZERO -* - DO 20 J = 1, N - 1 - TMP2 = SQRT( WORK( J ) ) - GU = MAX( GU, D( J )+TMP1+TMP2 ) - GL = MIN( GL, D( J )-TMP1-TMP2 ) - TMP1 = TMP2 - 20 CONTINUE -* - GU = MAX( GU, D( N )+TMP1 ) - GL = MIN( GL, D( N )-TMP1 ) - TNORM = MAX( ABS( GL ), ABS( GU ) ) - GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN - GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN -* -* Compute Iteration parameters -* - ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / - $ LOG( TWO ) ) + 2 - IF( ABSTOL.LE.ZERO ) THEN - ATOLI = ULP*TNORM - ELSE - ATOLI = ABSTOL - END IF -* - WORK( N+1 ) = GL - WORK( N+2 ) = GL - WORK( N+3 ) = GU - WORK( N+4 ) = GU - WORK( N+5 ) = GL - WORK( N+6 ) = GU - IWORK( 1 ) = -1 - IWORK( 2 ) = -1 - IWORK( 3 ) = N + 1 - IWORK( 4 ) = N + 1 - IWORK( 5 ) = IL - 1 - IWORK( 6 ) = IU -* - CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E, - $ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT, - $ IWORK, W, IBLOCK, IINFO ) -* - IF( IWORK( 6 ).EQ.IU ) THEN - WL = WORK( N+1 ) - WLU = WORK( N+3 ) - NWL = IWORK( 1 ) - WU = WORK( N+4 ) - WUL = WORK( N+2 ) - NWU = IWORK( 4 ) - ELSE - WL = WORK( N+2 ) - WLU = WORK( N+4 ) - NWL = IWORK( 2 ) - WU = WORK( N+3 ) - WUL = WORK( N+1 ) - NWU = IWORK( 3 ) - END IF -* - IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN - INFO = 4 - RETURN - END IF - ELSE -* -* RANGE='A' or 'V' -- Set ATOLI -* - TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), - $ ABS( D( N ) )+ABS( E( N-1 ) ) ) -* - DO 30 J = 2, N - 1 - TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+ - $ ABS( E( J ) ) ) - 30 CONTINUE -* - IF( ABSTOL.LE.ZERO ) THEN - ATOLI = ULP*TNORM - ELSE - ATOLI = ABSTOL - END IF -* - IF( IRANGE.EQ.2 ) THEN - WL = VL - WU = VU - ELSE - WL = ZERO - WU = ZERO - END IF - END IF -* -* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU. -* NWL accumulates the number of eigenvalues .le. WL, -* NWU accumulates the number of eigenvalues .le. WU -* - M = 0 - IEND = 0 - INFO = 0 - NWL = 0 - NWU = 0 -* - DO 70 JB = 1, NSPLIT - IOFF = IEND - IBEGIN = IOFF + 1 - IEND = ISPLIT( JB ) - IN = IEND - IOFF -* - IF( IN.EQ.1 ) THEN -* -* Special Case -- IN=1 -* - IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN ) - $ NWL = NWL + 1 - IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN ) - $ NWU = NWU + 1 - IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE. - $ D( IBEGIN )-PIVMIN ) ) THEN - M = M + 1 - W( M ) = D( IBEGIN ) - IBLOCK( M ) = JB - END IF - ELSE -* -* General Case -- IN > 1 -* -* Compute Gershgorin Interval -* and use it as the initial interval -* - GU = D( IBEGIN ) - GL = D( IBEGIN ) - TMP1 = ZERO -* - DO 40 J = IBEGIN, IEND - 1 - TMP2 = ABS( E( J ) ) - GU = MAX( GU, D( J )+TMP1+TMP2 ) - GL = MIN( GL, D( J )-TMP1-TMP2 ) - TMP1 = TMP2 - 40 CONTINUE -* - GU = MAX( GU, D( IEND )+TMP1 ) - GL = MIN( GL, D( IEND )-TMP1 ) - BNORM = MAX( ABS( GL ), ABS( GU ) ) - GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN - GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN -* -* Compute ATOLI for the current submatrix -* - IF( ABSTOL.LE.ZERO ) THEN - ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) ) - ELSE - ATOLI = ABSTOL - END IF -* - IF( IRANGE.GT.1 ) THEN - IF( GU.LT.WL ) THEN - NWL = NWL + IN - NWU = NWU + IN - GO TO 70 - END IF - GL = MAX( GL, WL ) - GU = MIN( GU, WU ) - IF( GL.GE.GU ) - $ GO TO 70 - END IF -* -* Set Up Initial Interval -* - WORK( N+1 ) = GL - WORK( N+IN+1 ) = GU - CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, - $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), - $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM, - $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) -* - NWL = NWL + IWORK( 1 ) - NWU = NWU + IWORK( IN+1 ) - IWOFF = M - IWORK( 1 ) -* -* Compute Eigenvalues -* - ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) / - $ LOG( TWO ) ) + 2 - CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, - $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), - $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT, - $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) -* -* Copy Eigenvalues Into W and IBLOCK -* Use -JB for block number for unconverged eigenvalues. -* - DO 60 J = 1, IOUT - TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) ) -* -* Flag non-convergence. -* - IF( J.GT.IOUT-IINFO ) THEN - NCNVRG = .TRUE. - IB = -JB - ELSE - IB = JB - END IF - DO 50 JE = IWORK( J ) + 1 + IWOFF, - $ IWORK( J+IN ) + IWOFF - W( JE ) = TMP1 - IBLOCK( JE ) = IB - 50 CONTINUE - 60 CONTINUE -* - M = M + IM - END IF - 70 CONTINUE -* -* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU -* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. -* - IF( IRANGE.EQ.3 ) THEN - IM = 0 - IDISCL = IL - 1 - NWL - IDISCU = NWU - IU -* - IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN - DO 80 JE = 1, M - IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN - IDISCL = IDISCL - 1 - ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN - IDISCU = IDISCU - 1 - ELSE - IM = IM + 1 - W( IM ) = W( JE ) - IBLOCK( IM ) = IBLOCK( JE ) - END IF - 80 CONTINUE - M = IM - END IF - IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN -* -* Code to deal with effects of bad arithmetic: -* Some low eigenvalues to be discarded are not in (WL,WLU], -* or high eigenvalues to be discarded are not in (WUL,WU] -* so just kill off the smallest IDISCL/largest IDISCU -* eigenvalues, by simply finding the smallest/largest -* eigenvalue(s). -* -* (If N(w) is monotone non-decreasing, this should never -* happen.) -* - IF( IDISCL.GT.0 ) THEN - WKILL = WU - DO 100 JDISC = 1, IDISCL - IW = 0 - DO 90 JE = 1, M - IF( IBLOCK( JE ).NE.0 .AND. - $ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN - IW = JE - WKILL = W( JE ) - END IF - 90 CONTINUE - IBLOCK( IW ) = 0 - 100 CONTINUE - END IF - IF( IDISCU.GT.0 ) THEN -* - WKILL = WL - DO 120 JDISC = 1, IDISCU - IW = 0 - DO 110 JE = 1, M - IF( IBLOCK( JE ).NE.0 .AND. - $ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN - IW = JE - WKILL = W( JE ) - END IF - 110 CONTINUE - IBLOCK( IW ) = 0 - 120 CONTINUE - END IF - IM = 0 - DO 130 JE = 1, M - IF( IBLOCK( JE ).NE.0 ) THEN - IM = IM + 1 - W( IM ) = W( JE ) - IBLOCK( IM ) = IBLOCK( JE ) - END IF - 130 CONTINUE - M = IM - END IF - IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN - TOOFEW = .TRUE. - END IF - END IF -* -* If ORDER='B', do nothing -- the eigenvalues are already sorted -* by block. -* If ORDER='E', sort the eigenvalues from smallest to largest -* - IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN - DO 150 JE = 1, M - 1 - IE = 0 - TMP1 = W( JE ) - DO 140 J = JE + 1, M - IF( W( J ).LT.TMP1 ) THEN - IE = J - TMP1 = W( J ) - END IF - 140 CONTINUE -* - IF( IE.NE.0 ) THEN - ITMP1 = IBLOCK( IE ) - W( IE ) = W( JE ) - IBLOCK( IE ) = IBLOCK( JE ) - W( JE ) = TMP1 - IBLOCK( JE ) = ITMP1 - END IF - 150 CONTINUE - END IF -* - INFO = 0 - IF( NCNVRG ) - $ INFO = INFO + 1 - IF( TOOFEW ) - $ INFO = INFO + 2 - RETURN -* -* End of DSTEBZ -* - END - SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, - $ IWORK, IFAIL, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDZ, M, N -* .. -* .. Array Arguments .. - INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), - $ IWORK( * ) - DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) - COMPLEX*16 Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* ZSTEIN computes the eigenvectors of a real symmetric tridiagonal -* matrix T corresponding to specified eigenvalues, using inverse -* iteration. -* -* The maximum number of iterations allowed for each eigenvector is -* specified by an internal parameter MAXITS (currently set to 5). -* -* Although the eigenvectors are real, they are stored in a complex -* array, which may be passed to ZUNMTR or ZUPMTR for back -* transformation to the eigenvectors of a complex Hermitian matrix -* which was reduced to tridiagonal form. -* -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix. N >= 0. -* -* D (input) DOUBLE PRECISION array, dimension (N) -* The n diagonal elements of the tridiagonal matrix T. -* -* E (input) DOUBLE PRECISION array, dimension (N) -* The (n-1) subdiagonal elements of the tridiagonal matrix -* T, stored in elements 1 to N-1; E(N) need not be set. -* -* M (input) INTEGER -* The number of eigenvectors to be found. 0 <= M <= N. -* -* W (input) DOUBLE PRECISION array, dimension (N) -* The first M elements of W contain the eigenvalues for -* which eigenvectors are to be computed. The eigenvalues -* should be grouped by split-off block and ordered from -* smallest to largest within the block. ( The output array -* W from DSTEBZ with ORDER = 'B' is expected here. ) -* -* IBLOCK (input) INTEGER array, dimension (N) -* The submatrix indices associated with the corresponding -* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to -* the first submatrix from the top, =2 if W(i) belongs to -* the second submatrix, etc. ( The output array IBLOCK -* from DSTEBZ is expected here. ) -* -* ISPLIT (input) INTEGER array, dimension (N) -* The splitting points, at which T breaks up into submatrices. -* The first submatrix consists of rows/columns 1 to -* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 -* through ISPLIT( 2 ), etc. -* ( The output array ISPLIT from DSTEBZ is expected here. ) -* -* Z (output) COMPLEX*16 array, dimension (LDZ, M) -* The computed eigenvectors. The eigenvector associated -* with the eigenvalue W(i) is stored in the i-th column of -* Z. Any vector which fails to converge is set to its current -* iterate after MAXITS iterations. -* The imaginary parts of the eigenvectors are set to zero. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= max(1,N). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (5*N) -* -* IWORK (workspace) INTEGER array, dimension (N) -* -* IFAIL (output) INTEGER array, dimension (M) -* On normal exit, all elements of IFAIL are zero. -* If one or more eigenvectors fail to converge after -* MAXITS iterations, then their indices are stored in -* array IFAIL. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, then i eigenvectors failed to converge -* in MAXITS iterations. Their indices are stored in -* array IFAIL. -* -* Internal Parameters -* =================== -* -* MAXITS INTEGER, default = 5 -* The maximum number of iterations performed. -* -* EXTRA INTEGER, default = 2 -* The number of iterations performed after norm growth -* criterion is satisfied, should be at least 1. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 CZERO, CONE - PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), - $ CONE = ( 1.0D+0, 0.0D+0 ) ) - DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1, - $ ODM3 = 1.0D-3, ODM1 = 1.0D-1 ) - INTEGER MAXITS, EXTRA - PARAMETER ( MAXITS = 5, EXTRA = 2 ) -* .. -* .. Local Scalars .. - INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1, - $ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1, - $ JBLK, JMAX, JR, NBLK, NRMCHK - DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL, - $ SCL, SEP, TOL, XJ, XJM, ZTR -* .. -* .. Local Arrays .. - INTEGER ISEED( 4 ) -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DASUM, DLAMCH, DNRM2 - EXTERNAL IDAMAX, DASUM, DLAMCH, DNRM2 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX, MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - DO 10 I = 1, M - IFAIL( I ) = 0 - 10 CONTINUE -* - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 .OR. M.GT.N ) THEN - INFO = -4 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE - DO 20 J = 2, M - IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN - INFO = -6 - GO TO 30 - END IF - IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) - $ THEN - INFO = -5 - GO TO 30 - END IF - 20 CONTINUE - 30 CONTINUE - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZSTEIN', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. M.EQ.0 ) THEN - RETURN - ELSE IF( N.EQ.1 ) THEN - Z( 1, 1 ) = CONE - RETURN - END IF -* -* Get machine constants. -* - EPS = DLAMCH( 'Precision' ) -* -* Initialize seed for random number generator DLARNV. -* - DO 40 I = 1, 4 - ISEED( I ) = 1 - 40 CONTINUE -* -* Initialize pointers. -* - INDRV1 = 0 - INDRV2 = INDRV1 + N - INDRV3 = INDRV2 + N - INDRV4 = INDRV3 + N - INDRV5 = INDRV4 + N -* -* Compute eigenvectors of matrix blocks. -* - J1 = 1 - DO 180 NBLK = 1, IBLOCK( M ) -* -* Find starting and ending indices of block nblk. -* - IF( NBLK.EQ.1 ) THEN - B1 = 1 - ELSE - B1 = ISPLIT( NBLK-1 ) + 1 - END IF - BN = ISPLIT( NBLK ) - BLKSIZ = BN - B1 + 1 - IF( BLKSIZ.EQ.1 ) - $ GO TO 60 - GPIND = B1 -* -* Compute reorthogonalization criterion and stopping criterion. -* - ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) ) - ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) ) - DO 50 I = B1 + 1, BN - 1 - ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+ - $ ABS( E( I ) ) ) - 50 CONTINUE - ORTOL = ODM3*ONENRM -* - DTPCRT = SQRT( ODM1 / BLKSIZ ) -* -* Loop through eigenvalues of block nblk. -* - 60 CONTINUE - JBLK = 0 - DO 170 J = J1, M - IF( IBLOCK( J ).NE.NBLK ) THEN - J1 = J - GO TO 180 - END IF - JBLK = JBLK + 1 - XJ = W( J ) -* -* Skip all the work if the block size is one. -* - IF( BLKSIZ.EQ.1 ) THEN - WORK( INDRV1+1 ) = ONE - GO TO 140 - END IF -* -* If eigenvalues j and j-1 are too close, add a relatively -* small perturbation. -* - IF( JBLK.GT.1 ) THEN - EPS1 = ABS( EPS*XJ ) - PERTOL = TEN*EPS1 - SEP = XJ - XJM - IF( SEP.LT.PERTOL ) - $ XJ = XJM + PERTOL - END IF -* - ITS = 0 - NRMCHK = 0 -* -* Get random starting vector. -* - CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) ) -* -* Copy the matrix T so it won't be destroyed in factorization. -* - CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 ) - CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 ) - CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 ) -* -* Compute LU factors with partial pivoting ( PT = LU ) -* - TOL = ZERO - CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), - $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, - $ IINFO ) -* -* Update iteration count. -* - 70 CONTINUE - ITS = ITS + 1 - IF( ITS.GT.MAXITS ) - $ GO TO 120 -* -* Normalize and scale the righthand side vector Pb. -* - SCL = BLKSIZ*ONENRM*MAX( EPS, - $ ABS( WORK( INDRV4+BLKSIZ ) ) ) / - $ DASUM( BLKSIZ, WORK( INDRV1+1 ), 1 ) - CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) -* -* Solve the system LU = Pb. -* - CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), - $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, - $ WORK( INDRV1+1 ), TOL, IINFO ) -* -* Reorthogonalize by modified Gram-Schmidt if eigenvalues are -* close enough. -* - IF( JBLK.EQ.1 ) - $ GO TO 110 - IF( ABS( XJ-XJM ).GT.ORTOL ) - $ GPIND = J - IF( GPIND.NE.J ) THEN - DO 100 I = GPIND, J - 1 - ZTR = ZERO - DO 80 JR = 1, BLKSIZ - ZTR = ZTR + WORK( INDRV1+JR )* - $ DBLE( Z( B1-1+JR, I ) ) - 80 CONTINUE - DO 90 JR = 1, BLKSIZ - WORK( INDRV1+JR ) = WORK( INDRV1+JR ) - - $ ZTR*DBLE( Z( B1-1+JR, I ) ) - 90 CONTINUE - 100 CONTINUE - END IF -* -* Check the infinity norm of the iterate. -* - 110 CONTINUE - JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) - NRM = ABS( WORK( INDRV1+JMAX ) ) -* -* Continue for additional iterations after norm reaches -* stopping criterion. -* - IF( NRM.LT.DTPCRT ) - $ GO TO 70 - NRMCHK = NRMCHK + 1 - IF( NRMCHK.LT.EXTRA+1 ) - $ GO TO 70 -* - GO TO 130 -* -* If stopping criterion was not satisfied, update info and -* store eigenvector number in array ifail. -* - 120 CONTINUE - INFO = INFO + 1 - IFAIL( INFO ) = J -* -* Accept iterate as jth eigenvector. -* - 130 CONTINUE - SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 ) - JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) - IF( WORK( INDRV1+JMAX ).LT.ZERO ) - $ SCL = -SCL - CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) - 140 CONTINUE - DO 150 I = 1, N - Z( I, J ) = CZERO - 150 CONTINUE - DO 160 I = 1, BLKSIZ - Z( B1+I-1, J ) = DCMPLX( WORK( INDRV1+I ), ZERO ) - 160 CONTINUE -* -* Save the shift to check eigenvalue spacing at next -* iteration. -* - XJM = XJ -* - 170 CONTINUE - 180 CONTINUE -* - RETURN -* -* End of ZSTEIN -* - END - SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNMTR overwrites the general complex M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'C': Q**H * C C * Q**H -* -* where Q is a complex unitary matrix of order nq, with nq = m if -* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of -* nq-1 elementary reflectors, as returned by ZHETRD: -* -* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); -* -* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**H from the Left; -* = 'R': apply Q or Q**H from the Right. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A contains elementary reflectors -* from ZHETRD; -* = 'L': Lower triangle of A contains elementary reflectors -* from ZHETRD. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'C': Conjugate transpose, apply Q**H. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* A (input) COMPLEX*16 array, dimension -* (LDA,M) if SIDE = 'L' -* (LDA,N) if SIDE = 'R' -* The vectors which define the elementary reflectors, as -* returned by ZHETRD. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. -* -* TAU (input) COMPLEX*16 array, dimension -* (M-1) if SIDE = 'L' -* (N-1) if SIDE = 'R' -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZHETRD. -* -* C (input/output) COMPLEX*16 array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >=M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, UPPER - INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZUNMQL, ZUNMQR -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) - $ THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( UPPER ) THEN - IF( LEFT ) THEN - NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - ELSE - IF( LEFT ) THEN - NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - END IF - LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNMTR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - ELSE - MI = M - NI = N - 1 - END IF -* - IF( UPPER ) THEN -* -* Q was determined by a call to ZHETRD with UPLO = 'U' -* - CALL ZUNMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, - $ LDC, WORK, LWORK, IINFO ) - ELSE -* -* Q was determined by a call to ZHETRD with UPLO = 'L' -* - IF( LEFT ) THEN - I1 = 2 - I2 = 1 - ELSE - I1 = 1 - I2 = 2 - END IF - CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, - $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNMTR -* - END - SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION SCALE, SUMSQ -* .. -* .. Array Arguments .. - COMPLEX*16 X( * ) -* .. -* -* Purpose -* ======= -* -* ZLASSQ returns the values scl and ssq such that -* -* ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, -* -* where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is -* assumed to be at least unity and the value of ssq will then satisfy -* -* 1.0 .le. ssq .le. ( sumsq + 2*n ). -* -* scale is assumed to be non-negative and scl returns the value -* -* scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), -* i -* -* scale and sumsq must be supplied in SCALE and SUMSQ respectively. -* SCALE and SUMSQ are overwritten by scl and ssq respectively. -* -* The routine makes only one pass through the vector X. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of elements to be used from the vector X. -* -* X (input) COMPLEX*16 array, dimension (N) -* The vector x as described above. -* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. -* -* INCX (input) INTEGER -* The increment between successive values of the vector X. -* INCX > 0. -* -* SCALE (input/output) DOUBLE PRECISION -* On entry, the value scale in the equation above. -* On exit, SCALE is overwritten with the value scl . -* -* SUMSQ (input/output) DOUBLE PRECISION -* On entry, the value sumsq in the equation above. -* On exit, SUMSQ is overwritten with the value ssq . -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION TEMP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DIMAG -* .. -* .. Executable Statements .. -* - IF( N.GT.0 ) THEN - DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX - IF( DBLE( X( IX ) ).NE.ZERO ) THEN - TEMP1 = ABS( DBLE( X( IX ) ) ) - IF( SCALE.LT.TEMP1 ) THEN - SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 - SCALE = TEMP1 - ELSE - SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 - END IF - END IF - IF( DIMAG( X( IX ) ).NE.ZERO ) THEN - TEMP1 = ABS( DIMAG( X( IX ) ) ) - IF( SCALE.LT.TEMP1 ) THEN - SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 - SCALE = TEMP1 - ELSE - SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 - END IF - END IF - 10 CONTINUE - END IF -* - RETURN -* -* End of ZLASSQ -* - END - SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDW, N, NB -* .. -* .. Array Arguments .. - DOUBLE PRECISION E( * ) - COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * ) -* .. -* -* Purpose -* ======= -* -* ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to -* Hermitian tridiagonal form by a unitary similarity -* transformation Q' * A * Q, and returns the matrices V and W which are -* needed to apply the transformation to the unreduced part of A. -* -* If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a -* matrix, of which the upper triangle is supplied; -* if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a -* matrix, of which the lower triangle is supplied. -* -* This is an auxiliary routine called by ZHETRD. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER -* Specifies whether the upper or lower triangular part of the -* Hermitian matrix A is stored: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. -* -* NB (input) INTEGER -* The number of rows and columns to be reduced. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the Hermitian matrix A. If UPLO = 'U', the leading -* n-by-n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n-by-n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* On exit: -* if UPLO = 'U', the last NB columns have been reduced to -* tridiagonal form, with the diagonal elements overwriting -* the diagonal elements of A; the elements above the diagonal -* with the array TAU, represent the unitary matrix Q as a -* product of elementary reflectors; -* if UPLO = 'L', the first NB columns have been reduced to -* tridiagonal form, with the diagonal elements overwriting -* the diagonal elements of A; the elements below the diagonal -* with the array TAU, represent the unitary matrix Q as a -* product of elementary reflectors. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* E (output) DOUBLE PRECISION array, dimension (N-1) -* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal -* elements of the last NB columns of the reduced matrix; -* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of -* the first NB columns of the reduced matrix. -* -* TAU (output) COMPLEX*16 array, dimension (N-1) -* The scalar factors of the elementary reflectors, stored in -* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. -* See Further Details. -* -* W (output) COMPLEX*16 array, dimension (LDW,NB) -* The n-by-nb matrix W required to update the unreduced part -* of A. -* -* LDW (input) INTEGER -* The leading dimension of the array W. LDW >= max(1,N). -* -* Further Details -* =============== -* -* If UPLO = 'U', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(n) H(n-1) . . . H(n-nb+1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a complex scalar, and v is a complex vector with -* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), -* and tau in TAU(i-1). -* -* If UPLO = 'L', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(1) H(2) . . . H(nb). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a complex scalar, and v is a complex vector with -* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), -* and tau in TAU(i). -* -* The elements of the vectors v together form the n-by-nb matrix V -* which is needed, with W, to apply the transformation to the unreduced -* part of the matrix, using a Hermitian rank-2k update of the form: -* A := A - V*W' - W*V'. -* -* The contents of A on exit are illustrated by the following examples -* with n = 5 and nb = 2: -* -* if UPLO = 'U': if UPLO = 'L': -* -* ( a a a v4 v5 ) ( d ) -* ( a a v4 v5 ) ( 1 d ) -* ( a 1 v5 ) ( v1 1 a ) -* ( d 1 ) ( v1 v2 a a ) -* ( d ) ( v1 v2 a a a ) -* -* where d denotes a diagonal element of the reduced matrix, a denotes -* an element of the original matrix that is unchanged, and vi denotes -* an element of the vector defining H(i). -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE, HALF - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ), - $ HALF = ( 0.5D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, IW - COMPLEX*16 ALPHA -* .. -* .. External Subroutines .. - EXTERNAL ZAXPY, ZGEMV, ZHEMV, ZLACGV, ZLARFG, ZSCAL -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Reduce last NB columns of upper triangle -* - DO 10 I = N, N - NB + 1, -1 - IW = I - N + NB - IF( I.LT.N ) THEN -* -* Update A(1:i,i) -* - A( I, I ) = DBLE( A( I, I ) ) - CALL ZLACGV( N-I, W( I, IW+1 ), LDW ) - CALL ZGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), - $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) - CALL ZLACGV( N-I, W( I, IW+1 ), LDW ) - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - CALL ZGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), - $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - A( I, I ) = DBLE( A( I, I ) ) - END IF - IF( I.GT.1 ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(1:i-2,i) -* - ALPHA = A( I-1, I ) - CALL ZLARFG( I-1, ALPHA, A( 1, I ), 1, TAU( I-1 ) ) - E( I-1 ) = ALPHA - A( I-1, I ) = ONE -* -* Compute W(1:i-1,i) -* - CALL ZHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, - $ ZERO, W( 1, IW ), 1 ) - IF( I.LT.N ) THEN - CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE, - $ W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO, - $ W( I+1, IW ), 1 ) - CALL ZGEMV( 'No transpose', I-1, N-I, -ONE, - $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, - $ W( 1, IW ), 1 ) - CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE, - $ A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO, - $ W( I+1, IW ), 1 ) - CALL ZGEMV( 'No transpose', I-1, N-I, -ONE, - $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, - $ W( 1, IW ), 1 ) - END IF - CALL ZSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) - ALPHA = -HALF*TAU( I-1 )*ZDOTC( I-1, W( 1, IW ), 1, - $ A( 1, I ), 1 ) - CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) - END IF -* - 10 CONTINUE - ELSE -* -* Reduce first NB columns of lower triangle -* - DO 20 I = 1, NB -* -* Update A(i:n,i) -* - A( I, I ) = DBLE( A( I, I ) ) - CALL ZLACGV( I-1, W( I, 1 ), LDW ) - CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), - $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) - CALL ZLACGV( I-1, W( I, 1 ), LDW ) - CALL ZLACGV( I-1, A( I, 1 ), LDA ) - CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), - $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) - CALL ZLACGV( I-1, A( I, 1 ), LDA ) - A( I, I ) = DBLE( A( I, I ) ) - IF( I.LT.N ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(i+2:n,i) -* - ALPHA = A( I+1, I ) - CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, - $ TAU( I ) ) - E( I ) = ALPHA - A( I+1, I ) = ONE -* -* Compute W(i+1:n,i) -* - CALL ZHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, - $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, - $ W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO, - $ W( 1, I ), 1 ) - CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, - $ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO, - $ W( 1, I ), 1 ) - CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), - $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) - CALL ZSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) - ALPHA = -HALF*TAU( I )*ZDOTC( N-I, W( I+1, I ), 1, - $ A( I+1, I ), 1 ) - CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) - END IF -* - 20 CONTINUE - END IF -* - RETURN -* -* End of ZLATRD -* - END - SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) - COMPLEX*16 A( LDA, * ), TAU( * ) -* .. -* -* Purpose -* ======= -* -* ZHETD2 reduces a complex Hermitian matrix A to real symmetric -* tridiagonal form T by a unitary similarity transformation: -* Q' * A * Q = T. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* Hermitian matrix A is stored: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the Hermitian matrix A. If UPLO = 'U', the leading -* n-by-n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n-by-n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* On exit, if UPLO = 'U', the diagonal and first superdiagonal -* of A are overwritten by the corresponding elements of the -* tridiagonal matrix T, and the elements above the first -* superdiagonal, with the array TAU, represent the unitary -* matrix Q as a product of elementary reflectors; if UPLO -* = 'L', the diagonal and first subdiagonal of A are over- -* written by the corresponding elements of the tridiagonal -* matrix T, and the elements below the first subdiagonal, with -* the array TAU, represent the unitary matrix Q as a product -* of elementary reflectors. See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* D (output) DOUBLE PRECISION array, dimension (N) -* The diagonal elements of the tridiagonal matrix T: -* D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (N-1) -* The off-diagonal elements of the tridiagonal matrix T: -* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. -* -* TAU (output) COMPLEX*16 array, dimension (N-1) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* If UPLO = 'U', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(n-1) . . . H(2) H(1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a complex scalar, and v is a complex vector with -* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in -* A(1:i-1,i+1), and tau in TAU(i). -* -* If UPLO = 'L', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(1) H(2) . . . H(n-1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a complex scalar, and v is a complex vector with -* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), -* and tau in TAU(i). -* -* The contents of A on exit are illustrated by the following examples -* with n = 5: -* -* if UPLO = 'U': if UPLO = 'L': -* -* ( d e v2 v3 v4 ) ( d ) -* ( d e v3 v4 ) ( e d ) -* ( d e v4 ) ( v1 e d ) -* ( d e ) ( v1 v2 e d ) -* ( d ) ( v1 v2 v3 e d ) -* -* where d and e denote diagonal and off-diagonal elements of T, and vi -* denotes an element of the vector defining H(i). -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO, HALF - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ), - $ HALF = ( 0.5D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I - COMPLEX*16 ALPHA, TAUI -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZAXPY, ZHEMV, ZHER2, ZLARFG -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHETD2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Reduce the upper triangle of A -* - A( N, N ) = DBLE( A( N, N ) ) - DO 10 I = N - 1, 1, -1 -* -* Generate elementary reflector H(i) = I - tau * v * v' -* to annihilate A(1:i-1,i+1) -* - ALPHA = A( I, I+1 ) - CALL ZLARFG( I, ALPHA, A( 1, I+1 ), 1, TAUI ) - E( I ) = ALPHA -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(1:i,1:i) -* - A( I, I+1 ) = ONE -* -* Compute x := tau * A * v storing x in TAU(1:i) -* - CALL ZHEMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, - $ TAU, 1 ) -* -* Compute w := x - 1/2 * tau * (x'*v) * v -* - ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, A( 1, I+1 ), 1 ) - CALL ZAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w' - w * v' -* - CALL ZHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, - $ LDA ) -* - ELSE - A( I, I ) = DBLE( A( I, I ) ) - END IF - A( I, I+1 ) = E( I ) - D( I+1 ) = A( I+1, I+1 ) - TAU( I ) = TAUI - 10 CONTINUE - D( 1 ) = A( 1, 1 ) - ELSE -* -* Reduce the lower triangle of A -* - A( 1, 1 ) = DBLE( A( 1, 1 ) ) - DO 20 I = 1, N - 1 -* -* Generate elementary reflector H(i) = I - tau * v * v' -* to annihilate A(i+2:n,i) -* - ALPHA = A( I+1, I ) - CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAUI ) - E( I ) = ALPHA -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(i+1:n,i+1:n) -* - A( I+1, I ) = ONE -* -* Compute x := tau * A * v storing y in TAU(i:n-1) -* - CALL ZHEMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, - $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) -* -* Compute w := x - 1/2 * tau * (x'*v) * v -* - ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, A( I+1, I ), - $ 1 ) - CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w' - w * v' -* - CALL ZHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, - $ A( I+1, I+1 ), LDA ) -* - ELSE - A( I+1, I+1 ) = DBLE( A( I+1, I+1 ) ) - END IF - A( I+1, I ) = E( I ) - D( I ) = A( I, I ) - TAU( I ) = TAUI - 20 CONTINUE - D( N ) = A( N, N ) - END IF -* - RETURN -* -* End of ZHETD2 -* - END - SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns, -* which is defined as the last N columns of a product of K elementary -* reflectors of order M -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by ZGEQLF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the (n-k+i)-th column must contain the vector which -* defines the elementary reflector H(i), for i = 1,2,...,k, as -* returned by ZGEQLF in the last k columns of its array -* argument A. -* On exit, the M-by-N matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) COMPLEX*16 array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZGEQLF. -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is the -* optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, - $ NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2L -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, N )*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNGQL', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'ZUNGQL', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQL', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the first block. -* The last kk columns are handled by the block method. -* - KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) -* -* Set A(m-kk+1:m,1:n-kk) to zero. -* - DO 20 J = 1, N - KK - DO 10 I = M - KK + 1, M - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the first or only block. -* - CALL ZUNG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = K - KK + 1, K, NB - IB = MIN( NB, K-I+1 ) - IF( N-K+I.GT.1 ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i+ib-1) . . . H(i+1) H(i) -* - CALL ZLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, - $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left -* - CALL ZLARFB( 'Left', 'No transpose', 'Backward', - $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, - $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, - $ WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows 1:m-k+i+ib-1 of current block -* - CALL ZUNG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, - $ TAU( I ), WORK, IINFO ) -* -* Set rows m-k+i+ib:m of current block to zero -* - DO 40 J = N - K + I, N - K + I + IB - 1 - DO 30 L = M - K + I + IB, M - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of ZUNGQL -* - END - SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns, -* which is defined as the first N columns of a product of K elementary -* reflectors of order M -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by ZGEQRF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the i-th column must contain the vector which -* defines the elementary reflector H(i), for i = 1,2,...,k, as -* returned by ZGEQRF in the first k columns of its array -* argument A. -* On exit, the M-by-N matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) COMPLEX*16 array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZGEQRF. -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is the -* optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, - $ LWKOPT, NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2R -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, N )*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNGQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the last block. -* The first kk columns are handled by the block method. -* - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) -* -* Set A(1:kk,kk+1:n) to zero. -* - DO 20 J = KK + 1, N - DO 10 I = 1, KK - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the last or only block. -* - IF( KK.LT.N ) - $ CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, - $ TAU( KK+1 ), WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(i:m,i+ib:n) from the left -* - CALL ZLARFB( 'Left', 'No transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows i:m of current block -* - CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* -* Set rows 1:i-1 of current block to zero -* - DO 40 J = I, I + IB - 1 - DO 30 L = 1, I - 1 - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of ZUNGQR -* - END - SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIRECT, PIVOT, SIDE - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( * ), S( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZLASR performs the transformation -* -* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) -* -* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) -* -* where A is an m by n complex matrix and P is an orthogonal matrix, -* consisting of a sequence of plane rotations determined by the -* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' -* and z = n when SIDE = 'R' or 'r' ): -* -* When DIRECT = 'F' or 'f' ( Forward sequence ) then -* -* P = P( z - 1 )*...*P( 2 )*P( 1 ), -* -* and when DIRECT = 'B' or 'b' ( Backward sequence ) then -* -* P = P( 1 )*P( 2 )*...*P( z - 1 ), -* -* where P( k ) is a plane rotation matrix for the following planes: -* -* when PIVOT = 'V' or 'v' ( Variable pivot ), -* the plane ( k, k + 1 ) -* -* when PIVOT = 'T' or 't' ( Top pivot ), -* the plane ( 1, k + 1 ) -* -* when PIVOT = 'B' or 'b' ( Bottom pivot ), -* the plane ( k, z ) -* -* c( k ) and s( k ) must contain the cosine and sine that define the -* matrix P( k ). The two by two plane rotation part of the matrix -* P( k ), R( k ), is assumed to be of the form -* -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* Specifies whether the plane rotation matrix P is applied to -* A on the left or the right. -* = 'L': Left, compute A := P*A -* = 'R': Right, compute A:= A*P' -* -* DIRECT (input) CHARACTER*1 -* Specifies whether P is a forward or backward sequence of -* plane rotations. -* = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) -* = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) -* -* PIVOT (input) CHARACTER*1 -* Specifies the plane for which P(k) is a plane rotation -* matrix. -* = 'V': Variable pivot, the plane (k,k+1) -* = 'T': Top pivot, the plane (1,k+1) -* = 'B': Bottom pivot, the plane (k,z) -* -* M (input) INTEGER -* The number of rows of the matrix A. If m <= 1, an immediate -* return is effected. -* -* N (input) INTEGER -* The number of columns of the matrix A. If n <= 1, an -* immediate return is effected. -* -* C, S (input) DOUBLE PRECISION arrays, dimension -* (M-1) if SIDE = 'L' -* (N-1) if SIDE = 'R' -* c(k) and s(k) contain the cosine and sine that define the -* matrix P(k). The two by two plane rotation part of the -* matrix P(k), R(k), is assumed to be of the form -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* The m by n matrix A. On exit, A is overwritten by P*A if -* SIDE = 'R' or by A*P' if SIDE = 'L'. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, J - DOUBLE PRECISION CTEMP, STEMP - COMPLEX*16 TEMP -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN - INFO = 1 - ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, - $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN - INFO = 2 - ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) - $ THEN - INFO = 3 - ELSE IF( M.LT.0 ) THEN - INFO = 4 - ELSE IF( N.LT.0 ) THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = 9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZLASR ', INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) - $ RETURN - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form P * A -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 20 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 10 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 40 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 30 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 30 CONTINUE - END IF - 40 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 60 J = 2, M - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 50 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 80 J = M, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 70 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 70 CONTINUE - END IF - 80 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 100 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 90 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 90 CONTINUE - END IF - 100 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 120 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 110 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 110 CONTINUE - END IF - 120 CONTINUE - END IF - END IF - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form A * P' -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 140 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 130 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 130 CONTINUE - END IF - 140 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 160 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 150 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 150 CONTINUE - END IF - 160 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 180 J = 2, N - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 170 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 170 CONTINUE - END IF - 180 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 200 J = N, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 190 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 190 CONTINUE - END IF - 200 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 220 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 210 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 210 CONTINUE - END IF - 220 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 240 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 230 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 230 CONTINUE - END IF - 240 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZLASR -* - END - SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, - $ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, - $ NAB, WORK, IWORK, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX - DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL -* .. -* .. Array Arguments .. - INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * ) - DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ), - $ WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLAEBZ contains the iteration loops which compute and use the -* function N(w), which is the count of eigenvalues of a symmetric -* tridiagonal matrix T less than or equal to its argument w. It -* performs a choice of two types of loops: -* -* IJOB=1, followed by -* IJOB=2: It takes as input a list of intervals and returns a list of -* sufficiently small intervals whose union contains the same -* eigenvalues as the union of the original intervals. -* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP. -* The output interval (AB(j,1),AB(j,2)] will contain -* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT. -* -* IJOB=3: It performs a binary search in each input interval -* (AB(j,1),AB(j,2)] for a point w(j) such that -* N(w(j))=NVAL(j), and uses C(j) as the starting point of -* the search. If such a w(j) is found, then on output -* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output -* (AB(j,1),AB(j,2)] will be a small interval containing the -* point where N(w) jumps through NVAL(j), unless that point -* lies outside the initial interval. -* -* Note that the intervals are in all cases half-open intervals, -* i.e., of the form (a,b] , which includes b but not a . -* -* To avoid underflow, the matrix should be scaled so that its largest -* element is no greater than overflow**(1/2) * underflow**(1/4) -* in absolute value. To assure the most accurate computation -* of small eigenvalues, the matrix should be scaled to be -* not much smaller than that, either. -* -* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal -* Matrix", Report CS41, Computer Science Dept., Stanford -* University, July 21, 1966 -* -* Note: the arguments are, in general, *not* checked for unreasonable -* values. -* -* Arguments -* ========= -* -* IJOB (input) INTEGER -* Specifies what is to be done: -* = 1: Compute NAB for the initial intervals. -* = 2: Perform bisection iteration to find eigenvalues of T. -* = 3: Perform bisection iteration to invert N(w), i.e., -* to find a point which has a specified number of -* eigenvalues of T to its left. -* Other values will cause DLAEBZ to return with INFO=-1. -* -* NITMAX (input) INTEGER -* The maximum number of "levels" of bisection to be -* performed, i.e., an interval of width W will not be made -* smaller than 2^(-NITMAX) * W. If not all intervals -* have converged after NITMAX iterations, then INFO is set -* to the number of non-converged intervals. -* -* N (input) INTEGER -* The dimension n of the tridiagonal matrix T. It must be at -* least 1. -* -* MMAX (input) INTEGER -* The maximum number of intervals. If more than MMAX intervals -* are generated, then DLAEBZ will quit with INFO=MMAX+1. -* -* MINP (input) INTEGER -* The initial number of intervals. It may not be greater than -* MMAX. -* -* NBMIN (input) INTEGER -* The smallest number of intervals that should be processed -* using a vector loop. If zero, then only the scalar loop -* will be used. -* -* ABSTOL (input) DOUBLE PRECISION -* The minimum (absolute) width of an interval. When an -* interval is narrower than ABSTOL, or than RELTOL times the -* larger (in magnitude) endpoint, then it is considered to be -* sufficiently small, i.e., converged. This must be at least -* zero. -* -* RELTOL (input) DOUBLE PRECISION -* The minimum relative width of an interval. When an interval -* is narrower than ABSTOL, or than RELTOL times the larger (in -* magnitude) endpoint, then it is considered to be -* sufficiently small, i.e., converged. Note: this should -* always be at least radix*machine epsilon. -* -* PIVMIN (input) DOUBLE PRECISION -* The minimum absolute value of a "pivot" in the Sturm -* sequence loop. This *must* be at least max |e(j)**2| * -* safe_min and at least safe_min, where safe_min is at least -* the smallest number that can divide one without overflow. -* -* D (input) DOUBLE PRECISION array, dimension (N) -* The diagonal elements of the tridiagonal matrix T. -* -* E (input) DOUBLE PRECISION array, dimension (N) -* The offdiagonal elements of the tridiagonal matrix T in -* positions 1 through N-1. E(N) is arbitrary. -* -* E2 (input) DOUBLE PRECISION array, dimension (N) -* The squares of the offdiagonal elements of the tridiagonal -* matrix T. E2(N) is ignored. -* -* NVAL (input/output) INTEGER array, dimension (MINP) -* If IJOB=1 or 2, not referenced. -* If IJOB=3, the desired values of N(w). The elements of NVAL -* will be reordered to correspond with the intervals in AB. -* Thus, NVAL(j) on output will not, in general be the same as -* NVAL(j) on input, but it will correspond with the interval -* (AB(j,1),AB(j,2)] on output. -* -* AB (input/output) DOUBLE PRECISION array, dimension (MMAX,2) -* The endpoints of the intervals. AB(j,1) is a(j), the left -* endpoint of the j-th interval, and AB(j,2) is b(j), the -* right endpoint of the j-th interval. The input intervals -* will, in general, be modified, split, and reordered by the -* calculation. -* -* C (input/output) DOUBLE PRECISION array, dimension (MMAX) -* If IJOB=1, ignored. -* If IJOB=2, workspace. -* If IJOB=3, then on input C(j) should be initialized to the -* first search point in the binary search. -* -* MOUT (output) INTEGER -* If IJOB=1, the number of eigenvalues in the intervals. -* If IJOB=2 or 3, the number of intervals output. -* If IJOB=3, MOUT will equal MINP. -* -* NAB (input/output) INTEGER array, dimension (MMAX,2) -* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). -* If IJOB=2, then on input, NAB(i,j) should be set. It must -* satisfy the condition: -* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), -* which means that in interval i only eigenvalues -* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually, -* NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with -* IJOB=1. -* On output, NAB(i,j) will contain -* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of -* the input interval that the output interval -* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the -* the input values of NAB(k,1) and NAB(k,2). -* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), -* unless N(w) > NVAL(i) for all search points w , in which -* case NAB(i,1) will not be modified, i.e., the output -* value will be the same as the input value (modulo -* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) -* for all search points w , in which case NAB(i,2) will -* not be modified. Normally, NAB should be set to some -* distinctive value(s) before DLAEBZ is called. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (MMAX) -* Workspace. -* -* IWORK (workspace) INTEGER array, dimension (MMAX) -* Workspace. -* -* INFO (output) INTEGER -* = 0: All intervals converged. -* = 1--MMAX: The last INFO intervals did not converge. -* = MMAX+1: More than MMAX intervals were generated. -* -* Further Details -* =============== -* -* This routine is intended to be called only by other LAPACK -* routines, thus the interface is less user-friendly. It is intended -* for two purposes: -* -* (a) finding eigenvalues. In this case, DLAEBZ should have one or -* more initial intervals set up in AB, and DLAEBZ should be called -* with IJOB=1. This sets up NAB, and also counts the eigenvalues. -* Intervals with no eigenvalues would usually be thrown out at -* this point. Also, if not all the eigenvalues in an interval i -* are desired, NAB(i,1) can be increased or NAB(i,2) decreased. -* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest -* eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX -* no smaller than the value of MOUT returned by the call with -* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1 -* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the -* tolerance specified by ABSTOL and RELTOL. -* -* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l). -* In this case, start with a Gershgorin interval (a,b). Set up -* AB to contain 2 search intervals, both initially (a,b). One -* NVAL element should contain f-1 and the other should contain l -* , while C should contain a and b, resp. NAB(i,1) should be -1 -* and NAB(i,2) should be N+1, to flag an error if the desired -* interval does not lie in (a,b). DLAEBZ is then called with -* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals -- -* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while -* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r -* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and -* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and -* w(l-r)=...=w(l+k) are handled similarly. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, TWO, HALF - PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0, - $ HALF = 1.0D0 / TWO ) -* .. -* .. Local Scalars .. - INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL, - $ KLNEW - DOUBLE PRECISION TMP1, TMP2 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Executable Statements .. -* -* Check for Errors -* - INFO = 0 - IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN - INFO = -1 - RETURN - END IF -* -* Initialize NAB -* - IF( IJOB.EQ.1 ) THEN -* -* Compute the number of eigenvalues in the initial intervals. -* - MOUT = 0 -*DIR$ NOVECTOR - DO 30 JI = 1, MINP - DO 20 JP = 1, 2 - TMP1 = D( 1 ) - AB( JI, JP ) - IF( ABS( TMP1 ).LT.PIVMIN ) - $ TMP1 = -PIVMIN - NAB( JI, JP ) = 0 - IF( TMP1.LE.ZERO ) - $ NAB( JI, JP ) = 1 -* - DO 10 J = 2, N - TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP ) - IF( ABS( TMP1 ).LT.PIVMIN ) - $ TMP1 = -PIVMIN - IF( TMP1.LE.ZERO ) - $ NAB( JI, JP ) = NAB( JI, JP ) + 1 - 10 CONTINUE - 20 CONTINUE - MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 ) - 30 CONTINUE - RETURN - END IF -* -* Initialize for loop -* -* KF and KL have the following meaning: -* Intervals 1,...,KF-1 have converged. -* Intervals KF,...,KL still need to be refined. -* - KF = 1 - KL = MINP -* -* If IJOB=2, initialize C. -* If IJOB=3, use the user-supplied starting point. -* - IF( IJOB.EQ.2 ) THEN - DO 40 JI = 1, MINP - C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) - 40 CONTINUE - END IF -* -* Iteration loop -* - DO 130 JIT = 1, NITMAX -* -* Loop over intervals -* - IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN -* -* Begin of Parallel Version of the loop -* - DO 60 JI = KF, KL -* -* Compute N(c), the number of eigenvalues less than c -* - WORK( JI ) = D( 1 ) - C( JI ) - IWORK( JI ) = 0 - IF( WORK( JI ).LE.PIVMIN ) THEN - IWORK( JI ) = 1 - WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) - END IF -* - DO 50 J = 2, N - WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI ) - IF( WORK( JI ).LE.PIVMIN ) THEN - IWORK( JI ) = IWORK( JI ) + 1 - WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) - END IF - 50 CONTINUE - 60 CONTINUE -* - IF( IJOB.LE.2 ) THEN -* -* IJOB=2: Choose all intervals containing eigenvalues. -* - KLNEW = KL - DO 70 JI = KF, KL -* -* Insure that N(w) is monotone -* - IWORK( JI ) = MIN( NAB( JI, 2 ), - $ MAX( NAB( JI, 1 ), IWORK( JI ) ) ) -* -* Update the Queue -- add intervals if both halves -* contain eigenvalues. -* - IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN -* -* No eigenvalue in the upper interval: -* just use the lower interval. -* - AB( JI, 2 ) = C( JI ) -* - ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN -* -* No eigenvalue in the lower interval: -* just use the upper interval. -* - AB( JI, 1 ) = C( JI ) - ELSE - KLNEW = KLNEW + 1 - IF( KLNEW.LE.MMAX ) THEN -* -* Eigenvalue in both intervals -- add upper to -* queue. -* - AB( KLNEW, 2 ) = AB( JI, 2 ) - NAB( KLNEW, 2 ) = NAB( JI, 2 ) - AB( KLNEW, 1 ) = C( JI ) - NAB( KLNEW, 1 ) = IWORK( JI ) - AB( JI, 2 ) = C( JI ) - NAB( JI, 2 ) = IWORK( JI ) - ELSE - INFO = MMAX + 1 - END IF - END IF - 70 CONTINUE - IF( INFO.NE.0 ) - $ RETURN - KL = KLNEW - ELSE -* -* IJOB=3: Binary search. Keep only the interval containing -* w s.t. N(w) = NVAL -* - DO 80 JI = KF, KL - IF( IWORK( JI ).LE.NVAL( JI ) ) THEN - AB( JI, 1 ) = C( JI ) - NAB( JI, 1 ) = IWORK( JI ) - END IF - IF( IWORK( JI ).GE.NVAL( JI ) ) THEN - AB( JI, 2 ) = C( JI ) - NAB( JI, 2 ) = IWORK( JI ) - END IF - 80 CONTINUE - END IF -* - ELSE -* -* End of Parallel Version of the loop -* -* Begin of Serial Version of the loop -* - KLNEW = KL - DO 100 JI = KF, KL -* -* Compute N(w), the number of eigenvalues less than w -* - TMP1 = C( JI ) - TMP2 = D( 1 ) - TMP1 - ITMP1 = 0 - IF( TMP2.LE.PIVMIN ) THEN - ITMP1 = 1 - TMP2 = MIN( TMP2, -PIVMIN ) - END IF -* -* A series of compiler directives to defeat vectorization -* for the next loop -* -*$PL$ CMCHAR=' ' -CDIR$ NEXTSCALAR -C$DIR SCALAR -CDIR$ NEXT SCALAR -CVD$L NOVECTOR -CDEC$ NOVECTOR -CVD$ NOVECTOR -*VDIR NOVECTOR -*VOCL LOOP,SCALAR -CIBM PREFER SCALAR -*$PL$ CMCHAR='*' -* - DO 90 J = 2, N - TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1 - IF( TMP2.LE.PIVMIN ) THEN - ITMP1 = ITMP1 + 1 - TMP2 = MIN( TMP2, -PIVMIN ) - END IF - 90 CONTINUE -* - IF( IJOB.LE.2 ) THEN -* -* IJOB=2: Choose all intervals containing eigenvalues. -* -* Insure that N(w) is monotone -* - ITMP1 = MIN( NAB( JI, 2 ), - $ MAX( NAB( JI, 1 ), ITMP1 ) ) -* -* Update the Queue -- add intervals if both halves -* contain eigenvalues. -* - IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN -* -* No eigenvalue in the upper interval: -* just use the lower interval. -* - AB( JI, 2 ) = TMP1 -* - ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN -* -* No eigenvalue in the lower interval: -* just use the upper interval. -* - AB( JI, 1 ) = TMP1 - ELSE IF( KLNEW.LT.MMAX ) THEN -* -* Eigenvalue in both intervals -- add upper to queue. -* - KLNEW = KLNEW + 1 - AB( KLNEW, 2 ) = AB( JI, 2 ) - NAB( KLNEW, 2 ) = NAB( JI, 2 ) - AB( KLNEW, 1 ) = TMP1 - NAB( KLNEW, 1 ) = ITMP1 - AB( JI, 2 ) = TMP1 - NAB( JI, 2 ) = ITMP1 - ELSE - INFO = MMAX + 1 - RETURN - END IF - ELSE -* -* IJOB=3: Binary search. Keep only the interval -* containing w s.t. N(w) = NVAL -* - IF( ITMP1.LE.NVAL( JI ) ) THEN - AB( JI, 1 ) = TMP1 - NAB( JI, 1 ) = ITMP1 - END IF - IF( ITMP1.GE.NVAL( JI ) ) THEN - AB( JI, 2 ) = TMP1 - NAB( JI, 2 ) = ITMP1 - END IF - END IF - 100 CONTINUE - KL = KLNEW -* -* End of Serial Version of the loop -* - END IF -* -* Check for convergence -* - KFNEW = KF - DO 110 JI = KF, KL - TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) ) - TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) ) - IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR. - $ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN -* -* Converged -- Swap with position KFNEW, -* then increment KFNEW -* - IF( JI.GT.KFNEW ) THEN - TMP1 = AB( JI, 1 ) - TMP2 = AB( JI, 2 ) - ITMP1 = NAB( JI, 1 ) - ITMP2 = NAB( JI, 2 ) - AB( JI, 1 ) = AB( KFNEW, 1 ) - AB( JI, 2 ) = AB( KFNEW, 2 ) - NAB( JI, 1 ) = NAB( KFNEW, 1 ) - NAB( JI, 2 ) = NAB( KFNEW, 2 ) - AB( KFNEW, 1 ) = TMP1 - AB( KFNEW, 2 ) = TMP2 - NAB( KFNEW, 1 ) = ITMP1 - NAB( KFNEW, 2 ) = ITMP2 - IF( IJOB.EQ.3 ) THEN - ITMP1 = NVAL( JI ) - NVAL( JI ) = NVAL( KFNEW ) - NVAL( KFNEW ) = ITMP1 - END IF - END IF - KFNEW = KFNEW + 1 - END IF - 110 CONTINUE - KF = KFNEW -* -* Choose Midpoints -* - DO 120 JI = KF, KL - C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) - 120 CONTINUE -* -* If no more intervals to refine, quit. -* - IF( KF.GT.KL ) - $ GO TO 140 - 130 CONTINUE -* -* Converged -* - 140 CONTINUE - INFO = MAX( KL+1-KF, 0 ) - MOUT = KL -* - RETURN -* -* End of DLAEBZ -* - END - SUBROUTINE DLARNV( IDIST, ISEED, N, X ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER IDIST, N -* .. -* .. Array Arguments .. - INTEGER ISEED( 4 ) - DOUBLE PRECISION X( * ) -* .. -* -* Purpose -* ======= -* -* DLARNV returns a vector of n random real numbers from a uniform or -* normal distribution. -* -* Arguments -* ========= -* -* IDIST (input) INTEGER -* Specifies the distribution of the random numbers: -* = 1: uniform (0,1) -* = 2: uniform (-1,1) -* = 3: normal (0,1) -* -* ISEED (input/output) INTEGER array, dimension (4) -* On entry, the seed of the random number generator; the array -* elements must be between 0 and 4095, and ISEED(4) must be -* odd. -* On exit, the seed is updated. -* -* N (input) INTEGER -* The number of random numbers to be generated. -* -* X (output) DOUBLE PRECISION array, dimension (N) -* The generated random numbers. -* -* Further Details -* =============== -* -* This routine calls the auxiliary routine DLARUV to generate random -* real numbers from a uniform (0,1) distribution, in batches of up to -* 128 using vectorisable code. The Box-Muller method is used to -* transform numbers from a uniform to a normal distribution. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, TWO - PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) - INTEGER LV - PARAMETER ( LV = 128 ) - DOUBLE PRECISION TWOPI - PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IL, IL2, IV -* .. -* .. Local Arrays .. - DOUBLE PRECISION U( LV ) -* .. -* .. Intrinsic Functions .. - INTRINSIC COS, LOG, MIN, SQRT -* .. -* .. External Subroutines .. - EXTERNAL DLARUV -* .. -* .. Executable Statements .. -* - DO 40 IV = 1, N, LV / 2 - IL = MIN( LV / 2, N-IV+1 ) - IF( IDIST.EQ.3 ) THEN - IL2 = 2*IL - ELSE - IL2 = IL - END IF -* -* Call DLARUV to generate IL2 numbers from a uniform (0,1) -* distribution (IL2 <= LV) -* - CALL DLARUV( ISEED, IL2, U ) -* - IF( IDIST.EQ.1 ) THEN -* -* Copy generated numbers -* - DO 10 I = 1, IL - X( IV+I-1 ) = U( I ) - 10 CONTINUE - ELSE IF( IDIST.EQ.2 ) THEN -* -* Convert generated numbers to uniform (-1,1) distribution -* - DO 20 I = 1, IL - X( IV+I-1 ) = TWO*U( I ) - ONE - 20 CONTINUE - ELSE IF( IDIST.EQ.3 ) THEN -* -* Convert generated numbers to normal (0,1) distribution -* - DO 30 I = 1, IL - X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* - $ COS( TWOPI*U( 2*I ) ) - 30 CONTINUE - END IF - 40 CONTINUE - RETURN -* -* End of DLARNV -* - END - SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, N - DOUBLE PRECISION LAMBDA, TOL -* .. -* .. Array Arguments .. - INTEGER IN( * ) - DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ) -* .. -* -* Purpose -* ======= -* -* DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n -* tridiagonal matrix and lambda is a scalar, as -* -* T - lambda*I = PLU, -* -* where P is a permutation matrix, L is a unit lower tridiagonal matrix -* with at most one non-zero sub-diagonal elements per column and U is -* an upper triangular matrix with at most two non-zero super-diagonal -* elements per column. -* -* The factorization is obtained by Gaussian elimination with partial -* pivoting and implicit row scaling. -* -* The parameter LAMBDA is included in the routine so that DLAGTF may -* be used, in conjunction with DLAGTS, to obtain eigenvectors of T by -* inverse iteration. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix T. -* -* A (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, A must contain the diagonal elements of T. -* -* On exit, A is overwritten by the n diagonal elements of the -* upper triangular matrix U of the factorization of T. -* -* LAMBDA (input) DOUBLE PRECISION -* On entry, the scalar lambda. -* -* B (input/output) DOUBLE PRECISION array, dimension (N-1) -* On entry, B must contain the (n-1) super-diagonal elements of -* T. -* -* On exit, B is overwritten by the (n-1) super-diagonal -* elements of the matrix U of the factorization of T. -* -* C (input/output) DOUBLE PRECISION array, dimension (N-1) -* On entry, C must contain the (n-1) sub-diagonal elements of -* T. -* -* On exit, C is overwritten by the (n-1) sub-diagonal elements -* of the matrix L of the factorization of T. -* -* TOL (input) DOUBLE PRECISION -* On entry, a relative tolerance used to indicate whether or -* not the matrix (T - lambda*I) is nearly singular. TOL should -* normally be chose as approximately the largest relative error -* in the elements of T. For example, if the elements of T are -* correct to about 4 significant figures, then TOL should be -* set to about 5*10**(-4). If TOL is supplied as less than eps, -* where eps is the relative machine precision, then the value -* eps is used in place of TOL. -* -* D (output) DOUBLE PRECISION array, dimension (N-2) -* On exit, D is overwritten by the (n-2) second super-diagonal -* elements of the matrix U of the factorization of T. -* -* IN (output) INTEGER array, dimension (N) -* On exit, IN contains details of the permutation matrix P. If -* an interchange occurred at the kth step of the elimination, -* then IN(k) = 1, otherwise IN(k) = 0. The element IN(n) -* returns the smallest positive integer j such that -* -* abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL, -* -* where norm( A(j) ) denotes the sum of the absolute values of -* the jth row of the matrix A. If no such j exists then IN(n) -* is returned as zero. If IN(n) is returned as positive, then a -* diagonal element of U is small, indicating that -* (T - lambda*I) is singular or nearly singular, -* -* INFO (output) INTEGER -* = 0 : successful exit -* .lt. 0: if INFO = -k, the kth argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER K - DOUBLE PRECISION EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'DLAGTF', -INFO ) - RETURN - END IF -* - IF( N.EQ.0 ) - $ RETURN -* - A( 1 ) = A( 1 ) - LAMBDA - IN( N ) = 0 - IF( N.EQ.1 ) THEN - IF( A( 1 ).EQ.ZERO ) - $ IN( 1 ) = 1 - RETURN - END IF -* - EPS = DLAMCH( 'Epsilon' ) -* - TL = MAX( TOL, EPS ) - SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) ) - DO 10 K = 1, N - 1 - A( K+1 ) = A( K+1 ) - LAMBDA - SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) ) - IF( K.LT.( N-1 ) ) - $ SCALE2 = SCALE2 + ABS( B( K+1 ) ) - IF( A( K ).EQ.ZERO ) THEN - PIV1 = ZERO - ELSE - PIV1 = ABS( A( K ) ) / SCALE1 - END IF - IF( C( K ).EQ.ZERO ) THEN - IN( K ) = 0 - PIV2 = ZERO - SCALE1 = SCALE2 - IF( K.LT.( N-1 ) ) - $ D( K ) = ZERO - ELSE - PIV2 = ABS( C( K ) ) / SCALE2 - IF( PIV2.LE.PIV1 ) THEN - IN( K ) = 0 - SCALE1 = SCALE2 - C( K ) = C( K ) / A( K ) - A( K+1 ) = A( K+1 ) - C( K )*B( K ) - IF( K.LT.( N-1 ) ) - $ D( K ) = ZERO - ELSE - IN( K ) = 1 - MULT = A( K ) / C( K ) - A( K ) = C( K ) - TEMP = A( K+1 ) - A( K+1 ) = B( K ) - MULT*TEMP - IF( K.LT.( N-1 ) ) THEN - D( K ) = B( K+1 ) - B( K+1 ) = -MULT*D( K ) - END IF - B( K ) = TEMP - C( K ) = MULT - END IF - END IF - IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) ) - $ IN( N ) = K - 10 CONTINUE - IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) ) - $ IN( N ) = N -* - RETURN -* -* End of DLAGTF -* - END - SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, JOB, N - DOUBLE PRECISION TOL -* .. -* .. Array Arguments .. - INTEGER IN( * ) - DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DLAGTS may be used to solve one of the systems of equations -* -* (T - lambda*I)*x = y or (T - lambda*I)'*x = y, -* -* where T is an n by n tridiagonal matrix, for x, following the -* factorization of (T - lambda*I) as -* -* (T - lambda*I) = P*L*U , -* -* by routine DLAGTF. The choice of equation to be solved is -* controlled by the argument JOB, and in each case there is an option -* to perturb zero or very small diagonal elements of U, this option -* being intended for use in applications such as inverse iteration. -* -* Arguments -* ========= -* -* JOB (input) INTEGER -* Specifies the job to be performed by DLAGTS as follows: -* = 1: The equations (T - lambda*I)x = y are to be solved, -* but diagonal elements of U are not to be perturbed. -* = -1: The equations (T - lambda*I)x = y are to be solved -* and, if overflow would otherwise occur, the diagonal -* elements of U are to be perturbed. See argument TOL -* below. -* = 2: The equations (T - lambda*I)'x = y are to be solved, -* but diagonal elements of U are not to be perturbed. -* = -2: The equations (T - lambda*I)'x = y are to be solved -* and, if overflow would otherwise occur, the diagonal -* elements of U are to be perturbed. See argument TOL -* below. -* -* N (input) INTEGER -* The order of the matrix T. -* -* A (input) DOUBLE PRECISION array, dimension (N) -* On entry, A must contain the diagonal elements of U as -* returned from DLAGTF. -* -* B (input) DOUBLE PRECISION array, dimension (N-1) -* On entry, B must contain the first super-diagonal elements of -* U as returned from DLAGTF. -* -* C (input) DOUBLE PRECISION array, dimension (N-1) -* On entry, C must contain the sub-diagonal elements of L as -* returned from DLAGTF. -* -* D (input) DOUBLE PRECISION array, dimension (N-2) -* On entry, D must contain the second super-diagonal elements -* of U as returned from DLAGTF. -* -* IN (input) INTEGER array, dimension (N) -* On entry, IN must contain details of the matrix P as returned -* from DLAGTF. -* -* Y (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the right hand side vector y. -* On exit, Y is overwritten by the solution vector x. -* -* TOL (input/output) DOUBLE PRECISION -* On entry, with JOB .lt. 0, TOL should be the minimum -* perturbation to be made to very small diagonal elements of U. -* TOL should normally be chosen as about eps*norm(U), where eps -* is the relative machine precision, but if TOL is supplied as -* non-positive, then it is reset to eps*max( abs( u(i,j) ) ). -* If JOB .gt. 0 then TOL is not referenced. -* -* On exit, TOL is changed as described above, only if TOL is -* non-positive on entry. Otherwise TOL is unchanged. -* -* INFO (output) INTEGER -* = 0 : successful exit -* .lt. 0: if INFO = -i, the i-th argument had an illegal value -* .gt. 0: overflow would occur when computing the INFO(th) -* element of the solution vector x. This can only occur -* when JOB is supplied as positive and either means -* that a diagonal element of U is very small, or that -* the elements of the right-hand side vector y are very -* large. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER K - DOUBLE PRECISION ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* - INFO = 0 - IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAGTS', -INFO ) - RETURN - END IF -* - IF( N.EQ.0 ) - $ RETURN -* - EPS = DLAMCH( 'Epsilon' ) - SFMIN = DLAMCH( 'Safe minimum' ) - BIGNUM = ONE / SFMIN -* - IF( JOB.LT.0 ) THEN - IF( TOL.LE.ZERO ) THEN - TOL = ABS( A( 1 ) ) - IF( N.GT.1 ) - $ TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) ) - DO 10 K = 3, N - TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ), - $ ABS( D( K-2 ) ) ) - 10 CONTINUE - TOL = TOL*EPS - IF( TOL.EQ.ZERO ) - $ TOL = EPS - END IF - END IF -* - IF( ABS( JOB ).EQ.1 ) THEN - DO 20 K = 2, N - IF( IN( K-1 ).EQ.0 ) THEN - Y( K ) = Y( K ) - C( K-1 )*Y( K-1 ) - ELSE - TEMP = Y( K-1 ) - Y( K-1 ) = Y( K ) - Y( K ) = TEMP - C( K-1 )*Y( K ) - END IF - 20 CONTINUE - IF( JOB.EQ.1 ) THEN - DO 30 K = N, 1, -1 - IF( K.LE.N-2 ) THEN - TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) - ELSE IF( K.EQ.N-1 ) THEN - TEMP = Y( K ) - B( K )*Y( K+1 ) - ELSE - TEMP = Y( K ) - END IF - AK = A( K ) - ABSAK = ABS( AK ) - IF( ABSAK.LT.ONE ) THEN - IF( ABSAK.LT.SFMIN ) THEN - IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) - $ THEN - INFO = K - RETURN - ELSE - TEMP = TEMP*BIGNUM - AK = AK*BIGNUM - END IF - ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN - INFO = K - RETURN - END IF - END IF - Y( K ) = TEMP / AK - 30 CONTINUE - ELSE - DO 50 K = N, 1, -1 - IF( K.LE.N-2 ) THEN - TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) - ELSE IF( K.EQ.N-1 ) THEN - TEMP = Y( K ) - B( K )*Y( K+1 ) - ELSE - TEMP = Y( K ) - END IF - AK = A( K ) - PERT = SIGN( TOL, AK ) - 40 CONTINUE - ABSAK = ABS( AK ) - IF( ABSAK.LT.ONE ) THEN - IF( ABSAK.LT.SFMIN ) THEN - IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) - $ THEN - AK = AK + PERT - PERT = 2*PERT - GO TO 40 - ELSE - TEMP = TEMP*BIGNUM - AK = AK*BIGNUM - END IF - ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN - AK = AK + PERT - PERT = 2*PERT - GO TO 40 - END IF - END IF - Y( K ) = TEMP / AK - 50 CONTINUE - END IF - ELSE -* -* Come to here if JOB = 2 or -2 -* - IF( JOB.EQ.2 ) THEN - DO 60 K = 1, N - IF( K.GE.3 ) THEN - TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) - ELSE IF( K.EQ.2 ) THEN - TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - ELSE - TEMP = Y( K ) - END IF - AK = A( K ) - ABSAK = ABS( AK ) - IF( ABSAK.LT.ONE ) THEN - IF( ABSAK.LT.SFMIN ) THEN - IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) - $ THEN - INFO = K - RETURN - ELSE - TEMP = TEMP*BIGNUM - AK = AK*BIGNUM - END IF - ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN - INFO = K - RETURN - END IF - END IF - Y( K ) = TEMP / AK - 60 CONTINUE - ELSE - DO 80 K = 1, N - IF( K.GE.3 ) THEN - TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) - ELSE IF( K.EQ.2 ) THEN - TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - ELSE - TEMP = Y( K ) - END IF - AK = A( K ) - PERT = SIGN( TOL, AK ) - 70 CONTINUE - ABSAK = ABS( AK ) - IF( ABSAK.LT.ONE ) THEN - IF( ABSAK.LT.SFMIN ) THEN - IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) - $ THEN - AK = AK + PERT - PERT = 2*PERT - GO TO 70 - ELSE - TEMP = TEMP*BIGNUM - AK = AK*BIGNUM - END IF - ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN - AK = AK + PERT - PERT = 2*PERT - GO TO 70 - END IF - END IF - Y( K ) = TEMP / AK - 80 CONTINUE - END IF -* - DO 90 K = N, 2, -1 - IF( IN( K-1 ).EQ.0 ) THEN - Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K ) - ELSE - TEMP = Y( K-1 ) - Y( K-1 ) = Y( K ) - Y( K ) = TEMP - C( K-1 )*Y( K ) - END IF - 90 CONTINUE - END IF -* -* End of DLAGTS -* - END - SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNMQL overwrites the general complex M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'C': Q**H * C C * Q**H -* -* where Q is a complex unitary matrix defined as the product of k -* elementary reflectors -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**H from the Left; -* = 'R': apply Q or Q**H from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'C': Transpose, apply Q**H. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) COMPLEX*16 array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* ZGEQLF in the last k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) COMPLEX*16 array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZGEQLF. -* -* C (input/output) COMPLEX*16 array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT, - $ MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - COMPLEX*16 T( LDT, NBMAX ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2L -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNMQL', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQL', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IF( ( LEFT .AND. NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - ELSE - MI = M - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i+ib-1) . . . H(i+1) H(i) -* - CALL ZLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB, - $ A( 1, I ), LDA, TAU( I ), T, LDT ) - IF( LEFT ) THEN -* -* H or H' is applied to C(1:m-k+i+ib-1,1:n) -* - MI = M - K + I + IB - 1 - ELSE -* -* H or H' is applied to C(1:m,1:n-k+i+ib-1) -* - NI = N - K + I + IB - 1 - END IF -* -* Apply H or H' -* - CALL ZLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, - $ IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK, - $ LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNMQL -* - END - SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNMQR overwrites the general complex M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'C': Q**H * C C * Q**H -* -* where Q is a complex unitary matrix defined as the product of k -* elementary reflectors -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**H from the Left; -* = 'R': apply Q or Q**H from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'C': Conjugate transpose, apply Q**H. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) COMPLEX*16 array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* ZGEQRF in the first k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) COMPLEX*16 array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZGEQRF. -* -* C (input/output) COMPLEX*16 array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - COMPLEX*16 T( LDT, NBMAX ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2R -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNMQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), T, LDT ) - IF( LEFT ) THEN -* -* H or H' is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H' is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H' -* - CALL ZLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, - $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, - $ WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNMQR -* - END - SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INCX, N - COMPLEX*16 ALPHA, TAU -* .. -* .. Array Arguments .. - COMPLEX*16 X( * ) -* .. -* -* Purpose -* ======= -* -* ZLARFG generates a complex elementary reflector H of order n, such -* that -* -* H' * ( alpha ) = ( beta ), H' * H = I. -* ( x ) ( 0 ) -* -* where alpha and beta are scalars, with beta real, and x is an -* (n-1)-element complex vector. H is represented in the form -* -* H = I - tau * ( 1 ) * ( 1 v' ) , -* ( v ) -* -* where tau is a complex scalar and v is a complex (n-1)-element -* vector. Note that H is not hermitian. -* -* If the elements of x are all zero and alpha is real, then tau = 0 -* and H is taken to be the unit matrix. -* -* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the elementary reflector. -* -* ALPHA (input/output) COMPLEX*16 -* On entry, the value alpha. -* On exit, it is overwritten with the value beta. -* -* X (input/output) COMPLEX*16 array, dimension -* (1+(N-2)*abs(INCX)) -* On entry, the vector x. -* On exit, it is overwritten with the vector v. -* -* INCX (input) INTEGER -* The increment between elements of X. INCX > 0. -* -* TAU (output) COMPLEX*16 -* The value tau. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, KNT - DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2 - COMPLEX*16 ZLADIV - EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN -* .. -* .. External Subroutines .. - EXTERNAL ZDSCAL, ZSCAL -* .. -* .. Executable Statements .. -* - IF( N.LE.0 ) THEN - TAU = ZERO - RETURN - END IF -* - XNORM = DZNRM2( N-1, X, INCX ) - ALPHR = DBLE( ALPHA ) - ALPHI = DIMAG( ALPHA ) -* - IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN -* -* H = I -* - TAU = ZERO - ELSE -* -* general case -* - BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) - SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) - RSAFMN = ONE / SAFMIN -* - IF( ABS( BETA ).LT.SAFMIN ) THEN -* -* XNORM, BETA may be inaccurate; scale X and recompute them -* - KNT = 0 - 10 CONTINUE - KNT = KNT + 1 - CALL ZDSCAL( N-1, RSAFMN, X, INCX ) - BETA = BETA*RSAFMN - ALPHI = ALPHI*RSAFMN - ALPHR = ALPHR*RSAFMN - IF( ABS( BETA ).LT.SAFMIN ) - $ GO TO 10 -* -* New BETA is at most 1, at least SAFMIN -* - XNORM = DZNRM2( N-1, X, INCX ) - ALPHA = DCMPLX( ALPHR, ALPHI ) - BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) - TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) - ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) - CALL ZSCAL( N-1, ALPHA, X, INCX ) -* -* If ALPHA is subnormal, it may lose relative accuracy -* - ALPHA = BETA - DO 20 J = 1, KNT - ALPHA = ALPHA*SAFMIN - 20 CONTINUE - ELSE - TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) - ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) - CALL ZSCAL( N-1, ALPHA, X, INCX ) - ALPHA = BETA - END IF - END IF -* - RETURN -* -* End of ZLARFG -* - END - SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNG2L generates an m by n complex matrix Q with orthonormal columns, -* which is defined as the last n columns of a product of k elementary -* reflectors of order m -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by ZGEQLF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the (n-k+i)-th column must contain the vector which -* defines the elementary reflector H(i), for i = 1,2,...,k, as -* returned by ZGEQLF in the last k columns of its array -* argument A. -* On exit, the m-by-n matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) COMPLEX*16 array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZGEQLF. -* -* WORK (workspace) COMPLEX*16 array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, II, J, L -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARF, ZSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNG2L', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns 1:n-k to columns of the unit matrix -* - DO 20 J = 1, N - K - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( M-N+J, J ) = ONE - 20 CONTINUE -* - DO 40 I = 1, K - II = N - K + I -* -* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left -* - A( M-N+II, II ) = ONE - CALL ZLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, - $ LDA, WORK ) - CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) - A( M-N+II, II ) = ONE - TAU( I ) -* -* Set A(m-k+i+1:m,n-k+i) to zero -* - DO 30 L = M - N + II + 1, M - A( L, II ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of ZUNG2L -* - END - SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNG2R generates an m by n complex matrix Q with orthonormal columns, -* which is defined as the first n columns of a product of k elementary -* reflectors of order m -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by ZGEQRF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the i-th column must contain the vector which -* defines the elementary reflector H(i), for i = 1,2,...,k, as -* returned by ZGEQRF in the first k columns of its array -* argument A. -* On exit, the m by n matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) COMPLEX*16 array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZGEQRF. -* -* WORK (workspace) COMPLEX*16 array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARF, ZSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNG2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns k+1:n to columns of the unit matrix -* - DO 20 J = K + 1, N - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( J, J ) = ONE - 20 CONTINUE -* - DO 40 I = K, 1, -1 -* -* Apply H(i) to A(i:m,i:n) from the left -* - IF( I.LT.N ) THEN - A( I, I ) = ONE - CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - END IF - IF( I.LT.M ) - $ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) - A( I, I ) = ONE - TAU( I ) -* -* Set A(1:i-1,i) to zero -* - DO 30 L = 1, I - 1 - A( L, I ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of ZUNG2R -* - END - SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER INCV, LDC, M, N - COMPLEX*16 TAU -* .. -* .. Array Arguments .. - COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZLARF applies a complex elementary reflector H to a complex M-by-N -* matrix C, from either the left or the right. H is represented in the -* form -* -* H = I - tau * v * v' -* -* where tau is a complex scalar and v is a complex vector. -* -* If tau = 0, then H is taken to be the unit matrix. -* -* To apply H' (the conjugate transpose of H), supply conjg(tau) instead -* tau. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': form H * C -* = 'R': form C * H -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* V (input) COMPLEX*16 array, dimension -* (1 + (M-1)*abs(INCV)) if SIDE = 'L' -* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' -* The vector v in the representation of H. V is not used if -* TAU = 0. -* -* INCV (input) INTEGER -* The increment between elements of v. INCV <> 0. -* -* TAU (input) COMPLEX*16 -* The value tau in the representation of H. -* -* C (input/output) COMPLEX*16 array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by the matrix H * C if SIDE = 'L', -* or C * H if SIDE = 'R'. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) COMPLEX*16 array, dimension -* (N) if SIDE = 'L' -* or (M) if SIDE = 'R' -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. External Subroutines .. - EXTERNAL ZGEMV, ZGERC -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C -* - IF( TAU.NE.ZERO ) THEN -* -* w := C' * v -* - CALL ZGEMV( 'Conjugate transpose', M, N, ONE, C, LDC, V, - $ INCV, ZERO, WORK, 1 ) -* -* C := C - v * w' -* - CALL ZGERC( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) - END IF - ELSE -* -* Form C * H -* - IF( TAU.NE.ZERO ) THEN -* -* w := C * v -* - CALL ZGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, - $ ZERO, WORK, 1 ) -* -* C := C - w * v' -* - CALL ZGERC( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) - END IF - END IF - RETURN -* -* End of ZLARF -* - END - SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* Purpose -* ======= -* -* ZLARFT forms the triangular factor T of a complex block reflector H -* of order n, which is defined as a product of k elementary reflectors. -* -* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; -* -* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. -* -* If STOREV = 'C', the vector which defines the elementary reflector -* H(i) is stored in the i-th column of the array V, and -* -* H = I - V * T * V' -* -* If STOREV = 'R', the vector which defines the elementary reflector -* H(i) is stored in the i-th row of the array V, and -* -* H = I - V' * T * V -* -* Arguments -* ========= -* -* DIRECT (input) CHARACTER*1 -* Specifies the order in which the elementary reflectors are -* multiplied to form the block reflector: -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Specifies how the vectors which define the elementary -* reflectors are stored (see also Further Details): -* = 'C': columnwise -* = 'R': rowwise -* -* N (input) INTEGER -* The order of the block reflector H. N >= 0. -* -* K (input) INTEGER -* The order of the triangular factor T (= the number of -* elementary reflectors). K >= 1. -* -* V (input/output) COMPLEX*16 array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,N) if STOREV = 'R' -* The matrix V. See further details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. -* -* TAU (input) COMPLEX*16 array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i). -* -* T (output) COMPLEX*16 array, dimension (LDT,K) -* The k by k triangular factor T of the block reflector. -* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is -* lower triangular. The rest of the array is not used. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* Further Details -* =============== -* -* The shape of the matrix V and the storage of the vectors which define -* the H(i) is best illustrated by the following example with n = 5 and -* k = 3. The elements equal to 1 are not stored; the corresponding -* array elements are modified but restored on exit. The rest of the -* array is not used. -* -* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -* -* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -* ( v1 1 ) ( 1 v2 v2 v2 ) -* ( v1 v2 1 ) ( 1 v3 v3 ) -* ( v1 v2 v3 ) -* ( v1 v2 v3 ) -* -* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -* -* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -* ( v1 v2 v3 ) ( v2 v2 v2 1 ) -* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -* ( 1 v3 ) -* ( 1 ) -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, J - COMPLEX*16 VII -* .. -* .. External Subroutines .. - EXTERNAL ZGEMV, ZLACGV, ZTRMV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 20 I = 1, K - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 10 J = 1, I - T( J, I ) = ZERO - 10 CONTINUE - ELSE -* -* general case -* - VII = V( I, I ) - V( I, I ) = ONE - IF( LSAME( STOREV, 'C' ) ) THEN -* -* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) -* - CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1, - $ -TAU( I ), V( I, 1 ), LDV, V( I, I ), 1, - $ ZERO, T( 1, I ), 1 ) - ELSE -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' -* - IF( I.LT.N ) - $ CALL ZLACGV( N-I, V( I, I+1 ), LDV ) - CALL ZGEMV( 'No transpose', I-1, N-I+1, -TAU( I ), - $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, - $ T( 1, I ), 1 ) - IF( I.LT.N ) - $ CALL ZLACGV( N-I, V( I, I+1 ), LDV ) - END IF - V( I, I ) = VII -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - END IF - 20 CONTINUE - ELSE - DO 40 I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 30 J = I, K - T( J, I ) = ZERO - 30 CONTINUE - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN - VII = V( N-K+I, I ) - V( N-K+I, I ) = ONE -* -* T(i+1:k,i) := -* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) -* - CALL ZGEMV( 'Conjugate transpose', N-K+I, K-I, - $ -TAU( I ), V( 1, I+1 ), LDV, V( 1, I ), - $ 1, ZERO, T( I+1, I ), 1 ) - V( N-K+I, I ) = VII - ELSE - VII = V( I, N-K+I ) - V( I, N-K+I ) = ONE -* -* T(i+1:k,i) := -* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' -* - CALL ZLACGV( N-K+I-1, V( I, 1 ), LDV ) - CALL ZGEMV( 'No transpose', K-I, N-K+I, -TAU( I ), - $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, - $ T( I+1, I ), 1 ) - CALL ZLACGV( N-K+I-1, V( I, 1 ), LDV ) - V( I, N-K+I ) = VII - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - END IF - T( I, I ) = TAU( I ) - END IF - 40 CONTINUE - END IF - RETURN -* -* End of ZLARFT -* - END - SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, - $ T, LDT, C, LDC, WORK, LDWORK ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER DIRECT, SIDE, STOREV, TRANS - INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), - $ WORK( LDWORK, * ) -* .. -* -* Purpose -* ======= -* -* ZLARFB applies a complex block reflector H or its transpose H' to a -* complex M-by-N matrix C, from either the left or the right. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply H or H' from the Left -* = 'R': apply H or H' from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply H (No transpose) -* = 'C': apply H' (Conjugate transpose) -* -* DIRECT (input) CHARACTER*1 -* Indicates how H is formed from a product of elementary -* reflectors -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Indicates how the vectors which define the elementary -* reflectors are stored: -* = 'C': Columnwise -* = 'R': Rowwise -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* K (input) INTEGER -* The order of the matrix T (= the number of elementary -* reflectors whose product defines the block reflector). -* -* V (input) COMPLEX*16 array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,M) if STOREV = 'R' and SIDE = 'L' -* (LDV,N) if STOREV = 'R' and SIDE = 'R' -* The matrix V. See further details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); -* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); -* if STOREV = 'R', LDV >= K. -* -* T (input) COMPLEX*16 array, dimension (LDT,K) -* The triangular K-by-K matrix T in the representation of the -* block reflector. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* C (input/output) COMPLEX*16 array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K) -* -* LDWORK (input) INTEGER -* The leading dimension of the array WORK. -* If SIDE = 'L', LDWORK >= max(1,N); -* if SIDE = 'R', LDWORK >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - CHARACTER TRANST - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( LSAME( TRANS, 'N' ) ) THEN - TRANST = 'C' - ELSE - TRANST = 'N' - END IF -* - IF( LSAME( STOREV, 'C' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 ) (first K rows) -* ( V2 ) -* where V1 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) -* -* W := C1' -* - DO 10 J = 1, K - CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL ZLACGV( N, WORK( 1, J ), 1 ) - 10 CONTINUE -* -* W := W * V1 -* - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2'*V2 -* - CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, - $ K, M-K, ONE, C( K+1, 1 ), LDC, - $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W' -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2 * W' -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK, - $ LDWORK, ONE, C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1' -* - CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W' -* - DO 30 J = 1, K - DO 20 I = 1, N - C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C1 -* - DO 40 J = 1, K - CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 40 CONTINUE -* -* W := W * V1 -* - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C2 * V2 -* - CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V' -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2' -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, - $ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ), - $ LDV, ONE, C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1' -* - CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 60 J = 1, K - DO 50 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - ELSE -* -* Let V = ( V1 ) -* ( V2 ) (last K rows) -* where V2 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) -* -* W := C2' -* - DO 70 J = 1, K - CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL ZLACGV( N, WORK( 1, J ), 1 ) - 70 CONTINUE -* -* W := W * V2 -* - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, - $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1'*V1 -* - CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, - $ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK, - $ LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W' -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1 * W' -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ M-K, N, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) - END IF -* -* W := W * V2' -* - CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK, - $ LDWORK ) -* -* C2 := C2 - W' -* - DO 90 J = 1, K - DO 80 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - - $ DCONJG( WORK( I, J ) ) - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C2 -* - DO 100 J = 1, K - CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 100 CONTINUE -* -* W := W * V2 -* - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, - $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C1 * V1 -* - CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V' -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1' -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, - $ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE, - $ C, LDC ) - END IF -* -* W := W * V2' -* - CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK, - $ LDWORK ) -* -* C2 := C2 - W -* - DO 120 J = 1, K - DO 110 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 110 CONTINUE - 120 CONTINUE - END IF - END IF -* - ELSE IF( LSAME( STOREV, 'R' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 V2 ) (V1: first K columns) -* where V1 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) -* -* W := C1' -* - DO 130 J = 1, K - CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL ZLACGV( N, WORK( 1, J ), 1 ) - 130 CONTINUE -* -* W := W * V1' -* - CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2'*V2' -* - CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', N, K, M-K, ONE, - $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, - $ WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V' * W' -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2' * W' -* - CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', M-K, N, K, -ONE, - $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W' -* - DO 150 J = 1, K - DO 140 I = 1, N - C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) - 140 CONTINUE - 150 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) -* -* W := C1 -* - DO 160 J = 1, K - CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 160 CONTINUE -* -* W := W * V1' -* - CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C2 * V2' -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, - $ K, N-K, ONE, C( 1, K+1 ), LDC, - $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2 -* - CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 180 J = 1, K - DO 170 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 170 CONTINUE - 180 CONTINUE -* - END IF -* - ELSE -* -* Let V = ( V1 V2 ) (V2: last K columns) -* where V2 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) -* -* W := C2' -* - DO 190 J = 1, K - CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL ZLACGV( N, WORK( 1, J ), 1 ) - 190 CONTINUE -* -* W := W * V2' -* - CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK, - $ LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1'*V1' -* - CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', N, K, M-K, ONE, C, - $ LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V' * W' -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1' * W' -* - CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', M-K, N, K, -ONE, V, - $ LDV, WORK, LDWORK, ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W' -* - DO 210 J = 1, K - DO 200 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - - $ DCONJG( WORK( I, J ) ) - 200 CONTINUE - 210 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) -* -* W := C2 -* - DO 220 J = 1, K - CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 220 CONTINUE -* -* W := W * V2' -* - CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK, - $ LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C1 * V1' -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, - $ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK, - $ LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1 -* - CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, - $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 240 J = 1, K - DO 230 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 230 CONTINUE - 240 CONTINUE -* - END IF -* - END IF - END IF -* - RETURN -* -* End of ZLARFB -* - END - SUBROUTINE DLARUV( ISEED, N, X ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - INTEGER N -* .. -* .. Array Arguments .. - INTEGER ISEED( 4 ) - DOUBLE PRECISION X( N ) -* .. -* -* Purpose -* ======= -* -* DLARUV returns a vector of n random real numbers from a uniform (0,1) -* distribution (n <= 128). -* -* This is an auxiliary routine called by DLARNV and ZLARNV. -* -* Arguments -* ========= -* -* ISEED (input/output) INTEGER array, dimension (4) -* On entry, the seed of the random number generator; the array -* elements must be between 0 and 4095, and ISEED(4) must be -* odd. -* On exit, the seed is updated. -* -* N (input) INTEGER -* The number of random numbers to be generated. N <= 128. -* -* X (output) DOUBLE PRECISION array, dimension (N) -* The generated random numbers. -* -* Further Details -* =============== -* -* This routine uses a multiplicative congruential method with modulus -* 2**48 and multiplier 33952834046453 (see G.S.Fishman, -* 'Multiplicative congruential random number generators with modulus -* 2**b: an exhaustive analysis for b = 32 and a partial analysis for -* b = 48', Math. Comp. 189, pp 331-344, 1990). -* -* 48-bit integers are stored in 4 integer array elements with 12 bits -* per element. Hence the routine is portable across machines with -* integers of 32 bits or more. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - INTEGER LV, IPW2 - DOUBLE PRECISION R - PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 ) -* .. -* .. Local Scalars .. - INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J -* .. -* .. Local Arrays .. - INTEGER MM( LV, 4 ) -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MIN, MOD -* .. -* .. Data statements .. - DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508, - $ 2549 / - DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754, - $ 1145 / - DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766, - $ 2253 / - DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572, - $ 305 / - DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893, - $ 3301 / - DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307, - $ 1065 / - DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297, - $ 3133 / - DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966, - $ 2913 / - DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758, - $ 3285 / - DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598, - $ 1241 / - DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406, - $ 1197 / - DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922, - $ 3729 / - DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038, - $ 2501 / - DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934, - $ 1673 / - DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091, - $ 541 / - DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451, - $ 2753 / - DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580, - $ 949 / - DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958, - $ 2361 / - DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055, - $ 1165 / - DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507, - $ 4081 / - DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078, - $ 2725 / - DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273, - $ 3305 / - DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17, - $ 3069 / - DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854, - $ 3617 / - DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916, - $ 3733 / - DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971, - $ 409 / - DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889, - $ 2157 / - DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831, - $ 1361 / - DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621, - $ 3973 / - DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541, - $ 1865 / - DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893, - $ 2525 / - DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736, - $ 1409 / - DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992, - $ 3445 / - DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787, - $ 3577 / - DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125, - $ 77 / - DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364, - $ 3761 / - DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460, - $ 2149 / - DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257, - $ 1449 / - DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574, - $ 3005 / - DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912, - $ 225 / - DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216, - $ 85 / - DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248, - $ 3673 / - DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401, - $ 3117 / - DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124, - $ 3089 / - DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762, - $ 1349 / - DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149, - $ 2057 / - DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245, - $ 413 / - DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166, - $ 65 / - DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466, - $ 1845 / - DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018, - $ 697 / - DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399, - $ 3085 / - DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190, - $ 3441 / - DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879, - $ 1573 / - DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153, - $ 3689 / - DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320, - $ 2941 / - DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18, - $ 929 / - DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712, - $ 533 / - DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159, - $ 2841 / - DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318, - $ 4077 / - DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091, - $ 721 / - DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443, - $ 2821 / - DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510, - $ 2249 / - DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449, - $ 2397 / - DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956, - $ 2817 / - DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201, - $ 245 / - DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137, - $ 1913 / - DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399, - $ 1997 / - DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321, - $ 3121 / - DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271, - $ 997 / - DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667, - $ 1833 / - DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703, - $ 2877 / - DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629, - $ 1633 / - DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365, - $ 981 / - DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431, - $ 2009 / - DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113, - $ 941 / - DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922, - $ 2449 / - DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554, - $ 197 / - DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184, - $ 2441 / - DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099, - $ 285 / - DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228, - $ 1473 / - DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012, - $ 2741 / - DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921, - $ 3129 / - DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452, - $ 909 / - DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901, - $ 2801 / - DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572, - $ 421 / - DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309, - $ 4073 / - DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171, - $ 2813 / - DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817, - $ 2337 / - DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039, - $ 1429 / - DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696, - $ 1177 / - DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256, - $ 1901 / - DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715, - $ 81 / - DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077, - $ 1669 / - DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019, - $ 2633 / - DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497, - $ 2269 / - DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101, - $ 129 / - DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717, - $ 1141 / - DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51, - $ 249 / - DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981, - $ 3917 / - DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978, - $ 2481 / - DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813, - $ 3941 / - DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881, - $ 2217 / - DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76, - $ 2749 / - DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846, - $ 3041 / - DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694, - $ 1877 / - DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682, - $ 345 / - DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124, - $ 2861 / - DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660, - $ 1809 / - DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997, - $ 3141 / - DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479, - $ 2825 / - DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141, - $ 157 / - DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886, - $ 2881 / - DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514, - $ 3637 / - DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301, - $ 1465 / - DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604, - $ 2829 / - DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888, - $ 2161 / - DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836, - $ 3365 / - DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990, - $ 361 / - DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058, - $ 2685 / - DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692, - $ 3745 / - DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194, - $ 2325 / - DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20, - $ 3609 / - DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285, - $ 3821 / - DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046, - $ 3537 / - DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107, - $ 517 / - DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508, - $ 3017 / - DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525, - $ 2141 / - DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801, - $ 1537 / -* .. -* .. Executable Statements .. -* - I1 = ISEED( 1 ) - I2 = ISEED( 2 ) - I3 = ISEED( 3 ) - I4 = ISEED( 4 ) -* - DO 10 I = 1, MIN( N, LV ) -* -* Multiply the seed by i-th power of the multiplier modulo 2**48 -* - IT4 = I4*MM( I, 4 ) - IT3 = IT4 / IPW2 - IT4 = IT4 - IPW2*IT3 - IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 ) - IT2 = IT3 / IPW2 - IT3 = IT3 - IPW2*IT2 - IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 ) - IT1 = IT2 / IPW2 - IT2 = IT2 - IPW2*IT1 - IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) + - $ I4*MM( I, 1 ) - IT1 = MOD( IT1, IPW2 ) -* -* Convert 48-bit integer to a real number in the interval (0,1) -* - X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R* - $ DBLE( IT4 ) ) ) ) - 10 CONTINUE -* -* Return final value of seed -* - ISEED( 1 ) = IT1 - ISEED( 2 ) = IT2 - ISEED( 3 ) = IT3 - ISEED( 4 ) = IT4 - RETURN -* -* End of DLARUV -* - END - SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNM2L overwrites the general complex m-by-n matrix C with -* -* Q * C if SIDE = 'L' and TRANS = 'N', or -* -* Q'* C if SIDE = 'L' and TRANS = 'C', or -* -* C * Q if SIDE = 'R' and TRANS = 'N', or -* -* C * Q' if SIDE = 'R' and TRANS = 'C', -* -* where Q is a complex unitary matrix defined as the product of k -* elementary reflectors -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q' from the Left -* = 'R': apply Q or Q' from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply Q (No transpose) -* = 'C': apply Q' (Conjugate transpose) -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) COMPLEX*16 array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* ZGEQLF in the last k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) COMPLEX*16 array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZGEQLF. -* -* C (input/output) COMPLEX*16 array, dimension (LDC,N) -* On entry, the m-by-n matrix C. -* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) COMPLEX*16 array, dimension -* (N) if SIDE = 'L', -* (M) if SIDE = 'R' -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, MI, NI, NQ - COMPLEX*16 AII, TAUI -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARF -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNM2L', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - ELSE - MI = M - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) or H(i)' is applied to C(1:m-k+i,1:n) -* - MI = M - K + I - ELSE -* -* H(i) or H(i)' is applied to C(1:m,1:n-k+i) -* - NI = N - K + I - END IF -* -* Apply H(i) or H(i)' -* - IF( NOTRAN ) THEN - TAUI = TAU( I ) - ELSE - TAUI = DCONJG( TAU( I ) ) - END IF - AII = A( NQ-K+I, I ) - A( NQ-K+I, I ) = ONE - CALL ZLARF( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, WORK ) - A( NQ-K+I, I ) = AII - 10 CONTINUE - RETURN -* -* End of ZUNM2L -* - END - SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNM2R overwrites the general complex m-by-n matrix C with -* -* Q * C if SIDE = 'L' and TRANS = 'N', or -* -* Q'* C if SIDE = 'L' and TRANS = 'C', or -* -* C * Q if SIDE = 'R' and TRANS = 'N', or -* -* C * Q' if SIDE = 'R' and TRANS = 'C', -* -* where Q is a complex unitary matrix defined as the product of k -* elementary reflectors -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q' from the Left -* = 'R': apply Q or Q' from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply Q (No transpose) -* = 'C': apply Q' (Conjugate transpose) -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) COMPLEX*16 array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* ZGEQRF in the first k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) COMPLEX*16 array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZGEQRF. -* -* C (input/output) COMPLEX*16 array, dimension (LDC,N) -* On entry, the m-by-n matrix C. -* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) COMPLEX*16 array, dimension -* (N) if SIDE = 'L', -* (M) if SIDE = 'R' -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - COMPLEX*16 AII, TAUI -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARF -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNM2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) or H(i)' is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) or H(i)' is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) or H(i)' -* - IF( NOTRAN ) THEN - TAUI = TAU( I ) - ELSE - TAUI = DCONJG( TAU( I ) ) - END IF - AII = A( I, I ) - A( I, I ) = ONE - CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC, - $ WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of ZUNM2R -* - END - SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DSYEV computes all eigenvalues and, optionally, eigenvectors of a -* real symmetric matrix A. -* -* Arguments -* ========= -* -* JOBZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only; -* = 'V': Compute eigenvalues and eigenvectors. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) -* On entry, the symmetric matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of A contains the -* upper triangular part of the matrix A. If UPLO = 'L', -* the leading N-by-N lower triangular part of A contains -* the lower triangular part of the matrix A. -* On exit, if JOBZ = 'V', then if INFO = 0, A contains the -* orthonormal eigenvectors of the matrix A. -* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') -* or the upper triangle (if UPLO='U') of A, including the -* diagonal, is destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* W (output) DOUBLE PRECISION array, dimension (N) -* If INFO = 0, the eigenvalues in ascending order. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The length of the array WORK. LWORK >= max(1,3*N-1). -* For optimal efficiency, LWORK >= (NB+2)*N, -* where NB is the blocksize for DSYTRD returned by ILAENV. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the algorithm failed to converge; i -* off-diagonal elements of an intermediate tridiagonal -* form did not converge to zero. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LOWER, LQUERY, WANTZ - INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, - $ LLWORK, LOPT, LWKOPT, NB - DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, - $ SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY -* .. -* .. External Subroutines .. - EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD, - $ XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - LOWER = LSAME( UPLO, 'L' ) - LQUERY = ( LWORK.EQ.-1 ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF -* - IF( INFO.EQ.0 ) THEN - NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) - LWKOPT = MAX( 1, ( NB+2 )*N ) - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYEV ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( N.EQ.1 ) THEN - W( 1 ) = A( 1, 1 ) - WORK( 1 ) = 3 - IF( WANTZ ) - $ A( 1, 1 ) = ONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = SQRT( BIGNUM ) -* -* Scale matrix to allowable range, if necessary. -* - ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) - ISCALE = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) - $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) -* -* Call DSYTRD to reduce symmetric matrix to tridiagonal form. -* - INDE = 1 - INDTAU = INDE + N - INDWRK = INDTAU + N - LLWORK = LWORK - INDWRK + 1 - CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), - $ WORK( INDWRK ), LLWORK, IINFO ) - LOPT = 2*N + WORK( INDWRK ) -* -* For eigenvalues only, call DSTERF. For eigenvectors, first call -* DORGTR to generate the orthogonal matrix, then call DSTEQR. -* - IF( .NOT.WANTZ ) THEN - CALL DSTERF( N, W, WORK( INDE ), INFO ) - ELSE - CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), - $ LLWORK, IINFO ) - CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ), - $ INFO ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = N - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF -* -* Set WORK(1) to optimal workspace size. -* - WORK( 1 ) = LWKOPT -* - RETURN -* -* End of DSYEV -* - END - DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER NORM, UPLO - INTEGER LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLANSY returns the value of the one norm, or the Frobenius norm, or -* the infinity norm, or the element of largest absolute value of a -* real symmetric matrix A. -* -* Description -* =========== -* -* DLANSY returns the value -* -* DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' -* ( -* ( norm1(A), NORM = '1', 'O' or 'o' -* ( -* ( normI(A), NORM = 'I' or 'i' -* ( -* ( normF(A), NORM = 'F', 'f', 'E' or 'e' -* -* where norm1 denotes the one norm of a matrix (maximum column sum), -* normI denotes the infinity norm of a matrix (maximum row sum) and -* normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies the value to be returned in DLANSY as described -* above. -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is to be referenced. -* = 'U': Upper triangular part of A is referenced -* = 'L': Lower triangular part of A is referenced -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. When N = 0, DLANSY is -* set to zero. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The symmetric matrix A. If UPLO = 'U', the leading n by n -* upper triangular part of A contains the upper triangular part -* of the matrix A, and the strictly lower triangular part of A -* is not referenced. If UPLO = 'L', the leading n by n lower -* triangular part of A contains the lower triangular part of -* the matrix A, and the strictly upper triangular part of A is -* not referenced. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(N,1). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), -* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, -* WORK is not referenced. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION ABSA, SCALE, SUM, VALUE -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* - IF( N.EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, J - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = J, N - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. - $ ( NORM.EQ.'1' ) ) THEN -* -* Find normI(A) ( = norm1(A), since A is symmetric). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 60 J = 1, N - SUM = ZERO - DO 50 I = 1, J - 1 - ABSA = ABS( A( I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 50 CONTINUE - WORK( J ) = SUM + ABS( A( J, J ) ) - 60 CONTINUE - DO 70 I = 1, N - VALUE = MAX( VALUE, WORK( I ) ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - WORK( I ) = ZERO - 80 CONTINUE - DO 100 J = 1, N - SUM = WORK( J ) + ABS( A( J, J ) ) - DO 90 I = J + 1, N - ABSA = ABS( A( I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 90 CONTINUE - VALUE = MAX( VALUE, SUM ) - 100 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - IF( LSAME( UPLO, 'U' ) ) THEN - DO 110 J = 2, N - CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) - 110 CONTINUE - ELSE - DO 120 J = 1, N - 1 - CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) - 120 CONTINUE - END IF - SUM = 2*SUM - CALL DLASSQ( N, A, LDA+1, SCALE, SUM ) - VALUE = SCALE*SQRT( SUM ) - END IF -* - DLANSY = VALUE - RETURN -* -* End of DLANSY -* - END - SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), - $ WORK( * ) -* .. -* -* Purpose -* ======= -* -* DSYTRD reduces a real symmetric matrix A to real symmetric -* tridiagonal form T by an orthogonal similarity transformation: -* Q**T * A * Q = T. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* N-by-N upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* On exit, if UPLO = 'U', the diagonal and first superdiagonal -* of A are overwritten by the corresponding elements of the -* tridiagonal matrix T, and the elements above the first -* superdiagonal, with the array TAU, represent the orthogonal -* matrix Q as a product of elementary reflectors; if UPLO -* = 'L', the diagonal and first subdiagonal of A are over- -* written by the corresponding elements of the tridiagonal -* matrix T, and the elements below the first subdiagonal, with -* the array TAU, represent the orthogonal matrix Q as a product -* of elementary reflectors. See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* D (output) DOUBLE PRECISION array, dimension (N) -* The diagonal elements of the tridiagonal matrix T: -* D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (N-1) -* The off-diagonal elements of the tridiagonal matrix T: -* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. -* -* TAU (output) DOUBLE PRECISION array, dimension (N-1) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= 1. -* For optimum performance LWORK >= N*NB, where NB is the -* optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* If UPLO = 'U', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(n-1) . . . H(2) H(1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in -* A(1:i-1,i+1), and tau in TAU(i). -* -* If UPLO = 'L', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(1) H(2) . . . H(n-1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), -* and tau in TAU(i). -* -* The contents of A on exit are illustrated by the following examples -* with n = 5: -* -* if UPLO = 'U': if UPLO = 'L': -* -* ( d e v2 v3 v4 ) ( d ) -* ( d e v3 v4 ) ( e d ) -* ( d e v4 ) ( v1 e d ) -* ( d e ) ( v1 v2 e d ) -* ( d ) ( v1 v2 v3 e d ) -* -* where d and e denote diagonal and off-diagonal elements of T, and vi -* denotes an element of the vector defining H(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER - INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN - INFO = -9 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. -* - NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYTRD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NX = N - IWS = 1 - IF( NB.GT.1 .AND. NB.LT.N ) THEN -* -* Determine when to cross over from blocked to unblocked code -* (last block is always handled by unblocked code). -* - NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) - IF( NX.LT.N ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: determine the -* minimum value of NB, and reduce NB or force use of -* unblocked code by setting NX = N. -* - NB = MAX( LWORK / LDWORK, 1 ) - NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 ) - IF( NB.LT.NBMIN ) - $ NX = N - END IF - ELSE - NX = N - END IF - ELSE - NB = 1 - END IF -* - IF( UPPER ) THEN -* -* Reduce the upper triangle of A. -* Columns 1:kk are handled by the unblocked method. -* - KK = N - ( ( N-NX+NB-1 ) / NB )*NB - DO 20 I = N - NB + 1, KK + 1, -NB -* -* Reduce columns i:i+nb-1 to tridiagonal form and form the -* matrix W which is needed to update the unreduced part of -* the matrix -* - CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, - $ LDWORK ) -* -* Update the unreduced submatrix A(1:i-1,1:i-1), using an -* update of the form: A := A - V*W' - W*V' -* - CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ), - $ LDA, WORK, LDWORK, ONE, A, LDA ) -* -* Copy superdiagonal elements back into A, and diagonal -* elements into D -* - DO 10 J = I, I + NB - 1 - A( J-1, J ) = E( J-1 ) - D( J ) = A( J, J ) - 10 CONTINUE - 20 CONTINUE -* -* Use unblocked code to reduce the last or only block -* - CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) - ELSE -* -* Reduce the lower triangle of A -* - DO 40 I = 1, N - NX, NB -* -* Reduce columns i:i+nb-1 to tridiagonal form and form the -* matrix W which is needed to update the unreduced part of -* the matrix -* - CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), - $ TAU( I ), WORK, LDWORK ) -* -* Update the unreduced submatrix A(i+ib:n,i+ib:n), using -* an update of the form: A := A - V*W' - W*V' -* - CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE, - $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, - $ A( I+NB, I+NB ), LDA ) -* -* Copy subdiagonal elements back into A, and diagonal -* elements into D -* - DO 30 J = I, I + NB - 1 - A( J+1, J ) = E( J ) - D( J ) = A( J, J ) - 30 CONTINUE - 40 CONTINUE -* -* Use unblocked code to reduce the last or only block -* - CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), - $ TAU( I ), IINFO ) - END IF -* - WORK( 1 ) = LWKOPT - RETURN -* -* End of DSYTRD -* - END - SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORGTR generates a real orthogonal matrix Q which is defined as the -* product of n-1 elementary reflectors of order N, as returned by -* DSYTRD: -* -* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), -* -* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A contains elementary reflectors -* from DSYTRD; -* = 'L': Lower triangle of A contains elementary reflectors -* from DSYTRD. -* -* N (input) INTEGER -* The order of the matrix Q. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the vectors which define the elementary reflectors, -* as returned by DSYTRD. -* On exit, the N-by-N orthogonal matrix Q. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* TAU (input) DOUBLE PRECISION array, dimension (N-1) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DSYTRD. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N-1). -* For optimum performance LWORK >= (N-1)*NB, where NB is -* the optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER - INTEGER I, IINFO, J, LWKOPT, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DORGQL, DORGQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( UPPER ) THEN - NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 ) - ELSE - NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 ) - END IF - LWKOPT = MAX( 1, N-1 )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGTR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( UPPER ) THEN -* -* Q was determined by a call to DSYTRD with UPLO = 'U' -* -* Shift the vectors which define the elementary reflectors one -* column to the left, and set the last row and column of Q to -* those of the unit matrix -* - DO 20 J = 1, N - 1 - DO 10 I = 1, J - 1 - A( I, J ) = A( I, J+1 ) - 10 CONTINUE - A( N, J ) = ZERO - 20 CONTINUE - DO 30 I = 1, N - 1 - A( I, N ) = ZERO - 30 CONTINUE - A( N, N ) = ONE -* -* Generate Q(1:n-1,1:n-1) -* - CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* Q was determined by a call to DSYTRD with UPLO = 'L'. -* -* Shift the vectors which define the elementary reflectors one -* column to the right, and set the first row and column of Q to -* those of the unit matrix -* - DO 50 J = N, 2, -1 - A( 1, J ) = ZERO - DO 40 I = J + 1, N - A( I, J ) = A( I, J-1 ) - 40 CONTINUE - 50 CONTINUE - A( 1, 1 ) = ONE - DO 60 I = 2, N - A( I, 1 ) = ZERO - 60 CONTINUE - IF( N.GT.1 ) THEN -* -* Generate Q(2:n,2:n) -* - CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORGTR -* - END - SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER COMPZ - INTEGER INFO, LDZ, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a -* symmetric tridiagonal matrix using the implicit QL or QR method. -* The eigenvectors of a full or band symmetric matrix can also be found -* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to -* tridiagonal form. -* -* Arguments -* ========= -* -* COMPZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only. -* = 'V': Compute eigenvalues and eigenvectors of the original -* symmetric matrix. On entry, Z must contain the -* orthogonal matrix used to reduce the original matrix -* to tridiagonal form. -* = 'I': Compute eigenvalues and eigenvectors of the -* tridiagonal matrix. Z is initialized to the identity -* matrix. -* -* N (input) INTEGER -* The order of the matrix. N >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the diagonal elements of the tridiagonal matrix. -* On exit, if INFO = 0, the eigenvalues in ascending order. -* -* E (input/output) DOUBLE PRECISION array, dimension (N-1) -* On entry, the (n-1) subdiagonal elements of the tridiagonal -* matrix. -* On exit, E has been destroyed. -* -* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) -* On entry, if COMPZ = 'V', then Z contains the orthogonal -* matrix used in the reduction to tridiagonal form. -* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the -* orthonormal eigenvectors of the original symmetric matrix, -* and if COMPZ = 'I', Z contains the orthonormal eigenvectors -* of the symmetric tridiagonal matrix. -* If COMPZ = 'N', then Z is not referenced. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= 1, and if -* eigenvectors are desired, then LDZ >= max(1,N). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) -* If COMPZ = 'N', then WORK is not referenced. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: the algorithm has failed to find all the eigenvalues in -* a total of 30*N iterations; if INFO = i, then i -* elements of E have not converged to zero; on exit, D -* and E contain the elements of a symmetric tridiagonal -* matrix which is orthogonally similar to the original -* matrix. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) -* .. -* .. Local Scalars .. - INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, - $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, - $ NM1, NMAXIT - DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, - $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 - EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR, - $ DLASRT, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( LSAME( COMPZ, 'N' ) ) THEN - ICOMPZ = 0 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ICOMPZ = 2 - ELSE - ICOMPZ = -1 - END IF - IF( ICOMPZ.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, - $ N ) ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSTEQR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - IF( ICOMPZ.EQ.2 ) - $ Z( 1, 1 ) = ONE - RETURN - END IF -* -* Determine the unit roundoff and over/underflow thresholds. -* - EPS = DLAMCH( 'E' ) - EPS2 = EPS**2 - SAFMIN = DLAMCH( 'S' ) - SAFMAX = ONE / SAFMIN - SSFMAX = SQRT( SAFMAX ) / THREE - SSFMIN = SQRT( SAFMIN ) / EPS2 -* -* Compute the eigenvalues and eigenvectors of the tridiagonal -* matrix. -* - IF( ICOMPZ.EQ.2 ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -* - NMAXIT = N*MAXIT - JTOT = 0 -* -* Determine where the matrix splits and choose QL or QR iteration -* for each block, according to whether top or bottom diagonal -* element is smaller. -* - L1 = 1 - NM1 = N - 1 -* - 10 CONTINUE - IF( L1.GT.N ) - $ GO TO 160 - IF( L1.GT.1 ) - $ E( L1-1 ) = ZERO - IF( L1.LE.NM1 ) THEN - DO 20 M = L1, NM1 - TST = ABS( E( M ) ) - IF( TST.EQ.ZERO ) - $ GO TO 30 - IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ - $ 1 ) ) ) )*EPS ) THEN - E( M ) = ZERO - GO TO 30 - END IF - 20 CONTINUE - END IF - M = N -* - 30 CONTINUE - L = L1 - LSV = L - LEND = M - LENDSV = LEND - L1 = M + 1 - IF( LEND.EQ.L ) - $ GO TO 10 -* -* Scale submatrix in rows and columns L to LEND -* - ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) - ISCALE = 0 - IF( ANORM.EQ.ZERO ) - $ GO TO 10 - IF( ANORM.GT.SSFMAX ) THEN - ISCALE = 1 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, - $ INFO ) - ELSE IF( ANORM.LT.SSFMIN ) THEN - ISCALE = 2 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, - $ INFO ) - END IF -* -* Choose between QL and QR iteration -* - IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN - LEND = LSV - L = LENDSV - END IF -* - IF( LEND.GT.L ) THEN -* -* QL Iteration -* -* Look for small subdiagonal element. -* - 40 CONTINUE - IF( L.NE.LEND ) THEN - LENDM1 = LEND - 1 - DO 50 M = L, LENDM1 - TST = ABS( E( M ) )**2 - IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ - $ SAFMIN )GO TO 60 - 50 CONTINUE - END IF -* - M = LEND -* - 60 CONTINUE - IF( M.LT.LEND ) - $ E( M ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 80 -* -* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -* to compute its eigensystem. -* - IF( M.EQ.L+1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) - WORK( L ) = C - WORK( N-1+L ) = S - CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), - $ WORK( N-1+L ), Z( 1, L ), LDZ ) - ELSE - CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) - END IF - D( L ) = RT1 - D( L+1 ) = RT2 - E( L ) = ZERO - L = L + 2 - IF( L.LE.LEND ) - $ GO TO 40 - GO TO 140 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 140 - JTOT = JTOT + 1 -* -* Form shift. -* - G = ( D( L+1 )-P ) / ( TWO*E( L ) ) - R = DLAPY2( G, ONE ) - G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) -* - S = ONE - C = ONE - P = ZERO -* -* Inner loop -* - MM1 = M - 1 - DO 70 I = MM1, L, -1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M-1 ) - $ E( I+1 ) = R - G = D( I+1 ) - P - R = ( D( I )-G )*S + TWO*C*B - P = S*R - D( I+1 ) = G + P - G = C*R - B -* -* If eigenvectors are desired, then save rotations. -* - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = -S - END IF -* - 70 CONTINUE -* -* If eigenvectors are desired, then apply saved rotations. -* - IF( ICOMPZ.GT.0 ) THEN - MM = M - L + 1 - CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), - $ Z( 1, L ), LDZ ) - END IF -* - D( L ) = D( L ) - P - E( L ) = G - GO TO 40 -* -* Eigenvalue found. -* - 80 CONTINUE - D( L ) = P -* - L = L + 1 - IF( L.LE.LEND ) - $ GO TO 40 - GO TO 140 -* - ELSE -* -* QR Iteration -* -* Look for small superdiagonal element. -* - 90 CONTINUE - IF( L.NE.LEND ) THEN - LENDP1 = LEND + 1 - DO 100 M = L, LENDP1, -1 - TST = ABS( E( M-1 ) )**2 - IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ - $ SAFMIN )GO TO 110 - 100 CONTINUE - END IF -* - M = LEND -* - 110 CONTINUE - IF( M.GT.LEND ) - $ E( M-1 ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 130 -* -* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -* to compute its eigensystem. -* - IF( M.EQ.L-1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) - WORK( M ) = C - WORK( N-1+M ) = S - CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), - $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) - ELSE - CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) - END IF - D( L-1 ) = RT1 - D( L ) = RT2 - E( L-1 ) = ZERO - L = L - 2 - IF( L.GE.LEND ) - $ GO TO 90 - GO TO 140 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 140 - JTOT = JTOT + 1 -* -* Form shift. -* - G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) - R = DLAPY2( G, ONE ) - G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) -* - S = ONE - C = ONE - P = ZERO -* -* Inner loop -* - LM1 = L - 1 - DO 120 I = M, LM1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M ) - $ E( I-1 ) = R - G = D( I ) - P - R = ( D( I+1 )-G )*S + TWO*C*B - P = S*R - D( I ) = G + P - G = C*R - B -* -* If eigenvectors are desired, then save rotations. -* - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = S - END IF -* - 120 CONTINUE -* -* If eigenvectors are desired, then apply saved rotations. -* - IF( ICOMPZ.GT.0 ) THEN - MM = L - M + 1 - CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), - $ Z( 1, M ), LDZ ) - END IF -* - D( L ) = D( L ) - P - E( LM1 ) = G - GO TO 90 -* -* Eigenvalue found. -* - 130 CONTINUE - D( L ) = P -* - L = L - 1 - IF( L.GE.LEND ) - $ GO TO 90 - GO TO 140 -* - END IF -* -* Undo scaling if necessary -* - 140 CONTINUE - IF( ISCALE.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), - $ N, INFO ) - ELSE IF( ISCALE.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), - $ N, INFO ) - END IF -* -* Check for no convergence to an eigenvalue after a total -* of N*MAXIT iterations. -* - IF( JTOT.LT.NMAXIT ) - $ GO TO 10 - DO 150 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 150 CONTINUE - GO TO 190 -* -* Order eigenvalues and eigenvectors. -* - 160 CONTINUE - IF( ICOMPZ.EQ.0 ) THEN -* -* Use Quick Sort -* - CALL DLASRT( 'I', N, D, INFO ) -* - ELSE -* -* Use Selection Sort to minimize swaps of eigenvectors -* - DO 180 II = 2, N - I = II - 1 - K = I - P = D( I ) - DO 170 J = II, N - IF( D( J ).LT.P ) THEN - K = J - P = D( J ) - END IF - 170 CONTINUE - IF( K.NE.I ) THEN - D( K ) = D( I ) - D( I ) = P - CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) - END IF - 180 CONTINUE - END IF -* - 190 CONTINUE - RETURN -* -* End of DSTEQR -* - END - SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDW, N, NB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) -* .. -* -* Purpose -* ======= -* -* DLATRD reduces NB rows and columns of a real symmetric matrix A to -* symmetric tridiagonal form by an orthogonal similarity -* transformation Q' * A * Q, and returns the matrices V and W which are -* needed to apply the transformation to the unreduced part of A. -* -* If UPLO = 'U', DLATRD reduces the last NB rows and columns of a -* matrix, of which the upper triangle is supplied; -* if UPLO = 'L', DLATRD reduces the first NB rows and columns of a -* matrix, of which the lower triangle is supplied. -* -* This is an auxiliary routine called by DSYTRD. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. -* -* NB (input) INTEGER -* The number of rows and columns to be reduced. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* n-by-n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n-by-n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* On exit: -* if UPLO = 'U', the last NB columns have been reduced to -* tridiagonal form, with the diagonal elements overwriting -* the diagonal elements of A; the elements above the diagonal -* with the array TAU, represent the orthogonal matrix Q as a -* product of elementary reflectors; -* if UPLO = 'L', the first NB columns have been reduced to -* tridiagonal form, with the diagonal elements overwriting -* the diagonal elements of A; the elements below the diagonal -* with the array TAU, represent the orthogonal matrix Q as a -* product of elementary reflectors. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= (1,N). -* -* E (output) DOUBLE PRECISION array, dimension (N-1) -* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal -* elements of the last NB columns of the reduced matrix; -* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of -* the first NB columns of the reduced matrix. -* -* TAU (output) DOUBLE PRECISION array, dimension (N-1) -* The scalar factors of the elementary reflectors, stored in -* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. -* See Further Details. -* -* W (output) DOUBLE PRECISION array, dimension (LDW,NB) -* The n-by-nb matrix W required to update the unreduced part -* of A. -* -* LDW (input) INTEGER -* The leading dimension of the array W. LDW >= max(1,N). -* -* Further Details -* =============== -* -* If UPLO = 'U', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(n) H(n-1) . . . H(n-nb+1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), -* and tau in TAU(i-1). -* -* If UPLO = 'L', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(1) H(2) . . . H(nb). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), -* and tau in TAU(i). -* -* The elements of the vectors v together form the n-by-nb matrix V -* which is needed, with W, to apply the transformation to the unreduced -* part of the matrix, using a symmetric rank-2k update of the form: -* A := A - V*W' - W*V'. -* -* The contents of A on exit are illustrated by the following examples -* with n = 5 and nb = 2: -* -* if UPLO = 'U': if UPLO = 'L': -* -* ( a a a v4 v5 ) ( d ) -* ( a a v4 v5 ) ( 1 d ) -* ( a 1 v5 ) ( v1 1 a ) -* ( d 1 ) ( v1 v2 a a ) -* ( d ) ( v1 v2 a a a ) -* -* where d denotes a diagonal element of the reduced matrix, a denotes -* an element of the original matrix that is unchanged, and vi denotes -* an element of the vector defining H(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IW - DOUBLE PRECISION ALPHA -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DSYMV -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Reduce last NB columns of upper triangle -* - DO 10 I = N, N - NB + 1, -1 - IW = I - N + NB - IF( I.LT.N ) THEN -* -* Update A(1:i,i) -* - CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), - $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) - CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), - $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) - END IF - IF( I.GT.1 ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(1:i-2,i) -* - CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) ) - E( I-1 ) = A( I-1, I ) - A( I-1, I ) = ONE -* -* Compute W(1:i-1,i) -* - CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, - $ ZERO, W( 1, IW ), 1 ) - IF( I.LT.N ) THEN - CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ), - $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, -ONE, - $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, - $ W( 1, IW ), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, -ONE, - $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, - $ W( 1, IW ), 1 ) - END IF - CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) - ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1, - $ A( 1, I ), 1 ) - CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) - END IF -* - 10 CONTINUE - ELSE -* -* Reduce first NB columns of lower triangle -* - DO 20 I = 1, NB -* -* Update A(i:n,i) -* - CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), - $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) - CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), - $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) - IF( I.LT.N ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(i+2:n,i) -* - CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, - $ TAU( I ) ) - E( I ) = A( I+1, I ) - A( I+1, I ) = ONE -* -* Compute W(i+1:n,i) -* - CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, - $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW, - $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, - $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), - $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) - CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) - ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1, - $ A( I+1, I ), 1 ) - CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) - END IF -* - 20 CONTINUE - END IF -* - RETURN -* -* End of DLATRD -* - END - SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) -* .. -* -* Purpose -* ======= -* -* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal -* form T by an orthogonal similarity transformation: Q' * A * Q = T. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* n-by-n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n-by-n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* On exit, if UPLO = 'U', the diagonal and first superdiagonal -* of A are overwritten by the corresponding elements of the -* tridiagonal matrix T, and the elements above the first -* superdiagonal, with the array TAU, represent the orthogonal -* matrix Q as a product of elementary reflectors; if UPLO -* = 'L', the diagonal and first subdiagonal of A are over- -* written by the corresponding elements of the tridiagonal -* matrix T, and the elements below the first subdiagonal, with -* the array TAU, represent the orthogonal matrix Q as a product -* of elementary reflectors. See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* D (output) DOUBLE PRECISION array, dimension (N) -* The diagonal elements of the tridiagonal matrix T: -* D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (N-1) -* The off-diagonal elements of the tridiagonal matrix T: -* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. -* -* TAU (output) DOUBLE PRECISION array, dimension (N-1) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* If UPLO = 'U', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(n-1) . . . H(2) H(1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in -* A(1:i-1,i+1), and tau in TAU(i). -* -* If UPLO = 'L', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(1) H(2) . . . H(n-1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), -* and tau in TAU(i). -* -* The contents of A on exit are illustrated by the following examples -* with n = 5: -* -* if UPLO = 'U': if UPLO = 'L': -* -* ( d e v2 v3 v4 ) ( d ) -* ( d e v3 v4 ) ( e d ) -* ( d e v4 ) ( v1 e d ) -* ( d e ) ( v1 v2 e d ) -* ( d ) ( v1 v2 v3 e d ) -* -* where d and e denote diagonal and off-diagonal elements of T, and vi -* denotes an element of the vector defining H(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO, HALF - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, - $ HALF = 1.0D0 / 2.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I - DOUBLE PRECISION ALPHA, TAUI -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DLARFG, DSYMV, DSYR2, XERBLA -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYTD2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Reduce the upper triangle of A -* - DO 10 I = N - 1, 1, -1 -* -* Generate elementary reflector H(i) = I - tau * v * v' -* to annihilate A(1:i-1,i+1) -* - CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI ) - E( I ) = A( I, I+1 ) -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(1:i,1:i) -* - A( I, I+1 ) = ONE -* -* Compute x := tau * A * v storing x in TAU(1:i) -* - CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, - $ TAU, 1 ) -* -* Compute w := x - 1/2 * tau * (x'*v) * v -* - ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 ) - CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w' - w * v' -* - CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, - $ LDA ) -* - A( I, I+1 ) = E( I ) - END IF - D( I+1 ) = A( I+1, I+1 ) - TAU( I ) = TAUI - 10 CONTINUE - D( 1 ) = A( 1, 1 ) - ELSE -* -* Reduce the lower triangle of A -* - DO 20 I = 1, N - 1 -* -* Generate elementary reflector H(i) = I - tau * v * v' -* to annihilate A(i+2:n,i) -* - CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, - $ TAUI ) - E( I ) = A( I+1, I ) -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(i+1:n,i+1:n) -* - A( I+1, I ) = ONE -* -* Compute x := tau * A * v storing y in TAU(i:n-1) -* - CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, - $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) -* -* Compute w := x - 1/2 * tau * (x'*v) * v -* - ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ), - $ 1 ) - CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w' - w * v' -* - CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, - $ A( I+1, I+1 ), LDA ) -* - A( I+1, I ) = E( I ) - END IF - D( I ) = A( I, I ) - TAU( I ) = TAUI - 20 CONTINUE - D( N ) = A( N, N ) - END IF -* - RETURN -* -* End of DSYTD2 -* - END - SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORGQL generates an M-by-N real matrix Q with orthonormal columns, -* which is defined as the last N columns of a product of K elementary -* reflectors of order M -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGEQLF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the (n-k+i)-th column must contain the vector which -* defines the elementary reflector H(i), for i = 1,2,...,k, as -* returned by DGEQLF in the last k columns of its array -* argument A. -* On exit, the M-by-N matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQLF. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is the -* optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, - $ NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, N )*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGQL', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the first block. -* The last kk columns are handled by the block method. -* - KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) -* -* Set A(m-kk+1:m,1:n-kk) to zero. -* - DO 20 J = 1, N - KK - DO 10 I = M - KK + 1, M - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the first or only block. -* - CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = K - KK + 1, K, NB - IB = MIN( NB, K-I+1 ) - IF( N-K+I.GT.1 ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i+ib-1) . . . H(i+1) H(i) -* - CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, - $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left -* - CALL DLARFB( 'Left', 'No transpose', 'Backward', - $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, - $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, - $ WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows 1:m-k+i+ib-1 of current block -* - CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, - $ TAU( I ), WORK, IINFO ) -* -* Set rows m-k+i+ib:m of current block to zero -* - DO 40 J = N - K + I, N - K + I + IB - 1 - DO 30 L = M - K + I + IB, M - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DORGQL -* - END - SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORGQR generates an M-by-N real matrix Q with orthonormal columns, -* which is defined as the first N columns of a product of K elementary -* reflectors of order M -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the i-th column must contain the vector which -* defines the elementary reflector H(i), for i = 1,2,...,k, as -* returned by DGEQRF in the first k columns of its array -* argument A. -* On exit, the M-by-N matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is the -* optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, - $ LWKOPT, NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, N )*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the last block. -* The first kk columns are handled by the block method. -* - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) -* -* Set A(1:kk,kk+1:n) to zero. -* - DO 20 J = KK + 1, N - DO 10 I = 1, KK - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the last or only block. -* - IF( KK.LT.N ) - $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, - $ TAU( KK+1 ), WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(i:m,i+ib:n) from the left -* - CALL DLARFB( 'Left', 'No transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows i:m of current block -* - CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* -* Set rows 1:i-1 of current block to zero -* - DO 40 J = I, I + IB - 1 - DO 30 L = 1, I - 1 - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DORGQR -* - END - SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, M, N - DOUBLE PRECISION ALPHA, BETA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASET initializes an m-by-n matrix A to BETA on the diagonal and -* ALPHA on the offdiagonals. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies the part of the matrix A to be set. -* = 'U': Upper triangular part is set; the strictly lower -* triangular part of A is not changed. -* = 'L': Lower triangular part is set; the strictly upper -* triangular part of A is not changed. -* Otherwise: All of the matrix A is set. -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* ALPHA (input) DOUBLE PRECISION -* The constant to which the offdiagonal elements are to be set. -* -* BETA (input) DOUBLE PRECISION -* The constant to which the diagonal elements are to be set. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On exit, the leading m-by-n submatrix of A is set as follows: -* -* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, -* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, -* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, -* -* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Set the strictly upper triangular or trapezoidal part of the -* array to ALPHA. -* - DO 20 J = 2, N - DO 10 I = 1, MIN( J-1, M ) - A( I, J ) = ALPHA - 10 CONTINUE - 20 CONTINUE -* - ELSE IF( LSAME( UPLO, 'L' ) ) THEN -* -* Set the strictly lower triangular or trapezoidal part of the -* array to ALPHA. -* - DO 40 J = 1, MIN( M, N ) - DO 30 I = J + 1, M - A( I, J ) = ALPHA - 30 CONTINUE - 40 CONTINUE -* - ELSE -* -* Set the leading m-by-n submatrix to ALPHA. -* - DO 60 J = 1, N - DO 50 I = 1, M - A( I, J ) = ALPHA - 50 CONTINUE - 60 CONTINUE - END IF -* -* Set the first min(M,N) diagonal elements to BETA. -* - DO 70 I = 1, MIN( M, N ) - A( I, I ) = BETA - 70 CONTINUE -* - RETURN -* -* End of DLASET -* - END - SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIRECT, PIVOT, SIDE - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) -* .. -* -* Purpose -* ======= -* -* DLASR performs the transformation -* -* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) -* -* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) -* -* where A is an m by n real matrix and P is an orthogonal matrix, -* consisting of a sequence of plane rotations determined by the -* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' -* and z = n when SIDE = 'R' or 'r' ): -* -* When DIRECT = 'F' or 'f' ( Forward sequence ) then -* -* P = P( z - 1 )*...*P( 2 )*P( 1 ), -* -* and when DIRECT = 'B' or 'b' ( Backward sequence ) then -* -* P = P( 1 )*P( 2 )*...*P( z - 1 ), -* -* where P( k ) is a plane rotation matrix for the following planes: -* -* when PIVOT = 'V' or 'v' ( Variable pivot ), -* the plane ( k, k + 1 ) -* -* when PIVOT = 'T' or 't' ( Top pivot ), -* the plane ( 1, k + 1 ) -* -* when PIVOT = 'B' or 'b' ( Bottom pivot ), -* the plane ( k, z ) -* -* c( k ) and s( k ) must contain the cosine and sine that define the -* matrix P( k ). The two by two plane rotation part of the matrix -* P( k ), R( k ), is assumed to be of the form -* -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) -* -* This version vectorises across rows of the array A when SIDE = 'L'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* Specifies whether the plane rotation matrix P is applied to -* A on the left or the right. -* = 'L': Left, compute A := P*A -* = 'R': Right, compute A:= A*P' -* -* DIRECT (input) CHARACTER*1 -* Specifies whether P is a forward or backward sequence of -* plane rotations. -* = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) -* = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) -* -* PIVOT (input) CHARACTER*1 -* Specifies the plane for which P(k) is a plane rotation -* matrix. -* = 'V': Variable pivot, the plane (k,k+1) -* = 'T': Top pivot, the plane (1,k+1) -* = 'B': Bottom pivot, the plane (k,z) -* -* M (input) INTEGER -* The number of rows of the matrix A. If m <= 1, an immediate -* return is effected. -* -* N (input) INTEGER -* The number of columns of the matrix A. If n <= 1, an -* immediate return is effected. -* -* C, S (input) DOUBLE PRECISION arrays, dimension -* (M-1) if SIDE = 'L' -* (N-1) if SIDE = 'R' -* c(k) and s(k) contain the cosine and sine that define the -* matrix P(k). The two by two plane rotation part of the -* matrix P(k), R(k), is assumed to be of the form -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. On exit, A is overwritten by P*A if -* SIDE = 'R' or by A*P' if SIDE = 'L'. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, J - DOUBLE PRECISION CTEMP, STEMP, TEMP -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN - INFO = 1 - ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, - $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN - INFO = 2 - ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) - $ THEN - INFO = 3 - ELSE IF( M.LT.0 ) THEN - INFO = 4 - ELSE IF( N.LT.0 ) THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = 9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASR ', INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) - $ RETURN - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form P * A -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 20 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 10 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 40 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 30 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 30 CONTINUE - END IF - 40 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 60 J = 2, M - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 50 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 80 J = M, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 70 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 70 CONTINUE - END IF - 80 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 100 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 90 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 90 CONTINUE - END IF - 100 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 120 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 110 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 110 CONTINUE - END IF - 120 CONTINUE - END IF - END IF - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form A * P' -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 140 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 130 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 130 CONTINUE - END IF - 140 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 160 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 150 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 150 CONTINUE - END IF - 160 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 180 J = 2, N - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 170 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 170 CONTINUE - END IF - 180 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 200 J = N, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 190 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 190 CONTINUE - END IF - 200 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 220 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 210 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 210 CONTINUE - END IF - 220 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 240 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 230 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 230 CONTINUE - END IF - 240 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DLASR -* - END - SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION ALPHA, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* Purpose -* ======= -* -* DLARFG generates a real elementary reflector H of order n, such -* that -* -* H * ( alpha ) = ( beta ), H' * H = I. -* ( x ) ( 0 ) -* -* where alpha and beta are scalars, and x is an (n-1)-element real -* vector. H is represented in the form -* -* H = I - tau * ( 1 ) * ( 1 v' ) , -* ( v ) -* -* where tau is a real scalar and v is a real (n-1)-element -* vector. -* -* If the elements of x are all zero, then tau = 0 and H is taken to be -* the unit matrix. -* -* Otherwise 1 <= tau <= 2. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the elementary reflector. -* -* ALPHA (input/output) DOUBLE PRECISION -* On entry, the value alpha. -* On exit, it is overwritten with the value beta. -* -* X (input/output) DOUBLE PRECISION array, dimension -* (1+(N-2)*abs(INCX)) -* On entry, the vector x. -* On exit, it is overwritten with the vector v. -* -* INCX (input) INTEGER -* The increment between elements of X. INCX > 0. -* -* TAU (output) DOUBLE PRECISION -* The value tau. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, KNT - DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 - EXTERNAL DLAMCH, DLAPY2, DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN -* .. -* .. External Subroutines .. - EXTERNAL DSCAL -* .. -* .. Executable Statements .. -* - IF( N.LE.1 ) THEN - TAU = ZERO - RETURN - END IF -* - XNORM = DNRM2( N-1, X, INCX ) -* - IF( XNORM.EQ.ZERO ) THEN -* -* H = I -* - TAU = ZERO - ELSE -* -* general case -* - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) - IF( ABS( BETA ).LT.SAFMIN ) THEN -* -* XNORM, BETA may be inaccurate; scale X and recompute them -* - RSAFMN = ONE / SAFMIN - KNT = 0 - 10 CONTINUE - KNT = KNT + 1 - CALL DSCAL( N-1, RSAFMN, X, INCX ) - BETA = BETA*RSAFMN - ALPHA = ALPHA*RSAFMN - IF( ABS( BETA ).LT.SAFMIN ) - $ GO TO 10 -* -* New BETA is at most 1, at least SAFMIN -* - XNORM = DNRM2( N-1, X, INCX ) - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - TAU = ( BETA-ALPHA ) / BETA - CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) -* -* If ALPHA is subnormal, it may lose relative accuracy -* - ALPHA = BETA - DO 20 J = 1, KNT - ALPHA = ALPHA*SAFMIN - 20 CONTINUE - ELSE - TAU = ( BETA-ALPHA ) / BETA - CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) - ALPHA = BETA - END IF - END IF -* - RETURN -* -* End of DLARFG -* - END - SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORG2L generates an m by n real matrix Q with orthonormal columns, -* which is defined as the last n columns of a product of k elementary -* reflectors of order m -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGEQLF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the (n-k+i)-th column must contain the vector which -* defines the elementary reflector H(i), for i = 1,2,...,k, as -* returned by DGEQLF in the last k columns of its array -* argument A. -* On exit, the m by n matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQLF. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, II, J, L -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORG2L', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns 1:n-k to columns of the unit matrix -* - DO 20 J = 1, N - K - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( M-N+J, J ) = ONE - 20 CONTINUE -* - DO 40 I = 1, K - II = N - K + I -* -* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left -* - A( M-N+II, II ) = ONE - CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, - $ LDA, WORK ) - CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) - A( M-N+II, II ) = ONE - TAU( I ) -* -* Set A(m-k+i+1:m,n-k+i) to zero -* - DO 30 L = M - N + II + 1, M - A( L, II ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of DORG2L -* - END - SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* Purpose -* ======= -* -* DLARFT forms the triangular factor T of a real block reflector H -* of order n, which is defined as a product of k elementary reflectors. -* -* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; -* -* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. -* -* If STOREV = 'C', the vector which defines the elementary reflector -* H(i) is stored in the i-th column of the array V, and -* -* H = I - V * T * V' -* -* If STOREV = 'R', the vector which defines the elementary reflector -* H(i) is stored in the i-th row of the array V, and -* -* H = I - V' * T * V -* -* Arguments -* ========= -* -* DIRECT (input) CHARACTER*1 -* Specifies the order in which the elementary reflectors are -* multiplied to form the block reflector: -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Specifies how the vectors which define the elementary -* reflectors are stored (see also Further Details): -* = 'C': columnwise -* = 'R': rowwise -* -* N (input) INTEGER -* The order of the block reflector H. N >= 0. -* -* K (input) INTEGER -* The order of the triangular factor T (= the number of -* elementary reflectors). K >= 1. -* -* V (input/output) DOUBLE PRECISION array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,N) if STOREV = 'R' -* The matrix V. See further details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i). -* -* T (output) DOUBLE PRECISION array, dimension (LDT,K) -* The k by k triangular factor T of the block reflector. -* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is -* lower triangular. The rest of the array is not used. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* Further Details -* =============== -* -* The shape of the matrix V and the storage of the vectors which define -* the H(i) is best illustrated by the following example with n = 5 and -* k = 3. The elements equal to 1 are not stored; the corresponding -* array elements are modified but restored on exit. The rest of the -* array is not used. -* -* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -* -* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -* ( v1 1 ) ( 1 v2 v2 v2 ) -* ( v1 v2 1 ) ( 1 v3 v3 ) -* ( v1 v2 v3 ) -* ( v1 v2 v3 ) -* -* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -* -* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -* ( v1 v2 v3 ) ( v2 v2 v2 1 ) -* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -* ( 1 v3 ) -* ( 1 ) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION VII -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DTRMV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 20 I = 1, K - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 10 J = 1, I - T( J, I ) = ZERO - 10 CONTINUE - ELSE -* -* general case -* - VII = V( I, I ) - V( I, I ) = ONE - IF( LSAME( STOREV, 'C' ) ) THEN -* -* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) -* - CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ), - $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, - $ T( 1, I ), 1 ) - ELSE -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' -* - CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ), - $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, - $ T( 1, I ), 1 ) - END IF - V( I, I ) = VII -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - END IF - 20 CONTINUE - ELSE - DO 40 I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 30 J = I, K - T( J, I ) = ZERO - 30 CONTINUE - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN - VII = V( N-K+I, I ) - V( N-K+I, I ) = ONE -* -* T(i+1:k,i) := -* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) -* - CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO, - $ T( I+1, I ), 1 ) - V( N-K+I, I ) = VII - ELSE - VII = V( I, N-K+I ) - V( I, N-K+I ) = ONE -* -* T(i+1:k,i) := -* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' -* - CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ), - $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, - $ T( I+1, I ), 1 ) - V( I, N-K+I ) = VII - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - END IF - T( I, I ) = TAU( I ) - END IF - 40 CONTINUE - END IF - RETURN -* -* End of DLARFT -* - END - SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, - $ T, LDT, C, LDC, WORK, LDWORK ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIRECT, SIDE, STOREV, TRANS - INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), - $ WORK( LDWORK, * ) -* .. -* -* Purpose -* ======= -* -* DLARFB applies a real block reflector H or its transpose H' to a -* real m by n matrix C, from either the left or the right. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply H or H' from the Left -* = 'R': apply H or H' from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply H (No transpose) -* = 'T': apply H' (Transpose) -* -* DIRECT (input) CHARACTER*1 -* Indicates how H is formed from a product of elementary -* reflectors -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Indicates how the vectors which define the elementary -* reflectors are stored: -* = 'C': Columnwise -* = 'R': Rowwise -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* K (input) INTEGER -* The order of the matrix T (= the number of elementary -* reflectors whose product defines the block reflector). -* -* V (input) DOUBLE PRECISION array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,M) if STOREV = 'R' and SIDE = 'L' -* (LDV,N) if STOREV = 'R' and SIDE = 'R' -* The matrix V. See further details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); -* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); -* if STOREV = 'R', LDV >= K. -* -* T (input) DOUBLE PRECISION array, dimension (LDT,K) -* The triangular k by k matrix T in the representation of the -* block reflector. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDA >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) -* -* LDWORK (input) INTEGER -* The leading dimension of the array WORK. -* If SIDE = 'L', LDWORK >= max(1,N); -* if SIDE = 'R', LDWORK >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - CHARACTER TRANST - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DTRMM -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( LSAME( TRANS, 'N' ) ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - IF( LSAME( STOREV, 'C' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 ) (first K rows) -* ( V2 ) -* where V1 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) -* -* W := C1' -* - DO 10 J = 1, K - CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 10 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2'*V2 -* - CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, - $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W' -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2 * W' -* - CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, - $ ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W' -* - DO 30 J = 1, K - DO 20 I = 1, N - C( J, I ) = C( J, I ) - WORK( I, J ) - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C1 -* - DO 40 J = 1, K - CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 40 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C2 * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V' -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2' -* - CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, - $ ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 60 J = 1, K - DO 50 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - ELSE -* -* Let V = ( V1 ) -* ( V2 ) (last K rows) -* where V2 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) -* -* W := C2' -* - DO 70 J = 1, K - CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) - 70 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, - $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1'*V1 -* - CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W' -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1 * W' -* - CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, - $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) - END IF -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, - $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W' -* - DO 90 J = 1, K - DO 80 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C2 -* - DO 100 J = 1, K - CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 100 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, - $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C1 * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V' -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1' -* - CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) - END IF -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, - $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W -* - DO 120 J = 1, K - DO 110 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 110 CONTINUE - 120 CONTINUE - END IF - END IF -* - ELSE IF( LSAME( STOREV, 'R' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 V2 ) (V1: first K columns) -* where V1 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) -* -* W := C1' -* - DO 130 J = 1, K - CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 130 CONTINUE -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, - $ ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2'*V2' -* - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, - $ WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V' * W' -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2' * W' -* - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, - $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W' -* - DO 150 J = 1, K - DO 140 I = 1, N - C( J, I ) = C( J, I ) - WORK( I, J ) - 140 CONTINUE - 150 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) -* -* W := C1 -* - DO 160 J = 1, K - CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 160 CONTINUE -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, - $ ONE, V, LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C2 * V2' -* - CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, - $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 180 J = 1, K - DO 170 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 170 CONTINUE - 180 CONTINUE -* - END IF -* - ELSE -* -* Let V = ( V1 V2 ) (V2: last K columns) -* where V2 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) -* -* W := C2' -* - DO 190 J = 1, K - CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) - 190 CONTINUE -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, - $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1'*V1' -* - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V' * W' -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1' * W' -* - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, - $ V, LDV, WORK, LDWORK, ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W' -* - DO 210 J = 1, K - DO 200 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) - 200 CONTINUE - 210 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) -* -* W := C2 -* - DO 220 J = 1, K - CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 220 CONTINUE -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, - $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C1 * V1' -* - CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, - $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 240 J = 1, K - DO 230 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 230 CONTINUE - 240 CONTINUE -* - END IF -* - END IF - END IF -* - RETURN -* -* End of DLARFB -* - END - SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORG2R generates an m by n real matrix Q with orthonormal columns, -* which is defined as the first n columns of a product of k elementary -* reflectors of order m -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the i-th column must contain the vector which -* defines the elementary reflector H(i), for i = 1,2,...,k, as -* returned by DGEQRF in the first k columns of its array -* argument A. -* On exit, the m-by-n matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORG2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns k+1:n to columns of the unit matrix -* - DO 20 J = K + 1, N - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( J, J ) = ONE - 20 CONTINUE -* - DO 40 I = K, 1, -1 -* -* Apply H(i) to A(i:m,i:n) from the left -* - IF( I.LT.N ) THEN - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - END IF - IF( I.LT.M ) - $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) - A( I, I ) = ONE - TAU( I ) -* -* Set A(1:i-1,i) to zero -* - DO 30 L = 1, I - 1 - A( L, I ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of DORG2R -* - END - SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER INCV, LDC, M, N - DOUBLE PRECISION TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLARF applies a real elementary reflector H to a real m by n matrix -* C, from either the left or the right. H is represented in the form -* -* H = I - tau * v * v' -* -* where tau is a real scalar and v is a real vector. -* -* If tau = 0, then H is taken to be the unit matrix. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': form H * C -* = 'R': form C * H -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* V (input) DOUBLE PRECISION array, dimension -* (1 + (M-1)*abs(INCV)) if SIDE = 'L' -* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' -* The vector v in the representation of H. V is not used if -* TAU = 0. -* -* INCV (input) INTEGER -* The increment between elements of v. INCV <> 0. -* -* TAU (input) DOUBLE PRECISION -* The value tau in the representation of H. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by the matrix H * C if SIDE = 'L', -* or C * H if SIDE = 'R'. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L' -* or (M) if SIDE = 'R' -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DGER -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C -* - IF( TAU.NE.ZERO ) THEN -* -* w := C' * v -* - CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO, - $ WORK, 1 ) -* -* C := C - v * w' -* - CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) - END IF - ELSE -* -* Form C * H -* - IF( TAU.NE.ZERO ) THEN -* -* w := C * v -* - CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, - $ ZERO, WORK, 1 ) -* -* C := C - w * v' -* - CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) - END IF - END IF - RETURN -* -* End of DLARF -* - END - SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZGESV computes the solution to a complex system of linear equations -* A * X = B, -* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. -* -* The LU decomposition with partial pivoting and row interchanges is -* used to factor A as -* A = P * L * U, -* where P is a permutation matrix, L is unit lower triangular, and U is -* upper triangular. The factored form of A is then used to solve the -* system of equations A * X = B. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of linear equations, i.e., the order of the -* matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the N-by-N coefficient matrix A. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (output) INTEGER array, dimension (N) -* The pivot indices that define the permutation matrix P; -* row i of the matrix was interchanged with row IPIV(i). -* -* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) -* On entry, the N-by-NRHS matrix of right hand side matrix B. -* On exit, if INFO = 0, the N-by-NRHS solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, so the solution could not be computed. -* -* ===================================================================== -* -* .. External Subroutines .. - EXTERNAL XERBLA, ZGETRF, ZGETRS -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGESV ', -INFO ) - RETURN - END IF -* -* Compute the LU factorization of A. -* - CALL ZGETRF( N, N, A, LDA, IPIV, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL ZGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, - $ INFO ) - END IF - RETURN -* -* End of ZGESV -* - END - SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, - $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER JOBVL, JOBVR - INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION RWORK( * ) - COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), - $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ), - $ WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZGGEV computes for a pair of N-by-N complex nonsymmetric matrices -* (A,B), the generalized eigenvalues, and optionally, the left and/or -* right generalized eigenvectors. -* -* A generalized eigenvalue for a pair of matrices (A,B) is a scalar -* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is -* singular. It is usually represented as the pair (alpha,beta), as -* there is a reasonable interpretation for beta=0, and even for both -* being zero. -* -* The right generalized eigenvector v(j) corresponding to the -* generalized eigenvalue lambda(j) of (A,B) satisfies -* -* A * v(j) = lambda(j) * B * v(j). -* -* The left generalized eigenvector u(j) corresponding to the -* generalized eigenvalues lambda(j) of (A,B) satisfies -* -* u(j)**H * A = lambda(j) * u(j)**H * B -* -* where u(j)**H is the conjugate-transpose of u(j). -* -* Arguments -* ========= -* -* JOBVL (input) CHARACTER*1 -* = 'N': do not compute the left generalized eigenvectors; -* = 'V': compute the left generalized eigenvectors. -* -* JOBVR (input) CHARACTER*1 -* = 'N': do not compute the right generalized eigenvectors; -* = 'V': compute the right generalized eigenvectors. -* -* N (input) INTEGER -* The order of the matrices A, B, VL, and VR. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA, N) -* On entry, the matrix A in the pair (A,B). -* On exit, A has been overwritten. -* -* LDA (input) INTEGER -* The leading dimension of A. LDA >= max(1,N). -* -* B (input/output) COMPLEX*16 array, dimension (LDB, N) -* On entry, the matrix B in the pair (A,B). -* On exit, B has been overwritten. -* -* LDB (input) INTEGER -* The leading dimension of B. LDB >= max(1,N). -* -* ALPHA (output) COMPLEX*16 array, dimension (N) -* BETA (output) COMPLEX*16 array, dimension (N) -* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the -* generalized eigenvalues. -* -* Note: the quotients ALPHA(j)/BETA(j) may easily over- or -* underflow, and BETA(j) may even be zero. Thus, the user -* should avoid naively computing the ratio alpha/beta. -* However, ALPHA will be always less than and usually -* comparable with norm(A) in magnitude, and BETA always less -* than and usually comparable with norm(B). -* -* VL (output) COMPLEX*16 array, dimension (LDVL,N) -* If JOBVL = 'V', the left generalized eigenvectors u(j) are -* stored one after another in the columns of VL, in the same -* order as their eigenvalues. -* Each eigenvector will be scaled so the largest component -* will have abs(real part) + abs(imag. part) = 1. -* Not referenced if JOBVL = 'N'. -* -* LDVL (input) INTEGER -* The leading dimension of the matrix VL. LDVL >= 1, and -* if JOBVL = 'V', LDVL >= N. -* -* VR (output) COMPLEX*16 array, dimension (LDVR,N) -* If JOBVR = 'V', the right generalized eigenvectors v(j) are -* stored one after another in the columns of VR, in the same -* order as their eigenvalues. -* Each eigenvector will be scaled so the largest component -* will have abs(real part) + abs(imag. part) = 1. -* Not referenced if JOBVR = 'N'. -* -* LDVR (input) INTEGER -* The leading dimension of the matrix VR. LDVR >= 1, and -* if JOBVR = 'V', LDVR >= N. -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,2*N). -* For good performance, LWORK must generally be larger. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* RWORK (workspace/output) DOUBLE PRECISION array, dimension (8*N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* =1,...,N: -* The QZ iteration failed. No eigenvectors have been -* calculated, but ALPHA(j) and BETA(j) should be -* correct for j=INFO+1,...,N. -* > N: =N+1: other then QZ iteration failed in DHGEQZ, -* =N+2: error return from DTGEVC. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - COMPLEX*16 CZERO, CONE - PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), - $ CONE = ( 1.0D0, 0.0D0 ) ) -* .. -* .. Local Scalars .. - LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY - CHARACTER CHTEMP - INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO, - $ IN, IRIGHT, IROWS, IRWRK, ITAU, IWRK, JC, JR, - $ LWKMIN, LWKOPT - DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, - $ SMLNUM, TEMP - COMPLEX*16 X -* .. -* .. Local Arrays .. - LOGICAL LDUMMA( 1 ) -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD, ZHGEQZ, - $ ZLACPY, ZLASCL, ZLASET, ZTGEVC, ZUNGQR, ZUNMQR -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DIMAG, MAX, SQRT -* .. -* .. Statement Functions .. - DOUBLE PRECISION ABS1 -* .. -* .. Statement Function definitions .. - ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) ) -* .. -* .. Executable Statements .. -* -* Decode the input arguments -* - IF( LSAME( JOBVL, 'N' ) ) THEN - IJOBVL = 1 - ILVL = .FALSE. - ELSE IF( LSAME( JOBVL, 'V' ) ) THEN - IJOBVL = 2 - ILVL = .TRUE. - ELSE - IJOBVL = -1 - ILVL = .FALSE. - END IF -* - IF( LSAME( JOBVR, 'N' ) ) THEN - IJOBVR = 1 - ILVR = .FALSE. - ELSE IF( LSAME( JOBVR, 'V' ) ) THEN - IJOBVR = 2 - ILVR = .TRUE. - ELSE - IJOBVR = -1 - ILVR = .FALSE. - END IF - ILV = ILVL .OR. ILVR -* -* Test the input arguments -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - IF( IJOBVL.LE.0 ) THEN - INFO = -1 - ELSE IF( IJOBVR.LE.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN - INFO = -11 - ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN - INFO = -13 - END IF -* -* Compute workspace -* (Note: Comments in the code beginning "Workspace:" describe the -* minimal amount of workspace needed at that point in the code, -* as well as the preferred amount for good performance. -* NB refers to the optimal block size for the immediately -* following subroutine, as returned by ILAENV. The workspace is -* computed assuming ILO = 1 and IHI = N, the worst case.) -* - LWKMIN = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN - LWKOPT = N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N, 0 ) - LWKMIN = MAX( 1, 2*N ) - WORK( 1 ) = LWKOPT - END IF -* - IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) - $ INFO = -15 -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGGEV ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - WORK( 1 ) = LWKOPT - IF( N.EQ.0 ) - $ RETURN -* -* Get machine constants -* - EPS = DLAMCH( 'E' )*DLAMCH( 'B' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SQRT( SMLNUM ) / EPS - BIGNUM = ONE / SMLNUM -* -* Scale A if max element outside range [SMLNUM,BIGNUM] -* - ANRM = ZLANGE( 'M', N, N, A, LDA, RWORK ) - ILASCL = .FALSE. - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN - ANRMTO = SMLNUM - ILASCL = .TRUE. - ELSE IF( ANRM.GT.BIGNUM ) THEN - ANRMTO = BIGNUM - ILASCL = .TRUE. - END IF - IF( ILASCL ) - $ CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) -* -* Scale B if max element outside range [SMLNUM,BIGNUM] -* - BNRM = ZLANGE( 'M', N, N, B, LDB, RWORK ) - ILBSCL = .FALSE. - IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN - BNRMTO = SMLNUM - ILBSCL = .TRUE. - ELSE IF( BNRM.GT.BIGNUM ) THEN - BNRMTO = BIGNUM - ILBSCL = .TRUE. - END IF - IF( ILBSCL ) - $ CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) -* -* Permute the matrices A, B to isolate eigenvalues if possible -* (Real Workspace: need 6*N) -* - ILEFT = 1 - IRIGHT = N + 1 - IRWRK = IRIGHT + N - CALL ZGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ), - $ RWORK( IRIGHT ), RWORK( IRWRK ), IERR ) -* -* Reduce B to triangular form (QR decomposition of B) -* (Complex Workspace: need N, prefer N*NB) -* - IROWS = IHI + 1 - ILO - IF( ILV ) THEN - ICOLS = N + 1 - ILO - ELSE - ICOLS = IROWS - END IF - ITAU = 1 - IWRK = ITAU + IROWS - CALL ZGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), - $ WORK( IWRK ), LWORK+1-IWRK, IERR ) -* -* Apply the orthogonal transformation to matrix A -* (Complex Workspace: need N, prefer N*NB) -* - CALL ZUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, - $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), - $ LWORK+1-IWRK, IERR ) -* -* Initialize VL -* (Complex Workspace: need N, prefer N*NB) -* - IF( ILVL ) THEN - CALL ZLASET( 'Full', N, N, CZERO, CONE, VL, LDVL ) - CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, - $ VL( ILO+1, ILO ), LDVL ) - CALL ZUNGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL, - $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) - END IF -* -* Initialize VR -* - IF( ILVR ) - $ CALL ZLASET( 'Full', N, N, CZERO, CONE, VR, LDVR ) -* -* Reduce to generalized Hessenberg form -* - IF( ILV ) THEN -* -* Eigenvectors requested -- work on whole matrix. -* - CALL ZGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL, - $ LDVL, VR, LDVR, IERR ) - ELSE - CALL ZGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA, - $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR ) - END IF -* -* Perform QZ algorithm (Compute eigenvalues, and optionally, the -* Schur form and Schur vectors) -* (Complex Workspace: need N) -* (Real Workspace: need N) -* - IWRK = ITAU - IF( ILV ) THEN - CHTEMP = 'S' - ELSE - CHTEMP = 'E' - END IF - CALL ZHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, - $ ALPHA, BETA, VL, LDVL, VR, LDVR, WORK( IWRK ), - $ LWORK+1-IWRK, RWORK( IRWRK ), IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.GT.0 .AND. IERR.LE.N ) THEN - INFO = IERR - ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN - INFO = IERR - N - ELSE - INFO = N + 1 - END IF - GO TO 70 - END IF -* -* Compute Eigenvectors -* (Real Workspace: need 2*N) -* (Complex Workspace: need 2*N) -* - IF( ILV ) THEN - IF( ILVL ) THEN - IF( ILVR ) THEN - CHTEMP = 'B' - ELSE - CHTEMP = 'L' - END IF - ELSE - CHTEMP = 'R' - END IF -* - CALL ZTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL, - $ VR, LDVR, N, IN, WORK( IWRK ), RWORK( IRWRK ), - $ IERR ) - IF( IERR.NE.0 ) THEN - INFO = N + 2 - GO TO 70 - END IF -* -* Undo balancing on VL and VR and normalization -* (Workspace: none needed) -* - IF( ILVL ) THEN - CALL ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ), - $ RWORK( IRIGHT ), N, VL, LDVL, IERR ) - DO 30 JC = 1, N - TEMP = ZERO - DO 10 JR = 1, N - TEMP = MAX( TEMP, ABS1( VL( JR, JC ) ) ) - 10 CONTINUE - IF( TEMP.LT.SMLNUM ) - $ GO TO 30 - TEMP = ONE / TEMP - DO 20 JR = 1, N - VL( JR, JC ) = VL( JR, JC )*TEMP - 20 CONTINUE - 30 CONTINUE - END IF - IF( ILVR ) THEN - CALL ZGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ), - $ RWORK( IRIGHT ), N, VR, LDVR, IERR ) - DO 60 JC = 1, N - TEMP = ZERO - DO 40 JR = 1, N - TEMP = MAX( TEMP, ABS1( VR( JR, JC ) ) ) - 40 CONTINUE - IF( TEMP.LT.SMLNUM ) - $ GO TO 60 - TEMP = ONE / TEMP - DO 50 JR = 1, N - VR( JR, JC ) = VR( JR, JC )*TEMP - 50 CONTINUE - 60 CONTINUE - END IF - END IF -* -* Undo scaling if necessary -* - IF( ILASCL ) - $ CALL ZLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR ) -* - IF( ILBSCL ) - $ CALL ZLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) -* - 70 CONTINUE - WORK( 1 ) = LWKOPT -* - RETURN -* -* End of ZGGEV -* - END - SUBROUTINE DLABAD( SMALL, LARGE ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - DOUBLE PRECISION LARGE, SMALL -* .. -* -* Purpose -* ======= -* -* DLABAD takes as input the values computed by DLAMCH for underflow and -* overflow, and returns the square root of each of these values if the -* log of LARGE is sufficiently large. This subroutine is intended to -* identify machines with a large exponent range, such as the Crays, and -* redefine the underflow and overflow limits to be the square roots of -* the values computed by DLAMCH. This subroutine is needed because -* DLAMCH does not compensate for poor arithmetic in the upper half of -* the exponent range, as is found on a Cray. -* -* Arguments -* ========= -* -* SMALL (input/output) DOUBLE PRECISION -* On entry, the underflow threshold as computed by DLAMCH. -* On exit, if LOG10(LARGE) is sufficiently large, the square -* root of SMALL, otherwise unchanged. -* -* LARGE (input/output) DOUBLE PRECISION -* On entry, the overflow threshold as computed by DLAMCH. -* On exit, if LOG10(LARGE) is sufficiently large, the square -* root of LARGE, otherwise unchanged. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC LOG10, SQRT -* .. -* .. Executable Statements .. -* -* If it looks like we're on a Cray, take the square root of -* SMALL and LARGE to avoid overflow and underflow problems. -* - IF( LOG10( LARGE ).GT.2000.D0 ) THEN - SMALL = SQRT( SMALL ) - LARGE = SQRT( LARGE ) - END IF -* - RETURN -* -* End of DLABAD -* - END - DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION WORK( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZLANGE returns the value of the one norm, or the Frobenius norm, or -* the infinity norm, or the element of largest absolute value of a -* complex matrix A. -* -* Description -* =========== -* -* ZLANGE returns the value -* -* ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' -* ( -* ( norm1(A), NORM = '1', 'O' or 'o' -* ( -* ( normI(A), NORM = 'I' or 'i' -* ( -* ( normF(A), NORM = 'F', 'f', 'E' or 'e' -* -* where norm1 denotes the one norm of a matrix (maximum column sum), -* normI denotes the infinity norm of a matrix (maximum row sum) and -* normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies the value to be returned in ZLANGE as described -* above. -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. When M = 0, -* ZLANGE is set to zero. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. When N = 0, -* ZLANGE is set to zero. -* -* A (input) COMPLEX*16 array, dimension (LDA,N) -* The m by n matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(M,1). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), -* where LWORK >= M when NORM = 'I'; otherwise, WORK is not -* referenced. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION SCALE, SUM, VALUE -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL ZLASSQ -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - IF( MIN( M, N ).EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - DO 20 J = 1, N - DO 10 I = 1, M - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 10 CONTINUE - 20 CONTINUE - ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN -* -* Find norm1(A). -* - VALUE = ZERO - DO 40 J = 1, N - SUM = ZERO - DO 30 I = 1, M - SUM = SUM + ABS( A( I, J ) ) - 30 CONTINUE - VALUE = MAX( VALUE, SUM ) - 40 CONTINUE - ELSE IF( LSAME( NORM, 'I' ) ) THEN -* -* Find normI(A). -* - DO 50 I = 1, M - WORK( I ) = ZERO - 50 CONTINUE - DO 70 J = 1, N - DO 60 I = 1, M - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 60 CONTINUE - 70 CONTINUE - VALUE = ZERO - DO 80 I = 1, M - VALUE = MAX( VALUE, WORK( I ) ) - 80 CONTINUE - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - DO 90 J = 1, N - CALL ZLASSQ( M, A( 1, J ), 1, SCALE, SUM ) - 90 CONTINUE - VALUE = SCALE*SQRT( SUM ) - END IF -* - ZLANGE = VALUE - RETURN -* -* End of ZLANGE -* - END - SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, - $ RSCALE, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER JOB - INTEGER IHI, ILO, INFO, LDA, LDB, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION LSCALE( * ), RSCALE( * ), WORK( * ) - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZGGBAL balances a pair of general complex matrices (A,B). This -* involves, first, permuting A and B by similarity transformations to -* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N -* elements on the diagonal; and second, applying a diagonal similarity -* transformation to rows and columns ILO to IHI to make the rows -* and columns as close in norm as possible. Both steps are optional. -* -* Balancing may reduce the 1-norm of the matrices, and improve the -* accuracy of the computed eigenvalues and/or eigenvectors in the -* generalized eigenvalue problem A*x = lambda*B*x. -* -* Arguments -* ========= -* -* JOB (input) CHARACTER*1 -* Specifies the operations to be performed on A and B: -* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 -* and RSCALE(I) = 1.0 for i=1,...,N; -* = 'P': permute only; -* = 'S': scale only; -* = 'B': both permute and scale. -* -* N (input) INTEGER -* The order of the matrices A and B. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the input matrix A. -* On exit, A is overwritten by the balanced matrix. -* If JOB = 'N', A is not referenced. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* B (input/output) COMPLEX*16 array, dimension (LDB,N) -* On entry, the input matrix B. -* On exit, B is overwritten by the balanced matrix. -* If JOB = 'N', B is not referenced. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* ILO (output) INTEGER -* IHI (output) INTEGER -* ILO and IHI are set to integers such that on exit -* A(i,j) = 0 and B(i,j) = 0 if i > j and -* j = 1,...,ILO-1 or i = IHI+1,...,N. -* If JOB = 'N' or 'S', ILO = 1 and IHI = N. -* -* LSCALE (output) DOUBLE PRECISION array, dimension (N) -* Details of the permutations and scaling factors applied -* to the left side of A and B. If P(j) is the index of the -* row interchanged with row j, and D(j) is the scaling factor -* applied to row j, then -* LSCALE(j) = P(j) for J = 1,...,ILO-1 -* = D(j) for J = ILO,...,IHI -* = P(j) for J = IHI+1,...,N. -* The order in which the interchanges are made is N to IHI+1, -* then 1 to ILO-1. -* -* RSCALE (output) DOUBLE PRECISION array, dimension (N) -* Details of the permutations and scaling factors applied -* to the right side of A and B. If P(j) is the index of the -* column interchanged with column j, and D(j) is the scaling -* factor applied to column j, then -* RSCALE(j) = P(j) for J = 1,...,ILO-1 -* = D(j) for J = ILO,...,IHI -* = P(j) for J = IHI+1,...,N. -* The order in which the interchanges are made is N to IHI+1, -* then 1 to ILO-1. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (6*N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* See R.C. WARD, Balancing the generalized eigenvalue problem, -* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION THREE, SCLFAC - PARAMETER ( THREE = 3.0D+0, SCLFAC = 1.0D+1 ) - COMPLEX*16 CZERO - PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1, - $ K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN, - $ M, NR, NRP2 - DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, - $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, - $ SFMIN, SUM, T, TA, TB, TC - COMPLEX*16 CDUM -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IZAMAX - DOUBLE PRECISION DDOT, DLAMCH - EXTERNAL LSAME, IZAMAX, DDOT, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DSCAL, XERBLA, ZDSCAL, ZSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DIMAG, INT, LOG10, MAX, MIN, SIGN -* .. -* .. Statement Functions .. - DOUBLE PRECISION CABS1 -* .. -* .. Statement Function definitions .. - CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. - $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGGBAL', -INFO ) - RETURN - END IF -* - K = 1 - L = N -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( JOB, 'N' ) ) THEN - ILO = 1 - IHI = N - DO 10 I = 1, N - LSCALE( I ) = ONE - RSCALE( I ) = ONE - 10 CONTINUE - RETURN - END IF -* - IF( K.EQ.L ) THEN - ILO = 1 - IHI = 1 - LSCALE( 1 ) = ONE - RSCALE( 1 ) = ONE - RETURN - END IF -* - IF( LSAME( JOB, 'S' ) ) - $ GO TO 190 -* - GO TO 30 -* -* Permute the matrices A and B to isolate the eigenvalues. -* -* Find row with one nonzero in columns 1 through L -* - 20 CONTINUE - L = LM1 - IF( L.NE.1 ) - $ GO TO 30 -* - RSCALE( 1 ) = 1 - LSCALE( 1 ) = 1 - GO TO 190 -* - 30 CONTINUE - LM1 = L - 1 - DO 80 I = L, 1, -1 - DO 40 J = 1, LM1 - JP1 = J + 1 - IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) - $ GO TO 50 - 40 CONTINUE - J = L - GO TO 70 -* - 50 CONTINUE - DO 60 J = JP1, L - IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) - $ GO TO 80 - 60 CONTINUE - J = JP1 - 1 -* - 70 CONTINUE - M = L - IFLOW = 1 - GO TO 160 - 80 CONTINUE - GO TO 100 -* -* Find column with one nonzero in rows K through N -* - 90 CONTINUE - K = K + 1 -* - 100 CONTINUE - DO 150 J = K, L - DO 110 I = K, LM1 - IP1 = I + 1 - IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) - $ GO TO 120 - 110 CONTINUE - I = L - GO TO 140 - 120 CONTINUE - DO 130 I = IP1, L - IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) - $ GO TO 150 - 130 CONTINUE - I = IP1 - 1 - 140 CONTINUE - M = K - IFLOW = 2 - GO TO 160 - 150 CONTINUE - GO TO 190 -* -* Permute rows M and I -* - 160 CONTINUE - LSCALE( M ) = I - IF( I.EQ.M ) - $ GO TO 170 - CALL ZSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA ) - CALL ZSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB ) -* -* Permute columns M and J -* - 170 CONTINUE - RSCALE( M ) = J - IF( J.EQ.M ) - $ GO TO 180 - CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) - CALL ZSWAP( L, B( 1, J ), 1, B( 1, M ), 1 ) -* - 180 CONTINUE - GO TO ( 20, 90 )IFLOW -* - 190 CONTINUE - ILO = K - IHI = L -* - IF( ILO.EQ.IHI ) - $ RETURN -* - IF( LSAME( JOB, 'P' ) ) - $ RETURN -* -* Balance the submatrix in rows ILO to IHI. -* - NR = IHI - ILO + 1 - DO 200 I = ILO, IHI - RSCALE( I ) = ZERO - LSCALE( I ) = ZERO -* - WORK( I ) = ZERO - WORK( I+N ) = ZERO - WORK( I+2*N ) = ZERO - WORK( I+3*N ) = ZERO - WORK( I+4*N ) = ZERO - WORK( I+5*N ) = ZERO - 200 CONTINUE -* -* Compute right side vector in resulting linear equations -* - BASL = LOG10( SCLFAC ) - DO 240 I = ILO, IHI - DO 230 J = ILO, IHI - IF( A( I, J ).EQ.CZERO ) THEN - TA = ZERO - GO TO 210 - END IF - TA = LOG10( CABS1( A( I, J ) ) ) / BASL -* - 210 CONTINUE - IF( B( I, J ).EQ.CZERO ) THEN - TB = ZERO - GO TO 220 - END IF - TB = LOG10( CABS1( B( I, J ) ) ) / BASL -* - 220 CONTINUE - WORK( I+4*N ) = WORK( I+4*N ) - TA - TB - WORK( J+5*N ) = WORK( J+5*N ) - TA - TB - 230 CONTINUE - 240 CONTINUE -* - COEF = ONE / DBLE( 2*NR ) - COEF2 = COEF*COEF - COEF5 = HALF*COEF2 - NRP2 = NR + 2 - BETA = ZERO - IT = 1 -* -* Start generalized conjugate gradient iteration -* - 250 CONTINUE -* - GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) + - $ DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 ) -* - EW = ZERO - EWC = ZERO - DO 260 I = ILO, IHI - EW = EW + WORK( I+4*N ) - EWC = EWC + WORK( I+5*N ) - 260 CONTINUE -* - GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2 - IF( GAMMA.EQ.ZERO ) - $ GO TO 350 - IF( IT.NE.1 ) - $ BETA = GAMMA / PGAMMA - T = COEF5*( EWC-THREE*EW ) - TC = COEF5*( EW-THREE*EWC ) -* - CALL DSCAL( NR, BETA, WORK( ILO ), 1 ) - CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 ) -* - CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 ) - CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 ) -* - DO 270 I = ILO, IHI - WORK( I ) = WORK( I ) + TC - WORK( I+N ) = WORK( I+N ) + T - 270 CONTINUE -* -* Apply matrix to vector -* - DO 300 I = ILO, IHI - KOUNT = 0 - SUM = ZERO - DO 290 J = ILO, IHI - IF( A( I, J ).EQ.CZERO ) - $ GO TO 280 - KOUNT = KOUNT + 1 - SUM = SUM + WORK( J ) - 280 CONTINUE - IF( B( I, J ).EQ.CZERO ) - $ GO TO 290 - KOUNT = KOUNT + 1 - SUM = SUM + WORK( J ) - 290 CONTINUE - WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM - 300 CONTINUE -* - DO 330 J = ILO, IHI - KOUNT = 0 - SUM = ZERO - DO 320 I = ILO, IHI - IF( A( I, J ).EQ.CZERO ) - $ GO TO 310 - KOUNT = KOUNT + 1 - SUM = SUM + WORK( I+N ) - 310 CONTINUE - IF( B( I, J ).EQ.CZERO ) - $ GO TO 320 - KOUNT = KOUNT + 1 - SUM = SUM + WORK( I+N ) - 320 CONTINUE - WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM - 330 CONTINUE -* - SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) + - $ DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 ) - ALPHA = GAMMA / SUM -* -* Determine correction to current iteration -* - CMAX = ZERO - DO 340 I = ILO, IHI - COR = ALPHA*WORK( I+N ) - IF( ABS( COR ).GT.CMAX ) - $ CMAX = ABS( COR ) - LSCALE( I ) = LSCALE( I ) + COR - COR = ALPHA*WORK( I ) - IF( ABS( COR ).GT.CMAX ) - $ CMAX = ABS( COR ) - RSCALE( I ) = RSCALE( I ) + COR - 340 CONTINUE - IF( CMAX.LT.HALF ) - $ GO TO 350 -* - CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 ) - CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 ) -* - PGAMMA = GAMMA - IT = IT + 1 - IF( IT.LE.NRP2 ) - $ GO TO 250 -* -* End generalized conjugate gradient iteration -* - 350 CONTINUE - SFMIN = DLAMCH( 'S' ) - SFMAX = ONE / SFMIN - LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE ) - LSFMAX = INT( LOG10( SFMAX ) / BASL ) - DO 360 I = ILO, IHI - IRAB = IZAMAX( N-ILO+1, A( I, ILO ), LDA ) - RAB = ABS( A( I, IRAB+ILO-1 ) ) - IRAB = IZAMAX( N-ILO+1, B( I, ILO ), LDA ) - RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) - LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) - IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) - IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) - LSCALE( I ) = SCLFAC**IR - ICAB = IZAMAX( IHI, A( 1, I ), 1 ) - CAB = ABS( A( ICAB, I ) ) - ICAB = IZAMAX( IHI, B( 1, I ), 1 ) - CAB = MAX( CAB, ABS( B( ICAB, I ) ) ) - LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE ) - JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) ) - JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) - RSCALE( I ) = SCLFAC**JC - 360 CONTINUE -* -* Row scaling of matrices A and B -* - DO 370 I = ILO, IHI - CALL ZDSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA ) - CALL ZDSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB ) - 370 CONTINUE -* -* Column scaling of matrices A and B -* - DO 380 J = ILO, IHI - CALL ZDSCAL( IHI, RSCALE( J ), A( 1, J ), 1 ) - CALL ZDSCAL( IHI, RSCALE( J ), B( 1, J ), 1 ) - 380 CONTINUE -* - RETURN -* -* End of ZGGBAL -* - END - SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZGEQRF computes a QR factorization of a complex M-by-N matrix A: -* A = Q * R. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the M-by-N matrix A. -* On exit, the elements on and above the diagonal of the array -* contain the min(M,N)-by-N upper trapezoidal matrix R (R is -* upper triangular if m >= n); the elements below the diagonal, -* with the array TAU, represent the unitary matrix Q as a -* product of min(m,n) elementary reflectors (see Further -* Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) COMPLEX*16 array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is -* the optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(1) H(2) . . . H(k), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a complex scalar, and v is a complex vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGEQR2, ZLARFB, ZLARFT -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGEQRF', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'ZGEQRF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZGEQRF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the QR factorization of the current block -* A(i:m,i:i+ib-1) -* - CALL ZGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H' to A(i:m,i+ib:n) from the left -* - CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL ZGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of ZGEQRF -* - END - SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, - $ LDQ, Z, LDZ, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ - INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), - $ Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper -* Hessenberg form using unitary transformations, where A is a -* general matrix and B is upper triangular: Q' * A * Z = H and -* Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular, -* and Q and Z are unitary, and ' means conjugate transpose. -* -* The unitary matrices Q and Z are determined as products of Givens -* rotations. They may either be formed explicitly, or they may be -* postmultiplied into input matrices Q1 and Z1, so that -* -* Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' -* Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)' -* -* Arguments -* ========= -* -* COMPQ (input) CHARACTER*1 -* = 'N': do not compute Q; -* = 'I': Q is initialized to the unit matrix, and the -* unitary matrix Q is returned; -* = 'V': Q must contain a unitary matrix Q1 on entry, -* and the product Q1*Q is returned. -* -* COMPZ (input) CHARACTER*1 -* = 'N': do not compute Q; -* = 'I': Q is initialized to the unit matrix, and the -* unitary matrix Q is returned; -* = 'V': Q must contain a unitary matrix Q1 on entry, -* and the product Q1*Q is returned. -* -* N (input) INTEGER -* The order of the matrices A and B. N >= 0. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* It is assumed that A is already upper triangular in rows and -* columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally set -* by a previous call to ZGGBAL; otherwise they should be set -* to 1 and N respectively. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA, N) -* On entry, the N-by-N general matrix to be reduced. -* On exit, the upper triangle and the first subdiagonal of A -* are overwritten with the upper Hessenberg matrix H, and the -* rest is set to zero. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* B (input/output) COMPLEX*16 array, dimension (LDB, N) -* On entry, the N-by-N upper triangular matrix B. -* On exit, the upper triangular matrix T = Q' B Z. The -* elements below the diagonal are set to zero. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* Q (input/output) COMPLEX*16 array, dimension (LDQ, N) -* If COMPQ='N': Q is not referenced. -* If COMPQ='I': on entry, Q need not be set, and on exit it -* contains the unitary matrix Q, where Q' -* is the product of the Givens transformations -* which are applied to A and B on the left. -* If COMPQ='V': on entry, Q must contain a unitary matrix -* Q1, and on exit this is overwritten by Q1*Q. -* -* LDQ (input) INTEGER -* The leading dimension of the array Q. -* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. -* -* Z (input/output) COMPLEX*16 array, dimension (LDZ, N) -* If COMPZ='N': Z is not referenced. -* If COMPZ='I': on entry, Z need not be set, and on exit it -* contains the unitary matrix Z, which is -* the product of the Givens transformations -* which are applied to A and B on the right. -* If COMPZ='V': on entry, Z must contain a unitary matrix -* Z1, and on exit this is overwritten by Z1*Z. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. -* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* This routine reduces A to Hessenberg and B to triangular form by -* an unblocked reduction, as described in _Matrix_Computations_, -* by Golub and van Loan (Johns Hopkins Press). -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 CONE, CZERO - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), - $ CZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL ILQ, ILZ - INTEGER ICOMPQ, ICOMPZ, JCOL, JROW - DOUBLE PRECISION C - COMPLEX*16 CTEMP, S -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARTG, ZLASET, ZROT -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Decode COMPQ -* - IF( LSAME( COMPQ, 'N' ) ) THEN - ILQ = .FALSE. - ICOMPQ = 1 - ELSE IF( LSAME( COMPQ, 'V' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 2 - ELSE IF( LSAME( COMPQ, 'I' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 3 - ELSE - ICOMPQ = 0 - END IF -* -* Decode COMPZ -* - IF( LSAME( COMPZ, 'N' ) ) THEN - ILZ = .FALSE. - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 2 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 3 - ELSE - ICOMPZ = 0 - END IF -* -* Test the input parameters. -* - INFO = 0 - IF( ICOMPQ.LE.0 ) THEN - INFO = -1 - ELSE IF( ICOMPZ.LE.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( ILO.LT.1 ) THEN - INFO = -4 - ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN - INFO = -11 - ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN - INFO = -13 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGGHRD', -INFO ) - RETURN - END IF -* -* Initialize Q and Z if desired. -* - IF( ICOMPQ.EQ.3 ) - $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ ) - IF( ICOMPZ.EQ.3 ) - $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) -* -* Quick return if possible -* - IF( N.LE.1 ) - $ RETURN -* -* Zero out lower triangle of B -* - DO 20 JCOL = 1, N - 1 - DO 10 JROW = JCOL + 1, N - B( JROW, JCOL ) = CZERO - 10 CONTINUE - 20 CONTINUE -* -* Reduce A and B -* - DO 40 JCOL = ILO, IHI - 2 -* - DO 30 JROW = IHI, JCOL + 2, -1 -* -* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) -* - CTEMP = A( JROW-1, JCOL ) - CALL ZLARTG( CTEMP, A( JROW, JCOL ), C, S, - $ A( JROW-1, JCOL ) ) - A( JROW, JCOL ) = CZERO - CALL ZROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA, - $ A( JROW, JCOL+1 ), LDA, C, S ) - CALL ZROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB, - $ B( JROW, JROW-1 ), LDB, C, S ) - IF( ILQ ) - $ CALL ZROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, - $ DCONJG( S ) ) -* -* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) -* - CTEMP = B( JROW, JROW ) - CALL ZLARTG( CTEMP, B( JROW, JROW-1 ), C, S, - $ B( JROW, JROW ) ) - B( JROW, JROW-1 ) = CZERO - CALL ZROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S ) - CALL ZROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C, - $ S ) - IF( ILZ ) - $ CALL ZROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S ) - 30 CONTINUE - 40 CONTINUE -* - RETURN -* -* End of ZGGHRD -* - END - SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, - $ ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, - $ RWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ, JOB - INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION RWORK( * ) - COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), - $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* ZHGEQZ implements a single-shift version of the QZ -* method for finding the generalized eigenvalues w(i)=ALPHA(i)/BETA(i) -* of the equation -* -* det( A - w(i) B ) = 0 -* -* If JOB='S', then the pair (A,B) is simultaneously -* reduced to Schur form (i.e., A and B are both upper triangular) by -* applying one unitary tranformation (usually called Q) on the left and -* another (usually called Z) on the right. The diagonal elements of -* A are then ALPHA(1),...,ALPHA(N), and of B are BETA(1),...,BETA(N). -* -* If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the unitary -* transformations used to reduce (A,B) are accumulated into the arrays -* Q and Z s.t.: -* -* Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)* -* Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)* -* -* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix -* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), -* pp. 241--256. -* -* Arguments -* ========= -* -* JOB (input) CHARACTER*1 -* = 'E': compute only ALPHA and BETA. A and B will not -* necessarily be put into generalized Schur form. -* = 'S': put A and B into generalized Schur form, as well -* as computing ALPHA and BETA. -* -* COMPQ (input) CHARACTER*1 -* = 'N': do not modify Q. -* = 'V': multiply the array Q on the right by the conjugate -* transpose of the unitary tranformation that is -* applied to the left side of A and B to reduce them -* to Schur form. -* = 'I': like COMPQ='V', except that Q will be initialized to -* the identity first. -* -* COMPZ (input) CHARACTER*1 -* = 'N': do not modify Z. -* = 'V': multiply the array Z on the right by the unitary -* tranformation that is applied to the right side of -* A and B to reduce them to Schur form. -* = 'I': like COMPZ='V', except that Z will be initialized to -* the identity first. -* -* N (input) INTEGER -* The order of the matrices A, B, Q, and Z. N >= 0. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* It is assumed that A is already upper triangular in rows and -* columns 1:ILO-1 and IHI+1:N. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA, N) -* On entry, the N-by-N upper Hessenberg matrix A. Elements -* below the subdiagonal must be zero. -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to upper triangular form. -* If JOB='E', then on exit A will have been destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max( 1, N ). -* -* B (input/output) COMPLEX*16 array, dimension (LDB, N) -* On entry, the N-by-N upper triangular matrix B. Elements -* below the diagonal must be zero. -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to upper triangular form. -* If JOB='E', then on exit B will have been destroyed. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max( 1, N ). -* -* ALPHA (output) COMPLEX*16 array, dimension (N) -* The diagonal elements of A when the pair (A,B) has been -* reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N -* are the generalized eigenvalues. -* -* BETA (output) COMPLEX*16 array, dimension (N) -* The diagonal elements of B when the pair (A,B) has been -* reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N -* are the generalized eigenvalues. A and B are normalized -* so that BETA(1),...,BETA(N) are non-negative real numbers. -* -* Q (input/output) COMPLEX*16 array, dimension (LDQ, N) -* If COMPQ='N', then Q will not be referenced. -* If COMPQ='V' or 'I', then the conjugate transpose of the -* unitary transformations which are applied to A and B on -* the left will be applied to the array Q on the right. -* -* LDQ (input) INTEGER -* The leading dimension of the array Q. LDQ >= 1. -* If COMPQ='V' or 'I', then LDQ >= N. -* -* Z (input/output) COMPLEX*16 array, dimension (LDZ, N) -* If COMPZ='N', then Z will not be referenced. -* If COMPZ='V' or 'I', then the unitary transformations which -* are applied to A and B on the right will be applied to the -* array Z on the right. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= 1. -* If COMPZ='V' or 'I', then LDZ >= N. -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* RWORK (workspace) DOUBLE PRECISION array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* = 1,...,N: the QZ iteration did not converge. (A,B) is not -* in Schur form, but ALPHA(i) and BETA(i), -* i=INFO+1,...,N should be correct. -* = N+1,...,2*N: the shift calculation failed. (A,B) is not -* in Schur form, but ALPHA(i) and BETA(i), -* i=INFO-N+1,...,N should be correct. -* > 2*N: various "impossible" errors. -* -* Further Details -* =============== -* -* We assume that complex ABS works as long as its value is less than -* overflow. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 CZERO, CONE - PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), - $ CONE = ( 1.0D+0, 0.0D+0 ) ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION HALF - PARAMETER ( HALF = 0.5D+0 ) -* .. -* .. Local Scalars .. - LOGICAL ILAZR2, ILAZRO, ILQ, ILSCHR, ILZ, LQUERY - INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST, - $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER, - $ JR, MAXIT - DOUBLE PRECISION ABSB, ANORM, ASCALE, ATOL, BNORM, BSCALE, BTOL, - $ C, SAFMIN, TEMP, TEMP2, TEMPR, ULP - COMPLEX*16 ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2, - $ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T, - $ U12, X -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, ZLANHS - EXTERNAL LSAME, DLAMCH, ZLANHS -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARTG, ZLASET, ZROT, ZSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN, - $ SQRT -* .. -* .. Statement Functions .. - DOUBLE PRECISION ABS1 -* .. -* .. Statement Function definitions .. - ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) ) -* .. -* .. Executable Statements .. -* -* Decode JOB, COMPQ, COMPZ -* - IF( LSAME( JOB, 'E' ) ) THEN - ILSCHR = .FALSE. - ISCHUR = 1 - ELSE IF( LSAME( JOB, 'S' ) ) THEN - ILSCHR = .TRUE. - ISCHUR = 2 - ELSE - ISCHUR = 0 - END IF -* - IF( LSAME( COMPQ, 'N' ) ) THEN - ILQ = .FALSE. - ICOMPQ = 1 - ELSE IF( LSAME( COMPQ, 'V' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 2 - ELSE IF( LSAME( COMPQ, 'I' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 3 - ELSE - ICOMPQ = 0 - END IF -* - IF( LSAME( COMPZ, 'N' ) ) THEN - ILZ = .FALSE. - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 2 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 3 - ELSE - ICOMPZ = 0 - END IF -* -* Check Argument Values -* - INFO = 0 - WORK( 1 ) = MAX( 1, N ) - LQUERY = ( LWORK.EQ.-1 ) - IF( ISCHUR.EQ.0 ) THEN - INFO = -1 - ELSE IF( ICOMPQ.EQ.0 ) THEN - INFO = -2 - ELSE IF( ICOMPZ.EQ.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( ILO.LT.1 ) THEN - INFO = -5 - ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN - INFO = -6 - ELSE IF( LDA.LT.N ) THEN - INFO = -8 - ELSE IF( LDB.LT.N ) THEN - INFO = -10 - ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN - INFO = -14 - ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN - INFO = -16 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -18 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHGEQZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* -* WORK( 1 ) = CMPLX( 1 ) - IF( N.LE.0 ) THEN - WORK( 1 ) = DCMPLX( 1 ) - RETURN - END IF -* -* Initialize Q and Z -* - IF( ICOMPQ.EQ.3 ) - $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ ) - IF( ICOMPZ.EQ.3 ) - $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) -* -* Machine Constants -* - IN = IHI + 1 - ILO - SAFMIN = DLAMCH( 'S' ) - ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) - ANORM = ZLANHS( 'F', IN, A( ILO, ILO ), LDA, RWORK ) - BNORM = ZLANHS( 'F', IN, B( ILO, ILO ), LDB, RWORK ) - ATOL = MAX( SAFMIN, ULP*ANORM ) - BTOL = MAX( SAFMIN, ULP*BNORM ) - ASCALE = ONE / MAX( SAFMIN, ANORM ) - BSCALE = ONE / MAX( SAFMIN, BNORM ) -* -* -* Set Eigenvalues IHI+1:N -* - DO 10 J = IHI + 1, N - ABSB = ABS( B( J, J ) ) - IF( ABSB.GT.SAFMIN ) THEN - SIGNBC = DCONJG( B( J, J ) / ABSB ) - B( J, J ) = ABSB - IF( ILSCHR ) THEN - CALL ZSCAL( J-1, SIGNBC, B( 1, J ), 1 ) - CALL ZSCAL( J, SIGNBC, A( 1, J ), 1 ) - ELSE - A( J, J ) = A( J, J )*SIGNBC - END IF - IF( ILZ ) - $ CALL ZSCAL( N, SIGNBC, Z( 1, J ), 1 ) - ELSE - B( J, J ) = CZERO - END IF - ALPHA( J ) = A( J, J ) - BETA( J ) = B( J, J ) - 10 CONTINUE -* -* If IHI < ILO, skip QZ steps -* - IF( IHI.LT.ILO ) - $ GO TO 190 -* -* MAIN QZ ITERATION LOOP -* -* Initialize dynamic indices -* -* Eigenvalues ILAST+1:N have been found. -* Column operations modify rows IFRSTM:whatever -* Row operations modify columns whatever:ILASTM -* -* If only eigenvalues are being computed, then -* IFRSTM is the row of the last splitting row above row ILAST; -* this is always at least ILO. -* IITER counts iterations since the last eigenvalue was found, -* to tell when to use an extraordinary shift. -* MAXIT is the maximum number of QZ sweeps allowed. -* - ILAST = IHI - IF( ILSCHR ) THEN - IFRSTM = 1 - ILASTM = N - ELSE - IFRSTM = ILO - ILASTM = IHI - END IF - IITER = 0 - ESHIFT = CZERO - MAXIT = 30*( IHI-ILO+1 ) -* - DO 170 JITER = 1, MAXIT -* -* Check for too many iterations. -* - IF( JITER.GT.MAXIT ) - $ GO TO 180 -* -* Split the matrix if possible. -* -* Two tests: -* 1: A(j,j-1)=0 or j=ILO -* 2: B(j,j)=0 -* -* Special case: j=ILAST -* - IF( ILAST.EQ.ILO ) THEN - GO TO 60 - ELSE - IF( ABS1( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN - A( ILAST, ILAST-1 ) = CZERO - GO TO 60 - END IF - END IF -* - IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN - B( ILAST, ILAST ) = CZERO - GO TO 50 - END IF -* -* General case: j= 0. -* -* A (input) COMPLEX*16 array, dimension (LDA,N) -* The upper triangular matrix A. -* -* LDA (input) INTEGER -* The leading dimension of array A. LDA >= max(1,N). -* -* B (input) COMPLEX*16 array, dimension (LDB,N) -* The upper triangular matrix B. B must have real diagonal -* elements. -* -* LDB (input) INTEGER -* The leading dimension of array B. LDB >= max(1,N). -* -* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) -* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must -* contain an N-by-N matrix Q (usually the unitary matrix Q -* of left Schur vectors returned by ZHGEQZ). -* On exit, if SIDE = 'L' or 'B', VL contains: -* if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); -* if HOWMNY = 'B', the matrix Q*Y; -* if HOWMNY = 'S', the left eigenvectors of (A,B) specified by -* SELECT, stored consecutively in the columns of -* VL, in the same order as their eigenvalues. -* If SIDE = 'R', VL is not referenced. -* -* LDVL (input) INTEGER -* The leading dimension of array VL. -* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. -* -* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) -* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must -* contain an N-by-N matrix Q (usually the unitary matrix Z -* of right Schur vectors returned by ZHGEQZ). -* On exit, if SIDE = 'R' or 'B', VR contains: -* if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); -* if HOWMNY = 'B', the matrix Z*X; -* if HOWMNY = 'S', the right eigenvectors of (A,B) specified by -* SELECT, stored consecutively in the columns of -* VR, in the same order as their eigenvalues. -* If SIDE = 'L', VR is not referenced. -* -* LDVR (input) INTEGER -* The leading dimension of the array VR. -* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. -* -* MM (input) INTEGER -* The number of columns in the arrays VL and/or VR. MM >= M. -* -* M (output) INTEGER -* The number of columns in the arrays VL and/or VR actually -* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M -* is set to N. Each selected eigenvector occupies one column. -* -* WORK (workspace) COMPLEX*16 array, dimension (2*N) -* -* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - COMPLEX*16 CZERO, CONE - PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), - $ CONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL COMPL, COMPR, ILALL, ILBACK, ILBBAD, ILCOMP, - $ LSA, LSB - INTEGER I, IBEG, IEIG, IEND, IHWMNY, IM, ISIDE, ISRC, - $ J, JE, JR - DOUBLE PRECISION ACOEFA, ACOEFF, ANORM, ASCALE, BCOEFA, BIG, - $ BIGNUM, BNORM, BSCALE, DMIN, SAFMIN, SBETA, - $ SCALE, SMALL, TEMP, ULP, XMAX - COMPLEX*16 BCOEFF, CA, CB, D, SALPHA, SUM, SUMA, SUMB, X -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - COMPLEX*16 ZLADIV - EXTERNAL LSAME, DLAMCH, ZLADIV -* .. -* .. External Subroutines .. - EXTERNAL DLABAD, XERBLA, ZGEMV -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN -* .. -* .. Statement Functions .. - DOUBLE PRECISION ABS1 -* .. -* .. Statement Function definitions .. - ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) ) -* .. -* .. Executable Statements .. -* -* Decode and Test the input parameters -* - IF( LSAME( HOWMNY, 'A' ) ) THEN - IHWMNY = 1 - ILALL = .TRUE. - ILBACK = .FALSE. - ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN - IHWMNY = 2 - ILALL = .FALSE. - ILBACK = .FALSE. - ELSE IF( LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'T' ) ) THEN - IHWMNY = 3 - ILALL = .TRUE. - ILBACK = .TRUE. - ELSE - IHWMNY = -1 - END IF -* - IF( LSAME( SIDE, 'R' ) ) THEN - ISIDE = 1 - COMPL = .FALSE. - COMPR = .TRUE. - ELSE IF( LSAME( SIDE, 'L' ) ) THEN - ISIDE = 2 - COMPL = .TRUE. - COMPR = .FALSE. - ELSE IF( LSAME( SIDE, 'B' ) ) THEN - ISIDE = 3 - COMPL = .TRUE. - COMPR = .TRUE. - ELSE - ISIDE = -1 - END IF -* - INFO = 0 - IF( ISIDE.LT.0 ) THEN - INFO = -1 - ELSE IF( IHWMNY.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZTGEVC', -INFO ) - RETURN - END IF -* -* Count the number of eigenvectors -* - IF( .NOT.ILALL ) THEN - IM = 0 - DO 10 J = 1, N - IF( SELECT( J ) ) - $ IM = IM + 1 - 10 CONTINUE - ELSE - IM = N - END IF -* -* Check diagonal of B -* - ILBBAD = .FALSE. - DO 20 J = 1, N - IF( DIMAG( B( J, J ) ).NE.ZERO ) - $ ILBBAD = .TRUE. - 20 CONTINUE -* - IF( ILBBAD ) THEN - INFO = -7 - ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN - INFO = -10 - ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN - INFO = -12 - ELSE IF( MM.LT.IM ) THEN - INFO = -13 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZTGEVC', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - M = IM - IF( N.EQ.0 ) - $ RETURN -* -* Machine Constants -* - SAFMIN = DLAMCH( 'Safe minimum' ) - BIG = ONE / SAFMIN - CALL DLABAD( SAFMIN, BIG ) - ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) - SMALL = SAFMIN*N / ULP - BIG = ONE / SMALL - BIGNUM = ONE / ( SAFMIN*N ) -* -* Compute the 1-norm of each column of the strictly upper triangular -* part of A and B to check for possible overflow in the triangular -* solver. -* - ANORM = ABS1( A( 1, 1 ) ) - BNORM = ABS1( B( 1, 1 ) ) - RWORK( 1 ) = ZERO - RWORK( N+1 ) = ZERO - DO 40 J = 2, N - RWORK( J ) = ZERO - RWORK( N+J ) = ZERO - DO 30 I = 1, J - 1 - RWORK( J ) = RWORK( J ) + ABS1( A( I, J ) ) - RWORK( N+J ) = RWORK( N+J ) + ABS1( B( I, J ) ) - 30 CONTINUE - ANORM = MAX( ANORM, RWORK( J )+ABS1( A( J, J ) ) ) - BNORM = MAX( BNORM, RWORK( N+J )+ABS1( B( J, J ) ) ) - 40 CONTINUE -* - ASCALE = ONE / MAX( ANORM, SAFMIN ) - BSCALE = ONE / MAX( BNORM, SAFMIN ) -* -* Left eigenvectors -* - IF( COMPL ) THEN - IEIG = 0 -* -* Main loop over eigenvalues -* - DO 140 JE = 1, N - IF( ILALL ) THEN - ILCOMP = .TRUE. - ELSE - ILCOMP = SELECT( JE ) - END IF - IF( ILCOMP ) THEN - IEIG = IEIG + 1 -* - IF( ABS1( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( DBLE( B( JE, JE ) ) ).LE.SAFMIN ) THEN -* -* Singular matrix pencil -- return unit eigenvector -* - DO 50 JR = 1, N - VL( JR, IEIG ) = CZERO - 50 CONTINUE - VL( IEIG, IEIG ) = CONE - GO TO 140 - END IF -* -* Non-singular eigenvalue: -* Compute coefficients a and b in -* H -* y ( a A - b B ) = 0 -* - TEMP = ONE / MAX( ABS1( A( JE, JE ) )*ASCALE, - $ ABS( DBLE( B( JE, JE ) ) )*BSCALE, SAFMIN ) - SALPHA = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*DBLE( B( JE, JE ) ) )*BSCALE - ACOEFF = SBETA*ASCALE - BCOEFF = SALPHA*BSCALE -* -* Scale to avoid underflow -* - LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL - LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT. - $ SMALL -* - SCALE = ONE - IF( LSA ) - $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) - IF( LSB ) - $ SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )* - $ MIN( BNORM, BIG ) ) - IF( LSA .OR. LSB ) THEN - SCALE = MIN( SCALE, ONE / - $ ( SAFMIN*MAX( ONE, ABS( ACOEFF ), - $ ABS1( BCOEFF ) ) ) ) - IF( LSA ) THEN - ACOEFF = ASCALE*( SCALE*SBETA ) - ELSE - ACOEFF = SCALE*ACOEFF - END IF - IF( LSB ) THEN - BCOEFF = BSCALE*( SCALE*SALPHA ) - ELSE - BCOEFF = SCALE*BCOEFF - END IF - END IF -* - ACOEFA = ABS( ACOEFF ) - BCOEFA = ABS1( BCOEFF ) - XMAX = ONE - DO 60 JR = 1, N - WORK( JR ) = CZERO - 60 CONTINUE - WORK( JE ) = CONE - DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) -* -* H -* Triangular solve of (a A - b B) y = 0 -* -* H -* (rowwise in (a A - b B) , or columnwise in a A - b B) -* - DO 100 J = JE + 1, N -* -* Compute -* j-1 -* SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k) -* k=je -* (Scale if necessary) -* - TEMP = ONE / XMAX - IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GT.BIGNUM* - $ TEMP ) THEN - DO 70 JR = JE, J - 1 - WORK( JR ) = TEMP*WORK( JR ) - 70 CONTINUE - XMAX = ONE - END IF - SUMA = CZERO - SUMB = CZERO -* - DO 80 JR = JE, J - 1 - SUMA = SUMA + DCONJG( A( JR, J ) )*WORK( JR ) - SUMB = SUMB + DCONJG( B( JR, J ) )*WORK( JR ) - 80 CONTINUE - SUM = ACOEFF*SUMA - DCONJG( BCOEFF )*SUMB -* -* Form x(j) = - SUM / conjg( a*A(j,j) - b*B(j,j) ) -* -* with scaling and perturbation of the denominator -* - D = DCONJG( ACOEFF*A( J, J )-BCOEFF*B( J, J ) ) - IF( ABS1( D ).LE.DMIN ) - $ D = DCMPLX( DMIN ) -* - IF( ABS1( D ).LT.ONE ) THEN - IF( ABS1( SUM ).GE.BIGNUM*ABS1( D ) ) THEN - TEMP = ONE / ABS1( SUM ) - DO 90 JR = JE, J - 1 - WORK( JR ) = TEMP*WORK( JR ) - 90 CONTINUE - XMAX = TEMP*XMAX - SUM = TEMP*SUM - END IF - END IF - WORK( J ) = ZLADIV( -SUM, D ) - XMAX = MAX( XMAX, ABS1( WORK( J ) ) ) - 100 CONTINUE -* -* Back transform eigenvector if HOWMNY='B'. -* - IF( ILBACK ) THEN - CALL ZGEMV( 'N', N, N+1-JE, CONE, VL( 1, JE ), LDVL, - $ WORK( JE ), 1, CZERO, WORK( N+1 ), 1 ) - ISRC = 2 - IBEG = 1 - ELSE - ISRC = 1 - IBEG = JE - END IF -* -* Copy and scale eigenvector into column of VL -* - XMAX = ZERO - DO 110 JR = IBEG, N - XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) ) - 110 CONTINUE -* - IF( XMAX.GT.SAFMIN ) THEN - TEMP = ONE / XMAX - DO 120 JR = IBEG, N - VL( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR ) - 120 CONTINUE - ELSE - IBEG = N + 1 - END IF -* - DO 130 JR = 1, IBEG - 1 - VL( JR, IEIG ) = CZERO - 130 CONTINUE -* - END IF - 140 CONTINUE - END IF -* -* Right eigenvectors -* - IF( COMPR ) THEN - IEIG = IM + 1 -* -* Main loop over eigenvalues -* - DO 250 JE = N, 1, -1 - IF( ILALL ) THEN - ILCOMP = .TRUE. - ELSE - ILCOMP = SELECT( JE ) - END IF - IF( ILCOMP ) THEN - IEIG = IEIG - 1 -* - IF( ABS1( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( DBLE( B( JE, JE ) ) ).LE.SAFMIN ) THEN -* -* Singular matrix pencil -- return unit eigenvector -* - DO 150 JR = 1, N - VR( JR, IEIG ) = CZERO - 150 CONTINUE - VR( IEIG, IEIG ) = CONE - GO TO 250 - END IF -* -* Non-singular eigenvalue: -* Compute coefficients a and b in -* -* ( a A - b B ) x = 0 -* - TEMP = ONE / MAX( ABS1( A( JE, JE ) )*ASCALE, - $ ABS( DBLE( B( JE, JE ) ) )*BSCALE, SAFMIN ) - SALPHA = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*DBLE( B( JE, JE ) ) )*BSCALE - ACOEFF = SBETA*ASCALE - BCOEFF = SALPHA*BSCALE -* -* Scale to avoid underflow -* - LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL - LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT. - $ SMALL -* - SCALE = ONE - IF( LSA ) - $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) - IF( LSB ) - $ SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )* - $ MIN( BNORM, BIG ) ) - IF( LSA .OR. LSB ) THEN - SCALE = MIN( SCALE, ONE / - $ ( SAFMIN*MAX( ONE, ABS( ACOEFF ), - $ ABS1( BCOEFF ) ) ) ) - IF( LSA ) THEN - ACOEFF = ASCALE*( SCALE*SBETA ) - ELSE - ACOEFF = SCALE*ACOEFF - END IF - IF( LSB ) THEN - BCOEFF = BSCALE*( SCALE*SALPHA ) - ELSE - BCOEFF = SCALE*BCOEFF - END IF - END IF -* - ACOEFA = ABS( ACOEFF ) - BCOEFA = ABS1( BCOEFF ) - XMAX = ONE - DO 160 JR = 1, N - WORK( JR ) = CZERO - 160 CONTINUE - WORK( JE ) = CONE - DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) -* -* Triangular solve of (a A - b B) x = 0 (columnwise) -* -* WORK(1:j-1) contains sums w, -* WORK(j+1:JE) contains x -* - DO 170 JR = 1, JE - 1 - WORK( JR ) = ACOEFF*A( JR, JE ) - BCOEFF*B( JR, JE ) - 170 CONTINUE - WORK( JE ) = CONE -* - DO 210 J = JE - 1, 1, -1 -* -* Form x(j) := - w(j) / d -* with scaling and perturbation of the denominator -* - D = ACOEFF*A( J, J ) - BCOEFF*B( J, J ) - IF( ABS1( D ).LE.DMIN ) - $ D = DCMPLX( DMIN ) -* - IF( ABS1( D ).LT.ONE ) THEN - IF( ABS1( WORK( J ) ).GE.BIGNUM*ABS1( D ) ) THEN - TEMP = ONE / ABS1( WORK( J ) ) - DO 180 JR = 1, JE - WORK( JR ) = TEMP*WORK( JR ) - 180 CONTINUE - END IF - END IF -* - WORK( J ) = ZLADIV( -WORK( J ), D ) -* - IF( J.GT.1 ) THEN -* -* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling -* - IF( ABS1( WORK( J ) ).GT.ONE ) THEN - TEMP = ONE / ABS1( WORK( J ) ) - IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GE. - $ BIGNUM*TEMP ) THEN - DO 190 JR = 1, JE - WORK( JR ) = TEMP*WORK( JR ) - 190 CONTINUE - END IF - END IF -* - CA = ACOEFF*WORK( J ) - CB = BCOEFF*WORK( J ) - DO 200 JR = 1, J - 1 - WORK( JR ) = WORK( JR ) + CA*A( JR, J ) - - $ CB*B( JR, J ) - 200 CONTINUE - END IF - 210 CONTINUE -* -* Back transform eigenvector if HOWMNY='B'. -* - IF( ILBACK ) THEN - CALL ZGEMV( 'N', N, JE, CONE, VR, LDVR, WORK, 1, - $ CZERO, WORK( N+1 ), 1 ) - ISRC = 2 - IEND = N - ELSE - ISRC = 1 - IEND = JE - END IF -* -* Copy and scale eigenvector into column of VR -* - XMAX = ZERO - DO 220 JR = 1, IEND - XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) ) - 220 CONTINUE -* - IF( XMAX.GT.SAFMIN ) THEN - TEMP = ONE / XMAX - DO 230 JR = 1, IEND - VR( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR ) - 230 CONTINUE - ELSE - IEND = 0 - END IF -* - DO 240 JR = IEND + 1, N - VR( JR, IEIG ) = CZERO - 240 CONTINUE -* - END IF - 250 CONTINUE - END IF -* - RETURN -* -* End of ZTGEVC -* - END - SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, - $ LDV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER JOB, SIDE - INTEGER IHI, ILO, INFO, LDV, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION LSCALE( * ), RSCALE( * ) - COMPLEX*16 V( LDV, * ) -* .. -* -* Purpose -* ======= -* -* ZGGBAK forms the right or left eigenvectors of a complex generalized -* eigenvalue problem A*x = lambda*B*x, by backward transformation on -* the computed eigenvectors of the balanced pair of matrices output by -* ZGGBAL. -* -* Arguments -* ========= -* -* JOB (input) CHARACTER*1 -* Specifies the type of backward transformation required: -* = 'N': do nothing, return immediately; -* = 'P': do backward transformation for permutation only; -* = 'S': do backward transformation for scaling only; -* = 'B': do backward transformations for both permutation and -* scaling. -* JOB must be the same as the argument JOB supplied to ZGGBAL. -* -* SIDE (input) CHARACTER*1 -* = 'R': V contains right eigenvectors; -* = 'L': V contains left eigenvectors. -* -* N (input) INTEGER -* The number of rows of the matrix V. N >= 0. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* The integers ILO and IHI determined by ZGGBAL. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -* -* LSCALE (input) DOUBLE PRECISION array, dimension (N) -* Details of the permutations and/or scaling factors applied -* to the left side of A and B, as returned by ZGGBAL. -* -* RSCALE (input) DOUBLE PRECISION array, dimension (N) -* Details of the permutations and/or scaling factors applied -* to the right side of A and B, as returned by ZGGBAL. -* -* M (input) INTEGER -* The number of columns of the matrix V. M >= 0. -* -* V (input/output) COMPLEX*16 array, dimension (LDV,M) -* On entry, the matrix of right or left eigenvectors to be -* transformed, as returned by ZTGEVC. -* On exit, V is overwritten by the transformed eigenvectors. -* -* LDV (input) INTEGER -* The leading dimension of the matrix V. LDV >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* See R.C. Ward, Balancing the generalized eigenvalue problem, -* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LEFTV, RIGHTV - INTEGER I, K -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL, ZSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - RIGHTV = LSAME( SIDE, 'R' ) - LEFTV = LSAME( SIDE, 'L' ) -* - INFO = 0 - IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. - $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN - INFO = -1 - ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( ILO.LT.1 ) THEN - INFO = -4 - ELSE IF( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( LDV.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGGBAK', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN - IF( M.EQ.0 ) - $ RETURN - IF( LSAME( JOB, 'N' ) ) - $ RETURN -* - IF( ILO.EQ.IHI ) - $ GO TO 30 -* -* Backward balance -* - IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN -* -* Backward transformation on right eigenvectors -* - IF( RIGHTV ) THEN - DO 10 I = ILO, IHI - CALL ZDSCAL( M, RSCALE( I ), V( I, 1 ), LDV ) - 10 CONTINUE - END IF -* -* Backward transformation on left eigenvectors -* - IF( LEFTV ) THEN - DO 20 I = ILO, IHI - CALL ZDSCAL( M, LSCALE( I ), V( I, 1 ), LDV ) - 20 CONTINUE - END IF - END IF -* -* Backward permutation -* - 30 CONTINUE - IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN -* -* Backward permutation on right eigenvectors -* - IF( RIGHTV ) THEN - IF( ILO.EQ.1 ) - $ GO TO 50 - DO 40 I = ILO - 1, 1, -1 - K = RSCALE( I ) - IF( K.EQ.I ) - $ GO TO 40 - CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) - 40 CONTINUE -* - 50 CONTINUE - IF( IHI.EQ.N ) - $ GO TO 70 - DO 60 I = IHI + 1, N - K = RSCALE( I ) - IF( K.EQ.I ) - $ GO TO 60 - CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) - 60 CONTINUE - END IF -* -* Backward permutation on left eigenvectors -* - 70 CONTINUE - IF( LEFTV ) THEN - IF( ILO.EQ.1 ) - $ GO TO 90 - DO 80 I = ILO - 1, 1, -1 - K = LSCALE( I ) - IF( K.EQ.I ) - $ GO TO 80 - CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) - 80 CONTINUE -* - 90 CONTINUE - IF( IHI.EQ.N ) - $ GO TO 110 - DO 100 I = IHI + 1, N - K = LSCALE( I ) - IF( K.EQ.I ) - $ GO TO 100 - CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) - 100 CONTINUE - END IF - END IF -* - 110 CONTINUE -* - RETURN -* -* End of ZGGBAK -* - END - SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZGEQR2 computes a QR factorization of a complex m by n matrix A: -* A = Q * R. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the m by n matrix A. -* On exit, the elements on and above the diagonal of the array -* contain the min(m,n) by n upper trapezoidal matrix R (R is -* upper triangular if m >= n); the elements below the diagonal, -* with the array TAU, represent the unitary matrix Q as a -* product of elementary reflectors (see Further Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) COMPLEX*16 array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace) COMPLEX*16 array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(1) H(2) . . . H(k), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a complex scalar, and v is a complex vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, K - COMPLEX*16 ALPHA -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARF, ZLARFG -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGEQR2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i+1:m,i) -* - CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAU( I ) ) - IF( I.LT.N ) THEN -* -* Apply H(i)' to A(i:m,i+1:n) from the left -* - ALPHA = A( I, I ) - A( I, I ) = ONE - CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, - $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) - A( I, I ) = ALPHA - END IF - 10 CONTINUE - RETURN -* -* End of ZGEQR2 -* - END - SUBROUTINE ZLARTG( F, G, CS, SN, R ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - DOUBLE PRECISION CS - COMPLEX*16 F, G, R, SN -* .. -* -* Purpose -* ======= -* -* ZLARTG generates a plane rotation so that -* -* [ CS SN ] [ F ] [ R ] -* [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. -* [ -SN CS ] [ G ] [ 0 ] -* -* This is a faster version of the BLAS1 routine ZROTG, except for -* the following differences: -* F and G are unchanged on return. -* If G=0, then CS=1 and SN=0. -* If F=0, then CS=0 and SN is chosen so that R is real. -* -* Arguments -* ========= -* -* F (input) COMPLEX*16 -* The first component of vector to be rotated. -* -* G (input) COMPLEX*16 -* The second component of vector to be rotated. -* -* CS (output) DOUBLE PRECISION -* The cosine of the rotation. -* -* SN (output) COMPLEX*16 -* The sine of the rotation. -* -* R (output) COMPLEX*16 -* The nonzero component of the rotated vector. -* -* Further Details -* ======= ======= -* -* 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION TWO, ONE, ZERO - PARAMETER ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) - COMPLEX*16 CZERO - PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL FIRST - INTEGER COUNT, I - DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN, - $ SAFMN2, SAFMX2, SCALE - COMPLEX*16 FF, FS, GS -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL DLAMCH, DLAPY2 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG, - $ MAX, SQRT -* .. -* .. Statement Functions .. - DOUBLE PRECISION ABS1, ABSSQ -* .. -* .. Save statement .. - SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Statement Function definitions .. - ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) ) - ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2 -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - SAFMIN = DLAMCH( 'S' ) - EPS = DLAMCH( 'E' ) - SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / - $ LOG( DLAMCH( 'B' ) ) / TWO ) - SAFMX2 = ONE / SAFMN2 - END IF - SCALE = MAX( ABS1( F ), ABS1( G ) ) - FS = F - GS = G - COUNT = 0 - IF( SCALE.GE.SAFMX2 ) THEN - 10 CONTINUE - COUNT = COUNT + 1 - FS = FS*SAFMN2 - GS = GS*SAFMN2 - SCALE = SCALE*SAFMN2 - IF( SCALE.GE.SAFMX2 ) - $ GO TO 10 - ELSE IF( SCALE.LE.SAFMN2 ) THEN - IF( G.EQ.CZERO ) THEN - CS = ONE - SN = CZERO - R = F - RETURN - END IF - 20 CONTINUE - COUNT = COUNT - 1 - FS = FS*SAFMX2 - GS = GS*SAFMX2 - SCALE = SCALE*SAFMX2 - IF( SCALE.LE.SAFMN2 ) - $ GO TO 20 - END IF - F2 = ABSSQ( FS ) - G2 = ABSSQ( GS ) - IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN -* -* This is a rare case: F is very small. -* - IF( F.EQ.CZERO ) THEN - CS = ZERO - R = DLAPY2( DBLE( G ), DIMAG( G ) ) -* Do complex/real division explicitly with two real divisions - D = DLAPY2( DBLE( GS ), DIMAG( GS ) ) - SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D ) - RETURN - END IF - F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) ) -* G2 and G2S are accurate -* G2 is at least SAFMIN, and G2S is at least SAFMN2 - G2S = SQRT( G2 ) -* Error in CS from underflow in F2S is at most -* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS -* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, -* and so CS .lt. sqrt(SAFMIN) -* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN -* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) -* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S - CS = F2S / G2S -* Make sure abs(FF) = 1 -* Do complex/real division explicitly with 2 real divisions - IF( ABS1( F ).GT.ONE ) THEN - D = DLAPY2( DBLE( F ), DIMAG( F ) ) - FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D ) - ELSE - DR = SAFMX2*DBLE( F ) - DI = SAFMX2*DIMAG( F ) - D = DLAPY2( DR, DI ) - FF = DCMPLX( DR / D, DI / D ) - END IF - SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S ) - R = CS*F + SN*G - ELSE -* -* This is the most common case. -* Neither F2 nor F2/G2 are less than SAFMIN -* F2S cannot overflow, and it is accurate -* - F2S = SQRT( ONE+G2 / F2 ) -* Do the F2S(real)*FS(complex) multiply with two real multiplies - R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) ) - CS = ONE / F2S - D = F2 + G2 -* Do complex/real division explicitly with two real divisions - SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D ) - SN = SN*DCONJG( GS ) - IF( COUNT.NE.0 ) THEN - IF( COUNT.GT.0 ) THEN - DO 30 I = 1, COUNT - R = R*SAFMX2 - 30 CONTINUE - ELSE - DO 40 I = 1, -COUNT - R = R*SAFMN2 - 40 CONTINUE - END IF - END IF - END IF - RETURN -* -* End of ZLARTG -* - END - DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION WORK( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZLANHS returns the value of the one norm, or the Frobenius norm, or -* the infinity norm, or the element of largest absolute value of a -* Hessenberg matrix A. -* -* Description -* =========== -* -* ZLANHS returns the value -* -* ZLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' -* ( -* ( norm1(A), NORM = '1', 'O' or 'o' -* ( -* ( normI(A), NORM = 'I' or 'i' -* ( -* ( normF(A), NORM = 'F', 'f', 'E' or 'e' -* -* where norm1 denotes the one norm of a matrix (maximum column sum), -* normI denotes the infinity norm of a matrix (maximum row sum) and -* normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies the value to be returned in ZLANHS as described -* above. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. When N = 0, ZLANHS is -* set to zero. -* -* A (input) COMPLEX*16 array, dimension (LDA,N) -* The n by n upper Hessenberg matrix A; the part of A below the -* first sub-diagonal is not referenced. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(N,1). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), -* where LWORK >= N when NORM = 'I'; otherwise, WORK is not -* referenced. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION SCALE, SUM, VALUE -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL ZLASSQ -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - IF( N.EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - DO 20 J = 1, N - DO 10 I = 1, MIN( N, J+1 ) - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 10 CONTINUE - 20 CONTINUE - ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN -* -* Find norm1(A). -* - VALUE = ZERO - DO 40 J = 1, N - SUM = ZERO - DO 30 I = 1, MIN( N, J+1 ) - SUM = SUM + ABS( A( I, J ) ) - 30 CONTINUE - VALUE = MAX( VALUE, SUM ) - 40 CONTINUE - ELSE IF( LSAME( NORM, 'I' ) ) THEN -* -* Find normI(A). -* - DO 50 I = 1, N - WORK( I ) = ZERO - 50 CONTINUE - DO 70 J = 1, N - DO 60 I = 1, MIN( N, J+1 ) - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 60 CONTINUE - 70 CONTINUE - VALUE = ZERO - DO 80 I = 1, N - VALUE = MAX( VALUE, WORK( I ) ) - 80 CONTINUE - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - DO 90 J = 1, N - CALL ZLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) - 90 CONTINUE - VALUE = SCALE*SQRT( SUM ) - END IF -* - ZLANHS = VALUE - RETURN -* -* End of ZLANHS -* - END - SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - INTEGER INCX, INCY, N - DOUBLE PRECISION C - COMPLEX*16 S -* .. -* .. Array Arguments .. - COMPLEX*16 CX( * ), CY( * ) -* .. -* -* Purpose -* ======= -* -* ZROT applies a plane rotation, where the cos (C) is real and the -* sin (S) is complex, and the vectors CX and CY are complex. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of elements in the vectors CX and CY. -* -* CX (input/output) COMPLEX*16 array, dimension (N) -* On input, the vector X. -* On output, CX is overwritten with C*X + S*Y. -* -* INCX (input) INTEGER -* The increment between successive values of CY. INCX <> 0. -* -* CY (input/output) COMPLEX*16 array, dimension (N) -* On input, the vector Y. -* On output, CY is overwritten with -CONJG(S)*X + C*Y. -* -* INCY (input) INTEGER -* The increment between successive values of CY. INCX <> 0. -* -* C (input) DOUBLE PRECISION -* where C*C + S*CONJG(S) = 1.0. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IX, IY - COMPLEX*16 STEMP -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* .. Executable Statements .. -* - IF( N.LE.0 ) - $ RETURN - IF( INCX.EQ.1 .AND. INCY.EQ.1 ) - $ GO TO 20 -* -* Code for unequal increments or equal increments not equal to 1 -* - IX = 1 - IY = 1 - IF( INCX.LT.0 ) - $ IX = ( -N+1 )*INCX + 1 - IF( INCY.LT.0 ) - $ IY = ( -N+1 )*INCY + 1 - DO 10 I = 1, N - STEMP = C*CX( IX ) + S*CY( IY ) - CY( IY ) = C*CY( IY ) - DCONJG( S )*CX( IX ) - CX( IX ) = STEMP - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -* -* Code for both increments equal to 1 -* - 20 CONTINUE - DO 30 I = 1, N - STEMP = C*CX( I ) + S*CY( I ) - CY( I ) = C*CY( I ) - DCONJG( S )*CX( I ) - CX( I ) = STEMP - 30 CONTINUE - RETURN - END - SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, - $ LWORK, INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, ITYPE, LDA, LDB, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DSYGV computes all the eigenvalues, and optionally, the eigenvectors -* of a real generalized symmetric-definite eigenproblem, of the form -* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. -* Here A and B are assumed to be symmetric and B is also -* positive definite. -* -* Arguments -* ========= -* -* ITYPE (input) INTEGER -* Specifies the problem type to be solved: -* = 1: A*x = (lambda)*B*x -* = 2: A*B*x = (lambda)*x -* = 3: B*A*x = (lambda)*x -* -* JOBZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only; -* = 'V': Compute eigenvalues and eigenvectors. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangles of A and B are stored; -* = 'L': Lower triangles of A and B are stored. -* -* N (input) INTEGER -* The order of the matrices A and B. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) -* On entry, the symmetric matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of A contains the -* upper triangular part of the matrix A. If UPLO = 'L', -* the leading N-by-N lower triangular part of A contains -* the lower triangular part of the matrix A. -* -* On exit, if JOBZ = 'V', then if INFO = 0, A contains the -* matrix Z of eigenvectors. The eigenvectors are normalized -* as follows: -* if ITYPE = 1 or 2, Z**T*B*Z = I; -* if ITYPE = 3, Z**T*inv(B)*Z = I. -* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') -* or the lower triangle (if UPLO='L') of A, including the -* diagonal, is destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) -* On entry, the symmetric positive definite matrix B. -* If UPLO = 'U', the leading N-by-N upper triangular part of B -* contains the upper triangular part of the matrix B. -* If UPLO = 'L', the leading N-by-N lower triangular part of B -* contains the lower triangular part of the matrix B. -* -* On exit, if INFO <= N, the part of B containing the matrix is -* overwritten by the triangular factor U or L from the Cholesky -* factorization B = U**T*U or B = L*L**T. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* W (output) DOUBLE PRECISION array, dimension (N) -* If INFO = 0, the eigenvalues in ascending order. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The length of the array WORK. LWORK >= max(1,3*N-1). -* For optimal efficiency, LWORK >= (NB+2)*N, -* where NB is the blocksize for DSYTRD returned by ILAENV. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: DPOTRF or DSYEV returned an error code: -* <= N: if INFO = i, DSYEV failed to converge; -* i off-diagonal elements of an intermediate -* tridiagonal form did not converge to zero; -* > N: if INFO = N + i, for 1 <= i <= N, then the leading -* minor of order i of B is not positive definite. -* The factorization of B could not be completed and -* no eigenvalues or eigenvectors were computed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER, WANTZ - CHARACTER TRANS - INTEGER LWKOPT, NB, NEIG -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DPOTRF, DSYEV, DSYGST, DTRMM, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) -* - INFO = 0 - IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -11 - END IF -* - IF( INFO.EQ.0 ) THEN - NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) - LWKOPT = ( NB+2 )*N - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYGV ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Form a Cholesky factorization of B. -* - CALL DPOTRF( UPLO, N, B, LDB, INFO ) - IF( INFO.NE.0 ) THEN - INFO = N + INFO - RETURN - END IF -* -* Transform problem to standard eigenvalue problem and solve. -* - CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) - CALL DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) -* - IF( WANTZ ) THEN -* -* Backtransform eigenvectors to the original problem. -* - NEIG = N - IF( INFO.GT.0 ) - $ NEIG = INFO - 1 - IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN -* -* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; -* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y -* - IF( UPPER ) THEN - TRANS = 'N' - ELSE - TRANS = 'T' - END IF -* - CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, - $ B, LDB, A, LDA ) -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* For B*A*x=(lambda)*x; -* backtransform eigenvectors: x = L*y or U'*y -* - IF( UPPER ) THEN - TRANS = 'T' - ELSE - TRANS = 'N' - END IF -* - CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, - $ B, LDB, A, LDA ) - END IF - END IF -* - WORK( 1 ) = LWKOPT - RETURN -* -* End of DSYGV -* - END - SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, ITYPE, LDA, LDB, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DSYGST reduces a real symmetric-definite generalized eigenproblem -* to standard form. -* -* If ITYPE = 1, the problem is A*x = lambda*B*x, -* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) -* -* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or -* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. -* -* B must have been previously factorized as U**T*U or L*L**T by DPOTRF. -* -* Arguments -* ========= -* -* ITYPE (input) INTEGER -* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); -* = 2 or 3: compute U*A*U**T or L**T*A*L. -* -* UPLO (input) CHARACTER -* = 'U': Upper triangle of A is stored and B is factored as -* U**T*U; -* = 'L': Lower triangle of A is stored and B is factored as -* L*L**T. -* -* N (input) INTEGER -* The order of the matrices A and B. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* N-by-N upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the transformed matrix, stored in the -* same format as A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* B (input) DOUBLE PRECISION array, dimension (LDB,N) -* The triangular factor from the Cholesky factorization of B, -* as returned by DPOTRF. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, HALF - PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER K, KB, NB -* .. -* .. External Subroutines .. - EXTERNAL DSYGS2, DSYMM, DSYR2K, DTRMM, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYGST', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DSYGST', UPLO, N, -1, -1, -1 ) -* - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) - ELSE -* -* Use blocked code -* - IF( ITYPE.EQ.1 ) THEN - IF( UPPER ) THEN -* -* Compute inv(U')*A*inv(U) -* - DO 10 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the upper triangle of A(k:n,k:n) -* - CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - IF( K+KB.LE.N ) THEN - CALL DTRSM( 'Left', UPLO, 'Transpose', 'Non-unit', - $ KB, N-K-KB+1, ONE, B( K, K ), LDB, - $ A( K, K+KB ), LDA ) - CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, - $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, - $ A( K, K+KB ), LDA ) - CALL DSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE, - $ A( K, K+KB ), LDA, B( K, K+KB ), LDB, - $ ONE, A( K+KB, K+KB ), LDA ) - CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, - $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, - $ A( K, K+KB ), LDA ) - CALL DTRSM( 'Right', UPLO, 'No transpose', - $ 'Non-unit', KB, N-K-KB+1, ONE, - $ B( K+KB, K+KB ), LDB, A( K, K+KB ), - $ LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute inv(L)*A*inv(L') -* - DO 20 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the lower triangle of A(k:n,k:n) -* - CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - IF( K+KB.LE.N ) THEN - CALL DTRSM( 'Right', UPLO, 'Transpose', 'Non-unit', - $ N-K-KB+1, KB, ONE, B( K, K ), LDB, - $ A( K+KB, K ), LDA ) - CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, - $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, - $ A( K+KB, K ), LDA ) - CALL DSYR2K( UPLO, 'No transpose', N-K-KB+1, KB, - $ -ONE, A( K+KB, K ), LDA, B( K+KB, K ), - $ LDB, ONE, A( K+KB, K+KB ), LDA ) - CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, - $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, - $ A( K+KB, K ), LDA ) - CALL DTRSM( 'Left', UPLO, 'No transpose', - $ 'Non-unit', N-K-KB+1, KB, ONE, - $ B( K+KB, K+KB ), LDB, A( K+KB, K ), - $ LDA ) - END IF - 20 CONTINUE - END IF - ELSE - IF( UPPER ) THEN -* -* Compute U*A*U' -* - DO 30 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) -* - CALL DTRMM( 'Left', UPLO, 'No transpose', 'Non-unit', - $ K-1, KB, ONE, B, LDB, A( 1, K ), LDA ) - CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), - $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) - CALL DSYR2K( UPLO, 'No transpose', K-1, KB, ONE, - $ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A, - $ LDA ) - CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), - $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) - CALL DTRMM( 'Right', UPLO, 'Transpose', 'Non-unit', - $ K-1, KB, ONE, B( K, K ), LDB, A( 1, K ), - $ LDA ) - CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - 30 CONTINUE - ELSE -* -* Compute L'*A*L -* - DO 40 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) -* - CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', - $ KB, K-1, ONE, B, LDB, A( K, 1 ), LDA ) - CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), - $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) - CALL DSYR2K( UPLO, 'Transpose', K-1, KB, ONE, - $ A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A, - $ LDA ) - CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), - $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) - CALL DTRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB, - $ K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA ) - CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - 40 CONTINUE - END IF - END IF - END IF - RETURN -* -* End of DSYGST -* - END - SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, ITYPE, LDA, LDB, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DSYGS2 reduces a real symmetric-definite generalized eigenproblem -* to standard form. -* -* If ITYPE = 1, the problem is A*x = lambda*B*x, -* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') -* -* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or -* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. -* -* B must have been previously factorized as U'*U or L*L' by DPOTRF. -* -* Arguments -* ========= -* -* ITYPE (input) INTEGER -* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); -* = 2 or 3: compute U*A*U' or L'*A*L. -* -* UPLO (input) CHARACTER -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored, and how B has been factorized. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrices A and B. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* n by n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the transformed matrix, stored in the -* same format as A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* B (input) DOUBLE PRECISION array, dimension (LDB,N) -* The triangular factor from the Cholesky factorization of B, -* as returned by DPOTRF. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, HALF - PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER K - DOUBLE PRECISION AKK, BKK, CT -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DSCAL, DSYR2, DTRMV, DTRSV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYGS2', -INFO ) - RETURN - END IF -* - IF( ITYPE.EQ.1 ) THEN - IF( UPPER ) THEN -* -* Compute inv(U')*A*inv(U) -* - DO 10 K = 1, N -* -* Update the upper triangle of A(k:n,k:n) -* - AKK = A( K, K ) - BKK = B( K, K ) - AKK = AKK / BKK**2 - A( K, K ) = AKK - IF( K.LT.N ) THEN - CALL DSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA ) - CT = -HALF*AKK - CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), - $ LDA ) - CALL DSYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA, - $ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA ) - CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), - $ LDA ) - CALL DTRSV( UPLO, 'Transpose', 'Non-unit', N-K, - $ B( K+1, K+1 ), LDB, A( K, K+1 ), LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute inv(L)*A*inv(L') -* - DO 20 K = 1, N -* -* Update the lower triangle of A(k:n,k:n) -* - AKK = A( K, K ) - BKK = B( K, K ) - AKK = AKK / BKK**2 - A( K, K ) = AKK - IF( K.LT.N ) THEN - CALL DSCAL( N-K, ONE / BKK, A( K+1, K ), 1 ) - CT = -HALF*AKK - CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) - CALL DSYR2( UPLO, N-K, -ONE, A( K+1, K ), 1, - $ B( K+1, K ), 1, A( K+1, K+1 ), LDA ) - CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) - CALL DTRSV( UPLO, 'No transpose', 'Non-unit', N-K, - $ B( K+1, K+1 ), LDB, A( K+1, K ), 1 ) - END IF - 20 CONTINUE - END IF - ELSE - IF( UPPER ) THEN -* -* Compute U*A*U' -* - DO 30 K = 1, N -* -* Update the upper triangle of A(1:k,1:k) -* - AKK = A( K, K ) - BKK = B( K, K ) - CALL DTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B, - $ LDB, A( 1, K ), 1 ) - CT = HALF*AKK - CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) - CALL DSYR2( UPLO, K-1, ONE, A( 1, K ), 1, B( 1, K ), 1, - $ A, LDA ) - CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) - CALL DSCAL( K-1, BKK, A( 1, K ), 1 ) - A( K, K ) = AKK*BKK**2 - 30 CONTINUE - ELSE -* -* Compute L'*A*L -* - DO 40 K = 1, N -* -* Update the lower triangle of A(1:k,1:k) -* - AKK = A( K, K ) - BKK = B( K, K ) - CALL DTRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB, - $ A( K, 1 ), LDA ) - CT = HALF*AKK - CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) - CALL DSYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ), - $ LDB, A, LDA ) - CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) - CALL DSCAL( K-1, BKK, A( K, 1 ), LDA ) - A( K, K ) = AKK*BKK**2 - 40 CONTINUE - END IF - END IF - RETURN -* -* End of DSYGS2 -* - END - SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, - $ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, - $ LWORK, IWORK, IFAIL, INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER JOBZ, RANGE, UPLO - INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N - DOUBLE PRECISION ABSTOL, VL, VU -* .. -* .. Array Arguments .. - INTEGER IFAIL( * ), IWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ), - $ Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* DSYGVX computes selected eigenvalues, and optionally, eigenvectors -* of a real generalized symmetric-definite eigenproblem, of the form -* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A -* and B are assumed to be symmetric and B is also positive definite. -* Eigenvalues and eigenvectors can be selected by specifying either a -* range of values or a range of indices for the desired eigenvalues. -* -* Arguments -* ========= -* -* ITYPE (input) INTEGER -* Specifies the problem type to be solved: -* = 1: A*x = (lambda)*B*x -* = 2: A*B*x = (lambda)*x -* = 3: B*A*x = (lambda)*x -* -* JOBZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only; -* = 'V': Compute eigenvalues and eigenvectors. -* -* RANGE (input) CHARACTER*1 -* = 'A': all eigenvalues will be found. -* = 'V': all eigenvalues in the half-open interval (VL,VU] -* will be found. -* = 'I': the IL-th through IU-th eigenvalues will be found. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A and B are stored; -* = 'L': Lower triangle of A and B are stored. -* -* N (input) INTEGER -* The order of the matrix pencil (A,B). N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) -* On entry, the symmetric matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of A contains the -* upper triangular part of the matrix A. If UPLO = 'L', -* the leading N-by-N lower triangular part of A contains -* the lower triangular part of the matrix A. -* -* On exit, the lower triangle (if UPLO='L') or the upper -* triangle (if UPLO='U') of A, including the diagonal, is -* destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDA, N) -* On entry, the symmetric matrix B. If UPLO = 'U', the -* leading N-by-N upper triangular part of B contains the -* upper triangular part of the matrix B. If UPLO = 'L', -* the leading N-by-N lower triangular part of B contains -* the lower triangular part of the matrix B. -* -* On exit, if INFO <= N, the part of B containing the matrix is -* overwritten by the triangular factor U or L from the Cholesky -* factorization B = U**T*U or B = L*L**T. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* VL (input) DOUBLE PRECISION -* VU (input) DOUBLE PRECISION -* If RANGE='V', the lower and upper bounds of the interval to -* be searched for eigenvalues. VL < VU. -* Not referenced if RANGE = 'A' or 'I'. -* -* IL (input) INTEGER -* IU (input) INTEGER -* If RANGE='I', the indices (in ascending order) of the -* smallest and largest eigenvalues to be returned. -* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. -* Not referenced if RANGE = 'A' or 'V'. -* -* ABSTOL (input) DOUBLE PRECISION -* The absolute error tolerance for the eigenvalues. -* An approximate eigenvalue is accepted as converged -* when it is determined to lie in an interval [a,b] -* of width less than or equal to -* -* ABSTOL + EPS * max( |a|,|b| ) , -* -* where EPS is the machine precision. If ABSTOL is less than -* or equal to zero, then EPS*|T| will be used in its place, -* where |T| is the 1-norm of the tridiagonal matrix obtained -* by reducing A to tridiagonal form. -* -* Eigenvalues will be computed most accurately when ABSTOL is -* set to twice the underflow threshold 2*DLAMCH('S'), not zero. -* If this routine returns with INFO>0, indicating that some -* eigenvectors did not converge, try setting ABSTOL to -* 2*DLAMCH('S'). -* -* M (output) INTEGER -* The total number of eigenvalues found. 0 <= M <= N. -* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. -* -* W (output) DOUBLE PRECISION array, dimension (N) -* On normal exit, the first M elements contain the selected -* eigenvalues in ascending order. -* -* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) -* If JOBZ = 'N', then Z is not referenced. -* If JOBZ = 'V', then if INFO = 0, the first M columns of Z -* contain the orthonormal eigenvectors of the matrix A -* corresponding to the selected eigenvalues, with the i-th -* column of Z holding the eigenvector associated with W(i). -* The eigenvectors are normalized as follows: -* if ITYPE = 1 or 2, Z**T*B*Z = I; -* if ITYPE = 3, Z**T*inv(B)*Z = I. -* -* If an eigenvector fails to converge, then that column of Z -* contains the latest approximation to the eigenvector, and the -* index of the eigenvector is returned in IFAIL. -* Note: the user must ensure that at least max(1,M) columns are -* supplied in the array Z; if RANGE = 'V', the exact value of M -* is not known in advance and an upper bound must be used. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= 1, and if -* JOBZ = 'V', LDZ >= max(1,N). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The length of the array WORK. LWORK >= max(1,8*N). -* For optimal efficiency, LWORK >= (NB+3)*N, -* where NB is the blocksize for DSYTRD returned by ILAENV. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* IWORK (workspace) INTEGER array, dimension (5*N) -* -* IFAIL (output) INTEGER array, dimension (N) -* If JOBZ = 'V', then if INFO = 0, the first M elements of -* IFAIL are zero. If INFO > 0, then IFAIL contains the -* indices of the eigenvectors that failed to converge. -* If JOBZ = 'N', then IFAIL is not referenced. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: DPOTRF or DSYEVX returned an error code: -* <= N: if INFO = i, DSYEVX failed to converge; -* i eigenvectors failed to converge. Their indices -* are stored in array IFAIL. -* > N: if INFO = N + i, for 1 <= i <= N, then the leading -* minor of order i of B is not positive definite. -* The factorization of B could not be completed and -* no eigenvalues or eigenvectors were computed. -* -* Further Details -* =============== -* -* Based on contributions by -* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ - CHARACTER TRANS - INTEGER LOPT, LWKOPT, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DPOTRF, DSYEVX, DSYGST, DTRMM, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - UPPER = LSAME( UPLO, 'U' ) - WANTZ = LSAME( JOBZ, 'V' ) - ALLEIG = LSAME( RANGE, 'A' ) - VALEIG = LSAME( RANGE, 'V' ) - INDEIG = LSAME( RANGE, 'I' ) - LQUERY = ( LWORK.EQ.-1 ) -* - INFO = 0 - IF( ITYPE.LT.0 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN - INFO = -3 - ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( VALEIG .AND. N.GT.0 ) THEN - IF( VU.LE.VL ) - $ INFO = -11 - ELSE IF( INDEIG .AND. IL.LT.1 ) THEN - INFO = -12 - ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN - INFO = -13 - ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN - INFO = -18 - ELSE IF( LWORK.LT.MAX( 1, 8*N ) .AND. .NOT.LQUERY ) THEN - INFO = -20 - END IF -* - IF( INFO.EQ.0 ) THEN - NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) - LWKOPT = ( NB+3 )*N - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYGVX', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - M = 0 - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Form a Cholesky factorization of B. -* - CALL DPOTRF( UPLO, N, B, LDB, INFO ) - IF( INFO.NE.0 ) THEN - INFO = N + INFO - RETURN - END IF -* -* Transform problem to standard eigenvalue problem and solve. -* - CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) - CALL DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, - $ M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO ) - LOPT = WORK( 1 ) -* - IF( WANTZ ) THEN -* -* Backtransform eigenvectors to the original problem. -* - IF( INFO.GT.0 ) - $ M = INFO - 1 - IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN -* -* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; -* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y -* - IF( UPPER ) THEN - TRANS = 'N' - ELSE - TRANS = 'T' - END IF -* - CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B, - $ LDB, Z, LDZ ) -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* For B*A*x=(lambda)*x; -* backtransform eigenvectors: x = L*y or U'*y -* - IF( UPPER ) THEN - TRANS = 'T' - ELSE - TRANS = 'N' - END IF -* - CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B, - $ LDB, Z, LDZ ) - END IF - END IF -* -* Set WORK(1) to optimal workspace size. -* - WORK( 1 ) = LWKOPT -* - RETURN -* -* End of DSYGVX -* - END - SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, - $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, - $ IFAIL, INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER JOBZ, RANGE, UPLO - INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N - DOUBLE PRECISION ABSTOL, VL, VU -* .. -* .. Array Arguments .. - INTEGER IFAIL( * ), IWORK( * ) - DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* DSYEVX computes selected eigenvalues and, optionally, eigenvectors -* of a real symmetric matrix A. Eigenvalues and eigenvectors can be -* selected by specifying either a range of values or a range of indices -* for the desired eigenvalues. -* -* Arguments -* ========= -* -* JOBZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only; -* = 'V': Compute eigenvalues and eigenvectors. -* -* RANGE (input) CHARACTER*1 -* = 'A': all eigenvalues will be found. -* = 'V': all eigenvalues in the half-open interval (VL,VU] -* will be found. -* = 'I': the IL-th through IU-th eigenvalues will be found. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) -* On entry, the symmetric matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of A contains the -* upper triangular part of the matrix A. If UPLO = 'L', -* the leading N-by-N lower triangular part of A contains -* the lower triangular part of the matrix A. -* On exit, the lower triangle (if UPLO='L') or the upper -* triangle (if UPLO='U') of A, including the diagonal, is -* destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* VL (input) DOUBLE PRECISION -* VU (input) DOUBLE PRECISION -* If RANGE='V', the lower and upper bounds of the interval to -* be searched for eigenvalues. VL < VU. -* Not referenced if RANGE = 'A' or 'I'. -* -* IL (input) INTEGER -* IU (input) INTEGER -* If RANGE='I', the indices (in ascending order) of the -* smallest and largest eigenvalues to be returned. -* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. -* Not referenced if RANGE = 'A' or 'V'. -* -* ABSTOL (input) DOUBLE PRECISION -* The absolute error tolerance for the eigenvalues. -* An approximate eigenvalue is accepted as converged -* when it is determined to lie in an interval [a,b] -* of width less than or equal to -* -* ABSTOL + EPS * max( |a|,|b| ) , -* -* where EPS is the machine precision. If ABSTOL is less than -* or equal to zero, then EPS*|T| will be used in its place, -* where |T| is the 1-norm of the tridiagonal matrix obtained -* by reducing A to tridiagonal form. -* -* Eigenvalues will be computed most accurately when ABSTOL is -* set to twice the underflow threshold 2*DLAMCH('S'), not zero. -* If this routine returns with INFO>0, indicating that some -* eigenvectors did not converge, try setting ABSTOL to -* 2*DLAMCH('S'). -* -* See "Computing Small Singular Values of Bidiagonal Matrices -* with Guaranteed High Relative Accuracy," by Demmel and -* Kahan, LAPACK Working Note #3. -* -* M (output) INTEGER -* The total number of eigenvalues found. 0 <= M <= N. -* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. -* -* W (output) DOUBLE PRECISION array, dimension (N) -* On normal exit, the first M elements contain the selected -* eigenvalues in ascending order. -* -* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) -* If JOBZ = 'V', then if INFO = 0, the first M columns of Z -* contain the orthonormal eigenvectors of the matrix A -* corresponding to the selected eigenvalues, with the i-th -* column of Z holding the eigenvector associated with W(i). -* If an eigenvector fails to converge, then that column of Z -* contains the latest approximation to the eigenvector, and the -* index of the eigenvector is returned in IFAIL. -* If JOBZ = 'N', then Z is not referenced. -* Note: the user must ensure that at least max(1,M) columns are -* supplied in the array Z; if RANGE = 'V', the exact value of M -* is not known in advance and an upper bound must be used. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= 1, and if -* JOBZ = 'V', LDZ >= max(1,N). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The length of the array WORK. LWORK >= max(1,8*N). -* For optimal efficiency, LWORK >= (NB+3)*N, -* where NB is the max of the blocksize for DSYTRD and DORMTR -* returned by ILAENV. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* IWORK (workspace) INTEGER array, dimension (5*N) -* -* IFAIL (output) INTEGER array, dimension (N) -* If JOBZ = 'V', then if INFO = 0, the first M elements of -* IFAIL are zero. If INFO > 0, then IFAIL contains the -* indices of the eigenvectors that failed to converge. -* If JOBZ = 'N', then IFAIL is not referenced. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, then i eigenvectors failed to converge. -* Their indices are stored in array IFAIL. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ - CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, - $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, - $ ITMP1, J, JJ, LLWORK, LLWRKN, LOPT, LWKOPT, NB, - $ NSPLIT - DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, - $ SIGMA, SMLNUM, TMP1, VLL, VUU -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ, - $ DSTEIN, DSTEQR, DSTERF, DSWAP, DSYTRD, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LOWER = LSAME( UPLO, 'L' ) - WANTZ = LSAME( JOBZ, 'V' ) - ALLEIG = LSAME( RANGE, 'A' ) - VALEIG = LSAME( RANGE, 'V' ) - INDEIG = LSAME( RANGE, 'I' ) - LQUERY = ( LWORK.EQ.-1 ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN - INFO = -2 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE - IF( VALEIG ) THEN - IF( N.GT.0 .AND. VU.LE.VL ) - $ INFO = -8 - ELSE IF( INDEIG ) THEN - IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN - INFO = -10 - END IF - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN - INFO = -15 - ELSE IF( LWORK.LT.MAX( 1, 8*N ) .AND. .NOT.LQUERY ) THEN - INFO = -17 - END IF - END IF -* - IF( INFO.EQ.0 ) THEN - NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) - NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) ) - LWKOPT = ( NB+3 )*N - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYEVX', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - M = 0 - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( N.EQ.1 ) THEN - WORK( 1 ) = 7 - IF( ALLEIG .OR. INDEIG ) THEN - M = 1 - W( 1 ) = A( 1, 1 ) - ELSE - IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN - M = 1 - W( 1 ) = A( 1, 1 ) - END IF - END IF - IF( WANTZ ) - $ Z( 1, 1 ) = ONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) -* -* Scale matrix to allowable range, if necessary. -* - ISCALE = 0 - ABSTLL = ABSTOL - VLL = VL - VUU = VU - ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) THEN - IF( LOWER ) THEN - DO 10 J = 1, N - CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) - 10 CONTINUE - ELSE - DO 20 J = 1, N - CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) - 20 CONTINUE - END IF - IF( ABSTOL.GT.0 ) - $ ABSTLL = ABSTOL*SIGMA - IF( VALEIG ) THEN - VLL = VL*SIGMA - VUU = VU*SIGMA - END IF - END IF -* -* Call DSYTRD to reduce symmetric matrix to tridiagonal form. -* - INDTAU = 1 - INDE = INDTAU + N - INDD = INDE + N - INDWRK = INDD + N - LLWORK = LWORK - INDWRK + 1 - CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ), - $ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO ) - LOPT = 3*N + WORK( INDWRK ) -* -* If all eigenvalues are desired and ABSTOL is less than or equal to -* zero, then call DSTERF or DORGTR and SSTEQR. If this fails for -* some eigenvalue, then try DSTEBZ. -* - IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. - $ ( ABSTOL.LE.ZERO ) ) THEN - CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) - INDEE = INDWRK + 2*N - IF( .NOT.WANTZ ) THEN - CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) - CALL DSTERF( N, W, WORK( INDEE ), INFO ) - ELSE - CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ ) - CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), - $ WORK( INDWRK ), LLWORK, IINFO ) - CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) - CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, - $ WORK( INDWRK ), INFO ) - IF( INFO.EQ.0 ) THEN - DO 30 I = 1, N - IFAIL( I ) = 0 - 30 CONTINUE - END IF - END IF - IF( INFO.EQ.0 ) THEN - M = N - GO TO 40 - END IF - INFO = 0 - END IF -* -* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. -* - IF( WANTZ ) THEN - ORDER = 'B' - ELSE - ORDER = 'E' - END IF - INDIBL = 1 - INDISP = INDIBL + N - INDIWO = INDISP + N - CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, - $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, - $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), - $ IWORK( INDIWO ), INFO ) -* - IF( WANTZ ) THEN - CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, - $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, - $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) -* -* Apply orthogonal matrix used in reduction to tridiagonal -* form to eigenvectors returned by DSTEIN. -* - INDWKN = INDE - LLWRKN = LWORK - INDWKN + 1 - CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, - $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - 40 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF -* -* If eigenvalues are not in order, then sort them, along with -* eigenvectors. -* - IF( WANTZ ) THEN - DO 60 J = 1, M - 1 - I = 0 - TMP1 = W( J ) - DO 50 JJ = J + 1, M - IF( W( JJ ).LT.TMP1 ) THEN - I = JJ - TMP1 = W( JJ ) - END IF - 50 CONTINUE -* - IF( I.NE.0 ) THEN - ITMP1 = IWORK( INDIBL+I-1 ) - W( I ) = W( J ) - IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) - W( J ) = TMP1 - IWORK( INDIBL+J-1 ) = ITMP1 - CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) - IF( INFO.NE.0 ) THEN - ITMP1 = IFAIL( I ) - IFAIL( I ) = IFAIL( J ) - IFAIL( J ) = ITMP1 - END IF - END IF - 60 CONTINUE - END IF -* -* Set WORK(1) to optimal workspace size. -* - WORK( 1 ) = LWKOPT -* - RETURN -* -* End of DSYEVX -* - END - SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DLACPY copies all or part of a two-dimensional matrix A to another -* matrix B. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies the part of the matrix A to be copied to B. -* = 'U': Upper triangular part -* = 'L': Lower triangular part -* Otherwise: All of the matrix A -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. If UPLO = 'U', only the upper triangle -* or trapezoid is accessed; if UPLO = 'L', only the lower -* triangle or trapezoid is accessed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* B (output) DOUBLE PRECISION array, dimension (LDB,N) -* On exit, B = A in the locations specified by UPLO. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,M). -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) - B( I, J ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE - ELSE IF( LSAME( UPLO, 'L' ) ) THEN - DO 40 J = 1, N - DO 30 I = J, M - B( I, J ) = A( I, J ) - 30 CONTINUE - 40 CONTINUE - ELSE - DO 60 J = 1, N - DO 50 I = 1, M - B( I, J ) = A( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF - RETURN -* -* End of DLACPY -* - END - SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, - $ IWORK, IFAIL, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDZ, M, N -* .. -* .. Array Arguments .. - INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), - $ IWORK( * ) - DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* DSTEIN computes the eigenvectors of a real symmetric tridiagonal -* matrix T corresponding to specified eigenvalues, using inverse -* iteration. -* -* The maximum number of iterations allowed for each eigenvector is -* specified by an internal parameter MAXITS (currently set to 5). -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix. N >= 0. -* -* D (input) DOUBLE PRECISION array, dimension (N) -* The n diagonal elements of the tridiagonal matrix T. -* -* E (input) DOUBLE PRECISION array, dimension (N) -* The (n-1) subdiagonal elements of the tridiagonal matrix -* T, in elements 1 to N-1. E(N) need not be set. -* -* M (input) INTEGER -* The number of eigenvectors to be found. 0 <= M <= N. -* -* W (input) DOUBLE PRECISION array, dimension (N) -* The first M elements of W contain the eigenvalues for -* which eigenvectors are to be computed. The eigenvalues -* should be grouped by split-off block and ordered from -* smallest to largest within the block. ( The output array -* W from DSTEBZ with ORDER = 'B' is expected here. ) -* -* IBLOCK (input) INTEGER array, dimension (N) -* The submatrix indices associated with the corresponding -* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to -* the first submatrix from the top, =2 if W(i) belongs to -* the second submatrix, etc. ( The output array IBLOCK -* from DSTEBZ is expected here. ) -* -* ISPLIT (input) INTEGER array, dimension (N) -* The splitting points, at which T breaks up into submatrices. -* The first submatrix consists of rows/columns 1 to -* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 -* through ISPLIT( 2 ), etc. -* ( The output array ISPLIT from DSTEBZ is expected here. ) -* -* Z (output) DOUBLE PRECISION array, dimension (LDZ, M) -* The computed eigenvectors. The eigenvector associated -* with the eigenvalue W(i) is stored in the i-th column of -* Z. Any vector which fails to converge is set to its current -* iterate after MAXITS iterations. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= max(1,N). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (5*N) -* -* IWORK (workspace) INTEGER array, dimension (N) -* -* IFAIL (output) INTEGER array, dimension (M) -* On normal exit, all elements of IFAIL are zero. -* If one or more eigenvectors fail to converge after -* MAXITS iterations, then their indices are stored in -* array IFAIL. -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, then i eigenvectors failed to converge -* in MAXITS iterations. Their indices are stored in -* array IFAIL. -* -* Internal Parameters -* =================== -* -* MAXITS INTEGER, default = 5 -* The maximum number of iterations performed. -* -* EXTRA INTEGER, default = 2 -* The number of iterations performed after norm growth -* criterion is satisfied, should be at least 1. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1, - $ ODM3 = 1.0D-3, ODM1 = 1.0D-1 ) - INTEGER MAXITS, EXTRA - PARAMETER ( MAXITS = 5, EXTRA = 2 ) -* .. -* .. Local Scalars .. - INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1, - $ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1, - $ JBLK, JMAX, NBLK, NRMCHK - DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL, - $ SCL, SEP, TOL, XJ, XJM, ZTR -* .. -* .. Local Arrays .. - INTEGER ISEED( 4 ) -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DASUM, DDOT, DLAMCH, DNRM2 - EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DNRM2 -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, - $ XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - DO 10 I = 1, M - IFAIL( I ) = 0 - 10 CONTINUE -* - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 .OR. M.GT.N ) THEN - INFO = -4 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE - DO 20 J = 2, M - IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN - INFO = -6 - GO TO 30 - END IF - IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) - $ THEN - INFO = -5 - GO TO 30 - END IF - 20 CONTINUE - 30 CONTINUE - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSTEIN', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. M.EQ.0 ) THEN - RETURN - ELSE IF( N.EQ.1 ) THEN - Z( 1, 1 ) = ONE - RETURN - END IF -* -* Get machine constants. -* - EPS = DLAMCH( 'Precision' ) -* -* Initialize seed for random number generator DLARNV. -* - DO 40 I = 1, 4 - ISEED( I ) = 1 - 40 CONTINUE -* -* Initialize pointers. -* - INDRV1 = 0 - INDRV2 = INDRV1 + N - INDRV3 = INDRV2 + N - INDRV4 = INDRV3 + N - INDRV5 = INDRV4 + N -* -* Compute eigenvectors of matrix blocks. -* - J1 = 1 - DO 160 NBLK = 1, IBLOCK( M ) -* -* Find starting and ending indices of block nblk. -* - IF( NBLK.EQ.1 ) THEN - B1 = 1 - ELSE - B1 = ISPLIT( NBLK-1 ) + 1 - END IF - BN = ISPLIT( NBLK ) - BLKSIZ = BN - B1 + 1 - IF( BLKSIZ.EQ.1 ) - $ GO TO 60 - GPIND = B1 -* -* Compute reorthogonalization criterion and stopping criterion. -* - ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) ) - ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) ) - DO 50 I = B1 + 1, BN - 1 - ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+ - $ ABS( E( I ) ) ) - 50 CONTINUE - ORTOL = ODM3*ONENRM -* - DTPCRT = SQRT( ODM1 / BLKSIZ ) -* -* Loop through eigenvalues of block nblk. -* - 60 CONTINUE - JBLK = 0 - DO 150 J = J1, M - IF( IBLOCK( J ).NE.NBLK ) THEN - J1 = J - GO TO 160 - END IF - JBLK = JBLK + 1 - XJ = W( J ) -* -* Skip all the work if the block size is one. -* - IF( BLKSIZ.EQ.1 ) THEN - WORK( INDRV1+1 ) = ONE - GO TO 120 - END IF -* -* If eigenvalues j and j-1 are too close, add a relatively -* small perturbation. -* - IF( JBLK.GT.1 ) THEN - EPS1 = ABS( EPS*XJ ) - PERTOL = TEN*EPS1 - SEP = XJ - XJM - IF( SEP.LT.PERTOL ) - $ XJ = XJM + PERTOL - END IF -* - ITS = 0 - NRMCHK = 0 -* -* Get random starting vector. -* - CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) ) -* -* Copy the matrix T so it won't be destroyed in factorization. -* - CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 ) - CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 ) - CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 ) -* -* Compute LU factors with partial pivoting ( PT = LU ) -* - TOL = ZERO - CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), - $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, - $ IINFO ) -* -* Update iteration count. -* - 70 CONTINUE - ITS = ITS + 1 - IF( ITS.GT.MAXITS ) - $ GO TO 100 -* -* Normalize and scale the righthand side vector Pb. -* - SCL = BLKSIZ*ONENRM*MAX( EPS, - $ ABS( WORK( INDRV4+BLKSIZ ) ) ) / - $ DASUM( BLKSIZ, WORK( INDRV1+1 ), 1 ) - CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) -* -* Solve the system LU = Pb. -* - CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), - $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, - $ WORK( INDRV1+1 ), TOL, IINFO ) -* -* Reorthogonalize by modified Gram-Schmidt if eigenvalues are -* close enough. -* - IF( JBLK.EQ.1 ) - $ GO TO 90 - IF( ABS( XJ-XJM ).GT.ORTOL ) - $ GPIND = J - IF( GPIND.NE.J ) THEN - DO 80 I = GPIND, J - 1 - ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ), - $ 1 ) - CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1, - $ WORK( INDRV1+1 ), 1 ) - 80 CONTINUE - END IF -* -* Check the infinity norm of the iterate. -* - 90 CONTINUE - JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) - NRM = ABS( WORK( INDRV1+JMAX ) ) -* -* Continue for additional iterations after norm reaches -* stopping criterion. -* - IF( NRM.LT.DTPCRT ) - $ GO TO 70 - NRMCHK = NRMCHK + 1 - IF( NRMCHK.LT.EXTRA+1 ) - $ GO TO 70 -* - GO TO 110 -* -* If stopping criterion was not satisfied, update info and -* store eigenvector number in array ifail. -* - 100 CONTINUE - INFO = INFO + 1 - IFAIL( INFO ) = J -* -* Accept iterate as jth eigenvector. -* - 110 CONTINUE - SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 ) - JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) - IF( WORK( INDRV1+JMAX ).LT.ZERO ) - $ SCL = -SCL - CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) - 120 CONTINUE - DO 130 I = 1, N - Z( I, J ) = ZERO - 130 CONTINUE - DO 140 I = 1, BLKSIZ - Z( B1+I-1, J ) = WORK( INDRV1+I ) - 140 CONTINUE -* -* Save the shift to check eigenvalue spacing at next -* iteration. -* - XJM = XJ -* - 150 CONTINUE - 160 CONTINUE -* - RETURN -* -* End of DSTEIN -* - END - SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORMTR overwrites the general real M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**T -* -* where Q is a real orthogonal matrix of order nq, with nq = m if -* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of -* nq-1 elementary reflectors, as returned by DSYTRD: -* -* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); -* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**T from the Left; -* = 'R': apply Q or Q**T from the Right. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A contains elementary reflectors -* from DSYTRD; -* = 'L': Lower triangle of A contains elementary reflectors -* from DSYTRD. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'T': Transpose, apply Q**T. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* A (input) DOUBLE PRECISION array, dimension -* (LDA,M) if SIDE = 'L' -* (LDA,N) if SIDE = 'R' -* The vectors which define the elementary reflectors, as -* returned by DSYTRD. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. -* -* TAU (input) DOUBLE PRECISION array, dimension -* (M-1) if SIDE = 'L' -* (N-1) if SIDE = 'R' -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DSYTRD. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, UPPER - INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DORMQL, DORMQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) - $ THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( UPPER ) THEN - IF( LEFT ) THEN - NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - ELSE - IF( LEFT ) THEN - NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - END IF - LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMTR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - ELSE - MI = M - NI = N - 1 - END IF -* - IF( UPPER ) THEN -* -* Q was determined by a call to DSYTRD with UPLO = 'U' -* - CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, - $ LDC, WORK, LWORK, IINFO ) - ELSE -* -* Q was determined by a call to DSYTRD with UPLO = 'L' -* - IF( LEFT ) THEN - I1 = 2 - I2 = 1 - ELSE - I1 = 1 - I2 = 2 - END IF - CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, - $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMTR -* - END - SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORMQR overwrites the general real M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**T -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**T from the Left; -* = 'R': apply Q or Q**T from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'T': Transpose, apply Q**T. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGEQRF in the first k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), T, LDT ) - IF( LEFT ) THEN -* -* H or H' is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H' is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H' -* - CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, - $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, - $ WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMQR -* - END - SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORMQL overwrites the general real M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**T -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**T from the Left; -* = 'R': apply Q or Q**T from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'T': Transpose, apply Q**T. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGEQLF in the last k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQLF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT, - $ MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORM2L, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMQL', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IF( ( LEFT .AND. NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - ELSE - MI = M - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i+ib-1) . . . H(i+1) H(i) -* - CALL DLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB, - $ A( 1, I ), LDA, TAU( I ), T, LDT ) - IF( LEFT ) THEN -* -* H or H' is applied to C(1:m-k+i+ib-1,1:n) -* - MI = M - K + I + IB - 1 - ELSE -* -* H or H' is applied to C(1:m,1:n-k+i+ib-1) -* - NI = N - K + I + IB - 1 - END IF -* -* Apply H or H' -* - CALL DLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, - $ IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK, - $ LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMQL -* - END - SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORM2L overwrites the general real m by n matrix C with -* -* Q * C if SIDE = 'L' and TRANS = 'N', or -* -* Q'* C if SIDE = 'L' and TRANS = 'T', or -* -* C * Q if SIDE = 'R' and TRANS = 'N', or -* -* C * Q' if SIDE = 'R' and TRANS = 'T', -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q' from the Left -* = 'R': apply Q or Q' from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply Q (No transpose) -* = 'T': apply Q' (Transpose) -* -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGEQLF in the last k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQLF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L', -* (M) if SIDE = 'R' -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORM2L', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - ELSE - MI = M - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(1:m-k+i,1:n) -* - MI = M - K + I - ELSE -* -* H(i) is applied to C(1:m,1:n-k+i) -* - NI = N - K + I - END IF -* -* Apply H(i) -* - AII = A( NQ-K+I, I ) - A( NQ-K+I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC, - $ WORK ) - A( NQ-K+I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORM2L -* - END - SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORM2R overwrites the general real m by n matrix C with -* -* Q * C if SIDE = 'L' and TRANS = 'N', or -* -* Q'* C if SIDE = 'L' and TRANS = 'T', or -* -* C * Q if SIDE = 'R' and TRANS = 'N', or -* -* C * Q' if SIDE = 'R' and TRANS = 'T', -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q' from the Left -* = 'R': apply Q or Q' from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply Q (No transpose) -* = 'T': apply Q' (Transpose) -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGEQRF in the first k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L', -* (M) if SIDE = 'R' -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORM2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), - $ LDC, WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORM2R -* - END - SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, - $ WORK, LWORK, RWORK, INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 -* -* .. Scalar Arguments .. - CHARACTER JOBU, JOBVT - INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION RWORK( * ), S( * ) - COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ), - $ WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZGESVD computes the singular value decomposition (SVD) of a complex -* M-by-N matrix A, optionally computing the left and/or right singular -* vectors. The SVD is written -* -* A = U * SIGMA * conjugate-transpose(V) -* -* where SIGMA is an M-by-N matrix which is zero except for its -* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and -* V is an N-by-N unitary matrix. The diagonal elements of SIGMA -* are the singular values of A; they are real and non-negative, and -* are returned in descending order. The first min(m,n) columns of -* U and V are the left and right singular vectors of A. -* -* Note that the routine returns V**H, not V. -* -* Arguments -* ========= -* -* JOBU (input) CHARACTER*1 -* Specifies options for computing all or part of the matrix U: -* = 'A': all M columns of U are returned in array U: -* = 'S': the first min(m,n) columns of U (the left singular -* vectors) are returned in the array U; -* = 'O': the first min(m,n) columns of U (the left singular -* vectors) are overwritten on the array A; -* = 'N': no columns of U (no left singular vectors) are -* computed. -* -* JOBVT (input) CHARACTER*1 -* Specifies options for computing all or part of the matrix -* V**H: -* = 'A': all N rows of V**H are returned in the array VT; -* = 'S': the first min(m,n) rows of V**H (the right singular -* vectors) are returned in the array VT; -* = 'O': the first min(m,n) rows of V**H (the right singular -* vectors) are overwritten on the array A; -* = 'N': no rows of V**H (no right singular vectors) are -* computed. -* -* JOBVT and JOBU cannot both be 'O'. -* -* M (input) INTEGER -* The number of rows of the input matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the input matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the M-by-N matrix A. -* On exit, -* if JOBU = 'O', A is overwritten with the first min(m,n) -* columns of U (the left singular vectors, -* stored columnwise); -* if JOBVT = 'O', A is overwritten with the first min(m,n) -* rows of V**H (the right singular vectors, -* stored rowwise); -* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A -* are destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* S (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The singular values of A, sorted so that S(i) >= S(i+1). -* -* U (output) COMPLEX*16 array, dimension (LDU,UCOL) -* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. -* If JOBU = 'A', U contains the M-by-M unitary matrix U; -* if JOBU = 'S', U contains the first min(m,n) columns of U -* (the left singular vectors, stored columnwise); -* if JOBU = 'N' or 'O', U is not referenced. -* -* LDU (input) INTEGER -* The leading dimension of the array U. LDU >= 1; if -* JOBU = 'S' or 'A', LDU >= M. -* -* VT (output) COMPLEX*16 array, dimension (LDVT,N) -* If JOBVT = 'A', VT contains the N-by-N unitary matrix -* V**H; -* if JOBVT = 'S', VT contains the first min(m,n) rows of -* V**H (the right singular vectors, stored rowwise); -* if JOBVT = 'N' or 'O', VT is not referenced. -* -* LDVT (input) INTEGER -* The leading dimension of the array VT. LDVT >= 1; if -* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= 1. -* LWORK >= 2*MIN(M,N)+MAX(M,N). -* For good performance, LWORK should generally be larger. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N)) -* On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the -* unconverged superdiagonal elements of an upper bidiagonal -* matrix B whose diagonal is in S (not necessarily sorted). -* B satisfies A = U * B * VT, so it has the same singular -* values as A, and singular vectors related by U and VT. -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* > 0: if ZBDSQR did not converge, INFO specifies how many -* superdiagonals of an intermediate bidiagonal form B -* did not converge to zero. See the description of RWORK -* above for details. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 CZERO, CONE - PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), - $ CONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, - $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS - INTEGER BLK, CHUNK, I, IE, IERR, IR, IRWORK, ISCL, - $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, - $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, - $ NRVT, WRKBL - DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM -* .. -* .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ) - COMPLEX*16 CDUM( 1 ) -* .. -* .. External Subroutines .. - EXTERNAL DLASCL, XERBLA, ZBDSQR, ZGEBRD, ZGELQF, ZGEMM, - $ ZGEQRF, ZLACPY, ZLASCL, ZLASET, ZUNGBR, ZUNGLQ, - $ ZUNGQR, ZUNMBR -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - MINMN = MIN( M, N ) - MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) - WNTUA = LSAME( JOBU, 'A' ) - WNTUS = LSAME( JOBU, 'S' ) - WNTUAS = WNTUA .OR. WNTUS - WNTUO = LSAME( JOBU, 'O' ) - WNTUN = LSAME( JOBU, 'N' ) - WNTVA = LSAME( JOBVT, 'A' ) - WNTVS = LSAME( JOBVT, 'S' ) - WNTVAS = WNTVA .OR. WNTVS - WNTVO = LSAME( JOBVT, 'O' ) - WNTVN = LSAME( JOBVT, 'N' ) - MINWRK = 1 - LQUERY = ( LWORK.EQ.-1 ) -* - IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN - INFO = -1 - ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR. - $ ( WNTVO .AND. WNTUO ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN - INFO = -9 - ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR. - $ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN - INFO = -11 - END IF -* -* Compute workspace -* (Note: Comments in the code beginning "Workspace:" describe the -* minimal amount of workspace needed at that point in the code, -* as well as the preferred amount for good performance. -* CWorkspace refers to complex workspace, and RWorkspace to -* real workspace. NB refers to the optimal block size for the -* immediately following subroutine, as returned by ILAENV.) -* - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) .AND. M.GT.0 .AND. - $ N.GT.0 ) THEN - IF( M.GE.N ) THEN -* -* Space needed for ZBDSQR is BDSPAC = 5*N -* - IF( M.GE.MNTHR ) THEN - IF( WNTUN ) THEN -* -* Path 1 (M much larger than N, JOBU='N') -* - MAXWRK = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, - $ -1 ) - MAXWRK = MAX( MAXWRK, 2*N+2*N* - $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) - IF( WNTVO .OR. WNTVAS ) - $ MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) - MINWRK = 3*N - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTUO .AND. WNTVN ) THEN -* -* Path 2 (M much larger than N, JOBU='O', JOBVT='N') -* - WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) - MAXWRK = MAX( N*N+WRKBL, N*N+M*N ) - MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTUO .AND. WNTVAS ) THEN -* -* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or -* 'A') -* - WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+( N-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) - MAXWRK = MAX( N*N+WRKBL, N*N+M*N ) - MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTUS .AND. WNTVN ) THEN -* -* Path 4 (M much larger than N, JOBU='S', JOBVT='N') -* - WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) - MAXWRK = N*N + WRKBL - MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTUS .AND. WNTVO ) THEN -* -* Path 5 (M much larger than N, JOBU='S', JOBVT='O') -* - WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+( N-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) - MAXWRK = 2*N*N + WRKBL - MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTUS .AND. WNTVAS ) THEN -* -* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or -* 'A') -* - WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+( N-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) - MAXWRK = N*N + WRKBL - MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTUA .AND. WNTVN ) THEN -* -* Path 7 (M much larger than N, JOBU='A', JOBVT='N') -* - WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M, - $ M, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) - MAXWRK = N*N + WRKBL - MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTUA .AND. WNTVO ) THEN -* -* Path 8 (M much larger than N, JOBU='A', JOBVT='O') -* - WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M, - $ M, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+( N-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) - MAXWRK = 2*N*N + WRKBL - MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTUA .AND. WNTVAS ) THEN -* -* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or -* 'A') -* - WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M, - $ M, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+N* - $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 2*N+( N-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) - MAXWRK = N*N + WRKBL - MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) - END IF - ELSE -* -* Path 10 (M at least N, but not much larger) -* - MAXWRK = 2*N + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N, - $ -1, -1 ) - IF( WNTUS .OR. WNTUO ) - $ MAXWRK = MAX( MAXWRK, 2*N+N* - $ ILAENV( 1, 'ZUNGBR', 'Q', M, N, N, -1 ) ) - IF( WNTUA ) - $ MAXWRK = MAX( MAXWRK, 2*N+M* - $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) ) - IF( .NOT.WNTVN ) - $ MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) - MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) - END IF - ELSE -* -* Space needed for ZBDSQR is BDSPAC = 5*M -* - IF( N.GE.MNTHR ) THEN - IF( WNTVN ) THEN -* -* Path 1t(N much larger than M, JOBVT='N') -* - MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, - $ -1 ) - MAXWRK = MAX( MAXWRK, 2*M+2*M* - $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) - IF( WNTUO .OR. WNTUAS ) - $ MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) - MINWRK = 3*M - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTVO .AND. WNTUN ) THEN -* -* Path 2t(N much larger than M, JOBU='N', JOBVT='O') -* - WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+2*M* - $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+( M-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) - MAXWRK = MAX( M*M+WRKBL, M*M+M*N ) - MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTVO .AND. WNTUAS ) THEN -* -* Path 3t(N much larger than M, JOBU='S' or 'A', -* JOBVT='O') -* - WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+2*M* - $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+( M-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) - MAXWRK = MAX( M*M+WRKBL, M*M+M*N ) - MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTVS .AND. WNTUN ) THEN -* -* Path 4t(N much larger than M, JOBU='N', JOBVT='S') -* - WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+2*M* - $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+( M-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) - MAXWRK = M*M + WRKBL - MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTVS .AND. WNTUO ) THEN -* -* Path 5t(N much larger than M, JOBU='O', JOBVT='S') -* - WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+2*M* - $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+( M-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) - MAXWRK = 2*M*M + WRKBL - MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTVS .AND. WNTUAS ) THEN -* -* Path 6t(N much larger than M, JOBU='S' or 'A', -* JOBVT='S') -* - WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+2*M* - $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+( M-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) - MAXWRK = M*M + WRKBL - MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTVA .AND. WNTUN ) THEN -* -* Path 7t(N much larger than M, JOBU='N', JOBVT='A') -* - WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+2*M* - $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+( M-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) - MAXWRK = M*M + WRKBL - MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTVA .AND. WNTUO ) THEN -* -* Path 8t(N much larger than M, JOBU='O', JOBVT='A') -* - WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+2*M* - $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+( M-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) - MAXWRK = 2*M*M + WRKBL - MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) - ELSE IF( WNTVA .AND. WNTUAS ) THEN -* -* Path 9t(N much larger than M, JOBU='S' or 'A', -* JOBVT='A') -* - WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+2*M* - $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+( M-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) - MAXWRK = M*M + WRKBL - MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) - END IF - ELSE -* -* Path 10t(N greater than M, but not much larger) -* - MAXWRK = 2*M + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N, - $ -1, -1 ) - IF( WNTVS .OR. WNTVO ) - $ MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'P', M, N, M, -1 ) ) - IF( WNTVA ) - $ MAXWRK = MAX( MAXWRK, 2*M+N* - $ ILAENV( 1, 'ZUNGBR', 'P', N, N, M, -1 ) ) - IF( .NOT.WNTUN ) - $ MAXWRK = MAX( MAXWRK, 2*M+( M-1 )* - $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) - MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) - END IF - END IF - WORK( 1 ) = MAXWRK - END IF -* - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGESVD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - IF( LWORK.GE.1 ) - $ WORK( 1 ) = ONE - RETURN - END IF -* -* Get machine constants -* - EPS = DLAMCH( 'P' ) - SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS - BIGNUM = ONE / SMLNUM -* -* Scale A if max element outside range [SMLNUM,BIGNUM] -* - ANRM = ZLANGE( 'M', M, N, A, LDA, DUM ) - ISCL = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN - ISCL = 1 - CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR ) - ELSE IF( ANRM.GT.BIGNUM ) THEN - ISCL = 1 - CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR ) - END IF -* - IF( M.GE.N ) THEN -* -* A has at least as many rows as columns. If A has sufficiently -* more rows than columns, first reduce using the QR -* decomposition (if sufficient workspace available) -* - IF( M.GE.MNTHR ) THEN -* - IF( WNTUN ) THEN -* -* Path 1 (M much larger than N, JOBU='N') -* No left singular vectors to be computed -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: need 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Zero out below R -* - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ), - $ LDA ) - IE = 1 - ITAUQ = 1 - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in A -* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ IERR ) - NCVT = 0 - IF( WNTVO .OR. WNTVAS ) THEN -* -* If right singular vectors desired, generate P'. -* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - NCVT = N - END IF - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in A if desired -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, NCVT, 0, 0, S, RWORK( IE ), A, LDA, - $ CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO ) -* -* If right singular vectors desired in VT, copy them there -* - IF( WNTVAS ) - $ CALL ZLACPY( 'F', N, N, A, LDA, VT, LDVT ) -* - ELSE IF( WNTUO .AND. WNTVN ) THEN -* -* Path 2 (M much larger than N, JOBU='O', JOBVT='N') -* N left singular vectors to be overwritten on A and -* no right singular vectors to be computed -* - IF( LWORK.GE.N*N+3*N ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN -* -* WORK(IU) is LDA by N, WORK(IR) is LDA by N -* - LDWRKU = LDA - LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN -* -* WORK(IU) is LDA by N, WORK(IR) is N by N -* - LDWRKU = LDA - LDWRKR = N - ELSE -* -* WORK(IU) is LDWRKU by N, WORK(IR) is N by N -* - LDWRKU = ( LWORK-N*N ) / N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) -* (RWorkspace: 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IR) and zero out below it -* - CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR ) - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ WORK( IR+1 ), LDWRKR ) -* -* Generate Q in A -* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IR) -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left vectors bidiagonalizing R -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) -* (RWorkspace: need 0) -* - CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IR) -* (CWorkspace: need N*N) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, 1, - $ WORK( IR ), LDWRKR, CDUM, 1, - $ RWORK( IRWORK ), INFO ) - IU = ITAUQ -* -* Multiply Q in A by left singular vectors of R in -* WORK(IR), storing result in WORK(IU) and copying to A -* (CWorkspace: need N*N+N, prefer N*N+M*N) -* (RWorkspace: 0) -* - DO 10 I = 1, M, LDWRKU - CHUNK = MIN( M-I+1, LDWRKU ) - CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ), - $ LDA, WORK( IR ), LDWRKR, CZERO, - $ WORK( IU ), LDWRKU ) - CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, - $ A( I, 1 ), LDA ) - 10 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - IE = 1 - ITAUQ = 1 - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize A -* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) -* (RWorkspace: N) -* - CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left vectors bidiagonalizing A -* (CWorkspace: need 3*N, prefer 2*N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in A -* (CWorkspace: need 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, 1, - $ A, LDA, CDUM, 1, RWORK( IRWORK ), INFO ) -* - END IF -* - ELSE IF( WNTUO .AND. WNTVAS ) THEN -* -* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A') -* N left singular vectors to be overwritten on A and -* N right singular vectors to be computed in VT -* - IF( LWORK.GE.N*N+3*N ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by N -* - LDWRKU = LDA - LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is N by N -* - LDWRKU = LDA - LDWRKR = N - ELSE -* -* WORK(IU) is LDWRKU by N and WORK(IR) is N by N -* - LDWRKU = ( LWORK-N*N ) / N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) -* (RWorkspace: 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to VT, zeroing out below it -* - CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, VT( 2, 1 ), - $ LDVT ) -* -* Generate Q in A -* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in VT, copying result to WORK(IR) -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR ) -* -* Generate left vectors bidiagonalizing R in WORK(IR) -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing R in VT -* (CWorkspace: need N*N+3*N-1, prefer N*N+2*N+(N-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IR) and computing right -* singular vectors of R in VT -* (CWorkspace: need N*N) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT, - $ LDVT, WORK( IR ), LDWRKR, CDUM, 1, - $ RWORK( IRWORK ), INFO ) - IU = ITAUQ -* -* Multiply Q in A by left singular vectors of R in -* WORK(IR), storing result in WORK(IU) and copying to A -* (CWorkspace: need N*N+N, prefer N*N+M*N) -* (RWorkspace: 0) -* - DO 20 I = 1, M, LDWRKU - CHUNK = MIN( M-I+1, LDWRKU ) - CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ), - $ LDA, WORK( IR ), LDWRKR, CZERO, - $ WORK( IU ), LDWRKU ) - CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, - $ A( I, 1 ), LDA ) - 20 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to VT, zeroing out below it -* - CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, VT( 2, 1 ), - $ LDVT ) -* -* Generate Q in A -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in VT -* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) -* (RWorkspace: N) -* - CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in A by left vectors bidiagonalizing R -* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) -* (RWorkspace: 0) -* - CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, - $ WORK( ITAUQ ), A, LDA, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing R in VT -* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in A and computing right -* singular vectors of A in VT -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT, - $ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTUS ) THEN -* - IF( WNTVN ) THEN -* Path 4 (M much larger than N, JOBU='S', JOBVT='N') -* N left singular vectors to be computed in U and -* no right singular vectors to be computed -* - IF( LWORK.GE.N*N+3*N ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IR) is LDA by N -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is N by N -* - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) -* (RWorkspace: 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IR), zeroing out below it -* - CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ WORK( IR+1 ), LDWRKR ) -* -* Generate Q in A -* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IR) -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, - $ RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left vectors bidiagonalizing R in WORK(IR) -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IR) -* (CWorkspace: need N*N) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, - $ 1, WORK( IR ), LDWRKR, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* -* Multiply Q in A by left singular vectors of R in -* WORK(IR), storing result in U -* (CWorkspace: need N*N) -* (RWorkspace: 0) -* - CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, - $ WORK( IR ), LDWRKR, CZERO, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ A( 2, 1 ), LDA ) -* -* Bidiagonalize R in A -* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left vectors bidiagonalizing R -* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) -* (RWorkspace: 0) -* - CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, - $ 1, U, LDU, CDUM, 1, RWORK( IRWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVO ) THEN -* -* Path 5 (M much larger than N, JOBU='S', JOBVT='O') -* N left singular vectors to be computed in U and -* N right singular vectors to be overwritten on A -* - IF( LWORK.GE.2*N*N+3*N ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is N by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = N - ELSE -* -* WORK(IU) is N by N and WORK(IR) is N by N -* - LDWRKU = N - IR = IU + LDWRKU*N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) -* (RWorkspace: 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ WORK( IU+1 ), LDWRKU ) -* -* Generate Q in A -* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IU), copying result to -* WORK(IR) -* (CWorkspace: need 2*N*N+3*N, -* prefer 2*N*N+2*N+2*N*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, - $ WORK( IR ), LDWRKR ) -* -* Generate left bidiagonalizing vectors in WORK(IU) -* (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in WORK(IR) -* (CWorkspace: need 2*N*N+3*N-1, -* prefer 2*N*N+2*N+(N-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IU) and computing -* right singular vectors of R in WORK(IR) -* (CWorkspace: need 2*N*N) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), - $ WORK( IR ), LDWRKR, WORK( IU ), - $ LDWRKU, CDUM, 1, RWORK( IRWORK ), - $ INFO ) -* -* Multiply Q in A by left singular vectors of R in -* WORK(IU), storing result in U -* (CWorkspace: need N*N) -* (RWorkspace: 0) -* - CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, - $ WORK( IU ), LDWRKU, CZERO, U, LDU ) -* -* Copy right singular vectors of R to A -* (CWorkspace: need N*N) -* (RWorkspace: 0) -* - CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ A( 2, 1 ), LDA ) -* -* Bidiagonalize R in A -* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left vectors bidiagonalizing R -* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) -* (RWorkspace: 0) -* - CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing R in A -* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in A -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A, - $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVAS ) THEN -* -* Path 6 (M much larger than N, JOBU='S', JOBVT='S' -* or 'A') -* N left singular vectors to be computed in U and -* N right singular vectors to be computed in VT -* - IF( LWORK.GE.N*N+3*N ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IU) is LDA by N -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is N by N -* - LDWRKU = N - END IF - ITAU = IU + LDWRKU*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) -* (RWorkspace: 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ WORK( IU+1 ), LDWRKU ) -* -* Generate Q in A -* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IU), copying result to VT -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, - $ LDVT ) -* -* Generate left bidiagonalizing vectors in WORK(IU) -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in VT -* (CWorkspace: need N*N+3*N-1, -* prefer N*N+2*N+(N-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IU) and computing -* right singular vectors of R in VT -* (CWorkspace: need N*N) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT, - $ LDVT, WORK( IU ), LDWRKU, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* -* Multiply Q in A by left singular vectors of R in -* WORK(IU), storing result in U -* (CWorkspace: need N*N) -* (RWorkspace: 0) -* - CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, - $ WORK( IU ), LDWRKU, CZERO, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N - -* -* Compute A=Q*R, copying result to U -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to VT, zeroing out below it -* - CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ VT( 2, 1 ), LDVT ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in VT -* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left bidiagonalizing vectors -* in VT -* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) -* (RWorkspace: 0) -* - CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in VT -* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT, - $ LDVT, U, LDU, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* - END IF -* - END IF -* - ELSE IF( WNTUA ) THEN -* - IF( WNTVN ) THEN -* -* Path 7 (M much larger than N, JOBU='A', JOBVT='N') -* M left singular vectors to be computed in U and -* no right singular vectors to be computed -* - IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IR) is LDA by N -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is N by N -* - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) -* (RWorkspace: 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Copy R to WORK(IR), zeroing out below it -* - CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ WORK( IR+1 ), LDWRKR ) -* -* Generate Q in U -* (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IR) -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, - $ RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in WORK(IR) -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IR) -* (CWorkspace: need N*N) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, - $ 1, WORK( IR ), LDWRKR, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* -* Multiply Q in U by left singular vectors of R in -* WORK(IR), storing result in A -* (CWorkspace: need N*N) -* (RWorkspace: 0) -* - CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU, - $ WORK( IR ), LDWRKR, CZERO, A, LDA ) -* -* Copy left singular vectors of A from A to U -* - CALL ZLACPY( 'F', M, N, A, LDA, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (CWorkspace: need N+M, prefer N+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ A( 2, 1 ), LDA ) -* -* Bidiagonalize R in A -* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left bidiagonalizing vectors -* in A -* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) -* (RWorkspace: 0) -* - CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, - $ 1, U, LDU, CDUM, 1, RWORK( IRWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVO ) THEN -* -* Path 8 (M much larger than N, JOBU='A', JOBVT='O') -* M left singular vectors to be computed in U and -* N right singular vectors to be overwritten on A -* - IF( LWORK.GE.2*N*N+MAX( N+M, 3*N ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is N by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = N - ELSE -* -* WORK(IU) is N by N and WORK(IR) is N by N -* - LDWRKU = N - IR = IU + LDWRKU*N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) -* (RWorkspace: 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (CWorkspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ WORK( IU+1 ), LDWRKU ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IU), copying result to -* WORK(IR) -* (CWorkspace: need 2*N*N+3*N, -* prefer 2*N*N+2*N+2*N*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, - $ WORK( IR ), LDWRKR ) -* -* Generate left bidiagonalizing vectors in WORK(IU) -* (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in WORK(IR) -* (CWorkspace: need 2*N*N+3*N-1, -* prefer 2*N*N+2*N+(N-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IU) and computing -* right singular vectors of R in WORK(IR) -* (CWorkspace: need 2*N*N) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), - $ WORK( IR ), LDWRKR, WORK( IU ), - $ LDWRKU, CDUM, 1, RWORK( IRWORK ), - $ INFO ) -* -* Multiply Q in U by left singular vectors of R in -* WORK(IU), storing result in A -* (CWorkspace: need N*N) -* (RWorkspace: 0) -* - CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU, - $ WORK( IU ), LDWRKU, CZERO, A, LDA ) -* -* Copy left singular vectors of A from A to U -* - CALL ZLACPY( 'F', M, N, A, LDA, U, LDU ) -* -* Copy right singular vectors of R from WORK(IR) to A -* - CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (CWorkspace: need N+M, prefer N+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ A( 2, 1 ), LDA ) -* -* Bidiagonalize R in A -* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left bidiagonalizing vectors -* in A -* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) -* (RWorkspace: 0) -* - CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in A -* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in A -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A, - $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVAS ) THEN -* -* Path 9 (M much larger than N, JOBU='A', JOBVT='S' -* or 'A') -* M left singular vectors to be computed in U and -* N right singular vectors to be computed in VT -* - IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IU) is LDA by N -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is N by N -* - LDWRKU = N - END IF - ITAU = IU + LDWRKU*N - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) -* (RWorkspace: 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ WORK( IU+1 ), LDWRKU ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IU), copying result to VT -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, - $ LDVT ) -* -* Generate left bidiagonalizing vectors in WORK(IU) -* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in VT -* (CWorkspace: need N*N+3*N-1, -* prefer N*N+2*N+(N-1)*NB) -* (RWorkspace: need 0) -* - CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IU) and computing -* right singular vectors of R in VT -* (CWorkspace: need N*N) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT, - $ LDVT, WORK( IU ), LDWRKU, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* -* Multiply Q in U by left singular vectors of R in -* WORK(IU), storing result in A -* (CWorkspace: need N*N) -* (RWorkspace: 0) -* - CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU, - $ WORK( IU ), LDWRKU, CZERO, A, LDA ) -* -* Copy left singular vectors of A from A to U -* - CALL ZLACPY( 'F', M, N, A, LDA, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: 0) -* - CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (CWorkspace: need N+M, prefer N+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* -* Copy R from A to VT, zeroing out below it -* - CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ VT( 2, 1 ), LDVT ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in VT -* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left bidiagonalizing vectors -* in VT -* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) -* (RWorkspace: 0) -* - CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in VT -* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT, - $ LDVT, U, LDU, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* - END IF -* -* - END IF -* - END IF -* - ELSE -* -* M .LT. MNTHR -* -* Path 10 (M at least N, but not much larger) -* Reduce to bidiagonal form without QR decomposition -* - IE = 1 - ITAUQ = 1 - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize A -* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) -* (RWorkspace: need N) -* - CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ IERR ) - IF( WNTUAS ) THEN -* -* If left singular vectors desired in U, copy result to U -* and generate left bidiagonalizing vectors in U -* (CWorkspace: need 2*N+NCU, prefer 2*N+NCU*NB) -* (RWorkspace: 0) -* - CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) - IF( WNTUS ) - $ NCU = N - IF( WNTUA ) - $ NCU = M - CALL ZUNGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTVAS ) THEN -* -* If right singular vectors desired in VT, copy result to -* VT and generate right bidiagonalizing vectors in VT -* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) -* (RWorkspace: 0) -* - CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTUO ) THEN -* -* If left singular vectors desired in A, generate left -* bidiagonalizing vectors in A -* (CWorkspace: need 3*N, prefer 2*N+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTVO ) THEN -* -* If right singular vectors desired in A, generate right -* bidiagonalizing vectors in A -* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IRWORK = IE + N - IF( WNTUAS .OR. WNTUO ) - $ NRU = M - IF( WNTUN ) - $ NRU = 0 - IF( WNTVAS .OR. WNTVO ) - $ NCVT = N - IF( WNTVN ) - $ NCVT = 0 - IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in VT -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT, - $ LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ), - $ INFO ) - ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in A -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), A, - $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ), - $ INFO ) - ELSE -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in A and computing right singular -* vectors in VT -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT, - $ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ), - $ INFO ) - END IF -* - END IF -* - ELSE -* -* A has more columns than rows. If A has sufficiently more -* columns than rows, first reduce using the LQ decomposition (if -* sufficient workspace available) -* - IF( N.GE.MNTHR ) THEN -* - IF( WNTVN ) THEN -* -* Path 1t(N much larger than M, JOBVT='N') -* No right singular vectors to be computed -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Zero out above L -* - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, A( 1, 2 ), - $ LDA ) - IE = 1 - ITAUQ = 1 - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in A -* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ IERR ) - IF( WNTUO .OR. WNTUAS ) THEN -* -* If left singular vectors desired, generate Q -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IRWORK = IE + M - NRU = 0 - IF( WNTUO .OR. WNTUAS ) - $ NRU = M -* -* Perform bidiagonal QR iteration, computing left singular -* vectors of A in A if desired -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, 0, NRU, 0, S, RWORK( IE ), CDUM, 1, - $ A, LDA, CDUM, 1, RWORK( IRWORK ), INFO ) -* -* If left singular vectors desired in U, copy them there -* - IF( WNTUAS ) - $ CALL ZLACPY( 'F', M, M, A, LDA, U, LDU ) -* - ELSE IF( WNTVO .AND. WNTUN ) THEN -* -* Path 2t(N much larger than M, JOBU='N', JOBVT='O') -* M right singular vectors to be overwritten on A and -* no left singular vectors to be computed -* - IF( LWORK.GE.M*M+3*M ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by M -* - LDWRKU = LDA - CHUNK = N - LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is M by M -* - LDWRKU = LDA - CHUNK = N - LDWRKR = M - ELSE -* -* WORK(IU) is M by CHUNK and WORK(IR) is M by M -* - LDWRKU = M - CHUNK = ( LWORK-M*M ) / M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IR) and zero out above it -* - CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR ) - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, - $ WORK( IR+LDWRKR ), LDWRKR ) -* -* Generate Q in A -* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IR) -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing L -* (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of L in WORK(IR) -* (CWorkspace: need M*M) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ), - $ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1, - $ RWORK( IRWORK ), INFO ) - IU = ITAUQ -* -* Multiply right singular vectors of L in WORK(IR) by Q -* in A, storing result in WORK(IU) and copying to A -* (CWorkspace: need M*M+M, prefer M*M+M*N) -* (RWorkspace: 0) -* - DO 30 I = 1, N, CHUNK - BLK = MIN( N-I+1, CHUNK ) - CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ), - $ LDWRKR, A( 1, I ), LDA, CZERO, - $ WORK( IU ), LDWRKU ) - CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, - $ A( 1, I ), LDA ) - 30 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - IE = 1 - ITAUQ = 1 - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize A -* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing A -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in A -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'L', M, N, 0, 0, S, RWORK( IE ), A, LDA, - $ CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO ) -* - END IF -* - ELSE IF( WNTVO .AND. WNTUAS ) THEN -* -* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O') -* M right singular vectors to be overwritten on A and -* M left singular vectors to be computed in U -* - IF( LWORK.GE.M*M+3*M ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by M -* - LDWRKU = LDA - CHUNK = N - LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is M by M -* - LDWRKU = LDA - CHUNK = N - LDWRKR = M - ELSE -* -* WORK(IU) is M by CHUNK and WORK(IR) is M by M -* - LDWRKU = M - CHUNK = ( LWORK-M*M ) / M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to U, zeroing about above it -* - CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ), - $ LDU ) -* -* Generate Q in A -* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in U, copying result to WORK(IR) -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR ) -* -* Generate right vectors bidiagonalizing L in WORK(IR) -* (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left vectors bidiagonalizing L in U -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of L in U, and computing right -* singular vectors of L in WORK(IR) -* (CWorkspace: need M*M) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), - $ WORK( IR ), LDWRKR, U, LDU, CDUM, 1, - $ RWORK( IRWORK ), INFO ) - IU = ITAUQ -* -* Multiply right singular vectors of L in WORK(IR) by Q -* in A, storing result in WORK(IU) and copying to A -* (CWorkspace: need M*M+M, prefer M*M+M*N)) -* (RWorkspace: 0) -* - DO 40 I = 1, N, CHUNK - BLK = MIN( N-I+1, CHUNK ) - CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ), - $ LDWRKR, A( 1, I ), LDA, CZERO, - $ WORK( IU ), LDWRKU ) - CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, - $ A( 1, I ), LDA ) - 40 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to U, zeroing out above it -* - CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ), - $ LDU ) -* -* Generate Q in A -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in U -* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right vectors bidiagonalizing L by Q in A -* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) -* (RWorkspace: 0) -* - CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU, - $ WORK( ITAUP ), A, LDA, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left vectors bidiagonalizing L in U -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in A -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), A, LDA, - $ U, LDU, CDUM, 1, RWORK( IRWORK ), INFO ) -* - END IF -* - ELSE IF( WNTVS ) THEN -* - IF( WNTUN ) THEN -* -* Path 4t(N much larger than M, JOBU='N', JOBVT='S') -* M right singular vectors to be computed in VT and -* no left singular vectors to be computed -* - IF( LWORK.GE.M*M+3*M ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IR) is LDA by M -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is M by M -* - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IR), zeroing out above it -* - CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, - $ WORK( IR+LDWRKR ), LDWRKR ) -* -* Generate Q in A -* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IR) -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, - $ RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing L in -* WORK(IR) -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of L in WORK(IR) -* (CWorkspace: need M*M) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ), - $ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IR) by -* Q in A, storing result in VT -* (CWorkspace: need M*M) -* (RWorkspace: 0) -* - CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ), - $ LDWRKR, A, LDA, CZERO, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy result to VT -* - CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, - $ A( 1, 2 ), LDA ) -* -* Bidiagonalize L in A -* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right vectors bidiagonalizing L by Q in VT -* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) -* (RWorkspace: 0) -* - CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in VT -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT, - $ LDVT, CDUM, 1, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* - END IF -* - ELSE IF( WNTUO ) THEN -* -* Path 5t(N much larger than M, JOBU='O', JOBVT='S') -* M right singular vectors to be computed in VT and -* M left singular vectors to be overwritten on A -* - IF( LWORK.GE.2*M*M+3*M ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is LDA by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is M by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = M - ELSE -* -* WORK(IU) is M by M and WORK(IR) is M by M -* - LDWRKU = M - IR = IU + LDWRKU*M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IU), zeroing out below it -* - CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) -* -* Generate Q in A -* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IU), copying result to -* WORK(IR) -* (CWorkspace: need 2*M*M+3*M, -* prefer 2*M*M+2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, - $ WORK( IR ), LDWRKR ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (CWorkspace: need 2*M*M+3*M-1, -* prefer 2*M*M+2*M+(M-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in WORK(IR) -* (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of L in WORK(IR) and computing -* right singular vectors of L in WORK(IU) -* (CWorkspace: need 2*M*M) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), - $ WORK( IU ), LDWRKU, WORK( IR ), - $ LDWRKR, CDUM, 1, RWORK( IRWORK ), - $ INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in A, storing result in VT -* (CWorkspace: need M*M) -* (RWorkspace: 0) -* - CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), - $ LDWRKU, A, LDA, CZERO, VT, LDVT ) -* -* Copy left singular vectors of L to A -* (CWorkspace: need M*M) -* (RWorkspace: 0) -* - CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, - $ A( 1, 2 ), LDA ) -* -* Bidiagonalize L in A -* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right vectors bidiagonalizing L by Q in VT -* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) -* (RWorkspace: 0) -* - CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors of L in A -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in A and computing right -* singular vectors of A in VT -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, - $ LDVT, A, LDA, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* - END IF -* - ELSE IF( WNTUAS ) THEN -* -* Path 6t(N much larger than M, JOBU='S' or 'A', -* JOBVT='S') -* M right singular vectors to be computed in VT and -* M left singular vectors to be computed in U -* - IF( LWORK.GE.M*M+3*M ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IU) is LDA by N -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is LDA by M -* - LDWRKU = M - END IF - ITAU = IU + LDWRKU*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IU), zeroing out above it -* - CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) -* -* Generate Q in A -* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IU), copying result to U -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, - $ LDU ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (CWorkspace: need M*M+3*M-1, -* prefer M*M+2*M+(M-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in U -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of L in U and computing right -* singular vectors of L in WORK(IU) -* (CWorkspace: need M*M) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), - $ WORK( IU ), LDWRKU, U, LDU, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in A, storing result in VT -* (CWorkspace: need M*M) -* (RWorkspace: 0) -* - CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), - $ LDWRKU, A, LDA, CZERO, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to U, zeroing out above it -* - CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, - $ U( 1, 2 ), LDU ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in U -* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right bidiagonalizing vectors in U by Q -* in VT -* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) -* (RWorkspace: 0) -* - CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in U -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, - $ LDVT, U, LDU, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* - END IF -* - END IF -* - ELSE IF( WNTVA ) THEN -* - IF( WNTUN ) THEN -* -* Path 7t(N much larger than M, JOBU='N', JOBVT='A') -* N right singular vectors to be computed in VT and -* no left singular vectors to be computed -* - IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN -* -* Sufficient workspace for a fast algorithm - IR = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IR) is LDA by M -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is M by M -* - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Copy L to WORK(IR), zeroing out above it -* - CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, - $ WORK( IR+LDWRKR ), LDWRKR ) -* -* Generate Q in VT -* (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IR) -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, - $ RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in WORK(IR) -* (CWorkspace: need M*M+3*M-1, -* prefer M*M+2*M+(M-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of L in WORK(IR) -* (CWorkspace: need M*M) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ), - $ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IR) by -* Q in VT, storing result in A -* (CWorkspace: need M*M) -* (RWorkspace: 0) -* - CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ), - $ LDWRKR, VT, LDVT, CZERO, A, LDA ) -* -* Copy right singular vectors of A from A to VT -* - CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (CWorkspace: need M+N, prefer M+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, - $ A( 1, 2 ), LDA ) -* -* Bidiagonalize L in A -* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right bidiagonalizing vectors in A by Q -* in VT -* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) -* (RWorkspace: 0) -* - CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in VT -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT, - $ LDVT, CDUM, 1, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* - END IF -* - ELSE IF( WNTUO ) THEN -* -* Path 8t(N much larger than M, JOBU='O', JOBVT='A') -* N right singular vectors to be computed in VT and -* M left singular vectors to be overwritten on A -* - IF( LWORK.GE.2*M*M+MAX( N+M, 3*M ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is LDA by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is M by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = M - ELSE -* -* WORK(IU) is M by M and WORK(IR) is M by M -* - LDWRKU = M - IR = IU + LDWRKU*M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (CWorkspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IU), zeroing out above it -* - CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IU), copying result to -* WORK(IR) -* (CWorkspace: need 2*M*M+3*M, -* prefer 2*M*M+2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, - $ WORK( IR ), LDWRKR ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (CWorkspace: need 2*M*M+3*M-1, -* prefer 2*M*M+2*M+(M-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in WORK(IR) -* (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of L in WORK(IR) and computing -* right singular vectors of L in WORK(IU) -* (CWorkspace: need 2*M*M) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), - $ WORK( IU ), LDWRKU, WORK( IR ), - $ LDWRKR, CDUM, 1, RWORK( IRWORK ), - $ INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in VT, storing result in A -* (CWorkspace: need M*M) -* (RWorkspace: 0) -* - CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), - $ LDWRKU, VT, LDVT, CZERO, A, LDA ) -* -* Copy right singular vectors of A from A to VT -* - CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT ) -* -* Copy left singular vectors of A from WORK(IR) to A -* - CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (CWorkspace: need M+N, prefer M+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, - $ A( 1, 2 ), LDA ) -* -* Bidiagonalize L in A -* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right bidiagonalizing vectors in A by Q -* in VT -* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) -* (RWorkspace: 0) -* - CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in A -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in A and computing right -* singular vectors of A in VT -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, - $ LDVT, A, LDA, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* - END IF -* - ELSE IF( WNTUAS ) THEN -* -* Path 9t(N much larger than M, JOBU='S' or 'A', -* JOBVT='A') -* N right singular vectors to be computed in VT and -* M left singular vectors to be computed in U -* - IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IU) is LDA by M -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is M by M -* - LDWRKU = M - END IF - ITAU = IU + LDWRKU*M - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IU), zeroing out above it -* - CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IU), copying result to U -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, - $ LDU ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in U -* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of L in U and computing right -* singular vectors of L in WORK(IU) -* (CWorkspace: need M*M) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), - $ WORK( IU ), LDWRKU, U, LDU, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in VT, storing result in A -* (CWorkspace: need M*M) -* (RWorkspace: 0) -* - CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), - $ LDWRKU, VT, LDVT, CZERO, A, LDA ) -* -* Copy right singular vectors of A from A to VT -* - CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (CWorkspace: need 2*M, prefer M+M*NB) -* (RWorkspace: 0) -* - CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (CWorkspace: need M+N, prefer M+N*NB) -* (RWorkspace: 0) -* - CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to U, zeroing out above it -* - CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, - $ U( 1, 2 ), LDU ) - IE = 1 - ITAUQ = ITAU - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in U -* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) -* (RWorkspace: need M) -* - CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right bidiagonalizing vectors in U by Q -* in VT -* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) -* (RWorkspace: 0) -* - CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in U -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IRWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, - $ LDVT, U, LDU, CDUM, 1, - $ RWORK( IRWORK ), INFO ) -* - END IF -* - END IF -* - END IF -* - ELSE -* -* N .LT. MNTHR -* -* Path 10t(N greater than M, but not much larger) -* Reduce to bidiagonal form without LQ decomposition -* - IE = 1 - ITAUQ = 1 - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize A -* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) -* (RWorkspace: M) -* - CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ IERR ) - IF( WNTUAS ) THEN -* -* If left singular vectors desired in U, copy result to U -* and generate left bidiagonalizing vectors in U -* (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB) -* (RWorkspace: 0) -* - CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTVAS ) THEN -* -* If right singular vectors desired in VT, copy result to -* VT and generate right bidiagonalizing vectors in VT -* (CWorkspace: need 2*M+NRVT, prefer 2*M+NRVT*NB) -* (RWorkspace: 0) -* - CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) - IF( WNTVA ) - $ NRVT = N - IF( WNTVS ) - $ NRVT = M - CALL ZUNGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTUO ) THEN -* -* If left singular vectors desired in A, generate left -* bidiagonalizing vectors in A -* (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTVO ) THEN -* -* If right singular vectors desired in A, generate right -* bidiagonalizing vectors in A -* (CWorkspace: need 3*M, prefer 2*M+M*NB) -* (RWorkspace: 0) -* - CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IRWORK = IE + M - IF( WNTUAS .OR. WNTUO ) - $ NRU = M - IF( WNTUN ) - $ NRU = 0 - IF( WNTVAS .OR. WNTVO ) - $ NCVT = N - IF( WNTVN ) - $ NCVT = 0 - IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in VT -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT, - $ LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ), - $ INFO ) - ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in A -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), A, - $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ), - $ INFO ) - ELSE -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in A and computing right singular -* vectors in VT -* (CWorkspace: 0) -* (RWorkspace: need BDSPAC) -* - CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT, - $ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ), - $ INFO ) - END IF -* - END IF -* - END IF -* -* Undo scaling if necessary -* - IF( ISCL.EQ.1 ) THEN - IF( ANRM.GT.BIGNUM ) - $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, - $ IERR ) - IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) - $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, - $ RWORK( IE ), MINMN, IERR ) - IF( ANRM.LT.SMLNUM ) - $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, - $ IERR ) - IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) - $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, - $ RWORK( IE ), MINMN, IERR ) - END IF -* -* Return optimal workspace in WORK(1) -* - WORK( 1 ) = MAXWRK -* - RETURN -* -* End of ZGESVD -* - END - SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, - $ LDU, C, LDC, RWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ), RWORK( * ) - COMPLEX*16 C( LDC, * ), U( LDU, * ), VT( LDVT, * ) -* .. -* -* Purpose -* ======= -* -* ZBDSQR computes the singular value decomposition (SVD) of a real -* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' -* denotes the transpose of P), where S is a diagonal matrix with -* non-negative diagonal elements (the singular values of B), and Q -* and P are orthogonal matrices. -* -* The routine computes S, and optionally computes U * Q, P' * VT, -* or Q' * C, for given complex input matrices U, VT, and C. -* -* See "Computing Small Singular Values of Bidiagonal Matrices With -* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, -* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, -* no. 5, pp. 873-912, Sept 1990) and -* "Accurate singular values and differential qd algorithms," by -* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics -* Department, University of California at Berkeley, July 1992 -* for a detailed description of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': B is upper bidiagonal; -* = 'L': B is lower bidiagonal. -* -* N (input) INTEGER -* The order of the matrix B. N >= 0. -* -* NCVT (input) INTEGER -* The number of columns of the matrix VT. NCVT >= 0. -* -* NRU (input) INTEGER -* The number of rows of the matrix U. NRU >= 0. -* -* NCC (input) INTEGER -* The number of columns of the matrix C. NCC >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the n diagonal elements of the bidiagonal matrix B. -* On exit, if INFO=0, the singular values of B in decreasing -* order. -* -* E (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the elements of E contain the -* offdiagonal elements of of the bidiagonal matrix whose SVD -* is desired. On normal exit (INFO = 0), E is destroyed. -* If the algorithm does not converge (INFO > 0), D and E -* will contain the diagonal and superdiagonal elements of a -* bidiagonal matrix orthogonally equivalent to the one given -* as input. E(N) is used for workspace. -* -* VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT) -* On entry, an N-by-NCVT matrix VT. -* On exit, VT is overwritten by P' * VT. -* VT is not referenced if NCVT = 0. -* -* LDVT (input) INTEGER -* The leading dimension of the array VT. -* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. -* -* U (input/output) COMPLEX*16 array, dimension (LDU, N) -* On entry, an NRU-by-N matrix U. -* On exit, U is overwritten by U * Q. -* U is not referenced if NRU = 0. -* -* LDU (input) INTEGER -* The leading dimension of the array U. LDU >= max(1,NRU). -* -* C (input/output) COMPLEX*16 array, dimension (LDC, NCC) -* On entry, an N-by-NCC matrix C. -* On exit, C is overwritten by Q' * C. -* C is not referenced if NCC = 0. -* -* LDC (input) INTEGER -* The leading dimension of the array C. -* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. -* -* RWORK (workspace) DOUBLE PRECISION array, dimension (4*N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: If INFO = -i, the i-th argument had an illegal value -* > 0: the algorithm did not converge; D and E contain the -* elements of a bidiagonal matrix which is orthogonally -* similar to the input matrix B; if INFO = i, i -* elements of E have not converged to zero. -* -* Internal Parameters -* =================== -* -* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) -* TOLMUL controls the convergence criterion of the QR loop. -* If it is positive, TOLMUL*EPS is the desired relative -* precision in the computed singular values. -* If it is negative, abs(TOLMUL*EPS*sigma_max) is the -* desired absolute accuracy in the computed singular -* values (corresponds to relative accuracy -* abs(TOLMUL*EPS) in the largest singular value. -* abs(TOLMUL) should be between 1 and 1/EPS, and preferably -* between 10 (for fast convergence) and .1/EPS -* (for there to be some accuracy in the results). -* Default is to lose at either one eighth or 2 of the -* available decimal digits in each computed singular value -* (whichever is smaller). -* -* MAXITR INTEGER, default = 6 -* MAXITR controls the maximum number of passes of the -* algorithm through its inner loop. The algorithms stops -* (and so fails to converge) if the number of passes -* through the inner loop exceeds MAXITR*N**2. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION NEGONE - PARAMETER ( NEGONE = -1.0D0 ) - DOUBLE PRECISION HNDRTH - PARAMETER ( HNDRTH = 0.01D0 ) - DOUBLE PRECISION TEN - PARAMETER ( TEN = 10.0D0 ) - DOUBLE PRECISION HNDRD - PARAMETER ( HNDRD = 100.0D0 ) - DOUBLE PRECISION MEIGTH - PARAMETER ( MEIGTH = -0.125D0 ) - INTEGER MAXITR - PARAMETER ( MAXITR = 6 ) -* .. -* .. Local Scalars .. - LOGICAL LOWER, ROTATE - INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1, - $ NM12, NM13, OLDLL, OLDM - DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, - $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, - $ SINR, SLL, SMAX, SMIN, SMINL, SMINLO, SMINOA, - $ SN, THRESH, TOL, TOLMUL, UNFL -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLARTG, DLAS2, DLASQ1, DLASV2, XERBLA, ZDROT, - $ ZDSCAL, ZLASR, ZSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - LOWER = LSAME( UPLO, 'L' ) - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NCVT.LT.0 ) THEN - INFO = -3 - ELSE IF( NRU.LT.0 ) THEN - INFO = -4 - ELSE IF( NCC.LT.0 ) THEN - INFO = -5 - ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. - $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN - INFO = -9 - ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN - INFO = -11 - ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. - $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN - INFO = -13 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZBDSQR', -INFO ) - RETURN - END IF - IF( N.EQ.0 ) - $ RETURN - IF( N.EQ.1 ) - $ GO TO 160 -* -* ROTATE is true if any singular vectors desired, false otherwise -* - ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) -* -* If no singular vectors desired, use qd algorithm -* - IF( .NOT.ROTATE ) THEN - CALL DLASQ1( N, D, E, RWORK, INFO ) - RETURN - END IF -* - NM1 = N - 1 - NM12 = NM1 + NM1 - NM13 = NM12 + NM1 - IDIR = 0 -* -* Get machine constants -* - EPS = DLAMCH( 'Epsilon' ) - UNFL = DLAMCH( 'Safe minimum' ) -* -* If matrix lower bidiagonal, rotate to be upper bidiagonal -* by applying Givens rotations on the left -* - IF( LOWER ) THEN - DO 10 I = 1, N - 1 - CALL DLARTG( D( I ), E( I ), CS, SN, R ) - D( I ) = R - E( I ) = SN*D( I+1 ) - D( I+1 ) = CS*D( I+1 ) - RWORK( I ) = CS - RWORK( NM1+I ) = SN - 10 CONTINUE -* -* Update singular vectors if desired -* - IF( NRU.GT.0 ) - $ CALL ZLASR( 'R', 'V', 'F', NRU, N, RWORK( 1 ), RWORK( N ), - $ U, LDU ) - IF( NCC.GT.0 ) - $ CALL ZLASR( 'L', 'V', 'F', N, NCC, RWORK( 1 ), RWORK( N ), - $ C, LDC ) - END IF -* -* Compute singular values to relative accuracy TOL -* (By setting TOL to be negative, algorithm will compute -* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) -* - TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) ) - TOL = TOLMUL*EPS -* -* Compute approximate maximum, minimum singular values -* - SMAX = ZERO - DO 20 I = 1, N - SMAX = MAX( SMAX, ABS( D( I ) ) ) - 20 CONTINUE - DO 30 I = 1, N - 1 - SMAX = MAX( SMAX, ABS( E( I ) ) ) - 30 CONTINUE - SMINL = ZERO - IF( TOL.GE.ZERO ) THEN -* -* Relative accuracy desired -* - SMINOA = ABS( D( 1 ) ) - IF( SMINOA.EQ.ZERO ) - $ GO TO 50 - MU = SMINOA - DO 40 I = 2, N - MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) ) - SMINOA = MIN( SMINOA, MU ) - IF( SMINOA.EQ.ZERO ) - $ GO TO 50 - 40 CONTINUE - 50 CONTINUE - SMINOA = SMINOA / SQRT( DBLE( N ) ) - THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL ) - ELSE -* -* Absolute accuracy desired -* - THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL ) - END IF -* -* Prepare for main iteration loop for the singular values -* (MAXIT is the maximum number of passes through the inner -* loop permitted before nonconvergence signalled.) -* - MAXIT = MAXITR*N*N - ITER = 0 - OLDLL = -1 - OLDM = -1 -* -* M points to last element of unconverged part of matrix -* - M = N -* -* Begin main iteration loop -* - 60 CONTINUE -* -* Check for convergence or exceeding iteration count -* - IF( M.LE.1 ) - $ GO TO 160 - IF( ITER.GT.MAXIT ) - $ GO TO 200 -* -* Find diagonal block of matrix to work on -* - IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH ) - $ D( M ) = ZERO - SMAX = ABS( D( M ) ) - SMIN = SMAX - DO 70 LLL = 1, M - 1 - LL = M - LLL - ABSS = ABS( D( LL ) ) - ABSE = ABS( E( LL ) ) - IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH ) - $ D( LL ) = ZERO - IF( ABSE.LE.THRESH ) - $ GO TO 80 - SMIN = MIN( SMIN, ABSS ) - SMAX = MAX( SMAX, ABSS, ABSE ) - 70 CONTINUE - LL = 0 - GO TO 90 - 80 CONTINUE - E( LL ) = ZERO -* -* Matrix splits since E(LL) = 0 -* - IF( LL.EQ.M-1 ) THEN -* -* Convergence of bottom singular value, return to top of loop -* - M = M - 1 - GO TO 60 - END IF - 90 CONTINUE - LL = LL + 1 -* -* E(LL) through E(M-1) are nonzero, E(LL-1) is zero -* - IF( LL.EQ.M-1 ) THEN -* -* 2 by 2 block, handle separately -* - CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR, - $ COSR, SINL, COSL ) - D( M-1 ) = SIGMX - E( M-1 ) = ZERO - D( M ) = SIGMN -* -* Compute singular vectors, if desired -* - IF( NCVT.GT.0 ) - $ CALL ZDROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, - $ COSR, SINR ) - IF( NRU.GT.0 ) - $ CALL ZDROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL ) - IF( NCC.GT.0 ) - $ CALL ZDROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL, - $ SINL ) - M = M - 2 - GO TO 60 - END IF -* -* If working on new submatrix, choose shift direction -* (from larger end diagonal element towards smaller) -* - IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN - IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN -* -* Chase bulge from top (big end) to bottom (small end) -* - IDIR = 1 - ELSE -* -* Chase bulge from bottom (big end) to top (small end) -* - IDIR = 2 - END IF - END IF -* -* Apply convergence tests -* - IF( IDIR.EQ.1 ) THEN -* -* Run convergence test in forward direction -* First apply standard test to bottom of matrix -* - IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR. - $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN - E( M-1 ) = ZERO - GO TO 60 - END IF -* - IF( TOL.GE.ZERO ) THEN -* -* If relative accuracy desired, -* apply convergence criterion forward -* - MU = ABS( D( LL ) ) - SMINL = MU - DO 100 LLL = LL, M - 1 - IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN - E( LLL ) = ZERO - GO TO 60 - END IF - SMINLO = SMINL - MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) - SMINL = MIN( SMINL, MU ) - 100 CONTINUE - END IF -* - ELSE -* -* Run convergence test in backward direction -* First apply standard test to top of matrix -* - IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR. - $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN - E( LL ) = ZERO - GO TO 60 - END IF -* - IF( TOL.GE.ZERO ) THEN -* -* If relative accuracy desired, -* apply convergence criterion backward -* - MU = ABS( D( M ) ) - SMINL = MU - DO 110 LLL = M - 1, LL, -1 - IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN - E( LLL ) = ZERO - GO TO 60 - END IF - SMINLO = SMINL - MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) - SMINL = MIN( SMINL, MU ) - 110 CONTINUE - END IF - END IF - OLDLL = LL - OLDM = M -* -* Compute shift. First, test if shifting would ruin relative -* accuracy, and if so set the shift to zero. -* - IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE. - $ MAX( EPS, HNDRTH*TOL ) ) THEN -* -* Use a zero shift to avoid loss of relative accuracy -* - SHIFT = ZERO - ELSE -* -* Compute the shift from 2-by-2 block at end of matrix -* - IF( IDIR.EQ.1 ) THEN - SLL = ABS( D( LL ) ) - CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R ) - ELSE - SLL = ABS( D( M ) ) - CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R ) - END IF -* -* Test if shift negligible, and if so set to zero -* - IF( SLL.GT.ZERO ) THEN - IF( ( SHIFT / SLL )**2.LT.EPS ) - $ SHIFT = ZERO - END IF - END IF -* -* Increment iteration count -* - ITER = ITER + M - LL -* -* If SHIFT = 0, do simplified QR iteration -* - IF( SHIFT.EQ.ZERO ) THEN - IF( IDIR.EQ.1 ) THEN -* -* Chase bulge from top to bottom -* Save cosines and sines for later singular vector updates -* - CS = ONE - OLDCS = ONE - DO 120 I = LL, M - 1 - CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) - IF( I.GT.LL ) - $ E( I-1 ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) - RWORK( I-LL+1 ) = CS - RWORK( I-LL+1+NM1 ) = SN - RWORK( I-LL+1+NM12 ) = OLDCS - RWORK( I-LL+1+NM13 ) = OLDSN - 120 CONTINUE - H = D( M )*CS - D( M ) = H*OLDCS - E( M-1 ) = H*OLDSN -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ), - $ RWORK( N ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ), - $ RWORK( NM13+1 ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ), - $ RWORK( NM13+1 ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( M-1 ) ).LE.THRESH ) - $ E( M-1 ) = ZERO -* - ELSE -* -* Chase bulge from bottom to top -* Save cosines and sines for later singular vector updates -* - CS = ONE - OLDCS = ONE - DO 130 I = M, LL + 1, -1 - CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) - IF( I.LT.M ) - $ E( I ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) - RWORK( I-LL ) = CS - RWORK( I-LL+NM1 ) = -SN - RWORK( I-LL+NM12 ) = OLDCS - RWORK( I-LL+NM13 ) = -OLDSN - 130 CONTINUE - H = D( LL )*CS - D( LL ) = H*OLDCS - E( LL ) = H*OLDSN -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ), - $ RWORK( NM13+1 ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ), - $ RWORK( N ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ), - $ RWORK( N ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( LL ) ).LE.THRESH ) - $ E( LL ) = ZERO - END IF - ELSE -* -* Use nonzero shift -* - IF( IDIR.EQ.1 ) THEN -* -* Chase bulge from top to bottom -* Save cosines and sines for later singular vector updates -* - F = ( ABS( D( LL ) )-SHIFT )* - $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) ) - G = E( LL ) - DO 140 I = LL, M - 1 - CALL DLARTG( F, G, COSR, SINR, R ) - IF( I.GT.LL ) - $ E( I-1 ) = R - F = COSR*D( I ) + SINR*E( I ) - E( I ) = COSR*E( I ) - SINR*D( I ) - G = SINR*D( I+1 ) - D( I+1 ) = COSR*D( I+1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I ) + SINL*D( I+1 ) - D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) - IF( I.LT.M-1 ) THEN - G = SINL*E( I+1 ) - E( I+1 ) = COSL*E( I+1 ) - END IF - RWORK( I-LL+1 ) = COSR - RWORK( I-LL+1+NM1 ) = SINR - RWORK( I-LL+1+NM12 ) = COSL - RWORK( I-LL+1+NM13 ) = SINL - 140 CONTINUE - E( M-1 ) = F -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ), - $ RWORK( N ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ), - $ RWORK( NM13+1 ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ), - $ RWORK( NM13+1 ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( M-1 ) ).LE.THRESH ) - $ E( M-1 ) = ZERO -* - ELSE -* -* Chase bulge from bottom to top -* Save cosines and sines for later singular vector updates -* - F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT / - $ D( M ) ) - G = E( M-1 ) - DO 150 I = M, LL + 1, -1 - CALL DLARTG( F, G, COSR, SINR, R ) - IF( I.LT.M ) - $ E( I ) = R - F = COSR*D( I ) + SINR*E( I-1 ) - E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) - G = SINR*D( I-1 ) - D( I-1 ) = COSR*D( I-1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I-1 ) + SINL*D( I-1 ) - D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) - IF( I.GT.LL+1 ) THEN - G = SINL*E( I-2 ) - E( I-2 ) = COSL*E( I-2 ) - END IF - RWORK( I-LL ) = COSR - RWORK( I-LL+NM1 ) = -SINR - RWORK( I-LL+NM12 ) = COSL - RWORK( I-LL+NM13 ) = -SINL - 150 CONTINUE - E( LL ) = F -* -* Test convergence -* - IF( ABS( E( LL ) ).LE.THRESH ) - $ E( LL ) = ZERO -* -* Update singular vectors if desired -* - IF( NCVT.GT.0 ) - $ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ), - $ RWORK( NM13+1 ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ), - $ RWORK( N ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ), - $ RWORK( N ), C( LL, 1 ), LDC ) - END IF - END IF -* -* QR iteration finished, go back and check convergence -* - GO TO 60 -* -* All singular values converged, so make them positive -* - 160 CONTINUE - DO 170 I = 1, N - IF( D( I ).LT.ZERO ) THEN - D( I ) = -D( I ) -* -* Change sign of singular vectors, if desired -* - IF( NCVT.GT.0 ) - $ CALL ZDSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT ) - END IF - 170 CONTINUE -* -* Sort the singular values into decreasing order (insertion sort on -* singular values, but only one transposition per singular vector) -* - DO 190 I = 1, N - 1 -* -* Scan for smallest D(I) -* - ISUB = 1 - SMIN = D( 1 ) - DO 180 J = 2, N + 1 - I - IF( D( J ).LE.SMIN ) THEN - ISUB = J - SMIN = D( J ) - END IF - 180 CONTINUE - IF( ISUB.NE.N+1-I ) THEN -* -* Swap singular values and vectors -* - D( ISUB ) = D( N+1-I ) - D( N+1-I ) = SMIN - IF( NCVT.GT.0 ) - $ CALL ZSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ), - $ LDVT ) - IF( NRU.GT.0 ) - $ CALL ZSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 ) - IF( NCC.GT.0 ) - $ CALL ZSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC ) - END IF - 190 CONTINUE - GO TO 220 -* -* Maximum number of iterations exceeded, failure to converge -* - 200 CONTINUE - INFO = 0 - DO 210 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 210 CONTINUE - 220 CONTINUE - RETURN -* -* End of ZBDSQR -* - END - - SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, - $ INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) - COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZGEBRD reduces a general complex M-by-N matrix A to upper or lower -* bidiagonal form B by a unitary transformation: Q**H * A * P = B. -* -* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows in the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns in the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the M-by-N general matrix to be reduced. -* On exit, -* if m >= n, the diagonal and the first superdiagonal are -* overwritten with the upper bidiagonal matrix B; the -* elements below the diagonal, with the array TAUQ, represent -* the unitary matrix Q as a product of elementary -* reflectors, and the elements above the first superdiagonal, -* with the array TAUP, represent the unitary matrix P as -* a product of elementary reflectors; -* if m < n, the diagonal and the first subdiagonal are -* overwritten with the lower bidiagonal matrix B; the -* elements below the first subdiagonal, with the array TAUQ, -* represent the unitary matrix Q as a product of -* elementary reflectors, and the elements above the diagonal, -* with the array TAUP, represent the unitary matrix P as -* a product of elementary reflectors. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* D (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The diagonal elements of the bidiagonal matrix B: -* D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) -* The off-diagonal elements of the bidiagonal matrix B: -* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; -* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. -* -* TAUQ (output) COMPLEX*16 array dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the unitary matrix Q. See Further Details. -* -* TAUP (output) COMPLEX*16 array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the unitary matrix P. See Further Details. -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The length of the array WORK. LWORK >= max(1,M,N). -* For optimum performance LWORK >= (M+N)*NB, where NB -* is the optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* The matrices Q and P are represented as products of elementary -* reflectors: -* -* If m >= n, -* -* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are complex scalars, and v and u are complex -* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in -* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in -* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* If m < n, -* -* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are complex scalars, and v and u are complex -* vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in -* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in -* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* The contents of A on exit are illustrated by the following examples: -* -* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -* -* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) -* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) -* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) -* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) -* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) -* ( v1 v2 v3 v4 v5 ) -* -* where d and e denote diagonal and off-diagonal elements of B, vi -* denotes an element of the vector defining H(i), and ui an element of -* the vector defining G(i). -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, - $ NBMIN, NX - DOUBLE PRECISION WS -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGEBD2, ZGEMM, ZLABRD -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - NB = MAX( 1, ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) ) - LWKOPT = ( M+N )*NB - WORK( 1 ) = DBLE( LWKOPT ) - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN - INFO = -10 - END IF - IF( INFO.LT.0 ) THEN - CALL XERBLA( 'ZGEBRD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - MINMN = MIN( M, N ) - IF( MINMN.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - WS = MAX( M, N ) - LDWRKX = M - LDWRKY = N -* - IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN -* -* Set the crossover point NX. -* - NX = MAX( NB, ILAENV( 3, 'ZGEBRD', ' ', M, N, -1, -1 ) ) -* -* Determine when to switch from blocked to unblocked code. -* - IF( NX.LT.MINMN ) THEN - WS = ( M+N )*NB - IF( LWORK.LT.WS ) THEN -* -* Not enough work space for the optimal NB, consider using -* a smaller block size. -* - NBMIN = ILAENV( 2, 'ZGEBRD', ' ', M, N, -1, -1 ) - IF( LWORK.GE.( M+N )*NBMIN ) THEN - NB = LWORK / ( M+N ) - ELSE - NB = 1 - NX = MINMN - END IF - END IF - END IF - ELSE - NX = MINMN - END IF -* - DO 30 I = 1, MINMN - NX, NB -* -* Reduce rows and columns i:i+ib-1 to bidiagonal form and return -* the matrices X and Y which are needed to update the unreduced -* part of the matrix -* - CALL ZLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), - $ TAUQ( I ), TAUP( I ), WORK, LDWRKX, - $ WORK( LDWRKX*NB+1 ), LDWRKY ) -* -* Update the trailing submatrix A(i+ib:m,i+ib:n), using -* an update of the form A := A - V*Y' - X*U' -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-I-NB+1, - $ N-I-NB+1, NB, -ONE, A( I+NB, I ), LDA, - $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, - $ A( I+NB, I+NB ), LDA ) - CALL ZGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, - $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, - $ ONE, A( I+NB, I+NB ), LDA ) -* -* Copy diagonal and off-diagonal elements of B back into A -* - IF( M.GE.N ) THEN - DO 10 J = I, I + NB - 1 - A( J, J ) = D( J ) - A( J, J+1 ) = E( J ) - 10 CONTINUE - ELSE - DO 20 J = I, I + NB - 1 - A( J, J ) = D( J ) - A( J+1, J ) = E( J ) - 20 CONTINUE - END IF - 30 CONTINUE -* -* Use unblocked code to reduce the remainder of the matrix -* - CALL ZGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), - $ TAUQ( I ), TAUP( I ), WORK, IINFO ) - WORK( 1 ) = WS - RETURN -* -* End of ZGEBRD -* - END - SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZGELQF computes an LQ factorization of a complex M-by-N matrix A: -* A = L * Q. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the M-by-N matrix A. -* On exit, the elements on and below the diagonal of the array -* contain the m-by-min(m,n) lower trapezoidal matrix L (L is -* lower triangular if m <= n); the elements above the diagonal, -* with the array TAU, represent the unitary matrix Q as a -* product of elementary reflectors (see Further Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) COMPLEX*16 array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,M). -* For optimum performance LWORK >= M*NB, where NB is the -* optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a complex scalar, and v is a complex vector with -* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in -* A(i,i+1:n), and tau in TAU(i). -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGELQ2, ZLARFB, ZLARFT -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) - LWKOPT = M*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGELQF', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = M - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'ZGELQF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = M - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZGELQF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the LQ factorization of the current block -* A(i:i+ib-1,i:n) -* - CALL ZGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.M ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(i+ib:m,i:n) from the right -* - CALL ZLARFB( 'Right', 'No transpose', 'Forward', - $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), - $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, - $ WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL ZGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of ZGELQF -* - END - SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER VECT - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNGBR generates one of the complex unitary matrices Q or P**H -* determined by ZGEBRD when reducing a complex matrix A to bidiagonal -* form: A = Q * B * P**H. Q and P**H are defined as products of -* elementary reflectors H(i) or G(i) respectively. -* -* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q -* is of order M: -* if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n -* columns of Q, where m >= n >= k; -* if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an -* M-by-M matrix. -* -* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H -* is of order N: -* if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m -* rows of P**H, where n >= m >= k; -* if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as -* an N-by-N matrix. -* -* Arguments -* ========= -* -* VECT (input) CHARACTER*1 -* Specifies whether the matrix Q or the matrix P**H is -* required, as defined in the transformation applied by ZGEBRD: -* = 'Q': generate Q; -* = 'P': generate P**H. -* -* M (input) INTEGER -* The number of rows of the matrix Q or P**H to be returned. -* M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q or P**H to be returned. -* N >= 0. -* If VECT = 'Q', M >= N >= min(M,K); -* if VECT = 'P', N >= M >= min(N,K). -* -* K (input) INTEGER -* If VECT = 'Q', the number of columns in the original M-by-K -* matrix reduced by ZGEBRD. -* If VECT = 'P', the number of rows in the original K-by-N -* matrix reduced by ZGEBRD. -* K >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the vectors which define the elementary reflectors, -* as returned by ZGEBRD. -* On exit, the M-by-N matrix Q or P**H. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= M. -* -* TAU (input) COMPLEX*16 array, dimension -* (min(M,K)) if VECT = 'Q' -* (min(N,K)) if VECT = 'P' -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i) or G(i), which determines Q or P**H, as -* returned by ZGEBRD in its array argument TAUQ or TAUP. -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,min(M,N)). -* For optimum performance LWORK >= min(M,N)*NB, where NB -* is the optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, WANTQ - INTEGER I, IINFO, J, LWKOPT, MN, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZUNGLQ, ZUNGQR -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - WANTQ = LSAME( VECT, 'Q' ) - MN = MIN( M, N ) - LQUERY = ( LWORK.EQ.-1 ) - IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M, - $ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT. - $ MIN( N, K ) ) ) ) THEN - INFO = -3 - ELSE IF( K.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN - INFO = -9 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( WANTQ ) THEN - NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) - ELSE - NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 ) - END IF - LWKOPT = MAX( 1, MN )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNGBR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( WANTQ ) THEN -* -* Form Q, determined by a call to ZGEBRD to reduce an m-by-k -* matrix -* - IF( M.GE.K ) THEN -* -* If m >= k, assume m >= n >= k -* - CALL ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* If m < k, assume m = n -* -* Shift the vectors which define the elementary reflectors one -* column to the right, and set the first row and column of Q -* to those of the unit matrix -* - DO 20 J = M, 2, -1 - A( 1, J ) = ZERO - DO 10 I = J + 1, M - A( I, J ) = A( I, J-1 ) - 10 CONTINUE - 20 CONTINUE - A( 1, 1 ) = ONE - DO 30 I = 2, M - A( I, 1 ) = ZERO - 30 CONTINUE - IF( M.GT.1 ) THEN -* -* Form Q(2:m,2:m) -* - CALL ZUNGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - ELSE -* -* Form P', determined by a call to ZGEBRD to reduce a k-by-n -* matrix -* - IF( K.LT.N ) THEN -* -* If k < n, assume k <= m <= n -* - CALL ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* If k >= n, assume m = n -* -* Shift the vectors which define the elementary reflectors one -* row downward, and set the first row and column of P' to -* those of the unit matrix -* - A( 1, 1 ) = ONE - DO 40 I = 2, N - A( I, 1 ) = ZERO - 40 CONTINUE - DO 60 J = 2, N - DO 50 I = J - 1, 2, -1 - A( I, J ) = A( I-1, J ) - 50 CONTINUE - A( 1, J ) = ZERO - 60 CONTINUE - IF( N.GT.1 ) THEN -* -* Form P'(2:n,2:n) -* - CALL ZUNGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNGBR -* - END - SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows, -* which is defined as the first M rows of a product of K elementary -* reflectors of order N -* -* Q = H(k)' . . . H(2)' H(1)' -* -* as returned by ZGELQF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. N >= M. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. M >= K >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the i-th row must contain the vector which defines -* the elementary reflector H(i), for i = 1,2,...,k, as returned -* by ZGELQF in the first k rows of its array argument A. -* On exit, the M-by-N matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) COMPLEX*16 array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZGELQF. -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,M). -* For optimum performance LWORK >= M*NB, where NB is -* the optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit; -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, - $ LWKOPT, NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNGL2 -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, M )*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.M ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNGLQ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = M - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'ZUNGLQ', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = M - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZUNGLQ', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the last block. -* The first kk rows are handled by the block method. -* - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) -* -* Set A(kk+1:m,1:kk) to zero. -* - DO 20 J = 1, KK - DO 10 I = KK + 1, M - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the last or only block. -* - IF( KK.LT.M ) - $ CALL ZUNGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, - $ TAU( KK+1 ), WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF( I+IB.LE.M ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H' to A(i+ib:m,i:n) from the right -* - CALL ZLARFB( 'Right', 'Conjugate transpose', 'Forward', - $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), - $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, - $ WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H' to columns i:n of current block -* - CALL ZUNGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* -* Set columns 1:i-1 of current block to zero -* - DO 40 J = 1, I - 1 - DO 30 L = I, I + IB - 1 - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of ZUNGLQ -* - END - SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, - $ LDC, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS, VECT - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C -* with -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'C': Q**H * C C * Q**H -* -* If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C -* with -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': P * C C * P -* TRANS = 'C': P**H * C C * P**H -* -* Here Q and P**H are the unitary matrices determined by ZGEBRD when -* reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q -* and P**H are defined as products of elementary reflectors H(i) and -* G(i) respectively. -* -* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the -* order of the unitary matrix Q or P**H that is applied. -* -* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: -* if nq >= k, Q = H(1) H(2) . . . H(k); -* if nq < k, Q = H(1) H(2) . . . H(nq-1). -* -* If VECT = 'P', A is assumed to have been a K-by-NQ matrix: -* if k < nq, P = G(1) G(2) . . . G(k); -* if k >= nq, P = G(1) G(2) . . . G(nq-1). -* -* Arguments -* ========= -* -* VECT (input) CHARACTER*1 -* = 'Q': apply Q or Q**H; -* = 'P': apply P or P**H. -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q, Q**H, P or P**H from the Left; -* = 'R': apply Q, Q**H, P or P**H from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q or P; -* = 'C': Conjugate transpose, apply Q**H or P**H. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* If VECT = 'Q', the number of columns in the original -* matrix reduced by ZGEBRD. -* If VECT = 'P', the number of rows in the original -* matrix reduced by ZGEBRD. -* K >= 0. -* -* A (input) COMPLEX*16 array, dimension -* (LDA,min(nq,K)) if VECT = 'Q' -* (LDA,nq) if VECT = 'P' -* The vectors which define the elementary reflectors H(i) and -* G(i), whose products determine the matrices Q and P, as -* returned by ZGEBRD. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If VECT = 'Q', LDA >= max(1,nq); -* if VECT = 'P', LDA >= max(1,min(nq,K)). -* -* TAU (input) COMPLEX*16 array, dimension (min(nq,K)) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i) or G(i) which determines Q or P, as returned -* by ZGEBRD in the array argument TAUQ or TAUP. -* -* C (input/output) COMPLEX*16 array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q -* or P*C or P**H*C or C*P or C*P**H. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN - CHARACTER TRANST - INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZUNMLQ, ZUNMQR -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - APPLYQ = LSAME( VECT, 'Q' ) - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q or P and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( K.LT.0 ) THEN - INFO = -6 - ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. - $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) - $ THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -11 - ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( APPLYQ ) THEN - IF( LEFT ) THEN - NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - ELSE - IF( LEFT ) THEN - NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - END IF - LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNMBR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - END IF -* -* Quick return if possible -* - WORK( 1 ) = 1 - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - IF( APPLYQ ) THEN -* -* Apply Q -* - IF( NQ.GE.K ) THEN -* -* Q was determined by a call to ZGEBRD with nq >= k -* - CALL ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, IINFO ) - ELSE IF( NQ.GT.1 ) THEN -* -* Q was determined by a call to ZGEBRD with nq < k -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - I1 = 2 - I2 = 1 - ELSE - MI = M - NI = N - 1 - I1 = 1 - I2 = 2 - END IF - CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, - $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - ELSE -* -* Apply P -* - IF( NOTRAN ) THEN - TRANST = 'C' - ELSE - TRANST = 'N' - END IF - IF( NQ.GT.K ) THEN -* -* P was determined by a call to ZGEBRD with nq > k -* - CALL ZUNMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, IINFO ) - ELSE IF( NQ.GT.1 ) THEN -* -* P was determined by a call to ZGEBRD with nq <= k -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - I1 = 2 - I2 = 1 - ELSE - MI = M - NI = N - 1 - I1 = 1 - I2 = 2 - END IF - CALL ZUNMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, - $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNMBR -* - END - SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) - COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZGEBD2 reduces a complex general m by n matrix A to upper or lower -* real bidiagonal form B by a unitary transformation: Q' * A * P = B. -* -* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows in the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns in the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the m by n general matrix to be reduced. -* On exit, -* if m >= n, the diagonal and the first superdiagonal are -* overwritten with the upper bidiagonal matrix B; the -* elements below the diagonal, with the array TAUQ, represent -* the unitary matrix Q as a product of elementary -* reflectors, and the elements above the first superdiagonal, -* with the array TAUP, represent the unitary matrix P as -* a product of elementary reflectors; -* if m < n, the diagonal and the first subdiagonal are -* overwritten with the lower bidiagonal matrix B; the -* elements below the first subdiagonal, with the array TAUQ, -* represent the unitary matrix Q as a product of -* elementary reflectors, and the elements above the diagonal, -* with the array TAUP, represent the unitary matrix P as -* a product of elementary reflectors. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* D (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The diagonal elements of the bidiagonal matrix B: -* D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) -* The off-diagonal elements of the bidiagonal matrix B: -* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; -* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. -* -* TAUQ (output) COMPLEX*16 array dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the unitary matrix Q. See Further Details. -* -* TAUP (output) COMPLEX*16 array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the unitary matrix P. See Further Details. -* -* WORK (workspace) COMPLEX*16 array, dimension (max(M,N)) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* The matrices Q and P are represented as products of elementary -* reflectors: -* -* If m >= n, -* -* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are complex scalars, and v and u are complex -* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in -* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in -* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* If m < n, -* -* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are complex scalars, v and u are complex vectors; -* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); -* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); -* tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* The contents of A on exit are illustrated by the following examples: -* -* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -* -* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) -* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) -* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) -* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) -* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) -* ( v1 v2 v3 v4 v5 ) -* -* where d and e denote diagonal and off-diagonal elements of B, vi -* denotes an element of the vector defining H(i), and ui an element of -* the vector defining G(i). -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I - COMPLEX*16 ALPHA -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.LT.0 ) THEN - CALL XERBLA( 'ZGEBD2', -INFO ) - RETURN - END IF -* - IF( M.GE.N ) THEN -* -* Reduce to upper bidiagonal form -* - DO 10 I = 1, N -* -* Generate elementary reflector H(i) to annihilate A(i+1:m,i) -* - ALPHA = A( I, I ) - CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1, - $ TAUQ( I ) ) - D( I ) = ALPHA - A( I, I ) = ONE -* -* Apply H(i)' to A(i:m,i+1:n) from the left -* - CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, - $ DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) - A( I, I ) = D( I ) -* - IF( I.LT.N ) THEN -* -* Generate elementary reflector G(i) to annihilate -* A(i,i+2:n) -* - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - ALPHA = A( I, I+1 ) - CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA, - $ TAUP( I ) ) - E( I ) = ALPHA - A( I, I+1 ) = ONE -* -* Apply G(i) to A(i+1:m,i+1:n) from the right -* - CALL ZLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, - $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - A( I, I+1 ) = E( I ) - ELSE - TAUP( I ) = ZERO - END IF - 10 CONTINUE - ELSE -* -* Reduce to lower bidiagonal form -* - DO 20 I = 1, M -* -* Generate elementary reflector G(i) to annihilate A(i,i+1:n) -* - CALL ZLACGV( N-I+1, A( I, I ), LDA ) - ALPHA = A( I, I ) - CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, - $ TAUP( I ) ) - D( I ) = ALPHA - A( I, I ) = ONE -* -* Apply G(i) to A(i+1:m,i:n) from the right -* - CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ), - $ A( MIN( I+1, M ), I ), LDA, WORK ) - CALL ZLACGV( N-I+1, A( I, I ), LDA ) - A( I, I ) = D( I ) -* - IF( I.LT.M ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(i+2:m,i) -* - ALPHA = A( I+1, I ) - CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1, - $ TAUQ( I ) ) - E( I ) = ALPHA - A( I+1, I ) = ONE -* -* Apply H(i)' to A(i+1:m,i+1:n) from the left -* - CALL ZLARF( 'Left', M-I, N-I, A( I+1, I ), 1, - $ DCONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA, - $ WORK ) - A( I+1, I ) = E( I ) - ELSE - TAUQ( I ) = ZERO - END IF - 20 CONTINUE - END IF - RETURN -* -* End of ZGEBD2 -* - END - SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZGELQ2 computes an LQ factorization of a complex m by n matrix A: -* A = L * Q. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the m by n matrix A. -* On exit, the elements on and below the diagonal of the array -* contain the m by min(m,n) lower trapezoidal matrix L (L is -* lower triangular if m <= n); the elements above the diagonal, -* with the array TAU, represent the unitary matrix Q as a -* product of elementary reflectors (see Further Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) COMPLEX*16 array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace) COMPLEX*16 array, dimension (M) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a complex scalar, and v is a complex vector with -* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in -* A(i,i+1:n), and tau in TAU(i). -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, K - COMPLEX*16 ALPHA -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGELQ2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i,i+1:n) -* - CALL ZLACGV( N-I+1, A( I, I ), LDA ) - ALPHA = A( I, I ) - CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, - $ TAU( I ) ) - IF( I.LT.M ) THEN -* -* Apply H(i) to A(i+1:m,i:n) from the right -* - A( I, I ) = ONE - CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), - $ A( I+1, I ), LDA, WORK ) - END IF - A( I, I ) = ALPHA - CALL ZLACGV( N-I+1, A( I, I ), LDA ) - 10 CONTINUE - RETURN -* -* End of ZGELQ2 -* - END - SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, - $ LDY ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER LDA, LDX, LDY, M, N, NB -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) - COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ), - $ Y( LDY, * ) -* .. -* -* Purpose -* ======= -* -* ZLABRD reduces the first NB rows and columns of a complex general -* m by n matrix A to upper or lower real bidiagonal form by a unitary -* transformation Q' * A * P, and returns the matrices X and Y which -* are needed to apply the transformation to the unreduced part of A. -* -* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower -* bidiagonal form. -* -* This is an auxiliary routine called by ZGEBRD -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows in the matrix A. -* -* N (input) INTEGER -* The number of columns in the matrix A. -* -* NB (input) INTEGER -* The number of leading rows and columns of A to be reduced. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the m by n general matrix to be reduced. -* On exit, the first NB rows and columns of the matrix are -* overwritten; the rest of the array is unchanged. -* If m >= n, elements on and below the diagonal in the first NB -* columns, with the array TAUQ, represent the unitary -* matrix Q as a product of elementary reflectors; and -* elements above the diagonal in the first NB rows, with the -* array TAUP, represent the unitary matrix P as a product -* of elementary reflectors. -* If m < n, elements below the diagonal in the first NB -* columns, with the array TAUQ, represent the unitary -* matrix Q as a product of elementary reflectors, and -* elements on and above the diagonal in the first NB rows, -* with the array TAUP, represent the unitary matrix P as -* a product of elementary reflectors. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* D (output) DOUBLE PRECISION array, dimension (NB) -* The diagonal elements of the first NB rows and columns of -* the reduced matrix. D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (NB) -* The off-diagonal elements of the first NB rows and columns of -* the reduced matrix. -* -* TAUQ (output) COMPLEX*16 array dimension (NB) -* The scalar factors of the elementary reflectors which -* represent the unitary matrix Q. See Further Details. -* -* TAUP (output) COMPLEX*16 array, dimension (NB) -* The scalar factors of the elementary reflectors which -* represent the unitary matrix P. See Further Details. -* -* X (output) COMPLEX*16 array, dimension (LDX,NB) -* The m-by-nb matrix X required to update the unreduced part -* of A. -* -* LDX (input) INTEGER -* The leading dimension of the array X. LDX >= max(1,M). -* -* Y (output) COMPLEX*16 array, dimension (LDY,NB) -* The n-by-nb matrix Y required to update the unreduced part -* of A. -* -* LDY (output) INTEGER -* The leading dimension of the array Y. LDY >= max(1,N). -* -* Further Details -* =============== -* -* The matrices Q and P are represented as products of elementary -* reflectors: -* -* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are complex scalars, and v and u are complex -* vectors. -* -* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in -* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in -* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in -* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in -* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* The elements of the vectors v and u together form the m-by-nb matrix -* V and the nb-by-n matrix U' which are needed, with X and Y, to apply -* the transformation to the unreduced part of the matrix, using a block -* update of the form: A := A - V*Y' - X*U'. -* -* The contents of A on exit are illustrated by the following examples -* with nb = 2: -* -* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -* -* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) -* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) -* ( v1 v2 a a a ) ( v1 1 a a a a ) -* ( v1 v2 a a a ) ( v1 v2 a a a a ) -* ( v1 v2 a a a ) ( v1 v2 a a a a ) -* ( v1 v2 a a a ) -* -* where a denotes an element of the original matrix which is unchanged, -* vi denotes an element of the vector defining H(i), and ui an element -* of the vector defining G(i). -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I - COMPLEX*16 ALPHA -* .. -* .. External Subroutines .. - EXTERNAL ZGEMV, ZLACGV, ZLARFG, ZSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( M.GE.N ) THEN -* -* Reduce to upper bidiagonal form -* - DO 10 I = 1, NB -* -* Update A(i:m,i) -* - CALL ZLACGV( I-1, Y( I, 1 ), LDY ) - CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), - $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 ) - CALL ZLACGV( I-1, Y( I, 1 ), LDY ) - CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), - $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) -* -* Generate reflection Q(i) to annihilate A(i+1:m,i) -* - ALPHA = A( I, I ) - CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1, - $ TAUQ( I ) ) - D( I ) = ALPHA - IF( I.LT.N ) THEN - A( I, I ) = ONE -* -* Compute Y(i+1:n,i) -* - CALL ZGEMV( 'Conjugate transpose', M-I+1, N-I, ONE, - $ A( I, I+1 ), LDA, A( I, I ), 1, ZERO, - $ Y( I+1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE, - $ A( I, 1 ), LDA, A( I, I ), 1, ZERO, - $ Y( 1, I ), 1 ) - CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), - $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE, - $ X( I, 1 ), LDX, A( I, I ), 1, ZERO, - $ Y( 1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE, - $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE, - $ Y( I+1, I ), 1 ) - CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) -* -* Update A(i,i+1:n) -* - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - CALL ZLACGV( I, A( I, 1 ), LDA ) - CALL ZGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), - $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA ) - CALL ZLACGV( I, A( I, 1 ), LDA ) - CALL ZLACGV( I-1, X( I, 1 ), LDX ) - CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE, - $ A( 1, I+1 ), LDA, X( I, 1 ), LDX, ONE, - $ A( I, I+1 ), LDA ) - CALL ZLACGV( I-1, X( I, 1 ), LDX ) -* -* Generate reflection P(i) to annihilate A(i,i+2:n) -* - ALPHA = A( I, I+1 ) - CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA, - $ TAUP( I ) ) - E( I ) = ALPHA - A( I, I+1 ) = ONE -* -* Compute X(i+1:m,i) -* - CALL ZGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), - $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', N-I, I, ONE, - $ Y( I+1, 1 ), LDY, A( I, I+1 ), LDA, ZERO, - $ X( 1, I ), 1 ) - CALL ZGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), - $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) - CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), - $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - END IF - 10 CONTINUE - ELSE -* -* Reduce to lower bidiagonal form -* - DO 20 I = 1, NB -* -* Update A(i,i:n) -* - CALL ZLACGV( N-I+1, A( I, I ), LDA ) - CALL ZLACGV( I-1, A( I, 1 ), LDA ) - CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), - $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA ) - CALL ZLACGV( I-1, A( I, 1 ), LDA ) - CALL ZLACGV( I-1, X( I, 1 ), LDX ) - CALL ZGEMV( 'Conjugate transpose', I-1, N-I+1, -ONE, - $ A( 1, I ), LDA, X( I, 1 ), LDX, ONE, A( I, I ), - $ LDA ) - CALL ZLACGV( I-1, X( I, 1 ), LDX ) -* -* Generate reflection P(i) to annihilate A(i,i+1:n) -* - ALPHA = A( I, I ) - CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, - $ TAUP( I ) ) - D( I ) = ALPHA - IF( I.LT.M ) THEN - A( I, I ) = ONE -* -* Compute X(i+1:m,i) -* - CALL ZGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), - $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1, ONE, - $ Y( I, 1 ), LDY, A( I, I ), LDA, ZERO, - $ X( 1, I ), 1 ) - CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL ZGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), - $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) - CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), - $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) - CALL ZLACGV( N-I+1, A( I, I ), LDA ) -* -* Update A(i+1:m,i) -* - CALL ZLACGV( I-1, Y( I, 1 ), LDY ) - CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 ) - CALL ZLACGV( I-1, Y( I, 1 ), LDY ) - CALL ZGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), - $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) -* -* Generate reflection Q(i) to annihilate A(i+2:m,i) -* - ALPHA = A( I+1, I ) - CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1, - $ TAUQ( I ) ) - E( I ) = ALPHA - A( I+1, I ) = ONE -* -* Compute Y(i+1:n,i) -* - CALL ZGEMV( 'Conjugate transpose', M-I, N-I, ONE, - $ A( I+1, I+1 ), LDA, A( I+1, I ), 1, ZERO, - $ Y( I+1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', M-I, I-1, ONE, - $ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO, - $ Y( 1, I ), 1 ) - CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), - $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', M-I, I, ONE, - $ X( I+1, 1 ), LDX, A( I+1, I ), 1, ZERO, - $ Y( 1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', I, N-I, -ONE, - $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE, - $ Y( I+1, I ), 1 ) - CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) - ELSE - CALL ZLACGV( N-I+1, A( I, I ), LDA ) - END IF - 20 CONTINUE - END IF - RETURN -* -* End of ZLABRD -* - END - SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows, -* which is defined as the first m rows of a product of k elementary -* reflectors of order n -* -* Q = H(k)' . . . H(2)' H(1)' -* -* as returned by ZGELQF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. N >= M. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. M >= K >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the i-th row must contain the vector which defines -* the elementary reflector H(i), for i = 1,2,...,k, as returned -* by ZGELQF in the first k rows of its array argument A. -* On exit, the m by n matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) COMPLEX*16 array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZGELQF. -* -* WORK (workspace) COMPLEX*16 array, dimension (M) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLACGV, ZLARF, ZSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.M ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNGL2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 ) - $ RETURN -* - IF( K.LT.M ) THEN -* -* Initialise rows k+1:m to rows of the unit matrix -* - DO 20 J = 1, N - DO 10 L = K + 1, M - A( L, J ) = ZERO - 10 CONTINUE - IF( J.GT.K .AND. J.LE.M ) - $ A( J, J ) = ONE - 20 CONTINUE - END IF -* - DO 40 I = K, 1, -1 -* -* Apply H(i)' to A(i:m,i:n) from the right -* - IF( I.LT.N ) THEN - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - IF( I.LT.M ) THEN - A( I, I ) = ONE - CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ DCONJG( TAU( I ) ), A( I+1, I ), LDA, WORK ) - END IF - CALL ZSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - END IF - A( I, I ) = ONE - DCONJG( TAU( I ) ) -* -* Set A(i,1:i-1) to zero -* - DO 30 L = 1, I - 1 - A( I, L ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of ZUNGL2 -* - END - SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNMLQ overwrites the general complex M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'C': Q**H * C C * Q**H -* -* where Q is a complex unitary matrix defined as the product of k -* elementary reflectors -* -* Q = H(k)' . . . H(2)' H(1)' -* -* as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**H from the Left; -* = 'R': apply Q or Q**H from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'C': Conjugate transpose, apply Q**H. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) COMPLEX*16 array, dimension -* (LDA,M) if SIDE = 'L', -* (LDA,N) if SIDE = 'R' -* The i-th row must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* ZGELQF in the first k rows of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,K). -* -* TAU (input) COMPLEX*16 array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZGELQF. -* -* C (input/output) COMPLEX*16 array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - CHARACTER TRANST - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - COMPLEX*16 T( LDT, NBMAX ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNML2 -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNMLQ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZUNMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IF( ( LEFT .AND. NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - IF( NOTRAN ) THEN - TRANST = 'C' - ELSE - TRANST = 'N' - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL ZLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), T, LDT ) - IF( LEFT ) THEN -* -* H or H' is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H' is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H' -* - CALL ZLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, - $ A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, WORK, - $ LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNMLQ -* - END - SUBROUTINE DLASQ2( N, Z, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* Purpose -* ======= -* -* DLASQ2 computes all the eigenvalues of the symmetric positive -* definite tridiagonal matrix associated with the qd array Z to high -* relative accuracy are computed to high relative accuracy, in the -* absence of denormalization, underflow and overflow. -* -* To see the relation of Z to the tridiagonal matrix, let L be a -* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and -* let U be an upper bidiagonal matrix with 1's above and diagonal -* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the -* symmetric tridiagonal to which it is similar. -* -* Note : DLASQ2 defines a logical variable, IEEE, which is true -* on machines which follow ieee-754 floating-point standard in their -* handling of infinities and NaNs, and false otherwise. This variable -* is passed to DLASQ3. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of rows and columns in the matrix. N >= 0. -* -* Z (workspace) DOUBLE PRECISION array, dimension ( 4*N ) -* On entry Z holds the qd array. On exit, entries 1 to N hold -* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the -* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If -* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 ) -* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of -* shifts that failed. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if the i-th argument is a scalar and had an illegal -* value, then INFO = -i, if the i-th argument is an -* array and the j-entry had an illegal value, then -* INFO = -(i*100+j) -* > 0: the algorithm failed -* = 1, a split was marked by a positive value in E -* = 2, current block of Z not diagonalized after 30*N -* iterations (in inner while loop) -* = 3, termination criterion of outer while loop not met -* (program created more than N unreduced blocks) -* -* Further Details -* =============== -* Local Variables: I0:N0 defines a current unreduced segment of Z. -* The shifts are accumulated in SIGMA. Iteration count is in ITER. -* Ping-pong is controlled by PP (alternates between 0 and 1). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION CBIAS - PARAMETER ( CBIAS = 1.50D0 ) - DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, HUNDRD - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, - $ TWO = 2.0D0, FOUR = 4.0D0, HUNDRD = 100.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL IEEE - INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, - $ N0, NBIG, NDIV, NFAIL, PP, SPLT - DOUBLE PRECISION D, DESIG, DMIN, E, EMAX, EMIN, EPS, OLDEMN, - $ QMAX, QMIN, S, SAFMIN, SIGMA, T, TEMP, TOL, - $ TOL2, TRACE, ZMAX -* .. -* .. External Subroutines .. - EXTERNAL DLASQ3, DLASRT, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input arguments. -* (in case DLASQ2 is not called by DLASQ1) -* - INFO = 0 - EPS = DLAMCH( 'Precision' ) - SAFMIN = DLAMCH( 'Safe minimum' ) - TOL = EPS*HUNDRD - TOL2 = TOL**2 -* - IF( N.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'DLASQ2', 1 ) - RETURN - ELSE IF( N.EQ.0 ) THEN - RETURN - ELSE IF( N.EQ.1 ) THEN -* -* 1-by-1 case. -* - IF( Z( 1 ).LT.ZERO ) THEN - INFO = -201 - CALL XERBLA( 'DLASQ2', 2 ) - END IF - RETURN - ELSE IF( N.EQ.2 ) THEN -* -* 2-by-2 case. -* - IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN - INFO = -2 - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN - D = Z( 3 ) - Z( 3 ) = Z( 1 ) - Z( 1 ) = D - END IF - Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 ) - IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN - T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) ) - S = Z( 3 )*( Z( 2 ) / T ) - IF( S.LE.T ) THEN - S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) ) - ELSE - S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) - END IF - T = Z( 1 ) + ( S+Z( 2 ) ) - Z( 3 ) = Z( 3 )*( Z( 1 ) / T ) - Z( 1 ) = T - END IF - Z( 2 ) = Z( 3 ) - Z( 6 ) = Z( 2 ) + Z( 1 ) - RETURN - END IF -* -* Check for negative data and compute sums of q's and e's. -* - Z( 2*N ) = ZERO - EMIN = Z( 2 ) - QMAX = ZERO - ZMAX = ZERO - D = ZERO - E = ZERO -* - DO 10 K = 1, 2*( N-1 ), 2 - IF( Z( K ).LT.ZERO ) THEN - INFO = -( 200+K ) - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - ELSE IF( Z( K+1 ).LT.ZERO ) THEN - INFO = -( 200+K+1 ) - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - END IF - D = D + Z( K ) - E = E + Z( K+1 ) - QMAX = MAX( QMAX, Z( K ) ) - EMIN = MIN( EMIN, Z( K+1 ) ) - ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) ) - 10 CONTINUE - IF( Z( 2*N-1 ).LT.ZERO ) THEN - INFO = -( 200+2*N-1 ) - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - END IF - D = D + Z( 2*N-1 ) - QMAX = MAX( QMAX, Z( 2*N-1 ) ) - ZMAX = MAX( QMAX, ZMAX ) -* -* Check for diagonality. -* - IF( E.EQ.ZERO ) THEN - DO 20 K = 2, N - Z( K ) = Z( 2*K-1 ) - 20 CONTINUE - CALL DLASRT( 'D', N, Z, IINFO ) - Z( 2*N-1 ) = D - RETURN - END IF -* - TRACE = D + E -* -* Check for zero data. -* - IF( TRACE.EQ.ZERO ) THEN - Z( 2*N-1 ) = ZERO - RETURN - END IF -* -* Check whether the machine is IEEE conformable. -* - IEEE = ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND. - $ ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 -* -* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). -* - DO 30 K = 2*N, 2, -2 - Z( 2*K ) = ZERO - Z( 2*K-1 ) = Z( K ) - Z( 2*K-2 ) = ZERO - Z( 2*K-3 ) = Z( K-1 ) - 30 CONTINUE -* - I0 = 1 - N0 = N -* -* Reverse the qd-array, if warranted. -* - IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN - IPN4 = 4*( I0+N0 ) - DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4 - TEMP = Z( I4-3 ) - Z( I4-3 ) = Z( IPN4-I4-3 ) - Z( IPN4-I4-3 ) = TEMP - TEMP = Z( I4-1 ) - Z( I4-1 ) = Z( IPN4-I4-5 ) - Z( IPN4-I4-5 ) = TEMP - 40 CONTINUE - END IF -* -* Initial split checking via dqd and Li's test. -* - PP = 0 -* - DO 80 K = 1, 2 -* - D = Z( 4*N0+PP-3 ) - DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4 - IF( Z( I4-1 ).LE.TOL2*D ) THEN - Z( I4-1 ) = -ZERO - D = Z( I4-3 ) - ELSE - D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) ) - END IF - 50 CONTINUE -* -* dqd maps Z to ZZ plus Li's test. -* - EMIN = Z( 4*I0+PP+1 ) - D = Z( 4*I0+PP-3 ) - DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4 - Z( I4-2*PP-2 ) = D + Z( I4-1 ) - IF( Z( I4-1 ).LE.TOL2*D ) THEN - Z( I4-1 ) = -ZERO - Z( I4-2*PP-2 ) = D - Z( I4-2*PP ) = ZERO - D = Z( I4+1 ) - ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND. - $ SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN - TEMP = Z( I4+1 ) / Z( I4-2*PP-2 ) - Z( I4-2*PP ) = Z( I4-1 )*TEMP - D = D*TEMP - ELSE - Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) ) - D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) ) - END IF - EMIN = MIN( EMIN, Z( I4-2*PP ) ) - 60 CONTINUE - Z( 4*N0-PP-2 ) = D -* -* Now find qmax. -* - QMAX = Z( 4*I0-PP-2 ) - DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4 - QMAX = MAX( QMAX, Z( I4 ) ) - 70 CONTINUE -* -* Prepare for the next iteration on K. -* - PP = 1 - PP - 80 CONTINUE -* - ITER = 2 - NFAIL = 0 - NDIV = 2*( N0-I0 ) -* - DO 140 IWHILA = 1, N + 1 - IF( N0.LT.1 ) - $ GO TO 150 -* -* While array unfinished do -* -* E(N0) holds the value of SIGMA when submatrix in I0:N0 -* splits from the rest of the array, but is negated. -* - DESIG = ZERO - IF( N0.EQ.N ) THEN - SIGMA = ZERO - ELSE - SIGMA = -Z( 4*N0-1 ) - END IF - IF( SIGMA.LT.ZERO ) THEN - INFO = 1 - RETURN - END IF -* -* Find last unreduced submatrix's top index I0, find QMAX and -* EMIN. Find Gershgorin-type bound if Q's much greater than E's. -* - EMAX = ZERO - IF( N0.GT.I0 ) THEN - EMIN = ABS( Z( 4*N0-5 ) ) - ELSE - EMIN = ZERO - END IF - QMIN = Z( 4*N0-3 ) - QMAX = QMIN - DO 90 I4 = 4*N0, 8, -4 - IF( Z( I4-5 ).LE.ZERO ) - $ GO TO 100 - IF( QMIN.GE.FOUR*EMAX ) THEN - QMIN = MIN( QMIN, Z( I4-3 ) ) - EMAX = MAX( EMAX, Z( I4-5 ) ) - END IF - QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) ) - EMIN = MIN( EMIN, Z( I4-5 ) ) - 90 CONTINUE - I4 = 4 -* - 100 CONTINUE - I0 = I4 / 4 -* -* Store EMIN for passing to DLASQ3. -* - Z( 4*N0-1 ) = EMIN -* -* Put -(initial shift) into DMIN. -* - DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) ) -* -* Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong. -* - PP = 0 -* - NBIG = 30*( N0-I0+1 ) - DO 120 IWHILB = 1, NBIG - IF( I0.GT.N0 ) - $ GO TO 130 -* -* While submatrix unfinished take a good dqds step. -* - CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, - $ ITER, NDIV, IEEE ) -* - PP = 1 - PP -* -* When EMIN is very small check for splits. -* - IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN - IF( Z( 4*N0 ).LE.TOL2*QMAX .OR. - $ Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN - SPLT = I0 - 1 - QMAX = Z( 4*I0-3 ) - EMIN = Z( 4*I0-1 ) - OLDEMN = Z( 4*I0 ) - DO 110 I4 = 4*I0, 4*( N0-3 ), 4 - IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR. - $ Z( I4-1 ).LE.TOL2*SIGMA ) THEN - Z( I4-1 ) = -SIGMA - SPLT = I4 / 4 - QMAX = ZERO - EMIN = Z( I4+3 ) - OLDEMN = Z( I4+4 ) - ELSE - QMAX = MAX( QMAX, Z( I4+1 ) ) - EMIN = MIN( EMIN, Z( I4-1 ) ) - OLDEMN = MIN( OLDEMN, Z( I4 ) ) - END IF - 110 CONTINUE - Z( 4*N0-1 ) = EMIN - Z( 4*N0 ) = OLDEMN - I0 = SPLT + 1 - END IF - END IF -* - 120 CONTINUE -* - INFO = 2 - RETURN -* -* end IWHILB -* - 130 CONTINUE -* - 140 CONTINUE -* - INFO = 3 - RETURN -* -* end IWHILA -* - 150 CONTINUE -* -* Move q's to the front. -* - DO 160 K = 2, N - Z( K ) = Z( 4*K-3 ) - 160 CONTINUE -* -* Sort and compute sum of eigenvalues. -* - CALL DLASRT( 'D', N, Z, IINFO ) -* - E = ZERO - DO 170 K = N, 1, -1 - E = E + Z( K ) - 170 CONTINUE -* -* Store trace, sum(eigenvalues) and information on performance. -* - Z( 2*N+1 ) = TRACE - Z( 2*N+2 ) = E - Z( 2*N+3 ) = DBLE( ITER ) - Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 ) - Z( 2*N+5 ) = HUNDRD*NFAIL / DBLE( ITER ) - RETURN -* -* End of DLASQ2 -* - END - SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, - $ ITER, NDIV, IEEE ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* May 17, 2000 -* -* .. Scalar Arguments .. - LOGICAL IEEE - INTEGER I0, ITER, N0, NDIV, NFAIL, PP - DOUBLE PRECISION DESIG, DMIN, QMAX, SIGMA -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* Purpose -* ======= -* -* DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. -* In case of failure it changes shifts, and tries again until output -* is positive. -* -* Arguments -* ========= -* -* I0 (input) INTEGER -* First index. -* -* N0 (input) INTEGER -* Last index. -* -* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) -* Z holds the qd array. -* -* PP (input) INTEGER -* PP=0 for ping, PP=1 for pong. -* -* DMIN (output) DOUBLE PRECISION -* Minimum value of d. -* -* SIGMA (output) DOUBLE PRECISION -* Sum of shifts used in current segment. -* -* DESIG (input/output) DOUBLE PRECISION -* Lower order part of SIGMA -* -* QMAX (input) DOUBLE PRECISION -* Maximum value of q. -* -* NFAIL (output) INTEGER -* Number of times shift was too big. -* -* ITER (output) INTEGER -* Number of iterations. -* -* NDIV (output) INTEGER -* Number of divisions. -* -* TTYPE (output) INTEGER -* Shift type. -* -* IEEE (input) LOGICAL -* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION CBIAS - PARAMETER ( CBIAS = 1.50D0 ) - DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD - PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0, - $ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 ) -* .. -* .. Local Scalars .. - INTEGER IPN4, J4, N0IN, NN, TTYPE - DOUBLE PRECISION DMIN1, DMIN2, DN, DN1, DN2, EPS, S, SAFMIN, T, - $ TAU, TEMP, TOL, TOL2 -* .. -* .. External Subroutines .. - EXTERNAL DLASQ4, DLASQ5, DLASQ6 -* .. -* .. External Function .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MIN, SQRT -* .. -* .. Save statement .. - SAVE TTYPE - SAVE DMIN1, DMIN2, DN, DN1, DN2, TAU -* .. -* .. Data statement .. - DATA TTYPE / 0 / - DATA DMIN1 / ZERO /, DMIN2 / ZERO /, DN / ZERO /, - $ DN1 / ZERO /, DN2 / ZERO /, TAU / ZERO / -* .. -* .. Executable Statements .. -* - N0IN = N0 - EPS = DLAMCH( 'Precision' ) - SAFMIN = DLAMCH( 'Safe minimum' ) - TOL = EPS*HUNDRD - TOL2 = TOL**2 -* -* Check for deflation. -* - 10 CONTINUE -* - IF( N0.LT.I0 ) - $ RETURN - IF( N0.EQ.I0 ) - $ GO TO 20 - NN = 4*N0 + PP - IF( N0.EQ.( I0+1 ) ) - $ GO TO 40 -* -* Check whether E(N0-1) is negligible, 1 eigenvalue. -* - IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND. - $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) ) - $ GO TO 30 -* - 20 CONTINUE -* - Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA - N0 = N0 - 1 - GO TO 10 -* -* Check whether E(N0-2) is negligible, 2 eigenvalues. -* - 30 CONTINUE -* - IF( Z( NN-9 ).GT.TOL2*SIGMA .AND. - $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) ) - $ GO TO 50 -* - 40 CONTINUE -* - IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN - S = Z( NN-3 ) - Z( NN-3 ) = Z( NN-7 ) - Z( NN-7 ) = S - END IF - IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN - T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) ) - S = Z( NN-3 )*( Z( NN-5 ) / T ) - IF( S.LE.T ) THEN - S = Z( NN-3 )*( Z( NN-5 ) / - $ ( T*( ONE+SQRT( ONE+S / T ) ) ) ) - ELSE - S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) - END IF - T = Z( NN-7 ) + ( S+Z( NN-5 ) ) - Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T ) - Z( NN-7 ) = T - END IF - Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA - Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA - N0 = N0 - 2 - GO TO 10 -* - 50 CONTINUE -* -* Reverse the qd-array, if warranted. -* - IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN - IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN - IPN4 = 4*( I0+N0 ) - DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4 - TEMP = Z( J4-3 ) - Z( J4-3 ) = Z( IPN4-J4-3 ) - Z( IPN4-J4-3 ) = TEMP - TEMP = Z( J4-2 ) - Z( J4-2 ) = Z( IPN4-J4-2 ) - Z( IPN4-J4-2 ) = TEMP - TEMP = Z( J4-1 ) - Z( J4-1 ) = Z( IPN4-J4-5 ) - Z( IPN4-J4-5 ) = TEMP - TEMP = Z( J4 ) - Z( J4 ) = Z( IPN4-J4-4 ) - Z( IPN4-J4-4 ) = TEMP - 60 CONTINUE - IF( N0-I0.LE.4 ) THEN - Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 ) - Z( 4*N0-PP ) = Z( 4*I0-PP ) - END IF - DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) ) - Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ), - $ Z( 4*I0+PP+3 ) ) - Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ), - $ Z( 4*I0-PP+4 ) ) - QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) ) - DMIN = -ZERO - END IF - END IF -* - 70 CONTINUE -* - IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ), - $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN -* -* Choose a shift. -* - CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, - $ DN2, TAU, TTYPE ) -* -* Call dqds until DMIN > 0. -* - 80 CONTINUE -* - CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, IEEE ) -* - NDIV = NDIV + ( N0-I0+2 ) - ITER = ITER + 1 -* -* Check status. -* - IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN -* -* Success. -* - GO TO 100 -* - ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. - $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. - $ ABS( DN ).LT.TOL*SIGMA ) THEN -* -* Convergence hidden by negative DN. -* - Z( 4*( N0-1 )-PP+2 ) = ZERO - DMIN = ZERO - GO TO 100 - ELSE IF( DMIN.LT.ZERO ) THEN -* -* TAU too big. Select new TAU and try again. -* - NFAIL = NFAIL + 1 - IF( TTYPE.LT.-22 ) THEN -* -* Failed twice. Play it safe. -* - TAU = ZERO - ELSE IF( DMIN1.GT.ZERO ) THEN -* -* Late failure. Gives excellent shift. -* - TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) - TTYPE = TTYPE - 11 - ELSE -* -* Early failure. Divide by 4. -* - TAU = QURTR*TAU - TTYPE = TTYPE - 12 - END IF - GO TO 80 - ELSE IF( DMIN.NE.DMIN ) THEN -* -* NaN. -* - TAU = ZERO - GO TO 80 - ELSE -* -* Possible underflow. Play it safe. -* - GO TO 90 - END IF - END IF -* -* Risk of underflow. -* - 90 CONTINUE - CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) - NDIV = NDIV + ( N0-I0+2 ) - ITER = ITER + 1 - TAU = ZERO -* - 100 CONTINUE - IF( TAU.LT.SIGMA ) THEN - DESIG = DESIG + TAU - T = SIGMA + DESIG - DESIG = DESIG - ( T-SIGMA ) - ELSE - T = SIGMA + TAU - DESIG = SIGMA - ( T-TAU ) + DESIG - END IF - SIGMA = T -* - RETURN -* -* End of DLASQ3 -* - END - SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, TAU, TTYPE ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 -* -* .. Scalar Arguments .. - INTEGER I0, N0, N0IN, PP, TTYPE - DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* Purpose -* ======= -* -* DLASQ4 computes an approximation TAU to the smallest eigenvalue -* using values of d from the previous transform. -* -* I0 (input) INTEGER -* First index. -* -* N0 (input) INTEGER -* Last index. -* -* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) -* Z holds the qd array. -* -* PP (input) INTEGER -* PP=0 for ping, PP=1 for pong. -* -* NOIN (input) INTEGER -* The value of N0 at start of EIGTEST. -* -* DMIN (input) DOUBLE PRECISION -* Minimum value of d. -* -* DMIN1 (input) DOUBLE PRECISION -* Minimum value of d, excluding D( N0 ). -* -* DMIN2 (input) DOUBLE PRECISION -* Minimum value of d, excluding D( N0 ) and D( N0-1 ). -* -* DN (input) DOUBLE PRECISION -* d(N) -* -* DN1 (input) DOUBLE PRECISION -* d(N-1) -* -* DN2 (input) DOUBLE PRECISION -* d(N-2) -* -* TAU (output) DOUBLE PRECISION -* This is the shift. -* -* TTYPE (output) INTEGER -* Shift type. -* -* Further Details -* =============== -* CNST1 = 9/16 -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION CNST1, CNST2, CNST3 - PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0, - $ CNST3 = 1.050D0 ) - DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD - PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0, - $ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0, - $ TWO = 2.0D0, HUNDRD = 100.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I4, NN, NP - DOUBLE PRECISION A2, B1, B2, G, GAM, GAP1, GAP2, S -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Save statement .. - SAVE G -* .. -* .. Data statement .. - DATA G / ZERO / -* .. -* .. Executable Statements .. -* -* A negative DMIN forces the shift to take that absolute value -* TTYPE records the type of shift. -* - IF( DMIN.LE.ZERO ) THEN - TAU = -DMIN - TTYPE = -1 - RETURN - END IF -* - NN = 4*N0 + PP - IF( N0IN.EQ.N0 ) THEN -* -* No eigenvalues deflated. -* - IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN -* - B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) ) - B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) ) - A2 = Z( NN-7 ) + Z( NN-5 ) -* -* Cases 2 and 3. -* - IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN - GAP2 = DMIN2 - A2 - DMIN2*QURTR - IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN - GAP1 = A2 - DN - ( B2 / GAP2 )*B2 - ELSE - GAP1 = A2 - DN - ( B1+B2 ) - END IF - IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN - S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN ) - TTYPE = -2 - ELSE - S = ZERO - IF( DN.GT.B1 ) - $ S = DN - B1 - IF( A2.GT.( B1+B2 ) ) - $ S = MIN( S, A2-( B1+B2 ) ) - S = MAX( S, THIRD*DMIN ) - TTYPE = -3 - END IF - ELSE -* -* Case 4. -* - TTYPE = -4 - S = QURTR*DMIN - IF( DMIN.EQ.DN ) THEN - GAM = DN - A2 = ZERO - IF( Z( NN-5 ) .GT. Z( NN-7 ) ) - $ RETURN - B2 = Z( NN-5 ) / Z( NN-7 ) - NP = NN - 9 - ELSE - NP = NN - 2*PP - B2 = Z( NP-2 ) - GAM = DN1 - IF( Z( NP-4 ) .GT. Z( NP-2 ) ) - $ RETURN - A2 = Z( NP-4 ) / Z( NP-2 ) - IF( Z( NN-9 ) .GT. Z( NN-11 ) ) - $ RETURN - B2 = Z( NN-9 ) / Z( NN-11 ) - NP = NN - 13 - END IF -* -* Approximate contribution to norm squared from I < NN-1. -* - A2 = A2 + B2 - DO 10 I4 = NP, 4*I0 - 1 + PP, -4 - IF( B2.EQ.ZERO ) - $ GO TO 20 - B1 = B2 - IF( Z( I4 ) .GT. Z( I4-2 ) ) - $ RETURN - B2 = B2*( Z( I4 ) / Z( I4-2 ) ) - A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) - $ GO TO 20 - 10 CONTINUE - 20 CONTINUE - A2 = CNST3*A2 -* -* Rayleigh quotient residual bound. -* - IF( A2.LT.CNST1 ) - $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) - END IF - ELSE IF( DMIN.EQ.DN2 ) THEN -* -* Case 5. -* - TTYPE = -5 - S = QURTR*DMIN -* -* Compute contribution to norm squared from I > NN-2. -* - NP = NN - 2*PP - B1 = Z( NP-2 ) - B2 = Z( NP-6 ) - GAM = DN2 - IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 ) - $ RETURN - A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 ) -* -* Approximate contribution to norm squared from I < NN-2. -* - IF( N0-I0.GT.2 ) THEN - B2 = Z( NN-13 ) / Z( NN-15 ) - A2 = A2 + B2 - DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4 - IF( B2.EQ.ZERO ) - $ GO TO 40 - B1 = B2 - IF( Z( I4 ) .GT. Z( I4-2 ) ) - $ RETURN - B2 = B2*( Z( I4 ) / Z( I4-2 ) ) - A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) - $ GO TO 40 - 30 CONTINUE - 40 CONTINUE - A2 = CNST3*A2 - END IF -* - IF( A2.LT.CNST1 ) - $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) - ELSE -* -* Case 6, no information to guide us. -* - IF( TTYPE.EQ.-6 ) THEN - G = G + THIRD*( ONE-G ) - ELSE IF( TTYPE.EQ.-18 ) THEN - G = QURTR*THIRD - ELSE - G = QURTR - END IF - S = G*DMIN - TTYPE = -6 - END IF -* - ELSE IF( N0IN.EQ.( N0+1 ) ) THEN -* -* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. -* - IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN -* -* Cases 7 and 8. -* - TTYPE = -7 - S = THIRD*DMIN1 - IF( Z( NN-5 ).GT.Z( NN-7 ) ) - $ RETURN - B1 = Z( NN-5 ) / Z( NN-7 ) - B2 = B1 - IF( B2.EQ.ZERO ) - $ GO TO 60 - DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 - A2 = B1 - IF( Z( I4 ).GT.Z( I4-2 ) ) - $ RETURN - B1 = B1*( Z( I4 ) / Z( I4-2 ) ) - B2 = B2 + B1 - IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) - $ GO TO 60 - 50 CONTINUE - 60 CONTINUE - B2 = SQRT( CNST3*B2 ) - A2 = DMIN1 / ( ONE+B2**2 ) - GAP2 = HALF*DMIN2 - A2 - IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN - S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) - ELSE - S = MAX( S, A2*( ONE-CNST2*B2 ) ) - TTYPE = -8 - END IF - ELSE -* -* Case 9. -* - S = QURTR*DMIN1 - IF( DMIN1.EQ.DN1 ) - $ S = HALF*DMIN1 - TTYPE = -9 - END IF -* - ELSE IF( N0IN.EQ.( N0+2 ) ) THEN -* -* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. -* -* Cases 10 and 11. -* - IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN - TTYPE = -10 - S = THIRD*DMIN2 - IF( Z( NN-5 ).GT.Z( NN-7 ) ) - $ RETURN - B1 = Z( NN-5 ) / Z( NN-7 ) - B2 = B1 - IF( B2.EQ.ZERO ) - $ GO TO 80 - DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 - IF( Z( I4 ).GT.Z( I4-2 ) ) - $ RETURN - B1 = B1*( Z( I4 ) / Z( I4-2 ) ) - B2 = B2 + B1 - IF( HUNDRD*B1.LT.B2 ) - $ GO TO 80 - 70 CONTINUE - 80 CONTINUE - B2 = SQRT( CNST3*B2 ) - A2 = DMIN2 / ( ONE+B2**2 ) - GAP2 = Z( NN-7 ) + Z( NN-9 ) - - $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2 - IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN - S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) - ELSE - S = MAX( S, A2*( ONE-CNST2*B2 ) ) - END IF - ELSE - S = QURTR*DMIN2 - TTYPE = -11 - END IF - ELSE IF( N0IN.GT.( N0+2 ) ) THEN -* -* Case 12, more than two eigenvalues deflated. No information. -* - S = ZERO - TTYPE = -12 - END IF -* - TAU = S - RETURN -* -* End of DLASQ4 -* - END - SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, - $ DNM1, DNM2, IEEE ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* May 17, 2000 -* -* .. Scalar Arguments .. - LOGICAL IEEE - INTEGER I0, N0, PP - DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* Purpose -* ======= -* -* DLASQ5 computes one dqds transform in ping-pong form, one -* version for IEEE machines another for non IEEE machines. -* -* Arguments -* ========= -* -* I0 (input) INTEGER -* First index. -* -* N0 (input) INTEGER -* Last index. -* -* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) -* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid -* an extra argument. -* -* PP (input) INTEGER -* PP=0 for ping, PP=1 for pong. -* -* TAU (input) DOUBLE PRECISION -* This is the shift. -* -* DMIN (output) DOUBLE PRECISION -* Minimum value of d. -* -* DMIN1 (output) DOUBLE PRECISION -* Minimum value of d, excluding D( N0 ). -* -* DMIN2 (output) DOUBLE PRECISION -* Minimum value of d, excluding D( N0 ) and D( N0-1 ). -* -* DN (output) DOUBLE PRECISION -* d(N0), the last value of d. -* -* DNM1 (output) DOUBLE PRECISION -* d(N0-1). -* -* DNM2 (output) DOUBLE PRECISION -* d(N0-2). -* -* IEEE (input) LOGICAL -* Flag for IEEE or non IEEE arithmetic. -* -* ===================================================================== -* -* .. Parameter .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - INTEGER J4, J4P2 - DOUBLE PRECISION D, EMIN, TEMP -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( ( N0-I0-1 ).LE.0 ) - $ RETURN -* - J4 = 4*I0 + PP - 3 - EMIN = Z( J4+4 ) - D = Z( J4 ) - TAU - DMIN = D - DMIN1 = -Z( J4 ) -* - IF( IEEE ) THEN -* -* Code for IEEE arithmetic. -* - IF( PP.EQ.0 ) THEN - DO 10 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) - TEMP = Z( J4+1 ) / Z( J4-2 ) - D = D*TEMP - TAU - DMIN = MIN( DMIN, D ) - Z( J4 ) = Z( J4-1 )*TEMP - EMIN = MIN( Z( J4 ), EMIN ) - 10 CONTINUE - ELSE - DO 20 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) - TEMP = Z( J4+2 ) / Z( J4-3 ) - D = D*TEMP - TAU - DMIN = MIN( DMIN, D ) - Z( J4-1 ) = Z( J4 )*TEMP - EMIN = MIN( Z( J4-1 ), EMIN ) - 20 CONTINUE - END IF -* -* Unroll last two steps. -* - DNM2 = D - DMIN2 = DMIN - J4 = 4*( N0-2 ) - PP - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM2 + Z( J4P2 ) - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU - DMIN = MIN( DMIN, DNM1 ) -* - DMIN1 = DMIN - J4 = J4 + 4 - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM1 + Z( J4P2 ) - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU - DMIN = MIN( DMIN, DN ) -* - ELSE -* -* Code for non IEEE arithmetic. -* - IF( PP.EQ.0 ) THEN - DO 30 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) - IF( D.LT.ZERO ) THEN - RETURN - ELSE - Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) - D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU - END IF - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4 ) ) - 30 CONTINUE - ELSE - DO 40 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) - IF( D.LT.ZERO ) THEN - RETURN - ELSE - Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) - D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU - END IF - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4-1 ) ) - 40 CONTINUE - END IF -* -* Unroll last two steps. -* - DNM2 = D - DMIN2 = DMIN - J4 = 4*( N0-2 ) - PP - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM2 + Z( J4P2 ) - IF( DNM2.LT.ZERO ) THEN - RETURN - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU - END IF - DMIN = MIN( DMIN, DNM1 ) -* - DMIN1 = DMIN - J4 = J4 + 4 - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM1 + Z( J4P2 ) - IF( DNM1.LT.ZERO ) THEN - RETURN - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU - END IF - DMIN = MIN( DMIN, DN ) -* - END IF -* - Z( J4+2 ) = DN - Z( 4*N0-PP ) = EMIN - RETURN -* -* End of DLASQ5 -* - END - SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, - $ DNM1, DNM2 ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 -* -* .. Scalar Arguments .. - INTEGER I0, N0, PP - DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* Purpose -* ======= -* -* DLASQ6 computes one dqd (shift equal to zero) transform in -* ping-pong form, with protection against underflow and overflow. -* -* Arguments -* ========= -* -* I0 (input) INTEGER -* First index. -* -* N0 (input) INTEGER -* Last index. -* -* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) -* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid -* an extra argument. -* -* PP (input) INTEGER -* PP=0 for ping, PP=1 for pong. -* -* DMIN (output) DOUBLE PRECISION -* Minimum value of d. -* -* DMIN1 (output) DOUBLE PRECISION -* Minimum value of d, excluding D( N0 ). -* -* DMIN2 (output) DOUBLE PRECISION -* Minimum value of d, excluding D( N0 ) and D( N0-1 ). -* -* DN (output) DOUBLE PRECISION -* d(N0), the last value of d. -* -* DNM1 (output) DOUBLE PRECISION -* d(N0-1). -* -* DNM2 (output) DOUBLE PRECISION -* d(N0-2). -* -* ===================================================================== -* -* .. Parameter .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - INTEGER J4, J4P2 - DOUBLE PRECISION D, EMIN, SAFMIN, TEMP -* .. -* .. External Function .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( ( N0-I0-1 ).LE.0 ) - $ RETURN -* - SAFMIN = DLAMCH( 'Safe minimum' ) - J4 = 4*I0 + PP - 3 - EMIN = Z( J4+4 ) - D = Z( J4 ) - DMIN = D -* - IF( PP.EQ.0 ) THEN - DO 10 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) - IF( Z( J4-2 ).EQ.ZERO ) THEN - Z( J4 ) = ZERO - D = Z( J4+1 ) - DMIN = D - EMIN = ZERO - ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND. - $ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN - TEMP = Z( J4+1 ) / Z( J4-2 ) - Z( J4 ) = Z( J4-1 )*TEMP - D = D*TEMP - ELSE - Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) - D = Z( J4+1 )*( D / Z( J4-2 ) ) - END IF - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4 ) ) - 10 CONTINUE - ELSE - DO 20 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) - IF( Z( J4-3 ).EQ.ZERO ) THEN - Z( J4-1 ) = ZERO - D = Z( J4+2 ) - DMIN = D - EMIN = ZERO - ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND. - $ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN - TEMP = Z( J4+2 ) / Z( J4-3 ) - Z( J4-1 ) = Z( J4 )*TEMP - D = D*TEMP - ELSE - Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) - D = Z( J4+2 )*( D / Z( J4-3 ) ) - END IF - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4-1 ) ) - 20 CONTINUE - END IF -* -* Unroll last two steps. -* - DNM2 = D - DMIN2 = DMIN - J4 = 4*( N0-2 ) - PP - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM2 + Z( J4P2 ) - IF( Z( J4-2 ).EQ.ZERO ) THEN - Z( J4 ) = ZERO - DNM1 = Z( J4P2+2 ) - DMIN = DNM1 - EMIN = ZERO - ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. - $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN - TEMP = Z( J4P2+2 ) / Z( J4-2 ) - Z( J4 ) = Z( J4P2 )*TEMP - DNM1 = DNM2*TEMP - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - END IF - DMIN = MIN( DMIN, DNM1 ) -* - DMIN1 = DMIN - J4 = J4 + 4 - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM1 + Z( J4P2 ) - IF( Z( J4-2 ).EQ.ZERO ) THEN - Z( J4 ) = ZERO - DN = Z( J4P2+2 ) - DMIN = DN - EMIN = ZERO - ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. - $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN - TEMP = Z( J4P2+2 ) / Z( J4-2 ) - Z( J4 ) = Z( J4P2 )*TEMP - DN = DNM1*TEMP - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - END IF - DMIN = MIN( DMIN, DN ) -* - Z( J4+2 ) = DN - Z( 4*N0-PP ) = EMIN - RETURN -* -* End of DLASQ6 -* - END - SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNML2 overwrites the general complex m-by-n matrix C with -* -* Q * C if SIDE = 'L' and TRANS = 'N', or -* -* Q'* C if SIDE = 'L' and TRANS = 'C', or -* -* C * Q if SIDE = 'R' and TRANS = 'N', or -* -* C * Q' if SIDE = 'R' and TRANS = 'C', -* -* where Q is a complex unitary matrix defined as the product of k -* elementary reflectors -* -* Q = H(k)' . . . H(2)' H(1)' -* -* as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q' from the Left -* = 'R': apply Q or Q' from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply Q (No transpose) -* = 'C': apply Q' (Conjugate transpose) -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) COMPLEX*16 array, dimension -* (LDA,M) if SIDE = 'L', -* (LDA,N) if SIDE = 'R' -* The i-th row must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* ZGELQF in the first k rows of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,K). -* -* TAU (input) COMPLEX*16 array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZGELQF. -* -* C (input/output) COMPLEX*16 array, dimension (LDC,N) -* On entry, the m-by-n matrix C. -* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) COMPLEX*16 array, dimension -* (N) if SIDE = 'L', -* (M) if SIDE = 'R' -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - COMPLEX*16 AII, TAUI -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLACGV, ZLARF -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNML2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) or H(i)' is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) or H(i)' is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) or H(i)' -* - IF( NOTRAN ) THEN - TAUI = DCONJG( TAU( I ) ) - ELSE - TAUI = TAU( I ) - END IF - IF( I.LT.NQ ) - $ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA ) - AII = A( I, I ) - A( I, I ) = ONE - CALL ZLARF( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, JC ), - $ LDC, WORK ) - A( I, I ) = AII - IF( I.LT.NQ ) - $ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA ) - 10 CONTINUE - RETURN -* -* End of ZUNML2 -* - END - SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - DOUBLE PRECISION F, G, H, SSMAX, SSMIN -* .. -* -* Purpose -* ======= -* -* DLAS2 computes the singular values of the 2-by-2 matrix -* [ F G ] -* [ 0 H ]. -* On return, SSMIN is the smaller singular value and SSMAX is the -* larger singular value. -* -* Arguments -* ========= -* -* F (input) DOUBLE PRECISION -* The (1,1) element of the 2-by-2 matrix. -* -* G (input) DOUBLE PRECISION -* The (1,2) element of the 2-by-2 matrix. -* -* H (input) DOUBLE PRECISION -* The (2,2) element of the 2-by-2 matrix. -* -* SSMIN (output) DOUBLE PRECISION -* The smaller singular value. -* -* SSMAX (output) DOUBLE PRECISION -* The larger singular value. -* -* Further Details -* =============== -* -* Barring over/underflow, all output quantities are correct to within -* a few units in the last place (ulps), even in the absence of a guard -* digit in addition/subtraction. -* -* In IEEE arithmetic, the code works correctly if one matrix element is -* infinite. -* -* Overflow will not occur unless the largest singular value itself -* overflows, or is within a few ulps of overflow. (On machines with -* partial overflow, like the Cray, overflow may occur if the largest -* singular value is within a factor of 2 of overflow.) -* -* Underflow is harmless if underflow is gradual. Otherwise, results -* may correspond to a matrix modified by perturbations of size near -* the underflow threshold. -* -* ==================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION AS, AT, AU, C, FA, FHMN, FHMX, GA, HA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - FA = ABS( F ) - GA = ABS( G ) - HA = ABS( H ) - FHMN = MIN( FA, HA ) - FHMX = MAX( FA, HA ) - IF( FHMN.EQ.ZERO ) THEN - SSMIN = ZERO - IF( FHMX.EQ.ZERO ) THEN - SSMAX = GA - ELSE - SSMAX = MAX( FHMX, GA )*SQRT( ONE+ - $ ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 ) - END IF - ELSE - IF( GA.LT.FHMX ) THEN - AS = ONE + FHMN / FHMX - AT = ( FHMX-FHMN ) / FHMX - AU = ( GA / FHMX )**2 - C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) ) - SSMIN = FHMN*C - SSMAX = FHMX / C - ELSE - AU = FHMX / GA - IF( AU.EQ.ZERO ) THEN -* -* Avoid possible harmful underflow if exponent range -* asymmetric (true SSMIN may not underflow even if -* AU underflows) -* - SSMIN = ( FHMN*FHMX ) / GA - SSMAX = GA - ELSE - AS = ONE + FHMN / FHMX - AT = ( FHMX-FHMN ) / FHMX - C = ONE / ( SQRT( ONE+( AS*AU )**2 )+ - $ SQRT( ONE+( AT*AU )**2 ) ) - SSMIN = ( FHMN*C )*AU - SSMIN = SSMIN + SSMIN - SSMAX = GA / ( C+C ) - END IF - END IF - END IF - RETURN -* -* End of DLAS2 -* - END - SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLASQ1 computes the singular values of a real N-by-N bidiagonal -* matrix with diagonal D and off-diagonal E. The singular values -* are computed to high relative accuracy, in the absence of -* denormalization, underflow and overflow. The algorithm was first -* presented in -* -* "Accurate singular values and differential qd algorithms" by K. V. -* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230, -* 1994, -* -* and the present implementation is described in "An implementation of -* the dqds Algorithm (Positive Case)", LAPACK Working Note. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of rows and columns in the matrix. N >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, D contains the diagonal elements of the -* bidiagonal matrix whose SVD is desired. On normal exit, -* D contains the singular values in decreasing order. -* -* E (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, elements E(1:N-1) contain the off-diagonal elements -* of the bidiagonal matrix whose SVD is desired. -* On exit, E is overwritten. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: the algorithm failed -* = 1, a split was marked by a positive value in E -* = 2, current block of Z not diagonalized after 30*N -* iterations (in inner while loop) -* = 3, termination criterion of outer while loop not met -* (program created more than N unreduced blocks) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO - DOUBLE PRECISION EPS, SCALE, SAFMIN, SIGMN, SIGMX -* .. -* .. External Subroutines .. - EXTERNAL DLAS2, DLASQ2, DLASRT, XERBLA -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -2 - CALL XERBLA( 'DLASQ1', -INFO ) - RETURN - ELSE IF( N.EQ.0 ) THEN - RETURN - ELSE IF( N.EQ.1 ) THEN - D( 1 ) = ABS( D( 1 ) ) - RETURN - ELSE IF( N.EQ.2 ) THEN - CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX ) - D( 1 ) = SIGMX - D( 2 ) = SIGMN - RETURN - END IF -* -* Estimate the largest singular value. -* - SIGMX = ZERO - DO 10 I = 1, N - 1 - D( I ) = ABS( D( I ) ) - SIGMX = MAX( SIGMX, ABS( E( I ) ) ) - 10 CONTINUE - D( N ) = ABS( D( N ) ) -* -* Early return if SIGMX is zero (matrix is already diagonal). -* - IF( SIGMX.EQ.ZERO ) THEN - CALL DLASRT( 'D', N, D, IINFO ) - RETURN - END IF -* - DO 20 I = 1, N - SIGMX = MAX( SIGMX, D( I ) ) - 20 CONTINUE -* -* Copy D and E into WORK (in the Z format) and scale (squaring the -* input data makes scaling by a power of the radix pointless). -* - EPS = DLAMCH( 'Precision' ) - SAFMIN = DLAMCH( 'Safe minimum' ) - SCALE = SQRT( EPS / SAFMIN ) - CALL DCOPY( N, D, 1, WORK( 1 ), 2 ) - CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 ) - CALL DLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1, - $ IINFO ) -* -* Compute the q's and e's. -* - DO 30 I = 1, 2*N - 1 - WORK( I ) = WORK( I )**2 - 30 CONTINUE - WORK( 2*N ) = ZERO -* - CALL DLASQ2( N, WORK, INFO ) -* - IF( INFO.EQ.0 ) THEN - DO 40 I = 1, N - D( I ) = SQRT( WORK( I ) ) - 40 CONTINUE - CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO ) - END IF -* - RETURN -* -* End of DLASQ1 -* - END - SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN -* .. -* -* Purpose -* ======= -* -* DLASV2 computes the singular value decomposition of a 2-by-2 -* triangular matrix -* [ F G ] -* [ 0 H ]. -* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the -* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and -* right singular vectors for abs(SSMAX), giving the decomposition -* -* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] -* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. -* -* Arguments -* ========= -* -* F (input) DOUBLE PRECISION -* The (1,1) element of the 2-by-2 matrix. -* -* G (input) DOUBLE PRECISION -* The (1,2) element of the 2-by-2 matrix. -* -* H (input) DOUBLE PRECISION -* The (2,2) element of the 2-by-2 matrix. -* -* SSMIN (output) DOUBLE PRECISION -* abs(SSMIN) is the smaller singular value. -* -* SSMAX (output) DOUBLE PRECISION -* abs(SSMAX) is the larger singular value. -* -* SNL (output) DOUBLE PRECISION -* CSL (output) DOUBLE PRECISION -* The vector (CSL, SNL) is a unit left singular vector for the -* singular value abs(SSMAX). -* -* SNR (output) DOUBLE PRECISION -* CSR (output) DOUBLE PRECISION -* The vector (CSR, SNR) is a unit right singular vector for the -* singular value abs(SSMAX). -* -* Further Details -* =============== -* -* Any input parameter may be aliased with any output parameter. -* -* Barring over/underflow and assuming a guard digit in subtraction, all -* output quantities are correct to within a few units in the last -* place (ulps). -* -* In IEEE arithmetic, the code works correctly if one matrix element is -* infinite. -* -* Overflow will not occur unless the largest singular value itself -* overflows or is within a few ulps of overflow. (On machines with -* partial overflow, like the Cray, overflow may occur if the largest -* singular value is within a factor of 2 of overflow.) -* -* Underflow is harmless if underflow is gradual. Otherwise, results -* may correspond to a matrix modified by perturbations of size near -* the underflow threshold. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION HALF - PARAMETER ( HALF = 0.5D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) - DOUBLE PRECISION FOUR - PARAMETER ( FOUR = 4.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL GASMAL, SWAP - INTEGER PMAX - DOUBLE PRECISION A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M, - $ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN, SQRT -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Executable Statements .. -* - FT = F - FA = ABS( FT ) - HT = H - HA = ABS( H ) -* -* PMAX points to the maximum absolute element of matrix -* PMAX = 1 if F largest in absolute values -* PMAX = 2 if G largest in absolute values -* PMAX = 3 if H largest in absolute values -* - PMAX = 1 - SWAP = ( HA.GT.FA ) - IF( SWAP ) THEN - PMAX = 3 - TEMP = FT - FT = HT - HT = TEMP - TEMP = FA - FA = HA - HA = TEMP -* -* Now FA .ge. HA -* - END IF - GT = G - GA = ABS( GT ) - IF( GA.EQ.ZERO ) THEN -* -* Diagonal matrix -* - SSMIN = HA - SSMAX = FA - CLT = ONE - CRT = ONE - SLT = ZERO - SRT = ZERO - ELSE - GASMAL = .TRUE. - IF( GA.GT.FA ) THEN - PMAX = 2 - IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN -* -* Case of very large GA -* - GASMAL = .FALSE. - SSMAX = GA - IF( HA.GT.ONE ) THEN - SSMIN = FA / ( GA / HA ) - ELSE - SSMIN = ( FA / GA )*HA - END IF - CLT = ONE - SLT = HT / GT - SRT = ONE - CRT = FT / GT - END IF - END IF - IF( GASMAL ) THEN -* -* Normal case -* - D = FA - HA - IF( D.EQ.FA ) THEN -* -* Copes with infinite F or H -* - L = ONE - ELSE - L = D / FA - END IF -* -* Note that 0 .le. L .le. 1 -* - M = GT / FT -* -* Note that abs(M) .le. 1/macheps -* - T = TWO - L -* -* Note that T .ge. 1 -* - MM = M*M - TT = T*T - S = SQRT( TT+MM ) -* -* Note that 1 .le. S .le. 1 + 1/macheps -* - IF( L.EQ.ZERO ) THEN - R = ABS( M ) - ELSE - R = SQRT( L*L+MM ) - END IF -* -* Note that 0 .le. R .le. 1 + 1/macheps -* - A = HALF*( S+R ) -* -* Note that 1 .le. A .le. 1 + abs(M) -* - SSMIN = HA / A - SSMAX = FA*A - IF( MM.EQ.ZERO ) THEN -* -* Note that M is very tiny -* - IF( L.EQ.ZERO ) THEN - T = SIGN( TWO, FT )*SIGN( ONE, GT ) - ELSE - T = GT / SIGN( D, FT ) + M / T - END IF - ELSE - T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A ) - END IF - L = SQRT( T*T+FOUR ) - CRT = TWO / L - SRT = T / L - CLT = ( CRT+SRT*M ) / A - SLT = ( HT / FT )*SRT / A - END IF - END IF - IF( SWAP ) THEN - CSL = SRT - SNL = CRT - CSR = SLT - SNR = CLT - ELSE - CSL = CLT - SNL = SLT - CSR = CRT - SNR = SRT - END IF -* -* Correct signs of SSMAX and SSMIN -* - IF( PMAX.EQ.1 ) - $ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F ) - IF( PMAX.EQ.2 ) - $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G ) - IF( PMAX.EQ.3 ) - $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H ) - SSMAX = SIGN( SSMAX, TSIGN ) - SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) ) - RETURN -* -* End of DLASV2 -* - END - - SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) -* -* -- LAPACK DRIVER ROUTINE (VERSION 1.1) -- -* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., -* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY -* MARCH 31, 1993 -* -* .. SCALAR ARGUMENTS .. - CHARACTER JOBZ, UPLO - INTEGER INFO, LDZ, N -* .. -* .. ARRAY ARGUMENTS .. - DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* PURPOSE -* ======= -* -* DSPEV COMPUTES ALL THE EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A -* REAL SYMMETRIC MATRIX A IN PACKED STORAGE. -* -* ARGUMENTS -* ========= -* -* JOBZ (INPUT) CHARACTER*1 -* = 'N': COMPUTE EIGENVALUES ONLY; -* = 'V': COMPUTE EIGENVALUES AND EIGENVECTORS. -* -* UPLO (INPUT) CHARACTER*1 -* = 'U': UPPER TRIANGLE OF A IS STORED; -* = 'L': LOWER TRIANGLE OF A IS STORED. -* -* N (INPUT) INTEGER -* THE ORDER OF THE MATRIX A. N >= 0. -* -* AP (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N*(N+1)/2) -* ON ENTRY, THE UPPER OR LOWER TRIANGLE OF THE SYMMETRIC MATRIX -* A, PACKED COLUMNWISE IN A LINEAR ARRAY. THE J-TH COLUMN OF A -* IS STORED IN THE ARRAY AP AS FOLLOWS: -* IF UPLO = 'U', AP(I + (J-1)*J/2) = A(I,J) FOR 1<=I<=J; -* IF UPLO = 'L', AP(I + (J-1)*(2*N-J)/2) = A(I,J) FOR J<=I<=N. -* -* ON EXIT, AP IS OVERWRITTEN BY VALUES GENERATED DURING THE -* REDUCTION TO TRIDIAGONAL FORM. IF UPLO = 'U', THE DIAGONAL -* AND FIRST SUPERDIAGONAL OF THE TRIDIAGONAL MATRIX T OVERWRITE -* THE CORRESPONDING ELEMENTS OF A, AND IF UPLO = 'L', THE -* DIAGONAL AND FIRST SUBDIAGONAL OF T OVERWRITE THE -* CORRESPONDING ELEMENTS OF A. -* -* W (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) -* IF INFO = 0, THE EIGENVALUES IN ASCENDING ORDER. -* -* Z (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDZ, N) -* IF JOBZ = 'V', THEN IF INFO = 0, Z CONTAINS THE ORTHONORMAL -* EIGENVECTORS OF THE MATRIX A, WITH THE I-TH COLUMN OF Z -* HOLDING THE EIGENVECTOR ASSOCIATED WITH W(I). -* IF JOBZ = 'N', THEN Z IS NOT REFERENCED. -* -* LDZ (INPUT) INTEGER -* THE LEADING DIMENSION OF THE ARRAY Z. LDZ >= 1, AND IF -* JOBZ = 'V', LDZ >= MAX(1,N). -* -* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (3*N) -* -* INFO (OUTPUT) INTEGER -* = 0: SUCCESSFUL EXIT. -* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE. -* > 0: IF INFO = I, THE ALGORITHM FAILED TO CONVERGE; I -* OFF-DIAGONAL ELEMENTS OF AN INTERMEDIATE TRIDIAGONAL -* FORM DID NOT CONVERGE TO ZERO. -* -* ===================================================================== -* -* .. PARAMETERS .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. LOCAL SCALARS .. - LOGICAL WANTZ - INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE - DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, - $ SMLNUM -* .. -* .. EXTERNAL FUNCTIONS .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANSP - EXTERNAL LSAME, DLAMCH, DLANSP -* .. -* .. EXTERNAL SUBROUTINES .. - EXTERNAL DOPGTR, DSCAL, DSPTRD, DSTEQR, DSTERF, XERBLA -* .. -* .. INTRINSIC FUNCTIONS .. - INTRINSIC SQRT -* .. -* .. EXECUTABLE STATEMENTS .. -* -* TEST THE INPUT PARAMETERS. -* - WANTZ = LSAME( JOBZ, 'V' ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) - $ THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN - INFO = -7 - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSPEV ', -INFO ) - RETURN - END IF -* -* QUICK RETURN IF POSSIBLE -* - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - W( 1 ) = AP( 1 ) - IF( WANTZ ) - $ Z( 1, 1 ) = ONE - RETURN - END IF -* -* GET MACHINE CONSTANTS. -* - SAFMIN = DLAMCH( 'S' ) - EPS = DLAMCH( 'P' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = SQRT( BIGNUM ) -* -* SCALE MATRIX TO ALLOWABLE RANGE, IF NECESSARY. -* - ANRM = DLANSP( 'M', UPLO, N, AP, WORK ) - ISCALE = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) THEN - CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) - END IF -* -* CALL DSPTRD TO REDUCE SYMMETRIC PACKED MATRIX TO TRIDIAGONAL FORM. -* - INDE = 1 - INDTAU = INDE + N - CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO ) -* -* FOR EIGENVALUES ONLY, CALL DSTERF. FOR EIGENVECTORS, FIRST CALL -* DOPGTR TO GENERATE THE ORTHOGONAL MATRIX, THEN CALL DSTEQR. -* - IF( .NOT.WANTZ ) THEN - CALL DSTERF( N, W, WORK( INDE ), INFO ) - ELSE - INDWRK = INDTAU + N - CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ, - $ WORK( INDWRK ), IINFO ) - CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDTAU ), - $ INFO ) - END IF -* -* IF MATRIX WAS SCALED, THEN RESCALE EIGENVALUES APPROPRIATELY. -* - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = N - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF -* - RETURN -* -* END OF DSPEV -* - END - - - - SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, - $ INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, LDZ, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION RWORK( * ), W( * ) - COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a -* complex Hermitian matrix in packed storage. -* -* Arguments -* ========= -* -* JOBZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only; -* = 'V': Compute eigenvalues and eigenvectors. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) -* On entry, the upper or lower triangle of the Hermitian matrix -* A, packed columnwise in a linear array. The j-th column of A -* is stored in the array AP as follows: -* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; -* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. -* -* On exit, AP is overwritten by values generated during the -* reduction to tridiagonal form. If UPLO = 'U', the diagonal -* and first superdiagonal of the tridiagonal matrix T overwrite -* the corresponding elements of A, and if UPLO = 'L', the -* diagonal and first subdiagonal of T overwrite the -* corresponding elements of A. -* -* W (output) DOUBLE PRECISION array, dimension (N) -* If INFO = 0, the eigenvalues in ascending order. -* -* Z (output) COMPLEX*16 array, dimension (LDZ, N) -* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal -* eigenvectors of the matrix A, with the i-th column of Z -* holding the eigenvector associated with W(i). -* If JOBZ = 'N', then Z is not referenced. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= 1, and if -* JOBZ = 'V', LDZ >= max(1,N). -* -* WORK (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1)) -* -* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2)) -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* > 0: if INFO = i, the algorithm failed to converge; i -* off-diagonal elements of an intermediate tridiagonal -* form did not converge to zero. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL WANTZ - INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWRK, - $ ISCALE - DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, - $ SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, ZLANHP - EXTERNAL LSAME, DLAMCH, ZLANHP -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DSTERF, XERBLA, ZDSCAL, ZHPTRD, ZSTEQR, - $ ZUPGTR -* .. -* .. Intrinsic Functions .. - INTRINSIC SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) - $ THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN - INFO = -7 - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHPEV ', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - W( 1 ) = AP( 1 ) - RWORK( 1 ) = 1 - IF( WANTZ ) - $ Z( 1, 1 ) = ONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = SQRT( BIGNUM ) -* -* Scale matrix to allowable range, if necessary. -* - ANRM = ZLANHP( 'M', UPLO, N, AP, RWORK ) - ISCALE = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) THEN - CALL ZDSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) - END IF -* -* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form. -* - INDE = 1 - INDTAU = 1 - CALL ZHPTRD( UPLO, N, AP, W, RWORK( INDE ), WORK( INDTAU ), - $ IINFO ) -* -* For eigenvalues only, call DSTERF. For eigenvectors, first call -* ZUPGTR to generate the orthogonal matrix, then call ZSTEQR. -* - IF( .NOT.WANTZ ) THEN - CALL DSTERF( N, W, RWORK( INDE ), INFO ) - ELSE - INDWRK = INDTAU + N - CALL ZUPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ, - $ WORK( INDWRK ), IINFO ) - INDRWK = INDE + N - CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ, - $ RWORK( INDRWK ), INFO ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = N - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF -* - RETURN -* -* End of ZHPEV -* - END - DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) -* -* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- -* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., -* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY -* OCTOBER 31, 1992 -* -* .. SCALAR ARGUMENTS .. - CHARACTER NORM, UPLO - INTEGER N -* .. -* .. ARRAY ARGUMENTS .. - DOUBLE PRECISION AP( * ), WORK( * ) -* .. -* -* PURPOSE -* ======= -* -* DLANSP RETURNS THE VALUE OF THE ONE NORM, OR THE FROBENIUS NORM, OR -* THE INFINITY NORM, OR THE ELEMENT OF LARGEST ABSOLUTE VALUE OF A -* REAL SYMMETRIC MATRIX A, SUPPLIED IN PACKED FORM. -* -* DESCRIPTION -* =========== -* -* DLANSP RETURNS THE VALUE -* -* DLANSP = ( MAX(ABS(A(I,J))), NORM = 'M' OR 'M' -* ( -* ( NORM1(A), NORM = '1', 'O' OR 'O' -* ( -* ( NORMI(A), NORM = 'I' OR 'I' -* ( -* ( NORMF(A), NORM = 'F', 'F', 'E' OR 'E' -* -* WHERE NORM1 DENOTES THE ONE NORM OF A MATRIX (MAXIMUM COLUMN SUM), -* NORMI DENOTES THE INFINITY NORM OF A MATRIX (MAXIMUM ROW SUM) AND -* NORMF DENOTES THE FROBENIUS NORM OF A MATRIX (SQUARE ROOT OF SUM OF -* SQUARES). NOTE THAT MAX(ABS(A(I,J))) IS NOT A MATRIX NORM. -* -* ARGUMENTS -* ========= -* -* NORM (INPUT) CHARACTER*1 -* SPECIFIES THE VALUE TO BE RETURNED IN DLANSP AS DESCRIBED -* ABOVE. -* -* UPLO (INPUT) CHARACTER*1 -* SPECIFIES WHETHER THE UPPER OR LOWER TRIANGULAR PART OF THE -* SYMMETRIC MATRIX A IS SUPPLIED. -* = 'U': UPPER TRIANGULAR PART OF A IS SUPPLIED -* = 'L': LOWER TRIANGULAR PART OF A IS SUPPLIED -* -* N (INPUT) INTEGER -* THE ORDER OF THE MATRIX A. N >= 0. WHEN N = 0, DLANSP IS -* SET TO ZERO. -* -* AP (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N*(N+1)/2) -* THE UPPER OR LOWER TRIANGLE OF THE SYMMETRIC MATRIX A, PACKED -* COLUMNWISE IN A LINEAR ARRAY. THE J-TH COLUMN OF A IS STORED -* IN THE ARRAY AP AS FOLLOWS: -* IF UPLO = 'U', AP(I + (J-1)*J/2) = A(I,J) FOR 1<=I<=J; -* IF UPLO = 'L', AP(I + (J-1)*(2N-J)/2) = A(I,J) FOR J<=I<=N. -* -* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK), -* WHERE LWORK >= N WHEN NORM = 'I' OR '1' OR 'O'; OTHERWISE, -* WORK IS NOT REFERENCED. -* -* ===================================================================== -* -* .. PARAMETERS .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. LOCAL SCALARS .. - INTEGER I, J, K - DOUBLE PRECISION ABSA, SCALE, SUM, VALUE -* .. -* .. EXTERNAL SUBROUTINES .. - EXTERNAL DLASSQ -* .. -* .. EXTERNAL FUNCTIONS .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. INTRINSIC FUNCTIONS .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. EXECUTABLE STATEMENTS .. -* - IF( N.EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* FIND MAX(ABS(A(I,J))). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - K = 1 - DO 20 J = 1, N - DO 10 I = K, K + J - 1 - VALUE = MAX( VALUE, ABS( AP( I ) ) ) - 10 CONTINUE - K = K + J - 20 CONTINUE - ELSE - K = 1 - DO 40 J = 1, N - DO 30 I = K, K + N - J - VALUE = MAX( VALUE, ABS( AP( I ) ) ) - 30 CONTINUE - K = K + N - J + 1 - 40 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. - $ ( NORM.EQ.'1' ) ) THEN -* -* FIND NORMI(A) ( = NORM1(A), SINCE A IS SYMMETRIC). -* - VALUE = ZERO - K = 1 - IF( LSAME( UPLO, 'U' ) ) THEN - DO 60 J = 1, N - SUM = ZERO - DO 50 I = 1, J - 1 - ABSA = ABS( AP( K ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - K = K + 1 - 50 CONTINUE - WORK( J ) = SUM + ABS( AP( K ) ) - K = K + 1 - 60 CONTINUE - DO 70 I = 1, N - VALUE = MAX( VALUE, WORK( I ) ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - WORK( I ) = ZERO - 80 CONTINUE - DO 100 J = 1, N - SUM = WORK( J ) + ABS( AP( K ) ) - K = K + 1 - DO 90 I = J + 1, N - ABSA = ABS( AP( K ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - K = K + 1 - 90 CONTINUE - VALUE = MAX( VALUE, SUM ) - 100 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* FIND NORMF(A). -* - SCALE = ZERO - SUM = ONE - K = 2 - IF( LSAME( UPLO, 'U' ) ) THEN - DO 110 J = 2, N - CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM ) - K = K + J - 110 CONTINUE - ELSE - DO 120 J = 1, N - 1 - CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM ) - K = K + N - J + 1 - 120 CONTINUE - END IF - SUM = 2*SUM - K = 1 - DO 130 I = 1, N - IF( AP( K ).NE.ZERO ) THEN - ABSA = ABS( AP( K ) ) - IF( SCALE.LT.ABSA ) THEN - SUM = ONE + SUM*( SCALE / ABSA )**2 - SCALE = ABSA - ELSE - SUM = SUM + ( ABSA / SCALE )**2 - END IF - END IF - IF( LSAME( UPLO, 'U' ) ) THEN - K = K + I + 1 - ELSE - K = K + N - I + 1 - END IF - 130 CONTINUE - VALUE = SCALE*SQRT( SUM ) - END IF -* - DLANSP = VALUE - RETURN -* -* END OF DLANSP -* - END - - SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO ) -* -* -- LAPACK ROUTINE (VERSION 1.1) -- -* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., -* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY -* MARCH 31, 1993 -* -* .. SCALAR ARGUMENTS .. - CHARACTER UPLO - INTEGER INFO, N -* .. -* .. ARRAY ARGUMENTS .. - DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * ) -* .. -* -* PURPOSE -* ======= -* -* DSPTRD REDUCES A REAL SYMMETRIC MATRIX A STORED IN PACKED FORM TO -* SYMMETRIC TRIDIAGONAL FORM T BY AN ORTHOGONAL SIMILARITY -* TRANSFORMATION: Q**T * A * Q = T. -* -* ARGUMENTS -* ========= -* -* UPLO (INPUT) CHARACTER*1 -* = 'U': UPPER TRIANGLE OF A IS STORED; -* = 'L': LOWER TRIANGLE OF A IS STORED. -* -* N (INPUT) INTEGER -* THE ORDER OF THE MATRIX A. N >= 0. -* -* AP (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N*(N+1)/2) -* ON ENTRY, THE UPPER OR LOWER TRIANGLE OF THE SYMMETRIC MATRIX -* A, PACKED COLUMNWISE IN A LINEAR ARRAY. THE J-TH COLUMN OF A -* IS STORED IN THE ARRAY AP AS FOLLOWS: -* IF UPLO = 'U', AP(I + (J-1)*J/2) = A(I,J) FOR 1<=I<=J; -* IF UPLO = 'L', AP(I + (J-1)*(2*N-J)/2) = A(I,J) FOR J<=I<=N. -* ON EXIT, IF UPLO = 'U', THE DIAGONAL AND FIRST SUPERDIAGONAL -* OF A ARE OVERWRITTEN BY THE CORRESPONDING ELEMENTS OF THE -* TRIDIAGONAL MATRIX T, AND THE ELEMENTS ABOVE THE FIRST -* SUPERDIAGONAL, WITH THE ARRAY TAU, REPRESENT THE ORTHOGONAL -* MATRIX Q AS A PRODUCT OF ELEMENTARY REFLECTORS; IF UPLO -* = 'L', THE DIAGONAL AND FIRST SUBDIAGONAL OF A ARE OVER- -* WRITTEN BY THE CORRESPONDING ELEMENTS OF THE TRIDIAGONAL -* MATRIX T, AND THE ELEMENTS BELOW THE FIRST SUBDIAGONAL, WITH -* THE ARRAY TAU, REPRESENT THE ORTHOGONAL MATRIX Q AS A PRODUCT -* OF ELEMENTARY REFLECTORS. SEE FURTHER DETAILS. -* -* D (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) -* THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T: -* D(I) = A(I,I). -* -* E (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) -* THE OFF-DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T: -* E(I) = A(I,I+1) IF UPLO = 'U', E(I) = A(I+1,I) IF UPLO = 'L'. -* -* TAU (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) -* THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS (SEE FURTHER -* DETAILS). -* -* INFO (OUTPUT) INTEGER -* = 0: SUCCESSFUL EXIT -* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE -* -* FURTHER DETAILS -* =============== -* -* IF UPLO = 'U', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY -* REFLECTORS -* -* Q = H(N-1) . . . H(2) H(1). -* -* EACH H(I) HAS THE FORM -* -* H(I) = I - TAU * V * V' -* -* WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH -* V(I+1:N) = 0 AND V(I) = 1; V(1:I-1) IS STORED ON EXIT IN AP, -* OVERWRITING A(1:I-1,I+1), AND TAU IS STORED IN TAU(I). -* -* IF UPLO = 'L', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY -* REFLECTORS -* -* Q = H(1) H(2) . . . H(N-1). -* -* EACH H(I) HAS THE FORM -* -* H(I) = I - TAU * V * V' -* -* WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH -* V(1:I) = 0 AND V(I+1) = 1; V(I+2:N) IS STORED ON EXIT IN AP, -* OVERWRITING A(I+2:N,I), AND TAU IS STORED IN TAU(I). -* -* ===================================================================== -* -* .. PARAMETERS .. - DOUBLE PRECISION ONE, ZERO, HALF - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, - $ HALF = 1.0D0 / 2.0D0 ) -* .. -* .. LOCAL SCALARS .. - LOGICAL UPPER - INTEGER I, I1, I1I1, II - DOUBLE PRECISION ALPHA, TAUI -* .. -* .. EXTERNAL SUBROUTINES .. - EXTERNAL DAXPY, DLARFG, DSPMV, DSPR2, XERBLA -* .. -* .. EXTERNAL FUNCTIONS .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT -* .. -* .. EXECUTABLE STATEMENTS .. -* -* TEST THE INPUT PARAMETERS -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSPTRD', -INFO ) - RETURN - END IF -* -* QUICK RETURN IF POSSIBLE -* - IF( N.LE.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* REDUCE THE UPPER TRIANGLE OF A. -* I1 IS THE INDEX IN AP OF A(1,I+1). -* - I1 = N*( N-1 ) / 2 + 1 - DO 10 I = N - 1, 1, -1 -* -* GENERATE ELEMENTARY REFLECTOR H(I) = I - TAU * V * V' -* TO ANNIHILATE A(1:I-1,I+1) -* - CALL DLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI ) - E( I ) = AP( I1+I-1 ) -* - IF( TAUI.NE.ZERO ) THEN -* -* APPLY H(I) FROM BOTH SIDES TO A(1:I,1:I) -* - AP( I1+I-1 ) = ONE -* -* COMPUTE Y := TAU * A * V STORING Y IN TAU(1:I) -* - CALL DSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU, - $ 1 ) -* -* COMPUTE W := Y - 1/2 * TAU * (Y'*V) * V -* - ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, AP( I1 ), 1 ) - CALL DAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 ) -* -* APPLY THE TRANSFORMATION AS A RANK-2 UPDATE: -* A := A - V * W' - W * V' -* - CALL DSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP ) -* - AP( I1+I-1 ) = E( I ) - END IF - D( I+1 ) = AP( I1+I ) - TAU( I ) = TAUI - I1 = I1 - I - 10 CONTINUE - D( 1 ) = AP( 1 ) - ELSE -* -* REDUCE THE LOWER TRIANGLE OF A. II IS THE INDEX IN AP OF -* A(I,I) AND I1I1 IS THE INDEX OF A(I+1,I+1). -* - II = 1 - DO 20 I = 1, N - 1 - I1I1 = II + N - I + 1 -* -* GENERATE ELEMENTARY REFLECTOR H(I) = I - TAU * V * V' -* TO ANNIHILATE A(I+2:N,I) -* - CALL DLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI ) - E( I ) = AP( II+1 ) -* - IF( TAUI.NE.ZERO ) THEN -* -* APPLY H(I) FROM BOTH SIDES TO A(I+1:N,I+1:N) -* - AP( II+1 ) = ONE -* -* COMPUTE Y := TAU * A * V STORING Y IN TAU(I:N-1) -* - CALL DSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1, - $ ZERO, TAU( I ), 1 ) -* -* COMPUTE W := Y - 1/2 * TAU * (Y'*V) * V -* - ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, AP( II+1 ), - $ 1 ) - CALL DAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 ) -* -* APPLY THE TRANSFORMATION AS A RANK-2 UPDATE: -* A := A - V * W' - W * V' -* - CALL DSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1, - $ AP( I1I1 ) ) -* - AP( II+1 ) = E( I ) - END IF - D( I ) = AP( II ) - TAU( I ) = TAUI - II = I1I1 - 20 CONTINUE - D( N ) = AP( II ) - END IF -* - RETURN -* -* END OF DSPTRD -* - END - SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) -* -* -- LAPACK ROUTINE (VERSION 1.1) -- -* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., -* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY -* MARCH 31, 1993 -* -* .. SCALAR ARGUMENTS .. - CHARACTER UPLO - INTEGER INFO, LDQ, N -* .. -* .. ARRAY ARGUMENTS .. - DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) -* .. -* -* PURPOSE -* ======= -* -* DOPGTR GENERATES A REAL ORTHOGONAL MATRIX Q WHICH IS DEFINED AS THE -* PRODUCT OF N-1 ELEMENTARY REFLECTORS OF ORDER N, AS RETURNED BY -* DSPTRD USING PACKED STORAGE: -* -* IF UPLO = 'U', Q = H(N-1) . . . H(2) H(1), -* -* IF UPLO = 'L', Q = H(1) H(2) . . . H(N-1). -* -* ARGUMENTS -* ========= -* -* UPLO (INPUT) CHARACTER*1 -* = 'U': UPPER TRIANGULAR PACKED STORAGE USED IN PREVIOUS -* CALL TO DSPTRD; -* = 'L': LOWER TRIANGULAR PACKED STORAGE USED IN PREVIOUS -* CALL TO DSPTRD. -* -* N (INPUT) INTEGER -* THE ORDER OF THE MATRIX Q. N >= 0. -* -* AP (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N*(N+1)/2) -* THE VECTORS WHICH DEFINE THE ELEMENTARY REFLECTORS, AS -* RETURNED BY DSPTRD. -* -* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) -* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY -* REFLECTOR H(I), AS RETURNED BY DSPTRD. -* -* Q (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDQ,N) -* THE N-BY-N ORTHOGONAL MATRIX Q. -* -* LDQ (INPUT) INTEGER -* THE LEADING DIMENSION OF THE ARRAY Q. LDQ >= MAX(1,N). -* -* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (N-1) -* -* INFO (OUTPUT) INTEGER -* = 0: SUCCESSFUL EXIT -* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE -* -* ===================================================================== -* -* .. PARAMETERS .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. LOCAL SCALARS .. - LOGICAL UPPER - INTEGER I, IINFO, IJ, J -* .. -* .. EXTERNAL FUNCTIONS .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. EXTERNAL SUBROUTINES .. - EXTERNAL DORG2L, DORG2R, XERBLA -* .. -* .. INTRINSIC FUNCTIONS .. - INTRINSIC MAX -* .. -* .. EXECUTABLE STATEMENTS .. -* -* TEST THE INPUT ARGUMENTS -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DOPGTR', -INFO ) - RETURN - END IF -* -* QUICK RETURN IF POSSIBLE -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Q WAS DETERMINED BY A CALL TO DSPTRD WITH UPLO = 'U' -* -* UNPACK THE VECTORS WHICH DEFINE THE ELEMENTARY REFLECTORS AND -* SET THE LAST ROW AND COLUMN OF Q EQUAL TO THOSE OF THE UNIT -* MATRIX -* - IJ = 2 - DO 20 J = 1, N - 1 - DO 10 I = 1, J - 1 - Q( I, J ) = AP( IJ ) - IJ = IJ + 1 - 10 CONTINUE - IJ = IJ + 2 - Q( N, J ) = ZERO - 20 CONTINUE - DO 30 I = 1, N - 1 - Q( I, N ) = ZERO - 30 CONTINUE - Q( N, N ) = ONE -* -* GENERATE Q(1:N-1,1:N-1) -* - CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO ) -* - ELSE -* -* Q WAS DETERMINED BY A CALL TO DSPTRD WITH UPLO = 'L'. -* -* UNPACK THE VECTORS WHICH DEFINE THE ELEMENTARY REFLECTORS AND -* SET THE FIRST ROW AND COLUMN OF Q EQUAL TO THOSE OF THE UNIT -* MATRIX -* - Q( 1, 1 ) = ONE - DO 40 I = 2, N - Q( I, 1 ) = ZERO - 40 CONTINUE - IJ = 3 - DO 60 J = 2, N - Q( 1, J ) = ZERO - DO 50 I = J + 1, N - Q( I, J ) = AP( IJ ) - IJ = IJ + 1 - 50 CONTINUE - IJ = IJ + 2 - 60 CONTINUE - IF( N.GT.1 ) THEN -* -* GENERATE Q(2:N,2:N) -* - CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK, - $ IINFO ) - END IF - END IF - RETURN -* -* END OF DOPGTR -* - END - DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER NORM, UPLO - INTEGER N -* .. -* .. Array Arguments .. - DOUBLE PRECISION WORK( * ) - COMPLEX*16 AP( * ) -* .. -* -* Purpose -* ======= -* -* ZLANHP returns the value of the one norm, or the Frobenius norm, or -* the infinity norm, or the element of largest absolute value of a -* complex hermitian matrix A, supplied in packed form. -* -* Description -* =========== -* -* ZLANHP returns the value -* -* ZLANHP = ( max(abs(A(i,j))), NORM = 'M' or 'm' -* ( -* ( norm1(A), NORM = '1', 'O' or 'o' -* ( -* ( normI(A), NORM = 'I' or 'i' -* ( -* ( normF(A), NORM = 'F', 'f', 'E' or 'e' -* -* where norm1 denotes the one norm of a matrix (maximum column sum), -* normI denotes the infinity norm of a matrix (maximum row sum) and -* normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies the value to be returned in ZLANHP as described -* above. -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* hermitian matrix A is supplied. -* = 'U': Upper triangular part of A is supplied -* = 'L': Lower triangular part of A is supplied -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. When N = 0, ZLANHP is -* set to zero. -* -* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) -* The upper or lower triangle of the hermitian matrix A, packed -* columnwise in a linear array. The j-th column of A is stored -* in the array AP as follows: -* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; -* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. -* Note that the imaginary parts of the diagonal elements need -* not be set and are assumed to be zero. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), -* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, -* WORK is not referenced. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, K - DOUBLE PRECISION ABSA, SCALE, SUM, VALUE -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL ZLASSQ -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, SQRT -* .. -* .. Executable Statements .. -* - IF( N.EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - K = 0 - DO 20 J = 1, N - DO 10 I = K + 1, K + J - 1 - VALUE = MAX( VALUE, ABS( AP( I ) ) ) - 10 CONTINUE - K = K + J - VALUE = MAX( VALUE, ABS( DBLE( AP( K ) ) ) ) - 20 CONTINUE - ELSE - K = 1 - DO 40 J = 1, N - VALUE = MAX( VALUE, ABS( DBLE( AP( K ) ) ) ) - DO 30 I = K + 1, K + N - J - VALUE = MAX( VALUE, ABS( AP( I ) ) ) - 30 CONTINUE - K = K + N - J + 1 - 40 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. - $ ( NORM.EQ.'1' ) ) THEN -* -* Find normI(A) ( = norm1(A), since A is hermitian). -* - VALUE = ZERO - K = 1 - IF( LSAME( UPLO, 'U' ) ) THEN - DO 60 J = 1, N - SUM = ZERO - DO 50 I = 1, J - 1 - ABSA = ABS( AP( K ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - K = K + 1 - 50 CONTINUE - WORK( J ) = SUM + ABS( DBLE( AP( K ) ) ) - K = K + 1 - 60 CONTINUE - DO 70 I = 1, N - VALUE = MAX( VALUE, WORK( I ) ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - WORK( I ) = ZERO - 80 CONTINUE - DO 100 J = 1, N - SUM = WORK( J ) + ABS( DBLE( AP( K ) ) ) - K = K + 1 - DO 90 I = J + 1, N - ABSA = ABS( AP( K ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - K = K + 1 - 90 CONTINUE - VALUE = MAX( VALUE, SUM ) - 100 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - K = 2 - IF( LSAME( UPLO, 'U' ) ) THEN - DO 110 J = 2, N - CALL ZLASSQ( J-1, AP( K ), 1, SCALE, SUM ) - K = K + J - 110 CONTINUE - ELSE - DO 120 J = 1, N - 1 - CALL ZLASSQ( N-J, AP( K ), 1, SCALE, SUM ) - K = K + N - J + 1 - 120 CONTINUE - END IF - SUM = 2*SUM - K = 1 - DO 130 I = 1, N - IF( DBLE( AP( K ) ).NE.ZERO ) THEN - ABSA = ABS( DBLE( AP( K ) ) ) - IF( SCALE.LT.ABSA ) THEN - SUM = ONE + SUM*( SCALE / ABSA )**2 - SCALE = ABSA - ELSE - SUM = SUM + ( ABSA / SCALE )**2 - END IF - END IF - IF( LSAME( UPLO, 'U' ) ) THEN - K = K + I + 1 - ELSE - K = K + N - I + 1 - END IF - 130 CONTINUE - VALUE = SCALE*SQRT( SUM ) - END IF -* - ZLANHP = VALUE - RETURN -* -* End of ZLANHP -* - END - - SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) - COMPLEX*16 AP( * ), TAU( * ) -* .. -* -* Purpose -* ======= -* -* ZHPTRD reduces a complex Hermitian matrix A stored in packed form to -* real symmetric tridiagonal form T by a unitary similarity -* transformation: Q**H * A * Q = T. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) -* On entry, the upper or lower triangle of the Hermitian matrix -* A, packed columnwise in a linear array. The j-th column of A -* is stored in the array AP as follows: -* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; -* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. -* On exit, if UPLO = 'U', the diagonal and first superdiagonal -* of A are overwritten by the corresponding elements of the -* tridiagonal matrix T, and the elements above the first -* superdiagonal, with the array TAU, represent the unitary -* matrix Q as a product of elementary reflectors; if UPLO -* = 'L', the diagonal and first subdiagonal of A are over- -* written by the corresponding elements of the tridiagonal -* matrix T, and the elements below the first subdiagonal, with -* the array TAU, represent the unitary matrix Q as a product -* of elementary reflectors. See Further Details. -* -* D (output) DOUBLE PRECISION array, dimension (N) -* The diagonal elements of the tridiagonal matrix T: -* D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (N-1) -* The off-diagonal elements of the tridiagonal matrix T: -* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. -* -* TAU (output) COMPLEX*16 array, dimension (N-1) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* If UPLO = 'U', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(n-1) . . . H(2) H(1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a complex scalar, and v is a complex vector with -* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, -* overwriting A(1:i-1,i+1), and tau is stored in TAU(i). -* -* If UPLO = 'L', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(1) H(2) . . . H(n-1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a complex scalar, and v is a complex vector with -* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, -* overwriting A(i+2:n,i), and tau is stored in TAU(i). -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO, HALF - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ), - $ HALF = ( 0.5D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, I1, I1I1, II - COMPLEX*16 ALPHA, TAUI -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZAXPY, ZHPMV, ZHPR2, ZLARFG -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHPTRD', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Reduce the upper triangle of A. -* I1 is the index in AP of A(1,I+1). -* - I1 = N*( N-1 ) / 2 + 1 - AP( I1+N-1 ) = DBLE( AP( I1+N-1 ) ) - DO 10 I = N - 1, 1, -1 -* -* Generate elementary reflector H(i) = I - tau * v * v' -* to annihilate A(1:i-1,i+1) -* - ALPHA = AP( I1+I-1 ) - CALL ZLARFG( I, ALPHA, AP( I1 ), 1, TAUI ) - E( I ) = ALPHA -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(1:i,1:i) -* - AP( I1+I-1 ) = ONE -* -* Compute y := tau * A * v storing y in TAU(1:i) -* - CALL ZHPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU, - $ 1 ) -* -* Compute w := y - 1/2 * tau * (y'*v) * v -* - ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, AP( I1 ), 1 ) - CALL ZAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w' - w * v' -* - CALL ZHPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP ) -* - END IF - AP( I1+I-1 ) = E( I ) - D( I+1 ) = AP( I1+I ) - TAU( I ) = TAUI - I1 = I1 - I - 10 CONTINUE - D( 1 ) = AP( 1 ) - ELSE -* -* Reduce the lower triangle of A. II is the index in AP of -* A(i,i) and I1I1 is the index of A(i+1,i+1). -* - II = 1 - AP( 1 ) = DBLE( AP( 1 ) ) - DO 20 I = 1, N - 1 - I1I1 = II + N - I + 1 -* -* Generate elementary reflector H(i) = I - tau * v * v' -* to annihilate A(i+2:n,i) -* - ALPHA = AP( II+1 ) - CALL ZLARFG( N-I, ALPHA, AP( II+2 ), 1, TAUI ) - E( I ) = ALPHA -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(i+1:n,i+1:n) -* - AP( II+1 ) = ONE -* -* Compute y := tau * A * v storing y in TAU(i:n-1) -* - CALL ZHPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1, - $ ZERO, TAU( I ), 1 ) -* -* Compute w := y - 1/2 * tau * (y'*v) * v -* - ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, AP( II+1 ), - $ 1 ) - CALL ZAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w' - w * v' -* - CALL ZHPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1, - $ AP( I1I1 ) ) -* - END IF - AP( II+1 ) = E( I ) - D( I ) = AP( II ) - TAU( I ) = TAUI - II = I1I1 - 20 CONTINUE - D( N ) = AP( II ) - END IF -* - RETURN -* -* End of ZHPTRD -* - END - SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDQ, N -* .. -* .. Array Arguments .. - COMPLEX*16 AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUPGTR generates a complex unitary matrix Q which is defined as the -* product of n-1 elementary reflectors H(i) of order n, as returned by -* ZHPTRD using packed storage: -* -* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), -* -* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangular packed storage used in previous -* call to ZHPTRD; -* = 'L': Lower triangular packed storage used in previous -* call to ZHPTRD. -* -* N (input) INTEGER -* The order of the matrix Q. N >= 0. -* -* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) -* The vectors which define the elementary reflectors, as -* returned by ZHPTRD. -* -* TAU (input) COMPLEX*16 array, dimension (N-1) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZHPTRD. -* -* Q (output) COMPLEX*16 array, dimension (LDQ,N) -* The N-by-N unitary matrix Q. -* -* LDQ (input) INTEGER -* The leading dimension of the array Q. LDQ >= max(1,N). -* -* WORK (workspace) COMPLEX*16 array, dimension (N-1) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 CZERO, CONE - PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), - $ CONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IINFO, IJ, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZUNG2L, ZUNG2R -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUPGTR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Q was determined by a call to ZHPTRD with UPLO = 'U' -* -* Unpack the vectors which define the elementary reflectors and -* set the last row and column of Q equal to those of the unit -* matrix -* - IJ = 2 - DO 20 J = 1, N - 1 - DO 10 I = 1, J - 1 - Q( I, J ) = AP( IJ ) - IJ = IJ + 1 - 10 CONTINUE - IJ = IJ + 2 - Q( N, J ) = CZERO - 20 CONTINUE - DO 30 I = 1, N - 1 - Q( I, N ) = CZERO - 30 CONTINUE - Q( N, N ) = CONE -* -* Generate Q(1:n-1,1:n-1) -* - CALL ZUNG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO ) -* - ELSE -* -* Q was determined by a call to ZHPTRD with UPLO = 'L'. -* -* Unpack the vectors which define the elementary reflectors and -* set the first row and column of Q equal to those of the unit -* matrix -* - Q( 1, 1 ) = CONE - DO 40 I = 2, N - Q( I, 1 ) = CZERO - 40 CONTINUE - IJ = 3 - DO 60 J = 2, N - Q( 1, J ) = CZERO - DO 50 I = J + 1, N - Q( I, J ) = AP( IJ ) - IJ = IJ + 1 - 50 CONTINUE - IJ = IJ + 2 - 60 CONTINUE - IF( N.GT.1 ) THEN -* -* Generate Q(2:n,2:n) -* - CALL ZUNG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK, - $ IINFO ) - END IF - END IF - RETURN -* -* End of ZUPGTR -* - END - SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 25, 1997 -* -* .. Scalar Arguments .. - INTEGER INFO, LDB, N, NRHS -* .. -* .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) -* .. -* -* Purpose -* ======= -* -* DPTSV computes the solution to a real system of linear equations -* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal -* matrix, and X and B are N-by-NRHS matrices. -* -* A is factored as A = L*D*L**T, and the factored form of A is then -* used to solve the system of equations. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the n diagonal elements of the tridiagonal matrix -* A. On exit, the n diagonal elements of the diagonal matrix -* D from the factorization A = L*D*L**T. -* -* E (input/output) DOUBLE PRECISION array, dimension (N-1) -* On entry, the (n-1) subdiagonal elements of the tridiagonal -* matrix A. On exit, the (n-1) subdiagonal elements of the -* unit bidiagonal factor L from the L*D*L**T factorization of -* A. (E can also be regarded as the superdiagonal of the unit -* bidiagonal factor U from the U**T*D*U factorization of A.) -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the N-by-NRHS right hand side matrix B. -* On exit, if INFO = 0, the N-by-NRHS solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the leading minor of order i is not -* positive definite, and the solution has not been -* computed. The factorization has not been completed -* unless i = N. -* -* ===================================================================== -* -* .. External Subroutines .. - EXTERNAL DPTTRF, DPTTRS, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -2 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPTSV ', -INFO ) - RETURN - END IF -* -* Compute the L*D*L' (or U'*D*U) factorization of A. -* - CALL DPTTRF( N, D, E, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL DPTTRS( N, NRHS, D, E, B, LDB, INFO ) - END IF - RETURN -* -* End of DPTSV -* - END - SUBROUTINE DPTTRF( N, D, E, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) -* .. -* -* Purpose -* ======= -* -* DPTTRF computes the L*D*L' factorization of a real symmetric -* positive definite tridiagonal matrix A. The factorization may also -* be regarded as having the form A = U'*D*U. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the n diagonal elements of the tridiagonal matrix -* A. On exit, the n diagonal elements of the diagonal matrix -* D from the L*D*L' factorization of A. -* -* E (input/output) DOUBLE PRECISION array, dimension (N-1) -* On entry, the (n-1) subdiagonal elements of the tridiagonal -* matrix A. On exit, the (n-1) subdiagonal elements of the -* unit bidiagonal factor L from the L*D*L' factorization of A. -* E can also be regarded as the superdiagonal of the unit -* bidiagonal factor U from the U'*D*U factorization of A. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, the leading minor of order k is not -* positive definite; if k < N, the factorization could not -* be completed, while if k = N, the factorization was -* completed, but D(N) = 0. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, I4 - DOUBLE PRECISION EI -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'DPTTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Compute the L*D*L' (or U'*D*U) factorization of A. -* - I4 = MOD( N-1, 4 ) - DO 10 I = 1, I4 - IF( D( I ).LE.ZERO ) THEN - INFO = I - GO TO 30 - END IF - EI = E( I ) - E( I ) = EI / D( I ) - D( I+1 ) = D( I+1 ) - E( I )*EI - 10 CONTINUE -* - DO 20 I = I4 + 1, N - 4, 4 -* -* Drop out of the loop if d(i) <= 0: the matrix is not positive -* definite. -* - IF( D( I ).LE.ZERO ) THEN - INFO = I - GO TO 30 - END IF -* -* Solve for e(i) and d(i+1). -* - EI = E( I ) - E( I ) = EI / D( I ) - D( I+1 ) = D( I+1 ) - E( I )*EI -* - IF( D( I+1 ).LE.ZERO ) THEN - INFO = I + 1 - GO TO 30 - END IF -* -* Solve for e(i+1) and d(i+2). -* - EI = E( I+1 ) - E( I+1 ) = EI / D( I+1 ) - D( I+2 ) = D( I+2 ) - E( I+1 )*EI -* - IF( D( I+2 ).LE.ZERO ) THEN - INFO = I + 2 - GO TO 30 - END IF -* -* Solve for e(i+2) and d(i+3). -* - EI = E( I+2 ) - E( I+2 ) = EI / D( I+2 ) - D( I+3 ) = D( I+3 ) - E( I+2 )*EI -* - IF( D( I+3 ).LE.ZERO ) THEN - INFO = I + 3 - GO TO 30 - END IF -* -* Solve for e(i+3) and d(i+4). -* - EI = E( I+3 ) - E( I+3 ) = EI / D( I+3 ) - D( I+4 ) = D( I+4 ) - E( I+3 )*EI - 20 CONTINUE -* -* Check d(n) for positive definiteness. -* - IF( D( N ).LE.ZERO ) - $ INFO = N -* - 30 CONTINUE - RETURN -* -* End of DPTTRF -* - END - SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, LDB, N, NRHS -* .. -* .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) -* .. -* -* Purpose -* ======= -* -* DPTTRS solves a tridiagonal system of the form -* A * X = B -* using the L*D*L' factorization of A computed by DPTTRF. D is a -* diagonal matrix specified in the vector D, L is a unit bidiagonal -* matrix whose subdiagonal is specified in the vector E, and X and B -* are N by NRHS matrices. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the tridiagonal matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* D (input) DOUBLE PRECISION array, dimension (N) -* The n diagonal elements of the diagonal matrix D from the -* L*D*L' factorization of A. -* -* E (input) DOUBLE PRECISION array, dimension (N-1) -* The (n-1) subdiagonal elements of the unit bidiagonal factor -* L from the L*D*L' factorization of A. E can also be regarded -* as the superdiagonal of the unit bidiagonal factor U from the -* factorization A = U'*D*U. -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side vectors B for the system of -* linear equations. -* On exit, the solution vectors, X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER J, JB, NB -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DPTTS2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -2 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPTTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* -* Determine the number of right-hand sides to solve at a time. -* - IF( NRHS.EQ.1 ) THEN - NB = 1 - ELSE - NB = MAX( 1, ILAENV( 1, 'DPTTRS', ' ', N, NRHS, -1, -1 ) ) - END IF -* - IF( NB.GE.NRHS ) THEN - CALL DPTTS2( N, NRHS, D, E, B, LDB ) - ELSE - DO 10 J = 1, NRHS, NB - JB = MIN( NRHS-J+1, NB ) - CALL DPTTS2( N, JB, D, E, B( 1, J ), LDB ) - 10 CONTINUE - END IF -* - RETURN -* -* End of DPTTRS -* - END - - SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER LDB, N, NRHS -* .. -* .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) -* .. -* -* Purpose -* ======= -* -* DPTTS2 solves a tridiagonal system of the form -* A * X = B -* using the L*D*L' factorization of A computed by DPTTRF. D is a -* diagonal matrix specified in the vector D, L is a unit bidiagonal -* matrix whose subdiagonal is specified in the vector E, and X and B -* are N by NRHS matrices. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the tridiagonal matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* D (input) DOUBLE PRECISION array, dimension (N) -* The n diagonal elements of the diagonal matrix D from the -* L*D*L' factorization of A. -* -* E (input) DOUBLE PRECISION array, dimension (N-1) -* The (n-1) subdiagonal elements of the unit bidiagonal factor -* L from the L*D*L' factorization of A. E can also be regarded -* as the superdiagonal of the unit bidiagonal factor U from the -* factorization A = U'*D*U. -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side vectors B for the system of -* linear equations. -* On exit, the solution vectors, X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Subroutines .. - EXTERNAL DSCAL -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.1 ) THEN - IF( N.EQ.1 ) - $ CALL DSCAL( NRHS, 1.D0 / D( 1 ), B, LDB ) - RETURN - END IF -* -* Solve A * X = B using the factorization A = L*D*L', -* overwriting each right hand side vector with its solution. -* - DO 30 J = 1, NRHS -* -* Solve L * x = b. -* - DO 10 I = 2, N - B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 ) - 10 CONTINUE -* -* Solve D * L' * x = b. -* - B( N, J ) = B( N, J ) / D( N ) - DO 20 I = N - 1, 1, -1 - B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I ) - 20 CONTINUE - 30 CONTINUE -* - RETURN -* -* End of DPTTS2 -* - END -! -! dgels and following subroutines used only in wf.f90 -! - SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, - $ INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGELS solves overdetermined or underdetermined real linear systems -* involving an M-by-N matrix A, or its transpose, using a QR or LQ -* factorization of A. It is assumed that A has full rank. -* -* The following options are provided: -* -* 1. If TRANS = 'N' and m >= n: find the least squares solution of -* an overdetermined system, i.e., solve the least squares problem -* minimize || B - A*X ||. -* -* 2. If TRANS = 'N' and m < n: find the minimum norm solution of -* an underdetermined system A * X = B. -* -* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of -* an undetermined system A**T * X = B. -* -* 4. If TRANS = 'T' and m < n: find the least squares solution of -* an overdetermined system, i.e., solve the least squares problem -* minimize || B - A**T * X ||. -* -* Several right hand side vectors b and solution vectors x can be -* handled in a single call; they are stored as the columns of the -* M-by-NRHS right hand side matrix B and the N-by-NRHS solution -* matrix X. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER -* = 'N': the linear system involves A; -* = 'T': the linear system involves A**T. -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of -* columns of the matrices B and X. NRHS >=0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix A. -* On exit, -* if M >= N, A is overwritten by details of its QR -* factorization as returned by DGEQRF; -* if M < N, A is overwritten by details of its LQ -* factorization as returned by DGELQF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the matrix B of right hand side vectors, stored -* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS -* if TRANS = 'T'. -* On exit, B is overwritten by the solution vectors, stored -* columnwise: -* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least -* squares solution vectors; the residual sum of squares for the -* solution in each column is given by the sum of squares of -* elements N+1 to M in that column; -* if TRANS = 'N' and m < n, rows 1 to N of B contain the -* minimum norm solution vectors; -* if TRANS = 'T' and m >= n, rows 1 to M of B contain the -* minimum norm solution vectors; -* if TRANS = 'T' and m < n, rows 1 to M of B contain the -* least squares solution vectors; the residual sum of squares -* for the solution in each column is given by the sum of -* squares of elements M+1 to N in that column. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= MAX(1,M,N). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* LWORK >= max( 1, MN + max( MN, NRHS ) ). -* For optimal performance, -* LWORK >= max( 1, MN + max( MN, NRHS )*NB ). -* where MN = min(M,N) and NB is the optimum block size. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, TPSD - INTEGER BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE - DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM -* .. -* .. Local Arrays .. - DOUBLE PRECISION RWORK( 1 ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE -* .. -* .. External Subroutines .. - EXTERNAL DGELQF, DGEQRF, DLASCL, DLASET, DORMLQ, DORMQR, - $ DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments. -* - INFO = 0 - MN = MIN( M, N ) - LQUERY = ( LWORK.EQ.-1 ) - IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN - INFO = -8 - ELSE IF( LWORK.LT.MAX( 1, MN+MAX( MN, NRHS ) ) .AND. .NOT.LQUERY ) - $ THEN - INFO = -10 - END IF -* -* Figure out optimal block size -* - IF( INFO.EQ.0 .OR. INFO.EQ.-10 ) THEN -* - TPSD = .TRUE. - IF( LSAME( TRANS, 'N' ) ) - $ TPSD = .FALSE. -* - IF( M.GE.N ) THEN - NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - IF( TPSD ) THEN - NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LN', M, NRHS, N, - $ -1 ) ) - ELSE - NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, - $ -1 ) ) - END IF - ELSE - NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - IF( TPSD ) THEN - NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, - $ -1 ) ) - ELSE - NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LN', N, NRHS, M, - $ -1 ) ) - END IF - END IF -* - WSIZE = MAX( 1, MN+MAX( MN, NRHS )*NB ) - WORK( 1 ) = DBLE( WSIZE ) -* - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGELS ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( MIN( M, N, NRHS ).EQ.0 ) THEN - CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) - RETURN - END IF -* -* Get machine parameters -* - SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -* -* Scale A, B if max element outside range [SMLNUM,BIGNUM] -* - ANRM = DLANGE( 'M', M, N, A, LDA, RWORK ) - IASCL = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN -* -* Scale matrix norm up to SMLNUM -* - CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) - IASCL = 1 - ELSE IF( ANRM.GT.BIGNUM ) THEN -* -* Scale matrix norm down to BIGNUM -* - CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) - IASCL = 2 - ELSE IF( ANRM.EQ.ZERO ) THEN -* -* Matrix all zero. Return zero solution. -* - CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) - GO TO 50 - END IF -* - BROW = M - IF( TPSD ) - $ BROW = N - BNRM = DLANGE( 'M', BROW, NRHS, B, LDB, RWORK ) - IBSCL = 0 - IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN -* -* Scale matrix norm up to SMLNUM -* - CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB, - $ INFO ) - IBSCL = 1 - ELSE IF( BNRM.GT.BIGNUM ) THEN -* -* Scale matrix norm down to BIGNUM -* - CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB, - $ INFO ) - IBSCL = 2 - END IF -* - IF( M.GE.N ) THEN -* -* compute QR factorization of A -* - CALL DGEQRF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN, - $ INFO ) -* -* workspace at least N, optimally N*NB -* - IF( .NOT.TPSD ) THEN -* -* Least-Squares Problem min || A * X - B || -* -* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) -* - CALL DORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA, - $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, - $ INFO ) -* -* workspace at least NRHS, optimally NRHS*NB -* -* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) -* - SCLLEN = N -* - ELSE -* -* Overdetermined system of equations A' * X = B -* -* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) -* -* B(N+1:M,1:NRHS) = ZERO -* - DO 20 J = 1, NRHS - DO 10 I = N + 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* -* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) -* - CALL DORMQR( 'Left', 'No transpose', M, NRHS, N, A, LDA, - $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, - $ INFO ) -* -* workspace at least NRHS, optimally NRHS*NB -* - SCLLEN = M -* - END IF -* - ELSE -* -* Compute LQ factorization of A -* - CALL DGELQF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN, - $ INFO ) -* -* workspace at least M, optimally M*NB. -* - IF( .NOT.TPSD ) THEN -* -* underdetermined system of equations A * X = B -* -* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', M, - $ NRHS, ONE, A, LDA, B, LDB ) -* -* B(M+1:N,1:NRHS) = 0 -* - DO 40 J = 1, NRHS - DO 30 I = M + 1, N - B( I, J ) = ZERO - 30 CONTINUE - 40 CONTINUE -* -* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) -* - CALL DORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA, - $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, - $ INFO ) -* -* workspace at least NRHS, optimally NRHS*NB -* - SCLLEN = N -* - ELSE -* -* overdetermined system min || A' * X - B || -* -* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) -* - CALL DORMLQ( 'Left', 'No transpose', N, NRHS, M, A, LDA, - $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, - $ INFO ) -* -* workspace at least NRHS, optimally NRHS*NB -* -* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', M, - $ NRHS, ONE, A, LDA, B, LDB ) -* - SCLLEN = M -* - END IF -* - END IF -* -* Undo scaling -* - IF( IASCL.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB, - $ INFO ) - ELSE IF( IASCL.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB, - $ INFO ) - END IF - IF( IBSCL.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB, - $ INFO ) - ELSE IF( IBSCL.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB, - $ INFO ) - END IF -* - 50 CONTINUE - WORK( 1 ) = DBLE( WSIZE ) -* - RETURN -* -* End of DGELS -* - END - SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGELQF computes an LQ factorization of a real M-by-N matrix A: -* A = L * Q. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix A. -* On exit, the elements on and below the diagonal of the array -* contain the m-by-min(m,n) lower trapezoidal matrix L (L is -* lower triangular if m <= n); the elements above the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of elementary reflectors (see Further Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,M). -* For optimum performance LWORK >= M*NB, where NB is the -* optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(k) . . . H(2) H(1), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DGELQ2, DLARFB, DLARFT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - LWKOPT = M*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGELQF', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = M - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DGELQF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = M - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the LQ factorization of the current block -* A(i:i+ib-1,i:n) -* - CALL DGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.M ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(i+ib:m,i:n) from the right -* - CALL DLARFB( 'Right', 'No transpose', 'Forward', - $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), - $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, - $ WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of DGELQF -* - END - SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEQRF computes a QR factorization of a real M-by-N matrix A: -* A = Q * R. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix A. -* On exit, the elements on and above the diagonal of the array -* contain the min(M,N)-by-N upper trapezoidal matrix R (R is -* upper triangular if m >= n); the elements below the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of min(m,n) elementary reflectors (see Further -* Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is -* the optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(1) H(2) . . . H(k), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQRF', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the QR factorization of the current block -* A(i:m,i:i+ib-1) -* - CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H' to A(i:m,i+ib:n) from the left -* - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of DGEQRF -* - END - DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLANGE returns the value of the one norm, or the Frobenius norm, or -* the infinity norm, or the element of largest absolute value of a -* real matrix A. -* -* Description -* =========== -* -* DLANGE returns the value -* -* DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' -* ( -* ( norm1(A), NORM = '1', 'O' or 'o' -* ( -* ( normI(A), NORM = 'I' or 'i' -* ( -* ( normF(A), NORM = 'F', 'f', 'E' or 'e' -* -* where norm1 denotes the one norm of a matrix (maximum column sum), -* normI denotes the infinity norm of a matrix (maximum row sum) and -* normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies the value to be returned in DLANGE as described -* above. -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. When M = 0, -* DLANGE is set to zero. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. When N = 0, -* DLANGE is set to zero. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(M,1). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), -* where LWORK >= M when NORM = 'I'; otherwise, WORK is not -* referenced. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION SCALE, SUM, VALUE -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - IF( MIN( M, N ).EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - DO 20 J = 1, N - DO 10 I = 1, M - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 10 CONTINUE - 20 CONTINUE - ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN -* -* Find norm1(A). -* - VALUE = ZERO - DO 40 J = 1, N - SUM = ZERO - DO 30 I = 1, M - SUM = SUM + ABS( A( I, J ) ) - 30 CONTINUE - VALUE = MAX( VALUE, SUM ) - 40 CONTINUE - ELSE IF( LSAME( NORM, 'I' ) ) THEN -* -* Find normI(A). -* - DO 50 I = 1, M - WORK( I ) = ZERO - 50 CONTINUE - DO 70 J = 1, N - DO 60 I = 1, M - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 60 CONTINUE - 70 CONTINUE - VALUE = ZERO - DO 80 I = 1, M - VALUE = MAX( VALUE, WORK( I ) ) - 80 CONTINUE - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - DO 90 J = 1, N - CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM ) - 90 CONTINUE - VALUE = SCALE*SQRT( SUM ) - END IF -* - DLANGE = VALUE - RETURN -* -* End of DLANGE -* - END - SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORMLQ overwrites the general real M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**T -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**T from the Left; -* = 'R': apply Q or Q**T from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'T': Transpose, apply Q**T. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension -* (LDA,M) if SIDE = 'L', -* (LDA,N) if SIDE = 'R' -* The i-th row must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGELQF in the first k rows of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,K). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGELQF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - CHARACTER TRANST - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORML2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMLQ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IF( ( LEFT .AND. NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - IF( NOTRAN ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), T, LDT ) - IF( LEFT ) THEN -* -* H or H' is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H' is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H' -* - CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, - $ A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, WORK, - $ LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMLQ -* - END - SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGELQ2 computes an LQ factorization of a real m by n matrix A: -* A = L * Q. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix A. -* On exit, the elements on and below the diagonal of the array -* contain the m by min(m,n) lower trapezoidal matrix L (L is -* lower triangular if m <= n); the elements above the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of elementary reflectors (see Further Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (M) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(k) . . . H(2) H(1), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, K - DOUBLE PRECISION AII -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGELQ2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i,i+1:n) -* - CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, - $ TAU( I ) ) - IF( I.LT.M ) THEN -* -* Apply H(i) to A(i+1:m,i:n) from the right -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), - $ A( I+1, I ), LDA, WORK ) - A( I, I ) = AII - END IF - 10 CONTINUE - RETURN -* -* End of DGELQ2 -* - END - SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORML2 overwrites the general real m by n matrix C with -* -* Q * C if SIDE = 'L' and TRANS = 'N', or -* -* Q'* C if SIDE = 'L' and TRANS = 'T', or -* -* C * Q if SIDE = 'R' and TRANS = 'N', or -* -* C * Q' if SIDE = 'R' and TRANS = 'T', -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q' from the Left -* = 'R': apply Q or Q' from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply Q (No transpose) -* = 'T': apply Q' (Transpose) -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension -* (LDA,M) if SIDE = 'L', -* (LDA,N) if SIDE = 'R' -* The i-th row must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGELQF in the first k rows of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,K). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGELQF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L', -* (M) if SIDE = 'R' -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORML2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), - $ C( IC, JC ), LDC, WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORML2 -* - END - SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEQR2 computes a QR factorization of a real m by n matrix A: -* A = Q * R. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix A. -* On exit, the elements on and above the diagonal of the array -* contain the min(m,n) by n upper trapezoidal matrix R (R is -* upper triangular if m >= n); the elements below the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of elementary reflectors (see Further Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(1) H(2) . . . H(k), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, K - DOUBLE PRECISION AII -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQR2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAU( I ) ) - IF( I.LT.N ) THEN -* -* Apply H(i) to A(i:m,i+1:n) from the left -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = AII - END IF - 10 CONTINUE - RETURN -* -* End of DGEQR2 -* - END - - -* start: these routines for w90 * - - SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, - $ LDVS, WORK, LWORK, RWORK, BWORK, INFO ) -* -* -- LAPACK driver routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER JOBVS, SORT - INTEGER INFO, LDA, LDVS, LWORK, N, SDIM -* .. -* .. Array Arguments .. - LOGICAL BWORK( * ) - DOUBLE PRECISION RWORK( * ) - COMPLEX*16 A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * ) -* .. -* .. Function Arguments .. - LOGICAL SELECT - EXTERNAL SELECT -* .. -* -* Purpose -* ======= -* -* ZGEES computes for an N-by-N complex nonsymmetric matrix A, the -* eigenvalues, the Schur form T, and, optionally, the matrix of Schur -* vectors Z. This gives the Schur factorization A = Z*T*(Z**H). -* -* Optionally, it also orders the eigenvalues on the diagonal of the -* Schur form so that selected eigenvalues are at the top left. -* The leading columns of Z then form an orthonormal basis for the -* invariant subspace corresponding to the selected eigenvalues. -* -* A complex matrix is in Schur form if it is upper triangular. -* -* Arguments -* ========= -* -* JOBVS (input) CHARACTER*1 -* = 'N': Schur vectors are not computed; -* = 'V': Schur vectors are computed. -* -* SORT (input) CHARACTER*1 -* Specifies whether or not to order the eigenvalues on the -* diagonal of the Schur form. -* = 'N': Eigenvalues are not ordered: -* = 'S': Eigenvalues are ordered (see SELECT). -* -* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument -* SELECT must be declared EXTERNAL in the calling subroutine. -* If SORT = 'S', SELECT is used to select eigenvalues to order -* to the top left of the Schur form. -* IF SORT = 'N', SELECT is not referenced. -* The eigenvalue W(j) is selected if SELECT(W(j)) is true. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the N-by-N matrix A. -* On exit, A has been overwritten by its Schur form T. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* SDIM (output) INTEGER -* If SORT = 'N', SDIM = 0. -* If SORT = 'S', SDIM = number of eigenvalues for which -* SELECT is true. -* -* W (output) COMPLEX*16 array, dimension (N) -* W contains the computed eigenvalues, in the same order that -* they appear on the diagonal of the output Schur form T. -* -* VS (output) COMPLEX*16 array, dimension (LDVS,N) -* If JOBVS = 'V', VS contains the unitary matrix Z of Schur -* vectors. -* If JOBVS = 'N', VS is not referenced. -* -* LDVS (input) INTEGER -* The leading dimension of the array VS. LDVS >= 1; if -* JOBVS = 'V', LDVS >= N. -* -* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,2*N). -* For good performance, LWORK must generally be larger. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* RWORK (workspace) DOUBLE PRECISION array, dimension (N) -* -* BWORK (workspace) LOGICAL array, dimension (N) -* Not referenced if SORT = 'N'. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* > 0: if INFO = i, and i is -* <= N: the QR algorithm failed to compute all the -* eigenvalues; elements 1:ILO-1 and i+1:N of W -* contain those eigenvalues which have converged; -* if JOBVS = 'V', VS contains the matrix which -* reduces A to its partially converged Schur form. -* = N+1: the eigenvalues could not be reordered because -* some eigenvalues were too close to separate (the -* problem is very ill-conditioned); -* = N+2: after reordering, roundoff changed values of -* some complex eigenvalues so that leading -* eigenvalues in the Schur form no longer satisfy -* SELECT = .TRUE.. This could also be caused by -* underflow due to scaling. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, SCALEA, WANTST, WANTVS - INTEGER HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO, - $ ITAU, IWRK, MAXWRK, MINWRK - DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM -* .. -* .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ) -* .. -* .. External Subroutines .. - EXTERNAL DLABAD, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, ZGEHRD, - $ ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - WANTVS = LSAME( JOBVS, 'V' ) - WANTST = LSAME( SORT, 'S' ) - IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN - INFO = -10 - END IF -* -* Compute workspace -* (Note: Comments in the code beginning "Workspace:" describe the -* minimal amount of workspace needed at that point in the code, -* as well as the preferred amount for good performance. -* CWorkspace refers to complex workspace, and RWorkspace to real -* workspace. NB refers to the optimal block size for the -* immediately following subroutine, as returned by ILAENV. -* HSWORK refers to the workspace preferred by ZHSEQR, as -* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, -* the worst case.) -* - IF( INFO.EQ.0 ) THEN - IF( N.EQ.0 ) THEN - MINWRK = 1 - MAXWRK = 1 - ELSE - MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) - MINWRK = 2*N -* - CALL ZHSEQR( 'S', JOBVS, N, 1, N, A, LDA, W, VS, LDVS, - $ WORK, -1, IEVAL ) - HSWORK = WORK( 1 ) -* - IF( .NOT.WANTVS ) THEN - MAXWRK = MAX( MAXWRK, HSWORK ) - ELSE - MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', - $ ' ', N, 1, N, -1 ) ) - MAXWRK = MAX( MAXWRK, HSWORK ) - END IF - END IF - WORK( 1 ) = MAXWRK -* - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGEES ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - SDIM = 0 - RETURN - END IF -* -* Get machine constants -* - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SQRT( SMLNUM ) / EPS - BIGNUM = ONE / SMLNUM -* -* Scale A if max element outside range [SMLNUM,BIGNUM] -* - ANRM = ZLANGE( 'M', N, N, A, LDA, DUM ) - SCALEA = .FALSE. - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN - SCALEA = .TRUE. - CSCALE = SMLNUM - ELSE IF( ANRM.GT.BIGNUM ) THEN - SCALEA = .TRUE. - CSCALE = BIGNUM - END IF - IF( SCALEA ) - $ CALL ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) -* -* Permute the matrix to make it more nearly triangular -* (CWorkspace: none) -* (RWorkspace: need N) -* - IBAL = 1 - CALL ZGEBAL( 'P', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR ) -* -* Reduce to upper Hessenberg form -* (CWorkspace: need 2*N, prefer N+N*NB) -* (RWorkspace: none) -* - ITAU = 1 - IWRK = N + ITAU - CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), - $ LWORK-IWRK+1, IERR ) -* - IF( WANTVS ) THEN -* -* Copy Householder vectors to VS -* - CALL ZLACPY( 'L', N, N, A, LDA, VS, LDVS ) -* -* Generate unitary matrix in VS -* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) -* (RWorkspace: none) -* - CALL ZUNGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ), - $ LWORK-IWRK+1, IERR ) - END IF -* - SDIM = 0 -* -* Perform QR iteration, accumulating Schur vectors in VS if desired -* (CWorkspace: need 1, prefer HSWORK (see comments) ) -* (RWorkspace: none) -* - IWRK = ITAU - CALL ZHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, W, VS, LDVS, - $ WORK( IWRK ), LWORK-IWRK+1, IEVAL ) - IF( IEVAL.GT.0 ) - $ INFO = IEVAL -* -* Sort eigenvalues if desired -* - IF( WANTST .AND. INFO.EQ.0 ) THEN - IF( SCALEA ) - $ CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, W, N, IERR ) - DO 10 I = 1, N - BWORK( I ) = SELECT( W( I ) ) - 10 CONTINUE -* -* Reorder eigenvalues and transform Schur vectors -* (CWorkspace: none) -* (RWorkspace: none) -* - CALL ZTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, W, SDIM, - $ S, SEP, WORK( IWRK ), LWORK-IWRK+1, ICOND ) - END IF -* - IF( WANTVS ) THEN -* -* Undo balancing -* (CWorkspace: none) -* (RWorkspace: need N) -* - CALL ZGEBAK( 'P', 'R', N, ILO, IHI, RWORK( IBAL ), N, VS, LDVS, - $ IERR ) - END IF -* - IF( SCALEA ) THEN -* -* Undo scaling for the Schur form of A -* - CALL ZLASCL( 'U', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR ) - CALL ZCOPY( N, A, LDA+1, W, 1 ) - END IF -* - WORK( 1 ) = MAXWRK - RETURN -* -* End of ZGEES -* - END - - SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER JOB - INTEGER IHI, ILO, INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION SCALE( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZGEBAL balances a general complex matrix A. This involves, first, -* permuting A by a similarity transformation to isolate eigenvalues -* in the first 1 to ILO-1 and last IHI+1 to N elements on the -* diagonal; and second, applying a diagonal similarity transformation -* to rows and columns ILO to IHI to make the rows and columns as -* close in norm as possible. Both steps are optional. -* -* Balancing may reduce the 1-norm of the matrix, and improve the -* accuracy of the computed eigenvalues and/or eigenvectors. -* -* Arguments -* ========= -* -* JOB (input) CHARACTER*1 -* Specifies the operations to be performed on A: -* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 -* for i = 1,...,N; -* = 'P': permute only; -* = 'S': scale only; -* = 'B': both permute and scale. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the input matrix A. -* On exit, A is overwritten by the balanced matrix. -* If JOB = 'N', A is not referenced. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* ILO (output) INTEGER -* IHI (output) INTEGER -* ILO and IHI are set to integers such that on exit -* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. -* If JOB = 'N' or 'S', ILO = 1 and IHI = N. -* -* SCALE (output) DOUBLE PRECISION array, dimension (N) -* Details of the permutations and scaling factors applied to -* A. If P(j) is the index of the row and column interchanged -* with row and column j and D(j) is the scaling factor -* applied to row and column j, then -* SCALE(j) = P(j) for j = 1,...,ILO-1 -* = D(j) for j = ILO,...,IHI -* = P(j) for j = IHI+1,...,N. -* The order in which the interchanges are made is N to IHI+1, -* then 1 to ILO-1. -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* The permutations consist of row and column interchanges which put -* the matrix in the form -* -* ( T1 X Y ) -* P A P = ( 0 B Z ) -* ( 0 0 T2 ) -* -* where T1 and T2 are upper triangular matrices whose eigenvalues lie -* along the diagonal. The column indices ILO and IHI mark the starting -* and ending columns of the submatrix B. Balancing consists of applying -* a diagonal similarity transformation inv(D) * B * D to make the -* 1-norms of each row of B and its corresponding column nearly equal. -* The output matrix is -* -* ( T1 X*D Y ) -* ( 0 inv(D)*B*D inv(D)*Z ). -* ( 0 0 T2 ) -* -* Information about the permutations P and the diagonal matrix D is -* returned in the vector SCALE. -* -* This subroutine is based on the EISPACK routine CBAL. -* -* Modified by Tzu-Yi Chen, Computer Science Division, University of -* California at Berkeley, USA -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION SCLFAC - PARAMETER ( SCLFAC = 2.0D+0 ) - DOUBLE PRECISION FACTOR - PARAMETER ( FACTOR = 0.95D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOCONV - INTEGER I, ICA, IEXC, IRA, J, K, L, M - DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, - $ SFMIN2 - COMPLEX*16 CDUM -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IZAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IZAMAX, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL, ZSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DIMAG, MAX, MIN -* .. -* .. Statement Functions .. - DOUBLE PRECISION CABS1 -* .. -* .. Statement Function definitions .. - CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. - $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGEBAL', -INFO ) - RETURN - END IF -* - K = 1 - L = N -* - IF( N.EQ.0 ) - $ GO TO 210 -* - IF( LSAME( JOB, 'N' ) ) THEN - DO 10 I = 1, N - SCALE( I ) = ONE - 10 CONTINUE - GO TO 210 - END IF -* - IF( LSAME( JOB, 'S' ) ) - $ GO TO 120 -* -* Permutation to isolate eigenvalues if possible -* - GO TO 50 -* -* Row and column exchange. -* - 20 CONTINUE - SCALE( M ) = J - IF( J.EQ.M ) - $ GO TO 30 -* - CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) - CALL ZSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA ) -* - 30 CONTINUE - GO TO ( 40, 80 )IEXC -* -* Search for rows isolating an eigenvalue and push them down. -* - 40 CONTINUE - IF( L.EQ.1 ) - $ GO TO 210 - L = L - 1 -* - 50 CONTINUE - DO 70 J = L, 1, -1 -* - DO 60 I = 1, L - IF( I.EQ.J ) - $ GO TO 60 - IF( DBLE( A( J, I ) ).NE.ZERO .OR. DIMAG( A( J, I ) ).NE. - $ ZERO )GO TO 70 - 60 CONTINUE -* - M = L - IEXC = 1 - GO TO 20 - 70 CONTINUE -* - GO TO 90 -* -* Search for columns isolating an eigenvalue and push them left. -* - 80 CONTINUE - K = K + 1 -* - 90 CONTINUE - DO 110 J = K, L -* - DO 100 I = K, L - IF( I.EQ.J ) - $ GO TO 100 - IF( DBLE( A( I, J ) ).NE.ZERO .OR. DIMAG( A( I, J ) ).NE. - $ ZERO )GO TO 110 - 100 CONTINUE -* - M = K - IEXC = 2 - GO TO 20 - 110 CONTINUE -* - 120 CONTINUE - DO 130 I = K, L - SCALE( I ) = ONE - 130 CONTINUE -* - IF( LSAME( JOB, 'P' ) ) - $ GO TO 210 -* -* Balance the submatrix in rows K to L. -* -* Iterative loop for norm reduction -* - SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) - SFMAX1 = ONE / SFMIN1 - SFMIN2 = SFMIN1*SCLFAC - SFMAX2 = ONE / SFMIN2 - 140 CONTINUE - NOCONV = .FALSE. -* - DO 200 I = K, L - C = ZERO - R = ZERO -* - DO 150 J = K, L - IF( J.EQ.I ) - $ GO TO 150 - C = C + CABS1( A( J, I ) ) - R = R + CABS1( A( I, J ) ) - 150 CONTINUE - ICA = IZAMAX( L, A( 1, I ), 1 ) - CA = ABS( A( ICA, I ) ) - IRA = IZAMAX( N-K+1, A( I, K ), LDA ) - RA = ABS( A( I, IRA+K-1 ) ) -* -* Guard against zero C or R due to underflow. -* - IF( C.EQ.ZERO .OR. R.EQ.ZERO ) - $ GO TO 200 - G = R / SCLFAC - F = ONE - S = C + R - 160 CONTINUE - IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. - $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170 - F = F*SCLFAC - C = C*SCLFAC - CA = CA*SCLFAC - R = R / SCLFAC - G = G / SCLFAC - RA = RA / SCLFAC - GO TO 160 -* - 170 CONTINUE - G = C / SCLFAC - 180 CONTINUE - IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. - $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190 - F = F / SCLFAC - C = C / SCLFAC - G = G / SCLFAC - CA = CA / SCLFAC - R = R*SCLFAC - RA = RA*SCLFAC - GO TO 180 -* -* Now balance. -* - 190 CONTINUE - IF( ( C+R ).GE.FACTOR*S ) - $ GO TO 200 - IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN - IF( F*SCALE( I ).LE.SFMIN1 ) - $ GO TO 200 - END IF - IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN - IF( SCALE( I ).GE.SFMAX1 / F ) - $ GO TO 200 - END IF - G = ONE / F - SCALE( I ) = SCALE( I )*F - NOCONV = .TRUE. -* - CALL ZDSCAL( N-K+1, G, A( I, K ), LDA ) - CALL ZDSCAL( L, F, A( 1, I ), 1 ) -* - 200 CONTINUE -* - IF( NOCONV ) - $ GO TO 140 -* - 210 CONTINUE - ILO = K - IHI = L -* - RETURN -* -* End of ZGEBAL -* - END - - SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER IHI, ILO, INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by -* an unitary similarity transformation: Q' * A * Q = H . -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* It is assumed that A is already upper triangular in rows -* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally -* set by a previous call to ZGEBAL; otherwise they should be -* set to 1 and N respectively. See Further Details. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the N-by-N general matrix to be reduced. -* On exit, the upper triangle and the first subdiagonal of A -* are overwritten with the upper Hessenberg matrix H, and the -* elements below the first subdiagonal, with the array TAU, -* represent the unitary matrix Q as a product of elementary -* reflectors. See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* TAU (output) COMPLEX*16 array, dimension (N-1) -* The scalar factors of the elementary reflectors (see Further -* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to -* zero. -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The length of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is the -* optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of (ihi-ilo) elementary -* reflectors -* -* Q = H(ilo) H(ilo+1) . . . H(ihi-1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a complex scalar, and v is a complex vector with -* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on -* exit in A(i+2:ihi,i), and tau in TAU(i). -* -* The contents of A are illustrated by the following example, with -* n = 7, ilo = 2 and ihi = 6: -* -* on entry, on exit, -* -* ( a a a a a a a ) ( a a h h h h a ) -* ( a a a a a a ) ( a h h h h a ) -* ( a a a a a a ) ( h h h h h h ) -* ( a a a a a a ) ( v2 h h h h h ) -* ( a a a a a a ) ( v2 v3 h h h h ) -* ( a a a a a a ) ( v2 v3 v4 h h h ) -* ( a ) ( a ) -* -* where a denotes an element of the original matrix A, h denotes a -* modified element of the upper Hessenberg matrix H, and vi denotes an -* element of the vector defining H(i). -* -* This file is a slight modification of LAPACK-3.0's ZGEHRD -* subroutine incorporating improvements proposed by Quintana-Orti and -* Van de Geijn (2005). -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB, - $ NBMIN, NH, NX - COMPLEX*16 EI -* .. -* .. Local Arrays .. - COMPLEX*16 T( LDT, NBMAX ) -* .. -* .. External Subroutines .. - EXTERNAL ZAXPY, ZGEHD2, ZGEMM, ZLAHR2, ZLARFB, ZTRMM, - $ XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -2 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGEHRD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero -* - DO 10 I = 1, ILO - 1 - TAU( I ) = ZERO - 10 CONTINUE - DO 20 I = MAX( 1, IHI ), N - 1 - TAU( I ) = ZERO - 20 CONTINUE -* -* Quick return if possible -* - NH = IHI - ILO + 1 - IF( NH.LE.1 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Determine the block size -* - NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) - NBMIN = 2 - IWS = 1 - IF( NB.GT.1 .AND. NB.LT.NH ) THEN -* -* Determine when to cross over from blocked to unblocked code -* (last block is always handled by unblocked code) -* - NX = MAX( NB, ILAENV( 3, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) - IF( NX.LT.NH ) THEN -* -* Determine if workspace is large enough for blocked code -* - IWS = N*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: determine the -* minimum value of NB, and reduce NB or force use of -* unblocked code -* - NBMIN = MAX( 2, ILAENV( 2, 'ZGEHRD', ' ', N, ILO, IHI, - $ -1 ) ) - IF( LWORK.GE.N*NBMIN ) THEN - NB = LWORK / N - ELSE - NB = 1 - END IF - END IF - END IF - END IF - LDWORK = N -* - IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN -* -* Use unblocked code below -* - I = ILO -* - ELSE -* -* Use blocked code -* - DO 40 I = ILO, IHI - 1 - NX, NB - IB = MIN( NB, IHI-I ) -* -* Reduce columns i:i+ib-1 to Hessenberg form, returning the -* matrices V and T of the block reflector H = I - V*T*V' -* which performs the reduction, and also the matrix Y = A*V*T -* - CALL ZLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, - $ WORK, LDWORK ) -* -* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the -* right, computing A := A - Y * V'. V(i+ib,ib-1) must be set -* to 1 -* - EI = A( I+IB, I+IB-1 ) - A( I+IB, I+IB-1 ) = ONE - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ IHI, IHI-I-IB+1, - $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, - $ A( 1, I+IB ), LDA ) - A( I+IB, I+IB-1 ) = EI -* -* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the -* right -* - CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', I, IB-1, - $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) - DO 30 J = 0, IB-2 - CALL ZAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, - $ A( 1, I+J+1 ), 1 ) - 30 CONTINUE -* -* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the -* left -* - CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward', - $ 'Columnwise', - $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT, - $ A( I+1, I+IB ), LDA, WORK, LDWORK ) - 40 CONTINUE - END IF -* -* Use unblocked code to reduce the rest of the matrix -* - CALL ZGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) - WORK( 1 ) = IWS -* - RETURN -* -* End of ZGEHRD -* - END - - SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, - $ WORK, LWORK, INFO ) -* -* -- LAPACK driver routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N - CHARACTER COMPZ, JOB -* .. -* .. Array Arguments .. - COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) -* .. -* Purpose -* ======= -* -* ZHSEQR computes the eigenvalues of a Hessenberg matrix H -* and, optionally, the matrices T and Z from the Schur decomposition -* H = Z T Z**H, where T is an upper triangular matrix (the -* Schur form), and Z is the unitary matrix of Schur vectors. -* -* Optionally Z may be postmultiplied into an input unitary -* matrix Q so that this routine can give the Schur factorization -* of a matrix A which has been reduced to the Hessenberg form H -* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. -* -* Arguments -* ========= -* -* JOB (input) CHARACTER*1 -* = 'E': compute eigenvalues only; -* = 'S': compute eigenvalues and the Schur form T. -* -* COMPZ (input) CHARACTER*1 -* = 'N': no Schur vectors are computed; -* = 'I': Z is initialized to the unit matrix and the matrix Z -* of Schur vectors of H is returned; -* = 'V': Z must contain an unitary matrix Q on entry, and -* the product Q*Z is returned. -* -* N (input) INTEGER -* The order of the matrix H. N .GE. 0. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* It is assumed that H is already upper triangular in rows -* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally -* set by a previous call to ZGEBAL, and then passed to ZGEHRD -* when the matrix output by ZGEBAL is reduced to Hessenberg -* form. Otherwise ILO and IHI should be set to 1 and N -* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. -* If N = 0, then ILO = 1 and IHI = 0. -* -* H (input/output) COMPLEX*16 array, dimension (LDH,N) -* On entry, the upper Hessenberg matrix H. -* On exit, if INFO = 0 and JOB = 'S', H contains the upper -* triangular matrix T from the Schur decomposition (the -* Schur form). If INFO = 0 and JOB = 'E', the contents of -* H are unspecified on exit. (The output value of H when -* INFO.GT.0 is given under the description of INFO below.) -* -* Unlike earlier versions of ZHSEQR, this subroutine may -* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 -* or j = IHI+1, IHI+2, ... N. -* -* LDH (input) INTEGER -* The leading dimension of the array H. LDH .GE. max(1,N). -* -* W (output) COMPLEX*16 array, dimension (N) -* The computed eigenvalues. If JOB = 'S', the eigenvalues are -* stored in the same order as on the diagonal of the Schur -* form returned in H, with W(i) = H(i,i). -* -* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) -* If COMPZ = 'N', Z is not referenced. -* If COMPZ = 'I', on entry Z need not be set and on exit, -* if INFO = 0, Z contains the unitary matrix Z of the Schur -* vectors of H. If COMPZ = 'V', on entry Z must contain an -* N-by-N matrix Q, which is assumed to be equal to the unit -* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, -* if INFO = 0, Z contains Q*Z. -* Normally Q is the unitary matrix generated by ZUNGHR -* after the call to ZGEHRD which formed the Hessenberg matrix -* H. (The output value of Z when INFO.GT.0 is given under -* the description of INFO below.) -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. if COMPZ = 'I' or -* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. -* -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns an estimate of -* the optimal value for LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK .GE. max(1,N) -* is sufficient, but LWORK typically as large as 6*N may -* be required for optimal performance. A workspace query -* to determine the optimal workspace size is recommended. -* -* If LWORK = -1, then ZHSEQR does a workspace query. -* In this case, ZHSEQR checks the input parameters and -* estimates the optimal workspace size for the given -* values of N, ILO and IHI. The estimate is returned -* in WORK(1). No error message related to LWORK is -* issued by XERBLA. Neither H nor Z are accessed. -* -* -* INFO (output) INTEGER -* = 0: successful exit -* .LT. 0: if INFO = -i, the i-th argument had an illegal -* value -* .GT. 0: if INFO = i, ZHSEQR failed to compute all of -* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR -* and WI contain those eigenvalues which have been -* successfully computed. (Failures are rare.) -* -* If INFO .GT. 0 and JOB = 'E', then on exit, the -* remaining unconverged eigenvalues are the eigen- -* values of the upper Hessenberg matrix rows and -* columns ILO through INFO of the final, output -* value of H. -* -* If INFO .GT. 0 and JOB = 'S', then on exit -* -* (*) (initial value of H)*U = U*(final value of H) -* -* where U is a unitary matrix. The final -* value of H is upper Hessenberg and triangular in -* rows and columns INFO+1 through IHI. -* -* If INFO .GT. 0 and COMPZ = 'V', then on exit -* -* (final value of Z) = (initial value of Z)*U -* -* where U is the unitary matrix in (*) (regard- -* less of the value of JOB.) -* -* If INFO .GT. 0 and COMPZ = 'I', then on exit -* (final value of Z) = U -* where U is the unitary matrix in (*) (regard- -* less of the value of JOB.) -* -* If INFO .GT. 0 and COMPZ = 'N', then Z is not -* accessed. -* -* ================================================================ -* Default values supplied by -* ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). -* It is suggested that these defaults be adjusted in order -* to attain best performance in each particular -* computational environment. -* -* ISPEC=1: The ZLAHQR vs ZLAQR0 crossover point. -* Default: 75. (Must be at least 11.) -* -* ISPEC=2: Recommended deflation window size. -* This depends on ILO, IHI and NS. NS is the -* number of simultaneous shifts returned -* by ILAENV(ISPEC=4). (See ISPEC=4 below.) -* The default for (IHI-ILO+1).LE.500 is NS. -* The default for (IHI-ILO+1).GT.500 is 3*NS/2. -* -* ISPEC=3: Nibble crossover point. (See ILAENV for -* details.) Default: 14% of deflation window -* size. -* -* ISPEC=4: Number of simultaneous shifts, NS, in -* a multi-shift QR iteration. -* -* If IHI-ILO+1 is ... -* -* greater than ...but less ... the -* or equal to ... than default is -* -* 1 30 NS - 2(+) -* 30 60 NS - 4(+) -* 60 150 NS = 10(+) -* 150 590 NS = ** -* 590 3000 NS = 64 -* 3000 6000 NS = 128 -* 6000 infinity NS = 256 -* -* (+) By default some or all matrices of this order -* are passed to the implicit double shift routine -* ZLAHQR and NS is ignored. See ISPEC=1 above -* and comments in IPARM for details. -* -* The asterisks (**) indicate an ad-hoc -* function of N increasing from 10 to 64. -* -* ISPEC=5: Select structured matrix multiply. -* (See ILAENV for details.) Default: 3. -* -* ================================================================ -* Based on contributions by -* Karen Braman and Ralph Byers, Department of Mathematics, -* University of Kansas, USA -* -* ================================================================ -* References: -* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR -* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 -* Performance, SIAM Journal of Matrix Analysis, volume 23, pages -* 929--947, 2002. -* -* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR -* Algorithm Part II: Aggressive Early Deflation, SIAM Journal -* of Matrix Analysis, volume 23, pages 948--973, 2002. -* -* ================================================================ -* .. Parameters .. -* -* ==== Matrices of order NTINY or smaller must be processed by -* . ZLAHQR because of insufficient subdiagonal scratch space. -* . (This is a hard limit.) ==== -* -* ==== NL allocates some local workspace to help small matrices -* . through a rare ZLAHQR failure. NL .GT. NTINY = 11 is -* . required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom- -* . mended. (The default value of NMIN is 75.) Using NL = 49 -* . allows up to six simultaneous shifts and a 16-by-16 -* . deflation window. ==== -* - INTEGER NTINY - PARAMETER ( NTINY = 11 ) - INTEGER NL - PARAMETER ( NL = 49 ) - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), - $ ONE = ( 1.0d0, 0.0d0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0d0 ) -* .. -* .. Local Arrays .. - COMPLEX*16 HL( NL, NL ), WORKL( NL ) -* .. -* .. Local Scalars .. - INTEGER KBOT, NMIN - LOGICAL INITZ, LQUERY, WANTT, WANTZ -* .. -* .. External Functions .. - INTEGER ILAENV - LOGICAL LSAME - EXTERNAL ILAENV, LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZCOPY, ZLACPY, ZLAHQR, ZLAQR0, ZLASET -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, MAX, MIN -* .. -* .. Executable Statements .. -* -* ==== Decode and check the input parameters. ==== -* - WANTT = LSAME( JOB, 'S' ) - INITZ = LSAME( COMPZ, 'I' ) - WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) - WORK( 1 ) = DCMPLX( DBLE( MAX( 1, N ) ), RZERO ) - LQUERY = LWORK.EQ.-1 -* - INFO = 0 - IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN - INFO = -1 - ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -5 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.NE.0 ) THEN -* -* ==== Quick return in case of invalid argument. ==== -* - CALL XERBLA( 'ZHSEQR', -INFO ) - RETURN -* - ELSE IF( N.EQ.0 ) THEN -* -* ==== Quick return in case N = 0; nothing to do. ==== -* - RETURN -* - ELSE IF( LQUERY ) THEN -* -* ==== Quick return in case of a workspace query ==== -* - CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z, - $ LDZ, WORK, LWORK, INFO ) -* ==== Ensure reported workspace size is backward-compatible with -* . previous LAPACK versions. ==== - WORK( 1 ) = DCMPLX( MAX( DBLE( WORK( 1 ) ), DBLE( MAX( 1, - $ N ) ) ), RZERO ) - RETURN -* - ELSE -* -* ==== copy eigenvalues isolated by ZGEBAL ==== -* - IF( ILO.GT.1 ) - $ CALL ZCOPY( ILO-1, H, LDH+1, W, 1 ) - IF( IHI.LT.N ) - $ CALL ZCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 ) -* -* ==== Initialize Z, if requested ==== -* - IF( INITZ ) - $ CALL ZLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) -* -* ==== Quick return if possible ==== -* - IF( ILO.EQ.IHI ) THEN - W( ILO ) = H( ILO, ILO ) - RETURN - END IF -* -* ==== ZLAHQR/ZLAQR0 crossover point ==== -* - NMIN = ILAENV( 1, 'ZHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, ILO, - $ IHI, LWORK ) - NMIN = MAX( NTINY, NMIN ) -* -* ==== ZLAQR0 for big matrices; ZLAHQR for small ones ==== -* - IF( N.GT.NMIN ) THEN - CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, - $ Z, LDZ, WORK, LWORK, INFO ) - ELSE -* -* ==== Small matrix ==== -* - CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, - $ Z, LDZ, INFO ) -* - IF( INFO.GT.0 ) THEN -* -* ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds -* . when ZLAHQR fails. ==== -* - KBOT = INFO -* - IF( N.GE.NL ) THEN -* -* ==== Larger matrices have enough subdiagonal scratch -* . space to call ZLAQR0 directly. ==== -* - CALL ZLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, W, - $ ILO, IHI, Z, LDZ, WORK, LWORK, INFO ) -* - ELSE -* -* ==== Tiny matrices don't have enough subdiagonal -* . scratch space to benefit from ZLAQR0. Hence, -* . tiny matrices must be copied into a larger -* . array before calling ZLAQR0. ==== -* - CALL ZLACPY( 'A', N, N, H, LDH, HL, NL ) - HL( N+1, N ) = ZERO - CALL ZLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), - $ NL ) - CALL ZLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W, - $ ILO, IHI, Z, LDZ, WORKL, NL, INFO ) - IF( WANTT .OR. INFO.NE.0 ) - $ CALL ZLACPY( 'A', N, N, HL, NL, H, LDH ) - END IF - END IF - END IF -* -* ==== Clear out the trash, if necessary. ==== -* - IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) - $ CALL ZLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) -* -* ==== Ensure reported workspace size is backward-compatible with -* . previous LAPACK versions. ==== -* - WORK( 1 ) = DCMPLX( MAX( DBLE( MAX( 1, N ) ), - $ DBLE( WORK( 1 ) ) ), RZERO ) - END IF -* -* ==== End of ZHSEQR ==== -* - END - - SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, - $ SEP, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. -* -* .. Scalar Arguments .. - CHARACTER COMPQ, JOB - INTEGER INFO, LDQ, LDT, LWORK, M, N - DOUBLE PRECISION S, SEP -* .. -* .. Array Arguments .. - LOGICAL SELECT( * ) - COMPLEX*16 Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZTRSEN reorders the Schur factorization of a complex matrix -* A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in -* the leading positions on the diagonal of the upper triangular matrix -* T, and the leading columns of Q form an orthonormal basis of the -* corresponding right invariant subspace. -* -* Optionally the routine computes the reciprocal condition numbers of -* the cluster of eigenvalues and/or the invariant subspace. -* -* Arguments -* ========= -* -* JOB (input) CHARACTER*1 -* Specifies whether condition numbers are required for the -* cluster of eigenvalues (S) or the invariant subspace (SEP): -* = 'N': none; -* = 'E': for eigenvalues only (S); -* = 'V': for invariant subspace only (SEP); -* = 'B': for both eigenvalues and invariant subspace (S and -* SEP). -* -* COMPQ (input) CHARACTER*1 -* = 'V': update the matrix Q of Schur vectors; -* = 'N': do not update Q. -* -* SELECT (input) LOGICAL array, dimension (N) -* SELECT specifies the eigenvalues in the selected cluster. To -* select the j-th eigenvalue, SELECT(j) must be set to .TRUE.. -* -* N (input) INTEGER -* The order of the matrix T. N >= 0. -* -* T (input/output) COMPLEX*16 array, dimension (LDT,N) -* On entry, the upper triangular matrix T. -* On exit, T is overwritten by the reordered matrix T, with the -* selected eigenvalues as the leading diagonal elements. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= max(1,N). -* -* Q (input/output) COMPLEX*16 array, dimension (LDQ,N) -* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. -* On exit, if COMPQ = 'V', Q has been postmultiplied by the -* unitary transformation matrix which reorders T; the leading M -* columns of Q form an orthonormal basis for the specified -* invariant subspace. -* If COMPQ = 'N', Q is not referenced. -* -* LDQ (input) INTEGER -* The leading dimension of the array Q. -* LDQ >= 1; and if COMPQ = 'V', LDQ >= N. -* -* W (output) COMPLEX*16 array, dimension (N) -* The reordered eigenvalues of T, in the same order as they -* appear on the diagonal of T. -* -* M (output) INTEGER -* The dimension of the specified invariant subspace. -* 0 <= M <= N. -* -* S (output) DOUBLE PRECISION -* If JOB = 'E' or 'B', S is a lower bound on the reciprocal -* condition number for the selected cluster of eigenvalues. -* S cannot underestimate the true reciprocal condition number -* by more than a factor of sqrt(N). If M = 0 or N, S = 1. -* If JOB = 'N' or 'V', S is not referenced. -* -* SEP (output) DOUBLE PRECISION -* If JOB = 'V' or 'B', SEP is the estimated reciprocal -* condition number of the specified invariant subspace. If -* M = 0 or N, SEP = norm(T). -* If JOB = 'N' or 'E', SEP is not referenced. -* -* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If JOB = 'N', LWORK >= 1; -* if JOB = 'E', LWORK = max(1,M*(N-M)); -* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* ZTRSEN first collects the selected eigenvalues by computing a unitary -* transformation Z to move them to the top left corner of T. In other -* words, the selected eigenvalues are the eigenvalues of T11 in: -* -* Z'*T*Z = ( T11 T12 ) n1 -* ( 0 T22 ) n2 -* n1 n2 -* -* where N = n1+n2 and Z' means the conjugate transpose of Z. The first -* n1 columns of Z span the specified invariant subspace of T. -* -* If T has been obtained from the Schur factorization of a matrix -* A = Q*T*Q', then the reordered Schur factorization of A is given by -* A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the -* corresponding invariant subspace of A. -* -* The reciprocal condition number of the average of the eigenvalues of -* T11 may be returned in S. S lies between 0 (very badly conditioned) -* and 1 (very well conditioned). It is computed as follows. First we -* compute R so that -* -* P = ( I R ) n1 -* ( 0 0 ) n2 -* n1 n2 -* -* is the projector on the invariant subspace associated with T11. -* R is the solution of the Sylvester equation: -* -* T11*R - R*T22 = T12. -* -* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote -* the two-norm of M. Then S is computed as the lower bound -* -* (1 + F-norm(R)**2)**(-1/2) -* -* on the reciprocal of 2-norm(P), the true reciprocal condition number. -* S cannot underestimate 1 / 2-norm(P) by more than a factor of -* sqrt(N). -* -* An approximate error bound for the computed average of the -* eigenvalues of T11 is -* -* EPS * norm(T) / S -* -* where EPS is the machine precision. -* -* The reciprocal condition number of the right invariant subspace -* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. -* SEP is defined as the separation of T11 and T22: -* -* sep( T11, T22 ) = sigma-min( C ) -* -* where sigma-min(C) is the smallest singular value of the -* n1*n2-by-n1*n2 matrix -* -* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) -* -* I(m) is an m by m identity matrix, and kprod denotes the Kronecker -* product. We estimate sigma-min(C) by the reciprocal of an estimate of -* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) -* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). -* -* When SEP is small, small changes in T can cause large changes in -* the invariant subspace. An approximate bound on the maximum angular -* error in the computed right invariant subspace is -* -* EPS * norm(T) / SEP -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, WANTBH, WANTQ, WANTS, WANTSP - INTEGER IERR, K, KASE, KS, LWMIN, N1, N2, NN - DOUBLE PRECISION EST, RNORM, SCALE -* .. -* .. Local Arrays .. - INTEGER ISAVE( 3 ) - DOUBLE PRECISION RWORK( 1 ) -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION ZLANGE - EXTERNAL LSAME, ZLANGE -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLACN2, ZLACPY, ZTREXC, ZTRSYL -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Decode and test the input parameters. -* - WANTBH = LSAME( JOB, 'B' ) - WANTS = LSAME( JOB, 'E' ) .OR. WANTBH - WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH - WANTQ = LSAME( COMPQ, 'V' ) -* -* Set M to the number of selected eigenvalues. -* - M = 0 - DO 10 K = 1, N - IF( SELECT( K ) ) - $ M = M + 1 - 10 CONTINUE -* - N1 = M - N2 = N - M - NN = N1*N2 -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) -* - IF( WANTSP ) THEN - LWMIN = MAX( 1, 2*NN ) - ELSE IF( LSAME( JOB, 'N' ) ) THEN - LWMIN = 1 - ELSE IF( LSAME( JOB, 'E' ) ) THEN - LWMIN = MAX( 1, NN ) - END IF -* - IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) - $ THEN - INFO = -1 - ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN - INFO = -8 - ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN - INFO = -14 - END IF -* - IF( INFO.EQ.0 ) THEN - WORK( 1 ) = LWMIN - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZTRSEN', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.N .OR. M.EQ.0 ) THEN - IF( WANTS ) - $ S = ONE - IF( WANTSP ) - $ SEP = ZLANGE( '1', N, N, T, LDT, RWORK ) - GO TO 40 - END IF -* -* Collect the selected eigenvalues at the top left corner of T. -* - KS = 0 - DO 20 K = 1, N - IF( SELECT( K ) ) THEN - KS = KS + 1 -* -* Swap the K-th eigenvalue to position KS. -* - IF( K.NE.KS ) - $ CALL ZTREXC( COMPQ, N, T, LDT, Q, LDQ, K, KS, IERR ) - END IF - 20 CONTINUE -* - IF( WANTS ) THEN -* -* Solve the Sylvester equation for R: -* -* T11*R - R*T22 = scale*T12 -* - CALL ZLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 ) - CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ), - $ LDT, WORK, N1, SCALE, IERR ) -* -* Estimate the reciprocal of the condition number of the cluster -* of eigenvalues. -* - RNORM = ZLANGE( 'F', N1, N2, WORK, N1, RWORK ) - IF( RNORM.EQ.ZERO ) THEN - S = ONE - ELSE - S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )* - $ SQRT( RNORM ) ) - END IF - END IF -* - IF( WANTSP ) THEN -* -* Estimate sep(T11,T22). -* - EST = ZERO - KASE = 0 - 30 CONTINUE - CALL ZLACN2( NN, WORK( NN+1 ), WORK, EST, KASE, ISAVE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.1 ) THEN -* -* Solve T11*R - R*T22 = scale*X. -* - CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT, - $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, - $ IERR ) - ELSE -* -* Solve T11'*R - R*T22' = scale*X. -* - CALL ZTRSYL( 'C', 'C', -1, N1, N2, T, LDT, - $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, - $ IERR ) - END IF - GO TO 30 - END IF -* - SEP = SCALE / EST - END IF -* - 40 CONTINUE -* -* Copy reordered eigenvalues to W. -* - DO 50 K = 1, N - W( K ) = T( K, K ) - 50 CONTINUE -* - WORK( 1 ) = LWMIN -* - RETURN -* -* End of ZTRSEN -* - END - - SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, - $ INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER JOB, SIDE - INTEGER IHI, ILO, INFO, LDV, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION SCALE( * ) - COMPLEX*16 V( LDV, * ) -* .. -* -* Purpose -* ======= -* -* ZGEBAK forms the right or left eigenvectors of a complex general -* matrix by backward transformation on the computed eigenvectors of the -* balanced matrix output by ZGEBAL. -* -* Arguments -* ========= -* -* JOB (input) CHARACTER*1 -* Specifies the type of backward transformation required: -* = 'N', do nothing, return immediately; -* = 'P', do backward transformation for permutation only; -* = 'S', do backward transformation for scaling only; -* = 'B', do backward transformations for both permutation and -* scaling. -* JOB must be the same as the argument JOB supplied to ZGEBAL. -* -* SIDE (input) CHARACTER*1 -* = 'R': V contains right eigenvectors; -* = 'L': V contains left eigenvectors. -* -* N (input) INTEGER -* The number of rows of the matrix V. N >= 0. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* The integers ILO and IHI determined by ZGEBAL. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -* -* SCALE (input) DOUBLE PRECISION array, dimension (N) -* Details of the permutation and scaling factors, as returned -* by ZGEBAL. -* -* M (input) INTEGER -* The number of columns of the matrix V. M >= 0. -* -* V (input/output) COMPLEX*16 array, dimension (LDV,M) -* On entry, the matrix of right or left eigenvectors to be -* transformed, as returned by ZHSEIN or ZTREVC. -* On exit, V is overwritten by the transformed eigenvectors. -* -* LDV (input) INTEGER -* The leading dimension of the array V. LDV >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFTV, RIGHTV - INTEGER I, II, K - DOUBLE PRECISION S -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL, ZSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Decode and Test the input parameters -* - RIGHTV = LSAME( SIDE, 'R' ) - LEFTV = LSAME( SIDE, 'L' ) -* - INFO = 0 - IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. - $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN - INFO = -1 - ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -7 - ELSE IF( LDV.LT.MAX( 1, N ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGEBAK', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN - IF( M.EQ.0 ) - $ RETURN - IF( LSAME( JOB, 'N' ) ) - $ RETURN -* - IF( ILO.EQ.IHI ) - $ GO TO 30 -* -* Backward balance -* - IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN -* - IF( RIGHTV ) THEN - DO 10 I = ILO, IHI - S = SCALE( I ) - CALL ZDSCAL( M, S, V( I, 1 ), LDV ) - 10 CONTINUE - END IF -* - IF( LEFTV ) THEN - DO 20 I = ILO, IHI - S = ONE / SCALE( I ) - CALL ZDSCAL( M, S, V( I, 1 ), LDV ) - 20 CONTINUE - END IF -* - END IF -* -* Backward permutation -* -* For I = ILO-1 step -1 until 1, -* IHI+1 step 1 until N do -- -* - 30 CONTINUE - IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN - IF( RIGHTV ) THEN - DO 40 II = 1, N - I = II - IF( I.GE.ILO .AND. I.LE.IHI ) - $ GO TO 40 - IF( I.LT.ILO ) - $ I = ILO - II - K = SCALE( I ) - IF( K.EQ.I ) - $ GO TO 40 - CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) - 40 CONTINUE - END IF -* - IF( LEFTV ) THEN - DO 50 II = 1, N - I = II - IF( I.GE.ILO .AND. I.LE.IHI ) - $ GO TO 50 - IF( I.LT.ILO ) - $ I = ILO - II - K = SCALE( I ) - IF( K.EQ.I ) - $ GO TO 50 - CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) - 50 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZGEBAK -* - END - - SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER IHI, ILO, INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUNGHR generates a complex unitary matrix Q which is defined as the -* product of IHI-ILO elementary reflectors of order N, as returned by -* ZGEHRD: -* -* Q = H(ilo) H(ilo+1) . . . H(ihi-1). -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix Q. N >= 0. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* ILO and IHI must have the same values as in the previous call -* of ZGEHRD. Q is equal to the unit matrix except in the -* submatrix Q(ilo+1:ihi,ilo+1:ihi). -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the vectors which define the elementary reflectors, -* as returned by ZGEHRD. -* On exit, the N-by-N unitary matrix Q. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* TAU (input) COMPLEX*16 array, dimension (N-1) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZGEHRD. -* -* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= IHI-ILO. -* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is -* the optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IINFO, J, LWKOPT, NB, NH -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZUNGQR -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NH = IHI - ILO - LQUERY = ( LWORK.EQ.-1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -2 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF -* - IF( INFO.EQ.0 ) THEN - NB = ILAENV( 1, 'ZUNGQR', ' ', NH, NH, NH, -1 ) - LWKOPT = MAX( 1, NH )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNGHR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Shift the vectors which define the elementary reflectors one -* column to the right, and set the first ilo and the last n-ihi -* rows and columns to those of the unit matrix -* - DO 40 J = IHI, ILO + 1, -1 - DO 10 I = 1, J - 1 - A( I, J ) = ZERO - 10 CONTINUE - DO 20 I = J + 1, IHI - A( I, J ) = A( I, J-1 ) - 20 CONTINUE - DO 30 I = IHI + 1, N - A( I, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - DO 60 J = 1, ILO - DO 50 I = 1, N - A( I, J ) = ZERO - 50 CONTINUE - A( J, J ) = ONE - 60 CONTINUE - DO 80 J = IHI + 1, N - DO 70 I = 1, N - A( I, J ) = ZERO - 70 CONTINUE - A( J, J ) = ONE - 80 CONTINUE -* - IF( NH.GT.0 ) THEN -* -* Generate Q(ilo+1:ihi,ilo+1:ihi) -* - CALL ZUNGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), - $ WORK, LWORK, IINFO ) - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNGHR -* - END - - SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, - $ IHIZ, Z, LDZ, INFO ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N - LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. - COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* ZLAHQR is an auxiliary routine called by CHSEQR to update the -* eigenvalues and Schur decomposition already computed by CHSEQR, by -* dealing with the Hessenberg submatrix in rows and columns ILO to -* IHI. -* -* Arguments -* ========= -* -* WANTT (input) LOGICAL -* = .TRUE. : the full Schur form T is required; -* = .FALSE.: only eigenvalues are required. -* -* WANTZ (input) LOGICAL -* = .TRUE. : the matrix of Schur vectors Z is required; -* = .FALSE.: Schur vectors are not required. -* -* N (input) INTEGER -* The order of the matrix H. N >= 0. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* It is assumed that H is already upper triangular in rows and -* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). -* ZLAHQR works primarily with the Hessenberg submatrix in rows -* and columns ILO to IHI, but applies transformations to all of -* H if WANTT is .TRUE.. -* 1 <= ILO <= max(1,IHI); IHI <= N. -* -* H (input/output) COMPLEX*16 array, dimension (LDH,N) -* On entry, the upper Hessenberg matrix H. -* On exit, if INFO is zero and if WANTT is .TRUE., then H -* is upper triangular in rows and columns ILO:IHI. If INFO -* is zero and if WANTT is .FALSE., then the contents of H -* are unspecified on exit. The output state of H in case -* INF is positive is below under the description of INFO. -* -* LDH (input) INTEGER -* The leading dimension of the array H. LDH >= max(1,N). -* -* W (output) COMPLEX*16 array, dimension (N) -* The computed eigenvalues ILO to IHI are stored in the -* corresponding elements of W. If WANTT is .TRUE., the -* eigenvalues are stored in the same order as on the diagonal -* of the Schur form returned in H, with W(i) = H(i,i). -* -* ILOZ (input) INTEGER -* IHIZ (input) INTEGER -* Specify the rows of Z to which transformations must be -* applied if WANTZ is .TRUE.. -* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. -* -* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) -* If WANTZ is .TRUE., on entry Z must contain the current -* matrix Z of transformations accumulated by CHSEQR, and on -* exit Z has been updated; transformations are applied only to -* the submatrix Z(ILOZ:IHIZ,ILO:IHI). -* If WANTZ is .FALSE., Z is not referenced. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* .GT. 0: if INFO = i, ZLAHQR failed to compute all the -* eigenvalues ILO to IHI in a total of 30 iterations -* per eigenvalue; elements i+1:ihi of W contain -* those eigenvalues which have been successfully -* computed. -* -* If INFO .GT. 0 and WANTT is .FALSE., then on exit, -* the remaining unconverged eigenvalues are the -* eigenvalues of the upper Hessenberg matrix -* rows and columns ILO thorugh INFO of the final, -* output value of H. -* -* If INFO .GT. 0 and WANTT is .TRUE., then on exit -* (*) (initial value of H)*U = U*(final value of H) -* where U is an orthognal matrix. The final -* value of H is upper Hessenberg and triangular in -* rows and columns INFO+1 through IHI. -* -* If INFO .GT. 0 and WANTZ is .TRUE., then on exit -* (final value of Z) = (initial value of Z)*U -* where U is the orthogonal matrix in (*) -* (regardless of the value of WANTT.) -* -* Further Details -* =============== -* -* 02-96 Based on modifications by -* David Day, Sandia National Laboratory, USA -* -* 12-04 Further modifications by -* Ralph Byers, University of Kansas, USA -* -* This is a modified version of ZLAHQR from LAPACK version 3.0. -* It is (1) more robust against overflow and underflow and -* (2) adopts the more conservative Ahues & Tisseur stopping -* criterion (LAWN 122, 1997). -* -* ========================================================= -* -* .. Parameters .. - INTEGER ITMAX - PARAMETER ( ITMAX = 30 ) - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), - $ ONE = ( 1.0d0, 0.0d0 ) ) - DOUBLE PRECISION RZERO, RONE, HALF - PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0, HALF = 0.5d0 ) - DOUBLE PRECISION DAT1 - PARAMETER ( DAT1 = 3.0d0 / 4.0d0 ) -* .. -* .. Local Scalars .. - COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U, - $ V2, X, Y - DOUBLE PRECISION AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX, - $ SAFMIN, SMLNUM, SX, T2, TST, ULP - INTEGER I, I1, I2, ITS, J, JHI, JLO, K, L, M, NH, NZ -* .. -* .. Local Arrays .. - COMPLEX*16 V( 2 ) -* .. -* .. External Functions .. - COMPLEX*16 ZLADIV - DOUBLE PRECISION DLAMCH - EXTERNAL ZLADIV, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLABAD, ZCOPY, ZLARFG, ZSCAL -* .. -* .. Statement Functions .. - DOUBLE PRECISION CABS1 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT -* .. -* .. Statement Function definitions .. - CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) -* .. -* .. Executable Statements .. -* - INFO = 0 -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN - IF( ILO.EQ.IHI ) THEN - W( ILO ) = H( ILO, ILO ) - RETURN - END IF -* -* ==== clear out the trash ==== - DO 10 J = ILO, IHI - 3 - H( J+2, J ) = ZERO - H( J+3, J ) = ZERO - 10 CONTINUE - IF( ILO.LE.IHI-2 ) - $ H( IHI, IHI-2 ) = ZERO -* ==== ensure that subdiagonal entries are real ==== - DO 20 I = ILO + 1, IHI - IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN -* ==== The following redundant normalization -* . avoids problems with both gradual and -* . sudden underflow in ABS(H(I,I-1)) ==== - SC = H( I, I-1 ) / CABS1( H( I, I-1 ) ) - SC = DCONJG( SC ) / ABS( SC ) - H( I, I-1 ) = ABS( H( I, I-1 ) ) - IF( WANTT ) THEN - JLO = 1 - JHI = N - ELSE - JLO = ILO - JHI = IHI - END IF - CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH ) - CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ), - $ H( JLO, I ), 1 ) - IF( WANTZ ) - $ CALL ZSCAL( IHIZ-ILOZ+1, DCONJG( SC ), Z( ILOZ, I ), 1 ) - END IF - 20 CONTINUE -* - NH = IHI - ILO + 1 - NZ = IHIZ - ILOZ + 1 -* -* Set machine-dependent constants for the stopping criterion. -* - SAFMIN = DLAMCH( 'SAFE MINIMUM' ) - SAFMAX = RONE / SAFMIN - CALL DLABAD( SAFMIN, SAFMAX ) - ULP = DLAMCH( 'PRECISION' ) - SMLNUM = SAFMIN*( DBLE( NH ) / ULP ) -* -* I1 and I2 are the indices of the first row and last column of H -* to which transformations must be applied. If eigenvalues only are -* being computed, I1 and I2 are set inside the main loop. -* - IF( WANTT ) THEN - I1 = 1 - I2 = N - END IF -* -* The main loop begins here. I is the loop index and decreases from -* IHI to ILO in steps of 1. Each iteration of the loop works -* with the active submatrix in rows and columns L to I. -* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or -* H(L,L-1) is negligible so that the matrix splits. -* - I = IHI - 30 CONTINUE - IF( I.LT.ILO ) - $ GO TO 150 -* -* Perform QR iterations on rows and columns ILO to I until a -* submatrix of order 1 splits off at the bottom because a -* subdiagonal element has become negligible. -* - L = ILO - DO 130 ITS = 0, ITMAX -* -* Look for a single small subdiagonal element. -* - DO 40 K = I, L + 1, -1 - IF( CABS1( H( K, K-1 ) ).LE.SMLNUM ) - $ GO TO 50 - TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) - IF( TST.EQ.ZERO ) THEN - IF( K-2.GE.ILO ) - $ TST = TST + ABS( DBLE( H( K-1, K-2 ) ) ) - IF( K+1.LE.IHI ) - $ TST = TST + ABS( DBLE( H( K+1, K ) ) ) - END IF -* ==== The following is a conservative small subdiagonal -* . deflation criterion due to Ahues & Tisseur (LAWN 122, -* . 1997). It has better mathematical foundation and -* . improves accuracy in some examples. ==== - IF( ABS( DBLE( H( K, K-1 ) ) ).LE.ULP*TST ) THEN - AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) - BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) - AA = MAX( CABS1( H( K, K ) ), - $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) - BB = MIN( CABS1( H( K, K ) ), - $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) - S = AA + AB - IF( BA*( AB / S ).LE.MAX( SMLNUM, - $ ULP*( BB*( AA / S ) ) ) )GO TO 50 - END IF - 40 CONTINUE - 50 CONTINUE - L = K - IF( L.GT.ILO ) THEN -* -* H(L,L-1) is negligible -* - H( L, L-1 ) = ZERO - END IF -* -* Exit from loop if a submatrix of order 1 has split off. -* - IF( L.GE.I ) - $ GO TO 140 -* -* Now the active submatrix is in rows and columns L to I. If -* eigenvalues only are being computed, only the active submatrix -* need be transformed. -* - IF( .NOT.WANTT ) THEN - I1 = L - I2 = I - END IF -* - IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN -* -* Exceptional shift. -* - S = DAT1*ABS( DBLE( H( I, I-1 ) ) ) - T = S + H( I, I ) - ELSE -* -* Wilkinson's shift. -* - T = H( I, I ) - U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) ) - S = CABS1( U ) - IF( S.NE.RZERO ) THEN - X = HALF*( H( I-1, I-1 )-T ) - SX = CABS1( X ) - S = MAX( S, CABS1( X ) ) - Y = S*SQRT( ( X / S )**2+( U / S )**2 ) - IF( SX.GT.RZERO ) THEN - IF( DBLE( X / SX )*DBLE( Y )+DIMAG( X / SX )* - $ DIMAG( Y ).LT.RZERO )Y = -Y - END IF - T = T - U*ZLADIV( U, ( X+Y ) ) - END IF - END IF -* -* Look for two consecutive small subdiagonal elements. -* - DO 60 M = I - 1, L + 1, -1 -* -* Determine the effect of starting the single-shift QR -* iteration at row M, and see if this would make H(M,M-1) -* negligible. -* - H11 = H( M, M ) - H22 = H( M+1, M+1 ) - H11S = H11 - T - H21 = H( M+1, M ) - S = CABS1( H11S ) + ABS( H21 ) - H11S = H11S / S - H21 = H21 / S - V( 1 ) = H11S - V( 2 ) = H21 - H10 = H( M, M-1 ) - IF( ABS( H10 )*ABS( H21 ).LE.ULP* - $ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) ) - $ GO TO 70 - 60 CONTINUE - H11 = H( L, L ) - H22 = H( L+1, L+1 ) - H11S = H11 - T - H21 = H( L+1, L ) - S = CABS1( H11S ) + ABS( H21 ) - H11S = H11S / S - H21 = H21 / S - V( 1 ) = H11S - V( 2 ) = H21 - 70 CONTINUE -* -* Single-shift QR step -* - DO 120 K = M, I - 1 -* -* The first iteration of this loop determines a reflection G -* from the vector V and applies it from left and right to H, -* thus creating a nonzero bulge below the subdiagonal. -* -* Each subsequent iteration determines a reflection G to -* restore the Hessenberg form in the (K-1)th column, and thus -* chases the bulge one step toward the bottom of the active -* submatrix. -* -* V(2) is always real before the call to ZLARFG, and hence -* after the call T2 ( = T1*V(2) ) is also real. -* - IF( K.GT.M ) - $ CALL ZCOPY( 2, H( K, K-1 ), 1, V, 1 ) - CALL ZLARFG( 2, V( 1 ), V( 2 ), 1, T1 ) - IF( K.GT.M ) THEN - H( K, K-1 ) = V( 1 ) - H( K+1, K-1 ) = ZERO - END IF - V2 = V( 2 ) - T2 = DBLE( T1*V2 ) -* -* Apply G from the left to transform the rows of the matrix -* in columns K to I2. -* - DO 80 J = K, I2 - SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J ) - H( K, J ) = H( K, J ) - SUM - H( K+1, J ) = H( K+1, J ) - SUM*V2 - 80 CONTINUE -* -* Apply G from the right to transform the columns of the -* matrix in rows I1 to min(K+2,I). -* - DO 90 J = I1, MIN( K+2, I ) - SUM = T1*H( J, K ) + T2*H( J, K+1 ) - H( J, K ) = H( J, K ) - SUM - H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 ) - 90 CONTINUE -* - IF( WANTZ ) THEN -* -* Accumulate transformations in the matrix Z -* - DO 100 J = ILOZ, IHIZ - SUM = T1*Z( J, K ) + T2*Z( J, K+1 ) - Z( J, K ) = Z( J, K ) - SUM - Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 ) - 100 CONTINUE - END IF -* - IF( K.EQ.M .AND. M.GT.L ) THEN -* -* If the QR step was started at row M > L because two -* consecutive small subdiagonals were found, then extra -* scaling must be performed to ensure that H(M,M-1) remains -* real. -* - TEMP = ONE - T1 - TEMP = TEMP / ABS( TEMP ) - H( M+1, M ) = H( M+1, M )*DCONJG( TEMP ) - IF( M+2.LE.I ) - $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP - DO 110 J = M, I - IF( J.NE.M+1 ) THEN - IF( I2.GT.J ) - $ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH ) - CALL ZSCAL( J-I1, DCONJG( TEMP ), H( I1, J ), 1 ) - IF( WANTZ ) THEN - CALL ZSCAL( NZ, DCONJG( TEMP ), Z( ILOZ, J ), - $ 1 ) - END IF - END IF - 110 CONTINUE - END IF - 120 CONTINUE -* -* Ensure that H(I,I-1) is real. -* - TEMP = H( I, I-1 ) - IF( DIMAG( TEMP ).NE.RZERO ) THEN - RTEMP = ABS( TEMP ) - H( I, I-1 ) = RTEMP - TEMP = TEMP / RTEMP - IF( I2.GT.I ) - $ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH ) - CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 ) - IF( WANTZ ) THEN - CALL ZSCAL( NZ, TEMP, Z( ILOZ, I ), 1 ) - END IF - END IF -* - 130 CONTINUE -* -* Failure to converge in remaining number of iterations -* - INFO = I - RETURN -* - 140 CONTINUE -* -* H(I,I-1) is negligible: one eigenvalue has converged. -* - W( I ) = H( I, I ) -* -* return to start of the main loop with new value of I. -* - I = L - 1 - GO TO 30 -* - 150 CONTINUE - RETURN -* -* End of ZLAHQR -* - END - - SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, - $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N - LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. - COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* ZLAQR0 computes the eigenvalues of a Hessenberg matrix H -* and, optionally, the matrices T and Z from the Schur decomposition -* H = Z T Z**H, where T is an upper triangular matrix (the -* Schur form), and Z is the unitary matrix of Schur vectors. -* -* Optionally Z may be postmultiplied into an input unitary -* matrix Q so that this routine can give the Schur factorization -* of a matrix A which has been reduced to the Hessenberg form H -* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. -* -* Arguments -* ========= -* -* WANTT (input) LOGICAL -* = .TRUE. : the full Schur form T is required; -* = .FALSE.: only eigenvalues are required. -* -* WANTZ (input) LOGICAL -* = .TRUE. : the matrix of Schur vectors Z is required; -* = .FALSE.: Schur vectors are not required. -* -* N (input) INTEGER -* The order of the matrix H. N .GE. 0. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* It is assumed that H is already upper triangular in rows -* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, -* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a -* previous call to ZGEBAL, and then passed to ZGEHRD when the -* matrix output by ZGEBAL is reduced to Hessenberg form. -* Otherwise, ILO and IHI should be set to 1 and N, -* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. -* If N = 0, then ILO = 1 and IHI = 0. -* -* H (input/output) COMPLEX*16 array, dimension (LDH,N) -* On entry, the upper Hessenberg matrix H. -* On exit, if INFO = 0 and WANTT is .TRUE., then H -* contains the upper triangular matrix T from the Schur -* decomposition (the Schur form). If INFO = 0 and WANT is -* .FALSE., then the contents of H are unspecified on exit. -* (The output value of H when INFO.GT.0 is given under the -* description of INFO below.) -* -* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and -* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. -* -* LDH (input) INTEGER -* The leading dimension of the array H. LDH .GE. max(1,N). -* -* W (output) COMPLEX*16 array, dimension (N) -* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored -* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are -* stored in the same order as on the diagonal of the Schur -* form returned in H, with W(i) = H(i,i). -* -* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) -* If WANTZ is .FALSE., then Z is not referenced. -* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is -* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the -* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). -* (The output value of Z when INFO.GT.0 is given under -* the description of INFO below.) -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. if WANTZ is .TRUE. -* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. -* -* WORK (workspace/output) COMPLEX*16 array, dimension LWORK -* On exit, if LWORK = -1, WORK(1) returns an estimate of -* the optimal value for LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK .GE. max(1,N) -* is sufficient, but LWORK typically as large as 6*N may -* be required for optimal performance. A workspace query -* to determine the optimal workspace size is recommended. -* -* If LWORK = -1, then ZLAQR0 does a workspace query. -* In this case, ZLAQR0 checks the input parameters and -* estimates the optimal workspace size for the given -* values of N, ILO and IHI. The estimate is returned -* in WORK(1). No error message related to LWORK is -* issued by XERBLA. Neither H nor Z are accessed. -* -* -* INFO (output) INTEGER -* = 0: successful exit -* .GT. 0: if INFO = i, ZLAQR0 failed to compute all of -* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR -* and WI contain those eigenvalues which have been -* successfully computed. (Failures are rare.) -* -* If INFO .GT. 0 and WANT is .FALSE., then on exit, -* the remaining unconverged eigenvalues are the eigen- -* values of the upper Hessenberg matrix rows and -* columns ILO through INFO of the final, output -* value of H. -* -* If INFO .GT. 0 and WANTT is .TRUE., then on exit -* -* (*) (initial value of H)*U = U*(final value of H) -* -* where U is a unitary matrix. The final -* value of H is upper Hessenberg and triangular in -* rows and columns INFO+1 through IHI. -* -* If INFO .GT. 0 and WANTZ is .TRUE., then on exit -* -* (final value of Z(ILO:IHI,ILOZ:IHIZ) -* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U -* -* where U is the unitary matrix in (*) (regard- -* less of the value of WANTT.) -* -* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not -* accessed. -* -* ================================================================ -* Based on contributions by -* Karen Braman and Ralph Byers, Department of Mathematics, -* University of Kansas, USA -* -* ================================================================ -* References: -* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR -* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 -* Performance, SIAM Journal of Matrix Analysis, volume 23, pages -* 929--947, 2002. -* -* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR -* Algorithm Part II: Aggressive Early Deflation, SIAM Journal -* of Matrix Analysis, volume 23, pages 948--973, 2002. -* -* ================================================================ -* .. Parameters .. -* -* ==== Matrices of order NTINY or smaller must be processed by -* . ZLAHQR because of insufficient subdiagonal scratch space. -* . (This is a hard limit.) ==== -* -* ==== Exceptional deflation windows: try to cure rare -* . slow convergence by increasing the size of the -* . deflation window after KEXNW iterations. ===== -* -* ==== Exceptional shifts: try to cure rare slow convergence -* . with ad-hoc exceptional shifts every KEXSH iterations. -* . The constants WILK1 and WILK2 are used to form the -* . exceptional shifts. ==== -* - INTEGER NTINY - PARAMETER ( NTINY = 11 ) - INTEGER KEXNW, KEXSH - PARAMETER ( KEXNW = 5, KEXSH = 6 ) - DOUBLE PRECISION WILK1 - PARAMETER ( WILK1 = 0.75d0 ) - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), - $ ONE = ( 1.0d0, 0.0d0 ) ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0d0 ) -* .. -* .. Local Scalars .. - COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 - DOUBLE PRECISION S - INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, - $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, - $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, - $ NSR, NVE, NW, NWMAX, NWR - LOGICAL NWINC, SORTED - CHARACTER JBCMPZ*2 -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Local Arrays .. - COMPLEX*16 ZDUM( 1, 1 ) -* .. -* .. External Subroutines .. - EXTERNAL ZLACPY, ZLAHQR, ZLAQR3, ZLAQR4, ZLAQR5 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, - $ SQRT -* .. -* .. Statement Functions .. - DOUBLE PRECISION CABS1 -* .. -* .. Statement Function definitions .. - CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) -* .. -* .. Executable Statements .. - INFO = 0 -* -* ==== Quick return for N = 0: nothing to do. ==== -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = ONE - RETURN - END IF -* -* ==== Set up job flags for ILAENV. ==== -* - IF( WANTT ) THEN - JBCMPZ( 1: 1 ) = 'S' - ELSE - JBCMPZ( 1: 1 ) = 'E' - END IF - IF( WANTZ ) THEN - JBCMPZ( 2: 2 ) = 'V' - ELSE - JBCMPZ( 2: 2 ) = 'N' - END IF -* -* ==== Tiny matrices must use ZLAHQR. ==== -* - IF( N.LE.NTINY ) THEN -* -* ==== Estimate optimal workspace. ==== -* - LWKOPT = 1 - IF( LWORK.NE.-1 ) - $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, - $ IHIZ, Z, LDZ, INFO ) - ELSE -* -* ==== Use small bulge multi-shift QR with aggressive early -* . deflation on larger-than-tiny matrices. ==== -* -* ==== Hope for the best. ==== -* - INFO = 0 -* -* ==== NWR = recommended deflation window size. At this -* . point, N .GT. NTINY = 11, so there is enough -* . subdiagonal workspace for NWR.GE.2 as required. -* . (In fact, there is enough subdiagonal space for -* . NWR.GE.3.) ==== -* - NWR = ILAENV( 13, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) - NWR = MAX( 2, NWR ) - NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) - NW = NWR -* -* ==== NSR = recommended number of simultaneous shifts. -* . At this point N .GT. NTINY = 11, so there is at -* . enough subdiagonal workspace for NSR to be even -* . and greater than or equal to two as required. ==== -* - NSR = ILAENV( 15, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) - NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) - NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) -* -* ==== Estimate optimal workspace ==== -* -* ==== Workspace query call to ZLAQR3 ==== -* - CALL ZLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, - $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, - $ LDH, WORK, -1 ) -* -* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ==== -* - LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) -* -* ==== Quick return in case of workspace query. ==== -* - IF( LWORK.EQ.-1 ) THEN - WORK( 1 ) = DCMPLX( LWKOPT, 0 ) - RETURN - END IF -* -* ==== ZLAHQR/ZLAQR0 crossover point ==== -* - NMIN = ILAENV( 12, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) - NMIN = MAX( NTINY, NMIN ) -* -* ==== Nibble crossover point ==== -* - NIBBLE = ILAENV( 14, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) - NIBBLE = MAX( 0, NIBBLE ) -* -* ==== Accumulate reflections during ttswp? Use block -* . 2-by-2 structure during matrix-matrix multiply? ==== -* - KACC22 = ILAENV( 16, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) - KACC22 = MAX( 0, KACC22 ) - KACC22 = MIN( 2, KACC22 ) -* -* ==== NWMAX = the largest possible deflation window for -* . which there is sufficient workspace. ==== -* - NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) -* -* ==== NSMAX = the Largest number of simultaneous shifts -* . for which there is sufficient workspace. ==== -* - NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) - NSMAX = NSMAX - MOD( NSMAX, 2 ) -* -* ==== NDFL: an iteration count restarted at deflation. ==== -* - NDFL = 1 -* -* ==== ITMAX = iteration limit ==== -* - ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) -* -* ==== Last row and column in the active block ==== -* - KBOT = IHI -* -* ==== Main Loop ==== -* - DO 70 IT = 1, ITMAX -* -* ==== Done when KBOT falls below ILO ==== -* - IF( KBOT.LT.ILO ) - $ GO TO 80 -* -* ==== Locate active block ==== -* - DO 10 K = KBOT, ILO + 1, -1 - IF( H( K, K-1 ).EQ.ZERO ) - $ GO TO 20 - 10 CONTINUE - K = ILO - 20 CONTINUE - KTOP = K -* -* ==== Select deflation window size ==== -* - NH = KBOT - KTOP + 1 - IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN -* -* ==== Typical deflation window. If possible and -* . advisable, nibble the entire active block. -* . If not, use size NWR or NWR+1 depending upon -* . which has the smaller corresponding subdiagonal -* . entry (a heuristic). ==== -* - NWINC = .TRUE. - IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN - NW = NH - ELSE - NW = MIN( NWR, NH, NWMAX ) - IF( NW.LT.NWMAX ) THEN - IF( NW.GE.NH-1 ) THEN - NW = NH - ELSE - KWTOP = KBOT - NW + 1 - IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. - $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 - END IF - END IF - END IF - ELSE -* -* ==== Exceptional deflation window. If there have -* . been no deflations in KEXNW or more iterations, -* . then vary the deflation window size. At first, -* . because, larger windows are, in general, more -* . powerful than smaller ones, rapidly increase the -* . window up to the maximum reasonable and possible. -* . Then maybe try a slightly smaller window. ==== -* - IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN - NW = MIN( NWMAX, NH, 2*NW ) - ELSE - NWINC = .FALSE. - IF( NW.EQ.NH .AND. NH.GT.2 ) - $ NW = NH - 1 - END IF - END IF -* -* ==== Aggressive early deflation: -* . split workspace under the subdiagonal into -* . - an nw-by-nw work array V in the lower -* . left-hand-corner, -* . - an NW-by-at-least-NW-but-more-is-better -* . (NW-by-NHO) horizontal work array along -* . the bottom edge, -* . - an at-least-NW-but-more-is-better (NHV-by-NW) -* . vertical work array along the left-hand-edge. -* . ==== -* - KV = N - NW + 1 - KT = NW + 1 - NHO = ( N-NW-1 ) - KT + 1 - KWV = NW + 2 - NVE = ( N-NW ) - KWV + 1 -* -* ==== Aggressive early deflation ==== -* - CALL ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, - $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, - $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, - $ LWORK ) -* -* ==== Adjust KBOT accounting for new deflations. ==== -* - KBOT = KBOT - LD -* -* ==== KS points to the shifts. ==== -* - KS = KBOT - LS + 1 -* -* ==== Skip an expensive QR sweep if there is a (partly -* . heuristic) reason to expect that many eigenvalues -* . will deflate without it. Here, the QR sweep is -* . skipped if many eigenvalues have just been deflated -* . or if the remaining active block is small. -* - IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- - $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN -* -* ==== NS = nominal number of simultaneous shifts. -* . This may be lowered (slightly) if ZLAQR3 -* . did not provide that many shifts. ==== -* - NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) - NS = NS - MOD( NS, 2 ) -* -* ==== If there have been no deflations -* . in a multiple of KEXSH iterations, -* . then try exceptional shifts. -* . Otherwise use shifts provided by -* . ZLAQR3 above or from the eigenvalues -* . of a trailing principal submatrix. ==== -* - IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN - KS = KBOT - NS + 1 - DO 30 I = KBOT, KS + 1, -2 - W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) - W( I-1 ) = W( I ) - 30 CONTINUE - ELSE -* -* ==== Got NS/2 or fewer shifts? Use ZLAQR4 or -* . ZLAHQR on a trailing principal submatrix to -* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, -* . there is enough space below the subdiagonal -* . to fit an NS-by-NS scratch array.) ==== -* - IF( KBOT-KS+1.LE.NS / 2 ) THEN - KS = KBOT - NS + 1 - KT = N - NS + 1 - CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, - $ H( KT, 1 ), LDH ) - IF( NS.GT.NMIN ) THEN - CALL ZLAQR4( .false., .false., NS, 1, NS, - $ H( KT, 1 ), LDH, W( KS ), 1, 1, - $ ZDUM, 1, WORK, LWORK, INF ) - ELSE - CALL ZLAHQR( .false., .false., NS, 1, NS, - $ H( KT, 1 ), LDH, W( KS ), 1, 1, - $ ZDUM, 1, INF ) - END IF - KS = KS + INF -* -* ==== In case of a rare QR failure use -* . eigenvalues of the trailing 2-by-2 -* . principal submatrix. Scale to avoid -* . overflows, underflows and subnormals. -* . (The scale factor S can not be zero, -* . because H(KBOT,KBOT-1) is nonzero.) ==== -* - IF( KS.GE.KBOT ) THEN - S = CABS1( H( KBOT-1, KBOT-1 ) ) + - $ CABS1( H( KBOT, KBOT-1 ) ) + - $ CABS1( H( KBOT-1, KBOT ) ) + - $ CABS1( H( KBOT, KBOT ) ) - AA = H( KBOT-1, KBOT-1 ) / S - CC = H( KBOT, KBOT-1 ) / S - BB = H( KBOT-1, KBOT ) / S - DD = H( KBOT, KBOT ) / S - TR2 = ( AA+DD ) / TWO - DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC - RTDISC = SQRT( -DET ) - W( KBOT-1 ) = ( TR2+RTDISC )*S - W( KBOT ) = ( TR2-RTDISC )*S -* - KS = KBOT - 1 - END IF - END IF -* - IF( KBOT-KS+1.GT.NS ) THEN -* -* ==== Sort the shifts (Helps a little) ==== -* - SORTED = .false. - DO 50 K = KBOT, KS + 1, -1 - IF( SORTED ) - $ GO TO 60 - SORTED = .true. - DO 40 I = KS, K - 1 - IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) - $ THEN - SORTED = .false. - SWAP = W( I ) - W( I ) = W( I+1 ) - W( I+1 ) = SWAP - END IF - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - END IF - END IF -* -* ==== If there are only two shifts, then use -* . only one. ==== -* - IF( KBOT-KS+1.EQ.2 ) THEN - IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. - $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN - W( KBOT-1 ) = W( KBOT ) - ELSE - W( KBOT ) = W( KBOT-1 ) - END IF - END IF -* -* ==== Use up to NS of the the smallest magnatiude -* . shifts. If there aren't NS shifts available, -* . then use them all, possibly dropping one to -* . make the number of shifts even. ==== -* - NS = MIN( NS, KBOT-KS+1 ) - NS = NS - MOD( NS, 2 ) - KS = KBOT - NS + 1 -* -* ==== Small-bulge multi-shift QR sweep: -* . split workspace under the subdiagonal into -* . - a KDU-by-KDU work array U in the lower -* . left-hand-corner, -* . - a KDU-by-at-least-KDU-but-more-is-better -* . (KDU-by-NHo) horizontal work array WH along -* . the bottom edge, -* . - and an at-least-KDU-but-more-is-better-by-KDU -* . (NVE-by-KDU) vertical work WV arrow along -* . the left-hand-edge. ==== -* - KDU = 3*NS - 3 - KU = N - KDU + 1 - KWH = KDU + 1 - NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 - KWV = KDU + 4 - NVE = N - KDU - KWV + 1 -* -* ==== Small-bulge multi-shift QR sweep ==== -* - CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, - $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, - $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, - $ NHO, H( KU, KWH ), LDH ) - END IF -* -* ==== Note progress (or the lack of it). ==== -* - IF( LD.GT.0 ) THEN - NDFL = 1 - ELSE - NDFL = NDFL + 1 - END IF -* -* ==== End of main loop ==== - 70 CONTINUE -* -* ==== Iteration limit exceeded. Set INFO to show where -* . the problem occurred and exit. ==== -* - INFO = KBOT - 80 CONTINUE - END IF -* -* ==== Return the optimal value of LWORK. ==== -* - WORK( 1 ) = DCMPLX( LWKOPT, 0 ) -* -* ==== End of ZLAQR0 ==== -* - END - - SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, - $ LDC, SCALE, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER TRANA, TRANB - INTEGER INFO, ISGN, LDA, LDB, LDC, M, N - DOUBLE PRECISION SCALE -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZTRSYL solves the complex Sylvester matrix equation: -* -* op(A)*X + X*op(B) = scale*C or -* op(A)*X - X*op(B) = scale*C, -* -* where op(A) = A or A**H, and A and B are both upper triangular. A is -* M-by-M and B is N-by-N; the right hand side C and the solution X are -* M-by-N; and scale is an output scale factor, set <= 1 to avoid -* overflow in X. -* -* Arguments -* ========= -* -* TRANA (input) CHARACTER*1 -* Specifies the option op(A): -* = 'N': op(A) = A (No transpose) -* = 'C': op(A) = A**H (Conjugate transpose) -* -* TRANB (input) CHARACTER*1 -* Specifies the option op(B): -* = 'N': op(B) = B (No transpose) -* = 'C': op(B) = B**H (Conjugate transpose) -* -* ISGN (input) INTEGER -* Specifies the sign in the equation: -* = +1: solve op(A)*X + X*op(B) = scale*C -* = -1: solve op(A)*X - X*op(B) = scale*C -* -* M (input) INTEGER -* The order of the matrix A, and the number of rows in the -* matrices X and C. M >= 0. -* -* N (input) INTEGER -* The order of the matrix B, and the number of columns in the -* matrices X and C. N >= 0. -* -* A (input) COMPLEX*16 array, dimension (LDA,M) -* The upper triangular matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* B (input) COMPLEX*16 array, dimension (LDB,N) -* The upper triangular matrix B. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* C (input/output) COMPLEX*16 array, dimension (LDC,N) -* On entry, the M-by-N right hand side matrix C. -* On exit, C is overwritten by the solution matrix X. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M) -* -* SCALE (output) DOUBLE PRECISION -* The scale factor, scale, set <= 1 to avoid overflow in X. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* = 1: A and B have common or very close eigenvalues; perturbed -* values were used to solve the equation (but the matrices -* A and B are unchanged). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRNA, NOTRNB - INTEGER J, K, L - DOUBLE PRECISION BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN, - $ SMLNUM - COMPLEX*16 A11, SUML, SUMR, VEC, X11 -* .. -* .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ) -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, ZLANGE - COMPLEX*16 ZDOTC, ZDOTU, ZLADIV - EXTERNAL LSAME, DLAMCH, ZLANGE, ZDOTC, ZDOTU, ZLADIV -* .. -* .. External Subroutines .. - EXTERNAL DLABAD, XERBLA, ZDSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN -* .. -* .. Executable Statements .. -* -* Decode and Test input parameters -* - NOTRNA = LSAME( TRANA, 'N' ) - NOTRNB = LSAME( TRANB, 'N' ) -* - INFO = 0 - IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'C' ) ) THEN - INFO = -2 - ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -11 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZTRSYL', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Set constants to control overflow -* - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SMLNUM*DBLE( M*N ) / EPS - BIGNUM = ONE / SMLNUM - SMIN = MAX( SMLNUM, EPS*ZLANGE( 'M', M, M, A, LDA, DUM ), - $ EPS*ZLANGE( 'M', N, N, B, LDB, DUM ) ) - SCALE = ONE - SGN = ISGN -* - IF( NOTRNA .AND. NOTRNB ) THEN -* -* Solve A*X + ISGN*X*B = scale*C. -* -* The (K,L)th block of X is determined starting from -* bottom-left corner column by column by -* -* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) -* -* Where -* M L-1 -* R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]. -* I=K+1 J=1 -* - DO 30 L = 1, N - DO 20 K = M, 1, -1 -* - SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA, - $ C( MIN( K+1, M ), L ), 1 ) - SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 ) - VEC = C( K, L ) - ( SUML+SGN*SUMR ) -* - SCALOC = ONE - A11 = A( K, K ) + SGN*B( L, L ) - DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) - IF( DA11.LE.SMIN ) THEN - A11 = SMIN - DA11 = SMIN - INFO = 1 - END IF - DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) - IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN - IF( DB.GT.BIGNUM*DA11 ) - $ SCALOC = ONE / DB - END IF - X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) -* - IF( SCALOC.NE.ONE ) THEN - DO 10 J = 1, N - CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) - 10 CONTINUE - SCALE = SCALE*SCALOC - END IF - C( K, L ) = X11 -* - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN -* -* Solve A' *X + ISGN*X*B = scale*C. -* -* The (K,L)th block of X is determined starting from -* upper-left corner column by column by -* -* A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) -* -* Where -* K-1 L-1 -* R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)] -* I=1 J=1 -* - DO 60 L = 1, N - DO 50 K = 1, M -* - SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 ) - SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 ) - VEC = C( K, L ) - ( SUML+SGN*SUMR ) -* - SCALOC = ONE - A11 = DCONJG( A( K, K ) ) + SGN*B( L, L ) - DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) - IF( DA11.LE.SMIN ) THEN - A11 = SMIN - DA11 = SMIN - INFO = 1 - END IF - DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) - IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN - IF( DB.GT.BIGNUM*DA11 ) - $ SCALOC = ONE / DB - END IF -* - X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) -* - IF( SCALOC.NE.ONE ) THEN - DO 40 J = 1, N - CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) - 40 CONTINUE - SCALE = SCALE*SCALOC - END IF - C( K, L ) = X11 -* - 50 CONTINUE - 60 CONTINUE -* - ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN -* -* Solve A'*X + ISGN*X*B' = C. -* -* The (K,L)th block of X is determined starting from -* upper-right corner column by column by -* -* A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) -* -* Where -* K-1 -* R(K,L) = SUM [A'(I,K)*X(I,L)] + -* I=1 -* N -* ISGN*SUM [X(K,J)*B'(L,J)]. -* J=L+1 -* - DO 90 L = N, 1, -1 - DO 80 K = 1, M -* - SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 ) - SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC, - $ B( L, MIN( L+1, N ) ), LDB ) - VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) ) -* - SCALOC = ONE - A11 = DCONJG( A( K, K )+SGN*B( L, L ) ) - DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) - IF( DA11.LE.SMIN ) THEN - A11 = SMIN - DA11 = SMIN - INFO = 1 - END IF - DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) - IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN - IF( DB.GT.BIGNUM*DA11 ) - $ SCALOC = ONE / DB - END IF -* - X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) -* - IF( SCALOC.NE.ONE ) THEN - DO 70 J = 1, N - CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) - 70 CONTINUE - SCALE = SCALE*SCALOC - END IF - C( K, L ) = X11 -* - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN -* -* Solve A*X + ISGN*X*B' = C. -* -* The (K,L)th block of X is determined starting from -* bottom-left corner column by column by -* -* A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) -* -* Where -* M N -* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)] -* I=K+1 J=L+1 -* - DO 120 L = N, 1, -1 - DO 110 K = M, 1, -1 -* - SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA, - $ C( MIN( K+1, M ), L ), 1 ) - SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC, - $ B( L, MIN( L+1, N ) ), LDB ) - VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) ) -* - SCALOC = ONE - A11 = A( K, K ) + SGN*DCONJG( B( L, L ) ) - DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) - IF( DA11.LE.SMIN ) THEN - A11 = SMIN - DA11 = SMIN - INFO = 1 - END IF - DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) - IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN - IF( DB.GT.BIGNUM*DA11 ) - $ SCALOC = ONE / DB - END IF -* - X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) -* - IF( SCALOC.NE.ONE ) THEN - DO 100 J = 1, N - CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) - 100 CONTINUE - SCALE = SCALE*SCALOC - END IF - C( K, L ) = X11 -* - 110 CONTINUE - 120 CONTINUE -* - END IF -* - RETURN -* -* End of ZTRSYL -* - END - - SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER KASE, N - DOUBLE PRECISION EST -* .. -* .. Array Arguments .. - INTEGER ISAVE( 3 ) - COMPLEX*16 V( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZLACN2 estimates the 1-norm of a square, complex matrix A. -* Reverse communication is used for evaluating matrix-vector products. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix. N >= 1. -* -* V (workspace) COMPLEX*16 array, dimension (N) -* On the final return, V = A*W, where EST = norm(V)/norm(W) -* (W is not returned). -* -* X (input/output) COMPLEX*16 array, dimension (N) -* On an intermediate return, X should be overwritten by -* A * X, if KASE=1, -* A' * X, if KASE=2, -* where A' is the conjugate transpose of A, and ZLACN2 must be -* re-called with all the other parameters unchanged. -* -* EST (input/output) DOUBLE PRECISION -* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be -* unchanged from the previous call to ZLACN2. -* On exit, EST is an estimate (a lower bound) for norm(A). -* -* KASE (input/output) INTEGER -* On the initial call to ZLACN2, KASE should be 0. -* On an intermediate return, KASE will be 1 or 2, indicating -* whether X should be overwritten by A * X or A' * X. -* On the final return from ZLACN2, KASE will again be 0. -* -* ISAVE (input/output) INTEGER array, dimension (3) -* ISAVE is used to save variables between calls to ZLACN2 -* -* Further Details -* ======= ======= -* -* Contributed by Nick Higham, University of Manchester. -* Originally named CONEST, dated March 16, 1988. -* -* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of -* a real or complex matrix, with applications to condition estimation", -* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. -* -* Last modified: April, 1999 -* -* This is a thread safe version of ZLACON, which uses the array ISAVE -* in place of a SAVE statement, as follows: -* -* ZLACON ZLACN2 -* JUMP ISAVE(1) -* J ISAVE(2) -* ITER ISAVE(3) -* -* ===================================================================== -* -* .. Parameters .. - INTEGER ITMAX - PARAMETER ( ITMAX = 5 ) - DOUBLE PRECISION ONE, TWO - PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) - COMPLEX*16 CZERO, CONE - PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), - $ CONE = ( 1.0D0, 0.0D0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, JLAST - DOUBLE PRECISION ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP -* .. -* .. External Functions .. - INTEGER IZMAX1 - DOUBLE PRECISION DLAMCH, DZSUM1 - EXTERNAL IZMAX1, DLAMCH, DZSUM1 -* .. -* .. External Subroutines .. - EXTERNAL ZCOPY -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX, DIMAG -* .. -* .. Executable Statements .. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - IF( KASE.EQ.0 ) THEN - DO 10 I = 1, N - X( I ) = DCMPLX( ONE / DBLE( N ) ) - 10 CONTINUE - KASE = 1 - ISAVE( 1 ) = 1 - RETURN - END IF -* - GO TO ( 20, 40, 70, 90, 120 )ISAVE( 1 ) -* -* ................ ENTRY (ISAVE( 1 ) = 1) -* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. -* - 20 CONTINUE - IF( N.EQ.1 ) THEN - V( 1 ) = X( 1 ) - EST = ABS( V( 1 ) ) -* ... QUIT - GO TO 130 - END IF - EST = DZSUM1( N, X, 1 ) -* - DO 30 I = 1, N - ABSXI = ABS( X( I ) ) - IF( ABSXI.GT.SAFMIN ) THEN - X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, - $ DIMAG( X( I ) ) / ABSXI ) - ELSE - X( I ) = CONE - END IF - 30 CONTINUE - KASE = 2 - ISAVE( 1 ) = 2 - RETURN -* -* ................ ENTRY (ISAVE( 1 ) = 2) -* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. -* - 40 CONTINUE - ISAVE( 2 ) = IZMAX1( N, X, 1 ) - ISAVE( 3 ) = 2 -* -* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. -* - 50 CONTINUE - DO 60 I = 1, N - X( I ) = CZERO - 60 CONTINUE - X( ISAVE( 2 ) ) = CONE - KASE = 1 - ISAVE( 1 ) = 3 - RETURN -* -* ................ ENTRY (ISAVE( 1 ) = 3) -* X HAS BEEN OVERWRITTEN BY A*X. -* - 70 CONTINUE - CALL ZCOPY( N, X, 1, V, 1 ) - ESTOLD = EST - EST = DZSUM1( N, V, 1 ) -* -* TEST FOR CYCLING. - IF( EST.LE.ESTOLD ) - $ GO TO 100 -* - DO 80 I = 1, N - ABSXI = ABS( X( I ) ) - IF( ABSXI.GT.SAFMIN ) THEN - X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, - $ DIMAG( X( I ) ) / ABSXI ) - ELSE - X( I ) = CONE - END IF - 80 CONTINUE - KASE = 2 - ISAVE( 1 ) = 4 - RETURN -* -* ................ ENTRY (ISAVE( 1 ) = 4) -* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. -* - 90 CONTINUE - JLAST = ISAVE( 2 ) - ISAVE( 2 ) = IZMAX1( N, X, 1 ) - IF( ( ABS( X( JLAST ) ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. - $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN - ISAVE( 3 ) = ISAVE( 3 ) + 1 - GO TO 50 - END IF -* -* ITERATION COMPLETE. FINAL STAGE. -* - 100 CONTINUE - ALTSGN = ONE - DO 110 I = 1, N - X( I ) = DCMPLX( ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ) - ALTSGN = -ALTSGN - 110 CONTINUE - KASE = 1 - ISAVE( 1 ) = 5 - RETURN -* -* ................ ENTRY (ISAVE( 1 ) = 5) -* X HAS BEEN OVERWRITTEN BY A*X. -* - 120 CONTINUE - TEMP = TWO*( DZSUM1( N, X, 1 ) / DBLE( 3*N ) ) - IF( TEMP.GT.EST ) THEN - CALL ZCOPY( N, X, 1, V, 1 ) - EST = TEMP - END IF -* - 130 CONTINUE - KASE = 0 - RETURN -* -* End of ZLACN2 -* - END - - SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER COMPQ - INTEGER IFST, ILST, INFO, LDQ, LDT, N -* .. -* .. Array Arguments .. - COMPLEX*16 Q( LDQ, * ), T( LDT, * ) -* .. -* -* Purpose -* ======= -* -* ZTREXC reorders the Schur factorization of a complex matrix -* A = Q*T*Q**H, so that the diagonal element of T with row index IFST -* is moved to row ILST. -* -* The Schur form T is reordered by a unitary similarity transformation -* Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by -* postmultplying it with Z. -* -* Arguments -* ========= -* -* COMPQ (input) CHARACTER*1 -* = 'V': update the matrix Q of Schur vectors; -* = 'N': do not update Q. -* -* N (input) INTEGER -* The order of the matrix T. N >= 0. -* -* T (input/output) COMPLEX*16 array, dimension (LDT,N) -* On entry, the upper triangular matrix T. -* On exit, the reordered upper triangular matrix. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= max(1,N). -* -* Q (input/output) COMPLEX*16 array, dimension (LDQ,N) -* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. -* On exit, if COMPQ = 'V', Q has been postmultiplied by the -* unitary transformation matrix Z which reorders T. -* If COMPQ = 'N', Q is not referenced. -* -* LDQ (input) INTEGER -* The leading dimension of the array Q. LDQ >= max(1,N). -* -* IFST (input) INTEGER -* ILST (input) INTEGER -* Specify the reordering of the diagonal elements of T: -* The element with row index IFST is moved to row ILST by a -* sequence of transpositions between adjacent elements. -* 1 <= IFST <= N; 1 <= ILST <= N. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL WANTQ - INTEGER K, M1, M2, M3 - DOUBLE PRECISION CS - COMPLEX*16 SN, T11, T22, TEMP -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARTG, ZROT -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Decode and test the input parameters. -* - INFO = 0 - WANTQ = LSAME( COMPQ, 'V' ) - IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN - INFO = -6 - ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN - INFO = -7 - ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZTREXC', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.1 .OR. IFST.EQ.ILST ) - $ RETURN -* - IF( IFST.LT.ILST ) THEN -* -* Move the IFST-th diagonal element forward down the diagonal. -* - M1 = 0 - M2 = -1 - M3 = 1 - ELSE -* -* Move the IFST-th diagonal element backward up the diagonal. -* - M1 = -1 - M2 = 0 - M3 = -1 - END IF -* - DO 10 K = IFST + M1, ILST + M2, M3 -* -* Interchange the k-th and (k+1)-th diagonal elements. -* - T11 = T( K, K ) - T22 = T( K+1, K+1 ) -* -* Determine the transformation to perform the interchange. -* - CALL ZLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP ) -* -* Apply transformation to the matrix T. -* - IF( K+2.LE.N ) - $ CALL ZROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS, - $ SN ) - CALL ZROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS, - $ DCONJG( SN ) ) -* - T( K, K ) = T22 - T( K+1, K+1 ) = T11 -* - IF( WANTQ ) THEN -* -* Accumulate transformation in the matrix Q. -* - CALL ZROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS, - $ DCONJG( SN ) ) - END IF -* - 10 CONTINUE -* - RETURN -* -* End of ZTREXC -* - END - - SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER K, LDA, LDT, LDY, N, NB -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), - $ Y( LDY, NB ) -* .. -* -* Purpose -* ======= -* -* ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) -* matrix A so that elements below the k-th subdiagonal are zero. The -* reduction is performed by an unitary similarity transformation -* Q' * A * Q. The routine returns the matrices V and T which determine -* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. -* -* This is an auxiliary routine called by ZGEHRD. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix A. -* -* K (input) INTEGER -* The offset for the reduction. Elements below the k-th -* subdiagonal in the first NB columns are reduced to zero. -* K < N. -* -* NB (input) INTEGER -* The number of columns to be reduced. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1) -* On entry, the n-by-(n-k+1) general matrix A. -* On exit, the elements on and above the k-th subdiagonal in -* the first NB columns are overwritten with the corresponding -* elements of the reduced matrix; the elements below the k-th -* subdiagonal, with the array TAU, represent the matrix Q as a -* product of elementary reflectors. The other columns of A are -* unchanged. See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* TAU (output) COMPLEX*16 array, dimension (NB) -* The scalar factors of the elementary reflectors. See Further -* Details. -* -* T (output) COMPLEX*16 array, dimension (LDT,NB) -* The upper triangular matrix T. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= NB. -* -* Y (output) COMPLEX*16 array, dimension (LDY,NB) -* The n-by-nb matrix Y. -* -* LDY (input) INTEGER -* The leading dimension of the array Y. LDY >= N. -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of nb elementary reflectors -* -* Q = H(1) H(2) . . . H(nb). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a complex scalar, and v is a complex vector with -* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in -* A(i+k+1:n,i), and tau in TAU(i). -* -* The elements of the vectors v together form the (n-k+1)-by-nb matrix -* V which is needed, with T and Y, to apply the transformation to the -* unreduced part of the matrix, using an update of the form: -* A := (I - V*T*V') * (A - Y*V'). -* -* The contents of A on exit are illustrated by the following example -* with n = 7, k = 3 and nb = 2: -* -* ( a a a a a ) -* ( a a a a a ) -* ( a a a a a ) -* ( h h a a a ) -* ( v1 h a a a ) -* ( v1 v2 a a a ) -* ( v1 v2 a a a ) -* -* where a denotes an element of the original matrix A, h denotes a -* modified element of the upper Hessenberg matrix H, and vi denotes an -* element of the vector defining H(i). -* -* This file is a slight modification of LAPACK-3.0's ZLAHRD -* incorporating improvements proposed by Quintana-Orti and Van de -* Gejin. Note that the entries of A(1:K,2:NB) differ from those -* returned by the original LAPACK routine. This function is -* not backward compatible with LAPACK3.0. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I - COMPLEX*16 EI -* .. -* .. External Subroutines .. - EXTERNAL ZAXPY, ZCOPY, ZGEMM, ZGEMV, ZLACPY, - $ ZLARFG, ZSCAL, ZTRMM, ZTRMV, ZLACGV -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.1 ) - $ RETURN -* - DO 10 I = 1, NB - IF( I.GT.1 ) THEN -* -* Update A(K+1:N,I) -* -* Update I-th column of A - Y * V' -* - CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) - CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, - $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) - CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) -* -* Apply I - V * T' * V' to this column (call it b) from the -* left, using the last column of T as workspace -* -* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) -* ( V2 ) ( b2 ) -* -* where V1 is unit lower triangular -* -* w := V1' * b1 -* - CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) - CALL ZTRMV( 'Lower', 'Conjugate transpose', 'UNIT', - $ I-1, A( K+1, 1 ), - $ LDA, T( 1, NB ), 1 ) -* -* w := w + V2'*b2 -* - CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, - $ ONE, A( K+I, 1 ), - $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) -* -* w := T'*w -* - CALL ZTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT', - $ I-1, T, LDT, - $ T( 1, NB ), 1 ) -* -* b2 := b2 - V2*w -* - CALL ZGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, - $ A( K+I, 1 ), - $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) -* -* b1 := b1 - V1*w -* - CALL ZTRMV( 'Lower', 'NO TRANSPOSE', - $ 'UNIT', I-1, - $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) - CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) -* - A( K+I-1, I-1 ) = EI - END IF -* -* Generate the elementary reflector H(I) to annihilate -* A(K+I+1:N,I) -* - CALL ZLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, - $ TAU( I ) ) - EI = A( K+I, I ) - A( K+I, I ) = ONE -* -* Compute Y(K+1:N,I) -* - CALL ZGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, - $ ONE, A( K+1, I+1 ), - $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, - $ ONE, A( K+I, 1 ), LDA, - $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) - CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, - $ Y( K+1, 1 ), LDY, - $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) - CALL ZSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) -* -* Compute T(1:I,I) -* - CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) - CALL ZTRMV( 'Upper', 'No Transpose', 'NON-UNIT', - $ I-1, T, LDT, - $ T( 1, I ), 1 ) - T( I, I ) = TAU( I ) -* - 10 CONTINUE - A( K+NB, NB ) = EI -* -* Compute Y(1:K,1:NB) -* - CALL ZLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) - CALL ZTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', - $ 'UNIT', K, NB, - $ ONE, A( K+1, 1 ), LDA, Y, LDY ) - IF( N.GT.K+NB ) - $ CALL ZGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, - $ NB, N-K-NB, ONE, - $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, - $ LDY ) - CALL ZTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', - $ 'NON-UNIT', K, NB, - $ ONE, T, LDT, Y, LDY ) -* - RETURN -* -* End of ZLAHR2 -* - END - - SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, - $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, - $ NV, WV, LDWV, WORK, LWORK ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, - $ LDZ, LWORK, N, ND, NH, NS, NV, NW - LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. - COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), - $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) -* .. -* -* ****************************************************************** -* Aggressive early deflation: -* -* This subroutine accepts as input an upper Hessenberg matrix -* H and performs an unitary similarity transformation -* designed to detect and deflate fully converged eigenvalues from -* a trailing principal submatrix. On output H has been over- -* written by a new Hessenberg matrix that is a perturbation of -* an unitary similarity transformation of H. It is to be -* hoped that the final version of H has many zero subdiagonal -* entries. -* -* ****************************************************************** -* WANTT (input) LOGICAL -* If .TRUE., then the Hessenberg matrix H is fully updated -* so that the triangular Schur factor may be -* computed (in cooperation with the calling subroutine). -* If .FALSE., then only enough of H is updated to preserve -* the eigenvalues. -* -* WANTZ (input) LOGICAL -* If .TRUE., then the unitary matrix Z is updated so -* so that the unitary Schur factor may be computed -* (in cooperation with the calling subroutine). -* If .FALSE., then Z is not referenced. -* -* N (input) INTEGER -* The order of the matrix H and (if WANTZ is .TRUE.) the -* order of the unitary matrix Z. -* -* KTOP (input) INTEGER -* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. -* KBOT and KTOP together determine an isolated block -* along the diagonal of the Hessenberg matrix. -* -* KBOT (input) INTEGER -* It is assumed without a check that either -* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together -* determine an isolated block along the diagonal of the -* Hessenberg matrix. -* -* NW (input) INTEGER -* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). -* -* H (input/output) COMPLEX*16 array, dimension (LDH,N) -* On input the initial N-by-N section of H stores the -* Hessenberg matrix undergoing aggressive early deflation. -* On output H has been transformed by a unitary -* similarity transformation, perturbed, and the returned -* to Hessenberg form that (it is to be hoped) has some -* zero subdiagonal entries. -* -* LDH (input) integer -* Leading dimension of H just as declared in the calling -* subroutine. N .LE. LDH -* -* ILOZ (input) INTEGER -* IHIZ (input) INTEGER -* Specify the rows of Z to which transformations must be -* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. -* -* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) -* IF WANTZ is .TRUE., then on output, the unitary -* similarity transformation mentioned above has been -* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. -* If WANTZ is .FALSE., then Z is unreferenced. -* -* LDZ (input) integer -* The leading dimension of Z just as declared in the -* calling subroutine. 1 .LE. LDZ. -* -* NS (output) integer -* The number of unconverged (ie approximate) eigenvalues -* returned in SR and SI that may be used as shifts by the -* calling subroutine. -* -* ND (output) integer -* The number of converged eigenvalues uncovered by this -* subroutine. -* -* SH (output) COMPLEX*16 array, dimension KBOT -* On output, approximate eigenvalues that may -* be used for shifts are stored in SH(KBOT-ND-NS+1) -* through SR(KBOT-ND). Converged eigenvalues are -* stored in SH(KBOT-ND+1) through SH(KBOT). -* -* V (workspace) COMPLEX*16 array, dimension (LDV,NW) -* An NW-by-NW work array. -* -* LDV (input) integer scalar -* The leading dimension of V just as declared in the -* calling subroutine. NW .LE. LDV -* -* NH (input) integer scalar -* The number of columns of T. NH.GE.NW. -* -* T (workspace) COMPLEX*16 array, dimension (LDT,NW) -* -* LDT (input) integer -* The leading dimension of T just as declared in the -* calling subroutine. NW .LE. LDT -* -* NV (input) integer -* The number of rows of work array WV available for -* workspace. NV.GE.NW. -* -* WV (workspace) COMPLEX*16 array, dimension (LDWV,NW) -* -* LDWV (input) integer -* The leading dimension of W just as declared in the -* calling subroutine. NW .LE. LDV -* -* WORK (workspace) COMPLEX*16 array, dimension LWORK. -* On exit, WORK(1) is set to an estimate of the optimal value -* of LWORK for the given values of N, NW, KTOP and KBOT. -* -* LWORK (input) integer -* The dimension of the work array WORK. LWORK = 2*NW -* suffices, but greater efficiency may result from larger -* values of LWORK. -* -* If LWORK = -1, then a workspace query is assumed; ZLAQR3 -* only estimates the optimal workspace size for the given -* values of N, NW, KTOP and KBOT. The estimate is returned -* in WORK(1). No error message related to LWORK is issued -* by XERBLA. Neither H nor Z are accessed. -* -* ================================================================ -* Based on contributions by -* Karen Braman and Ralph Byers, Department of Mathematics, -* University of Kansas, USA -* -* ================================================================== -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), - $ ONE = ( 1.0d0, 0.0d0 ) ) - DOUBLE PRECISION RZERO, RONE - PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) -* .. -* .. Local Scalars .. - COMPLEX*16 BETA, CDUM, S, TAU - DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP - INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, - $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, - $ LWKOPT, NMIN -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - INTEGER ILAENV - EXTERNAL DLAMCH, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, - $ ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNGHR -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN -* .. -* .. Statement Functions .. - DOUBLE PRECISION CABS1 -* .. -* .. Statement Function definitions .. - CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) -* .. -* .. Executable Statements .. -* -* ==== Estimate optimal workspace. ==== -* - JW = MIN( NW, KBOT-KTOP+1 ) - IF( JW.LE.2 ) THEN - LWKOPT = 1 - ELSE -* -* ==== Workspace query call to ZGEHRD ==== -* - CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) - LWK1 = INT( WORK( 1 ) ) -* -* ==== Workspace query call to ZUNGHR ==== -* - CALL ZUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) - LWK2 = INT( WORK( 1 ) ) -* -* ==== Workspace query call to ZLAQR4 ==== -* - CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V, - $ LDV, WORK, -1, INFQR ) - LWK3 = INT( WORK( 1 ) ) -* -* ==== Optimal workspace ==== -* - LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) - END IF -* -* ==== Quick return in case of workspace query. ==== -* - IF( LWORK.EQ.-1 ) THEN - WORK( 1 ) = DCMPLX( LWKOPT, 0 ) - RETURN - END IF -* -* ==== Nothing to do ... -* ... for an empty active block ... ==== - NS = 0 - ND = 0 - IF( KTOP.GT.KBOT ) - $ RETURN -* ... nor for an empty deflation window. ==== - IF( NW.LT.1 ) - $ RETURN -* -* ==== Machine constants ==== -* - SAFMIN = DLAMCH( 'SAFE MINIMUM' ) - SAFMAX = RONE / SAFMIN - CALL DLABAD( SAFMIN, SAFMAX ) - ULP = DLAMCH( 'PRECISION' ) - SMLNUM = SAFMIN*( DBLE( N ) / ULP ) -* -* ==== Setup deflation window ==== -* - JW = MIN( NW, KBOT-KTOP+1 ) - KWTOP = KBOT - JW + 1 - IF( KWTOP.EQ.KTOP ) THEN - S = ZERO - ELSE - S = H( KWTOP, KWTOP-1 ) - END IF -* - IF( KBOT.EQ.KWTOP ) THEN -* -* ==== 1-by-1 deflation window: not much to do ==== -* - SH( KWTOP ) = H( KWTOP, KWTOP ) - NS = 1 - ND = 0 - IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, - $ KWTOP ) ) ) ) THEN - - NS = 0 - ND = 1 - IF( KWTOP.GT.KTOP ) - $ H( KWTOP, KWTOP-1 ) = ZERO - END IF - RETURN - END IF -* -* ==== Convert to spike-triangular form. (In case of a -* . rare QR failure, this routine continues to do -* . aggressive early deflation using that part of -* . the deflation window that converged using INFQR -* . here and there to keep track.) ==== -* - CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) - CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) -* - CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) - NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK ) - IF( JW.GT.NMIN ) THEN - CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, - $ JW, V, LDV, WORK, LWORK, INFQR ) - ELSE - CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, - $ JW, V, LDV, INFQR ) - END IF -* -* ==== Deflation detection loop ==== -* - NS = JW - ILST = INFQR + 1 - DO 10 KNT = INFQR + 1, JW -* -* ==== Small spike tip deflation test ==== -* - FOO = CABS1( T( NS, NS ) ) - IF( FOO.EQ.RZERO ) - $ FOO = CABS1( S ) - IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) - $ THEN -* -* ==== One more converged eigenvalue ==== -* - NS = NS - 1 - ELSE -* -* ==== One undflatable eigenvalue. Move it up out of the -* . way. (ZTREXC can not fail in this case.) ==== -* - IFST = NS - CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) - ILST = ILST + 1 - END IF - 10 CONTINUE -* -* ==== Return to Hessenberg form ==== -* - IF( NS.EQ.0 ) - $ S = ZERO -* - IF( NS.LT.JW ) THEN -* -* ==== sorting the diagonal of T improves accuracy for -* . graded matrices. ==== -* - DO 30 I = INFQR + 1, NS - IFST = I - DO 20 J = I + 1, NS - IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) - $ IFST = J - 20 CONTINUE - ILST = I - IF( IFST.NE.ILST ) - $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) - 30 CONTINUE - END IF -* -* ==== Restore shift/eigenvalue array from T ==== -* - DO 40 I = INFQR + 1, JW - SH( KWTOP+I-1 ) = T( I, I ) - 40 CONTINUE -* -* - IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN - IF( NS.GT.1 .AND. S.NE.ZERO ) THEN -* -* ==== Reflect spike back into lower triangle ==== -* - CALL ZCOPY( NS, V, LDV, WORK, 1 ) - DO 50 I = 1, NS - WORK( I ) = DCONJG( WORK( I ) ) - 50 CONTINUE - BETA = WORK( 1 ) - CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) - WORK( 1 ) = ONE -* - CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) -* - CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, - $ WORK( JW+1 ) ) - CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, - $ WORK( JW+1 ) ) -* - CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), - $ LWORK-JW, INFO ) - END IF -* -* ==== Copy updated reduced window into place ==== -* - IF( KWTOP.GT.1 ) - $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) - CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) - CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), - $ LDH+1 ) -* -* ==== Accumulate orthogonal matrix in order update -* . H and Z, if requested. (A modified version -* . of ZUNGHR that accumulates block Householder -* . transformations into V directly might be -* . marginally more efficient than the following.) ==== -* - IF( NS.GT.1 .AND. S.NE.ZERO ) THEN - CALL ZUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), - $ LWORK-JW, INFO ) - CALL ZGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, - $ WV, LDWV ) - CALL ZLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) - END IF -* -* ==== Update vertical slab in H ==== -* - IF( WANTT ) THEN - LTOP = 1 - ELSE - LTOP = KTOP - END IF - DO 60 KROW = LTOP, KWTOP - 1, NV - KLN = MIN( NV, KWTOP-KROW ) - CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), - $ LDH, V, LDV, ZERO, WV, LDWV ) - CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) - 60 CONTINUE -* -* ==== Update horizontal slab in H ==== -* - IF( WANTT ) THEN - DO 70 KCOL = KBOT + 1, N, NH - KLN = MIN( NH, N-KCOL+1 ) - CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, - $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) - CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), - $ LDH ) - 70 CONTINUE - END IF -* -* ==== Update vertical slab in Z ==== -* - IF( WANTZ ) THEN - DO 80 KROW = ILOZ, IHIZ, NV - KLN = MIN( NV, IHIZ-KROW+1 ) - CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), - $ LDZ, V, LDV, ZERO, WV, LDWV ) - CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), - $ LDZ ) - 80 CONTINUE - END IF - END IF -* -* ==== Return the number of deflations ... ==== -* - ND = JW - NS -* -* ==== ... and the number of shifts. (Subtracting -* . INFQR from the spike length takes care -* . of the case of a rare QR failure while -* . calculating eigenvalues of the deflation -* . window.) ==== -* - NS = NS - INFQR -* -* ==== Return optimal workspace. ==== -* - WORK( 1 ) = DCMPLX( LWKOPT, 0 ) -* -* ==== End of ZLAQR3 ==== -* - END - - SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, - $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N - LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. - COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* This subroutine implements one level of recursion for ZLAQR0. -* It is a complete implementation of the small bulge multi-shift -* QR algorithm. It may be called by ZLAQR0 and, for large enough -* deflation window size, it may be called by ZLAQR3. This -* subroutine is identical to ZLAQR0 except that it calls ZLAQR2 -* instead of ZLAQR3. -* -* Purpose -* ======= -* -* ZLAQR4 computes the eigenvalues of a Hessenberg matrix H -* and, optionally, the matrices T and Z from the Schur decomposition -* H = Z T Z**H, where T is an upper triangular matrix (the -* Schur form), and Z is the unitary matrix of Schur vectors. -* -* Optionally Z may be postmultiplied into an input unitary -* matrix Q so that this routine can give the Schur factorization -* of a matrix A which has been reduced to the Hessenberg form H -* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. -* -* Arguments -* ========= -* -* WANTT (input) LOGICAL -* = .TRUE. : the full Schur form T is required; -* = .FALSE.: only eigenvalues are required. -* -* WANTZ (input) LOGICAL -* = .TRUE. : the matrix of Schur vectors Z is required; -* = .FALSE.: Schur vectors are not required. -* -* N (input) INTEGER -* The order of the matrix H. N .GE. 0. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* It is assumed that H is already upper triangular in rows -* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, -* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a -* previous call to ZGEBAL, and then passed to ZGEHRD when the -* matrix output by ZGEBAL is reduced to Hessenberg form. -* Otherwise, ILO and IHI should be set to 1 and N, -* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. -* If N = 0, then ILO = 1 and IHI = 0. -* -* H (input/output) COMPLEX*16 array, dimension (LDH,N) -* On entry, the upper Hessenberg matrix H. -* On exit, if INFO = 0 and WANTT is .TRUE., then H -* contains the upper triangular matrix T from the Schur -* decomposition (the Schur form). If INFO = 0 and WANT is -* .FALSE., then the contents of H are unspecified on exit. -* (The output value of H when INFO.GT.0 is given under the -* description of INFO below.) -* -* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and -* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. -* -* LDH (input) INTEGER -* The leading dimension of the array H. LDH .GE. max(1,N). -* -* W (output) COMPLEX*16 array, dimension (N) -* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored -* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are -* stored in the same order as on the diagonal of the Schur -* form returned in H, with W(i) = H(i,i). -* -* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) -* If WANTZ is .FALSE., then Z is not referenced. -* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is -* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the -* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). -* (The output value of Z when INFO.GT.0 is given under -* the description of INFO below.) -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. if WANTZ is .TRUE. -* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. -* -* WORK (workspace/output) COMPLEX*16 array, dimension LWORK -* On exit, if LWORK = -1, WORK(1) returns an estimate of -* the optimal value for LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK .GE. max(1,N) -* is sufficient, but LWORK typically as large as 6*N may -* be required for optimal performance. A workspace query -* to determine the optimal workspace size is recommended. -* -* If LWORK = -1, then ZLAQR4 does a workspace query. -* In this case, ZLAQR4 checks the input parameters and -* estimates the optimal workspace size for the given -* values of N, ILO and IHI. The estimate is returned -* in WORK(1). No error message related to LWORK is -* issued by XERBLA. Neither H nor Z are accessed. -* -* -* INFO (output) INTEGER -* = 0: successful exit -* .GT. 0: if INFO = i, ZLAQR4 failed to compute all of -* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR -* and WI contain those eigenvalues which have been -* successfully computed. (Failures are rare.) -* -* If INFO .GT. 0 and WANT is .FALSE., then on exit, -* the remaining unconverged eigenvalues are the eigen- -* values of the upper Hessenberg matrix rows and -* columns ILO through INFO of the final, output -* value of H. -* -* If INFO .GT. 0 and WANTT is .TRUE., then on exit -* -* (*) (initial value of H)*U = U*(final value of H) -* -* where U is a unitary matrix. The final -* value of H is upper Hessenberg and triangular in -* rows and columns INFO+1 through IHI. -* -* If INFO .GT. 0 and WANTZ is .TRUE., then on exit -* -* (final value of Z(ILO:IHI,ILOZ:IHIZ) -* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U -* -* where U is the unitary matrix in (*) (regard- -* less of the value of WANTT.) -* -* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not -* accessed. -* -* ================================================================ -* Based on contributions by -* Karen Braman and Ralph Byers, Department of Mathematics, -* University of Kansas, USA -* -* ================================================================ -* References: -* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR -* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 -* Performance, SIAM Journal of Matrix Analysis, volume 23, pages -* 929--947, 2002. -* -* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR -* Algorithm Part II: Aggressive Early Deflation, SIAM Journal -* of Matrix Analysis, volume 23, pages 948--973, 2002. -* -* ================================================================ -* .. Parameters .. -* -* ==== Matrices of order NTINY or smaller must be processed by -* . ZLAHQR because of insufficient subdiagonal scratch space. -* . (This is a hard limit.) ==== -* -* ==== Exceptional deflation windows: try to cure rare -* . slow convergence by increasing the size of the -* . deflation window after KEXNW iterations. ===== -* -* ==== Exceptional shifts: try to cure rare slow convergence -* . with ad-hoc exceptional shifts every KEXSH iterations. -* . The constants WILK1 and WILK2 are used to form the -* . exceptional shifts. ==== -* - INTEGER NTINY - PARAMETER ( NTINY = 11 ) - INTEGER KEXNW, KEXSH - PARAMETER ( KEXNW = 5, KEXSH = 6 ) - DOUBLE PRECISION WILK1 - PARAMETER ( WILK1 = 0.75d0 ) - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), - $ ONE = ( 1.0d0, 0.0d0 ) ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0d0 ) -* .. -* .. Local Scalars .. - COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 - DOUBLE PRECISION S - INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, - $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, - $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, - $ NSR, NVE, NW, NWMAX, NWR - LOGICAL NWINC, SORTED - CHARACTER JBCMPZ*2 -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Local Arrays .. - COMPLEX*16 ZDUM( 1, 1 ) -* .. -* .. External Subroutines .. - EXTERNAL ZLACPY, ZLAHQR, ZLAQR2, ZLAQR5 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, - $ SQRT -* .. -* .. Statement Functions .. - DOUBLE PRECISION CABS1 -* .. -* .. Statement Function definitions .. - CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) -* .. -* .. Executable Statements .. - INFO = 0 -* -* ==== Quick return for N = 0: nothing to do. ==== -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = ONE - RETURN - END IF -* -* ==== Set up job flags for ILAENV. ==== -* - IF( WANTT ) THEN - JBCMPZ( 1: 1 ) = 'S' - ELSE - JBCMPZ( 1: 1 ) = 'E' - END IF - IF( WANTZ ) THEN - JBCMPZ( 2: 2 ) = 'V' - ELSE - JBCMPZ( 2: 2 ) = 'N' - END IF -* -* ==== Tiny matrices must use ZLAHQR. ==== -* - IF( N.LE.NTINY ) THEN -* -* ==== Estimate optimal workspace. ==== -* - LWKOPT = 1 - IF( LWORK.NE.-1 ) - $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, - $ IHIZ, Z, LDZ, INFO ) - ELSE -* -* ==== Use small bulge multi-shift QR with aggressive early -* . deflation on larger-than-tiny matrices. ==== -* -* ==== Hope for the best. ==== -* - INFO = 0 -* -* ==== NWR = recommended deflation window size. At this -* . point, N .GT. NTINY = 11, so there is enough -* . subdiagonal workspace for NWR.GE.2 as required. -* . (In fact, there is enough subdiagonal space for -* . NWR.GE.3.) ==== -* - NWR = ILAENV( 13, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) - NWR = MAX( 2, NWR ) - NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) - NW = NWR -* -* ==== NSR = recommended number of simultaneous shifts. -* . At this point N .GT. NTINY = 11, so there is at -* . enough subdiagonal workspace for NSR to be even -* . and greater than or equal to two as required. ==== -* - NSR = ILAENV( 15, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) - NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) - NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) -* -* ==== Estimate optimal workspace ==== -* -* ==== Workspace query call to ZLAQR2 ==== -* - CALL ZLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, - $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, - $ LDH, WORK, -1 ) -* -* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ==== -* - LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) -* -* ==== Quick return in case of workspace query. ==== -* - IF( LWORK.EQ.-1 ) THEN - WORK( 1 ) = DCMPLX( LWKOPT, 0 ) - RETURN - END IF -* -* ==== ZLAHQR/ZLAQR0 crossover point ==== -* - NMIN = ILAENV( 12, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) - NMIN = MAX( NTINY, NMIN ) -* -* ==== Nibble crossover point ==== -* - NIBBLE = ILAENV( 14, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) - NIBBLE = MAX( 0, NIBBLE ) -* -* ==== Accumulate reflections during ttswp? Use block -* . 2-by-2 structure during matrix-matrix multiply? ==== -* - KACC22 = ILAENV( 16, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) - KACC22 = MAX( 0, KACC22 ) - KACC22 = MIN( 2, KACC22 ) -* -* ==== NWMAX = the largest possible deflation window for -* . which there is sufficient workspace. ==== -* - NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) -* -* ==== NSMAX = the Largest number of simultaneous shifts -* . for which there is sufficient workspace. ==== -* - NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) - NSMAX = NSMAX - MOD( NSMAX, 2 ) -* -* ==== NDFL: an iteration count restarted at deflation. ==== -* - NDFL = 1 -* -* ==== ITMAX = iteration limit ==== -* - ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) -* -* ==== Last row and column in the active block ==== -* - KBOT = IHI -* -* ==== Main Loop ==== -* - DO 70 IT = 1, ITMAX -* -* ==== Done when KBOT falls below ILO ==== -* - IF( KBOT.LT.ILO ) - $ GO TO 80 -* -* ==== Locate active block ==== -* - DO 10 K = KBOT, ILO + 1, -1 - IF( H( K, K-1 ).EQ.ZERO ) - $ GO TO 20 - 10 CONTINUE - K = ILO - 20 CONTINUE - KTOP = K -* -* ==== Select deflation window size ==== -* - NH = KBOT - KTOP + 1 - IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN -* -* ==== Typical deflation window. If possible and -* . advisable, nibble the entire active block. -* . If not, use size NWR or NWR+1 depending upon -* . which has the smaller corresponding subdiagonal -* . entry (a heuristic). ==== -* - NWINC = .TRUE. - IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN - NW = NH - ELSE - NW = MIN( NWR, NH, NWMAX ) - IF( NW.LT.NWMAX ) THEN - IF( NW.GE.NH-1 ) THEN - NW = NH - ELSE - KWTOP = KBOT - NW + 1 - IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. - $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 - END IF - END IF - END IF - ELSE -* -* ==== Exceptional deflation window. If there have -* . been no deflations in KEXNW or more iterations, -* . then vary the deflation window size. At first, -* . because, larger windows are, in general, more -* . powerful than smaller ones, rapidly increase the -* . window up to the maximum reasonable and possible. -* . Then maybe try a slightly smaller window. ==== -* - IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN - NW = MIN( NWMAX, NH, 2*NW ) - ELSE - NWINC = .FALSE. - IF( NW.EQ.NH .AND. NH.GT.2 ) - $ NW = NH - 1 - END IF - END IF -* -* ==== Aggressive early deflation: -* . split workspace under the subdiagonal into -* . - an nw-by-nw work array V in the lower -* . left-hand-corner, -* . - an NW-by-at-least-NW-but-more-is-better -* . (NW-by-NHO) horizontal work array along -* . the bottom edge, -* . - an at-least-NW-but-more-is-better (NHV-by-NW) -* . vertical work array along the left-hand-edge. -* . ==== -* - KV = N - NW + 1 - KT = NW + 1 - NHO = ( N-NW-1 ) - KT + 1 - KWV = NW + 2 - NVE = ( N-NW ) - KWV + 1 -* -* ==== Aggressive early deflation ==== -* - CALL ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, - $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, - $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, - $ LWORK ) -* -* ==== Adjust KBOT accounting for new deflations. ==== -* - KBOT = KBOT - LD -* -* ==== KS points to the shifts. ==== -* - KS = KBOT - LS + 1 -* -* ==== Skip an expensive QR sweep if there is a (partly -* . heuristic) reason to expect that many eigenvalues -* . will deflate without it. Here, the QR sweep is -* . skipped if many eigenvalues have just been deflated -* . or if the remaining active block is small. -* - IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- - $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN -* -* ==== NS = nominal number of simultaneous shifts. -* . This may be lowered (slightly) if ZLAQR2 -* . did not provide that many shifts. ==== -* - NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) - NS = NS - MOD( NS, 2 ) -* -* ==== If there have been no deflations -* . in a multiple of KEXSH iterations, -* . then try exceptional shifts. -* . Otherwise use shifts provided by -* . ZLAQR2 above or from the eigenvalues -* . of a trailing principal submatrix. ==== -* - IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN - KS = KBOT - NS + 1 - DO 30 I = KBOT, KS + 1, -2 - W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) - W( I-1 ) = W( I ) - 30 CONTINUE - ELSE -* -* ==== Got NS/2 or fewer shifts? Use ZLAHQR -* . on a trailing principal submatrix to -* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, -* . there is enough space below the subdiagonal -* . to fit an NS-by-NS scratch array.) ==== -* - IF( KBOT-KS+1.LE.NS / 2 ) THEN - KS = KBOT - NS + 1 - KT = N - NS + 1 - CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, - $ H( KT, 1 ), LDH ) - CALL ZLAHQR( .false., .false., NS, 1, NS, - $ H( KT, 1 ), LDH, W( KS ), 1, 1, ZDUM, - $ 1, INF ) - KS = KS + INF -* -* ==== In case of a rare QR failure use -* . eigenvalues of the trailing 2-by-2 -* . principal submatrix. Scale to avoid -* . overflows, underflows and subnormals. -* . (The scale factor S can not be zero, -* . because H(KBOT,KBOT-1) is nonzero.) ==== -* - IF( KS.GE.KBOT ) THEN - S = CABS1( H( KBOT-1, KBOT-1 ) ) + - $ CABS1( H( KBOT, KBOT-1 ) ) + - $ CABS1( H( KBOT-1, KBOT ) ) + - $ CABS1( H( KBOT, KBOT ) ) - AA = H( KBOT-1, KBOT-1 ) / S - CC = H( KBOT, KBOT-1 ) / S - BB = H( KBOT-1, KBOT ) / S - DD = H( KBOT, KBOT ) / S - TR2 = ( AA+DD ) / TWO - DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC - RTDISC = SQRT( -DET ) - W( KBOT-1 ) = ( TR2+RTDISC )*S - W( KBOT ) = ( TR2-RTDISC )*S -* - KS = KBOT - 1 - END IF - END IF -* - IF( KBOT-KS+1.GT.NS ) THEN -* -* ==== Sort the shifts (Helps a little) ==== -* - SORTED = .false. - DO 50 K = KBOT, KS + 1, -1 - IF( SORTED ) - $ GO TO 60 - SORTED = .true. - DO 40 I = KS, K - 1 - IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) - $ THEN - SORTED = .false. - SWAP = W( I ) - W( I ) = W( I+1 ) - W( I+1 ) = SWAP - END IF - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - END IF - END IF -* -* ==== If there are only two shifts, then use -* . only one. ==== -* - IF( KBOT-KS+1.EQ.2 ) THEN - IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. - $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN - W( KBOT-1 ) = W( KBOT ) - ELSE - W( KBOT ) = W( KBOT-1 ) - END IF - END IF -* -* ==== Use up to NS of the the smallest magnatiude -* . shifts. If there aren't NS shifts available, -* . then use them all, possibly dropping one to -* . make the number of shifts even. ==== -* - NS = MIN( NS, KBOT-KS+1 ) - NS = NS - MOD( NS, 2 ) - KS = KBOT - NS + 1 -* -* ==== Small-bulge multi-shift QR sweep: -* . split workspace under the subdiagonal into -* . - a KDU-by-KDU work array U in the lower -* . left-hand-corner, -* . - a KDU-by-at-least-KDU-but-more-is-better -* . (KDU-by-NHo) horizontal work array WH along -* . the bottom edge, -* . - and an at-least-KDU-but-more-is-better-by-KDU -* . (NVE-by-KDU) vertical work WV arrow along -* . the left-hand-edge. ==== -* - KDU = 3*NS - 3 - KU = N - KDU + 1 - KWH = KDU + 1 - NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 - KWV = KDU + 4 - NVE = N - KDU - KWV + 1 -* -* ==== Small-bulge multi-shift QR sweep ==== -* - CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, - $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, - $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, - $ NHO, H( KU, KWH ), LDH ) - END IF -* -* ==== Note progress (or the lack of it). ==== -* - IF( LD.GT.0 ) THEN - NDFL = 1 - ELSE - NDFL = NDFL + 1 - END IF -* -* ==== End of main loop ==== - 70 CONTINUE -* -* ==== Iteration limit exceeded. Set INFO to show where -* . the problem occurred and exit. ==== -* - INFO = KBOT - 80 CONTINUE - END IF -* -* ==== Return the optimal value of LWORK. ==== -* - WORK( 1 ) = DCMPLX( LWKOPT, 0 ) -* -* ==== End of ZLAQR4 ==== -* - END - - SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, - $ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, - $ WV, LDWV, NH, WH, LDWH ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, - $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV - LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. - COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), - $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) -* .. -* -* This auxiliary subroutine called by ZLAQR0 performs a -* single small-bulge multi-shift QR sweep. -* -* WANTT (input) logical scalar -* WANTT = .true. if the triangular Schur factor -* is being computed. WANTT is set to .false. otherwise. -* -* WANTZ (input) logical scalar -* WANTZ = .true. if the unitary Schur factor is being -* computed. WANTZ is set to .false. otherwise. -* -* KACC22 (input) integer with value 0, 1, or 2. -* Specifies the computation mode of far-from-diagonal -* orthogonal updates. -* = 0: ZLAQR5 does not accumulate reflections and does not -* use matrix-matrix multiply to update far-from-diagonal -* matrix entries. -* = 1: ZLAQR5 accumulates reflections and uses matrix-matrix -* multiply to update the far-from-diagonal matrix entries. -* = 2: ZLAQR5 accumulates reflections, uses matrix-matrix -* multiply to update the far-from-diagonal matrix entries, -* and takes advantage of 2-by-2 block structure during -* matrix multiplies. -* -* N (input) integer scalar -* N is the order of the Hessenberg matrix H upon which this -* subroutine operates. -* -* KTOP (input) integer scalar -* KBOT (input) integer scalar -* These are the first and last rows and columns of an -* isolated diagonal block upon which the QR sweep is to be -* applied. It is assumed without a check that -* either KTOP = 1 or H(KTOP,KTOP-1) = 0 -* and -* either KBOT = N or H(KBOT+1,KBOT) = 0. -* -* NSHFTS (input) integer scalar -* NSHFTS gives the number of simultaneous shifts. NSHFTS -* must be positive and even. -* -* S (input) COMPLEX*16 array of size (NSHFTS) -* S contains the shifts of origin that define the multi- -* shift QR sweep. -* -* H (input/output) COMPLEX*16 array of size (LDH,N) -* On input H contains a Hessenberg matrix. On output a -* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied -* to the isolated diagonal block in rows and columns KTOP -* through KBOT. -* -* LDH (input) integer scalar -* LDH is the leading dimension of H just as declared in the -* calling procedure. LDH.GE.MAX(1,N). -* -* ILOZ (input) INTEGER -* IHIZ (input) INTEGER -* Specify the rows of Z to which transformations must be -* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N -* -* Z (input/output) COMPLEX*16 array of size (LDZ,IHI) -* If WANTZ = .TRUE., then the QR Sweep unitary -* similarity transformation is accumulated into -* Z(ILOZ:IHIZ,ILO:IHI) from the right. -* If WANTZ = .FALSE., then Z is unreferenced. -* -* LDZ (input) integer scalar -* LDA is the leading dimension of Z just as declared in -* the calling procedure. LDZ.GE.N. -* -* V (workspace) COMPLEX*16 array of size (LDV,NSHFTS/2) -* -* LDV (input) integer scalar -* LDV is the leading dimension of V as declared in the -* calling procedure. LDV.GE.3. -* -* U (workspace) COMPLEX*16 array of size -* (LDU,3*NSHFTS-3) -* -* LDU (input) integer scalar -* LDU is the leading dimension of U just as declared in the -* in the calling subroutine. LDU.GE.3*NSHFTS-3. -* -* NH (input) integer scalar -* NH is the number of columns in array WH available for -* workspace. NH.GE.1. -* -* WH (workspace) COMPLEX*16 array of size (LDWH,NH) -* -* LDWH (input) integer scalar -* Leading dimension of WH just as declared in the -* calling procedure. LDWH.GE.3*NSHFTS-3. -* -* NV (input) integer scalar -* NV is the number of rows in WV agailable for workspace. -* NV.GE.1. -* -* WV (workspace) COMPLEX*16 array of size -* (LDWV,3*NSHFTS-3) -* -* LDWV (input) integer scalar -* LDWV is the leading dimension of WV as declared in the -* in the calling subroutine. LDWV.GE.NV. -* -* ================================================================ -* Based on contributions by -* Karen Braman and Ralph Byers, Department of Mathematics, -* University of Kansas, USA -* -* ============================================================ -* Reference: -* -* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR -* Algorithm Part I: Maintaining Well Focused Shifts, and -* Level 3 Performance, SIAM Journal of Matrix Analysis, -* volume 23, pages 929--947, 2002. -* -* ============================================================ -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), - $ ONE = ( 1.0d0, 0.0d0 ) ) - DOUBLE PRECISION RZERO, RONE - PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) -* .. -* .. Local Scalars .. - COMPLEX*16 ALPHA, BETA, CDUM, REFSUM - DOUBLE PRECISION H11, H12, H21, H22, SAFMAX, SAFMIN, SCL, - $ SMLNUM, TST1, TST2, ULP - INTEGER I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, - $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, - $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, - $ NS, NU - LOGICAL ACCUM, BLK22, BMP22 -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. -* - INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD -* .. -* .. Local Arrays .. - COMPLEX*16 VT( 3 ) -* .. -* .. External Subroutines .. - EXTERNAL DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET, - $ ZTRMM -* .. -* .. Statement Functions .. - DOUBLE PRECISION CABS1 -* .. -* .. Statement Function definitions .. - CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) -* .. -* .. Executable Statements .. -* -* ==== If there are no shifts, then there is nothing to do. ==== -* - IF( NSHFTS.LT.2 ) - $ RETURN -* -* ==== If the active block is empty or 1-by-1, then there -* . is nothing to do. ==== -* - IF( KTOP.GE.KBOT ) - $ RETURN -* -* ==== NSHFTS is supposed to be even, but if is odd, -* . then simply reduce it by one. ==== -* - NS = NSHFTS - MOD( NSHFTS, 2 ) -* -* ==== Machine constants for deflation ==== -* - SAFMIN = DLAMCH( 'SAFE MINIMUM' ) - SAFMAX = RONE / SAFMIN - CALL DLABAD( SAFMIN, SAFMAX ) - ULP = DLAMCH( 'PRECISION' ) - SMLNUM = SAFMIN*( DBLE( N ) / ULP ) -* -* ==== Use accumulated reflections to update far-from-diagonal -* . entries ? ==== -* - ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) -* -* ==== If so, exploit the 2-by-2 block structure? ==== -* - BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) -* -* ==== clear trash ==== -* - IF( KTOP+2.LE.KBOT ) - $ H( KTOP+2, KTOP ) = ZERO -* -* ==== NBMPS = number of 2-shift bulges in the chain ==== -* - NBMPS = NS / 2 -* -* ==== KDU = width of slab ==== -* - KDU = 6*NBMPS - 3 -* -* ==== Create and chase chains of NBMPS bulges ==== -* - DO 210 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 - NDCOL = INCOL + KDU - IF( ACCUM ) - $ CALL ZLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU ) -* -* ==== Near-the-diagonal bulge chase. The following loop -* . performs the near-the-diagonal part of a small bulge -* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal -* . chunk extends from column INCOL to column NDCOL -* . (including both column INCOL and column NDCOL). The -* . following loop chases a 3*NBMPS column long chain of -* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL -* . may be less than KTOP and and NDCOL may be greater than -* . KBOT indicating phantom columns from which to chase -* . bulges before they are actually introduced or to which -* . to chase bulges beyond column KBOT.) ==== -* - DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) -* -* ==== Bulges number MTOP to MBOT are active double implicit -* . shift bulges. There may or may not also be small -* . 2-by-2 bulge, if there is room. The inactive bulges -* . (if any) must wait until the active bulges have moved -* . down the diagonal to make room. The phantom matrix -* . paradigm described above helps keep track. ==== -* - MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) - MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) - M22 = MBOT + 1 - BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. - $ ( KBOT-2 ) -* -* ==== Generate reflections to chase the chain right -* . one column. (The minimum value of K is KTOP-1.) ==== -* - DO 10 M = MTOP, MBOT - K = KRCOL + 3*( M-1 ) - IF( K.EQ.KTOP-1 ) THEN - CALL ZLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ), - $ S( 2*M ), V( 1, M ) ) - ALPHA = V( 1, M ) - CALL ZLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) - ELSE - BETA = H( K+1, K ) - V( 2, M ) = H( K+2, K ) - V( 3, M ) = H( K+3, K ) - CALL ZLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) -* -* ==== A Bulge may collapse because of vigilant -* . deflation or destructive underflow. (The -* . initial bulge is always collapsed.) Use -* . the two-small-subdiagonals trick to try -* . to get it started again. If V(2,M).NE.0 and -* . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then -* . this bulge is collapsing into a zero -* . subdiagonal. It will be restarted next -* . trip through the loop.) -* - IF( V( 1, M ).NE.ZERO .AND. - $ ( V( 3, M ).NE.ZERO .OR. ( H( K+3, - $ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) ) - $ THEN -* -* ==== Typical case: not collapsed (yet). ==== -* - H( K+1, K ) = BETA - H( K+2, K ) = ZERO - H( K+3, K ) = ZERO - ELSE -* -* ==== Atypical case: collapsed. Attempt to -* . reintroduce ignoring H(K+1,K). If the -* . fill resulting from the new reflector -* . is too large, then abandon it. -* . Otherwise, use the new one. ==== -* - CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ), - $ S( 2*M ), VT ) - SCL = CABS1( VT( 1 ) ) + CABS1( VT( 2 ) ) + - $ CABS1( VT( 3 ) ) - IF( SCL.NE.RZERO ) THEN - VT( 1 ) = VT( 1 ) / SCL - VT( 2 ) = VT( 2 ) / SCL - VT( 3 ) = VT( 3 ) / SCL - END IF -* -* ==== The following is the traditional and -* . conservative two-small-subdiagonals -* . test. ==== -* . - IF( CABS1( H( K+1, K ) )* - $ ( CABS1( VT( 2 ) )+CABS1( VT( 3 ) ) ).GT.ULP* - $ CABS1( VT( 1 ) )*( CABS1( H( K, - $ K ) )+CABS1( H( K+1, K+1 ) )+CABS1( H( K+2, - $ K+2 ) ) ) ) THEN -* -* ==== Starting a new bulge here would -* . create non-negligible fill. If -* . the old reflector is diagonal (only -* . possible with underflows), then -* . change it to I. Otherwise, use -* . it with trepidation. ==== -* - IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO ) - $ THEN - V( 1, M ) = ZERO - ELSE - H( K+1, K ) = BETA - H( K+2, K ) = ZERO - H( K+3, K ) = ZERO - END IF - ELSE -* -* ==== Stating a new bulge here would -* . create only negligible fill. -* . Replace the old reflector with -* . the new one. ==== -* - ALPHA = VT( 1 ) - CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) - REFSUM = H( K+1, K ) + - $ H( K+2, K )*DCONJG( VT( 2 ) ) + - $ H( K+3, K )*DCONJG( VT( 3 ) ) - H( K+1, K ) = H( K+1, K ) - - $ DCONJG( VT( 1 ) )*REFSUM - H( K+2, K ) = ZERO - H( K+3, K ) = ZERO - V( 1, M ) = VT( 1 ) - V( 2, M ) = VT( 2 ) - V( 3, M ) = VT( 3 ) - END IF - END IF - END IF - 10 CONTINUE -* -* ==== Generate a 2-by-2 reflection, if needed. ==== -* - K = KRCOL + 3*( M22-1 ) - IF( BMP22 ) THEN - IF( K.EQ.KTOP-1 ) THEN - CALL ZLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ), - $ S( 2*M22 ), V( 1, M22 ) ) - BETA = V( 1, M22 ) - CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) - ELSE - BETA = H( K+1, K ) - V( 2, M22 ) = H( K+2, K ) - CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) - H( K+1, K ) = BETA - H( K+2, K ) = ZERO - END IF - ELSE -* -* ==== Initialize V(1,M22) here to avoid possible undefined -* . variable problems later. ==== -* - V( 1, M22 ) = ZERO - END IF -* -* ==== Multiply H by reflections from the left ==== -* - IF( ACCUM ) THEN - JBOT = MIN( NDCOL, KBOT ) - ELSE IF( WANTT ) THEN - JBOT = N - ELSE - JBOT = KBOT - END IF - DO 30 J = MAX( KTOP, KRCOL ), JBOT - MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) - DO 20 M = MTOP, MEND - K = KRCOL + 3*( M-1 ) - REFSUM = DCONJG( V( 1, M ) )* - $ ( H( K+1, J )+DCONJG( V( 2, M ) )* - $ H( K+2, J )+DCONJG( V( 3, M ) )*H( K+3, J ) ) - H( K+1, J ) = H( K+1, J ) - REFSUM - H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) - H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) - 20 CONTINUE - 30 CONTINUE - IF( BMP22 ) THEN - K = KRCOL + 3*( M22-1 ) - DO 40 J = MAX( K+1, KTOP ), JBOT - REFSUM = DCONJG( V( 1, M22 ) )* - $ ( H( K+1, J )+DCONJG( V( 2, M22 ) )* - $ H( K+2, J ) ) - H( K+1, J ) = H( K+1, J ) - REFSUM - H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) - 40 CONTINUE - END IF -* -* ==== Multiply H by reflections from the right. -* . Delay filling in the last row until the -* . vigilant deflation check is complete. ==== -* - IF( ACCUM ) THEN - JTOP = MAX( KTOP, INCOL ) - ELSE IF( WANTT ) THEN - JTOP = 1 - ELSE - JTOP = KTOP - END IF - DO 80 M = MTOP, MBOT - IF( V( 1, M ).NE.ZERO ) THEN - K = KRCOL + 3*( M-1 ) - DO 50 J = JTOP, MIN( KBOT, K+3 ) - REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* - $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) - H( J, K+1 ) = H( J, K+1 ) - REFSUM - H( J, K+2 ) = H( J, K+2 ) - - $ REFSUM*DCONJG( V( 2, M ) ) - H( J, K+3 ) = H( J, K+3 ) - - $ REFSUM*DCONJG( V( 3, M ) ) - 50 CONTINUE -* - IF( ACCUM ) THEN -* -* ==== Accumulate U. (If necessary, update Z later -* . with with an efficient matrix-matrix -* . multiply.) ==== -* - KMS = K - INCOL - DO 60 J = MAX( 1, KTOP-INCOL ), KDU - REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* - $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) - U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM - U( J, KMS+2 ) = U( J, KMS+2 ) - - $ REFSUM*DCONJG( V( 2, M ) ) - U( J, KMS+3 ) = U( J, KMS+3 ) - - $ REFSUM*DCONJG( V( 3, M ) ) - 60 CONTINUE - ELSE IF( WANTZ ) THEN -* -* ==== U is not accumulated, so update Z -* . now by multiplying by reflections -* . from the right. ==== -* - DO 70 J = ILOZ, IHIZ - REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* - $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) - Z( J, K+1 ) = Z( J, K+1 ) - REFSUM - Z( J, K+2 ) = Z( J, K+2 ) - - $ REFSUM*DCONJG( V( 2, M ) ) - Z( J, K+3 ) = Z( J, K+3 ) - - $ REFSUM*DCONJG( V( 3, M ) ) - 70 CONTINUE - END IF - END IF - 80 CONTINUE -* -* ==== Special case: 2-by-2 reflection (if needed) ==== -* - K = KRCOL + 3*( M22-1 ) - IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN - DO 90 J = JTOP, MIN( KBOT, K+3 ) - REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* - $ H( J, K+2 ) ) - H( J, K+1 ) = H( J, K+1 ) - REFSUM - H( J, K+2 ) = H( J, K+2 ) - - $ REFSUM*DCONJG( V( 2, M22 ) ) - 90 CONTINUE -* - IF( ACCUM ) THEN - KMS = K - INCOL - DO 100 J = MAX( 1, KTOP-INCOL ), KDU - REFSUM = V( 1, M22 )*( U( J, KMS+1 )+V( 2, M22 )* - $ U( J, KMS+2 ) ) - U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM - U( J, KMS+2 ) = U( J, KMS+2 ) - - $ REFSUM*DCONJG( V( 2, M22 ) ) - 100 CONTINUE - ELSE IF( WANTZ ) THEN - DO 110 J = ILOZ, IHIZ - REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* - $ Z( J, K+2 ) ) - Z( J, K+1 ) = Z( J, K+1 ) - REFSUM - Z( J, K+2 ) = Z( J, K+2 ) - - $ REFSUM*DCONJG( V( 2, M22 ) ) - 110 CONTINUE - END IF - END IF -* -* ==== Vigilant deflation check ==== -* - MSTART = MTOP - IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) - $ MSTART = MSTART + 1 - MEND = MBOT - IF( BMP22 ) - $ MEND = MEND + 1 - IF( KRCOL.EQ.KBOT-2 ) - $ MEND = MEND + 1 - DO 120 M = MSTART, MEND - K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) -* -* ==== The following convergence test requires that -* . the tradition small-compared-to-nearby-diagonals -* . criterion and the Ahues & Tisseur (LAWN 122, 1997) -* . criteria both be satisfied. The latter improves -* . accuracy in some examples. Falling back on an -* . alternate convergence criterion when TST1 or TST2 -* . is zero (as done here) is traditional but probably -* . unnecessary. ==== -* - IF( H( K+1, K ).NE.ZERO ) THEN - TST1 = CABS1( H( K, K ) ) + CABS1( H( K+1, K+1 ) ) - IF( TST1.EQ.RZERO ) THEN - IF( K.GE.KTOP+1 ) - $ TST1 = TST1 + CABS1( H( K, K-1 ) ) - IF( K.GE.KTOP+2 ) - $ TST1 = TST1 + CABS1( H( K, K-2 ) ) - IF( K.GE.KTOP+3 ) - $ TST1 = TST1 + CABS1( H( K, K-3 ) ) - IF( K.LE.KBOT-2 ) - $ TST1 = TST1 + CABS1( H( K+2, K+1 ) ) - IF( K.LE.KBOT-3 ) - $ TST1 = TST1 + CABS1( H( K+3, K+1 ) ) - IF( K.LE.KBOT-4 ) - $ TST1 = TST1 + CABS1( H( K+4, K+1 ) ) - END IF - IF( CABS1( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) - $ THEN - H12 = MAX( CABS1( H( K+1, K ) ), - $ CABS1( H( K, K+1 ) ) ) - H21 = MIN( CABS1( H( K+1, K ) ), - $ CABS1( H( K, K+1 ) ) ) - H11 = MAX( CABS1( H( K+1, K+1 ) ), - $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) - H22 = MIN( CABS1( H( K+1, K+1 ) ), - $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) - SCL = H11 + H12 - TST2 = H22*( H11 / SCL ) -* - IF( TST2.EQ.RZERO .OR. H21*( H12 / SCL ).LE. - $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO - END IF - END IF - 120 CONTINUE -* -* ==== Fill in the last row of each bulge. ==== -* - MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) - DO 130 M = MTOP, MEND - K = KRCOL + 3*( M-1 ) - REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) - H( K+4, K+1 ) = -REFSUM - H( K+4, K+2 ) = -REFSUM*DCONJG( V( 2, M ) ) - H( K+4, K+3 ) = H( K+4, K+3 ) - - $ REFSUM*DCONJG( V( 3, M ) ) - 130 CONTINUE -* -* ==== End of near-the-diagonal bulge chase. ==== -* - 140 CONTINUE -* -* ==== Use U (if accumulated) to update far-from-diagonal -* . entries in H. If required, use U to update Z as -* . well. ==== -* - IF( ACCUM ) THEN - IF( WANTT ) THEN - JTOP = 1 - JBOT = N - ELSE - JTOP = KTOP - JBOT = KBOT - END IF - IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. - $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN -* -* ==== Updates not exploiting the 2-by-2 block -* . structure of U. K1 and NU keep track of -* . the location and size of U in the special -* . cases of introducing bulges and chasing -* . bulges off the bottom. In these special -* . cases and in case the number of shifts -* . is NS = 2, there is no 2-by-2 block -* . structure to exploit. ==== -* - K1 = MAX( 1, KTOP-INCOL ) - NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 -* -* ==== Horizontal Multiply ==== -* - DO 150 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH - JLEN = MIN( NH, JBOT-JCOL+1 ) - CALL ZGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), - $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, - $ LDWH ) - CALL ZLACPY( 'ALL', NU, JLEN, WH, LDWH, - $ H( INCOL+K1, JCOL ), LDH ) - 150 CONTINUE -* -* ==== Vertical multiply ==== -* - DO 160 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV - JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) - CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, - $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), - $ LDU, ZERO, WV, LDWV ) - CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, - $ H( JROW, INCOL+K1 ), LDH ) - 160 CONTINUE -* -* ==== Z multiply (also vertical) ==== -* - IF( WANTZ ) THEN - DO 170 JROW = ILOZ, IHIZ, NV - JLEN = MIN( NV, IHIZ-JROW+1 ) - CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, - $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), - $ LDU, ZERO, WV, LDWV ) - CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, - $ Z( JROW, INCOL+K1 ), LDZ ) - 170 CONTINUE - END IF - ELSE -* -* ==== Updates exploiting U's 2-by-2 block structure. -* . (I2, I4, J2, J4 are the last rows and columns -* . of the blocks.) ==== -* - I2 = ( KDU+1 ) / 2 - I4 = KDU - J2 = I4 - I2 - J4 = KDU -* -* ==== KZS and KNZ deal with the band of zeros -* . along the diagonal of one of the triangular -* . blocks. ==== -* - KZS = ( J4-J2 ) - ( NS+1 ) - KNZ = NS + 1 -* -* ==== Horizontal multiply ==== -* - DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH - JLEN = MIN( NH, JBOT-JCOL+1 ) -* -* ==== Copy bottom of H to top+KZS of scratch ==== -* (The first KZS rows get multiplied by zero.) ==== -* - CALL ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), - $ LDH, WH( KZS+1, 1 ), LDWH ) -* -* ==== Multiply by U21' ==== -* - CALL ZLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) - CALL ZTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, - $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), - $ LDWH ) -* -* ==== Multiply top of H by U11' ==== -* - CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, - $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) -* -* ==== Copy top of H bottom of WH ==== -* - CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, - $ WH( I2+1, 1 ), LDWH ) -* -* ==== Multiply by U21' ==== -* - CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, - $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) -* -* ==== Multiply by U22 ==== -* - CALL ZGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, - $ U( J2+1, I2+1 ), LDU, - $ H( INCOL+1+J2, JCOL ), LDH, ONE, - $ WH( I2+1, 1 ), LDWH ) -* -* ==== Copy it back ==== -* - CALL ZLACPY( 'ALL', KDU, JLEN, WH, LDWH, - $ H( INCOL+1, JCOL ), LDH ) - 180 CONTINUE -* -* ==== Vertical multiply ==== -* - DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV - JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) -* -* ==== Copy right of H to scratch (the first KZS -* . columns get multiplied by zero) ==== -* - CALL ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), - $ LDH, WV( 1, 1+KZS ), LDWV ) -* -* ==== Multiply by U21 ==== -* - CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) - CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, - $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), - $ LDWV ) -* -* ==== Multiply by U11 ==== -* - CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, - $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, - $ LDWV ) -* -* ==== Copy left of H to right of scratch ==== -* - CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, - $ WV( 1, 1+I2 ), LDWV ) -* -* ==== Multiply by U21 ==== -* - CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, - $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) -* -* ==== Multiply by U22 ==== -* - CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, - $ H( JROW, INCOL+1+J2 ), LDH, - $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), - $ LDWV ) -* -* ==== Copy it back ==== -* - CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, - $ H( JROW, INCOL+1 ), LDH ) - 190 CONTINUE -* -* ==== Multiply Z (also vertical) ==== -* - IF( WANTZ ) THEN - DO 200 JROW = ILOZ, IHIZ, NV - JLEN = MIN( NV, IHIZ-JROW+1 ) -* -* ==== Copy right of Z to left of scratch (first -* . KZS columns get multiplied by zero) ==== -* - CALL ZLACPY( 'ALL', JLEN, KNZ, - $ Z( JROW, INCOL+1+J2 ), LDZ, - $ WV( 1, 1+KZS ), LDWV ) -* -* ==== Multiply by U12 ==== -* - CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, - $ LDWV ) - CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, - $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), - $ LDWV ) -* -* ==== Multiply by U11 ==== -* - CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, - $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, - $ WV, LDWV ) -* -* ==== Copy left of Z to right of scratch ==== -* - CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), - $ LDZ, WV( 1, 1+I2 ), LDWV ) -* -* ==== Multiply by U21 ==== -* - CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, - $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), - $ LDWV ) -* -* ==== Multiply by U22 ==== -* - CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, - $ Z( JROW, INCOL+1+J2 ), LDZ, - $ U( J2+1, I2+1 ), LDU, ONE, - $ WV( 1, 1+I2 ), LDWV ) -* -* ==== Copy the result back to Z ==== -* - CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, - $ Z( JROW, INCOL+1 ), LDZ ) - 200 CONTINUE - END IF - END IF - END IF - 210 CONTINUE -* -* ==== End of ZLAQR5 ==== -* - END - - INTEGER FUNCTION IZMAX1( N, CX, INCX ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INCX, N -* .. -* .. Array Arguments .. - COMPLEX*16 CX( * ) -* .. -* -* Purpose -* ======= -* -* IZMAX1 finds the index of the element whose real part has maximum -* absolute value. -* -* Based on IZAMAX from Level 1 BLAS. -* The change is to use the 'genuine' absolute value. -* -* Contributed by Nick Higham for use with ZLACON. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of elements in the vector CX. -* -* CX (input) COMPLEX*16 array, dimension (N) -* The vector whose elements will be summed. -* -* INCX (input) INTEGER -* The spacing between successive values of CX. INCX >= 1. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IX - DOUBLE PRECISION SMAX - COMPLEX*16 ZDUM -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Statement Functions .. - DOUBLE PRECISION CABS1 -* .. -* .. Statement Function definitions .. -* -* NEXT LINE IS THE ONLY MODIFICATION. - CABS1( ZDUM ) = ABS( ZDUM ) -* .. -* .. Executable Statements .. -* - IZMAX1 = 0 - IF( N.LT.1 ) - $ RETURN - IZMAX1 = 1 - IF( N.EQ.1 ) - $ RETURN - IF( INCX.EQ.1 ) - $ GO TO 30 -* -* CODE FOR INCREMENT NOT EQUAL TO 1 -* - IX = 1 - SMAX = CABS1( CX( 1 ) ) - IX = IX + INCX - DO 20 I = 2, N - IF( CABS1( CX( IX ) ).LE.SMAX ) - $ GO TO 10 - IZMAX1 = I - SMAX = CABS1( CX( IX ) ) - 10 CONTINUE - IX = IX + INCX - 20 CONTINUE - RETURN -* -* CODE FOR INCREMENT EQUAL TO 1 -* - 30 CONTINUE - SMAX = CABS1( CX( 1 ) ) - DO 40 I = 2, N - IF( CABS1( CX( I ) ).LE.SMAX ) - $ GO TO 40 - IZMAX1 = I - SMAX = CABS1( CX( I ) ) - 40 CONTINUE - RETURN -* -* End of IZMAX1 -* - END - - DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INCX, N -* .. -* .. Array Arguments .. - COMPLEX*16 CX( * ) -* .. -* -* Purpose -* ======= -* -* DZSUM1 takes the sum of the absolute values of a complex -* vector and returns a double precision result. -* -* Based on DZASUM from the Level 1 BLAS. -* The change is to use the 'genuine' absolute value. -* -* Contributed by Nick Higham for use with ZLACON. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of elements in the vector CX. -* -* CX (input) COMPLEX*16 array, dimension (N) -* The vector whose elements will be summed. -* -* INCX (input) INTEGER -* The spacing between successive values of CX. INCX > 0. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, NINCX - DOUBLE PRECISION STEMP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* - DZSUM1 = 0.0D0 - STEMP = 0.0D0 - IF( N.LE.0 ) - $ RETURN - IF( INCX.EQ.1 ) - $ GO TO 20 -* -* CODE FOR INCREMENT NOT EQUAL TO 1 -* - NINCX = N*INCX - DO 10 I = 1, NINCX, INCX -* -* NEXT LINE MODIFIED. -* - STEMP = STEMP + ABS( CX( I ) ) - 10 CONTINUE - DZSUM1 = STEMP - RETURN -* -* CODE FOR INCREMENT EQUAL TO 1 -* - 20 CONTINUE - DO 30 I = 1, N -* -* NEXT LINE MODIFIED. -* - STEMP = STEMP + ABS( CX( I ) ) - 30 CONTINUE - DZSUM1 = STEMP - RETURN -* -* End of DZSUM1 -* - END - - SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER IHI, ILO, INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H -* by a unitary similarity transformation: Q' * A * Q = H . -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* It is assumed that A is already upper triangular in rows -* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally -* set by a previous call to ZGEBAL; otherwise they should be -* set to 1 and N respectively. See Further Details. -* 1 <= ILO <= IHI <= max(1,N). -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the n by n general matrix to be reduced. -* On exit, the upper triangle and the first subdiagonal of A -* are overwritten with the upper Hessenberg matrix H, and the -* elements below the first subdiagonal, with the array TAU, -* represent the unitary matrix Q as a product of elementary -* reflectors. See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* TAU (output) COMPLEX*16 array, dimension (N-1) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace) COMPLEX*16 array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of (ihi-ilo) elementary -* reflectors -* -* Q = H(ilo) H(ilo+1) . . . H(ihi-1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a complex scalar, and v is a complex vector with -* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on -* exit in A(i+2:ihi,i), and tau in TAU(i). -* -* The contents of A are illustrated by the following example, with -* n = 7, ilo = 2 and ihi = 6: -* -* on entry, on exit, -* -* ( a a a a a a a ) ( a a h h h h a ) -* ( a a a a a a ) ( a h h h h a ) -* ( a a a a a a ) ( h h h h h h ) -* ( a a a a a a ) ( v2 h h h h h ) -* ( a a a a a a ) ( v2 v3 h h h h ) -* ( a a a a a a ) ( v2 v3 v4 h h h ) -* ( a ) ( a ) -* -* where a denotes an element of the original matrix A, h denotes a -* modified element of the upper Hessenberg matrix H, and vi denotes an -* element of the vector defining H(i). -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I - COMPLEX*16 ALPHA -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARF, ZLARFG -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -2 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGEHD2', -INFO ) - RETURN - END IF -* - DO 10 I = ILO, IHI - 1 -* -* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) -* - ALPHA = A( I+1, I ) - CALL ZLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAU( I ) ) - A( I+1, I ) = ONE -* -* Apply H(i) to A(1:ihi,i+1:ihi) from the right -* - CALL ZLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), - $ A( 1, I+1 ), LDA, WORK ) -* -* Apply H(i)' to A(i+1:ihi,i+1:n) from the left -* - CALL ZLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, - $ DCONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK ) -* - A( I+1, I ) = ALPHA - 10 CONTINUE -* - RETURN -* -* End of ZGEHD2 -* - END - - SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, - $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, - $ NV, WV, LDWV, WORK, LWORK ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, - $ LDZ, LWORK, N, ND, NH, NS, NV, NW - LOGICAL WANTT, WANTZ -* .. -* .. Array Arguments .. - COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), - $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) -* .. -* -* This subroutine is identical to ZLAQR3 except that it avoids -* recursion by calling ZLAHQR instead of ZLAQR4. -* -* -* ****************************************************************** -* Aggressive early deflation: -* -* This subroutine accepts as input an upper Hessenberg matrix -* H and performs an unitary similarity transformation -* designed to detect and deflate fully converged eigenvalues from -* a trailing principal submatrix. On output H has been over- -* written by a new Hessenberg matrix that is a perturbation of -* an unitary similarity transformation of H. It is to be -* hoped that the final version of H has many zero subdiagonal -* entries. -* -* ****************************************************************** -* WANTT (input) LOGICAL -* If .TRUE., then the Hessenberg matrix H is fully updated -* so that the triangular Schur factor may be -* computed (in cooperation with the calling subroutine). -* If .FALSE., then only enough of H is updated to preserve -* the eigenvalues. -* -* WANTZ (input) LOGICAL -* If .TRUE., then the unitary matrix Z is updated so -* so that the unitary Schur factor may be computed -* (in cooperation with the calling subroutine). -* If .FALSE., then Z is not referenced. -* -* N (input) INTEGER -* The order of the matrix H and (if WANTZ is .TRUE.) the -* order of the unitary matrix Z. -* -* KTOP (input) INTEGER -* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. -* KBOT and KTOP together determine an isolated block -* along the diagonal of the Hessenberg matrix. -* -* KBOT (input) INTEGER -* It is assumed without a check that either -* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together -* determine an isolated block along the diagonal of the -* Hessenberg matrix. -* -* NW (input) INTEGER -* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). -* -* H (input/output) COMPLEX*16 array, dimension (LDH,N) -* On input the initial N-by-N section of H stores the -* Hessenberg matrix undergoing aggressive early deflation. -* On output H has been transformed by a unitary -* similarity transformation, perturbed, and the returned -* to Hessenberg form that (it is to be hoped) has some -* zero subdiagonal entries. -* -* LDH (input) integer -* Leading dimension of H just as declared in the calling -* subroutine. N .LE. LDH -* -* ILOZ (input) INTEGER -* IHIZ (input) INTEGER -* Specify the rows of Z to which transformations must be -* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. -* -* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) -* IF WANTZ is .TRUE., then on output, the unitary -* similarity transformation mentioned above has been -* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. -* If WANTZ is .FALSE., then Z is unreferenced. -* -* LDZ (input) integer -* The leading dimension of Z just as declared in the -* calling subroutine. 1 .LE. LDZ. -* -* NS (output) integer -* The number of unconverged (ie approximate) eigenvalues -* returned in SR and SI that may be used as shifts by the -* calling subroutine. -* -* ND (output) integer -* The number of converged eigenvalues uncovered by this -* subroutine. -* -* SH (output) COMPLEX*16 array, dimension KBOT -* On output, approximate eigenvalues that may -* be used for shifts are stored in SH(KBOT-ND-NS+1) -* through SR(KBOT-ND). Converged eigenvalues are -* stored in SH(KBOT-ND+1) through SH(KBOT). -* -* V (workspace) COMPLEX*16 array, dimension (LDV,NW) -* An NW-by-NW work array. -* -* LDV (input) integer scalar -* The leading dimension of V just as declared in the -* calling subroutine. NW .LE. LDV -* -* NH (input) integer scalar -* The number of columns of T. NH.GE.NW. -* -* T (workspace) COMPLEX*16 array, dimension (LDT,NW) -* -* LDT (input) integer -* The leading dimension of T just as declared in the -* calling subroutine. NW .LE. LDT -* -* NV (input) integer -* The number of rows of work array WV available for -* workspace. NV.GE.NW. -* -* WV (workspace) COMPLEX*16 array, dimension (LDWV,NW) -* -* LDWV (input) integer -* The leading dimension of W just as declared in the -* calling subroutine. NW .LE. LDV -* -* WORK (workspace) COMPLEX*16 array, dimension LWORK. -* On exit, WORK(1) is set to an estimate of the optimal value -* of LWORK for the given values of N, NW, KTOP and KBOT. -* -* LWORK (input) integer -* The dimension of the work array WORK. LWORK = 2*NW -* suffices, but greater efficiency may result from larger -* values of LWORK. -* -* If LWORK = -1, then a workspace query is assumed; ZLAQR2 -* only estimates the optimal workspace size for the given -* values of N, NW, KTOP and KBOT. The estimate is returned -* in WORK(1). No error message related to LWORK is issued -* by XERBLA. Neither H nor Z are accessed. -* -* ================================================================ -* Based on contributions by -* Karen Braman and Ralph Byers, Department of Mathematics, -* University of Kansas, USA -* -* ================================================================== -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), - $ ONE = ( 1.0d0, 0.0d0 ) ) - DOUBLE PRECISION RZERO, RONE - PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) -* .. -* .. Local Scalars .. - COMPLEX*16 BETA, CDUM, S, TAU - DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP - INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, - $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, - $ ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNGHR -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN -* .. -* .. Statement Functions .. - DOUBLE PRECISION CABS1 -* .. -* .. Statement Function definitions .. - CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) -* .. -* .. Executable Statements .. -* -* ==== Estimate optimal workspace. ==== -* - JW = MIN( NW, KBOT-KTOP+1 ) - IF( JW.LE.2 ) THEN - LWKOPT = 1 - ELSE -* -* ==== Workspace query call to ZGEHRD ==== -* - CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) - LWK1 = INT( WORK( 1 ) ) -* -* ==== Workspace query call to ZUNGHR ==== -* - CALL ZUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) - LWK2 = INT( WORK( 1 ) ) -* -* ==== Optimal workspace ==== -* - LWKOPT = JW + MAX( LWK1, LWK2 ) - END IF -* -* ==== Quick return in case of workspace query. ==== -* - IF( LWORK.EQ.-1 ) THEN - WORK( 1 ) = DCMPLX( LWKOPT, 0 ) - RETURN - END IF -* -* ==== Nothing to do ... -* ... for an empty active block ... ==== - NS = 0 - ND = 0 - IF( KTOP.GT.KBOT ) - $ RETURN -* ... nor for an empty deflation window. ==== - IF( NW.LT.1 ) - $ RETURN -* -* ==== Machine constants ==== -* - SAFMIN = DLAMCH( 'SAFE MINIMUM' ) - SAFMAX = RONE / SAFMIN - CALL DLABAD( SAFMIN, SAFMAX ) - ULP = DLAMCH( 'PRECISION' ) - SMLNUM = SAFMIN*( DBLE( N ) / ULP ) -* -* ==== Setup deflation window ==== -* - JW = MIN( NW, KBOT-KTOP+1 ) - KWTOP = KBOT - JW + 1 - IF( KWTOP.EQ.KTOP ) THEN - S = ZERO - ELSE - S = H( KWTOP, KWTOP-1 ) - END IF -* - IF( KBOT.EQ.KWTOP ) THEN -* -* ==== 1-by-1 deflation window: not much to do ==== -* - SH( KWTOP ) = H( KWTOP, KWTOP ) - NS = 1 - ND = 0 - IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, - $ KWTOP ) ) ) ) THEN - NS = 0 - ND = 1 - IF( KWTOP.GT.KTOP ) - $ H( KWTOP, KWTOP-1 ) = ZERO - END IF - RETURN - END IF -* -* ==== Convert to spike-triangular form. (In case of a -* . rare QR failure, this routine continues to do -* . aggressive early deflation using that part of -* . the deflation window that converged using INFQR -* . here and there to keep track.) ==== -* - CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) - CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) -* - CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) - CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, - $ JW, V, LDV, INFQR ) -* -* ==== Deflation detection loop ==== -* - NS = JW - ILST = INFQR + 1 - DO 10 KNT = INFQR + 1, JW -* -* ==== Small spike tip deflation test ==== -* - FOO = CABS1( T( NS, NS ) ) - IF( FOO.EQ.RZERO ) - $ FOO = CABS1( S ) - IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) - $ THEN -* -* ==== One more converged eigenvalue ==== -* - NS = NS - 1 - ELSE -* -* ==== One undflatable eigenvalue. Move it up out of the -* . way. (ZTREXC can not fail in this case.) ==== -* - IFST = NS - CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) - ILST = ILST + 1 - END IF - 10 CONTINUE -* -* ==== Return to Hessenberg form ==== -* - IF( NS.EQ.0 ) - $ S = ZERO -* - IF( NS.LT.JW ) THEN -* -* ==== sorting the diagonal of T improves accuracy for -* . graded matrices. ==== -* - DO 30 I = INFQR + 1, NS - IFST = I - DO 20 J = I + 1, NS - IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) - $ IFST = J - 20 CONTINUE - ILST = I - IF( IFST.NE.ILST ) - $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) - 30 CONTINUE - END IF -* -* ==== Restore shift/eigenvalue array from T ==== -* - DO 40 I = INFQR + 1, JW - SH( KWTOP+I-1 ) = T( I, I ) - 40 CONTINUE -* -* - IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN - IF( NS.GT.1 .AND. S.NE.ZERO ) THEN -* -* ==== Reflect spike back into lower triangle ==== -* - CALL ZCOPY( NS, V, LDV, WORK, 1 ) - DO 50 I = 1, NS - WORK( I ) = DCONJG( WORK( I ) ) - 50 CONTINUE - BETA = WORK( 1 ) - CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) - WORK( 1 ) = ONE -* - CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) -* - CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, - $ WORK( JW+1 ) ) - CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, - $ WORK( JW+1 ) ) -* - CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), - $ LWORK-JW, INFO ) - END IF -* -* ==== Copy updated reduced window into place ==== -* - IF( KWTOP.GT.1 ) - $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) - CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) - CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), - $ LDH+1 ) -* -* ==== Accumulate orthogonal matrix in order update -* . H and Z, if requested. (A modified version -* . of ZUNGHR that accumulates block Householder -* . transformations into V directly might be -* . marginally more efficient than the following.) ==== -* - IF( NS.GT.1 .AND. S.NE.ZERO ) THEN - CALL ZUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), - $ LWORK-JW, INFO ) - CALL ZGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, - $ WV, LDWV ) - CALL ZLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) - END IF -* -* ==== Update vertical slab in H ==== -* - IF( WANTT ) THEN - LTOP = 1 - ELSE - LTOP = KTOP - END IF - DO 60 KROW = LTOP, KWTOP - 1, NV - KLN = MIN( NV, KWTOP-KROW ) - CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), - $ LDH, V, LDV, ZERO, WV, LDWV ) - CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) - 60 CONTINUE -* -* ==== Update horizontal slab in H ==== -* - IF( WANTT ) THEN - DO 70 KCOL = KBOT + 1, N, NH - KLN = MIN( NH, N-KCOL+1 ) - CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, - $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) - CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), - $ LDH ) - 70 CONTINUE - END IF -* -* ==== Update vertical slab in Z ==== -* - IF( WANTZ ) THEN - DO 80 KROW = ILOZ, IHIZ, NV - KLN = MIN( NV, IHIZ-KROW+1 ) - CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), - $ LDZ, V, LDV, ZERO, WV, LDWV ) - CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), - $ LDZ ) - 80 CONTINUE - END IF - END IF -* -* ==== Return the number of deflations ... ==== -* - ND = JW - NS -* -* ==== ... and the number of shifts. (Subtracting -* . INFQR from the spike length takes care -* . of the case of a rare QR failure while -* . calculating eigenvalues of the deflation -* . window.) ==== -* - NS = NS - INFQR -* -* ==== Return optimal workspace. ==== -* - WORK( 1 ) = DCMPLX( LWKOPT, 0 ) -* -* ==== End of ZLAQR2 ==== -* - END - - SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - COMPLEX*16 S1, S2 - INTEGER LDH, N -* .. -* .. Array Arguments .. - COMPLEX*16 H( LDH, * ), V( * ) -* .. -* -* Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a -* scalar multiple of the first column of the product -* -* (*) K = (H - s1*I)*(H - s2*I) -* -* scaling to avoid overflows and most underflows. -* -* This is useful for starting double implicit shift bulges -* in the QR algorithm. -* -* -* N (input) integer -* Order of the matrix H. N must be either 2 or 3. -* -* H (input) COMPLEX*16 array of dimension (LDH,N) -* The 2-by-2 or 3-by-3 matrix H in (*). -* -* LDH (input) integer -* The leading dimension of H as declared in -* the calling procedure. LDH.GE.N -* -* S1 (input) COMPLEX*16 -* S2 S1 and S2 are the shifts defining K in (*) above. -* -* V (output) COMPLEX*16 array of dimension N -* A scalar multiple of the first column of the -* matrix K in (*). -* -* ================================================================ -* Based on contributions by -* Karen Braman and Ralph Byers, Department of Mathematics, -* University of Kansas, USA -* -* ================================================================ -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ) ) - DOUBLE PRECISION RZERO - PARAMETER ( RZERO = 0.0d0 ) -* .. -* .. Local Scalars .. - COMPLEX*16 CDUM - DOUBLE PRECISION H21S, H31S, S -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DIMAG -* .. -* .. Statement Functions .. - DOUBLE PRECISION CABS1 -* .. -* .. Statement Function definitions .. - CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) -* .. -* .. Executable Statements .. - IF( N.EQ.2 ) THEN - S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) - IF( S.EQ.RZERO ) THEN - V( 1 ) = ZERO - V( 2 ) = ZERO - ELSE - H21S = H( 2, 1 ) / S - V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-S1 )* - $ ( ( H( 1, 1 )-S2 ) / S ) - V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) - END IF - ELSE - S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) + - $ CABS1( H( 3, 1 ) ) - IF( S.EQ.ZERO ) THEN - V( 1 ) = ZERO - V( 2 ) = ZERO - V( 3 ) = ZERO - ELSE - H21S = H( 2, 1 ) / S - H31S = H( 3, 1 ) / S - V( 1 ) = ( H( 1, 1 )-S1 )*( ( H( 1, 1 )-S2 ) / S ) + - $ H( 1, 2 )*H21S + H( 1, 3 )*H31S - V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + H( 2, 3 )*H31S - V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-S1-S2 ) + H21S*H( 3, 2 ) - END IF - END IF - END - - SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, - $ WORK, LWORK, INFO ) -* -* -- LAPACK driver routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER JOBU, JOBVT - INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), - $ VT( LDVT, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGESVD computes the singular value decomposition (SVD) of a real -* M-by-N matrix A, optionally computing the left and/or right singular -* vectors. The SVD is written -* -* A = U * SIGMA * transpose(V) -* -* where SIGMA is an M-by-N matrix which is zero except for its -* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and -* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA -* are the singular values of A; they are real and non-negative, and -* are returned in descending order. The first min(m,n) columns of -* U and V are the left and right singular vectors of A. -* -* Note that the routine returns V**T, not V. -* -* Arguments -* ========= -* -* JOBU (input) CHARACTER*1 -* Specifies options for computing all or part of the matrix U: -* = 'A': all M columns of U are returned in array U: -* = 'S': the first min(m,n) columns of U (the left singular -* vectors) are returned in the array U; -* = 'O': the first min(m,n) columns of U (the left singular -* vectors) are overwritten on the array A; -* = 'N': no columns of U (no left singular vectors) are -* computed. -* -* JOBVT (input) CHARACTER*1 -* Specifies options for computing all or part of the matrix -* V**T: -* = 'A': all N rows of V**T are returned in the array VT; -* = 'S': the first min(m,n) rows of V**T (the right singular -* vectors) are returned in the array VT; -* = 'O': the first min(m,n) rows of V**T (the right singular -* vectors) are overwritten on the array A; -* = 'N': no rows of V**T (no right singular vectors) are -* computed. -* -* JOBVT and JOBU cannot both be 'O'. -* -* M (input) INTEGER -* The number of rows of the input matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the input matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix A. -* On exit, -* if JOBU = 'O', A is overwritten with the first min(m,n) -* columns of U (the left singular vectors, -* stored columnwise); -* if JOBVT = 'O', A is overwritten with the first min(m,n) -* rows of V**T (the right singular vectors, -* stored rowwise); -* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A -* are destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* S (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The singular values of A, sorted so that S(i) >= S(i+1). -* -* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL) -* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. -* If JOBU = 'A', U contains the M-by-M orthogonal matrix U; -* if JOBU = 'S', U contains the first min(m,n) columns of U -* (the left singular vectors, stored columnwise); -* if JOBU = 'N' or 'O', U is not referenced. -* -* LDU (input) INTEGER -* The leading dimension of the array U. LDU >= 1; if -* JOBU = 'S' or 'A', LDU >= M. -* -* VT (output) DOUBLE PRECISION array, dimension (LDVT,N) -* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix -* V**T; -* if JOBVT = 'S', VT contains the first min(m,n) rows of -* V**T (the right singular vectors, stored rowwise); -* if JOBVT = 'N' or 'O', VT is not referenced. -* -* LDVT (input) INTEGER -* The leading dimension of the array VT. LDVT >= 1; if -* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK; -* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged -* superdiagonal elements of an upper bidiagonal matrix B -* whose diagonal is in S (not necessarily sorted). B -* satisfies A = U * B * VT, so it has the same singular values -* as A, and singular vectors related by U and VT. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)). -* For good performance, LWORK should generally be larger. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* > 0: if DBDSQR did not converge, INFO specifies how many -* superdiagonals of an intermediate bidiagonal form B -* did not converge to zero. See the description of WORK -* above for details. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, - $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS - INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL, - $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, - $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, - $ NRVT, WRKBL - DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM -* .. -* .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ) -* .. -* .. External Subroutines .. - EXTERNAL DBDSQR, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY, - $ DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR, - $ XERBLA -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - MINMN = MIN( M, N ) - WNTUA = LSAME( JOBU, 'A' ) - WNTUS = LSAME( JOBU, 'S' ) - WNTUAS = WNTUA .OR. WNTUS - WNTUO = LSAME( JOBU, 'O' ) - WNTUN = LSAME( JOBU, 'N' ) - WNTVA = LSAME( JOBVT, 'A' ) - WNTVS = LSAME( JOBVT, 'S' ) - WNTVAS = WNTVA .OR. WNTVS - WNTVO = LSAME( JOBVT, 'O' ) - WNTVN = LSAME( JOBVT, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* - IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN - INFO = -1 - ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR. - $ ( WNTVO .AND. WNTUO ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN - INFO = -9 - ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR. - $ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN - INFO = -11 - END IF -* -* Compute workspace -* (Note: Comments in the code beginning "Workspace:" describe the -* minimal amount of workspace needed at that point in the code, -* as well as the preferred amount for good performance. -* NB refers to the optimal block size for the immediately -* following subroutine, as returned by ILAENV.) -* - IF( INFO.EQ.0 ) THEN - MINWRK = 1 - MAXWRK = 1 - IF( M.GE.N .AND. MINMN.GT.0 ) THEN -* -* Compute space needed for DBDSQR -* - MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) - BDSPAC = 5*N - IF( M.GE.MNTHR ) THEN - IF( WNTUN ) THEN -* -* Path 1 (M much larger than N, JOBU='N') -* - MAXWRK = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, - $ -1 ) - MAXWRK = MAX( MAXWRK, 3*N+2*N* - $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - IF( WNTVO .OR. WNTVAS ) - $ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* - $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 4*N, BDSPAC ) - ELSE IF( WNTUO .AND. WNTVN ) THEN -* -* Path 2 (M much larger than N, JOBU='O', JOBVT='N') -* - WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N ) - MINWRK = MAX( 3*N+M, BDSPAC ) - ELSE IF( WNTUO .AND. WNTVAS ) THEN -* -* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or -* 'A') -* - WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+( N-1 )* - $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N ) - MINWRK = MAX( 3*N+M, BDSPAC ) - ELSE IF( WNTUS .AND. WNTVN ) THEN -* -* Path 4 (M much larger than N, JOBU='S', JOBVT='N') -* - WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) - ELSE IF( WNTUS .AND. WNTVO ) THEN -* -* Path 5 (M much larger than N, JOBU='S', JOBVT='O') -* - WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+( N-1 )* - $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = 2*N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) - ELSE IF( WNTUS .AND. WNTVAS ) THEN -* -* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or -* 'A') -* - WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, - $ N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+( N-1 )* - $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) - ELSE IF( WNTUA .AND. WNTVN ) THEN -* -* Path 7 (M much larger than N, JOBU='A', JOBVT='N') -* - WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M, - $ M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) - ELSE IF( WNTUA .AND. WNTVO ) THEN -* -* Path 8 (M much larger than N, JOBU='A', JOBVT='O') -* - WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M, - $ M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+( N-1 )* - $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = 2*N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) - ELSE IF( WNTUA .AND. WNTVAS ) THEN -* -* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or -* 'A') -* - WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M, - $ M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+( N-1 )* - $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N+M, BDSPAC ) - END IF - ELSE -* -* Path 10 (M at least N, but not much larger) -* - MAXWRK = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, - $ -1, -1 ) - IF( WNTUS .OR. WNTUO ) - $ MAXWRK = MAX( MAXWRK, 3*N+N* - $ ILAENV( 1, 'DORGBR', 'Q', M, N, N, -1 ) ) - IF( WNTUA ) - $ MAXWRK = MAX( MAXWRK, 3*N+M* - $ ILAENV( 1, 'DORGBR', 'Q', M, M, N, -1 ) ) - IF( .NOT.WNTVN ) - $ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* - $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 3*N+M, BDSPAC ) - END IF - ELSE IF( MINMN.GT.0 ) THEN -* -* Compute space needed for DBDSQR -* - MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) - BDSPAC = 5*M - IF( N.GE.MNTHR ) THEN - IF( WNTVN ) THEN -* -* Path 1t(N much larger than M, JOBVT='N') -* - MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, - $ -1 ) - MAXWRK = MAX( MAXWRK, 3*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - IF( WNTUO .OR. WNTUAS ) - $ MAXWRK = MAX( MAXWRK, 3*M+M* - $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 4*M, BDSPAC ) - ELSE IF( WNTVO .AND. WNTUN ) THEN -* -* Path 2t(N much larger than M, JOBU='N', JOBVT='O') -* - WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+( M-1 )* - $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M ) - MINWRK = MAX( 3*M+N, BDSPAC ) - ELSE IF( WNTVO .AND. WNTUAS ) THEN -* -* Path 3t(N much larger than M, JOBU='S' or 'A', -* JOBVT='O') -* - WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+( M-1 )* - $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M ) - MINWRK = MAX( 3*M+N, BDSPAC ) - ELSE IF( WNTVS .AND. WNTUN ) THEN -* -* Path 4t(N much larger than M, JOBU='N', JOBVT='S') -* - WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+( M-1 )* - $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) - ELSE IF( WNTVS .AND. WNTUO ) THEN -* -* Path 5t(N much larger than M, JOBU='O', JOBVT='S') -* - WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+( M-1 )* - $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = 2*M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) - ELSE IF( WNTVS .AND. WNTUAS ) THEN -* -* Path 6t(N much larger than M, JOBU='S' or 'A', -* JOBVT='S') -* - WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+( M-1 )* - $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) - ELSE IF( WNTVA .AND. WNTUN ) THEN -* -* Path 7t(N much larger than M, JOBU='N', JOBVT='A') -* - WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+( M-1 )* - $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) - ELSE IF( WNTVA .AND. WNTUO ) THEN -* -* Path 8t(N much larger than M, JOBU='O', JOBVT='A') -* - WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+( M-1 )* - $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = 2*M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) - ELSE IF( WNTVA .AND. WNTUAS ) THEN -* -* Path 9t(N much larger than M, JOBU='S' or 'A', -* JOBVT='A') -* - WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N, - $ N, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+( M-1 )* - $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M+N, BDSPAC ) - END IF - ELSE -* -* Path 10t(N greater than M, but not much larger) -* - MAXWRK = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, - $ -1, -1 ) - IF( WNTVS .OR. WNTVO ) - $ MAXWRK = MAX( MAXWRK, 3*M+M* - $ ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 ) ) - IF( WNTVA ) - $ MAXWRK = MAX( MAXWRK, 3*M+N* - $ ILAENV( 1, 'DORGBR', 'P', N, N, M, -1 ) ) - IF( .NOT.WNTUN ) - $ MAXWRK = MAX( MAXWRK, 3*M+( M-1 )* - $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 3*M+N, BDSPAC ) - END IF - END IF - MAXWRK = MAX( MAXWRK, MINWRK ) - WORK( 1 ) = MAXWRK -* - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGESVD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - RETURN - END IF -* -* Get machine constants -* - EPS = DLAMCH( 'P' ) - SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS - BIGNUM = ONE / SMLNUM -* -* Scale A if max element outside range [SMLNUM,BIGNUM] -* - ANRM = DLANGE( 'M', M, N, A, LDA, DUM ) - ISCL = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN - ISCL = 1 - CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR ) - ELSE IF( ANRM.GT.BIGNUM ) THEN - ISCL = 1 - CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR ) - END IF -* - IF( M.GE.N ) THEN -* -* A has at least as many rows as columns. If A has sufficiently -* more rows than columns, first reduce using the QR -* decomposition (if sufficient workspace available) -* - IF( M.GE.MNTHR ) THEN -* - IF( WNTUN ) THEN -* -* Path 1 (M much larger than N, JOBU='N') -* No left singular vectors to be computed -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Zero out below R -* - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) - IE = 1 - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) -* - CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ IERR ) - NCVT = 0 - IF( WNTVO .OR. WNTVAS ) THEN -* -* If right singular vectors desired, generate P'. -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - NCVT = N - END IF - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in A if desired -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, NCVT, 0, 0, S, WORK( IE ), A, LDA, - $ DUM, 1, DUM, 1, WORK( IWORK ), INFO ) -* -* If right singular vectors desired in VT, copy them there -* - IF( WNTVAS ) - $ CALL DLACPY( 'F', N, N, A, LDA, VT, LDVT ) -* - ELSE IF( WNTUO .AND. WNTVN ) THEN -* -* Path 2 (M much larger than N, JOBU='O', JOBVT='N') -* N left singular vectors to be overwritten on A and -* no right singular vectors to be computed -* - IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN -* -* WORK(IU) is LDA by N, WORK(IR) is LDA by N -* - LDWRKU = LDA - LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN -* -* WORK(IU) is LDA by N, WORK(IR) is N by N -* - LDWRKU = LDA - LDWRKR = N - ELSE -* -* WORK(IU) is LDWRKU by N, WORK(IR) is N by N -* - LDWRKU = ( LWORK-N*N-N ) / N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IR) and zero out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ), - $ LDWRKR ) -* -* Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) -* - CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) -* - CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left vectors bidiagonalizing R -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IR) -* (Workspace: need N*N+BDSPAC) -* - CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1, - $ WORK( IR ), LDWRKR, DUM, 1, - $ WORK( IWORK ), INFO ) - IU = IE + N -* -* Multiply Q in A by left singular vectors of R in -* WORK(IR), storing result in WORK(IU) and copying to A -* (Workspace: need N*N+2*N, prefer N*N+M*N+N) -* - DO 10 I = 1, M, LDWRKU - CHUNK = MIN( M-I+1, LDWRKU ) - CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), - $ LDA, WORK( IR ), LDWRKR, ZERO, - $ WORK( IU ), LDWRKU ) - CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, - $ A( I, 1 ), LDA ) - 10 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - IE = 1 - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize A -* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) -* - CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left vectors bidiagonalizing A -* (Workspace: need 4*N, prefer 3*N+N*NB) -* - CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, 1, - $ A, LDA, DUM, 1, WORK( IWORK ), INFO ) -* - END IF -* - ELSE IF( WNTUO .AND. WNTVAS ) THEN -* -* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A') -* N left singular vectors to be overwritten on A and -* N right singular vectors to be computed in VT -* - IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by N -* - LDWRKU = LDA - LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is N by N -* - LDWRKU = LDA - LDWRKR = N - ELSE -* -* WORK(IU) is LDWRKU by N and WORK(IR) is N by N -* - LDWRKU = ( LWORK-N*N-N ) / N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to VT, zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - IF( N.GT.1 ) - $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ VT( 2, 1 ), LDVT ) -* -* Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) -* - CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in VT, copying result to WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) -* - CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR ) -* -* Generate left vectors bidiagonalizing R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing R in VT -* (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IR) and computing right -* singular vectors of R in VT -* (Workspace: need N*N+BDSPAC) -* - CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT, - $ WORK( IR ), LDWRKR, DUM, 1, - $ WORK( IWORK ), INFO ) - IU = IE + N -* -* Multiply Q in A by left singular vectors of R in -* WORK(IR), storing result in WORK(IU) and copying to A -* (Workspace: need N*N+2*N, prefer N*N+M*N+N) -* - DO 20 I = 1, M, LDWRKU - CHUNK = MIN( M-I+1, LDWRKU ) - CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), - $ LDA, WORK( IR ), LDWRKR, ZERO, - $ WORK( IU ), LDWRKU ) - CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, - $ A( I, 1 ), LDA ) - 20 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to VT, zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - IF( N.GT.1 ) - $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ VT( 2, 1 ), LDVT ) -* -* Generate Q in A -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in VT -* (Workspace: need 4*N, prefer 3*N+2*N*NB) -* - CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in A by left vectors bidiagonalizing R -* (Workspace: need 3*N+M, prefer 3*N+M*NB) -* - CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, - $ WORK( ITAUQ ), A, LDA, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing R in VT -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in A and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, LDVT, - $ A, LDA, DUM, 1, WORK( IWORK ), INFO ) -* - END IF -* - ELSE IF( WNTUS ) THEN -* - IF( WNTVN ) THEN -* -* Path 4 (M much larger than N, JOBU='S', JOBVT='N') -* N left singular vectors to be computed in U and -* no right singular vectors to be computed -* - IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IR) is LDA by N -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is N by N -* - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IR), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IR+1 ), LDWRKR ) -* -* Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) -* - CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) -* - CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left vectors bidiagonalizing R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IR) -* (Workspace: need N*N+BDSPAC) -* - CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, - $ 1, WORK( IR ), LDWRKR, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply Q in A by left singular vectors of R in -* WORK(IR), storing result in U -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, - $ WORK( IR ), LDWRKR, ZERO, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) -* -* Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) -* - CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left vectors bidiagonalizing R -* (Workspace: need 3*N+M, prefer 3*N+M*NB) -* - CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, - $ 1, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVO ) THEN -* -* Path 5 (M much larger than N, JOBU='S', JOBVT='O') -* N left singular vectors to be computed in U and -* N right singular vectors to be overwritten on A -* - IF( LWORK.GE.2*N*N+MAX( 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is N by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = N - ELSE -* -* WORK(IU) is N by N and WORK(IR) is N by N -* - LDWRKU = N - IR = IU + LDWRKU*N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IU+1 ), LDWRKU ) -* -* Generate Q in A -* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) -* - CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IU), copying result to -* WORK(IR) -* (Workspace: need 2*N*N+4*N, -* prefer 2*N*N+3*N+2*N*NB) -* - CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, - $ WORK( IR ), LDWRKR ) -* -* Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*N*N+4*N-1, -* prefer 2*N*N+3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IU) and computing -* right singular vectors of R in WORK(IR) -* (Workspace: need 2*N*N+BDSPAC) -* - CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, WORK( IU ), - $ LDWRKU, DUM, 1, WORK( IWORK ), INFO ) -* -* Multiply Q in A by left singular vectors of R in -* WORK(IU), storing result in U -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, - $ WORK( IU ), LDWRKU, ZERO, U, LDU ) -* -* Copy right singular vectors of R to A -* (Workspace: need N*N) -* - CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) -* -* Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) -* - CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left vectors bidiagonalizing R -* (Workspace: need 3*N+M, prefer 3*N+M*NB) -* - CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing R in A -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A, - $ LDA, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVAS ) THEN -* -* Path 6 (M much larger than N, JOBU='S', JOBVT='S' -* or 'A') -* N left singular vectors to be computed in U and -* N right singular vectors to be computed in VT -* - IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IU) is LDA by N -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is N by N -* - LDWRKU = N - END IF - ITAU = IU + LDWRKU*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IU+1 ), LDWRKU ) -* -* Generate Q in A -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) -* - CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IU), copying result to VT -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) -* - CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, - $ LDVT ) -* -* Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in VT -* (Workspace: need N*N+4*N-1, -* prefer N*N+3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IU) and computing -* right singular vectors of R in VT -* (Workspace: need N*N+BDSPAC) -* - CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, - $ LDVT, WORK( IU ), LDWRKU, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply Q in A by left singular vectors of R in -* WORK(IU), storing result in U -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, - $ WORK( IU ), LDWRKU, ZERO, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to VT, zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - IF( N.GT.1 ) - $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ VT( 2, 1 ), LDVT ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in VT -* (Workspace: need 4*N, prefer 3*N+2*N*NB) -* - CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left bidiagonalizing vectors -* in VT -* (Workspace: need 3*N+M, prefer 3*N+M*NB) -* - CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in VT -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - END IF -* - ELSE IF( WNTUA ) THEN -* - IF( WNTVN ) THEN -* -* Path 7 (M much larger than N, JOBU='A', JOBVT='N') -* M left singular vectors to be computed in U and -* no right singular vectors to be computed -* - IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IR) is LDA by N -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is N by N -* - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Copy R to WORK(IR), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IR+1 ), LDWRKR ) -* -* Generate Q in U -* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) -* - CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in WORK(IR) -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IR) -* (Workspace: need N*N+BDSPAC) -* - CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, - $ 1, WORK( IR ), LDWRKR, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply Q in U by left singular vectors of R in -* WORK(IR), storing result in A -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, - $ WORK( IR ), LDWRKR, ZERO, A, LDA ) -* -* Copy left singular vectors of A from A to U -* - CALL DLACPY( 'F', M, N, A, LDA, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need N+M, prefer N+M*NB) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) -* -* Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) -* - CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left bidiagonalizing vectors -* in A -* (Workspace: need 3*N+M, prefer 3*N+M*NB) -* - CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, - $ 1, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVO ) THEN -* -* Path 8 (M much larger than N, JOBU='A', JOBVT='O') -* M left singular vectors to be computed in U and -* N right singular vectors to be overwritten on A -* - IF( LWORK.GE.2*N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is N by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = N - ELSE -* -* WORK(IU) is N by N and WORK(IR) is N by N -* - LDWRKU = N - IR = IU + LDWRKU*N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IU+1 ), LDWRKU ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IU), copying result to -* WORK(IR) -* (Workspace: need 2*N*N+4*N, -* prefer 2*N*N+3*N+2*N*NB) -* - CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, - $ WORK( IR ), LDWRKR ) -* -* Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*N*N+4*N-1, -* prefer 2*N*N+3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IU) and computing -* right singular vectors of R in WORK(IR) -* (Workspace: need 2*N*N+BDSPAC) -* - CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, WORK( IU ), - $ LDWRKU, DUM, 1, WORK( IWORK ), INFO ) -* -* Multiply Q in U by left singular vectors of R in -* WORK(IU), storing result in A -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, - $ WORK( IU ), LDWRKU, ZERO, A, LDA ) -* -* Copy left singular vectors of A from A to U -* - CALL DLACPY( 'F', M, N, A, LDA, U, LDU ) -* -* Copy right singular vectors of R from WORK(IR) to A -* - CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need N+M, prefer N+M*NB) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) -* -* Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N+2*N*NB) -* - CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left bidiagonalizing vectors -* in A -* (Workspace: need 3*N+M, prefer 3*N+M*NB) -* - CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in A -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A, - $ LDA, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVAS ) THEN -* -* Path 9 (M much larger than N, JOBU='A', JOBVT='S' -* or 'A') -* M left singular vectors to be computed in U and -* N right singular vectors to be computed in VT -* - IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IU) is LDA by N -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is N by N -* - LDWRKU = N - END IF - ITAU = IU + LDWRKU*N - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IU+1 ), LDWRKU ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IU), copying result to VT -* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) -* - CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, - $ LDVT ) -* -* Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in VT -* (Workspace: need N*N+4*N-1, -* prefer N*N+3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IU) and computing -* right singular vectors of R in VT -* (Workspace: need N*N+BDSPAC) -* - CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, - $ LDVT, WORK( IU ), LDWRKU, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply Q in U by left singular vectors of R in -* WORK(IU), storing result in A -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, - $ WORK( IU ), LDWRKU, ZERO, A, LDA ) -* -* Copy left singular vectors of A from A to U -* - CALL DLACPY( 'F', M, N, A, LDA, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need N+M, prefer N+M*NB) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R from A to VT, zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - IF( N.GT.1 ) - $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ VT( 2, 1 ), LDVT ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in VT -* (Workspace: need 4*N, prefer 3*N+2*N*NB) -* - CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left bidiagonalizing vectors -* in VT -* (Workspace: need 3*N+M, prefer 3*N+M*NB) -* - CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in VT -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - END IF -* - END IF -* - ELSE -* -* M .LT. MNTHR -* -* Path 10 (M at least N, but not much larger) -* Reduce to bidiagonal form without QR decomposition -* - IE = 1 - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize A -* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) -* - CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ IERR ) - IF( WNTUAS ) THEN -* -* If left singular vectors desired in U, copy result to U -* and generate left bidiagonalizing vectors in U -* (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB) -* - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) - IF( WNTUS ) - $ NCU = N - IF( WNTUA ) - $ NCU = M - CALL DORGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTVAS ) THEN -* -* If right singular vectors desired in VT, copy result to -* VT and generate right bidiagonalizing vectors in VT -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) -* - CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTUO ) THEN -* -* If left singular vectors desired in A, generate left -* bidiagonalizing vectors in A -* (Workspace: need 4*N, prefer 3*N+N*NB) -* - CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTVO ) THEN -* -* If right singular vectors desired in A, generate right -* bidiagonalizing vectors in A -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IWORK = IE + N - IF( WNTUAS .OR. WNTUO ) - $ NRU = M - IF( WNTUN ) - $ NRU = 0 - IF( WNTVAS .OR. WNTVO ) - $ NCVT = N - IF( WNTVN ) - $ NCVT = 0 - IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO ) - ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), A, LDA, - $ U, LDU, DUM, 1, WORK( IWORK ), INFO ) - ELSE -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in A and computing right singular -* vectors in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT, - $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO ) - END IF -* - END IF -* - ELSE -* -* A has more columns than rows. If A has sufficiently more -* columns than rows, first reduce using the LQ decomposition (if -* sufficient workspace available) -* - IF( N.GE.MNTHR ) THEN -* - IF( WNTVN ) THEN -* -* Path 1t(N much larger than M, JOBVT='N') -* No right singular vectors to be computed -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Zero out above L -* - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA ) - IE = 1 - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) -* - CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ IERR ) - IF( WNTUO .OR. WNTUAS ) THEN -* -* If left singular vectors desired, generate Q -* (Workspace: need 4*M, prefer 3*M+M*NB) -* - CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IWORK = IE + M - NRU = 0 - IF( WNTUO .OR. WNTUAS ) - $ NRU = M -* -* Perform bidiagonal QR iteration, computing left singular -* vectors of A in A if desired -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, 0, NRU, 0, S, WORK( IE ), DUM, 1, A, - $ LDA, DUM, 1, WORK( IWORK ), INFO ) -* -* If left singular vectors desired in U, copy them there -* - IF( WNTUAS ) - $ CALL DLACPY( 'F', M, M, A, LDA, U, LDU ) -* - ELSE IF( WNTVO .AND. WNTUN ) THEN -* -* Path 2t(N much larger than M, JOBU='N', JOBVT='O') -* M right singular vectors to be overwritten on A and -* no left singular vectors to be computed -* - IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by M -* - LDWRKU = LDA - CHUNK = N - LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is M by M -* - LDWRKU = LDA - CHUNK = N - LDWRKR = M - ELSE -* -* WORK(IU) is M by CHUNK and WORK(IR) is M by M -* - LDWRKU = M - CHUNK = ( LWORK-M*M-M ) / M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IR) and zero out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IR+LDWRKR ), LDWRKR ) -* -* Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) -* - CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IR) -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) -* - CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing L -* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of L in WORK(IR) -* (Workspace: need M*M+BDSPAC) -* - CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, - $ WORK( IWORK ), INFO ) - IU = IE + M -* -* Multiply right singular vectors of L in WORK(IR) by Q -* in A, storing result in WORK(IU) and copying to A -* (Workspace: need M*M+2*M, prefer M*M+M*N+M) -* - DO 30 I = 1, N, CHUNK - BLK = MIN( N-I+1, CHUNK ) - CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ), - $ LDWRKR, A( 1, I ), LDA, ZERO, - $ WORK( IU ), LDWRKU ) - CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, - $ A( 1, I ), LDA ) - 30 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - IE = 1 - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize A -* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) -* - CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing A -* (Workspace: need 4*M, prefer 3*M+M*NB) -* - CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'L', M, N, 0, 0, S, WORK( IE ), A, LDA, - $ DUM, 1, DUM, 1, WORK( IWORK ), INFO ) -* - END IF -* - ELSE IF( WNTVO .AND. WNTUAS ) THEN -* -* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O') -* M right singular vectors to be overwritten on A and -* M left singular vectors to be computed in U -* - IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by M -* - LDWRKU = LDA - CHUNK = N - LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is M by M -* - LDWRKU = LDA - CHUNK = N - LDWRKR = M - ELSE -* -* WORK(IU) is M by CHUNK and WORK(IR) is M by M -* - LDWRKU = M - CHUNK = ( LWORK-M*M-M ) / M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to U, zeroing about above it -* - CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), - $ LDU ) -* -* Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) -* - CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in U, copying result to WORK(IR) -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) -* - CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR ) -* -* Generate right vectors bidiagonalizing L in WORK(IR) -* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left vectors bidiagonalizing L in U -* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of L in U, and computing right -* singular vectors of L in WORK(IR) -* (Workspace: need M*M+BDSPAC) -* - CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, U, LDU, DUM, 1, - $ WORK( IWORK ), INFO ) - IU = IE + M -* -* Multiply right singular vectors of L in WORK(IR) by Q -* in A, storing result in WORK(IU) and copying to A -* (Workspace: need M*M+2*M, prefer M*M+M*N+M)) -* - DO 40 I = 1, N, CHUNK - BLK = MIN( N-I+1, CHUNK ) - CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ), - $ LDWRKR, A( 1, I ), LDA, ZERO, - $ WORK( IU ), LDWRKU ) - CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, - $ A( 1, I ), LDA ) - 40 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to U, zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), - $ LDU ) -* -* Generate Q in A -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in U -* (Workspace: need 4*M, prefer 3*M+2*M*NB) -* - CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right vectors bidiagonalizing L by Q in A -* (Workspace: need 3*M+N, prefer 3*M+N*NB) -* - CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, - $ WORK( ITAUP ), A, LDA, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left vectors bidiagonalizing L in U -* (Workspace: need 4*M, prefer 3*M+M*NB) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), A, LDA, - $ U, LDU, DUM, 1, WORK( IWORK ), INFO ) -* - END IF -* - ELSE IF( WNTVS ) THEN -* - IF( WNTUN ) THEN -* -* Path 4t(N much larger than M, JOBU='N', JOBVT='S') -* M right singular vectors to be computed in VT and -* no left singular vectors to be computed -* - IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IR) is LDA by M -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is M by M -* - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IR), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IR+LDWRKR ), LDWRKR ) -* -* Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) -* - CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IR) -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) -* - CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing L in -* WORK(IR) -* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of L in WORK(IR) -* (Workspace: need M*M+BDSPAC) -* - CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IR) by -* Q in A, storing result in VT -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ), - $ LDWRKR, A, LDA, ZERO, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy result to VT -* - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), - $ LDA ) -* -* Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) -* - CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right vectors bidiagonalizing L by Q in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) -* - CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT, - $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTUO ) THEN -* -* Path 5t(N much larger than M, JOBU='O', JOBVT='S') -* M right singular vectors to be computed in VT and -* M left singular vectors to be overwritten on A -* - IF( LWORK.GE.2*M*M+MAX( 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is LDA by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is M by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = M - ELSE -* -* WORK(IU) is M by M and WORK(IR) is M by M -* - LDWRKU = M - IR = IU + LDWRKU*M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IU), zeroing out below it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) -* -* Generate Q in A -* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) -* - CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IU), copying result to -* WORK(IR) -* (Workspace: need 2*M*M+4*M, -* prefer 2*M*M+3*M+2*M*NB) -* - CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, - $ WORK( IR ), LDWRKR ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*M*M+4*M-1, -* prefer 2*M*M+3*M+(M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) -* - CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of L in WORK(IR) and computing -* right singular vectors of L in WORK(IU) -* (Workspace: need 2*M*M+BDSPAC) -* - CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), - $ WORK( IU ), LDWRKU, WORK( IR ), - $ LDWRKR, DUM, 1, WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in A, storing result in VT -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), - $ LDWRKU, A, LDA, ZERO, VT, LDVT ) -* -* Copy left singular vectors of L to A -* (Workspace: need M*M) -* - CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), - $ LDA ) -* -* Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) -* - CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right vectors bidiagonalizing L by Q in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) -* - CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors of L in A -* (Workspace: need 4*M, prefer 3*M+M*NB) -* - CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, compute left -* singular vectors of A in A and compute right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, - $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTUAS ) THEN -* -* Path 6t(N much larger than M, JOBU='S' or 'A', -* JOBVT='S') -* M right singular vectors to be computed in VT and -* M left singular vectors to be computed in U -* - IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IU) is LDA by N -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is LDA by M -* - LDWRKU = M - END IF - ITAU = IU + LDWRKU*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IU), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) -* -* Generate Q in A -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) -* - CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IU), copying result to U -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) -* - CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, - $ LDU ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need M*M+4*M-1, -* prefer M*M+3*M+(M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in U -* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of L in U and computing right -* singular vectors of L in WORK(IU) -* (Workspace: need M*M+BDSPAC) -* - CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), - $ WORK( IU ), LDWRKU, U, LDU, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in A, storing result in VT -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), - $ LDWRKU, A, LDA, ZERO, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to U, zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), - $ LDU ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in U -* (Workspace: need 4*M, prefer 3*M+2*M*NB) -* - CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right bidiagonalizing vectors in U by Q -* in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) -* - CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in U -* (Workspace: need 4*M, prefer 3*M+M*NB) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - END IF -* - ELSE IF( WNTVA ) THEN -* - IF( WNTUN ) THEN -* -* Path 7t(N much larger than M, JOBU='N', JOBVT='A') -* N right singular vectors to be computed in VT and -* no left singular vectors to be computed -* - IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IR) is LDA by M -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is M by M -* - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Copy L to WORK(IR), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IR+LDWRKR ), LDWRKR ) -* -* Generate Q in VT -* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IR) -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) -* - CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in WORK(IR) -* (Workspace: need M*M+4*M-1, -* prefer M*M+3*M+(M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of L in WORK(IR) -* (Workspace: need M*M+BDSPAC) -* - CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IR) by -* Q in VT, storing result in A -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ), - $ LDWRKR, VT, LDVT, ZERO, A, LDA ) -* -* Copy right singular vectors of A from A to VT -* - CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need M+N, prefer M+N*NB) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), - $ LDA ) -* -* Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) -* - CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right bidiagonalizing vectors in A by Q -* in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) -* - CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT, - $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTUO ) THEN -* -* Path 8t(N much larger than M, JOBU='O', JOBVT='A') -* N right singular vectors to be computed in VT and -* M left singular vectors to be overwritten on A -* - IF( LWORK.GE.2*M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is LDA by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is M by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = M - ELSE -* -* WORK(IU) is M by M and WORK(IR) is M by M -* - LDWRKU = M - IR = IU + LDWRKU*M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IU), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IU), copying result to -* WORK(IR) -* (Workspace: need 2*M*M+4*M, -* prefer 2*M*M+3*M+2*M*NB) -* - CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, - $ WORK( IR ), LDWRKR ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*M*M+4*M-1, -* prefer 2*M*M+3*M+(M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) -* - CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of L in WORK(IR) and computing -* right singular vectors of L in WORK(IU) -* (Workspace: need 2*M*M+BDSPAC) -* - CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), - $ WORK( IU ), LDWRKU, WORK( IR ), - $ LDWRKR, DUM, 1, WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in VT, storing result in A -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), - $ LDWRKU, VT, LDVT, ZERO, A, LDA ) -* -* Copy right singular vectors of A from A to VT -* - CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) -* -* Copy left singular vectors of A from WORK(IR) to A -* - CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need M+N, prefer M+N*NB) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), - $ LDA ) -* -* Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M+2*M*NB) -* - CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right bidiagonalizing vectors in A by Q -* in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) -* - CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in A -* (Workspace: need 4*M, prefer 3*M+M*NB) -* - CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in A and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, - $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTUAS ) THEN -* -* Path 9t(N much larger than M, JOBU='S' or 'A', -* JOBVT='A') -* N right singular vectors to be computed in VT and -* M left singular vectors to be computed in U -* - IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IU) is LDA by M -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is M by M -* - LDWRKU = M - END IF - ITAU = IU + LDWRKU*M - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IU), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IU), copying result to U -* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) -* - CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, - $ LDU ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in U -* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of L in U and computing right -* singular vectors of L in WORK(IU) -* (Workspace: need M*M+BDSPAC) -* - CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), - $ WORK( IU ), LDWRKU, U, LDU, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in VT, storing result in A -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), - $ LDWRKU, VT, LDVT, ZERO, A, LDA ) -* -* Copy right singular vectors of A from A to VT -* - CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need M+N, prefer M+N*NB) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to U, zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), - $ LDU ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in U -* (Workspace: need 4*M, prefer 3*M+2*M*NB) -* - CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right bidiagonalizing vectors in U by Q -* in VT -* (Workspace: need 3*M+N, prefer 3*M+N*NB) -* - CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in U -* (Workspace: need 4*M, prefer 3*M+M*NB) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - END IF -* - END IF -* - ELSE -* -* N .LT. MNTHR -* -* Path 10t(N greater than M, but not much larger) -* Reduce to bidiagonal form without LQ decomposition -* - IE = 1 - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize A -* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) -* - CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ IERR ) - IF( WNTUAS ) THEN -* -* If left singular vectors desired in U, copy result to U -* and generate left bidiagonalizing vectors in U -* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) -* - CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL DORGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTVAS ) THEN -* -* If right singular vectors desired in VT, copy result to -* VT and generate right bidiagonalizing vectors in VT -* (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB) -* - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) - IF( WNTVA ) - $ NRVT = N - IF( WNTVS ) - $ NRVT = M - CALL DORGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTUO ) THEN -* -* If left singular vectors desired in A, generate left -* bidiagonalizing vectors in A -* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) -* - CALL DORGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTVO ) THEN -* -* If right singular vectors desired in A, generate right -* bidiagonalizing vectors in A -* (Workspace: need 4*M, prefer 3*M+M*NB) -* - CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IWORK = IE + M - IF( WNTUAS .OR. WNTUO ) - $ NRU = M - IF( WNTUN ) - $ NRU = 0 - IF( WNTVAS .OR. WNTVO ) - $ NCVT = N - IF( WNTVN ) - $ NCVT = 0 - IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO ) - ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), A, LDA, - $ U, LDU, DUM, 1, WORK( IWORK ), INFO ) - ELSE -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in A and computing right singular -* vectors in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT, - $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO ) - END IF -* - END IF -* - END IF -* -* If DBDSQR failed to converge, copy unconverged superdiagonals -* to WORK( 2:MINMN ) -* - IF( INFO.NE.0 ) THEN - IF( IE.GT.2 ) THEN - DO 50 I = 1, MINMN - 1 - WORK( I+1 ) = WORK( I+IE-1 ) - 50 CONTINUE - END IF - IF( IE.LT.2 ) THEN - DO 60 I = MINMN - 1, 1, -1 - WORK( I+1 ) = WORK( I+IE-1 ) - 60 CONTINUE - END IF - END IF -* -* Undo scaling if necessary -* - IF( ISCL.EQ.1 ) THEN - IF( ANRM.GT.BIGNUM ) - $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, - $ IERR ) - IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) - $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, WORK( 2 ), - $ MINMN, IERR ) - IF( ANRM.LT.SMLNUM ) - $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, - $ IERR ) - IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) - $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, WORK( 2 ), - $ MINMN, IERR ) - END IF -* -* Return optimal workspace in WORK(1) -* - WORK( 1 ) = MAXWRK -* - RETURN -* -* End of DGESVD -* - END - - SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER VECT - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORGBR generates one of the real orthogonal matrices Q or P**T -* determined by DGEBRD when reducing a real matrix A to bidiagonal -* form: A = Q * B * P**T. Q and P**T are defined as products of -* elementary reflectors H(i) or G(i) respectively. -* -* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q -* is of order M: -* if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n -* columns of Q, where m >= n >= k; -* if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an -* M-by-M matrix. -* -* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T -* is of order N: -* if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m -* rows of P**T, where n >= m >= k; -* if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as -* an N-by-N matrix. -* -* Arguments -* ========= -* -* VECT (input) CHARACTER*1 -* Specifies whether the matrix Q or the matrix P**T is -* required, as defined in the transformation applied by DGEBRD: -* = 'Q': generate Q; -* = 'P': generate P**T. -* -* M (input) INTEGER -* The number of rows of the matrix Q or P**T to be returned. -* M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q or P**T to be returned. -* N >= 0. -* If VECT = 'Q', M >= N >= min(M,K); -* if VECT = 'P', N >= M >= min(N,K). -* -* K (input) INTEGER -* If VECT = 'Q', the number of columns in the original M-by-K -* matrix reduced by DGEBRD. -* If VECT = 'P', the number of rows in the original K-by-N -* matrix reduced by DGEBRD. -* K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the vectors which define the elementary reflectors, -* as returned by DGEBRD. -* On exit, the M-by-N matrix Q or P**T. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension -* (min(M,K)) if VECT = 'Q' -* (min(N,K)) if VECT = 'P' -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i) or G(i), which determines Q or P**T, as -* returned by DGEBRD in its array argument TAUQ or TAUP. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,min(M,N)). -* For optimum performance LWORK >= min(M,N)*NB, where NB -* is the optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, WANTQ - INTEGER I, IINFO, J, LWKOPT, MN, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DORGLQ, DORGQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - WANTQ = LSAME( VECT, 'Q' ) - MN = MIN( M, N ) - LQUERY = ( LWORK.EQ.-1 ) - IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M, - $ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT. - $ MIN( N, K ) ) ) ) THEN - INFO = -3 - ELSE IF( K.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN - INFO = -9 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( WANTQ ) THEN - NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) - ELSE - NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 ) - END IF - LWKOPT = MAX( 1, MN )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGBR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( WANTQ ) THEN -* -* Form Q, determined by a call to DGEBRD to reduce an m-by-k -* matrix -* - IF( M.GE.K ) THEN -* -* If m >= k, assume m >= n >= k -* - CALL DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* If m < k, assume m = n -* -* Shift the vectors which define the elementary reflectors one -* column to the right, and set the first row and column of Q -* to those of the unit matrix -* - DO 20 J = M, 2, -1 - A( 1, J ) = ZERO - DO 10 I = J + 1, M - A( I, J ) = A( I, J-1 ) - 10 CONTINUE - 20 CONTINUE - A( 1, 1 ) = ONE - DO 30 I = 2, M - A( I, 1 ) = ZERO - 30 CONTINUE - IF( M.GT.1 ) THEN -* -* Form Q(2:m,2:m) -* - CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - ELSE -* -* Form P', determined by a call to DGEBRD to reduce a k-by-n -* matrix -* - IF( K.LT.N ) THEN -* -* If k < n, assume k <= m <= n -* - CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* If k >= n, assume m = n -* -* Shift the vectors which define the elementary reflectors one -* row downward, and set the first row and column of P' to -* those of the unit matrix -* - A( 1, 1 ) = ONE - DO 40 I = 2, N - A( I, 1 ) = ZERO - 40 CONTINUE - DO 60 J = 2, N - DO 50 I = J - 1, 2, -1 - A( I, J ) = A( I-1, J ) - 50 CONTINUE - A( 1, J ) = ZERO - 60 CONTINUE - IF( N.GT.1 ) THEN -* -* Form P'(2:n,2:n) -* - CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORGBR -* - END - - SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, - $ LDU, C, LDC, WORK, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), - $ VT( LDVT, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DBDSQR computes the singular values and, optionally, the right and/or -* left singular vectors from the singular value decomposition (SVD) of -* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit -* zero-shift QR algorithm. The SVD of B has the form -* -* B = Q * S * P**T -* -* where S is the diagonal matrix of singular values, Q is an orthogonal -* matrix of left singular vectors, and P is an orthogonal matrix of -* right singular vectors. If left singular vectors are requested, this -* subroutine actually returns U*Q instead of Q, and, if right singular -* vectors are requested, this subroutine returns P**T*VT instead of -* P**T, for given real input matrices U and VT. When U and VT are the -* orthogonal matrices that reduce a general matrix A to bidiagonal -* form: A = U*B*VT, as computed by DGEBRD, then -* -* A = (U*Q) * S * (P**T*VT) -* -* is the SVD of A. Optionally, the subroutine may also compute Q**T*C -* for a given real input matrix C. -* -* See "Computing Small Singular Values of Bidiagonal Matrices With -* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, -* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, -* no. 5, pp. 873-912, Sept 1990) and -* "Accurate singular values and differential qd algorithms," by -* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics -* Department, University of California at Berkeley, July 1992 -* for a detailed description of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': B is upper bidiagonal; -* = 'L': B is lower bidiagonal. -* -* N (input) INTEGER -* The order of the matrix B. N >= 0. -* -* NCVT (input) INTEGER -* The number of columns of the matrix VT. NCVT >= 0. -* -* NRU (input) INTEGER -* The number of rows of the matrix U. NRU >= 0. -* -* NCC (input) INTEGER -* The number of columns of the matrix C. NCC >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the n diagonal elements of the bidiagonal matrix B. -* On exit, if INFO=0, the singular values of B in decreasing -* order. -* -* E (input/output) DOUBLE PRECISION array, dimension (N-1) -* On entry, the N-1 offdiagonal elements of the bidiagonal -* matrix B. -* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E -* will contain the diagonal and superdiagonal elements of a -* bidiagonal matrix orthogonally equivalent to the one given -* as input. -* -* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) -* On entry, an N-by-NCVT matrix VT. -* On exit, VT is overwritten by P**T * VT. -* Not referenced if NCVT = 0. -* -* LDVT (input) INTEGER -* The leading dimension of the array VT. -* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. -* -* U (input/output) DOUBLE PRECISION array, dimension (LDU, N) -* On entry, an NRU-by-N matrix U. -* On exit, U is overwritten by U * Q. -* Not referenced if NRU = 0. -* -* LDU (input) INTEGER -* The leading dimension of the array U. LDU >= max(1,NRU). -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) -* On entry, an N-by-NCC matrix C. -* On exit, C is overwritten by Q**T * C. -* Not referenced if NCC = 0. -* -* LDC (input) INTEGER -* The leading dimension of the array C. -* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) -* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: If INFO = -i, the i-th argument had an illegal value -* > 0: the algorithm did not converge; D and E contain the -* elements of a bidiagonal matrix which is orthogonally -* similar to the input matrix B; if INFO = i, i -* elements of E have not converged to zero. -* -* Internal Parameters -* =================== -* -* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) -* TOLMUL controls the convergence criterion of the QR loop. -* If it is positive, TOLMUL*EPS is the desired relative -* precision in the computed singular values. -* If it is negative, abs(TOLMUL*EPS*sigma_max) is the -* desired absolute accuracy in the computed singular -* values (corresponds to relative accuracy -* abs(TOLMUL*EPS) in the largest singular value. -* abs(TOLMUL) should be between 1 and 1/EPS, and preferably -* between 10 (for fast convergence) and .1/EPS -* (for there to be some accuracy in the results). -* Default is to lose at either one eighth or 2 of the -* available decimal digits in each computed singular value -* (whichever is smaller). -* -* MAXITR INTEGER, default = 6 -* MAXITR controls the maximum number of passes of the -* algorithm through its inner loop. The algorithms stops -* (and so fails to converge) if the number of passes -* through the inner loop exceeds MAXITR*N**2. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION NEGONE - PARAMETER ( NEGONE = -1.0D0 ) - DOUBLE PRECISION HNDRTH - PARAMETER ( HNDRTH = 0.01D0 ) - DOUBLE PRECISION TEN - PARAMETER ( TEN = 10.0D0 ) - DOUBLE PRECISION HNDRD - PARAMETER ( HNDRD = 100.0D0 ) - DOUBLE PRECISION MEIGTH - PARAMETER ( MEIGTH = -0.125D0 ) - INTEGER MAXITR - PARAMETER ( MAXITR = 6 ) -* .. -* .. Local Scalars .. - LOGICAL LOWER, ROTATE - INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1, - $ NM12, NM13, OLDLL, OLDM - DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, - $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, - $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA, - $ SN, THRESH, TOL, TOLMUL, UNFL -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT, - $ DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - LOWER = LSAME( UPLO, 'L' ) - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NCVT.LT.0 ) THEN - INFO = -3 - ELSE IF( NRU.LT.0 ) THEN - INFO = -4 - ELSE IF( NCC.LT.0 ) THEN - INFO = -5 - ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. - $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN - INFO = -9 - ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN - INFO = -11 - ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. - $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN - INFO = -13 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DBDSQR', -INFO ) - RETURN - END IF - IF( N.EQ.0 ) - $ RETURN - IF( N.EQ.1 ) - $ GO TO 160 -* -* ROTATE is true if any singular vectors desired, false otherwise -* - ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) -* -* If no singular vectors desired, use qd algorithm -* - IF( .NOT.ROTATE ) THEN - CALL DLASQ1( N, D, E, WORK, INFO ) - RETURN - END IF -* - NM1 = N - 1 - NM12 = NM1 + NM1 - NM13 = NM12 + NM1 - IDIR = 0 -* -* Get machine constants -* - EPS = DLAMCH( 'Epsilon' ) - UNFL = DLAMCH( 'Safe minimum' ) -* -* If matrix lower bidiagonal, rotate to be upper bidiagonal -* by applying Givens rotations on the left -* - IF( LOWER ) THEN - DO 10 I = 1, N - 1 - CALL DLARTG( D( I ), E( I ), CS, SN, R ) - D( I ) = R - E( I ) = SN*D( I+1 ) - D( I+1 ) = CS*D( I+1 ) - WORK( I ) = CS - WORK( NM1+I ) = SN - 10 CONTINUE -* -* Update singular vectors if desired -* - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U, - $ LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C, - $ LDC ) - END IF -* -* Compute singular values to relative accuracy TOL -* (By setting TOL to be negative, algorithm will compute -* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) -* - TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) ) - TOL = TOLMUL*EPS -* -* Compute approximate maximum, minimum singular values -* - SMAX = ZERO - DO 20 I = 1, N - SMAX = MAX( SMAX, ABS( D( I ) ) ) - 20 CONTINUE - DO 30 I = 1, N - 1 - SMAX = MAX( SMAX, ABS( E( I ) ) ) - 30 CONTINUE - SMINL = ZERO - IF( TOL.GE.ZERO ) THEN -* -* Relative accuracy desired -* - SMINOA = ABS( D( 1 ) ) - IF( SMINOA.EQ.ZERO ) - $ GO TO 50 - MU = SMINOA - DO 40 I = 2, N - MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) ) - SMINOA = MIN( SMINOA, MU ) - IF( SMINOA.EQ.ZERO ) - $ GO TO 50 - 40 CONTINUE - 50 CONTINUE - SMINOA = SMINOA / SQRT( DBLE( N ) ) - THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL ) - ELSE -* -* Absolute accuracy desired -* - THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL ) - END IF -* -* Prepare for main iteration loop for the singular values -* (MAXIT is the maximum number of passes through the inner -* loop permitted before nonconvergence signalled.) -* - MAXIT = MAXITR*N*N - ITER = 0 - OLDLL = -1 - OLDM = -1 -* -* M points to last element of unconverged part of matrix -* - M = N -* -* Begin main iteration loop -* - 60 CONTINUE -* -* Check for convergence or exceeding iteration count -* - IF( M.LE.1 ) - $ GO TO 160 - IF( ITER.GT.MAXIT ) - $ GO TO 200 -* -* Find diagonal block of matrix to work on -* - IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH ) - $ D( M ) = ZERO - SMAX = ABS( D( M ) ) - SMIN = SMAX - DO 70 LLL = 1, M - 1 - LL = M - LLL - ABSS = ABS( D( LL ) ) - ABSE = ABS( E( LL ) ) - IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH ) - $ D( LL ) = ZERO - IF( ABSE.LE.THRESH ) - $ GO TO 80 - SMIN = MIN( SMIN, ABSS ) - SMAX = MAX( SMAX, ABSS, ABSE ) - 70 CONTINUE - LL = 0 - GO TO 90 - 80 CONTINUE - E( LL ) = ZERO -* -* Matrix splits since E(LL) = 0 -* - IF( LL.EQ.M-1 ) THEN -* -* Convergence of bottom singular value, return to top of loop -* - M = M - 1 - GO TO 60 - END IF - 90 CONTINUE - LL = LL + 1 -* -* E(LL) through E(M-1) are nonzero, E(LL-1) is zero -* - IF( LL.EQ.M-1 ) THEN -* -* 2 by 2 block, handle separately -* - CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR, - $ COSR, SINL, COSL ) - D( M-1 ) = SIGMX - E( M-1 ) = ZERO - D( M ) = SIGMN -* -* Compute singular vectors, if desired -* - IF( NCVT.GT.0 ) - $ CALL DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR, - $ SINR ) - IF( NRU.GT.0 ) - $ CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL ) - IF( NCC.GT.0 ) - $ CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL, - $ SINL ) - M = M - 2 - GO TO 60 - END IF -* -* If working on new submatrix, choose shift direction -* (from larger end diagonal element towards smaller) -* - IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN - IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN -* -* Chase bulge from top (big end) to bottom (small end) -* - IDIR = 1 - ELSE -* -* Chase bulge from bottom (big end) to top (small end) -* - IDIR = 2 - END IF - END IF -* -* Apply convergence tests -* - IF( IDIR.EQ.1 ) THEN -* -* Run convergence test in forward direction -* First apply standard test to bottom of matrix -* - IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR. - $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN - E( M-1 ) = ZERO - GO TO 60 - END IF -* - IF( TOL.GE.ZERO ) THEN -* -* If relative accuracy desired, -* apply convergence criterion forward -* - MU = ABS( D( LL ) ) - SMINL = MU - DO 100 LLL = LL, M - 1 - IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN - E( LLL ) = ZERO - GO TO 60 - END IF - MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) - SMINL = MIN( SMINL, MU ) - 100 CONTINUE - END IF -* - ELSE -* -* Run convergence test in backward direction -* First apply standard test to top of matrix -* - IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR. - $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN - E( LL ) = ZERO - GO TO 60 - END IF -* - IF( TOL.GE.ZERO ) THEN -* -* If relative accuracy desired, -* apply convergence criterion backward -* - MU = ABS( D( M ) ) - SMINL = MU - DO 110 LLL = M - 1, LL, -1 - IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN - E( LLL ) = ZERO - GO TO 60 - END IF - MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) - SMINL = MIN( SMINL, MU ) - 110 CONTINUE - END IF - END IF - OLDLL = LL - OLDM = M -* -* Compute shift. First, test if shifting would ruin relative -* accuracy, and if so set the shift to zero. -* - IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE. - $ MAX( EPS, HNDRTH*TOL ) ) THEN -* -* Use a zero shift to avoid loss of relative accuracy -* - SHIFT = ZERO - ELSE -* -* Compute the shift from 2-by-2 block at end of matrix -* - IF( IDIR.EQ.1 ) THEN - SLL = ABS( D( LL ) ) - CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R ) - ELSE - SLL = ABS( D( M ) ) - CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R ) - END IF -* -* Test if shift negligible, and if so set to zero -* - IF( SLL.GT.ZERO ) THEN - IF( ( SHIFT / SLL )**2.LT.EPS ) - $ SHIFT = ZERO - END IF - END IF -* -* Increment iteration count -* - ITER = ITER + M - LL -* -* If SHIFT = 0, do simplified QR iteration -* - IF( SHIFT.EQ.ZERO ) THEN - IF( IDIR.EQ.1 ) THEN -* -* Chase bulge from top to bottom -* Save cosines and sines for later singular vector updates -* - CS = ONE - OLDCS = ONE - DO 120 I = LL, M - 1 - CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) - IF( I.GT.LL ) - $ E( I-1 ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) - WORK( I-LL+1 ) = CS - WORK( I-LL+1+NM1 ) = SN - WORK( I-LL+1+NM12 ) = OLDCS - WORK( I-LL+1+NM13 ) = OLDSN - 120 CONTINUE - H = D( M )*CS - D( M ) = H*OLDCS - E( M-1 ) = H*OLDSN -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), - $ WORK( N ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), - $ WORK( NM13+1 ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), - $ WORK( NM13+1 ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( M-1 ) ).LE.THRESH ) - $ E( M-1 ) = ZERO -* - ELSE -* -* Chase bulge from bottom to top -* Save cosines and sines for later singular vector updates -* - CS = ONE - OLDCS = ONE - DO 130 I = M, LL + 1, -1 - CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) - IF( I.LT.M ) - $ E( I ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) - WORK( I-LL ) = CS - WORK( I-LL+NM1 ) = -SN - WORK( I-LL+NM12 ) = OLDCS - WORK( I-LL+NM13 ) = -OLDSN - 130 CONTINUE - H = D( LL )*CS - D( LL ) = H*OLDCS - E( LL ) = H*OLDSN -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), - $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), - $ WORK( N ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), - $ WORK( N ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( LL ) ).LE.THRESH ) - $ E( LL ) = ZERO - END IF - ELSE -* -* Use nonzero shift -* - IF( IDIR.EQ.1 ) THEN -* -* Chase bulge from top to bottom -* Save cosines and sines for later singular vector updates -* - F = ( ABS( D( LL ) )-SHIFT )* - $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) ) - G = E( LL ) - DO 140 I = LL, M - 1 - CALL DLARTG( F, G, COSR, SINR, R ) - IF( I.GT.LL ) - $ E( I-1 ) = R - F = COSR*D( I ) + SINR*E( I ) - E( I ) = COSR*E( I ) - SINR*D( I ) - G = SINR*D( I+1 ) - D( I+1 ) = COSR*D( I+1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I ) + SINL*D( I+1 ) - D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) - IF( I.LT.M-1 ) THEN - G = SINL*E( I+1 ) - E( I+1 ) = COSL*E( I+1 ) - END IF - WORK( I-LL+1 ) = COSR - WORK( I-LL+1+NM1 ) = SINR - WORK( I-LL+1+NM12 ) = COSL - WORK( I-LL+1+NM13 ) = SINL - 140 CONTINUE - E( M-1 ) = F -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), - $ WORK( N ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), - $ WORK( NM13+1 ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), - $ WORK( NM13+1 ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( M-1 ) ).LE.THRESH ) - $ E( M-1 ) = ZERO -* - ELSE -* -* Chase bulge from bottom to top -* Save cosines and sines for later singular vector updates -* - F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT / - $ D( M ) ) - G = E( M-1 ) - DO 150 I = M, LL + 1, -1 - CALL DLARTG( F, G, COSR, SINR, R ) - IF( I.LT.M ) - $ E( I ) = R - F = COSR*D( I ) + SINR*E( I-1 ) - E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) - G = SINR*D( I-1 ) - D( I-1 ) = COSR*D( I-1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I-1 ) + SINL*D( I-1 ) - D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) - IF( I.GT.LL+1 ) THEN - G = SINL*E( I-2 ) - E( I-2 ) = COSL*E( I-2 ) - END IF - WORK( I-LL ) = COSR - WORK( I-LL+NM1 ) = -SINR - WORK( I-LL+NM12 ) = COSL - WORK( I-LL+NM13 ) = -SINL - 150 CONTINUE - E( LL ) = F -* -* Test convergence -* - IF( ABS( E( LL ) ).LE.THRESH ) - $ E( LL ) = ZERO -* -* Update singular vectors if desired -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), - $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), - $ WORK( N ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), - $ WORK( N ), C( LL, 1 ), LDC ) - END IF - END IF -* -* QR iteration finished, go back and check convergence -* - GO TO 60 -* -* All singular values converged, so make them positive -* - 160 CONTINUE - DO 170 I = 1, N - IF( D( I ).LT.ZERO ) THEN - D( I ) = -D( I ) -* -* Change sign of singular vectors, if desired -* - IF( NCVT.GT.0 ) - $ CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT ) - END IF - 170 CONTINUE -* -* Sort the singular values into decreasing order (insertion sort on -* singular values, but only one transposition per singular vector) -* - DO 190 I = 1, N - 1 -* -* Scan for smallest D(I) -* - ISUB = 1 - SMIN = D( 1 ) - DO 180 J = 2, N + 1 - I - IF( D( J ).LE.SMIN ) THEN - ISUB = J - SMIN = D( J ) - END IF - 180 CONTINUE - IF( ISUB.NE.N+1-I ) THEN -* -* Swap singular values and vectors -* - D( ISUB ) = D( N+1-I ) - D( N+1-I ) = SMIN - IF( NCVT.GT.0 ) - $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ), - $ LDVT ) - IF( NRU.GT.0 ) - $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 ) - IF( NCC.GT.0 ) - $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC ) - END IF - 190 CONTINUE - GO TO 220 -* -* Maximum number of iterations exceeded, failure to converge -* - 200 CONTINUE - INFO = 0 - DO 210 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 210 CONTINUE - 220 CONTINUE - RETURN -* -* End of DBDSQR -* - END - - SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, - $ LDC, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS, VECT - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C -* with -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**T -* -* If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C -* with -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': P * C C * P -* TRANS = 'T': P**T * C C * P**T -* -* Here Q and P**T are the orthogonal matrices determined by DGEBRD when -* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and -* P**T are defined as products of elementary reflectors H(i) and G(i) -* respectively. -* -* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the -* order of the orthogonal matrix Q or P**T that is applied. -* -* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: -* if nq >= k, Q = H(1) H(2) . . . H(k); -* if nq < k, Q = H(1) H(2) . . . H(nq-1). -* -* If VECT = 'P', A is assumed to have been a K-by-NQ matrix: -* if k < nq, P = G(1) G(2) . . . G(k); -* if k >= nq, P = G(1) G(2) . . . G(nq-1). -* -* Arguments -* ========= -* -* VECT (input) CHARACTER*1 -* = 'Q': apply Q or Q**T; -* = 'P': apply P or P**T. -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q, Q**T, P or P**T from the Left; -* = 'R': apply Q, Q**T, P or P**T from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q or P; -* = 'T': Transpose, apply Q**T or P**T. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* If VECT = 'Q', the number of columns in the original -* matrix reduced by DGEBRD. -* If VECT = 'P', the number of rows in the original -* matrix reduced by DGEBRD. -* K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension -* (LDA,min(nq,K)) if VECT = 'Q' -* (LDA,nq) if VECT = 'P' -* The vectors which define the elementary reflectors H(i) and -* G(i), whose products determine the matrices Q and P, as -* returned by DGEBRD. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If VECT = 'Q', LDA >= max(1,nq); -* if VECT = 'P', LDA >= max(1,min(nq,K)). -* -* TAU (input) DOUBLE PRECISION array, dimension (min(nq,K)) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i) or G(i) which determines Q or P, as returned -* by DGEBRD in the array argument TAUQ or TAUP. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q -* or P*C or P**T*C or C*P or C*P**T. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN - CHARACTER TRANST - INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DORMLQ, DORMQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - APPLYQ = LSAME( VECT, 'Q' ) - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q or P and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( K.LT.0 ) THEN - INFO = -6 - ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. - $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) - $ THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -11 - ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( APPLYQ ) THEN - IF( LEFT ) THEN - NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - ELSE - IF( LEFT ) THEN - NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - END IF - LWKOPT = MAX( 1, NW )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMBR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - WORK( 1 ) = 1 - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - IF( APPLYQ ) THEN -* -* Apply Q -* - IF( NQ.GE.K ) THEN -* -* Q was determined by a call to DGEBRD with nq >= k -* - CALL DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, IINFO ) - ELSE IF( NQ.GT.1 ) THEN -* -* Q was determined by a call to DGEBRD with nq < k -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - I1 = 2 - I2 = 1 - ELSE - MI = M - NI = N - 1 - I1 = 1 - I2 = 2 - END IF - CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, - $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - ELSE -* -* Apply P -* - IF( NOTRAN ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF - IF( NQ.GT.K ) THEN -* -* P was determined by a call to DGEBRD with nq > k -* - CALL DORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, IINFO ) - ELSE IF( NQ.GT.1 ) THEN -* -* P was determined by a call to DGEBRD with nq <= k -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - I1 = 2 - I2 = 1 - ELSE - MI = M - NI = N - 1 - I1 = 1 - I2 = 2 - END IF - CALL DORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, - $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMBR -* - END - - SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, - $ INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEBRD reduces a general real M-by-N matrix A to upper or lower -* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. -* -* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows in the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns in the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N general matrix to be reduced. -* On exit, -* if m >= n, the diagonal and the first superdiagonal are -* overwritten with the upper bidiagonal matrix B; the -* elements below the diagonal, with the array TAUQ, represent -* the orthogonal matrix Q as a product of elementary -* reflectors, and the elements above the first superdiagonal, -* with the array TAUP, represent the orthogonal matrix P as -* a product of elementary reflectors; -* if m < n, the diagonal and the first subdiagonal are -* overwritten with the lower bidiagonal matrix B; the -* elements below the first subdiagonal, with the array TAUQ, -* represent the orthogonal matrix Q as a product of -* elementary reflectors, and the elements above the diagonal, -* with the array TAUP, represent the orthogonal matrix P as -* a product of elementary reflectors. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* D (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The diagonal elements of the bidiagonal matrix B: -* D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) -* The off-diagonal elements of the bidiagonal matrix B: -* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; -* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. -* -* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix Q. See Further Details. -* -* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix P. See Further Details. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The length of the array WORK. LWORK >= max(1,M,N). -* For optimum performance LWORK >= (M+N)*NB, where NB -* is the optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* The matrices Q and P are represented as products of elementary -* reflectors: -* -* If m >= n, -* -* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are real scalars, and v and u are real vectors; -* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); -* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); -* tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* If m < n, -* -* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are real scalars, and v and u are real vectors; -* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); -* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); -* tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* The contents of A on exit are illustrated by the following examples: -* -* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -* -* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) -* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) -* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) -* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) -* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) -* ( v1 v2 v3 v4 v5 ) -* -* where d and e denote diagonal and off-diagonal elements of B, vi -* denotes an element of the vector defining H(i), and ui an element of -* the vector defining G(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, - $ NBMIN, NX - DOUBLE PRECISION WS -* .. -* .. External Subroutines .. - EXTERNAL DGEBD2, DGEMM, DLABRD, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) ) - LWKOPT = ( M+N )*NB - WORK( 1 ) = DBLE( LWKOPT ) - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN - INFO = -10 - END IF - IF( INFO.LT.0 ) THEN - CALL XERBLA( 'DGEBRD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - MINMN = MIN( M, N ) - IF( MINMN.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - WS = MAX( M, N ) - LDWRKX = M - LDWRKY = N -* - IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN -* -* Set the crossover point NX. -* - NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) ) -* -* Determine when to switch from blocked to unblocked code. -* - IF( NX.LT.MINMN ) THEN - WS = ( M+N )*NB - IF( LWORK.LT.WS ) THEN -* -* Not enough work space for the optimal NB, consider using -* a smaller block size. -* - NBMIN = ILAENV( 2, 'DGEBRD', ' ', M, N, -1, -1 ) - IF( LWORK.GE.( M+N )*NBMIN ) THEN - NB = LWORK / ( M+N ) - ELSE - NB = 1 - NX = MINMN - END IF - END IF - END IF - ELSE - NX = MINMN - END IF -* - DO 30 I = 1, MINMN - NX, NB -* -* Reduce rows and columns i:i+nb-1 to bidiagonal form and return -* the matrices X and Y which are needed to update the unreduced -* part of the matrix -* - CALL DLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), - $ TAUQ( I ), TAUP( I ), WORK, LDWRKX, - $ WORK( LDWRKX*NB+1 ), LDWRKY ) -* -* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update -* of the form A := A - V*Y' - X*U' -* - CALL DGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1, - $ NB, -ONE, A( I+NB, I ), LDA, - $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, - $ A( I+NB, I+NB ), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, - $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, - $ ONE, A( I+NB, I+NB ), LDA ) -* -* Copy diagonal and off-diagonal elements of B back into A -* - IF( M.GE.N ) THEN - DO 10 J = I, I + NB - 1 - A( J, J ) = D( J ) - A( J, J+1 ) = E( J ) - 10 CONTINUE - ELSE - DO 20 J = I, I + NB - 1 - A( J, J ) = D( J ) - A( J+1, J ) = E( J ) - 20 CONTINUE - END IF - 30 CONTINUE -* -* Use unblocked code to reduce the remainder of the matrix -* - CALL DGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), - $ TAUQ( I ), TAUP( I ), WORK, IINFO ) - WORK( 1 ) = WS - RETURN -* -* End of DGEBRD -* - END - - SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORGLQ generates an M-by-N real matrix Q with orthonormal rows, -* which is defined as the first M rows of a product of K elementary -* reflectors of order N -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGELQF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. N >= M. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. M >= K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the i-th row must contain the vector which defines -* the elementary reflector H(i), for i = 1,2,...,k, as returned -* by DGELQF in the first k rows of its array argument A. -* On exit, the M-by-N matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGELQF. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,M). -* For optimum performance LWORK >= M*NB, where NB is -* the optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, - $ LWKOPT, NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORGL2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, M )*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.M ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGLQ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = M - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DORGLQ', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = M - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORGLQ', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the last block. -* The first kk rows are handled by the block method. -* - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) -* -* Set A(kk+1:m,1:kk) to zero. -* - DO 20 J = 1, KK - DO 10 I = KK + 1, M - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the last or only block. -* - IF( KK.LT.M ) - $ CALL DORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, - $ TAU( KK+1 ), WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF( I+IB.LE.M ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H' to A(i+ib:m,i:n) from the right -* - CALL DLARFB( 'Right', 'Transpose', 'Forward', 'Rowwise', - $ M-I-IB+1, N-I+1, IB, A( I, I ), LDA, WORK, - $ LDWORK, A( I+IB, I ), LDA, WORK( IB+1 ), - $ LDWORK ) - END IF -* -* Apply H' to columns i:n of current block -* - CALL DORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* -* Set columns 1:i-1 of current block to zero -* - DO 40 J = 1, I - 1 - DO 30 L = I, I + IB - 1 - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DORGLQ -* - END - - - SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, - $ LDY ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER LDA, LDX, LDY, M, N, NB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) -* .. -* -* Purpose -* ======= -* -* DLABRD reduces the first NB rows and columns of a real general -* m by n matrix A to upper or lower bidiagonal form by an orthogonal -* transformation Q' * A * P, and returns the matrices X and Y which -* are needed to apply the transformation to the unreduced part of A. -* -* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower -* bidiagonal form. -* -* This is an auxiliary routine called by DGEBRD -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows in the matrix A. -* -* N (input) INTEGER -* The number of columns in the matrix A. -* -* NB (input) INTEGER -* The number of leading rows and columns of A to be reduced. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n general matrix to be reduced. -* On exit, the first NB rows and columns of the matrix are -* overwritten; the rest of the array is unchanged. -* If m >= n, elements on and below the diagonal in the first NB -* columns, with the array TAUQ, represent the orthogonal -* matrix Q as a product of elementary reflectors; and -* elements above the diagonal in the first NB rows, with the -* array TAUP, represent the orthogonal matrix P as a product -* of elementary reflectors. -* If m < n, elements below the diagonal in the first NB -* columns, with the array TAUQ, represent the orthogonal -* matrix Q as a product of elementary reflectors, and -* elements on and above the diagonal in the first NB rows, -* with the array TAUP, represent the orthogonal matrix P as -* a product of elementary reflectors. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* D (output) DOUBLE PRECISION array, dimension (NB) -* The diagonal elements of the first NB rows and columns of -* the reduced matrix. D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (NB) -* The off-diagonal elements of the first NB rows and columns of -* the reduced matrix. -* -* TAUQ (output) DOUBLE PRECISION array dimension (NB) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix Q. See Further Details. -* -* TAUP (output) DOUBLE PRECISION array, dimension (NB) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix P. See Further Details. -* -* X (output) DOUBLE PRECISION array, dimension (LDX,NB) -* The m-by-nb matrix X required to update the unreduced part -* of A. -* -* LDX (input) INTEGER -* The leading dimension of the array X. LDX >= M. -* -* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) -* The n-by-nb matrix Y required to update the unreduced part -* of A. -* -* LDY (input) INTEGER -* The leading dimension of the array Y. LDY >= N. -* -* Further Details -* =============== -* -* The matrices Q and P are represented as products of elementary -* reflectors: -* -* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are real scalars, and v and u are real vectors. -* -* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in -* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in -* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in -* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in -* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* The elements of the vectors v and u together form the m-by-nb matrix -* V and the nb-by-n matrix U' which are needed, with X and Y, to apply -* the transformation to the unreduced part of the matrix, using a block -* update of the form: A := A - V*Y' - X*U'. -* -* The contents of A on exit are illustrated by the following examples -* with nb = 2: -* -* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -* -* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) -* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) -* ( v1 v2 a a a ) ( v1 1 a a a a ) -* ( v1 v2 a a a ) ( v1 v2 a a a a ) -* ( v1 v2 a a a ) ( v1 v2 a a a a ) -* ( v1 v2 a a a ) -* -* where a denotes an element of the original matrix which is unchanged, -* vi denotes an element of the vector defining H(i), and ui an element -* of the vector defining G(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DLARFG, DSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( M.GE.N ) THEN -* -* Reduce to upper bidiagonal form -* - DO 10 I = 1, NB -* -* Update A(i:m,i) -* - CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), - $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 ) - CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), - $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) -* -* Generate reflection Q(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAUQ( I ) ) - D( I ) = A( I, I ) - IF( I.LT.N ) THEN - A( I, I ) = ONE -* -* Compute Y(i+1:n,i) -* - CALL DGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ), - $ LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA, - $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), - $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX, - $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), - $ LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) -* -* Update A(i,i+1:n) -* - CALL DGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), - $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), - $ LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA ) -* -* Generate reflection P(i) to annihilate A(i,i+2:n) -* - CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), - $ LDA, TAUP( I ) ) - E( I ) = A( I, I+1 ) - A( I, I+1 ) = ONE -* -* Compute X(i+1:m,i) -* - CALL DGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), - $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY, - $ A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), - $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), - $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) - END IF - 10 CONTINUE - ELSE -* -* Reduce to lower bidiagonal form -* - DO 20 I = 1, NB -* -* Update A(i,i:n) -* - CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), - $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA, - $ X( I, 1 ), LDX, ONE, A( I, I ), LDA ) -* -* Generate reflection P(i) to annihilate A(i,i+1:n) -* - CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, - $ TAUP( I ) ) - D( I ) = A( I, I ) - IF( I.LT.M ) THEN - A( I, I ) = ONE -* -* Compute X(i+1:m,i) -* - CALL DGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), - $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY, - $ A( I, I ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), - $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), - $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) -* -* Update A(i+1:m,i) -* - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), - $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) -* -* Generate reflection Q(i) to annihilate A(i+2:m,i) -* - CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, - $ TAUQ( I ) ) - E( I ) = A( I+1, I ) - A( I+1, I ) = ONE -* -* Compute Y(i+1:n,i) -* - CALL DGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ), - $ LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA, - $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), - $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX, - $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA, - $ Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DLABRD -* - END - SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEBD2 reduces a real general m by n matrix A to upper or lower -* bidiagonal form B by an orthogonal transformation: Q' * A * P = B. -* -* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows in the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns in the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n general matrix to be reduced. -* On exit, -* if m >= n, the diagonal and the first superdiagonal are -* overwritten with the upper bidiagonal matrix B; the -* elements below the diagonal, with the array TAUQ, represent -* the orthogonal matrix Q as a product of elementary -* reflectors, and the elements above the first superdiagonal, -* with the array TAUP, represent the orthogonal matrix P as -* a product of elementary reflectors; -* if m < n, the diagonal and the first subdiagonal are -* overwritten with the lower bidiagonal matrix B; the -* elements below the first subdiagonal, with the array TAUQ, -* represent the orthogonal matrix Q as a product of -* elementary reflectors, and the elements above the diagonal, -* with the array TAUP, represent the orthogonal matrix P as -* a product of elementary reflectors. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* D (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The diagonal elements of the bidiagonal matrix B: -* D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) -* The off-diagonal elements of the bidiagonal matrix B: -* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; -* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. -* -* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix Q. See Further Details. -* -* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix P. See Further Details. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* The matrices Q and P are represented as products of elementary -* reflectors: -* -* If m >= n, -* -* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are real scalars, and v and u are real vectors; -* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); -* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); -* tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* If m < n, -* -* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are real scalars, and v and u are real vectors; -* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); -* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); -* tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* The contents of A on exit are illustrated by the following examples: -* -* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -* -* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) -* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) -* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) -* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) -* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) -* ( v1 v2 v3 v4 v5 ) -* -* where d and e denote diagonal and off-diagonal elements of B, vi -* denotes an element of the vector defining H(i), and ui an element of -* the vector defining G(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.LT.0 ) THEN - CALL XERBLA( 'DGEBD2', -INFO ) - RETURN - END IF -* - IF( M.GE.N ) THEN -* -* Reduce to upper bidiagonal form -* - DO 10 I = 1, N -* -* Generate elementary reflector H(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAUQ( I ) ) - D( I ) = A( I, I ) - A( I, I ) = ONE -* -* Apply H(i) to A(i:m,i+1:n) from the left -* - IF( I.LT.N ) - $ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = D( I ) -* - IF( I.LT.N ) THEN -* -* Generate elementary reflector G(i) to annihilate -* A(i,i+2:n) -* - CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), - $ LDA, TAUP( I ) ) - E( I ) = A( I, I+1 ) - A( I, I+1 ) = ONE -* -* Apply G(i) to A(i+1:m,i+1:n) from the right -* - CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, - $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) - A( I, I+1 ) = E( I ) - ELSE - TAUP( I ) = ZERO - END IF - 10 CONTINUE - ELSE -* -* Reduce to lower bidiagonal form -* - DO 20 I = 1, M -* -* Generate elementary reflector G(i) to annihilate A(i,i+1:n) -* - CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, - $ TAUP( I ) ) - D( I ) = A( I, I ) - A( I, I ) = ONE -* -* Apply G(i) to A(i+1:m,i:n) from the right -* - IF( I.LT.M ) - $ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAUP( I ), A( I+1, I ), LDA, WORK ) - A( I, I ) = D( I ) -* - IF( I.LT.M ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(i+2:m,i) -* - CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, - $ TAUQ( I ) ) - E( I ) = A( I+1, I ) - A( I+1, I ) = ONE -* -* Apply H(i) to A(i+1:m,i+1:n) from the left -* - CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ), - $ A( I+1, I+1 ), LDA, WORK ) - A( I+1, I ) = E( I ) - ELSE - TAUQ( I ) = ZERO - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGEBD2 -* - END - - SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORGL2 generates an m by n real matrix Q with orthonormal rows, -* which is defined as the first m rows of a product of k elementary -* reflectors of order n -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGELQF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. N >= M. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. M >= K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the i-th row must contain the vector which defines -* the elementary reflector H(i), for i = 1,2,...,k, as returned -* by DGELQF in the first k rows of its array argument A. -* On exit, the m-by-n matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGELQF. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (M) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.M ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGL2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 ) - $ RETURN -* - IF( K.LT.M ) THEN -* -* Initialise rows k+1:m to rows of the unit matrix -* - DO 20 J = 1, N - DO 10 L = K + 1, M - A( L, J ) = ZERO - 10 CONTINUE - IF( J.GT.K .AND. J.LE.M ) - $ A( J, J ) = ONE - 20 CONTINUE - END IF -* - DO 40 I = K, 1, -1 -* -* Apply H(i) to A(i:m,i:n) from the right -* - IF( I.LT.N ) THEN - IF( I.LT.M ) THEN - A( I, I ) = ONE - CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAU( I ), A( I+1, I ), LDA, WORK ) - END IF - CALL DSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) - END IF - A( I, I ) = ONE - TAU( I ) -* -* Set A(i,1:i-1) to zero -* - DO 30 L = 1, I - 1 - A( I, L ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of DORGL2 -* - END - - SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, - $ ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, - $ IFAIL, INFO ) -* -* -- LAPACK driver routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER JOBZ, RANGE, UPLO - INTEGER IL, INFO, IU, LDZ, M, N - DOUBLE PRECISION ABSTOL, VL, VU -* .. -* .. Array Arguments .. - INTEGER IFAIL( * ), IWORK( * ) - DOUBLE PRECISION RWORK( * ), W( * ) - COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* ZHPEVX computes selected eigenvalues and, optionally, eigenvectors -* of a complex Hermitian matrix A in packed storage. -* Eigenvalues/vectors can be selected by specifying either a range of -* values or a range of indices for the desired eigenvalues. -* -* Arguments -* ========= -* -* JOBZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only; -* = 'V': Compute eigenvalues and eigenvectors. -* -* RANGE (input) CHARACTER*1 -* = 'A': all eigenvalues will be found; -* = 'V': all eigenvalues in the half-open interval (VL,VU] -* will be found; -* = 'I': the IL-th through IU-th eigenvalues will be found. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) -* On entry, the upper or lower triangle of the Hermitian matrix -* A, packed columnwise in a linear array. The j-th column of A -* is stored in the array AP as follows: -* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; -* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. -* -* On exit, AP is overwritten by values generated during the -* reduction to tridiagonal form. If UPLO = 'U', the diagonal -* and first superdiagonal of the tridiagonal matrix T overwrite -* the corresponding elements of A, and if UPLO = 'L', the -* diagonal and first subdiagonal of T overwrite the -* corresponding elements of A. -* -* VL (input) DOUBLE PRECISION -* VU (input) DOUBLE PRECISION -* If RANGE='V', the lower and upper bounds of the interval to -* be searched for eigenvalues. VL < VU. -* Not referenced if RANGE = 'A' or 'I'. -* -* IL (input) INTEGER -* IU (input) INTEGER -* If RANGE='I', the indices (in ascending order) of the -* smallest and largest eigenvalues to be returned. -* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. -* Not referenced if RANGE = 'A' or 'V'. -* -* ABSTOL (input) DOUBLE PRECISION -* The absolute error tolerance for the eigenvalues. -* An approximate eigenvalue is accepted as converged -* when it is determined to lie in an interval [a,b] -* of width less than or equal to -* -* ABSTOL + EPS * max( |a|,|b| ) , -* -* where EPS is the machine precision. If ABSTOL is less than -* or equal to zero, then EPS*|T| will be used in its place, -* where |T| is the 1-norm of the tridiagonal matrix obtained -* by reducing AP to tridiagonal form. -* -* Eigenvalues will be computed most accurately when ABSTOL is -* set to twice the underflow threshold 2*DLAMCH('S'), not zero. -* If this routine returns with INFO>0, indicating that some -* eigenvectors did not converge, try setting ABSTOL to -* 2*DLAMCH('S'). -* -* See "Computing Small Singular Values of Bidiagonal Matrices -* with Guaranteed High Relative Accuracy," by Demmel and -* Kahan, LAPACK Working Note #3. -* -* M (output) INTEGER -* The total number of eigenvalues found. 0 <= M <= N. -* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. -* -* W (output) DOUBLE PRECISION array, dimension (N) -* If INFO = 0, the selected eigenvalues in ascending order. -* -* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M)) -* If JOBZ = 'V', then if INFO = 0, the first M columns of Z -* contain the orthonormal eigenvectors of the matrix A -* corresponding to the selected eigenvalues, with the i-th -* column of Z holding the eigenvector associated with W(i). -* If an eigenvector fails to converge, then that column of Z -* contains the latest approximation to the eigenvector, and -* the index of the eigenvector is returned in IFAIL. -* If JOBZ = 'N', then Z is not referenced. -* Note: the user must ensure that at least max(1,M) columns are -* supplied in the array Z; if RANGE = 'V', the exact value of M -* is not known in advance and an upper bound must be used. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= 1, and if -* JOBZ = 'V', LDZ >= max(1,N). -* -* WORK (workspace) COMPLEX*16 array, dimension (2*N) -* -* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N) -* -* IWORK (workspace) INTEGER array, dimension (5*N) -* -* IFAIL (output) INTEGER array, dimension (N) -* If JOBZ = 'V', then if INFO = 0, the first M elements of -* IFAIL are zero. If INFO > 0, then IFAIL contains the -* indices of the eigenvectors that failed to converge. -* If JOBZ = 'N', then IFAIL is not referenced. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, then i eigenvectors failed to converge. -* Their indices are stored in array IFAIL. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) -* .. -* .. Local Scalars .. - LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ - CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, - $ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE, - $ ITMP1, J, JJ, NSPLIT - DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, - $ SIGMA, SMLNUM, TMP1, VLL, VUU -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, ZLANHP - EXTERNAL LSAME, DLAMCH, ZLANHP -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL, - $ ZHPTRD, ZSTEIN, ZSTEQR, ZSWAP, ZUPGTR, ZUPMTR -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - ALLEIG = LSAME( RANGE, 'A' ) - VALEIG = LSAME( RANGE, 'V' ) - INDEIG = LSAME( RANGE, 'I' ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN - INFO = -2 - ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) - $ THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE - IF( VALEIG ) THEN - IF( N.GT.0 .AND. VU.LE.VL ) - $ INFO = -7 - ELSE IF( INDEIG ) THEN - IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN - INFO = -9 - END IF - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) - $ INFO = -14 - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHPEVX', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - M = 0 - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - IF( ALLEIG .OR. INDEIG ) THEN - M = 1 - W( 1 ) = AP( 1 ) - ELSE - IF( VL.LT.DBLE( AP( 1 ) ) .AND. VU.GE.DBLE( AP( 1 ) ) ) THEN - M = 1 - W( 1 ) = AP( 1 ) - END IF - END IF - IF( WANTZ ) - $ Z( 1, 1 ) = CONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) -* -* Scale matrix to allowable range, if necessary. -* - ISCALE = 0 - ABSTLL = ABSTOL - IF( VALEIG ) THEN - VLL = VL - VUU = VU - ELSE - VLL = ZERO - VUU = ZERO - END IF - ANRM = ZLANHP( 'M', UPLO, N, AP, RWORK ) - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) THEN - CALL ZDSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) - IF( ABSTOL.GT.0 ) - $ ABSTLL = ABSTOL*SIGMA - IF( VALEIG ) THEN - VLL = VL*SIGMA - VUU = VU*SIGMA - END IF - END IF -* -* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form. -* - INDD = 1 - INDE = INDD + N - INDRWK = INDE + N - INDTAU = 1 - INDWRK = INDTAU + N - CALL ZHPTRD( UPLO, N, AP, RWORK( INDD ), RWORK( INDE ), - $ WORK( INDTAU ), IINFO ) -* -* If all eigenvalues are desired and ABSTOL is less than or equal -* to zero, then call DSTERF or ZUPGTR and ZSTEQR. If this fails -* for some eigenvalue, then try DSTEBZ. -* - TEST = .FALSE. - IF (INDEIG) THEN - IF (IL.EQ.1 .AND. IU.EQ.N) THEN - TEST = .TRUE. - END IF - END IF - IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN - CALL DCOPY( N, RWORK( INDD ), 1, W, 1 ) - INDEE = INDRWK + 2*N - IF( .NOT.WANTZ ) THEN - CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) - CALL DSTERF( N, W, RWORK( INDEE ), INFO ) - ELSE - CALL ZUPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ, - $ WORK( INDWRK ), IINFO ) - CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) - CALL ZSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ, - $ RWORK( INDRWK ), INFO ) - IF( INFO.EQ.0 ) THEN - DO 10 I = 1, N - IFAIL( I ) = 0 - 10 CONTINUE - END IF - END IF - IF( INFO.EQ.0 ) THEN - M = N - GO TO 20 - END IF - INFO = 0 - END IF -* -* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. -* - IF( WANTZ ) THEN - ORDER = 'B' - ELSE - ORDER = 'E' - END IF - INDIBL = 1 - INDISP = INDIBL + N - INDIWK = INDISP + N - CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, - $ RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W, - $ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ), - $ IWORK( INDIWK ), INFO ) -* - IF( WANTZ ) THEN - CALL ZSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W, - $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, - $ RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO ) -* -* Apply unitary matrix used in reduction to tridiagonal -* form to eigenvectors returned by ZSTEIN. -* - INDWRK = INDTAU + N - CALL ZUPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ, - $ WORK( INDWRK ), INFO ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - 20 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF -* -* If eigenvalues are not in order, then sort them, along with -* eigenvectors. -* - IF( WANTZ ) THEN - DO 40 J = 1, M - 1 - I = 0 - TMP1 = W( J ) - DO 30 JJ = J + 1, M - IF( W( JJ ).LT.TMP1 ) THEN - I = JJ - TMP1 = W( JJ ) - END IF - 30 CONTINUE -* - IF( I.NE.0 ) THEN - ITMP1 = IWORK( INDIBL+I-1 ) - W( I ) = W( J ) - IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) - W( J ) = TMP1 - IWORK( INDIBL+J-1 ) = ITMP1 - CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) - IF( INFO.NE.0 ) THEN - ITMP1 = IFAIL( I ) - IFAIL( I ) = IFAIL( J ) - IFAIL( J ) = ITMP1 - END IF - END IF - 40 CONTINUE - END IF -* - RETURN -* -* End of ZHPEVX -* - END - - SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, - $ INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDC, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 AP( * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* ZUPMTR overwrites the general complex M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'C': Q**H * C C * Q**H -* -* where Q is a complex unitary matrix of order nq, with nq = m if -* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of -* nq-1 elementary reflectors, as returned by ZHPTRD using packed -* storage: -* -* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); -* -* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**H from the Left; -* = 'R': apply Q or Q**H from the Right. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangular packed storage used in previous -* call to ZHPTRD; -* = 'L': Lower triangular packed storage used in previous -* call to ZHPTRD. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'C': Conjugate transpose, apply Q**H. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* AP (input) COMPLEX*16 array, dimension -* (M*(M+1)/2) if SIDE = 'L' -* (N*(N+1)/2) if SIDE = 'R' -* The vectors which define the elementary reflectors, as -* returned by ZHPTRD. AP is modified by the routine but -* restored on exit. -* -* TAU (input) COMPLEX*16 array, dimension (M-1) if SIDE = 'L' -* or (N-1) if SIDE = 'R' -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by ZHPTRD. -* -* C (input/output) COMPLEX*16 array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) COMPLEX*16 array, dimension -* (N) if SIDE = 'L' -* (M) if SIDE = 'R' -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL FORWRD, LEFT, NOTRAN, UPPER - INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ - COMPLEX*16 AII, TAUI -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARF -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - UPPER = LSAME( UPLO, 'U' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUPMTR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Q was determined by a call to ZHPTRD with UPLO = 'U' -* - FORWRD = ( LEFT .AND. NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) -* - IF( FORWRD ) THEN - I1 = 1 - I2 = NQ - 1 - I3 = 1 - II = 2 - ELSE - I1 = NQ - 1 - I2 = 1 - I3 = -1 - II = NQ*( NQ+1 ) / 2 - 1 - END IF -* - IF( LEFT ) THEN - NI = N - ELSE - MI = M - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) or H(i)' is applied to C(1:i,1:n) -* - MI = I - ELSE -* -* H(i) or H(i)' is applied to C(1:m,1:i) -* - NI = I - END IF -* -* Apply H(i) or H(i)' -* - IF( NOTRAN ) THEN - TAUI = TAU( I ) - ELSE - TAUI = DCONJG( TAU( I ) ) - END IF - AII = AP( II ) - AP( II ) = ONE - CALL ZLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAUI, C, LDC, - $ WORK ) - AP( II ) = AII -* - IF( FORWRD ) THEN - II = II + I + 2 - ELSE - II = II - I - 1 - END IF - 10 CONTINUE - ELSE -* -* Q was determined by a call to ZHPTRD with UPLO = 'L'. -* - FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. NOTRAN ) -* - IF( FORWRD ) THEN - I1 = 1 - I2 = NQ - 1 - I3 = 1 - II = 2 - ELSE - I1 = NQ - 1 - I2 = 1 - I3 = -1 - II = NQ*( NQ+1 ) / 2 - 1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 20 I = I1, I2, I3 - AII = AP( II ) - AP( II ) = ONE - IF( LEFT ) THEN -* -* H(i) or H(i)' is applied to C(i+1:m,1:n) -* - MI = M - I - IC = I + 1 - ELSE -* -* H(i) or H(i)' is applied to C(1:m,i+1:n) -* - NI = N - I - JC = I + 1 - END IF -* -* Apply H(i) or H(i)' -* - IF( NOTRAN ) THEN - TAUI = TAU( I ) - ELSE - TAUI = DCONJG( TAU( I ) ) - END IF - CALL ZLARF( SIDE, MI, NI, AP( II ), 1, TAUI, C( IC, JC ), - $ LDC, WORK ) - AP( II ) = AII -* - IF( FORWRD ) THEN - II = II + NQ - I + 1 - ELSE - II = II - NQ + I - 2 - END IF - 20 CONTINUE - END IF - RETURN -* -* End of ZUPMTR -* - END - - SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, - $ ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, - $ INFO ) -* -* -- LAPACK driver routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER JOBZ, RANGE, UPLO - INTEGER IL, INFO, IU, LDZ, M, N - DOUBLE PRECISION ABSTOL, VL, VU -* .. -* .. Array Arguments .. - INTEGER IFAIL( * ), IWORK( * ) - DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* DSPEVX computes selected eigenvalues and, optionally, eigenvectors -* of a real symmetric matrix A in packed storage. Eigenvalues/vectors -* can be selected by specifying either a range of values or a range of -* indices for the desired eigenvalues. -* -* Arguments -* ========= -* -* JOBZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only; -* = 'V': Compute eigenvalues and eigenvectors. -* -* RANGE (input) CHARACTER*1 -* = 'A': all eigenvalues will be found; -* = 'V': all eigenvalues in the half-open interval (VL,VU] -* will be found; -* = 'I': the IL-th through IU-th eigenvalues will be found. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) -* On entry, the upper or lower triangle of the symmetric matrix -* A, packed columnwise in a linear array. The j-th column of A -* is stored in the array AP as follows: -* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; -* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. -* -* On exit, AP is overwritten by values generated during the -* reduction to tridiagonal form. If UPLO = 'U', the diagonal -* and first superdiagonal of the tridiagonal matrix T overwrite -* the corresponding elements of A, and if UPLO = 'L', the -* diagonal and first subdiagonal of T overwrite the -* corresponding elements of A. -* -* VL (input) DOUBLE PRECISION -* VU (input) DOUBLE PRECISION -* If RANGE='V', the lower and upper bounds of the interval to -* be searched for eigenvalues. VL < VU. -* Not referenced if RANGE = 'A' or 'I'. -* -* IL (input) INTEGER -* IU (input) INTEGER -* If RANGE='I', the indices (in ascending order) of the -* smallest and largest eigenvalues to be returned. -* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. -* Not referenced if RANGE = 'A' or 'V'. -* -* ABSTOL (input) DOUBLE PRECISION -* The absolute error tolerance for the eigenvalues. -* An approximate eigenvalue is accepted as converged -* when it is determined to lie in an interval [a,b] -* of width less than or equal to -* -* ABSTOL + EPS * max( |a|,|b| ) , -* -* where EPS is the machine precision. If ABSTOL is less than -* or equal to zero, then EPS*|T| will be used in its place, -* where |T| is the 1-norm of the tridiagonal matrix obtained -* by reducing AP to tridiagonal form. -* -* Eigenvalues will be computed most accurately when ABSTOL is -* set to twice the underflow threshold 2*DLAMCH('S'), not zero. -* If this routine returns with INFO>0, indicating that some -* eigenvectors did not converge, try setting ABSTOL to -* 2*DLAMCH('S'). -* -* See "Computing Small Singular Values of Bidiagonal Matrices -* with Guaranteed High Relative Accuracy," by Demmel and -* Kahan, LAPACK Working Note #3. -* -* M (output) INTEGER -* The total number of eigenvalues found. 0 <= M <= N. -* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. -* -* W (output) DOUBLE PRECISION array, dimension (N) -* If INFO = 0, the selected eigenvalues in ascending order. -* -* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) -* If JOBZ = 'V', then if INFO = 0, the first M columns of Z -* contain the orthonormal eigenvectors of the matrix A -* corresponding to the selected eigenvalues, with the i-th -* column of Z holding the eigenvector associated with W(i). -* If an eigenvector fails to converge, then that column of Z -* contains the latest approximation to the eigenvector, and the -* index of the eigenvector is returned in IFAIL. -* If JOBZ = 'N', then Z is not referenced. -* Note: the user must ensure that at least max(1,M) columns are -* supplied in the array Z; if RANGE = 'V', the exact value of M -* is not known in advance and an upper bound must be used. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= 1, and if -* JOBZ = 'V', LDZ >= max(1,N). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (8*N) -* -* IWORK (workspace) INTEGER array, dimension (5*N) -* -* IFAIL (output) INTEGER array, dimension (N) -* If JOBZ = 'V', then if INFO = 0, the first M elements of -* IFAIL are zero. If INFO > 0, then IFAIL contains the -* indices of the eigenvectors that failed to converge. -* If JOBZ = 'N', then IFAIL is not referenced. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, then i eigenvectors failed to converge. -* Their indices are stored in array IFAIL. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ - CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, - $ INDISP, INDIWO, INDTAU, INDWRK, ISCALE, ITMP1, - $ J, JJ, NSPLIT - DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, - $ SIGMA, SMLNUM, TMP1, VLL, VUU -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANSP - EXTERNAL LSAME, DLAMCH, DLANSP -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DOPGTR, DOPMTR, DSCAL, DSPTRD, DSTEBZ, - $ DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - ALLEIG = LSAME( RANGE, 'A' ) - VALEIG = LSAME( RANGE, 'V' ) - INDEIG = LSAME( RANGE, 'I' ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN - INFO = -2 - ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) - $ THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE - IF( VALEIG ) THEN - IF( N.GT.0 .AND. VU.LE.VL ) - $ INFO = -7 - ELSE IF( INDEIG ) THEN - IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN - INFO = -9 - END IF - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) - $ INFO = -14 - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSPEVX', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - M = 0 - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - IF( ALLEIG .OR. INDEIG ) THEN - M = 1 - W( 1 ) = AP( 1 ) - ELSE - IF( VL.LT.AP( 1 ) .AND. VU.GE.AP( 1 ) ) THEN - M = 1 - W( 1 ) = AP( 1 ) - END IF - END IF - IF( WANTZ ) - $ Z( 1, 1 ) = ONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) -* -* Scale matrix to allowable range, if necessary. -* - ISCALE = 0 - ABSTLL = ABSTOL - IF( VALEIG ) THEN - VLL = VL - VUU = VU - ELSE - VLL = ZERO - VUU = ZERO - END IF - ANRM = DLANSP( 'M', UPLO, N, AP, WORK ) - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) THEN - CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) - IF( ABSTOL.GT.0 ) - $ ABSTLL = ABSTOL*SIGMA - IF( VALEIG ) THEN - VLL = VL*SIGMA - VUU = VU*SIGMA - END IF - END IF -* -* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. -* - INDTAU = 1 - INDE = INDTAU + N - INDD = INDE + N - INDWRK = INDD + N - CALL DSPTRD( UPLO, N, AP, WORK( INDD ), WORK( INDE ), - $ WORK( INDTAU ), IINFO ) -* -* If all eigenvalues are desired and ABSTOL is less than or equal -* to zero, then call DSTERF or DOPGTR and SSTEQR. If this fails -* for some eigenvalue, then try DSTEBZ. -* - TEST = .FALSE. - IF (INDEIG) THEN - IF (IL.EQ.1 .AND. IU.EQ.N) THEN - TEST = .TRUE. - END IF - END IF - IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN - CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) - INDEE = INDWRK + 2*N - IF( .NOT.WANTZ ) THEN - CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) - CALL DSTERF( N, W, WORK( INDEE ), INFO ) - ELSE - CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ, - $ WORK( INDWRK ), IINFO ) - CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) - CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, - $ WORK( INDWRK ), INFO ) - IF( INFO.EQ.0 ) THEN - DO 10 I = 1, N - IFAIL( I ) = 0 - 10 CONTINUE - END IF - END IF - IF( INFO.EQ.0 ) THEN - M = N - GO TO 20 - END IF - INFO = 0 - END IF -* -* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. -* - IF( WANTZ ) THEN - ORDER = 'B' - ELSE - ORDER = 'E' - END IF - INDIBL = 1 - INDISP = INDIBL + N - INDIWO = INDISP + N - CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, - $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, - $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), - $ IWORK( INDIWO ), INFO ) -* - IF( WANTZ ) THEN - CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, - $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, - $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) -* -* Apply orthogonal matrix used in reduction to tridiagonal -* form to eigenvectors returned by DSTEIN. -* - CALL DOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ, - $ WORK( INDWRK ), INFO ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - 20 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF -* -* If eigenvalues are not in order, then sort them, along with -* eigenvectors. -* - IF( WANTZ ) THEN - DO 40 J = 1, M - 1 - I = 0 - TMP1 = W( J ) - DO 30 JJ = J + 1, M - IF( W( JJ ).LT.TMP1 ) THEN - I = JJ - TMP1 = W( JJ ) - END IF - 30 CONTINUE -* - IF( I.NE.0 ) THEN - ITMP1 = IWORK( INDIBL+I-1 ) - W( I ) = W( J ) - IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) - W( J ) = TMP1 - IWORK( INDIBL+J-1 ) = ITMP1 - CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) - IF( INFO.NE.0 ) THEN - ITMP1 = IFAIL( I ) - IFAIL( I ) = IFAIL( J ) - IFAIL( J ) = ITMP1 - END IF - END IF - 40 CONTINUE - END IF -* - RETURN -* -* End of DSPEVX -* - END - - SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, - $ INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DOPMTR overwrites the general real M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**T -* -* where Q is a real orthogonal matrix of order nq, with nq = m if -* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of -* nq-1 elementary reflectors, as returned by DSPTRD using packed -* storage: -* -* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); -* -* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**T from the Left; -* = 'R': apply Q or Q**T from the Right. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangular packed storage used in previous -* call to DSPTRD; -* = 'L': Lower triangular packed storage used in previous -* call to DSPTRD. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'T': Transpose, apply Q**T. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* AP (input) DOUBLE PRECISION array, dimension -* (M*(M+1)/2) if SIDE = 'L' -* (N*(N+1)/2) if SIDE = 'R' -* The vectors which define the elementary reflectors, as -* returned by DSPTRD. AP is modified by the routine but -* restored on exit. -* -* TAU (input) DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L' -* or (N-1) if SIDE = 'R' -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DSPTRD. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L' -* (M) if SIDE = 'R' -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL FORWRD, LEFT, NOTRAN, UPPER - INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - UPPER = LSAME( UPLO, 'U' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DOPMTR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Q was determined by a call to DSPTRD with UPLO = 'U' -* - FORWRD = ( LEFT .AND. NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) -* - IF( FORWRD ) THEN - I1 = 1 - I2 = NQ - 1 - I3 = 1 - II = 2 - ELSE - I1 = NQ - 1 - I2 = 1 - I3 = -1 - II = NQ*( NQ+1 ) / 2 - 1 - END IF -* - IF( LEFT ) THEN - NI = N - ELSE - MI = M - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(1:i,1:n) -* - MI = I - ELSE -* -* H(i) is applied to C(1:m,1:i) -* - NI = I - END IF -* -* Apply H(i) -* - AII = AP( II ) - AP( II ) = ONE - CALL DLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC, - $ WORK ) - AP( II ) = AII -* - IF( FORWRD ) THEN - II = II + I + 2 - ELSE - II = II - I - 1 - END IF - 10 CONTINUE - ELSE -* -* Q was determined by a call to DSPTRD with UPLO = 'L'. -* - FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. NOTRAN ) -* - IF( FORWRD ) THEN - I1 = 1 - I2 = NQ - 1 - I3 = 1 - II = 2 - ELSE - I1 = NQ - 1 - I2 = 1 - I3 = -1 - II = NQ*( NQ+1 ) / 2 - 1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 20 I = I1, I2, I3 - AII = AP( II ) - AP( II ) = ONE - IF( LEFT ) THEN -* -* H(i) is applied to C(i+1:m,1:n) -* - MI = M - I - IC = I + 1 - ELSE -* -* H(i) is applied to C(1:m,i+1:n) -* - NI = N - I - JC = I + 1 - END IF -* -* Apply H(i) -* - CALL DLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ), - $ C( IC, JC ), LDC, WORK ) - AP( II ) = AII -* - IF( FORWRD ) THEN - II = II + NQ - I + 1 - ELSE - II = II - NQ + I - 2 - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DOPMTR -* - END - - SUBROUTINE ZGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) -* -* -- LAPACK driver routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 AB( LDAB, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZGBSV computes the solution to a complex system of linear equations -* A * X = B, where A is a band matrix of order N with KL subdiagonals -* and KU superdiagonals, and X and B are N-by-NRHS matrices. -* -* The LU decomposition with partial pivoting and row interchanges is -* used to factor A as A = L * U, where L is a product of permutation -* and unit lower triangular matrices with KL subdiagonals, and U is -* upper triangular with KL+KU superdiagonals. The factored form of A -* is then used to solve the system of equations A * X = B. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of linear equations, i.e., the order of the -* matrix A. N >= 0. -* -* KL (input) INTEGER -* The number of subdiagonals within the band of A. KL >= 0. -* -* KU (input) INTEGER -* The number of superdiagonals within the band of A. KU >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) -* On entry, the matrix A in band storage, in rows KL+1 to -* 2*KL+KU+1; rows 1 to KL of the array need not be set. -* The j-th column of A is stored in the j-th column of the -* array AB as follows: -* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL) -* On exit, details of the factorization: U is stored as an -* upper triangular band matrix with KL+KU superdiagonals in -* rows 1 to KL+KU+1, and the multipliers used during the -* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. -* See below for further details. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -* -* IPIV (output) INTEGER array, dimension (N) -* The pivot indices that define the permutation matrix P; -* row i of the matrix was interchanged with row IPIV(i). -* -* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) -* On entry, the N-by-NRHS right hand side matrix B. -* On exit, if INFO = 0, the N-by-NRHS solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and the solution has not been computed. -* -* Further Details -* =============== -* -* The band storage scheme is illustrated by the following example, when -* M = N = 6, KL = 2, KU = 1: -* -* On entry: On exit: -* -* * * * + + + * * * u14 u25 u36 -* * * + + + + * * u13 u24 u35 u46 -* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * -* a31 a42 a53 a64 * * m31 m42 m53 m64 * * -* -* Array elements marked * are not used by the routine; elements marked -* + need not be set on entry, but are required by the routine to store -* elements of U because of fill-in resulting from the row interchanges. -* -* ===================================================================== -* -* .. External Subroutines .. - EXTERNAL XERBLA, ZGBTRF, ZGBTRS -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( KL.LT.0 ) THEN - INFO = -2 - ELSE IF( KU.LT.0 ) THEN - INFO = -3 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGBSV ', -INFO ) - RETURN - END IF -* -* Compute the LU factorization of the band matrix A. -* - CALL ZGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL ZGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV, - $ B, LDB, INFO ) - END IF - RETURN -* -* End of ZGBSV -* - END - - SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 AB( LDAB, * ) -* .. -* -* Purpose -* ======= -* -* ZGBTRF computes an LU factorization of a complex m-by-n band matrix A -* using partial pivoting with row interchanges. -* -* This is the blocked version of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* KL (input) INTEGER -* The number of subdiagonals within the band of A. KL >= 0. -* -* KU (input) INTEGER -* The number of superdiagonals within the band of A. KU >= 0. -* -* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) -* On entry, the matrix A in band storage, in rows KL+1 to -* 2*KL+KU+1; rows 1 to KL of the array need not be set. -* The j-th column of A is stored in the j-th column of the -* array AB as follows: -* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) -* -* On exit, details of the factorization: U is stored as an -* upper triangular band matrix with KL+KU superdiagonals in -* rows 1 to KL+KU+1, and the multipliers used during the -* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. -* See below for further details. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* Further Details -* =============== -* -* The band storage scheme is illustrated by the following example, when -* M = N = 6, KL = 2, KU = 1: -* -* On entry: On exit: -* -* * * * + + + * * * u14 u25 u36 -* * * + + + + * * u13 u24 u35 u46 -* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * -* a31 a42 a53 a64 * * m31 m42 m53 m64 * * -* -* Array elements marked * are not used by the routine; elements marked -* + need not be set on entry, but are required by the routine to store -* elements of U because of fill-in resulting from the row interchanges. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) - INTEGER NBMAX, LDWORK - PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 ) -* .. -* .. Local Scalars .. - INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP, - $ JU, K2, KM, KV, NB, NW - COMPLEX*16 TEMP -* .. -* .. Local Arrays .. - COMPLEX*16 WORK13( LDWORK, NBMAX ), - $ WORK31( LDWORK, NBMAX ) -* .. -* .. External Functions .. - INTEGER ILAENV, IZAMAX - EXTERNAL ILAENV, IZAMAX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZCOPY, ZGBTF2, ZGEMM, ZGERU, ZLASWP, - $ ZSCAL, ZSWAP, ZTRSM -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* KV is the number of superdiagonals in the factor U, allowing for -* fill-in -* - KV = KU + KL -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.KL+KV+1 ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGBTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment -* - NB = ILAENV( 1, 'ZGBTRF', ' ', M, N, KL, KU ) -* -* The block size must not exceed the limit set by the size of the -* local arrays WORK13 and WORK31. -* - NB = MIN( NB, NBMAX ) -* - IF( NB.LE.1 .OR. NB.GT.KL ) THEN -* -* Use unblocked code -* - CALL ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) - ELSE -* -* Use blocked code -* -* Zero the superdiagonal elements of the work array WORK13 -* - DO 20 J = 1, NB - DO 10 I = 1, J - 1 - WORK13( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* -* Zero the subdiagonal elements of the work array WORK31 -* - DO 40 J = 1, NB - DO 30 I = J + 1, NB - WORK31( I, J ) = ZERO - 30 CONTINUE - 40 CONTINUE -* -* Gaussian elimination with partial pivoting -* -* Set fill-in elements in columns KU+2 to KV to zero -* - DO 60 J = KU + 2, MIN( KV, N ) - DO 50 I = KV - J + 2, KL - AB( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE -* -* JU is the index of the last column affected by the current -* stage of the factorization -* - JU = 1 -* - DO 180 J = 1, MIN( M, N ), NB - JB = MIN( NB, MIN( M, N )-J+1 ) -* -* The active part of the matrix is partitioned -* -* A11 A12 A13 -* A21 A22 A23 -* A31 A32 A33 -* -* Here A11, A21 and A31 denote the current block of JB columns -* which is about to be factorized. The number of rows in the -* partitioning are JB, I2, I3 respectively, and the numbers -* of columns are JB, J2, J3. The superdiagonal elements of A13 -* and the subdiagonal elements of A31 lie outside the band. -* - I2 = MIN( KL-JB, M-J-JB+1 ) - I3 = MIN( JB, M-J-KL+1 ) -* -* J2 and J3 are computed after JU has been updated. -* -* Factorize the current block of JB columns -* - DO 80 JJ = J, J + JB - 1 -* -* Set fill-in elements in column JJ+KV to zero -* - IF( JJ+KV.LE.N ) THEN - DO 70 I = 1, KL - AB( I, JJ+KV ) = ZERO - 70 CONTINUE - END IF -* -* Find pivot and test for singularity. KM is the number of -* subdiagonal elements in the current column. -* - KM = MIN( KL, M-JJ ) - JP = IZAMAX( KM+1, AB( KV+1, JJ ), 1 ) - IPIV( JJ ) = JP + JJ - J - IF( AB( KV+JP, JJ ).NE.ZERO ) THEN - JU = MAX( JU, MIN( JJ+KU+JP-1, N ) ) - IF( JP.NE.1 ) THEN -* -* Apply interchange to columns J to J+JB-1 -* - IF( JP+JJ-1.LT.J+KL ) THEN -* - CALL ZSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, - $ AB( KV+JP+JJ-J, J ), LDAB-1 ) - ELSE -* -* The interchange affects columns J to JJ-1 of A31 -* which are stored in the work array WORK31 -* - CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, - $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) - CALL ZSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1, - $ AB( KV+JP, JJ ), LDAB-1 ) - END IF - END IF -* -* Compute multipliers -* - CALL ZSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ), - $ 1 ) -* -* Update trailing submatrix within the band and within -* the current block. JM is the index of the last column -* which needs to be updated. -* - JM = MIN( JU, J+JB-1 ) - IF( JM.GT.JJ ) - $ CALL ZGERU( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1, - $ AB( KV, JJ+1 ), LDAB-1, - $ AB( KV+1, JJ+1 ), LDAB-1 ) - ELSE -* -* If pivot is zero, set INFO to the index of the pivot -* unless a zero pivot has already been found. -* - IF( INFO.EQ.0 ) - $ INFO = JJ - END IF -* -* Copy current column of A31 into the work array WORK31 -* - NW = MIN( JJ-J+1, I3 ) - IF( NW.GT.0 ) - $ CALL ZCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1, - $ WORK31( 1, JJ-J+1 ), 1 ) - 80 CONTINUE - IF( J+JB.LE.N ) THEN -* -* Apply the row interchanges to the other blocks. -* - J2 = MIN( JU-J+1, KV ) - JB - J3 = MAX( 0, JU-J-KV+1 ) -* -* Use ZLASWP to apply the row interchanges to A12, A22, and -* A32. -* - CALL ZLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB, - $ IPIV( J ), 1 ) -* -* Adjust the pivot indices. -* - DO 90 I = J, J + JB - 1 - IPIV( I ) = IPIV( I ) + J - 1 - 90 CONTINUE -* -* Apply the row interchanges to A13, A23, and A33 -* columnwise. -* - K2 = J - 1 + JB + J2 - DO 110 I = 1, J3 - JJ = K2 + I - DO 100 II = J + I - 1, J + JB - 1 - IP = IPIV( II ) - IF( IP.NE.II ) THEN - TEMP = AB( KV+1+II-JJ, JJ ) - AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ ) - AB( KV+1+IP-JJ, JJ ) = TEMP - END IF - 100 CONTINUE - 110 CONTINUE -* -* Update the relevant part of the trailing submatrix -* - IF( J2.GT.0 ) THEN -* -* Update A12 -* - CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, J2, ONE, AB( KV+1, J ), LDAB-1, - $ AB( KV+1-JB, J+JB ), LDAB-1 ) -* - IF( I2.GT.0 ) THEN -* -* Update A22 -* - CALL ZGEMM( 'No transpose', 'No transpose', I2, J2, - $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, - $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, - $ AB( KV+1, J+JB ), LDAB-1 ) - END IF -* - IF( I3.GT.0 ) THEN -* -* Update A32 -* - CALL ZGEMM( 'No transpose', 'No transpose', I3, J2, - $ JB, -ONE, WORK31, LDWORK, - $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, - $ AB( KV+KL+1-JB, J+JB ), LDAB-1 ) - END IF - END IF -* - IF( J3.GT.0 ) THEN -* -* Copy the lower triangle of A13 into the work array -* WORK13 -* - DO 130 JJ = 1, J3 - DO 120 II = JJ, JB - WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 ) - 120 CONTINUE - 130 CONTINUE -* -* Update A13 in the work array -* - CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, J3, ONE, AB( KV+1, J ), LDAB-1, - $ WORK13, LDWORK ) -* - IF( I2.GT.0 ) THEN -* -* Update A23 -* - CALL ZGEMM( 'No transpose', 'No transpose', I2, J3, - $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, - $ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ), - $ LDAB-1 ) - END IF -* - IF( I3.GT.0 ) THEN -* -* Update A33 -* - CALL ZGEMM( 'No transpose', 'No transpose', I3, J3, - $ JB, -ONE, WORK31, LDWORK, WORK13, - $ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 ) - END IF -* -* Copy the lower triangle of A13 back into place -* - DO 150 JJ = 1, J3 - DO 140 II = JJ, JB - AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ ) - 140 CONTINUE - 150 CONTINUE - END IF - ELSE -* -* Adjust the pivot indices. -* - DO 160 I = J, J + JB - 1 - IPIV( I ) = IPIV( I ) + J - 1 - 160 CONTINUE - END IF -* -* Partially undo the interchanges in the current block to -* restore the upper triangular form of A31 and copy the upper -* triangle of A31 back into place -* - DO 170 JJ = J + JB - 1, J, -1 - JP = IPIV( JJ ) - JJ + 1 - IF( JP.NE.1 ) THEN -* -* Apply interchange to columns J to JJ-1 -* - IF( JP+JJ-1.LT.J+KL ) THEN -* -* The interchange does not affect A31 -* - CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, - $ AB( KV+JP+JJ-J, J ), LDAB-1 ) - ELSE -* -* The interchange does affect A31 -* - CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, - $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) - END IF - END IF -* -* Copy the current column of A31 back into place -* - NW = MIN( I3, JJ-J+1 ) - IF( NW.GT.0 ) - $ CALL ZCOPY( NW, WORK31( 1, JJ-J+1 ), 1, - $ AB( KV+KL+1-JJ+J, JJ ), 1 ) - 170 CONTINUE - 180 CONTINUE - END IF -* - RETURN -* -* End of ZGBTRF -* - END - - SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, - $ INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 AB( LDAB, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZGBTRS solves a system of linear equations -* A * X = B, A**T * X = B, or A**H * X = B -* with a general band matrix A using the LU factorization computed -* by ZGBTRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations. -* = 'N': A * X = B (No transpose) -* = 'T': A**T * X = B (Transpose) -* = 'C': A**H * X = B (Conjugate transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* KL (input) INTEGER -* The number of subdiagonals within the band of A. KL >= 0. -* -* KU (input) INTEGER -* The number of superdiagonals within the band of A. KU >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* AB (input) COMPLEX*16 array, dimension (LDAB,N) -* Details of the LU factorization of the band matrix A, as -* computed by ZGBTRF. U is stored as an upper triangular band -* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and -* the multipliers used during the factorization are stored in -* rows KL+KU+2 to 2*KL+KU+1. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices; for 1 <= i <= N, row i of the matrix was -* interchanged with row IPIV(i). -* -* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LNOTI, NOTRAN - INTEGER I, J, KD, L, LM -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGEMV, ZGERU, ZLACGV, ZSWAP, ZTBSV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -5 - ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGBTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - KD = KU + KL + 1 - LNOTI = KL.GT.0 -* - IF( NOTRAN ) THEN -* -* Solve A*X = B. -* -* Solve L*X = B, overwriting B with X. -* -* L is represented as a product of permutations and unit lower -* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), -* where each transformation L(i) is a rank-one modification of -* the identity matrix. -* - IF( LNOTI ) THEN - DO 10 J = 1, N - 1 - LM = MIN( KL, N-J ) - L = IPIV( J ) - IF( L.NE.J ) - $ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) - CALL ZGERU( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), - $ LDB, B( J+1, 1 ), LDB ) - 10 CONTINUE - END IF -* - DO 20 I = 1, NRHS -* -* Solve U*X = B, overwriting B with X. -* - CALL ZTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, - $ AB, LDAB, B( 1, I ), 1 ) - 20 CONTINUE -* - ELSE IF( LSAME( TRANS, 'T' ) ) THEN -* -* Solve A**T * X = B. -* - DO 30 I = 1, NRHS -* -* Solve U**T * X = B, overwriting B with X. -* - CALL ZTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, - $ LDAB, B( 1, I ), 1 ) - 30 CONTINUE -* -* Solve L**T * X = B, overwriting B with X. -* - IF( LNOTI ) THEN - DO 40 J = N - 1, 1, -1 - LM = MIN( KL, N-J ) - CALL ZGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), - $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) - L = IPIV( J ) - IF( L.NE.J ) - $ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) - 40 CONTINUE - END IF -* - ELSE -* -* Solve A**H * X = B. -* - DO 50 I = 1, NRHS -* -* Solve U**H * X = B, overwriting B with X. -* - CALL ZTBSV( 'Upper', 'Conjugate transpose', 'Non-unit', N, - $ KL+KU, AB, LDAB, B( 1, I ), 1 ) - 50 CONTINUE -* -* Solve L**H * X = B, overwriting B with X. -* - IF( LNOTI ) THEN - DO 60 J = N - 1, 1, -1 - LM = MIN( KL, N-J ) - CALL ZLACGV( NRHS, B( J, 1 ), LDB ) - CALL ZGEMV( 'Conjugate transpose', LM, NRHS, -ONE, - $ B( J+1, 1 ), LDB, AB( KD+1, J ), 1, ONE, - $ B( J, 1 ), LDB ) - CALL ZLACGV( NRHS, B( J, 1 ), LDB ) - L = IPIV( J ) - IF( L.NE.J ) - $ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) - 60 CONTINUE - END IF - END IF - RETURN -* -* End of ZGBTRS -* - END - - SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 AB( LDAB, * ) -* .. -* -* Purpose -* ======= -* -* ZGBTF2 computes an LU factorization of a complex m-by-n band matrix -* A using partial pivoting with row interchanges. -* -* This is the unblocked version of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* KL (input) INTEGER -* The number of subdiagonals within the band of A. KL >= 0. -* -* KU (input) INTEGER -* The number of superdiagonals within the band of A. KU >= 0. -* -* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) -* On entry, the matrix A in band storage, in rows KL+1 to -* 2*KL+KU+1; rows 1 to KL of the array need not be set. -* The j-th column of A is stored in the j-th column of the -* array AB as follows: -* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) -* -* On exit, details of the factorization: U is stored as an -* upper triangular band matrix with KL+KU superdiagonals in -* rows 1 to KL+KU+1, and the multipliers used during the -* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. -* See below for further details. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* Further Details -* =============== -* -* The band storage scheme is illustrated by the following example, when -* M = N = 6, KL = 2, KU = 1: -* -* On entry: On exit: -* -* * * * + + + * * * u14 u25 u36 -* * * + + + + * * u13 u24 u35 u46 -* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * -* a31 a42 a53 a64 * * m31 m42 m53 m64 * * -* -* Array elements marked * are not used by the routine; elements marked -* + need not be set on entry, but are required by the routine to store -* elements of U, because of fill-in resulting from the row -* interchanges. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, J, JP, JU, KM, KV -* .. -* .. External Functions .. - INTEGER IZAMAX - EXTERNAL IZAMAX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* KV is the number of superdiagonals in the factor U, allowing for -* fill-in. -* - KV = KU + KL -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.KL+KV+1 ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGBTF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Gaussian elimination with partial pivoting -* -* Set fill-in elements in columns KU+2 to KV to zero. -* - DO 20 J = KU + 2, MIN( KV, N ) - DO 10 I = KV - J + 2, KL - AB( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* -* JU is the index of the last column affected by the current stage -* of the factorization. -* - JU = 1 -* - DO 40 J = 1, MIN( M, N ) -* -* Set fill-in elements in column J+KV to zero. -* - IF( J+KV.LE.N ) THEN - DO 30 I = 1, KL - AB( I, J+KV ) = ZERO - 30 CONTINUE - END IF -* -* Find pivot and test for singularity. KM is the number of -* subdiagonal elements in the current column. -* - KM = MIN( KL, M-J ) - JP = IZAMAX( KM+1, AB( KV+1, J ), 1 ) - IPIV( J ) = JP + J - 1 - IF( AB( KV+JP, J ).NE.ZERO ) THEN - JU = MAX( JU, MIN( J+KU+JP-1, N ) ) -* -* Apply interchange to columns J to JU. -* - IF( JP.NE.1 ) - $ CALL ZSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1, - $ AB( KV+1, J ), LDAB-1 ) - IF( KM.GT.0 ) THEN -* -* Compute multipliers. -* - CALL ZSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 ) -* -* Update trailing submatrix within the band. -* - IF( JU.GT.J ) - $ CALL ZGERU( KM, JU-J, -ONE, AB( KV+2, J ), 1, - $ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ), - $ LDAB-1 ) - END IF - ELSE -* -* If pivot is zero, set INFO to the index of the pivot -* unless a zero pivot has already been found. -* - IF( INFO.EQ.0 ) - $ INFO = J - END IF - 40 CONTINUE - RETURN -* -* End of ZGBTF2 -* - END - - SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZLASWP performs a series of row interchanges on the matrix A. -* One row interchange is initiated for each of rows K1 through K2 of A. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the matrix of column dimension N to which the row -* interchanges will be applied. -* On exit, the permuted matrix. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* -* K1 (input) INTEGER -* The first element of IPIV for which a row interchange will -* be done. -* -* K2 (input) INTEGER -* The last element of IPIV for which a row interchange will -* be done. -* -* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) -* The vector of pivot indices. Only the elements in positions -* K1 through K2 of IPIV are accessed. -* IPIV(K) = L implies rows K and L are to be interchanged. -* -* INCX (input) INTEGER -* The increment between successive values of IPIV. If IPIV -* is negative, the pivots are applied in reverse order. -* -* Further Details -* =============== -* -* Modified by -* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - COMPLEX*16 TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) for each of rows K1 through K2. -* - IF( INCX.GT.0 ) THEN - IX0 = K1 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of ZLASWP -* - END - - - -* end these routines for w90 * diff --git a/quantum_espresso/kcp/flib/lapack_mkl.f b/quantum_espresso/kcp/flib/lapack_mkl.f deleted file mode 100644 index d20bf8afd..000000000 --- a/quantum_espresso/kcp/flib/lapack_mkl.f +++ /dev/null @@ -1,299 +0,0 @@ - SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) -* -* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- -* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., -* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY -* OCTOBER 31, 1992 -* -* .. SCALAR ARGUMENTS .. - DOUBLE PRECISION A, B, C, RT1, RT2 -* .. -* -* PURPOSE -* ======= -* -* DLAE2 COMPUTES THE EIGENVALUES OF A 2-BY-2 SYMMETRIC MATRIX -* [ A B ] -* [ B C ]. -* ON RETURN, RT1 IS THE EIGENVALUE OF LARGER ABSOLUTE VALUE, AND RT2 -* IS THE EIGENVALUE OF SMALLER ABSOLUTE VALUE. -* -* ARGUMENTS -* ========= -* -* A (INPUT) DOUBLE PRECISION -* THE (1,1) ENTRY OF THE 2-BY-2 MATRIX. -* -* B (INPUT) DOUBLE PRECISION -* THE (1,2) AND (2,1) ENTRIES OF THE 2-BY-2 MATRIX. -* -* C (INPUT) DOUBLE PRECISION -* THE (2,2) ENTRY OF THE 2-BY-2 MATRIX. -* -* RT1 (OUTPUT) DOUBLE PRECISION -* THE EIGENVALUE OF LARGER ABSOLUTE VALUE. -* -* RT2 (OUTPUT) DOUBLE PRECISION -* THE EIGENVALUE OF SMALLER ABSOLUTE VALUE. -* -* FURTHER DETAILS -* =============== -* -* RT1 IS ACCURATE TO A FEW ULPS BARRING OVER/UNDERFLOW. -* -* RT2 MAY BE INACCURATE IF THERE IS MASSIVE CANCELLATION IN THE -* DETERMINANT A*C-B*B; HIGHER PRECISION OR CORRECTLY ROUNDED OR -* CORRECTLY TRUNCATED ARITHMETIC WOULD BE NEEDED TO COMPUTE RT2 -* ACCURATELY IN ALL CASES. -* -* OVERFLOW IS POSSIBLE ONLY IF RT1 IS WITHIN A FACTOR OF 5 OF OVERFLOW. -* UNDERFLOW IS HARMLESS IF THE INPUT DATA IS 0 OR EXCEEDS -* UNDERFLOW_THRESHOLD / MACHEPS. -* -* ===================================================================== -* -* .. PARAMETERS .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION HALF - PARAMETER ( HALF = 0.5D0 ) -* .. -* .. LOCAL SCALARS .. - DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB -* .. -* .. INTRINSIC FUNCTIONS .. - INTRINSIC ABS, SQRT -* .. -* .. EXECUTABLE STATEMENTS .. -* -* COMPUTE THE EIGENVALUES -* - SM = A + C - DF = A - C - ADF = ABS( DF ) - TB = B + B - AB = ABS( TB ) - IF( ABS( A ).GT.ABS( C ) ) THEN - ACMX = A - ACMN = C - ELSE - ACMX = C - ACMN = A - END IF - IF( ADF.GT.AB ) THEN - RT = ADF*SQRT( ONE+( AB / ADF )**2 ) - ELSE IF( ADF.LT.AB ) THEN - RT = AB*SQRT( ONE+( ADF / AB )**2 ) - ELSE -* -* INCLUDES CASE AB=ADF=0 -* - RT = AB*SQRT( TWO ) - END IF - IF( SM.LT.ZERO ) THEN - RT1 = HALF*( SM-RT ) -* -* ORDER OF EXECUTION IMPORTANT. -* TO GET FULLY ACCURATE SMALLER EIGENVALUE, -* NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE IF( SM.GT.ZERO ) THEN - RT1 = HALF*( SM+RT ) -* -* ORDER OF EXECUTION IMPORTANT. -* TO GET FULLY ACCURATE SMALLER EIGENVALUE, -* NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE -* -* INCLUDES CASE RT1 = RT2 = 0 -* - RT1 = HALF*RT - RT2 = -HALF*RT - END IF - RETURN -* -* END OF DLAE2 -* - END - SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) -* -* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- -* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., -* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY -* OCTOBER 31, 1992 -* -* .. SCALAR ARGUMENTS .. - DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 -* .. -* -* PURPOSE -* ======= -* -* DLAEV2 COMPUTES THE EIGENDECOMPOSITION OF A 2-BY-2 SYMMETRIC MATRIX -* [ A B ] -* [ B C ]. -* ON RETURN, RT1 IS THE EIGENVALUE OF LARGER ABSOLUTE VALUE, RT2 IS THE -* EIGENVALUE OF SMALLER ABSOLUTE VALUE, AND (CS1,SN1) IS THE UNIT RIGHT -* EIGENVECTOR FOR RT1, GIVING THE DECOMPOSITION -* -* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] -* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. -* -* ARGUMENTS -* ========= -* -* A (INPUT) DOUBLE PRECISION -* THE (1,1) ENTRY OF THE 2-BY-2 MATRIX. -* -* B (INPUT) DOUBLE PRECISION -* THE (1,2) ENTRY AND THE CONJUGATE OF THE (2,1) ENTRY OF THE -* 2-BY-2 MATRIX. -* -* C (INPUT) DOUBLE PRECISION -* THE (2,2) ENTRY OF THE 2-BY-2 MATRIX. -* -* RT1 (OUTPUT) DOUBLE PRECISION -* THE EIGENVALUE OF LARGER ABSOLUTE VALUE. -* -* RT2 (OUTPUT) DOUBLE PRECISION -* THE EIGENVALUE OF SMALLER ABSOLUTE VALUE. -* -* CS1 (OUTPUT) DOUBLE PRECISION -* SN1 (OUTPUT) DOUBLE PRECISION -* THE VECTOR (CS1, SN1) IS A UNIT RIGHT EIGENVECTOR FOR RT1. -* -* FURTHER DETAILS -* =============== -* -* RT1 IS ACCURATE TO A FEW ULPS BARRING OVER/UNDERFLOW. -* -* RT2 MAY BE INACCURATE IF THERE IS MASSIVE CANCELLATION IN THE -* DETERMINANT A*C-B*B; HIGHER PRECISION OR CORRECTLY ROUNDED OR -* CORRECTLY TRUNCATED ARITHMETIC WOULD BE NEEDED TO COMPUTE RT2 -* ACCURATELY IN ALL CASES. -* -* CS1 AND SN1 ARE ACCURATE TO A FEW ULPS BARRING OVER/UNDERFLOW. -* -* OVERFLOW IS POSSIBLE ONLY IF RT1 IS WITHIN A FACTOR OF 5 OF OVERFLOW. -* UNDERFLOW IS HARMLESS IF THE INPUT DATA IS 0 OR EXCEEDS -* UNDERFLOW_THRESHOLD / MACHEPS. -* -* ===================================================================== -* -* .. PARAMETERS .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION HALF - PARAMETER ( HALF = 0.5D0 ) -* .. -* .. LOCAL SCALARS .. - INTEGER SGN1, SGN2 - DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, - $ TB, TN -* .. -* .. INTRINSIC FUNCTIONS .. - INTRINSIC ABS, SQRT -* .. -* .. EXECUTABLE STATEMENTS .. -* -* COMPUTE THE EIGENVALUES -* - SM = A + C - DF = A - C - ADF = ABS( DF ) - TB = B + B - AB = ABS( TB ) - IF( ABS( A ).GT.ABS( C ) ) THEN - ACMX = A - ACMN = C - ELSE - ACMX = C - ACMN = A - END IF - IF( ADF.GT.AB ) THEN - RT = ADF*SQRT( ONE+( AB / ADF )**2 ) - ELSE IF( ADF.LT.AB ) THEN - RT = AB*SQRT( ONE+( ADF / AB )**2 ) - ELSE -* -* INCLUDES CASE AB=ADF=0 -* - RT = AB*SQRT( TWO ) - END IF - IF( SM.LT.ZERO ) THEN - RT1 = HALF*( SM-RT ) - SGN1 = -1 -* -* ORDER OF EXECUTION IMPORTANT. -* TO GET FULLY ACCURATE SMALLER EIGENVALUE, -* NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE IF( SM.GT.ZERO ) THEN - RT1 = HALF*( SM+RT ) - SGN1 = 1 -* -* ORDER OF EXECUTION IMPORTANT. -* TO GET FULLY ACCURATE SMALLER EIGENVALUE, -* NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE -* -* INCLUDES CASE RT1 = RT2 = 0 -* - RT1 = HALF*RT - RT2 = -HALF*RT - SGN1 = 1 - END IF -* -* COMPUTE THE EIGENVECTOR -* - IF( DF.GE.ZERO ) THEN - CS = DF + RT - SGN2 = 1 - ELSE - CS = DF - RT - SGN2 = -1 - END IF - ACS = ABS( CS ) - IF( ACS.GT.AB ) THEN - CT = -TB / CS - SN1 = ONE / SQRT( ONE+CT*CT ) - CS1 = CT*SN1 - ELSE - IF( AB.EQ.ZERO ) THEN - CS1 = ONE - SN1 = ZERO - ELSE - TN = -CS / TB - CS1 = ONE / SQRT( ONE+TN*TN ) - SN1 = TN*CS1 - END IF - END IF - IF( SGN1.EQ.SGN2 ) THEN - TN = CS1 - CS1 = -SN1 - SN1 = TN - END IF - RETURN -* -* END OF DLAEV2 -* - END - - INTEGER FUNCTION ILAENV () - ILAENV=64 - RETURN - END diff --git a/quantum_espresso/kcp/flib/latgen.f90 b/quantum_espresso/kcp/flib/latgen.f90 deleted file mode 100644 index 4bcbada46..000000000 --- a/quantum_espresso/kcp/flib/latgen.f90 +++ /dev/null @@ -1,306 +0,0 @@ -! -! Copyright (C) 2001-2003 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!------------------------------------------------------------------------- -subroutine latgen(ibrav,celldm,a1,a2,a3,omega) - !----------------------------------------------------------------------- - ! sets up the crystallographic vectors a1, a2, and a3. - ! - ! ibrav is the structure index: - ! 1 cubic p (sc) 8 orthorhombic p - ! 2 cubic f (fcc) 9 one face centered orthorhombic - ! 3 cubic i (bcc) 10 all face centered orthorhombic - ! 4 hexagonal and trigonal p 11 body centered orthorhombic - ! 5 trigonal r 12 monoclinic p - ! 6 tetragonal p (st) 13 one face centered monoclinic - ! 7 tetragonal i (bct) 14 triclinic p - ! - ! celldm are parameters which fix the shape of the unit cell - ! omega is the unit-cell volume - ! - ! NOTA BENE: all axis sets are right-handed - ! Boxes for US PPs do not work properly with left-handed axis - ! - use kinds, only: DP - implicit none - integer, intent(in) :: ibrav - real(DP), intent(inout) :: celldm(6) - real(DP), intent(inout) :: a1(3), a2(3), a3(3) - real(DP), intent(out) :: omega - ! - real(DP), parameter:: sr2 = 1.414213562373d0, & - sr3 = 1.732050807569d0 - integer :: i,j,k,l,iperm,ir - real(DP) :: term, cbya, s, term1, term2, singam, sen - ! - ! user-supplied lattice vectors - ! - if (ibrav == 0) then - if (SQRT( a1(1)**2 + a1(2)**2 + a1(3)**2 ) == 0 ) & - call errore ('latgen', 'wrong at for ibrav=0', 1) - if (SQRT( a2(1)**2 + a2(2)**2 + a2(3)**2 ) == 0 ) & - call errore ('latgen', 'wrong at for ibrav=0', 2) - if (SQRT( a3(1)**2 + a3(2)**2 + a3(3)**2 ) == 0 ) & - call errore ('latgen', 'wrong at for ibrav=0', 3) - - if ( celldm(1) /= 0.D0 ) then - ! - ! ... input at are in units of alat => convert them to a.u. - ! - a1(:) = a1(:) * celldm(1) - a2(:) = a2(:) * celldm(1) - a3(:) = a3(:) * celldm(1) - else - ! - ! ... input at are in atomic units: define celldm(1) from a1 - ! - celldm(1) = SQRT( a1(1)**2 + a1(2)**2 + a1(3)**2 ) - end if - ! - else - a1(:) = 0.d0 - a2(:) = 0.d0 - a3(:) = 0.d0 - end if - ! - if (celldm (1) <= 0.d0) call errore ('latgen', 'wrong celldm(1)', ibrav) - ! - ! index of bravais lattice supplied - ! - if (ibrav == 1) then - ! - ! simple cubic lattice - ! - a1(1)=celldm(1) - a2(2)=celldm(1) - a3(3)=celldm(1) - ! - else if (ibrav == 2) then - ! - ! fcc lattice - ! - term=celldm(1)/2.d0 - a1(1)=-term - a1(3)=term - a2(2)=term - a2(3)=term - a3(1)=-term - a3(2)=term - ! - else if (ibrav == 3) then - ! - ! bcc lattice - ! - term=celldm(1)/2.d0 - do ir=1,3 - a1(ir)=term - a2(ir)=term - a3(ir)=term - end do - a2(1)=-term - a3(1)=-term - a3(2)=-term - ! - else if (ibrav == 4) then - ! - ! hexagonal lattice - ! - if (celldm (3) <= 0.d0) call errore ('latgen', 'wrong celldm(3)', ibrav) - ! - cbya=celldm(3) - a1(1)=celldm(1) - a2(1)=-celldm(1)/2.d0 - a2(2)=celldm(1)*sr3/2.d0 - a3(3)=celldm(1)*cbya - ! - else if (ibrav == 5) then - ! - ! trigonal lattice - ! - if (celldm (4) <= -0.5d0 .or. celldm (4) >= 1) & - call errore ('latgen', 'wrong celldm(4)', ibrav) - ! - term1=sqrt(1.d0+2.d0*celldm(4)) - term2=sqrt(1.d0-celldm(4)) - a2(2)=sr2*celldm(1)*term2/sr3 - a2(3)=celldm(1)*term1/sr3 - a1(1)=celldm(1)*term2/sr2 - a1(2)=-a1(1)/sr3 - a1(3)= a2(3) - a3(1)=-a1(1) - a3(2)= a1(2) - a3(3)= a2(3) - ! - else if (ibrav == 6) then - ! - ! tetragonal lattice - ! - if (celldm (3) <= 0.d0) call errore ('latgen', 'wrong celldm(3)', ibrav) - ! - cbya=celldm(3) - a1(1)=celldm(1) - a2(2)=celldm(1) - a3(3)=celldm(1)*cbya - ! - else if (ibrav == 7) then - ! - ! body centered tetragonal lattice - ! - if (celldm (3) <= 0.d0) call errore ('latgen', 'wrong celldm(3)', ibrav) - ! - cbya=celldm(3) - a2(1)=celldm(1)/2.d0 - a2(2)=a2(1) - a2(3)=cbya*celldm(1)/2.d0 - a1(1)= a2(1) - a1(2)=-a2(1) - a1(3)= a2(3) - a3(1)=-a2(1) - a3(2)=-a2(1) - a3(3)= a2(3) - ! - else if (ibrav == 8) then - ! - ! Simple orthorhombic lattice - ! - if (celldm (2) <= 0.d0) call errore ('latgen', 'wrong celldm(2)', ibrav) - if (celldm (3) <= 0.d0) call errore ('latgen', 'wrong celldm(3)', ibrav) - ! - a1(1)=celldm(1) - a2(2)=celldm(1)*celldm(2) - a3(3)=celldm(1)*celldm(3) - ! - else if (ibrav == 9) then - ! - ! - ! One face centered orthorhombic lattice - ! - if (celldm (2) <= 0.d0) call errore ('latgen', 'wrong celldm(2)', ibrav) - if (celldm (3) <= 0.d0) call errore ('latgen', 'wrong celldm(3)', ibrav) - ! - a1(1) = 0.5d0 * celldm(1) - a1(2) = a1(1) * celldm(2) - a2(1) = - a1(1) - a2(2) = a1(2) - a3(3) = celldm(1) * celldm(3) - ! - else if (ibrav == 10) then - ! - ! All face centered orthorhombic lattice - ! - if (celldm (2) <= 0.d0) call errore ('latgen', 'wrong celldm(2)', ibrav) - if (celldm (3) <= 0.d0) call errore ('latgen', 'wrong celldm(3)', ibrav) - ! - a2(1) = 0.5d0 * celldm(1) - a2(2) = a2(1) * celldm(2) - a1(1) = a2(1) - a1(3) = a2(1) * celldm(3) - a3(2) = a2(1) * celldm(2) - a3(3) = a1(3) - ! - else if (ibrav == 11) then - ! - ! Body centered orthorhombic lattice - ! - if (celldm (2) <= 0.d0) call errore ('latgen', 'wrong celldm(2)', ibrav) - if (celldm (3) <= 0.d0) call errore ('latgen', 'wrong celldm(3)', ibrav) - ! - a1(1) = 0.5d0 * celldm(1) - a1(2) = a1(1) * celldm(2) - a1(3) = a1(1) * celldm(3) - a2(1) = - a1(1) - a2(2) = a1(2) - a2(3) = a1(3) - a3(1) = - a1(1) - a3(2) = - a1(2) - a3(3) = a1(3) - ! - else if (ibrav == 12) then - ! - ! Simple monoclinic lattice - ! - if (celldm (2) <= 0.d0) call errore ('latgen', 'wrong celldm(2)', ibrav) - if (celldm (3) <= 0.d0) call errore ('latgen', 'wrong celldm(3)', ibrav) - if (abs(celldm(4))>=1.d0) call errore ('latgen', 'wrong celldm(4)', ibrav) - ! - sen=sqrt(1.d0-celldm(4)**2) - a1(1)=celldm(1) - a2(1)=celldm(1)*celldm(2)*celldm(4) - a2(2)=celldm(1)*celldm(2)*sen - a3(3)=celldm(1)*celldm(3) - ! - else if (ibrav == 13) then - ! - ! One face centered monoclinic lattice - ! - if (celldm (2) <= 0.d0) call errore ('latgen', 'wrong celldm(2)', ibrav) - if (celldm (3) <= 0.d0) call errore ('latgen', 'wrong celldm(3)', ibrav) - if (abs(celldm(4))>=1.d0) call errore ('latgen', 'wrong celldm(4)', ibrav) - ! - sen = sqrt( 1.d0 - celldm(4) ** 2 ) - a1(1) = 0.5d0 * celldm(1) - a1(3) =-a1(1) * celldm(3) - a2(1) = celldm(1) * celldm(2) * celldm(4) - a2(2) = celldm(1) * celldm(2) * sen - a3(1) = a1(1) - a3(3) =-a1(3) - ! - else if (ibrav == 14) then - ! - ! Triclinic lattice - ! - if (celldm (2) <= 0.d0) call errore ('latgen', 'wrong celldm(2)', ibrav) - if (celldm (3) <= 0.d0) call errore ('latgen', 'wrong celldm(3)', ibrav) - if (abs(celldm(4))>=1.d0) call errore ('latgen', 'wrong celldm(4)', ibrav) - if (abs(celldm(5))>=1.d0) call errore ('latgen', 'wrong celldm(5)', ibrav) - if (abs(celldm(6))>=1.d0) call errore ('latgen', 'wrong celldm(6)', ibrav) - ! - singam=sqrt(1.d0-celldm(6)**2) - term= (1.d0+2.d0*celldm(4)*celldm(5)*celldm(6) & - -celldm(4)**2-celldm(5)**2-celldm(6)**2) - if (term < 0.d0) call errore & - ('latgen', 'celldm do not make sense, check your data', ibrav) - term= sqrt(term/(1.d0-celldm(6)**2)) - a1(1)=celldm(1) - a2(1)=celldm(1)*celldm(2)*celldm(6) - a2(2)=celldm(1)*celldm(2)*singam - a3(1)=celldm(1)*celldm(3)*celldm(5) - a3(2)=celldm(1)*celldm(3)*(celldm(4)-celldm(5)*celldm(6))/singam - a3(3)=celldm(1)*celldm(3)*term - ! - else - ! - call errore('latgen',' nonexistent bravais lattice',ibrav) - ! - end if - ! - ! calculate unit-cell volume omega - ! -100 omega=0.d0 - s=1.d0 - i=1 - j=2 - k=3 - ! -101 do iperm=1,3 - omega=omega+s*a1(i)*a2(j)*a3(k) - l=i - i=j - j=k - k=l - end do -! - i=2 - j=1 - k=3 - s=-s - if(s < 0.d0) go to 101 - omega=abs(omega) - return -! -end subroutine latgen diff --git a/quantum_espresso/kcp/flib/linpack.f90 b/quantum_espresso/kcp/flib/linpack.f90 deleted file mode 100644 index e53537e3f..000000000 --- a/quantum_espresso/kcp/flib/linpack.f90 +++ /dev/null @@ -1,251 +0,0 @@ -#include "f_defs.h" - - SUBROUTINE ZGEFA(A,LDA,N,IPVT,INFO) - USE kinds - INTEGER LDA,N,IPVT(1),INFO - COMPLEX(DP) A(LDA,1) -! -! ZGEFA FACTORS A COMPLEX(DP) MATRIX BY GAUSSIAN ELIMINATION. -! -! ZGEFA IS USUALLY CALLED BY ZGECO, BUT IT CAN BE CALLED -! DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. -! (TIME FOR ZGECO) = (1 + 9/N)*(TIME FOR ZGEFA) . -! -! ON ENTRY -! -! A COMPLEX(DP)(LDA, N) -! THE MATRIX TO BE FACTORED. -! -! LDA INTEGER -! THE LEADING DIMENSION OF THE ARRAY A . -! -! N INTEGER -! THE ORDER OF THE MATRIX A . -! -! ON RETURN -! -! A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS -! WHICH WERE USED TO OBTAIN IT. -! THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE -! L IS A PRODUCT OF PERMUTATION AND UNIT LOWER -! TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. -! -! IPVT INTEGER(N) -! AN INTEGER VECTOR OF PIVOT INDICES. -! -! INFO INTEGER -! = 0 NORMAL VALUE. -! = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR -! CONDITION FOR THIS SUBROUTINE, BUT IT DOES -! INDICATE THAT ZGESL OR ZGEDI WILL DIVIDE BY ZERO -! IF CALLED. USE RCOND IN ZGECO FOR A RELIABLE -! INDICATION OF SINGULARITY. -! -! LINPACK. THIS VERSION DATED 08/14/78 . -! CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. -! -! SUBROUTINES AND FUNCTIONS -! -! BLAS ZAXPY,ZSCAL,IZAMAX -! FORTRAN DABS -! -! INTERNAL VARIABLES -! - COMPLEX(DP) T - INTEGER IZAMAX,J,K,KP1,L,NM1 -! - COMPLEX(DP) ZDUM - REAL(DP) CABS1 - REAL(DP) REAL,AIMAG - COMPLEX(DP) ZDUMR,ZDUMI - REAL(ZDUMR) = ZDUMR - AIMAG(ZDUMI) = (0.0D0,-1.0D0)*ZDUMI - CABS1(ZDUM) = DABS(REAL(ZDUM)) + DABS(AIMAG(ZDUM)) -! -! GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING -! - INFO = 0 - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 70 - DO 60 K = 1, NM1 - KP1 = K + 1 -! -! FIND L = PIVOT INDEX -! - L = IZAMAX(N-K+1,A(K,K),1) + K - 1 - IPVT(K) = L -! -! ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED -! - IF (CABS1(A(L,K)) .EQ. 0.0D0) GO TO 40 -! -! INTERCHANGE IF NECESSARY -! - IF (L .EQ. K) GO TO 10 - T = A(L,K) - A(L,K) = A(K,K) - A(K,K) = T - 10 CONTINUE -! -! COMPUTE MULTIPLIERS -! - T = -(1.0D0,0.0D0)/A(K,K) - CALL ZSCAL(N-K,T,A(K+1,K),1) -! -! ROW ELIMINATION WITH COLUMN INDEXING -! - DO 30 J = KP1, N - T = A(L,J) - IF (L .EQ. K) GO TO 20 - A(L,J) = A(K,J) - A(K,J) = T - 20 CONTINUE - CALL ZAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) - 30 CONTINUE - GO TO 50 - 40 CONTINUE - INFO = K - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE - IPVT(N) = N - IF (CABS1(A(N,N)) .EQ. 0.0D0) INFO = N - RETURN - END SUBROUTINE ZGEFA - - SUBROUTINE ZGEDI(A,LDA,N,IPVT,DET,WORK,JOB) - USE kinds - INTEGER LDA,N,IPVT(1),JOB - COMPLEX(DP) A(LDA,1),DET(2),WORK(1) -! -! ZGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX -! USING THE FACTORS COMPUTED BY ZGECO OR ZGEFA. -! -! ON ENTRY -! -! A COMPLEX(DP)(LDA, N) -! THE OUTPUT FROM ZGECO OR ZGEFA. -! -! LDA INTEGER -! THE LEADING DIMENSION OF THE ARRAY A . -! -! N INTEGER -! THE ORDER OF THE MATRIX A . -! -! IPVT INTEGER(N) -! THE PIVOT VECTOR FROM ZGECO OR ZGEFA. -! -! WORK COMPLEX(DP)(N) -! WORK VECTOR. CONTENTS DESTROYED. -! -! JOB INTEGER -! = 11 BOTH DETERMINANT AND INVERSE. -! = 01 INVERSE ONLY. -! = 10 DETERMINANT ONLY. -! -! ON RETURN -! -! A INVERSE OF ORIGINAL MATRIX IF REQUESTED. -! OTHERWISE UNCHANGED. -! -! DET COMPLEX(DP)(2) -! DETERMINANT OF ORIGINAL MATRIX IF REQUESTED. -! OTHERWISE NOT REFERENCED. -! DETERMINANT = DET(1) * 10.0**DET(2) -! WITH 1.0 .LE. CABS1(DET(1)) .LT. 10.0 -! OR DET(1) .EQ. 0.0 . -! -! ERROR CONDITION -! -! A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS -! A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED. -! IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY -! AND IF ZGECO HAS SET RCOND .GT. 0.0 OR ZGEFA HAS SET -! INFO .EQ. 0 . -! -! LINPACK. THIS VERSION DATED 08/14/78 . -! CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. -! -! SUBROUTINES AND FUNCTIONS -! -! BLAS ZAXPY,ZSCAL,ZSWAP -! FORTRAN DABS,CMPLX,MOD -! -! INTERNAL VARIABLES -! - COMPLEX(DP) T - REAL(DP) TEN - INTEGER I,J,K,KB,KP1,L,NM1 -! - COMPLEX(DP) ZDUM - REAL(DP) CABS1 - REAL(DP) REAL,AIMAG - COMPLEX(DP) ZDUMR,ZDUMI - REAL(ZDUMR) = ZDUMR - AIMAG(ZDUMI) = (0.0D0,-1.0D0)*ZDUMI - CABS1(ZDUM) = DABS(REAL(ZDUM)) + DABS(AIMAG(ZDUM)) -! -! COMPUTE DETERMINANT -! - IF (JOB/10 .EQ. 0) GO TO 70 - DET(1) = (1.0D0,0.0D0) - DET(2) = (0.0D0,0.0D0) - TEN = 10.0D0 - DO 50 I = 1, N - IF (IPVT(I) .NE. I) DET(1) = -DET(1) - DET(1) = A(I,I)*DET(1) -! ...EXIT - IF (CABS1(DET(1)) .EQ. 0.0D0) GO TO 60 - 10 IF (CABS1(DET(1)) .GE. 1.0D0) GO TO 20 - DET(1) = CMPLX(TEN,0.0D0)*DET(1) - DET(2) = DET(2) - (1.0D0,0.0D0) - GO TO 10 - 20 CONTINUE - 30 IF (CABS1(DET(1)) .LT. TEN) GO TO 40 - DET(1) = DET(1)/CMPLX(TEN,0.0D0) - DET(2) = DET(2) + (1.0D0,0.0D0) - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE -! -! COMPUTE INVERSE(U) -! - IF (MOD(JOB,10) .EQ. 0) GO TO 150 - DO 100 K = 1, N - A(K,K) = (1.0D0,0.0D0)/A(K,K) - T = -A(K,K) - CALL ZSCAL(K-1,T,A(1,K),1) - KP1 = K + 1 - IF (N .LT. KP1) GO TO 90 - DO 80 J = KP1, N - T = A(K,J) - A(K,J) = (0.0D0,0.0D0) - CALL ZAXPY(K,T,A(1,K),1,A(1,J),1) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE -! -! FORM INVERSE(U)*INVERSE(L) -! - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 140 - DO 130 KB = 1, NM1 - K = N - KB - KP1 = K + 1 - DO 110 I = KP1, N - WORK(I) = A(I,K) - A(I,K) = (0.0D0,0.0D0) - 110 CONTINUE - DO 120 J = KP1, N - T = WORK(J) - CALL ZAXPY(N,T,A(1,J),1,A(1,K),1) - 120 CONTINUE - L = IPVT(K) - IF (L .NE. K) CALL ZSWAP(N,A(1,K),1,A(1,L),1) - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - RETURN - END SUBROUTINE ZGEDI diff --git a/quantum_espresso/kcp/flib/localdim.f90 b/quantum_espresso/kcp/flib/localdim.f90 deleted file mode 100644 index 8d6548f85..000000000 --- a/quantum_espresso/kcp/flib/localdim.f90 +++ /dev/null @@ -1,231 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - - - INTEGER FUNCTION ldim_cyclic(gdim, np, me) - -! gdim = global dimension of distributed array -! np = number of processors -! me = index of the calling processor (starting from 0) -! -! this function return the number of elements of the distributed array -! stored in the local memory of the processor "me" for a cyclic -! data distribution. -! Example of the cyclic distribution of a 10 elements array on 4 processors -! array elements | PEs -! a(1) | 0 -! a(2) | 1 -! a(3) | 2 -! a(4) | 3 -! a(5) | 0 -! a(6) | 1 -! a(7) | 2 -! a(8) | 3 -! a(9) | 0 -! a(10) | 1 - - IMPLICIT NONE - INTEGER :: gdim, np, me, r, q - - IF( me >= np .OR. me < 0 ) THEN - WRITE(6,*) ' ** ldim_cyclic: arg no. 3 out of range ' - STOP - END IF - - q = INT(gdim / np) - r = MOD(gdim, np) - - IF( me .LT. r ) THEN - ldim_cyclic = q+1 - ELSE - ldim_cyclic = q - END IF - - RETURN - END FUNCTION ldim_cyclic - -!=----------------------------------------------------------------------------=! - - INTEGER FUNCTION ldim_block(gdim, np, me) - -! gdim = global dimension of distributed array -! np = number of processors -! me = index of the calling processor (starting from 0) -! -! this function return the number of elements of the distributed array -! stored in the local memory of the processor "me" for a balanced block -! data distribution, with the larger block on the lower index processors. -! Example of the block distribution of 10 elements array a on 4 processors -! array elements | PEs -! a(1) | 0 -! a(2) | 0 -! a(3) | 0 -! a(4) | 1 -! a(5) | 1 -! a(6) | 1 -! a(7) | 2 -! a(8) | 2 -! a(9) | 3 -! a(10) | 3 - - IMPLICIT NONE - INTEGER :: gdim, np, me, r, q - - IF( me >= np .OR. me < 0 ) THEN - WRITE(6,*) ' ** ldim_block: arg no. 3 out of range ' - STOP - END IF - - q = INT(gdim / np) - r = MOD(gdim, np) - - IF( me .LT. r ) THEN -! ... if my index is less than the reminder I got an extra element - ldim_block = q+1 - ELSE - ldim_block = q - END IF - - RETURN - END FUNCTION ldim_block - -!=----------------------------------------------------------------------------=! - - INTEGER FUNCTION ldim_block_sca( gdim, np, me ) - -! gdim = global dimension of distributed array -! np = number of processors -! me = index of the calling processor (starting from 0) -! -! this function return the number of elements of the distributed array -! stored in the local memory of the processor "me" for equal block -! data distribution, all block have the same size but the last one. -! Example of the block distribution of 10 elements array a on 4 processors -! array elements | PEs -! a(1) | 0 -! a(2) | 0 -! a(3) | 0 -! a(4) | 1 -! a(5) | 1 -! a(6) | 1 -! a(7) | 2 -! a(8) | 2 -! a(9) | 2 -! a(10) | 3 - - IMPLICIT NONE - INTEGER :: gdim, np, me, nb - - IF( me >= np .OR. me < 0 ) THEN - WRITE(6,*) ' ** ldim_block: arg no. 3 out of range ' - STOP - END IF - - nb = INT( gdim / np ) - IF( MOD( gdim, np ) /= 0 ) THEN - nb = nb+1 - ! ... last processor take the rest - IF( me == ( np - 1 ) ) nb = gdim - (np-1)*nb - END IF - - ldim_block_sca = nb - - - RETURN - END FUNCTION ldim_block_sca - -!=----------------------------------------------------------------------------=! - - - - INTEGER FUNCTION ldim_block_cyclic( N, NB, NPROCS, IPROC ) - -! -- Derived from: NUMROC( N, NB, IPROC, ISRCPROC, NPROCS ) -! -- ScaLAPACK tools routine (version 1.5) -- -! University of Tennessee, Knoxville, Oak Ridge National Laboratory, -! and University of California, Berkeley. -! May 1, 1997 -! -! .. Scalar Arguments .. - IMPLICIT NONE - INTEGER IPROC, ISRCPROC, N, NB, NPROCS, NUMROC -! .. -! -! Purpose -! ======= -! -! NUMROC computes the NUMber of Rows Or Columns of a distributed -! matrix owned by the process indicated by IPROC. -! -! Arguments -! ========= -! -! N (global input) INTEGER -! The number of rows/columns in distributed matrix. -! -! NB (global input) INTEGER -! Block size, size of the blocks the distributed matrix is -! split into. -! -! IPROC (local input) INTEGER -! The coordinate of the process whose local array row or -! column is to be determined. -! -! ISRCPROC (global input) INTEGER -! The coordinate of the process that possesses the first -! row or column of the distributed matrix. -! -! NPROCS (global input) INTEGER -! The total number processes over which the matrix is -! distributed. -! -! ===================================================================== -! -! .. Local Scalars .. - INTEGER EXTRABLKS, MYDIST, NBLOCKS -! .. -! .. Intrinsic Functions .. - INTRINSIC MOD -! .. -! .. Executable Statements .. -! -! Figure PROC's distance from source process -! - ISRCPROC = 0 - MYDIST = MOD( NPROCS+IPROC-ISRCPROC, NPROCS ) -! -! Figure the total number of whole NB blocks N is split up into -! - NBLOCKS = N / NB -! -! Figure the minimum number of rows/cols a process can have -! - NUMROC = (NBLOCKS/NPROCS) * NB -! -! See if there are any extra blocks -! - EXTRABLKS = MOD( NBLOCKS, NPROCS ) -! -! If I have an extra block -! - IF( MYDIST.LT.EXTRABLKS ) THEN - NUMROC = NUMROC + NB -! -! If I have last block, it may be a partial block -! - ELSE IF( MYDIST.EQ.EXTRABLKS ) THEN - NUMROC = NUMROC + MOD( N, NB ) - END IF -! - - ldim_block_cyclic = numroc - RETURN -! -! End of NUMROC -! - END FUNCTION ldim_block_cyclic diff --git a/quantum_espresso/kcp/flib/localindex.f90 b/quantum_espresso/kcp/flib/localindex.f90 deleted file mode 100644 index 5207adae8..000000000 --- a/quantum_espresso/kcp/flib/localindex.f90 +++ /dev/null @@ -1,273 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - - - INTEGER FUNCTION lind_block(ig, nx, np, me) -! -! INPUT : -! ig global index of the x dimension of array element -! nx dimension of the global array -! np number of processor in the x dimension of the processors grid -! me index of the local processor in the processor grid -! (starting from zero) -! -! OUTPUT : -! -! lind_block return the local index corresponding to the -! global index "ig" for a balanced block distribution -! - - IMPLICIT NONE - - INTEGER :: ig, nx, np, me, r, q - - q = INT(nx/np) - r = MOD(nx,np) - - IF( me < r ) THEN - lind_block = ig - (q+1) * me - ELSE - lind_block = ig - (q+1) * r - q * (me - r) - END IF - - RETURN - END FUNCTION lind_block - - -!=----------------------------------------------------------------------------=! - - - INTEGER FUNCTION lind_block_sca(ig, nx, np, me) -! -! INPUT : -! ig global index of the x dimension of array element -! nx dimension of the global array -! np number of processor in the x dimension of the processors grid -! me index of the local processor in the processor grid -! (starting from zero) -! -! OUTPUT : -! -! lind_block_sca return the local index corresponding to the -! global index "ig" for an equal block distribution -! - - IMPLICIT NONE - - INTEGER :: ig, nx, np, me, nb - - nb = INT( nx / np ) - IF( MOD( nx, np ) /= 0 ) nb = nb+1 - - lind_block_sca = ig - me * nb - - RETURN - END FUNCTION lind_block_sca - - -!=----------------------------------------------------------------------------=! - - - - INTEGER FUNCTION lind_cyclic(ig, nx, np, me) -! -! INPUT : -! ig global index of the x dimension of array element -! nx dimension of the global array -! np number of processor in the x dimension of the processors grid -! me index of the local processor in the processor grid -! (starting from zero) -! -! OUTPUT : -! -! lind_cyclic return the local index corresponding to the -! global index "ig" for a cyclic distribution -! - - IMPLICIT NONE - - INTEGER :: ig, nx, np, me - - lind_cyclic = (ig-1)/np + 1 - - RETURN - END FUNCTION lind_cyclic - - -!=----------------------------------------------------------------------------=! - - - INTEGER FUNCTION lind_block_cyclic( INDXGLOB, NB, NPROCS, IPROC ) - -! Derived from: INDXG2L( INDXGLOB, NB, IPROC, ISRCPROC, NPROCS ) -! -- ScaLAPACK tools routine (version 1.5) -- -! University of Tennessee, Knoxville, Oak Ridge National Laboratory, -! and University of California, Berkeley. -! May 1, 1997 -! -! .. Scalar Arguments .. - IMPLICIT NONE - INTEGER INDXGLOB, IPROC, ISRCPROC, NB, NPROCS, INDXG2L -! .. -! -! Purpose -! ======= -! -! INDXG2L computes the local index of a distributed matrix entry -! pointed to by the global index INDXGLOB. -! -! Arguments -! ========= -! -! INDXGLOB (global input) INTEGER -! The global index of the distributed matrix entry. -! -! NB (global input) INTEGER -! Block size, size of the blocks the distributed matrix is -! split into. -! -! IPROC (local dummy) INTEGER -! Dummy argument in this case in order to unify the calling -! sequence of the tool-routines. -! -! ISRCPROC (local dummy) INTEGER -! Dummy argument in this case in order to unify the calling -! sequence of the tool-routines. -! -! NPROCS (global input) INTEGER -! The total number processes over which the distributed -! matrix is distributed. -! -! ===================================================================== -! -! .. Intrinsic Functions .. - INTRINSIC MOD -! .. -! .. Executable Statements .. -! - ISRCPROC = 0 - INDXG2L = NB*((INDXGLOB-1)/(NB*NPROCS))+MOD(INDXGLOB-1,NB)+1 - lind_block_cyclic = INDXG2L -! - RETURN -! -! End of INDXG2L -! - END FUNCTION lind_block_cyclic - - -!=----------------------------------------------------------------------------=! - - - INTEGER FUNCTION gind_cyclic( lind, n, np, me ) - -! This function computes the global index of a distributed array entry -! pointed to by the local index lind of the process indicated by me. -! lind local index of the distributed matrix entry. -! N is the size of the global array. -! me The coordinate of the process whose local array row or -! column is to be determined. -! np The total number processes over which the distributed -! matrix is distributed. -! - - INTEGER, INTENT(IN) :: lind, n, me, np - INTEGER r, q - - gind_cyclic = (lind-1) * np + me + 1 - - RETURN - END FUNCTION gind_cyclic - - -!=----------------------------------------------------------------------------=! - - - INTEGER FUNCTION gind_block( lind, n, np, me ) - -! This function computes the global index of a distributed array entry -! pointed to by the local index lind of the process indicated by me. -! lind local index of the distributed matrix entry. -! N is the size of the global array. -! me The coordinate of the process whose local array row or -! column is to be determined. -! np The total number processes over which the distributed -! matrix is distributed. - - - INTEGER, INTENT(IN) :: lind, n, me, np - INTEGER r, q - - q = INT(n/np) - r = MOD(n,np) - IF( me < r ) THEN - gind_block = (Q+1)*me + lind - ELSE - gind_block = Q*me + R + lind - END IF - - RETURN - END FUNCTION gind_block - -!=----------------------------------------------------------------------------=! - - INTEGER FUNCTION gind_block_sca( lind, n, np, me ) - -! This function computes the global index of a distributed array entry -! pointed to by the local index lind of the process indicated by me. -! lind local index of the distributed matrix entry. -! N is the size of the global array. -! me The coordinate of the process whose local array row or -! column is to be determined. -! np The total number processes over which the distributed -! matrix is distributed. - - - INTEGER, INTENT(IN) :: lind, n, me, np - INTEGER nb - - IF( me >= np .OR. me < 0 ) THEN - WRITE(6,*) ' ** ldim_block: arg no. 3 out of range ' - STOP - END IF - - nb = INT( n / np ) - IF( MOD( n, np ) /= 0 ) nb = nb+1 - - gind_block_sca = lind + me * nb - - RETURN - - END FUNCTION gind_block_sca - - -!=----------------------------------------------------------------------------=! - - INTEGER FUNCTION gind_block_cyclic( lind, n, nb, np, me ) - -! This function computes the global index of a distributed array entry -! pointed to by the local index lind of the process indicated by me. -! lind local index of the distributed matrix entry. -! N is the size of the global array. -! NB size of the blocks the distributed matrix is split into. -! me The coordinate of the process whose local array row or -! column is to be determined. -! np The total number processes over which the distributed -! matrix is distributed. - - - INTEGER, INTENT(IN) :: lind, n, nb, me, np - INTEGER r, q, isrc - - isrc = 0 - gind_block_cyclic = np*NB*((lind-1)/NB) + & - MOD(lind-1,NB) + MOD(np+me-isrc, np)*NB + 1 - - RETURN - END FUNCTION gind_block_cyclic - diff --git a/quantum_espresso/kcp/flib/lsda_functionals.f90 b/quantum_espresso/kcp/flib/lsda_functionals.f90 deleted file mode 100644 index c4e25acd6..000000000 --- a/quantum_espresso/kcp/flib/lsda_functionals.f90 +++ /dev/null @@ -1,652 +0,0 @@ -! -! Copyright (C) 2001-2009 Quantum ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -subroutine pz_polarized (rs, ec, vc) - !----------------------------------------------------------------------- - ! J.P. Perdew and A. Zunger, PRB 23, 5048 (1981) - ! spin-polarized energy and potential - ! - USE kinds - implicit none - real(DP) :: rs, ec, vc - real(DP) :: a, b, c, d, gc, b1, b2 - parameter (a = 0.01555d0, b = - 0.0269d0, c = 0.0007d0, d = & - - 0.0048d0, gc = - 0.0843d0, b1 = 1.3981d0, b2 = 0.2611d0) - real(DP) :: lnrs, rs12, ox, dox - REAL(DP), PARAMETER :: xcprefact = 0.022575584d0, pi34 = 0.6203504908994d0 - ! REAL(DP) :: betha, etha, csi, prefact - ! - if (rs.lt.1.0d0) then - ! high density formula - lnrs = log (rs) - ec = a * lnrs + b + c * rs * lnrs + d * rs - vc = a * lnrs + (b - a / 3.d0) + 2.d0 / 3.d0 * c * rs * lnrs + & - (2.d0 * d-c) / 3.d0 * rs - else - ! interpolation formula - rs12 = sqrt (rs) - ox = 1.d0 + b1 * rs12 + b2 * rs - dox = 1.d0 + 7.d0 / 6.d0 * b1 * rs12 + 4.d0 / 3.d0 * b2 * rs - ec = gc / ox - vc = ec * dox / ox - endif - ! -! IF ( lxc_rel ) THEN -! betha = prefact * pi34 / rs -! etha = DSQRT( 1 + betha**2 ) -! csi = betha + etha -! prefact = 1.0D0 - (3.0D0/2.0D0) * ( (betha*etha - log(csi))/betha**2 )**2 -! ec = ec * prefact -! vc = vc * prefact -! ENDIF - return -end subroutine pz_polarized -! -!----------------------------------------------------------------------- -subroutine pz_spin (rs, zeta, ec, vcup, vcdw) - !----------------------------------------------------------------------- - ! J.P. Perdew and Y. Wang, PRB 45, 13244 (1992) - ! - USE kinds - implicit none - real(DP) :: rs, zeta, ec, vcup, vcdw - ! - real(DP) :: ecu, vcu, ecp, vcp, fz, dfz - real(DP) :: p43, third - parameter (p43 = 4.0d0 / 3.d0, third = 1.d0 / 3.d0) - ! - ! unpolarized part (Perdew-Zunger formula) - call pz (rs, 1, ecu, vcu) - ! polarization contribution - call pz_polarized (rs, ecp, vcp) - ! - fz = ( (1.0d0 + zeta) **p43 + (1.d0 - zeta) **p43 - 2.d0) / & - (2.d0**p43 - 2.d0) - dfz = p43 * ( (1.0d0 + zeta) **third- (1.d0 - zeta) **third) & - / (2.d0**p43 - 2.d0) - ! - ec = ecu + fz * (ecp - ecu) - vcup = vcu + fz * (vcp - vcu) + (ecp - ecu) * dfz * (1.d0 - zeta) - vcdw = vcu + fz * (vcp - vcu) + (ecp - ecu) * dfz * ( - 1.d0 - & - zeta) - ! - return -end subroutine pz_spin -! -!--------- -SUBROUTINE vwn_spin(rs, zeta, ec, vcup, vcdw) - - USE kinds, ONLY: DP - IMPLICIT NONE - - ! parameters: e_c/para, e_c/ferro, alpha_c - real(DP), parameter :: & - A(3) = (/ 0.0310907_dp, 0.01554535_dp, -0.01688686394039_dp /), & - x0(3) = (/ -0.10498_dp, -0.32500_dp, -0.0047584_dp /), & - b(3) = (/3.72744_dp, 7.06042_dp, 1.13107_dp /), & - c(3) = (/ 12.9352_dp, 18.0578_dp, 13.0045_dp /),& - Q(3) = (/ 6.15199081975908_dp, 4.73092690956011_dp, 7.12310891781812_dp /), & - tbQ(3) = (/ 1.21178334272806_dp, 2.98479352354082_dp, 0.31757762321188_dp /), & - fx0(3) = (/ 12.5549141492_dp, 15.8687885_dp, 12.99914055888256_dp /), & - bx0fx0(3) = (/ -0.03116760867894_dp, -0.14460061018521_dp, -0.00041403379428_dp /) - ! N.B.: A is expressed in Hartree - ! Q = sqrt(4*c - b^2) - ! tbQ = 2*b/Q - ! fx0 = X(x_0) = x_0^2 + b*x_0 + c - ! bx0fx0 = b*x_0/X(x_0) - - real(DP), intent(in) :: rs, zeta - real(DP), intent(out):: ec, vcup, vcdw - - ! local - real(DP) :: zeta3, zeta4, trup, trdw, trup13, trdw13, fz, dfz, fzz4 - real(DP) :: sqrtrs, ecP, ecF, ac, De, vcP, vcF, dac, dec1, dec2 - real(DP) :: cfz, cfz1, cfz2, iddfz0 - - ! coefficients for f(z), df/dz, ddf/ddz(0) - cfz = 2.0_dp**(4.0_dp/3.0_dp) - 2.0_dp - cfz1 = 1.0_dp / cfz - cfz2 = 4.0_dp/3.0_dp * cfz1 - iddfz0 = 9.0_dp / 8.0_dp *cfz - sqrtrs = sqrt(rs) - zeta3 = zeta**3 - zeta4 = zeta3*zeta - trup = 1.0_dp + zeta - trdw = 1.0_dp - zeta - trup13 = trup**(1.0_dp/3.0_dp) - trdw13 = trdw**(1.0_dp/3.0_dp) - fz = cfz1 * (trup13*trup + trdw13*trdw - 2.0_dp) ! f(zeta) - dfz = cfz2 * (trup13 - trdw13) ! d f / d zeta - - call padefit(sqrtrs, 1, ecP, vcP) ! ecF = e_c Paramagnetic - call padefit(sqrtrs, 2, ecF, vcF) ! ecP = e_c Ferromagnetic - call padefit(sqrtrs, 3, ac, dac) ! ac = "spin stiffness" - - ac = ac * iddfz0 - dac = dac * iddfz0 - De = ecF - ecP - ac ! e_c[F] - e_c[P] - alpha_c/(ddf/ddz(z=0)) - fzz4 = fz * zeta4 - ec = ecP + ac * fz + De * fzz4 - - dec1 = vcP + dac*fz + (vcF - vcP - dac) * fzz4 ! e_c - (r_s/3)*(de_c/dr_s) - dec2 = ac*dfz + De*(4.0_dp*zeta3*fz + zeta4*dfz) ! de_c/dzeta - - ! v_c[s] = e_c - (r_s/3)*(de_c/dr_s) + [sign(s)-zeta]*(de_c/dzeta) - vcup = dec1 + (1.0_dp - zeta)*dec2 - vcdw = dec1 - (1.0_dp + zeta)*dec2 - - - contains - !--- - subroutine padefit(x, i, fit, dfit) - !---- - ! implements formula [4.4] in: - ! S.H. Vosko, L. Wilk, and M. Nusair, Can. J. Phys. 58, 1200 (1980) - - USE kinds, ONLY: DP - implicit none - - ! input - real(DP) :: x ! x is sqrt(r_s) - integer :: i ! i is the index of the fit - - ! output - real(DP) :: fit, dfit - ! Pade fit calculated in x and its derivative w.r.t. rho - ! rs = inv((rho*)^(1/3)) = x^2 - ! fit [eq. 4.4] - ! dfit/drho = fit - (rs/3)*dfit/drs = ec - (x/6)*dfit/dx - - ! local - real(DP) :: sqx, xx0, Qtxb, atg, fx - real(DP) :: txb, txbfx, itxbQ - - sqx = x * x ! x^2 = r_s - xx0 = x - x0(i) ! x - x_0 - Qtxb = Q(i) / (2.0_dp*x + b(i)) ! Q / (2x+b) - atg = atan(Qtxb) ! tan^-1(Q/(2x+b)) - fx = sqx + b(i)*x + c(i) ! X(x) = x^2 + b*x + c - - fit = A(i) * ( log(sqx/fx) + tbQ(i)*atg - & - bx0fx0(i) * ( log(xx0*xx0/fx) + (tbQ(i) + 4.0_dp*x0(i)/Q(i)) * atg ) ) - - txb = 2.0_dp*x + b(i) - txbfx = txb / fx - itxbQ = 1.0_dp / (txb*txb + Q(i)*Q(i)) - - dfit = fit - A(i) / 3.0_dp + A(i)*x/6.0_dp * ( txbfx + 4.0_dp*b(i)*itxbQ + & - bx0fx0(i) * ( 2.0_dp/xx0 - txbfx - 4.0_dp*(b(i)+2.0_dp*x0(i))*itxbQ ) ) - - end subroutine - -end subroutine - -!----------------------------------------------------------------------- -subroutine pw_spin (rs, zeta, ec, vcup, vcdw) - !----------------------------------------------------------------------- - ! J.P. Perdew and Y. Wang, PRB 45, 13244 (1992) - ! - USE kinds - implicit none - real(DP) :: rs, zeta, ec, vcup, vcdw - ! xc parameters, unpolarised - real(DP) :: a, a1, b1, b2, b3, b4, c0, c1, c2, c3, d0, d1 - parameter (a = 0.031091d0, a1 = 0.21370d0, b1 = 7.5957d0, b2 = & - 3.5876d0, b3 = 1.6382d0, b4 = 0.49294d0, c0 = a, c1 = 0.046644d0, & - c2 = 0.00664d0, c3 = 0.01043d0, d0 = 0.4335d0, d1 = 1.4408d0) - ! xc parameters, polarised - real(DP) :: ap, a1p, b1p, b2p, b3p, b4p, c0p, c1p, c2p, c3p, d0p, & - d1p - parameter (ap = 0.015545d0, a1p = 0.20548d0, b1p = 14.1189d0, b2p & - = 6.1977d0, b3p = 3.3662d0, b4p = 0.62517d0, c0p = ap, c1p = & - 0.025599d0, c2p = 0.00319d0, c3p = 0.00384d0, d0p = 0.3287d0, d1p & - = 1.7697d0) - ! xc parameters, antiferro - real(DP) :: aa, a1a, b1a, b2a, b3a, b4a, c0a, c1a, c2a, c3a, d0a, & - d1a - parameter (aa = 0.016887d0, a1a = 0.11125d0, b1a = 10.357d0, b2a = & - 3.6231d0, b3a = 0.88026d0, b4a = 0.49671d0, c0a = aa, c1a = & - 0.035475d0, c2a = 0.00188d0, c3a = 0.00521d0, d0a = 0.2240d0, d1a & - = 0.3969d0) - real(DP) :: fz0 - parameter (fz0 = 1.709921d0) - real(DP) :: rs12, rs32, rs2, zeta2, zeta3, zeta4, fz, dfz - real(DP) :: om, dom, olog, epwc, vpwc - real(DP) :: omp, domp, ologp, epwcp, vpwcp - real(DP) :: oma, doma, ologa, alpha, vpwca - ! - ! if(rs.lt.0.5d0) then - ! high density formula (not implemented) - ! - ! else if(rs.gt.100.d0) then - ! low density formula (not implemented) - ! - ! else - ! interpolation formula - zeta2 = zeta * zeta - zeta3 = zeta2 * zeta - zeta4 = zeta3 * zeta - rs12 = dsqrt (rs) - rs32 = rs * rs12 - rs2 = rs**2 - ! unpolarised - om = 2.d0 * a * (b1 * rs12 + b2 * rs + b3 * rs32 + b4 * rs2) - dom = 2.d0 * a * (0.5d0 * b1 * rs12 + b2 * rs + 1.5d0 * b3 * rs32 & - + 2.d0 * b4 * rs2) - olog = dlog (1.d0 + 1.0d0 / om) - epwc = - 2.d0 * a * (1.d0 + a1 * rs) * olog - vpwc = - 2.d0 * a * (1.d0 + 2.d0 / 3.d0 * a1 * rs) * olog - 2.d0 / & - 3.d0 * a * (1.d0 + a1 * rs) * dom / (om * (om + 1.d0) ) - ! polarized - omp = 2.d0 * ap * (b1p * rs12 + b2p * rs + b3p * rs32 + b4p * rs2) - domp = 2.d0 * ap * (0.5d0 * b1p * rs12 + b2p * rs + 1.5d0 * b3p * & - rs32 + 2.d0 * b4p * rs2) - ologp = dlog (1.d0 + 1.0d0 / omp) - epwcp = - 2.d0 * ap * (1.d0 + a1p * rs) * ologp - vpwcp = - 2.d0 * ap * (1.d0 + 2.d0 / 3.d0 * a1p * rs) * ologp - & - 2.d0 / 3.d0 * ap * (1.d0 + a1p * rs) * domp / (omp * (omp + 1.d0) & - ) - ! antiferro - oma = 2.d0 * aa * (b1a * rs12 + b2a * rs + b3a * rs32 + b4a * rs2) - doma = 2.d0 * aa * (0.5d0 * b1a * rs12 + b2a * rs + 1.5d0 * b3a * & - rs32 + 2.d0 * b4a * rs2) - ologa = dlog (1.d0 + 1.0d0 / oma) - alpha = 2.d0 * aa * (1.d0 + a1a * rs) * ologa - vpwca = + 2.d0 * aa * (1.d0 + 2.d0 / 3.d0 * a1a * rs) * ologa + & - 2.d0 / 3.d0 * aa * (1.d0 + a1a * rs) * doma / (oma * (oma + 1.d0) & - ) - ! - fz = ( (1.d0 + zeta) ** (4.d0 / 3.d0) + (1.d0 - zeta) ** (4.d0 / & - 3.d0) - 2.d0) / (2.d0** (4.d0 / 3.d0) - 2.d0) - dfz = ( (1.d0 + zeta) ** (1.d0 / 3.d0) - (1.d0 - zeta) ** (1.d0 / & - 3.d0) ) * 4.d0 / (3.d0 * (2.d0** (4.d0 / 3.d0) - 2.d0) ) - ! - ec = epwc + alpha * fz * (1.d0 - zeta4) / fz0 + (epwcp - epwc) & - * fz * zeta4 - ! - vcup = vpwc + vpwca * fz * (1.d0 - zeta4) / fz0 + (vpwcp - vpwc) & - * fz * zeta4 + (alpha / fz0 * (dfz * (1.d0 - zeta4) - 4.d0 * fz * & - zeta3) + (epwcp - epwc) * (dfz * zeta4 + 4.d0 * fz * zeta3) ) & - * (1.d0 - zeta) - - vcdw = vpwc + vpwca * fz * (1.d0 - zeta4) / fz0 + (vpwcp - vpwc) & - * fz * zeta4 - (alpha / fz0 * (dfz * (1.d0 - zeta4) - 4.d0 * fz * & - zeta3) + (epwcp - epwc) * (dfz * zeta4 + 4.d0 * fz * zeta3) ) & - * (1.d0 + zeta) - ! endif - ! - return -end subroutine pw_spin -! -!----------------------------------------------------------------------- -subroutine becke88_spin (rho, grho, sx, v1x, v2x) - !----------------------------------------------------------------------- - ! Becke exchange: A.D. Becke, PRA 38, 3098 (1988) - Spin polarized case - ! - USE kinds - implicit none - real(DP) :: rho, grho, sx, v1x, v2x - ! input: charge - ! input: gradient - ! output: the up and down energies - ! output: first part of the potential - ! output: the second part of the potential - ! - real(DP) :: beta, third - parameter (beta = 0.0042d0, third = 1.d0 / 3.d0) - real(DP) :: rho13, rho43, xs, xs2, sa2b8, shm1, dd, dd2, ee - ! - rho13 = rho**third - rho43 = rho13**4 - xs = sqrt (grho) / rho43 - xs2 = xs * xs - sa2b8 = sqrt (1.0d0 + xs2) - shm1 = log (xs + sa2b8) - dd = 1.0d0 + 6.0d0 * beta * xs * shm1 - dd2 = dd * dd - ee = 6.0d0 * beta * xs2 / sa2b8 - 1.d0 - sx = grho / rho43 * ( - beta / dd) - v1x = - (4.d0 / 3.d0) * xs2 * beta * rho13 * ee / dd2 - v2x = beta * (ee-dd) / (rho43 * dd2) - ! - return -end subroutine becke88_spin -! -!----------------------------------------------------------------------- -subroutine perdew86_spin (rho, zeta, grho, sc, v1cup, v1cdw, v2c) - !----------------------------------------------------------------------- - ! Perdew gradient correction on correlation: PRB 33, 8822 (1986) - ! spin-polarized case - ! - USE kinds - implicit none - real(DP) :: rho, zeta, grho, sc, v1cup, v1cdw, v2c - real(DP) :: p1, p2, p3, p4, pc1, pc2, pci - parameter (p1 = 0.023266d0, p2 = 7.389d-6, p3 = 8.723d0, p4 = & - 0.472d0) - parameter (pc1 = 0.001667d0, pc2 = 0.002568d0, pci = pc1 + pc2) - real(DP) :: third, pi34 - parameter (third = 1.d0 / 3.d0, pi34 = 0.6203504908994d0) - ! pi34=(3/4pi)^(1/3) - ! - real(DP) :: rho13, rho43, rs, rs2, rs3, cna, cnb, cn, drs - real(DP) :: dcna, dcnb, dcn, phi, ephi, dd, ddd - ! - rho13 = rho**third - rho43 = rho13**4 - rs = pi34 / rho13 - rs2 = rs * rs - rs3 = rs * rs2 - cna = pc2 + p1 * rs + p2 * rs2 - cnb = 1.d0 + p3 * rs + p4 * rs2 + 1.d4 * p2 * rs3 - cn = pc1 + cna / cnb - drs = - third * pi34 / rho43 - dcna = (p1 + 2.d0 * p2 * rs) * drs - dcnb = (p3 + 2.d0 * p4 * rs + 3.d4 * p2 * rs2) * drs - dcn = dcna / cnb - cna / (cnb * cnb) * dcnb - phi = 0.192d0 * pci / cn * sqrt (grho) * rho** ( - 7.d0 / 6.d0) - !SdG: in the original paper 1.745*0.11=0.19195 is used - dd = (2.d0) **third * sqrt ( ( (1.d0 + zeta) * 0.5d0) ** (5.d0 / & - 3.d0) + ( (1.d0 - zeta) * 0.5d0) ** (5.d0 / 3.d0) ) - ddd = (2.d0) ** ( - 4.d0 / 3.d0) * 5.d0 * ( ( (1.d0 + zeta) & - * 0.5d0) ** (2.d0 / 3.d0) - ( (1.d0 - zeta) * 0.5d0) ** (2.d0 / & - 3.d0) ) / (3.d0 * dd) - ephi = exp ( - phi) - sc = grho / rho43 * cn * ephi / dd - v1cup = sc * ( (1.d0 + phi) * dcn / cn - ( (4.d0 / 3.d0) - & - (7.d0 / 6.d0) * phi) / rho) - sc * ddd / dd * (1.d0 - zeta) & - / rho - v1cdw = sc * ( (1.d0 + phi) * dcn / cn - ( (4.d0 / 3.d0) - & - (7.d0 / 6.d0) * phi) / rho) + sc * ddd / dd * (1.d0 + zeta) & - / rho - v2c = cn * ephi / rho43 * (2.d0 - phi) / dd - ! - return -end subroutine perdew86_spin -! -!----------------------------------------------------------------------- -subroutine ggac_spin (rho, zeta, grho, sc, v1cup, v1cdw, v2c) - !----------------------------------------------------------------------- - ! Perdew-Wang GGA (PW91) correlation part - spin-polarized - ! - USE kinds - implicit none - real(DP) :: rho, zeta, grho, sc, v1cup, v1cdw, v2c - real(DP) :: al, pa, pb, pc, pd, cx, cxc0, cc0 - parameter (al = 0.09d0, pa = 0.023266d0, pb = 7.389d-6, pc = & - 8.723d0, pd = 0.472d0) - parameter (cx = - 0.001667d0, cxc0 = 0.002568d0, cc0 = - cx + & - cxc0) - real(DP) :: third, pi34, nu, be, xkf, xks - parameter (third = 1.d0 / 3.d0, pi34 = 0.6203504908994d0) - parameter (nu = 15.755920349483144d0, be = nu * cc0) - parameter (xkf = 1.919158292677513d0, xks = 1.128379167095513d0) - ! pi34=(3/4pi)^(1/3), nu=(16/pi)*(3 pi^2)^(1/3) - ! xkf=(9 pi/4)^(1/3), xks= sqrt(4/pi) - real(DP) :: kf, ks, rs, rs2, rs3, ec, vcup, vcdw, t, expe, af, y, & - xy, qy, s1, h0, ddh0, ee, cn, dcn, cna, dcna, cnb, dcnb, h1, dh1, & - ddh1, fz, fz2, fz3, fz4, dfz, bfup, bfdw, dh0up, dh0dw, dh0zup, & - dh0zdw, dh1zup, dh1zdw - ! - rs = pi34 / rho**third - rs2 = rs * rs - rs3 = rs * rs2 - call pw_spin (rs, zeta, ec, vcup, vcdw) - kf = xkf / rs - ks = xks * sqrt (kf) - fz = 0.5d0 * ( (1.d0 + zeta) ** (2.d0 / 3.d0) + (1.d0 - zeta) ** ( & - 2.d0 / 3.d0) ) - fz2 = fz * fz - fz3 = fz2 * fz - fz4 = fz3 * fz - dfz = ( (1.d0 + zeta) ** ( - 1.d0 / 3.d0) - (1.d0 - zeta) ** ( - & - 1.d0 / 3.d0) ) / 3.d0 - t = sqrt (grho) / (2.d0 * fz * ks * rho) - expe = exp ( - 2.d0 * al * ec / (fz3 * be * be) ) - af = 2.d0 * al / be * (1.d0 / (expe-1.d0) ) - bfup = expe * (vcup - ec) / fz3 - bfdw = expe * (vcdw - ec) / fz3 - y = af * t * t - xy = (1.d0 + y) / (1.d0 + y + y * y) - qy = y * y * (2.d0 + y) / (1.d0 + y + y * y) **2 - s1 = 1.d0 + 2.d0 * al / be * t * t * xy - h0 = fz3 * be * be / (2.d0 * al) * log (s1) - dh0up = be * t * t * fz3 / s1 * ( - 7.d0 / 3.d0 * xy - qy * & - (af * bfup / be-7.d0 / 3.d0) ) - dh0dw = be * t * t * fz3 / s1 * ( - 7.d0 / 3.d0 * xy - qy * & - (af * bfdw / be-7.d0 / 3.d0) ) - dh0zup = (3.d0 * h0 / fz - be * t * t * fz2 / s1 * (2.d0 * xy - & - qy * (3.d0 * af * expe * ec / fz3 / be+2.d0) ) ) * dfz * (1.d0 - & - zeta) - dh0zdw = - (3.d0 * h0 / fz - be * t * t * fz3 / s1 * (2.d0 * xy - & - qy * (3.d0 * af * expe * ec / fz3 / be+2.d0) ) ) * dfz * (1.d0 + & - zeta) - ddh0 = be * fz / (2.d0 * ks * ks * rho) * (xy - qy) / s1 - ee = - 100.d0 * fz4 * (ks / kf * t) **2 - cna = cxc0 + pa * rs + pb * rs2 - dcna = pa * rs + 2.d0 * pb * rs2 - cnb = 1.d0 + pc * rs + pd * rs2 + 1.d4 * pb * rs3 - dcnb = pc * rs + 2.d0 * pd * rs2 + 3.d4 * pb * rs3 - cn = cna / cnb - cx - dcn = dcna / cnb - cna * dcnb / (cnb * cnb) - h1 = nu * (cn - cc0 - 3.d0 / 7.d0 * cx) * fz3 * t * t * exp (ee) - dh1 = - third * (h1 * (7.d0 + 8.d0 * ee) + fz3 * nu * t * t * exp & - (ee) * dcn) - ddh1 = 2.d0 * h1 * (1.d0 + ee) * rho / grho - dh1zup = (1.d0 - zeta) * dfz * h1 * (1.d0 + 2.d0 * ee / fz) - dh1zdw = - (1.d0 + zeta) * dfz * h1 * (1.d0 + 2.d0 * ee / fz) - sc = rho * (h0 + h1) - v1cup = h0 + h1 + dh0up + dh1 + dh0zup + dh1zup - v1cdw = h0 + h1 + dh0up + dh1 + dh0zdw + dh1zdw - v2c = ddh0 + ddh1 - return -end subroutine ggac_spin -! -!--------------------------------------------------------------- -subroutine pbec_spin (rho, zeta, grho, iflag, sc, v1cup, v1cdw, v2c) - !--------------------------------------------------------------- - ! - ! PBE correlation (without LDA part) - spin-polarized - ! iflag = 1: J.P.Perdew, K.Burke, M.Ernzerhof, PRL 77, 3865 (1996). - ! iflag = 2: J.P.Perdew et al., PRL 100, 136406 (2008) - ! - USE kinds - implicit none - integer, intent(in) :: iflag - real(DP) :: rho, zeta, grho, sc, v1cup, v1cdw, v2c - real(DP) :: ga, be(2) - parameter (ga = 0.031091d0) - data be / 0.066725d0 , 0.046d0 / - real(DP) :: third, pi34, xkf, xks - parameter (third = 1.d0 / 3.d0, pi34 = 0.6203504908994d0) - parameter (xkf = 1.919158292677513d0, xks = 1.128379167095513d0) - ! pi34=(3/4pi)^(1/3), xkf=(9 pi/4)^(1/3), xks= sqrt(4/pi) - real(DP) :: kf, ks, rs, ec, vcup, vcdw, t, expe, af, y, xy, qy, & - s1, h0, ddh0 - real(DP) :: fz, fz2, fz3, fz4, dfz, bfup, bfdw, dh0up, dh0dw, & - dh0zup, dh0zdw - ! - rs = pi34 / rho**third - call pw_spin (rs, zeta, ec, vcup, vcdw) - kf = xkf / rs - ks = xks * sqrt (kf) - fz = 0.5d0 * ( (1.d0 + zeta) ** (2.d0 / 3.d0) + (1.d0 - zeta) ** ( & - 2.d0 / 3.d0) ) - fz2 = fz * fz - fz3 = fz2 * fz - fz4 = fz3 * fz - dfz = ( (1.d0 + zeta) ** ( - 1.d0 / 3.d0) - (1.d0 - zeta) ** ( - & - 1.d0 / 3.d0) ) / 3.d0 - t = sqrt (grho) / (2.d0 * fz * ks * rho) - expe = exp ( - ec / (fz3 * ga) ) - af = be(iflag) / ga * (1.d0 / (expe-1.d0) ) - bfup = expe * (vcup - ec) / fz3 - bfdw = expe * (vcdw - ec) / fz3 - y = af * t * t - xy = (1.d0 + y) / (1.d0 + y + y * y) - qy = y * y * (2.d0 + y) / (1.d0 + y + y * y) **2 - s1 = 1.d0 + be(iflag) / ga * t * t * xy - h0 = fz3 * ga * log (s1) - dh0up = be(iflag) * t * t * fz3 / s1 * ( - 7.d0 / 3.d0 * xy - qy * & - (af * bfup / be(iflag)-7.d0 / 3.d0) ) - dh0dw = be(iflag) * t * t * fz3 / s1 * ( - 7.d0 / 3.d0 * xy - qy * & - (af * bfdw / be(iflag)-7.d0 / 3.d0) ) - dh0zup = (3.d0 * h0 / fz - be(iflag) * t * t * fz2 / s1 * (2.d0 * xy - & - qy * (3.d0 * af * expe * ec / fz3 / be(iflag)+2.d0) ) ) * dfz * (1.d0 - zeta) - dh0zdw = - (3.d0 * h0 / fz - be(iflag) * t * t * fz2 / s1 * (2.d0 * xy - & - qy * (3.d0 * af * expe * ec / fz3 / be(iflag)+2.d0) ) ) * dfz * (1.d0 + zeta) - - ddh0 = be(iflag) * fz / (2.d0 * ks * ks * rho) * (xy - qy) / s1 - sc = rho * h0 - v1cup = h0 + dh0up + dh0zup - v1cdw = h0 + dh0dw + dh0zdw - v2c = ddh0 - return -end subroutine pbec_spin -! -!----------------------------------------------------------------------- -subroutine slater_spin (rho, zeta, ex, vxup, vxdw) - !----------------------------------------------------------------------- - ! Slater exchange with alpha=2/3, spin-polarized case - ! - USE kinds - implicit none - real(DP) :: rho, zeta, ex, vxup, vxdw - real(DP) :: f, alpha, third, p43 - parameter (f = - 1.10783814957303361d0, alpha = 2.0d0 / 3.0d0) - ! f = -9/8*(3/pi)^(1/3) - parameter (third = 1.d0 / 3.d0, p43 = 4.d0 / 3.d0) - real(DP) :: exup, exdw, rho13 - ! - rho13 = ( (1.d0 + zeta) * rho) **third - exup = f * alpha * rho13 - vxup = p43 * f * alpha * rho13 - rho13 = ( (1.d0 - zeta) * rho) **third - exdw = f * alpha * rho13 - vxdw = p43 * f * alpha * rho13 - ex = 0.5d0 * ( (1.d0 + zeta) * exup + (1.d0 - zeta) * exdw) - ! - return -end subroutine slater_spin - -!----------------------------------------------------------------------- -SUBROUTINE slater_rxc_spin ( rho, Z, ex, vxup, vxdw ) - !----------------------------------------------------------------------- - ! Slater exchange with alpha=2/3, relativistic exchange case - ! - USE kinds - USE constants, ONLY : pi - IMPLICIT none - real (DP):: rho, ex, vxup, vxdw - ! - real(DP), PARAMETER :: ZERO=0.D0, ONE=1.D0, PFIVE=.5D0, & - OPF=1.5D0, C014=0.014D0 - real (DP):: rs, trd, ftrd, tftm, a0, alp, z, fz, fzp, vxp, xp, & - beta, sb, alb, vxf, exf - - TRD = ONE/3.d0 - FTRD = 4.d0*TRD - TFTM = 2**FTRD-2.d0 - A0 = (4.d0/(9.d0*PI))**TRD - - ! X-alpha parameter: - ALP = 2.d0 * TRD - - IF (rho <= ZERO) THEN - EX = ZERO - vxup = ZERO - vxdw = ZERO - RETURN - ELSE - FZ = ((1.d0+Z)**FTRD+(1.d0-Z)**FTRD-2.d0)/TFTM - FZP = FTRD*((1.d0+Z)**TRD-(1.d0-Z)**TRD)/TFTM - ENDIF - RS = (3.d0 / (4.d0*PI*rho) )**TRD - VXP = -3.d0*ALP/(2.d0*PI*A0*RS) - XP = 3.d0*VXP/4.d0 - - BETA = C014/RS - SB = SQRT(1.d0+BETA*BETA) - ALB = LOG(BETA+SB) - VXP = VXP * (-PFIVE + OPF * ALB / (BETA*SB)) - XP = XP * (ONE-OPF*((BETA*SB-ALB)/BETA**2)**2) - - VXF = 2.d0**TRD*VXP - EXF = 2.d0**TRD*XP - vxup = VXP + FZ*(VXF-VXP) + (1.d0-Z)*FZP*(EXF-XP) - vxdw = VXP + FZ*(VXF-VXP) - (1.d0+Z)*FZP*(EXF-XP) - EX = XP + FZ*(EXF-XP) - -END SUBROUTINE slater_rxc_spin - - -!----------------------------------------------------------------------- -subroutine slater1_spin (rho, zeta, ex, vxup, vxdw) - !----------------------------------------------------------------------- - ! Slater exchange with alpha=2/3, spin-polarized case - ! - use kinds, only: dp - implicit none - real(DP) :: rho, zeta, ex, vxup, vxdw - real(DP), parameter :: f = - 1.10783814957303361d0, alpha = 1.0d0, & - third = 1.d0 / 3.d0, p43 = 4.d0 / 3.d0 - ! f = -9/8*(3/pi)^(1/3) - real(DP) :: exup, exdw, rho13 - ! - rho13 = ( (1.d0 + zeta) * rho) **third - exup = f * alpha * rho13 - vxup = p43 * f * alpha * rho13 - rho13 = ( (1.d0 - zeta) * rho) **third - exdw = f * alpha * rho13 - vxdw = p43 * f * alpha * rho13 - ex = 0.5d0 * ( (1.d0 + zeta) * exup + (1.d0 - zeta) * exdw) - ! - return -end subroutine slater1_spin -! -!----------------------------------------------------------------------- -function dpz_polarized (rs, iflg) - !----------------------------------------------------------------------- - ! derivative of the correlation potential with respect to local density - ! Perdew and Zunger parameterization of the Ceperley-Alder functional - ! spin-polarized case - ! - USE kinds, only : DP - USE constants, ONLY : pi, fpi - ! - implicit none - ! - real(DP), intent (in) :: rs - integer, intent(in) :: iflg - real(DP) :: dpz_polarized - ! - ! local variables - ! a,b,c,d,gc,b1,b2 are the parameters defining the functional - ! - real(DP), parameter :: a = 0.01555d0, b = -0.0269d0, c = 0.0007d0, & - d = -0.0048d0, gc = -0.0843d0, b1 = 1.3981d0, b2 = 0.2611d0,& - a1 = 7.0d0 * b1 / 6.d0, a2 = 4.d0 * b2 / 3.d0 - real(DP) :: x, den, dmx, dmrs - ! - ! - if (iflg == 1) then - dmrs = a / rs + 2.d0 / 3.d0 * c * (log (rs) + 1.d0) + & - (2.d0 * d-c) / 3.d0 - else - x = sqrt (rs) - den = 1.d0 + x * (b1 + x * b2) - dmx = gc * ( (a1 + 2.d0 * a2 * x) * den - 2.d0 * (b1 + 2.d0 * & - b2 * x) * (1.d0 + x * (a1 + x * a2) ) ) / den**3 - dmrs = 0.5d0 * dmx / x - endif - ! - dpz_polarized = - fpi * rs**4.d0 / 9.d0 * dmrs - return - ! -end function dpz_polarized diff --git a/quantum_espresso/kcp/flib/make.depend b/quantum_espresso/kcp/flib/make.depend deleted file mode 100644 index ff06ff10a..000000000 --- a/quantum_espresso/kcp/flib/make.depend +++ /dev/null @@ -1,38 +0,0 @@ -atomic_number.o : ../Modules/kind.o -avrec.o : ../Modules/kind.o -bachel.o : ../Modules/constants.o -bachel.o : ../Modules/kind.o -cryst_to_car.o : ../Modules/kind.o -dost.o : ../Modules/kind.o -dylmr2.o : ../Modules/kind.o -erf.o : ../Modules/kind.o -functionals.o : ../Modules/constants.o -functionals.o : ../Modules/kind.o -invmat.o : ../Modules/kind.o -invmat_complex.o : ../Modules/kind.o -latgen.o : ../Modules/kind.o -linpack.o : ../Modules/kind.o -lsda_functionals.o : ../Modules/constants.o -lsda_functionals.o : ../Modules/kind.o -more_functionals.o : ../Modules/constants.o -more_functionals.o : ../Modules/kind.o -recips.o : ../Modules/kind.o -remove_tot_torque.o : ../Modules/kind.o -simpsn.o : ../Modules/kind.o -sort.o : ../Modules/constants.o -sort.o : ../Modules/kind.o -sort_gvec.o : ../Modules/constants.o -sort_gvec.o : ../Modules/kind.o -sph_bes.o : ../Modules/constants.o -sph_bes.o : ../Modules/kind.o -sph_dbes.o : ../Modules/constants.o -sph_dbes.o : ../Modules/kind.o -volume.o : ../Modules/kind.o -ylmr2.o : ../Modules/constants.o -ylmr2.o : ../Modules/kind.o -dylmr2.o : ../include/f_defs.h -invmat.o : ../include/f_defs.h -invmat_complex.o : ../include/f_defs.h -linpack.o : ../include/f_defs.h -remove_tot_torque.o : ../include/f_defs.h -transto.o : ../include/opt_param.h diff --git a/quantum_espresso/kcp/flib/matches.f90 b/quantum_espresso/kcp/flib/matches.f90 deleted file mode 100644 index 836486515..000000000 --- a/quantum_espresso/kcp/flib/matches.f90 +++ /dev/null @@ -1,40 +0,0 @@ -! -! Copyright (C) 2001-2004 Carlo Cavazzoni and PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!----------------------------------------------------------------------- -FUNCTION matches( string1, string2 ) - !----------------------------------------------------------------------- - ! - ! ... .TRUE. if string1 is contained in string2, .FALSE. otherwise - ! - IMPLICIT NONE - ! - CHARACTER (LEN=*), INTENT(IN) :: string1, string2 - LOGICAL :: matches - INTEGER :: len1, len2, l - ! - ! - len1 = LEN_TRIM( string1 ) - len2 = LEN_TRIM( string2 ) - ! - DO l = 1, ( len2 - len1 + 1 ) - ! - IF ( string1(1:len1) == string2(l:(l+len1-1)) ) THEN - ! - matches = .TRUE. - ! - RETURN - ! - END IF - ! - END DO - ! - matches = .FALSE. - ! - RETURN - ! -END FUNCTION matches diff --git a/quantum_espresso/kcp/flib/more_functionals.f90 b/quantum_espresso/kcp/flib/more_functionals.f90 deleted file mode 100644 index e246713d5..000000000 --- a/quantum_espresso/kcp/flib/more_functionals.f90 +++ /dev/null @@ -1,1794 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - - -! ================================================================== - SUBROUTINE LSD_LYP(RHO,ETA,ELYP,VALYP,VBLYP) -! ==--------------------------------------------------------------== -! == C. LEE, W. YANG, AND R.G. PARR, PRB 37, 785 (1988) == -! == THIS IS ONLY THE LDA PART == -! ==--------------------------------------------------------------== - USE kinds, ONLY: DP -! - IMPLICIT NONE -! arguments - REAL(DP) :: RHO,ETA,ELYP,VALYP,VBLYP -! locals - REAL(DP) :: RA,RB,RM3,DR,E1,OR,DOR,E2,DE1A,DE1B,DE2A,DE2B - REAL(DP), PARAMETER :: SMALL=1.D-24, A=0.04918D0, B=0.132D0, & - C=0.2533D0, D=0.349D0, CF=2.87123400018819108D0 -! ==--------------------------------------------------------------== - RA=RHO*0.5D0*(1.D0+ETA) - RA=MAX(RA,SMALL) - RB=RHO*0.5D0*(1.D0-ETA) - RB=MAX(RB,SMALL) - RM3=RHO**(-1.D0/3.D0) - DR=(1.D0+D*RM3) - E1=4.D0*A*RA*RB/RHO/DR - OR=EXP(-C*RM3)/DR*RM3**11.D0 - DOR=-1.D0/3.D0*RM3**4*OR*(11.D0/RM3-C-D/DR) - E2=2.D0**(11.D0/3.D0)*CF*A*B*OR*RA*RB*(RA**(8.d0/3.d0)+ RB**(8.d0/3.d0)) - ELYP=(-E1-E2)/RHO - DE1A=-E1*(1.D0/3.D0*D*RM3**4/DR+1./RA-1./RHO) - DE1B=-E1*(1.D0/3.D0*D*RM3**4/DR+1./RB-1./RHO) - DE2A=-2.D0**(11.D0/3.D0)*CF*A*B*(DOR*RA*RB*(RA**(8.d0/3.d0)+ & - RB**(8.d0/3.d0))+OR*RB*(11.d0/3.d0*RA**(8.d0/3.d0)+ & - RB**(8.d0/3.d0))) - DE2B=-2.D0**(11.D0/3.D0)*CF*A*B*(DOR*RA*RB*(RA**(8.d0/3.d0)+ & - RB**(8.d0/3.d0))+OR*RA*(11.d0/3.d0*RB**(8.d0/3.d0)+ & - RA**(8.d0/3.d0))) - VALYP=DE1A+DE2A - VBLYP=DE1B+DE2B -! ==--------------------------------------------------------------== - RETURN - END SUBROUTINE LSD_LYP - - - -! ================================================================== - SUBROUTINE LSD_PADE(RHO,ETA,EC,VCA,VCB) -! ==--------------------------------------------------------------== -! == PADE APPROXIMATION == -! ==--------------------------------------------------------------== - USE kinds, ONLY: DP - IMPLICIT NONE -! arguments - REAL(DP) :: RHO,ETA,EC,VCA,VCB -! locals - REAL(DP) :: RS,FS,DFS,DFSA,DFSB,A0P,A1P,A2P,A3P,B1P,B2P,B3P,B4P - REAL(DP) :: TOP,DTOP,TOPX,BOT,DBOT,BOTX,VC,DX - REAL(DP), PARAMETER :: A0=.4581652932831429d0, A1=2.217058676663745d0, & - A2=0.7405551735357053d0, A3=0.01968227878617998d0 - REAL(DP), PARAMETER :: B1=1.0D0, B2=4.504130959426697d0, & - B3=1.110667363742916d0, B4=0.02359291751427506d0 - REAL(DP), PARAMETER :: DA0=.119086804055547D0, DA1=.6157402568883345d0, & - DA2=.1574201515892867d0, DA3=.003532336663397157d0 - REAL(DP), PARAMETER :: DB1=0.0d0, DB2=.2673612973836267d0, & - DB3=.2052004607777787d0, DB4=.004200005045691381d0 - REAL(DP), PARAMETER :: RSFAC=.6203504908994000d0, FSFAC=1.92366105093153617d0 -! ==--------------------------------------------------------------== - RS=RSFAC*RHO**(-1.d0/3.d0) - FS=FSFAC*((1.d0+ETA)**(4.d0/3.d0)+(1.d0-ETA)**(4.d0/3.d0)-2.d0) - DFS=FSFAC*4.d0/3.d0* ((1.d0+ETA)**(1.d0/3.d0)-(1.d0-ETA)**(1.d0/3.d0)) - DFSA=DFS*(1.d0-ETA) - DFSB=DFS*(-1.d0-ETA) - A0P=A0+FS*DA0 - A1P=A1+FS*DA1 - A2P=A2+FS*DA2 - A3P=A3+FS*DA3 - B1P=B1+FS*DB1 - B2P=B2+FS*DB2 - B3P=B3+FS*DB3 - B4P=B4+FS*DB4 - TOP=A0P+RS*(A1P+RS*(A2P+RS*A3P)) - DTOP=A1P+RS*(2.d0*A2P+RS*3.d0*A3P) - TOPX=DA0+RS*(DA1+RS*(DA2+RS*DA3)) - BOT=RS*(B1P+RS*(B2P+RS*(B3P+RS*B4P))) - DBOT=B1P+RS*(2.d0*B2P+RS*(3.d0*B3P+RS*4.d0*B4P)) - BOTX=RS*(DB1+RS*(DB2+RS*(DB3+RS*DB4))) - EC=-TOP/BOT - VC=EC+RS*(DTOP/BOT-TOP*DBOT/(BOT*BOT))/3.d0 - DX=-(TOPX/BOT-TOP*BOTX/(BOT*BOT)) - VCA=VC+DX*DFSA - VCB=VC+DX*DFSB -! ==--------------------------------------------------------------== - RETURN - END SUBROUTINE LSD_PADE - - - -! ================================================================== - SUBROUTINE LSD_GLYP(RA,RB,GRHOAA,GRHOAB,GRHOBB,SC, & - V1CA,V2CA,V1CB,V2CB,V2CAB) -! ==--------------------------------------------------------------== - USE kinds, ONLY: DP -! LEE, YANG PARR: GRADIENT CORRECTION PART - IMPLICIT NONE ! REAL(DP) (A-H,O-Z), INTEGER (I-N) -! arguments - REAL(DP) :: RA,RB,GRHOAA,GRHOAB,GRHOBB,SC, & - V1CA,V2CA,V1CB,V2CB,V2CAB -! locals - REAL(DP) :: RHO,RM3,DR,OR,DOR,DER,DDER - REAL(DP) :: DLAA,DLAB,DLBB,DLAAA,DLAAB,DLABA,DLABB,DLBBA,DLBBB - REAL(DP), PARAMETER :: A=0.04918D0,B=0.132D0,C=0.2533D0,D=0.349D0 -! ==--------------------------------------------------------------== - RHO=RA+RB - RM3=RHO**(-1.D0/3.D0) - DR=(1.D0+D*RM3) - OR=EXP(-C*RM3)/DR*RM3**11.D0 - DOR=-1.D0/3.D0*RM3**4*OR*(11.D0/RM3-C-D/DR) - DER=C*RM3+D*RM3/DR - DDER=1.d0/3.d0*(D*D*RM3**5/DR/DR-DER/RHO) - DLAA=-A*B*OR*(RA*RB/9.d0*(1.d0-3*DER-(DER-11.d0)*RA/RHO)-RB*RB) - DLAB=-A*B*OR*(RA*RB/9.d0*(47.d0-7.d0*DER)-4.d0/3.d0*RHO*RHO) - DLBB=-A*B*OR*(RA*RB/9.d0*(1.d0-3*DER-(DER-11.d0)*RB/RHO)-RA*RA) - DLAAA=DOR/OR*DLAA-A*B*OR*(RB/9.d0*(1.d0-3*DER-(DER-11.d0)*RA/RHO)- & - RA*RB/9.d0*((3.d0+RA/RHO)*DDER+(DER-11.d0)*RB/RHO/RHO)) - DLAAB=DOR/OR*DLAA-A*B*OR*(RA/9.d0*(1.d0-3.d0*DER-(DER-11.d0)*RA/RHO)- & - RA*RB/9.d0*((3.d0+RA/RHO)*DDER-(DER-11.d0)*RA/RHO/RHO)-2.d0*RB) - DLABA=DOR/OR*DLAB-A*B*OR*(RB/9.d0*(47.d0-7.d0*DER)-7.d0/9.d0*RA*RB*DDER- & - 8.d0/3.d0*RHO) - DLABB=DOR/OR*DLAB-A*B*OR*(RA/9.d0*(47.d0-7.d0*DER)-7.d0/9.d0*RA*RB*DDER- & - 8.d0/3.d0*RHO) - DLBBA=DOR/OR*DLBB-A*B*OR*(RB/9.d0*(1.d0-3.d0*DER-(DER-11.d0)*RB/RHO)- & - RA*RB/9.d0*((3.d0+RB/RHO)*DDER-(DER-11.d0)*RB/RHO/RHO)-2.d0*RA) - DLBBB=DOR/OR*DLBB-A*B*OR*(RA/9.d0*(1.d0-3*DER-(DER-11.d0)*RB/RHO)- & - RA*RB/9.d0*((3.d0+RB/RHO)*DDER+(DER-11.d0)*RA/RHO/RHO)) - SC=DLAA*GRHOAA+DLAB*GRHOAB+DLBB*GRHOBB - V1CA=DLAAA*GRHOAA+DLABA*GRHOAB+DLBBA*GRHOBB - V1CB=DLAAB*GRHOAA+DLABB*GRHOAB+DLBBB*GRHOBB - V2CA=2.d0*DLAA - V2CB=2.d0*DLBB - V2CAB=DLAB -! ==--------------------------------------------------------------== - RETURN - END SUBROUTINE LSD_GLYP - - -!______________________________________________________________________ - subroutine ggablyp4(nnr,nspin,gradr,rhor,exc) -! _________________________________________________________________ -! becke-lee-yang-parr gga -! -! exchange: becke, pra 38, 3098 (1988) but derived from -! pw91 exchange formula given in prb 48, 14944 (1993) -! by setting "b3" and "b4" to 0.0 -! correlation: miehlich et al., cpl 157, 200 (1989) -! method by ja white & dm bird, prb 50, 4954 (1994) -! -! spin-polarized version by andras stirling 10/1998, -! using original gga program of alfredo pasquarello 22/09/1994 -! and spin-unpolarized blyp routine of olivier parisel and -! alfredo pasquarello (02/1997) -! - USE kinds, ONLY : DP - USE constants, ONLY: pi, fpi -! - implicit none -! input - integer nspin, nnr - real(DP) gradr(nnr,3,nspin), rhor(nnr,nspin) -! output -! on output: rhor contains the exchange-correlation potential - real(DP) exc -! local - integer isdw, isup, isign, ir -! - real(DP) abo, agdr, agdr2, agr, agr2, agur, agur2, arodw, & - arodw2, aroe, aroe2, aroup, aroup2, ax - real(DP) byagdr, byagr, byagur, cden, cf, cl1, cl11, cl2, & - cl21, cl22, cl23, cl24, cl25, cl26, cl27, clyp, csum - real(DP) dddn, dexcdg, dexcdgd, dexcdgu, df1d, df1u, df2d, & - df2u, dfd, dfnum1d, dfnum1u, dfnum2d, dfnum2u, dfs, dfu, & - dfxdd, dfxdg, dfxdgd, dfxdgu, dfxdu, dilta, dilta119, dl1dn, & - dl1dnd, dl1dnu, dl2dd, dl2dg, dl2dgd, dl2dgu, dl2dn, & - dl2dnd, dl2dnd1, dl2dnu, dl2dnu1, dl2do, dlt, dodn, & - disign, dwsign, dys, dysd, dysu - real(DP) ex, excupdt, exd, exu, fac1, fac2, factor1, factor2, & - fx, fxd, fxden, fxdend, fxdenu, fxnum, fxnumd, fxnumu, fxu - real(DP) gkf, gkfd, gkfu, grdx, grdy, grdz, grux, gruy, gruz, & - grx, gry, grz - real(DP) omiga, pd, pi2, pider2, piexch, pu - real(DP) rhodw, rhoup, roe, roedth, roeth, roeuth, rometh - real(DP) s, s2, sd, sd2, sddw, sdup, su, su2, sysl, sysld, syslu - real(DP) t113, upsign, usign - real(DP) x1124, x113, x118, x13, x143, x19, x23, x43, & - x4718, x53, x672, x718, x772, x83 - real(DP) ys, ysd, ysl, ysld, yslu, ysr, ysrd, ysru, ysu -!=========================================================================== - real(DP) bb1, bb2, bb5, aa, bb, cc, dd, delt, eps - parameter(bb1=0.19644797d0,bb2=0.2742931d0,bb5=7.79555418d0, & - aa=0.04918d0, & - bb=0.132d0,cc=0.2533d0,dd=0.349d0,delt=1.0d-12,eps=1.0d-14) -! -! - x13=1.0d0/3.0d0 - x19=1.0d0/9.0d0 - x23=2.0d0/3.0d0 - x43=4.0d0/3.0d0 - x53=5.0d0/3.0d0 - x83=8.0d0/3.0d0 - x113=11.0d0/3.0d0 - x4718=47.0d0/18.0d0 - x718=7.0d0/18.0d0 - x118=1.0d0/18.0d0 - x1124=11.0d0/24.0d0 - x143=14.0d0/3.0d0 - x772=7.0d0/72.0d0 - x672=6.0d0/72.0d0 -! -! _________________________________________________________________ -! derived parameters from pi -! - pi2=pi*pi - ax=-0.75d0*(3.0d0/pi)**x13 - piexch=-0.75d0/pi - pider2=(3.0d0*pi2)**x13 - cf=0.3d0*pider2*pider2 -! _________________________________________________________________ -! other parameters -! - t113=2.0d0**x113 -! - rhodw=0.0d0 - grdx=0.0d0 - grdy=0.0d0 - grdz=0.0d0 -! - fac1=1.0d0 -! _________________________________________________________________ -! main loop -! - isup=1 - isdw=2 - do ir=1,nnr - rhoup=rhor(ir,isup) - grux=gradr(ir,1,isup) - gruy=gradr(ir,2,isup) - gruz=gradr(ir,3,isup) - if(nspin.eq.2) then - rhodw=rhor(ir,isdw) - grdx=gradr(ir,1,isdw) - grdy=gradr(ir,2,isdw) - grdz=gradr(ir,3,isdw) - else - rhodw=0.0d0 - grdx =0.0d0 - grdy =0.0d0 - grdz =0.0d0 - endif - roe=rhoup+rhodw - if(roe.eq.0.0) goto 100 - aroup=abs(rhoup) - arodw=abs(rhodw) - aroe=abs(roe) - grx=grux + grdx - gry=gruy + grdy - grz=gruz + grdz - agur2=grux*grux+gruy*gruy+gruz*gruz - agur=sqrt(agur2) - agdr2=grdx*grdx+grdy*grdy+grdz*grdz - agdr=sqrt(agdr2) - agr2=grx*grx+gry*gry+grz*grz - agr=sqrt(agr2) - roeth=aroe**x13 - rometh=1.0d0/roeth - gkf=pider2*roeth - sd=1.0d0/(2.0d0*gkf*aroe) - s=agr*sd - s2=s*s -! _________________________________________________________________ -! exchange -! - if(nspin.eq.1) then -! -! - ysr=sqrt(1.0d0+bb5*bb5*s2) - ys=bb5*s+ysr - ysl=log(ys)*bb1 - sysl=s*ysl - fxnum=1.0d0+sysl+bb2*s2 - fxden=1.0d0/(1.0d0+sysl) - fx=fxnum*fxden -! - ex=ax*fx*roeth*aroe -! -! ### potential contribution ### -! - dys=bb5*(1.0d0+bb5*s/ysr)/ys - dfs=-fxnum*(ysl+bb1*s*dys)*fxden*fxden & - & +(ysl+bb1*s*dys+2.0d0*s*bb2)*fxden - dfxdu=(ax*roeth*x43)*(fx-dfs*s) - dfxdg=ax*roeth*dfs*sd -! -! ### end of potential contribution ### -! - else -! - roeuth=(2.0d0*aroup)**x13 - roedth=(2.0d0*arodw)**x13 - gkfu=pider2*roeuth*aroup - gkfd=pider2*roedth*arodw - upsign=sign(1.d0,gkfu-eps) - dwsign=sign(1.d0,gkfd-eps) - factor1=0.5d0*(1+upsign)/(gkfu+(1-upsign)*eps) - fac1=gkfu*factor1 - factor2=0.5d0*(1+dwsign)/(gkfd+(1-dwsign)*eps) - fac2=gkfd*factor2 - sdup=1.0d0/2.0d0*factor1 - sddw=1.0d0/2.0d0*factor2 - su=agur*sdup - su2=su*su - sd=agdr*sddw - sd2=sd*sd -! - ysru=sqrt(1.0d0+bb5*bb5*su2) - ysu=bb5*su+ysru - yslu=log(ysu)*bb1 - syslu=su*yslu - fxnumu=1.0d0+syslu+bb2*su2 - fxdenu=1.0d0/(1.0d0+syslu) - fxu=fxnumu*fxdenu - exu=piexch*2.0d0*gkfu*fxu*fac1 -! - ysrd=sqrt(1.0d0+bb5*bb5*sd2) - ysd=bb5*sd+ysrd - ysld=log(ysd)*bb1 - sysld=sd*ysld - fxnumd=1.0d0+sysld+bb2*sd2 - fxdend=1.0d0/(1.0d0+sysld) - fxd=fxnumd*fxdend - exd=piexch*2.0d0*gkfd*fxd*fac2 -! - ex=0.5d0*(exu+exd) -! -! ### potential contribution ### -! - dysu=bb5*(1.0d0+bb5*su/ysru)/ysu - pu=2.0d0*su*bb2 - dfnum1u=yslu+bb1*su*dysu+pu - df1u=dfnum1u*fxdenu - dfnum2u=fxnumu*(yslu+bb1*su*dysu) - df2u=dfnum2u*fxdenu*fxdenu - dfu=df1u-df2u - dfxdu=ax*roeuth*x43*1.0d0*(fxu-dfu*su)*fac1 - dfxdgu=ax*aroup*roeuth*dfu*sdup*fac1 -! - dysd=bb5*(1.0d0+bb5*sd/ysrd)/ysd - pd=2.0d0*sd*bb2 - dfnum1d=ysld+bb1*sd*dysd+pd - df1d=dfnum1d*fxdend - dfnum2d=fxnumd*(ysld+bb1*sd*dysd) - df2d=dfnum2d*fxdend*fxdend - dfd=df1d-df2d - dfxdd=ax*roedth*x43*1.0d0*(fxd-dfd*sd)*fac2 - dfxdgd=ax*arodw*roedth*dfd*sddw*fac2 -! -! ### end of potential contribution ### -! - endif -! _________________________________________________________________ -! correlation lyp(aroe,aroup,arodw,agr,agur,agdr) -! - cden=1.0d0+dd*rometh - cl1=-aa/cden -! - omiga=exp(-cc*rometh)/cden/aroe**x113 - dilta=rometh*(cc+dd/cden) - aroe2=aroe*aroe - abo=aa*bb*omiga -! - dodn=x13*omiga/aroe*(dilta-11.0d0) - dddn=x13*(dd*dd*aroe**(-x53)/cden/cden-dilta/aroe) -! - if(nspin.eq.1) then -! - cl1=cl1*aroe -! - cl21=4.0d0*cf*aroe**x83 - cl22=(x4718-x718*dilta)*agr2 - cl23=(2.5d0-x118*dilta)*agr2/2.0d0 - cl24=(dilta-11.0d0)/9.0d0*agr2/4.0d0 - cl25=x1124*agr2 -! - cl2=-abo*aroe2*(0.25d0*(cl21+cl22-cl23-cl24)-cl25) -! -! ### potential contribution ### -! - dl1dnu=-aa*(1/cden+x13*dd*rometh/cden/cden) -! - dlt=x672+2.0d0*x772*dilta - dl2dn=-abo*aroe*(cf*x143*aroe**x83-dlt*agr2) - dl2do=cl2/omiga - dl2dd=abo*aroe2*x772*agr2 - dl2dnu=dl2dn+dl2do*dodn+dl2dd*dddn -! - dl2dg=abo*aroe2*agr*dlt -! -! ### end of potential contribution ### -! - else -! - cl11=cl1*4.0d0/aroe - cl1=cl11*aroup*arodw -! - aroup2=aroup*aroup - arodw2=arodw*arodw -! - cl21=t113*cf*(aroup**x83+arodw**x83) - cl22=(x4718-x718*dilta)*agr2 - cl23=(2.5d0-x118*dilta)*(agur2+agdr2) - dilta119=(dilta-11.0d0)/9.0d0 - cl24=dilta119/aroe*(aroup*agur2+arodw*agdr2) - cl25=x23*aroe2*agr2 - cl26=(x23*aroe2-aroup2)*agdr2 - cl27=(x23*aroe2-arodw2)*agur2 -! - csum=cl21+cl22-cl23-cl24 - cl2=-abo*(aroup*arodw*csum-cl25+cl26+cl27) -! -! ### potential contribution ### -! -! *** cl1 has changed its form! *** -! - dl1dn=cl1/aroe*(x13*dd/cden*rometh-1.0d0) - dl1dnu=dl1dn+cl11*arodw - dl1dnd=dl1dn+cl11*aroup -! - dl2dnu1=arodw*csum+ & - & arodw*aroup*(t113*cf*x83*aroup**x53- & - & dilta119*arodw/aroe2*(agur2-agdr2))-x43*aroe*agr2+ & - & x23*agdr2*(2.0d0*arodw-aroup)+x43*aroe*agur2 - dl2dnd1=aroup*csum+ & - & aroup*arodw*(t113*cf*x83*arodw**x53+ & - & dilta119*aroup/aroe2*(agur2-agdr2))-x43*aroe*agr2+ & - & x23*agur2*(2.0d0*aroup-arodw)+x43*aroe*agdr2 -! - dl2do=cl2/omiga - dl2dd=-abo*aroup*arodw* & - & (-x718*agr2+x118*(agur2+agdr2)- & - & x19*(aroup*agur2+arodw*agdr2)/aroe) -! - dl2dnu=-abo*dl2dnu1+dl2do*dodn+dl2dd*dddn - dl2dnd=-abo*dl2dnd1+dl2do*dodn+dl2dd*dddn -! - dl2dg=-abo* & - & (aroup*arodw*2.0d0*(x4718-x718*dilta)*agr- & - & x43*aroe2*agr) - dl2dgu=-2.0d0*abo*agur*((x118*dilta-2.5d0- & - & dilta119*aroup/aroe)*aroup*arodw & - & +x23*aroe2-arodw2) - dl2dgd=-2.0d0*abo*agdr*((x118*dilta-2.5d0- & - & dilta119*arodw/aroe)*aroup*arodw & - & +x23*aroe2-aroup2) -! - endif -! - clyp=cl1+cl2 -! _________________________________________________________________ -! updating of xc-energy -! - excupdt=ex+clyp -! - exc=exc+excupdt -! -! _________________________________________________________________ -! first part xc-potential construction -! -! - rhor(ir,isup)=dfxdu+(dl1dnu+dl2dnu)*fac1 - isign=sign(1.d0,agr-delt) - byagr=0.5d0*(1+isign)/(agr+(1-isign)*delt) -! - if(nspin.eq.1) then -! - dexcdg=(dfxdg*aroe+dl2dg)*byagr - gradr(ir,1,isup)=grx*dexcdg - gradr(ir,2,isup)=gry*dexcdg - gradr(ir,3,isup)=grz*dexcdg -! - else -! - rhor(ir,isdw)=dfxdd+(dl1dnd+dl2dnd)*fac2 -! - usign =sign(1.d0,agur-delt) - disign=sign(1.d0,agdr-delt) - byagur=0.5d0*(1+ usign)/(agur+(1- usign)*delt) - byagdr=0.5d0*(1+disign)/(agdr+(1-disign)*delt) -! - dexcdgu=(dfxdgu+dl2dgu)*byagur - dexcdgd=(dfxdgd+dl2dgd)*byagdr - dexcdg=dl2dg*byagr -! - gradr(ir,1,isup)=(dexcdgu*grux+dexcdg*grx)*fac1 - gradr(ir,2,isup)=(dexcdgu*gruy+dexcdg*gry)*fac1 - gradr(ir,3,isup)=(dexcdgu*gruz+dexcdg*grz)*fac1 - gradr(ir,1,isdw)=(dexcdgd*grdx+dexcdg*grx)*fac2 - gradr(ir,2,isdw)=(dexcdgd*grdy+dexcdg*gry)*fac2 - gradr(ir,3,isdw)=(dexcdgd*grdz+dexcdg*grz)*fac2 -! - endif -! - 100 continue - end do -! - return - end subroutine ggablyp4 -! -!______________________________________________________________________ - subroutine ggapbe(nnr,nspin,gradr,rhor,excrho) -! _________________________________________________________________ -! Perdew-Burke-Ernzerhof gga -! Perdew, et al. PRL 77, 3865, 1996 -! - USE kinds, ONLY: DP - use constants, only: pi, fpi -! - implicit none -! input - integer nspin, nnr - real(DP) gradr(nnr,3,nspin), rhor(nnr,nspin) -! output: excrho: exc * rho ; E_xc = \int excrho(r) d_r -! output: rhor: contains the exchange-correlation potential - real(DP) excrho -! local - integer ir, icar, iss, isup, isdw, nspinx - real(DP) lim1, lim2 - parameter ( lim1=1.d-8, lim2=1.d-8, nspinx=2 ) - real(DP) zet, arho(nspinx), grad(3,nspinx), agrad(nspinx), & - arhotot, gradtot(3), agradtot, & - scl, scl1, wrkup, wrkdw, & - exrho(nspinx), dexdrho(nspinx), dexdg(nspinx), & - ecrho, decdrho(nspinx), decdg -! -! main loop -! - isup=1 - isdw=2 - do ir=1,nnr -! - arho(isup) = abs(rhor(ir,isup)) - arhotot = arho(isup) - zet = 0.d0 - do icar = 1, 3 - grad(icar,isup) = gradr(ir,icar,isup) - gradtot(icar) = gradr(ir,icar,isup) - enddo -! - if (nspin.eq.2) then - arho(isdw) = abs(rhor(ir,isdw)) - arhotot = abs(rhor(ir,isup)+rhor(ir,isdw)) - do icar = 1, 3 - grad(icar,isdw) = gradr(ir,icar,isdw) - gradtot(icar) = gradr(ir,icar,isup)+gradr(ir,icar,isdw) - enddo - zet = (rhor(ir,isup) - rhor(ir,isdw)) / arhotot - if (zet.ge. 1.d0) zet = 1.d0 - if (zet.le.-1.d0) zet = -1.d0 - endif -! - do iss = 1, nspin - agrad(iss) = sqrt( grad(1,iss)*grad(1,iss) + & - & grad(2,iss)*grad(2,iss) + & - & grad(3,iss)*grad(3,iss) ) - agradtot = sqrt( gradtot(1)*gradtot(1) + & - & gradtot(2)*gradtot(2) + & - & gradtot(3)*gradtot(3) ) - enddo -! -! _________________________________________________________________ -! First it calculates the energy density excrho -! exrho: exchange term -! ecrho: correlation term -! - if ( nspin.eq.2 ) then - scl = 2.d0 - scl1 = 0.5d0 - else - scl = 1.d0 - scl1 = 1.d0 - endif - do iss = 1, nspin - if ( arho(iss).gt.lim1) then - call exchpbe( scl*arho(iss), scl*agrad(iss), & - & exrho(iss),dexdrho(iss),dexdg(iss)) - excrho = excrho + scl1*exrho(iss) - else - dexdrho(iss) = 0.d0 - dexdg(iss) = 0.d0 - endif - enddo - if ( arhotot.gt.lim1) then - call ecorpbe( arhotot, agradtot, zet, ecrho, & - & decdrho(1), decdrho(2), decdg, nspin ) - excrho = excrho + ecrho - else - decdrho(isup) = 0.d0 - decdrho(isdw) = 0.d0 - decdg = 0.d0 - endif -! _________________________________________________________________ -! Now it calculates the potential and writes it in rhor -! it uses the following variables: -! dexdrho = d ( ex*rho ) / d (rho) -! decdrho = d ( ec*rho ) / d (rho) -! dexdg = (d ( ex*rho ) / d (grad(rho)_i)) * agrad / grad_i -! decdg = (d ( ec*rho ) / d (grad(rho)_i)) * agrad / grad_i -! gradr here is used as a working array -! -! _________________________________________________________________ -! first part of the xc-potential : D(rho*exc)/D(rho) -! - do iss = 1, nspin - rhor(ir,iss) = dexdrho(iss) + decdrho(iss) - enddo -! -! gradr = D(rho*exc)/D(|grad rho|) * (grad rho) / |grad rho| -! - do iss = 1, nspin - do icar = 1,3 - wrkup =0.d0 - wrkdw =0.d0 - if (agrad(iss).gt.lim2) & - & wrkup = dexdg(iss)*grad(icar,iss)/agrad(iss) - if (agradtot.gt.lim2) & - & wrkdw = decdg*gradtot(icar)/agradtot - gradr(ir,icar,iss) = wrkup + wrkdw - enddo - enddo -! - end do -! - return - end subroutine ggapbe -! -!______________________________________________________________________ - subroutine exchpbe(rho,agrad,ex,dexdrho,dexdg) -! _________________________________________________________________ -! -! Perdew-Burke-Ernzerhof gga, Exchange term: -! Calculates the exchange energy density and the two functional derivative -! that will be used to calculate the potential -! - USE kinds, ONLY: DP - implicit none -! input -! input rho: charge density -! input agrad: abs(grad rho) - real(DP) rho, agrad -! ouput -! output ex: Ex[rho,grad_rho] = \int ex dr -! output dexdrho: d ex / d rho -! output dexdg: d ex / d grad_rho(i) = dexdg*grad_rho(i)/abs(grad_rho) - real(DP) ex, dexdrho, dexdg -! local - real(DP) thrd, thrd4, pi32td, ax, al, um, uk, ul - parameter(thrd=.33333333333333333333d0,thrd4=4.d0/3.d0) - parameter(pi32td=3.09366772628014d0) ! pi32td=(3.d0*pi*pi)**0.333d0 - parameter(al=0.161620459673995d0) ! al=1.0/(2.0*(pi32)**0.333d0) - parameter(ax=-0.738558766382022405884230032680836d0) - parameter(um=0.2195149727645171d0,uk=0.8040d0,ul=um/uk) -! - real(DP) rhothrd, exunif, dexunif, kf, s, s2, p0, fxpbe, fs -!---------------------------------------------------------------------- -! construct LDA exchange energy density -! - rhothrd = rho**thrd - dexunif = ax*rhothrd - exunif = rho*dexunif -!---------------------------------------------------------------------- -! construct PBE enhancement factor -! - kf = pi32td*rhothrd - s = agrad/(2.d0*kf*rho) - s2 = s*s - p0 = 1.d0 + ul*s2 - fxpbe = 1.d0 + uk - uk/p0 - ex = exunif*fxpbe -!---------------------------------------------------------------------- -! now calculates the potential terms -! -! fs=(1/s)*d fxPBE/ ds -! - fs=2.d0*uk*ul/(p0*p0) - dexdrho = dexunif*thrd4*(fxpbe-s2*fs) - dexdg = ax*al*s*fs -! - return - end subroutine exchpbe - -!---------------------------------------------------------------------- - subroutine ecorpbe(rho,agrad,zet,ectot,decup,decdn,decdg,nspin) -! ----------------------------------------------------------------- -! -! Adapted from the Official PBE correlation code. K. Burke, May 14, 1996. -! -! input: rho = rho_up + rho_down; total charge density -! input: agrad = abs( grad(rho) ) -! input: zet = (rho_up-rho_down)/rho -! input: nspin -! output: ectot = ec*rho ---correlation energy density--- -! output: decup = d ( ec*rho ) / d (rho_up) -! output: decdn = d ( ec*rho ) / d (rho_down) -! output: decdg = (d ( ec*rho ) / d (grad(rho)_i)) * agrad / grad_i -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -! References: -! [a] J.P.~Perdew, K.~Burke, and M.~Ernzerhof, -! {\sl Generalized gradient approximation made simple}, sub. -! to Phys. Rev.Lett. May 1996. -! [b] J. P. Perdew, K. Burke, and Y. Wang, {\sl Real-space cutoff -! construction of a generalized gradient approximation: The PW91 -! density functional}, submitted to Phys. Rev. B, Feb. 1996. -! [c] J. P. Perdew and Y. Wang, Phys. Rev. B {\bf 45}, 13244 (1992). -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- - USE kinds, ONLY: DP - USE constants, ONLY: pi - implicit none - real(DP) rho, agrad, zet, ectot, decup, decdn, decdg - integer nspin - real(DP) pi32, alpha, thrd, thrdm, thrd2, sixthm, thrd4, & - gam, fzz, gamma, bet, delt, eta -! thrd*=various multiples of 1/3 -! numbers for use in LSD energy spin-interpolation formula, [c](9). -! gam= 2^(4/3)-2 -! fzz=f''(0)= 8/(9*gam) -! numbers for construction of PBE -! gamma=(1-log(2))/pi^2 -! bet=coefficient in gradient expansion for correlation, [a](4). -! eta=small number to stop d phi/ dzeta from blowing up at -! |zeta|=1. - parameter(pi32=29.608813203268075856503472999628d0) - parameter(alpha=1.91915829267751300662482032624669d0) - parameter(thrd=1.d0/3.d0,thrdm=-thrd,thrd2=2.d0*thrd) - parameter(sixthm=thrdm/2.d0) - parameter(thrd4=4.d0*thrd) - parameter(gam=0.5198420997897463295344212145565d0) - parameter(fzz=8.d0/(9.d0*gam)) - parameter(gamma=0.03109069086965489503494086371273d0) - parameter(bet=0.06672455060314922d0,delt=bet/gamma) - parameter(eta=1.d-12) - real(DP) g, fk, rs, sk, twoksg, t - real(DP) rtrs, eu, eurs, ep, eprs, alfm, alfrsm, z4, f, ec - real(DP) ecrs, fz, eczet, comm, vcup, vcdn, g3, pon, b, b2, t2, t4 - real(DP) q4, q5, h, g4, t6, rsthrd, gz, fac - real(DP) bg, bec, q8, q9, hb, hrs, hz, ht, pref -!---------------------------------------------------------------------- - if (nspin.eq.1) then - g=1.d0 - else - g=((1.d0+zet)**thrd2+(1.d0-zet)**thrd2)*0.5d0 - endif - fk=(pi32*rho)**thrd - rs=alpha/fk - sk=sqrt(4.d0*fk/pi) - twoksg=2.d0*sk*g - t=agrad/(twoksg*rho) -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -! find LSD energy contributions, using [c](10) and Table I[c]. -! eu=unpolarized LSD correlation energy -! eurs=deu/drs -! ep=fully polarized LSD correlation energy -! eprs=dep/drs -! alfm=-spin stiffness, [c](3). -! alfrsm=-dalpha/drs -! f=spin-scaling factor from [c](9). -! construct ec, using [c](8) - rtrs=dsqrt(rs) - call gcor2(0.0310907d0,0.21370d0,7.5957d0,3.5876d0,1.6382d0, & - & 0.49294d0,rtrs,eu,eurs) - if (nspin.eq.2) then - call gcor2(0.01554535d0,0.20548d0,14.1189d0,6.1977d0,3.3662d0, & - & 0.62517d0,rtrs,ep,eprs) - call gcor2(0.0168869d0,0.11125d0,10.357d0,3.6231d0,0.88026d0, & - & 0.49671d0,rtrs,alfm,alfrsm) - z4 = zet**4 - f=((1.d0+zet)**thrd4+(1.d0-zet)**thrd4-2.d0)/gam - ec = eu*(1.d0-f*z4)+ep*f*z4-alfm*f*(1.d0-z4)/fzz -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -! LSD potential from [c](A1) -! ecrs = dec/drs [c](A2) -! eczet=dec/dzeta [c](A3) -! fz = df/dzeta [c](A4) - ecrs = eurs*(1.d0-f*z4)+eprs*f*z4-alfrsm*f*(1.d0-z4)/fzz - fz = thrd4*((1.d0+zet)**thrd-(1.d0-zet)**thrd)/gam - eczet = 4.d0*(zet**3)*f*(ep-eu+alfm/fzz)+fz*(z4*ep-z4*eu & - & -(1.d0-z4)*alfm/fzz) - comm = ec -rs*ecrs/3.d0-zet*eczet - vcup = comm + eczet - vcdn = comm - eczet - else - ecrs = eurs - ec = eu - vcup = ec -rs*ecrs/3.d0 - endif -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -! PBE correlation energy -! g=phi(zeta), given after [a](3) -! delt=bet/gamma -! b=a of [a](8) -! g=((1.d0+zet)**thrd2+(1.d0-zet)**thrd2)/2.d0 - g3 = g**3 - pon=-ec/(g3*gamma) - b = delt/(dexp(pon)-1.d0) - b2 = b*b - t2 = t*t - t4 = t2*t2 - q4 = 1.d0+b*t2 - q5 = 1.d0+b*t2+b2*t4 - h = g3*(bet/delt)*dlog(1.d0+delt*Q4*t2/Q5) - ectot = rho*(ec + h) -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -! energy done. Now the potential, using appendix e of [b]. - t6 = t4*t2 - rsthrd = rs/3.d0 - fac = delt/b+1.d0 - bec = b2*fac/(bet*g3) - q8 = q5*q5+delt*q4*q5*t2 - q9 = 1.d0+2.d0*b*t2 - hb = -bet*g3*b*t6*(2.d0+b*t2)/q8 - hrs = -rsthrd*hb*bec*ecrs - ht = 2.d0*bet*g3*q9/q8 - comm = h+hrs-7.d0*t2*ht/6.d0 - if (nspin.eq.2) then - g4 = g3*g - bg = -3.d0*b2*ec*fac/(bet*g4) - gz=(((1.d0+zet)**2+eta)**sixthm- & - & ((1.d0-zet)**2+eta)**sixthm)/3.d0 - hz = 3.d0*gz*h/g + hb*(bg*gz+bec*eczet) - pref = hz-gz*t2*ht/g - decup = vcup + comm + pref*( 1.d0 - zet) - decdn = vcdn + comm + pref*( -1.d0 - zet) - else - decup = vcup + comm - endif - decdg = t*ht/twoksg -! - return - end subroutine ecorpbe -!______________________________________________________________________ - subroutine gcor2(a,a1,b1,b2,b3,b4,rtrs,gg,ggrs) -! _________________________________________________________________ -! slimmed down version of GCOR used in PW91 routines, to interpolate -! LSD correlation energy, as given by (10) of -! J. P. Perdew and Y. Wang, Phys. Rev. B {\bf 45}, 13244 (1992). -! K. Burke, May 11, 1996. -! - USE kinds, ONLY : DP - implicit none - real(DP) a, a1, b1, b2, b3, b4, rtrs, gg, ggrs - real(DP) q0, q1, q2, q3 -! - q0 = -2.d0*a*(1.d0+a1*rtrs*rtrs) - q1 = 2.d0*a*rtrs*(b1+rtrs*(b2+rtrs*(b3+b4*rtrs))) - q2 = dlog(1.d0+1.d0/q1) - gg = q0*q2 - q3 = a*(b1/rtrs+2.d0*b2+rtrs*(3.d0*b3+4.d0*b4*rtrs)) - ggrs = -2.d0*a*a1*q2-q0*q3/(q1*(1.d0+q1)) -! - return - end subroutine gcor2 -! -!______________________________________________________________________ - subroutine ggapw(nnr,nspin,gradr,rhor,exc) -! _________________________________________________________________ -! perdew-wang gga (PW91) -! - USE kinds, ONLY: DP - use constants, only: pi, fpi -! - implicit none -! input - integer nspin, nnr - real(DP) gradr(nnr,3,nspin), rhor(nnr,nspin) -! output - real(DP) exc -! local - integer isup, isdw, ir - real(DP) rhoup, rhodw, roe, aroe, rs, zeta - real(DP) grxu, gryu, grzu, grhou, grxd, gryd, grzd, grhod, grho - real(DP) ex, ec,vc, sc, v1x, v2x, v1c, v2c - real(DP) ecrs, eczeta - real(DP) exup, vcup, v1xup, v2xup, v1cup - real(DP) exdw, vcdw, v1xdw, v2xdw, v1cdw - real(DP), parameter:: pi34 = 0.75d0/pi, third = 1.d0/3.d0, & - small = 1.d-10 -! -! _________________________________________________________________ -! main loop -! - isup=1 - isdw=2 - exc=0.0d0 - do ir=1,nnr - rhoup=rhor(ir,isup) - if(nspin.eq.2) then - rhodw=rhor(ir,isdw) - else - rhodw=0.0d0 - end if - roe=rhoup+rhodw - aroe=abs(roe) - if (aroe.lt.small) then - rhor(ir,isup) =0.0d0 - gradr(ir,1,isup)=0.0d0 - gradr(ir,2,isup)=0.0d0 - gradr(ir,3,isup)=0.0d0 - if(nspin.eq.2) then - rhor(ir,isdw) =0.0d0 - gradr(ir,1,isdw)=0.0d0 - gradr(ir,2,isdw)=0.0d0 - gradr(ir,3,isdw)=0.0d0 - end if - go to 100 - end if - grxu =gradr(ir,1,isup) - gryu =gradr(ir,2,isup) - grzu =gradr(ir,3,isup) - grhou=sqrt(grxu**2+gryu**2+grzu**2) - if(nspin.eq.2) then - grxd =gradr(ir,1,isdw) - gryd =gradr(ir,2,isdw) - grzd =gradr(ir,3,isdw) - grhod=sqrt(grxd**2+gryd**2+grzd**2) - else - grxd =0.0d0 - gryd =0.0d0 - grzd =0.0d0 - grhod=0.0d0 - endif - grho=sqrt((grxu+grxd)**2+(gryu+gryd)**2+(grzu+grzd)**2) -! - rs=(pi34/aroe)**third - if (nspin.eq.1) then - call exchpw91(aroe,grho,ex,v1x,v2x) - call pwlda(rs,ec,vc,ecrs) - call corpw91ns(rs,grho,ec,ecrs,sc,v1c,v2c) - exc = exc + roe*(ex+ec) + sc - rhor(ir,isup) = vc + v1x + v1c -! -! gradr = D(rho*exc)/D(|grad rho|) * (grad rho) / |grad rho| -! - gradr(ir,1,isup)=grxu*(v2x+v2c) - gradr(ir,2,isup)=gryu*(v2x+v2c) - gradr(ir,3,isup)=grzu*(v2x+v2c) - else - zeta=(rhoup-rhodw)/aroe - zeta=min(zeta, 1.d0) - zeta=max(zeta,-1.d0) - call exchpw91(2.d0*abs(rhoup),2.0d0*grhou,exup,v1xup,v2xup) - call exchpw91(2.d0*abs(rhodw),2.0d0*grhod,exdw,v1xdw,v2xdw) - call pwlsd(rs,zeta,ec,vcup,vcdw,ecrs,eczeta) - call corpw91(rs,zeta,grho,ec,ecrs,eczeta,sc,v1cup,v1cdw,v2c) - rhor(ir,isup) = vcup + v1xup + v1cup - rhor(ir,isdw) = vcdw + v1xdw + v1cdw - exc = exc+roe*(0.5d0*((1.d0+zeta)*exup+(1.d0-zeta)*exdw)+ec) & - + sc -! -! gradr = D(rho*exc)/D(|grad rho|) * (grad rho) / |grad rho| -! - gradr(ir,1,isup)=grxu*(2.0d0*v2xup+v2c)+grxd*v2c - gradr(ir,2,isup)=gryu*(2.0d0*v2xup+v2c)+gryd*v2c - gradr(ir,3,isup)=grzu*(2.0d0*v2xup+v2c)+grzd*v2c - gradr(ir,1,isdw)=grxd*(2.0d0*v2xdw+v2c)+grxu*v2c - gradr(ir,2,isdw)=gryd*(2.0d0*v2xdw+v2c)+gryu*v2c - gradr(ir,3,isdw)=grzd*(2.0d0*v2xdw+v2c)+grzu*v2c - end if - 100 continue - end do -! - return - end subroutine ggapw -! -!---------------------------------------------------------------------- - subroutine exchpw91(rho,grho,ex,v1x,v2x) -!---------------------------------------------------------------------- -! -! PW91 exchange for a spin-unpolarized electronic system -! Modified from the "official" PBE code of Perdew, Burke et al. -! input rho : density -! input grho: abs(grad rho) -! output: exchange energy per electron (ex) and potentials -! v1x = d(rho*exc)/drho -! v2x = d(rho*exc)/d|grho| * (1/|grho|) -! - USE kinds, ONLY : DP - USE constants, ONLY : pi - implicit none -! input - real(DP) rho, grho -! output - real(DP) ex, v1x, v2x -! local - real(DP) ex0, kf, s, s2, s4, f, fs, p0,p1,p2,p3,p4,p5,p6,p7 -! parameters - real(DP) a1, a2, a3, a4, a, b1, bx, pi34, thrd, thrd4 - parameter(a1=0.19645d0,a2=0.27430d0,a=7.7956d0,a4=100.d0) -! for becke exchange, set a3=b1=0 - parameter(a3=0.15084d0,b1=0.004d0) -! pi34=3/(4pi) , bx=(3pi^2)^(1/3) - parameter(pi34=0.75d0/pi, bx=3.093667726d0, thrd=0.333333333333d0, & - thrd4=4.d0*thrd) -! - if (rho.lt.1.d-10) then - ex =0.0d0 - v1x=0.0d0 - v2x=0.0d0 - end if -! -! kf=k_Fermi, ex0=Slater exchange energy -! - kf = bx*(rho**thrd) - ex0=-pi34*kf - if (grho.lt.1.d-10) then - ex =ex0 - v1x=ex0*thrd4 - v2x=0.0d0 - end if - s = grho/(2.d0*kf*rho) - s2 = s*s - s4 = s2*s2 - p0 = 1.d0/sqrt(1.d0+a*a*s2) - p1 = log(a*s+1.d0/p0) - p2 = exp(-a4*s2) - p3 = 1.d0/(1.d0+a1*s*p1+b1*s4) - p4 = 1.d0+a1*s*p1+(a2-a3*p2)*s2 -! f is the enhancement factor - f = p3*p4 - ex = ex0*f -! energy done. now the potential: - p5 = b1*s2-(a2-a3*p2) - p6 = a1*s*(p1+a*s*p0) - p7 = 2.d0*(a2-a3*p2)+2.d0*a3*a4*s2*p2-4.d0*b1*s2*f -! fs = (1/s) dF(s)/ds - fs = p3*(p3*p5*p6+p7) - v1x = ex0*thrd4*(f-s2*fs) - v2x = 0.5d0*ex0/kf*s*fs/grho -! - return - end subroutine exchpw91 -! -!---------------------------------------------------------------------- - subroutine corpw91ns(rs,grho,ec,ecrs,h,v1c,v2c) -!---------------------------------------------------------------------- -! -! PW91 correlation (gradient correction term) - no spin case -! Modified from the "official" PBE code of Perdew, Burke et al. -! -! input rs: seitz radius -! input zeta: relative spin polarization -! input grho: abs(grad rho) -! input ec: Perdew-Wang correlation energy -! input ecrs: d(rho*ec)/d r_s - -! output h : nonlocal part of correlation energy per electron -! output v1c: nonlocal parts of correlation potential -! v1c = d(rho*exc)/drho -! v2c = d(rho*exc)/d|grho|*(1/|grho|) -! - USE kinds, ONLY : DP - USE constants, ONLY : pi - implicit none -! input - real(DP) rs, grho, ec, ecrs -! output - real(DP) h, v1c, v2c -! local - real(DP) rho, t, ks, bet, delt, pon, b, b2, t2, t4, t6 - real(DP) q4, q5, q6, q7, q8, q9, r0, r1, r2, r3, r4, rs2, rs3 - real(DP) ccrs, rsthrd, fac, bec, coeff, cc - real(DP) h0, h0b, h0rs, h0t, h1, h1t, h1rs, hrs, ht -! parameters - real(DP) nu, cc0, cx, alf, c1, c2, c3, c4, c5, c6, a4, ax, pi34 - parameter(nu=15.75592d0,cc0=0.004235d0,cx=-0.001667212d0) - parameter(c1=0.002568d0,c2=0.023266d0,c3=7.389d-6,c4=8.723d0) - parameter(c5=0.472d0,c6=7.389d-2,a4=100.d0, alf=0.09d0) -! ax=(4*1.9191583/pi)^(1/2), where k_F=1.9191583/r_s, k_s=boh*r_s^(1/2) - parameter(ax=1.5631853d0, pi34 = 0.75d0/pi) -! -! - rs2 = rs*rs - rs3 = rs2*rs - rho=pi34/rs3 -! k_s=(4k_F/pi)^(1/2) - ks=ax/sqrt(rs) -! t=abs(grad rho)/(rho*2.*ks) - t=grho/(2.d0*rho*ks) - bet = nu*cc0 - delt = 2.d0*alf/bet - pon = -delt*ec/bet - b = delt/(exp(pon)-1.d0) - b2 = b*b - t2 = t*t - t4 = t2*t2 - t6 = t4*t2 - q4 = 1.d0+b*t2 - q5 = 1.d0+b*t2+b2*t4 - q6 = c1+c2*rs+c3*rs2 - q7 = 1.d0+c4*rs+c5*rs2+c6*rs3 - cc = -cx + q6/q7 - r0 = 0.663436444d0*rs - r1 = a4*r0 - coeff = cc-cc0-3.d0*cx/7.d0 - r2 = nu*coeff - r3 = exp(-r1*t2) - h0 = (bet/delt)*log(1.d0+delt*q4*t2/q5) - h1 = r3*r2*t2 - h = (h0+h1)*rho -! energy done. now the potential: - ccrs = (c2+2.d0*c3*rs)/q7 - q6*(c4+2.d0*c5*rs+3.d0*c6*rs2)/q7**2 - rsthrd = rs/3.d0 - r4 = rsthrd*ccrs/coeff - fac = delt/b+1.d0 - bec = b2*fac/bet - q8 = q5*q5+delt*q4*q5*t2 - q9 = 1.d0+2.d0*b*t2 - h0b = -bet*b*t6*(2.d0+b*t2)/q8 - h0rs = -rsthrd*h0b*bec*ecrs - h0t = 2.d0*bet*q9/q8 - h1rs = r3*r2*t2*(-r4+r1*t2/3.d0) - h1t = 2.d0*r3*r2*(1.d0-r1*t2) - hrs = h0rs+h1rs - ht = h0t+h1t - v1c = h0+h1+hrs-7.d0*t2*ht/6.d0 - v2c = t*ht/(2.d0*ks*grho) -! - return - end subroutine corpw91ns -! -!---------------------------------------------------------------------- - subroutine corpw91(rs,zeta,grho,ec,ecrs,eczeta,h,v1cup,v1cdn,v2c) -!---------------------------------------------------------------------- -! -! PW91 correlation (gradient correction term) -! Modified from the "official" PBE code of Perdew, Burke et al. -! -! input rs: seitz radius -! input zeta: relative spin polarization -! input grho: abs(grad rho) -! input ec: Perdew-Wang correlation energy -! input ecrs: d(rho*ec)/d r_s ? -! input eczeta: d(rho*ec)/d zeta ? - -! output h: nonlocal part of correlation energy per electron -! output v1cup,v1cdn: nonlocal parts of correlation potentials -! v1c** = d(rho*exc)/drho (up and down components) -! v2c = d(rho*exc)/d|grho|*(1/|grho|) (same for up and down) -! - USE kinds, ONLY : DP - USE constants, ONLY : pi - implicit none -! input - real(DP) rs, zeta, grho, ec, ecrs, eczeta -! output - real(DP) h, v1cup, v1cdn, v2c -! local - real(DP) rho, g, t, ks, gz, bet, delt, g3, g4, pon, b, b2, t2, t4, t6 - real(DP) q4, q5, q6, q7, q8, q9, r0, r1, r2, r3, r4, rs2, rs3 - real(DP) ccrs, rsthrd, fac, bg, bec, coeff, cc - real(DP) h0, h0b, h0rs, h0z, h0t, h1, h1t, h1rs, h1z - real(DP) hz, hrs, ht, comm, pref -! parameters - real(DP) nu, cc0, cx, alf, c1, c2, c3, c4, c5, c6, a4 - real(DP) thrdm, thrd2, ax, eta, pi34 - parameter(nu=15.75592d0,cc0=0.004235d0,cx=-0.001667212d0) - parameter(c1=0.002568d0,c2=0.023266d0,c3=7.389d-6,c4=8.723d0) - parameter(c5=0.472d0,c6=7.389d-2,a4=100.d0, alf=0.09d0) - parameter(thrdm=-0.333333333333d0,thrd2=0.666666666667d0) -! ax=(4*1.9191583/pi)^(1/2), where k_F=1.9191583/r_s, k_s=boh*r_s^(1/2) - parameter(ax=1.5631853d0, eta=1.d-12, pi34 = 0.75d0/pi ) -! -! - if (grho.lt.1.d-10) then - h=0.0d0 - v1cup=0.0d0 - v1cdn=0.0d0 - v2c=0.0d0 - end if - rs2 = rs*rs - rs3 = rs2*rs - rho=pi34/rs3 - g=((1.d0+zeta)**thrd2+(1.d0-zeta)**thrd2)/2.d0 -! k_s=(4k_F/pi)^(1/2) - ks=ax/sqrt(rs) -! t=abs(grad rho)/(rho*2.*ks*g) - t=grho/(2.d0*rho*g*ks) - bet = nu*cc0 - delt = 2.d0*alf/bet - g3 = g**3 - g4 = g3*g - pon = -delt*ec/(g3*bet) - b = delt/(exp(pon)-1.d0) - b2 = b*b - t2 = t*t - t4 = t2*t2 - t6 = t4*t2 - q4 = 1.d0+b*t2 - q5 = 1.d0+b*t2+b2*t4 - q6 = c1+c2*rs+c3*rs2 - q7 = 1.d0+c4*rs+c5*rs2+c6*rs3 - cc = -cx + q6/q7 - r0 = 0.663436444d0*rs - r1 = a4*r0*g4 - coeff = cc-cc0-3.d0*cx/7.d0 - r2 = nu*coeff*g3 - r3 = dexp(-r1*t2) - h0 = g3*(bet/delt)*log(1.d0+delt*q4*t2/q5) - h1 = r3*r2*t2 - h = (h0+h1)*rho -! energy done. now the potential: - ccrs = (c2+2.d0*c3*rs)/q7 - q6*(c4+2.d0*c5*rs+3.d0*c6*rs2)/q7**2 - rsthrd = rs/3.d0 - r4 = rsthrd*ccrs/coeff -! eta is a small quantity that avoids trouble if zeta=+1 or -1 - gz = ((1.d0+zeta+eta)**thrdm - (1.d0-zeta+eta)**thrdm)/3.d0 - fac = delt/b+1.d0 - bg = -3.d0*b2*ec*fac/(bet*g4) - bec = b2*fac/(bet*g3) - q8 = q5*q5+delt*q4*q5*t2 - q9 = 1.d0+2.d0*b*t2 - h0b = -bet*g3*b*t6*(2.d0+b*t2)/q8 - h0rs = -rsthrd*h0b*bec*ecrs - h0z = 3.d0*gz*h0/g + h0b*(bg*gz+bec*eczeta) - h0t = 2.d0*bet*g3*q9/q8 - h1rs = r3*r2*t2*(-r4+r1*t2/3.d0) - h1z = gz*r3*r2*t2*(3.d0-4.d0*r1*t2)/g - h1t = 2.d0*r3*r2*(1.d0-r1*t2) - hrs = h0rs+h1rs - ht = h0t+h1t - hz = h0z+h1z - comm = h0+h1+hrs-7.d0*t2*ht/6.d0 - pref = hz-gz*t2*ht/g - comm = comm-pref*zeta - v1cup = comm + pref - v1cdn = comm - pref - v2c = t*ht/(2.d0*ks*g*grho) -! - return - end subroutine corpw91 -!---------------------------------------------------------------------- - subroutine pwlda(rs,ec,vc,ecrs) -!---------------------------------------------------------------------- -! -! uniform-gas, spin-unpolarised correlation of perdew and wang 1991 -! input: rs seitz radius -! output: ec correlation energy per electron -! vc potential -! ecrs derivatives of ec wrt rs -! - USE kinds, ONLY : DP - implicit none -! input - real(DP) rs -! output - real(DP) ec, vc, ecrs -! local - real(DP) q0, rs12, q1, q2, q3 -! parameters - real(DP) a, a1, b1, b2, b3, b4 - parameter(a =0.0310907d0, a1=0.21370d0, b1=7.5957d0, & - b2=3.5876d0, b3=1.6382d0, b4=0.49294d0) -! - q0 = -2.d0*a*(1.d0+a1*rs) - rs12 = sqrt(rs) - q1 = 2.d0*a*rs12*(b1+rs12*(b2+rs12*(b3+b4*rs12))) - q2 = log(1.d0+1.d0/q1) - ec = q0*q2 - q3 = a*(b1/rs12+2.d0*b2+3.d0*b3*rs12+2.d0*b4*2.d0*rs) - ecrs = -2.d0*a*a1*q2-q0*q3/(q1**2+q1) - vc = ec - rs*ecrs/3.d0 -! - return - end subroutine pwlda -!---------------------------------------------------------------------- - subroutine pwlsd(rs,zeta,ec,vcup,vcdn,ecrs,eczeta) -!---------------------------------------------------------------------- -! -! uniform-gas correlation of perdew and wang 1991 -! Modified from the "official" PBE code of Perdew, Burke et al. -! input: seitz radius (rs), relative spin polarization (zeta) -! output: correlation energy per electron (ec) -! up- and down-spin potentials (vcup,vcdn) -! derivatives of ec wrt rs (ecrs) & zeta (eczeta) -! - USE kinds, ONLY : DP - implicit none -! input - real(DP) rs, zeta -! output - real(DP) ec, vcup, vcdn, ecrs, eczeta -! local - real(DP) f, eu, ep, eurs, eprs, alfm, alfrsm, z4, fz, comm - real(DP) rs12, q0, q1, q2, q3 -! parameters - real(DP) gam, fzz, thrd, thrd4 - parameter(gam=0.5198421d0,fzz=1.709921d0) - parameter(thrd=0.333333333333d0,thrd4=1.333333333333d0) -! - real(DP) au, au1, bu1, bu2, bu3, bu4 - parameter(au =0.0310907d0, au1=0.21370d0, bu1=7.5957d0, & - bu2=3.5876d0, bu3=1.6382d0, bu4=0.49294d0) - real(DP) ap, ap1, bp1, bp2, bp3, bp4 - parameter(ap =0.01554535d0,ap1=0.20548d0, bp1=14.1189d0, & - bp2=6.1977d0, bp3=3.3662d0, bp4=0.62517d0 ) - real(DP) am, am1, bm1, bm2, bm3, bm4 - parameter(am =0.0168869d0, am1=0.11125d0, bm1=10.357d0, & - bm2=3.6231d0, bm3=0.88026d0, bm4=0.49671d0 ) -! - rs12 = sqrt(rs) -! - q0 = -2.d0*au*(1.d0+au1*rs) - q1 = 2.d0*au*rs12*(bu1+rs12*(bu2+rs12*(bu3+bu4*rs12))) - q2 = log(1.d0+1.d0/q1) - eu = q0*q2 - q3 = au*(bu1/rs12+2.d0*bu2+3.d0*bu3*rs12+2.d0*bu4*2.d0*rs) - eurs = -2.d0*au*au1*q2-q0*q3/(q1**2+q1) -! - q0 = -2.d0*ap*(1.d0+ap1*rs) - q1 = 2.d0*ap*rs12*(bp1+rs12*(bp2+rs12*(bp3+bp4*rs12))) - q2 = log(1.d0+1.d0/q1) - ep = q0*q2 - q3 = ap*(bp1/rs12+2.d0*bp2+3.d0*bp3*rs12+2.d0*bp4*2.d0*rs) - eprs = -2.d0*ap*ap1*q2-q0*q3/(q1**2+q1) -! - q0 = -2.d0*am*(1.d0+am1*rs) - q1 = 2.d0*am*rs12*(bm1+rs12*(bm2+rs12*(bm3+bm4*rs12))) - q2 = log(1.d0+1.d0/q1) -! alfm is minus the spin stiffness alfc - alfm=q0*q2 - q3 = am*(bm1/rs12+2.d0*bm2+3.d0*bm3*rs12+2.d0*bm4*2.d0*rs) - alfrsm=-2.d0*am*am1*q2-q0*q3/(q1**2+q1) -! - f = ((1.d0+zeta)**thrd4+(1.d0-zeta)**thrd4-2.d0)/gam - z4 = zeta**4 - ec = eu*(1.d0-f*z4)+ep*f*z4-alfm*f*(1.d0-z4)/fzz -! energy done. now the potential: - ecrs = eurs*(1.d0-f*z4)+eprs*f*z4-alfrsm*f*(1.d0-z4)/fzz - fz = thrd4*((1.d0+zeta)**thrd-(1.d0-zeta)**thrd)/gam - eczeta = 4.d0*(zeta**3)*f*(ep-eu+alfm/fzz)+fz*(z4*ep-z4*eu & - & -(1.d0-z4)*alfm/fzz) - comm = ec -rs*ecrs/3.d0-zeta*eczeta - vcup = comm + eczeta - vcdn = comm - eczeta -! - return - end subroutine pwlsd -! -!______________________________________________________________________ - subroutine ggapwold(nnr,nspin,gradr,rhor,exc) -! _________________________________________________________________ -! perdew-wang gga -! as given in y-m juan & e kaxiras, prb 48, 14944 (1993) -! method by ja white & dm bird, prb 50, 4954 (1994) -! non-spin polarized case only -! _________________________________________________________________ -! by alfredo pasquarello 22/09/1994 -! - USE kinds, ONLY: DP - use constants, only: pi, fpi -! - implicit none -! - integer nspin, nnr - real(DP) gradr(nnr,3), rhor(nnr), exc -! - real(DP) bb1, bb2, bb3, bb4, bb5, alfa, beta, cc0, cc1, delt, & - c1, c2, c3, c4, c5, c6, c7, a, alfa1, bt1, bt2, bt3, bt4 - parameter(bb1=0.19645d0,bb2=0.27430d0,bb3=-0.15084d0,bb4=0.004d0, & - bb5=7.7956d0,alfa=0.09d0,beta=0.0667263212d0,cc0=15.75592d0, & - cc1=0.003521d0,c1=0.001667d0,c2=0.002568d0,c3=0.023266d0,c4=7.389d-6, & - c5=8.723d0,c6=0.472d0,c7=7.389d-2,a=0.0621814d0,alfa1=0.2137d0, & - bt1=7.5957d0,bt2=3.5876d0,bt3=1.6382d0,bt4=0.49294d0,delt=1.0d-12) - real(DP) x13, x43, x76, pi2, ax, pider1, pider2, pider3, & - abder1, abder2, abder3 - integer isign, ir - real(DP) & - aexp, abig, abig2, agr, aroe, byagr, ccr, ccrnum, ccrden, & - dfxd, dfxdg, dys, dfs, dh1ds, dh1dg, dh1d, dh1dt, dexcdg, & - dexcd, dh1drs, dh0da, dadec, decdrs, decd, dh0dg, dcdrs, & - dh0d, dh0dt, eclog, ecr, ecden, fx, fxnum, fxden, fxexp, & - gkf, grx, gry, grz, h0, h1, h0den, h0arg, h0num, & - roeth, roe, rs, rs12, rs2, rs3, rs32, s, sd, s2, s3, s4, & - sysl, t, td, t2, t3, t4, xchge, ys, ysl, ysr -! -! - if (nspin.ne.1) call errore('ggapw','spin not implemented',nspin) -! - x13=1.0d0/3.0d0 - x43=4.0d0/3.0d0 - x76=7.0d0/6.0d0 -! _________________________________________________________________ -! derived parameters from pi -! - pi2=pi*pi - ax=-0.75d0*(3.0d0/pi)**x13 - pider1=(0.75d0/pi)**x13 - pider2=(3.0d0*pi2)**x13 - pider3=(3.0d0*pi2/16.0d0)**x13 -! _________________________________________________________________ -! derived parameters from alfa and beta -! - abder1=beta*beta/(2.0d0*alfa) - abder2=1.0d0/abder1 - abder3=2.0d0*alfa/beta -! _________________________________________________________________ -! main loop -! - do ir=1,nnr - roe=rhor(ir) - if(roe.eq.0.0) goto 100 - aroe=abs(roe) - grx=gradr(ir,1) - gry=gradr(ir,2) - grz=gradr(ir,3) - agr=sqrt(grx*grx+gry*gry+grz*grz) - roeth=aroe**x13 - rs= pider1/roeth - gkf=pider2*roeth - sd=1.0d0/(2.0d0*gkf*aroe) - s=agr*sd - s2=s*s - s3=s*s2 - s4=s2*s2 -! _________________________________________________________________ -! exchange -! - ysr=sqrt(1.0d0+bb5*bb5*s2) - ys=bb5*s+ysr - ysl=log(ys)*bb1 - sysl=s*ysl - fxexp=exp(-100.0d0*s2) - fxnum=1.0d0+sysl+(bb2+bb3*fxexp)*s2 - fxden=1.0d0/(1.0d0+sysl+bb4*s4) - fx=fxnum*fxden - xchge=ax*fx*roeth -! _________________________________________________________________ -! correlation ecr=ec(rho) -! - rs12=sqrt(rs) - rs32=rs12*rs - rs2=rs*rs - rs3=rs*rs2 - ecden=a*(bt1*rs12+bt2*rs+bt3*rs32+bt4*rs2) - eclog=log(1.0d0+(1.0d0/ecden)) - ecr=-a*(1.0d0+alfa1*rs)*eclog -! _________________________________________________________________ -! correlation h0(t,ecr) -! - td=pider3*sd/rs12 - t=agr*td - t2=t*t - t3=t*t2 - t4=t2*t2 - aexp=exp(-abder2*ecr)-1.0d0 - abig=abder3/aexp - abig2=abig*abig - h0num=t2+abig*t4 - h0den=1.0d0/(1.0d0+abig*t2+abig2*t4) - h0arg=1.0d0+abder3*h0num*h0den - h0=abder1*log(h0arg) -! _________________________________________________________________ -! correlation h1(t,s,aroe) -! - ccrnum=c2+c3*rs+c4*rs2 - ccrden=1.0d0/(1.0d0+c5*rs+c6*rs2+c7*rs3) - ccr=c1+ccrnum*ccrden - h1=cc0*(ccr-cc1)*t2*fxexp -! _________________________________________________________________ -! updating of xc-energy -! - exc=exc+(xchge+ecr+h0+h1)*aroe -! _________________________________________________________________ -! first part xc-potential from exchange -! - dys=bb5*(1.0d0+bb5*s/ysr)/ys - dfs=-fxnum*(ysl+bb1*s*dys+4.0d0*bb4*s3)*fxden*fxden & - & +(ysl+bb1*s*dys+2.0d0*s*(bb2+bb3*fxexp) & - & -200.0d0*s3*bb3*fxexp)*fxden - dfxd=(ax*roeth*x43)*(fx-dfs*s) - dfxdg=ax*roeth*dfs*sd -! _________________________________________________________________ -! first part xc-potential from ecr -! - decdrs=-a*alfa1*eclog*rs + a*(1+alfa1*rs) & - & *a*(0.5d0*bt1*rs12+bt2*rs+1.5d0*bt3*rs32+2.0d0*bt4*rs2) & - & /(ecden*ecden+ecden) - decd=-x13*decdrs -! _________________________________________________________________ -! first part xc-potential from h0 -! - dh0da=abder1/h0arg*abder3*h0den* & - & (t4-h0num*h0den*(t2+2.0d0*abig*t4)) - dadec=abder3*abder2*(aexp+1.0d0)/(aexp*aexp) - dh0d=dh0da*dadec*decd - dh0dt=abder1/h0arg*abder3*h0den & - & *(2.0d0*t+4.0d0*abig*t3-h0num*h0den*(2.0d0*abig*t+4.0d0*abig2*t3)) - dh0d=dh0d-x76*t*dh0dt - dh0dg=dh0dt*td -! _________________________________________________________________ -! first part xc-potential from h1 -! - dcdrs=(c3+2.0d0*c4*rs-ccrnum*ccrden*(c5+2.0d0*c6*rs+3.0d0*c7*rs2)) & - & *ccrden - dh1drs=cc0*t2*fxexp*dcdrs - dh1d=-x13*rs*dh1drs - dh1dt=2.0d0*t*cc0*(ccr-cc1)*fxexp - dh1d=dh1d-x76*t*dh1dt - dh1ds=-200.0d0*s*cc0*(ccr-cc1)*t2*fxexp - dh1d=dh1d-x43*s*dh1ds - dh1dg=dh1dt*td+dh1ds*sd -! _________________________________________________________________ -! first part of xc-potential: D(rho*exc)/D(rho) -! - dexcd=dfxd+decd+dh0d+dh1d+ecr+h0+h1 - isign=sign(1.d0,agr-delt) - byagr=0.5d0*(1+isign)/(agr+(1-isign)*delt) - rhor(ir)=dexcd -! -! gradr = D(rho*exc)/D(|grad rho|) * (grad rho) / |grad rho| -! - dexcdg=(dfxdg+dh0dg+dh1dg)*aroe*byagr - gradr(ir,1)=gradr(ir,1)*dexcdg - gradr(ir,2)=gradr(ir,2)*dexcdg - gradr(ir,3)=gradr(ir,3)*dexcdg - 100 continue - end do -! - return - end subroutine ggapwold - -!----------------------------------------------------------------------- - subroutine dftname_cp (exfact, dft) -!----------------------------------------------------------------------- -! - implicit none - integer :: exfact - character(len=20) dft -! - if (exfact == 0) then - dft = 'PZ' - elseif (exfact == 1) then - dft = 'BLYP' - elseif (exfact == 2) then - dft = 'B88' - elseif (exfact == - 5 .or. exfact == 3) then - dft = 'BP' - elseif (exfact == - 6 .or. exfact == 4) then - dft = 'PW91' - elseif (exfact == 5) then - dft = 'PBE' - elseif (exfact ==-1) then - dft = 'WIG' - elseif (exfact ==-2) then - dft = 'HL' - elseif (exfact ==-3) then - dft = 'GL' - elseif (exfact == 6) then - dft = 'TPSS' - else - call errore ('dftname','unknown exch-corr functional',exfact) - end if - - return - end subroutine dftname_cp - - -!------------------------------------------------------------------------- - subroutine expxc(nnr,nspin,rhor,exc) -!---------------------------------------------------------------------- -! -! ceperley & alder's correlation energy -! after j.p. perdew & a. zunger prb 23, 5048 (1981) -! -! rhor contains rho(r) on input, vxc(r) on output -! - USE kinds, ONLY : DP - use constants, only: pi, fpi -! - implicit none -! - integer nnr, nspin - real(DP) rhor(nnr,nspin), exc -! local variables - integer ir, iflg, isup, isdw - real(DP) roe, aroe, rs, rsl, rsq, ecca, vcca, eccp, vccp, & - zeta, onemz, zp, zm, fz, dfzdz, exc1, vxc1, vxc2 -! constants - real(DP) x76, x43, x13 - parameter(x76=7.d0/6.d0, x43=4.d0/3.d0, x13=1.d0/3.d0) - real(DP) ax - parameter (ax = -0.916330586d0) -! Perdew and Zunger parameters - real(DP) ap, bp, cp, dp0, af, bf, cf, df, & - bp1, cp1, dp1, bf1, cf1, df1 - parameter & - ( ap=0.03110d0*2.0d0, bp=-0.0480d0*2.0d0, cp=0.0020d0*2.0d0, dp0=-0.0116d0*2.0d0 & - , af=0.01555d0*2.0d0, bf=-0.0269d0*2.0d0, cf=0.0007d0*2.0d0, df=-0.0048d0*2.0d0 & - , bp1=bp-ap/3.0d0, cp1=2.0d0*cp/3.0d0, dp1=(2.0d0*dp0-cp)/3.0d0 & - , bf1=bf-af/3.0d0, cf1=2.0d0*cf/3.0d0, df1=(2.0d0*df-cf)/3.0d0 ) - real(DP) va(2), vb(2), vc(2), vd(2), vbt1(2), vbt2(2) - real(DP) a(2), b(2), c(2), d(2), g(2), b1(2), b2(2) - data va/ap ,af /, vb/bp1,bf1/, vc/cp1,cf1/, vd/dp1,df1/, & - vbt1/1.0529d0,1.3981d0/, vbt2/0.3334d0,0.2611d0/ - data a/0.0622d0,0.0311d0/, b/-0.096d0,-0.0538d0/, c/0.0040d0,0.0014d0/, & - d/-0.0232d0,-0.0096d0/, b1/1.0529d0,1.3981d0/, b2/0.3334d0,0.2611d0/, & - g/-0.2846d0,-0.1686d0/ -! - if (nspin.eq.1) then -! -! iflg=1: paramagnetic (unpolarised) results -! - iflg=1 - do ir=1,nnr - roe=rhor(ir,1) - if(roe.lt.1.0d-30) goto 10 - aroe=abs(roe) - rs= (3.d0/aroe/fpi)**x13 - if(rs.le.1.d0) then - rsl=log(rs) - ecca= a(iflg)*rsl+ b(iflg)+ c(iflg)*rs*rsl+ d(iflg)*rs - vcca=va(iflg)*rsl+vb(iflg)+vc(iflg)*rs*rsl+vd(iflg)*rs - else - rsq=sqrt(rs) - ecca=g(iflg)/(1.d0+b1(iflg)*rsq+b2(iflg)*rs) - vcca=ecca*(1.d0+x76*vbt1(iflg)*rsq+x43*vbt2(iflg)*rs)/ & - & (1.d0+ vbt1(iflg)*rsq+ vbt2(iflg)*rs) - end if - exc1 = ( ax/rs + ecca )/2.d0 - exc = exc + exc1*roe - rhor(ir,1)= ( x43*ax/rs + vcca )/2.d0 - 10 continue - end do - else - isup=1 - isdw=2 - do ir=1,nnr - roe=rhor(ir,isup)+rhor(ir,isdw) - if(roe.lt.1.0d-30) goto 20 - aroe=abs(roe) - rs= (3.d0/aroe/fpi)**x13 - zeta=abs(rhor(ir,isup)-rhor(ir,isdw))/aroe - zp = (1.d0+zeta)**x13 - onemz=max(0.d0,1.d0-zeta) - zm = onemz**x13 - fz= ((1.d0+zeta)*zp + onemz*zm - 2.d0)/ & - & (2.d0**x43 -2.d0) - dfzdz= x43*(zp - zm)/(2.d0**x43-2.d0) -! -! iflg=1: paramagnetic (unpolarised) results -! iflg=2: ferromagnetic ( polarised) results -! - if(rs.le.1.d0) then - rsl=log(rs) - ecca= a(1)*rsl+ b(1)+ c(1)*rs*rsl+ d(1)*rs - vcca=va(1)*rsl+vb(1)+vc(1)*rs*rsl+vd(1)*rs - eccp= a(2)*rsl+ b(2)+ c(2)*rs*rsl+ d(2)*rs - vccp=va(2)*rsl+vb(2)+vc(2)*rs*rsl+vd(2)*rs - else - rsq=sqrt(rs) - ecca=g(1)/(1.d0+b1(1)*rsq+b2(1)*rs) - vcca=ecca*(1.d0+x76*vbt1(1)*rsq+x43*vbt2(1)*rs)/ & - & (1.d0+ vbt1(1)*rsq+ vbt2(1)*rs) - eccp=g(2)/(1.d0+b1(2)*rsq+b2(2)*rs) - vccp=eccp*(1.d0+x76*vbt1(2)*rsq+x43*vbt2(2)*rs)/ & - & (1.d0+ vbt1(2)*rsq+ vbt2(2)*rs) - end if -! exchange part - exc1 = ax/rs*((1.d0+zeta)*zp+(1.d0-zeta)*zm)/2.d0 - vxc1 = x43*ax/rs*zp - vxc2 = x43*ax/rs*zm -! correlation part - vxc1 = vxc1 + vcca + fz*(vccp-vcca) & - & + dfzdz*(eccp-ecca)*( 1.d0-zeta) - vxc2 = vxc2 + vcca + fz*(vccp-vcca) & - & + dfzdz*(eccp-ecca)*(-1.d0-zeta) - exc = exc + (exc1 + ecca+fz*(eccp-ecca))*roe/2.d0 - rhor(ir,isup)=vxc1/2.d0 - rhor(ir,isdw)=vxc2/2.d0 - 20 continue - end do - end if - - return - end subroutine expxc - - SUBROUTINE wrap_b88( rho, grho, sx, v1x, v2x ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP) :: rho, grho, sx, v1x, v2x - REAL(DP) :: b1 = 0.0042d0 - REAL(DP) :: RHOA,RHOB,GRHOA,GRHOB, V1XA,V2XA,V1XB,V2XB - rhoa = 0.5d0 * rho - rhob = 0.5d0 * rho - grhoa = 0.25d0 * grho - grhob = 0.25d0 * grho - CALL LSD_B88(B1,RHOA,RHOB,GRHOA,GRHOB,sx,V1XA,V2XA,V1XB,V2XB) - v1x = V1XA - v2x = V2XA - END SUBROUTINE wrap_b88 - - SUBROUTINE wrap_glyp( rho, grho, sc, v1c, v2c ) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP) :: rho, grho, sc, v1c, v2c - REAL(DP) :: RA,RB,GRHOAA,GRHOAB,GRHOBB - REAL(DP) :: V1CA,V2CA,V1CB,V2CB,V2CAB - ra = rho * 0.5d0 - rb = rho * 0.5d0 - grhoaa = 0.25d0 * grho - grhobb = 0.25d0 * grho - grhoab = 0.25d0 * grho - CALL LSD_GLYP(RA,RB,GRHOAA,GRHOAB,GRHOBB,SC, & - V1CA,V2CA,V1CB,V2CB,V2CAB) - v1c = V1CA - v2c = 2.0d0*(v2ca+v2cb+v2cab*2.d0)*0.25d0 - END SUBROUTINE wrap_glyp - -! ================================================================== - SUBROUTINE LSD_B88(B1,RHOA,RHOB,GRHOA,GRHOB,sx,V1XA,V2XA,V1XB,V2XB) -! ==--------------------------------------------------------------== -! BECKE EXCHANGE: PRA 38, 3098 (1988) - USE kinds, ONLY: DP - IMPLICIT NONE - REAL(DP),PARAMETER :: OB3=1.D0/3.D0, SMALL=1.D-20 - REAL(DP) :: xs, xs2, sa2b8, br1, br2, br4, ddd, gf, dgf, shm1, dd - REAL(DP) :: dd2, grhoa, grhob, sx, b1, rhoa, rhob, v2xb, aa, a - REAL(DP) :: v1xa, v2xa, v1xb - -! ==--------------------------------------------------------------== - sx=0.0D0 - V1XA=0.0D0 - V2XA=0.0D0 - V1XB=0.0D0 - V2XB=0.0D0 - IF(ABS(RHOA).GT.SMALL) THEN - AA = GRHOA - A = SQRT(AA) - BR1 = RHOA**OB3 - BR2 = BR1*BR1 - BR4 = BR2*BR2 - XS = A/BR4 - XS2 = XS*XS - SA2B8 = SQRT(1.0D0+XS2) - SHM1 = LOG(XS+SA2B8) - DD = 1.0D0 + 6.0D0*B1*XS*SHM1 - DD2 = DD*DD - DDD = 6.0D0*B1*(SHM1+XS/SA2B8) - GF = -B1*XS2/DD - DGF = (-2.0D0*B1*XS*DD + B1*XS2*DDD)/DD2 - sx = GF*BR4 - V1XA = 4.d0/3.d0*BR1*(GF-XS*DGF) - V2XA = DGF/A - ENDIF - IF(ABS(RHOB).GT.SMALL) THEN - AA = GRHOB - A = SQRT(AA) - BR1 = RHOB**OB3 - BR2 = BR1*BR1 - BR4 = BR2*BR2 - XS = A/BR4 - XS2 = XS*XS - SA2B8 = SQRT(1.0D0+XS2) - SHM1 = LOG(XS+SA2B8) - DD = 1.0D0 + 6.0D0*B1*XS*SHM1 - DD2 = DD*DD - DDD = 6.0D0*B1*(SHM1+XS/SA2B8) - GF = -B1*XS2/DD - DGF = (-2.0D0*B1*XS*DD + B1*XS2*DDD)/DD2 - sx = sx+GF*BR4 - V1XB = 4.d0/3.d0*BR1*(GF-XS*DGF) - V2XB = DGF/A - ENDIF -! ==--------------------------------------------------------------== - RETURN - END SUBROUTINE LSD_B88 diff --git a/quantum_espresso/kcp/flib/recips.f90 b/quantum_espresso/kcp/flib/recips.f90 deleted file mode 100644 index ccecd2c0f..000000000 --- a/quantum_espresso/kcp/flib/recips.f90 +++ /dev/null @@ -1,77 +0,0 @@ -! -! Copyright (C) 2001 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!--------------------------------------------------------------------- - -subroutine recips (a1, a2, a3, b1, b2, b3) - !--------------------------------------------------------------------- - ! - ! This routine generates the reciprocal lattice vectors b1,b2,b3 - ! given the real space vectors a1,a2,a3. The b's are units of 2 pi/a. - ! - ! first the input variables - ! - use kinds, ONLY: DP - implicit none - real(DP) :: a1 (3), a2 (3), a3 (3), b1 (3), b2 (3), b3 (3) - ! input: first direct lattice vector - ! input: second direct lattice vector - ! input: third direct lattice vector - ! output: first reciprocal lattice vector - ! output: second reciprocal lattice vector - ! output: third reciprocal lattice vector - ! - ! then the local variables - ! - real(DP) :: den, s - ! the denominator - ! the sign of the permutations - integer :: iperm, i, j, k, l, ipol - ! counter on the permutations - !\ - ! Auxiliary variables - !/ - ! - ! Counter on the polarizations - ! - ! first we compute the denominator - ! - den = 0 - i = 1 - j = 2 - k = 3 - s = 1.d0 -100 do iperm = 1, 3 - den = den + s * a1 (i) * a2 (j) * a3 (k) - l = i - i = j - j = k - k = l - enddo - i = 2 - j = 1 - k = 3 - s = - s - if (s.lt.0.d0) goto 100 - ! - ! here we compute the reciprocal vectors - ! - i = 1 - j = 2 - k = 3 - do ipol = 1, 3 - b1 (ipol) = (a2 (j) * a3 (k) - a2 (k) * a3 (j) ) / den - b2 (ipol) = (a3 (j) * a1 (k) - a3 (k) * a1 (j) ) / den - b3 (ipol) = (a1 (j) * a2 (k) - a1 (k) * a2 (j) ) / den - l = i - i = j - j = k - k = l - enddo - return -end subroutine recips diff --git a/quantum_espresso/kcp/flib/remove_tot_torque.f90 b/quantum_espresso/kcp/flib/remove_tot_torque.f90 deleted file mode 100644 index 27642c1b5..000000000 --- a/quantum_espresso/kcp/flib/remove_tot_torque.f90 +++ /dev/null @@ -1,120 +0,0 @@ -! -! Copyright (C) 2001-2006 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -#include "f_defs.h" -! -!---------------------------------------------------------------------------- -SUBROUTINE remove_tot_torque( nat, tau, mass, force ) - !---------------------------------------------------------------------------- - ! - ! ... This routine sets to zero the total torque associated to the internal - ! ... forces acting on the atoms by correcting the force vector. - ! - ! ... The algorithm is based on the following expressions ( F' is the - ! ... troqueless force ) : - ! _ - ! _ 1 \ __ _ __ _ _ - ! ... m = --- /_ dR_i /\ F_i , dR_i = ( R_i - R_cm ) , - ! N i - ! - ! __ _ 1 _ __ - ! ... F'_i = F_i - -------- m /\ dR_i - ! |dR_i|^2 - ! - ! - ! ... written by carlo sbraccia (2006) - ! - USE kinds, ONLY : DP - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: nat - REAL(DP), INTENT(IN) :: tau(3,nat) - REAL(DP), INTENT(IN) :: mass(nat) - REAL(DP), INTENT(INOUT) :: force(3,nat) - ! - INTEGER :: ia - REAL(DP) :: m(3), mo(3), tauref(3), delta(3), sumf(3) - REAL(DP) :: nrmsq - ! - ! - tauref(:) = 0.D0 - ! - DO ia = 1, nat - ! - tauref(:) = tauref(:) + tau(:,ia)*mass(ia) - ! - END DO - ! - tauref(:) = tauref(:) / SUM( mass(:) ) - ! - m(:) = 0.D0 - ! - DO ia = 1, nat - ! - delta(:) = tau(:,ia) - tauref(:) - ! - m(:) = m(:) + ext_prod( delta(:), force(:,ia) ) - ! - END DO - ! - mo(:) = m(:) - ! - m(:) = m(:) / DBLE( nat ) - ! - sumf(:) = 0.D0 - ! - DO ia = 1, nat - ! - delta(:) = tau(:,ia) - tauref(:) - ! - nrmsq = delta(1)**2 + delta(2)**2 + delta(3)**2 - ! - force(:,ia) = force(:,ia) - ext_prod( m(:), delta(:) ) / nrmsq - ! - sumf(:) = sumf(:) + force(:,ia) - ! - END DO - ! - DO ia = 1, nat - ! - force(:,ia) = force(:,ia) - sumf(:) / DBLE( nat ) - ! - END DO - ! - m(:) = 0.D0 - ! - DO ia = 1, nat - ! - delta(:) = tau(:,ia) - tauref(:) - ! - m(:) = m(:) + ext_prod( delta(:), force(:,ia) ) - ! - END DO - ! - IF ( m(1)**2+m(2)**2+m(3)**2 > mo(1)**2+mo(2)**2+mo(3)**2 ) & - CALL errore( 'remove_tot_torque', & - 'total torque has not been properly removed', 1 ) - ! - RETURN - ! - CONTAINS - ! - !------------------------------------------------------------------------ - FUNCTION ext_prod( a, b ) - !------------------------------------------------------------------------ - ! - REAL(DP), INTENT(IN) :: a(3), b(3) - REAL(DP) :: ext_prod(3) - ! - ext_prod(1) = a(2)*b(3) - a(3)*b(2) - ext_prod(2) = a(3)*b(1) - a(1)*b(3) - ext_prod(3) = a(1)*b(2) - a(2)*b(1) - ! - END FUNCTION ext_prod - ! -END SUBROUTINE remove_tot_torque diff --git a/quantum_espresso/kcp/flib/simpsn.f90 b/quantum_espresso/kcp/flib/simpsn.f90 deleted file mode 100644 index 29014a894..000000000 --- a/quantum_espresso/kcp/flib/simpsn.f90 +++ /dev/null @@ -1,134 +0,0 @@ -! -! Copyright (C) 2001 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!----------------------------------------------------------------------- -subroutine simpson (mesh, func, rab, asum) - !----------------------------------------------------------------------- - ! - ! simpson's rule integration. On input: - ! mesh = mhe number of grid points (should be odd) - ! func(i)= function to be integrated - ! rab(i) = r(i) * dr(i)/di * di - ! For the logarithmic grid not including r=0 : - ! r(i) = r_0*exp((i-1)*dx) ==> rab(i)=r(i)*dx - ! For the logarithmic grid including r=0 : - ! r(i) = a(exp((i-1)*dx)-1) ==> rab(i)=(r(i)+a)*dx - ! Output in asum = \sum_i c_i f(i)*rab(i) = \int_0^\infty f(r) dr - ! where c_i are alternativaly 2/3, 4/3 except c_1 = c_mesh = 1/3 - ! - use kinds, ONLY: DP - implicit none - integer, intent(in) :: mesh - real(DP), intent(in) :: rab (mesh), func (mesh) - real(DP), intent(out):: asum - ! - real(DP) :: f1, f2, f3, r12 - integer :: i - ! - ! routine assumes that mesh is an odd number so run check - ! if ( mesh+1 - ( (mesh+1) / 2 ) * 2 .ne. 1 ) then - ! write(*,*) '***error in subroutine radlg' - ! write(*,*) 'routine assumes mesh is odd but mesh =',mesh+1 - ! stop - ! endif - asum = 0.0d0 - r12 = 1.0d0 / 12.0d0 - f3 = func (1) * rab (1) * r12 - - do i = 2, mesh - 1, 2 - f1 = f3 - f2 = func (i) * rab (i) * r12 - f3 = func (i + 1) * rab (i + 1) * r12 - asum = asum + 4.0d0 * f1 + 16.0d0 * f2 + 4.0d0 * f3 - enddo - - return -end subroutine simpson - -!=----------------------------------------------------------------------- -subroutine simpson_cp90( mesh, func, rab, asum ) - !----------------------------------------------------------------------- - ! - ! This routine computes the integral of a function defined on a - ! logaritmic mesh, by using the open simpson formula given on - ! pag. 109 of Numerical Recipes. In principle it is used to - ! perform integrals from zero to infinity. The first point of - ! the function should be the closest to zero but not the value - ! in zero. The formula used here automatically includes the - ! contribution from the zero point and no correction is required. - ! - ! Input as "simpson". At least 8 integrating points are required. - ! - ! last revised 12 May 1995 by Andrea Dal Corso - ! - use kinds, ONLY: DP - implicit none - integer, intent(in) :: mesh - real(DP), intent(in) :: rab (mesh), func (mesh) - real(DP), intent(out):: asum - ! - real(DP) :: c(4) - integer ::i - ! - if ( mesh < 8 ) call errore ('simpson_cp90','few mesh points',8) - - c(1) = 109.0d0 / 48.d0 - c(2) = -5.d0 / 48.d0 - c(3) = 63.d0 / 48.d0 - c(4) = 49.d0 / 48.d0 - - asum = ( func(1)*rab(1) + func(mesh )*rab(mesh ) )*c(1) & - + ( func(2)*rab(2) + func(mesh-1)*rab(mesh-1) )*c(2) & - + ( func(3)*rab(3) + func(mesh-2)*rab(mesh-2) )*c(3) & - + ( func(4)*rab(4) + func(mesh-3)*rab(mesh-3) )*c(4) - do i=5,mesh-4 - asum = asum + func(i)*rab(i) - end do - - return -end subroutine simpson_cp90 -! -!----------------------------------------------------------------------- -SUBROUTINE herman_skillman_int(mesh,func,rab,asum) -!----------------------------------------------------------------------- - ! simpson rule integration for herman skillman mesh (obsolescent) - ! Input as in "simpson". BEWARE: "func" is overwritten!!! - ! - use kinds, ONLY: DP - IMPLICIT NONE - integer, intent(in) :: mesh - real(DP), intent(in) :: rab (mesh) - real(DP), intent(inout) :: func (mesh) - real(DP), intent(out):: asum - ! - INTEGER :: i, j, k, i1, nblock - REAL(DP) :: a1, a2e, a2o, a2es - ! - a1=0.0d0 - a2e=0.0d0 - asum=0.0d0 - nblock=mesh/40 - i=1 - func(1)=0.0d0 - DO j=1,nblock - DO k=1,20 - i=i+2 - i1=i-1 - a2es=a2e - a2o=func(i1)/12.0d0 - a2e=func(i)/12.0d0 - a1=a1+5.0d0*a2es+8.0d0*a2o-a2e - func(i1)=asum+a1*rab(i1) - a1=a1-a2es+8.0d0*a2o+5.0d0*a2e - func(i)=asum+a1*rab(i) - END DO - asum=func(i) - a1=0.0d0 - END DO - ! - RETURN -END SUBROUTINE herman_skillman_int diff --git a/quantum_espresso/kcp/flib/sort.f90 b/quantum_espresso/kcp/flib/sort.f90 deleted file mode 100644 index 25a427da3..000000000 --- a/quantum_espresso/kcp/flib/sort.f90 +++ /dev/null @@ -1,997 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - - logical function cpgt(a,b) - USE kinds - USE constants, only: eps8 - implicit none - REAL(DP) :: a, b, r - r = abs(a-b) - if( r .lt. eps8 ) then - cpgt = .false. - else - cpgt = ( a .gt. b ) - end if - end function cpgt - - logical function cplt(a,b) - USE kinds - USE constants, only: eps8 - implicit none - REAL(DP) :: a, b, r - r = abs(a-b) - if( r .lt. eps8 ) then - cplt = .false. - else - cplt = ( a .lt. b ) - end if - end function cplt -! -! Copyright (C) 2001 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!--------------------------------------------------------------------- -subroutine hpsort_eps (n, ra, ind, eps) - !--------------------------------------------------------------------- - ! sort an array ra(1:n) into ascending order using heapsort algorithm, - ! and considering two elements being equal if their values differ - ! for less than "eps". - ! n is input, ra is replaced on output by its sorted rearrangement. - ! create an index table (ind) by making an exchange in the index array - ! whenever an exchange is made on the sorted data array (ra). - ! in case of equal values in the data array (ra) the values in the - ! index array (ind) are used to order the entries. - ! if on input ind(1) = 0 then indices are initialized in the routine, - ! if on input ind(1) != 0 then indices are assumed to have been - ! initialized before entering the routine and these - ! indices are carried around during the sorting process - ! - ! no work space needed ! - ! free us from machine-dependent sorting-routines ! - ! - ! adapted from Numerical Recipes pg. 329 (new edition) - ! - use kinds - implicit none - !-input/output variables - integer, intent(in) :: n - integer, intent(inout) :: ind (*) - real(DP), intent(inout) :: ra (*) - real(DP), intent(in) :: eps - !-local variables - integer :: i, ir, j, l, iind - real(DP) :: rra - ! initialize index array - if (ind (1) .eq.0) then - do i = 1, n - ind (i) = i - enddo - endif - ! nothing to order - if (n.lt.2) return - ! initialize indices for hiring and retirement-promotion phase - l = n / 2 + 1 - - ir = n - - sorting: do - - ! still in hiring phase - if ( l .gt. 1 ) then - l = l - 1 - rra = ra (l) - iind = ind (l) - ! in retirement-promotion phase. - else - ! clear a space at the end of the array - rra = ra (ir) - ! - iind = ind (ir) - ! retire the top of the heap into it - ra (ir) = ra (1) - ! - ind (ir) = ind (1) - ! decrease the size of the corporation - ir = ir - 1 - ! done with the last promotion - if ( ir .eq. 1 ) then - ! the least competent worker at all ! - ra (1) = rra - ! - ind (1) = iind - exit sorting - endif - endif - ! wheter in hiring or promotion phase, we - i = l - ! set up to place rra in its proper level - j = l + l - ! - do while ( j .le. ir ) - if ( j .lt. ir ) then - ! compare to better underling - if ( hslt( ra (j), ra (j + 1) ) ) then - j = j + 1 - else if ( .not. hslt( ra (j+1), ra (j) ) ) then - ! this means ra(j) == ra(j+1) within tolerance - if (ind (j) .lt.ind (j + 1) ) j = j + 1 - endif - endif - ! demote rra - if ( hslt( rra, ra (j) ) ) then - ra (i) = ra (j) - ind (i) = ind (j) - i = j - j = j + j - else if ( .not. hslt ( ra(j) , rra ) ) then - !this means rra == ra(j) within tolerance - ! demote rra - if (iind.lt.ind (j) ) then - ra (i) = ra (j) - ind (i) = ind (j) - i = j - j = j + j - else - ! set j to terminate do-while loop - j = ir + 1 - endif - ! this is the right place for rra - else - ! set j to terminate do-while loop - j = ir + 1 - endif - enddo - ra (i) = rra - ind (i) = iind - - end do sorting - -contains - - ! internal function - ! compare two real number and return the result - - logical function hslt( a, b ) - REAL(DP) :: a, b - if( abs(a-b) < eps ) then - hslt = .false. - else - hslt = ( a < b ) - end if - end function hslt - - ! -end subroutine hpsort_eps - -! -! Copyright (C) 2001 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!--------------------------------------------------------------------- -subroutine hpsort (n, ra, ind) - !--------------------------------------------------------------------- - ! sort an array ra(1:n) into ascending order using heapsort algorithm. - ! n is input, ra is replaced on output by its sorted rearrangement. - ! create an index table (ind) by making an exchange in the index array - ! whenever an exchange is made on the sorted data array (ra). - ! in case of equal values in the data array (ra) the values in the - ! index array (ind) are used to order the entries. - ! if on input ind(1) = 0 then indices are initialized in the routine, - ! if on input ind(1) != 0 then indices are assumed to have been - ! initialized before entering the routine and these - ! indices are carried around during the sorting process - ! - ! no work space needed ! - ! free us from machine-dependent sorting-routines ! - ! - ! adapted from Numerical Recipes pg. 329 (new edition) - ! - use kinds - implicit none - !-input/output variables - integer :: n - integer :: ind (*) - real(DP) :: ra (*) - !-local variables - integer :: i, ir, j, l, iind - real(DP) :: rra - ! initialize index array - if (ind (1) .eq.0) then - do i = 1, n - ind (i) = i - enddo - endif - ! nothing to order - if (n.lt.2) return - ! initialize indices for hiring and retirement-promotion phase - l = n / 2 + 1 - ir = n -10 continue - ! still in hiring phase - if (l.gt.1) then - l = l - 1 - rra = ra (l) - iind = ind (l) - ! in retirement-promotion phase. - else - ! clear a space at the end of the array - rra = ra (ir) - ! - iind = ind (ir) - ! retire the top of the heap into it - ra (ir) = ra (1) - ! - ind (ir) = ind (1) - ! decrease the size of the corporation - ir = ir - 1 - ! done with the last promotion - if (ir.eq.1) then - ! the least competent worker at all ! - ra (1) = rra - ! - ind (1) = iind - return - endif - endif - ! wheter in hiring or promotion phase, we - i = l - ! set up to place rra in its proper level - j = l + l - ! - do while (j.le.ir) - if (j.lt.ir) then - ! compare to better underling - if (ra (j) .lt.ra (j + 1) ) then - j = j + 1 - elseif (ra (j) .eq.ra (j + 1) ) then - if (ind (j) .lt.ind (j + 1) ) j = j + 1 - endif - endif - ! demote rra - if (rra.lt.ra (j) ) then - ra (i) = ra (j) - ind (i) = ind (j) - i = j - j = j + j - elseif (rra.eq.ra (j) ) then - ! demote rra - if (iind.lt.ind (j) ) then - ra (i) = ra (j) - ind (i) = ind (j) - i = j - j = j + j - else - ! set j to terminate do-while loop - j = ir + 1 - endif - ! this is the right place for rra - else - ! set j to terminate do-while loop - j = ir + 1 - endif - enddo - ra (i) = rra - ind (i) = iind - goto 10 - ! -end subroutine hpsort - - -! -! Copyright (C) 2001 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!--------------------------------------------------------------------- -subroutine ihpsort (n, ia, ind) - !--------------------------------------------------------------------- - ! sort an integer array ia(1:n) into ascending order using heapsort algorithm. - ! n is input, ia is replaced on output by its sorted rearrangement. - ! create an index table (ind) by making an exchange in the index array - ! whenever an exchange is made on the sorted data array (ia). - ! in case of equal values in the data array (ia) the values in the - ! index array (ind) are used to order the entries. - ! if on input ind(1) = 0 then indices are initialized in the routine, - ! if on input ind(1) != 0 then indices are assumed to have been - ! initialized before entering the routine and these - ! indices are carried around during the sorting process - ! - ! no work space needed ! - ! free us from machine-dependent sorting-routines ! - ! - ! adapted from Numerical Recipes pg. 329 (new edition) - ! - implicit none - !-input/output variables - integer :: n - integer :: ind (*) - integer :: ia (*) - !-local variables - integer :: i, ir, j, l, iind - integer :: iia - ! initialize index array - if (ind (1) .eq.0) then - do i = 1, n - ind (i) = i - enddo - endif - ! nothing to order - if (n.lt.2) return - ! initialize indices for hiring and retirement-promotion phase - l = n / 2 + 1 - ir = n -10 continue - ! still in hiring phase - if (l.gt.1) then - l = l - 1 - iia = ia (l) - iind = ind (l) - ! in retirement-promotion phase. - else - ! clear a space at the end of the array - iia = ia (ir) - ! - iind = ind (ir) - ! retire the top of the heap into it - ia (ir) = ia (1) - ! - ind (ir) = ind (1) - ! decrease the size of the corporation - ir = ir - 1 - ! done with the last promotion - if (ir.eq.1) then - ! the least competent worker at all ! - ia (1) = iia - ! - ind (1) = iind - return - endif - endif - ! wheter in hiring or promotion phase, we - i = l - ! set up to place iia in its proper level - j = l + l - ! - do while (j.le.ir) - if (j.lt.ir) then - ! compare to better underling - if (ia (j) .lt.ia (j + 1) ) then - j = j + 1 - elseif (ia (j) .eq.ia (j + 1) ) then - if (ind (j) .lt.ind (j + 1) ) j = j + 1 - endif - endif - ! demote iia - if (iia.lt.ia (j) ) then - ia (i) = ia (j) - ind (i) = ind (j) - i = j - j = j + j - elseif (iia.eq.ia (j) ) then - ! demote iia - if (iind.lt.ind (j) ) then - ia (i) = ia (j) - ind (i) = ind (j) - i = j - j = j + j - else - ! set j to terminate do-while loop - j = ir + 1 - endif - ! this is the right place for iia - else - ! set j to terminate do-while loop - j = ir + 1 - endif - enddo - ia (i) = iia - ind (i) = iind - goto 10 - ! -end subroutine ihpsort - -! ================================================================== - SUBROUTINE gqsort(COUNT,N,IDX) -! ==--------------------------------------------------------------== -! == Sorting routine for the reciprocal space vectors (g) == -! == Warning, this is not an exact SORT!! This routine has been == -! == designed to give always the same order for the G vectors of == -! == a given shell, independently of the processor == -! == THE WORK-SPACE 'MARK' OF LENGTH 50 PERMITS UP TO 2**(50/2) == -! ==--------------------------------------------------------------== - USE kinds - - INTEGER :: N, MARK, I, M, LA, IS, IF, MLOOP, IFKA, IS1, J, IT, & - IY, INTEST, K, IFK, K1, IP, LNGTH - - logical :: cpgt,cplt - REAL(DP) :: COUNT(*),AV,X - - INTEGER :: IDX(*) - DIMENSION :: MARK(50) -! ==--------------------------------------------------------------== -! == SET INDEX ARRAY TO ORIGINAL ORDER . == -! ==--------------------------------------------------------------== - DO I=1,N - IDX(I)=I - ENDDO -! ==--------------------------------------------------------------== -! == CHECK THAT A TRIVIAL CASE HAS NOT BEEN ENTERED. == -! ==--------------------------------------------------------------== - IF(N.EQ.1)GOTO 200 - IF(N.GE.1)GOTO 30 - GOTO 200 -! ==--------------------------------------------------------------== -! == 'M' IS THE LENGTH OF SEGMENT WHICH IS SHORT ENOUGH TO ENTER == -! == THE FINAL SORTING ROUTINE. IT MAY BE EASILY CHANGED. == -! ==--------------------------------------------------------------== - 30 M=12 -! ==--------------------------------------------------------------== -! == SET UP INITIAL VALUES. == -! ==--------------------------------------------------------------== - LA=2 - IS=1 - IF=N - DO 190 MLOOP=1,N -! ==--------------------------------------------------------------== -! == IF SEGMENT IS SHORT ENOUGH SORT WITH FINAL SORTING ROUTINE. == -! ==--------------------------------------------------------------== - IFKA=IF-IS - IF((IFKA+1).GT.M)GOTO 70 -! ==--------------------------------------------------------------== -! == FINAL SORTING ( A SIMPLE BUBBLE SORT ) == -! ==--------------------------------------------------------------== - IS1=IS+1 - DO 60 J=IS1,IF - I=J - 40 IF(cplt(COUNT(I-1),COUNT(I)) )GOTO 60 - IF(cpgt(COUNT(I-1),COUNT(I)) )GOTO 50 - IF(IDX(I-1).LT.IDX(I))GOTO 60 - 50 AV=COUNT(I-1) - COUNT(I-1)=COUNT(I) - COUNT(I)=AV - IT=IDX(I-1) - IDX(I-1)=IDX(I) - IDX(I)=IT - I=I-1 - IF(I.GT.IS)GOTO 40 - 60 CONTINUE - LA=LA-2 - GOTO 170 -! ==--------------------------------------------------------------== -! == ******* QUICKSORT ******** == -! == SELECT THE NUMBER IN THE CENTRAL POSITION IN THE SEGMENT AS == -! == THE TEST NUMBER.REPLACE IT WITH THE NUMBER FROM THE SEGMENT'S== -! == HIGHEST ADDRESS. == -! ==--------------------------------------------------------------== - 70 IY=(IS+IF)/2 - X=COUNT(IY) - INTEST=IDX(IY) - COUNT(IY)=COUNT(IF) - IDX(IY)=IDX(IF) -! ==--------------------------------------------------------------== -! == THE MARKERS 'I' AND 'IFK' ARE USED FOR THE BEGINNING AND END == -! == OF THE SECTION NOT SO FAR TESTED AGAINST THE PRESENT VALUE == -! == OF X . == -! ==--------------------------------------------------------------== - K=1 - IFK=IF -! ==--------------------------------------------------------------== -! == WE ALTERNATE BETWEEN THE OUTER LOOP THAT INCREASES I AND THE == -! == INNER LOOP THAT REDUCES IFK, MOVING NUMBERS AND INDICES AS == -! == NECESSARY, UNTIL THEY MEET . == -! ==--------------------------------------------------------------== - DO 110 I=IS,IF - IF(cpgt(X,COUNT(I)))GOTO 110 - IF(cplt(X,COUNT(I)))GOTO 80 - IF(INTEST.GT.IDX(I))GOTO 110 - 80 IF(I.GE.IFK)GOTO 120 - COUNT(IFK)=COUNT(I) - IDX(IFK)=IDX(I) - K1=K - DO 100 K=K1,IFKA - IFK=IF-K - IF(cpgt(COUNT(IFK),X))GOTO 100 - IF(cplt(COUNT(IFK),X))GOTO 90 - IF(INTEST.LE.IDX(IFK))GOTO 100 - 90 IF(I.GE.IFK)GOTO 130 - COUNT(I)=COUNT(IFK) - IDX(I)=IDX(IFK) - GO TO 110 - 100 CONTINUE - GOTO 120 - 110 CONTINUE -! ==--------------------------------------------------------------== -! == RETURN THE TEST NUMBER TO THE POSITION MARKED BY THE MARKER == -! == WHICH DID NOT MOVE LAST. IT DIVIDES THE INITIAL SEGMENT INTO == -! == 2 PARTS. ANY ELEMENT IN THE FIRST PART IS LESS THAN OR EQUAL == -! == TO ANY ELEMENT IN THE SECOND PART, AND THEY MAY NOW BE SORTED== -! == INDEPENDENTLY . == -! ==--------------------------------------------------------------== - 120 COUNT(IFK)=X - IDX(IFK)=INTEST - IP=IFK - GOTO 140 - 130 COUNT(I)=X - IDX(I)=INTEST - IP=I -! ==--------------------------------------------------------------== -! == STORE THE LONGER SUBDIVISION IN WORKSPACE. == -! ==--------------------------------------------------------------== - 140 IF((IP-IS).GT.(IF-IP))GOTO 150 - MARK(LA)=IF - MARK(LA-1)=IP+1 - IF=IP-1 - GOTO 160 - 150 MARK(LA)=IP-1 - MARK(LA-1)=IS - IS=IP+1 -! ==--------------------------------------------------------------== -! == FIND THE LENGTH OF THE SHORTER SUBDIVISION. == -! ==--------------------------------------------------------------== - 160 LNGTH=IF-IS - IF(LNGTH.LE.0)GOTO 180 -! ==--------------------------------------------------------------== -! == IF IT CONTAINS MORE THAN ONE ELEMENT SUPPLY IT WITH WORKSPACE== -! ==--------------------------------------------------------------== - LA=LA+2 - GOTO 190 - 170 IF(LA.LE.0)GOTO 200 -! ==--------------------------------------------------------------== -! == OBTAIN THE ADDRESS OF THE SHORTEST SEGMENT AWAITING QUICKSORT== -! ==--------------------------------------------------------------== - 180 IF=MARK(LA) - IS=MARK(LA-1) - 190 CONTINUE -! ==--------------------------------------------------------------== - 200 RETURN - END SUBROUTINE gqsort -! ================================================================== - - -! ================================================================== - SUBROUTINE iqsort(COUNT,N,IDX) -! ==--------------------------------------------------------------== -! == same as rqsort but for array of integers == -! ==--------------------------------------------------------------== - USE kinds - - INTEGER :: N, I, M, LA, IS, IF, MLOOP, IFKA, IS1, J, IT, & - IY, INTEST, K, IFK, K1, IP, LNGTH - - - INTEGER :: COUNT(*),AV,X - INTEGER :: IDX(*),MARK(50) -! ==--------------------------------------------------------------== -! == SET INDEX ARRAY TO ORIGINAL ORDER . == -! ==--------------------------------------------------------------== - DO I=1,N - IDX(I)=I - ENDDO -! ==--------------------------------------------------------------== -! == CHECK THAT A TRIVIAL CASE HAS NOT BEEN ENTERED. == -! ==--------------------------------------------------------------== - IF(N.EQ.1)GOTO 200 - IF(N.GE.1)GOTO 30 - GOTO 200 -! ==--------------------------------------------------------------== -! == 'M' IS THE LENGTH OF SEGMENT WHICH IS SHORT ENOUGH TO ENTER == -! == THE FINAL SORTING ROUTINE. IT MAY BE EASILY CHANGED. == -! ==--------------------------------------------------------------== - 30 M=12 -! ==--------------------------------------------------------------== -! == SET UP INITIAL VALUES. == -! ==--------------------------------------------------------------== - LA=2 - IS=1 - IF=N - DO 190 MLOOP=1,N -! ==--------------------------------------------------------------== -! == IF SEGMENT IS SHORT ENOUGH SORT WITH FINAL SORTING ROUTINE. == -! ==--------------------------------------------------------------== - IFKA=IF-IS - IF((IFKA+1).GT.M)GOTO 70 -! ==--------------------------------------------------------------== -! == FINAL SORTING ( A SIMPLE BUBBLE SORT ) == -! ==--------------------------------------------------------------== - IS1=IS+1 - DO 60 J=IS1,IF - I=J - 40 IF((COUNT(I-1).LT.COUNT(I)) )GOTO 60 - IF((COUNT(I-1).GT.COUNT(I)) )GOTO 50 - IF(IDX(I-1).LT.IDX(I))GOTO 60 - 50 AV=COUNT(I-1) - COUNT(I-1)=COUNT(I) - COUNT(I)=AV - IT=IDX(I-1) - IDX(I-1)=IDX(I) - IDX(I)=IT - I=I-1 - IF(I.GT.IS)GOTO 40 - 60 CONTINUE - LA=LA-2 - GOTO 170 -! ==--------------------------------------------------------------== -! == ******* QUICKSORT ******** == -! == SELECT THE NUMBER IN THE CENTRAL POSITION IN THE SEGMENT AS == -! == THE TEST NUMBER.REPLACE IT WITH THE NUMBER FROM THE SEGMENT'S== -! == HIGHEST ADDRESS. == -! ==--------------------------------------------------------------== - 70 IY=(IS+IF)/2 - X=COUNT(IY) - INTEST=IDX(IY) - COUNT(IY)=COUNT(IF) - IDX(IY)=IDX(IF) -! ==--------------------------------------------------------------== -! == THE MARKERS 'I' AND 'IFK' ARE USED FOR THE BEGINNING AND END == -! == OF THE SECTION NOT SO FAR TESTED AGAINST THE PRESENT VALUE == -! == OF X . == -! ==--------------------------------------------------------------== - K=1 - IFK=IF -! ==--------------------------------------------------------------== -! == WE ALTERNATE BETWEEN THE OUTER LOOP THAT INCREASES I AND THE == -! == INNER LOOP THAT REDUCES IFK, MOVING NUMBERS AND INDICES AS == -! == NECESSARY, UNTIL THEY MEET . == -! ==--------------------------------------------------------------== - DO 110 I=IS,IF - IF((X.GT.COUNT(I)))GOTO 110 - IF((X.LT.COUNT(I)))GOTO 80 - IF(INTEST.GT.IDX(I))GOTO 110 - 80 IF(I.GE.IFK)GOTO 120 - COUNT(IFK)=COUNT(I) - IDX(IFK)=IDX(I) - K1=K - DO 100 K=K1,IFKA - IFK=IF-K - IF((COUNT(IFK).GT.X))GOTO 100 - IF((COUNT(IFK).LT.X))GOTO 90 - IF(INTEST.LE.IDX(IFK))GOTO 100 - 90 IF(I.GE.IFK)GOTO 130 - COUNT(I)=COUNT(IFK) - IDX(I)=IDX(IFK) - GO TO 110 - 100 CONTINUE - GOTO 120 - 110 CONTINUE -! ==--------------------------------------------------------------== -! == RETURN THE TEST NUMBER TO THE POSITION MARKED BY THE MARKER == -! == WHICH DID NOT MOVE LAST. IT DIVIDES THE INITIAL SEGMENT INTO == -! == 2 PARTS. ANY ELEMENT IN THE FIRST PART IS LESS THAN OR EQUAL == -! == TO ANY ELEMENT IN THE SECOND PART, AND THEY MAY NOW BE SORTED== -! == INDEPENDENTLY . == -! ==--------------------------------------------------------------== - 120 COUNT(IFK)=X - IDX(IFK)=INTEST - IP=IFK - GOTO 140 - 130 COUNT(I)=X - IDX(I)=INTEST - IP=I -! ==--------------------------------------------------------------== -! == STORE THE LONGER SUBDIVISION IN WORKSPACE. == -! ==--------------------------------------------------------------== - 140 IF((IP-IS).GT.(IF-IP))GOTO 150 - MARK(LA)=IF - MARK(LA-1)=IP+1 - IF=IP-1 - GOTO 160 - 150 MARK(LA)=IP-1 - MARK(LA-1)=IS - IS=IP+1 -! ==--------------------------------------------------------------== -! == FIND THE LENGTH OF THE SHORTER SUBDIVISION. == -! ==--------------------------------------------------------------== - 160 LNGTH=IF-IS - IF(LNGTH.LE.0)GOTO 180 -! ==--------------------------------------------------------------== -! == IF IT CONTAINS MORE THAN ONE ELEMENT SUPPLY IT WITH WORKSPACE== -! ==--------------------------------------------------------------== - LA=LA+2 - GOTO 190 - 170 IF(LA.LE.0)GOTO 200 -! ==--------------------------------------------------------------== -! == OBTAIN THE ADDRESS OF THE SHORTEST SEGMENT AWAITING QUICKSORT== -! ==--------------------------------------------------------------== - 180 IF=MARK(LA) - IS=MARK(LA-1) - 190 CONTINUE -! ==--------------------------------------------------------------== - 200 RETURN - END SUBROUTINE iqsort -! ================================================================== - - - -! ================================================================== - SUBROUTINE rqsort(COUNT,N,IDX) -! ==--------------------------------------------------------------== -! == Sorting routine for the double precison arrayis == -! == THE WORK-SPACE 'MARK' OF LENGTH 50 PERMITS UP TO 2**(50/2) == -! ==--------------------------------------------------------------== - USE kinds - - INTEGER :: N, I, M, LA, IS, IF, MLOOP, IFKA, IS1, J, IT, & - IY, INTEST, K, IFK, K1, IP, LNGTH - - REAL(DP) :: COUNT(*),AV,X - INTEGER :: IDX(*), MARK(50) -! ==--------------------------------------------------------------== -! == SET INDEX ARRAY TO ORIGINAL ORDER . == -! ==--------------------------------------------------------------== - DO I=1,N - IDX(I)=I - ENDDO -! ==--------------------------------------------------------------== -! == CHECK THAT A TRIVIAL CASE HAS NOT BEEN ENTERED. == -! ==--------------------------------------------------------------== - IF(N.EQ.1)GOTO 200 - IF(N.GE.1)GOTO 30 - GOTO 200 -! ==--------------------------------------------------------------== -! == 'M' IS THE LENGTH OF SEGMENT WHICH IS SHORT ENOUGH TO ENTER == -! == THE FINAL SORTING ROUTINE. IT MAY BE EASILY CHANGED. == -! ==--------------------------------------------------------------== - 30 M=12 -! ==--------------------------------------------------------------== -! == SET UP INITIAL VALUES. == -! ==--------------------------------------------------------------== - LA=2 - IS=1 - IF=N - DO 190 MLOOP=1,N -! ==--------------------------------------------------------------== -! == IF SEGMENT IS SHORT ENOUGH SORT WITH FINAL SORTING ROUTINE. == -! ==--------------------------------------------------------------== - IFKA=IF-IS - IF((IFKA+1).GT.M)GOTO 70 -! ==--------------------------------------------------------------== -! == FINAL SORTING ( A SIMPLE BUBBLE SORT ) == -! ==--------------------------------------------------------------== - IS1=IS+1 - DO 60 J=IS1,IF - I=J - 40 IF( (COUNT(I-1) .LT. COUNT(I)) )GOTO 60 - IF( (COUNT(I-1) .GT. COUNT(I)) )GOTO 50 - IF(IDX(I-1).LT.IDX(I))GOTO 60 - 50 AV=COUNT(I-1) - COUNT(I-1)=COUNT(I) - COUNT(I)=AV - IT=IDX(I-1) - IDX(I-1)=IDX(I) - IDX(I)=IT - I=I-1 - IF(I.GT.IS)GOTO 40 - 60 CONTINUE - LA=LA-2 - GOTO 170 -! ==--------------------------------------------------------------== -! == ******* QUICKSORT ******** == -! == SELECT THE NUMBER IN THE CENTRAL POSITION IN THE SEGMENT AS == -! == THE TEST NUMBER.REPLACE IT WITH THE NUMBER FROM THE SEGMENT'S== -! == HIGHEST ADDRESS. == -! ==--------------------------------------------------------------== - 70 IY=(IS+IF)/2 - X=COUNT(IY) - INTEST=IDX(IY) - COUNT(IY)=COUNT(IF) - IDX(IY)=IDX(IF) -! ==--------------------------------------------------------------== -! == THE MARKERS 'I' AND 'IFK' ARE USED FOR THE BEGINNING AND END == -! == OF THE SECTION NOT SO FAR TESTED AGAINST THE PRESENT VALUE == -! == OF X . == -! ==--------------------------------------------------------------== - K=1 - IFK=IF -! ==--------------------------------------------------------------== -! == WE ALTERNATE BETWEEN THE OUTER LOOP THAT INCREASES I AND THE == -! == INNER LOOP THAT REDUCES IFK, MOVING NUMBERS AND INDICES AS == -! == NECESSARY, UNTIL THEY MEET . == -! ==--------------------------------------------------------------== - DO 110 I=IS,IF - IF((X .GT. COUNT(I)))GOTO 110 - IF((X .LT. COUNT(I)))GOTO 80 - IF(INTEST.GT.IDX(I))GOTO 110 - 80 IF(I.GE.IFK)GOTO 120 - COUNT(IFK)=COUNT(I) - IDX(IFK)=IDX(I) - K1=K - DO 100 K=K1,IFKA - IFK=IF-K - IF((COUNT(IFK) .GT. X))GOTO 100 - IF((COUNT(IFK) .LT. X))GOTO 90 - IF(INTEST.LE.IDX(IFK))GOTO 100 - 90 IF(I.GE.IFK)GOTO 130 - COUNT(I)=COUNT(IFK) - IDX(I)=IDX(IFK) - GO TO 110 - 100 CONTINUE - GOTO 120 - 110 CONTINUE -! ==--------------------------------------------------------------== -! == RETURN THE TEST NUMBER TO THE POSITION MARKED BY THE MARKER == -! == WHICH DID NOT MOVE LAST. IT DIVIDES THE INITIAL SEGMENT INTO == -! == 2 PARTS. ANY ELEMENT IN THE FIRST PART IS LESS THAN OR EQUAL == -! == TO ANY ELEMENT IN THE SECOND PART, AND THEY MAY NOW BE SORTED== -! == INDEPENDENTLY . == -! ==--------------------------------------------------------------== - 120 COUNT(IFK)=X - IDX(IFK)=INTEST - IP=IFK - GOTO 140 - 130 COUNT(I)=X - IDX(I)=INTEST - IP=I -! ==--------------------------------------------------------------== -! == STORE THE LONGER SUBDIVISION IN WORKSPACE. == -! ==--------------------------------------------------------------== - 140 IF((IP-IS).GT.(IF-IP))GOTO 150 - MARK(LA)=IF - MARK(LA-1)=IP+1 - IF=IP-1 - GOTO 160 - 150 MARK(LA)=IP-1 - MARK(LA-1)=IS - IS=IP+1 -! ==--------------------------------------------------------------== -! == FIND THE LENGTH OF THE SHORTER SUBDIVISION. == -! ==--------------------------------------------------------------== - 160 LNGTH=IF-IS - IF(LNGTH.LE.0)GOTO 180 -! ==--------------------------------------------------------------== -! == IF IT CONTAINS MORE THAN ONE ELEMENT SUPPLY IT WITH WORKSPACE== -! ==--------------------------------------------------------------== - LA=LA+2 - GOTO 190 - 170 IF(LA.LE.0)GOTO 200 -! ==--------------------------------------------------------------== -! == OBTAIN THE ADDRESS OF THE SHORTEST SEGMENT AWAITING QUICKSORT== -! ==--------------------------------------------------------------== - 180 IF=MARK(LA) - IS=MARK(LA-1) - 190 CONTINUE -! ==--------------------------------------------------------------== - 200 RETURN - END SUBROUTINE rqsort -! ================================================================== - -!------------------------------------------------------------------------- - subroutine kb07ad_cp90(count,n,idx) -!------------------------------------------------------------------------- -! -! kb07ad handles double precision variables -! standard fortran 66 (a verified pfort subroutine) -! the work-space 'mark' of length 50 permits up to 2**(50/2) numbers -! to be sorted. - implicit none - integer :: n, idx(*) - real(8) :: count(*) - real(8) :: av, x - integer :: k1, ifk, lngth, ip, k, it, ifka, intest, iy - integer :: i, m, la, is, idf, mloop, is1, j, mark(50) -! set index array to original order . - do i=1,n - idx(i)=i - end do -! check that a trivial case has not been entered . - if(n.eq.1) go to 10 - if(n.gt.1) go to 30 - write(6,20) - 20 format(///20x,'***kb07ad***no numbers to be sorted ** return to', & - & ' calling program' ) - goto 10 -! 'm' is the length of segment which is short enough to enter -! the final sorting routine. it may be easily changed. - 30 m=12 -! set up initial values. - la=2 - is=1 - idf=n - do 190 mloop=1,n -! if segment is short enough sort with final sorting routine . - ifka=idf-is - if((ifka+1).gt.m)goto 70 -!********* final sorting *** -! ( a simple bubble sort ) - is1=is+1 - do 60 j=is1,idf - i=j - 40 if(count(i-1).lt.count(i))goto 60 - if(count(i-1).gt.count(i))goto 50 - if(idx(i-1).lt.idx(i))goto 60 - 50 av=count(i-1) - count(i-1)=count(i) - count(i)=av - it=idx(i-1) - idx(i-1)=idx(i) - idx(i)=it - i=i-1 - if(i.gt.is)goto 40 - 60 continue - la=la-2 - goto 170 -! ******* quicksort ******** -! select the number in the central position in the segment as -! the test number.replace it with the number from the segment's -! highest address. - 70 iy=(is+idf)/2 - x=count(iy) - intest=idx(iy) - count(iy)=count(idf) - idx(iy)=idx(idf) -! the markers 'i' and 'ifk' are used for the beginning and end -! of the section not so far tested against the present value -! of x . - k=1 - ifk=idf -! we alternate between the outer loop that increases i and the -! inner loop that reduces ifk, moving numbers and indices as -! necessary, until they meet . - do 110 i=is,idf - if(x.gt.count(i))goto 110 - if(x.lt.count(i))goto 80 - if(intest.gt.idx(i))goto 110 - 80 if(i.ge.ifk)goto 120 - count(ifk)=count(i) - idx(ifk)=idx(i) - k1=k - do 100 k=k1,ifka - ifk=idf-k - if(count(ifk).gt.x)goto 100 - if(count(ifk).lt.x)goto 90 - if(intest.le.idx(ifk))goto 100 - 90 if(i.ge.ifk)goto 130 - count(i)=count(ifk) - idx(i)=idx(ifk) - go to 110 - 100 continue - goto 120 - 110 continue -! return the test number to the position marked by the marker -! which did not move last. it divides the initial segment into -! 2 parts. any element in the first part is less than or equal -! to any element in the second part, and they may now be sorted -! independently . - 120 count(ifk)=x - idx(ifk)=intest - ip=ifk - goto 140 - 130 count(i)=x - idx(i)=intest - ip=i -! store the longer subdivision in workspace. - 140 if((ip-is).gt.(idf-ip))goto 150 - mark(la)=idf - mark(la-1)=ip+1 - idf=ip-1 - goto 160 - 150 mark(la)=ip-1 - mark(la-1)=is - is=ip+1 -! find the length of the shorter subdivision. - 160 lngth=idf-is - if(lngth.le.0)goto 180 -! if it contains more than one element supply it with workspace . - la=la+2 - goto 190 - 170 if(la.le.0)goto 10 -! obtain the address of the shortest segment awaiting quicksort - 180 idf=mark(la) - is=mark(la-1) - 190 continue - 10 return - end subroutine kb07ad_cp90 - diff --git a/quantum_espresso/kcp/flib/sort_gvec.f90 b/quantum_espresso/kcp/flib/sort_gvec.f90 deleted file mode 100644 index 3ce449ba0..000000000 --- a/quantum_espresso/kcp/flib/sort_gvec.f90 +++ /dev/null @@ -1,66 +0,0 @@ -! -! Copyright (C) 2001 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!--------------------------------------------------------------------- - -subroutine sort_gvec( ng, g2, mill ) - !--------------------------------------------------------------------- - ! - ! first the input variables - ! - use kinds, ONLY: DP - use constants, ONLY: eps8 - implicit none - INTEGER, INTENT(IN) :: ng - REAL(DP) :: g2( * ) - INTEGER :: mill( 3, * ) - - REAL(DP), ALLOCATABLE :: gsort( : ) - INTEGER, ALLOCATABLE :: idx( : ) - INTEGER :: ig, icurr, it, im - REAL(DP) :: gsq - - ALLOCATE( gsort( ng ) ) - ALLOCATE( idx( ng ) ) - - DO ig = 1, ng - IF ( g2(ig) > eps8 ) THEN - gsort(ig) = g2(ig) - ELSE - gsort(ig) = 0.d0 - END IF - END DO - - idx(1) = 0 - CALL hpsort_eps( ng, gsort( 1 ), idx( 1 ), eps8 ) - - ! ... sort indices accordingly - DO ig = 1, ng-1 - icurr = ig -30 IF( idx(icurr) /= ig ) THEN - ! ... swap g-vec indices - im = mill(1,icurr); mill(1,icurr) = mill(1,idx(icurr)); mill(1,idx(icurr)) = im - im = mill(2,icurr); mill(2,icurr) = mill(2,idx(icurr)); mill(2,idx(icurr)) = im - im = mill(3,icurr); mill(3,icurr) = mill(3,idx(icurr)); mill(3,idx(icurr)) = im - ! ... swap modules - gsq = g2( icurr ); g2( icurr ) = g2( idx(icurr) ); g2( idx(icurr) ) = gsq - ! ... swap indices - it = icurr; icurr = idx(icurr); idx(it) = it - IF( idx(icurr) == ig ) THEN - idx(icurr) = icurr - ELSE - GOTO 30 - END IF - END IF - END DO - - DEALLOCATE( gsort ) - DEALLOCATE( idx ) - - return -end subroutine sort_gvec diff --git a/quantum_espresso/kcp/flib/sph_bes.f90 b/quantum_espresso/kcp/flib/sph_bes.f90 deleted file mode 100644 index e5074313e..000000000 --- a/quantum_espresso/kcp/flib/sph_bes.f90 +++ /dev/null @@ -1,260 +0,0 @@ -! -! Copyright (C) 2001-2007 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!-------------------------------------------------------------------- -subroutine sph_bes (msh, r, q, l, jl) - !-------------------------------------------------------------------- - ! - ! ... input: - ! ... msh = number of grid points points - ! ... r(1:msh)= radial grid - ! ... q = q - ! ... l = angular momentum (-1 <= l <= 6) - ! ... output: - ! ... jl(1:msh) = j_l(q*r(i)) (j_l = spherical bessel function) - ! - use kinds, only: DP - USE constants, ONLY : eps14 - ! - implicit none - ! - integer :: msh, l - real(DP) :: r (msh), q, jl (msh) - ! - ! xseries = convergence radius of the series for small x of j_l(x) - real(DP) :: x, xl, xseries = 0.05_dp - integer :: ir, ir0 - integer, external:: semifact - ! -#if defined (__MASS) - real(DP) :: qr(msh), sin_qr(msh), cos_qr(msh) -#endif - - ! case q=0 - - if (abs (q) < eps14) then - if (l == -1) then - call errore ('sph_bes', 'j_{-1}(0) ?!?', 1) - elseif (l == 0) then - jl(:) = 1.d0 - else - jl(:) = 0.d0 - endif - return - end if - - ! case l=-1 - - if (l == - 1) then - if (abs (q * r (1) ) < eps14) call errore ('sph_bes', 'j_{-1}(0) ?!?',1) - -#if defined (__MASS) - - qr = q * r - call vcos( cos_qr, qr, msh) - jl = cos_qr / qr - -#else - - jl (:) = cos (q * r (:) ) / (q * r (:) ) - -#endif - - return - - end if - - ! series expansion for small values of the argument - ! ir0 is the first grid point for which q*r(ir0) > xseries - ! notice that for small q it may happen that q*r(msh) < xseries ! - - ir0 = msh+1 - do ir = 1, msh - if ( abs (q * r (ir) ) > xseries ) then - ir0 = ir - exit - end if - end do - - do ir = 1, ir0 - 1 - x = q * r (ir) - if ( l == 0 ) then - xl = 1.0_dp - else - xl = x**l - end if - jl (ir) = xl/semifact(2*l+1) * & - ( 1.0_dp - x**2/1.0_dp/2.0_dp/(2.0_dp*l+3) * & - ( 1.0_dp - x**2/2.0_dp/2.0_dp/(2.0_dp*l+5) * & - ( 1.0_dp - x**2/3.0_dp/2.0_dp/(2.0_dp*l+7) * & - ( 1.0_dp - x**2/4.0_dp/2.0_dp/(2.0_dp*l+9) ) ) ) ) - end do - - ! the following shouldn't be needed but do you trust compilers - ! to do the right thing in this special case ? I don't - PG - - if ( ir0 > msh ) return - - if (l == 0) then - -#if defined (__MASS) - - qr = q * r - call vsin( sin_qr, qr, msh) - jl (ir0:) = sin_qr(ir0:) / (q * r (ir0:) ) - -#else - - jl (ir0:) = sin (q * r (ir0:) ) / (q * r (ir0:) ) - -#endif - - elseif (l == 1) then - -#if defined (__MASS) - - qr = q * r - call vcos( cos_qr, qr, msh) - call vsin( sin_qr, qr, msh) - jl (ir0:) = ( sin_qr(ir0:) / (q * r (ir0:) ) - & - cos_qr(ir0:) ) / (q * r (ir0:) ) - -#else - - jl (ir0:) = (sin (q * r (ir0:) ) / (q * r (ir0:) ) - & - cos (q * r (ir0:) ) ) / (q * r (ir0:) ) - -#endif - - elseif (l == 2) then - -#if defined (__MASS) - - qr = q * r - call vcos( cos_qr, qr, msh) - call vsin( sin_qr, qr, msh) - jl (ir0:) = ( (3.d0 / (q*r(ir0:)) - (q*r(ir0:)) ) * sin_qr(ir0: ) - & - 3.d0 * cos_qr(ir0:) ) / (q*r(ir0:))**2 - -#else - - jl (ir0:) = ( (3.d0 / (q*r(ir0:)) - (q*r(ir0:)) ) * sin (q*r(ir0:)) - & - 3.d0 * cos (q*r(ir0:)) ) / (q*r(ir0:))**2 - -#endif - - elseif (l == 3) then - -#if defined (__MASS) - - qr = q * r - call vcos( cos_qr, qr, msh) - call vsin( sin_qr, qr, msh) - jl (ir0:) = (sin_qr (ir0:) * & - (15.d0 / (q*r(ir0:)) - 6.d0 * (q*r(ir0:)) ) + & - cos_qr (ir0:) * ( (q*r(ir0:))**2 - 15.d0) ) / & - (q*r(ir0:))**3 - -#else - - jl (ir0:) = (sin (q*r(ir0:)) * & - (15.d0 / (q*r(ir0:)) - 6.d0 * (q*r(ir0:)) ) + & - cos (q*r(ir0:)) * ( (q*r(ir0:))**2 - 15.d0) ) / & - (q*r(ir0:)) **3 - -#endif - - elseif (l == 4) then - -#if defined (__MASS) - - qr = q * r - call vcos( cos_qr, qr, msh) - call vsin( sin_qr, qr, msh) - jl (ir0:) = (sin_qr (ir0:) * & - (105.d0 - 45.d0 * (q*r(ir0:))**2 + (q*r(ir0:))**4) + & - cos_qr (ir0:) * & - (10.d0 * (q*r(ir0:))**3 - 105.d0 * (q*r(ir0:))) ) / & - (q*r(ir0:))**5 - -#else - - jl (ir0:) = (sin (q*r(ir0:)) * & - (105.d0 - 45.d0 * (q*r(ir0:))**2 + (q*r(ir0:))**4) + & - cos (q*r(ir0:)) * & - (10.d0 * (q*r(ir0:))**3 - 105.d0 * (q*r(ir0:))) ) / & - (q*r(ir0:))**5 -#endif - - elseif (l == 5) then - -#if defined (__MASS) - qr = q * r - call vcos( cos_qr, qr, msh) - call vsin( sin_qr, qr, msh) - jl (ir0:) = (-cos_qr(ir0:) - & - (945.d0*cos_qr(ir0:)) / (q*r(ir0:)) ** 4 + & - (105.d0*cos_qr(ir0:)) / (q*r(ir0:)) ** 2 + & - (945.d0*sin_qr(ir0:)) / (q*r(ir0:)) ** 5 - & - (420.d0*sin_qr(ir0:)) / (q*r(ir0:)) ** 3 + & - ( 15.d0*sin_qr(ir0:)) / (q*r(ir0:)) ) / (q*r(ir0:)) -#else - jl (ir0:) = (-cos(q*r(ir0:)) - & - (945.d0*cos(q*r(ir0:))) / (q*r(ir0:)) ** 4 + & - (105.d0*cos(q*r(ir0:))) / (q*r(ir0:)) ** 2 + & - (945.d0*sin(q*r(ir0:))) / (q*r(ir0:)) ** 5 - & - (420.d0*sin(q*r(ir0:))) / (q*r(ir0:)) ** 3 + & - ( 15.d0*sin(q*r(ir0:))) / (q*r(ir0:)) ) / (q*r(ir0:)) -#endif - - elseif (l == 6) then - -#if defined (__MASS) - - qr = q * r - call vcos( cos_qr, qr, msh) - call vsin( sin_qr, qr, msh) - jl (ir0:) = ((-10395.d0*cos_qr(ir0:)) / (q*r(ir0:))**5 + & - ( 1260.d0*cos_qr(ir0:)) / (q*r(ir0:))**3 - & - ( 21.d0*cos_qr(ir0:)) / (q*r(ir0:)) - & - sin_qr(ir0:) + & - ( 10395.d0*sin_qr(ir0:)) / (q*r(ir0:))**6 - & - ( 4725.d0*sin_qr(ir0:)) / (q*r(ir0:))**4 + & - ( 210.d0*sin_qr(ir0:)) / (q*r(ir0:))**2 ) / (q*r(ir0:)) -#else - - jl (ir0:) = ((-10395.d0*cos(q*r(ir0:))) / (q*r(ir0:))**5 + & - ( 1260.d0*cos(q*r(ir0:))) / (q*r(ir0:))**3 - & - ( 21.d0*cos(q*r(ir0:))) / (q*r(ir0:)) - & - sin(q*r(ir0:)) + & - ( 10395.d0*sin(q*r(ir0:))) / (q*r(ir0:))**6 - & - ( 4725.d0*sin(q*r(ir0:))) / (q*r(ir0:))**4 + & - ( 210.d0*sin(q*r(ir0:))) / (q*r(ir0:))**2 ) / (q*r(ir0:)) -#endif - - else - - call errore ('sph_bes', 'not implemented', abs(l)) - - endif - ! - return -end subroutine sph_bes - -integer function semifact(n) - ! semifact(n) = n!! - implicit none - integer :: n, i - - semifact = 1 - do i = n, 1, -2 - semifact = i*semifact - end do - return -end function semifact - diff --git a/quantum_espresso/kcp/flib/sph_dbes.f90 b/quantum_espresso/kcp/flib/sph_dbes.f90 deleted file mode 100644 index d98750165..000000000 --- a/quantum_espresso/kcp/flib/sph_dbes.f90 +++ /dev/null @@ -1,147 +0,0 @@ -! -! Copyright (C) 2001-2004 PWSCF-FPMD-CP90 group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!---------------------------------------------------------------------------- -SUBROUTINE sph_dbes( MMAX, R, XG, L, DJL ) - !---------------------------------------------------------------------------- - ! - ! ... calculates derivatives of spherical bessel functions j_l(Gr) - ! ... with respect to h_alpha,beta (without the factor GAGK(KK,IG)*HTM1) - ! ... i.e. -x * D(jl(x))/dx - ! - USE kinds, ONLY : DP - USE constants, ONLY : eps8 - ! - IMPLICIT NONE - ! - INTEGER :: MMAX, L - REAL(DP) :: XG - REAL(DP) :: DJL(MMAX), R(MMAX) - ! - INTEGER :: IR - REAL(DP) :: XRG, XRG2 - ! - ! - IF ( L == 1 ) THEN ! S PART - IF( XG < eps8 ) THEN - DO IR=1,MMAX - DJL(IR) = 0.D0 - END DO - ELSE - DJL(1) = 0.D0 - DO IR=2,MMAX - XRG=R(IR)*XG - DJL(IR) = SIN(XRG)/XRG-COS(XRG) - END DO - ENDIF - ENDIF - ! - IF ( L == 2 ) THEN ! P PART - IF( XG < eps8 ) THEN - DO IR=1,MMAX - DJL(IR) = 0.D0 - END DO - ELSE - DJL(1) = 0.D0 - DO IR=2,MMAX - XRG=R(IR)*XG - DJL(IR) = 2.D0*(SIN(XRG)/XRG-COS(XRG))/XRG - SIN(XRG) - END DO - ENDIF - ENDIF - ! - IF ( L == 3 ) THEN ! D PART - IF ( XG < eps8 ) THEN - DO IR=1,MMAX - DJL(IR) = 0.D0 - END DO - ELSE - DJL(1) = 0.D0 - DO IR=2,MMAX - XRG=R(IR)*XG - DJL(IR) = ( SIN(XRG)*(9.D0/(XRG*XRG)-4.D0) - & - 9.D0*COS(XRG)/XRG ) /XRG + COS(XRG) - END DO - END IF - END IF - ! - IF ( L == 4 ) THEN ! F PART - IF ( XG < eps8 ) THEN - DO IR=1,MMAX - DJL(IR) = 0.D0 - END DO - ELSE - DJL(1) = 0.D0 - DO IR=2,MMAX - XRG=R(IR)*XG - XRG2=XRG*XRG - DJL(IR) = SIN(XRG)*(60.D0/(XRG2*XRG2)-27.D0/XRG2+1.d0) - & - COS(XRG)*(60.D0/XRG2-7.D0)/XRG - END DO - END IF - END IF - ! - IF ( L == 5 ) THEN ! G PART - IF ( XG < eps8 ) THEN - DO IR=1,MMAX - DJL(IR) = 0.D0 - END DO - ELSE - DJL(1) = 0.D0 - DO IR=2,MMAX - XRG=R(IR)*XG - XRG2=XRG*XRG - DJL(IR) = SIN(XRG)*(525.D0/(XRG2*XRG2)-240.D0/XRG2+11.D0)/XRG - & - COS(XRG)*(525.D0/(XRG2*XRG2)-65.D0/XRG2+1.D0) - END DO - END IF - END IF - ! - IF ( L <= 0 .OR. L >= 6 ) & - CALL errore( 'sph_dbes', ' L NOT PROGRAMMED, L= ',L ) - ! - RETURN - ! -END SUBROUTINE sph_dbes - -! -SUBROUTINE sph_dbes1 ( nr, r, xg, l, jl, djl ) - ! - ! calculates x*dj_l(x)/dx using the recursion formula - ! dj_l(x)/dx = l/x*j_l(x) - j_(l+1)(x) - ! for l=0, and for l>0 : - ! dj_l(x)/dx = j_(l-1)(x) - (l+1)/x * j_l(x) - ! requires j_l(r) in input - ! - USE kinds, ONLY : DP - USE constants, ONLY : eps8 - ! - IMPLICIT NONE - INTEGER, INTENT(IN) :: l, nr - REAL (DP), INTENT(IN) :: xg, jl(nr), r(nr) - REAL (DP), INTENT(OUT):: djl(nr) - ! - if ( xg < eps8 ) then - ! - ! special case q=0 - ! note that x*dj_l(x)/dx = 0 for x = 0 - ! - djl(:) = 0.0d0 - else - ! - if ( l > 0 ) then - call sph_bes ( nr, r, xg, l-1, djl ) - djl(:) = djl(:) * (xg * r(:) ) - (l+1) * jl(:) - else if ( l == 0 ) then - call sph_bes ( nr, r, xg, l+1, djl ) - djl(:) = - djl(:) * (xg * r(:) ) - else - call errore('sph_dbes','l < 0 not implemented', abs(l) ) - end if - end if - ! -end SUBROUTINE sph_dbes1 diff --git a/quantum_espresso/kcp/flib/transto.f90 b/quantum_espresso/kcp/flib/transto.f90 deleted file mode 100644 index ec5526505..000000000 --- a/quantum_espresso/kcp/flib/transto.f90 +++ /dev/null @@ -1,411 +0,0 @@ -! -! Copyright (C) 2001 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -#include "opt_param.h" - -! OPTIMIZED DRIVER FOR MATRIX TRASPOSITION -! -! written by Carlo Cavazzoni -! - - SUBROUTINE mytranspose(x, ldx, y, ldy, n, m) -! -! x input matrix (n by m) to be trasposed -! y output matrix (m by n), the transpose of x -! - - IMPLICIT NONE - - - INTEGER :: ldx, ldy, n, m, what - REAL(8) :: x(ldx, m), y(ldy, n) - INTEGER :: i, j, k, d, nb, mb, ib, jb, ioff, joff - INTEGER :: iind, jind - INTEGER, PARAMETER :: bsiz = __BSIZ_VALUE - REAL(8) :: buf(bsiz, bsiz), bswp - - if( n>ldx ) then - write(6,fmt='("trasponi: inconsistent ldx and n: ",2I6)') ldx, n - end if - if( m>ldy ) then - write(6,fmt='("trasponi: inconsistent ldy and m: ",2I6)') ldy, m - end if - - nb = n / bsiz - mb = m / bsiz - - IF( nb < 2 .AND. mb < 2 ) THEN - what = 1 - ELSE - what = 2 - END IF - - select case (what) - - case (1) - - do i=1,n - do j=1,m - y(j,i) = x(i,j) - enddo - enddo - - case (2) - - do ib = 1, nb - ioff = (ib-1) * bsiz - do jb = 1, mb - joff = (jb-1) * bsiz - do j = 1, bsiz - do i = 1, bsiz - buf(i,j) = x(i+ioff, j+joff) - enddo - enddo - do j = 1, bsiz - do i = 1, j-1 - bswp = buf(i,j) - buf(i,j) = buf(j,i) - buf(j,i) = bswp - enddo - enddo - do i=1,bsiz - do j=1,bsiz - y(j+joff, i+ioff) = buf(j,i) - enddo - enddo - enddo - enddo - - IF( MIN(1, MOD(n, bsiz)) > 0 ) THEN - ioff = nb * bsiz - do jb = 1, mb - joff = (jb-1) * bsiz - do j = 1, bsiz - do i = 1, MIN(bsiz, n-ioff) - buf(i,j) = x(i+ioff, j+joff) - enddo - enddo - do i = 1, MIN(bsiz, n-ioff) - do j = 1, bsiz - y(j+joff,i+ioff) = buf(i,j) - enddo - enddo - enddo - END IF - - IF( MIN(1, MOD(m, bsiz)) > 0 ) THEN - joff = mb * bsiz - do ib = 1, nb - ioff = (ib-1) * bsiz - do j = 1, MIN(bsiz, m-joff) - do i = 1, bsiz - buf(i,j) = x(i+ioff, j+joff) - enddo - enddo - do i = 1, bsiz - do j = 1, MIN(bsiz, m-joff) - y(j+joff,i+ioff) = buf(i,j) - enddo - enddo - enddo - END IF - - IF( MIN(1,MOD(n,bsiz))>0 .AND. MIN(1,MOD(m,bsiz))>0 ) THEN - joff = mb * bsiz - ioff = nb * bsiz - do j = 1, MIN(bsiz, m-joff) - do i = 1, MIN(bsiz, n-ioff) - buf(i,j) = x(i+ioff, j+joff) - enddo - enddo - do i = 1, MIN(bsiz, n-ioff) - do j = 1, MIN(bsiz, m-joff) - y(j+joff,i+ioff) = buf(i,j) - enddo - enddo - END IF - -#if defined __ESSL - case (3) - - CALL DGETMO (x, ldx, n, m, y, ldy) -#endif - - case default - - write(6,fmt='("trasponi: undefined method")') - - end select - - RETURN - END SUBROUTINE mytranspose - - - SUBROUTINE mytransposez(x, ldx, y, ldy, n, m) -! -! x input matrix (n by m) to be trasposed -! y output matrix (m by n), the transpose of x -! - - IMPLICIT NONE - - - INTEGER :: ldx, ldy, n, m, what - COMPLEX(8) :: x(ldx, m), y(ldy, n) - INTEGER :: i, j, k, d, nb, mb, ib, jb, ioff, joff - INTEGER :: iind, jind - INTEGER, PARAMETER :: bsiz = __BSIZ_VALUE / 2 - COMPLEX(8) :: buf(bsiz, bsiz), bswp -! write(6,*) "inside mytransposez" !added:giovanni:debug - if( n>ldx ) then - write(6,fmt='("trasponi: inconsistent ldx and n")') - end if - if( m>ldy ) then - write(6,fmt='("trasponi: inconsistent ldy and m")') - end if - - nb = n / bsiz - mb = m / bsiz - - IF( nb < 2 .AND. mb < 2 ) THEN - what = 1 - ELSE - what = 2 - END IF - write(6,*) "middle mytransposez", what !added:giovanni:debug - select case (what) - - case (1) - - do i=1,n - do j=1,m - y(j,i) = x(i,j) - enddo - enddo - - case (2) - - do ib = 1, nb - ioff = (ib-1) * bsiz - do jb = 1, mb - joff = (jb-1) * bsiz - do j = 1, bsiz - do i = 1, bsiz - buf(i,j) = x(i+ioff, j+joff) - enddo - enddo - do j = 1, bsiz - do i = 1, j-1 - bswp = buf(i,j) - buf(i,j) = buf(j,i) - buf(j,i) = bswp - enddo - enddo - do i=1,bsiz - do j=1,bsiz - y(j+joff, i+ioff) = buf(j,i) - enddo - enddo - enddo - enddo - - IF( MIN(1, MOD(n, bsiz)) > 0 ) THEN - ioff = nb * bsiz - do jb = 1, mb - joff = (jb-1) * bsiz - do j = 1, bsiz - do i = 1, MIN(bsiz, n-ioff) - buf(i,j) = x(i+ioff, j+joff) - enddo - enddo - do i = 1, MIN(bsiz, n-ioff) - do j = 1, bsiz - y(j+joff,i+ioff) = buf(i,j) - enddo - enddo - enddo - END IF - - IF( MIN(1, MOD(m, bsiz)) > 0 ) THEN - joff = mb * bsiz - do ib = 1, nb - ioff = (ib-1) * bsiz - do j = 1, MIN(bsiz, m-joff) - do i = 1, bsiz - buf(i,j) = x(i+ioff, j+joff) - enddo - enddo - do i = 1, bsiz - do j = 1, MIN(bsiz, m-joff) - y(j+joff,i+ioff) = buf(i,j) - enddo - enddo - enddo - END IF - - IF( MIN(1,MOD(n,bsiz))>0 .AND. MIN(1,MOD(m,bsiz))>0 ) THEN - joff = mb * bsiz - ioff = nb * bsiz - do j = 1, MIN(bsiz, m-joff) - do i = 1, MIN(bsiz, n-ioff) - buf(i,j) = x(i+ioff, j+joff) - enddo - enddo - do i = 1, MIN(bsiz, n-ioff) - do j = 1, MIN(bsiz, m-joff) - y(j+joff,i+ioff) = buf(i,j) - enddo - enddo - END IF - -#if defined __ESSL - case (3) - - CALL ZGETMO (x, ldx, n, m, y, ldy) -#endif - - case default - - write(6,fmt='("trasponi: undefined method")') - - end select - RETURN - END SUBROUTINE mytransposez - - SUBROUTINE mytransposezc(x, ldx, y, ldy, n, m) -! -! x input matrix (n by m) to be trasposed -! y output matrix (m by n), the transpose of x -! - - IMPLICIT NONE - - - INTEGER :: ldx, ldy, n, m, what - COMPLEX(8) :: x(ldx, m), y(ldy, n) - INTEGER :: i, j, k, d, nb, mb, ib, jb, ioff, joff - INTEGER :: iind, jind - INTEGER, PARAMETER :: bsiz = __BSIZ_VALUE / 2 - COMPLEX(8) :: buf(bsiz, bsiz), bswp -! write(6,*) "inside mytransposez" !added:giovanni:debug - if( n>ldx ) then - write(6,fmt='("trasponi: inconsistent ldx and n")') - end if - if( m>ldy ) then - write(6,fmt='("trasponi: inconsistent ldy and m")') - end if - - nb = n / bsiz - mb = m / bsiz - - IF( nb < 2 .AND. mb < 2 ) THEN - what = 1 - ELSE - what = 2 - END IF -! write(6,*) "middle mytransposez", what !added:giovanni:debug - select case (what) - - case (1) - - do i=1,n - do j=1,m - y(j,i) = CONJG(x(i,j)) - enddo - enddo - - case (2) - - do ib = 1, nb - ioff = (ib-1) * bsiz - do jb = 1, mb - joff = (jb-1) * bsiz - do j = 1, bsiz - do i = 1, bsiz - buf(i,j) = x(i+ioff, j+joff) - enddo - enddo - do j = 1, bsiz - do i = 1, j-1 - bswp = buf(i,j) - buf(i,j) = buf(j,i) - buf(j,i) = bswp - enddo - enddo - do i=1,bsiz - do j=1,bsiz - y(j+joff, i+ioff) = CONJG(buf(j,i)) - enddo - enddo - enddo - enddo - - IF( MIN(1, MOD(n, bsiz)) > 0 ) THEN - ioff = nb * bsiz - do jb = 1, mb - joff = (jb-1) * bsiz - do j = 1, bsiz - do i = 1, MIN(bsiz, n-ioff) - buf(i,j) = x(i+ioff, j+joff) - enddo - enddo - do i = 1, MIN(bsiz, n-ioff) - do j = 1, bsiz - y(j+joff,i+ioff) = CONJG(buf(i,j)) - enddo - enddo - enddo - END IF - - IF( MIN(1, MOD(m, bsiz)) > 0 ) THEN - joff = mb * bsiz - do ib = 1, nb - ioff = (ib-1) * bsiz - do j = 1, MIN(bsiz, m-joff) - do i = 1, bsiz - buf(i,j) = x(i+ioff, j+joff) - enddo - enddo - do i = 1, bsiz - do j = 1, MIN(bsiz, m-joff) - y(j+joff,i+ioff) = CONJG(buf(i,j)) - enddo - enddo - enddo - END IF - - IF( MIN(1,MOD(n,bsiz))>0 .AND. MIN(1,MOD(m,bsiz))>0 ) THEN - joff = mb * bsiz - ioff = nb * bsiz - do j = 1, MIN(bsiz, m-joff) - do i = 1, MIN(bsiz, n-ioff) - buf(i,j) = x(i+ioff, j+joff) - enddo - enddo - do i = 1, MIN(bsiz, n-ioff) - do j = 1, MIN(bsiz, m-joff) - y(j+joff,i+ioff) = CONJG(buf(i,j)) - enddo - enddo - END IF - -#if defined __ESSL - case (3) - - CALL ZGETMO (CONJG(x), ldx, n, m, y, ldy) -#endif - - case default - - write(6,fmt='("trasponi: undefined method")') - - end select -! write(6,*) "exiting mytransposez" !added:giovanni:debug - RETURN - END SUBROUTINE mytransposezc - diff --git a/quantum_espresso/kcp/flib/volume.f90 b/quantum_espresso/kcp/flib/volume.f90 deleted file mode 100644 index eda856217..000000000 --- a/quantum_espresso/kcp/flib/volume.f90 +++ /dev/null @@ -1,62 +0,0 @@ -! -! Copyright (C) 2001 PWSCF group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!--------------------------------------------------------------------- -subroutine volume (alat, a1, a2, a3, omega) - !--------------------------------------------------------------------- - ! - ! Compute the volume of the unit cell - ! - use kinds, ONLY: DP - implicit none - ! - ! First the I/O variables - ! - real(DP) :: alat, a1 (3), a2 (3), a3 (3), omega - ! input: lattice parameter (unit length) - ! input: the first lattice vector - ! input: the second lattice vector - ! input: the third lattice vector - ! input: the volume of the unit cell - ! - ! Here the local variables required by the routine - ! - - real(DP) :: s - ! the sign of a permutation - integer :: i, j, k, l, iperm - !\ - ! \ - ! / auxiliary indices - !/ - ! counter on permutations - ! - ! Compute the volume - ! - omega = 0.d0 - s = 1.d0 - i = 1 - j = 2 - k = 3 -101 do iperm = 1, 3 - omega = omega + s * a1 (i) * a2 (j) * a3 (k) - l = i - i = j - j = k - k = l - enddo - i = 2 - j = 1 - k = 3 - s = - s - - if (s.lt.0.d0) goto 101 - - omega = abs (omega) * alat**3 - return -end subroutine volume diff --git a/quantum_espresso/kcp/flib/xerbla.f b/quantum_espresso/kcp/flib/xerbla.f deleted file mode 100644 index 6e11175f3..000000000 --- a/quantum_espresso/kcp/flib/xerbla.f +++ /dev/null @@ -1,46 +0,0 @@ - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER*6 SRNAME - INTEGER INFO -* .. -* -* Purpose -* ======= -* -* XERBLA is an error handler for the LAPACK routines. -* It is called by an LAPACK routine if an input parameter has an -* invalid value. A message is printed and execution stops. -* -* Installers may consider modifying the STOP statement in order to -* call system-specific exception-handling facilities. -* -* Arguments -* ========= -* -* SRNAME (input) CHARACTER*6 -* The name of the routine which called XERBLA. -* -* INFO (input) INTEGER -* The position of the invalid parameter in the parameter list -* of the calling routine. -* -* ===================================================================== -* -* .. Executable Statements .. -* - WRITE( *, FMT = 9999 )SRNAME, INFO -* - STOP -* - 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', - $ 'an illegal value' ) -* -* End of XERBLA -* - END diff --git a/quantum_espresso/kcp/flib/ylmr2.f90 b/quantum_espresso/kcp/flib/ylmr2.f90 deleted file mode 100644 index befb1f7f3..000000000 --- a/quantum_espresso/kcp/flib/ylmr2.f90 +++ /dev/null @@ -1,149 +0,0 @@ -! -! Copyright (C) 2001-2007 Quantum-Espresso group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!----------------------------------------------------------------------- -subroutine ylmr2 (lmax2, ng, g, gg, ylm) - !----------------------------------------------------------------------- - ! - ! Real spherical harmonics ylm(G) up to l=lmax - ! lmax2 = (lmax+1)^2 is the total number of spherical harmonics - ! Numerical recursive algorithm based on the one given in Numerical - ! Recipes but avoiding the calculation of factorials that generate - ! overflow for lmax > 11 - ! - USE kinds - USE constants, ONLY : pi, fpi - implicit none - ! - integer, intent(in) :: lmax2, ng - real(DP), intent(in) :: g (3, ng), gg (ng) - ! - ! BEWARE: gg = g(1)^2 + g(2)^2 +g(3)^2 is not checked on input - ! incorrect results will ensue if the above does not hold - ! - real(DP), intent(out) :: ylm (ng,lmax2) - ! - ! local variables - ! - real(DP), parameter :: eps = 1.0d-9 - real(DP), allocatable :: cost (:), sent(:), phi (:), Q(:,:,:) - real(DP) :: c, gmod - integer :: lmax, ig, l, m, lm - ! - if (ng < 1 .or. lmax2 < 1) return - do lmax = 0, 25 - if ((lmax+1)**2 == lmax2) go to 10 - end do - call errore (' ylmr', 'l > 25 or wrong number of Ylm required',lmax2) -10 continue - - ! - if (lmax == 0) then - ylm(:,1) = sqrt (1.d0 / fpi) - return - end if - ! - ! theta and phi are polar angles, cost = cos(theta) - ! - allocate(cost(ng), sent(ng), phi(ng), Q(ng,0:lmax,0:lmax) ) - ! -!$omp parallel default(shared), private(ig,gmod,lm,l,c,m) - -!$omp do - do ig = 1, ng - gmod = sqrt (gg (ig) ) - if (gmod < eps) then - cost(ig) = 0.d0 - else - cost(ig) = g(3,ig)/gmod - endif - ! - ! beware the arc tan, it is defined modulo pi - ! - if (g(1,ig) > eps) then - phi (ig) = atan( g(2,ig)/g(1,ig) ) - else if (g(1,ig) < -eps) then - phi (ig) = atan( g(2,ig)/g(1,ig) ) + pi - else - phi (ig) = sign( pi/2.d0,g(2,ig) ) - end if - sent(ig) = sqrt(max(0d0,1.d0-cost(ig)**2)) - enddo - ! - ! Q(:,l,m) are defined as sqrt ((l-m)!/(l+m)!) * P(:,l,m) where - ! P(:,l,m) are the Legendre Polynomials (0 <= m <= l) - ! - lm = 0 - do l = 0, lmax - c = sqrt (DBLE(2*l+1) / fpi) - if ( l == 0 ) then -!$omp do - do ig = 1, ng - Q (ig,0,0) = 1.d0 - end do - else if ( l == 1 ) then -!$omp do - do ig = 1, ng - Q (ig,1,0) = cost(ig) - Q (ig,1,1) =-sent(ig)/sqrt(2.d0) - end do - else - ! - ! recursion on l for Q(:,l,m) - ! - do m = 0, l - 2 -!$omp do - do ig = 1, ng - Q(ig,l,m) = cost(ig)*(2*l-1)/sqrt(DBLE(l*l-m*m))*Q(ig,l-1,m) & - - sqrt(DBLE((l-1)*(l-1)-m*m))/sqrt(DBLE(l*l-m*m))*Q(ig,l-2,m) - end do - end do -!$omp do - do ig = 1, ng - Q(ig,l,l-1) = cost(ig) * sqrt(DBLE(2*l-1)) * Q(ig,l-1,l-1) - end do -!$omp do - do ig = 1, ng - Q(ig,l,l) = - sqrt(DBLE(2*l-1))/sqrt(DBLE(2*l))*sent(ig)*Q(ig,l-1,l-1) - end do - end if - ! - ! Y_lm, m = 0 - ! - lm = lm + 1 -!$omp do - do ig = 1, ng - ylm(ig, lm) = c * Q(ig,l,0) - end do - ! - do m = 1, l - ! - ! Y_lm, m > 0 - ! - lm = lm + 1 -!$omp do - do ig = 1, ng - ylm(ig, lm) = c * sqrt(2.d0) * Q(ig,l,m) * cos (m*phi(ig)) - end do - ! - ! Y_lm, m < 0 - ! - lm = lm + 1 -!$omp do - do ig = 1, ng - ylm(ig, lm) = c * sqrt(2.d0) * Q(ig,l,m) * sin (m*phi(ig)) - end do - end do - end do - ! -!$omp end parallel - ! - deallocate(cost, sent, phi, Q) - ! - return -end subroutine ylmr2 - diff --git a/quantum_espresso/kcp/include/c_defs.h.in b/quantum_espresso/kcp/include/c_defs.h.in deleted file mode 100644 index ebbabcffa..000000000 --- a/quantum_espresso/kcp/include/c_defs.h.in +++ /dev/null @@ -1,21 +0,0 @@ -/* -Copyright (C) 2006 Quantum-ESPRESSO group -This file is distributed under the terms of the -GNU General Public License. See the file `License' -in the root directory of the present distribution, -or http://www.gnu.org/copyleft/gpl.txt . -*/ - -/* File c_defs.h.in is used by configure to generate c_defs.h - Variables that configure defines should be #undef-ined in - include/c_defs.h.in !!! */ - -/* fortran-to-C naming convention, for functions with and without - underscores in the name (some compilers treat them differently) */ - -#undef F77_FUNC -#undef F77_FUNC_ - -/* do we have the mallinfo structure (see clib/memstat.c) ? */ - -#undef HAVE_MALLINFO diff --git a/quantum_espresso/kcp/include/configure.h.in b/quantum_espresso/kcp/include/configure.h.in deleted file mode 100644 index 4b0ec3cb2..000000000 --- a/quantum_espresso/kcp/include/configure.h.in +++ /dev/null @@ -1,47 +0,0 @@ -! -! Copyright (C) 2006 WanT Group -! -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -! -! contains configure infos -! - -#define __HAVE_CONFIG_INFO - -#define __CONF_HOST "@host@" -#define __CONF_ARCH "@arch@" - -#define __CONF_CC "@cc@" -#define __CONF_CFLAGS "@cflags@" -#define __CONF_DFLAGS "@dflags@" -#define __CONF_CPP "@cpp@" -#define __CONF_CPPFLAGS "@cppflags@" - -#define __CONF_F90 "@f90@" -#define __CONF_MPIF90 "@mpif90@" -#define __CONF_F90FLAGS "@f90flags@" -#define __CONF_F77 "@f77@" -#define __CONF_FFLAGS "@fflags@" -#define __CONF_FFLAGS_NOOPT "@fflags_noopt@" -#define __CONF_PRE_FDFLAGS "@pre_fdflags@" -#define __CONF_FDFLAGS "@fdflags@" - -#define __CONF_LD "@ld@" -#define __CONF_LDFLAGS "@ldflags@" -#define __CONF_IMOD "@imod@" - -#define __CONF_BLAS_LIBS "@blas_libs@" -#define __CONF_LAPACK_LIBS "@lapack_libs@" -#define __CONF_FFT_LIBS "@fft_libs@" -#define __CONF_MASS_LIBS "@mass_libs@" - -#define __CONF_AR "@ar@" -#define __CONF_ARFLAGS "@arflags@" -#define __CONF_RANLIB "@ranlib@" - - diff --git a/quantum_espresso/kcp/include/defs.h.README b/quantum_espresso/kcp/include/defs.h.README deleted file mode 100644 index 5522251f8..000000000 --- a/quantum_espresso/kcp/include/defs.h.README +++ /dev/null @@ -1,103 +0,0 @@ - ----------------------------------------------------------------------------- - CONFIGURATION FILES - -You shouldn't need to edit the following files. The two first are -automatically generated by "configure". - -* include/fft_defs.h - ================== - automatically generated by configure using include/fft_defs.h.in - as template - included in Modules/fft_scalar.f90 - contains the type for C pointers called by fortran: - C_POINTER is integer*8 for 64-bit machines, - integer*4 on most other machines - DO NOT add C-style comments! some fortran compilers do not like them - -* include/c_defs.h - ================ - automatically generated by configure using include/c_defs.h.in - as template - included in C files in clib/ . Contains: - -1) #define HAVE_MALLINFO - if the mallinfo structure is present (Linux, AIX) - -2) Macros redefining C symbols so that Fortran finds them - F77_FUNC, F77_FUNC_ - C routine 'name' in *.c files are defined as - F77_FUNC('name','NAME') - if 'name' does not contain an underscore; if it does, as - F77_FUNC_('name','NAME') - - Absoft: convert to capital, no added underscores - #define F77_FUNC(name,NAME) NAME - #define F77_FUNC_(name,NAME) NAME - XLF, HP-UX: convert to lowercase, no added underscores - #define F77_FUNC(name,NAME) name - #define F77_FUNC_(name,NAME) name - G95, EKOPath, Alpha Linux: convert to lowercase, add one underscore - if the name does not contain underscores, add two if it does - #define F77_FUNC(name,NAME) name ## _ - #define F77_FUNC_(name,NAME) name ## __ - Most other cases: convert to lowercase, add one underscore - #define F77_FUNC(name,NAME) name ## _ - #define F77_FUNC_(name,NAME) name ## _ - -* include/f_defs.h - ================ - - contains definitions to be included in FORTRAN files ONLY - DO NOT add C-style comments! some fortran compilers do not like them - Defines on output: - Blas/Lapack names lowercase and with underscores appended if requested - iargc, system libraries that need to be redefined (i.e. - getarg, getenv add an underscore) in some specific cases - CMPLX force it to produce double-precision numbers - DREAL DIMAG DCMPLX redefined as fake names to prevent their usage - -* iotk/include/iotk_config.h - ========================= - contains definitions for iotk . Defines on output: - __IOTK_REAL1 kind for single-precision reals - __IOTK_REAL2 kind for double-precision reals - __IOTK_WORKAROUND* various workarounds for miscellaneous compiler bugs - ----------------------------------------------------------------------------- - - PREPROCESSING OPTIONS USED IN *.h FILES AND IN THE SOURCES - -Hardware/Compiler: - __AIX Ibm rs/6000 machines - __XLF xlf compiler (ibm or macintosh with powerpc processor) - __ALTIX sgi altix 350/3000 machines running Linux - __ORIGIN sgi origin 2k or 3k machines (Mips compiler) - __ALPHA hp-compaq (formerly dec) alphas - __SX6 Nec sx-6 vector machines (Nec compiler) - __PGI Portland Group compiler (workarounds for compiler bugs) - __GFORTRAN gnu gfortran (workarounds for compiler bugs) - __INTEL Intel ifc and ifort compilers (workaround for compiler - bugs and for insufficient stack size) - __XD1 Specialized code for Cray XD1 -OS: -Parallel execution: - __PARA Parallel execution, in general - __MPI Use MPI library - __SHMEM Use Shared Memory library (only Altix and Origin) -Libraries: - __FFTW FFT routines from internal FFTW library - __FFTW3 FFT routines from external FFTW v.3 library - __ACML FFT routines from ACML for AMD CPUs - __SCSL FFT routines from SGI SCSL scientific library - __SUNPERF FFT routines from SUN sunperf scientific library - __ESSL use blas/lapack/fft routines from IBM ESSL library - __LINUX_ESSL use blas/lapack/fft routines from IBM ESSL library (linux version) - __MASS use mathematical routines from IBM MASS library - ASL, MICRO SX-6 specific libraries - ADD_BLAS_TWO_UNDERSCORES - ADD_BLAS_ONE_UNDERSCORE - some precompiled blas/lapack packages may contain underscores - at the end - may need one of these in order to be linked -Timing: - __HPM Hardware Performance Monitor (IBM SP) - __QK_USER__ for better timing of fftw in cray xt3 (?) - diff --git a/quantum_espresso/kcp/include/f_defs.h b/quantum_espresso/kcp/include/f_defs.h deleted file mode 100644 index 8a00afe98..000000000 --- a/quantum_espresso/kcp/include/f_defs.h +++ /dev/null @@ -1,61 +0,0 @@ -! -! Copyright (C) 2002-2006 Quantum-ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -# define DREAL @@_use_DBLE_instead@@ -# define DIMAG @@_use_AIMAG_instead@@ -# define DCMPLX @@_use_CMPLX_instead@@ -# define DFLOAT @@_use_DBLE_instead@@ -# define CMPLX(a,b) cmplx(a,b,kind=DP) - -#if defined(ADD_BLAS_TWO_UNDERSCORES) -# define C_NAME(name) name ## __ -#elif defined(ADD_BLAS_ONE_UNDERSCORE) -# define C_NAME(name) name ## _ -#else -# define C_NAME(name) name -#endif - -#define DAXPY C_NAME(daxpy) -#define DCOPY C_NAME(dcopy) -#define DDOT C_NAME(ddot) -#define DGETRF C_NAME(dgetrf) -#define DGETRI C_NAME(dgetri) -#define DGEMV C_NAME(dgemv) -#define DGEMM C_NAME(dgemm) -#define DGER C_NAME(dger) -#define DNRM2 C_NAME(dnrm2) -#define DPOTRF C_NAME(dpotrf) -#define DPOTRS C_NAME(dpotrs) -#define DSCAL C_NAME(dscal) -#define DSPEV C_NAME(dspev) -#define DSYTRF C_NAME(dsytrf) -#define DSYTRI C_NAME(dsytri) -#define DSYEV C_NAME(dsyev) -#define DSYGV C_NAME(dsygv) -#define DSYGVX C_NAME(dsygvx) -#define DSWAP C_NAME(dswap) -#define ILAENV C_NAME(ilaenv) -#define IDAMAX C_NAME(idamax) -#define IZAMAX C_NAME(izamax) -#define ZAXPY C_NAME(zaxpy) -#define ZCOPY C_NAME(zcopy) -#define ZDOTC C_NAME(zdotc) -#define ZDOTU C_NAME(zdotu) -#define ZGEMM C_NAME(zgemm) -#define ZGEMV C_NAME(zgemv) -#define ZGESV C_NAME(zgesv) -#define ZGESVD C_NAME(zgesvd) -#define ZGGEV C_NAME(zggev) -#define ZHEEV C_NAME(zheev) -#define ZHEEVX C_NAME(zheevx) -#define ZHEGV C_NAME(zhegv) -#define ZHEGVX C_NAME(zhegvx) -#define ZHPEV C_NAME(zhpev) -#define ZSCAL C_NAME(zscal) -#define ZSWAP C_NAME(zswap) -#define ZDSCAL C_NAME(zdscal) - diff --git a/quantum_espresso/kcp/include/fft_defs.h.in b/quantum_espresso/kcp/include/fft_defs.h.in deleted file mode 100644 index 180c1bba6..000000000 --- a/quantum_espresso/kcp/include/fft_defs.h.in +++ /dev/null @@ -1,2 +0,0 @@ - -#define C_POINTER integer*@SIZEOF_INT_P@ diff --git a/quantum_espresso/kcp/include/opt_param.h b/quantum_espresso/kcp/include/opt_param.h deleted file mode 100644 index 05b1737a9..000000000 --- a/quantum_espresso/kcp/include/opt_param.h +++ /dev/null @@ -1,13 +0,0 @@ -! -! Copyright (C) 2002 FPMD group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! - -#if defined __AIX -# define __BSIZ_VALUE 55 -#else -# define __BSIZ_VALUE 35 -#endif diff --git a/quantum_espresso/kcp/install-sh b/quantum_espresso/kcp/install-sh deleted file mode 100755 index 6ce63b9f7..000000000 --- a/quantum_espresso/kcp/install-sh +++ /dev/null @@ -1,294 +0,0 @@ -#!/bin/sh -# -# install - install a program, script, or datafile -# -# This originates from X11R5 (mit/util/scripts/install.sh), which was -# later released in X11R6 (xc/config/util/install.sh) with the -# following copyright and license. -# -# Copyright (C) 1994 X Consortium -# -# Permission is hereby granted, free of charge, to any person obtaining a copy -# of this software and associated documentation files (the "Software"), to -# deal in the Software without restriction, including without limitation the -# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -# sell copies of the Software, and to permit persons to whom the Software is -# furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN -# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- -# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -# -# Except as contained in this notice, the name of the X Consortium shall not -# be used in advertising or otherwise to promote the sale, use or other deal- -# ings in this Software without prior written authorization from the X Consor- -# tium. -# -# -# FSF changes to this file are in the public domain. -# -# Calling this script install-sh is preferred over install.sh, to prevent -# `make' implicit rules from creating a file called install from it -# when there is no Makefile. -# -# This script is compatible with the BSD install script, but was written -# from scratch. It can only install one file at a time, a restriction -# shared with many OS's install programs. - - -# set DOITPROG to echo to test this script - -# Don't use :- since 4.3BSD and earlier shells don't like it. -doit="${DOITPROG-}" - - -# put in absolute paths if you don't have them in your path; or use env. vars. - -mvprog="${MVPROG-mv}" -cpprog="${CPPROG-cp}" -chmodprog="${CHMODPROG-chmod}" -chownprog="${CHOWNPROG-chown}" -chgrpprog="${CHGRPPROG-chgrp}" -stripprog="${STRIPPROG-strip}" -rmprog="${RMPROG-rm}" -mkdirprog="${MKDIRPROG-mkdir}" - -transformbasename="" -transform_arg="" -instcmd="$mvprog" -chmodcmd="$chmodprog 0755" -chowncmd="" -chgrpcmd="" -stripcmd="" -rmcmd="$rmprog -f" -mvcmd="$mvprog" -src="" -dst="" -dir_arg="" - -while [ x"$1" != x ]; do - case $1 in - -c) instcmd=$cpprog - shift - continue;; - - -d) dir_arg=true - shift - continue;; - - -m) chmodcmd="$chmodprog $2" - shift - shift - continue;; - - -o) chowncmd="$chownprog $2" - shift - shift - continue;; - - -g) chgrpcmd="$chgrpprog $2" - shift - shift - continue;; - - -s) stripcmd=$stripprog - shift - continue;; - - -t=*) transformarg=`echo $1 | sed 's/-t=//'` - shift - continue;; - - -b=*) transformbasename=`echo $1 | sed 's/-b=//'` - shift - continue;; - - *) if [ x"$src" = x ] - then - src=$1 - else - # this colon is to work around a 386BSD /bin/sh bug - : - dst=$1 - fi - shift - continue;; - esac -done - -if [ x"$src" = x ] -then - echo "$0: no input file specified" >&2 - exit 1 -else - : -fi - -if [ x"$dir_arg" != x ]; then - dst=$src - src="" - - if [ -d "$dst" ]; then - instcmd=: - chmodcmd="" - else - instcmd=$mkdirprog - fi -else - -# Waiting for this to be detected by the "$instcmd $src $dsttmp" command -# might cause directories to be created, which would be especially bad -# if $src (and thus $dsttmp) contains '*'. - - if [ -f "$src" ] || [ -d "$src" ] - then - : - else - echo "$0: $src does not exist" >&2 - exit 1 - fi - - if [ x"$dst" = x ] - then - echo "$0: no destination specified" >&2 - exit 1 - else - : - fi - -# If destination is a directory, append the input filename; if your system -# does not like double slashes in filenames, you may need to add some logic - - if [ -d "$dst" ] - then - dst=$dst/`basename "$src"` - else - : - fi -fi - -## this sed command emulates the dirname command -dstdir=`echo "$dst" | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` - -# Make sure that the destination directory exists. -# this part is taken from Noah Friedman's mkinstalldirs script - -# Skip lots of stat calls in the usual case. -if [ ! -d "$dstdir" ]; then -defaultIFS=' - ' -IFS="${IFS-$defaultIFS}" - -oIFS=$IFS -# Some sh's can't handle IFS=/ for some reason. -IFS='%' -set - `echo "$dstdir" | sed -e 's@/@%@g' -e 's@^%@/@'` -IFS=$oIFS - -pathcomp='' - -while [ $# -ne 0 ] ; do - pathcomp=$pathcomp$1 - shift - - if [ ! -d "$pathcomp" ] ; - then - $mkdirprog "$pathcomp" - else - : - fi - - pathcomp=$pathcomp/ -done -fi - -if [ x"$dir_arg" != x ] -then - $doit $instcmd "$dst" && - - if [ x"$chowncmd" != x ]; then $doit $chowncmd "$dst"; else : ; fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd "$dst"; else : ; fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd "$dst"; else : ; fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd "$dst"; else : ; fi -else - -# If we're going to rename the final executable, determine the name now. - - if [ x"$transformarg" = x ] - then - dstfile=`basename "$dst"` - else - dstfile=`basename "$dst" $transformbasename | - sed $transformarg`$transformbasename - fi - -# don't allow the sed command to completely eliminate the filename - - if [ x"$dstfile" = x ] - then - dstfile=`basename "$dst"` - else - : - fi - -# Make a couple of temp file names in the proper directory. - - dsttmp=$dstdir/_inst.$$_ - rmtmp=$dstdir/_rm.$$_ - -# Trap to clean up temp files at exit. - - trap 'status=$?; rm -f "$dsttmp" "$rmtmp" && exit $status' 0 - trap '(exit $?); exit' 1 2 13 15 - -# Move or copy the file name to the temp name - - $doit $instcmd "$src" "$dsttmp" && - -# and set any options; do chmod last to preserve setuid bits - -# If any of these fail, we abort the whole thing. If we want to -# ignore errors from any of these, just make sure not to ignore -# errors from the above "$doit $instcmd $src $dsttmp" command. - - if [ x"$chowncmd" != x ]; then $doit $chowncmd "$dsttmp"; else :;fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd "$dsttmp"; else :;fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd "$dsttmp"; else :;fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd "$dsttmp"; else :;fi && - -# Now remove or move aside any old file at destination location. We try this -# two ways since rm can't unlink itself on some systems and the destination -# file might be busy for other reasons. In this case, the final cleanup -# might fail but the new file should still install successfully. - -{ - if [ -f "$dstdir/$dstfile" ] - then - $doit $rmcmd -f "$dstdir/$dstfile" 2>/dev/null || - $doit $mvcmd -f "$dstdir/$dstfile" "$rmtmp" 2>/dev/null || - { - echo "$0: cannot unlink or rename $dstdir/$dstfile" >&2 - (exit 1); exit - } - else - : - fi -} && - -# Now rename the file to the real destination. - - $doit $mvcmd "$dsttmp" "$dstdir/$dstfile" - -fi && - -# The final little trick to "correctly" pass the exit status to the exit trap. - -{ - (exit 0); exit -} diff --git a/quantum_espresso/kcp/install/.gitignore b/quantum_espresso/kcp/install/.gitignore deleted file mode 100644 index dcce31287..000000000 --- a/quantum_espresso/kcp/install/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -*.inc -autom4te.cache diff --git a/quantum_espresso/kcp/install/Makefile.lib_eigsolve b/quantum_espresso/kcp/install/Makefile.lib_eigsolve deleted file mode 100644 index be620b518..000000000 --- a/quantum_espresso/kcp/install/Makefile.lib_eigsolve +++ /dev/null @@ -1,65 +0,0 @@ -include ../../make.inc - -# Stripped version of F90FLAGS to remove GPU details added explicitly below. -F90FLAGSS := $(filter-out $(CUDA_F90FLAGS),$(F90FLAGS)) - -FLAGS = -O3 -pgf90libs -Mcuda=cc$(GPU_ARCH),cuda$(CUDA_RUNTIME),ptxinfo $(F90FLAGSS) -FLAGS2 = -O3 -pgf90libs -Mcuda=cc$(GPU_ARCH),cuda$(CUDA_RUNTIME),ptxinfo,maxregcount:64 $(F90FLAGSS) - -# For performance reasons, cc of FLAGS3 must be <= 60 -define MIN -$(firstword $(sort ${1} ${2})) -endef -FLAGS3 = -O3 -pgf90libs -Mcuda=cc$(call MIN,${GPU_ARCH},60),cuda$(CUDA_RUNTIME),ptxinfo,nordc,maxregcount:255 $(F90FLAGSS) - -# Uncomment to enable NVTX markers -#OPTFLAGS = -DUSE_NVTX - -all: lib_eigsolve.a - -OBJS = cusolverDn_m.o eigsolve_vars.o toolbox.o zhegst_gpu.o zhemv_gpu.o zhetd2_gpu.o zhetrd_gpu.o zheevd_gpu.o zhegvdx_gpu.o \ - dsygst_gpu.o dsymv_gpu.o dsytd2_gpu.o dsytrd_gpu.o dsyevd_gpu.o dsygvdx_gpu.o - -zhetd2_gpu.o : zhetd2_gpu.F90 - pgf90 -c ${FLAGS2} ${OPTFLAGS} $*.F90 -o $*.o -zhemv_gpu.o : zhemv_gpu.F90 - pgf90 -c ${FLAGS3} ${OPTFLAGS} $*.F90 -o $*.o -dsytd2_gpu.o : dsytd2_gpu.F90 - pgf90 -c ${FLAGS2} ${OPTFLAGS} $*.F90 -o $*.o -dsymv_gpu.o : dsymv_gpu.F90 - pgf90 -c ${FLAGS3} ${OPTFLAGS} $*.F90 -o $*.o -%.o: %.cuf - pgf90 -c ${FLAGS} ${OPTFLAGS} $*.cuf -o $*.o -%.o: %.F90 - pgf90 -c ${FLAGS} ${OPTFLAGS} $*.F90 -o $*.o - -lib_eigsolve.a: $(OBJS) - ar -cr lib_eigsolve.a $(OBJS) - -clean: - rm -f lib_eigsolve.a *.mod *.o - -# Dependencies -dsyevd_gpu.o : dsytrd_gpu.o -dsyevd_gpu.o : eigsolve_vars.o -dsyevd_gpu.o : toolbox.o -dsygst_gpu.o : eigsolve_vars.o -dsygvdx_gpu.o : dsyevd_gpu.o -dsygvdx_gpu.o : dsygst_gpu.o -dsygvdx_gpu.o : eigsolve_vars.o -dsygvdx_gpu.o : toolbox.o -dsytrd_gpu.o : dsymv_gpu.o -dsytrd_gpu.o : dsytd2_gpu.o -dsytrd_gpu.o : eigsolve_vars.o -eigsolve_vars.o : cusolverDn_m.o -zheevd_gpu.o : eigsolve_vars.o -zheevd_gpu.o : toolbox.o -zheevd_gpu.o : zhetrd_gpu.o -zhegst_gpu.o : eigsolve_vars.o -zhegvdx_gpu.o : eigsolve_vars.o -zhegvdx_gpu.o : toolbox.o -zhegvdx_gpu.o : zheevd_gpu.o -zhegvdx_gpu.o : zhegst_gpu.o -zhetrd_gpu.o : eigsolve_vars.o -zhetrd_gpu.o : zhemv_gpu.o -zhetrd_gpu.o : zhetd2_gpu.o diff --git a/quantum_espresso/kcp/install/README.FX10 b/quantum_espresso/kcp/install/README.FX10 deleted file mode 100644 index 8d0250bb0..000000000 --- a/quantum_espresso/kcp/install/README.FX10 +++ /dev/null @@ -1,167 +0,0 @@ -The following is tha "make.inc" file for Fujitsu FX10, a commercial version -of the "K" supercomputer. Mitsuaki Kawamura, March 2017 - -# make.inc. Generated from make.inc.in by configure. - -# compilation rules - -.SUFFIXES : -.SUFFIXES : .o .c .f .f90 - -# most fortran compilers can directly preprocess c-like directives: use -# $(MPIF90) $(F90FLAGS) -c $< -# if explicit preprocessing by the C preprocessor is needed, use: -# $(CPP) $(CPPFLAGS) $< -o $*.F90 -# $(MPIF90) $(F90FLAGS) -c $*.F90 -o $*.o -# remember the tabulator in the first column !!! - -.f90.o: - $(MPIF90) $(F90FLAGS) -c $< - -# .f.o and .c.o: do not modify - -.f.o: - $(F77) $(FFLAGS) -c $< - -.c.o: - $(CC) $(CFLAGS) -c $< - - - -# Top QE directory, useful for locating libraries, linking QE with plugins -# The following syntax should always point to TOPDIR: -TOPDIR = $(dir $(abspath $(filter %make.inc,$(MAKEFILE_LIST)))) -# if it doesn't work, uncomment the following line (edit if needed): - -# TOPDIR = - -# DFLAGS = precompilation options (possible arguments to -D and -U) -# used by the C compiler and preprocessor -# FDFLAGS = as DFLAGS, for the f90 compiler -# See include/defs.h.README for a list of options and their meaning -# With the exception of IBM xlf, FDFLAGS = $(DFLAGS) -# For IBM xlf, FDFLAGS is the same as DFLAGS with separating commas - -# MANUAL_DFLAGS = additional precompilation option(s), if desired -# BEWARE: it does not work for IBM xlf! Manually edit FDFLAGS -MANUAL_DFLAGS = -DFLAGS = -D__FFTW3 -D__MPI -D__PARA -D__SCALAPACK -FDFLAGS = $(DFLAGS) $(MANUAL_DFLAGS) - -# IFLAGS = how to locate directories with *.h or *.f90 file to be included -# typically -I../include -I/some/other/directory/ -# the latter contains .e.g. files needed by FFT libraries - -IFLAGS = -I$(TOPDIR)/include -I../include/ - -# MOD_FLAGS = flag used by f90 compiler to locate modules -# Each Makefile defines the list of needed modules in MODFLAGS - -MOD_FLAG = -I - -# Compilers: fortran-90, fortran-77, C -# If a parallel compilation is desired, MPIF90 should be a fortran-90 -# compiler that produces executables for parallel execution using MPI -# (such as for instance mpif90, mpf90, mpxlf90,...); -# otherwise, an ordinary fortran-90 compiler (f90, g95, xlf90, ifort,...) -# If you have a parallel machine but no suitable candidate for MPIF90, -# try to specify the directory containing "mpif.h" in IFLAGS -# and to specify the location of MPI libraries in MPI_LIBS - -MPIF90 = mpifrtpx -#F90 = frtpx -CC = fccpx -F77 = frtpx - -# C preprocessor and preprocessing flags - for explicit preprocessing, -# if needed (see the compilation rules above) -# preprocessing flags must include DFLAGS and IFLAGS - -CPP = fccpx -CPPFLAGS = -P $(DFLAGS) $(IFLAGS) - -# compiler flags: C, F90, F77 -# C flags must include DFLAGS and IFLAGS -# F90 flags must include MODFLAGS, IFLAGS, and FDFLAGS with appropriate syntax - -CFLAGS = -O3 $(DFLAGS) $(IFLAGS) -F90FLAGS = $(FFLAGS) -Cpp $(FDFLAGS) $(IFLAGS) $(MODFLAGS) -FFLAGS = -Kfast -g -Ksimd=2 -Kprefetch_indirect -KXFILL #-Nquickdbg - -# compiler flags without optimization for fortran-77 -# the latter is NEEDED to properly compile dlamch.f, used by lapack - -FFLAGS_NOOPT = -O0 -g - -# compiler flag needed by some compilers when the main program is not fortran -# Currently used for Yambo - -FFLAGS_NOMAIN = - -# Linker, linker-specific flags (if any) -# Typically LD coincides with F90 or MPIF90, LD_LIBS is empty - -LD = mpifrtpx -LDFLAGS = -g -LD_LIBS = - -# External Libraries (if any) : blas, lapack, fft, MPI - -# If you have nothing better, use the local copy : -# BLAS_LIBS = /your/path/to/espresso/BLAS/blas.a -# BLAS_LIBS_SWITCH = internal - -BLAS_LIBS = -KSPARC64IXfx -SSL2BLAMP -BLAS_LIBS_SWITCH = external - -# If you have nothing better, use the local copy : -# LAPACK_LIBS = /your/path/to/espresso/lapack-3.2/lapack.a -# LAPACK_LIBS_SWITCH = internal -# For IBM machines with essl (-D__ESSL): load essl BEFORE lapack ! -# remember that LAPACK_LIBS precedes BLAS_LIBS in loading order - -LAPACK_LIBS = -LAPACK_LIBS_SWITCH = external - -ELPA_LIBS_SWITCH = disabled -SCALAPACK_LIBS = -SCALAPACK - -# nothing needed here if the the internal copy of FFTW is compiled -# (needs -D__FFTW in DFLAGS) - -FFT_LIBS = -lfftw3 - -# HDF5 -- experimental -HFD5_LIB = - -# For parallel execution, the correct path to MPI libraries must -# be specified in MPI_LIBS (except for IBM if you use mpxlf) - -MPI_LIBS = - -# IBM-specific: MASS libraries, if available and if -D__MASS is defined in FDFLAGS - -MASS_LIBS = - -# ar command and flags - for most architectures: AR = ar, ARFLAGS = ruv - -AR = ar -ARFLAGS = ruv - -# ranlib command. If ranlib is not needed (it isn't in most cases) use -# RANLIB = echo - -RANLIB = ranlib - -# all internal and external libraries - do not modify - -FLIB_TARGETS = all - -LIBOBJS = $(TOPDIR)/clib/clib.a $(TOPDIR)/iotk/src/libiotk.a -LIBS = $(SCALAPACK_LIBS) $(LAPACK_LIBS) $(FFT_LIBS) $(BLAS_LIBS) $(MPI_LIBS) $(MASS_LIBS) ${HFD5_LIB} $(LD_LIBS) - -# wget or curl - useful to download from network -WGET = wget -O - -# Install directory - not currently used -PREFIX = /usr/local diff --git a/quantum_espresso/kcp/install/aclocal.m4 b/quantum_espresso/kcp/install/aclocal.m4 deleted file mode 100644 index 1bf331092..000000000 --- a/quantum_espresso/kcp/install/aclocal.m4 +++ /dev/null @@ -1,39 +0,0 @@ -# generated automatically by aclocal 1.16.2 -*- Autoconf -*- - -# Copyright (C) 1996-2020 Free Software Foundation, Inc. - -# This file is free software; the Free Software Foundation -# gives unlimited permission to copy and/or distribute it, -# with or without modifications, as long as this notice is preserved. - -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY, to the extent permitted by law; without -# even the implied warranty of MERCHANTABILITY or FITNESS FOR A -# PARTICULAR PURPOSE. - -m4_ifndef([AC_CONFIG_MACRO_DIRS], [m4_defun([_AM_CONFIG_MACRO_DIRS], [])m4_defun([AC_CONFIG_MACRO_DIRS], [_AM_CONFIG_MACRO_DIRS($@)])]) -m4_include([m4/ax_check_compile_flag.m4]) -m4_include([m4/x_ac_qe_aix_dflags.m4]) -m4_include([m4/x_ac_qe_ar.m4]) -m4_include([m4/x_ac_qe_arch.m4]) -m4_include([m4/x_ac_qe_blas.m4]) -m4_include([m4/x_ac_qe_cc.m4]) -m4_include([m4/x_ac_qe_cpp.m4]) -m4_include([m4/x_ac_qe_default_env.m4]) -m4_include([m4/x_ac_qe_elpa.m4]) -m4_include([m4/x_ac_qe_environ.m4]) -m4_include([m4/x_ac_qe_f90.m4]) -m4_include([m4/x_ac_qe_f90rule.m4]) -m4_include([m4/x_ac_qe_fft.m4]) -m4_include([m4/x_ac_qe_hdf5.m4]) -m4_include([m4/x_ac_qe_lapack.m4]) -m4_include([m4/x_ac_qe_ld.m4]) -m4_include([m4/x_ac_qe_libxc.m4]) -m4_include([m4/x_ac_qe_mass.m4]) -m4_include([m4/x_ac_qe_mpi.m4]) -m4_include([m4/x_ac_qe_mpif90.m4]) -m4_include([m4/x_ac_qe_openmp.m4]) -m4_include([m4/x_ac_qe_ranlib.m4]) -m4_include([m4/x_ac_qe_scalapack.m4]) -m4_include([m4/x_ac_qe_signal.m4]) -m4_include([m4/x_ac_qe_wget.m4]) diff --git a/quantum_espresso/kcp/install/addsonpatch.sh b/quantum_espresso/kcp/install/addsonpatch.sh deleted file mode 100755 index face8cd61..000000000 --- a/quantum_espresso/kcp/install/addsonpatch.sh +++ /dev/null @@ -1,77 +0,0 @@ -#!/bin/bash -# PATCH SCRIPT FOR QE Makefiles with addson -# - -# this script needs to be launched from the root directory of the host code -# two arguments are neede where the addson source code is and -# where the source code has to be linked in order to be -# compiled by QE - -# This script has been adapted from an original patch script -# of plumed (www.plumed-code.org) - -destination="$PWD" -#echo "root directory of host package: $destination" - -# bisogna prendere il nome del plugin in input -ADDSON_NAME="$1" - -LINKED_FILES="$2/*.f90" -WHERE_LINKS="$3/" - -echo "The NAME of the addson is: $ADDSON_NAME" -echo "LINKED_FILES are: $LINKED_FILES" -echo "WHERE_LINKS are: $WHERE_LINKS" - -function to_do_before_patch () { - echo > /dev/null - cp $destination/make.inc $destination/make.inc.pre$ADDSON_NAME - cp $destination/$WHERE_LINKS/Makefile $destination/$WHERE_LINKS/Makefile.pre$ADDSON_NAME - if test -e $destination/$WHERE_LINKS/make.depend ; then - cp $destination/$WHERE_LINKS/make.depend $destination/$WHERE_LINKS/make.depend.pre$ADDSON_NAME - fi -} - -function to_do_after_patch () { - { - echo -n "${ADDSON_NAME}_OBJECTS=" - for file in $destination/$LINKED_FILES - do f=${file##*/} - echo " \\" - echo -n " ${f%.f90}.o" - done - echo - echo -n "${ADDSON_NAME}_SRC=" - for file in $destination/$LINKED_FILES - do f=${file##*/} - echo " \\" - echo -n " ${f%.f90}.f90" - done - echo - echo - } >> $destination/$WHERE_LINKS/$ADDSON_NAME.inc -} - -function to_do_before_revert () { - rm $destination/$WHERE_LINKS/$ADDSON_NAME.inc - echo > /dev/null -} - -function to_do_after_revert () { - echo > /dev/null - mv $destination/make.inc.pre$ADDSON_NAME $destination/make.inc - mv $destination/$WHERE_LINKS/Makefile.pre$ADDSON_NAME $destination/$WHERE_LINKS/Makefile - if test -e $destination/$WHERE_LINKS/make.depend.pre$ADDSON_NAME ; then \ - mv $destination/$WHERE_LINKS/make.depend.pre$ADDSON_NAME $destination/$WHERE_LINKS/make.depend ; fi -} - -######### - -NAME="$0" -echo "NAME $NAME " -if test -e $destination/install/addsontool.sh ; then - source $destination/install/addsontool.sh -else - echo "missing file addsontool.sh in install directory" - EXIT -fi diff --git a/quantum_espresso/kcp/install/addsontool.sh b/quantum_espresso/kcp/install/addsontool.sh deleted file mode 100755 index a55c22fa4..000000000 --- a/quantum_espresso/kcp/install/addsontool.sh +++ /dev/null @@ -1,190 +0,0 @@ -#!/bin/bash - -# everything is performed in the destination directory -# this script has to be run by addsonpatch.sh -# do not execut it manually - -cd "$destination" - -if [ "$#" -eq 0 ]; -then - echo "[ USAGE :" - echo "./install/addsonpatch.sh ADDSON_NAME WHERE_SOURCE WHERE_LINKS (-patch) (-revert) " - echo " addsonpatch.sh has to be run from the Quantum ESPRESSO root directory" - echo "WHERE_SOURCE is the relative path to the sources of the Addson code " - echo "WHERE_LINKS is the relative path to the QE directory where the addson sources have to be linked" - echo "at the moment it only allows for pure f90 routines to be linked in flib" - echo "or pure f90 modules to be linked in Modules" - echo " -patch : apply patch to Makefiles " - echo " -revert : revert Makefiles to original " - echo " ]" - exit -fi - -case "$4" in -(-patch) - - echo "* I will try to patch needed files for integrated compilation ..." - - if test -e "${ADDSON_NAME}_PATCH" ; then - echo "-- File $destination/${ADDSON_NAME}_PATCH exists" - echo "-- I guess you have already patched $ADDSON_NAME" - echo "-- Please unpatch it first, or start from a clean source tree" - echo "-- See you later..." - echo "* ABORT" - exit - fi - echo "#Please do not remove or modify this file" > ${ADDSON_NAME}_PATCH - echo "#It is keeps track of the steps for patching $ADDSON package" >> ${ADDSON_NAME}_PATCH - -#------------------- - echo "-- Executing pre script" - - command -v patch &>/dev/null || { echo "I require patch command but it's not installed. Aborting." >&2; exit 1; } - -#------------------- check if GNU patch works - cat > test_patch1 << \EOF - alfa - beta -EOF - - cat > test_patch2 << \EOF - alfa - gamma -EOF - - cat > test_patch3 << \EOF_EOF - patch -c -l -b -F 3 --suffix=.pre "./test_patch1" << \EOF -EOF_EOF - - diff -c test_patch1 test_patch2 >> test_patch3 - - echo EOF >> test_patch3 - - bash test_patch3 &> test_patch4 - - status=$? - if [ $status -ne 0 ] - then - echo "patch does not work! Error message:" - echo "**********" - cat test_patch4 - echo "**********" - echo "Please install a recent version of the GNU patch utility and try again." - exit - fi - - rm test_patch1 test_patch2 test_patch3 test_patch4 - if [ -e test_patch1.pre ] - then - rm test_patch1.pre - fi -#------------------------------------------- - - command -v sed &>/dev/null || { echo "I require sed command but it's not installed. Aborting." >&2; exit 1; } - -#------------------- check if GNU sed works - cat > test_sed1 << \EOF - alfa - beta -EOF - - cat > test_sed2 << \EOF - alfa - gamma - beta -EOF - - sed '/alfa/ a\ - gamma' test_sed1 > tmp.1 - - mv tmp.1 test_sed1 - - diff -c test_sed1 test_sed2 >> test_sed3 - -# echo EOF >> test_sed3 - - bash test_sed3 &> test_sed4 - - status=$? - if [ $status -ne 0 ] - then - echo "sed does not work! Error message:" - echo "**********" - cat test_sed4 - echo "**********" - echo "Please install a recent version of the GNU sed utility and try again." - exit - fi - - rm test_sed1 test_sed2 test_sed3 test_sed4 -# ----------------------------------------- -# ----------------------------------------- - to_do_before_patch - - echo "-- Setting up symlinks" - for file in $destination/$LINKED_FILES ; do - base="${file##*/}" - if test -e $destination/$WHERE_LINKS/$base ; then - echo "PATCH ERROR: file $base is already in $WHERE_LINKS" - exit 1 - fi -# echo "$destination/$WHERE_LINKS/$base" - ln -s $file $destination/$WHERE_LINKS/$base - done - - tmp_var=\$\(${ADDSON_NAME}_OBJECTS\) - - echo "-- modifying $WHERE_LINKS/Makefile" - sed < $destination/$WHERE_LINKS/Makefile.pre$ADDSON_NAME > $destination/$WHERE_LINKS/tmp.1 '/make.inc/ a\ - include '"${ADDSON_NAME}"'.inc \ - ' - sed < $destination/$WHERE_LINKS/tmp.1 > $destination/$WHERE_LINKS/Makefile '/= \\/ a\ - '"${tmp_var}"' \\' - - rm $destination/$WHERE_LINKS/tmp.1 - - echo "-- Executing post script" - to_do_after_patch - - echo "- DONE!" -;; -(-revert) - echo "* I will try to revert ..." - echo "-- Executing pre script" - - to_do_before_revert - - - echo "-- Removing symlinks" - for file in $destination/$LINKED_FILES ; do - base="${file##*/}" - if test -e $destination/$WHERE_LINKS/$base ; then \ -# echo "$destination/$WHERE_LINKS/$base" ; \ - rm $destination/$WHERE_LINKS/$base ; \ - else - echo "where_links base: $destination/$WHERE_LINKS/$base" - echo "PATCH WARNING: file $base is not in $destination/$WHERE_LINKS" - fi - done - - - - echo "-- Restoring .pre$ADDSON_NAME files" - PREADDSON=$(find . -name "*.pre*") - if ! test "$PREADDSON" ; then - echo "-- I cannot find any .pre$ADDSON_NAME file" - echo "* ABORT" - exit - fi - - rm ${ADDSON_NAME}_PATCH - - echo "-- Executing post script" - to_do_after_revert - - echo "* DONE!" -;; -(*) - echo "Missing input argument" -esac diff --git a/quantum_espresso/kcp/install/build_fox_with_pgi.sh b/quantum_espresso/kcp/install/build_fox_with_pgi.sh deleted file mode 100644 index fbd9bc5c6..000000000 --- a/quantum_espresso/kcp/install/build_fox_with_pgi.sh +++ /dev/null @@ -1,171 +0,0 @@ -#!/bin/bash - -# This script allows to compile FoX with PGI v.19.10 Community Edition -# on Windows 10 - configure works in general but fails for FoX - -set -x - -rm -rf FoX - -mkdir -p FoX -cd FoX - -tar xvzf ../archive/fox.tgz -cd fox - -myflags="-fast -Mcache_align -Mlarge_arrays -mp " -mydefs="-Mpreprocess -DPGF90 -DFC_HAVE_FLUSH -DFC_HAVE_ABORT -DFC_ABORT_ARG -DFC_EOR_LF" - -mkdir -p objs/lib objs/finclude - -cd fsys -pgfortran $myflags -c $mydefs fox_m_fsys_abort_flush.F90 -o fox_m_fsys_abort_flush.o -pgfortran $myflags -c $mydefs fox_m_fsys_array_str.F90 -o fox_m_fsys_array_str.o -pgfortran $myflags -c fox_m_fsys_realtypes.f90 -o fox_m_fsys_realtypes.o -pgfortran $myflags -c $mydefs fox_m_fsys_format.F90 -o fox_m_fsys_format.o -pgfortran $myflags -c $mydefs fox_m_fsys_parse_input.F90 -o fox_m_fsys_parse_input.o -pgfortran $myflags -c $mydefs fox_m_fsys_count_parse_input.F90 -o fox_m_fsys_count_parse_input.o -pgfortran $myflags -c $mydefs fox_m_fsys_string.F90 -o fox_m_fsys_string.o -pgfortran $myflags -c $mydefs fox_m_fsys_string_list.F90 -o fox_m_fsys_string_list.o -pgfortran $myflags -c $mydefs fox_m_fsys_varstr.F90 -o fox_m_fsys_varstr.o -ar ruv libFoX_fsys.a fox_m_fsys_abort_flush.o fox_m_fsys_array_str.o fox_m_fsys_format.o fox_m_fsys_parse_input.o fox_m_fsys_count_parse_input.o fox_m_fsys_string.o fox_m_fsys_string_list.o fox_m_fsys_realtypes.o fox_m_fsys_varstr.o -cp -p libFoX_fsys.a ../objs/lib/libFoX_fsys.lib -for i in *.mod -do - cp -p $i ../objs/finclude -done -cd .. - -cd utils -pgfortran $myflags -c -I../objs/finclude $mydefs fox_m_utils_mtprng.F90 -o fox_m_utils_mtprng.o -pgfortran $myflags -c -I../objs/finclude $mydefs fox_m_utils_uuid.F90 -o fox_m_utils_uuid.o -pgfortran $myflags -c -I../objs/finclude $mydefs fox_m_utils_uri.F90 -o fox_m_utils_uri.o -pgfortran $myflags -c -I../objs/finclude FoX_utils.f90 -o FoX_utils.o -ar ruv libFoX_utils.a FoX_utils.o fox_m_utils_mtprng.o fox_m_utils_uuid.o fox_m_utils_uri.o -cp -p libFoX_utils.a ../objs/lib/libFoX_utils.lib -for i in *.mod -do - cp -p $i ../objs/finclude -done -cd .. - -cd common -pgfortran $myflags -c -I../objs/finclude $mydefs m_common_charset.F90 -o m_common_charset.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_common_content_model.F90 -o m_common_content_model.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_common_error.F90 -o m_common_error.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_common_namecheck.F90 -o m_common_namecheck.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_common_element.F90 -o m_common_element.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_common_attrs.F90 -o m_common_attrs.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_common_buffer.F90 -o m_common_buffer.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_common_entities.F90 -o m_common_entities.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_common_notations.F90 -o m_common_notations.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_common_struct.F90 -o m_common_struct.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_common_namespaces.F90 -o m_common_namespaces.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_common_elstack.F90 -o m_common_elstack.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_common_io.F90 -o m_common_io.o -pgfortran $myflags -c -I../objs/finclude $mydefs FoX_common.F90 -o FoX_common.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_common_entity_expand.F90 -o m_common_entity_expand.o -ar ruv libFoX_common.a m_common_attrs.o m_common_buffer.o m_common_charset.o m_common_namespaces.o m_common_error.o m_common_elstack.o m_common_io.o FoX_common.o m_common_namecheck.o m_common_entities.o m_common_notations.o m_common_element.o m_common_struct.o m_common_entity_expand.o m_common_content_model.o -cp -p libFoX_common.a ../objs/lib/libFoX_common.lib -for i in *.mod -do - cp -p $i ../objs/finclude -done -cd .. - -cd wxml -pgfortran $myflags -c -I../objs/finclude $mydefs m_wxml_escape.F90 -o m_wxml_escape.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_wxml_core.F90 -o m_wxml_core.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_wxml_overloads.F90 -o m_wxml_overloads.o -pgfortran $myflags -c -I../objs/finclude FoX_wxml.f90 -o FoX_wxml.o -ar ruv libFoX_wxml.a m_wxml_escape.o m_wxml_core.o m_wxml_overloads.o FoX_wxml.o -cp -p libFoX_wxml.a ../objs/lib/libFoX_wxml.lib -for i in *.mod -do - cp -p $i ../objs/finclude -done -cd .. - -cd wcml -pgfortran $myflags -c -I../objs/finclude $mydefs m_wcml_stml.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wcml_coma.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wcml_metadata.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wcml_core.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wcml_geometry.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wcml_lattice.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wcml_lists.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wcml_molecule.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wcml_parameter.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wcml_property.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wcml_inputdec.F90 -pgfortran $myflags -c -I../objs/finclude FoX_wcml.f90 -ar ruv libFoX_wcml.a FoX_wcml.obj m_wcml_coma.obj m_wcml_core.obj m_wcml_stml.obj m_wcml_parameter.obj m_wcml_property.obj m_wcml_metadata.obj m_wcml_lattice.obj m_wcml_geometry.obj m_wcml_molecule.obj m_wcml_lists.obj m_wcml_inputdec.obj -cp -p libFoX_wcml.a ../objs/lib/libFoX_wcml.lib ; -for i in *.mod -do - cp -p $i ../objs/finclude -done -cd .. - -cd wkml -pgfortran $myflags -c -I../objs/finclude $mydefs m_wkml_color_def.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wkml_color.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_contours.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wkml_lowlevel.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wkml_styling.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wkml_core.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wkml_chart.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wkml_features.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wkml_contours.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_wkml_coverage.F90 -pgfortran $myflags -c -I../objs/finclude FoX_wkml.f90 -ar ruv libFoX_wkml.a FoX_wkml.obj m_wkml_lowlevel.obj m_wkml_color.obj m_wkml_styling.obj m_wkml_features.obj m_wkml_coverage.obj m_wkml_core.obj m_wkml_contours.obj m_contours.obj m_wkml_color_def.obj m_wkml_chart.obj -cp -p libFoX_wkml.a ../objs/lib/libFoX_wkml.lib ; -for i in *.mod -do - cp -p $i ../objs/finclude -done -cd .. - -cd sax -pgfortran $myflags -c -I../objs/finclude $mydefs m_sax_xml_source.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_sax_reader.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_sax_types.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_sax_tokenizer.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_sax_parser.F90 -pgfortran $myflags -c -I../objs/finclude $mydefs m_sax_operate.F90 -pgfortran $myflags -c -I../objs/finclude FoX_sax.f90 -ar ruv libFoX_sax.a m_sax_types.obj m_sax_tokenizer.obj m_sax_reader.obj m_sax_parser.obj m_sax_operate.obj m_sax_xml_source.obj FoX_sax.obj -cp -p libFoX_sax.a ../objs/lib/libFoX_sax.lib -for i in *.mod -do - cp -p $i ../objs/finclude -done -cd .. - - -cd dom -pgfortran $myflags -c -I../objs/finclude m_dom_error.f90 -o m_dom_error.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_dom_dom.F90 -o m_dom_dom.o -pgfortran $myflags -c -I../objs/finclude m_dom_parse.f90 -o m_dom_parse.o -pgfortran $myflags -c -I../objs/finclude m_dom_utils.f90 -o m_dom_utils.o -pgfortran $myflags -c -I../objs/finclude $mydefs m_dom_extras.F90 -o m_dom_extras.o -pgfortran $myflags -c -I../objs/finclude FoX_dom.f90 -o FoX_dom.o -ar ruv libFoX_dom.a m_dom_error.o m_dom_parse.o m_dom_utils.o m_dom_extras.o m_dom_dom.o FoX_dom.o -cp -p libFoX_dom.a ../objs/lib/libFoX_dom.lib -for i in *.mod -do - cp -p $i ../objs/finclude -done -cd .. - -chmod 777 objs/lib/* -chmod 777 objs/finclude/* - -cd .. - -mkdir -p lib finclude bin -cp -p fox/objs/lib/* lib -cp -p fox/objs/finclude/* finclude - -cd .. diff --git a/quantum_espresso/kcp/install/config.guess b/quantum_espresso/kcp/install/config.guess deleted file mode 100755 index fddac4281..000000000 --- a/quantum_espresso/kcp/install/config.guess +++ /dev/null @@ -1,1438 +0,0 @@ -#! /bin/sh -# Attempt to guess a canonical system name. -# Copyright 1992-2015 Free Software Foundation, Inc. - -timestamp='2015-07-03' - -# This file is free software; you can redistribute it and/or modify it -# under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, see . -# -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that -# program. This Exception is an additional permission under section 7 -# of the GNU General Public License, version 3 ("GPLv3"). -# -# Originally written by Per Bothner; maintained since 2000 by Ben Elliston. -# -# You can get the latest version of this script from: -# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD -# -# Please send patches to . - - -me=`echo "$0" | sed -e 's,.*/,,'` - -usage="\ -Usage: $0 [OPTION] - -Output the configuration name of the system \`$me' is run on. - -Operation modes: - -h, --help print this help, then exit - -t, --time-stamp print date of last modification, then exit - -v, --version print version number, then exit - -Report bugs and patches to ." - -version="\ -GNU config.guess ($timestamp) - -Originally written by Per Bothner. -Copyright 1992-2015 Free Software Foundation, Inc. - -This is free software; see the source for copying conditions. There is NO -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." - -help=" -Try \`$me --help' for more information." - -# Parse command line -while test $# -gt 0 ; do - case $1 in - --time-stamp | --time* | -t ) - echo "$timestamp" ; exit ;; - --version | -v ) - echo "$version" ; exit ;; - --help | --h* | -h ) - echo "$usage"; exit ;; - -- ) # Stop option processing - shift; break ;; - - ) # Use stdin as input. - break ;; - -* ) - echo "$me: invalid option $1$help" >&2 - exit 1 ;; - * ) - break ;; - esac -done - -if test $# != 0; then - echo "$me: too many arguments$help" >&2 - exit 1 -fi - -trap 'exit 1' 1 2 15 - -# CC_FOR_BUILD -- compiler used by this script. Note that the use of a -# compiler to aid in system detection is discouraged as it requires -# temporary files to be created and, as you can see below, it is a -# headache to deal with in a portable fashion. - -# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still -# use `HOST_CC' if defined, but it is deprecated. - -# Portable tmp directory creation inspired by the Autoconf team. - -set_cc_for_build=' -trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; -trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; -: ${TMPDIR=/tmp} ; - { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || - { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || - { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || - { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; -dummy=$tmp/dummy ; -tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; -case $CC_FOR_BUILD,$HOST_CC,$CC in - ,,) echo "int x;" > $dummy.c ; - for c in cc gcc c89 c99 ; do - if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then - CC_FOR_BUILD="$c"; break ; - fi ; - done ; - if test x"$CC_FOR_BUILD" = x ; then - CC_FOR_BUILD=no_compiler_found ; - fi - ;; - ,,*) CC_FOR_BUILD=$CC ;; - ,*,*) CC_FOR_BUILD=$HOST_CC ;; -esac ; set_cc_for_build= ;' - -# This is needed to find uname on a Pyramid OSx when run in the BSD universe. -# (ghazi@noc.rutgers.edu 1994-08-24) -if (test -f /.attbin/uname) >/dev/null 2>&1 ; then - PATH=$PATH:/.attbin ; export PATH -fi - -UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown -UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown -UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown -UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown - -case "${UNAME_SYSTEM}" in -Linux|GNU|GNU/*) - # If the system lacks a compiler, then just pick glibc. - # We could probably try harder. - LIBC=gnu - - eval $set_cc_for_build - cat <<-EOF > $dummy.c - #include - #if defined(__UCLIBC__) - LIBC=uclibc - #elif defined(__dietlibc__) - LIBC=dietlibc - #else - LIBC=gnu - #endif - EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC' | sed 's, ,,g'` - ;; -esac - -# Note: order is significant - the case branches are not exclusive. - -case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in - *:NetBSD:*:*) - # NetBSD (nbsd) targets should (where applicable) match one or - # more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*, - # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently - # switched to ELF, *-*-netbsd* would select the old - # object file format. This provides both forward - # compatibility and a consistent mechanism for selecting the - # object file format. - # - # Note: NetBSD doesn't particularly care about the vendor - # portion of the name. We always set it to "unknown". - sysctl="sysctl -n hw.machine_arch" - UNAME_MACHINE_ARCH=`(uname -p 2>/dev/null || \ - /sbin/$sysctl 2>/dev/null || \ - /usr/sbin/$sysctl 2>/dev/null || \ - echo unknown)` - case "${UNAME_MACHINE_ARCH}" in - armeb) machine=armeb-unknown ;; - arm*) machine=arm-unknown ;; - sh3el) machine=shl-unknown ;; - sh3eb) machine=sh-unknown ;; - sh5el) machine=sh5le-unknown ;; - earmv*) - arch=`echo ${UNAME_MACHINE_ARCH} | sed -e 's,^e\(armv[0-9]\).*$,\1,'` - endian=`echo ${UNAME_MACHINE_ARCH} | sed -ne 's,^.*\(eb\)$,\1,p'` - machine=${arch}${endian}-unknown - ;; - *) machine=${UNAME_MACHINE_ARCH}-unknown ;; - esac - # The Operating System including object format, if it has switched - # to ELF recently, or will in the future. - case "${UNAME_MACHINE_ARCH}" in - arm*|earm*|i386|m68k|ns32k|sh3*|sparc|vax) - eval $set_cc_for_build - if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep -q __ELF__ - then - # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). - # Return netbsd for either. FIX? - os=netbsd - else - os=netbsdelf - fi - ;; - *) - os=netbsd - ;; - esac - # Determine ABI tags. - case "${UNAME_MACHINE_ARCH}" in - earm*) - expr='s/^earmv[0-9]/-eabi/;s/eb$//' - abi=`echo ${UNAME_MACHINE_ARCH} | sed -e "$expr"` - ;; - esac - # The OS release - # Debian GNU/NetBSD machines have a different userland, and - # thus, need a distinct triplet. However, they do not need - # kernel version information, so it can be replaced with a - # suitable tag, in the style of linux-gnu. - case "${UNAME_VERSION}" in - Debian*) - release='-gnu' - ;; - *) - release=`echo ${UNAME_RELEASE} | sed -e 's/[-_].*//' | cut -d. -f1,2` - ;; - esac - # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: - # contains redundant information, the shorter form: - # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. - echo "${machine}-${os}${release}${abi}" - exit ;; - *:Bitrig:*:*) - UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` - echo ${UNAME_MACHINE_ARCH}-unknown-bitrig${UNAME_RELEASE} - exit ;; - *:OpenBSD:*:*) - UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` - echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} - exit ;; - *:ekkoBSD:*:*) - echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} - exit ;; - *:SolidBSD:*:*) - echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} - exit ;; - macppc:MirBSD:*:*) - echo powerpc-unknown-mirbsd${UNAME_RELEASE} - exit ;; - *:MirBSD:*:*) - echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} - exit ;; - alpha:OSF1:*:*) - case $UNAME_RELEASE in - *4.0) - UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` - ;; - *5.*) - UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` - ;; - esac - # According to Compaq, /usr/sbin/psrinfo has been available on - # OSF/1 and Tru64 systems produced since 1995. I hope that - # covers most systems running today. This code pipes the CPU - # types through head -n 1, so we only detect the type of CPU 0. - ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` - case "$ALPHA_CPU_TYPE" in - "EV4 (21064)") - UNAME_MACHINE="alpha" ;; - "EV4.5 (21064)") - UNAME_MACHINE="alpha" ;; - "LCA4 (21066/21068)") - UNAME_MACHINE="alpha" ;; - "EV5 (21164)") - UNAME_MACHINE="alphaev5" ;; - "EV5.6 (21164A)") - UNAME_MACHINE="alphaev56" ;; - "EV5.6 (21164PC)") - UNAME_MACHINE="alphapca56" ;; - "EV5.7 (21164PC)") - UNAME_MACHINE="alphapca57" ;; - "EV6 (21264)") - UNAME_MACHINE="alphaev6" ;; - "EV6.7 (21264A)") - UNAME_MACHINE="alphaev67" ;; - "EV6.8CB (21264C)") - UNAME_MACHINE="alphaev68" ;; - "EV6.8AL (21264B)") - UNAME_MACHINE="alphaev68" ;; - "EV6.8CX (21264D)") - UNAME_MACHINE="alphaev68" ;; - "EV6.9A (21264/EV69A)") - UNAME_MACHINE="alphaev69" ;; - "EV7 (21364)") - UNAME_MACHINE="alphaev7" ;; - "EV7.9 (21364A)") - UNAME_MACHINE="alphaev79" ;; - esac - # A Pn.n version is a patched version. - # A Vn.n version is a released version. - # A Tn.n version is a released field test version. - # A Xn.n version is an unreleased experimental baselevel. - # 1.2 uses "1.2" for uname -r. - echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - # Reset EXIT trap before exiting to avoid spurious non-zero exit code. - exitcode=$? - trap '' 0 - exit $exitcode ;; - Alpha\ *:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # Should we change UNAME_MACHINE based on the output of uname instead - # of the specific Alpha model? - echo alpha-pc-interix - exit ;; - 21064:Windows_NT:50:3) - echo alpha-dec-winnt3.5 - exit ;; - Amiga*:UNIX_System_V:4.0:*) - echo m68k-unknown-sysv4 - exit ;; - *:[Aa]miga[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-unknown-amigaos - exit ;; - *:[Mm]orph[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-unknown-morphos - exit ;; - *:OS/390:*:*) - echo i370-ibm-openedition - exit ;; - *:z/VM:*:*) - echo s390-ibm-zvmoe - exit ;; - *:OS400:*:*) - echo powerpc-ibm-os400 - exit ;; - arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) - echo arm-acorn-riscix${UNAME_RELEASE} - exit ;; - arm*:riscos:*:*|arm*:RISCOS:*:*) - echo arm-unknown-riscos - exit ;; - SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) - echo hppa1.1-hitachi-hiuxmpp - exit ;; - Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) - # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. - if test "`(/bin/universe) 2>/dev/null`" = att ; then - echo pyramid-pyramid-sysv3 - else - echo pyramid-pyramid-bsd - fi - exit ;; - NILE*:*:*:dcosx) - echo pyramid-pyramid-svr4 - exit ;; - DRS?6000:unix:4.0:6*) - echo sparc-icl-nx6 - exit ;; - DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) - case `/usr/bin/uname -p` in - sparc) echo sparc-icl-nx7; exit ;; - esac ;; - s390x:SunOS:*:*) - echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4H:SunOS:5.*:*) - echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) - echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) - echo i386-pc-auroraux${UNAME_RELEASE} - exit ;; - i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) - eval $set_cc_for_build - SUN_ARCH="i386" - # If there is a compiler, see if it is configured for 64-bit objects. - # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. - # This test works for both compilers. - if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then - if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ - (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ - grep IS_64BIT_ARCH >/dev/null - then - SUN_ARCH="x86_64" - fi - fi - echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4*:SunOS:6*:*) - # According to config.sub, this is the proper way to canonicalize - # SunOS6. Hard to guess exactly what SunOS6 will be like, but - # it's likely to be more like Solaris than SunOS4. - echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4*:SunOS:*:*) - case "`/usr/bin/arch -k`" in - Series*|S4*) - UNAME_RELEASE=`uname -v` - ;; - esac - # Japanese Language versions have a version number like `4.1.3-JL'. - echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` - exit ;; - sun3*:SunOS:*:*) - echo m68k-sun-sunos${UNAME_RELEASE} - exit ;; - sun*:*:4.2BSD:*) - UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` - test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 - case "`/bin/arch`" in - sun3) - echo m68k-sun-sunos${UNAME_RELEASE} - ;; - sun4) - echo sparc-sun-sunos${UNAME_RELEASE} - ;; - esac - exit ;; - aushp:SunOS:*:*) - echo sparc-auspex-sunos${UNAME_RELEASE} - exit ;; - # The situation for MiNT is a little confusing. The machine name - # can be virtually everything (everything which is not - # "atarist" or "atariste" at least should have a processor - # > m68000). The system name ranges from "MiNT" over "FreeMiNT" - # to the lowercase version "mint" (or "freemint"). Finally - # the system name "TOS" denotes a system which is actually not - # MiNT. But MiNT is downward compatible to TOS, so this should - # be no problem. - atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit ;; - atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit ;; - *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit ;; - milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) - echo m68k-milan-mint${UNAME_RELEASE} - exit ;; - hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) - echo m68k-hades-mint${UNAME_RELEASE} - exit ;; - *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) - echo m68k-unknown-mint${UNAME_RELEASE} - exit ;; - m68k:machten:*:*) - echo m68k-apple-machten${UNAME_RELEASE} - exit ;; - powerpc:machten:*:*) - echo powerpc-apple-machten${UNAME_RELEASE} - exit ;; - RISC*:Mach:*:*) - echo mips-dec-mach_bsd4.3 - exit ;; - RISC*:ULTRIX:*:*) - echo mips-dec-ultrix${UNAME_RELEASE} - exit ;; - VAX*:ULTRIX*:*:*) - echo vax-dec-ultrix${UNAME_RELEASE} - exit ;; - 2020:CLIX:*:* | 2430:CLIX:*:*) - echo clipper-intergraph-clix${UNAME_RELEASE} - exit ;; - mips:*:*:UMIPS | mips:*:*:RISCos) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c -#ifdef __cplusplus -#include /* for printf() prototype */ - int main (int argc, char *argv[]) { -#else - int main (argc, argv) int argc; char *argv[]; { -#endif - #if defined (host_mips) && defined (MIPSEB) - #if defined (SYSTYPE_SYSV) - printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); - #endif - #if defined (SYSTYPE_SVR4) - printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); - #endif - #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) - printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); - #endif - #endif - exit (-1); - } -EOF - $CC_FOR_BUILD -o $dummy $dummy.c && - dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && - SYSTEM_NAME=`$dummy $dummyarg` && - { echo "$SYSTEM_NAME"; exit; } - echo mips-mips-riscos${UNAME_RELEASE} - exit ;; - Motorola:PowerMAX_OS:*:*) - echo powerpc-motorola-powermax - exit ;; - Motorola:*:4.3:PL8-*) - echo powerpc-harris-powermax - exit ;; - Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) - echo powerpc-harris-powermax - exit ;; - Night_Hawk:Power_UNIX:*:*) - echo powerpc-harris-powerunix - exit ;; - m88k:CX/UX:7*:*) - echo m88k-harris-cxux7 - exit ;; - m88k:*:4*:R4*) - echo m88k-motorola-sysv4 - exit ;; - m88k:*:3*:R3*) - echo m88k-motorola-sysv3 - exit ;; - AViiON:dgux:*:*) - # DG/UX returns AViiON for all architectures - UNAME_PROCESSOR=`/usr/bin/uname -p` - if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] - then - if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ - [ ${TARGET_BINARY_INTERFACE}x = x ] - then - echo m88k-dg-dgux${UNAME_RELEASE} - else - echo m88k-dg-dguxbcs${UNAME_RELEASE} - fi - else - echo i586-dg-dgux${UNAME_RELEASE} - fi - exit ;; - M88*:DolphinOS:*:*) # DolphinOS (SVR3) - echo m88k-dolphin-sysv3 - exit ;; - M88*:*:R3*:*) - # Delta 88k system running SVR3 - echo m88k-motorola-sysv3 - exit ;; - XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) - echo m88k-tektronix-sysv3 - exit ;; - Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) - echo m68k-tektronix-bsd - exit ;; - *:IRIX*:*:*) - echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` - exit ;; - ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. - echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id - exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' - i*86:AIX:*:*) - echo i386-ibm-aix - exit ;; - ia64:AIX:*:*) - if [ -x /usr/bin/oslevel ] ; then - IBM_REV=`/usr/bin/oslevel` - else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} - fi - echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} - exit ;; - *:AIX:2:3) - if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - - main() - { - if (!__power_pc()) - exit(1); - puts("powerpc-ibm-aix3.2.5"); - exit(0); - } -EOF - if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` - then - echo "$SYSTEM_NAME" - else - echo rs6000-ibm-aix3.2.5 - fi - elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then - echo rs6000-ibm-aix3.2.4 - else - echo rs6000-ibm-aix3.2 - fi - exit ;; - *:AIX:*:[4567]) - IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` - if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then - IBM_ARCH=rs6000 - else - IBM_ARCH=powerpc - fi - if [ -x /usr/bin/lslpp ] ; then - IBM_REV=`/usr/bin/lslpp -Lqc bos.rte.libc | - awk -F: '{ print $3 }' | sed s/[0-9]*$/0/` - else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} - fi - echo ${IBM_ARCH}-ibm-aix${IBM_REV} - exit ;; - *:AIX:*:*) - echo rs6000-ibm-aix - exit ;; - ibmrt:4.4BSD:*|romp-ibm:BSD:*) - echo romp-ibm-bsd4.4 - exit ;; - ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and - echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to - exit ;; # report: romp-ibm BSD 4.3 - *:BOSX:*:*) - echo rs6000-bull-bosx - exit ;; - DPX/2?00:B.O.S.:*:*) - echo m68k-bull-sysv3 - exit ;; - 9000/[34]??:4.3bsd:1.*:*) - echo m68k-hp-bsd - exit ;; - hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) - echo m68k-hp-bsd4.4 - exit ;; - 9000/[34678]??:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - case "${UNAME_MACHINE}" in - 9000/31? ) HP_ARCH=m68000 ;; - 9000/[34]?? ) HP_ARCH=m68k ;; - 9000/[678][0-9][0-9]) - if [ -x /usr/bin/getconf ]; then - sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` - sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` - case "${sc_cpu_version}" in - 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 - 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 - 532) # CPU_PA_RISC2_0 - case "${sc_kernel_bits}" in - 32) HP_ARCH="hppa2.0n" ;; - 64) HP_ARCH="hppa2.0w" ;; - '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 - esac ;; - esac - fi - if [ "${HP_ARCH}" = "" ]; then - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - - #define _HPUX_SOURCE - #include - #include - - int main () - { - #if defined(_SC_KERNEL_BITS) - long bits = sysconf(_SC_KERNEL_BITS); - #endif - long cpu = sysconf (_SC_CPU_VERSION); - - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1"); break; - case CPU_PA_RISC2_0: - #if defined(_SC_KERNEL_BITS) - switch (bits) - { - case 64: puts ("hppa2.0w"); break; - case 32: puts ("hppa2.0n"); break; - default: puts ("hppa2.0"); break; - } break; - #else /* !defined(_SC_KERNEL_BITS) */ - puts ("hppa2.0"); break; - #endif - default: puts ("hppa1.0"); break; - } - exit (0); - } -EOF - (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` - test -z "$HP_ARCH" && HP_ARCH=hppa - fi ;; - esac - if [ ${HP_ARCH} = "hppa2.0w" ] - then - eval $set_cc_for_build - - # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating - # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler - # generating 64-bit code. GNU and HP use different nomenclature: - # - # $ CC_FOR_BUILD=cc ./config.guess - # => hppa2.0w-hp-hpux11.23 - # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess - # => hppa64-hp-hpux11.23 - - if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | - grep -q __LP64__ - then - HP_ARCH="hppa2.0w" - else - HP_ARCH="hppa64" - fi - fi - echo ${HP_ARCH}-hp-hpux${HPUX_REV} - exit ;; - ia64:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - echo ia64-hp-hpux${HPUX_REV} - exit ;; - 3050*:HI-UX:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - int - main () - { - long cpu = sysconf (_SC_CPU_VERSION); - /* The order matters, because CPU_IS_HP_MC68K erroneously returns - true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct - results, however. */ - if (CPU_IS_PA_RISC (cpu)) - { - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; - case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; - default: puts ("hppa-hitachi-hiuxwe2"); break; - } - } - else if (CPU_IS_HP_MC68K (cpu)) - puts ("m68k-hitachi-hiuxwe2"); - else puts ("unknown-hitachi-hiuxwe2"); - exit (0); - } -EOF - $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && - { echo "$SYSTEM_NAME"; exit; } - echo unknown-hitachi-hiuxwe2 - exit ;; - 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) - echo hppa1.1-hp-bsd - exit ;; - 9000/8??:4.3bsd:*:*) - echo hppa1.0-hp-bsd - exit ;; - *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) - echo hppa1.0-hp-mpeix - exit ;; - hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) - echo hppa1.1-hp-osf - exit ;; - hp8??:OSF1:*:*) - echo hppa1.0-hp-osf - exit ;; - i*86:OSF1:*:*) - if [ -x /usr/sbin/sysversion ] ; then - echo ${UNAME_MACHINE}-unknown-osf1mk - else - echo ${UNAME_MACHINE}-unknown-osf1 - fi - exit ;; - parisc*:Lites*:*:*) - echo hppa1.1-hp-lites - exit ;; - C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) - echo c1-convex-bsd - exit ;; - C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit ;; - C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) - echo c34-convex-bsd - exit ;; - C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) - echo c38-convex-bsd - exit ;; - C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) - echo c4-convex-bsd - exit ;; - CRAY*Y-MP:*:*:*) - echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*[A-Z]90:*:*:*) - echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ - | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ - -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ - -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*TS:*:*:*) - echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*T3E:*:*:*) - echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*SV1:*:*:*) - echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - *:UNICOS/mp:*:*) - echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) - FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` - echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" - exit ;; - 5000:UNIX_System_V:4.*:*) - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` - echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" - exit ;; - i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) - echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} - exit ;; - sparc*:BSD/OS:*:*) - echo sparc-unknown-bsdi${UNAME_RELEASE} - exit ;; - *:BSD/OS:*:*) - echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} - exit ;; - *:FreeBSD:*:*) - UNAME_PROCESSOR=`/usr/bin/uname -p` - case ${UNAME_PROCESSOR} in - amd64) - echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - *) - echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - esac - exit ;; - i*:CYGWIN*:*) - echo ${UNAME_MACHINE}-pc-cygwin - exit ;; - *:MINGW64*:*) - echo ${UNAME_MACHINE}-pc-mingw64 - exit ;; - *:MINGW*:*) - echo ${UNAME_MACHINE}-pc-mingw32 - exit ;; - *:MSYS*:*) - echo ${UNAME_MACHINE}-pc-msys - exit ;; - i*:windows32*:*) - # uname -m includes "-pc" on this system. - echo ${UNAME_MACHINE}-mingw32 - exit ;; - i*:PW*:*) - echo ${UNAME_MACHINE}-pc-pw32 - exit ;; - *:Interix*:*) - case ${UNAME_MACHINE} in - x86) - echo i586-pc-interix${UNAME_RELEASE} - exit ;; - authenticamd | genuineintel | EM64T) - echo x86_64-unknown-interix${UNAME_RELEASE} - exit ;; - IA64) - echo ia64-unknown-interix${UNAME_RELEASE} - exit ;; - esac ;; - [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) - echo i${UNAME_MACHINE}-pc-mks - exit ;; - 8664:Windows_NT:*) - echo x86_64-pc-mks - exit ;; - i*:Windows_NT*:* | Pentium*:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we - # UNAME_MACHINE based on the output of uname instead of i386? - echo i586-pc-interix - exit ;; - i*:UWIN*:*) - echo ${UNAME_MACHINE}-pc-uwin - exit ;; - amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) - echo x86_64-unknown-cygwin - exit ;; - p*:CYGWIN*:*) - echo powerpcle-unknown-cygwin - exit ;; - prep*:SunOS:5.*:*) - echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - *:GNU:*:*) - # the GNU system - echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-${LIBC}`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` - exit ;; - *:GNU/*:*:*) - # other systems with GNU libc and userland - echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-${LIBC} - exit ;; - i*86:Minix:*:*) - echo ${UNAME_MACHINE}-pc-minix - exit ;; - aarch64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - aarch64_be:Linux:*:*) - UNAME_MACHINE=aarch64_be - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - alpha:Linux:*:*) - case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in - EV5) UNAME_MACHINE=alphaev5 ;; - EV56) UNAME_MACHINE=alphaev56 ;; - PCA56) UNAME_MACHINE=alphapca56 ;; - PCA57) UNAME_MACHINE=alphapca56 ;; - EV6) UNAME_MACHINE=alphaev6 ;; - EV67) UNAME_MACHINE=alphaev67 ;; - EV68*) UNAME_MACHINE=alphaev68 ;; - esac - objdump --private-headers /bin/sh | grep -q ld.so.1 - if test "$?" = 0 ; then LIBC="gnulibc1" ; fi - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - arc:Linux:*:* | arceb:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - arm*:Linux:*:*) - eval $set_cc_for_build - if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep -q __ARM_EABI__ - then - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - else - if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep -q __ARM_PCS_VFP - then - echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabi - else - echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabihf - fi - fi - exit ;; - avr32*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - cris:Linux:*:*) - echo ${UNAME_MACHINE}-axis-linux-${LIBC} - exit ;; - crisv32:Linux:*:*) - echo ${UNAME_MACHINE}-axis-linux-${LIBC} - exit ;; - e2k:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - frv:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - hexagon:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - i*86:Linux:*:*) - echo ${UNAME_MACHINE}-pc-linux-${LIBC} - exit ;; - ia64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - m32r*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - m68*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - mips:Linux:*:* | mips64:Linux:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #undef CPU - #undef ${UNAME_MACHINE} - #undef ${UNAME_MACHINE}el - #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) - CPU=${UNAME_MACHINE}el - #else - #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) - CPU=${UNAME_MACHINE} - #else - CPU= - #endif - #endif -EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` - test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; } - ;; - openrisc*:Linux:*:*) - echo or1k-unknown-linux-${LIBC} - exit ;; - or32:Linux:*:* | or1k*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - padre:Linux:*:*) - echo sparc-unknown-linux-${LIBC} - exit ;; - parisc64:Linux:*:* | hppa64:Linux:*:*) - echo hppa64-unknown-linux-${LIBC} - exit ;; - parisc:Linux:*:* | hppa:Linux:*:*) - # Look for CPU level - case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in - PA7*) echo hppa1.1-unknown-linux-${LIBC} ;; - PA8*) echo hppa2.0-unknown-linux-${LIBC} ;; - *) echo hppa-unknown-linux-${LIBC} ;; - esac - exit ;; - ppc64:Linux:*:*) - echo powerpc64-unknown-linux-${LIBC} - exit ;; - ppc:Linux:*:*) - echo powerpc-unknown-linux-${LIBC} - exit ;; - ppc64le:Linux:*:*) - echo powerpc64le-unknown-linux-${LIBC} - exit ;; - ppcle:Linux:*:*) - echo powerpcle-unknown-linux-${LIBC} - exit ;; - s390:Linux:*:* | s390x:Linux:*:*) - echo ${UNAME_MACHINE}-ibm-linux-${LIBC} - exit ;; - sh64*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - sh*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - sparc:Linux:*:* | sparc64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - tile*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - vax:Linux:*:*) - echo ${UNAME_MACHINE}-dec-linux-${LIBC} - exit ;; - x86_64:Linux:*:*) - echo ${UNAME_MACHINE}-pc-linux-${LIBC} - exit ;; - xtensa*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} - exit ;; - i*86:DYNIX/ptx:4*:*) - # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. - # earlier versions are messed up and put the nodename in both - # sysname and nodename. - echo i386-sequent-sysv4 - exit ;; - i*86:UNIX_SV:4.2MP:2.*) - # Unixware is an offshoot of SVR4, but it has its own version - # number series starting with 2... - # I am not positive that other SVR4 systems won't match this, - # I just have to hope. -- rms. - # Use sysv4.2uw... so that sysv4* matches it. - echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} - exit ;; - i*86:OS/2:*:*) - # If we were able to find `uname', then EMX Unix compatibility - # is probably installed. - echo ${UNAME_MACHINE}-pc-os2-emx - exit ;; - i*86:XTS-300:*:STOP) - echo ${UNAME_MACHINE}-unknown-stop - exit ;; - i*86:atheos:*:*) - echo ${UNAME_MACHINE}-unknown-atheos - exit ;; - i*86:syllable:*:*) - echo ${UNAME_MACHINE}-pc-syllable - exit ;; - i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) - echo i386-unknown-lynxos${UNAME_RELEASE} - exit ;; - i*86:*DOS:*:*) - echo ${UNAME_MACHINE}-pc-msdosdjgpp - exit ;; - i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) - UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` - if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then - echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} - else - echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} - fi - exit ;; - i*86:*:5:[678]*) - # UnixWare 7.x, OpenUNIX and OpenServer 6. - case `/bin/uname -X | grep "^Machine"` in - *486*) UNAME_MACHINE=i486 ;; - *Pentium) UNAME_MACHINE=i586 ;; - *Pent*|*Celeron) UNAME_MACHINE=i686 ;; - esac - echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} - exit ;; - i*86:*:3.2:*) - if test -f /usr/options/cb.name; then - UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then - UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` - (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 - (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ - && UNAME_MACHINE=i586 - (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ - && UNAME_MACHINE=i686 - (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ - && UNAME_MACHINE=i686 - echo ${UNAME_MACHINE}-pc-sco$UNAME_REL - else - echo ${UNAME_MACHINE}-pc-sysv32 - fi - exit ;; - pc:*:*:*) - # Left here for compatibility: - # uname -m prints for DJGPP always 'pc', but it prints nothing about - # the processor, so we play safe by assuming i586. - # Note: whatever this is, it MUST be the same as what config.sub - # prints for the "djgpp" host, or else GDB configury will decide that - # this is a cross-build. - echo i586-pc-msdosdjgpp - exit ;; - Intel:Mach:3*:*) - echo i386-pc-mach3 - exit ;; - paragon:*:*:*) - echo i860-intel-osf1 - exit ;; - i860:*:4.*:*) # i860-SVR4 - if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then - echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 - else # Add other i860-SVR4 vendors below as they are discovered. - echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 - fi - exit ;; - mini*:CTIX:SYS*5:*) - # "miniframe" - echo m68010-convergent-sysv - exit ;; - mc68k:UNIX:SYSTEM5:3.51m) - echo m68k-convergent-sysv - exit ;; - M680?0:D-NIX:5.3:*) - echo m68k-diab-dnix - exit ;; - M68*:*:R3V[5678]*:*) - test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; - 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) - OS_REL='' - test -r /etc/.relid \ - && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && { echo i486-ncr-sysv4.3${OS_REL}; exit; } - /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ - && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; - 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && { echo i486-ncr-sysv4; exit; } ;; - NCR*:*:4.2:* | MPRAS*:*:4.2:*) - OS_REL='.3' - test -r /etc/.relid \ - && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && { echo i486-ncr-sysv4.3${OS_REL}; exit; } - /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ - && { echo i586-ncr-sysv4.3${OS_REL}; exit; } - /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ - && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; - m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) - echo m68k-unknown-lynxos${UNAME_RELEASE} - exit ;; - mc68030:UNIX_System_V:4.*:*) - echo m68k-atari-sysv4 - exit ;; - TSUNAMI:LynxOS:2.*:*) - echo sparc-unknown-lynxos${UNAME_RELEASE} - exit ;; - rs6000:LynxOS:2.*:*) - echo rs6000-unknown-lynxos${UNAME_RELEASE} - exit ;; - PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) - echo powerpc-unknown-lynxos${UNAME_RELEASE} - exit ;; - SM[BE]S:UNIX_SV:*:*) - echo mips-dde-sysv${UNAME_RELEASE} - exit ;; - RM*:ReliantUNIX-*:*:*) - echo mips-sni-sysv4 - exit ;; - RM*:SINIX-*:*:*) - echo mips-sni-sysv4 - exit ;; - *:SINIX-*:*:*) - if uname -p 2>/dev/null >/dev/null ; then - UNAME_MACHINE=`(uname -p) 2>/dev/null` - echo ${UNAME_MACHINE}-sni-sysv4 - else - echo ns32k-sni-sysv - fi - exit ;; - PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort - # says - echo i586-unisys-sysv4 - exit ;; - *:UNIX_System_V:4*:FTX*) - # From Gerald Hewes . - # How about differentiating between stratus architectures? -djm - echo hppa1.1-stratus-sysv4 - exit ;; - *:*:*:FTX*) - # From seanf@swdc.stratus.com. - echo i860-stratus-sysv4 - exit ;; - i*86:VOS:*:*) - # From Paul.Green@stratus.com. - echo ${UNAME_MACHINE}-stratus-vos - exit ;; - *:VOS:*:*) - # From Paul.Green@stratus.com. - echo hppa1.1-stratus-vos - exit ;; - mc68*:A/UX:*:*) - echo m68k-apple-aux${UNAME_RELEASE} - exit ;; - news*:NEWS-OS:6*:*) - echo mips-sony-newsos6 - exit ;; - R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) - if [ -d /usr/nec ]; then - echo mips-nec-sysv${UNAME_RELEASE} - else - echo mips-unknown-sysv${UNAME_RELEASE} - fi - exit ;; - BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. - echo powerpc-be-beos - exit ;; - BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. - echo powerpc-apple-beos - exit ;; - BePC:BeOS:*:*) # BeOS running on Intel PC compatible. - echo i586-pc-beos - exit ;; - BePC:Haiku:*:*) # Haiku running on Intel PC compatible. - echo i586-pc-haiku - exit ;; - x86_64:Haiku:*:*) - echo x86_64-unknown-haiku - exit ;; - SX-4:SUPER-UX:*:*) - echo sx4-nec-superux${UNAME_RELEASE} - exit ;; - SX-5:SUPER-UX:*:*) - echo sx5-nec-superux${UNAME_RELEASE} - exit ;; - SX-6:SUPER-UX:*:*) - echo sx6-nec-superux${UNAME_RELEASE} - exit ;; - SX-7:SUPER-UX:*:*) - echo sx7-nec-superux${UNAME_RELEASE} - exit ;; - SX-8:SUPER-UX:*:*) - echo sx8-nec-superux${UNAME_RELEASE} - exit ;; - SX-8R:SUPER-UX:*:*) - echo sx8r-nec-superux${UNAME_RELEASE} - exit ;; - Power*:Rhapsody:*:*) - echo powerpc-apple-rhapsody${UNAME_RELEASE} - exit ;; - *:Rhapsody:*:*) - echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} - exit ;; - *:Darwin:*:*) - UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown - eval $set_cc_for_build - if test "$UNAME_PROCESSOR" = unknown ; then - UNAME_PROCESSOR=powerpc - fi - if test `echo "$UNAME_RELEASE" | sed -e 's/\..*//'` -le 10 ; then - if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then - if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ - (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ - grep IS_64BIT_ARCH >/dev/null - then - case $UNAME_PROCESSOR in - i386) UNAME_PROCESSOR=x86_64 ;; - powerpc) UNAME_PROCESSOR=powerpc64 ;; - esac - fi - fi - elif test "$UNAME_PROCESSOR" = i386 ; then - # Avoid executing cc on OS X 10.9, as it ships with a stub - # that puts up a graphical alert prompting to install - # developer tools. Any system running Mac OS X 10.7 or - # later (Darwin 11 and later) is required to have a 64-bit - # processor. This is not true of the ARM version of Darwin - # that Apple uses in portable devices. - UNAME_PROCESSOR=x86_64 - fi - echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} - exit ;; - *:procnto*:*:* | *:QNX:[0123456789]*:*) - UNAME_PROCESSOR=`uname -p` - if test "$UNAME_PROCESSOR" = "x86"; then - UNAME_PROCESSOR=i386 - UNAME_MACHINE=pc - fi - echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} - exit ;; - *:QNX:*:4*) - echo i386-pc-qnx - exit ;; - NEO-?:NONSTOP_KERNEL:*:*) - echo neo-tandem-nsk${UNAME_RELEASE} - exit ;; - NSE-*:NONSTOP_KERNEL:*:*) - echo nse-tandem-nsk${UNAME_RELEASE} - exit ;; - NSR-?:NONSTOP_KERNEL:*:*) - echo nsr-tandem-nsk${UNAME_RELEASE} - exit ;; - *:NonStop-UX:*:*) - echo mips-compaq-nonstopux - exit ;; - BS2000:POSIX*:*:*) - echo bs2000-siemens-sysv - exit ;; - DS/*:UNIX_System_V:*:*) - echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} - exit ;; - *:Plan9:*:*) - # "uname -m" is not consistent, so use $cputype instead. 386 - # is converted to i386 for consistency with other x86 - # operating systems. - if test "$cputype" = "386"; then - UNAME_MACHINE=i386 - else - UNAME_MACHINE="$cputype" - fi - echo ${UNAME_MACHINE}-unknown-plan9 - exit ;; - *:TOPS-10:*:*) - echo pdp10-unknown-tops10 - exit ;; - *:TENEX:*:*) - echo pdp10-unknown-tenex - exit ;; - KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) - echo pdp10-dec-tops20 - exit ;; - XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) - echo pdp10-xkl-tops20 - exit ;; - *:TOPS-20:*:*) - echo pdp10-unknown-tops20 - exit ;; - *:ITS:*:*) - echo pdp10-unknown-its - exit ;; - SEI:*:*:SEIUX) - echo mips-sei-seiux${UNAME_RELEASE} - exit ;; - *:DragonFly:*:*) - echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` - exit ;; - *:*VMS:*:*) - UNAME_MACHINE=`(uname -p) 2>/dev/null` - case "${UNAME_MACHINE}" in - A*) echo alpha-dec-vms ; exit ;; - I*) echo ia64-dec-vms ; exit ;; - V*) echo vax-dec-vms ; exit ;; - esac ;; - *:XENIX:*:SysV) - echo i386-pc-xenix - exit ;; - i*86:skyos:*:*) - echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' - exit ;; - i*86:rdos:*:*) - echo ${UNAME_MACHINE}-pc-rdos - exit ;; - i*86:AROS:*:*) - echo ${UNAME_MACHINE}-pc-aros - exit ;; - x86_64:VMkernel:*:*) - echo ${UNAME_MACHINE}-unknown-esx - exit ;; -esac - -cat >&2 < in order to provide the needed -information to handle your system. - -config.guess timestamp = $timestamp - -uname -m = `(uname -m) 2>/dev/null || echo unknown` -uname -r = `(uname -r) 2>/dev/null || echo unknown` -uname -s = `(uname -s) 2>/dev/null || echo unknown` -uname -v = `(uname -v) 2>/dev/null || echo unknown` - -/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` -/bin/uname -X = `(/bin/uname -X) 2>/dev/null` - -hostinfo = `(hostinfo) 2>/dev/null` -/bin/universe = `(/bin/universe) 2>/dev/null` -/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` -/bin/arch = `(/bin/arch) 2>/dev/null` -/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` -/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` - -UNAME_MACHINE = ${UNAME_MACHINE} -UNAME_RELEASE = ${UNAME_RELEASE} -UNAME_SYSTEM = ${UNAME_SYSTEM} -UNAME_VERSION = ${UNAME_VERSION} -EOF - -exit 1 - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "timestamp='" -# time-stamp-format: "%:y-%02m-%02d" -# time-stamp-end: "'" -# End: diff --git a/quantum_espresso/kcp/install/config.sub b/quantum_espresso/kcp/install/config.sub deleted file mode 100644 index f018151c6..000000000 --- a/quantum_espresso/kcp/install/config.sub +++ /dev/null @@ -1,1813 +0,0 @@ -#! /bin/sh -# Configuration validation subroutine script. -# Copyright 1992-2015 Free Software Foundation, Inc. - -timestamp='2015-07-28' - -# This file is free software; you can redistribute it and/or modify it -# under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, see . -# -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that -# program. This Exception is an additional permission under section 7 -# of the GNU General Public License, version 3 ("GPLv3"). - - -# Please send patches to . -# -# Configuration subroutine to validate and canonicalize a configuration type. -# Supply the specified configuration type as an argument. -# If it is invalid, we print an error message on stderr and exit with code 1. -# Otherwise, we print the canonical config type on stdout and succeed. - -# You can get the latest version of this script from: -# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD - -# This file is supposed to be the same for all GNU packages -# and recognize all the CPU types, system types and aliases -# that are meaningful with *any* GNU software. -# Each package is responsible for reporting which valid configurations -# it does not support. The user should be able to distinguish -# a failure to support a valid configuration from a meaningless -# configuration. - -# The goal of this file is to map all the various variations of a given -# machine specification into a single specification in the form: -# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM -# or in some cases, the newer four-part form: -# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM -# It is wrong to echo any other type of specification. - -me=`echo "$0" | sed -e 's,.*/,,'` - -usage="\ -Usage: $0 [OPTION] CPU-MFR-OPSYS - $0 [OPTION] ALIAS - -Canonicalize a configuration name. - -Operation modes: - -h, --help print this help, then exit - -t, --time-stamp print date of last modification, then exit - -v, --version print version number, then exit - -Report bugs and patches to ." - -version="\ -GNU config.sub ($timestamp) - -Copyright 1992-2015 Free Software Foundation, Inc. - -This is free software; see the source for copying conditions. There is NO -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." - -help=" -Try \`$me --help' for more information." - -# Parse command line -while test $# -gt 0 ; do - case $1 in - --time-stamp | --time* | -t ) - echo "$timestamp" ; exit ;; - --version | -v ) - echo "$version" ; exit ;; - --help | --h* | -h ) - echo "$usage"; exit ;; - -- ) # Stop option processing - shift; break ;; - - ) # Use stdin as input. - break ;; - -* ) - echo "$me: invalid option $1$help" - exit 1 ;; - - *local*) - # First pass through any local machine types. - echo $1 - exit ;; - - * ) - break ;; - esac -done - -case $# in - 0) echo "$me: missing argument$help" >&2 - exit 1;; - 1) ;; - *) echo "$me: too many arguments$help" >&2 - exit 1;; -esac - -# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). -# Here we must recognize all the valid KERNEL-OS combinations. -maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` -case $maybe_os in - nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ - linux-musl* | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ - knetbsd*-gnu* | netbsd*-gnu* | netbsd*-eabi* | \ - kopensolaris*-gnu* | \ - storm-chaos* | os2-emx* | rtmk-nova*) - os=-$maybe_os - basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` - ;; - android-linux) - os=-linux-android - basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`-unknown - ;; - *) - basic_machine=`echo $1 | sed 's/-[^-]*$//'` - if [ $basic_machine != $1 ] - then os=`echo $1 | sed 's/.*-/-/'` - else os=; fi - ;; -esac - -### Let's recognize common machines as not being operating systems so -### that things like config.sub decstation-3100 work. We also -### recognize some manufacturers as not being operating systems, so we -### can provide default operating systems below. -case $os in - -sun*os*) - # Prevent following clause from handling this invalid input. - ;; - -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ - -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ - -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ - -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ - -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ - -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ - -apple | -axis | -knuth | -cray | -microblaze*) - os= - basic_machine=$1 - ;; - -bluegene*) - os=-cnk - ;; - -sim | -cisco | -oki | -wec | -winbond) - os= - basic_machine=$1 - ;; - -scout) - ;; - -wrs) - os=-vxworks - basic_machine=$1 - ;; - -chorusos*) - os=-chorusos - basic_machine=$1 - ;; - -chorusrdb) - os=-chorusrdb - basic_machine=$1 - ;; - -hiux*) - os=-hiuxwe2 - ;; - -sco6) - os=-sco5v6 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco5) - os=-sco3.2v5 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco4) - os=-sco3.2v4 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco3.2.[4-9]*) - os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco3.2v[4-9]*) - # Don't forget version if it is 3.2v4 or newer. - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco5v6*) - # Don't forget version if it is 3.2v4 or newer. - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco*) - os=-sco3.2v2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -udk*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -isc) - os=-isc2.2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -clix*) - basic_machine=clipper-intergraph - ;; - -isc*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -lynx*178) - os=-lynxos178 - ;; - -lynx*5) - os=-lynxos5 - ;; - -lynx*) - os=-lynxos - ;; - -ptx*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` - ;; - -windowsnt*) - os=`echo $os | sed -e 's/windowsnt/winnt/'` - ;; - -psos*) - os=-psos - ;; - -mint | -mint[0-9]*) - basic_machine=m68k-atari - os=-mint - ;; -esac - -# Decode aliases for certain CPU-COMPANY combinations. -case $basic_machine in - # Recognize the basic CPU types without company name. - # Some are omitted here because they have special meanings below. - 1750a | 580 \ - | a29k \ - | aarch64 | aarch64_be \ - | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ - | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ - | am33_2.0 \ - | arc | arceb \ - | arm | arm[bl]e | arme[lb] | armv[2-8] | armv[3-8][lb] | armv7[arm] \ - | avr | avr32 \ - | ba \ - | be32 | be64 \ - | bfin \ - | c4x | c8051 | clipper \ - | d10v | d30v | dlx | dsp16xx \ - | e2k | epiphany \ - | fido | fr30 | frv | ft32 \ - | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ - | hexagon \ - | i370 | i860 | i960 | ia64 \ - | ip2k | iq2000 \ - | k1om \ - | le32 | le64 \ - | lm32 \ - | m32c | m32r | m32rle | m68000 | m68k | m88k \ - | maxq | mb | microblaze | microblazeel | mcore | mep | metag \ - | mips | mipsbe | mipseb | mipsel | mipsle \ - | mips16 \ - | mips64 | mips64el \ - | mips64octeon | mips64octeonel \ - | mips64orion | mips64orionel \ - | mips64r5900 | mips64r5900el \ - | mips64vr | mips64vrel \ - | mips64vr4100 | mips64vr4100el \ - | mips64vr4300 | mips64vr4300el \ - | mips64vr5000 | mips64vr5000el \ - | mips64vr5900 | mips64vr5900el \ - | mipsisa32 | mipsisa32el \ - | mipsisa32r2 | mipsisa32r2el \ - | mipsisa32r6 | mipsisa32r6el \ - | mipsisa64 | mipsisa64el \ - | mipsisa64r2 | mipsisa64r2el \ - | mipsisa64r6 | mipsisa64r6el \ - | mipsisa64sb1 | mipsisa64sb1el \ - | mipsisa64sr71k | mipsisa64sr71kel \ - | mipsr5900 | mipsr5900el \ - | mipstx39 | mipstx39el \ - | mn10200 | mn10300 \ - | moxie \ - | mt \ - | msp430 \ - | nds32 | nds32le | nds32be \ - | nios | nios2 | nios2eb | nios2el \ - | ns16k | ns32k \ - | open8 | or1k | or1knd | or32 \ - | pdp10 | pdp11 | pj | pjl \ - | powerpc | powerpc64 | powerpc64le | powerpcle \ - | pyramid \ - | riscv32 | riscv64 \ - | rl78 | rx \ - | score \ - | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ - | sh64 | sh64le \ - | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ - | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ - | spu \ - | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ - | ubicom32 \ - | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ - | visium \ - | we32k \ - | x86 | xc16x | xstormy16 | xtensa \ - | z8k | z80) - basic_machine=$basic_machine-unknown - ;; - c54x) - basic_machine=tic54x-unknown - ;; - c55x) - basic_machine=tic55x-unknown - ;; - c6x) - basic_machine=tic6x-unknown - ;; - leon|leon[3-9]) - basic_machine=sparc-$basic_machine - ;; - m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | nvptx | picochip) - basic_machine=$basic_machine-unknown - os=-none - ;; - m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) - ;; - ms1) - basic_machine=mt-unknown - ;; - - strongarm | thumb | xscale) - basic_machine=arm-unknown - ;; - xgate) - basic_machine=$basic_machine-unknown - os=-none - ;; - xscaleeb) - basic_machine=armeb-unknown - ;; - - xscaleel) - basic_machine=armel-unknown - ;; - - # We use `pc' rather than `unknown' - # because (1) that's what they normally are, and - # (2) the word "unknown" tends to confuse beginning users. - i*86 | x86_64) - basic_machine=$basic_machine-pc - ;; - # Object if more than one company name word. - *-*-*) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; - # Recognize the basic CPU types with company name. - 580-* \ - | a29k-* \ - | aarch64-* | aarch64_be-* \ - | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ - | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ - | alphapca5[67]-* | alpha64pca5[67]-* | arc-* | arceb-* \ - | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ - | avr-* | avr32-* \ - | ba-* \ - | be32-* | be64-* \ - | bfin-* | bs2000-* \ - | c[123]* | c30-* | [cjt]90-* | c4x-* \ - | c8051-* | clipper-* | craynv-* | cydra-* \ - | d10v-* | d30v-* | dlx-* \ - | e2k-* | elxsi-* \ - | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ - | h8300-* | h8500-* \ - | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ - | hexagon-* \ - | i*86-* | i860-* | i960-* | ia64-* \ - | ip2k-* | iq2000-* \ - | k1om-* \ - | le32-* | le64-* \ - | lm32-* \ - | m32c-* | m32r-* | m32rle-* \ - | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ - | m88110-* | m88k-* | maxq-* | mcore-* | metag-* \ - | microblaze-* | microblazeel-* \ - | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ - | mips16-* \ - | mips64-* | mips64el-* \ - | mips64octeon-* | mips64octeonel-* \ - | mips64orion-* | mips64orionel-* \ - | mips64r5900-* | mips64r5900el-* \ - | mips64vr-* | mips64vrel-* \ - | mips64vr4100-* | mips64vr4100el-* \ - | mips64vr4300-* | mips64vr4300el-* \ - | mips64vr5000-* | mips64vr5000el-* \ - | mips64vr5900-* | mips64vr5900el-* \ - | mipsisa32-* | mipsisa32el-* \ - | mipsisa32r2-* | mipsisa32r2el-* \ - | mipsisa32r6-* | mipsisa32r6el-* \ - | mipsisa64-* | mipsisa64el-* \ - | mipsisa64r2-* | mipsisa64r2el-* \ - | mipsisa64r6-* | mipsisa64r6el-* \ - | mipsisa64sb1-* | mipsisa64sb1el-* \ - | mipsisa64sr71k-* | mipsisa64sr71kel-* \ - | mipsr5900-* | mipsr5900el-* \ - | mipstx39-* | mipstx39el-* \ - | mmix-* \ - | mt-* \ - | msp430-* \ - | nds32-* | nds32le-* | nds32be-* \ - | nios-* | nios2-* | nios2eb-* | nios2el-* \ - | none-* | np1-* | ns16k-* | ns32k-* \ - | open8-* \ - | or1k*-* \ - | orion-* \ - | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ - | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ - | pyramid-* \ - | riscv32-* | riscv64-* \ - | rl78-* | romp-* | rs6000-* | rx-* \ - | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ - | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ - | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ - | sparclite-* \ - | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx*-* \ - | tahoe-* \ - | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ - | tile*-* \ - | tron-* \ - | ubicom32-* \ - | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ - | vax-* \ - | visium-* \ - | we32k-* \ - | x86-* | x86_64-* | xc16x-* | xps100-* \ - | xstormy16-* | xtensa*-* \ - | ymp-* \ - | z8k-* | z80-*) - ;; - # Recognize the basic CPU types without company name, with glob match. - xtensa*) - basic_machine=$basic_machine-unknown - ;; - # Recognize the various machine names and aliases which stand - # for a CPU type and a company and sometimes even an OS. - 386bsd) - basic_machine=i386-unknown - os=-bsd - ;; - 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) - basic_machine=m68000-att - ;; - 3b*) - basic_machine=we32k-att - ;; - a29khif) - basic_machine=a29k-amd - os=-udi - ;; - abacus) - basic_machine=abacus-unknown - ;; - adobe68k) - basic_machine=m68010-adobe - os=-scout - ;; - alliant | fx80) - basic_machine=fx80-alliant - ;; - altos | altos3068) - basic_machine=m68k-altos - ;; - am29k) - basic_machine=a29k-none - os=-bsd - ;; - amd64) - basic_machine=x86_64-pc - ;; - amd64-*) - basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - amdahl) - basic_machine=580-amdahl - os=-sysv - ;; - amiga | amiga-*) - basic_machine=m68k-unknown - ;; - amigaos | amigados) - basic_machine=m68k-unknown - os=-amigaos - ;; - amigaunix | amix) - basic_machine=m68k-unknown - os=-sysv4 - ;; - apollo68) - basic_machine=m68k-apollo - os=-sysv - ;; - apollo68bsd) - basic_machine=m68k-apollo - os=-bsd - ;; - aros) - basic_machine=i386-pc - os=-aros - ;; - asmjs) - basic_machine=asmjs-unknown - ;; - aux) - basic_machine=m68k-apple - os=-aux - ;; - balance) - basic_machine=ns32k-sequent - os=-dynix - ;; - blackfin) - basic_machine=bfin-unknown - os=-linux - ;; - blackfin-*) - basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` - os=-linux - ;; - bluegene*) - basic_machine=powerpc-ibm - os=-cnk - ;; - c54x-*) - basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - c55x-*) - basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - c6x-*) - basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - c90) - basic_machine=c90-cray - os=-unicos - ;; - cegcc) - basic_machine=arm-unknown - os=-cegcc - ;; - convex-c1) - basic_machine=c1-convex - os=-bsd - ;; - convex-c2) - basic_machine=c2-convex - os=-bsd - ;; - convex-c32) - basic_machine=c32-convex - os=-bsd - ;; - convex-c34) - basic_machine=c34-convex - os=-bsd - ;; - convex-c38) - basic_machine=c38-convex - os=-bsd - ;; - cray | j90) - basic_machine=j90-cray - os=-unicos - ;; - craynv) - basic_machine=craynv-cray - os=-unicosmp - ;; - cr16 | cr16-*) - basic_machine=cr16-unknown - os=-elf - ;; - crds | unos) - basic_machine=m68k-crds - ;; - crisv32 | crisv32-* | etraxfs*) - basic_machine=crisv32-axis - ;; - cris | cris-* | etrax*) - basic_machine=cris-axis - ;; - crx) - basic_machine=crx-unknown - os=-elf - ;; - da30 | da30-*) - basic_machine=m68k-da30 - ;; - decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) - basic_machine=mips-dec - ;; - decsystem10* | dec10*) - basic_machine=pdp10-dec - os=-tops10 - ;; - decsystem20* | dec20*) - basic_machine=pdp10-dec - os=-tops20 - ;; - delta | 3300 | motorola-3300 | motorola-delta \ - | 3300-motorola | delta-motorola) - basic_machine=m68k-motorola - ;; - delta88) - basic_machine=m88k-motorola - os=-sysv3 - ;; - dicos) - basic_machine=i686-pc - os=-dicos - ;; - djgpp) - basic_machine=i586-pc - os=-msdosdjgpp - ;; - dpx20 | dpx20-*) - basic_machine=rs6000-bull - os=-bosx - ;; - dpx2* | dpx2*-bull) - basic_machine=m68k-bull - os=-sysv3 - ;; - ebmon29k) - basic_machine=a29k-amd - os=-ebmon - ;; - elxsi) - basic_machine=elxsi-elxsi - os=-bsd - ;; - encore | umax | mmax) - basic_machine=ns32k-encore - ;; - es1800 | OSE68k | ose68k | ose | OSE) - basic_machine=m68k-ericsson - os=-ose - ;; - fx2800) - basic_machine=i860-alliant - ;; - genix) - basic_machine=ns32k-ns - ;; - gmicro) - basic_machine=tron-gmicro - os=-sysv - ;; - go32) - basic_machine=i386-pc - os=-go32 - ;; - h3050r* | hiux*) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - h8300hms) - basic_machine=h8300-hitachi - os=-hms - ;; - h8300xray) - basic_machine=h8300-hitachi - os=-xray - ;; - h8500hms) - basic_machine=h8500-hitachi - os=-hms - ;; - harris) - basic_machine=m88k-harris - os=-sysv3 - ;; - hp300-*) - basic_machine=m68k-hp - ;; - hp300bsd) - basic_machine=m68k-hp - os=-bsd - ;; - hp300hpux) - basic_machine=m68k-hp - os=-hpux - ;; - hp3k9[0-9][0-9] | hp9[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hp9k2[0-9][0-9] | hp9k31[0-9]) - basic_machine=m68000-hp - ;; - hp9k3[2-9][0-9]) - basic_machine=m68k-hp - ;; - hp9k6[0-9][0-9] | hp6[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hp9k7[0-79][0-9] | hp7[0-79][0-9]) - basic_machine=hppa1.1-hp - ;; - hp9k78[0-9] | hp78[0-9]) - # FIXME: really hppa2.0-hp - basic_machine=hppa1.1-hp - ;; - hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) - # FIXME: really hppa2.0-hp - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][13679] | hp8[0-9][13679]) - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][0-9] | hp8[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hppa-next) - os=-nextstep3 - ;; - hppaosf) - basic_machine=hppa1.1-hp - os=-osf - ;; - hppro) - basic_machine=hppa1.1-hp - os=-proelf - ;; - i370-ibm* | ibm*) - basic_machine=i370-ibm - ;; - i*86v32) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv32 - ;; - i*86v4*) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv4 - ;; - i*86v) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv - ;; - i*86sol2) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-solaris2 - ;; - i386mach) - basic_machine=i386-mach - os=-mach - ;; - i386-vsta | vsta) - basic_machine=i386-unknown - os=-vsta - ;; - iris | iris4d) - basic_machine=mips-sgi - case $os in - -irix*) - ;; - *) - os=-irix4 - ;; - esac - ;; - isi68 | isi) - basic_machine=m68k-isi - os=-sysv - ;; - leon-*|leon[3-9]-*) - basic_machine=sparc-`echo $basic_machine | sed 's/-.*//'` - ;; - m68knommu) - basic_machine=m68k-unknown - os=-linux - ;; - m68knommu-*) - basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` - os=-linux - ;; - m88k-omron*) - basic_machine=m88k-omron - ;; - magnum | m3230) - basic_machine=mips-mips - os=-sysv - ;; - merlin) - basic_machine=ns32k-utek - os=-sysv - ;; - microblaze*) - basic_machine=microblaze-xilinx - ;; - mingw64) - basic_machine=x86_64-pc - os=-mingw64 - ;; - mingw32) - basic_machine=i686-pc - os=-mingw32 - ;; - mingw32ce) - basic_machine=arm-unknown - os=-mingw32ce - ;; - miniframe) - basic_machine=m68000-convergent - ;; - *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) - basic_machine=m68k-atari - os=-mint - ;; - mips3*-*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` - ;; - mips3*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown - ;; - monitor) - basic_machine=m68k-rom68k - os=-coff - ;; - morphos) - basic_machine=powerpc-unknown - os=-morphos - ;; - moxiebox) - basic_machine=moxie-unknown - os=-moxiebox - ;; - msdos) - basic_machine=i386-pc - os=-msdos - ;; - ms1-*) - basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` - ;; - msys) - basic_machine=i686-pc - os=-msys - ;; - mvs) - basic_machine=i370-ibm - os=-mvs - ;; - nacl) - basic_machine=le32-unknown - os=-nacl - ;; - ncr3000) - basic_machine=i486-ncr - os=-sysv4 - ;; - netbsd386) - basic_machine=i386-unknown - os=-netbsd - ;; - netwinder) - basic_machine=armv4l-rebel - os=-linux - ;; - news | news700 | news800 | news900) - basic_machine=m68k-sony - os=-newsos - ;; - news1000) - basic_machine=m68030-sony - os=-newsos - ;; - news-3600 | risc-news) - basic_machine=mips-sony - os=-newsos - ;; - necv70) - basic_machine=v70-nec - os=-sysv - ;; - next | m*-next ) - basic_machine=m68k-next - case $os in - -nextstep* ) - ;; - -ns2*) - os=-nextstep2 - ;; - *) - os=-nextstep3 - ;; - esac - ;; - nh3000) - basic_machine=m68k-harris - os=-cxux - ;; - nh[45]000) - basic_machine=m88k-harris - os=-cxux - ;; - nindy960) - basic_machine=i960-intel - os=-nindy - ;; - mon960) - basic_machine=i960-intel - os=-mon960 - ;; - nonstopux) - basic_machine=mips-compaq - os=-nonstopux - ;; - np1) - basic_machine=np1-gould - ;; - neo-tandem) - basic_machine=neo-tandem - ;; - nse-tandem) - basic_machine=nse-tandem - ;; - nsr-tandem) - basic_machine=nsr-tandem - ;; - op50n-* | op60c-*) - basic_machine=hppa1.1-oki - os=-proelf - ;; - openrisc | openrisc-*) - basic_machine=or32-unknown - ;; - os400) - basic_machine=powerpc-ibm - os=-os400 - ;; - OSE68000 | ose68000) - basic_machine=m68000-ericsson - os=-ose - ;; - os68k) - basic_machine=m68k-none - os=-os68k - ;; - pa-hitachi) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - paragon) - basic_machine=i860-intel - os=-osf - ;; - parisc) - basic_machine=hppa-unknown - os=-linux - ;; - parisc-*) - basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` - os=-linux - ;; - pbd) - basic_machine=sparc-tti - ;; - pbb) - basic_machine=m68k-tti - ;; - pc532 | pc532-*) - basic_machine=ns32k-pc532 - ;; - pc98) - basic_machine=i386-pc - ;; - pc98-*) - basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentium | p5 | k5 | k6 | nexgen | viac3) - basic_machine=i586-pc - ;; - pentiumpro | p6 | 6x86 | athlon | athlon_*) - basic_machine=i686-pc - ;; - pentiumii | pentium2 | pentiumiii | pentium3) - basic_machine=i686-pc - ;; - pentium4) - basic_machine=i786-pc - ;; - pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) - basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentiumpro-* | p6-* | 6x86-* | athlon-*) - basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) - basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentium4-*) - basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pn) - basic_machine=pn-gould - ;; - power) basic_machine=power-ibm - ;; - ppc | ppcbe) basic_machine=powerpc-unknown - ;; - ppc-* | ppcbe-*) - basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppcle | powerpclittle | ppc-le | powerpc-little) - basic_machine=powerpcle-unknown - ;; - ppcle-* | powerpclittle-*) - basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppc64) basic_machine=powerpc64-unknown - ;; - ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppc64le | powerpc64little | ppc64-le | powerpc64-little) - basic_machine=powerpc64le-unknown - ;; - ppc64le-* | powerpc64little-*) - basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ps2) - basic_machine=i386-ibm - ;; - pw32) - basic_machine=i586-unknown - os=-pw32 - ;; - rdos | rdos64) - basic_machine=x86_64-pc - os=-rdos - ;; - rdos32) - basic_machine=i386-pc - os=-rdos - ;; - rom68k) - basic_machine=m68k-rom68k - os=-coff - ;; - rm[46]00) - basic_machine=mips-siemens - ;; - rtpc | rtpc-*) - basic_machine=romp-ibm - ;; - s390 | s390-*) - basic_machine=s390-ibm - ;; - s390x | s390x-*) - basic_machine=s390x-ibm - ;; - sa29200) - basic_machine=a29k-amd - os=-udi - ;; - sb1) - basic_machine=mipsisa64sb1-unknown - ;; - sb1el) - basic_machine=mipsisa64sb1el-unknown - ;; - sde) - basic_machine=mipsisa32-sde - os=-elf - ;; - sei) - basic_machine=mips-sei - os=-seiux - ;; - sequent) - basic_machine=i386-sequent - ;; - sh) - basic_machine=sh-hitachi - os=-hms - ;; - sh5el) - basic_machine=sh5le-unknown - ;; - sh64) - basic_machine=sh64-unknown - ;; - sparclite-wrs | simso-wrs) - basic_machine=sparclite-wrs - os=-vxworks - ;; - sps7) - basic_machine=m68k-bull - os=-sysv2 - ;; - spur) - basic_machine=spur-unknown - ;; - st2000) - basic_machine=m68k-tandem - ;; - stratus) - basic_machine=i860-stratus - os=-sysv4 - ;; - strongarm-* | thumb-*) - basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - sun2) - basic_machine=m68000-sun - ;; - sun2os3) - basic_machine=m68000-sun - os=-sunos3 - ;; - sun2os4) - basic_machine=m68000-sun - os=-sunos4 - ;; - sun3os3) - basic_machine=m68k-sun - os=-sunos3 - ;; - sun3os4) - basic_machine=m68k-sun - os=-sunos4 - ;; - sun4os3) - basic_machine=sparc-sun - os=-sunos3 - ;; - sun4os4) - basic_machine=sparc-sun - os=-sunos4 - ;; - sun4sol2) - basic_machine=sparc-sun - os=-solaris2 - ;; - sun3 | sun3-*) - basic_machine=m68k-sun - ;; - sun4) - basic_machine=sparc-sun - ;; - sun386 | sun386i | roadrunner) - basic_machine=i386-sun - ;; - sv1) - basic_machine=sv1-cray - os=-unicos - ;; - symmetry) - basic_machine=i386-sequent - os=-dynix - ;; - t3e) - basic_machine=alphaev5-cray - os=-unicos - ;; - t90) - basic_machine=t90-cray - os=-unicos - ;; - tile*) - basic_machine=$basic_machine-unknown - os=-linux-gnu - ;; - tx39) - basic_machine=mipstx39-unknown - ;; - tx39el) - basic_machine=mipstx39el-unknown - ;; - toad1) - basic_machine=pdp10-xkl - os=-tops20 - ;; - tower | tower-32) - basic_machine=m68k-ncr - ;; - tpf) - basic_machine=s390x-ibm - os=-tpf - ;; - udi29k) - basic_machine=a29k-amd - os=-udi - ;; - ultra3) - basic_machine=a29k-nyu - os=-sym1 - ;; - v810 | necv810) - basic_machine=v810-nec - os=-none - ;; - vaxv) - basic_machine=vax-dec - os=-sysv - ;; - vms) - basic_machine=vax-dec - os=-vms - ;; - vpp*|vx|vx-*) - basic_machine=f301-fujitsu - ;; - vxworks960) - basic_machine=i960-wrs - os=-vxworks - ;; - vxworks68) - basic_machine=m68k-wrs - os=-vxworks - ;; - vxworks29k) - basic_machine=a29k-wrs - os=-vxworks - ;; - w65*) - basic_machine=w65-wdc - os=-none - ;; - w89k-*) - basic_machine=hppa1.1-winbond - os=-proelf - ;; - xbox) - basic_machine=i686-pc - os=-mingw32 - ;; - xps | xps100) - basic_machine=xps100-honeywell - ;; - xscale-* | xscalee[bl]-*) - basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'` - ;; - ymp) - basic_machine=ymp-cray - os=-unicos - ;; - z8k-*-coff) - basic_machine=z8k-unknown - os=-sim - ;; - z80-*-coff) - basic_machine=z80-unknown - os=-sim - ;; - none) - basic_machine=none-none - os=-none - ;; - -# Here we handle the default manufacturer of certain CPU types. It is in -# some cases the only manufacturer, in others, it is the most popular. - w89k) - basic_machine=hppa1.1-winbond - ;; - op50n) - basic_machine=hppa1.1-oki - ;; - op60c) - basic_machine=hppa1.1-oki - ;; - romp) - basic_machine=romp-ibm - ;; - mmix) - basic_machine=mmix-knuth - ;; - rs6000) - basic_machine=rs6000-ibm - ;; - vax) - basic_machine=vax-dec - ;; - pdp10) - # there are many clones, so DEC is not a safe bet - basic_machine=pdp10-unknown - ;; - pdp11) - basic_machine=pdp11-dec - ;; - we32k) - basic_machine=we32k-att - ;; - sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) - basic_machine=sh-unknown - ;; - sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) - basic_machine=sparc-sun - ;; - cydra) - basic_machine=cydra-cydrome - ;; - orion) - basic_machine=orion-highlevel - ;; - orion105) - basic_machine=clipper-highlevel - ;; - mac | mpw | mac-mpw) - basic_machine=m68k-apple - ;; - pmac | pmac-mpw) - basic_machine=powerpc-apple - ;; - *-unknown) - # Make sure to match an already-canonicalized machine name. - ;; - *) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; -esac - -# Here we canonicalize certain aliases for manufacturers. -case $basic_machine in - *-digital*) - basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` - ;; - *-commodore*) - basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` - ;; - *) - ;; -esac - -# Decode manufacturer-specific aliases for certain operating systems. - -if [ x"$os" != x"" ] -then -case $os in - # First match some system type aliases - # that might get confused with valid system types. - # -solaris* is a basic system type, with this one exception. - -auroraux) - os=-auroraux - ;; - -solaris1 | -solaris1.*) - os=`echo $os | sed -e 's|solaris1|sunos4|'` - ;; - -solaris) - os=-solaris2 - ;; - -svr4*) - os=-sysv4 - ;; - -unixware*) - os=-sysv4.2uw - ;; - -gnu/linux*) - os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` - ;; - # First accept the basic system types. - # The portable systems comes first. - # Each alternative MUST END IN A *, to match a version number. - # -sysv* is not here because it comes later, after sysvr4. - -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ - | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ - | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ - | -sym* | -kopensolaris* | -plan9* \ - | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ - | -aos* | -aros* | -cloudabi* \ - | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ - | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ - | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ - | -bitrig* | -openbsd* | -solidbsd* \ - | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ - | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ - | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ - | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ - | -chorusos* | -chorusrdb* | -cegcc* \ - | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ - | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ - | -linux-newlib* | -linux-musl* | -linux-uclibc* \ - | -uxpv* | -beos* | -mpeix* | -udk* | -moxiebox* \ - | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ - | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ - | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ - | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ - | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ - | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ - | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es* | -tirtos*) - # Remember, each alternative MUST END IN *, to match a version number. - ;; - -qnx*) - case $basic_machine in - x86-* | i*86-*) - ;; - *) - os=-nto$os - ;; - esac - ;; - -nto-qnx*) - ;; - -nto*) - os=`echo $os | sed -e 's|nto|nto-qnx|'` - ;; - -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ - | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ - | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) - ;; - -mac*) - os=`echo $os | sed -e 's|mac|macos|'` - ;; - -linux-dietlibc) - os=-linux-dietlibc - ;; - -linux*) - os=`echo $os | sed -e 's|linux|linux-gnu|'` - ;; - -sunos5*) - os=`echo $os | sed -e 's|sunos5|solaris2|'` - ;; - -sunos6*) - os=`echo $os | sed -e 's|sunos6|solaris3|'` - ;; - -opened*) - os=-openedition - ;; - -os400*) - os=-os400 - ;; - -wince*) - os=-wince - ;; - -osfrose*) - os=-osfrose - ;; - -osf*) - os=-osf - ;; - -utek*) - os=-bsd - ;; - -dynix*) - os=-bsd - ;; - -acis*) - os=-aos - ;; - -atheos*) - os=-atheos - ;; - -syllable*) - os=-syllable - ;; - -386bsd) - os=-bsd - ;; - -ctix* | -uts*) - os=-sysv - ;; - -nova*) - os=-rtmk-nova - ;; - -ns2 ) - os=-nextstep2 - ;; - -nsk*) - os=-nsk - ;; - # Preserve the version number of sinix5. - -sinix5.*) - os=`echo $os | sed -e 's|sinix|sysv|'` - ;; - -sinix*) - os=-sysv4 - ;; - -tpf*) - os=-tpf - ;; - -triton*) - os=-sysv3 - ;; - -oss*) - os=-sysv3 - ;; - -svr4) - os=-sysv4 - ;; - -svr3) - os=-sysv3 - ;; - -sysvr4) - os=-sysv4 - ;; - # This must come after -sysvr4. - -sysv*) - ;; - -ose*) - os=-ose - ;; - -es1800*) - os=-ose - ;; - -xenix) - os=-xenix - ;; - -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) - os=-mint - ;; - -aros*) - os=-aros - ;; - -zvmoe) - os=-zvmoe - ;; - -dicos*) - os=-dicos - ;; - -nacl*) - ;; - -none) - ;; - *) - # Get rid of the `-' at the beginning of $os. - os=`echo $os | sed 's/[^-]*-//'` - echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 - exit 1 - ;; -esac -else - -# Here we handle the default operating systems that come with various machines. -# The value should be what the vendor currently ships out the door with their -# machine or put another way, the most popular os provided with the machine. - -# Note that if you're going to try to match "-MANUFACTURER" here (say, -# "-sun"), then you have to tell the case statement up towards the top -# that MANUFACTURER isn't an operating system. Otherwise, code above -# will signal an error saying that MANUFACTURER isn't an operating -# system, and we'll never get to this point. - -case $basic_machine in - score-*) - os=-elf - ;; - spu-*) - os=-elf - ;; - *-acorn) - os=-riscix1.2 - ;; - arm*-rebel) - os=-linux - ;; - arm*-semi) - os=-aout - ;; - c4x-* | tic4x-*) - os=-coff - ;; - c8051-*) - os=-elf - ;; - hexagon-*) - os=-elf - ;; - tic54x-*) - os=-coff - ;; - tic55x-*) - os=-coff - ;; - tic6x-*) - os=-coff - ;; - # This must come before the *-dec entry. - pdp10-*) - os=-tops20 - ;; - pdp11-*) - os=-none - ;; - *-dec | vax-*) - os=-ultrix4.2 - ;; - m68*-apollo) - os=-domain - ;; - i386-sun) - os=-sunos4.0.2 - ;; - m68000-sun) - os=-sunos3 - ;; - m68*-cisco) - os=-aout - ;; - mep-*) - os=-elf - ;; - mips*-cisco) - os=-elf - ;; - mips*-*) - os=-elf - ;; - or32-*) - os=-coff - ;; - *-tti) # must be before sparc entry or we get the wrong os. - os=-sysv3 - ;; - sparc-* | *-sun) - os=-sunos4.1.1 - ;; - *-be) - os=-beos - ;; - *-haiku) - os=-haiku - ;; - *-ibm) - os=-aix - ;; - *-knuth) - os=-mmixware - ;; - *-wec) - os=-proelf - ;; - *-winbond) - os=-proelf - ;; - *-oki) - os=-proelf - ;; - *-hp) - os=-hpux - ;; - *-hitachi) - os=-hiux - ;; - i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) - os=-sysv - ;; - *-cbm) - os=-amigaos - ;; - *-dg) - os=-dgux - ;; - *-dolphin) - os=-sysv3 - ;; - m68k-ccur) - os=-rtu - ;; - m88k-omron*) - os=-luna - ;; - *-next ) - os=-nextstep - ;; - *-sequent) - os=-ptx - ;; - *-crds) - os=-unos - ;; - *-ns) - os=-genix - ;; - i370-*) - os=-mvs - ;; - *-next) - os=-nextstep3 - ;; - *-gould) - os=-sysv - ;; - *-highlevel) - os=-bsd - ;; - *-encore) - os=-bsd - ;; - *-sgi) - os=-irix - ;; - *-siemens) - os=-sysv4 - ;; - *-masscomp) - os=-rtu - ;; - f30[01]-fujitsu | f700-fujitsu) - os=-uxpv - ;; - *-rom68k) - os=-coff - ;; - *-*bug) - os=-coff - ;; - *-apple) - os=-macos - ;; - *-atari*) - os=-mint - ;; - *) - os=-none - ;; -esac -fi - -# Here we handle the case where we know the os, and the CPU type, but not the -# manufacturer. We pick the logical manufacturer. -vendor=unknown -case $basic_machine in - *-unknown) - case $os in - -riscix*) - vendor=acorn - ;; - -sunos*) - vendor=sun - ;; - -cnk*|-aix*) - vendor=ibm - ;; - -beos*) - vendor=be - ;; - -hpux*) - vendor=hp - ;; - -mpeix*) - vendor=hp - ;; - -hiux*) - vendor=hitachi - ;; - -unos*) - vendor=crds - ;; - -dgux*) - vendor=dg - ;; - -luna*) - vendor=omron - ;; - -genix*) - vendor=ns - ;; - -mvs* | -opened*) - vendor=ibm - ;; - -os400*) - vendor=ibm - ;; - -ptx*) - vendor=sequent - ;; - -tpf*) - vendor=ibm - ;; - -vxsim* | -vxworks* | -windiss*) - vendor=wrs - ;; - -aux*) - vendor=apple - ;; - -hms*) - vendor=hitachi - ;; - -mpw* | -macos*) - vendor=apple - ;; - -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) - vendor=atari - ;; - -vos*) - vendor=stratus - ;; - esac - basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` - ;; -esac - -echo $basic_machine$os -exit - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "timestamp='" -# time-stamp-format: "%:y-%02m-%02d" -# time-stamp-end: "'" -# End: diff --git a/quantum_espresso/kcp/install/configure b/quantum_espresso/kcp/install/configure deleted file mode 100755 index 04227941f..000000000 --- a/quantum_espresso/kcp/install/configure +++ /dev/null @@ -1,10712 +0,0 @@ -#! /bin/sh -# Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.71 for ESPRESSO 6.6. -# -# -# Copyright (C) 1992-1996, 1998-2017, 2020-2021 Free Software Foundation, -# Inc. -# -# -# This configure script is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. -## -------------------- ## -## M4sh Initialization. ## -## -------------------- ## - -# Be more Bourne compatible -DUALCASE=1; export DUALCASE # for MKS sh -as_nop=: -if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 -then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which - # is contrary to our usage. Disable this feature. - alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else $as_nop - case `(set -o) 2>/dev/null` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi - - - -# Reset variables that may have inherited troublesome values from -# the environment. - -# IFS needs to be set, to space, tab, and newline, in precisely that order. -# (If _AS_PATH_WALK were called with IFS unset, it would have the -# side effect of setting IFS to empty, thus disabling word splitting.) -# Quoting is to prevent editors from complaining about space-tab. -as_nl=' -' -export as_nl -IFS=" "" $as_nl" - -PS1='$ ' -PS2='> ' -PS4='+ ' - -# Ensure predictable behavior from utilities with locale-dependent output. -LC_ALL=C -export LC_ALL -LANGUAGE=C -export LANGUAGE - -# We cannot yet rely on "unset" to work, but we need these variables -# to be unset--not just set to an empty or harmless value--now, to -# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct -# also avoids known problems related to "unset" and subshell syntax -# in other old shells (e.g. bash 2.01 and pdksh 5.2.14). -for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH -do eval test \${$as_var+y} \ - && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : -done - -# Ensure that fds 0, 1, and 2 are open. -if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi -if (exec 3>&2) ; then :; else exec 2>/dev/null; fi - -# The user is always right. -if ${PATH_SEPARATOR+false} :; then - PATH_SEPARATOR=: - (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { - (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || - PATH_SEPARATOR=';' - } -fi - - -# Find who we are. Look in the path if we contain no directory separator. -as_myself= -case $0 in #(( - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - test -r "$as_dir$0" && as_myself=$as_dir$0 && break - done -IFS=$as_save_IFS - - ;; -esac -# We did not find ourselves, most probably we were run as `sh COMMAND' -# in which case we are not to be found in the path. -if test "x$as_myself" = x; then - as_myself=$0 -fi -if test ! -f "$as_myself"; then - printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - exit 1 -fi - - -# Use a proper internal environment variable to ensure we don't fall - # into an infinite loop, continuously re-executing ourselves. - if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then - _as_can_reexec=no; export _as_can_reexec; - # We cannot yet assume a decent shell, so we have to provide a -# neutralization value for shells without unset; and this also -# works around shells that cannot unset nonexistent variables. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 -exit 255 - fi - # We don't want this to propagate to other subprocesses. - { _as_can_reexec=; unset _as_can_reexec;} -if test "x$CONFIG_SHELL" = x; then - as_bourne_compatible="as_nop=: -if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 -then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which - # is contrary to our usage. Disable this feature. - alias -g '\${1+\"\$@\"}'='\"\$@\"' - setopt NO_GLOB_SUBST -else \$as_nop - case \`(set -o) 2>/dev/null\` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi -" - as_required="as_fn_return () { (exit \$1); } -as_fn_success () { as_fn_return 0; } -as_fn_failure () { as_fn_return 1; } -as_fn_ret_success () { return 0; } -as_fn_ret_failure () { return 1; } - -exitcode=0 -as_fn_success || { exitcode=1; echo as_fn_success failed.; } -as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } -as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } -as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } -if ( set x; as_fn_ret_success y && test x = \"\$1\" ) -then : - -else \$as_nop - exitcode=1; echo positional parameters were not saved. -fi -test x\$exitcode = x0 || exit 1 -blah=\$(echo \$(echo blah)) -test x\"\$blah\" = xblah || exit 1 -test -x / || exit 1" - as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO - as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO - eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && - test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 -test \$(( 1 + 1 )) = 2 || exit 1" - if (eval "$as_required") 2>/dev/null -then : - as_have_required=yes -else $as_nop - as_have_required=no -fi - if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null -then : - -else $as_nop - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -as_found=false -for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - as_found=: - case $as_dir in #( - /*) - for as_base in sh bash ksh sh5; do - # Try only shells that exist, to save several forks. - as_shell=$as_dir$as_base - if { test -f "$as_shell" || test -f "$as_shell.exe"; } && - as_run=a "$as_shell" -c "$as_bourne_compatible""$as_required" 2>/dev/null -then : - CONFIG_SHELL=$as_shell as_have_required=yes - if as_run=a "$as_shell" -c "$as_bourne_compatible""$as_suggested" 2>/dev/null -then : - break 2 -fi -fi - done;; - esac - as_found=false -done -IFS=$as_save_IFS -if $as_found -then : - -else $as_nop - if { test -f "$SHELL" || test -f "$SHELL.exe"; } && - as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null -then : - CONFIG_SHELL=$SHELL as_have_required=yes -fi -fi - - - if test "x$CONFIG_SHELL" != x -then : - export CONFIG_SHELL - # We cannot yet assume a decent shell, so we have to provide a -# neutralization value for shells without unset; and this also -# works around shells that cannot unset nonexistent variables. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 -exit 255 -fi - - if test x$as_have_required = xno -then : - printf "%s\n" "$0: This script requires a shell more modern than all" - printf "%s\n" "$0: the shells that I found on your system." - if test ${ZSH_VERSION+y} ; then - printf "%s\n" "$0: In particular, zsh $ZSH_VERSION has bugs and should" - printf "%s\n" "$0: be upgraded to zsh 4.3.4 or later." - else - printf "%s\n" "$0: Please tell bug-autoconf@gnu.org about your system, -$0: including any error possibly output before this -$0: message. Then install a modern shell, or manually run -$0: the script under such a shell if you do have one." - fi - exit 1 -fi -fi -fi -SHELL=${CONFIG_SHELL-/bin/sh} -export SHELL -# Unset more variables known to interfere with behavior of common tools. -CLICOLOR_FORCE= GREP_OPTIONS= -unset CLICOLOR_FORCE GREP_OPTIONS - -## --------------------- ## -## M4sh Shell Functions. ## -## --------------------- ## -# as_fn_unset VAR -# --------------- -# Portably unset VAR. -as_fn_unset () -{ - { eval $1=; unset $1;} -} -as_unset=as_fn_unset - - -# as_fn_set_status STATUS -# ----------------------- -# Set $? to STATUS, without forking. -as_fn_set_status () -{ - return $1 -} # as_fn_set_status - -# as_fn_exit STATUS -# ----------------- -# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. -as_fn_exit () -{ - set +e - as_fn_set_status $1 - exit $1 -} # as_fn_exit -# as_fn_nop -# --------- -# Do nothing but, unlike ":", preserve the value of $?. -as_fn_nop () -{ - return $? -} -as_nop=as_fn_nop - -# as_fn_mkdir_p -# ------------- -# Create "$as_dir" as a directory, including parents if necessary. -as_fn_mkdir_p () -{ - - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || eval $as_mkdir_p || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -printf "%s\n" X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - -} # as_fn_mkdir_p - -# as_fn_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_p -# as_fn_append VAR VALUE -# ---------------------- -# Append the text in VALUE to the end of the definition contained in VAR. Take -# advantage of any shell optimizations that allow amortized linear growth over -# repeated appends, instead of the typical quadratic growth present in naive -# implementations. -if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null -then : - eval 'as_fn_append () - { - eval $1+=\$2 - }' -else $as_nop - as_fn_append () - { - eval $1=\$$1\$2 - } -fi # as_fn_append - -# as_fn_arith ARG... -# ------------------ -# Perform arithmetic evaluation on the ARGs, and store the result in the -# global $as_val. Take advantage of shells that can avoid forks. The arguments -# must be portable across $(()) and expr. -if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null -then : - eval 'as_fn_arith () - { - as_val=$(( $* )) - }' -else $as_nop - as_fn_arith () - { - as_val=`expr "$@" || test $? -eq 1` - } -fi # as_fn_arith - -# as_fn_nop -# --------- -# Do nothing but, unlike ":", preserve the value of $?. -as_fn_nop () -{ - return $? -} -as_nop=as_fn_nop - -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- -# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are -# provided, also output the error to LOG_FD, referencing LINENO. Then exit the -# script with STATUS, using 1 if that was 0. -as_fn_error () -{ - as_status=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - printf "%s\n" "$as_me: error: $2" >&2 - as_fn_exit $as_status -} # as_fn_error - -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then - as_expr=expr -else - as_expr=false -fi - -if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then - as_basename=basename -else - as_basename=false -fi - -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi - -as_me=`$as_basename -- "$0" || -$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| . 2>/dev/null || -printf "%s\n" X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - -# Avoid depending upon Character Ranges. -as_cr_letters='abcdefghijklmnopqrstuvwxyz' -as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' -as_cr_Letters=$as_cr_letters$as_cr_LETTERS -as_cr_digits='0123456789' -as_cr_alnum=$as_cr_Letters$as_cr_digits - - - as_lineno_1=$LINENO as_lineno_1a=$LINENO - as_lineno_2=$LINENO as_lineno_2a=$LINENO - eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && - test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { - # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) - sed -n ' - p - /[$]LINENO/= - ' <$as_myself | - sed ' - s/[$]LINENO.*/&-/ - t lineno - b - :lineno - N - :loop - s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ - t loop - s/-\n.*// - ' >$as_me.lineno && - chmod +x "$as_me.lineno" || - { printf "%s\n" "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } - - # If we had to re-execute with $CONFIG_SHELL, we're ensured to have - # already done that, so ensure we don't try to do so again and fall - # in an infinite loop. This has already happened in practice. - _as_can_reexec=no; export _as_can_reexec - # Don't try to exec as it changes $[0], causing all sort of problems - # (the dirname of $[0] is not the place where we might find the - # original and so on. Autoconf is especially sensitive to this). - . "./$as_me.lineno" - # Exit status is that of the last command. - exit -} - - -# Determine whether it's possible to make 'echo' print without a newline. -# These variables are no longer used directly by Autoconf, but are AC_SUBSTed -# for compatibility with existing Makefiles. -ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in #((((( --n*) - case `echo 'xy\c'` in - *c*) ECHO_T=' ';; # ECHO_T is single tab character. - xy) ECHO_C='\c';; - *) echo `echo ksh88 bug on AIX 6.1` > /dev/null - ECHO_T=' ';; - esac;; -*) - ECHO_N='-n';; -esac - -# For backward compatibility with old third-party macros, we provide -# the shell variables $as_echo and $as_echo_n. New code should use -# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. -as_echo='printf %s\n' -as_echo_n='printf %s' - - -rm -f conf$$ conf$$.exe conf$$.file -if test -d conf$$.dir; then - rm -f conf$$.dir/conf$$.file -else - rm -f conf$$.dir - mkdir conf$$.dir 2>/dev/null -fi -if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then - as_ln_s='ln -s' - # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -fi -rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file -rmdir conf$$.dir 2>/dev/null - -if mkdir -p . 2>/dev/null; then - as_mkdir_p='mkdir -p "$as_dir"' -else - test -d ./-p && rmdir ./-p - as_mkdir_p=false -fi - -as_test_x='test -x' -as_executable_p=as_fn_executable_p - -# Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" - -# Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" - -as_awk_strverscmp=' - # Use only awk features that work with 7th edition Unix awk (1978). - # My, what an old awk you have, Mr. Solaris! - END { - while (length(v1) && length(v2)) { - # Set d1 to be the next thing to compare from v1, and likewise for d2. - # Normally this is a single character, but if v1 and v2 contain digits, - # compare them as integers and fractions as strverscmp does. - if (v1 ~ /^[0-9]/ && v2 ~ /^[0-9]/) { - # Split v1 and v2 into their leading digit string components d1 and d2, - # and advance v1 and v2 past the leading digit strings. - for (len1 = 1; substr(v1, len1 + 1) ~ /^[0-9]/; len1++) continue - for (len2 = 1; substr(v2, len2 + 1) ~ /^[0-9]/; len2++) continue - d1 = substr(v1, 1, len1); v1 = substr(v1, len1 + 1) - d2 = substr(v2, 1, len2); v2 = substr(v2, len2 + 1) - if (d1 ~ /^0/) { - if (d2 ~ /^0/) { - # Compare two fractions. - while (d1 ~ /^0/ && d2 ~ /^0/) { - d1 = substr(d1, 2); len1-- - d2 = substr(d2, 2); len2-- - } - if (len1 != len2 && ! (len1 && len2 && substr(d1, 1, 1) == substr(d2, 1, 1))) { - # The two components differ in length, and the common prefix - # contains only leading zeros. Consider the longer to be less. - d1 = -len1 - d2 = -len2 - } else { - # Otherwise, compare as strings. - d1 = "x" d1 - d2 = "x" d2 - } - } else { - # A fraction is less than an integer. - exit 1 - } - } else { - if (d2 ~ /^0/) { - # An integer is greater than a fraction. - exit 2 - } else { - # Compare two integers. - d1 += 0 - d2 += 0 - } - } - } else { - # The normal case, without worrying about digits. - d1 = substr(v1, 1, 1); v1 = substr(v1, 2) - d2 = substr(v2, 1, 1); v2 = substr(v2, 2) - } - if (d1 < d2) exit 1 - if (d1 > d2) exit 2 - } - # Beware Solaris /usr/xgp4/bin/awk (at least through Solaris 10), - # which mishandles some comparisons of empty strings to integers. - if (length(v2)) exit 1 - if (length(v1)) exit 2 - } -' - -test -n "$DJDIR" || exec 7<&0 &1 - -# Name of the host. -# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, -# so uname gets run too. -ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` - -# -# Initializations. -# -ac_default_prefix=/usr/local -ac_clean_files= -ac_config_libobj_dir=. -LIBOBJS= -cross_compiling=no -subdirs= -MFLAGS= -MAKEFLAGS= - -# Identity of this package. -PACKAGE_NAME='ESPRESSO' -PACKAGE_TARNAME='espresso' -PACKAGE_VERSION='6.6' -PACKAGE_STRING='ESPRESSO 6.6' -PACKAGE_BUGREPORT='' -PACKAGE_URL='' - -# Factoring default headers for most tests. -ac_includes_default="\ -#include -#ifdef HAVE_STDIO_H -# include -#endif -#ifdef HAVE_STDLIB_H -# include -#endif -#ifdef HAVE_STRING_H -# include -#endif -#ifdef HAVE_INTTYPES_H -# include -#endif -#ifdef HAVE_STDINT_H -# include -#endif -#ifdef HAVE_STRINGS_H -# include -#endif -#ifdef HAVE_SYS_TYPES_H -# include -#endif -#ifdef HAVE_SYS_STAT_H -# include -#endif -#ifdef HAVE_UNISTD_H -# include -#endif" - -ac_header_c_list= -ac_subst_vars='LTLIBOBJS -LIBOBJS -extlib_flags -topdir -ld_libs -iflags -fdflags -dflags -wget -ranlib -hdf5_line -hdf5_libs -elpa_line -elpa_libs -scalapack_line -scalapack_libs -parallel_report -mpi_line -mpi_libs -mass_line -mass_libs -libxc_line -LIBS_LIBXC -fft_line -fft_libs -lapack_line -lapack_libs_switch -lapack_libs -blas_line -blas_libs -FLIBS -host_os -host_vendor -host_cpu -host -ac_ct_F77 -FFLAGS -F77 -SIZEOF_INT_P -f90rule -SET_MAKE -ldflags -ld -cppflags -cpp -foxflags -imod -fflags_nomain -fflags_noopt -fflags -f90flags -pre_fdflags -cflags -cc -ac_ct_CC -CPPFLAGS -CFLAGS -CC -mpif90 -f90 -FCFLAGS_f90 -OBJEXT -EXEEXT -ac_ct_FC -LDFLAGS -FCFLAGS -FC -arflags -ar -arch -build_os -build_vendor -build_cpu -build -EXTLIB_FLAGS -target_alias -host_alias -build_alias -LIBS -ECHO_T -ECHO_N -ECHO_C -DEFS -mandir -localedir -libdir -psdir -pdfdir -dvidir -htmldir -infodir -docdir -oldincludedir -includedir -runstatedir -localstatedir -sharedstatedir -sysconfdir -datadir -datarootdir -libexecdir -sbindir -bindir -program_transform_name -prefix -exec_prefix -PACKAGE_URL -PACKAGE_BUGREPORT -PACKAGE_STRING -PACKAGE_VERSION -PACKAGE_TARNAME -PACKAGE_NAME -PATH_SEPARATOR -SHELL' -ac_subst_files='' -ac_user_opts=' -enable_option_checking -enable_openmp -enable_parallel -enable_environment -enable_debug -enable_pedantic -enable_shared -with_libxc -with_libxc_prefix -with_libxc_include -with_scalapack -with_elpa_include -with_elpa_lib -with_elpa_version -with_hdf5 -with_hdf5_libs -with_hdf5_include -enable_signals -' - ac_precious_vars='build_alias -host_alias -target_alias -EXTLIB_FLAGS -FC -FCFLAGS -LDFLAGS -LIBS -CC -CFLAGS -CPPFLAGS -F77 -FFLAGS' - - -# Initialize some variables set by options. -ac_init_help= -ac_init_version=false -ac_unrecognized_opts= -ac_unrecognized_sep= -# The variables have the same names as the options, with -# dashes changed to underlines. -cache_file=/dev/null -exec_prefix=NONE -no_create= -no_recursion= -prefix=NONE -program_prefix=NONE -program_suffix=NONE -program_transform_name=s,x,x, -silent= -site= -srcdir= -verbose= -x_includes=NONE -x_libraries=NONE - -# Installation directory options. -# These are left unexpanded so users can "make install exec_prefix=/foo" -# and all the variables that are supposed to be based on exec_prefix -# by default will actually change. -# Use braces instead of parens because sh, perl, etc. also accept them. -# (The list follows the same order as the GNU Coding Standards.) -bindir='${exec_prefix}/bin' -sbindir='${exec_prefix}/sbin' -libexecdir='${exec_prefix}/libexec' -datarootdir='${prefix}/share' -datadir='${datarootdir}' -sysconfdir='${prefix}/etc' -sharedstatedir='${prefix}/com' -localstatedir='${prefix}/var' -runstatedir='${localstatedir}/run' -includedir='${prefix}/include' -oldincludedir='/usr/include' -docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' -infodir='${datarootdir}/info' -htmldir='${docdir}' -dvidir='${docdir}' -pdfdir='${docdir}' -psdir='${docdir}' -libdir='${exec_prefix}/lib' -localedir='${datarootdir}/locale' -mandir='${datarootdir}/man' - -ac_prev= -ac_dashdash= -for ac_option -do - # If the previous option needs an argument, assign it. - if test -n "$ac_prev"; then - eval $ac_prev=\$ac_option - ac_prev= - continue - fi - - case $ac_option in - *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; - *=) ac_optarg= ;; - *) ac_optarg=yes ;; - esac - - case $ac_dashdash$ac_option in - --) - ac_dashdash=yes ;; - - -bindir | --bindir | --bindi | --bind | --bin | --bi) - ac_prev=bindir ;; - -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) - bindir=$ac_optarg ;; - - -build | --build | --buil | --bui | --bu) - ac_prev=build_alias ;; - -build=* | --build=* | --buil=* | --bui=* | --bu=*) - build_alias=$ac_optarg ;; - - -cache-file | --cache-file | --cache-fil | --cache-fi \ - | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) - ac_prev=cache_file ;; - -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ - | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) - cache_file=$ac_optarg ;; - - --config-cache | -C) - cache_file=config.cache ;; - - -datadir | --datadir | --datadi | --datad) - ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=*) - datadir=$ac_optarg ;; - - -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ - | --dataroo | --dataro | --datar) - ac_prev=datarootdir ;; - -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ - | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) - datarootdir=$ac_optarg ;; - - -disable-* | --disable-*) - ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: \`$ac_useropt'" - ac_useropt_orig=$ac_useropt - ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval enable_$ac_useropt=no ;; - - -docdir | --docdir | --docdi | --doc | --do) - ac_prev=docdir ;; - -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) - docdir=$ac_optarg ;; - - -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) - ac_prev=dvidir ;; - -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) - dvidir=$ac_optarg ;; - - -enable-* | --enable-*) - ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: \`$ac_useropt'" - ac_useropt_orig=$ac_useropt - ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval enable_$ac_useropt=\$ac_optarg ;; - - -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ - | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ - | --exec | --exe | --ex) - ac_prev=exec_prefix ;; - -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ - | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ - | --exec=* | --exe=* | --ex=*) - exec_prefix=$ac_optarg ;; - - -gas | --gas | --ga | --g) - # Obsolete; use --with-gas. - with_gas=yes ;; - - -help | --help | --hel | --he | -h) - ac_init_help=long ;; - -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) - ac_init_help=recursive ;; - -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) - ac_init_help=short ;; - - -host | --host | --hos | --ho) - ac_prev=host_alias ;; - -host=* | --host=* | --hos=* | --ho=*) - host_alias=$ac_optarg ;; - - -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) - ac_prev=htmldir ;; - -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ - | --ht=*) - htmldir=$ac_optarg ;; - - -includedir | --includedir | --includedi | --included | --include \ - | --includ | --inclu | --incl | --inc) - ac_prev=includedir ;; - -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ - | --includ=* | --inclu=* | --incl=* | --inc=*) - includedir=$ac_optarg ;; - - -infodir | --infodir | --infodi | --infod | --info | --inf) - ac_prev=infodir ;; - -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) - infodir=$ac_optarg ;; - - -libdir | --libdir | --libdi | --libd) - ac_prev=libdir ;; - -libdir=* | --libdir=* | --libdi=* | --libd=*) - libdir=$ac_optarg ;; - - -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ - | --libexe | --libex | --libe) - ac_prev=libexecdir ;; - -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ - | --libexe=* | --libex=* | --libe=*) - libexecdir=$ac_optarg ;; - - -localedir | --localedir | --localedi | --localed | --locale) - ac_prev=localedir ;; - -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) - localedir=$ac_optarg ;; - - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst | --locals) - ac_prev=localstatedir ;; - -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) - localstatedir=$ac_optarg ;; - - -mandir | --mandir | --mandi | --mand | --man | --ma | --m) - ac_prev=mandir ;; - -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) - mandir=$ac_optarg ;; - - -nfp | --nfp | --nf) - # Obsolete; use --without-fp. - with_fp=no ;; - - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c | -n) - no_create=yes ;; - - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) - no_recursion=yes ;; - - -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ - | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ - | --oldin | --oldi | --old | --ol | --o) - ac_prev=oldincludedir ;; - -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ - | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ - | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) - oldincludedir=$ac_optarg ;; - - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - prefix=$ac_optarg ;; - - -program-prefix | --program-prefix | --program-prefi | --program-pref \ - | --program-pre | --program-pr | --program-p) - ac_prev=program_prefix ;; - -program-prefix=* | --program-prefix=* | --program-prefi=* \ - | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) - program_prefix=$ac_optarg ;; - - -program-suffix | --program-suffix | --program-suffi | --program-suff \ - | --program-suf | --program-su | --program-s) - ac_prev=program_suffix ;; - -program-suffix=* | --program-suffix=* | --program-suffi=* \ - | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) - program_suffix=$ac_optarg ;; - - -program-transform-name | --program-transform-name \ - | --program-transform-nam | --program-transform-na \ - | --program-transform-n | --program-transform- \ - | --program-transform | --program-transfor \ - | --program-transfo | --program-transf \ - | --program-trans | --program-tran \ - | --progr-tra | --program-tr | --program-t) - ac_prev=program_transform_name ;; - -program-transform-name=* | --program-transform-name=* \ - | --program-transform-nam=* | --program-transform-na=* \ - | --program-transform-n=* | --program-transform-=* \ - | --program-transform=* | --program-transfor=* \ - | --program-transfo=* | --program-transf=* \ - | --program-trans=* | --program-tran=* \ - | --progr-tra=* | --program-tr=* | --program-t=*) - program_transform_name=$ac_optarg ;; - - -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) - ac_prev=pdfdir ;; - -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) - pdfdir=$ac_optarg ;; - - -psdir | --psdir | --psdi | --psd | --ps) - ac_prev=psdir ;; - -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) - psdir=$ac_optarg ;; - - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - silent=yes ;; - - -runstatedir | --runstatedir | --runstatedi | --runstated \ - | --runstate | --runstat | --runsta | --runst | --runs \ - | --run | --ru | --r) - ac_prev=runstatedir ;; - -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ - | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ - | --run=* | --ru=* | --r=*) - runstatedir=$ac_optarg ;; - - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) - ac_prev=sbindir ;; - -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ - | --sbi=* | --sb=*) - sbindir=$ac_optarg ;; - - -sharedstatedir | --sharedstatedir | --sharedstatedi \ - | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ - | --sharedst | --shareds | --shared | --share | --shar \ - | --sha | --sh) - ac_prev=sharedstatedir ;; - -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ - | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ - | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ - | --sha=* | --sh=*) - sharedstatedir=$ac_optarg ;; - - -site | --site | --sit) - ac_prev=site ;; - -site=* | --site=* | --sit=*) - site=$ac_optarg ;; - - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - srcdir=$ac_optarg ;; - - -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ - | --syscon | --sysco | --sysc | --sys | --sy) - ac_prev=sysconfdir ;; - -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ - | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) - sysconfdir=$ac_optarg ;; - - -target | --target | --targe | --targ | --tar | --ta | --t) - ac_prev=target_alias ;; - -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) - target_alias=$ac_optarg ;; - - -v | -verbose | --verbose | --verbos | --verbo | --verb) - verbose=yes ;; - - -version | --version | --versio | --versi | --vers | -V) - ac_init_version=: ;; - - -with-* | --with-*) - ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: \`$ac_useropt'" - ac_useropt_orig=$ac_useropt - ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval with_$ac_useropt=\$ac_optarg ;; - - -without-* | --without-*) - ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: \`$ac_useropt'" - ac_useropt_orig=$ac_useropt - ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval with_$ac_useropt=no ;; - - --x) - # Obsolete; use --with-x. - with_x=yes ;; - - -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ - | --x-incl | --x-inc | --x-in | --x-i) - ac_prev=x_includes ;; - -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ - | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) - x_includes=$ac_optarg ;; - - -x-libraries | --x-libraries | --x-librarie | --x-librari \ - | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) - ac_prev=x_libraries ;; - -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ - | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) - x_libraries=$ac_optarg ;; - - -*) as_fn_error $? "unrecognized option: \`$ac_option' -Try \`$0 --help' for more information" - ;; - - *=*) - ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` - # Reject names that are not valid shell variable names. - case $ac_envvar in #( - '' | [0-9]* | *[!_$as_cr_alnum]* ) - as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; - esac - eval $ac_envvar=\$ac_optarg - export $ac_envvar ;; - - *) - # FIXME: should be removed in autoconf 3.0. - printf "%s\n" "$as_me: WARNING: you should use --build, --host, --target" >&2 - expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && - printf "%s\n" "$as_me: WARNING: invalid host type: $ac_option" >&2 - : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" - ;; - - esac -done - -if test -n "$ac_prev"; then - ac_option=--`echo $ac_prev | sed 's/_/-/g'` - as_fn_error $? "missing argument to $ac_option" -fi - -if test -n "$ac_unrecognized_opts"; then - case $enable_option_checking in - no) ;; - fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; - *) printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; - esac -fi - -# Check all directory arguments for consistency. -for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ - datadir sysconfdir sharedstatedir localstatedir includedir \ - oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir runstatedir -do - eval ac_val=\$$ac_var - # Remove trailing slashes. - case $ac_val in - */ ) - ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` - eval $ac_var=\$ac_val;; - esac - # Be sure to have absolute directory names. - case $ac_val in - [\\/$]* | ?:[\\/]* ) continue;; - NONE | '' ) case $ac_var in *prefix ) continue;; esac;; - esac - as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" -done - -# There might be people who depend on the old broken behavior: `$host' -# used to hold the argument of --host etc. -# FIXME: To remove some day. -build=$build_alias -host=$host_alias -target=$target_alias - -# FIXME: To remove some day. -if test "x$host_alias" != x; then - if test "x$build_alias" = x; then - cross_compiling=maybe - elif test "x$build_alias" != "x$host_alias"; then - cross_compiling=yes - fi -fi - -ac_tool_prefix= -test -n "$host_alias" && ac_tool_prefix=$host_alias- - -test "$silent" = yes && exec 6>/dev/null - - -ac_pwd=`pwd` && test -n "$ac_pwd" && -ac_ls_di=`ls -di .` && -ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || - as_fn_error $? "working directory cannot be determined" -test "X$ac_ls_di" = "X$ac_pwd_ls_di" || - as_fn_error $? "pwd does not report name of working directory" - - -# Find the source files, if location was not specified. -if test -z "$srcdir"; then - ac_srcdir_defaulted=yes - # Try the directory containing this script, then the parent directory. - ac_confdir=`$as_dirname -- "$as_myself" || -$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_myself" : 'X\(//\)[^/]' \| \ - X"$as_myself" : 'X\(//\)$' \| \ - X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || -printf "%s\n" X"$as_myself" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - srcdir=$ac_confdir - if test ! -r "$srcdir/$ac_unique_file"; then - srcdir=.. - fi -else - ac_srcdir_defaulted=no -fi -if test ! -r "$srcdir/$ac_unique_file"; then - test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." - as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" -fi -ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" -ac_abs_confdir=`( - cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" - pwd)` -# When building in place, set srcdir=. -if test "$ac_abs_confdir" = "$ac_pwd"; then - srcdir=. -fi -# Remove unnecessary trailing slashes from srcdir. -# Double slashes in file names in object file debugging info -# mess up M-x gdb in Emacs. -case $srcdir in -*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; -esac -for ac_var in $ac_precious_vars; do - eval ac_env_${ac_var}_set=\${${ac_var}+set} - eval ac_env_${ac_var}_value=\$${ac_var} - eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} - eval ac_cv_env_${ac_var}_value=\$${ac_var} -done - -# -# Report the --help message. -# -if test "$ac_init_help" = "long"; then - # Omit some internal or obsolete options to make the list less imposing. - # This message is too long to be a string in the A/UX 3.1 sh. - cat <<_ACEOF -\`configure' configures ESPRESSO 6.6 to adapt to many kinds of systems. - -Usage: $0 [OPTION]... [VAR=VALUE]... - -To assign environment variables (e.g., CC, CFLAGS...), specify them as -VAR=VALUE. See below for descriptions of some of the useful variables. - -Defaults for the options are specified in brackets. - -Configuration: - -h, --help display this help and exit - --help=short display options specific to this package - --help=recursive display the short help of all the included packages - -V, --version display version information and exit - -q, --quiet, --silent do not print \`checking ...' messages - --cache-file=FILE cache test results in FILE [disabled] - -C, --config-cache alias for \`--cache-file=config.cache' - -n, --no-create do not create output files - --srcdir=DIR find the sources in DIR [configure dir or \`..'] - -Installation directories: - --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] - --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [PREFIX] - -By default, \`make install' will install all the files in -\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify -an installation prefix other than \`$ac_default_prefix' using \`--prefix', -for instance \`--prefix=\$HOME'. - -For better control, use the options below. - -Fine tuning of the installation directories: - --bindir=DIR user executables [EPREFIX/bin] - --sbindir=DIR system admin executables [EPREFIX/sbin] - --libexecdir=DIR program executables [EPREFIX/libexec] - --sysconfdir=DIR read-only single-machine data [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] - --localstatedir=DIR modifiable single-machine data [PREFIX/var] - --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] - --libdir=DIR object code libraries [EPREFIX/lib] - --includedir=DIR C header files [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc [/usr/include] - --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] - --datadir=DIR read-only architecture-independent data [DATAROOTDIR] - --infodir=DIR info documentation [DATAROOTDIR/info] - --localedir=DIR locale-dependent data [DATAROOTDIR/locale] - --mandir=DIR man documentation [DATAROOTDIR/man] - --docdir=DIR documentation root [DATAROOTDIR/doc/espresso] - --htmldir=DIR html documentation [DOCDIR] - --dvidir=DIR dvi documentation [DOCDIR] - --pdfdir=DIR pdf documentation [DOCDIR] - --psdir=DIR ps documentation [DOCDIR] -_ACEOF - - cat <<\_ACEOF - -System types: - --build=BUILD configure for building on BUILD [guessed] - --host=HOST cross-compile to build programs to run on HOST [BUILD] -_ACEOF -fi - -if test -n "$ac_init_help"; then - case $ac_init_help in - short | recursive ) echo "Configuration of ESPRESSO 6.6:";; - esac - cat <<\_ACEOF - -Optional Features: - --disable-option-checking ignore unrecognized --enable/--with options - --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) - --enable-FEATURE[=ARG] include FEATURE [ARG=yes] - --enable-openmp compile for openmp execution if possible (default: - no) - --enable-parallel compile for parallel execution if possible (default: - yes) - --enable-environment compile solvent-related stuff (default: no) - --enable-debug compile Fortran with debug flags (default: no) - --enable-pedantic compile Fortran with pedantic flags (default: no) - --enable-shared use shared libraries if available (default: yes) - --enable-signals enable signal trapping (default: no) - -Optional Packages: - --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] - --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) - --with-libxc (yes|no) Use libXC for some XC functionals (default: - no) - --with-libxc-prefix=DIR Directory where libxc was installed. - --with-libxc-include=DIR - Directory where libxc Fortran headers were - installed. - --with-scalapack (yes|no|intel) Use scalapack if available. Set to - "intel" to use Intel MPI and blacs (default: use - openMPI) - --with-elpa-include Specify full path ELPA include and modules headers - (default: no) - --with-elpa-lib Specify full path ELPA static or dynamic library - (default: no) - --with-elpa-version Specify ELPA version, only year (2015 - 2019, - default: 2016) - --with-hdf5 (no|yes|) Use HDF5, if yes configure assumes - that a valid installation with version >= 1.8.16 is - available, and h5cc and h5fc are in the default - executable search path; must be the root - folder of a standalone hdf5 installation. (default: - no) - --with-hdf5-libs Specify the linker options needed by HDF5 when - configure fails to detect them by itself. As value - to specify here is usually composed by many - substrings it should be enclosed by quotes so to - prevent configure failures. (default: no) - --with-hdf5-include Specify full path the HDF5 include folder containing - module and headers files. Use it if configure fails - to detect the path by itself. (default: no) - -Some influential environment variables: - EXTLIB_FLAGS - This variable controls the flags passed to internal BLAS and - LAPACK libraries - FC Fortran compiler command - FCFLAGS Fortran compiler flags - LDFLAGS linker flags, e.g. -L if you have libraries in a - nonstandard directory - LIBS libraries to pass to the linker, e.g. -l - CC C compiler command - CFLAGS C compiler flags - CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if - you have headers in a nonstandard directory - F77 Fortran 77 compiler command - FFLAGS Fortran 77 compiler flags - -Use these variables to override the choices made by `configure' or to help -it to find libraries and programs with nonstandard names/locations. - -Report bugs to the package provider. -_ACEOF -ac_status=$? -fi - -if test "$ac_init_help" = "recursive"; then - # If there are subdirs, report their specific --help. - for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue - test -d "$ac_dir" || - { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || - continue - ac_builddir=. - -case "$ac_dir" in -.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; -*) - ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` - # A ".." for each directory in $ac_dir_suffix. - ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` - case $ac_top_builddir_sub in - "") ac_top_builddir_sub=. ac_top_build_prefix= ;; - *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; - esac ;; -esac -ac_abs_top_builddir=$ac_pwd -ac_abs_builddir=$ac_pwd$ac_dir_suffix -# for backward compatibility: -ac_top_builddir=$ac_top_build_prefix - -case $srcdir in - .) # We are building in place. - ac_srcdir=. - ac_top_srcdir=$ac_top_builddir_sub - ac_abs_top_srcdir=$ac_pwd ;; - [\\/]* | ?:[\\/]* ) # Absolute name. - ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir - ac_abs_top_srcdir=$srcdir ;; - *) # Relative name. - ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_build_prefix$srcdir - ac_abs_top_srcdir=$ac_pwd/$srcdir ;; -esac -ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix - - cd "$ac_dir" || { ac_status=$?; continue; } - # Check for configure.gnu first; this name is used for a wrapper for - # Metaconfig's "Configure" on case-insensitive file systems. - if test -f "$ac_srcdir/configure.gnu"; then - echo && - $SHELL "$ac_srcdir/configure.gnu" --help=recursive - elif test -f "$ac_srcdir/configure"; then - echo && - $SHELL "$ac_srcdir/configure" --help=recursive - else - printf "%s\n" "$as_me: WARNING: no configuration information is in $ac_dir" >&2 - fi || ac_status=$? - cd "$ac_pwd" || { ac_status=$?; break; } - done -fi - -test -n "$ac_init_help" && exit $ac_status -if $ac_init_version; then - cat <<\_ACEOF -ESPRESSO configure 6.6 -generated by GNU Autoconf 2.71 - -Copyright (C) 2021 Free Software Foundation, Inc. -This configure script is free software; the Free Software Foundation -gives unlimited permission to copy, distribute and modify it. -_ACEOF - exit -fi - -## ------------------------ ## -## Autoconf initialization. ## -## ------------------------ ## - -# ac_fn_fc_try_compile LINENO -# --------------------------- -# Try to compile conftest.$ac_ext, and return whether this succeeded. -ac_fn_fc_try_compile () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext conftest.beam - if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext -then : - ac_retval=0 -else $as_nop - printf "%s\n" "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_fc_try_compile - -# ac_fn_c_try_compile LINENO -# -------------------------- -# Try to compile conftest.$ac_ext, and return whether this succeeded. -ac_fn_c_try_compile () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext conftest.beam - if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext -then : - ac_retval=0 -else $as_nop - printf "%s\n" "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_compile - -# ac_fn_c_try_run LINENO -# ---------------------- -# Try to run conftest.$ac_ext, and return whether this succeeded. Assumes that -# executables *can* be run. -ac_fn_c_try_run () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' - { { case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_try") 2>&5 - ac_status=$? - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; } -then : - ac_retval=0 -else $as_nop - printf "%s\n" "$as_me: program exited with status $ac_status" >&5 - printf "%s\n" "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=$ac_status -fi - rm -rf conftest.dSYM conftest_ipa8_conftest.oo - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_run - -# ac_fn_c_compute_int LINENO EXPR VAR INCLUDES -# -------------------------------------------- -# Tries to find the compile-time value of EXPR in a program that includes -# INCLUDES, setting VAR accordingly. Returns whether the value could be -# computed -ac_fn_c_compute_int () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - if test "$cross_compiling" = yes; then - # Depending upon the size, compute the lo and hi bounds. -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -int -main (void) -{ -static int test_array [1 - 2 * !(($2) >= 0)]; -test_array [0] = 0; -return test_array [0]; - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO" -then : - ac_lo=0 ac_mid=0 - while :; do - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -int -main (void) -{ -static int test_array [1 - 2 * !(($2) <= $ac_mid)]; -test_array [0] = 0; -return test_array [0]; - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO" -then : - ac_hi=$ac_mid; break -else $as_nop - as_fn_arith $ac_mid + 1 && ac_lo=$as_val - if test $ac_lo -le $ac_mid; then - ac_lo= ac_hi= - break - fi - as_fn_arith 2 '*' $ac_mid + 1 && ac_mid=$as_val -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - done -else $as_nop - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -int -main (void) -{ -static int test_array [1 - 2 * !(($2) < 0)]; -test_array [0] = 0; -return test_array [0]; - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO" -then : - ac_hi=-1 ac_mid=-1 - while :; do - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -int -main (void) -{ -static int test_array [1 - 2 * !(($2) >= $ac_mid)]; -test_array [0] = 0; -return test_array [0]; - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO" -then : - ac_lo=$ac_mid; break -else $as_nop - as_fn_arith '(' $ac_mid ')' - 1 && ac_hi=$as_val - if test $ac_mid -le $ac_hi; then - ac_lo= ac_hi= - break - fi - as_fn_arith 2 '*' $ac_mid && ac_mid=$as_val -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - done -else $as_nop - ac_lo= ac_hi= -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext -# Binary search between lo and hi bounds. -while test "x$ac_lo" != "x$ac_hi"; do - as_fn_arith '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo && ac_mid=$as_val - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -int -main (void) -{ -static int test_array [1 - 2 * !(($2) <= $ac_mid)]; -test_array [0] = 0; -return test_array [0]; - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO" -then : - ac_hi=$ac_mid -else $as_nop - as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext -done -case $ac_lo in #(( -?*) eval "$3=\$ac_lo"; ac_retval=0 ;; -'') ac_retval=1 ;; -esac - else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -static long int longval (void) { return $2; } -static unsigned long int ulongval (void) { return $2; } -#include -#include -int -main (void) -{ - - FILE *f = fopen ("conftest.val", "w"); - if (! f) - return 1; - if (($2) < 0) - { - long int i = longval (); - if (i != ($2)) - return 1; - fprintf (f, "%ld", i); - } - else - { - unsigned long int i = ulongval (); - if (i != ($2)) - return 1; - fprintf (f, "%lu", i); - } - /* Do not output a trailing newline, as this causes \r\n confusion - on some platforms. */ - return ferror (f) || fclose (f) != 0; - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_run "$LINENO" -then : - echo >>conftest.val; read $3 &5 -printf %s "checking for $2... " >&6; } -if eval test \${$3+y} -then : - printf %s "(cached) " >&6 -else $as_nop - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -#include <$2> -_ACEOF -if ac_fn_c_try_compile "$LINENO" -then : - eval "$3=yes" -else $as_nop - eval "$3=no" -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext -fi -eval ac_res=\$$3 - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -printf "%s\n" "$ac_res" >&6; } - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_header_compile - -# ac_fn_f77_try_compile LINENO -# ---------------------------- -# Try to compile conftest.$ac_ext, and return whether this succeeded. -ac_fn_f77_try_compile () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext conftest.beam - if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_f77_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext -then : - ac_retval=0 -else $as_nop - printf "%s\n" "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_f77_try_compile - -# ac_fn_c_try_link LINENO -# ----------------------- -# Try to link conftest.$ac_ext, and return whether this succeeded. -ac_fn_c_try_link () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext conftest.beam conftest$ac_exeext - if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - test -x conftest$ac_exeext - } -then : - ac_retval=0 -else $as_nop - printf "%s\n" "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information - # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would - # interfere with the next link command; also delete a directory that is - # left behind by Apple's compiler. We do this before executing the actions. - rm -rf conftest.dSYM conftest_ipa8_conftest.oo - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_link - -# ac_fn_f77_try_link LINENO -# ------------------------- -# Try to link conftest.$ac_ext, and return whether this succeeded. -ac_fn_f77_try_link () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext conftest.beam conftest$ac_exeext - if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_f77_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - test -x conftest$ac_exeext - } -then : - ac_retval=0 -else $as_nop - printf "%s\n" "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information - # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would - # interfere with the next link command; also delete a directory that is - # left behind by Apple's compiler. We do this before executing the actions. - rm -rf conftest.dSYM conftest_ipa8_conftest.oo - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_f77_try_link - -# ac_fn_fc_try_link LINENO -# ------------------------ -# Try to link conftest.$ac_ext, and return whether this succeeded. -ac_fn_fc_try_link () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext conftest.beam conftest$ac_exeext - if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - test -x conftest$ac_exeext - } -then : - ac_retval=0 -else $as_nop - printf "%s\n" "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information - # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would - # interfere with the next link command; also delete a directory that is - # left behind by Apple's compiler. We do this before executing the actions. - rm -rf conftest.dSYM conftest_ipa8_conftest.oo - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_fc_try_link -ac_configure_args_raw= -for ac_arg -do - case $ac_arg in - *\'*) - ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; - esac - as_fn_append ac_configure_args_raw " '$ac_arg'" -done - -case $ac_configure_args_raw in - *$as_nl*) - ac_safe_unquote= ;; - *) - ac_unsafe_z='|&;<>()$`\\"*?[ '' ' # This string ends in space, tab. - ac_unsafe_a="$ac_unsafe_z#~" - ac_safe_unquote="s/ '\\([^$ac_unsafe_a][^$ac_unsafe_z]*\\)'/ \\1/g" - ac_configure_args_raw=` printf "%s\n" "$ac_configure_args_raw" | sed "$ac_safe_unquote"`;; -esac - -cat >config.log <<_ACEOF -This file contains any messages produced by compilers while -running configure, to aid debugging if configure makes a mistake. - -It was created by ESPRESSO $as_me 6.6, which was -generated by GNU Autoconf 2.71. Invocation command line was - - $ $0$ac_configure_args_raw - -_ACEOF -exec 5>>config.log -{ -cat <<_ASUNAME -## --------- ## -## Platform. ## -## --------- ## - -hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` -uname -m = `(uname -m) 2>/dev/null || echo unknown` -uname -r = `(uname -r) 2>/dev/null || echo unknown` -uname -s = `(uname -s) 2>/dev/null || echo unknown` -uname -v = `(uname -v) 2>/dev/null || echo unknown` - -/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` -/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` - -/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` -/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` -/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` -/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` -/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` -/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` -/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` - -_ASUNAME - -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - printf "%s\n" "PATH: $as_dir" - done -IFS=$as_save_IFS - -} >&5 - -cat >&5 <<_ACEOF - - -## ----------- ## -## Core tests. ## -## ----------- ## - -_ACEOF - - -# Keep a trace of the command line. -# Strip out --no-create and --no-recursion so they do not pile up. -# Strip out --silent because we don't want to record it for future runs. -# Also quote any args containing shell meta-characters. -# Make two passes to allow for proper duplicate-argument suppression. -ac_configure_args= -ac_configure_args0= -ac_configure_args1= -ac_must_keep_next=false -for ac_pass in 1 2 -do - for ac_arg - do - case $ac_arg in - -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - continue ;; - *\'*) - ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; - esac - case $ac_pass in - 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; - 2) - as_fn_append ac_configure_args1 " '$ac_arg'" - if test $ac_must_keep_next = true; then - ac_must_keep_next=false # Got value, back to normal. - else - case $ac_arg in - *=* | --config-cache | -C | -disable-* | --disable-* \ - | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ - | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ - | -with-* | --with-* | -without-* | --without-* | --x) - case "$ac_configure_args0 " in - "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; - esac - ;; - -* ) ac_must_keep_next=true ;; - esac - fi - as_fn_append ac_configure_args " '$ac_arg'" - ;; - esac - done -done -{ ac_configure_args0=; unset ac_configure_args0;} -{ ac_configure_args1=; unset ac_configure_args1;} - -# When interrupted or exit'd, cleanup temporary files, and complete -# config.log. We remove comments because anyway the quotes in there -# would cause problems or look ugly. -# WARNING: Use '\'' to represent an apostrophe within the trap. -# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. -trap 'exit_status=$? - # Sanitize IFS. - IFS=" "" $as_nl" - # Save into config.log some information that might help in debugging. - { - echo - - printf "%s\n" "## ---------------- ## -## Cache variables. ## -## ---------------- ##" - echo - # The following way of writing the cache mishandles newlines in values, -( - for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do - eval ac_val=\$$ac_var - case $ac_val in #( - *${as_nl}*) - case $ac_var in #( - *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 -printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; - esac - case $ac_var in #( - _ | IFS | as_nl) ;; #( - BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) { eval $ac_var=; unset $ac_var;} ;; - esac ;; - esac - done - (set) 2>&1 | - case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( - *${as_nl}ac_space=\ *) - sed -n \ - "s/'\''/'\''\\\\'\'''\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" - ;; #( - *) - sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" - ;; - esac | - sort -) - echo - - printf "%s\n" "## ----------------- ## -## Output variables. ## -## ----------------- ##" - echo - for ac_var in $ac_subst_vars - do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - printf "%s\n" "$ac_var='\''$ac_val'\''" - done | sort - echo - - if test -n "$ac_subst_files"; then - printf "%s\n" "## ------------------- ## -## File substitutions. ## -## ------------------- ##" - echo - for ac_var in $ac_subst_files - do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - printf "%s\n" "$ac_var='\''$ac_val'\''" - done | sort - echo - fi - - if test -s confdefs.h; then - printf "%s\n" "## ----------- ## -## confdefs.h. ## -## ----------- ##" - echo - cat confdefs.h - echo - fi - test "$ac_signal" != 0 && - printf "%s\n" "$as_me: caught signal $ac_signal" - printf "%s\n" "$as_me: exit $exit_status" - } >&5 - rm -f core *.core core.conftest.* && - rm -f -r conftest* confdefs* conf$$* $ac_clean_files && - exit $exit_status -' 0 -for ac_signal in 1 2 13 15; do - trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal -done -ac_signal=0 - -# confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -f -r conftest* confdefs.h - -printf "%s\n" "/* confdefs.h */" > confdefs.h - -# Predefined preprocessor variables. - -printf "%s\n" "#define PACKAGE_NAME \"$PACKAGE_NAME\"" >>confdefs.h - -printf "%s\n" "#define PACKAGE_TARNAME \"$PACKAGE_TARNAME\"" >>confdefs.h - -printf "%s\n" "#define PACKAGE_VERSION \"$PACKAGE_VERSION\"" >>confdefs.h - -printf "%s\n" "#define PACKAGE_STRING \"$PACKAGE_STRING\"" >>confdefs.h - -printf "%s\n" "#define PACKAGE_BUGREPORT \"$PACKAGE_BUGREPORT\"" >>confdefs.h - -printf "%s\n" "#define PACKAGE_URL \"$PACKAGE_URL\"" >>confdefs.h - - -# Let the site file select an alternate cache file if it wants to. -# Prefer an explicitly selected file to automatically selected ones. -if test -n "$CONFIG_SITE"; then - ac_site_files="$CONFIG_SITE" -elif test "x$prefix" != xNONE; then - ac_site_files="$prefix/share/config.site $prefix/etc/config.site" -else - ac_site_files="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" -fi - -for ac_site_file in $ac_site_files -do - case $ac_site_file in #( - */*) : - ;; #( - *) : - ac_site_file=./$ac_site_file ;; -esac - if test -f "$ac_site_file" && test -r "$ac_site_file"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 -printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;} - sed 's/^/| /' "$ac_site_file" >&5 - . "$ac_site_file" \ - || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "failed to load site script $ac_site_file -See \`config.log' for more details" "$LINENO" 5; } - fi -done - -if test -r "$cache_file"; then - # Some versions of bash will fail to source /dev/null (special files - # actually), so we avoid doing that. DJGPP emulates it as a regular file. - if test /dev/null != "$cache_file" && test -f "$cache_file"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 -printf "%s\n" "$as_me: loading cache $cache_file" >&6;} - case $cache_file in - [\\/]* | ?:[\\/]* ) . "$cache_file";; - *) . "./$cache_file";; - esac - fi -else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 -printf "%s\n" "$as_me: creating cache $cache_file" >&6;} - >$cache_file -fi - -# Test code for whether the C compiler supports C89 (global declarations) -ac_c_conftest_c89_globals=' -/* Does the compiler advertise C89 conformance? - Do not test the value of __STDC__, because some compilers set it to 0 - while being otherwise adequately conformant. */ -#if !defined __STDC__ -# error "Compiler does not advertise C89 conformance" -#endif - -#include -#include -struct stat; -/* Most of the following tests are stolen from RCS 5.7 src/conf.sh. */ -struct buf { int x; }; -struct buf * (*rcsopen) (struct buf *, struct stat *, int); -static char *e (p, i) - char **p; - int i; -{ - return p[i]; -} -static char *f (char * (*g) (char **, int), char **p, ...) -{ - char *s; - va_list v; - va_start (v,p); - s = g (p, va_arg (v,int)); - va_end (v); - return s; -} - -/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has - function prototypes and stuff, but not \xHH hex character constants. - These do not provoke an error unfortunately, instead are silently treated - as an "x". The following induces an error, until -std is added to get - proper ANSI mode. Curiously \x00 != x always comes out true, for an - array size at least. It is necessary to write \x00 == 0 to get something - that is true only with -std. */ -int osf4_cc_array ['\''\x00'\'' == 0 ? 1 : -1]; - -/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters - inside strings and character constants. */ -#define FOO(x) '\''x'\'' -int xlc6_cc_array[FOO(a) == '\''x'\'' ? 1 : -1]; - -int test (int i, double x); -struct s1 {int (*f) (int a);}; -struct s2 {int (*f) (double a);}; -int pairnames (int, char **, int *(*)(struct buf *, struct stat *, int), - int, int);' - -# Test code for whether the C compiler supports C89 (body of main). -ac_c_conftest_c89_main=' -ok |= (argc == 0 || f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]); -' - -# Test code for whether the C compiler supports C99 (global declarations) -ac_c_conftest_c99_globals=' -// Does the compiler advertise C99 conformance? -#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L -# error "Compiler does not advertise C99 conformance" -#endif - -#include -extern int puts (const char *); -extern int printf (const char *, ...); -extern int dprintf (int, const char *, ...); -extern void *malloc (size_t); - -// Check varargs macros. These examples are taken from C99 6.10.3.5. -// dprintf is used instead of fprintf to avoid needing to declare -// FILE and stderr. -#define debug(...) dprintf (2, __VA_ARGS__) -#define showlist(...) puts (#__VA_ARGS__) -#define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__)) -static void -test_varargs_macros (void) -{ - int x = 1234; - int y = 5678; - debug ("Flag"); - debug ("X = %d\n", x); - showlist (The first, second, and third items.); - report (x>y, "x is %d but y is %d", x, y); -} - -// Check long long types. -#define BIG64 18446744073709551615ull -#define BIG32 4294967295ul -#define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0) -#if !BIG_OK - #error "your preprocessor is broken" -#endif -#if BIG_OK -#else - #error "your preprocessor is broken" -#endif -static long long int bignum = -9223372036854775807LL; -static unsigned long long int ubignum = BIG64; - -struct incomplete_array -{ - int datasize; - double data[]; -}; - -struct named_init { - int number; - const wchar_t *name; - double average; -}; - -typedef const char *ccp; - -static inline int -test_restrict (ccp restrict text) -{ - // See if C++-style comments work. - // Iterate through items via the restricted pointer. - // Also check for declarations in for loops. - for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i) - continue; - return 0; -} - -// Check varargs and va_copy. -static bool -test_varargs (const char *format, ...) -{ - va_list args; - va_start (args, format); - va_list args_copy; - va_copy (args_copy, args); - - const char *str = ""; - int number = 0; - float fnumber = 0; - - while (*format) - { - switch (*format++) - { - case '\''s'\'': // string - str = va_arg (args_copy, const char *); - break; - case '\''d'\'': // int - number = va_arg (args_copy, int); - break; - case '\''f'\'': // float - fnumber = va_arg (args_copy, double); - break; - default: - break; - } - } - va_end (args_copy); - va_end (args); - - return *str && number && fnumber; -} -' - -# Test code for whether the C compiler supports C99 (body of main). -ac_c_conftest_c99_main=' - // Check bool. - _Bool success = false; - success |= (argc != 0); - - // Check restrict. - if (test_restrict ("String literal") == 0) - success = true; - char *restrict newvar = "Another string"; - - // Check varargs. - success &= test_varargs ("s, d'\'' f .", "string", 65, 34.234); - test_varargs_macros (); - - // Check flexible array members. - struct incomplete_array *ia = - malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10)); - ia->datasize = 10; - for (int i = 0; i < ia->datasize; ++i) - ia->data[i] = i * 1.234; - - // Check named initializers. - struct named_init ni = { - .number = 34, - .name = L"Test wide string", - .average = 543.34343, - }; - - ni.number = 58; - - int dynamic_array[ni.number]; - dynamic_array[0] = argv[0][0]; - dynamic_array[ni.number - 1] = 543; - - // work around unused variable warnings - ok |= (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == '\''x'\'' - || dynamic_array[ni.number - 1] != 543); -' - -# Test code for whether the C compiler supports C11 (global declarations) -ac_c_conftest_c11_globals=' -// Does the compiler advertise C11 conformance? -#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L -# error "Compiler does not advertise C11 conformance" -#endif - -// Check _Alignas. -char _Alignas (double) aligned_as_double; -char _Alignas (0) no_special_alignment; -extern char aligned_as_int; -char _Alignas (0) _Alignas (int) aligned_as_int; - -// Check _Alignof. -enum -{ - int_alignment = _Alignof (int), - int_array_alignment = _Alignof (int[100]), - char_alignment = _Alignof (char) -}; -_Static_assert (0 < -_Alignof (int), "_Alignof is signed"); - -// Check _Noreturn. -int _Noreturn does_not_return (void) { for (;;) continue; } - -// Check _Static_assert. -struct test_static_assert -{ - int x; - _Static_assert (sizeof (int) <= sizeof (long int), - "_Static_assert does not work in struct"); - long int y; -}; - -// Check UTF-8 literals. -#define u8 syntax error! -char const utf8_literal[] = u8"happens to be ASCII" "another string"; - -// Check duplicate typedefs. -typedef long *long_ptr; -typedef long int *long_ptr; -typedef long_ptr long_ptr; - -// Anonymous structures and unions -- taken from C11 6.7.2.1 Example 1. -struct anonymous -{ - union { - struct { int i; int j; }; - struct { int k; long int l; } w; - }; - int m; -} v1; -' - -# Test code for whether the C compiler supports C11 (body of main). -ac_c_conftest_c11_main=' - _Static_assert ((offsetof (struct anonymous, i) - == offsetof (struct anonymous, w.k)), - "Anonymous union alignment botch"); - v1.i = 2; - v1.w.k = 5; - ok |= v1.i != 5; -' - -# Test code for whether the C compiler supports C11 (complete). -ac_c_conftest_c11_program="${ac_c_conftest_c89_globals} -${ac_c_conftest_c99_globals} -${ac_c_conftest_c11_globals} - -int -main (int argc, char **argv) -{ - int ok = 0; - ${ac_c_conftest_c89_main} - ${ac_c_conftest_c99_main} - ${ac_c_conftest_c11_main} - return ok; -} -" - -# Test code for whether the C compiler supports C99 (complete). -ac_c_conftest_c99_program="${ac_c_conftest_c89_globals} -${ac_c_conftest_c99_globals} - -int -main (int argc, char **argv) -{ - int ok = 0; - ${ac_c_conftest_c89_main} - ${ac_c_conftest_c99_main} - return ok; -} -" - -# Test code for whether the C compiler supports C89 (complete). -ac_c_conftest_c89_program="${ac_c_conftest_c89_globals} - -int -main (int argc, char **argv) -{ - int ok = 0; - ${ac_c_conftest_c89_main} - return ok; -} -" - -as_fn_append ac_header_c_list " stdio.h stdio_h HAVE_STDIO_H" -as_fn_append ac_header_c_list " stdlib.h stdlib_h HAVE_STDLIB_H" -as_fn_append ac_header_c_list " string.h string_h HAVE_STRING_H" -as_fn_append ac_header_c_list " inttypes.h inttypes_h HAVE_INTTYPES_H" -as_fn_append ac_header_c_list " stdint.h stdint_h HAVE_STDINT_H" -as_fn_append ac_header_c_list " strings.h strings_h HAVE_STRINGS_H" -as_fn_append ac_header_c_list " sys/stat.h sys_stat_h HAVE_SYS_STAT_H" -as_fn_append ac_header_c_list " sys/types.h sys_types_h HAVE_SYS_TYPES_H" -as_fn_append ac_header_c_list " unistd.h unistd_h HAVE_UNISTD_H" - -# Auxiliary files required by this configure script. -ac_aux_files="config.guess config.sub" - -# Locations in which to look for auxiliary files. -ac_aux_dir_candidates="${srcdir}${PATH_SEPARATOR}${srcdir}/..${PATH_SEPARATOR}${srcdir}/../.." - -# Search for a directory containing all of the required auxiliary files, -# $ac_aux_files, from the $PATH-style list $ac_aux_dir_candidates. -# If we don't find one directory that contains all the files we need, -# we report the set of missing files from the *first* directory in -# $ac_aux_dir_candidates and give up. -ac_missing_aux_files="" -ac_first_candidate=: -printf "%s\n" "$as_me:${as_lineno-$LINENO}: looking for aux files: $ac_aux_files" >&5 -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -as_found=false -for as_dir in $ac_aux_dir_candidates -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - as_found=: - - printf "%s\n" "$as_me:${as_lineno-$LINENO}: trying $as_dir" >&5 - ac_aux_dir_found=yes - ac_install_sh= - for ac_aux in $ac_aux_files - do - # As a special case, if "install-sh" is required, that requirement - # can be satisfied by any of "install-sh", "install.sh", or "shtool", - # and $ac_install_sh is set appropriately for whichever one is found. - if test x"$ac_aux" = x"install-sh" - then - if test -f "${as_dir}install-sh"; then - printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}install-sh found" >&5 - ac_install_sh="${as_dir}install-sh -c" - elif test -f "${as_dir}install.sh"; then - printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}install.sh found" >&5 - ac_install_sh="${as_dir}install.sh -c" - elif test -f "${as_dir}shtool"; then - printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}shtool found" >&5 - ac_install_sh="${as_dir}shtool install -c" - else - ac_aux_dir_found=no - if $ac_first_candidate; then - ac_missing_aux_files="${ac_missing_aux_files} install-sh" - else - break - fi - fi - else - if test -f "${as_dir}${ac_aux}"; then - printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}${ac_aux} found" >&5 - else - ac_aux_dir_found=no - if $ac_first_candidate; then - ac_missing_aux_files="${ac_missing_aux_files} ${ac_aux}" - else - break - fi - fi - fi - done - if test "$ac_aux_dir_found" = yes; then - ac_aux_dir="$as_dir" - break - fi - ac_first_candidate=false - - as_found=false -done -IFS=$as_save_IFS -if $as_found -then : - -else $as_nop - as_fn_error $? "cannot find required auxiliary files:$ac_missing_aux_files" "$LINENO" 5 -fi - - -# These three variables are undocumented and unsupported, -# and are intended to be withdrawn in a future Autoconf release. -# They can cause serious problems if a builder's source tree is in a directory -# whose full name contains unusual characters. -if test -f "${ac_aux_dir}config.guess"; then - ac_config_guess="$SHELL ${ac_aux_dir}config.guess" -fi -if test -f "${ac_aux_dir}config.sub"; then - ac_config_sub="$SHELL ${ac_aux_dir}config.sub" -fi -if test -f "$ac_aux_dir/configure"; then - ac_configure="$SHELL ${ac_aux_dir}configure" -fi - -# Check that the precious variables saved in the cache have kept the same -# value. -ac_cache_corrupted=false -for ac_var in $ac_precious_vars; do - eval ac_old_set=\$ac_cv_env_${ac_var}_set - eval ac_new_set=\$ac_env_${ac_var}_set - eval ac_old_val=\$ac_cv_env_${ac_var}_value - eval ac_new_val=\$ac_env_${ac_var}_value - case $ac_old_set,$ac_new_set in - set,) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 -printf "%s\n" "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} - ac_cache_corrupted=: ;; - ,set) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 -printf "%s\n" "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} - ac_cache_corrupted=: ;; - ,);; - *) - if test "x$ac_old_val" != "x$ac_new_val"; then - # differences in whitespace do not lead to failure. - ac_old_val_w=`echo x $ac_old_val` - ac_new_val_w=`echo x $ac_new_val` - if test "$ac_old_val_w" != "$ac_new_val_w"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 -printf "%s\n" "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} - ac_cache_corrupted=: - else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 -printf "%s\n" "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} - eval $ac_var=\$ac_old_val - fi - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 -printf "%s\n" "$as_me: former value: \`$ac_old_val'" >&2;} - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 -printf "%s\n" "$as_me: current value: \`$ac_new_val'" >&2;} - fi;; - esac - # Pass precious variables to config.status. - if test "$ac_new_set" = set; then - case $ac_new_val in - *\'*) ac_arg=$ac_var=`printf "%s\n" "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; - *) ac_arg=$ac_var=$ac_new_val ;; - esac - case " $ac_configure_args " in - *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. - *) as_fn_append ac_configure_args " '$ac_arg'" ;; - esac - fi -done -if $ac_cache_corrupted; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 -printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;} - as_fn_error $? "run \`${MAKE-make} distclean' and/or \`rm $cache_file' - and start over" "$LINENO" 5 -fi -## -------------------- ## -## Main body of script. ## -## -------------------- ## - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - - - - - -# Initialize variables, filling with one comes from the environment... - - -# Non-standard precious variables - - -# store variables from the environment, if set (may be or not be set) -# If set, they take precedence over configure internal choice. -# Flags and libraries are accepted without further testing; -# compilers are tested. Specify compiler name only, not the full path -# (i.e. F90=/usr/local/bin/f90 may not work, use F90=f90) - -topdir=$TOPDIR # current directory -arch=$ARCH # see below for recognized architectures -env_cc=$CC # C compiler (must be in the execution path) -cpp=$CPP # C preprocessor (as above) -cflags=$CFLAGS # Flags for C compiler -cppflags=$CPPFLAGS # Flags for C preprocessor -dflags=$DFLAGS # Fortran file preprocessing options, e.g. -D__DEFINE_THIS -iflags=$IFLAGS # Location of include files - shouldn't be needed -f90=$F90 # Fortran 90 serial compiler (must be in execution path) -mpif90=$MPIF90 # Fortran 90 parallel compiler (must be in execution path) -fflags=$FFLAGS # Flags for Fortran 77 and 90 compilers -fflags_nomain=$FFLAGS_NOMAIN # Flags for linking Fortran sources with main in a different language -fflags_noopt=$FFLAGS_NOOPT # as FFLAGS With optimization disabled -f90flags=$F90FLAGS # Flags for Fortran 90 compiler only -ld=$LD # Loader (must be in the execution path) -ldflags=$LDFLAGS # Flags for loader -ld_libs=$LD_LIBS # Additional libraries -blas_libs=$BLAS_LIBS # blas library - specify e.g. /my/blas/lib/libmyblas.a - # or -L/my/blas/lib -lmyblas -lapack_libs=$LAPACK_LIBS # lapack library, similar to above -fft_libs=$FFT_LIBS # FFT libraries - may depend upon DFLAGS -mpi_libs=$MPI_LIBS # MPI libraries - shouldn't be needed -mass_libs=$MASS_LIBS # MASS libraries (IBM only) -libdirs=$LIBDIRS # Where to look for libraries (e.g. /my/blas/lib) -scalapack_libs=$SCALAPACK_LIBS # scalapack libs -scalapack_dir=$SCALAPACK_LIB # Where to look for scalapack libs -blacs_dir=$BLACS_LIB # Where to look for libblacs.a -ar=$AR # ar (shouldn't be needed) -arflags=$ARFLAGS # Flags for ar (as above) -extlib_flags=$EXTLIB_FLAGS # Flags for internal copies of lapack and blas - - - - -# configure for current directory by default -if test "$topdir" = "" ; then topdir="`pwd`" ; fi - -# check system type (no cross-compilation for now) - - - - # Make sure we can run config.sub. -$SHELL "${ac_aux_dir}config.sub" sun4 >/dev/null 2>&1 || - as_fn_error $? "cannot run $SHELL ${ac_aux_dir}config.sub" "$LINENO" 5 - -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 -printf %s "checking build system type... " >&6; } -if test ${ac_cv_build+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_build_alias=$build_alias -test "x$ac_build_alias" = x && - ac_build_alias=`$SHELL "${ac_aux_dir}config.guess"` -test "x$ac_build_alias" = x && - as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5 -ac_cv_build=`$SHELL "${ac_aux_dir}config.sub" $ac_build_alias` || - as_fn_error $? "$SHELL ${ac_aux_dir}config.sub $ac_build_alias failed" "$LINENO" 5 - -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 -printf "%s\n" "$ac_cv_build" >&6; } -case $ac_cv_build in -*-*-*) ;; -*) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;; -esac -build=$ac_cv_build -ac_save_IFS=$IFS; IFS='-' -set x $ac_cv_build -shift -build_cpu=$1 -build_vendor=$2 -shift; shift -# Remember, the first character of IFS is used to create $*, -# except with old shells: -build_os=$* -IFS=$ac_save_IFS -case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac - - - -# Checking Architecture... - - - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking ARCH" >&5 -printf %s "checking ARCH... " >&6; } - -# many HPC systems are configured so that running parallel programs -# interactively is disabled: on those systems, AC_PROG_FC / _CC -# would fail because they can't run the compiled executables. -# to work around that, let's pretend we are cross-compiling even if we aren't -# !!! this relies on undocumented Autoconf behavior !!! - -# This is used to distinguish between true and fake cross compilation -# (only on NEC SX8 actually) -if test "$host" != "" ; then ranlib=echo; fi - - -# cross compiling? Why? -#cross_compiling=yes - -if test "$host" = "" ; then host=$build; fi - -# identify host architecture -if test "$arch" = "" -then - case $host in - ia64-*-linux-gnu ) arch=ia64 ;; - x86_64-*-linux-gnu ) arch=x86_64 ;; - arm-*linux* ) arch=arm ;; - aarch64-*-linux-gnu ) arch=arm ;; - *-pc-linux-gnu ) arch=ia32 ;; - *-apple-darwin* ) arch=mac686 ;; - *-pc-cygwin ) arch=cygwin ;; - sx*-nec* ) arch=necsx ;; - powerpc64-*-linux-gnu ) arch=ppc64 ;; - powerpc64le-*-linux-gnu ) arch=ppc64le ;; - *-*-mingw32 ) arch=mingw32;; - *-*-mingw64 ) arch=mingw64;; - * ) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Unrecognized build architecture" >&5 -printf "%s\n" "$as_me: WARNING: Unrecognized build architecture" >&2;} - ;; - esac - # workaround for Cray-XT machines - test -d /proc/cray_xt && arch=crayxt - # workaround for IBM BG machines - test -d /bgsys && arch=ppc64-bg - test -f /bgsys/drivers/ppcfloor/bin/runjob && arch=ppc64-bgq -fi - case $arch in - ia32 | ia64 | necsx | crayxt | ppc64-bg ) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Obsolete architecture? $arch" >&5 -printf "%s\n" "$as_me: WARNING: Obsolete architecture? $arch" >&2;} - ;; - esac - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${arch}" >&5 -printf "%s\n" "${arch}" >&6; } - - - - -# Add all needed -D options to try_dflags -try_dflags="" - -# Add needed include directories -try_iflags="-I../include " - -# Checking archiver... - - - # default from the environment (shouldn't be needed) - ar=$AR - arflags=$ARFLAGS - - try_ar="ar" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking setting AR... " >&5 -printf %s "checking setting AR... ... " >&6; } - if test "$arch" = "necsx"; then - try_ar="sxar" - fi - if test "$ar" = "" ; then ar="$try_ar" ; fi - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${ar}" >&5 -printf "%s\n" "${ar}" >&6; } - - - try_arflags="ruv" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking setting ARFLAGS... " >&5 -printf %s "checking setting ARFLAGS... ... " >&6; } - if test "$arch" = "necsx"; then - try_arflags="rv" - fi - if test "$arflags" = "" ; then arflags="$try_arflags" ; fi - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${arflags}" >&5 -printf "%s\n" "${arflags}" >&6; } - - - - - -# Checking OpenMP... - - -# Check whether --enable-openmp was given. -if test ${enable_openmp+y} -then : - enableval=$enable_openmp; if test "$enableval" = "yes" ; then - use_openmp=1 - else - use_openmp=0 - fi -else $as_nop - use_openmp=0 -fi - - - - -# Checking MPIF90... -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu -if test -n "$ac_tool_prefix"; then - for ac_prog in gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn nagfor xlf90 f90 pgf90 pghpf epcf90 g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 - do - # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. -set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -printf %s "checking for $ac_word... " >&6; } -if test ${ac_cv_prog_FC+y} -then : - printf %s "(cached) " >&6 -else $as_nop - if test -n "$FC"; then - ac_cv_prog_FC="$FC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then - ac_cv_prog_FC="$ac_tool_prefix$ac_prog" - printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -FC=$ac_cv_prog_FC -if test -n "$FC"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $FC" >&5 -printf "%s\n" "$FC" >&6; } -else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } -fi - - - test -n "$FC" && break - done -fi -if test -z "$FC"; then - ac_ct_FC=$FC - for ac_prog in gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn nagfor xlf90 f90 pgf90 pghpf epcf90 g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 -do - # Extract the first word of "$ac_prog", so it can be a program name with args. -set dummy $ac_prog; ac_word=$2 -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -printf %s "checking for $ac_word... " >&6; } -if test ${ac_cv_prog_ac_ct_FC+y} -then : - printf %s "(cached) " >&6 -else $as_nop - if test -n "$ac_ct_FC"; then - ac_cv_prog_ac_ct_FC="$ac_ct_FC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_FC="$ac_prog" - printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -ac_ct_FC=$ac_cv_prog_ac_ct_FC -if test -n "$ac_ct_FC"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_FC" >&5 -printf "%s\n" "$ac_ct_FC" >&6; } -else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } -fi - - - test -n "$ac_ct_FC" && break -done - - if test "x$ac_ct_FC" = x; then - FC="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - FC=$ac_ct_FC - fi -fi - - -# Provide some information about the compiler. -printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler version" >&5 -set X $ac_compile -ac_compiler=$2 -for ac_option in --version -v -V -qversion; do - { { ac_try="$ac_compiler $ac_option >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_compiler $ac_option >&5") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - sed '10a\ -... rest of stderr output deleted ... - 10q' conftest.err >conftest.er1 - cat conftest.er1 >&5 - fi - rm -f conftest.er1 conftest.err - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } -done -rm -f a.out - -cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -ac_clean_files_save=$ac_clean_files -ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" -# Try to create an executable without -o first, disregard a.out. -# It will help us diagnose broken compilers, and finding out an intuition -# of exeext. -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the Fortran compiler works" >&5 -printf %s "checking whether the Fortran compiler works... " >&6; } -ac_link_default=`printf "%s\n" "$ac_link" | sed 's/ -o *conftest[^ ]*//'` - -# The possible output files: -ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" - -ac_rmfiles= -for ac_file in $ac_files -do - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; - * ) ac_rmfiles="$ac_rmfiles $ac_file";; - esac -done -rm -f $ac_rmfiles - -if { { ac_try="$ac_link_default" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_link_default") 2>&5 - ac_status=$? - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } -then : - # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. -# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' -# in a Makefile. We should not override ac_cv_exeext if it was cached, -# so that the user can short-circuit this test for compilers unknown to -# Autoconf. -for ac_file in $ac_files '' -do - test -f "$ac_file" || continue - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) - ;; - [ab].out ) - # We found the default executable, but exeext='' is most - # certainly right. - break;; - *.* ) - if test ${ac_cv_exeext+y} && test "$ac_cv_exeext" != no; - then :; else - ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - fi - # We set ac_cv_exeext here because the later test for it is not - # safe: cross compilers may not add the suffix if given an `-o' - # argument, so we may need to know it at that point already. - # Even if this section looks crufty: it has the advantage of - # actually working. - break;; - * ) - break;; - esac -done -test "$ac_cv_exeext" = no && ac_cv_exeext= - -else $as_nop - ac_file='' -fi -if test -z "$ac_file" -then : - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } -printf "%s\n" "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error 77 "Fortran compiler cannot create executables -See \`config.log' for more details" "$LINENO" 5; } -else $as_nop - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -printf "%s\n" "yes" >&6; } -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler default output file name" >&5 -printf %s "checking for Fortran compiler default output file name... " >&6; } -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 -printf "%s\n" "$ac_file" >&6; } -ac_exeext=$ac_cv_exeext - -rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out -ac_clean_files=$ac_clean_files_save -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 -printf %s "checking for suffix of executables... " >&6; } -if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } -then : - # If both `conftest.exe' and `conftest' are `present' (well, observable) -# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will -# work properly (i.e., refer to `conftest.exe'), while it won't with -# `rm'. -for ac_file in conftest.exe conftest conftest.*; do - test -f "$ac_file" || continue - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; - *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - break;; - * ) break;; - esac -done -else $as_nop - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot compute suffix of executables: cannot compile and link -See \`config.log' for more details" "$LINENO" 5; } -fi -rm -f conftest conftest$ac_cv_exeext -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 -printf "%s\n" "$ac_cv_exeext" >&6; } - -rm -f conftest.$ac_ext -EXEEXT=$ac_cv_exeext -ac_exeext=$EXEEXT -cat > conftest.$ac_ext <<_ACEOF - program main - open(unit=9,file='conftest.out') - close(unit=9) - - end -_ACEOF -ac_clean_files="$ac_clean_files conftest.out" -# Check that the compiler produces executables we can run. If not, either -# the compiler is broken, or we cross compile. -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 -printf %s "checking whether we are cross compiling... " >&6; } -if test "$cross_compiling" != yes; then - { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } - if { ac_try='./conftest$ac_cv_exeext' - { { case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_try") 2>&5 - ac_status=$? - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; }; then - cross_compiling=no - else - if test "$cross_compiling" = maybe; then - cross_compiling=yes - else - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error 77 "cannot run Fortran compiled programs. -If you meant to cross compile, use \`--host'. -See \`config.log' for more details" "$LINENO" 5; } - fi - fi -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 -printf "%s\n" "$cross_compiling" >&6; } - -rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out -ac_clean_files=$ac_clean_files_save -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 -printf %s "checking for suffix of object files... " >&6; } -if test ${ac_cv_objext+y} -then : - printf %s "(cached) " >&6 -else $as_nop - cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -rm -f conftest.o conftest.obj -if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>&5 - ac_status=$? - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } -then : - for ac_file in conftest.o conftest.obj conftest.*; do - test -f "$ac_file" || continue; - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; - *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` - break;; - esac -done -else $as_nop - printf "%s\n" "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot compute suffix of object files: cannot compile -See \`config.log' for more details" "$LINENO" 5; } -fi -rm -f conftest.$ac_cv_objext conftest.$ac_ext -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 -printf "%s\n" "$ac_cv_objext" >&6; } -OBJEXT=$ac_cv_objext -ac_objext=$OBJEXT -# If we don't use `.F' as extension, the preprocessor is not run on the -# input file. (Note that this only needs to work for GNU compilers.) -ac_save_ext=$ac_ext -ac_ext=F -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU Fortran" >&5 -printf %s "checking whether the compiler supports GNU Fortran... " >&6; } -if test ${ac_cv_fc_compiler_gnu+y} -then : - printf %s "(cached) " >&6 -else $as_nop - cat > conftest.$ac_ext <<_ACEOF - program main -#ifndef __GNUC__ - choke me -#endif - - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO" -then : - ac_compiler_gnu=yes -else $as_nop - ac_compiler_gnu=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext -ac_cv_fc_compiler_gnu=$ac_compiler_gnu - -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_compiler_gnu" >&5 -printf "%s\n" "$ac_cv_fc_compiler_gnu" >&6; } -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - -ac_ext=$ac_save_ext -ac_test_FCFLAGS=${FCFLAGS+y} -ac_save_FCFLAGS=$FCFLAGS -FCFLAGS= -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $FC accepts -g" >&5 -printf %s "checking whether $FC accepts -g... " >&6; } -if test ${ac_cv_prog_fc_g+y} -then : - printf %s "(cached) " >&6 -else $as_nop - FCFLAGS=-g -cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO" -then : - ac_cv_prog_fc_g=yes -else $as_nop - ac_cv_prog_fc_g=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_fc_g" >&5 -printf "%s\n" "$ac_cv_prog_fc_g" >&6; } -if test $ac_test_FCFLAGS; then - FCFLAGS=$ac_save_FCFLAGS -elif test $ac_cv_prog_fc_g = yes; then - if test "x$ac_cv_fc_compiler_gnu" = xyes; then - FCFLAGS="-g -O2" - else - FCFLAGS="-g" - fi -else - if test "x$ac_cv_fc_compiler_gnu" = xyes; then - FCFLAGS="-O2" - else - FCFLAGS= - fi -fi - -if test $ac_compiler_gnu = yes; then - GFC=yes -else - GFC= -fi -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - - - -# Check whether --enable-parallel was given. -if test ${enable_parallel+y} -then : - enableval=$enable_parallel; set_use_parallel=1 - if test "$enableval" = "yes" ; then - use_parallel=1 - else - use_parallel=0 - fi -else $as_nop - set_use_parallel=0 use_parallel=1 -fi - - -# candidate fortran compilers good for all cases -try_mpif90="mpif90" -try_f90="gfortran f90" - -# candidate compilers and flags based on architecture -case $arch in -ia32 | ia64 | x86_64 ) - try_f90="ifort nvfortran pgf90 nagfor $try_f90" - try_mpif90="mpiifort $try_mpif90" - ;; -arm ) - try_f90="nvfortran pgf90 armflang $try_f90" - ;; -crayxt* ) - try_f90="ftn" - try_mpif90="ftn" - ;; -mac686 | cygwin ) - try_f90="ifort $try_f90" - ;; -mingw* ) - ld="$F90" - # this is set for C/C++, but we need it for Fortran, too. - try_dflags="-D_WIN32" - ;; -necsx ) - # most likely the following generates a bug - sxopt=`echo $host|awk '{print substr(,1,3)}'` - echo $sxopt $host - try_mpif90="sxmpif90" - try_f90="sxf90" - try_dflags='-D__SX6 ' - use_fft_asl=0 - use_fft_mathkeisan=1 - use_fft_para=0 -# default for Nec: no parallel unless explicitly required - if test "$set_use_parallel" -ne 1 ; then use_parallel=0 ; fi - if test "$use_parallel" -eq 1 ; then use_fft_para=1 ; fi - try_dflags_fft_asl='-DASL' - try_dflags_fft_mathkeisan=' ' - try_dflags_fft_para='-D__USE_3D_FFT' - ;; -ppc64 ) - try_mpif90="mpxlf90_r mpf90_r mpif90" - try_f90="xlf90_r $try_f90" - ;; -# PowerPC little endian -ppc64le ) - try_mpif90="$try_mpif90 mpixlf" - try_f90="xlf90_r" - ;; -# IBM BlueGene - obsolete -ppc64-bg | ppc64-bgq ) - if test "$use_openmp" -eq 0 ; then - try_mpif90="mpixlf90" - try_f90="bgxlf90" - else - try_mpif90="mpixlf90_r" - # Executable paths are usually consistent across several - # IBM BG/P BG/Q machine deployed - ld="/bgsys/drivers/ppcfloor/comm/xl.ndebug/bin/mpixlf90_r" - try_f90="bgxlf90_r" - fi - try_arflags="ruv" - ;; -* ) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $arch : unsupported architecture?" >&5 -printf "%s\n" "$as_me: WARNING: $arch : unsupported architecture?" >&2;} - ;; -esac - -# check Fortran 90 compiler - -# clear cached values -unset FC ac_cv_prog_ac_ct_FC ac_cv_fc_compiler_gnu ac_cv_prog_fc_g - -if test "$use_parallel" -eq 0 ; then -# serial case - use F90 if set - if test "$f90" = "" ; then - mpif90="$try_f90" - else - mpif90="$f90" - fi -else -# parallel case - use MPIF90 if set - if test "$mpif90" = "" ; then - mpif90="$try_mpif90 $f90 $try_f90 " - fi - if test "$f90" != "" ; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: F90 value is set to be consistent with value of MPIF90" >&5 -printf "%s\n" "$as_me: WARNING: F90 value is set to be consistent with value of MPIF90" >&2;} - fi -fi - -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu -if test -n "$ac_tool_prefix"; then - for ac_prog in $mpif90 - do - # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. -set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -printf %s "checking for $ac_word... " >&6; } -if test ${ac_cv_prog_FC+y} -then : - printf %s "(cached) " >&6 -else $as_nop - if test -n "$FC"; then - ac_cv_prog_FC="$FC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then - ac_cv_prog_FC="$ac_tool_prefix$ac_prog" - printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -FC=$ac_cv_prog_FC -if test -n "$FC"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $FC" >&5 -printf "%s\n" "$FC" >&6; } -else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } -fi - - - test -n "$FC" && break - done -fi -if test -z "$FC"; then - ac_ct_FC=$FC - for ac_prog in $mpif90 -do - # Extract the first word of "$ac_prog", so it can be a program name with args. -set dummy $ac_prog; ac_word=$2 -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -printf %s "checking for $ac_word... " >&6; } -if test ${ac_cv_prog_ac_ct_FC+y} -then : - printf %s "(cached) " >&6 -else $as_nop - if test -n "$ac_ct_FC"; then - ac_cv_prog_ac_ct_FC="$ac_ct_FC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_FC="$ac_prog" - printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -ac_ct_FC=$ac_cv_prog_ac_ct_FC -if test -n "$ac_ct_FC"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_FC" >&5 -printf "%s\n" "$ac_ct_FC" >&6; } -else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } -fi - - - test -n "$ac_ct_FC" && break -done - - if test "x$ac_ct_FC" = x; then - FC="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - FC=$ac_ct_FC - fi -fi - - -# Provide some information about the compiler. -printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler version" >&5 -set X $ac_compile -ac_compiler=$2 -for ac_option in --version -v -V -qversion; do - { { ac_try="$ac_compiler $ac_option >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_compiler $ac_option >&5") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - sed '10a\ -... rest of stderr output deleted ... - 10q' conftest.err >conftest.er1 - cat conftest.er1 >&5 - fi - rm -f conftest.er1 conftest.err - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } -done -rm -f a.out - -# If we don't use `.F' as extension, the preprocessor is not run on the -# input file. (Note that this only needs to work for GNU compilers.) -ac_save_ext=$ac_ext -ac_ext=F -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU Fortran" >&5 -printf %s "checking whether the compiler supports GNU Fortran... " >&6; } -if test ${ac_cv_fc_compiler_gnu+y} -then : - printf %s "(cached) " >&6 -else $as_nop - cat > conftest.$ac_ext <<_ACEOF - program main -#ifndef __GNUC__ - choke me -#endif - - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO" -then : - ac_compiler_gnu=yes -else $as_nop - ac_compiler_gnu=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext -ac_cv_fc_compiler_gnu=$ac_compiler_gnu - -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_compiler_gnu" >&5 -printf "%s\n" "$ac_cv_fc_compiler_gnu" >&6; } -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - -ac_ext=$ac_save_ext -ac_test_FCFLAGS=${FCFLAGS+y} -ac_save_FCFLAGS=$FCFLAGS -FCFLAGS= -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $FC accepts -g" >&5 -printf %s "checking whether $FC accepts -g... " >&6; } -if test ${ac_cv_prog_fc_g+y} -then : - printf %s "(cached) " >&6 -else $as_nop - FCFLAGS=-g -cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO" -then : - ac_cv_prog_fc_g=yes -else $as_nop - ac_cv_prog_fc_g=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_fc_g" >&5 -printf "%s\n" "$ac_cv_prog_fc_g" >&6; } -if test $ac_test_FCFLAGS; then - FCFLAGS=$ac_save_FCFLAGS -elif test $ac_cv_prog_fc_g = yes; then - if test "x$ac_cv_fc_compiler_gnu" = xyes; then - FCFLAGS="-g -O2" - else - FCFLAGS="-g" - fi -else - if test "x$ac_cv_fc_compiler_gnu" = xyes; then - FCFLAGS="-O2" - else - FCFLAGS= - fi -fi - -if test $ac_compiler_gnu = yes; then - GFC=yes -else - GFC= -fi -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -# this avoids that an empty MPIF90 field is produced if the corresponding -# environment variable MPIF90 does not contain an acceptable compiler -if test "$FC" = "" ; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: MPIF90 not found: using MPIF90 anyway" >&5 -printf "%s\n" "$as_me: WARNING: MPIF90 not found: using MPIF90 anyway" >&2;} - FC=$mpif90 -fi -mpif90=$FC - -# check which compiler does mpif90 wrap - -case "$arch" in - * ) - echo $ECHO_N "checking version of $mpif90... $ECHO_C" - ifort_version=`$mpif90 -V 2>&1 | grep "Intel(R)"` - pgf_version=`$mpif90 -V 2>&1 | grep "^pgf"` - nvfortran_version=`$mpif90 -V 2>&1 | grep "^nvfortran"` - gfortran_version=`$mpif90 -v 2>&1 | grep "gcc version"` - nagfor_version=`$mpif90 -v 2>&1 | grep "NAG Fortran"` - xlf_version=`$mpif90 -v 2>&1 | grep "xlf"` - armflang_version=`$mpif90 -v 2>&1 | grep "Arm C/C++/Fortran Compiler version"` - # - if test "$ifort_version" != "" - then - version=`$mpif90 --version 2>&1 | grep "IFORT" | cut -d ' ' -f3` - f90_major_version=`echo $version | cut -d. -f1` - echo "${ECHO_T}ifort $f90_major_version" - f90_in_mpif90="ifort" - elif test "$nvfortran_version" != "" - then - version=`echo $nvfortran_version | cut -d ' ' -f2` - echo "${ECHO_T}nvfortran $version" - f90_in_mpif90="nvfortran" - elif test "$pgf_version" != "" - then - version=`echo $pgf_version | cut -d ' ' -f2` - echo "${ECHO_T}pgf90 $version" - f90_in_mpif90="pgf90" - elif test "$gfortran_version" != "" - then - version=`echo $gfortran_version | cut -d ' ' -f3` - f90_major_version=`echo $version | cut -d. -f1` - f90_minor_version=`echo $version | cut -d. -f2` - echo "${ECHO_T}gfortran $f90_major_version.$f90_minor_version" - f90_in_mpif90="gfortran" - elif test "$nagfor_version" != "" - then - # NAG 6.0 has the codename attached to version number... annoying - version=`echo $nagfor_version | cut -d ' ' -f5` - echo "${ECHO_T}nagfor $version" - f90_in_mpif90="nagfor" - elif test "$xlf_version" != "" - then - echo "${ECHO_T}xlf (version unknonw)" - f90_in_mpif90="xlf90_r" - try_dflags="-D__XLF" - elif test "$armflang_version" != "" - then - version=`echo $armflang_version | cut -d" " -f 5` - f90_major_version=`echo $version | cut -d. -f1` - f90_minor_version=`echo $version | cut -d. -f2` - f90_in_mpif90="armflang" - try_foxflags="-D__PGI" - else - echo "${ECHO_T}unknown, assuming gfortran" - f90_in_mpif90="gfortran" - fi - # notify if serial and parallel compiler are the same - if test "$set_use_parallel" -eq 1 ; then - if test "$mpif90" = "$f90_in_mpif90"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: parallel and serial compiler are the same" >&5 -printf "%s\n" "$as_me: WARNING: parallel and serial compiler are the same" >&2;} - fi - fi - f90=$f90_in_mpif90 - ;; -esac -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Fortran flag to compile .f90 files" >&5 -printf %s "checking for Fortran flag to compile .f90 files... " >&6; } -if test ${ac_cv_fc_srcext_f90+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_ext=f90 -ac_fcflags_srcext_save=$ac_fcflags_srcext -ac_fcflags_srcext= -ac_cv_fc_srcext_f90=unknown -case $ac_ext in #( - [fF]77) ac_try=f77;; #( - *) ac_try=f95;; -esac -for ac_flag in none -qsuffix=f=f90 -Tf "-x $ac_try"; do - test "x$ac_flag" != xnone && ac_fcflags_srcext="$ac_flag" - cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO" -then : - ac_cv_fc_srcext_f90=$ac_flag; break -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext -done -rm -f conftest.$ac_objext conftest.f90 -ac_fcflags_srcext=$ac_fcflags_srcext_save - -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_srcext_f90" >&5 -printf "%s\n" "$ac_cv_fc_srcext_f90" >&6; } -if test "x$ac_cv_fc_srcext_f90" = xunknown; then - as_fn_error $? "Fortran could not compile .f90 files" "$LINENO" 5 -else - ac_fc_srcext=f90 - if test "x$ac_cv_fc_srcext_f90" = xnone; then - ac_fcflags_srcext="" - FCFLAGS_f90="" - else - ac_fcflags_srcext=$ac_cv_fc_srcext_f90 - FCFLAGS_f90=$ac_cv_fc_srcext_f90 - fi - - -fi -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -echo setting F90... $f90 -echo setting MPIF90... $mpif90 - -# For cray compiler -case "$f90" in -f90 | fc | ftn ) - echo $ECHO_N "checking version wrapped by $f90 command... $ECHO_C" - - if $f90 -V 2>&1 | grep -q "Intel(R)" ; then - f90_flavor=ifort - elif $f90 -V 2>&1 | grep -q "^pgf" ; then - f90_flavor=pgf - elif $f90 -v 2>&1 | grep -q "gcc version" ; then - f90_flavor=gfortran - elif $f90 -V 2>&1 | grep -q "Cray Fortran" ; then - f90_flavor=crayftn - elif $f90 -version 2>&1 | grep -q "NAG Fortran" ; then - f90_flavor=nagfor - else - echo $ECHO_N "unknown, leaving as... $ECHO_C" - f90_flavor=$f90 - fi - echo $f90_flavor - ;; -* ) - f90_flavor=$f90 - ;; -esac - - - - - - -# Check environ... - - - # Check whether --enable-environment was given. -if test ${enable_environment+y} -then : - enableval=$enable_environment; if test "$enableval" = "yes" ; then - enable_environment=1 - else - enable_environment=0 - fi -else $as_nop - enable_environment=0 -fi - - - if test "$enable_environment" -eq 1 ; - then - try_dflags="$try_dflags -D__ENVIRONMENT" - fi - - - - -# Checking CC... - - - - - - - - - - - -# candidate C compilers good for all cases -try_cc="cc gcc" - -case "$arch:$f90_flavor" in -*:ifort* ) - try_cc="icc ecc $try_cc" - ;; -*:pgf90 ) - try_cc="pgcc $try_cc" - ;; -cray*:* ) - try_cc="cc" - ;; -necsx:* ) - try_cc="sxcc" - ;; -ppc64-bg*:*xlf90_r ) - try_cc="bgxlc_r" - ;; -ppc64-bg*:*xlf90 ) - try_cc="bgxlc" - ;; -ppc64:*xlf* | ppc64le:*xlf* ) - try_cc="xlc_r $try_cc" - ;; -esac - -# check serial C compiler -if test "$env_cc" = "" ; then cc="$try_cc" ; else cc="$env_cc"; fi -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu -if test -n "$ac_tool_prefix"; then - for ac_prog in $cc - do - # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. -set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -printf %s "checking for $ac_word... " >&6; } -if test ${ac_cv_prog_CC+y} -then : - printf %s "(cached) " >&6 -else $as_nop - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then - ac_cv_prog_CC="$ac_tool_prefix$ac_prog" - printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -CC=$ac_cv_prog_CC -if test -n "$CC"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -printf "%s\n" "$CC" >&6; } -else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } -fi - - - test -n "$CC" && break - done -fi -if test -z "$CC"; then - ac_ct_CC=$CC - for ac_prog in $cc -do - # Extract the first word of "$ac_prog", so it can be a program name with args. -set dummy $ac_prog; ac_word=$2 -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -printf %s "checking for $ac_word... " >&6; } -if test ${ac_cv_prog_ac_ct_CC+y} -then : - printf %s "(cached) " >&6 -else $as_nop - if test -n "$ac_ct_CC"; then - ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_CC="$ac_prog" - printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -ac_ct_CC=$ac_cv_prog_ac_ct_CC -if test -n "$ac_ct_CC"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 -printf "%s\n" "$ac_ct_CC" >&6; } -else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } -fi - - - test -n "$ac_ct_CC" && break -done - - if test "x$ac_ct_CC" = x; then - CC="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - CC=$ac_ct_CC - fi -fi - - -test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "no acceptable C compiler found in \$PATH -See \`config.log' for more details" "$LINENO" 5; } - -# Provide some information about the compiler. -printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 -set X $ac_compile -ac_compiler=$2 -for ac_option in --version -v -V -qversion -version; do - { { ac_try="$ac_compiler $ac_option >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_compiler $ac_option >&5") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - sed '10a\ -... rest of stderr output deleted ... - 10q' conftest.err >conftest.er1 - cat conftest.er1 >&5 - fi - rm -f conftest.er1 conftest.err - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } -done - -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5 -printf %s "checking whether the compiler supports GNU C... " >&6; } -if test ${ac_cv_c_compiler_gnu+y} -then : - printf %s "(cached) " >&6 -else $as_nop - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main (void) -{ -#ifndef __GNUC__ - choke me -#endif - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO" -then : - ac_compiler_gnu=yes -else $as_nop - ac_compiler_gnu=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext -ac_cv_c_compiler_gnu=$ac_compiler_gnu - -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 -printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; } -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -if test $ac_compiler_gnu = yes; then - GCC=yes -else - GCC= -fi -ac_test_CFLAGS=${CFLAGS+y} -ac_save_CFLAGS=$CFLAGS -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 -printf %s "checking whether $CC accepts -g... " >&6; } -if test ${ac_cv_prog_cc_g+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_save_c_werror_flag=$ac_c_werror_flag - ac_c_werror_flag=yes - ac_cv_prog_cc_g=no - CFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main (void) -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO" -then : - ac_cv_prog_cc_g=yes -else $as_nop - CFLAGS="" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main (void) -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO" -then : - -else $as_nop - ac_c_werror_flag=$ac_save_c_werror_flag - CFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main (void) -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO" -then : - ac_cv_prog_cc_g=yes -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - ac_c_werror_flag=$ac_save_c_werror_flag -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 -printf "%s\n" "$ac_cv_prog_cc_g" >&6; } -if test $ac_test_CFLAGS; then - CFLAGS=$ac_save_CFLAGS -elif test $ac_cv_prog_cc_g = yes; then - if test "$GCC" = yes; then - CFLAGS="-g -O2" - else - CFLAGS="-g" - fi -else - if test "$GCC" = yes; then - CFLAGS="-O2" - else - CFLAGS= - fi -fi -ac_prog_cc_stdc=no -if test x$ac_prog_cc_stdc = xno -then : - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5 -printf %s "checking for $CC option to enable C11 features... " >&6; } -if test ${ac_cv_prog_cc_c11+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_cv_prog_cc_c11=no -ac_save_CC=$CC -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$ac_c_conftest_c11_program -_ACEOF -for ac_arg in '' -std=gnu11 -do - CC="$ac_save_CC $ac_arg" - if ac_fn_c_try_compile "$LINENO" -then : - ac_cv_prog_cc_c11=$ac_arg -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam - test "x$ac_cv_prog_cc_c11" != "xno" && break -done -rm -f conftest.$ac_ext -CC=$ac_save_CC -fi - -if test "x$ac_cv_prog_cc_c11" = xno -then : - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 -printf "%s\n" "unsupported" >&6; } -else $as_nop - if test "x$ac_cv_prog_cc_c11" = x -then : - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 -printf "%s\n" "none needed" >&6; } -else $as_nop - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5 -printf "%s\n" "$ac_cv_prog_cc_c11" >&6; } - CC="$CC $ac_cv_prog_cc_c11" -fi - ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11 - ac_prog_cc_stdc=c11 -fi -fi -if test x$ac_prog_cc_stdc = xno -then : - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5 -printf %s "checking for $CC option to enable C99 features... " >&6; } -if test ${ac_cv_prog_cc_c99+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_cv_prog_cc_c99=no -ac_save_CC=$CC -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$ac_c_conftest_c99_program -_ACEOF -for ac_arg in '' -std=gnu99 -std=c99 -c99 -qlanglvl=extc1x -qlanglvl=extc99 -AC99 -D_STDC_C99= -do - CC="$ac_save_CC $ac_arg" - if ac_fn_c_try_compile "$LINENO" -then : - ac_cv_prog_cc_c99=$ac_arg -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam - test "x$ac_cv_prog_cc_c99" != "xno" && break -done -rm -f conftest.$ac_ext -CC=$ac_save_CC -fi - -if test "x$ac_cv_prog_cc_c99" = xno -then : - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 -printf "%s\n" "unsupported" >&6; } -else $as_nop - if test "x$ac_cv_prog_cc_c99" = x -then : - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 -printf "%s\n" "none needed" >&6; } -else $as_nop - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 -printf "%s\n" "$ac_cv_prog_cc_c99" >&6; } - CC="$CC $ac_cv_prog_cc_c99" -fi - ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 - ac_prog_cc_stdc=c99 -fi -fi -if test x$ac_prog_cc_stdc = xno -then : - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5 -printf %s "checking for $CC option to enable C89 features... " >&6; } -if test ${ac_cv_prog_cc_c89+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_cv_prog_cc_c89=no -ac_save_CC=$CC -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$ac_c_conftest_c89_program -_ACEOF -for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" -do - CC="$ac_save_CC $ac_arg" - if ac_fn_c_try_compile "$LINENO" -then : - ac_cv_prog_cc_c89=$ac_arg -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam - test "x$ac_cv_prog_cc_c89" != "xno" && break -done -rm -f conftest.$ac_ext -CC=$ac_save_CC -fi - -if test "x$ac_cv_prog_cc_c89" = xno -then : - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 -printf "%s\n" "unsupported" >&6; } -else $as_nop - if test "x$ac_cv_prog_cc_c89" = x -then : - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 -printf "%s\n" "none needed" >&6; } -else $as_nop - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 -printf "%s\n" "$ac_cv_prog_cc_c89" >&6; } - CC="$CC $ac_cv_prog_cc_c89" -fi - ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 - ac_prog_cc_stdc=c89 -fi -fi - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -cc=$CC - -echo setting CC... $cc - - - -# tentative C and loader flags, good for many cases -try_cflags="-O3" -c_ldflags="" -try_cpp="cpp" - -case "$arch:$cc" in -*:pgcc ) - # Do I need preprocessing here? - try_cflags="-fast -Mpreprocess" - ;; -crayxt*:cc ) - # Actually we need something like is done for ftn to detect - # the proper compiler used (NdFilippo) - try_cflags="-O3" - ;; -necsx:* ) - #try_cflags="-D__SX6 \$(IFLAGS) \$(MODFLAGS)" - try_cflags="" - ;; -ppc64le:* ) - try_cflags="-O3" - ;; -ppc64-bg:* ) - try_cflags="-O3 -q32" - ;; -ppc64-bgq:* ) - try_cflags="-O3" - ;; -ppc64:xlc*) - try_cflags="-O3 -q64 -qthreaded" - c_ldflags="-q64" - ;; - -esac -if test "$cflags" = "" ; then cflags=$try_cflags ; fi -echo setting CFLAGS... $cflags - -# compilation flags for all subsequent tests -test_cflags="`echo $cflags | sed 's/\$([^)]*)//g'`" - - - - -# Checking F90... - - -# debug flags are implemented only for a few cases -# Check whether --enable-debug was given. -if test ${enable_debug+y} -then : - enableval=$enable_debug; if test "$enableval" = "yes" ; then - use_debug=1 - else - use_debug=0 - fi -else $as_nop - use_debug=0 -fi - - -# pedantic flags implemented only for gcc -# Check whether --enable-pedantic was given. -if test ${enable_pedantic+y} -then : - enableval=$enable_pedantic; if test "$enableval" = "yes" ; then - use_pedantic=1 - else - use_pedantic=0 - fi -else $as_nop - use_pedantic=0 -fi - - -# shared library flags are implemented only for a few (untested) cases -# Check whether --enable-shared was given. -if test ${enable_shared+y} -then : - enableval=$enable_shared; if test "$enableval" = "yes" ; then - use_shared=1 - else - use_shared=0 - fi -else $as_nop - use_shared=1 -fi - - -# check Fortran compiler flags -# have_cpp=0: use external C preprocessing for fortran code -# have_cpp=1: use C-like preprocessing in fortran compiler -have_cpp=1 -xlf_flags=0 - -echo using F90... $f90 - -case "$arch:$f90_flavor" in -*:ifort* ) - try_fflags="-O2 -assume byterecl -g -traceback" - if test "$use_debug" -eq 1; then - try_fflags="$try_fflags -fpe0 -CB" - fi - try_fflags_nomain="-nofor_main" - try_f90flags="\$(FFLAGS) -nomodule" - try_fflags_noopt="-O0 -assume byterecl -g -traceback" - try_ldflags="" - try_ldflags_static="-static" - try_dflags="$try_dflags -D__INTEL" - if test "$f90_major_version" -ge "15"; then - try_fflags_openmp="-qopenmp" - try_ldflags_openmp="-qopenmp" - else - try_fflags_openmp="-openmp" - try_ldflags_openmp="-openmp" - fi - pre_fdflags="-fpp " - ;; -arm:armflang ) - try_fflags="-O3 -mcpu=native $try_fflags" - if test "$use_debug" -eq 1; then - try_fflags="$try_fflags -g" - fi - try_ldflags="-mcpu=native" - try_fflags_openmp="-fopenmp" - try_ldfflags_openmp="-fopenmp" - try_f90flags="\$(FFLAGS) -cpp" - try_ldflags="-g -mcpu=native" - try_ldflags_openmp="-fopenmp" - try_ldflags_static="-static -static-flang-libs" - - ;; -x86_64:nagfor* ) - try_fflags="-O3 -kind=byte -dcfuns -mismatch" - if test "$use_debug" -eq 1; then - try_fflags="$try_fflags -g" - fi - try_fflags_nomain="" - try_fflags_openmp="-openmp" - try_f90flags="-O3 -kind=byte -dcfuns -mismatch" - try_fflags_noopt="-O0 -kind=byte -dcfuns -mismatch" - try_ldflags="" - try_ldflags_static="-unsharedrts" - try_ldflags_openmp="-openmp" - try_dflags="$try_dflags -D__NAG" - have_cpp=0 - ;; -crayxt*:cray* ) - try_fflags_nomain="" - #NOTE: by default OpenMP is always ON (see crayftn man page) - try_fflags_openmp="-homp" - try_fflags="-O2" - #NOTE: add '-rm' to get messages from crayftn about why - # optimizations have not been applied - # -x dir disable directives introduced by !DIR$ - try_f90flags="-O3,fp3 -f free -x dir" - try_fflags_noopt="-O0" - try_ldflags_openmp="-homp" - try_ldflags="-v" - try_ldflags_static="-static" - try_dflags="$try_dflags -D__CRAY" - have_cpp=0 - ;; -crayxt*:pgf* ) -# see comment above for pgf* - try_fflags_nomain="-Mnomain" - try_fflags_openmp="-mp" - try_fflags="-O3" - try_f90flags="-fast -Mcache_align -Mpreprocess -Mlarge_arrays" - try_fflags_noopt="-O0" - try_ldflags_openmp="-mp" - try_ldflags="-v" - try_dflags="$try_dflags -D__PGI -D__IOTK_WORKAROUND1" - have_cpp=1 - ;; -necsx:* ) - try_fflags=' -float0 -Cvopt -eab -R5 -Wf,-Ncont,-A dbl4,-P nh,-ptr byte,-pvctl noifopt loopcnt=9999999 expand=12 fullmsg vwork=stack,-fusion,-O noif,-init stack=nan heap=nan' - try_f90flags=' -f2003 -float0 -Cvopt -eab -R5 -Wf,-Ncont,-A dbl4,-P nh,-ptr byte,-pvctl noifopt loopcnt=9999999 expand=12 fullmsg vwork=stack,-fusion,-O noif,-init stack=nan heap=nan' - try_f90flags="-$sxopt $try_f90flags" - try_fflags_noopt='-float0 ' - try_f90flags_noopt='-f2003 -float0 -eab -R5 -C debug -Wf,-Ncont,-A dbl4,-P nh ,ptr byte,-init stack=nan heap=nan' - try_f90flags_noopt="$try_f90flags_noopt" - try_f90flags_inline='-f2003 -float0 -Cvopt -eab -R5 -pi noauto incdir exp=w0gauss -Wf,-Ncont,-A dbl4,-P nh,-ptr byte,-pvctl noifopt loopcnt=9999999 expand=12 fullmsg vwork=stack,-fusion,-O noif,-init stack=nan heap=nan' - try_f90flags_inline="$try_f90flags_inline" - try_ldflags_static='-P static' - try_ldflags='-Wl,-f zero' - try_ldflags="-p $try_ldflags" - pre_fdflags="" - ;; - -ppc64:*xlf* ) - if test "$use_debug" -eq 1; then - try_fflags="-g -C -qsuffix=cpp=f90 -qdpc -qalias=nointptr -Q" - else - try_fflags="-q64 -qthreaded -O4 -qsuffix=cpp=f90 -qdpc -qalias=nointptr -Q" - fi - try_f90flags="\$(FFLAGS) -qfree=f90" - try_fflags_noopt="-q64 -qthreaded -O0" - try_ldflags="-q64 -qthreaded" - try_dflags="-D__XLF" - pre_fdflags="-WF," - xlf_flags=1 - ;; -ppc64le:*xlf* ) - if test "$use_debug" -eq 1; then - try_fflags="-g -C -qstrict -qdpc -qalias=nointptr -qarch=auto" - else - try_fflags="-O3 -qstrict -qdpc -qalias=nointptr -qarch=auto" - fi - try_fflags_openmp="-qsmp=noauto:omp" - try_f90flags="\$(FFLAGS) -qsuffix=cpp=f90" - try_fflags_noopt="-O0" - try_ldflags="" - try_ldflags_openmp="-qsmp=noauto:omp" - try_dflags="-D__XLF" - pre_fdflags="-WF," - xlf_flags=1 - ;; -ppc64-bg:*xlf* ) - if test "$use_debug" -eq 1; then - try_fflags="-q32 -qalias=noaryovrlp:nointptr -g -C -qdpc=e" - else - try_fflags="-q32 -qalias=noaryovrlp:nointptr -O3 -qstrict -qdpc=e" - fi - try_fflags_openmp="-qsmp=omp -qthreaded" - try_f90flags="\$(FFLAGS) -qsuffix=cpp=f90" - try_fflags_noopt="-q32 -O0" - try_ldflags="-q32" - try_ldflags_openmp="-qsmp=omp -qthreaded" - try_dflags="-D__XLF" - pre_fdflags="-WF," - xlf_flags=1 - ;; -ppc64-bgq:*xlf* ) - if test "$use_debug" -eq 1; then - try_fflags="-qalias=noaryovrlp:nointptr -g -C -qdpc=e" - else - try_fflags="-qalias=noaryovrlp:nointptr -O3 -qstrict -qdpc=e -qarch=qp -qtune=qp" - fi - try_fflags_openmp="-qsmp=noauto:omp -qtm -qthreaded" - try_f90flags="\$(FFLAGS) -qsuffix=cpp=f90" - try_fflags_noopt="-O0" - try_ldflags="" - try_ldflags_openmp="-qstatic -qsmp=noauto:omp -qtm -qthreaded" - try_dflags="-D__XLF" - pre_fdflags="-WF," - xlf_flags=1 - ;; -*:pgf* ) - try_fflags_nomain="-Mnomain" - try_fflags="-fast" - try_fflags_openmp="-mp" - if test "$use_debug" -eq 1; then - try_f90flags="-g -C -Mcache_align -Mpreprocess -Mlarge_arrays" - else - try_f90flags="-fast -Mcache_align -Mpreprocess -Mlarge_arrays" - fi - try_foxflags="-fast -Mcache_align -Mpreprocess -Mlarge_arrays" - try_fflags_noopt="-O0" - try_ldflags="" - try_ldflags_openmp="-mp" - try_ldflags_static="-Bstatic" - try_dflags="$try_dflags -D__PGI" - have_cpp=1 - ;; -*:*gfortran ) - try_fflags="-O3 -g" - if test "$f90_major_version" -ge "10"; then - try_fflags="$try_fflags -fallow-argument-mismatch" - fi - if test "$use_debug" -eq 1; then - try_fflags="-O3 -g -Wall -fbounds-check -frange-check -finit-integer=987654321 -finit-real=nan -finit-logical=true -finit-character=64" - fi - if test "$use_pedantic" -eq 1; then - try_fflags="-O2 -g -pedantic -Wall -Wextra -Wconversion -fimplicit-none -fbacktrace -ffree-line-length-0 -fcheck=all" - fi - try_fflags_openmp="-fopenmp" - try_f90flags="\$(FFLAGS) -cpp" - try_fflags_noopt="-O0 -g" - try_ldflags="-g" - try_ldflags_openmp="-pthread -fopenmp" - try_ldflags_static="-static" - try_dflags="$try_dflags -D__GFORTRAN" - ;; - -* ) - # unknown, try these - try_fflags="-O1" - try_f90flags="\$(FFLAGS)" - try_fflags_noopt="-O0" - try_ldflags="" - have_cpp=0 - ;; - -esac - -if test "$use_shared" -eq 0 ; then - try_ldflags="$try_ldflags $try_ldflags_static" ; fi - -# Flags are repeated, need better way to handle this ... -if test "$use_openmp" -eq 1 ; then - try_f90flags="$try_f90flags $try_fflags_openmp" - try_fflags="$try_fflags $try_fflags_openmp" - try_ldflags="$try_ldflags $try_ldflags_openmp" -fi - -if test "$fflags" = "" ; then fflags=$try_fflags ; fi -if test "$f90flags" = "" ; then f90flags=$try_f90flags ; fi -if test "try_foxflags" != ""; then foxflags=$try_foxflags; fi -if test "$fflags_noopt" = "" ; then fflags_noopt=$try_fflags_noopt ; fi -if test "$fflags_nomain" = "" ; then fflags_nomain=$try_fflags_nomain ; fi - -echo setting FFLAGS... $fflags -echo setting F90FLAGS... $f90flags -echo setting FFLAGS_NOOPT... $fflags_noopt -if test "$fflags_nomain" != "" ; then echo setting FFLAGS_NOMAIN... $fflags_nomain ; fi - -if test "$imod" = "" ; then imod="-I" ; fi - -# compilation flags for all subsequent tests -# remove all $(...) because at least one compiler doesn't like them -# but if f90flags contains $(FFLAGS), substitute it -if test "`echo $f90flags | grep '$(FFLAGS)'`" != "" -then - test_fflags="`echo $fflags $f90flags | sed 's/\$([^)]*)//g'`" -else - test_fflags="`echo $f90flags | sed 's/\$([^)]*)//g'`" -fi - - - - - - - - - - -# Checking preprocessor... - - -# preprocessor - try cpp in all cases; the preprocessor returned by -# AC_PROG_CPP -# may sometimes refuse to preprocess fortran files -if test "$cpp" = "" ; then cpp=$try_cpp; fi -# if test "$cpp" = "" ; then cpp=$CPP; fi -echo setting CPP... $cpp - -echo $ECHO_N "setting CPPFLAGS... $ECHO_C" -# Note: option -C makes trouble with recent gcc versions and pgi -case $cpp in - cpp) try_cppflags="-P -traditional -Uvector" ;; - fpp) try_cppflags="-P " ;; - *) try_cppflags="" ;; -esac -if test "$cppflags" = "" ; then cppflags=$try_cppflags ; fi -echo "${ECHO_T}$cppflags" - -# compilation flags for all subsequent tests -test_cppflags="$test_cflags" - - - - - - - -# Checking linker... - - -# linker and archiver -# note that from this point on, further additions to -# linker flags should be added to ldflags rather than try_ldflags -if test "$ld" = "" ; then ld="$mpif90" ; fi -if test "$ldflags" = "" ; then ldflags="$try_ldflags" ; fi -echo setting LD... $ld -echo setting LDFLAGS... $ldflags - -# compilation flags for all subsequent tests -test_ldflags="`echo $ldflags | sed 's/\$([^)]*)//g'`" - - - - - - - -# Checking F90 rule... - - -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 -printf %s "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } -set x ${MAKE-make} -ac_make=`printf "%s\n" "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` -if eval test \${ac_cv_prog_make_${ac_make}_set+y} -then : - printf %s "(cached) " >&6 -else $as_nop - cat >conftest.make <<\_ACEOF -SHELL = /bin/sh -all: - @echo '@@@%%%=$(MAKE)=@@@%%%' -_ACEOF -# GNU make sometimes prints "make[1]: Entering ...", which would confuse us. -case `${MAKE-make} -f conftest.make 2>/dev/null` in - *@@@%%%=?*=@@@%%%*) - eval ac_cv_prog_make_${ac_make}_set=yes;; - *) - eval ac_cv_prog_make_${ac_make}_set=no;; -esac -rm -f conftest.make -fi -if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -printf "%s\n" "yes" >&6; } - SET_MAKE= -else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } - SET_MAKE="MAKE=${MAKE-make}" -fi - -echo $ECHO_N "checking whether Fortran files must be preprocessed... $ECHO_C" -if test "$have_cpp" -ne 0 -then - f90rule="\$(MPIF90) \$(F90FLAGS) -c \$<" - echo "${ECHO_T}no" -else - f90rule="\$(CPP) \$(CPPFLAGS) \$< -o \$(*)_tmp.f90 ; \\ - \$(MPIF90) \$(F90FLAGS) -c \$(*)_tmp.f90 -o \$(*).o" - echo "${ECHO_T}yes" -fi - - - - - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -ac_header= ac_cache= -for ac_item in $ac_header_c_list -do - if test $ac_cache; then - ac_fn_c_check_header_compile "$LINENO" $ac_header ac_cv_header_$ac_cache "$ac_includes_default" - if eval test \"x\$ac_cv_header_$ac_cache\" = xyes; then - printf "%s\n" "#define $ac_item 1" >> confdefs.h - fi - ac_header= ac_cache= - elif test $ac_header; then - ac_cache=$ac_item - else - ac_header=$ac_item - fi -done - - - - - - - - -if test $ac_cv_header_stdlib_h = yes && test $ac_cv_header_string_h = yes -then : - -printf "%s\n" "#define STDC_HEADERS 1" >>confdefs.h - -fi -# The cast to long int works around a bug in the HP C Compiler -# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects -# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. -# This bug is HP SR number 8606223364. -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of int *" >&5 -printf %s "checking size of int *... " >&6; } -if test ${ac_cv_sizeof_int_p+y} -then : - printf %s "(cached) " >&6 -else $as_nop - if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (int *))" "ac_cv_sizeof_int_p" "$ac_includes_default" -then : - -else $as_nop - if test "$ac_cv_type_int_p" = yes; then - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error 77 "cannot compute sizeof (int *) -See \`config.log' for more details" "$LINENO" 5; } - else - ac_cv_sizeof_int_p=0 - fi -fi - -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_int_p" >&5 -printf "%s\n" "$ac_cv_sizeof_int_p" >&6; } - - - -printf "%s\n" "#define SIZEOF_INT_P $ac_cv_sizeof_int_p" >>confdefs.h - - -SIZEOF_INT_P=$ac_cv_sizeof_int_p - -ac_config_files="$ac_config_files include/fft_defs.h:include/fft_defs.h.in" - - -# Find fortran-to-C wrappers -ac_ext=f -ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' -ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_f77_compiler_gnu -if test -n "$ac_tool_prefix"; then - for ac_prog in g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 xlf90 f90 pgf90 pghpf epcf90 gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn nagfor - do - # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. -set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -printf %s "checking for $ac_word... " >&6; } -if test ${ac_cv_prog_F77+y} -then : - printf %s "(cached) " >&6 -else $as_nop - if test -n "$F77"; then - ac_cv_prog_F77="$F77" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then - ac_cv_prog_F77="$ac_tool_prefix$ac_prog" - printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -F77=$ac_cv_prog_F77 -if test -n "$F77"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $F77" >&5 -printf "%s\n" "$F77" >&6; } -else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } -fi - - - test -n "$F77" && break - done -fi -if test -z "$F77"; then - ac_ct_F77=$F77 - for ac_prog in g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 xlf90 f90 pgf90 pghpf epcf90 gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn nagfor -do - # Extract the first word of "$ac_prog", so it can be a program name with args. -set dummy $ac_prog; ac_word=$2 -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -printf %s "checking for $ac_word... " >&6; } -if test ${ac_cv_prog_ac_ct_F77+y} -then : - printf %s "(cached) " >&6 -else $as_nop - if test -n "$ac_ct_F77"; then - ac_cv_prog_ac_ct_F77="$ac_ct_F77" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_F77="$ac_prog" - printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -ac_ct_F77=$ac_cv_prog_ac_ct_F77 -if test -n "$ac_ct_F77"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_F77" >&5 -printf "%s\n" "$ac_ct_F77" >&6; } -else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } -fi - - - test -n "$ac_ct_F77" && break -done - - if test "x$ac_ct_F77" = x; then - F77="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - F77=$ac_ct_F77 - fi -fi - - -# Provide some information about the compiler. -printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Fortran 77 compiler version" >&5 -set X $ac_compile -ac_compiler=$2 -for ac_option in --version -v -V -qversion; do - { { ac_try="$ac_compiler $ac_option >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -printf "%s\n" "$ac_try_echo"; } >&5 - (eval "$ac_compiler $ac_option >&5") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - sed '10a\ -... rest of stderr output deleted ... - 10q' conftest.err >conftest.er1 - cat conftest.er1 >&5 - fi - rm -f conftest.er1 conftest.err - printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } -done -rm -f a.out - -# If we don't use `.F' as extension, the preprocessor is not run on the -# input file. (Note that this only needs to work for GNU compilers.) -ac_save_ext=$ac_ext -ac_ext=F -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU Fortran 77" >&5 -printf %s "checking whether the compiler supports GNU Fortran 77... " >&6; } -if test ${ac_cv_f77_compiler_gnu+y} -then : - printf %s "(cached) " >&6 -else $as_nop - cat > conftest.$ac_ext <<_ACEOF - program main -#ifndef __GNUC__ - choke me -#endif - - end -_ACEOF -if ac_fn_f77_try_compile "$LINENO" -then : - ac_compiler_gnu=yes -else $as_nop - ac_compiler_gnu=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext -ac_cv_f77_compiler_gnu=$ac_compiler_gnu - -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_f77_compiler_gnu" >&5 -printf "%s\n" "$ac_cv_f77_compiler_gnu" >&6; } -ac_compiler_gnu=$ac_cv_f77_compiler_gnu - -ac_ext=$ac_save_ext -ac_test_FFLAGS=${FFLAGS+y} -ac_save_FFLAGS=$FFLAGS -FFLAGS= -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $F77 accepts -g" >&5 -printf %s "checking whether $F77 accepts -g... " >&6; } -if test ${ac_cv_prog_f77_g+y} -then : - printf %s "(cached) " >&6 -else $as_nop - FFLAGS=-g -cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -if ac_fn_f77_try_compile "$LINENO" -then : - ac_cv_prog_f77_g=yes -else $as_nop - ac_cv_prog_f77_g=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_f77_g" >&5 -printf "%s\n" "$ac_cv_prog_f77_g" >&6; } -if test $ac_test_FFLAGS; then - FFLAGS=$ac_save_FFLAGS -elif test $ac_cv_prog_f77_g = yes; then - if test "x$ac_cv_f77_compiler_gnu" = xyes; then - FFLAGS="-g -O2" - else - FFLAGS="-g" - fi -else - if test "x$ac_cv_f77_compiler_gnu" = xyes; then - FFLAGS="-O2" - else - FFLAGS= - fi -fi - -if test $ac_compiler_gnu = yes; then - G77=yes -else - G77= -fi -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking host system type" >&5 -printf %s "checking host system type... " >&6; } -if test ${ac_cv_host+y} -then : - printf %s "(cached) " >&6 -else $as_nop - if test "x$host_alias" = x; then - ac_cv_host=$ac_cv_build -else - ac_cv_host=`$SHELL "${ac_aux_dir}config.sub" $host_alias` || - as_fn_error $? "$SHELL ${ac_aux_dir}config.sub $host_alias failed" "$LINENO" 5 -fi - -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5 -printf "%s\n" "$ac_cv_host" >&6; } -case $ac_cv_host in -*-*-*) ;; -*) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;; -esac -host=$ac_cv_host -ac_save_IFS=$IFS; IFS='-' -set x $ac_cv_host -shift -host_cpu=$1 -host_vendor=$2 -shift; shift -# Remember, the first character of IFS is used to create $*, -# except with old shells: -host_os=$* -IFS=$ac_save_IFS -case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac - - - -ac_ext=f -ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' -ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_f77_compiler_gnu -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to get verbose linking output from $F77" >&5 -printf %s "checking how to get verbose linking output from $F77... " >&6; } -if test ${ac_cv_prog_f77_v+y} -then : - printf %s "(cached) " >&6 -else $as_nop - cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -if ac_fn_f77_try_compile "$LINENO" -then : - ac_cv_prog_f77_v= -# Try some options frequently used verbose output -for ac_verb in -v -verbose --verbose -V -\#\#\#; do - cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF - -# Compile and link our simple test program by passing a flag (argument -# 1 to this macro) to the Fortran compiler in order to get -# "verbose" output that we can then parse for the Fortran linker -# flags. -ac_save_FFLAGS=$FFLAGS -FFLAGS="$FFLAGS $ac_verb" -eval "set x $ac_link" -shift -printf "%s\n" "$as_me:${as_lineno-$LINENO}: $*" >&5 -# gfortran 4.3 outputs lines setting COLLECT_GCC_OPTIONS, COMPILER_PATH, -# LIBRARY_PATH; skip all such settings. -ac_f77_v_output=`eval $ac_link 5>&1 2>&1 | - sed '/^Driving:/d; /^Configured with:/d; - '"/^[_$as_cr_Letters][_$as_cr_alnum]*=/d"` -printf "%s\n" "$ac_f77_v_output" >&5 -FFLAGS=$ac_save_FFLAGS - -rm -rf conftest* - -# On HP/UX there is a line like: "LPATH is: /foo:/bar:/baz" where -# /foo, /bar, and /baz are search directories for the Fortran linker. -# Here, we change these into -L/foo -L/bar -L/baz (and put it first): -ac_f77_v_output="`echo $ac_f77_v_output | - grep 'LPATH is:' | - sed 's|.*LPATH is\(: *[^ ]*\).*|\1|;s|: */| -L/|g'` $ac_f77_v_output" - -# FIXME: we keep getting bitten by quoted arguments; a more general fix -# that detects unbalanced quotes in FLIBS should be implemented -# and (ugh) tested at some point. -case $ac_f77_v_output in - # With xlf replace commas with spaces, - # and remove "-link" and closing parenthesis. - *xlfentry*) - ac_f77_v_output=`echo $ac_f77_v_output | - sed ' - s/,/ /g - s/ -link / /g - s/) *$// - ' - ` ;; - - # With Intel ifc, ignore the quoted -mGLOB_options_string stuff (quoted - # $LIBS confuse us, and the libraries appear later in the output anyway). - *mGLOB_options_string*) - ac_f77_v_output=`echo $ac_f77_v_output | sed 's/"-mGLOB[^"]*"/ /g'` ;; - - # Portland Group compiler has singly- or doubly-quoted -cmdline argument - # Singly-quoted arguments were reported for versions 5.2-4 and 6.0-4. - # Doubly-quoted arguments were reported for "PGF90/x86 Linux/x86 5.0-2". - *-cmdline\ * | *-ignore\ * | *-def\ *) - ac_f77_v_output=`echo $ac_f77_v_output | sed "\ - s/-cmdline *'[^']*'/ /g; s/-cmdline *\"[^\"]*\"/ /g - s/-ignore *'[^']*'/ /g; s/-ignore *\"[^\"]*\"/ /g - s/-def *'[^']*'/ /g; s/-def *\"[^\"]*\"/ /g"` ;; - - # If we are using fort77 (the f2c wrapper) then filter output and delete quotes. - *fort77*f2c*gcc*) - ac_f77_v_output=`echo "$ac_f77_v_output" | sed -n ' - /:[ ]\+Running[ ]\{1,\}"gcc"/{ - /"-c"/d - /[.]c"*/d - s/^.*"gcc"/"gcc"/ - s/"//gp - }'` ;; - - # If we are using Cray Fortran then delete quotes. - *cft90*) - ac_f77_v_output=`echo $ac_f77_v_output | sed 's/"//g'` ;; -esac - - - # look for -l* and *.a constructs in the output - for ac_arg in $ac_f77_v_output; do - case $ac_arg in - [\\/]*.a | ?:[\\/]*.a | -[lLRu]*) - ac_cv_prog_f77_v=$ac_verb - break 2 ;; - esac - done -done -if test -z "$ac_cv_prog_f77_v"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cannot determine how to obtain linking information from $F77" >&5 -printf "%s\n" "$as_me: WARNING: cannot determine how to obtain linking information from $F77" >&2;} -fi -else $as_nop - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: compilation failed" >&5 -printf "%s\n" "$as_me: WARNING: compilation failed" >&2;} -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_f77_v" >&5 -printf "%s\n" "$ac_cv_prog_f77_v" >&6; } -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Fortran 77 libraries of $F77" >&5 -printf %s "checking for Fortran 77 libraries of $F77... " >&6; } -if test ${ac_cv_f77_libs+y} -then : - printf %s "(cached) " >&6 -else $as_nop - if test "x$FLIBS" != "x"; then - ac_cv_f77_libs="$FLIBS" # Let the user override the test. -else - -cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF - -# Compile and link our simple test program by passing a flag (argument -# 1 to this macro) to the Fortran compiler in order to get -# "verbose" output that we can then parse for the Fortran linker -# flags. -ac_save_FFLAGS=$FFLAGS -FFLAGS="$FFLAGS $ac_cv_prog_f77_v" -eval "set x $ac_link" -shift -printf "%s\n" "$as_me:${as_lineno-$LINENO}: $*" >&5 -# gfortran 4.3 outputs lines setting COLLECT_GCC_OPTIONS, COMPILER_PATH, -# LIBRARY_PATH; skip all such settings. -ac_f77_v_output=`eval $ac_link 5>&1 2>&1 | - sed '/^Driving:/d; /^Configured with:/d; - '"/^[_$as_cr_Letters][_$as_cr_alnum]*=/d"` -printf "%s\n" "$ac_f77_v_output" >&5 -FFLAGS=$ac_save_FFLAGS - -rm -rf conftest* - -# On HP/UX there is a line like: "LPATH is: /foo:/bar:/baz" where -# /foo, /bar, and /baz are search directories for the Fortran linker. -# Here, we change these into -L/foo -L/bar -L/baz (and put it first): -ac_f77_v_output="`echo $ac_f77_v_output | - grep 'LPATH is:' | - sed 's|.*LPATH is\(: *[^ ]*\).*|\1|;s|: */| -L/|g'` $ac_f77_v_output" - -# FIXME: we keep getting bitten by quoted arguments; a more general fix -# that detects unbalanced quotes in FLIBS should be implemented -# and (ugh) tested at some point. -case $ac_f77_v_output in - # With xlf replace commas with spaces, - # and remove "-link" and closing parenthesis. - *xlfentry*) - ac_f77_v_output=`echo $ac_f77_v_output | - sed ' - s/,/ /g - s/ -link / /g - s/) *$// - ' - ` ;; - - # With Intel ifc, ignore the quoted -mGLOB_options_string stuff (quoted - # $LIBS confuse us, and the libraries appear later in the output anyway). - *mGLOB_options_string*) - ac_f77_v_output=`echo $ac_f77_v_output | sed 's/"-mGLOB[^"]*"/ /g'` ;; - - # Portland Group compiler has singly- or doubly-quoted -cmdline argument - # Singly-quoted arguments were reported for versions 5.2-4 and 6.0-4. - # Doubly-quoted arguments were reported for "PGF90/x86 Linux/x86 5.0-2". - *-cmdline\ * | *-ignore\ * | *-def\ *) - ac_f77_v_output=`echo $ac_f77_v_output | sed "\ - s/-cmdline *'[^']*'/ /g; s/-cmdline *\"[^\"]*\"/ /g - s/-ignore *'[^']*'/ /g; s/-ignore *\"[^\"]*\"/ /g - s/-def *'[^']*'/ /g; s/-def *\"[^\"]*\"/ /g"` ;; - - # If we are using fort77 (the f2c wrapper) then filter output and delete quotes. - *fort77*f2c*gcc*) - ac_f77_v_output=`echo "$ac_f77_v_output" | sed -n ' - /:[ ]\+Running[ ]\{1,\}"gcc"/{ - /"-c"/d - /[.]c"*/d - s/^.*"gcc"/"gcc"/ - s/"//gp - }'` ;; - - # If we are using Cray Fortran then delete quotes. - *cft90*) - ac_f77_v_output=`echo $ac_f77_v_output | sed 's/"//g'` ;; -esac - - - -ac_cv_f77_libs= - -# Save positional arguments (if any) -ac_save_positional="$@" - -set X $ac_f77_v_output -while test $# != 1; do - shift - ac_arg=$1 - case $ac_arg in - [\\/]*.a | ?:[\\/]*.a) - ac_exists=false - for ac_i in $ac_cv_f77_libs; do - if test x"$ac_arg" = x"$ac_i"; then - ac_exists=true - break - fi - done - - if test x"$ac_exists" = xtrue -then : - -else $as_nop - ac_cv_f77_libs="$ac_cv_f77_libs $ac_arg" -fi - ;; - -bI:*) - ac_exists=false - for ac_i in $ac_cv_f77_libs; do - if test x"$ac_arg" = x"$ac_i"; then - ac_exists=true - break - fi - done - - if test x"$ac_exists" = xtrue -then : - -else $as_nop - if test "$ac_compiler_gnu" = yes; then - for ac_link_opt in $ac_arg; do - ac_cv_f77_libs="$ac_cv_f77_libs -Xlinker $ac_link_opt" - done -else - ac_cv_f77_libs="$ac_cv_f77_libs $ac_arg" -fi -fi - ;; - # Ignore these flags. - -lang* | -lcrt*.o | -lc | -lgcc* | -lSystem | -libmil | -little \ - |-LANG:=* | -LIST:* | -LNO:* | -link) - ;; - -lkernel32) - # Ignore this library only on Windows-like systems. - case $host_os in - cygwin* | msys* ) ;; - *) - ac_exists=false - for ac_i in $ac_cv_f77_libs; do - if test x"$ac_arg" = x"$ac_i"; then - ac_exists=true - break - fi - done - - if test x"$ac_exists" = xtrue -then : - -else $as_nop - ac_cv_f77_libs="$ac_cv_f77_libs $ac_arg" -fi - ;; - esac - ;; - -[LRuYz]) - # These flags, when seen by themselves, take an argument. - # We remove the space between option and argument and re-iterate - # unless we find an empty arg or a new option (starting with -) - case $2 in - "" | -*);; - *) - ac_arg="$ac_arg$2" - shift; shift - set X $ac_arg "$@" - ;; - esac - ;; - -YP,*) - for ac_j in `printf "%s\n" "$ac_arg" | sed -e 's/-YP,/-L/;s/:/ -L/g'`; do - ac_exists=false - for ac_i in $ac_cv_f77_libs; do - if test x"$ac_j" = x"$ac_i"; then - ac_exists=true - break - fi - done - - if test x"$ac_exists" = xtrue -then : - -else $as_nop - ac_arg="$ac_arg $ac_j" - ac_cv_f77_libs="$ac_cv_f77_libs $ac_j" -fi - done - ;; - -[lLR]*) - ac_exists=false - for ac_i in $ac_cv_f77_libs; do - if test x"$ac_arg" = x"$ac_i"; then - ac_exists=true - break - fi - done - - if test x"$ac_exists" = xtrue -then : - -else $as_nop - ac_cv_f77_libs="$ac_cv_f77_libs $ac_arg" -fi - ;; - -zallextract*| -zdefaultextract) - ac_cv_f77_libs="$ac_cv_f77_libs $ac_arg" - ;; - -mllvm) ${2+shift};; # Defend against 'clang -mllvm -loopopt=0'. - # Ignore everything else. - esac -done -# restore positional arguments -set X $ac_save_positional; shift - -# We only consider "LD_RUN_PATH" on Solaris systems. If this is seen, -# then we insist that the "run path" must be an absolute path (i.e. it -# must begin with a "/"). -case `(uname -sr) 2>/dev/null` in - "SunOS 5"*) - ac_ld_run_path=`printf "%s\n" "$ac_f77_v_output" | - sed -n 's,^.*LD_RUN_PATH *= *\(/[^ ]*\).*$,-R\1,p'` - test "x$ac_ld_run_path" != x && - if test "$ac_compiler_gnu" = yes; then - for ac_link_opt in $ac_ld_run_path; do - ac_cv_f77_libs="$ac_cv_f77_libs -Xlinker $ac_link_opt" - done -else - ac_cv_f77_libs="$ac_cv_f77_libs $ac_ld_run_path" -fi - ;; -esac -fi # test "x$[]_AC_LANG_PREFIX[]LIBS" = "x" - -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_f77_libs" >&5 -printf "%s\n" "$ac_cv_f77_libs" >&6; } -FLIBS="$ac_cv_f77_libs" - - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -ac_ext=f -ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' -ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_f77_compiler_gnu - -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dummy main to link with Fortran 77 libraries" >&5 -printf %s "checking for dummy main to link with Fortran 77 libraries... " >&6; } -if test ${ac_cv_f77_dummy_main+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_f77_dm_save_LIBS=$LIBS - LIBS="$LIBS $FLIBS" - ac_fortran_dm_var=F77_DUMMY_MAIN - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - # First, try linking without a dummy main: - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -#ifdef F77_DUMMY_MAIN - -# ifdef __cplusplus - extern "C" -# endif - int F77_DUMMY_MAIN() { return 1; } - -#endif -int -main (void) -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO" -then : - ac_cv_fortran_dummy_main=none -else $as_nop - ac_cv_fortran_dummy_main=unknown -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext conftest.$ac_ext - - if test $ac_cv_fortran_dummy_main = unknown; then - for ac_func in MAIN__ MAIN_ __main MAIN _MAIN __MAIN main_ main__ _main; do - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#define $ac_fortran_dm_var $ac_func -#ifdef F77_DUMMY_MAIN - -# ifdef __cplusplus - extern "C" -# endif - int F77_DUMMY_MAIN() { return 1; } - -#endif -int -main (void) -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO" -then : - ac_cv_fortran_dummy_main=$ac_func; break -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext conftest.$ac_ext - done - fi - ac_ext=f -ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' -ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_f77_compiler_gnu - ac_cv_f77_dummy_main=$ac_cv_fortran_dummy_main - rm -rf conftest* - LIBS=$ac_f77_dm_save_LIBS - -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_f77_dummy_main" >&5 -printf "%s\n" "$ac_cv_f77_dummy_main" >&6; } -F77_DUMMY_MAIN=$ac_cv_f77_dummy_main -if test "$F77_DUMMY_MAIN" != unknown -then : - if test $F77_DUMMY_MAIN != none; then - -printf "%s\n" "#define F77_DUMMY_MAIN $F77_DUMMY_MAIN" >>confdefs.h - - if test "x$ac_cv_fc_dummy_main" = "x$ac_cv_f77_dummy_main"; then - -printf "%s\n" "#define FC_DUMMY_MAIN_EQ_F77 1" >>confdefs.h - - fi -fi -else $as_nop - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "linking to Fortran libraries from C fails -See \`config.log' for more details" "$LINENO" 5; } -fi - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -ac_ext=f -ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' -ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_f77_compiler_gnu -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Fortran 77 name-mangling scheme" >&5 -printf %s "checking for Fortran 77 name-mangling scheme... " >&6; } -if test ${ac_cv_f77_mangling+y} -then : - printf %s "(cached) " >&6 -else $as_nop - cat > conftest.$ac_ext <<_ACEOF - subroutine foobar() - return - end - subroutine foo_bar() - return - end -_ACEOF -if ac_fn_f77_try_compile "$LINENO" -then : - mv conftest.$ac_objext cfortran_test.$ac_objext - - ac_save_LIBS=$LIBS - LIBS="cfortran_test.$ac_objext $LIBS $FLIBS" - - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - ac_success=no - for ac_foobar in foobar FOOBAR; do - for ac_underscore in "" "_"; do - ac_func="$ac_foobar$ac_underscore" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -char $ac_func (); -#ifdef F77_DUMMY_MAIN - -# ifdef __cplusplus - extern "C" -# endif - int F77_DUMMY_MAIN() { return 1; } - -#endif -int -main (void) -{ -return $ac_func (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO" -then : - ac_success=yes; break 2 -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext conftest.$ac_ext - done - done - ac_ext=f -ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' -ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_f77_compiler_gnu - - if test "$ac_success" = "yes"; then - case $ac_foobar in - foobar) - ac_case=lower - ac_foo_bar=foo_bar - ;; - FOOBAR) - ac_case=upper - ac_foo_bar=FOO_BAR - ;; - esac - - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - ac_success_extra=no - for ac_extra in "" "_"; do - ac_func="$ac_foo_bar$ac_underscore$ac_extra" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -char $ac_func (); -#ifdef F77_DUMMY_MAIN - -# ifdef __cplusplus - extern "C" -# endif - int F77_DUMMY_MAIN() { return 1; } - -#endif -int -main (void) -{ -return $ac_func (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO" -then : - ac_success_extra=yes; break -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext conftest.$ac_ext - done - ac_ext=f -ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' -ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_f77_compiler_gnu - - if test "$ac_success_extra" = "yes"; then - ac_cv_f77_mangling="$ac_case case" - if test -z "$ac_underscore"; then - ac_cv_f77_mangling="$ac_cv_f77_mangling, no underscore" - else - ac_cv_f77_mangling="$ac_cv_f77_mangling, underscore" - fi - if test -z "$ac_extra"; then - ac_cv_f77_mangling="$ac_cv_f77_mangling, no extra underscore" - else - ac_cv_f77_mangling="$ac_cv_f77_mangling, extra underscore" - fi - else - ac_cv_f77_mangling="unknown" - fi - else - ac_cv_f77_mangling="unknown" - fi - - LIBS=$ac_save_LIBS - rm -rf conftest* - rm -f cfortran_test* -else $as_nop - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot compile a simple Fortran program -See \`config.log' for more details" "$LINENO" 5; } -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_f77_mangling" >&5 -printf "%s\n" "$ac_cv_f77_mangling" >&6; } - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -ac_ext=f -ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' -ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_f77_compiler_gnu -case $ac_cv_f77_mangling in - "lower case, no underscore, no extra underscore") - printf "%s\n" "#define F77_FUNC(name,NAME) name" >>confdefs.h - - printf "%s\n" "#define F77_FUNC_(name,NAME) name" >>confdefs.h - ;; - "lower case, no underscore, extra underscore") - printf "%s\n" "#define F77_FUNC(name,NAME) name" >>confdefs.h - - printf "%s\n" "#define F77_FUNC_(name,NAME) name ## _" >>confdefs.h - ;; - "lower case, underscore, no extra underscore") - printf "%s\n" "#define F77_FUNC(name,NAME) name ## _" >>confdefs.h - - printf "%s\n" "#define F77_FUNC_(name,NAME) name ## _" >>confdefs.h - ;; - "lower case, underscore, extra underscore") - printf "%s\n" "#define F77_FUNC(name,NAME) name ## _" >>confdefs.h - - printf "%s\n" "#define F77_FUNC_(name,NAME) name ## __" >>confdefs.h - ;; - "upper case, no underscore, no extra underscore") - printf "%s\n" "#define F77_FUNC(name,NAME) NAME" >>confdefs.h - - printf "%s\n" "#define F77_FUNC_(name,NAME) NAME" >>confdefs.h - ;; - "upper case, no underscore, extra underscore") - printf "%s\n" "#define F77_FUNC(name,NAME) NAME" >>confdefs.h - - printf "%s\n" "#define F77_FUNC_(name,NAME) NAME ## _" >>confdefs.h - ;; - "upper case, underscore, no extra underscore") - printf "%s\n" "#define F77_FUNC(name,NAME) NAME ## _" >>confdefs.h - - printf "%s\n" "#define F77_FUNC_(name,NAME) NAME ## _" >>confdefs.h - ;; - "upper case, underscore, extra underscore") - printf "%s\n" "#define F77_FUNC(name,NAME) NAME ## _" >>confdefs.h - - printf "%s\n" "#define F77_FUNC_(name,NAME) NAME ## __" >>confdefs.h - ;; - *) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unknown Fortran name-mangling scheme" >&5 -printf "%s\n" "$as_me: WARNING: unknown Fortran name-mangling scheme" >&2;} - ;; -esac - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -ac_ext=f -ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' -ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_f77_compiler_gnu - -F77=$f90 # use Fortran 90 actually -FFLAGS="$test_fflags" -LDFLAGS="$test_ldflags" - -# Checking BLAS... - - -have_blas=0 - -# Flags for machine-specific libraries -have_acml=0 -have_atlas=0 -have_essl=0 -have_mkl=0 -have_armpl=0 - -if test "$blas_libs" != "" -then - echo setting BLAS from \$BLAS_LIBS with no check ... $blas_libs - have_blas=1 -else - # check directories in LD_LIBRARY_PATH too - # (maybe they are already searched by default: useless?) - ld_library_path=`echo $LD_LIBRARY_PATH | sed 's/:/ /g'` - - case "$arch:$f90" in - - # search for architecture-specific libraries - - x86_64:* | mac686:* ) - # - # search for MKL in directory $MKL_ROOT - # - # Following architectures no longer supported: - # ia64 $MKLROOT/lib/64 -lmkl_gf_ipf, -lmkl_intel_ipf - # ia32 $MKLROOT/lib/ia32 -lmkl_gf , -lmkl_intel - # - if test "$MKLROOT" == ""; then - MKLROOT=/opt/intel/mkl - fi - case "$f90" in - ifort* ) - mkl_lib="mkl_intel_lp64" - mkl_omp="mkl_intel_thread" - if test "$arch" == "mac686"; then - add_mkl_flag="-openmp" - add_mkl_lib="-lpthread" - add_mkl_omp="-lpthread" - fi - ;; - gfortran* ) - mkl_lib="mkl_gf_lp64" - mkl_omp="mkl_gnu_thread" - ;; - nvfortran* ) - mkl_lib="mkl_intel_lp64" - mkl_omp="mkl_intel_thread" - # FIXME: is the following correct? - add_mkl_flag="-pgf90libs" - ;; - pgf* ) - # Detect PGI version - FIXME: WHY? pgf_version is known - pgf_version=`$mpif90 -V 2>&1 | sed '/^$/d' | grep "^pgf" | cut -d ' ' -f2` - # From version 19.1, the new llvm backend requires linking to mkl_intel_thread - ompimp="" - as_arg_v1=$pgf_version -as_arg_v2=19.1 -awk "$as_awk_strverscmp" v1="$as_arg_v1" v2="$as_arg_v2" /dev/null -case $? in #( - 1) : - ompimp="pgi" ;; #( - 0) : - ompimp="intel" ;; #( - 2) : - ompimp="intel" ;; #( - *) : - ;; -esac - mkl_lib="mkl_${ompimp}_lp64" - mkl_omp="mkl_${ompimp}_thread" - add_mkl_flag="-pgf90libs" - ;; - esac - try_libdirs="$libdirs $MKLROOT/lib/intel64 $ld_library_path" - for dir in none $try_libdirs - do - unset ac_cv_search_dgemm # clear cached value - if test "$dir" = "none" - then - try_loption=" " - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$add_mkl_flag $test_ldflags $try_loption" - # LIBS="" - # not sure the above is needed - if test "$use_openmp" -eq 0; then - # test MKL (no OMP) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dgemm" >&5 -printf %s "checking for library containing dgemm... " >&6; } -if test ${ac_cv_search_dgemm+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dgemm - end -_ACEOF -for ac_lib in '' $mkl_lib -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib -lmkl_sequential -lmkl_core $add_mkl_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dgemm=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dgemm+y} -then : - break -fi -done -if test ${ac_cv_search_dgemm+y} -then : - -else $as_nop - ac_cv_search_dgemm=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dgemm" >&5 -printf "%s\n" "$ac_cv_search_dgemm" >&6; } -ac_res=$ac_cv_search_dgemm -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_blas=1 have_mkl=1 - blas_libs="$try_loption $LIBS -lmkl_sequential -lmkl_core" - ldflags="$add_mkl_flag $ldflags" -else $as_nop - echo "MKL not found" -fi - - else - # test MKL (OMP) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dgemm" >&5 -printf %s "checking for library containing dgemm... " >&6; } -if test ${ac_cv_search_dgemm+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dgemm - end -_ACEOF -for ac_lib in '' $mkl_lib -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib -l$mkl_omp -lmkl_core $add_mkl_omp $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dgemm=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dgemm+y} -then : - break -fi -done -if test ${ac_cv_search_dgemm+y} -then : - -else $as_nop - ac_cv_search_dgemm=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dgemm" >&5 -printf "%s\n" "$ac_cv_search_dgemm" >&6; } -ac_res=$ac_cv_search_dgemm -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_blas=1 have_mkl=1 - blas_libs="$try_loption $LIBS -l$mkl_omp -lmkl_core" - ldflags="$add_mkl_flag $ldflags" -else $as_nop - echo "MKL not found" -fi - - fi - if test "$ac_cv_search_dgemm" != "no" - then break ; fi - done - ;; - - ppc64:* ) - # - # search for ESSL - newer (?) powerPC machines - # - unset ac_cv_search_dgemm # clear cached value - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags" - LIBS="" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dgemm" >&5 -printf %s "checking for library containing dgemm... " >&6; } -if test ${ac_cv_search_dgemm+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dgemm - end -_ACEOF -for ac_lib in '' essl -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dgemm=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dgemm+y} -then : - break -fi -done -if test ${ac_cv_search_dgemm+y} -then : - -else $as_nop - ac_cv_search_dgemm=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dgemm" >&5 -printf "%s\n" "$ac_cv_search_dgemm" >&6; } -ac_res=$ac_cv_search_dgemm -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_blas=1 - blas_libs="$LIBS" -fi - - # notice that some IBM machines may not need -lessl - # to load blas so the above test may fail - if test "`echo $blas_libs | grep essl`" != "" - then - have_essl=1 - try_dflags="$try_dflags -D__LINUX_ESSL" - fi - # OBM:Yet another work-around if the above search - # returns "none required" - if test "$ac_cv_search_dgemm" = "none required" - then - echo "There is no need for -lessl in this machine" - have_essl=1 - try_dflags="$try_dflags -D__LINUX_ESSL" - fi - # we need esslsmp for hybrid (MPI+OpenMP) build - if test "$have_essl"="1"; then - if test "$use_openmp" -ne 0 ; then - blas_libs="-lesslsmp" - fi - fi - ;; - - ppc64-*:* ) - # - # assume ESSL without testing - old powerPC machines, BlueGene - # - unset ac_cv_search_dgemm # clear cached value - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags" - have_blas=1 - have_essl=1 - # BlueGene: for some obscure reason there is no need to - # specify a library path to have essl linked, while - # in reality it is needed to specify where essl are - if test "$arch"="ppc64-bg"; then - try_dflags="$try_dflags -D__LINUX_ESSL" - if test "$blas_libs"=""; then - if test "$use_openmp" -eq 0 ; then - blas_libs="-L/opt/ibmmath/essl/4.4/lib/ -lesslbg" - else - blas_libs="-L/opt/ibmmath/essl/4.4/lib/ -lesslsmpbg" - fi - fi - else - try_dflags="$try_dflags -D__LINUX_ESSL" - fi - ;; - - arm:armflang ) - # search for ARM libs - ARM compiler - if test "$use_openmp" -eq 0; then - FFLAGS="-armpl" - else - FFLAGS="-fopenmp -armpl=parallel" - fi - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dgemm" >&5 -printf %s "checking for library containing dgemm... " >&6; } -if test ${ac_cv_search_dgemm+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dgemm - end -_ACEOF -for ac_lib in '' armpl_arm -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib yes $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dgemm=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dgemm+y} -then : - break -fi -done -if test ${ac_cv_search_dgemm+y} -then : - -else $as_nop - ac_cv_search_dgemm=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dgemm" >&5 -printf "%s\n" "$ac_cv_search_dgemm" >&6; } -ac_res=$ac_cv_search_dgemm -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_blas=1 have_armpl=1 - blas_libs="" - ldflags="$ldflags \$(FFLAGS)" -else $as_nop - echo "armpl not found" -fi - - if test "$have_armpl" -eq 1; then - if test "$use_openmp" -eq 0; then - fflags="$fflags -armpl" - else - fflags="$fflags -armpl=parallel" - fi - fi - ;; - - arm:gfortran ) - # search for ARM libs - gfortran compiler - try_libdirs="$libdirs $ARMPL_LIBRARIES $ld_library_path" - for dir in none $try_libdirs - do - unset ac_cv_search_dgemm # clear cached value - if test "$dir" = "none" - then - try_loption=" " - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - # LIBS="" - # not sure the above is needed - # - if test "$use_openmp" -eq 0; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dgemm" >&5 -printf %s "checking for library containing dgemm... " >&6; } -if test ${ac_cv_search_dgemm+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dgemm - end -_ACEOF -for ac_lib in '' armpl -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dgemm=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dgemm+y} -then : - break -fi -done -if test ${ac_cv_search_dgemm+y} -then : - -else $as_nop - ac_cv_search_dgemm=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dgemm" >&5 -printf "%s\n" "$ac_cv_search_dgemm" >&6; } -ac_res=$ac_cv_search_dgemm -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_blas=1 have_armpl=1 - blas_libs="$try_loption $LIBS " - ldflags="$ldflags" -else $as_nop - echo "armpl not found" -fi - - else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dgemm" >&5 -printf %s "checking for library containing dgemm... " >&6; } -if test ${ac_cv_search_dgemm+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dgemm - end -_ACEOF -for ac_lib in '' armpl_mp -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dgemm=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dgemm+y} -then : - break -fi -done -if test ${ac_cv_search_dgemm+y} -then : - -else $as_nop - ac_cv_search_dgemm=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dgemm" >&5 -printf "%s\n" "$ac_cv_search_dgemm" >&6; } -ac_res=$ac_cv_search_dgemm -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_blas=1 have_armpl=1 - blas_libs="$try_loption $LIBS " - ldflags="$ldflags" -else $as_nop - echo "armpl not found" -fi - - fi - if test "$ac_cv_search_dgemm" != "no" - then break ; fi - done - ;; - - # obsolescent or obsolete architectures - - crayxt*:* ) - # check for acml - OBSOLETE? - try_libdirs="$ld_library_path $libdirs" - for dir in none $try_libdirs - do - unset ac_cv_search_dgemm # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - - if test "$use_openmp" -eq 0; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dgemm" >&5 -printf %s "checking for library containing dgemm... " >&6; } -if test ${ac_cv_search_dgemm+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dgemm - end -_ACEOF -for ac_lib in '' acml -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dgemm=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dgemm+y} -then : - break -fi -done -if test ${ac_cv_search_dgemm+y} -then : - -else $as_nop - ac_cv_search_dgemm=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dgemm" >&5 -printf "%s\n" "$ac_cv_search_dgemm" >&6; } -ac_res=$ac_cv_search_dgemm -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_blas=1 have_lapack=1 - have_acml=1 blas_libs="$try_loption $LIBS" -fi - - else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dgemm" >&5 -printf %s "checking for library containing dgemm... " >&6; } -if test ${ac_cv_search_dgemm+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dgemm - end -_ACEOF -for ac_lib in '' acml_mp -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dgemm=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dgemm+y} -then : - break -fi -done -if test ${ac_cv_search_dgemm+y} -then : - -else $as_nop - ac_cv_search_dgemm=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dgemm" >&5 -printf "%s\n" "$ac_cv_search_dgemm" >&6; } -ac_res=$ac_cv_search_dgemm -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_blas=1 have_lapack=1 - have_acml=1 blas_libs="$try_loption $LIBS" -fi - - fi - - if test "$ac_cv_search_dgemm" != "no" - then break ; fi - done - ;; - - necsx:* ) - #sx5-nec or sx6-nec or sx8-nec: check in (/SX)/usr/lib - #sx8-nec-idris: check in /SX/opt/mathkeisan/inst/lib0 - try_libdirs="/SX/usr/lib /SX/opt/mathkeisan/inst/lib0" - for dir in none $try_libdirs - do - unset ac_cv_search_dgemm # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dgemm" >&5 -printf %s "checking for library containing dgemm... " >&6; } -if test ${ac_cv_search_dgemm+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dgemm - end -_ACEOF -for ac_lib in '' blas -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dgemm=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dgemm+y} -then : - break -fi -done -if test ${ac_cv_search_dgemm+y} -then : - -else $as_nop - ac_cv_search_dgemm=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dgemm" >&5 -printf "%s\n" "$ac_cv_search_dgemm" >&6; } -ac_res=$ac_cv_search_dgemm -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_blas=1 - blas_libs="$try_loption $LIBS" -fi - - if test "$ac_cv_search_dgemm" != "no" - then break ; fi - done - ;; - esac - - # blas not (yet) found: look for more possibilities - - if test "$have_blas" -eq 0 - then - case "$f90" in - pgf* ) - # check for PGI blas - unset ac_cv_search_dgemm # clear cached value - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags" - LIBS="" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dgemm" >&5 -printf %s "checking for library containing dgemm... " >&6; } -if test ${ac_cv_search_dgemm+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dgemm - end -_ACEOF -for ac_lib in '' blas -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dgemm=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dgemm+y} -then : - break -fi -done -if test ${ac_cv_search_dgemm+y} -then : - -else $as_nop - ac_cv_search_dgemm=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dgemm" >&5 -printf "%s\n" "$ac_cv_search_dgemm" >&6; } -ac_res=$ac_cv_search_dgemm -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_blas=1 blas_libs="$LIBS" -fi - - ;; - esac - fi - - if test "$have_blas" -eq 0 - then - # check for atlas (in several directories) - try_libdirs="$libdirs /usr/local/lib $ld_library_path" - - for dir in none $try_libdirs - do - unset ac_cv_search_dgemm # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="-latlas" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dgemm" >&5 -printf %s "checking for library containing dgemm... " >&6; } -if test ${ac_cv_search_dgemm+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dgemm - end -_ACEOF -for ac_lib in '' f77blas -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib -lg2c $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dgemm=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dgemm+y} -then : - break -fi -done -if test ${ac_cv_search_dgemm+y} -then : - -else $as_nop - ac_cv_search_dgemm=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dgemm" >&5 -printf "%s\n" "$ac_cv_search_dgemm" >&6; } -ac_res=$ac_cv_search_dgemm -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_blas=1 have_atlas=1 - blas_libs="$try_loption $LIBS" -fi - - if test "$ac_cv_search_dgemm" != "no" - then break ; fi - done - fi - - if test "$have_blas" -eq 0 - then - # check for blas (in several directories) - try_libdirs="$libdirs /usr/local/lib $ld_library_path" - - for dir in none $try_libdirs - do - unset ac_cv_search_dgemm # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dgemm" >&5 -printf %s "checking for library containing dgemm... " >&6; } -if test ${ac_cv_search_dgemm+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dgemm - end -_ACEOF -for ac_lib in '' blas-3 openblas blas -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dgemm=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dgemm+y} -then : - break -fi -done -if test ${ac_cv_search_dgemm+y} -then : - -else $as_nop - ac_cv_search_dgemm=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dgemm" >&5 -printf "%s\n" "$ac_cv_search_dgemm" >&6; } -ac_res=$ac_cv_search_dgemm -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_blas=1 - blas_libs="$try_loption $LIBS" -fi - - if test "$ac_cv_search_dgemm" != "no" - then break ; fi - done - fi -fi - -if test "$have_blas" -eq 0 ; then - # No blas library found: use internal one (in lapack) - blas_libs="\$(TOPDIR)/LAPACK/libblas.a" -else - echo setting BLAS_LIBS... $blas_libs -fi -blas_line="BLAS_LIBS=$blas_libs" - - - - - - - -# Checking LAPACK... - - -if test "$have_mkl" -ne 0 || test "$have_armpl" -ne 0 || test "$have_acml" -ne 0 || test "$have_essl" -ne 0 -then - # MKL or ARM libraries or ACML (obsolete) or ESSL (obsolete?) found: - # no need to check for lapack - have_lapack=1 -else - # check for lapack - have_lapack=0 -fi -# -if test "$have_lapack" -eq 0 -then - if test "$lapack_libs" = "" - then - # check directories in LD_LIBRARY_PATH too - # (maybe they are already searched by default, but I'm not sure) - ld_library_path=`echo $LD_LIBRARY_PATH | sed 's/:/ /g'` - - case "$arch:$f90" in - - necsx:* ) - # NECSX: OBSOLETE? - try_libdirs="/SX/usr/lib /SX/opt/mathkeisan/inst/lib0" - for dir in none $try_libdirs - do - unset ac_cv_search_dspev # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption $blas_libs" - LIBS="" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dspev" >&5 -printf %s "checking for library containing dspev... " >&6; } -if test ${ac_cv_search_dspev+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dspev - end -_ACEOF -for ac_lib in '' lapack -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dspev=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dspev+y} -then : - break -fi -done -if test ${ac_cv_search_dspev+y} -then : - -else $as_nop - ac_cv_search_dspev=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dspev" >&5 -printf "%s\n" "$ac_cv_search_dspev" >&6; } -ac_res=$ac_cv_search_dspev -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_lapack=1 - lapack_libs="$try_loption $LIBS" -fi - - if test "$ac_cv_search_dspev" != "no" - then break ; fi - done - ;; - esac - - if test "$have_lapack" -eq 0 - then - # generic check for lapack (in several directories) - try_libdirs="/usr/local/lib" - try_libdirs="$libdirs $try_libdirs $ld_library_path" - - for dir in none $try_libdirs - do - unset ac_cv_search_dspev # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="$blas_libs" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dspev" >&5 -printf %s "checking for library containing dspev... " >&6; } -if test ${ac_cv_search_dspev+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dspev - end -_ACEOF -for ac_lib in '' lapack-3 lapack -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dspev=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dspev+y} -then : - break -fi -done -if test ${ac_cv_search_dspev+y} -then : - -else $as_nop - ac_cv_search_dspev=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dspev" >&5 -printf "%s\n" "$ac_cv_search_dspev" >&6; } -ac_res=$ac_cv_search_dspev -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_lapack=1 - lapack_libs="$try_loption $LIBS" -fi - - done - fi - - else - # lapack provided in LAPACK_LIBS: not checked - echo setting LAPACK from \$LAPACK_LIBS with no check ... $lapack_libs - have_lapack=1 - fi - -fi - -# No lapack library found: use internal lapack - -if test "$have_lapack" -eq 0 ; then - lapack_libs="\$(TOPDIR)/LAPACK/liblapack.a" - echo setting LAPACK to internal library ... $lapack_libs - lapack_libs_switch="internal" -else - lapack_libs_switch="external" -fi -lapack_line="LAPACK_LIBS=$lapack_libs" - - - - - -ac_config_files="$ac_config_files install/make_lapack.inc" - - - - - -# Checking for FFT... - - -have_fft=0 -have_fft_include=0 - -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking FFT" >&5 -printf %s "checking FFT... " >&6; } - -if test "$fft_libs" = ""; then - # if FFT_LIBS is defined, use it without further checking - - if test "$have_mkl" -eq 1; then - # no check needed if MKL libraries have been detected - try_dflags="$try_dflags -D__FFTW3" - # If not set on input, MKLROOT was set when checking blas - try_iflags="$try_iflags -I$MKLROOT/include" - have_fft=1 - - elif test "$have_armpl" -eq 1; then - # no check needed if ARM libraries have been detected - try_dflags="$try_dflags -D__ARM_LIB" - have_fft=1 - - elif test "$have_essl" -eq 1; then - # no check needed for ESSL on PPC64 machine: TO BE VERIFIED - case "$arch" in - ppc64* ) - try_dflags="$try_dflags -D__LINUX_ESSL" - ;; - esac - - elif test "$use_openmp" -eq 0; then - - # check for OBSOLETE? FFT libraries (not for explicit openmp) - # ASL/Mathkeisan on Nec (OBSOLETE) - # acml on amd - - # check directories in LD_LIBRARY_PATH too - # (maybe they are already searched by default, but I'm not sure) - ld_library_path=`echo $LD_LIBRARY_PATH | sed 's/:/ /g'` - - case "$arch" in - necsx ) - # NEC-SX: OBSOLETE? - if test "$use_fft_mathkeisan" -ne 0 - then - #sx5-nec or sx6-nec or sx8-nec: check in (/SX)/usr/lib - #sx8-nec-idris: check in /SX/opt/mathkeisan/inst/lib0 - try_libdirs="/SX/usr/lib /SX/opt/mathkeisan/inst/lib0" - #check for Mathkeisan (Cray simple precision ) - #search for initialization subroutine - echo $ECHO_N "Searching in Mathkeisan" $ECHO_C - for dir in none $try_libdirs - do - unset ac_cv_search_zftfax # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing zftfax" >&5 -printf %s "checking for library containing zftfax... " >&6; } -if test ${ac_cv_search_zftfax+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call zftfax - end -_ACEOF -for ac_lib in '' fft -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_zftfax=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_zftfax+y} -then : - break -fi -done -if test ${ac_cv_search_zftfax+y} -then : - -else $as_nop - ac_cv_search_zftfax=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_zftfax" >&5 -printf "%s\n" "$ac_cv_search_zftfax" >&6; } -ac_res=$ac_cv_search_zftfax -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_fft=1 - try_dflags="$try_dflags try_dflags_fft_mathkeisan" - fft_libs="$try_loption $LIBS" -fi - - if test "$ac_cv_search_zftfax" != "no" - then break ; fi - done - fi - if test "$use_fft_asl" -ne 0 - then - #check for asl in (/SX)/usr/lib - try_libdirs="/SX/usr/lib" - #search for initialization subroutine - echo $ECHO_N "Searching in Asl" $ECHO_C - for dir in none $try_libdirs - do - unset ac_cv_search_zfc3cl # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing zfc3cl" >&5 -printf %s "checking for library containing zfc3cl... " >&6; } -if test ${ac_cv_search_zfc3cl+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call zfc3cl - end -_ACEOF -for ac_lib in '' asl -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_zfc3cl=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_zfc3cl+y} -then : - break -fi -done -if test ${ac_cv_search_zfc3cl+y} -then : - -else $as_nop - ac_cv_search_zfc3cl=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_zfc3cl" >&5 -printf "%s\n" "$ac_cv_search_zfc3cl" >&6; } -ac_res=$ac_cv_search_zfc3cl -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_fft=1 - asl_libs="$try_loption $LIBS" - try_dflags="$try_dflags $try_dflags_fft_asl" - fft_libs="$fft_libs $asl_libs" -fi - - if test "$ac_cv_search_zfc3cl" != "no" - then break ; fi - done - fi - if test "$use_fft_para" -ne 0 - then - try_dflags="$try_dflags $try_dflags_fft_para" - fi - ;; - esac - fi - - if test "$have_fft" -eq 0 - then - - # Nothing found: look for fftw v3 - - try_libdirs="/usr/local/lib" - try_libdirs="$libdirs $try_libdirs $ld_library_path " - for dir in none $try_libdirs - do - unset ac_cv_search_dfftw_execute_dft # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - - CFLAGS="$test_cflags" - CPPFLAGS="$test_cppflags" - LDFLAGS=" $test_ldflags $try_loption" - LIBS="$fft_libs" - - if test "$use_openmp" -eq 1 - then - # Try testing openmp without -lfftw3 first, if that fails then return - # to previous behaviour - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dfftw_execute_dft" >&5 -printf %s "checking for library containing dfftw_execute_dft... " >&6; } -if test ${ac_cv_search_dfftw_execute_dft+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dfftw_execute_dft - end -_ACEOF -for ac_lib in '' fftw3_omp -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib -lm $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dfftw_execute_dft=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dfftw_execute_dft+y} -then : - break -fi -done -if test ${ac_cv_search_dfftw_execute_dft+y} -then : - -else $as_nop - ac_cv_search_dfftw_execute_dft=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dfftw_execute_dft" >&5 -printf "%s\n" "$ac_cv_search_dfftw_execute_dft" >&6; } -ac_res=$ac_cv_search_dfftw_execute_dft -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_fft=1 - fft_libs="$try_loption $LIBS" -fi - - if test "$have_fft" -eq 0 - then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dfftw_execute_dft" >&5 -printf %s "checking for library containing dfftw_execute_dft... " >&6; } -if test ${ac_cv_search_dfftw_execute_dft+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dfftw_execute_dft - end -_ACEOF -for ac_lib in '' fftw3_omp -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib -lfftw3 -lm $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dfftw_execute_dft=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dfftw_execute_dft+y} -then : - break -fi -done -if test ${ac_cv_search_dfftw_execute_dft+y} -then : - -else $as_nop - ac_cv_search_dfftw_execute_dft=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dfftw_execute_dft" >&5 -printf "%s\n" "$ac_cv_search_dfftw_execute_dft" >&6; } -ac_res=$ac_cv_search_dfftw_execute_dft -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_fft=1 - fft_libs="$try_loption $LIBS -lfftw3" -fi - - fi - else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dfftw_execute_dft" >&5 -printf %s "checking for library containing dfftw_execute_dft... " >&6; } -if test ${ac_cv_search_dfftw_execute_dft+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call dfftw_execute_dft - end -_ACEOF -for ac_lib in '' fftw3 -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib -lm $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_dfftw_execute_dft=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_dfftw_execute_dft+y} -then : - break -fi -done -if test ${ac_cv_search_dfftw_execute_dft+y} -then : - -else $as_nop - ac_cv_search_dfftw_execute_dft=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dfftw_execute_dft" >&5 -printf "%s\n" "$ac_cv_search_dfftw_execute_dft" >&6; } -ac_res=$ac_cv_search_dfftw_execute_dft -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_fft=1 - fft_libs="$try_loption $LIBS" -fi - - fi - - if test "$have_fft" -eq 1 - then - try_dflags="$try_dflags -D__FFTW3" - try_incdir="$FFTW_INCLUDE $FFTW_INC $INCLUDE_PATH $CPATH $FPATH" - orig_fflags="$FFLAGS" - for inc in $try_incdir - do - FFLAGS="$orig_fflags -I$inc -ffree-form" - cat > conftest.$ac_ext <<_ACEOF -use iso_c_binding -include "fftw3.f03" -end -_ACEOF -if ac_fn_f77_try_compile "$LINENO" -then : - have_fft_include=1 -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - if test "$have_fft_include" -eq 1 - then - try_iflags="$try_iflags -I$inc" - break - fi - done - FFLAGS="$orig_fflags" - break - fi - - done - fi - - # if no valid FFT library was found, use the local copy - if test "$have_fft" -eq 0 - then - echo "using internal copy of FFTW" - try_dflags="$try_dflags -D__FFTW" - fi - -else - - echo "using FFT_LIBS with no testing ... " - if test -n "$FFT_INCLUDE" ; then : - try_iflags="$try_iflags -I$FFT_INCLUDE" - fi - if test -n "$FFTW_INCLUDE" ; then : - try_dflags="$try_dflags -D__FFTW3" - try_iflags="$try_iflags -I$FFTW_INCLUDE" - fi - -fi - -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${fft_libs}" >&5 -printf "%s\n" "${fft_libs}" >&6; } -fft_line="FFT_LIBS=$fft_libs" - - - - - - - -# Setting libxc... - -acx_libxc_ok=no - - -# Check whether --with-libxc was given. -if test ${with_libxc+y} -then : - withval=$with_libxc; if test "$withval" = "no" ; then - with_libxc=0 - else - with_libxc=1 - fi -else $as_nop - with_libxc=0 - -fi - - - -# Check whether --with-libxc-prefix was given. -if test ${with_libxc_prefix+y} -then : - withval=$with_libxc_prefix; -fi - - -# Check whether --with-libxc-include was given. -if test ${with_libxc_include+y} -then : - withval=$with_libxc_include; -fi - - -if test "$with_libxc" -ne 0; then - -lxcf="f03" -lxcf2="f03" -if test ! -z "$with_libxc_prefix"; then -lxc_version=`grep "XC_MAJOR_VERSION" "$with_libxc_prefix/xc_version.h" | tr -dc '1-9'` -if test "$lxc_version" = 5; then - lxcf="f90" - lxcf2="f90" -fi -if test "$lxc_version" -gt 5; then - lxcf="f90" - lxcf2="f03" -fi -fi - -if test x"$FCFLAGS_LIBXC" = x; then - case $with_libxc_prefix in - "") FCFLAGS_LIBXC="$imod/usr/include" ;; - *) FCFLAGS_LIBXC="$imod$with_libxc_prefix/include" ;; - esac -fi - -case $with_libxc_include in - "") ;; - *) FCFLAGS_LIBXC="$imod$with_libxc_include" ;; -esac - -acx_libxc_save_LIBS="$LIBS" -acx_libxc_save_FCFLAGS="$FCFLAGS" - -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for libxc" >&5 -printf %s "checking for libxc... " >&6; } -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - -FCFLAGS="$FCFLAGS_LIBXC $acx_libxc_save_FCFLAGS" - -testprog=" program main - - use xc_${lxcf2}_lib_m - implicit none - integer :: major - integer :: minor - integer :: micro - call xc_${lxcf2}_version(major, minor, micro) - end" - -LDFLAGS_KEEP="$LDFLAGS" -LDFLAGS="" - -if test ! -z "$LIBS_LIBXC"; then - LIBS="$LIBS_LIBXC" - cat > conftest.$ac_ext <<_ACEOF -$testprog -_ACEOF -if ac_fn_fc_try_link "$LINENO" -then : - acx_libxc_ok=yes -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext conftest.$ac_ext - LIBS="$LIBS_LIBXC $acx_libxc_save_LIBS" -fi - -if test ! -z "$with_libxc_prefix"; then - if test x"$acx_libxc_ok" = xno; then - LIBS_LIBXC="-L$with_libxc_prefix/lib -lxc$lxcf -lxc" - LIBS="$LIBS_LIBXC" - cat > conftest.$ac_ext <<_ACEOF -$testprog -_ACEOF -if ac_fn_fc_try_link "$LINENO" -then : - acx_libxc_ok=yes -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext conftest.$ac_ext - LIBS="$LIBS_LIBXC $acx_libxc_save_LIBS" - fi -else - LIBS_LIBXC="-lxc$lxcf -lxc" - LIBS="$LIBS_LIBXC" - cat > conftest.$ac_ext <<_ACEOF -$testprog -_ACEOF -if ac_fn_fc_try_link "$LINENO" -then : - acx_libxc_ok=yes -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext conftest.$ac_ext - LIBS="$LIBS_LIBXC $acx_libxc_save_LIBS" -fi - -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $acx_libxc_ok ($FCFLAGS_LIBXC $LIBS_LIBXC)" >&5 -printf "%s\n" "$acx_libxc_ok ($FCFLAGS_LIBXC $LIBS_LIBXC)" >&6; } -LDFLAGS="$LDFLAGS_KEEP" - -libxc_line="@delete@" -if test x"$acx_libxc_ok" = xyes; then - try_dflags="$try_dflags -D__LIBXC" - try_iflags="$try_iflags $FCFLAGS_LIBXC" - - libxc_line="LIBXC_LIBS= $LIBS_LIBXC" - -else - as_fn_error $? "Could not find required libxc library." "$LINENO" 5 -fi - -ac_ext=f -ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' -ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_f77_compiler_gnu - - -fi - -# Checking for IBM MASS library... - - - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking MASS" >&5 -printf %s "checking MASS... " >&6; } - - # check for IBM mass -if test "$mass_libs" = "" -then - # check directories in LD_LIBRARY_PATH too - # (maybe they are already searched by default, but I'm not sure) - ld_library_path=`echo $LD_LIBRARY_PATH | sed 's/:/ /g'` - - case "$arch" in - ppc64-bg ) - # check for mass (in several directories) - try_libdirs="/opt/ibmcmp/xlmass/bg/7.3/bglib64 /opt/ibmcmp/xlmass/bg/4.4/bglib /cineca/lib /cineca/lib/mass" - try_libdirs="$libdirs $try_libdirs $ld_library_path" - - for dir in none $try_libdirs - do - unset ac_cv_search_vexp # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing vexp" >&5 -printf %s "checking for library containing vexp... " >&6; } -if test ${ac_cv_search_vexp+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call vexp - end -_ACEOF -for ac_lib in '' massvp4 massv -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib -lmass $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_vexp=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_vexp+y} -then : - break -fi -done -if test ${ac_cv_search_vexp+y} -then : - -else $as_nop - ac_cv_search_vexp=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_vexp" >&5 -printf "%s\n" "$ac_cv_search_vexp" >&6; } -ac_res=$ac_cv_search_vexp -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - -fi - - if test "$ac_cv_search_vexp" = "-lmassvp4" \ - -o "$ac_cv_search_vexp" = "-lmassv" - then mass_libs="$try_loption $ac_cv_search_vexp -lmass" - fi - if test "$ac_cv_search_vexp" != "no" ; then break ; fi - done - ;; - ppc64-bgq ) - # check for mass (in several directories) - try_libdirs="/opt/ibmcmp/xlmass/bg/7.3/bglib64" - try_libdirs="$libdirs $try_libdirs $ld_library_path" - - for dir in none $try_libdirs - do - unset ac_cv_search_vexp # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing vexp" >&5 -printf %s "checking for library containing vexp... " >&6; } -if test ${ac_cv_search_vexp+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call vexp - end -_ACEOF -for ac_lib in '' massv -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib -lmass_simd $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_vexp=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_vexp+y} -then : - break -fi -done -if test ${ac_cv_search_vexp+y} -then : - -else $as_nop - ac_cv_search_vexp=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_vexp" >&5 -printf "%s\n" "$ac_cv_search_vexp" >&6; } -ac_res=$ac_cv_search_vexp -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - -fi - - if test "$ac_cv_search_vexp" = "-lmassv" - then mass_libs="$try_loption $ac_cv_search_vexp -lmass_simd" - fi - if test "$ac_cv_search_vexp" != "no" ; then break ; fi - done - ;; - - ppc64* ) - # check for mass (in several directories) - try_libdirs="/usr/local/lib /opt/ibmcmp/xlmass/*/lib64" - try_libdirs="$libdirs $try_libdirs $ld_library_path" - - for dir in none $try_libdirs - do - unset ac_cv_search_vexp # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing vexp" >&5 -printf %s "checking for library containing vexp... " >&6; } -if test ${ac_cv_search_vexp+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call vexp - end -_ACEOF -for ac_lib in '' massvp4_64 -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib -lmass_64 $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_vexp=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_vexp+y} -then : - break -fi -done -if test ${ac_cv_search_vexp+y} -then : - -else $as_nop - ac_cv_search_vexp=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_vexp" >&5 -printf "%s\n" "$ac_cv_search_vexp" >&6; } -ac_res=$ac_cv_search_vexp -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - -fi - - if test "$ac_cv_search_vexp" = "-lmassvp4_64" - then mass_libs="$try_loption $ac_cv_search_vexp -lmass_64" - fi - if test "$ac_cv_search_vexp" != "no" ; then break ; fi - done - ;; - - esac -fi - -if test "$mass_libs" != ""; then - try_dflags="$try_dflags -D__MASS" - if test "$arch" = "ppc64-bg"; then - # BlueGene wants this when mass libs are loaded, SP6 doesn't want this! - ldflags="$ldflags -Wl,--allow-multiple-definition" - fi - if test "$arch" = "ppc64-bgq"; then - # BlueGene wants this when mass libs are loaded, SP6 doesn't want this! - ldflags="$ldflags -Wl,--allow-multiple-definition" - fi -fi - -# Configuring output message -if test "$mass_libs" != "" ; then - mass_line="MASS_LIBS=$mass_libs" -else - mass_line="@delete@" -fi - - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${mass_libs}" >&5 -printf "%s\n" "${mass_libs}" >&6; } - - - - - - - -# check for MPI library... - - -have_mpi=0 -parallel=0 - -# some architectures require to link mpi libraries explicitly -F77=$mpif90 # use parallel compiler -if test "$mpi_libs" = "" -then - # check directories in LD_LIBRARY_PATH too - # (maybe they are already searched by default, but I'm not sure) - ld_library_path=`echo $LD_LIBRARY_PATH | sed 's/:/ /g'` - - if test "$use_parallel" -ne 0 - then - if test "$have_mpi" -eq 0 - # check for mpi - then - unset ac_cv_search_mpi_init # clear cached value - LDFLAGS="$test_ldflags" - LIBS="$mpi_libs" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing mpi_init" >&5 -printf %s "checking for library containing mpi_init... " >&6; } -if test ${ac_cv_search_mpi_init+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call mpi_init - end -_ACEOF -for ac_lib in '' mpi -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_mpi_init=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_mpi_init+y} -then : - break -fi -done -if test ${ac_cv_search_mpi_init+y} -then : - -else $as_nop - ac_cv_search_mpi_init=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_mpi_init" >&5 -printf "%s\n" "$ac_cv_search_mpi_init" >&6; } -ac_res=$ac_cv_search_mpi_init -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_mpi=1 parallel=1 mpi_libs="$LIBS" try_dflags="$try_dflags -D__MPI -D__PARA" -fi - - fi - fi -else - if test "$use_parallel" -ne 0 - then - have_mpi=1 - parallel=1 - try_dflags="$try_dflags -D__MPI -D__PARA" - fi -fi - -# Configuring output message -if test "$mpi_libs" != "" ; then - mpi_line="MPI_LIBS=$mpi_libs" -else - mpi_line="@delete@" -fi - -# Parallel report -if test "$use_parallel" -ne 0 -then - if test "$parallel" -ne 0 - then - parallel_report="Parallel environment detected successfully.\\ -Configured for compilation of parallel executables." - else - parallel_report="Parallel environment not detected \ -\(is this a parallel machine?\).\\ -Configured for compilation of serial executables." - fi -else - parallel_report="Configured for compilation of serial executables." -fi - - - - - - - - -# Setting ScaLAPACK... - - -have_scalapack=0 - - -# Check whether --with-scalapack was given. -if test ${with_scalapack+y} -then : - withval=$with_scalapack; if test "$withval" = "yes" ; then - with_scalapack=1 - elif test "$withval" = "intel" ; then - with_scalapack=2 - elif test "$withval" = "no" ; then - with_scalapack=0 - fi -else $as_nop - with_scalapack=1 -fi - - -# final check on availability of parallel environment -for dummy in x # to allow simple 'break' -do - test "$have_mpi" -eq 0 && break - - F77=$mpif90 - LIBS="$mpi_libs" - -# look for scalapack if required - test "$with_scalapack" -eq 0 && break - if test "$scalapack_libs" = "" ; then -# no additional libraries needed - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing pdgemr2d" >&5 -printf %s "checking for library containing pdgemr2d... " >&6; } -if test ${ac_cv_search_pdgemr2d+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call pdgemr2d - end -_ACEOF -for ac_lib in '' "" -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_pdgemr2d=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_pdgemr2d+y} -then : - break -fi -done -if test ${ac_cv_search_pdgemr2d+y} -then : - -else $as_nop - ac_cv_search_pdgemr2d=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_pdgemr2d" >&5 -printf "%s\n" "$ac_cv_search_pdgemr2d" >&6; } -ac_res=$ac_cv_search_pdgemr2d -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_scalapack=1 - try_dflags="$try_dflags -D__SCALAPACK" -fi - - test "$have_scalapack" -eq 1 && break - -if test "$have_mkl" -eq 1 - then - unset ac_cv_search_pdgemr2d # clear cached value - LIBS="$mpi_libs $blas_libs" - if test $with_scalapack -eq 1; then - scalapack_libs=-lmkl_blacs_openmpi_lp64 - else - scalapack_libs=-lmkl_blacs_intelmpi_lp64 - fi - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing pdgemr2d" >&5 -printf %s "checking for library containing pdgemr2d... " >&6; } -if test ${ac_cv_search_pdgemr2d+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call pdgemr2d - end -_ACEOF -for ac_lib in '' "mkl_scalapack_lp64" -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib "$scalapack_libs" $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_pdgemr2d=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_pdgemr2d+y} -then : - break -fi -done -if test ${ac_cv_search_pdgemr2d+y} -then : - -else $as_nop - ac_cv_search_pdgemr2d=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_pdgemr2d" >&5 -printf "%s\n" "$ac_cv_search_pdgemr2d" >&6; } -ac_res=$ac_cv_search_pdgemr2d -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_scalapack=1 - try_dflags="$try_dflags -D__SCALAPACK" - scalapack_libs="-lmkl_scalapack_lp64 $scalapack_libs" -fi - - test "$have_scalapack" -eq 1 && break -fi -# -# sci libraries (e.g. cray xt) - unset ac_cv_search_pdgemr2d # clear cached value - scalapack_libs="-lsci" - LIBS="$mpi_libs $scalapack_libs" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing pdgemr2d" >&5 -printf %s "checking for library containing pdgemr2d... " >&6; } -if test ${ac_cv_search_pdgemr2d+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call pdgemr2d - end -_ACEOF -for ac_lib in '' "" -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_pdgemr2d=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_pdgemr2d+y} -then : - break -fi -done -if test ${ac_cv_search_pdgemr2d+y} -then : - -else $as_nop - ac_cv_search_pdgemr2d=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_pdgemr2d" >&5 -printf "%s\n" "$ac_cv_search_pdgemr2d" >&6; } -ac_res=$ac_cv_search_pdgemr2d -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_scalapack=1 - try_dflags="$try_dflags -D__SCALAPACK" -fi - - test "$have_scalapack" -eq 1 && break -# scalapack (including blacs), no -L options - unset ac_cv_search_pdgemr2d # clear cached value - scalapack_libs="-lscalapack" - LIBS="$mpi_libs $scalapack_libs" - LDFLAGS="" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing pdgemr2d" >&5 -printf %s "checking for library containing pdgemr2d... " >&6; } -if test ${ac_cv_search_pdgemr2d+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call pdgemr2d - end -_ACEOF -for ac_lib in '' "" -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_pdgemr2d=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_pdgemr2d+y} -then : - break -fi -done -if test ${ac_cv_search_pdgemr2d+y} -then : - -else $as_nop - ac_cv_search_pdgemr2d=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_pdgemr2d" >&5 -printf "%s\n" "$ac_cv_search_pdgemr2d" >&6; } -ac_res=$ac_cv_search_pdgemr2d -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_scalapack=1 - try_dflags="$try_dflags -D__SCALAPACK" -fi - - test "$have_scalapack" -eq 1 && break -# scalapack + blacs, no -L options - unset ac_cv_search_pdgemr2d # clear cached value - blacs_libs="-lblacs -lblacsF77init -lblacs" - scalapack_libs="-lscalapack $blacs_libs" - LIBS="$mpi_libs $scalapack_libs" - LDFLAGS="" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing pdgemr2d" >&5 -printf %s "checking for library containing pdgemr2d... " >&6; } -if test ${ac_cv_search_pdgemr2d+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call pdgemr2d - end -_ACEOF -for ac_lib in '' "" -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_pdgemr2d=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_pdgemr2d+y} -then : - break -fi -done -if test ${ac_cv_search_pdgemr2d+y} -then : - -else $as_nop - ac_cv_search_pdgemr2d=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_pdgemr2d" >&5 -printf "%s\n" "$ac_cv_search_pdgemr2d" >&6; } -ac_res=$ac_cv_search_pdgemr2d -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_scalapack=1 - try_dflags="$try_dflags -D__SCALAPACK" -fi - - test "$have_scalapack" -eq 1 && break -# scalapack + blacs with -L options - unset ac_cv_search_pdgemr2d # clear cached value - if test "$scalapack_dir" = ""; then scalapack_dir="/bgsys/local/scalapack/lib"; fi - if test "$blacs_dir" = ""; then blacs_dir="/bgsys/local/blacs/lib"; fi - blacs_libs="-L$blacs_dir -lblacs -lblacsF77init -lblacs" - scalapack_libs="-L$scalapack_dir -lscalapack $blacs_libs" - LIBS="$mpi_libs $scalapack_libs" - LDFLAGS="" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing pdgemr2d" >&5 -printf %s "checking for library containing pdgemr2d... " >&6; } -if test ${ac_cv_search_pdgemr2d+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat > conftest.$ac_ext <<_ACEOF - program main - call pdgemr2d - end -_ACEOF -for ac_lib in '' "" -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_f77_try_link "$LINENO" -then : - ac_cv_search_pdgemr2d=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_pdgemr2d+y} -then : - break -fi -done -if test ${ac_cv_search_pdgemr2d+y} -then : - -else $as_nop - ac_cv_search_pdgemr2d=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_pdgemr2d" >&5 -printf "%s\n" "$ac_cv_search_pdgemr2d" >&6; } -ac_res=$ac_cv_search_pdgemr2d -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_scalapack=1 - try_dflags="$try_dflags -D__SCALAPACK" -fi - - else - # scalapack provided in SCALAPACK_LIBS - not checked! - have_scalapack=1 - try_dflags="$try_dflags -D__SCALAPACK" - fi -done - -# Configuring output message -if test "$have_scalapack" -eq 1; then - scalapack_line="SCALAPACK_LIBS=$scalapack_libs" -else - scalapack_libs="" - scalapack_line="@delete@" -fi - - - - - - - -# Setting ELPA... - - - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking ELPA" >&5 -printf %s "checking ELPA... " >&6; } - - -# Check whether --with-elpa-include was given. -if test ${with_elpa_include+y} -then : - withval=$with_elpa_include; if test "$withval" = "no" ; then - with_elpa_include=0 - else - with_elpa_include=1 - elpa_include="$withval" - fi -else $as_nop - with_elpa_include=0 -fi - - - -# Check whether --with-elpa-lib was given. -if test ${with_elpa_lib+y} -then : - withval=$with_elpa_lib; if test "$withval" = "no" ; then - with_elpa_libs=0 - else - with_elpa_libs=1 - elpa_libs="$withval" - fi -else $as_nop - with_elpa_libs=0 -fi - - - -# Check whether --with-elpa-version was given. -if test ${with_elpa_version+y} -then : - withval=$with_elpa_version; if test "$withval" = "no" ; then - with_elpa_version=0 - else - with_elpa_version="$withval" - fi -else $as_nop - with_elpa_version="2016" -fi - - - -elpa_line="@delete@" - -# ELPA iff SCALAPACK -if test "$with_elpa_libs" -eq 1; then - if test "$have_scalapack" -eq 1; then - if test "$with_elpa_include" -eq 1 && test "$with_elpa_libs" -eq 1; then - - if test "$with_elpa_version" = "2015"; then - try_dflags="$try_dflags -D__ELPA_2015" - elif test "$with_elpa_version" = "2016"; then - try_dflags="$try_dflags -D__ELPA_2016" - elif test "$with_elpa_version" = "2017"; then - try_dflags="$try_dflags -D__ELPA_2017" - elif test "$with_elpa_version" = "2018"; then - try_dflags="$try_dflags -D__ELPA_2018" - elif test "$with_elpa_version" = "2019"; then - try_dflags="$try_dflags -D__ELPA_2019" - else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: *** Invalid ELPA version, defaulting to 2016" >&5 -printf "%s\n" "$as_me: WARNING: *** Invalid ELPA version, defaulting to 2016" >&2;} - try_dflags="$try_dflags -D__ELPA_2016" - fi - - try_iflags="$try_iflags -I$elpa_include" - scalapack_libs="$elpa_libs $scalapack_libs" - elpa_line="ELPA_LIBS=$elpa_libs" - fi - else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: *** ScaLAPACK is needed to use ELPA" >&5 -printf "%s\n" "$as_me: WARNING: *** ScaLAPACK is needed to use ELPA" >&2;} - fi -fi - - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${elpa_libs}" >&5 -printf "%s\n" "${elpa_libs}" >&6; } - - - - - - -# Setting HDF5... - - -# Check whether --with-hdf5 was given. -if test ${with_hdf5+y} -then : - withval=$with_hdf5; if test "$withval" = "no" ; then - with_hdf5=0 - elif test $withval = "yes" ; then - with_hdf5=1 - skip_hdf5_module_check=1 - else - with_hdf5_path="$withval" - skip_hdf5_module_chek=0 - with_hdf5=1 - fi -else $as_nop - with_hdf5=0 -fi - - - -# Check whether --with-hdf5-libs was given. -if test ${with_hdf5_libs+y} -then : - withval=$with_hdf5_libs; if test "$withval" = "no" ; then - with_hdf5_libs=0 - else - with_hdf5_libline="$withval" - with_hdf5_libs=1 - fi -else $as_nop - with_hdf5_libs=0 -fi - - - -# Check whether --with-hdf5-include was given. -if test ${with_hdf5_include+y} -then : - withval=$with_hdf5_include; if test "$withval" = "no" ; then - with_hdf5_include=0 - else - with_hdf5_include_line="$withval" - with_hdf5_include=1 - fi -else $as_nop - with_hdf5_include=0 -fi - - - - - -hdf5_libs="" -have_hdf5=0 - - -if test "$use_parallel" -ne 0; then - - if test "$with_hdf5" -ne 0 && test "$with_hdf5_path" != "yes"; then - - # Checking compiler compatibility: GCC >= 4.9 - if test "x$f90_in_mpif90" = xgfortran && - test "$f90_major_version" -le "4" && - test "$f90_minor_version" -lt "9" ; then - - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: *** HDF5 support requires GNU GFORTRAN >= 4.9 " >&5 -printf "%s\n" "$as_me: WARNING: *** HDF5 support requires GNU GFORTRAN >= 4.9 " >&2;} - else - - # Test if it is really installed where it has been specified - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - - if test -e $with_hdf5_path/bin/h5pcc; then - h5cc=$with_hdf5_path/bin/h5pcc; - elif test -e $with_hdf5_path/bin/h5cc ; then - h5cc=$with_hdf5_path/bin/h5cc; - elif command -v h5pcc > /dev/null; then - h5cc=$(command -v h5pcc) - elif command -v h5cci > /dev/null; then - h5cc=$(command -v h5cc) - else - h5cc=$CC; - fi - ac_compile='$h5cc -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' - ac_link='$h5cc -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' - - try_libdirs="$with_hdf5_path/lib" - for dir in $try_libdirs - do - unset ac_cv_search_H5Fcreate - - if test "$dir" = "none" - then - try_loption= - else - try_loption="-L$dir" - fi - - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - #LIBS="-lhdf5" - LIBS="" - - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing H5Fcreate" >&5 -printf %s "checking for library containing H5Fcreate... " >&6; } -if test ${ac_cv_search_H5Fcreate+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -char H5Fcreate (); -#ifdef F77_DUMMY_MAIN - -# ifdef __cplusplus - extern "C" -# endif - int F77_DUMMY_MAIN() { return 1; } - -#endif -int -main (void) -{ -return H5Fcreate (); - ; - return 0; -} -_ACEOF -for ac_lib in '' hdf5 hdf5_fortran -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_c_try_link "$LINENO" -then : - ac_cv_search_H5Fcreate=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_H5Fcreate+y} -then : - break -fi -done -if test ${ac_cv_search_H5Fcreate+y} -then : - -else $as_nop - ac_cv_search_H5Fcreate=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_H5Fcreate" >&5 -printf "%s\n" "$ac_cv_search_H5Fcreate" >&6; } -ac_res=$ac_cv_search_H5Fcreate -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_hdf5=1 -fi - - - if test "$ac_cv_search_H5Fcreate" != "no" - then break ; fi - done - - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - ac_ext=f -ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' -ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_f77_compiler_gnu - - - if test "$have_hdf5" -eq 1 ; then - if test "$with_hdf5_include" -eq 1 ; then - as_ac_File=`printf "%s\n" "ac_cv_file_$with_hdf5_include_line/hdf5.mod" | $as_tr_sh` -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $with_hdf5_include_line/hdf5.mod" >&5 -printf %s "checking for $with_hdf5_include_line/hdf5.mod... " >&6; } -if eval test \${$as_ac_File+y} -then : - printf %s "(cached) " >&6 -else $as_nop - test "$cross_compiling" = yes && - as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 -if test -r "$with_hdf5_include_line/hdf5.mod"; then - eval "$as_ac_File=yes" -else - eval "$as_ac_File=no" -fi -fi -eval ac_res=\$$as_ac_File - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -printf "%s\n" "$ac_res" >&6; } -if eval test \"x\$"$as_ac_File"\" = x"yes" -then : - -else $as_nop - - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: ***HDF5 Fortran extensions not found" >&5 -printf "%s\n" "$as_me: WARNING: ***HDF5 Fortran extensions not found" >&2;} - have_hdf5=0 -fi - - elif skip_hdf5_module_chek -eq 0; then - as_ac_File=`printf "%s\n" "ac_cv_file_$with_hdf5_path/include/hdf5.mod" | $as_tr_sh` -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $with_hdf5_path/include/hdf5.mod" >&5 -printf %s "checking for $with_hdf5_path/include/hdf5.mod... " >&6; } -if eval test \${$as_ac_File+y} -then : - printf %s "(cached) " >&6 -else $as_nop - test "$cross_compiling" = yes && - as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 -if test -r "$with_hdf5_path/include/hdf5.mod"; then - eval "$as_ac_File=yes" -else - eval "$as_ac_File=no" -fi -fi -eval ac_res=\$$as_ac_File - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -printf "%s\n" "$ac_res" >&6; } -if eval test \"x\$"$as_ac_File"\" = x"yes" -then : - -else $as_nop - - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: ***HDF5 Fortran extensions not found" >&5 -printf "%s\n" "$as_me: WARNING: ***HDF5 Fortran extensions not found" >&2;} - have_hdf5=0 -fi - - fi - fi - if test "$have_hdf5" -eq 1; then - version=`grep "HDF5 Version" $with_hdf5_path/lib/libhdf5.settings | cut -d: -f2` - major=`echo $version | cut -d. -f2` - minor=`echo $version | cut -d. -f3` - if test "$major" -lt 8 || (test "$major" -eq 8 && test "$minor" -lt 16); then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: HDF5 version: 1.$major.$minor" >&5 -printf "%s\n" "$as_me: WARNING: HDF5 version: 1.$major.$minor" >&2;}; - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: *** HDF5 version must be 1.8.16 or later" >&5 -printf "%s\n" "$as_me: WARNING: *** HDF5 version must be 1.8.16 or later" >&2;}; - have_hdf5=0; - fi - fi - - if test "$have_hdf5" -eq 1 ; then - if test -e $with_hdf5_path/bin/h5pfc; then - if test $with_hdf5_libs -eq 1; then - hdf5_libs=$with_hdf5_libline - else - hdf5_libs=`$with_hdf5_path/bin/h5pfc -show | awk -F'-L' '{$1=""; for (i=2; i<=NF;i++) $i="-L"$i; print $0}'` - fi - elif command -v h5pfc >/dev/null; then - if test $with_hdf5_libs -eq 1; then - hdf5_libs=$with_hdf5_libline - else - hdf5_libs=`h5pfc -show | awk -F'-L' '{$1=""; for (i=2; i<=NF;i++) $i="-L"$i; print $0}'` - fi - - elif test -e $with_hdf5_path/bin/h5fc; then - if test $with_hdf5_libs -eq 1; then - hdf5_libs=$with_hdf5_libline - else - hdf5_libs=`$with_hdf5_path/bin/h5fc -show | awk -F'-L' '{$1=""; for (i=2; i<=NF;i++) $i="-L"$i; print $0}'` - fi - try_dflags="$try_dflags -D__HDF5_SERIAL" - elif command -v h5fc>/dev/null; then - if test $with_hdf5_libs -eq 1; then - hdf5_libs=$with_hdf5_libline - else - hdf5_libs=`h5fc -show | awk -F'-L' '{$1=""; for (i=2; i<=NF;i++) $i="-L"$i; print $0}'` - fi - try_dflags="$try_dflags -D__HDF5_SERIAL" - - else - if test $with_hdf5_libs -eq 1; then - hdf5_libs=$with_hdf5_libline - else - hdf5_libs="-L$with_hdf5_path/lib -lhdf5_fortran -lhdf5 -lrt -lz -ldl -lm -Wl,-rpath -Wl,$with_hdf5_path/lib" - fi - fi - if test $with_hdf5_include -eq 1; then - try_iflags="$try_iflags -I$with_hdf5_include_line" - else - try_iflags="$try_iflags -I$with_hdf5_path/include" - fi - try_dflags="$try_dflags -D__HDF5" - fi - - hdf5_line="HDF5_LIBS=$hdf5_libs" - fi - fi -else - if test "$with_hdf5" -ne 0 && test "$with_hdf5_path" != "yes"; then - - # Checking compiler compatibility: GCC >= 4.9 - if test "x$f90" = xgfortran && - test "$f90_major_version" -le "4" && - test "$f90_minor_version" -lt "9" ; then - - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: *** HDF5 support requires GNU GFORTRAN >= 4.9 " >&5 -printf "%s\n" "$as_me: WARNING: *** HDF5 support requires GNU GFORTRAN >= 4.9 " >&2;} - else - - # Test if it is really installed where it has been specified - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - - if test -e $with_hdf5_path/bin/h5cc ; then - h5cc=$with_hdf5_path/bin/h5cc; - else - h5cc=$CC; - fi - ac_compile='$h5cc -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' - ac_link='$h5cc -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' - - try_libdirs="$with_hdf5_path/lib" - for dir in $try_libdirs - do - unset ac_cv_search_H5Fcreate - - if test "$dir" = "none" - then - try_loption= - else - try_loption="-L$dir" - fi - - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - #LIBS="-lhdf5" - LIBS="" - - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing H5Fcreate" >&5 -printf %s "checking for library containing H5Fcreate... " >&6; } -if test ${ac_cv_search_H5Fcreate+y} -then : - printf %s "(cached) " >&6 -else $as_nop - ac_func_search_save_LIBS=$LIBS -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -char H5Fcreate (); -#ifdef F77_DUMMY_MAIN - -# ifdef __cplusplus - extern "C" -# endif - int F77_DUMMY_MAIN() { return 1; } - -#endif -int -main (void) -{ -return H5Fcreate (); - ; - return 0; -} -_ACEOF -for ac_lib in '' hdf5 hdf5_fortran -do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_c_try_link "$LINENO" -then : - ac_cv_search_H5Fcreate=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext - if test ${ac_cv_search_H5Fcreate+y} -then : - break -fi -done -if test ${ac_cv_search_H5Fcreate+y} -then : - -else $as_nop - ac_cv_search_H5Fcreate=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_H5Fcreate" >&5 -printf "%s\n" "$ac_cv_search_H5Fcreate" >&6; } -ac_res=$ac_cv_search_H5Fcreate -if test "$ac_res" != no -then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - have_hdf5=1 -fi - - - if test "$ac_cv_search_H5Fcreate" != "no" - then break ; fi - done - - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - ac_ext=f -ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' -ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_f77_compiler_gnu - - - if test "$have_hdf5" -eq 1 ; then - as_ac_File=`printf "%s\n" "ac_cv_file_$with_hdf5_path/include/hdf5.mod" | $as_tr_sh` -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $with_hdf5_path/include/hdf5.mod" >&5 -printf %s "checking for $with_hdf5_path/include/hdf5.mod... " >&6; } -if eval test \${$as_ac_File+y} -then : - printf %s "(cached) " >&6 -else $as_nop - test "$cross_compiling" = yes && - as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 -if test -r "$with_hdf5_path/include/hdf5.mod"; then - eval "$as_ac_File=yes" -else - eval "$as_ac_File=no" -fi -fi -eval ac_res=\$$as_ac_File - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -printf "%s\n" "$ac_res" >&6; } -if eval test \"x\$"$as_ac_File"\" = x"yes" -then : - -else $as_nop - - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: ***HDF5 Fortran extensions not found" >&5 -printf "%s\n" "$as_me: WARNING: ***HDF5 Fortran extensions not found" >&2;} - have_hdf5=0 -fi - - fi - if test "$have_hdf5" -eq 1; then - version=`grep "HDF5 Version" $with_hdf5_path/lib/libhdf5.settings | cut -d: -f2` - major=`echo $version | cut -d. -f2` - minor=`echo $version | cut -d. -f3` - if test "$major" -lt 8 || (test "$major" -eq 8 && test "$minor" -lt 16); then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: HDF5 version: 1.$major.$minor" >&5 -printf "%s\n" "$as_me: WARNING: HDF5 version: 1.$major.$minor" >&2;}; - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: *** HDF5 version must be 1.8.16 or later" >&5 -printf "%s\n" "$as_me: WARNING: *** HDF5 version must be 1.8.16 or later" >&2;}; - have_hdf5=0; - fi - fi - - if test "$have_hdf5" -eq 1 ; then - if test -e $with_hdf5_path/bin/h5fc; then - hdf5_libs=`$with_hdf5_path/bin/h5fc -show | awk -F'-L' '{$1="";$2="-L"$2; print $0}'` - try_dflags="$try_dflags -D__HDF5_SERIAL" - else - hdf5_libs="-L$with_hdf5_path/lib -lhdf5_fortran -lhdf5 -lrt -lz -ldl -lm -Wl,-rpath -Wl,$with_hdf5_path/lib" - fi - try_iflags="$try_iflags -I$with_hdf5_path/include" - try_dflags="$try_dflags -D__HDF5" - fi - - hdf5_line="HDF5_LIBS=$hdf5_libs" - fi - fi - -# AC_MSG_WARN([HDF5 support is for parallel execution only]) -fi - - - - - - -# Checking SIGNAL... - - - # Check whether --enable-signals was given. -if test ${enable_signals+y} -then : - enableval=$enable_signals; if test "$enableval" = "yes" ; then - use_signals=1 - else - use_signals=0 - fi -else $as_nop - use_signals=0 -fi - - - # preprocessing flag for signal trapping (experimental) - if test "$use_signals" -eq 1 ; then try_dflags="$try_dflags -D__TRAP_SIGUSR1" ; fi - - - - -# Checking for ranlib... - - - - if test "$ranlib" != "echo" - then - # Extract the first word of "ranlib", so it can be a program name with args. -set dummy ranlib; ac_word=$2 -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -printf %s "checking for $ac_word... " >&6; } -if test ${ac_cv_prog_ranlib+y} -then : - printf %s "(cached) " >&6 -else $as_nop - if test -n "$ranlib"; then - ac_cv_prog_ranlib="$ranlib" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then - ac_cv_prog_ranlib="ranlib" - printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - test -z "$ac_cv_prog_ranlib" && ac_cv_prog_ranlib="echo" -fi -fi -ranlib=$ac_cv_prog_ranlib -if test -n "$ranlib"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ranlib" >&5 -printf "%s\n" "$ranlib" >&6; } -else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } -fi - - - fi - - if test "$arch" = "mac686"; then - if test "$ranlib" = "ranlib"; then - ranlib="ranlib -c" - fi - fi - - - - - - -# Checking wget or curl... - - - # Extract the first word of "wget", so it can be a program name with args. -set dummy wget; ac_word=$2 -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -printf %s "checking for $ac_word... " >&6; } -if test ${ac_cv_prog_wget+y} -then : - printf %s "(cached) " >&6 -else $as_nop - if test -n "$wget"; then - ac_cv_prog_wget="$wget" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then - ac_cv_prog_wget="wget -O" - printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -wget=$ac_cv_prog_wget -if test -n "$wget"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $wget" >&5 -printf "%s\n" "$wget" >&6; } -else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } -fi - - - if test "$wget" = ""; then - # Extract the first word of "curl", so it can be a program name with args. -set dummy curl; ac_word=$2 -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -printf %s "checking for $ac_word... " >&6; } -if test ${ac_cv_prog_wget+y} -then : - printf %s "(cached) " >&6 -else $as_nop - if test -n "$wget"; then - ac_cv_prog_wget="$wget" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then - ac_cv_prog_wget="curl -o" - printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -wget=$ac_cv_prog_wget -if test -n "$wget"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $wget" >&5 -printf "%s\n" "$wget" >&6; } -else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } -fi - - - fi - echo setting WGET... $wget - - - - - - -# Show dflags before adding $(MANUAL_DFLAGS) and adapt to XLF (if needed) -if test "$dflags" = "" ; then dflags="$try_dflags" ; fi -echo setting DFLAGS... $try_dflags - -# xlf compilers (AIX and powerpc) want comma-separated -D directives - - -# xlf compilers (AIX and powerpc) want comma-separated -D directives -if test "$xlf_flags" -ne 0 -then - fdflags="`echo $dflags | sed 's/ */,/g'`" -else - fdflags="\$(DFLAGS)" -fi - - - -if test "$iflags" = "" ; then iflags="$try_iflags" ; fi -echo setting IFLAGS... $iflags - -# export additional settings to generated files - - - - - - -ac_config_headers="$ac_config_headers include/c_defs.h:include/c_defs.h.in" - -ac_config_files="$ac_config_files include/configure.h:include/configure.h.in" - - -#AC_CONFIG_FILES(Makefile.cpu) -ac_config_files="$ac_config_files make.inc" - -ac_config_files="$ac_config_files configure.msg" - -ac_config_files="$ac_config_files install/make_wannier90.inc" - - - -cat >confcache <<\_ACEOF -# This file is a shell script that caches the results of configure -# tests run on this system so they can be shared between configure -# scripts and configure runs, see configure's option --config-cache. -# It is not useful on other systems. If it contains results you don't -# want to keep, you may remove or edit it. -# -# config.status only pays attention to the cache file if you give it -# the --recheck option to rerun configure. -# -# `ac_cv_env_foo' variables (set or unset) will be overridden when -# loading this file, other *unset* `ac_cv_foo' will be assigned the -# following values. - -_ACEOF - -# The following way of writing the cache mishandles newlines in values, -# but we know of no workaround that is simple, portable, and efficient. -# So, we kill variables containing newlines. -# Ultrix sh set writes to stderr and can't be redirected directly, -# and sets the high bit in the cache file unless we assign to the vars. -( - for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do - eval ac_val=\$$ac_var - case $ac_val in #( - *${as_nl}*) - case $ac_var in #( - *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 -printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; - esac - case $ac_var in #( - _ | IFS | as_nl) ;; #( - BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) { eval $ac_var=; unset $ac_var;} ;; - esac ;; - esac - done - - (set) 2>&1 | - case $as_nl`(ac_space=' '; set) 2>&1` in #( - *${as_nl}ac_space=\ *) - # `set' does not quote correctly, so add quotes: double-quote - # substitution turns \\\\ into \\, and sed turns \\ into \. - sed -n \ - "s/'/'\\\\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" - ;; #( - *) - # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" - ;; - esac | - sort -) | - sed ' - /^ac_cv_env_/b end - t clear - :clear - s/^\([^=]*\)=\(.*[{}].*\)$/test ${\1+y} || &/ - t end - s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ - :end' >>confcache -if diff "$cache_file" confcache >/dev/null 2>&1; then :; else - if test -w "$cache_file"; then - if test "x$cache_file" != "x/dev/null"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 -printf "%s\n" "$as_me: updating cache $cache_file" >&6;} - if test ! -f "$cache_file" || test -h "$cache_file"; then - cat confcache >"$cache_file" - else - case $cache_file in #( - */* | ?:*) - mv -f confcache "$cache_file"$$ && - mv -f "$cache_file"$$ "$cache_file" ;; #( - *) - mv -f confcache "$cache_file" ;; - esac - fi - fi - else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 -printf "%s\n" "$as_me: not updating unwritable cache $cache_file" >&6;} - fi -fi -rm -f confcache - -test "x$prefix" = xNONE && prefix=$ac_default_prefix -# Let make expand exec_prefix. -test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' - -DEFS=-DHAVE_CONFIG_H - -ac_libobjs= -ac_ltlibobjs= -U= -for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue - # 1. Remove the extension, and $U if already installed. - ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' - ac_i=`printf "%s\n" "$ac_i" | sed "$ac_script"` - # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR - # will be set to the directory where LIBOBJS objects are built. - as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" - as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' -done -LIBOBJS=$ac_libobjs - -LTLIBOBJS=$ac_ltlibobjs - - - -: "${CONFIG_STATUS=./config.status}" -ac_write_fail=0 -ac_clean_files_save=$ac_clean_files -ac_clean_files="$ac_clean_files $CONFIG_STATUS" -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 -printf "%s\n" "$as_me: creating $CONFIG_STATUS" >&6;} -as_write_fail=0 -cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 -#! $SHELL -# Generated by $as_me. -# Run this file to recreate the current configuration. -# Compiler output produced by configure, useful for debugging -# configure, is in config.log if it exists. - -debug=false -ac_cs_recheck=false -ac_cs_silent=false - -SHELL=\${CONFIG_SHELL-$SHELL} -export SHELL -_ASEOF -cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 -## -------------------- ## -## M4sh Initialization. ## -## -------------------- ## - -# Be more Bourne compatible -DUALCASE=1; export DUALCASE # for MKS sh -as_nop=: -if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 -then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which - # is contrary to our usage. Disable this feature. - alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else $as_nop - case `(set -o) 2>/dev/null` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi - - - -# Reset variables that may have inherited troublesome values from -# the environment. - -# IFS needs to be set, to space, tab, and newline, in precisely that order. -# (If _AS_PATH_WALK were called with IFS unset, it would have the -# side effect of setting IFS to empty, thus disabling word splitting.) -# Quoting is to prevent editors from complaining about space-tab. -as_nl=' -' -export as_nl -IFS=" "" $as_nl" - -PS1='$ ' -PS2='> ' -PS4='+ ' - -# Ensure predictable behavior from utilities with locale-dependent output. -LC_ALL=C -export LC_ALL -LANGUAGE=C -export LANGUAGE - -# We cannot yet rely on "unset" to work, but we need these variables -# to be unset--not just set to an empty or harmless value--now, to -# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct -# also avoids known problems related to "unset" and subshell syntax -# in other old shells (e.g. bash 2.01 and pdksh 5.2.14). -for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH -do eval test \${$as_var+y} \ - && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : -done - -# Ensure that fds 0, 1, and 2 are open. -if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi -if (exec 3>&2) ; then :; else exec 2>/dev/null; fi - -# The user is always right. -if ${PATH_SEPARATOR+false} :; then - PATH_SEPARATOR=: - (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { - (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || - PATH_SEPARATOR=';' - } -fi - - -# Find who we are. Look in the path if we contain no directory separator. -as_myself= -case $0 in #(( - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - test -r "$as_dir$0" && as_myself=$as_dir$0 && break - done -IFS=$as_save_IFS - - ;; -esac -# We did not find ourselves, most probably we were run as `sh COMMAND' -# in which case we are not to be found in the path. -if test "x$as_myself" = x; then - as_myself=$0 -fi -if test ! -f "$as_myself"; then - printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - exit 1 -fi - - - -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- -# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are -# provided, also output the error to LOG_FD, referencing LINENO. Then exit the -# script with STATUS, using 1 if that was 0. -as_fn_error () -{ - as_status=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - printf "%s\n" "$as_me: error: $2" >&2 - as_fn_exit $as_status -} # as_fn_error - - - -# as_fn_set_status STATUS -# ----------------------- -# Set $? to STATUS, without forking. -as_fn_set_status () -{ - return $1 -} # as_fn_set_status - -# as_fn_exit STATUS -# ----------------- -# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. -as_fn_exit () -{ - set +e - as_fn_set_status $1 - exit $1 -} # as_fn_exit - -# as_fn_unset VAR -# --------------- -# Portably unset VAR. -as_fn_unset () -{ - { eval $1=; unset $1;} -} -as_unset=as_fn_unset - -# as_fn_append VAR VALUE -# ---------------------- -# Append the text in VALUE to the end of the definition contained in VAR. Take -# advantage of any shell optimizations that allow amortized linear growth over -# repeated appends, instead of the typical quadratic growth present in naive -# implementations. -if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null -then : - eval 'as_fn_append () - { - eval $1+=\$2 - }' -else $as_nop - as_fn_append () - { - eval $1=\$$1\$2 - } -fi # as_fn_append - -# as_fn_arith ARG... -# ------------------ -# Perform arithmetic evaluation on the ARGs, and store the result in the -# global $as_val. Take advantage of shells that can avoid forks. The arguments -# must be portable across $(()) and expr. -if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null -then : - eval 'as_fn_arith () - { - as_val=$(( $* )) - }' -else $as_nop - as_fn_arith () - { - as_val=`expr "$@" || test $? -eq 1` - } -fi # as_fn_arith - - -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then - as_expr=expr -else - as_expr=false -fi - -if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then - as_basename=basename -else - as_basename=false -fi - -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi - -as_me=`$as_basename -- "$0" || -$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| . 2>/dev/null || -printf "%s\n" X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - -# Avoid depending upon Character Ranges. -as_cr_letters='abcdefghijklmnopqrstuvwxyz' -as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' -as_cr_Letters=$as_cr_letters$as_cr_LETTERS -as_cr_digits='0123456789' -as_cr_alnum=$as_cr_Letters$as_cr_digits - - -# Determine whether it's possible to make 'echo' print without a newline. -# These variables are no longer used directly by Autoconf, but are AC_SUBSTed -# for compatibility with existing Makefiles. -ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in #((((( --n*) - case `echo 'xy\c'` in - *c*) ECHO_T=' ';; # ECHO_T is single tab character. - xy) ECHO_C='\c';; - *) echo `echo ksh88 bug on AIX 6.1` > /dev/null - ECHO_T=' ';; - esac;; -*) - ECHO_N='-n';; -esac - -# For backward compatibility with old third-party macros, we provide -# the shell variables $as_echo and $as_echo_n. New code should use -# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. -as_echo='printf %s\n' -as_echo_n='printf %s' - -rm -f conf$$ conf$$.exe conf$$.file -if test -d conf$$.dir; then - rm -f conf$$.dir/conf$$.file -else - rm -f conf$$.dir - mkdir conf$$.dir 2>/dev/null -fi -if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then - as_ln_s='ln -s' - # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -fi -rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file -rmdir conf$$.dir 2>/dev/null - - -# as_fn_mkdir_p -# ------------- -# Create "$as_dir" as a directory, including parents if necessary. -as_fn_mkdir_p () -{ - - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || eval $as_mkdir_p || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -printf "%s\n" X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - -} # as_fn_mkdir_p -if mkdir -p . 2>/dev/null; then - as_mkdir_p='mkdir -p "$as_dir"' -else - test -d ./-p && rmdir ./-p - as_mkdir_p=false -fi - - -# as_fn_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_p -as_test_x='test -x' -as_executable_p=as_fn_executable_p - -# Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" - -# Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" - - -exec 6>&1 -## ----------------------------------- ## -## Main body of $CONFIG_STATUS script. ## -## ----------------------------------- ## -_ASEOF -test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# Save the log message, to keep $0 and so on meaningful, and to -# report actual input values of CONFIG_FILES etc. instead of their -# values after options handling. -ac_log=" -This file was extended by ESPRESSO $as_me 6.6, which was -generated by GNU Autoconf 2.71. Invocation command line was - - CONFIG_FILES = $CONFIG_FILES - CONFIG_HEADERS = $CONFIG_HEADERS - CONFIG_LINKS = $CONFIG_LINKS - CONFIG_COMMANDS = $CONFIG_COMMANDS - $ $0 $@ - -on `(hostname || uname -n) 2>/dev/null | sed 1q` -" - -_ACEOF - -case $ac_config_files in *" -"*) set x $ac_config_files; shift; ac_config_files=$*;; -esac - -case $ac_config_headers in *" -"*) set x $ac_config_headers; shift; ac_config_headers=$*;; -esac - - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -# Files that config.status was made for. -config_files="$ac_config_files" -config_headers="$ac_config_headers" - -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -ac_cs_usage="\ -\`$as_me' instantiates files and other configuration actions -from templates according to the current configuration. Unless the files -and actions are specified as TAGs, all are instantiated by default. - -Usage: $0 [OPTION]... [TAG]... - - -h, --help print this help, then exit - -V, --version print version number and configuration settings, then exit - --config print configuration, then exit - -q, --quiet, --silent - do not print progress messages - -d, --debug don't remove temporary files - --recheck update $as_me by reconfiguring in the same conditions - --file=FILE[:TEMPLATE] - instantiate the configuration file FILE - --header=FILE[:TEMPLATE] - instantiate the configuration header FILE - -Configuration files: -$config_files - -Configuration headers: -$config_headers - -Report bugs to the package provider." - -_ACEOF -ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"` -ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"` -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_cs_config='$ac_cs_config_escaped' -ac_cs_version="\\ -ESPRESSO config.status 6.6 -configured by $0, generated by GNU Autoconf 2.71, - with options \\"\$ac_cs_config\\" - -Copyright (C) 2021 Free Software Foundation, Inc. -This config.status script is free software; the Free Software Foundation -gives unlimited permission to copy, distribute and modify it." - -ac_pwd='$ac_pwd' -srcdir='$srcdir' -test -n "\$AWK" || AWK=awk -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# The default lists apply if the user does not specify any file. -ac_need_defaults=: -while test $# != 0 -do - case $1 in - --*=?*) - ac_option=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` - ac_shift=: - ;; - --*=) - ac_option=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg= - ac_shift=: - ;; - *) - ac_option=$1 - ac_optarg=$2 - ac_shift=shift - ;; - esac - - case $ac_option in - # Handling of the options. - -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) - ac_cs_recheck=: ;; - --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) - printf "%s\n" "$ac_cs_version"; exit ;; - --config | --confi | --conf | --con | --co | --c ) - printf "%s\n" "$ac_cs_config"; exit ;; - --debug | --debu | --deb | --de | --d | -d ) - debug=: ;; - --file | --fil | --fi | --f ) - $ac_shift - case $ac_optarg in - *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; - '') as_fn_error $? "missing file argument" ;; - esac - as_fn_append CONFIG_FILES " '$ac_optarg'" - ac_need_defaults=false;; - --header | --heade | --head | --hea ) - $ac_shift - case $ac_optarg in - *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; - esac - as_fn_append CONFIG_HEADERS " '$ac_optarg'" - ac_need_defaults=false;; - --he | --h) - # Conflict between --help and --header - as_fn_error $? "ambiguous option: \`$1' -Try \`$0 --help' for more information.";; - --help | --hel | -h ) - printf "%s\n" "$ac_cs_usage"; exit ;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil | --si | --s) - ac_cs_silent=: ;; - - # This is an error. - -*) as_fn_error $? "unrecognized option: \`$1' -Try \`$0 --help' for more information." ;; - - *) as_fn_append ac_config_targets " $1" - ac_need_defaults=false ;; - - esac - shift -done - -ac_configure_extra_args= - -if $ac_cs_silent; then - exec 6>/dev/null - ac_configure_extra_args="$ac_configure_extra_args --silent" -fi - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -if \$ac_cs_recheck; then - set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion - shift - \printf "%s\n" "running CONFIG_SHELL=$SHELL \$*" >&6 - CONFIG_SHELL='$SHELL' - export CONFIG_SHELL - exec "\$@" -fi - -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -exec 5>>config.log -{ - echo - sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX -## Running $as_me. ## -_ASBOX - printf "%s\n" "$ac_log" -} >&5 - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 - -# Handling of arguments. -for ac_config_target in $ac_config_targets -do - case $ac_config_target in - "include/fft_defs.h") CONFIG_FILES="$CONFIG_FILES include/fft_defs.h:include/fft_defs.h.in" ;; - "install/make_lapack.inc") CONFIG_FILES="$CONFIG_FILES install/make_lapack.inc" ;; - "include/c_defs.h") CONFIG_HEADERS="$CONFIG_HEADERS include/c_defs.h:include/c_defs.h.in" ;; - "include/configure.h") CONFIG_FILES="$CONFIG_FILES include/configure.h:include/configure.h.in" ;; - "make.inc") CONFIG_FILES="$CONFIG_FILES make.inc" ;; - "configure.msg") CONFIG_FILES="$CONFIG_FILES configure.msg" ;; - "install/make_wannier90.inc") CONFIG_FILES="$CONFIG_FILES install/make_wannier90.inc" ;; - - *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; - esac -done - - -# If the user did not use the arguments to specify the items to instantiate, -# then the envvar interface is used. Set only those that are not. -# We use the long form for the default assignment because of an extremely -# bizarre bug on SunOS 4.1.3. -if $ac_need_defaults; then - test ${CONFIG_FILES+y} || CONFIG_FILES=$config_files - test ${CONFIG_HEADERS+y} || CONFIG_HEADERS=$config_headers -fi - -# Have a temporary directory for convenience. Make it in the build tree -# simply because there is no reason against having it here, and in addition, -# creating and moving files from /tmp can sometimes cause problems. -# Hook for its removal unless debugging. -# Note that there is a small window in which the directory will not be cleaned: -# after its creation but before its name has been assigned to `$tmp'. -$debug || -{ - tmp= ac_tmp= - trap 'exit_status=$? - : "${ac_tmp:=$tmp}" - { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status -' 0 - trap 'as_fn_exit 1' 1 2 13 15 -} -# Create a (secure) tmp directory for tmp files. - -{ - tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && - test -d "$tmp" -} || -{ - tmp=./conf$$-$RANDOM - (umask 077 && mkdir "$tmp") -} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 -ac_tmp=$tmp - -# Set up the scripts for CONFIG_FILES section. -# No need to generate them if there are no CONFIG_FILES. -# This happens for instance with `./config.status config.h'. -if test -n "$CONFIG_FILES"; then - - -ac_cr=`echo X | tr X '\015'` -# On cygwin, bash can eat \r inside `` if the user requested igncr. -# But we know of no other shell where ac_cr would be empty at this -# point, so we can use a bashism as a fallback. -if test "x$ac_cr" = x; then - eval ac_cr=\$\'\\r\' -fi -ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` -if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then - ac_cs_awk_cr='\\r' -else - ac_cs_awk_cr=$ac_cr -fi - -echo 'BEGIN {' >"$ac_tmp/subs1.awk" && -_ACEOF - - -{ - echo "cat >conf$$subs.awk <<_ACEOF" && - echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && - echo "_ACEOF" -} >conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 -ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` -ac_delim='%!_!# ' -for ac_last_try in false false false false false :; do - . ./conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - - ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` - if test $ac_delim_n = $ac_delim_num; then - break - elif $ac_last_try; then - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - else - ac_delim="$ac_delim!$ac_delim _$ac_delim!! " - fi -done -rm -f conf$$subs.sh - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && -_ACEOF -sed -n ' -h -s/^/S["/; s/!.*/"]=/ -p -g -s/^[^!]*!// -:repl -t repl -s/'"$ac_delim"'$// -t delim -:nl -h -s/\(.\{148\}\)..*/\1/ -t more1 -s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ -p -n -b repl -:more1 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t nl -:delim -h -s/\(.\{148\}\)..*/\1/ -t more2 -s/["\\]/\\&/g; s/^/"/; s/$/"/ -p -b -:more2 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t delim -' >$CONFIG_STATUS || ac_write_fail=1 -rm -f conf$$subs.awk -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -_ACAWK -cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && - for (key in S) S_is_set[key] = 1 - FS = "" - -} -{ - line = $ 0 - nfields = split(line, field, "@") - substed = 0 - len = length(field[1]) - for (i = 2; i < nfields; i++) { - key = field[i] - keylen = length(key) - if (S_is_set[key]) { - value = S[key] - line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) - len += length(value) + length(field[++i]) - substed = 1 - } else - len += 1 + keylen - } - - print line -} - -_ACAWK -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then - sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" -else - cat -fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ - || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 -_ACEOF - -# VPATH may cause trouble with some makes, so we remove sole $(srcdir), -# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and -# trailing colons and then remove the whole line if VPATH becomes empty -# (actually we leave an empty line to preserve line numbers). -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ -h -s/// -s/^/:/ -s/[ ]*$/:/ -s/:\$(srcdir):/:/g -s/:\${srcdir}:/:/g -s/:@srcdir@:/:/g -s/^:*// -s/:*$// -x -s/\(=[ ]*\).*/\1/ -G -s/\n// -s/^[^=]*=[ ]*$// -}' -fi - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -fi # test -n "$CONFIG_FILES" - -# Set up the scripts for CONFIG_HEADERS section. -# No need to generate them if there are no CONFIG_HEADERS. -# This happens for instance with `./config.status Makefile'. -if test -n "$CONFIG_HEADERS"; then -cat >"$ac_tmp/defines.awk" <<\_ACAWK || -BEGIN { -_ACEOF - -# Transform confdefs.h into an awk script `defines.awk', embedded as -# here-document in config.status, that substitutes the proper values into -# config.h.in to produce config.h. - -# Create a delimiter string that does not exist in confdefs.h, to ease -# handling of long lines. -ac_delim='%!_!# ' -for ac_last_try in false false :; do - ac_tt=`sed -n "/$ac_delim/p" confdefs.h` - if test -z "$ac_tt"; then - break - elif $ac_last_try; then - as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 - else - ac_delim="$ac_delim!$ac_delim _$ac_delim!! " - fi -done - -# For the awk script, D is an array of macro values keyed by name, -# likewise P contains macro parameters if any. Preserve backslash -# newline sequences. - -ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* -sed -n ' -s/.\{148\}/&'"$ac_delim"'/g -t rset -:rset -s/^[ ]*#[ ]*define[ ][ ]*/ / -t def -d -:def -s/\\$// -t bsnl -s/["\\]/\\&/g -s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ -D["\1"]=" \3"/p -s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p -d -:bsnl -s/["\\]/\\&/g -s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ -D["\1"]=" \3\\\\\\n"\\/p -t cont -s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p -t cont -d -:cont -n -s/.\{148\}/&'"$ac_delim"'/g -t clear -:clear -s/\\$// -t bsnlc -s/["\\]/\\&/g; s/^/"/; s/$/"/p -d -:bsnlc -s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p -b cont -' >$CONFIG_STATUS || ac_write_fail=1 - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 - for (key in D) D_is_set[key] = 1 - FS = "" -} -/^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { - line = \$ 0 - split(line, arg, " ") - if (arg[1] == "#") { - defundef = arg[2] - mac1 = arg[3] - } else { - defundef = substr(arg[1], 2) - mac1 = arg[2] - } - split(mac1, mac2, "(") #) - macro = mac2[1] - prefix = substr(line, 1, index(line, defundef) - 1) - if (D_is_set[macro]) { - # Preserve the white space surrounding the "#". - print prefix "define", macro P[macro] D[macro] - next - } else { - # Replace #undef with comments. This is necessary, for example, - # in the case of _POSIX_SOURCE, which is predefined and required - # on some systems where configure will not decide to define it. - if (defundef == "undef") { - print "/*", prefix defundef, macro, "*/" - next - } - } -} -{ print } -_ACAWK -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 - as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 -fi # test -n "$CONFIG_HEADERS" - - -eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS " -shift -for ac_tag -do - case $ac_tag in - :[FHLC]) ac_mode=$ac_tag; continue;; - esac - case $ac_mode$ac_tag in - :[FHL]*:*);; - :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; - :[FH]-) ac_tag=-:-;; - :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; - esac - ac_save_IFS=$IFS - IFS=: - set x $ac_tag - IFS=$ac_save_IFS - shift - ac_file=$1 - shift - - case $ac_mode in - :L) ac_source=$1;; - :[FH]) - ac_file_inputs= - for ac_f - do - case $ac_f in - -) ac_f="$ac_tmp/stdin";; - *) # Look for the file first in the build tree, then in the source tree - # (if the path is not absolute). The absolute path cannot be DOS-style, - # because $ac_f cannot contain `:'. - test -f "$ac_f" || - case $ac_f in - [\\/$]*) false;; - *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; - esac || - as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; - esac - case $ac_f in *\'*) ac_f=`printf "%s\n" "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac - as_fn_append ac_file_inputs " '$ac_f'" - done - - # Let's still pretend it is `configure' which instantiates (i.e., don't - # use $as_me), people would be surprised to read: - # /* config.h. Generated by config.status. */ - configure_input='Generated from '` - printf "%s\n" "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' - `' by configure.' - if test x"$ac_file" != x-; then - configure_input="$ac_file. $configure_input" - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 -printf "%s\n" "$as_me: creating $ac_file" >&6;} - fi - # Neutralize special characters interpreted by sed in replacement strings. - case $configure_input in #( - *\&* | *\|* | *\\* ) - ac_sed_conf_input=`printf "%s\n" "$configure_input" | - sed 's/[\\\\&|]/\\\\&/g'`;; #( - *) ac_sed_conf_input=$configure_input;; - esac - - case $ac_tag in - *:-:* | *:-) cat >"$ac_tmp/stdin" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; - esac - ;; - esac - - ac_dir=`$as_dirname -- "$ac_file" || -$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$ac_file" : 'X\(//\)[^/]' \| \ - X"$ac_file" : 'X\(//\)$' \| \ - X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || -printf "%s\n" X"$ac_file" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - as_dir="$ac_dir"; as_fn_mkdir_p - ac_builddir=. - -case "$ac_dir" in -.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; -*) - ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` - # A ".." for each directory in $ac_dir_suffix. - ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` - case $ac_top_builddir_sub in - "") ac_top_builddir_sub=. ac_top_build_prefix= ;; - *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; - esac ;; -esac -ac_abs_top_builddir=$ac_pwd -ac_abs_builddir=$ac_pwd$ac_dir_suffix -# for backward compatibility: -ac_top_builddir=$ac_top_build_prefix - -case $srcdir in - .) # We are building in place. - ac_srcdir=. - ac_top_srcdir=$ac_top_builddir_sub - ac_abs_top_srcdir=$ac_pwd ;; - [\\/]* | ?:[\\/]* ) # Absolute name. - ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir - ac_abs_top_srcdir=$srcdir ;; - *) # Relative name. - ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_build_prefix$srcdir - ac_abs_top_srcdir=$ac_pwd/$srcdir ;; -esac -ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix - - - case $ac_mode in - :F) - # - # CONFIG_FILE - # - -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# If the template does not know about datarootdir, expand it. -# FIXME: This hack should be removed a few years after 2.60. -ac_datarootdir_hack=; ac_datarootdir_seen= -ac_sed_dataroot=' -/datarootdir/ { - p - q -} -/@datadir@/p -/@docdir@/p -/@infodir@/p -/@localedir@/p -/@mandir@/p' -case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in -*datarootdir*) ac_datarootdir_seen=yes;; -*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 -printf "%s\n" "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 - ac_datarootdir_hack=' - s&@datadir@&$datadir&g - s&@docdir@&$docdir&g - s&@infodir@&$infodir&g - s&@localedir@&$localedir&g - s&@mandir@&$mandir&g - s&\\\${datarootdir}&$datarootdir&g' ;; -esac -_ACEOF - -# Neutralize VPATH when `$srcdir' = `.'. -# Shell code in configure.ac might set extrasub. -# FIXME: do we really want to maintain this feature? -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_sed_extra="$ac_vpsub -$extrasub -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -:t -/@[a-zA-Z_][a-zA-Z_0-9]*@/!b -s|@configure_input@|$ac_sed_conf_input|;t t -s&@top_builddir@&$ac_top_builddir_sub&;t t -s&@top_build_prefix@&$ac_top_build_prefix&;t t -s&@srcdir@&$ac_srcdir&;t t -s&@abs_srcdir@&$ac_abs_srcdir&;t t -s&@top_srcdir@&$ac_top_srcdir&;t t -s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t -s&@builddir@&$ac_builddir&;t t -s&@abs_builddir@&$ac_abs_builddir&;t t -s&@abs_top_builddir@&$ac_abs_top_builddir&;t t -$ac_datarootdir_hack -" -eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ - >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - -test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && - { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && - { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ - "$ac_tmp/out"`; test -z "$ac_out"; } && - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&5 -printf "%s\n" "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&2;} - - rm -f "$ac_tmp/stdin" - case $ac_file in - -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; - *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; - esac \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - ;; - :H) - # - # CONFIG_HEADER - # - if test x"$ac_file" != x-; then - { - printf "%s\n" "/* $configure_input */" >&1 \ - && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" - } >"$ac_tmp/config.h" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 -printf "%s\n" "$as_me: $ac_file is unchanged" >&6;} - else - rm -f "$ac_file" - mv "$ac_tmp/config.h" "$ac_file" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - fi - else - printf "%s\n" "/* $configure_input */" >&1 \ - && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ - || as_fn_error $? "could not create -" "$LINENO" 5 - fi - ;; - - - esac - -done # for ac_tag - - -as_fn_exit 0 -_ACEOF -ac_clean_files=$ac_clean_files_save - -test $ac_write_fail = 0 || - as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 - - -# configure is writing to config.log, and then calls config.status. -# config.status does its own redirection, appending to config.log. -# Unfortunately, on DOS this fails, as config.log is still kept open -# by configure, so config.status won't be able to write to it; its -# output is simply discarded. So we exec the FD to /dev/null, -# effectively closing config.log, so it can be properly (re)opened and -# appended to by config.status. When coming back to configure, we -# need to make the FD available again. -if test "$no_create" != yes; then - ac_cs_success=: - ac_config_status_args= - test "$silent" = yes && - ac_config_status_args="$ac_config_status_args --quiet" - exec 5>/dev/null - $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false - exec 5>>config.log - # Use ||, not &&, to avoid exiting from the if with $? = 1, which - # would make configure fail if this is the last instruction. - $ac_cs_success || as_fn_exit 1 -fi -if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 -printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} -fi - - -# final messages -sed '/@delete@/d' configure.msg -echo configure: success - diff --git a/quantum_espresso/kcp/install/configure-w90 b/quantum_espresso/kcp/install/configure-w90 deleted file mode 100644 index e69de29bb..000000000 diff --git a/quantum_espresso/kcp/install/configure.ac b/quantum_espresso/kcp/install/configure.ac deleted file mode 100644 index feef5652a..000000000 --- a/quantum_espresso/kcp/install/configure.ac +++ /dev/null @@ -1,139 +0,0 @@ -# Copyright (C) 2001-2018 Quantum ESPRESSO group -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License. See the file `License' in the root directory -# of the present distribution. - -AC_INIT(ESPRESSO, 6.6, , espresso) - -AC_PREREQ(2.64) -AC_CONFIG_MACRO_DIR([m4/]) - -# Initialize variables, filling with one comes from the environment... -X_AC_QE_DEFAULT_ENV() - -# configure for current directory by default -if test "$topdir" = "" ; then topdir="`pwd`" ; fi - -# check system type (no cross-compilation for now) -AC_CANONICAL_BUILD - -# Checking Architecture... -X_AC_QE_ARCH() - -# Add all needed -D options to try_dflags -try_dflags="" - -# Add needed include directories -try_iflags="-I../include " - -# Checking archiver... -X_AC_QE_AR() - -# Checking OpenMP... -X_AC_QE_OPENMP() - -# Checking MPIF90... -X_AC_QE_MPIF90() - -# Check environ... -X_AC_QE_ENVIRON() - -# Checking CC... -X_AC_QE_CC() - -# Checking F90... -X_AC_QE_F90() - -# Checking preprocessor... -X_AC_QE_CPP() - -# Checking linker... -X_AC_QE_LD() - -# Checking F90 rule... -X_AC_QE_F90RULE() - -AC_LANG_PUSH(C) -AC_CHECK_SIZEOF([int *]) -SIZEOF_INT_P=$ac_cv_sizeof_int_p -AC_SUBST(SIZEOF_INT_P) -AC_CONFIG_FILES([include/fft_defs.h:include/fft_defs.h.in]) - -# Find fortran-to-C wrappers -AC_F77_WRAPPERS() - -AC_LANG_PUSH(Fortran 77) -F77=$f90 # use Fortran 90 actually -FFLAGS="$test_fflags" -LDFLAGS="$test_ldflags" - -# Checking BLAS... -X_AC_QE_BLAS() - -# Checking LAPACK... -X_AC_QE_LAPACK() - -# Checking for FFT... -X_AC_QE_FFT() - -# Setting libxc... -ACX_LIBXC() - -# Checking for IBM MASS library... -X_AC_QE_MASS() - -# check for MPI library... -X_AC_QE_MPI() - -# Setting ScaLAPACK... -X_AC_QE_SCALAPACK() - -# Setting ELPA... -X_AC_QE_ELPA() - -# Setting HDF5... -X_AC_QE_HDF5() - -# Checking SIGNAL... -X_AC_QE_SIGNAL() - -# Checking for ranlib... -X_AC_QE_RANLIB() - -# Checking wget or curl... -X_AC_QE_WGET() - -# Show dflags before adding $(MANUAL_DFLAGS) and adapt to XLF (if needed) -if test "$dflags" = "" ; then dflags="$try_dflags" ; fi -echo setting DFLAGS... $try_dflags - -# xlf compilers (AIX and powerpc) want comma-separated -D directives -X_AC_QE_AIX_DFLAGS() - -if test "$iflags" = "" ; then iflags="$try_iflags" ; fi -echo setting IFLAGS... $iflags - -# export additional settings to generated files -AC_SUBST(dflags) -AC_SUBST(fdflags) -AC_SUBST(iflags) -AC_SUBST(ld_libs) -AC_SUBST(topdir) -AC_SUBST(extlib_flags) -AC_CONFIG_HEADERS([include/c_defs.h:include/c_defs.h.in]) -AC_CONFIG_FILES([include/configure.h:include/configure.h.in]) - -#AC_CONFIG_FILES(Makefile.cpu) -AC_CONFIG_FILES(make.inc) -AC_CONFIG_FILES(configure.msg) -AC_CONFIG_FILES(install/make_wannier90.inc) - - -AC_OUTPUT - -# final messages -sed '/@delete@/d' configure.msg -echo configure: success diff --git a/quantum_espresso/kcp/install/configure.msg.in b/quantum_espresso/kcp/install/configure.msg.in deleted file mode 100644 index c63889dbe..000000000 --- a/quantum_espresso/kcp/install/configure.msg.in +++ /dev/null @@ -1,27 +0,0 @@ --------------------------------------------------------------------- -ESPRESSO can take advantage of several optimized numerical libraries -(essl, fftw, mkl...). This configure script attempts to find them, -but may fail if they have been installed in non-standard locations. -If a required library is not found, the local copy will be compiled. - -The following libraries have been found: - @blas_line@ - @lapack_line@ - @scalapack_line@ - @elpa_line@ - @fft_line@ - @mpi_line@ - @hdf5_line@ - @mass_line@ - @libxc_line@ - -Please check if this is what you expect. - -If any libraries are missing, you may specify a list of directories -to search and retry, as follows: - ./configure LIBDIRS="list of directories, separated by spaces" - -@parallel_report@ - -For more info, read the ESPRESSO User's Guide (Doc/users-guide.tex). --------------------------------------------------------------------- diff --git a/quantum_espresso/kcp/install/extlibs_makefile b/quantum_espresso/kcp/install/extlibs_makefile deleted file mode 100644 index 9c765ad65..000000000 --- a/quantum_espresso/kcp/install/extlibs_makefile +++ /dev/null @@ -1,152 +0,0 @@ -# Copyright (C) 2001-2020 Quantum ESPRESSO group -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License. See the file `License' in the root directory -# of the present distribution. -# -# Makefile for fundamental math and utility libraries - -include ../make.inc -include install_utils - -LAPACK_NETLIB=lapack-3.6.1.tgz -LAPACK_NETLIB_NAME=lapack-3.6.1 -LAPACK_NETLIB_URL=http://www.netlib.org/lapack/${LAPACK_NETLIB} - -# For NVIDIA Eigensolver -EIGENSOLVER_VERSION=0.3.1 -EIGENSOLVER_GPU=v${EIGENSOLVER_VERSION}.tar.gz -EIGENSOLVER_GPU_NAME=Eigensolver_gpu-${EIGENSOLVER_VERSION} -EIGENSOLVER_GPU_URL=https://github.com/NVIDIA/Eigensolver_gpu/archive/${EIGENSOLVER_GPU} - -# For DevXlib -DEVXLIB_VERSION=master -DEVXLIB_URL="https://gitlab.com/max-centre/components/devicexlib/-/archive/master/devicexlib-${DEVXLIB_VERSION}.tar.gz" - -# MAIN target - -all: libcuda - -################################### -# LAPACK (includes BLAS) -################################### - -liblapack : liblapack_$(LAPACK_LIBS_SWITCH) - -# lapack is external: don't do anything -liblapack_external : - -liblapack_internal: - $(call download_and_unpack,$(LAPACK_NETLIB_NAME),$(LAPACK_NETLIB_URL),LAPACK,LAPACK) - if test ! -e ../LAPACK/liblapack.a && test -e make_lapack.inc; then \ - (cp make_lapack.inc ../LAPACK/make.inc; \ - cd ../LAPACK; $(MAKE) blaslib lapacklib); else \ - (echo "no configuration file found for lapack"; \ - echo "run configure from main QE dir"; exit); fi -lapack_clean: - if test -d ../LAPACK; then (cd ../LAPACK; $(MAKE) clean); fi -lapack_veryclean: - if test -d ../LAPACK; then (rm -R -f ../LAPACK ../${LAPACK_NETLIB_NAME}); fi - -################################### -# FoX -################################### - -libfox: - if test ! -d ../FoX; then \ - mkdir ../FoX; \ - (gzip -dc ../archive/fox.tgz | (cd ../FoX; tar -xvf -)); \ - cd ../FoX/fox/; export FC=$(F90); export FCFLAGS="$(FOX_FLAGS)"; \ - ./configure --prefix=$(TOPDIR)/FoX ;\ - touch cp_test; \ - if cp -p cp_test cp_test_1; then \ - echo "cp -p works"; \ - else \ - find -type f | xargs sed -i 's/cp -p/cp/g'; \ - fi; \ - $(MAKE) install; cd ../; rm -fr fox;fi - -fox_clean: - if test -d ../FoX; then (rm -R -f ../FoX); fi - -################################### -# CUDA -################################### - -libcuda : $(addprefix libcuda_,$(CUDA_EXTLIBS)) - -libcuda_eigensolver : - $(call download_and_unpack,$(EIGENSOLVER_GPU_NAME),$(EIGENSOLVER_GPU_URL),EIGENSOLVER_GPU,EIGENSOLVER_GPU) - if test ! -e ../EIGENSOLVER_GPU/lib_eigsolve/lib_eigsolve.a ; then \ - (cp Makefile.lib_eigsolve ../EIGENSOLVER_GPU/lib_eigsolve/Makefile; \ - cd ../EIGENSOLVER_GPU/lib_eigsolve/; $(MAKE) ); else \ - (echo "No configuration file found for GPU custom eigensolver"; exit); fi - -libcuda_eigensolver_clean: - if test -d ../EIGENSOLVER_GPU; then (cd ../EIGENSOLVER_GPU/lib_eigsolve ; $(MAKE) clean); fi -libcuda_eigensolver_veryclean: - if test -d ../EIGENSOLVER_GPU; then (rm -R -f ../EIGENSOLVER_GPU ../${EIGENSOLVER_GPU_NAME}); fi - -CUDA_PATH := $(if $(GPU_ARCH),$(CUDA_PATH),no) -libcuda_devxlib : - cd ../external/devxlib; \ - if test ! -e configure; then \ - wget $(DEVXLIB_URL) -O devxlib.tar.gz || curl $(DEVXLIB_URL) -o devxlib.tar.gz ; \ - tar xzf devxlib.tar.gz --strip-components=1 -C . ; \ - rm devxlib.tar.gz ; \ - fi; \ - if test ! -f make.inc; then \ - touch make.inc; \ - $(MAKE) clean; \ - export F90FLAGS="$(FOX_FLAGS)"; \ - ./configure FC=$(F90) CC=$(CC) \ - --with-cuda=$(CUDA_PATH) \ - --with-cuda-cc=$(GPU_ARCH) \ - --with-cuda-runtime=$(CUDA_RUNTIME) \ - --disable-parallel \ - --enable-cuda-env-check=no; \ - fi; \ - make all - touch ../install/libcuda_devxlib # do not download and configure again - -libcuda_devxlib_clean: - rm libcuda_devxlib - cd ../external/devxlib; \ - if test -f make.inc; then ($(MAKE) clean); fi -libcuda_devxlib_veryclean: - cd ../external/devxlib; \ - if test -f make.inc; then ($(MAKE) distclean && rm make.inc); fi - -################################### -# BEEF -################################### -# NOTA BENE: BEEF is not strictly speaking a mathematical libraries -# It should be compiled like, and together with, the other XC functionals - -libbeef : libbeef_$(BEEF_LIBS_SWITCH) - -libbeef_external : fake_libbeef_external - -fake_libbeef_external : - touch fake_libbeef.a - -rm fake_libbeef.a - -libbeef_internal: - if test ! -d ../LIBBEEF; then mkdir ../LIBBEEF; \ - ( gzip -dc ../archive/libbeef-0.1.2.tar.gz |(cd ../LIBBEEF; tar -xvf -)); fi - cd ../LIBBEEF; $(MAKE) - -libbeef_clean: - if test -d ../LIBBEEF; then (cd ../LIBBEEF ; $(MAKE) clean); fi -libbeef_veryclean: - if test -d ../LIBBEEF; then (rm -R -f ../LIBBEEF); fi - -################################### -# cleaning -################################### - -clean: lapack_clean fox_clean libcuda_eigensolver_clean libcuda_devxlib_clean libbeef_clean - -veryclean: lapack_veryclean fox_clean libcuda_eigensolver_veryclean libcuda_devxlib_veryclean libbeef_veryclean diff --git a/quantum_espresso/kcp/install/includedep.sh b/quantum_espresso/kcp/install/includedep.sh deleted file mode 100755 index 6f4812fdf..000000000 --- a/quantum_espresso/kcp/install/includedep.sh +++ /dev/null @@ -1,52 +0,0 @@ -#!/bin/sh -# includedep.sh -- script that computes dependencies on preprocessor includes - -# make sure there is no locale setting creating unneeded differences. -LC_ALL=C -export LC_ALL - -# files whose dependencies must be computed -sources=`echo *.c *.f90 | -sed 's/\*\.c//g - s/\*\.f90//g'` # remove the "*.c" and "*.f90" that remain -# # when there are no such files -if test "$sources" = " " ; then exit ; fi - -# files that may be included -# extra directories may be specified on the command line -includes=`echo *.h` -for dir in $* -do - includes="$includes `echo $dir/*.h`" -done -includes=`echo $includes | -sed 's/[^ ]*\*\.h//g'` # remove the "dir/*.h" that remain -# # when there are no such files - -# create list of include dependencies -# each line is of the form: -# file_name.o : @include_file.h@ -egrep -H '^ *# *include *"' $sources | # look for #include "..." statements -# # ignore #include <...> ones -sed 's/f90:/o / - s/c:/o / - s/# *include *// - s/\"/ /g' | # replace extension, insert space -# # remove '# include' statements -# # remove quotes -awk '{print $1 " : @" $2 "@"}' | # create dependency entry -sort | uniq > includedep.tmp1 # remove duplicates - -# create list of available include files -# for each file, create a line of the form: -# s/@file_name@/pathname/g -echo $includes | tr " " "\n" | -sed 's/\//\\\//g - s/.*\/\([^/]*\)/\1 &/' | # escape slashes -awk '{print "s/@" $1 "@/" $2 "/" }' > includedep.tmp2 - -# replace file names with pathnames -# by applying the file of substitution patterns just created -sed -f includedep.tmp2 includedep.tmp1 - -rm -f includedep.tmp1 includedep.tmp2 # remove temporary files diff --git a/quantum_espresso/kcp/install/install-sh b/quantum_espresso/kcp/install/install-sh deleted file mode 100755 index 6ce63b9f7..000000000 --- a/quantum_espresso/kcp/install/install-sh +++ /dev/null @@ -1,294 +0,0 @@ -#!/bin/sh -# -# install - install a program, script, or datafile -# -# This originates from X11R5 (mit/util/scripts/install.sh), which was -# later released in X11R6 (xc/config/util/install.sh) with the -# following copyright and license. -# -# Copyright (C) 1994 X Consortium -# -# Permission is hereby granted, free of charge, to any person obtaining a copy -# of this software and associated documentation files (the "Software"), to -# deal in the Software without restriction, including without limitation the -# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -# sell copies of the Software, and to permit persons to whom the Software is -# furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN -# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- -# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -# -# Except as contained in this notice, the name of the X Consortium shall not -# be used in advertising or otherwise to promote the sale, use or other deal- -# ings in this Software without prior written authorization from the X Consor- -# tium. -# -# -# FSF changes to this file are in the public domain. -# -# Calling this script install-sh is preferred over install.sh, to prevent -# `make' implicit rules from creating a file called install from it -# when there is no Makefile. -# -# This script is compatible with the BSD install script, but was written -# from scratch. It can only install one file at a time, a restriction -# shared with many OS's install programs. - - -# set DOITPROG to echo to test this script - -# Don't use :- since 4.3BSD and earlier shells don't like it. -doit="${DOITPROG-}" - - -# put in absolute paths if you don't have them in your path; or use env. vars. - -mvprog="${MVPROG-mv}" -cpprog="${CPPROG-cp}" -chmodprog="${CHMODPROG-chmod}" -chownprog="${CHOWNPROG-chown}" -chgrpprog="${CHGRPPROG-chgrp}" -stripprog="${STRIPPROG-strip}" -rmprog="${RMPROG-rm}" -mkdirprog="${MKDIRPROG-mkdir}" - -transformbasename="" -transform_arg="" -instcmd="$mvprog" -chmodcmd="$chmodprog 0755" -chowncmd="" -chgrpcmd="" -stripcmd="" -rmcmd="$rmprog -f" -mvcmd="$mvprog" -src="" -dst="" -dir_arg="" - -while [ x"$1" != x ]; do - case $1 in - -c) instcmd=$cpprog - shift - continue;; - - -d) dir_arg=true - shift - continue;; - - -m) chmodcmd="$chmodprog $2" - shift - shift - continue;; - - -o) chowncmd="$chownprog $2" - shift - shift - continue;; - - -g) chgrpcmd="$chgrpprog $2" - shift - shift - continue;; - - -s) stripcmd=$stripprog - shift - continue;; - - -t=*) transformarg=`echo $1 | sed 's/-t=//'` - shift - continue;; - - -b=*) transformbasename=`echo $1 | sed 's/-b=//'` - shift - continue;; - - *) if [ x"$src" = x ] - then - src=$1 - else - # this colon is to work around a 386BSD /bin/sh bug - : - dst=$1 - fi - shift - continue;; - esac -done - -if [ x"$src" = x ] -then - echo "$0: no input file specified" >&2 - exit 1 -else - : -fi - -if [ x"$dir_arg" != x ]; then - dst=$src - src="" - - if [ -d "$dst" ]; then - instcmd=: - chmodcmd="" - else - instcmd=$mkdirprog - fi -else - -# Waiting for this to be detected by the "$instcmd $src $dsttmp" command -# might cause directories to be created, which would be especially bad -# if $src (and thus $dsttmp) contains '*'. - - if [ -f "$src" ] || [ -d "$src" ] - then - : - else - echo "$0: $src does not exist" >&2 - exit 1 - fi - - if [ x"$dst" = x ] - then - echo "$0: no destination specified" >&2 - exit 1 - else - : - fi - -# If destination is a directory, append the input filename; if your system -# does not like double slashes in filenames, you may need to add some logic - - if [ -d "$dst" ] - then - dst=$dst/`basename "$src"` - else - : - fi -fi - -## this sed command emulates the dirname command -dstdir=`echo "$dst" | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` - -# Make sure that the destination directory exists. -# this part is taken from Noah Friedman's mkinstalldirs script - -# Skip lots of stat calls in the usual case. -if [ ! -d "$dstdir" ]; then -defaultIFS=' - ' -IFS="${IFS-$defaultIFS}" - -oIFS=$IFS -# Some sh's can't handle IFS=/ for some reason. -IFS='%' -set - `echo "$dstdir" | sed -e 's@/@%@g' -e 's@^%@/@'` -IFS=$oIFS - -pathcomp='' - -while [ $# -ne 0 ] ; do - pathcomp=$pathcomp$1 - shift - - if [ ! -d "$pathcomp" ] ; - then - $mkdirprog "$pathcomp" - else - : - fi - - pathcomp=$pathcomp/ -done -fi - -if [ x"$dir_arg" != x ] -then - $doit $instcmd "$dst" && - - if [ x"$chowncmd" != x ]; then $doit $chowncmd "$dst"; else : ; fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd "$dst"; else : ; fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd "$dst"; else : ; fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd "$dst"; else : ; fi -else - -# If we're going to rename the final executable, determine the name now. - - if [ x"$transformarg" = x ] - then - dstfile=`basename "$dst"` - else - dstfile=`basename "$dst" $transformbasename | - sed $transformarg`$transformbasename - fi - -# don't allow the sed command to completely eliminate the filename - - if [ x"$dstfile" = x ] - then - dstfile=`basename "$dst"` - else - : - fi - -# Make a couple of temp file names in the proper directory. - - dsttmp=$dstdir/_inst.$$_ - rmtmp=$dstdir/_rm.$$_ - -# Trap to clean up temp files at exit. - - trap 'status=$?; rm -f "$dsttmp" "$rmtmp" && exit $status' 0 - trap '(exit $?); exit' 1 2 13 15 - -# Move or copy the file name to the temp name - - $doit $instcmd "$src" "$dsttmp" && - -# and set any options; do chmod last to preserve setuid bits - -# If any of these fail, we abort the whole thing. If we want to -# ignore errors from any of these, just make sure not to ignore -# errors from the above "$doit $instcmd $src $dsttmp" command. - - if [ x"$chowncmd" != x ]; then $doit $chowncmd "$dsttmp"; else :;fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd "$dsttmp"; else :;fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd "$dsttmp"; else :;fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd "$dsttmp"; else :;fi && - -# Now remove or move aside any old file at destination location. We try this -# two ways since rm can't unlink itself on some systems and the destination -# file might be busy for other reasons. In this case, the final cleanup -# might fail but the new file should still install successfully. - -{ - if [ -f "$dstdir/$dstfile" ] - then - $doit $rmcmd -f "$dstdir/$dstfile" 2>/dev/null || - $doit $mvcmd -f "$dstdir/$dstfile" "$rmtmp" 2>/dev/null || - { - echo "$0: cannot unlink or rename $dstdir/$dstfile" >&2 - (exit 1); exit - } - else - : - fi -} && - -# Now rename the file to the real destination. - - $doit $mvcmd "$dsttmp" "$dstdir/$dstfile" - -fi && - -# The final little trick to "correctly" pass the exit status to the exit trap. - -{ - (exit 0); exit -} diff --git a/quantum_espresso/kcp/install/install_utils b/quantum_espresso/kcp/install/install_utils deleted file mode 100644 index 007cc61bf..000000000 --- a/quantum_espresso/kcp/install/install_utils +++ /dev/null @@ -1,38 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO group -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License. See the file `License' in the root directory -# of the present distribution. -# -# Utilities - -########################################################### -# Template function -# $(1) = package name -# $(2) = package URL -# $(3) = directory name -# $(4) = plugin/code name -########################################################### - -define download_and_unpack - @(if test ! -s ../archive/`echo "$(2)" | sed 's/.*\///;s/.*=//'` && test ! -e ../$(3) ; then \ - wget -O ../archive/`echo "$(2)" | sed 's/.*\///;s/.*=//'` $(2) > /dev/null 2>&1; \ - if test "`echo $$?`" -ne "0" ; then \ - curl -o ../archive/`echo "$(2)" | sed 's/.*\///;s/.*=//'` $(2) > /dev/null 2>&1; \ - if test "`echo $$?`" -ne "0" ; then \ - echo "*** Unable to download $(4). Test whether curl or wget is installed and working," ; \ - echo "*** if you have direct access to internet. If not, copy into archive/ the file" ; \ - echo "*** located here $(2)" ; \ - exit 1 ; fi ; fi ; fi) - if test ! -e ../$(3); then \ - (gzip -dc ../archive/`echo "$(2)" | sed 's/.*\///;s/.*=//'` | \ - (cd ../ ; tar -xvf - ) ) ; \ - if test "`echo $$?`" -ne "0" ; then \ - echo "*** Unable to download $(2)." ; \ - echo "*** Verify that the url is correct." ; \ - exit 1 ; \ - else \ - (cd ../ ; ln -s $(1) $(3)) ; fi ; fi -endef diff --git a/quantum_espresso/kcp/install/m4/ax_check_compile_flag.m4 b/quantum_espresso/kcp/install/m4/ax_check_compile_flag.m4 deleted file mode 100644 index dcabb92a1..000000000 --- a/quantum_espresso/kcp/install/m4/ax_check_compile_flag.m4 +++ /dev/null @@ -1,74 +0,0 @@ -# =========================================================================== -# https://www.gnu.org/software/autoconf-archive/ax_check_compile_flag.html -# =========================================================================== -# -# SYNOPSIS -# -# AX_CHECK_COMPILE_FLAG(FLAG, [ACTION-SUCCESS], [ACTION-FAILURE], [EXTRA-FLAGS], [INPUT]) -# -# DESCRIPTION -# -# Check whether the given FLAG works with the current language's compiler -# or gives an error. (Warnings, however, are ignored) -# -# ACTION-SUCCESS/ACTION-FAILURE are shell commands to execute on -# success/failure. -# -# If EXTRA-FLAGS is defined, it is added to the current language's default -# flags (e.g. CFLAGS) when the check is done. The check is thus made with -# the flags: "CFLAGS EXTRA-FLAGS FLAG". This can for example be used to -# force the compiler to issue an error when a bad flag is given. -# -# INPUT gives an alternative input source to AC_COMPILE_IFELSE. -# -# NOTE: Implementation based on AX_CFLAGS_GCC_OPTION. Please keep this -# macro in sync with AX_CHECK_{PREPROC,LINK}_FLAG. -# -# LICENSE -# -# Copyright (c) 2008 Guido U. Draheim -# Copyright (c) 2011 Maarten Bosmans -# -# This program is free software: you can redistribute it and/or modify it -# under the terms of the GNU General Public License as published by the -# Free Software Foundation, either version 3 of the License, or (at your -# option) any later version. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General -# Public License for more details. -# -# You should have received a copy of the GNU General Public License along -# with this program. If not, see . -# -# As a special exception, the respective Autoconf Macro's copyright owner -# gives unlimited permission to copy, distribute and modify the configure -# scripts that are the output of Autoconf when processing the Macro. You -# need not follow the terms of the GNU General Public License when using -# or distributing such scripts, even though portions of the text of the -# Macro appear in them. The GNU General Public License (GPL) does govern -# all other use of the material that constitutes the Autoconf Macro. -# -# This special exception to the GPL applies to versions of the Autoconf -# Macro released by the Autoconf Archive. When you make and distribute a -# modified version of the Autoconf Macro, you may extend this special -# exception to the GPL to apply to your modified version as well. - -#serial 5 - -AC_DEFUN([AX_CHECK_COMPILE_FLAG], -[AC_PREREQ(2.64)dnl for _AC_LANG_PREFIX and AS_VAR_IF -AS_VAR_PUSHDEF([CACHEVAR],[ax_cv_check_[]_AC_LANG_ABBREV[]flags_$4_$1])dnl -AC_CACHE_CHECK([whether _AC_LANG compiler accepts $1], CACHEVAR, [ - ax_check_save_flags=$[]_AC_LANG_PREFIX[]FLAGS - _AC_LANG_PREFIX[]FLAGS="$[]_AC_LANG_PREFIX[]FLAGS $4 $1" - AC_COMPILE_IFELSE([m4_default([$5],[AC_LANG_PROGRAM()])], - [AS_VAR_SET(CACHEVAR,[yes])], - [AS_VAR_SET(CACHEVAR,[no])]) - _AC_LANG_PREFIX[]FLAGS=$ax_check_save_flags]) -AS_VAR_IF(CACHEVAR,yes, - [m4_default([$2], :)], - [m4_default([$3], :)]) -AS_VAR_POPDEF([CACHEVAR])dnl -])dnl AX_CHECK_COMPILE_FLAGS diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_aix_dflags.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_aix_dflags.m4 deleted file mode 100644 index 22da5997c..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_aix_dflags.m4 +++ /dev/null @@ -1,13 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_AIX_DFLAGS], [ - -# xlf compilers (AIX and powerpc) want comma-separated -D directives -if test "$xlf_flags" -ne 0 -then - fdflags="`echo $dflags | sed 's/ */,/g'`" -else - fdflags="\$(DFLAGS)" -fi - ] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_ar.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_ar.m4 deleted file mode 100644 index 53509f6a8..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_ar.m4 +++ /dev/null @@ -1,28 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_AR], [ - - # default from the environment (shouldn't be needed) - ar=$AR - arflags=$ARFLAGS - - try_ar="ar" - AC_MSG_CHECKING([setting AR... ]) - if test "$arch" = "necsx"; then - try_ar="sxar" - fi - if test "$ar" = "" ; then ar="$try_ar" ; fi - AC_MSG_RESULT(${ar}) - AC_SUBST(ar) - - try_arflags="ruv" - AC_MSG_CHECKING([setting ARFLAGS... ]) - if test "$arch" = "necsx"; then - try_arflags="rv" - fi - if test "$arflags" = "" ; then arflags="$try_arflags" ; fi - AC_MSG_RESULT(${arflags}) - AC_SUBST(arflags) - - ] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_arch.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_arch.m4 deleted file mode 100644 index 613485dad..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_arch.m4 +++ /dev/null @@ -1,56 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_ARCH], [ - - AC_MSG_CHECKING([ARCH]) - -# many HPC systems are configured so that running parallel programs -# interactively is disabled: on those systems, AC_PROG_FC / _CC -# would fail because they can't run the compiled executables. -# to work around that, let's pretend we are cross-compiling even if we aren't -# !!! this relies on undocumented Autoconf behavior !!! - -# This is used to distinguish between true and fake cross compilation -# (only on NEC SX8 actually) -if test "$host" != "" ; then ranlib=echo; fi - - -# cross compiling? Why? -#cross_compiling=yes - -if test "$host" = "" ; then host=$build; fi - -# identify host architecture -if test "$arch" = "" -then - case $host in - ia64-*-linux-gnu ) arch=ia64 ;; - x86_64-*-linux-gnu ) arch=x86_64 ;; - arm-*linux* ) arch=arm ;; - aarch64-*-linux-gnu ) arch=arm ;; - *-pc-linux-gnu ) arch=ia32 ;; - *-apple-darwin* ) arch=mac686 ;; - *-pc-cygwin ) arch=cygwin ;; - sx*-nec* ) arch=necsx ;; - powerpc64-*-linux-gnu ) arch=ppc64 ;; - powerpc64le-*-linux-gnu ) arch=ppc64le ;; - *-*-mingw32 ) arch=mingw32;; - *-*-mingw64 ) arch=mingw64;; - * ) AC_MSG_WARN(Unrecognized build architecture) - ;; - esac - # workaround for Cray-XT machines - test -d /proc/cray_xt && arch=crayxt - # workaround for IBM BG machines - test -d /bgsys && arch=ppc64-bg - test -f /bgsys/drivers/ppcfloor/bin/runjob && arch=ppc64-bgq -fi - case $arch in - ia32 | ia64 | necsx | crayxt | ppc64-bg ) - AC_MSG_WARN(Obsolete architecture? $arch) - ;; - esac - AC_MSG_RESULT(${arch}) - AC_SUBST(arch) - -]) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_blas.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_blas.m4 deleted file mode 100644 index 3fdd552cd..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_blas.m4 +++ /dev/null @@ -1,362 +0,0 @@ -# Copyright (C) 2001-2020 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_BLAS], [ - -have_blas=0 - -# Flags for machine-specific libraries -have_acml=0 -have_atlas=0 -have_essl=0 -have_mkl=0 -have_armpl=0 - -if test "$blas_libs" != "" -then - echo setting BLAS from \$BLAS_LIBS with no check ... $blas_libs - have_blas=1 -else - # check directories in LD_LIBRARY_PATH too - # (maybe they are already searched by default: useless?) - ld_library_path=`echo $LD_LIBRARY_PATH | sed 's/:/ /g'` - - case "$arch:$f90" in - - # search for architecture-specific libraries - - x86_64:* | mac686:* ) - # - # search for MKL in directory $MKL_ROOT - # - # Following architectures no longer supported: - # ia64 $MKLROOT/lib/64 -lmkl_gf_ipf, -lmkl_intel_ipf - # ia32 $MKLROOT/lib/ia32 -lmkl_gf , -lmkl_intel - # - if test "$MKLROOT" == ""; then - MKLROOT=/opt/intel/mkl - fi - case "$f90" in - ifort* ) - mkl_lib="mkl_intel_lp64" - mkl_omp="mkl_intel_thread" - if test "$arch" == "mac686"; then - add_mkl_flag="-openmp" - add_mkl_lib="-lpthread" - add_mkl_omp="-lpthread" - fi - ;; - gfortran* ) - mkl_lib="mkl_gf_lp64" - mkl_omp="mkl_gnu_thread" - ;; - nvfortran* ) - mkl_lib="mkl_intel_lp64" - mkl_omp="mkl_intel_thread" - # FIXME: is the following correct? - add_mkl_flag="-pgf90libs" - ;; - pgf* ) - # Detect PGI version - FIXME: WHY? pgf_version is known - pgf_version=`$mpif90 -V 2>&1 | sed '/^$/d' | grep "^pgf" | cut -d ' ' -f2` - # From version 19.1, the new llvm backend requires linking to mkl_intel_thread - ompimp="" - AS_VERSION_COMPARE([$pgf_version], [19.1], [ ompimp="pgi" ], [ ompimp="intel" ], [ ompimp="intel" ] ) - mkl_lib="mkl_${ompimp}_lp64" - mkl_omp="mkl_${ompimp}_thread" - add_mkl_flag="-pgf90libs" - ;; - esac - try_libdirs="$libdirs $MKLROOT/lib/intel64 $ld_library_path" - for dir in none $try_libdirs - do - unset ac_cv_search_dgemm # clear cached value - if test "$dir" = "none" - then - try_loption=" " - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$add_mkl_flag $test_ldflags $try_loption" - # LIBS="" - # not sure the above is needed - if test "$use_openmp" -eq 0; then - # test MKL (no OMP) - AC_SEARCH_LIBS(dgemm, $mkl_lib, - have_blas=1 have_mkl=1 - blas_libs="$try_loption $LIBS -lmkl_sequential -lmkl_core" - ldflags="$add_mkl_flag $ldflags", - echo "MKL not found", - -lmkl_sequential -lmkl_core $add_mkl_lib) - else - # test MKL (OMP) - AC_SEARCH_LIBS(dgemm, $mkl_lib, - have_blas=1 have_mkl=1 - blas_libs="$try_loption $LIBS -l$mkl_omp -lmkl_core" - ldflags="$add_mkl_flag $ldflags", - echo "MKL not found", - -l$mkl_omp -lmkl_core $add_mkl_omp) - fi - if test "$ac_cv_search_dgemm" != "no" - then break ; fi - done - ;; - - ppc64:* ) - # - # search for ESSL - newer (?) powerPC machines - # - unset ac_cv_search_dgemm # clear cached value - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags" - LIBS="" - AC_SEARCH_LIBS(dgemm, essl, have_blas=1 - blas_libs="$LIBS" ) - # notice that some IBM machines may not need -lessl - # to load blas so the above test may fail - if test "`echo $blas_libs | grep essl`" != "" - then - have_essl=1 - try_dflags="$try_dflags -D__LINUX_ESSL" - fi - # OBM:Yet another work-around if the above search - # returns "none required" - if test "$ac_cv_search_dgemm" = "none required" - then - echo "There is no need for -lessl in this machine" - have_essl=1 - try_dflags="$try_dflags -D__LINUX_ESSL" - fi - # we need esslsmp for hybrid (MPI+OpenMP) build - if test "$have_essl"="1"; then - if test "$use_openmp" -ne 0 ; then - blas_libs="-lesslsmp" - fi - fi - ;; - - ppc64-*:* ) - # - # assume ESSL without testing - old powerPC machines, BlueGene - # - unset ac_cv_search_dgemm # clear cached value - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags" - have_blas=1 - have_essl=1 - # BlueGene: for some obscure reason there is no need to - # specify a library path to have essl linked, while - # in reality it is needed to specify where essl are - if test "$arch"="ppc64-bg"; then - try_dflags="$try_dflags -D__LINUX_ESSL" - if test "$blas_libs"=""; then - if test "$use_openmp" -eq 0 ; then - blas_libs="-L/opt/ibmmath/essl/4.4/lib/ -lesslbg" - else - blas_libs="-L/opt/ibmmath/essl/4.4/lib/ -lesslsmpbg" - fi - fi - else - try_dflags="$try_dflags -D__LINUX_ESSL" - fi - ;; - - arm:armflang ) - # search for ARM libs - ARM compiler - if test "$use_openmp" -eq 0; then - FFLAGS="-armpl" - else - FFLAGS="-fopenmp -armpl=parallel" - fi - AC_SEARCH_LIBS(dgemm, armpl_arm, - have_blas=1 have_armpl=1 - blas_libs="" - ldflags="$ldflags \$(FFLAGS)", - echo "armpl not found", - yes) - if test "$have_armpl" -eq 1; then - if test "$use_openmp" -eq 0; then - fflags="$fflags -armpl" - else - fflags="$fflags -armpl=parallel" - fi - fi - ;; - - arm:gfortran ) - # search for ARM libs - gfortran compiler - try_libdirs="$libdirs $ARMPL_LIBRARIES $ld_library_path" - for dir in none $try_libdirs - do - unset ac_cv_search_dgemm # clear cached value - if test "$dir" = "none" - then - try_loption=" " - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - # LIBS="" - # not sure the above is needed - # - if test "$use_openmp" -eq 0; then - AC_SEARCH_LIBS(dgemm, armpl, - have_blas=1 have_armpl=1 - blas_libs="$try_loption $LIBS " - ldflags="$ldflags", - echo "armpl not found", - ) - else - AC_SEARCH_LIBS(dgemm, armpl_mp, - have_blas=1 have_armpl=1 - blas_libs="$try_loption $LIBS " - ldflags="$ldflags", - echo "armpl not found", - ) - fi - if test "$ac_cv_search_dgemm" != "no" - then break ; fi - done - ;; - - # obsolescent or obsolete architectures - - crayxt*:* ) - # check for acml - OBSOLETE? - try_libdirs="$ld_library_path $libdirs" - for dir in none $try_libdirs - do - unset ac_cv_search_dgemm # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - - if test "$use_openmp" -eq 0; then - AC_SEARCH_LIBS(dgemm, acml, have_blas=1 have_lapack=1 - have_acml=1 blas_libs="$try_loption $LIBS") - else - AC_SEARCH_LIBS(dgemm, acml_mp, have_blas=1 have_lapack=1 - have_acml=1 blas_libs="$try_loption $LIBS") - fi - - if test "$ac_cv_search_dgemm" != "no" - then break ; fi - done - ;; - - necsx:* ) - #sx5-nec or sx6-nec or sx8-nec: check in (/SX)/usr/lib - #sx8-nec-idris: check in /SX/opt/mathkeisan/inst/lib0 - try_libdirs="/SX/usr/lib /SX/opt/mathkeisan/inst/lib0" - for dir in none $try_libdirs - do - unset ac_cv_search_dgemm # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - AC_SEARCH_LIBS(dgemm, blas, have_blas=1 - blas_libs="$try_loption $LIBS") - if test "$ac_cv_search_dgemm" != "no" - then break ; fi - done - ;; - esac - - # blas not (yet) found: look for more possibilities - - if test "$have_blas" -eq 0 - then - case "$f90" in - pgf* ) - # check for PGI blas - unset ac_cv_search_dgemm # clear cached value - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags" - LIBS="" - AC_SEARCH_LIBS(dgemm, blas, have_blas=1 blas_libs="$LIBS") - ;; - esac - fi - - if test "$have_blas" -eq 0 - then - # check for atlas (in several directories) - try_libdirs="$libdirs /usr/local/lib $ld_library_path" - - for dir in none $try_libdirs - do - unset ac_cv_search_dgemm # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="-latlas" - AC_SEARCH_LIBS(dgemm, f77blas, have_blas=1 have_atlas=1 - blas_libs="$try_loption $LIBS", , -lg2c) - if test "$ac_cv_search_dgemm" != "no" - then break ; fi - done - fi - - if test "$have_blas" -eq 0 - then - # check for blas (in several directories) - try_libdirs="$libdirs /usr/local/lib $ld_library_path" - - for dir in none $try_libdirs - do - unset ac_cv_search_dgemm # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - AC_SEARCH_LIBS(dgemm, blas-3 openblas blas, have_blas=1 - blas_libs="$try_loption $LIBS") - if test "$ac_cv_search_dgemm" != "no" - then break ; fi - done - fi -fi - -if test "$have_blas" -eq 0 ; then - # No blas library found: use internal one (in lapack) - blas_libs="\$(TOPDIR)/LAPACK/libblas.a" -else - echo setting BLAS_LIBS... $blas_libs -fi -blas_line="BLAS_LIBS=$blas_libs" - -AC_SUBST(blas_libs) -AC_SUBST(blas_line) - -] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_cc.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_cc.m4 deleted file mode 100644 index a1bbe70ff..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_cc.m4 +++ /dev/null @@ -1,82 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_CC], [ - -# candidate C compilers good for all cases -try_cc="cc gcc" - -case "$arch:$f90_flavor" in -*:ifort* ) - try_cc="icc ecc $try_cc" - ;; -*:pgf90 ) - try_cc="pgcc $try_cc" - ;; -cray*:* ) - try_cc="cc" - ;; -necsx:* ) - try_cc="sxcc" - ;; -ppc64-bg*:*xlf90_r ) - try_cc="bgxlc_r" - ;; -ppc64-bg*:*xlf90 ) - try_cc="bgxlc" - ;; -ppc64:*xlf* | ppc64le:*xlf* ) - try_cc="xlc_r $try_cc" - ;; -esac - -# check serial C compiler -if test "$env_cc" = "" ; then cc="$try_cc" ; else cc="$env_cc"; fi -AC_PROG_CC($cc) -cc=$CC - -echo setting CC... $cc - -AC_SUBST(cc) - -# tentative C and loader flags, good for many cases -try_cflags="-O3" -c_ldflags="" -try_cpp="cpp" - -case "$arch:$cc" in -*:pgcc ) - # Do I need preprocessing here? - try_cflags="-fast -Mpreprocess" - ;; -crayxt*:cc ) - # Actually we need something like is done for ftn to detect - # the proper compiler used (NdFilippo) - try_cflags="-O3" - ;; -necsx:* ) - #try_cflags="-D__SX6 \$(IFLAGS) \$(MODFLAGS)" - try_cflags="" - ;; -ppc64le:* ) - try_cflags="-O3" - ;; -ppc64-bg:* ) - try_cflags="-O3 -q32" - ;; -ppc64-bgq:* ) - try_cflags="-O3" - ;; -ppc64:xlc*) - try_cflags="-O3 -q64 -qthreaded" - c_ldflags="-q64" - ;; - -esac -if test "$cflags" = "" ; then cflags=$try_cflags ; fi -echo setting CFLAGS... $cflags - -# compilation flags for all subsequent tests -test_cflags="`echo $cflags | sed 's/\$([[^)]]*)//g'`" - -AC_SUBST(cflags) -]) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_cpp.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_cpp.m4 deleted file mode 100644 index e6dfde656..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_cpp.m4 +++ /dev/null @@ -1,29 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_CPP], [ - -# preprocessor - try cpp in all cases; the preprocessor returned by -# AC_PROG_CPP -# may sometimes refuse to preprocess fortran files -if test "$cpp" = "" ; then cpp=$try_cpp; fi -# if test "$cpp" = "" ; then cpp=$CPP; fi -echo setting CPP... $cpp - -echo $ECHO_N "setting CPPFLAGS... $ECHO_C" -# Note: option -C makes trouble with recent gcc versions and pgi -case $cpp in - cpp) try_cppflags="-P -traditional -Uvector" ;; - fpp) try_cppflags="-P " ;; - *) try_cppflags="" ;; -esac -if test "$cppflags" = "" ; then cppflags=$try_cppflags ; fi -echo "${ECHO_T}$cppflags" - -# compilation flags for all subsequent tests -test_cppflags="$test_cflags" - -AC_SUBST(cpp) -AC_SUBST(cppflags) - - ] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_default_env.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_default_env.m4 deleted file mode 100644 index 47fb4594f..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_default_env.m4 +++ /dev/null @@ -1,46 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_DEFAULT_ENV], [ - -# Non-standard precious variables -AC_ARG_VAR(EXTLIB_FLAGS, This variable controls the flags passed to internal BLAS and LAPACK libraries) - -# store variables from the environment, if set (may be or not be set) -# If set, they take precedence over configure internal choice. -# Flags and libraries are accepted without further testing; -# compilers are tested. Specify compiler name only, not the full path -# (i.e. F90=/usr/local/bin/f90 may not work, use F90=f90) - -topdir=$TOPDIR # current directory -arch=$ARCH # see below for recognized architectures -env_cc=$CC # C compiler (must be in the execution path) -cpp=$CPP # C preprocessor (as above) -cflags=$CFLAGS # Flags for C compiler -cppflags=$CPPFLAGS # Flags for C preprocessor -dflags=$DFLAGS # Fortran file preprocessing options, e.g. -D__DEFINE_THIS -iflags=$IFLAGS # Location of include files - shouldn't be needed -f90=$F90 # Fortran 90 serial compiler (must be in execution path) -mpif90=$MPIF90 # Fortran 90 parallel compiler (must be in execution path) -fflags=$FFLAGS # Flags for Fortran 77 and 90 compilers -fflags_nomain=$FFLAGS_NOMAIN # Flags for linking Fortran sources with main in a different language -fflags_noopt=$FFLAGS_NOOPT # as FFLAGS With optimization disabled -f90flags=$F90FLAGS # Flags for Fortran 90 compiler only -ld=$LD # Loader (must be in the execution path) -ldflags=$LDFLAGS # Flags for loader -ld_libs=$LD_LIBS # Additional libraries -blas_libs=$BLAS_LIBS # blas library - specify e.g. /my/blas/lib/libmyblas.a - # or -L/my/blas/lib -lmyblas -lapack_libs=$LAPACK_LIBS # lapack library, similar to above -fft_libs=$FFT_LIBS # FFT libraries - may depend upon DFLAGS -mpi_libs=$MPI_LIBS # MPI libraries - shouldn't be needed -mass_libs=$MASS_LIBS # MASS libraries (IBM only) -libdirs=$LIBDIRS # Where to look for libraries (e.g. /my/blas/lib) -scalapack_libs=$SCALAPACK_LIBS # scalapack libs -scalapack_dir=$SCALAPACK_LIB # Where to look for scalapack libs -blacs_dir=$BLACS_LIB # Where to look for libblacs.a -ar=$AR # ar (shouldn't be needed) -arflags=$ARFLAGS # Flags for ar (as above) -extlib_flags=$EXTLIB_FLAGS # Flags for internal copies of lapack and blas - - ] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_elpa.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_elpa.m4 deleted file mode 100644 index 9e608381f..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_elpa.m4 +++ /dev/null @@ -1,76 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_ELPA], [ - - AC_MSG_CHECKING([ELPA]) - -AC_ARG_WITH(elpa-include, - [AS_HELP_STRING([--with-elpa-include], - [Specify full path ELPA include and modules headers (default: no)])], - [if test "$withval" = "no" ; then - with_elpa_include=0 - else - with_elpa_include=1 - elpa_include="$withval" - fi], - [with_elpa_include=0]) - -AC_ARG_WITH(elpa-lib, - [AS_HELP_STRING([--with-elpa-lib], - [Specify full path ELPA static or dynamic library (default: no)])], - [if test "$withval" = "no" ; then - with_elpa_libs=0 - else - with_elpa_libs=1 - elpa_libs="$withval" - fi], - [with_elpa_libs=0]) - -AC_ARG_WITH(elpa-version, - [AS_HELP_STRING([--with-elpa-version], - [Specify ELPA version, only year (2015 - 2019, default: 2016)])], - [if test "$withval" = "no" ; then - with_elpa_version=0 - else - with_elpa_version="$withval" - fi], - [with_elpa_version="2016"]) - - -elpa_line="@delete@" - -# ELPA iff SCALAPACK -if test "$with_elpa_libs" -eq 1; then - if test "$have_scalapack" -eq 1; then - if test "$with_elpa_include" -eq 1 && test "$with_elpa_libs" -eq 1; then - - if test "$with_elpa_version" = "2015"; then - try_dflags="$try_dflags -D__ELPA_2015" - elif test "$with_elpa_version" = "2016"; then - try_dflags="$try_dflags -D__ELPA_2016" - elif test "$with_elpa_version" = "2017"; then - try_dflags="$try_dflags -D__ELPA_2017" - elif test "$with_elpa_version" = "2018"; then - try_dflags="$try_dflags -D__ELPA_2018" - elif test "$with_elpa_version" = "2019"; then - try_dflags="$try_dflags -D__ELPA_2019" - else - AC_MSG_WARN([*** Invalid ELPA version, defaulting to 2016]) - try_dflags="$try_dflags -D__ELPA_2016" - fi - - try_iflags="$try_iflags -I$elpa_include" - scalapack_libs="$elpa_libs $scalapack_libs" - elpa_line="ELPA_LIBS=$elpa_libs" - fi - else - AC_MSG_WARN([*** ScaLAPACK is needed to use ELPA]) - fi -fi - - AC_MSG_RESULT(${elpa_libs}) - - AC_SUBST(elpa_libs) - AC_SUBST(elpa_line) - ] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_environ.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_environ.m4 deleted file mode 100644 index 1727eda07..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_environ.m4 +++ /dev/null @@ -1,20 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation -# -AC_DEFUN([X_AC_QE_ENVIRON], [ - - AC_ARG_ENABLE(environment, - [AS_HELP_STRING([--enable-environment], [compile solvent-related stuff (default: no)])], - [if test "$enableval" = "yes" ; then - enable_environment=1 - else - enable_environment=0 - fi], - [enable_environment=0]) - - if test "$enable_environment" -eq 1 ; - then - try_dflags="$try_dflags -D__ENVIRONMENT" - fi - - ] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_f90.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_f90.m4 deleted file mode 100644 index 10e2690ab..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_f90.m4 +++ /dev/null @@ -1,285 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_F90], [ - -# debug flags are implemented only for a few cases -AC_ARG_ENABLE(debug, - [AS_HELP_STRING([--enable-debug], - [compile Fortran with debug flags (default: no)])], - [if test "$enableval" = "yes" ; then - use_debug=1 - else - use_debug=0 - fi], - [use_debug=0]) - -# pedantic flags implemented only for gcc -AC_ARG_ENABLE(pedantic, - [AS_HELP_STRING([--enable-pedantic], - [compile Fortran with pedantic flags (default: no)])], - [if test "$enableval" = "yes" ; then - use_pedantic=1 - else - use_pedantic=0 - fi], - [use_pedantic=0]) - -# shared library flags are implemented only for a few (untested) cases -AC_ARG_ENABLE(shared, - [AS_HELP_STRING([--enable-shared], - [use shared libraries if available (default: yes)])], - [if test "$enableval" = "yes" ; then - use_shared=1 - else - use_shared=0 - fi], - [use_shared=1]) - -# check Fortran compiler flags -# have_cpp=0: use external C preprocessing for fortran code -# have_cpp=1: use C-like preprocessing in fortran compiler -have_cpp=1 -xlf_flags=0 - -echo using F90... $f90 - -case "$arch:$f90_flavor" in -*:ifort* ) - try_fflags="-O2 -assume byterecl -g -traceback" - if test "$use_debug" -eq 1; then - try_fflags="$try_fflags -fpe0 -CB" - fi - try_fflags_nomain="-nofor_main" - try_f90flags="\$(FFLAGS) -nomodule" - try_fflags_noopt="-O0 -assume byterecl -g -traceback" - try_ldflags="" - try_ldflags_static="-static" - try_dflags="$try_dflags -D__INTEL" - if test "$f90_major_version" -ge "15"; then - try_fflags_openmp="-qopenmp" - try_ldflags_openmp="-qopenmp" - else - try_fflags_openmp="-openmp" - try_ldflags_openmp="-openmp" - fi - pre_fdflags="-fpp " - ;; -arm:armflang ) - try_fflags="-O3 -mcpu=native $try_fflags" - if test "$use_debug" -eq 1; then - try_fflags="$try_fflags -g" - fi - try_ldflags="-mcpu=native" - try_fflags_openmp="-fopenmp" - try_ldfflags_openmp="-fopenmp" - try_f90flags="\$(FFLAGS) -cpp" - try_ldflags="-g -mcpu=native" - try_ldflags_openmp="-fopenmp" - try_ldflags_static="-static -static-flang-libs" - - ;; -x86_64:nagfor* ) - try_fflags="-O3 -kind=byte -dcfuns -mismatch" - if test "$use_debug" -eq 1; then - try_fflags="$try_fflags -g" - fi - try_fflags_nomain="" - try_fflags_openmp="-openmp" - try_f90flags="-O3 -kind=byte -dcfuns -mismatch" - try_fflags_noopt="-O0 -kind=byte -dcfuns -mismatch" - try_ldflags="" - try_ldflags_static="-unsharedrts" - try_ldflags_openmp="-openmp" - try_dflags="$try_dflags -D__NAG" - have_cpp=0 - ;; -crayxt*:cray* ) - try_fflags_nomain="" - #NOTE: by default OpenMP is always ON (see crayftn man page) - try_fflags_openmp="-homp" - try_fflags="-O2" - #NOTE: add '-rm' to get messages from crayftn about why - # optimizations have not been applied - # -x dir disable directives introduced by !DIR$ - try_f90flags="-O3,fp3 -f free -x dir" - try_fflags_noopt="-O0" - try_ldflags_openmp="-homp" - try_ldflags="-v" - try_ldflags_static="-static" - try_dflags="$try_dflags -D__CRAY" - have_cpp=0 - ;; -crayxt*:pgf* ) -# see comment above for pgf* - try_fflags_nomain="-Mnomain" - try_fflags_openmp="-mp" - try_fflags="-O3" - try_f90flags="-fast -Mcache_align -Mpreprocess -Mlarge_arrays" - try_fflags_noopt="-O0" - try_ldflags_openmp="-mp" - try_ldflags="-v" - try_dflags="$try_dflags -D__PGI -D__IOTK_WORKAROUND1" - have_cpp=1 - ;; -necsx:* ) - try_fflags=' -float0 -Cvopt -eab -R5 -Wf,-Ncont,-A dbl4,-P nh,-ptr byte,-pvctl noifopt loopcnt=9999999 expand=12 fullmsg vwork=stack,-fusion,-O noif,-init stack=nan heap=nan' - try_f90flags=' -f2003 -float0 -Cvopt -eab -R5 -Wf,-Ncont,-A dbl4,-P nh,-ptr byte,-pvctl noifopt loopcnt=9999999 expand=12 fullmsg vwork=stack,-fusion,-O noif,-init stack=nan heap=nan' - try_f90flags="-$sxopt $try_f90flags" - try_fflags_noopt='-float0 ' - try_f90flags_noopt='-f2003 -float0 -eab -R5 -C debug -Wf,-Ncont,-A dbl4,-P nh ,ptr byte,-init stack=nan heap=nan' - try_f90flags_noopt="$try_f90flags_noopt" - try_f90flags_inline='-f2003 -float0 -Cvopt -eab -R5 -pi noauto incdir exp=w0gauss -Wf,-Ncont,-A dbl4,-P nh,-ptr byte,-pvctl noifopt loopcnt=9999999 expand=12 fullmsg vwork=stack,-fusion,-O noif,-init stack=nan heap=nan' - try_f90flags_inline="$try_f90flags_inline" - try_ldflags_static='-P static' - try_ldflags='-Wl,-f zero' - try_ldflags="-p $try_ldflags" - pre_fdflags="" - ;; - -ppc64:*xlf* ) - if test "$use_debug" -eq 1; then - try_fflags="-g -C -qsuffix=cpp=f90 -qdpc -qalias=nointptr -Q" - else - try_fflags="-q64 -qthreaded -O4 -qsuffix=cpp=f90 -qdpc -qalias=nointptr -Q" - fi - try_f90flags="\$(FFLAGS) -qfree=f90" - try_fflags_noopt="-q64 -qthreaded -O0" - try_ldflags="-q64 -qthreaded" - try_dflags="-D__XLF" - pre_fdflags="-WF," - xlf_flags=1 - ;; -ppc64le:*xlf* ) - if test "$use_debug" -eq 1; then - try_fflags="-g -C -qstrict -qdpc -qalias=nointptr -qarch=auto" - else - try_fflags="-O3 -qstrict -qdpc -qalias=nointptr -qarch=auto" - fi - try_fflags_openmp="-qsmp=noauto:omp" - try_f90flags="\$(FFLAGS) -qsuffix=cpp=f90" - try_fflags_noopt="-O0" - try_ldflags="" - try_ldflags_openmp="-qsmp=noauto:omp" - try_dflags="-D__XLF" - pre_fdflags="-WF," - xlf_flags=1 - ;; -ppc64-bg:*xlf* ) - if test "$use_debug" -eq 1; then - try_fflags="-q32 -qalias=noaryovrlp:nointptr -g -C -qdpc=e" - else - try_fflags="-q32 -qalias=noaryovrlp:nointptr -O3 -qstrict -qdpc=e" - fi - try_fflags_openmp="-qsmp=omp -qthreaded" - try_f90flags="\$(FFLAGS) -qsuffix=cpp=f90" - try_fflags_noopt="-q32 -O0" - try_ldflags="-q32" - try_ldflags_openmp="-qsmp=omp -qthreaded" - try_dflags="-D__XLF" - pre_fdflags="-WF," - xlf_flags=1 - ;; -ppc64-bgq:*xlf* ) - if test "$use_debug" -eq 1; then - try_fflags="-qalias=noaryovrlp:nointptr -g -C -qdpc=e" - else - try_fflags="-qalias=noaryovrlp:nointptr -O3 -qstrict -qdpc=e -qarch=qp -qtune=qp" - fi - try_fflags_openmp="-qsmp=noauto:omp -qtm -qthreaded" - try_f90flags="\$(FFLAGS) -qsuffix=cpp=f90" - try_fflags_noopt="-O0" - try_ldflags="" - try_ldflags_openmp="-qstatic -qsmp=noauto:omp -qtm -qthreaded" - try_dflags="-D__XLF" - pre_fdflags="-WF," - xlf_flags=1 - ;; -*:pgf* ) - try_fflags_nomain="-Mnomain" - try_fflags="-fast" - try_fflags_openmp="-mp" - if test "$use_debug" -eq 1; then - try_f90flags="-g -C -Mcache_align -Mpreprocess -Mlarge_arrays" - else - try_f90flags="-fast -Mcache_align -Mpreprocess -Mlarge_arrays" - fi - try_foxflags="-fast -Mcache_align -Mpreprocess -Mlarge_arrays" - try_fflags_noopt="-O0" - try_ldflags="" - try_ldflags_openmp="-mp" - try_ldflags_static="-Bstatic" - try_dflags="$try_dflags -D__PGI" - have_cpp=1 - ;; -*:*gfortran ) - try_fflags="-O3 -g" - if test "$f90_major_version" -ge "10"; then - try_fflags="$try_fflags -fallow-argument-mismatch" - fi - if test "$use_debug" -eq 1; then - try_fflags="-O3 -g -Wall -fbounds-check -frange-check -finit-integer=987654321 -finit-real=nan -finit-logical=true -finit-character=64" - fi - if test "$use_pedantic" -eq 1; then - try_fflags="-O2 -g -pedantic -Wall -Wextra -Wconversion -fimplicit-none -fbacktrace -ffree-line-length-0 -fcheck=all" - fi - try_fflags_openmp="-fopenmp" - try_f90flags="\$(FFLAGS) -cpp" - try_fflags_noopt="-O0 -g" - try_ldflags="-g" - try_ldflags_openmp="-pthread -fopenmp" - try_ldflags_static="-static" - try_dflags="$try_dflags -D__GFORTRAN" - ;; - -* ) - # unknown, try these - try_fflags="-O1" - try_f90flags="\$(FFLAGS)" - try_fflags_noopt="-O0" - try_ldflags="" - have_cpp=0 - ;; - -esac - -if test "$use_shared" -eq 0 ; then - try_ldflags="$try_ldflags $try_ldflags_static" ; fi - -# Flags are repeated, need better way to handle this ... -if test "$use_openmp" -eq 1 ; then - try_f90flags="$try_f90flags $try_fflags_openmp" - try_fflags="$try_fflags $try_fflags_openmp" - try_ldflags="$try_ldflags $try_ldflags_openmp" -fi - -if test "$fflags" = "" ; then fflags=$try_fflags ; fi -if test "$f90flags" = "" ; then f90flags=$try_f90flags ; fi -if test "try_foxflags" != ""; then foxflags=$try_foxflags; fi -if test "$fflags_noopt" = "" ; then fflags_noopt=$try_fflags_noopt ; fi -if test "$fflags_nomain" = "" ; then fflags_nomain=$try_fflags_nomain ; fi - -echo setting FFLAGS... $fflags -echo setting F90FLAGS... $f90flags -echo setting FFLAGS_NOOPT... $fflags_noopt -if test "$fflags_nomain" != "" ; then echo setting FFLAGS_NOMAIN... $fflags_nomain ; fi - -if test "$imod" = "" ; then imod="-I" ; fi - -# compilation flags for all subsequent tests -# remove all $(...) because at least one compiler doesn't like them -# but if f90flags contains $(FFLAGS), substitute it -if test "`echo $f90flags | grep '$(FFLAGS)'`" != "" -then - test_fflags="`echo $fflags $f90flags | sed 's/\$([[^)]]*)//g'`" -else - test_fflags="`echo $f90flags | sed 's/\$([[^)]]*)//g'`" -fi - -AC_SUBST(pre_fdflags) -AC_SUBST(f90flags) -AC_SUBST(fflags) -AC_SUBST(fflags_noopt) -AC_SUBST(fflags_nomain) -AC_SUBST(imod) -AC_SUBST(foxflags) -]) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_f90rule.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_f90rule.m4 deleted file mode 100644 index e8127dfeb..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_f90rule.m4 +++ /dev/null @@ -1,19 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_F90RULE], [ - -AC_PROG_MAKE_SET -echo $ECHO_N "checking whether Fortran files must be preprocessed... $ECHO_C" -if test "$have_cpp" -ne 0 -then - f90rule="\$(MPIF90) \$(F90FLAGS) -c \$<" - echo "${ECHO_T}no" -else - f90rule="\$(CPP) \$(CPPFLAGS) \$< -o \$(*)_tmp.f90 ; \\ - \$(MPIF90) \$(F90FLAGS) -c \$(*)_tmp.f90 -o \$(*).o" - echo "${ECHO_T}yes" -fi - -AC_SUBST(f90rule) - -]) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_fft.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_fft.m4 deleted file mode 100644 index ea69002f9..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_fft.m4 +++ /dev/null @@ -1,199 +0,0 @@ -# Copyright (C) 2001-2020 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_FFT], [ - -have_fft=0 -have_fft_include=0 - -AC_MSG_CHECKING([FFT]) - -if test "$fft_libs" = ""; then - # if FFT_LIBS is defined, use it without further checking - - if test "$have_mkl" -eq 1; then - # no check needed if MKL libraries have been detected - try_dflags="$try_dflags -D__FFTW3" - # If not set on input, MKLROOT was set when checking blas - try_iflags="$try_iflags -I$MKLROOT/include" - have_fft=1 - - elif test "$have_armpl" -eq 1; then - # no check needed if ARM libraries have been detected - try_dflags="$try_dflags -D__ARM_LIB" - have_fft=1 - - elif test "$have_essl" -eq 1; then - # no check needed for ESSL on PPC64 machine: TO BE VERIFIED - case "$arch" in - ppc64* ) - try_dflags="$try_dflags -D__LINUX_ESSL" - ;; - esac - - elif test "$use_openmp" -eq 0; then - - # check for OBSOLETE? FFT libraries (not for explicit openmp) - # ASL/Mathkeisan on Nec (OBSOLETE) - # acml on amd - - # check directories in LD_LIBRARY_PATH too - # (maybe they are already searched by default, but I'm not sure) - ld_library_path=`echo $LD_LIBRARY_PATH | sed 's/:/ /g'` - - case "$arch" in - necsx ) - # NEC-SX: OBSOLETE? - if test "$use_fft_mathkeisan" -ne 0 - then - #sx5-nec or sx6-nec or sx8-nec: check in (/SX)/usr/lib - #sx8-nec-idris: check in /SX/opt/mathkeisan/inst/lib0 - try_libdirs="/SX/usr/lib /SX/opt/mathkeisan/inst/lib0" - #check for Mathkeisan (Cray simple precision ) - #search for initialization subroutine - echo $ECHO_N "Searching in Mathkeisan" $ECHO_C - for dir in none $try_libdirs - do - unset ac_cv_search_zftfax # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - AC_SEARCH_LIBS(zftfax, fft, have_fft=1 - try_dflags="$try_dflags try_dflags_fft_mathkeisan" - fft_libs="$try_loption $LIBS") - if test "$ac_cv_search_zftfax" != "no" - then break ; fi - done - fi - if test "$use_fft_asl" -ne 0 - then - #check for asl in (/SX)/usr/lib - try_libdirs="/SX/usr/lib" - #search for initialization subroutine - echo $ECHO_N "Searching in Asl" $ECHO_C - for dir in none $try_libdirs - do - unset ac_cv_search_zfc3cl # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - AC_SEARCH_LIBS(zfc3cl, asl, have_fft=1 - asl_libs="$try_loption $LIBS" - try_dflags="$try_dflags $try_dflags_fft_asl" - fft_libs="$fft_libs $asl_libs") - if test "$ac_cv_search_zfc3cl" != "no" - then break ; fi - done - fi - if test "$use_fft_para" -ne 0 - then - try_dflags="$try_dflags $try_dflags_fft_para" - fi - ;; - esac - fi - - if test "$have_fft" -eq 0 - then - - # Nothing found: look for fftw v3 - - try_libdirs="/usr/local/lib" - try_libdirs="$libdirs $try_libdirs $ld_library_path " - for dir in none $try_libdirs - do - unset ac_cv_search_dfftw_execute_dft # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - - CFLAGS="$test_cflags" - CPPFLAGS="$test_cppflags" - LDFLAGS=" $test_ldflags $try_loption" - LIBS="$fft_libs" - - if test "$use_openmp" -eq 1 - then - # Try testing openmp without -lfftw3 first, if that fails then return - # to previous behaviour - AC_SEARCH_LIBS(dfftw_execute_dft, fftw3_omp, have_fft=1 - fft_libs="$try_loption $LIBS", , -lm) - if test "$have_fft" -eq 0 - then - AC_SEARCH_LIBS(dfftw_execute_dft, fftw3_omp, have_fft=1 - fft_libs="$try_loption $LIBS -lfftw3", , -lfftw3 -lm) - fi - else - AC_SEARCH_LIBS(dfftw_execute_dft, fftw3, have_fft=1 - fft_libs="$try_loption $LIBS", , -lm) - fi - - if test "$have_fft" -eq 1 - then - try_dflags="$try_dflags -D__FFTW3" - try_incdir="$FFTW_INCLUDE $FFTW_INC $INCLUDE_PATH $CPATH $FPATH" - orig_fflags="$FFLAGS" - for inc in $try_incdir - do - FFLAGS="$orig_fflags -I$inc -ffree-form" - AC_COMPILE_IFELSE([use iso_c_binding -include "fftw3.f03" -end],have_fft_include=1,) - if test "$have_fft_include" -eq 1 - then - try_iflags="$try_iflags -I$inc" - break - fi - done - FFLAGS="$orig_fflags" - break - fi - - done - fi - - # if no valid FFT library was found, use the local copy - if test "$have_fft" -eq 0 - then - echo "using internal copy of FFTW" - try_dflags="$try_dflags -D__FFTW" - fi - -else - - echo "using FFT_LIBS with no testing ... " - if test -n "$FFT_INCLUDE" ; then : - try_iflags="$try_iflags -I$FFT_INCLUDE" - fi - if test -n "$FFTW_INCLUDE" ; then : - try_dflags="$try_dflags -D__FFTW3" - try_iflags="$try_iflags -I$FFTW_INCLUDE" - fi - -fi - -AC_MSG_RESULT(${fft_libs}) -fft_line="FFT_LIBS=$fft_libs" - -AC_SUBST(fft_libs) -AC_SUBST(fft_line) - - ] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_hdf5.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_hdf5.m4 deleted file mode 100644 index 476021aa7..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_hdf5.m4 +++ /dev/null @@ -1,261 +0,0 @@ --# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_HDF5], [ -AC_ARG_WITH(hdf5, - [AS_HELP_STRING([--with-hdf5], - [(no|yes|) Use HDF5, if yes configure assumes that a valid installation with version >= 1.8.16 is available, and h5cc and h5fc are in the default executable search path; must be the root folder of a standalone hdf5 installation. (default: no)])], - [if test "$withval" = "no" ; then - with_hdf5=0 - elif test $withval = "yes" ; then - with_hdf5=1 - skip_hdf5_module_check=1 - else - with_hdf5_path="$withval" - skip_hdf5_module_chek=0 - with_hdf5=1 - fi], - [with_hdf5=0]) - -AC_ARG_WITH(hdf5-libs, - [AS_HELP_STRING([--with-hdf5-libs], - [Specify the linker options needed by HDF5 when configure fails to detect them by itself. As value to specify here is usually composed by many substrings it should be enclosed by quotes so to prevent configure failures. (default: no)])], - [if test "$withval" = "no" ; then - with_hdf5_libs=0 - else - with_hdf5_libline="$withval" - with_hdf5_libs=1 - fi], - [with_hdf5_libs=0]) - -AC_ARG_WITH(hdf5-include, - [AS_HELP_STRING([--with-hdf5-include], - [Specify full path the HDF5 include folder containing module and headers files. Use it if configure fails to detect the path by itself. (default: no)])], - [if test "$withval" = "no" ; then - with_hdf5_include=0 - else - with_hdf5_include_line="$withval" - with_hdf5_include=1 - fi], - [with_hdf5_include=0]) - - - - -hdf5_libs="" -have_hdf5=0 - - -if test "$use_parallel" -ne 0; then - - if test "$with_hdf5" -ne 0 && test "$with_hdf5_path" != "yes"; then - - # Checking compiler compatibility: GCC >= 4.9 - if test "x$f90_in_mpif90" = xgfortran && - test "$f90_major_version" -le "4" && - test "$f90_minor_version" -lt "9" ; then - - AC_MSG_RESULT(no) - AC_MSG_WARN([*** HDF5 support requires GNU GFORTRAN >= 4.9 ]) - else - - # Test if it is really installed where it has been specified - AC_LANG_POP(Fortran 77) - AC_LANG_PUSH(C) - - if test -e $with_hdf5_path/bin/h5pcc; then - h5cc=$with_hdf5_path/bin/h5pcc; - elif test -e $with_hdf5_path/bin/h5cc ; then - h5cc=$with_hdf5_path/bin/h5cc; - elif command -v h5pcc > /dev/null; then - h5cc=$(command -v h5pcc) - elif command -v h5cci > /dev/null; then - h5cc=$(command -v h5cc) - else - h5cc=$CC; - fi - ac_compile='$h5cc -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' - ac_link='$h5cc -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' - - try_libdirs="$with_hdf5_path/lib" - for dir in $try_libdirs - do - unset ac_cv_search_H5Fcreate - - if test "$dir" = "none" - then - try_loption= - else - try_loption="-L$dir" - fi - - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - #LIBS="-lhdf5" - LIBS="" - - AC_SEARCH_LIBS(H5Fcreate, hdf5 hdf5_fortran, [have_hdf5=1]) - - if test "$ac_cv_search_H5Fcreate" != "no" - then break ; fi - done - - AC_LANG_POP(C) - AC_LANG_PUSH(Fortran 77) - - if test "$have_hdf5" -eq 1 ; then - if test "$with_hdf5_include" -eq 1 ; then - AC_CHECK_FILE($with_hdf5_include_line/hdf5.mod,,[ - AC_MSG_WARN([***HDF5 Fortran extensions not found]) - have_hdf5=0]) - elif skip_hdf5_module_chek -eq 0; then - AC_CHECK_FILE($with_hdf5_path/include/hdf5.mod,,[ - AC_MSG_WARN([***HDF5 Fortran extensions not found]) - have_hdf5=0]) - fi - fi - if test "$have_hdf5" -eq 1; then - version=`grep "HDF5 Version" $with_hdf5_path/lib/libhdf5.settings | cut -d: -f2` - major=`echo $version | cut -d. -f2` - minor=`echo $version | cut -d. -f3` - if test "$major" -lt 8 || (test "$major" -eq 8 && test "$minor" -lt 16); then - AC_MSG_WARN([ HDF5 version: 1.$major.$minor]); - AC_MSG_WARN([*** HDF5 version must be 1.8.16 or later]); - have_hdf5=0; - fi - fi - - if test "$have_hdf5" -eq 1 ; then - if test -e $with_hdf5_path/bin/h5pfc; then - if test $with_hdf5_libs -eq 1; then - hdf5_libs=$with_hdf5_libline - else - hdf5_libs=`$with_hdf5_path/bin/h5pfc -show | awk -F'-L' '{@S|@1=""; for (i=2; i<=NF;i++) @S|@i="-L"@S|@i; print @S|@0}'` - fi - elif command -v h5pfc >/dev/null; then - if test $with_hdf5_libs -eq 1; then - hdf5_libs=$with_hdf5_libline - else - hdf5_libs=`h5pfc -show | awk -F'-L' '{@S|@1=""; for (i=2; i<=NF;i++) @S|@i="-L"@S|@i; print @S|@0}'` - fi - - elif test -e $with_hdf5_path/bin/h5fc; then - if test $with_hdf5_libs -eq 1; then - hdf5_libs=$with_hdf5_libline - else - hdf5_libs=`$with_hdf5_path/bin/h5fc -show | awk -F'-L' '{@S|@1=""; for (i=2; i<=NF;i++) @S|@i="-L"@S|@i; print @S|@0}'` - fi - try_dflags="$try_dflags -D__HDF5_SERIAL" - elif command -v h5fc>/dev/null; then - if test $with_hdf5_libs -eq 1; then - hdf5_libs=$with_hdf5_libline - else - hdf5_libs=`h5fc -show | awk -F'-L' '{@S|@1=""; for (i=2; i<=NF;i++) @S|@i="-L"@S|@i; print @S|@0}'` - fi - try_dflags="$try_dflags -D__HDF5_SERIAL" - - else - if test $with_hdf5_libs -eq 1; then - hdf5_libs=$with_hdf5_libline - else - hdf5_libs="-L$with_hdf5_path/lib -lhdf5_fortran -lhdf5 -lrt -lz -ldl -lm -Wl,-rpath -Wl,$with_hdf5_path/lib" - fi - fi - if test $with_hdf5_include -eq 1; then - try_iflags="$try_iflags -I$with_hdf5_include_line" - else - try_iflags="$try_iflags -I$with_hdf5_path/include" - fi - try_dflags="$try_dflags -D__HDF5" - fi - - hdf5_line="HDF5_LIBS=$hdf5_libs" - fi - fi -else - if test "$with_hdf5" -ne 0 && test "$with_hdf5_path" != "yes"; then - - # Checking compiler compatibility: GCC >= 4.9 - if test "x$f90" = xgfortran && - test "$f90_major_version" -le "4" && - test "$f90_minor_version" -lt "9" ; then - - AC_MSG_RESULT(no) - AC_MSG_WARN([*** HDF5 support requires GNU GFORTRAN >= 4.9 ]) - else - - # Test if it is really installed where it has been specified - AC_LANG_POP(Fortran 77) - AC_LANG_PUSH(C) - - if test -e $with_hdf5_path/bin/h5cc ; then - h5cc=$with_hdf5_path/bin/h5cc; - else - h5cc=$CC; - fi - ac_compile='$h5cc -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' - ac_link='$h5cc -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' - - try_libdirs="$with_hdf5_path/lib" - for dir in $try_libdirs - do - unset ac_cv_search_H5Fcreate - - if test "$dir" = "none" - then - try_loption= - else - try_loption="-L$dir" - fi - - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - #LIBS="-lhdf5" - LIBS="" - - AC_SEARCH_LIBS(H5Fcreate, hdf5 hdf5_fortran, [have_hdf5=1]) - - if test "$ac_cv_search_H5Fcreate" != "no" - then break ; fi - done - - AC_LANG_POP(C) - AC_LANG_PUSH(Fortran 77) - - if test "$have_hdf5" -eq 1 ; then - AC_CHECK_FILE($with_hdf5_path/include/hdf5.mod,,[ - AC_MSG_WARN([***HDF5 Fortran extensions not found]) - have_hdf5=0]) - fi - if test "$have_hdf5" -eq 1; then - version=`grep "HDF5 Version" $with_hdf5_path/lib/libhdf5.settings | cut -d: -f2` - major=`echo $version | cut -d. -f2` - minor=`echo $version | cut -d. -f3` - if test "$major" -lt 8 || (test "$major" -eq 8 && test "$minor" -lt 16); then - AC_MSG_WARN([ HDF5 version: 1.$major.$minor]); - AC_MSG_WARN([*** HDF5 version must be 1.8.16 or later]); - have_hdf5=0; - fi - fi - - if test "$have_hdf5" -eq 1 ; then - if test -e $with_hdf5_path/bin/h5fc; then - hdf5_libs=`$with_hdf5_path/bin/h5fc -show | awk -F'-L' '{@S|@1="";@S|@2="-L"@S|@2; print @S|@0}'` - try_dflags="$try_dflags -D__HDF5_SERIAL" - else - hdf5_libs="-L$with_hdf5_path/lib -lhdf5_fortran -lhdf5 -lrt -lz -ldl -lm -Wl,-rpath -Wl,$with_hdf5_path/lib" - fi - try_iflags="$try_iflags -I$with_hdf5_path/include" - try_dflags="$try_dflags -D__HDF5" - fi - - hdf5_line="HDF5_LIBS=$hdf5_libs" - fi - fi - -# AC_MSG_WARN([HDF5 support is for parallel execution only]) -fi - - AC_SUBST(hdf5_libs) - AC_SUBST(hdf5_line) - ] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_lapack.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_lapack.m4 deleted file mode 100644 index f6a113eb0..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_lapack.m4 +++ /dev/null @@ -1,99 +0,0 @@ -# Copyright (C) 2001-2020 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_LAPACK], [ - -if test "$have_mkl" -ne 0 || test "$have_armpl" -ne 0 || test "$have_acml" -ne 0 || test "$have_essl" -ne 0 -then - # MKL or ARM libraries or ACML (obsolete) or ESSL (obsolete?) found: - # no need to check for lapack - have_lapack=1 -else - # check for lapack - have_lapack=0 -fi -# -if test "$have_lapack" -eq 0 -then - if test "$lapack_libs" = "" - then - # check directories in LD_LIBRARY_PATH too - # (maybe they are already searched by default, but I'm not sure) - ld_library_path=`echo $LD_LIBRARY_PATH | sed 's/:/ /g'` - - case "$arch:$f90" in - - necsx:* ) - # NECSX: OBSOLETE? - try_libdirs="/SX/usr/lib /SX/opt/mathkeisan/inst/lib0" - for dir in none $try_libdirs - do - unset ac_cv_search_dspev # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption $blas_libs" - LIBS="" - AC_SEARCH_LIBS(dspev, lapack, have_lapack=1 - lapack_libs="$try_loption $LIBS") - if test "$ac_cv_search_dspev" != "no" - then break ; fi - done - ;; - esac - - if test "$have_lapack" -eq 0 - then - # generic check for lapack (in several directories) - try_libdirs="/usr/local/lib" - try_libdirs="$libdirs $try_libdirs $ld_library_path" - - for dir in none $try_libdirs - do - unset ac_cv_search_dspev # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="$blas_libs" - AC_SEARCH_LIBS(dspev, lapack-3 lapack, have_lapack=1 - lapack_libs="$try_loption $LIBS") - done - fi - - else - # lapack provided in LAPACK_LIBS: not checked - echo setting LAPACK from \$LAPACK_LIBS with no check ... $lapack_libs - have_lapack=1 - fi - -fi - -# No lapack library found: use internal lapack - -if test "$have_lapack" -eq 0 ; then - lapack_libs="\$(TOPDIR)/LAPACK/liblapack.a" - echo setting LAPACK to internal library ... $lapack_libs - lapack_libs_switch="internal" -else - lapack_libs_switch="external" -fi -lapack_line="LAPACK_LIBS=$lapack_libs" - -AC_SUBST(lapack_libs) -AC_SUBST(lapack_libs_switch) -AC_SUBST(lapack_line) - -AC_CONFIG_FILES(install/make_lapack.inc) - - ] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_ld.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_ld.m4 deleted file mode 100644 index d8bc14cd0..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_ld.m4 +++ /dev/null @@ -1,20 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_LD], [ - -# linker and archiver -# note that from this point on, further additions to -# linker flags should be added to ldflags rather than try_ldflags -if test "$ld" = "" ; then ld="$mpif90" ; fi -if test "$ldflags" = "" ; then ldflags="$try_ldflags" ; fi -echo setting LD... $ld -echo setting LDFLAGS... $ldflags - -# compilation flags for all subsequent tests -test_ldflags="`echo $ldflags | sed 's/\$([[^)]]*)//g'`" - -AC_SUBST(ld) -AC_SUBST(ldflags) - - ] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_libxc.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_libxc.m4 deleted file mode 100644 index 099e9d72f..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_libxc.m4 +++ /dev/null @@ -1,131 +0,0 @@ -## Copyright (C) 2010-2015 M. Marques, X. Andrade, D. Strubbe, M. Oliveira -## -## This program is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as published by -## the Free Software Foundation; either version 2, or (at your option) -## any later version. -## -## This program is distributed in the hope that it will be useful, -## but WITHOUT ANY WARRANTY; without even the implied warranty of -## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -## GNU General Public License for more details. -## -## You should have received a copy of the GNU General Public License -## along with this program; if not, write to the Free Software -## Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -## 02110-1301, USA. -## -## $Id: libxc.m4 12311 2016-04-19 20:52:52Z dstrubbe $ -## - -## Modified by D. Ceresoli to work with Quantum-Espresso - -AC_DEFUN([ACX_LIBXC], [ -acx_libxc_ok=no - -AC_ARG_WITH(libxc, - [AS_HELP_STRING([--with-libxc], - [(yes|no) Use libXC for some XC functionals (default: no)])], - [if test "$withval" = "no" ; then - with_libxc=0 - else - with_libxc=1 - fi], - [with_libxc=0] -) - -AC_ARG_WITH(libxc-prefix, [AS_HELP_STRING([--with-libxc-prefix=DIR], [Directory where libxc was installed.])]) -AC_ARG_WITH(libxc-include, [AS_HELP_STRING([--with-libxc-include=DIR], [Directory where libxc Fortran headers were installed.])]) - -dnl continue only if --with-libxc=yes -if test "$with_libxc" -ne 0; then - -lxcf="f03" -lxcf2="f03" -if test ! -z "$with_libxc_prefix"; then -lxc_version=`grep "XC_MAJOR_VERSION" "$with_libxc_prefix/xc_version.h" | tr -dc '1-9'` -if test "$lxc_version" = 5; then - lxcf="f90" - lxcf2="f90" -fi -if test "$lxc_version" -gt 5; then - lxcf="f90" - lxcf2="f03" -fi -fi - -dnl Set FCFLAGS_LIBXC only if not set from environment -if test x"$FCFLAGS_LIBXC" = x; then - case $with_libxc_prefix in - "") FCFLAGS_LIBXC="$imod/usr/include" ;; - *) FCFLAGS_LIBXC="$imod$with_libxc_prefix/include" ;; - esac -fi - -case $with_libxc_include in - "") ;; - *) FCFLAGS_LIBXC="$imod$with_libxc_include" ;; -esac - -dnl Backup LIBS and FCFLAGS -acx_libxc_save_LIBS="$LIBS" -acx_libxc_save_FCFLAGS="$FCFLAGS" - -dnl The tests -AC_MSG_CHECKING([for libxc]) -AC_LANG_PUSH(Fortran) -FCFLAGS="$FCFLAGS_LIBXC $acx_libxc_save_FCFLAGS" - -testprog="AC_LANG_PROGRAM([],[ - use xc_${lxcf2}_lib_m - implicit none - integer :: major - integer :: minor - integer :: micro - call xc_${lxcf2}_version(major, minor, micro)])" - -dnl set from environment variable, if not blank -LDFLAGS_KEEP="$LDFLAGS" -LDFLAGS="" - -if test ! -z "$LIBS_LIBXC"; then - LIBS="$LIBS_LIBXC" - AC_LINK_IFELSE($testprog, [acx_libxc_ok=yes], []) - LIBS="$LIBS_LIBXC $acx_libxc_save_LIBS" -fi - -if test ! -z "$with_libxc_prefix"; then - if test x"$acx_libxc_ok" = xno; then - LIBS_LIBXC="-L$with_libxc_prefix/lib -lxc$lxcf -lxc" - LIBS="$LIBS_LIBXC" - AC_LINK_IFELSE($testprog, [acx_libxc_ok=yes], []) - LIBS="$LIBS_LIBXC $acx_libxc_save_LIBS" - fi -else - LIBS_LIBXC="-lxc$lxcf -lxc" - LIBS="$LIBS_LIBXC" - AC_LINK_IFELSE($testprog, [acx_libxc_ok=yes], []) - LIBS="$LIBS_LIBXC $acx_libxc_save_LIBS" -fi - -AC_MSG_RESULT([$acx_libxc_ok ($FCFLAGS_LIBXC $LIBS_LIBXC)]) -LDFLAGS="$LDFLAGS_KEEP" - -dnl Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: -libxc_line="@delete@" -if test x"$acx_libxc_ok" = xyes; then - try_dflags="$try_dflags -D__LIBXC" - try_iflags="$try_iflags $FCFLAGS_LIBXC" - AC_SUBST(LIBS_LIBXC) - libxc_line="LIBXC_LIBS= $LIBS_LIBXC" - AC_SUBST(libxc_line) -else - AC_MSG_ERROR([Could not find required libxc library.]) -fi - -AC_LANG_POP(Fortran) - -fi dnl with_libxc=yes -]) - - diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_mass.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_mass.m4 deleted file mode 100644 index 19f93b581..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_mass.m4 +++ /dev/null @@ -1,121 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_MASS], [ - - AC_MSG_CHECKING([MASS]) - - # check for IBM mass -if test "$mass_libs" = "" -then - # check directories in LD_LIBRARY_PATH too - # (maybe they are already searched by default, but I'm not sure) - ld_library_path=`echo $LD_LIBRARY_PATH | sed 's/:/ /g'` - - case "$arch" in - ppc64-bg ) - # check for mass (in several directories) - try_libdirs="/opt/ibmcmp/xlmass/bg/7.3/bglib64 /opt/ibmcmp/xlmass/bg/4.4/bglib /cineca/lib /cineca/lib/mass" - try_libdirs="$libdirs $try_libdirs $ld_library_path" - - for dir in none $try_libdirs - do - unset ac_cv_search_vexp # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - AC_SEARCH_LIBS(vexp, massvp4 massv, , , -lmass) - if test "$ac_cv_search_vexp" = "-lmassvp4" \ - -o "$ac_cv_search_vexp" = "-lmassv" - then mass_libs="$try_loption $ac_cv_search_vexp -lmass" - fi - if test "$ac_cv_search_vexp" != "no" ; then break ; fi - done - ;; - ppc64-bgq ) - # check for mass (in several directories) - try_libdirs="/opt/ibmcmp/xlmass/bg/7.3/bglib64" - try_libdirs="$libdirs $try_libdirs $ld_library_path" - - for dir in none $try_libdirs - do - unset ac_cv_search_vexp # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - AC_SEARCH_LIBS(vexp, massv, , , -lmass_simd) - if test "$ac_cv_search_vexp" = "-lmassv" - then mass_libs="$try_loption $ac_cv_search_vexp -lmass_simd" - fi - if test "$ac_cv_search_vexp" != "no" ; then break ; fi - done - ;; - - ppc64* ) - # check for mass (in several directories) - try_libdirs="/usr/local/lib /opt/ibmcmp/xlmass/*/lib64" - try_libdirs="$libdirs $try_libdirs $ld_library_path" - - for dir in none $try_libdirs - do - unset ac_cv_search_vexp # clear cached value - if test "$dir" = "none" - then - try_loption= - else - echo $ECHO_N "in $dir: " $ECHO_C - try_loption="-L$dir" - fi - FFLAGS="$test_fflags" - LDFLAGS="$test_ldflags $try_loption" - LIBS="" - AC_SEARCH_LIBS(vexp, massvp4_64, , , -lmass_64) - if test "$ac_cv_search_vexp" = "-lmassvp4_64" - then mass_libs="$try_loption $ac_cv_search_vexp -lmass_64" - fi - if test "$ac_cv_search_vexp" != "no" ; then break ; fi - done - ;; - - esac -fi - -if test "$mass_libs" != ""; then - try_dflags="$try_dflags -D__MASS" - if test "$arch" = "ppc64-bg"; then - # BlueGene wants this when mass libs are loaded, SP6 doesn't want this! - ldflags="$ldflags -Wl,--allow-multiple-definition" - fi - if test "$arch" = "ppc64-bgq"; then - # BlueGene wants this when mass libs are loaded, SP6 doesn't want this! - ldflags="$ldflags -Wl,--allow-multiple-definition" - fi -fi - -# Configuring output message -if test "$mass_libs" != "" ; then - mass_line="MASS_LIBS=$mass_libs" -else - mass_line="@delete@" -fi - - AC_MSG_RESULT(${mass_libs}) - - AC_SUBST(mass_libs) - AC_SUBST(mass_line) - - ] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_mpi.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_mpi.m4 deleted file mode 100644 index 15c7594cf..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_mpi.m4 +++ /dev/null @@ -1,65 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_MPI], [ - -have_mpi=0 -parallel=0 - -# some architectures require to link mpi libraries explicitly -F77=$mpif90 # use parallel compiler -if test "$mpi_libs" = "" -then - # check directories in LD_LIBRARY_PATH too - # (maybe they are already searched by default, but I'm not sure) - ld_library_path=`echo $LD_LIBRARY_PATH | sed 's/:/ /g'` - - if test "$use_parallel" -ne 0 - then - if test "$have_mpi" -eq 0 - # check for mpi - then - unset ac_cv_search_mpi_init # clear cached value - LDFLAGS="$test_ldflags" - LIBS="$mpi_libs" - AC_SEARCH_LIBS(mpi_init, mpi, - have_mpi=1 parallel=1 mpi_libs="$LIBS" try_dflags="$try_dflags -D__MPI -D__PARA") - fi - fi -else - if test "$use_parallel" -ne 0 - then - have_mpi=1 - parallel=1 - try_dflags="$try_dflags -D__MPI -D__PARA" - fi -fi - -# Configuring output message -if test "$mpi_libs" != "" ; then - mpi_line="MPI_LIBS=$mpi_libs" -else - mpi_line="@delete@" -fi - -# Parallel report -if test "$use_parallel" -ne 0 -then - if test "$parallel" -ne 0 - then - parallel_report="Parallel environment detected successfully.\\ -Configured for compilation of parallel executables." - else - parallel_report="Parallel environment not detected \ -\(is this a parallel machine?\).\\ -Configured for compilation of serial executables." - fi -else - parallel_report="Configured for compilation of serial executables." -fi - - AC_SUBST(mpi_libs) - AC_SUBST(mpi_line) - AC_SUBST(parallel_report) - - ] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_mpif90.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_mpif90.m4 deleted file mode 100644 index 90f0c838b..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_mpif90.m4 +++ /dev/null @@ -1,218 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_MPIF90], [ -AC_REQUIRE([AC_PROG_FC]) -AC_ARG_ENABLE(parallel, - [AS_HELP_STRING([--enable-parallel], - [compile for parallel execution if possible (default: yes)])], - [set_use_parallel=1 - if test "$enableval" = "yes" ; then - use_parallel=1 - else - use_parallel=0 - fi], - [set_use_parallel=0 use_parallel=1]) - -# candidate fortran compilers good for all cases -try_mpif90="mpif90" -try_f90="gfortran f90" - -# candidate compilers and flags based on architecture -case $arch in -ia32 | ia64 | x86_64 ) - try_f90="ifort nvfortran pgf90 nagfor $try_f90" - try_mpif90="mpiifort $try_mpif90" - ;; -arm ) - try_f90="nvfortran pgf90 armflang $try_f90" - ;; -crayxt* ) - try_f90="ftn" - try_mpif90="ftn" - ;; -mac686 | cygwin ) - try_f90="ifort $try_f90" - ;; -mingw* ) - ld="$F90" - # this is set for C/C++, but we need it for Fortran, too. - try_dflags="-D_WIN32" - ;; -necsx ) - # most likely the following generates a bug - sxopt=`echo $host|awk '{print substr($1,1,3)}'` - echo $sxopt $host - try_mpif90="sxmpif90" - try_f90="sxf90" - try_dflags='-D__SX6 ' - use_fft_asl=0 - use_fft_mathkeisan=1 - use_fft_para=0 -# default for Nec: no parallel unless explicitly required - if test "$set_use_parallel" -ne 1 ; then use_parallel=0 ; fi - if test "$use_parallel" -eq 1 ; then use_fft_para=1 ; fi - try_dflags_fft_asl='-DASL' - try_dflags_fft_mathkeisan=' ' - try_dflags_fft_para='-D__USE_3D_FFT' - ;; -ppc64 ) - try_mpif90="mpxlf90_r mpf90_r mpif90" - try_f90="xlf90_r $try_f90" - ;; -# PowerPC little endian -ppc64le ) - try_mpif90="$try_mpif90 mpixlf" - try_f90="xlf90_r" - ;; -# IBM BlueGene - obsolete -ppc64-bg | ppc64-bgq ) - if test "$use_openmp" -eq 0 ; then - try_mpif90="mpixlf90" - try_f90="bgxlf90" - else - try_mpif90="mpixlf90_r" - # Executable paths are usually consistent across several - # IBM BG/P BG/Q machine deployed - ld="/bgsys/drivers/ppcfloor/comm/xl.ndebug/bin/mpixlf90_r" - try_f90="bgxlf90_r" - fi - try_arflags="ruv" - ;; -* ) - AC_MSG_WARN($arch : unsupported architecture?) - ;; -esac - -# check Fortran 90 compiler - -# clear cached values -unset FC ac_cv_prog_ac_ct_FC ac_cv_fc_compiler_gnu ac_cv_prog_fc_g - -if test "$use_parallel" -eq 0 ; then -# serial case - use F90 if set - if test "$f90" = "" ; then - mpif90="$try_f90" - else - mpif90="$f90" - fi -else -# parallel case - use MPIF90 if set - if test "$mpif90" = "" ; then - mpif90="$try_mpif90 $f90 $try_f90 " - fi - if test "$f90" != "" ; then - AC_MSG_WARN([F90 value is set to be consistent with value of MPIF90]) - fi -fi - -AC_PROG_FC($mpif90) -# this avoids that an empty MPIF90 field is produced if the corresponding -# environment variable MPIF90 does not contain an acceptable compiler -if test "$FC" = "" ; then - AC_MSG_WARN([MPIF90 not found: using MPIF90 anyway]) - FC=$mpif90 -fi -mpif90=$FC - -# check which compiler does mpif90 wrap - -case "$arch" in - * ) - echo $ECHO_N "checking version of $mpif90... $ECHO_C" - ifort_version=`$mpif90 -V 2>&1 | grep "Intel(R)"` - pgf_version=`$mpif90 -V 2>&1 | grep "^pgf"` - nvfortran_version=`$mpif90 -V 2>&1 | grep "^nvfortran"` - gfortran_version=`$mpif90 -v 2>&1 | grep "gcc version"` - nagfor_version=`$mpif90 -v 2>&1 | grep "NAG Fortran"` - xlf_version=`$mpif90 -v 2>&1 | grep "xlf"` - armflang_version=`$mpif90 -v 2>&1 | grep "Arm C/C++/Fortran Compiler version"` - # - if test "$ifort_version" != "" - then - version=`$mpif90 --version 2>&1 | grep "IFORT" | cut -d ' ' -f3` - f90_major_version=`echo $version | cut -d. -f1` - echo "${ECHO_T}ifort $f90_major_version" - f90_in_mpif90="ifort" - elif test "$nvfortran_version" != "" - then - version=`echo $nvfortran_version | cut -d ' ' -f2` - echo "${ECHO_T}nvfortran $version" - f90_in_mpif90="nvfortran" - elif test "$pgf_version" != "" - then - version=`echo $pgf_version | cut -d ' ' -f2` - echo "${ECHO_T}pgf90 $version" - f90_in_mpif90="pgf90" - elif test "$gfortran_version" != "" - then - version=`echo $gfortran_version | cut -d ' ' -f3` - f90_major_version=`echo $version | cut -d. -f1` - f90_minor_version=`echo $version | cut -d. -f2` - echo "${ECHO_T}gfortran $f90_major_version.$f90_minor_version" - f90_in_mpif90="gfortran" - elif test "$nagfor_version" != "" - then - # NAG 6.0 has the codename attached to version number... annoying - version=`echo $nagfor_version | cut -d ' ' -f5` - echo "${ECHO_T}nagfor $version" - f90_in_mpif90="nagfor" - elif test "$xlf_version" != "" - then - echo "${ECHO_T}xlf (version unknonw)" - f90_in_mpif90="xlf90_r" - try_dflags="-D__XLF" - elif test "$armflang_version" != "" - then - version=`echo $armflang_version | cut -d" " -f 5` - f90_major_version=`echo $version | cut -d. -f1` - f90_minor_version=`echo $version | cut -d. -f2` - f90_in_mpif90="armflang" - try_foxflags="-D__PGI" - else - echo "${ECHO_T}unknown, assuming gfortran" - f90_in_mpif90="gfortran" - fi - # notify if serial and parallel compiler are the same - if test "$set_use_parallel" -eq 1 ; then - if test "$mpif90" = "$f90_in_mpif90"; then - AC_MSG_WARN([parallel and serial compiler are the same]) - fi - fi - f90=$f90_in_mpif90 - ;; -esac -AC_FC_SRCEXT(f90) - -echo setting F90... $f90 -echo setting MPIF90... $mpif90 - -# For cray compiler -case "$f90" in -f90 | fc | ftn ) - echo $ECHO_N "checking version wrapped by $f90 command... $ECHO_C" - - if $f90 -V 2>&1 | grep -q "Intel(R)" ; then - f90_flavor=ifort - elif $f90 -V 2>&1 | grep -q "^pgf" ; then - f90_flavor=pgf - elif $f90 -v 2>&1 | grep -q "gcc version" ; then - f90_flavor=gfortran - elif $f90 -V 2>&1 | grep -q "Cray Fortran" ; then - f90_flavor=crayftn - elif $f90 -version 2>&1 | grep -q "NAG Fortran" ; then - f90_flavor=nagfor - else - echo $ECHO_N "unknown, leaving as... $ECHO_C" - f90_flavor=$f90 - fi - echo $f90_flavor - ;; -* ) - f90_flavor=$f90 - ;; -esac - -AC_SUBST(f90) -AC_SUBST(mpif90) - -]) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_openmp.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_openmp.m4 deleted file mode 100644 index c04cd2ae8..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_openmp.m4 +++ /dev/null @@ -1,15 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_OPENMP], [ - -AC_ARG_ENABLE(openmp, - [AS_HELP_STRING([--enable-openmp], - [compile for openmp execution if possible (default: no)])], - [if test "$enableval" = "yes" ; then - use_openmp=1 - else - use_openmp=0 - fi], - [use_openmp=0]) - -]) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_ranlib.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_ranlib.m4 deleted file mode 100644 index bcf46b535..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_ranlib.m4 +++ /dev/null @@ -1,20 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation -# -AC_DEFUN([X_AC_QE_RANLIB], [ - - - if test "$ranlib" != "echo" - then - AC_CHECK_PROG(ranlib,ranlib,ranlib,echo) - fi - - if test "$arch" = "mac686"; then - if test "$ranlib" = "ranlib"; then - ranlib="ranlib -c" - fi - fi - - AC_SUBST(ranlib) - - ] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_scalapack.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_scalapack.m4 deleted file mode 100644 index 3c5dd5718..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_scalapack.m4 +++ /dev/null @@ -1,105 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_SCALAPACK], [ - -have_scalapack=0 - -AC_ARG_WITH(scalapack, - [AS_HELP_STRING([--with-scalapack], - [(yes|no|intel) Use scalapack if available. Set to "intel" to use Intel MPI and blacs (default: use openMPI)])], - [if test "$withval" = "yes" ; then - with_scalapack=1 - elif test "$withval" = "intel" ; then - with_scalapack=2 - elif test "$withval" = "no" ; then - with_scalapack=0 - fi], - [with_scalapack=1]) - -# final check on availability of parallel environment -for dummy in x # to allow simple 'break' -do - test "$have_mpi" -eq 0 && break - - F77=$mpif90 - LIBS="$mpi_libs" - -# look for scalapack if required - test "$with_scalapack" -eq 0 && break - if test "$scalapack_libs" = "" ; then -# no additional libraries needed - AC_SEARCH_LIBS(pdgemr2d, "" , have_scalapack=1 - try_dflags="$try_dflags -D__SCALAPACK") - test "$have_scalapack" -eq 1 && break - -if test "$have_mkl" -eq 1 - then - unset ac_cv_search_pdgemr2d # clear cached value - LIBS="$mpi_libs $blas_libs" - if test $with_scalapack -eq 1; then - scalapack_libs=-lmkl_blacs_openmpi_lp64 - else - scalapack_libs=-lmkl_blacs_intelmpi_lp64 - fi - AC_SEARCH_LIBS(pdgemr2d, "mkl_scalapack_lp64" , have_scalapack=1 - try_dflags="$try_dflags -D__SCALAPACK" - scalapack_libs="-lmkl_scalapack_lp64 $scalapack_libs", - , - "$scalapack_libs" ) - test "$have_scalapack" -eq 1 && break -fi -# -# sci libraries (e.g. cray xt) - unset ac_cv_search_pdgemr2d # clear cached value - scalapack_libs="-lsci" - LIBS="$mpi_libs $scalapack_libs" - AC_SEARCH_LIBS(pdgemr2d, "" , have_scalapack=1 - try_dflags="$try_dflags -D__SCALAPACK") - test "$have_scalapack" -eq 1 && break -# scalapack (including blacs), no -L options - unset ac_cv_search_pdgemr2d # clear cached value - scalapack_libs="-lscalapack" - LIBS="$mpi_libs $scalapack_libs" - LDFLAGS="" - AC_SEARCH_LIBS(pdgemr2d, "" , have_scalapack=1 - try_dflags="$try_dflags -D__SCALAPACK") - test "$have_scalapack" -eq 1 && break -# scalapack + blacs, no -L options - unset ac_cv_search_pdgemr2d # clear cached value - blacs_libs="-lblacs -lblacsF77init -lblacs" - scalapack_libs="-lscalapack $blacs_libs" - LIBS="$mpi_libs $scalapack_libs" - LDFLAGS="" - AC_SEARCH_LIBS(pdgemr2d, "" , have_scalapack=1 - try_dflags="$try_dflags -D__SCALAPACK") - test "$have_scalapack" -eq 1 && break -# scalapack + blacs with -L options - unset ac_cv_search_pdgemr2d # clear cached value - if test "$scalapack_dir" = ""; then scalapack_dir="/bgsys/local/scalapack/lib"; fi - if test "$blacs_dir" = ""; then blacs_dir="/bgsys/local/blacs/lib"; fi - blacs_libs="-L$blacs_dir -lblacs -lblacsF77init -lblacs" - scalapack_libs="-L$scalapack_dir -lscalapack $blacs_libs" - LIBS="$mpi_libs $scalapack_libs" - LDFLAGS="" - AC_SEARCH_LIBS(pdgemr2d, "" , have_scalapack=1 - try_dflags="$try_dflags -D__SCALAPACK") - else - # scalapack provided in SCALAPACK_LIBS - not checked! - have_scalapack=1 - try_dflags="$try_dflags -D__SCALAPACK" - fi -done - -# Configuring output message -if test "$have_scalapack" -eq 1; then - scalapack_line="SCALAPACK_LIBS=$scalapack_libs" -else - scalapack_libs="" - scalapack_line="@delete@" -fi - - AC_SUBST(scalapack_libs) - AC_SUBST(scalapack_line) - - ] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_signal.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_signal.m4 deleted file mode 100644 index 67a1f2105..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_signal.m4 +++ /dev/null @@ -1,19 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_SIGNAL], [ - - AC_ARG_ENABLE(signals, - [AS_HELP_STRING([--enable-signals], - [enable signal trapping (default: no)])], - [if test "$enableval" = "yes" ; then - use_signals=1 - else - use_signals=0 - fi], - [use_signals=0]) - - # preprocessing flag for signal trapping (experimental) - if test "$use_signals" -eq 1 ; then try_dflags="$try_dflags -D__TRAP_SIGUSR1" ; fi - - ] -) diff --git a/quantum_espresso/kcp/install/m4/x_ac_qe_wget.m4 b/quantum_espresso/kcp/install/m4/x_ac_qe_wget.m4 deleted file mode 100644 index 78da40ab5..000000000 --- a/quantum_espresso/kcp/install/m4/x_ac_qe_wget.m4 +++ /dev/null @@ -1,14 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO Foundation - -AC_DEFUN([X_AC_QE_WGET], [ - - AC_CHECK_PROG(wget, wget, wget -O) - if test "$wget" = ""; then - AC_CHECK_PROG(wget, curl, curl -o) - fi - echo setting WGET... $wget - - AC_SUBST(wget) - - ] -) diff --git a/quantum_espresso/kcp/install/make-w90 b/quantum_espresso/kcp/install/make-w90 deleted file mode 100644 index e69de29bb..000000000 diff --git a/quantum_espresso/kcp/install/make.inc.in b/quantum_espresso/kcp/install/make.inc.in deleted file mode 100644 index 39fb15f15..000000000 --- a/quantum_espresso/kcp/install/make.inc.in +++ /dev/null @@ -1,138 +0,0 @@ -# @configure_input@ - -# compilation rules - -.SUFFIXES : -.SUFFIXES : .o .c .f .f90 - -# most fortran compilers can directly preprocess c-like directives: use -# $(MPIF90) $(F90FLAGS) -c $< -# if explicit preprocessing by the C preprocessor is needed, use: -# $(CPP) $(CPPFLAGS) $< -o $*.F90 -# $(MPIF90) $(F90FLAGS) -c $*.F90 -o $*.o -# remember the tabulator in the first column !!! - -.f90.o: - @f90rule@ - -# .f.o and .c.o: do not modify - -.f.o: - $(F77) $(FFLAGS) -c $< - -.c.o: - $(CC) $(CFLAGS) -c $< - -@SET_MAKE@ -# DFLAGS = precompilation options (possible arguments to -D and -U) -# used by the C compiler and preprocessor -# FDFLAGS = as DFLAGS, for the f90 compiler -# See include/defs.h.README for a list of options and their meaning -# With the exception of IBM xlf, FDFLAGS = $(DFLAGS) -# For IBM xlf, FDFLAGS is the same as DFLAGS with separating commas - -DFLAGS = @dflags@ -FDFLAGS = @fdflags@ - -# IFLAGS = how to locate directories where files to be included are -# In most cases, IFLAGS = -I../include - -IFLAGS = @iflags@ - -# MODFLAGS = flag used by f90 compiler to locate modules -# You need to search for modules in ./, in ../iotk/src, in ../Modules - -MODFLAGS = @imod@./ @imod@../Modules @imod@../iotk/src - -# Compilers: fortran-90, fortran-77, C -# If a parallel compilation is desired, MPIF90 should be a fortran-90 -# compiler that produces executables for parallel execution using MPI -# (such as for instance mpif90, mpf90, mpxlf90,...); -# otherwise, an ordinary fortran-90 compiler (f90, g95, xlf90, ifort,...) -# If you have a parallel machine but no suitable candidate for MPIF90, -# try to specify the directory containing "mpif.h" in IFLAGS -# and to specify the location of MPI libraries in MPI_LIBS - -MPIF90 = @mpif90@ -#F90 = @f90@ -CC = @cc@ -F77 = @f90@ - -# C preprocessor and preprocessing flags - for explicit preprocessing, -# if needed (see the compilation rules above) -# preprocessing flags must include DFLAGS and IFLAGS - -CPP = @cpp@ -CPPFLAGS = @cppflags@ $(DFLAGS) $(IFLAGS) - -# compiler flags: C, F90, F77 -# C flags must include DFLAGS and IFLAGS -# F90 flags must include MODFLAGS, IFLAGS, and FDFLAGS with appropriate syntax - -CFLAGS = @cflags@ $(DFLAGS) $(IFLAGS) -F90FLAGS = @f90flags@ @pre_fdflags@$(FDFLAGS) $(IFLAGS) $(MODFLAGS) -FFLAGS = @fflags@ - -# compiler flags without optimization for fortran-77 -# the latter is NEEDED to properly compile dlamch.f, used by lapack - -FFLAGS_NOOPT = @fflags_noopt@ - -# Linker, linker-specific flags (if any) -# Typically LD coincides with F90 or MPIF90, LD_LIBS is empty - -LD = @ld@ -LDFLAGS = @ldflags@ -LD_LIBS = - -# External Libraries (if any) : blas, lapack, fft, MPI - -# If you have nothing better, use the local copy : ../flib/blas.a - -BLAS_LIBS = @blas_libs@ - -# The following lapack libraries will be available in flib/ : -# ../flib/lapack.a : contains all needed routines -# ../flib/lapack_atlas.a: only routines not present in the Atlas library -# For IBM machines with essl (-D__ESSL): load essl BEFORE lapack ! -# remember that LAPACK_LIBS precedes BLAS_LIBS in loading order - -LAPACK_LIBS = @lapack_libs@ - -# nothing needed here if the the internal copy of FFTW is compiled -# (needs -D__FFTW in DFLAGS) - -FFT_LIBS = @fft_libs@ - -# For parallel execution, the correct path to MPI libraries must -# be specified in MPI_LIBS (except for IBM if you use mpxlf) - -MPI_LIBS = @mpi_libs@ - -# IBM-specific: MASS libraries, if available and if -D__MASS is defined in FDFLAGS - -MASS_LIBS = @mass_libs@ - -# pgplot libraries (used by some post-processing tools) - -PGPLOT_LIBS = - -# ar command and flags - for most architectures: AR = ar, ARFLAGS = ruv -# ARFLAGS_DYNAMIC is used in iotk to produce a dynamical library, -# for Mac OS-X with PowerPC and xlf compiler. In all other cases -# ARFLAGS_DYNAMIC = $(ARFLAGS) - -AR = @ar@ -ARFLAGS = @arflags@ -ARFLAGS_DYNAMIC= @arflags@ - -# ranlib command. If ranlib is not needed (it isn't in most cases) use -# RANLIB = echo - -RANLIB = @ranlib@ - -# all internal and external libraries - do not modify - -LIBOBJS = ../flib/ptools.a ../flib/flib.a ../clib/clib.a ../iotk/src/libiotk.a -LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FFT_LIBS) $(MPI_LIBS) $(MASS_LIBS) $(PGPLOT_LIBS) $(LD_LIBS) - diff --git a/quantum_espresso/kcp/install/make_lapack.inc.in b/quantum_espresso/kcp/install/make_lapack.inc.in deleted file mode 100644 index a57b5f8d4..000000000 --- a/quantum_espresso/kcp/install/make_lapack.inc.in +++ /dev/null @@ -1,82 +0,0 @@ -#################################################################### -# LAPACK make include file. # -# LAPACK, Version 3.6.1 # -# June 2016 # -#################################################################### -# -SHELL = /bin/sh -# -# Modify the FORTRAN and OPTS definitions to refer to the -# compiler and desired compiler options for your machine. NOOPT -# refers to the compiler options desired when NO OPTIMIZATION is -# selected. Define LOADER and LOADOPTS to refer to the loader and -# desired load options for your machine. -# -# Note: During a regular execution, LAPACK might create NaN and Inf -# and handle these quantities appropriately. As a consequence, one -# should not compile LAPACK with flags such as -ffpe-trap=overflow. -# -FORTRAN = @f90@ -OPTS = @fflags@ -DRVOPTS = $(OPTS) -NOOPT = @fflags_noopt@ -LOADER = @f90@ -LOADOPTS = @ldflags@ -# -# Comment out the following line to include deprecated routines to the -# LAPACK library. -# -# MAKEDEPRECATED = Yes -# BUILD_DEPRECATED = Yes -# -# Timer for the SECOND and DSECND routines -# -# Default : SECOND and DSECND will use a call to the EXTERNAL FUNCTION ETIME -# TIMER = EXT_ETIME -# For RS6K : SECOND and DSECND will use a call to the EXTERNAL FUNCTION ETIME_ -# TIMER = EXT_ETIME_ -# For gfortran compiler: SECOND and DSECND will use a call to the INTERNAL FUNCTION ETIME -# TIMER = INT_ETIME -# If your Fortran compiler does not provide etime (like Nag Fortran Compiler, etc...) -# SECOND and DSECND will use a call to the INTERNAL FUNCTION CPU_TIME -TIMER = INT_CPU_TIME -# If neither of this works...you can use the NONE value... In that case, SECOND and DSECND will always return 0 -# TIMER = NONE -# -# Configuration LAPACKE: Native C interface to LAPACK -# To generate LAPACKE library: type 'make lapackelib' -# Configuration file: turned off (default) -# Complex types: C99 (default) -# Name pattern: mixed case (default) -# (64-bit) Data model: LP64 (default) -# -# CC is the C compiler, normally invoked with options CFLAGS. -# -CC = @cc@ -CFLAGS = @cflags@ -# -# The archiver and the flag(s) to use when building archive (library) -# If you system has no ranlib, set RANLIB = echo. -# -ARCH = @ar@ -ARCHFLAGS= @arflags@ -RANLIB = @ranlib@ -# -# Location of the extended-precision BLAS (XBLAS) Fortran library -# used for building and testing extended-precision routines. The -# relevant routines will be compiled and XBLAS will be linked only if -# USEXBLAS is defined. -# -# USEXBLAS = Yes -XBLASLIB = -# XBLASLIB = -lxblas -# -# The location of the libraries to which you will link. (The -# machine-specific, optimized BLAS library should be used whenever -# possible.) -# -BLASLIB = ../../libblas.a -CBLASLIB = ../../libcblas.a -LAPACKLIB = liblapack.a -TMGLIB = libtmglib.a -LAPACKELIB = liblapacke.a diff --git a/quantum_espresso/kcp/install/make_wannier90.inc.in b/quantum_espresso/kcp/install/make_wannier90.inc.in deleted file mode 100644 index f53e9ad4e..000000000 --- a/quantum_espresso/kcp/install/make_wannier90.inc.in +++ /dev/null @@ -1,11 +0,0 @@ -#======================================= -# WANNIER90 -#======================================= - -TOPDIR = @topdir@ - -F90=@mpif90@ -FCOPTS=@f90flags@ -LDOPTS=@ldflags@ - -LIBS = @lapack_libs@ @blas_libs@ @mass_libs@ diff --git a/quantum_espresso/kcp/install/makedeps.sh b/quantum_espresso/kcp/install/makedeps.sh deleted file mode 100755 index 1216b010e..000000000 --- a/quantum_espresso/kcp/install/makedeps.sh +++ /dev/null @@ -1,173 +0,0 @@ -#!/bin/sh -# compute dependencies for the PWscf directory tree - -# make sure there is no locale setting creating unneeded differences. -LC_ALL=C -export LC_ALL - -# run from directory where this script is -cd `echo $0 | sed 's/\(.*\)\/.*/\1/'` # extract pathname -TOPDIR=`pwd` - -if test $# = 0 -then - dirs=" LAXlib FFTXlib UtilXlib upflib Modules clib LR_Modules \ - KS_Solvers/Davidson KS_Solvers/Davidson_RCI KS_Solvers/CG KS_Solvers/PPCG \ - KS_Solvers/ParO KS_Solvers/DENSE \ - PW/src CPV/src PW/tools PP/src PWCOND/src \ - PHonon/Gamma PHonon/PH PHonon/FD HP/src atomic/src \ - EPW/src XSpectra/src ACFDT/src NEB/src TDDFPT/src \ - GWW/pw4gww GWW/gww GWW/head GWW/bse GWW/simple \ - GWW/simple_bse GWW/simple_ip" - -elif - test $1 = "-addson" -then - echo "The script for adding new dependencies is running" - echo "Usage: $0 -addson DIR DEPENDENCY_DIRS" - echo "$0 assumes that the new dependencies are in $TOPDIR/../" -# ninput=$# -# echo "number of input arguments: $ninput" - dirs=$2 - shift - shift - add_deps=$* - echo "dependencies in $add_deps will be searched for $dirs" -else - dirs=$* -fi - - -for dir in $dirs; do - - # the following command removes a trailing slash - DIR=`echo ${dir%/}` - - # the following would also work - #DIR=`echo $dir | sed "s,/$,,"` - - # set inter-directory dependencies - only directories containing - # modules that are used, or files that are included, by routines - # in directory DIR should be listed in DEPENDS - LEVEL1=.. - LEVEL2=../.. - # default - DEPENDS="$LEVEL1/include" - # for convenience, used later - DEPEND1="$LEVEL1/include $LEVEL1/FFTXlib $LEVEL1/LAXlib $LEVEL1/UtilXlib" - DEPEND2="$LEVEL2/include $LEVEL2/FFTXlib $LEVEL2/LAXlib $LEVEL2/UtilXlib \ - $LEVEL2/Modules $LEVEL2/upflib " - DEPEND3="$LEVEL2/include $LEVEL2/FFTXlib $LEVEL2/LAXlib $LEVEL2/UtilXlib" - case $DIR in - Modules ) - DEPENDS="$DEPEND1 $LEVEL1/UtilXlib $LEVEL1/upflib" ;; - LAXlib ) - DEPENDS="$LEVEL1/UtilXlib " ;; - LR_Modules ) - DEPENDS="$DEPEND1 $LEVEL1/Modules $LEVEL1/upflib $LEVEL1/PW/src" ;; - ACFDT/src ) - DEPENDS="$DEPEND2 $LEVEL2/PW/src $LEVEL2/PHonon/PH $LEVEL2/LR_Modules" ;; - atomic/src | GWW/gww ) - DEPENDS="$DEPEND2" ;; - PW/src | CPV/src ) - DEPENDS="$DEPEND2 ../../KS_Solvers/Davidson ../../KS_Solvers/CG ../../KS_Solvers/PPCG ../../KS_Solvers/ParO ../../KS_Solvers/DENSE ../../dft-d3" ;; - KS_Solvers/Davidson | KS_Solvers/Davidson_RCI | KS_Solvers/CG | KS_Solvers/PPCG | KS_Solvers/ParO | KS_Solvers/DENSE ) - DEPENDS="$DEPEND3" ;; - PW/tools | PP/src | PWCOND/src | GWW/pw4gww | NEB/src ) - DEPENDS="$DEPEND2 $LEVEL2/PW/src" ;; - PHonon/FD | PHonon/PH | PHonon/Gamma | HP/src | TDDFPT/src | XSpectra/src | GIPAW/src ) - DEPENDS="$DEPEND2 $LEVEL2/PW/src $LEVEL2/LR_Modules" ;; - EPW/src ) - DEPENDS="$DEPEND2 $LEVEL2/PW/src $LEVEL2/LR_Modules $LEVEL2/PHonon/PH $LEVEL2/Modules" ;; - GWW/head ) - DEPENDS="$DEPEND2 $LEVEL2/PW/src $LEVEL2/PHonon/PH $LEVEL2/LR_Modules" ;; - GWW/bse ) - DEPENDS="$DEPEND2 $LEVEL2/PW/src $LEVEL2/PHonon/PH $LEVEL2/LR_Modules $LEVEL2/GWW/pw4gww $LEVEL2/GWW/gww" ;; - GWW/simple ) - DEPENDS="$DEPEND2 $LEVEL2/PW/src $LEVEL2/GWW/pw4gww $LEVEL2/GWW/gww" ;; - GWW/simple_bse ) - DEPENDS="$DEPEND2 $LEVEL2/GWW/gww" ;; - GWW/simple_ip) - DEPENDS="$DEPEND2" ;; - *) -# if addson needs a make.depend file - DEPENDS="$DEPENDS $add_deps" - - esac - - # generate dependencies file (only for directories that are present) - if test -d $TOPDIR/../$DIR - then - cd $TOPDIR/../$DIR - - $TOPDIR/moduledep.sh $DEPENDS > make.depend - $TOPDIR/includedep.sh $DEPENDS >> make.depend - - # handle special cases: modules for C-fortran binding, - # hdf5, MPI, FoX, libxc - sed '/@iso_c_binding@/d' make.depend > tmp; mv tmp make.depend - sed '/@hdf5@/d' make.depend > tmp; mv tmp make.depend - sed '/@mpi@/d' make.depend > tmp; mv tmp make.depend - sed '/@fox_dom@/d;/@fox_wxml@/d;/@m_common_io@/d' make.depend > tmp; mv tmp make.depend - sed '/@xc_version.h@/d;/@xc_f03_lib_m@/d' make.depend > tmp; mv tmp make.depend - - if test "$DIR" = "FFTXlib" - then - # more special cases: modules for FFTs, GPU, OpenMP - sed '/@omp_lib@/d' make.depend > tmp; mv tmp make.depend - sed '/@mkl_dfti/d' make.depend > tmp; mv tmp make.depend - sed '/@fftw3.f/d;s/@fftw.c@/fftw.c/' make.depend > tmp; mv tmp make.depend - sed '/@cudafor@/d;/@cufft@/d;/@flops_tracker@/d' make.depend > tmp; mv tmp make.depend - fi - - if test "$DIR" = "LAXlib" - then - # more special cases: modules for ELPA, GPUs - sed '/@elpa1@/d;/@elpa@/d' make.depend > tmp; mv tmp make.depend - sed '/@cudafor@/d;/@cusolverdn@/d;/@gbuffers@/d' make.depend > tmp; mv tmp make.depend - sed '/@zhegvdx_gpu@/d;/@dsyevd_gpu@/d;/@dsygvdx_gpu@/d' make.depend > tmp; mv tmp make.depend - sed '/@cublas@/d;/@eigsolve_vars@/d;/@nvtx_inters@/d' make.depend > tmp ; mv tmp make.depend - sed '/@device_fbuff_m@/d' make.depend > tmp ; mv tmp make.depend - fi - - if test "$DIR" = "UtilXlib" - then - sed '/@ifcore@/d' make.depend > tmp; mv tmp make.depend - sed '/@cudafor@/d' make.depend> tmp; mv tmp make.depend - fi - - - if test "$DIR" = "PW/src" || test "$DIR" = "TDDFPT/src" - then - sed '/@environ_/d;/@solvent_tddfpt@/d' make.depend > tmp; mv tmp make.depend - fi - - if test "$DIR" = "CPV/src" - then - sed '/@f90_unix_proc@/d' make.depend > tmp; mv tmp make.depend - fi - - if test "$DIR" = "EPW/src" - then - sed '/@f90_unix_io@/d' make.depend > tmp; mv tmp make.depend - sed '/@f90_unix_env@/d' make.depend> tmp; mv tmp make.depend - sed '/@w90_io@/d' make.depend > tmp; mv tmp make.depend - sed '/@ifport@/d' make.depend > tmp; mv tmp make.depend - fi - - # check for missing dependencies - if grep @ make.depend - then - notfound=1 - echo WARNING: dependencies not found in directory $DIR - else - echo directory $DIR : ok - fi - else - echo directory $DIR : not present in $TOPDIR - fi -done -if test "$notfound" = "" -then - echo all dependencies updated successfully -fi diff --git a/quantum_espresso/kcp/install/moduledep.sh b/quantum_espresso/kcp/install/moduledep.sh deleted file mode 100755 index 3dc0b76ac..000000000 --- a/quantum_espresso/kcp/install/moduledep.sh +++ /dev/null @@ -1,54 +0,0 @@ -#!/bin/sh -# moduledep.sh -- script that computes dependencies on Fortran 90 modules - -# make sure there is no locale setting creating unneeded differences. -LC_ALL=C -export LC_ALL - -# files whose dependencies must be computed -sources=`echo *.f90 | -sed 's/\*\.f90//g'` # remove the "*.f90" that remains -# # when there are no such files -if test "$sources" = "" ; then exit ; fi - -# files that may contain modules -# extra directories can be specified on the command line -sources_all="$sources" -for dir in $* -do - sources_all="$sources_all `echo $dir/*.f90`" -done -sources_all=`echo $sources_all | -sed 's/[^ ]*\*\.f90//g'` # remove the "dir/*.f90" that remain -# # when there are no such files - -rm -f moduledep.tmp1 moduledep.tmp2 # destroy previous contents - -# create list of module dependencies -# each line is of the form: -# file_name.o : @module_name@ -# cast all module names to lowercase because Fortran is case insensitive -egrep -H -i "^ *use " $sources | # look for "USE name" -sed 's/f90:/o / - s/,/ /' | # replace extension, insert space -# # and remove trailing comma -awk '{print $1 " : @" tolower($3) "@"}' | # create dependency entry -sort | uniq > moduledep.tmp1 # remove duplicates - -# create list of available modules -# for each module, create a line of the form: -# s/@module_name@/file_name/g -egrep -H -i "^ *module " $sources_all | # look for "MODULE name" -sed 's/f90:/o / - s/\//\\\//g' | # replace extension, insert -# # space and escape slashes -awk '{print "s/@" tolower($3) "@/" $1 "/" }' | # create substitution line -sort | uniq > moduledep.tmp2 # remove duplicates - -# replace module names with file names -# by applying the file of substitution patterns just created -sed -f moduledep.tmp2 moduledep.tmp1 | -awk '{if ($1 != $3) print}' | # remove self dependencies -sort | uniq # remove duplicates - -rm -f moduledep.tmp1 moduledep.tmp2 # remove temporary files diff --git a/quantum_espresso/kcp/install/namedep.sh b/quantum_espresso/kcp/install/namedep.sh deleted file mode 100755 index c56bc3790..000000000 --- a/quantum_espresso/kcp/install/namedep.sh +++ /dev/null @@ -1,114 +0,0 @@ -#!/bin/sh -# namedep.sh -- script that computes dependencies on Fortran 90 modules - -# make sure there is no locale setting creating unneeded differences. -LC_ALL=C -export LC_ALL - -# first argument is mandatory -if test $# = 0 -then - echo usage: $0 name [files] - exit 1 -fi - -# run from directory where this script is -cd `echo $0 | sed 's/\(.*\)\/.*/\1/'` # extract pathname - -# module, function or subroutine whose dependencies must be computed -name=$1 -shift - -# list of files to be searched -sources_all=`ls */*.f90` -if test $# = 0 ; then sources="$sources_all" -else sources="$* /dev/null" ; fi - -# search for declaration of $name -# caution: must not select names that _contain_ $name -decls=`egrep -ni -e "^ *subroutine *$name *(\(.*)?$" \ - -e "^ *function *$name *(\(.*)?$" \ - -e "^ *module *$name *$" \ - $sources | sed 's/[:(]/ /g' | awk '{print $1 "@" $2 "@" $4}'` - -num=`echo $decls | wc | awk '{print $2}'` -if test $num = 0 -then - echo error: $name not found - exit 1 -elif test $num -gt 1 -then - # $name is defined in more than one place, must choose one - echo error: there are multiple declarations: - for decl in $decls - do - file=`echo $decl | sed 's/@/ /g' | awk '{print $1}'` - echo " $name [$file]" - done - echo please specify file - exit 1 -fi - -# build list of all module declarations -# list format is: file_name starting_line module_name -egrep -ni "^ *module *[a-zA-Z_][a-zA-Z_]*" $sources_all | -grep -iv procedure | # exclude "module procedure" declarations -sed 's/:/ /g' | awk '{print $1, $2, $4}' > namedep.sh.tmp1 - -decl=`echo $decls | sed 's/@/ /g'` -file=`echo $decl | awk '{print $1}'` -echo $name [$file]: - -# find starting and ending line -start=`echo $decl | awk '{print $2}'` -end=`egrep -ni -e "^ *end *subroutine *$name *$" \ - -e "^ *end *function *$name *$" \ - -e "^ *end *module *$name *$" \ - $file | sed 's/:.*//'` - -# look for use declarations -modules=`sed -n "$start,${end}p" $file | egrep -i "^ *use " | - sed 's/,.*//' | # remove ", only: ..." - awk '{print tolower($2)}' | # cast module name to lowercase - sort | uniq # remove duplicates` - -# look for recursive dependencies -modules_prev="" -until test "$modules_prev" = "$modules" -do - modules_tested="$modules_prev" - modules_prev="$modules" - for module in $modules - do - # skip module if already tested - if test "`echo $modules_tested | tr ' ' '\n' | grep ^$module\$`" = "" - then - mdecl=`egrep -i " $module *$" namedep.sh.tmp1` - file=`echo $mdecl | awk '{print $1}'` - - # find starting and ending line - start=`echo $mdecl | awk '{print $2}'` - end=`egrep -ni "^ *end *module *$module *$" $file | sed 's/:.*//'` - - # look for use declarations - recur=`sed -n "$start,${end}p" $file | egrep -i "^ *use " | - sed 's/,.*//' | # remove ", only: ..." - awk '{print tolower($2)}' | # cast module name to lowercase - sort | uniq # remove duplicates` - modules="$modules $recur" - fi - done - # remove duplicates - modules=`echo $modules | tr " " "\n" | sort | uniq` -done - -# print final list of modules -for module in $modules -do - mdecl=`grep -i $module namedep.sh.tmp1` - file=`echo $mdecl | awk '{print $1}'` - echo " $module [$file]" -done - -# remove temporary file -rm -f namedep.sh.tmp1 diff --git a/quantum_espresso/kcp/install/plugins_list b/quantum_espresso/kcp/install/plugins_list deleted file mode 100644 index 9e0930f97..000000000 --- a/quantum_espresso/kcp/install/plugins_list +++ /dev/null @@ -1,37 +0,0 @@ -# Copyright (C) 2001-2016 Quantum ESPRESSO group -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License. See the file `License' in the root directory -# of the present distribution. - -######################################## -# definition of plugins version and URL -######################################## -# -URL=http://files.qe-forge.org/index.php?file= -RELEASE_VERSION := $(shell awk -F\' '/version_number/{print $$2}' ../include/qe_version.h ) -# -# -# Package maintainer: Andrea Ferretti -WANT=want-want-2.6.1 -WANT_URL=https://github.com/QEF/want/archive/want-2.6.1.tar.gz - -# -# Package maintainer: Andrea Ferretti -YAMBO=yambo-4.5.2 -YAMBO_URL=https://github.com/yambo-code/yambo/archive/4.5.2.tar.gz - -# -# Package maintainer: -W90=wannier90-3.1.0 -W90_URL=https://codeload.github.com/wannier-developers/wannier90/tar.gz/v3.1.0 -# -# Package maintainer: Davide Ceresoli -GIPAW=qe-gipaw-$(RELEASE_VERSION) -GIPAW_URL=https://github.com/dceresoli/qe-gipaw/archive/$(RELEASE_VERSION).tar.gz -# -# Package maintainer: Lorenzo Paulatto -D3Q=d3q-latest -D3Q_URL=https://d3q.sourceforge.io/d3q-qe$(RELEASE_VERSION)-latest.php?outname=d3q-qe$(RELEASE_VERSION)-latest.tgz diff --git a/quantum_espresso/kcp/install/plugins_makefile b/quantum_espresso/kcp/install/plugins_makefile deleted file mode 100644 index b41357ed5..000000000 --- a/quantum_espresso/kcp/install/plugins_makefile +++ /dev/null @@ -1,213 +0,0 @@ -# Copyright (C) 2001-2020 Quantum ESPRESSO group -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License. See the file `License' in the root directory -# of the present distribution. -# -# Makefile for plugins - -sinclude ../make.inc -include plugins_list -include install_utils - -########################################################### -# D3Q -########################################################### - -d3q: uncompress-d3q - if test -d ../D3Q; then \ - cd ../D3Q; $(MAKE) || exit 1; \ - fi - touch make-d3q - -uncompress-d3q: - $(call download_and_unpack,$(D3Q),$(D3Q_URL),D3Q,d3q) - touch uncompress-d3q - -d3q_clean: - if test -d ../D3Q; then (cd ../D3Q; $(MAKE) clean); fi - rm -f ../bin/d3q.x - rm -f ../bin/d3_*.x - rm -f ../bin/diffd3.x - rm -f ../bin/xml2giorgia.x - -d3q_veryclean: d3q_clean - # delete unpacked directory and its links, keep the archive - test -e ../D3Q/protect || \ - (cd ..; \ - i=D3Q; \ - while j=$$(readlink $$i);do rm -rf $$i; i=$$j;done;\ - rm -rf $$i\ - ); - -d3q_distclean: d3q_veryclean - # also delete the tgz archive - rm -f ../archive/$(D3Q); \ - rm -f make-d3q uncompress-d3q - -########################################################## -# GIPAW -########################################################### - -gipaw: uncompress-gipaw configure-gipaw - if test -d ../GIPAW; then \ - cd ../GIPAW; $(MAKE) all || exit 1; cd ../bin; ln -fs ../GIPAW/src/gipaw.x . ; fi - touch make-gipaw - -uncompress-gipaw: - $(call download_and_unpack,$(GIPAW),$(GIPAW_URL),GIPAW,qe-gipaw) - touch uncompress-gipaw - -configure-gipaw: - cd ../GIPAW ; \ - ./configure --with-qe-source=${TOPDIR} - touch ./configure-gipaw - -gipaw_clean: - if test -d ../GIPAW; then (cd ../GIPAW; $(MAKE) clean); fi - rm -f ../bin/gipaw.x - rm -rf ./make-gipaw - -gipaw_veryclean: gipaw_clean - if test -d ../GIPAW; then (cd ../GIPAW; \ - rm -f config.log config.status ); fi - rm -rf ./configure-gipaw - -gipaw_distclean: - #if test -d ../GIPAW; then (rm -R -f ../GIPAW ); fi - #if test -d ../$(GIPAW); then (rm -R -f ../$(GIPAW) ); fi - rm -f ../archive/$(GIPAW).tar.gz - -########################################################### -# wannier90 -########################################################### - -w90: uncompress-w90 configure-w90 - if test -d ../W90; then \ - cd ../W90; $(MAKE) || exit 1; cd ../bin; ln -fs ../W90/wannier90.x . ; fi - -(cd ../bin; ln -fs ../W90/wannier90.x .) - touch make-w90 - -uncompress-w90: - $(call download_and_unpack,$(W90),$(W90_URL),W90,wannier90) - touch uncompress-w90 - -configure-w90: - cd ../W90 ; \ - if (test -e ../install/make_wannier90.inc) || (test -d ../W90); then \ - (cp ../install/make_wannier90.inc ../W90/make.inc); fi - touch ./configure-w90 - -w90_clean: - if test -d ../W90; then (cd ../W90; \ - $(MAKE) veryclean); fi - rm -f ../bin/wannier90.x - rm -rf ./make-w90 ./configure-w90 - -w90_veryclean: w90_clean - if test -d ../W90; then (rm -R -f ../W90); fi - if test -d ../$(W90); then (rm -R -f ../$(W90)); fi - rm -f ../bin/wannier90.x - rm -rf ./uncompress-w90 - -w90_distclean: - rm -f ../archive/$(W90).tar.gz - -########################################################### -# WANT -########################################################### - -want: uncompress-want configure-want - if test -d ../WANT; then \ - cd ../WANT; $(MAKE) all || exit 1; fi - touch ./make-want - -uncompress-want: - $(call download_and_unpack,$(WANT),$(WANT_URL),WANT,want) - touch uncompress-want - -configure-want: - cd ../WANT ; \ - ./configure \ - CC="$(CC)" \ - F90="$(F90)" \ - MPIF90="$(MPIF90)" \ - LD="$(LD)" \ - LDFLAGS="$(LDFLAGS)" \ - AR="$(AR)" \ - ARFLAGS="$(ARFLAGS)" \ - RANLIB="$(RANLIB)" \ - LAPACK_LIBS="$(LAPACK_LIBS)" \ - BLAS_LIBS="$(BLAS_LIBS)" \ - FFT_LIBS="$(FFT_LIBS)" - touch ./configure-want - -want_clean: - if test -d ../WANT; then (cd ../WANT; \ - $(MAKE) clean); fi - - rm -rf ./make-want ./configure-want - -want_veryclean: want_clean - if test -d ../WANT; then (rm -R -f ../WANT); fi - if test -d ../$(WANT); then (rm -R -f ../$(WANT)); fi - if test -e ../archive/$(WANT).tar.gz ; then (rm -f ../archive/$(WANT).tar.gz); fi - - rm -rf ./uncompress-want ./configure.h - -want_distclean: - rm -f ../archive/$(WANT).tar.gz - -########################################################### -# YAMBO -########################################################### - -yambo: uncompress-yambo configure-yambo - if test -d ../YAMBO; then \ - cd ../YAMBO; $(MAKE) yambo interfaces ypp || exit 1; fi - touch ./make-yambo - -uncompress-yambo: - $(call download_and_unpack,$(YAMBO),$(YAMBO_URL),YAMBO,yambo) - touch uncompress-yambo - -configure-yambo: - @(if test -z "$(F90)" ; then \ - echo "*** F90 is not defined; please define F90 or edit make.inc" ; exit 1 ; fi) - cd ../YAMBO ; \ - ./configure \ - --with-blas-libs="$(BLAS_LIBS)" \ - --with-lapack-libs="$(LAPACK_LIBS) $(BLAS_LIBS)" \ - --with-fft-libs="$(FFT_LIBS)" \ - --with-scalapack-libs="$(SCALAPACK_LIBS)" \ - --with-blacs-libs="$(SCALAPACK_LIBS)" \ - PFC="$(MPIF90)" \ - FC="$(F90)" - touch ./configure-yambo - -yambo_clean: - if test -d ../YAMBO; then (cd ../YAMBO; \ - $(MAKE) clean); fi - - rm -rf ./make-yambo ./configure-yambo - -yambo_veryclean: yambo_clean - if test -d ../YAMBO; then (rm -R -f ../YAMBO); fi - if test -d ../$(YAMBO); then (rm -R -f ../$(YAMBO)); fi - - rm -rf ./uncompress-yambo - -yambo_distclean: - if test -e ../archive/$(YAMBO).tar.gz ; then \ - rm -f ../archive/$(YAMBO).tar.gz; fi - -########################################################### -# cleaning -########################################################### - -clean: w90_clean want_clean yambo_clean gipaw_clean d3q_clean - -veryclean: w90_veryclean want_veryclean yambo_veryclean \ - gipaw_veryclean d3q_veryclean - -distclean: w90_distclean want_distclean yambo_distclean \ - gipaw_distclean d3q_distclean - diff --git a/quantum_espresso/kcp/install/refresh-configure.sh b/quantum_espresso/kcp/install/refresh-configure.sh deleted file mode 100755 index d1c78b07f..000000000 --- a/quantum_espresso/kcp/install/refresh-configure.sh +++ /dev/null @@ -1,20 +0,0 @@ -#!/bin/bash -# -# Copyright (C) 2001-2016 Quantum ESPRESSO group -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License. See the file `License' in the root directory -# of the present distribution. -# -# Dependency: GNU AUTOCONF (minimum 2.60, 2.69 suggested) -# -# Tested using: -# - autoconf (GNU Autoconf) 2.63 -# - aclocal (GNU automake) 1.11.1 -# - m4 (GNU M4) 1.4.13 - -aclocal -I m4 --install - -autoconf -f -v --output=configure configure.ac diff --git a/quantum_espresso/kcp/install/uncompress-w90 b/quantum_espresso/kcp/install/uncompress-w90 deleted file mode 100644 index e69de29bb..000000000 diff --git a/quantum_espresso/kcp/iotk/ABOUT b/quantum_espresso/kcp/iotk/ABOUT deleted file mode 100644 index edd5b10c1..000000000 --- a/quantum_espresso/kcp/iotk/ABOUT +++ /dev/null @@ -1,38 +0,0 @@ - -The input/output tool kit (IOTK) is a Fortran90 library intended to provide a -simplified access to tagged files formatted using some specific rule. -A tagged file is a file containing tags and data, and can be textual, -in which case a XML-compliant format is used, or binary, in which case a -special format is used. The structure of the obtained files is hierarchical -and suitable to represent complex objects. Textual files can be -accessed with an XML browser or read with an XML parser. - -IOTK has a simple Fortran interface, some-what similar to the interface -of the native Fortran i/o library. The library interface is overloaded over -all Fortran types, kinds and ranks, so that the same interface is -used to write a scalar integer or a matrix of double precision real numbers. -Moreover, when reading binary files, kind conversion (e.g. from single to -double precision) is performed transparently by the library. - -Even if the way used by IOTK to store the tags in binary files -is not standard, there is a one-to-one correspondence between -binary files and textual files, so that it is possible to transform a -(fast but unportable) binary file into a (portable and human-readable) XML file -without any knowledge about its content. A small external tool to perform -these conversions is provided with this package. - -Refer to the documentation in the package for a complete reference. - -Note that this kit is not conceived an XML parser, but it can be used as a -writer/parser for a limited subset of XML language. - -Known defects: -+ DTD informations are not processed. -+ There is presently no feature to list the tags in a file, or the - attributes in a tag. To found a tag or an attribute, its name has to be known. -+ Access to files is serial. If data are written in a given order - and read in a different order, performance overheads are expected. - This problem can be partially overcome by splitting the file in - a number of smaller files and pointing to them with virtual links - (see the documentation for details). - diff --git a/quantum_espresso/kcp/iotk/CHANGES b/quantum_espresso/kcp/iotk/CHANGES deleted file mode 100644 index 53bfaf240..000000000 --- a/quantum_espresso/kcp/iotk/CHANGES +++ /dev/null @@ -1,20 +0,0 @@ -This document describe the main changes between the -official versions. It is more coarse grained with respect -to the CVS log. - -1.0.0 First official version -1.0.1 Bug fix (loss of precision when reading complex from textual files) -1.0.2 Bug fix (wrong call to 'modulo' intrinsic, not working with 64-bit default integers) - Improved portability in tools/auto_config (from Guido Roma) - Improved portability in include/iotk_config.h - Insertion of a check for , to improve checks with files - generated with more advanced versions of the library - Bug fix (some __IOTK_WORKAROUND6 macros were mis-spelled) (from Paolo Giannozzi) - -1.1.0 New features: - - binary reading through streams, when supported (still experimental) - - more parameters can be configured runtime - - iotk.x tool (wrapped by iotk script) - - embedded manual (accessible with iotk.x tool) - Code reorganization: - - list template diff --git a/quantum_espresso/kcp/iotk/DOWNLOAD b/quantum_espresso/kcp/iotk/DOWNLOAD deleted file mode 100644 index 95f4255b3..000000000 --- a/quantum_espresso/kcp/iotk/DOWNLOAD +++ /dev/null @@ -1,17 +0,0 @@ -RELEASE POLICY -Version number is major.minor.patch -Major number will be increased if/when a strong redesign of the library will be necessary. -Minor number is increased when new features are added. -Patch number is increased with bug fixes. -For a given major.minor branch, the latest release (i.e. highest patch number) is the most reliable. - -DOWNLOADS. -- iotk1.0.1.tar.gz - -DISCLAIMER. While the developers of IOTK make every effort to deliver a high quality scientific software, we do not guarantee that our codes are free from defects. Our software is provided "as is". Users are solely responsible for determining the appropriateness of using this package and assume all risks associated with the use of it, including but not limited to the risks of program errors, damage to or loss of data, programs or equipment, and unavailability or interruption of operations. Due to the limited human resources involved in the development of this software package, no support will be given to individual users for either installation or execution of the codes. -Finally, in the spirit of every open source project, any contribution from external users is welcome, encouraged and, if appropriate, will be included in future releses. - -LICENCE. All the material included in this distribution is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. -These programs are distributed in the hope that they will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - diff --git a/quantum_espresso/kcp/iotk/IDE/IDE.conf b/quantum_espresso/kcp/iotk/IDE/IDE.conf deleted file mode 100644 index 9c0acfed8..000000000 --- a/quantum_espresso/kcp/iotk/IDE/IDE.conf +++ /dev/null @@ -1,33 +0,0 @@ -# -# ======================================================== -# This file contains the DEFAULTS for IDE configuration -# and Makefile generation -# ======================================================== -# - -# -# Manage Suffixes -SUFFIXES_SOURCE='*.f90 *.c *.f' -SUFFIXES_CLEAN='*.a *.o *.mod *.d *.pc *.pcl *.x *.F90' - -# -# Directory Names -STDDIR_SOURCE=src -STDDIR_INCLUDE=include -STDDIR_BINARY=bin -STDDIR_TMP=tmp -STDDIR_DOC=doc - -# -# Rule for library name -NAMERULE='[[:alpha:]]*([[:alnum:]_])' - -# Rule for version -VERSRULE='+([[:digit:]]).+([[:digit:]]).+([[:digit:]])*([[:alnum:]_])' - -# -# newline -newline=" -" - - diff --git a/quantum_espresso/kcp/iotk/IDE/IDE_makemake.sh b/quantum_espresso/kcp/iotk/IDE/IDE_makemake.sh deleted file mode 100755 index ab2949b11..000000000 --- a/quantum_espresso/kcp/iotk/IDE/IDE_makemake.sh +++ /dev/null @@ -1,190 +0,0 @@ -#!/bin/bash -# -# IDE_makemake.sh -# -MANUAL="\ -USAGE - IDE_makemake.sh [-h] - - -h : print this manual - - The script generates a working Makefile for the IDE HOME directory. - The Makefile is able to deal with library compilation Makefile generation. - If present options are read from \${IDEHOME}/OPTIONS. - Configuration parameters from file \${IDEHOME}/IDE/IDE.conf ). -" - -shopt -s extglob - -# -# input check -if [ "$1" = "-h" ] ; then echo "$MANUAL" ; exit 0 ; fi -if [ "$#" != "0" ] ; then - echo " Invalid number of arguments, type makemake.sh -h for help" - exit 1 -fi - -# -# load DEFAULTS -if [ ! -e ./IDE/IDE.conf ] ; then - echo "ERROR: Unable to find ./IDE/IDE.conf" ; exit 1 -fi -. ./IDE/IDE.conf - -# -# tmp dir -tmpdir=$STDDIR_TMP -if [ -e $TMPDIR ] ; then rm -rf $tmpdir ; fi -mkdir $tmpdir -makefile=$tmpdir/Makefile - -# -# set trap for clean exit in case of stopping -trap "test -d $tmpdir && rm -rf $tmpdir" EXIT -trap "test -d $tmpdir && rm -rf $tmpdir" 2 - -# -# version and README -if [[ ! -r IDE/README ]] ; then - echo " File IDE/README is not present" - exit 1 -fi -if [ -e README -a ! -L README ] ; then - echo " File README exists but not a symbolic link" - exit 1 -fi -ln -sf IDE/README . -IDE/makeversion.sh IDE - - - - -header="\ -# -# DO NOT EDIT THIS FILE MANUALLY -# This makefile was automatically generate for IDE home directory -#" -echo "$header" > $makefile -# -# ADD eventually the following line in the header -# Today is $(date) - - - -# -# option file -options= -if test -r OPTIONS ; then - options="$options$(cat OPTIONS) -" - echo "# Global OPTIONS file has been used in generation" >> $makefile -else - echo "# Global OPTIONS file has NOT been found" >> $makefile -fi - - -# -# order the found packages -IDE_LIBS="$(IDE/packls.sh)" -IDE_LIBS="$(echo USE $IDE_LIBS | IDE/used -s -i)" - - -# -# main target -echo >> $makefile -echo "# Main target" >> $makefile -txt="\ -info: - @echo - @echo \" S3 IDE (Integrated Development Environment)\" - @echo - @echo \" type: make \" - @echo \" Possible 's are: \" - @echo \" make make IDE global Makefile\" - @echo \" allmake make IDE Makefiles in each dir \" - @echo \" clean IDE total cleanup \" - @echo \" add launch a script to add a new pakage \" - @echo \" _all make all executable in \" - @echo \" _loclib make the local library in \" - @echo \" _make make the Makefile for \" - @echo \" _allmake make all the Makefiles for and its libs \" - @echo \" _clean cleanup in \" - @echo \" _tar tar of a single dir \" - @echo \" _alltar tar of a dir with its libs \" - @echo - @echo \" Possible values are: \" " -echo "$txt" >> $makefile -for lib in $IDE_LIBS -do - echo " @echo \" $lib \" ">> $makefile -done -echo " @echo " >> $makefile - - -# -# loop over libs -echo >> $makefile -echo >> $makefile -echo "# targets for libs handling" >> $makefile -for lib in $IDE_LIBS -do - echo >> $makefile - echo "${lib}_all: " >> $makefile - echo " cd $lib ; make all " >> $makefile - echo "${lib}_loclib: " >> $makefile - echo " cd $lib ; make loclib ">> $makefile - echo "${lib}_make: " >> $makefile - echo " IDE/makemake.sh $lib " >> $makefile - echo "${lib}_allmake: ${lib}_make " >> $makefile - echo " cd $lib ; make allmake" >> $makefile - echo "${lib}_clean: " >> $makefile - echo " cd $lib ; make clean " >> $makefile - echo "${lib}_tar: " >> $makefile - echo " cd $lib ; make tar " >> $makefile - echo "${lib}_alltar: " >> $makefile - echo " cd $lib ; make alltar " >> $makefile -done - -echo >> $makefile -echo >> $makefile -echo "# make all Makefiles" >> $makefile -echo "allmake: make " >> $makefile -echo " make -f Makefile allmake_" >> $makefile -echo "allmake_:" >> $makefile -for lib in $IDE_LIBS -do - echo " IDE/makemake.sh $lib" >> $makefile -done - - -# -# local Makefile re-generation -echo >> $makefile -echo "# target for making Makefile" >> $makefile -echo "make: " >> $makefile -echo " IDE/IDE_makemake.sh " >> $makefile - -echo >> $makefile -echo "# target to launch add_dir" >> $makefile -echo "add: " >> $makefile -echo " IDE/add_dir" >> $makefile - -# -# clean all -echo >> $makefile -echo "# clean all" >> $makefile -echo "clean: " >> $makefile -for lib in $IDE_LIBS -do - echo " cd $lib ; make clean_" >> $makefile -done - - - -# -# Moving generated Makefile in the main dir -# -cp $makefile . - -exit 0 - diff --git a/quantum_espresso/kcp/iotk/IDE/README b/quantum_espresso/kcp/iotk/IDE/README deleted file mode 100644 index 2c25c5217..000000000 --- a/quantum_espresso/kcp/iotk/IDE/README +++ /dev/null @@ -1,34 +0,0 @@ -PACKAGE S3 Development Environment -VERSION 0.1.0 -AUTHORS Giovanni Bussi, Andrea Ferretti -LICENSE - -===================================================================== - S3DE -- S3 Development Environment -===================================================================== - -This package is a suite of scripts used to manage an environment -suitable for code development. Automatic Makefile generation, versions, -portability among different systems and library loading are some -of the main tasks of the DE. - -Content of S3DE - -IDE dir containing the scripts -CONFIG dir with all the stuff related to portability and system - configuration. At the moment, different make.sys.SYSTEM are - stored, waiting for an automatic configurator based on - autoconf-generated scripts. -OPTIONS file contining the definition of global options ruling on - the whole environment (such as e.g. the autodobule or 64bit compiler - options) - -README This readme file (a symbolic link to IDE/README) - -Makefile global Makefile. It is automatically generated and may not be present - when downloading. Type make to get a manual. - - All the other directories should be the packages actually present - in the environment. - - diff --git a/quantum_espresso/kcp/iotk/IDE/README.options b/quantum_espresso/kcp/iotk/IDE/README.options deleted file mode 100644 index 0a6356b28..000000000 --- a/quantum_espresso/kcp/iotk/IDE/README.options +++ /dev/null @@ -1,22 +0,0 @@ - -Here are reported the possible option TAGs to be set in the -OPTIONS file in each directory. -For each the sintax may be: - - or - -begin - -end - -Note: names should be capital case -Allowed 's are: - - USE list the used libraries - MAIN list the source files to be used as main programs - - DEFINITION include lines in the header part of the produced Makefile (inner) - MAKEFILE directly include lines at the end of the produced Makefile (inner) - HOME_MAKEFILE directly include lines at the end of the library HOME Makefile (outer) - DEFINITION. produce a specific compilation rule to make .o - diff --git a/quantum_espresso/kcp/iotk/IDE/add_dir b/quantum_espresso/kcp/iotk/IDE/add_dir deleted file mode 100755 index 712b8d241..000000000 --- a/quantum_espresso/kcp/iotk/IDE/add_dir +++ /dev/null @@ -1,37 +0,0 @@ -#!/bin/bash - -shopt -s extglob - -source IDE/IDE.conf - -echo "Answer to each of the following questions with a single line" - -DIRECTORY= -while true ; do - read -p "Name of new directory:" DIRECTORY - [[ "$DIRECTORY" != $NAMERULE ]] && echo "Name is not correct, retry" && continue - [ -e "$DIRECTORY" ] && echo "Directory exists, retry" && continue - break -done - -read -p "Full name of package:" NAME - -VERSION= -while true ; do - read -p "Version:" VERSION - [[ "$VERSION" != $VERSRULE ]] && echo "Version is not correct, retry" && continue - break -done - -read -p "Authors:" AUTHORS - -mkdir "$DIRECTORY" - - -cat > $DIRECTORY/README << EOF -PACKAGE $NAME -VERSION $VERSION -AUTHORS $AUTHORS -EOF - -IDE/makemake.sh $DIRECTORY diff --git a/quantum_espresso/kcp/iotk/IDE/arch.sh b/quantum_espresso/kcp/iotk/IDE/arch.sh deleted file mode 100755 index 562f50efc..000000000 --- a/quantum_espresso/kcp/iotk/IDE/arch.sh +++ /dev/null @@ -1,56 +0,0 @@ -#!/bin/bash - -NEXT= -SCRIPT= -FILES= -AFTER= -for OPT -do - case "$NEXT" in - (--after-extraction|-a) AFTER="$OPT" ; NEXT= ;; - (--script|-s) SCRIPT="$OPT" ; NEXT= ;; - (*) - case "$OPT" in - (--help) ;; - (--after-extraction|-a) NEXT="$OPT" ;; - (--script|-s) NEXT="$OPT" ;; - (-*) echo "$0: Unknown option $OPT" ; exit 1 ;; - (*) FILES="$FILES"$'\n'"$OPT" ;; - esac - ;; - esac -done - -test -z "$SCRIPT" && { echo "$0: specify the script file with -s" ; exit 1 ; } - -#test -e "$SCRIPT" && rm "$SCRIPT" -#touch "$SCRIPT" -test -e "$SCRIPT" || touch "$SCRIPT" - -IFS=$'\n' -for FILE in $FILES ; do - test -r "$FILE" || { echo "$0: file not found: $FILE" ; continue ; } - IFS=/ - ACCDIR=. - for DIR in ${FILE%\/*} ; do - ACCDIR="$ACCDIR/$DIR" - echo "test -e \"$ACCDIR\" || mkdir \"$ACCDIR\"" >> "$SCRIPT" - done - IFS=" "$'\n' - EOF="$RANDOM$RANDOM$RANDOM$RANDOM$RANDOM$RANDOM" - echo "cat << \"$EOF\" > \"$FILE\"" >> "$SCRIPT" - cat "$FILE" >> "$SCRIPT" - echo "$EOF" >> "$SCRIPT" -done - -if [ -n "$AFTER" ] ; then -if [ -r "$AFTER" ] ; then - cat "$AFTER" >> "$SCRIPT" -else - echo "$0: file not found $AFTER" -fi -fi - -# for simple direct use -chmod u+x $SCRIPT - diff --git a/quantum_espresso/kcp/iotk/IDE/basename_src b/quantum_espresso/kcp/iotk/IDE/basename_src deleted file mode 100755 index cfb74d826..000000000 --- a/quantum_espresso/kcp/iotk/IDE/basename_src +++ /dev/null @@ -1,60 +0,0 @@ -#!/bin/bash - -# -# cut the source SUFFIXES (defined in IDE/IDE.conf) -# from the input file names -# -# Suffix list is in SUFFIXES_SOURCE -# -c option writes the output columnwise -# - -shopt -s extglob - -# -# load DEFAULTS -if [ ! -e ./IDE/IDE.conf ] ; then - echo "ERROR: Unable to find ./IDE/IDE.conf" ; exit 1 -fi -. ./IDE/IDE.conf - -col="" -if [ "$1" = "-c" ] ; then col="yes" ; fi - -# -# read source names -source_list=`cat` - -newlist="" -for src in $source_list -do - newlist="$newlist ${src%.*}" -done - -if [ "$col" = "yes" ] ; then - echo "$newlist" | tr " " "\n" | grep -v "^ *$" -else - echo $newlist -fi - - -exit 0 -#old version follows - -for src in $source_list -do - tmp=$src - for suffix in $SUFFIXES_SOURCE - do - tmp=`basename $tmp $suffix` - done - newlist="$newlist $tmp" -done - -if [ "$col" = "yes" ] ; then - echo "$newlist" | tr " " "\n" | grep -v "^ *$" -else - echo $newlist -fi - -exit 0 - diff --git a/quantum_espresso/kcp/iotk/IDE/check_main b/quantum_espresso/kcp/iotk/IDE/check_main deleted file mode 100755 index 9a9400478..000000000 --- a/quantum_espresso/kcp/iotk/IDE/check_main +++ /dev/null @@ -1,57 +0,0 @@ -#!/bin/sh - -# writes to stdout the list of arguments that contain a fortran main. -# -n => write the others -# if no argument is copied to stdout, it exits with an error - -negative=no -if test "$1" = -n -then - negative=yes - shift -fi - -# returns true if $1 is a f90 program -# grep -qi '^[ \t]*program' $1 && grep -qi '^[ \t]*end[ \t]*program' $1 - -#nothing=yes -#output="" -#for argument -#do -# main=no -# if test -r $argument -# then -# grep -qi '^[ \t]*program' $argument && -# grep -qi '^[ \t]*end[ \t]*program' $argument && -# main=yes -# test $negative = no && test $main = yes && output="$output$argument " -# test $negative = yes && test $main = no && output="$output$argument " -# fi -#done -# -#test "$output" && echo "$output" || exit 1 -#exit 0 - -# Questa e' piu' veloce -# Occhio perche' non e' esattamente consistente (la negazione) - -output= -if [ $negative = no ] ; then - for file in $(grep -li '^[ \t]*program' "$@") - do - # NOTA: va eliminato per il caso in cui i programmi - # finiscono solo con "end" - #grep -qi '^[ \t]*end[ \t]*program' $file && - # - output="$output$file " - done -else - for file in $(grep -vli '^[ \t]*program' "$@") - do - output="$output$file " - done -fi - -test "$output" && echo "$output" || exit 1 -exit 0 - diff --git a/quantum_espresso/kcp/iotk/IDE/cvssnap.sh b/quantum_espresso/kcp/iotk/IDE/cvssnap.sh deleted file mode 100755 index ed836e63c..000000000 --- a/quantum_espresso/kcp/iotk/IDE/cvssnap.sh +++ /dev/null @@ -1,156 +0,0 @@ -#!/bin/bash - -MANUAL="\ - USAGE - cvssnap.sh [-h] [ -n ] [ -d dir...dirN] - the script produces a second script file able to reproduce the CVS dir - structure and and automatically updating all the files with the current - revision is produced. - If no dir is given ./ is assumed. -" -shopt -s extglob -IDEHOME=$(pwd) - -filename= -list= -while getopts :hn:d: OPT -do - case $OPT in - (h) echo "$MANUAL" ; exit 0 ;; - (n) filename=$OPTARG ;; - (d) list=$OPTARG ;; - (:) echo "error: $OPTARG requires an argument" ; exit 1 ;; - (?) echo "error: unkwown option $OPTARG" ; exit 1 ;; - esac -done - -if [ -z "$filename" ] ; then - echo "ERROR: -n should be specified" - exit 1 -fi - -if [ -n "$filename" ] ; then - test -e $filename && rm $filename - touch $filename - chmod ug+x $filename -fi - -# by default, void list is set to the current dir -[ -z "$list" ] && list="./" - -# -# if the script is generated here write the header -# -HEADER="\ -#!/bin/sh -# -# Today is $(date) -# The script has been automatically generated. -# -MANUAL=\"\\ - USAGE: - $filename [-h] [-u cvsuser] - - The present script extract a snapshot of a project or part - of it from the CVS repository. The -u option overwrite the name - of the cvs user set in the snapshot. \" - -while getopts :hu: OPT -do - case \$OPT in - (h) echo \"\$MANUAL\" ; exit 0 ;; - (u) newuser=\$OPTARG ;; - (:) echo \"error: \$OPTARG requires an argument\" ; exit 1 ;; - (?) echo \"error: unkwown option \$OPTARG\" ; exit 1 ;; - esac -done - -# -# here start the generation of the CVS tree -CVSROOT_LOCAL=\$CVSROOT -" - -echo "$HEADER" > $filename - -# -# storing the CVS directories -# -for dir in $list -do - cvslist=$(find $dir -name CVS) - for cvsdir in $cvslist - do - dirname=${cvsdir#"./"} - dirname=${dirname%CVS} - # - # the list of file in the format - # revision filename - # - filelist="$filelist $( awk -v DIR=$dirname -F / \ - '{ if ( $1 != "D" ) print DIR"@"$2"@"$3 }' $cvsdir/Entries )" - # - # reproducing the CVS dirs - # - $IDEHOME/IDE/arch.sh --script $filename $cvsdir/* - - # - # changing the CVS/Root files if needed - # - TMP="\ - -# Change the CVSROOT environment in CVS/Root file if needed -if [ -n \"\$newuser\" ] ; then - rootstr=\`cat $cvsdir/Root \` - new_rootstr=\`echo \$rootstr | sed "s/:[a-z]*@/:\$newuser@/" \` - rm $cvsdir/Root - echo \${new_rootstr} > $cvsdir/Root - CVSROOT_LOCAL=\$new_rootstr -fi - -" - echo "$TMP" >> $filename - - # - # adding the sticky tags to the Entries file - # - TMP="\ - -# Add the sticky tags to the CVS/Entries file - tmp=\"\$( awk -F / ' { if ( \$1 != \"D\" ) { sticky=\"T\"\$3 } else { sticky=\" \" } } - { print \$0sticky }' $cvsdir/Entries )\" - rm $cvsdir/Entries - echo \"\$tmp\" > $cvsdir/Entries - -" - echo "$TMP" >> $filename - - done -done - - -# -# updating the files -# -TMP="\ - -#Retrieving files with the correct revisions -# -# NOTA BENE: when the snapshotted dirs have different root it probably does not work... -# -cvs -d \$CVSROOT_LOCAL login - -for dir in $list -do - cd \$dir - cvs update - cd - -done - -cvs -d \$CVSROOT_LOCAL logout -exit 0 - -" -echo "$TMP" >> $filename - -exit 0 - diff --git a/quantum_espresso/kcp/iotk/IDE/dir_setup.sh b/quantum_espresso/kcp/iotk/IDE/dir_setup.sh deleted file mode 100755 index 4d4cecba2..000000000 --- a/quantum_espresso/kcp/iotk/IDE/dir_setup.sh +++ /dev/null @@ -1,71 +0,0 @@ -#!/bin/bash -# -# dir_setup.sh -# - -PADIR=iotk - -MANUAL="\ -USAGE - dir_setup.sh [-h] [ [-f] ] - - -h : print this manual - -f : force the creation of all defined directories - : the directory to be set - - The script sets up the required directories and files in - according to the \${IDEHOME}/IDE/IDE.conf file." - -# -# input check -shopt -s extglob -if [ "$1" = "-h" ] ; then echo "$MANUAL" ; exit 0 ; fi -force="" -if [ "$1" = "-f" ] ; then force=yes ; shift 1 ; fi -if [ "$#" != "1" ] ; then - echo " Invalid number of arguments, type dir_setup.sh -h for help" - exit 1 -fi - -directory=$1 -if [ ! -d $directory ] ; then - echo " Input argument is not a directory, type dir_setup.sh -h for help" - exit 1 -fi - -# -# load DEFAULTS -if [ ! -e $PADIR/IDE/IDE.conf ] ; then - echo "ERROR: Unable to find $PADIR/IDE/IDE.conf" ; exit 1 -fi -. $PADIR/IDE/IDE.conf - -list="\ -$STDDIR_SOURCE -$STDDIR_INCLUDE -$STDDIR_BINARY -$STDDIR_TMP -$STDDIR_DOC -" - -# -# check if exists and it is not a file -for dir in $list -do - if [ -e $directory/$dir -a ! -d $directory/$dir ] ; then - echo "ERROR: $dir exists and it is NOT a directory" - exit 1 - fi -done - -# -# create dirs -for dir in $list -do - test -d $directory/$dir || mkdir $directory/$dir - test -e $directory/$dir/.touch || touch $directory/$dir/.touch -done - - - - diff --git a/quantum_espresso/kcp/iotk/IDE/getoption b/quantum_espresso/kcp/iotk/IDE/getoption deleted file mode 100755 index 4b974ebc1..000000000 --- a/quantum_espresso/kcp/iotk/IDE/getoption +++ /dev/null @@ -1,90 +0,0 @@ -#!/bin/bash - -# getoption [-c] keyword -# -c incolonna le parole dell'output - -column=no -if test "$1" = -c -then - column=yes - shift -fi - -search="$*" - -IFSBCK="$IFS" -IFSNL=" -" -shopt -s extglob - -OUTPUT="" -PREPEND="" -while IFS="$IFSNL" && read -r LINE && IFS="$IFSBCK" ; do - case "$LINE" in - (begin+([[:space:]])+([^[:space:]])*([[:space:]])) - NAME="${LINE##begin+([[:space:]])}" - NAME="${NAME%%*([[:space:]])}" - PREPEND="$PREPEND$NAME " ;; - (end+([[:space:]])+([^[:space:]])*([[:space:]])) - PREPEND="${PREPEND%%+([^[:space:]]) }" ;; - (*) NLINE="$PREPEND$LINE" - if [[ "$NLINE" == $search\ * ]] ; then - OUTPUT="$OUTPUT${NLINE#$search } -" - fi ;; - esac -done -IFS="$IFSBCK" - -if [ $column = yes ] ; then - for ITEM in $OUTPUT ; do - echo "$ITEM" - done -else - echo -n "$OUTPUT" -fi - -exit - -# old versions follow ... - -test $# -ne 1 && exit 1 - -option=$1 - -tmp="$( sed "s/^/>/ - /^>begin *$option *$/,/^>end *$option *$/{ - /^>begin *$option *$/!{ - /^>end *$option *$/!{ - s/^>/+/ - } - } - } - s/^>$option /+/" | -sed -n "s/^+//p" )" - - - -#tmp="$(sed "/^begin *$option *$/,/^end *$option *$/{ -# /^begin *$option *$/!{ -# /^end *$option *$/!{ -# s/^/$option / -# } -# } -# }" | -#sed -n "s/^$option //p" )" - -# auxiliary version -#tmp="`awk "BEGIN { p=0 } -# /^$option */ {print} -# /^begin *$option *$/ { p=1 } -# /^end *$option *$/ { p=0 } -# { if ( p == 1 ) print }" | -# egrep -v "^begin *option *$" | -# sed -n "s/^$option //p" `" - -test $column = yes && -tmp="`echo $tmp | tr " " "\n" | grep -v "^ *$" `" - -echo "$tmp" - diff --git a/quantum_espresso/kcp/iotk/IDE/include/CVS/Entries b/quantum_espresso/kcp/iotk/IDE/include/CVS/Entries deleted file mode 100644 index 4bbca2ed2..000000000 --- a/quantum_espresso/kcp/iotk/IDE/include/CVS/Entries +++ /dev/null @@ -1,3 +0,0 @@ -/IDE_version.h/1.1.1.1/Wed Apr 21 09:20:57 2010// -/IDE_version.sh/1.1.1.1/Wed Apr 21 09:20:57 2010// -D diff --git a/quantum_espresso/kcp/iotk/IDE/include/CVS/Repository b/quantum_espresso/kcp/iotk/IDE/include/CVS/Repository deleted file mode 100644 index f5e582986..000000000 --- a/quantum_espresso/kcp/iotk/IDE/include/CVS/Repository +++ /dev/null @@ -1 +0,0 @@ -espresso-4.1-nk-para/iotk/IDE/include diff --git a/quantum_espresso/kcp/iotk/IDE/include/CVS/Root b/quantum_espresso/kcp/iotk/IDE/include/CVS/Root deleted file mode 100644 index 148e98b8a..000000000 --- a/quantum_espresso/kcp/iotk/IDE/include/CVS/Root +++ /dev/null @@ -1 +0,0 @@ -:ext:nnlinh@qeforge.qe-forge.org:/cvsroot/nkc diff --git a/quantum_espresso/kcp/iotk/IDE/include/IDE_version.h b/quantum_espresso/kcp/iotk/IDE/include/IDE_version.h deleted file mode 100644 index be41ae6b4..000000000 --- a/quantum_espresso/kcp/iotk/IDE/include/IDE_version.h +++ /dev/null @@ -1,5 +0,0 @@ -#define __IDE_VERSION "0.1.0" -#define __IDE_VERSION_MAJOR 0 -#define __IDE_VERSION_MINOR 1 -#define __IDE_VERSION_PATCH 0 -#define __IDE_VERSION_EXTRA "" diff --git a/quantum_espresso/kcp/iotk/IDE/include/IDE_version.sh b/quantum_espresso/kcp/iotk/IDE/include/IDE_version.sh deleted file mode 100644 index 7530242f7..000000000 --- a/quantum_espresso/kcp/iotk/IDE/include/IDE_version.sh +++ /dev/null @@ -1,5 +0,0 @@ -__IDE_VERSION=0.1.0 -__IDE_VERSION_MAJOR=0 -__IDE_VERSION_MINOR=1 -__IDE_VERSION_PATCH=0 -__IDE_VERSION_EXTRA= diff --git a/quantum_espresso/kcp/iotk/IDE/linked b/quantum_espresso/kcp/iotk/IDE/linked deleted file mode 100755 index 89b83dbc9..000000000 --- a/quantum_espresso/kcp/iotk/IDE/linked +++ /dev/null @@ -1,17 +0,0 @@ -#!/bin/bash - -PADIR=iotk - -test -d "$1" || exit 1 -test -r $1/OPTIONS || exit 0 - -LINKED= -for dir ; do -LINKED="$LINKED $($PADIR/IDE/getoption LINK < $1/OPTIONS)" -done -for dir in $LINKED ; do - echo "$dir" -done - - - diff --git a/quantum_espresso/kcp/iotk/IDE/makeinfo.sh b/quantum_espresso/kcp/iotk/IDE/makeinfo.sh deleted file mode 100755 index b9ea3a1d3..000000000 --- a/quantum_espresso/kcp/iotk/IDE/makeinfo.sh +++ /dev/null @@ -1,28 +0,0 @@ -#!/bin/bash -# Generate info target -# Usage: makeinfo.sh -# makefile is read on stdin -# info target is written on stdout - -shopt -s extglob - -[ $# -ne 0 ] && { echo "Incorrect usage" ; exit 1 ; } - -INFO= -while read LINE ; do - if [[ $LINE == \#*([[:space:]])INFO* ]] ; then - INFO="${LINE##\#*([[:space:]])INFO*([[:space:]])}" - elif [[ $LINE == +([^=#]):* && "$INFO" ]] ; then - TARGET="${LINE%%:*}" - echo -n " @echo \" $TARGET " - count=$(( 30 - ${#TARGET} )) - for((i=0;i $makefile - -# -# option file -options= -txt= -if test -r OPTIONS ; then - options="$options$(cat OPTIONS) -" - echo "# Global OPTIONS file has been used in generation" >> $makefile -else - echo "# Global OPTIONS file has NOT been found" >> $makefile -fi -if test -r $directory/OPTIONS ; then - options="$options$(cat $directory/OPTIONS) -" - echo "# Local OPTIONS file has been used in generation" >> $makefile -else - echo "# Local OPTIONS file has NOT been found" >> $makefile -fi - -# -# versions -# -$PADIR/IDE/makeversion.sh $directory - -# -# ORA ESEGUI I COMANDI IN BEFORE_MAKEMAKE -# -# setting DEFAULT for variables -POSSIBLE_MAIN="@undef@" -ADD_TO_MAIN= -IDEHOME=../.. -#IDEHOME=.. -# -# cd-ing in the package home -cd $directory -# -eval "$(echo "$options" | ../$PADIR/IDE/getoption BEFORE_MAKEMAKE)" -# FINE COMANDI -# come back to IDE main dir -cd $IDE_PATH - - -# -# get sources -src=" $(cd $directory/$STDDIR_SOURCE ; echo $SUFFIXES_SOURCE) " -cat >> $makefile << EOF -# -# Sources defined by: $SUFFIXES_SOURCE -EOF - -# no source -if test -z "$src" -then -cat >> $makefile << EOF -# -# There is no source file in this directory -EOF -fi - - -# -# if exist sources -if [ "$src" ] ; then - - # - # define main programs - - # substitute defined macro - # - case "$POSSIBLE_MAIN" in - @undef@) src_for_main="$src" ;; - @NONE@|@none@) src_for_main="" ;; - *) src_for_main="$POSSIBLE_MAIN" ;; - esac - - # - # add files assumed to be main - [ -n "$src_for_main" ] && - src_main="$(cd $directory/$STDDIR_SOURCE ; ../../$PADIR/IDE/check_main $src_for_main)" - src_main="${ADD_TO_MAIN}${src_main}" - - # - # define lib sources - - src_lib="$src" - for file_main in $src_main ; do - src_lib="${src_lib//" "$file_main" "/ }" - done - - # - # define objs from sources - obj_main="" - obj_lib="" - for file in $src_main ; do - obj_main="$obj_main ${file%.*}.o" - done - for file in $src_lib ; do - obj_lib="$obj_lib ${file%.*}.o" - done - - if test "$src_main" - then - echo "#" >> $makefile - echo "# List of MAIN source files" >> $makefile - echo "# (Fortran files containing a program statement):" >> $makefile - echo "# $src_main" | $PADIR/IDE/split_line 80 >> $makefile - fi - if test "$src_lib" - then - echo "#" >> $makefile - echo "# List of LIB source files" >> $makefile - echo "# (Fortran files NOT containing a program statement and c files):" >> $makefile - echo "# $src_lib" | $PADIR/IDE/split_line 80 >> $makefile - fi - echo "#" >> $makefile - -# -# METTI UN CONTROLLO SUI DOPPIONI PIU' VELOCE DI QUESTO -# for file in $src ; do -# for file2 in $src ; do -# if [ $file != $file2 ] && [ ${file%.*} = ${file2%.*} ] ; then -# echo "Duplicated source file: $file $file2" ; exit 1 -# fi -# done -# done -# - - used="$($PADIR/IDE/used -s -d $directory)" - linked= - for dir in $directory $used ; do - linked="$linked$($PADIR/IDE/linked $dir) " - done - - echo "# Used libraries" >> $makefile - echo "#" $used | $PADIR/IDE/split_line 80 >> $makefile - echo "#" >> $makefile - echo "# Linked libraries" >> $makefile - echo "#" $linked | $PADIR/IDE/split_line 80 >> $makefile - echo "#" >> $makefile - - echo "# The real Makefile starts here" >> $makefile - echo "#" >> $makefile - - echo "# IDE HOME variable set to DEFAULT" >> $makefile - echo "IDEHOME=$IDEHOME" >> $makefile - echo "# Default configuratione file" >> $makefile - echo "CONFIG_FILE=$CONFIG_FILE" >> $makefile - echo "#" >> $makefile - - echo "# Objects to be linked in the library" >> $makefile - echo "OBJ_LIB=$obj_lib" | $PADIR/IDE/split_line 80 >> $makefile - echo >> $makefile -LIBRARIES="$(cat << EOF -# - -# Macros to link the present library -# (may be change by make.sys to the path of installed library) -LIB_${uppercase_directory}=lib${directory}.a -LIB_${uppercase_directory}_INCLUDE=-I. -I\$(IDEHOME)/$directory/$STDDIR_INCLUDE - -# Switch to enable actual compilation -# (may be change by make.sys to "external") -LIB_${uppercase_directory}_SWITCH=internal -EOF -for file in $($PADIR/IDE/reverse $used) ; do - uppercase_file="$(echo "$file" | tr "[a-z]" "[A-Z]")" -cat << EOF -# Options to link the $uppercase_file library -LIB_${uppercase_file}=\$(IDEHOME)/$file/$STDDIR_SOURCE/lib${file}.a -LIB_${uppercase_file}_INCLUDE=-I\$(IDEHOME)/$file/$STDDIR_SOURCE/ \ - -I\$(IDEHOME)/$file/$STDDIR_INCLUDE - -EOF - -done -for file in $($PADIR/IDE/reverse $linked) ; do - uppercase_file="$(echo "$file" | tr "[a-z]" "[A-Z]")" -cat << EOF -# Options to link the $uppercase_file library -LIB_${uppercase_file}= -LIB_${uppercase_file}_INCLUDE= - -EOF -done - auto_include="\$(LIB_${uppercase_directory}_INCLUDE) " - auto_libs="\$(LIB_${uppercase_directory}) " - for file in $($PADIR/IDE/reverse $used) $($PADIR/IDE/reverse $linked) - do - uppercase_file="$(echo "$file" | tr "[a-z]" "[A-Z]")" - auto_include="$auto_include\$(LIB_${uppercase_file}_INCLUDE) " - auto_libs="$auto_libs\$(LIB_${uppercase_file}) " - done - # -echo "# Path for include" -echo "AUTO_INCLUDE=$auto_include" | $PADIR/IDE/split_line 80 -echo -echo "# List of used library files" -echo "AUTO_LIBS=$auto_libs" | $PADIR/IDE/split_line 80 -)" -echo "$LIBRARIES" >> $makefile - -libs="lib${directory}.a" -for file in $($PADIR/IDE/reverse $used) ; do - libs="${libs} \$(IDEHOME)/$file/src/lib${file}.a" -done - -fi -#define the list of files to tar - - -# SYSTEM DEPENDENT FILES -INCLUDES="$( - echo "# Inclusion of system dependent files" - echo "include \$(CONFIG_FILE)" - echo -)" -echo "$INCLUDES" >> $makefile - -# -# definitions -# keyword DEFINITION from file OPTIONS -# - txt="$(echo "$options" | $PADIR/IDE/getoption DEFINITION)" - echo "# Macro (re)definitions from OPTIONS file (keyword DEFINITION)" >> $makefile - if [ "$txt" ] ; then - echo "$txt" >> $makefile - else - echo "# Nothing found" >> $makefile - fi - echo >> $makefile - - -# -# objs target definition -# -cat >> $makefile << EOF -# Main target -# INFO print a short help -info: - @make print_info -EOF - - -# -# objs target definition -# - echo "# INFO make local library and all executables" >> $makefile - echo "all:" >> $makefile - echo " make loclib" >> $makefile - for file in $obj_main - do - echo " make ${file%.o}.x" >> $makefile - done - echo >> $makefile - echo "# INFO make local library" >> $makefile - echo "loclib: libs loclib_only" >> $makefile - echo >> $makefile - echo "loclib_only: ide_\$(LIB_${uppercase_directory}_SWITCH)" >> $makefile - echo >> $makefile - echo "ide_internal: lib${directory}.a" >> $makefile - echo >> $makefile - echo "ide_external: fake_external.a" >> $makefile - echo >> $makefile - echo "fake_external.a:" >> $makefile - echo " touch \$(OBJ_LIB)" >> $makefile - echo " touch lib${directory}.a" >> $makefile - echo " touch fake_external.a" >> $makefile - -# -# executables loading -# - echo "# Targets for executables" >> $makefile - for file in $obj_main - do - echo "# INFO make program ${file%.o}.x" >> $makefile - echo "${file%.o}.x: ${file} $libs" >> $makefile - echo " make loclib_only" >> $makefile - echo " \$(LD) \$(LDFLAGS) -o ${file%.o}.x $file \$(AUTO_LIBS) \$(MPI_LIBS) \$(LD_LIBS)" >> $makefile -#Q-ESPRESSO -# echo " \$(LD) \$(LDFLAGS) -o ${file%.o}.x $file \$(AUTO_LIBS) \$(LIBS)" >> $makefile -# echo " cd \$(IDEHOME)/$directory/$STDDIR_BINARY ; \ -# ln -sf \$(IDEHOME)/$directory/$STDDIR_SOURCE/${file%.o}.x . " >> $makefile -#Q-ESPRESSO - done - echo >> $makefile - echo >> $makefile - - -# -# local library -# - echo "# Targets for libraries" >> $makefile - echo "# INFO make local library (without the used libraries)" >> $makefile - echo "lib${directory}.a: \$(OBJ_LIB)" >> $makefile - echo " \$(AR) \$(ARFLAGS) lib${directory}.a \$(OBJ_LIB)" >> $makefile - echo " \$(RANLIB) lib${directory}.a" >> $makefile - echo >> $makefile - -# -# other libraries -# - echo "# INFO make all the used libs" >> $makefile - echo "libs:" >> $makefile - for file in $used - do - echo " cd \$(IDEHOME)/$file/$STDDIR_SOURCE ; make loclib_only" >> $makefile - done - echo >> $makefile - echo >> $makefile - - -# -# Makefile re-generation -# -echo "# target for making Makefile" >> $makefile -echo "# INFO make local Makefile" >> $makefile -echo "make: " >> $makefile -echo " cd \$(IDEHOME) ; $PADIR/IDE/makemake.sh $directory " >> $makefile -echo >> $makefile -#Q-ESPRESSO -#echo "# INFO make local and libs Makefiles" >> $makefile -#echo "allmake:" >> $makefile -#for lib in $used -#do -# echo " cd \$(IDEHOME) ; $PADIR/IDE/makemake.sh $lib " >> $makefile -# echo " cd \$(IDEHOME) ; $PADIR/IDE/makemake.sh $directory " >> $makefile -#done -#echo >> $makefile -#echo >> $makefile -#Q-ESPRESSO - -# -# cleaning -# -echo "# target for cleaning" >> $makefile -echo "clean_: clean" >> $makefile -echo "# INFO cleanup" >> $makefile -echo "clean: " >> $makefile -echo " - rm -f $SUFFIXES_CLEAN" >> $makefile -echo " - rm -rf \$(IDEHOME)/$directory/$STDDIR_TMP/*" >> $makefile -echo " - rm -f \$(IDEHOME)/$directory/$STDDIR_BINARY/*.x " >> $makefile -echo >> $makefile - -#Q-ESPRESSO -## -## tarlist (this is a special target, only in the inner file) -## -#echo "tarlist: " >> $makefile -#echo " cd \$(IDEHOME) ; $PADIR/IDE/tarlist.sh $directory > $directory/tmp/tarlist" >> $makefile -#echo >> $makefile -# -# -#echo "# INFO gzipped tar" >> $makefile -#echo "tar: tarlist" >> $makefile -#echo " cd \$(IDEHOME) ; \ -# tar cf $directory-$version.tar \`cat $directory/tmp/tarlist\`" >> $makefile -#echo " cd \$(IDEHOME) ; gzip -9 $directory-$version.tar" >> $makefile -#echo >> $makefile -# -#echo "# INFO gzipped tar including used libraries and IDE" >> $makefile -#echo "alltar: " >> $makefile -#echo " cd \$(IDEHOME) ; \ -# tar cf $directory-$version-withdeps.tar IDE CONFIG configure Makefile" >> $makefile -#test -r OPTIONS && -# echo " cd \$(IDEHOME) ; \ -# tar rf $directory-$version-withdeps.tar OPTIONS" >> $makefile -#echo " cd \$(IDEHOME) ; \ -# tar rf $directory-$version-withdeps.tar \`cat $directory/tmp/tarlist\`" >> $makefile -#for lib in $used ; do -# echo " cd \$(IDEHOME)/$lib/src ; make tarlist" >> $makefile -# echo " cd \$(IDEHOME) ; tar rf $directory-$version-withdeps.tar \`cat $lib/tmp/tarlist\`" >> $makefile -#done -#echo " cd \$(IDEHOME) ; gzip -9 $directory-$version-withdeps.tar" >> $makefile -#echo >> $makefile -#Q-ESPRESSO - -# -# directly added Makefile lines -# keyword MAKEFILE in OPTIONS -# -# see later on keyword HOME_MAKEFILE for -# lines directly added to outer Makefile -# - echo "# Directly added lines from OPTIONS file (keyword MAKEFILE)" >> $makefile - txt=`echo "$options" | $PADIR/IDE/getoption MAKEFILE` - if [ ! -z "$txt" ] ; then - echo "# Directly added lines" >> $makefile - echo "$txt" >> $makefile - echo >> $makefile - else - echo "# Nothing found" >> $makefile - fi - - - - -# -# Makefile special rules -# - echo "# Special rules for selected files (keyword DEFINITION.filebase)" >> $makefile -found="$(echo "$options" | $PADIR/IDE/getoption "DEFINITION.*")" -if [ "$found" ] ; then - first=yes - for file in $src - do - file_base="${file%.*}" - newrule="$(echo "$options" | $PADIR/IDE/getoption DEFINITION.$file_base)" - # - # if something is found - if [ "$newrule" ] ; then -# Temporaneamente, lo faccio copiando il file makefile -# Ci sarebbero varie cose inutili, e da eliminare - makefile_name=$tmpdir/Makefile.$file_base - echo "$HEADER" > $makefile_name - echo "# Special makefile for file $file" >> $makefile_name - echo "IDEHOME=$IDEHOME" >> $makefile_name - echo "$LIBRARIES" >> $makefile_name - echo >> $makefile_name - echo "$INCLUDES" >> $makefile_name - echo >> $makefile_name - echo "$newrule" >> $makefile_name - - if [ "$first" ] ; then - echo "# Special rules" >> $makefile - first= - fi - echo "$file_base.o: $file" >> $makefile - echo " make -f Makefile.$file_base $file_base.o" >> $makefile - echo >> $makefile - fi - done - echo >> $makefile -else - echo "# Nothing found" >> $makefile -fi - echo >> $makefile - -cat >> $makefile << EOF -print_info: - @echo " Package : $package" - @echo " Version : $version" - @echo " Authors : $authors" - @echo - @echo " type: make " - @echo " Possible 's are:" -EOF -cat $makefile | $PADIR/IDE/makeinfo.sh >> $makefile - -if [ "$src" ] ; then - # - echo "# Dependencies" >> $makefile - cd $directory/$STDDIR_SOURCE - dirs="../$STDDIR_INCLUDE" - for lib in $used ; do - dirs="$dirs ../../$lib/$STDDIR_SOURCE ../../$lib/$STDDIR_INCLUDE" - done - # - # search for dependencies - txt=`../../$PADIR/IDE/moduledep.sh $dirs` - cd - - # check for missing dependencies - txttmp=`echo "$txt" | grep @` - if [ -n "$txttmp" ] ; then - echo "$txttmp" - echo "WARNING: modules not found in directories:" - echo " $dirs" - fi - echo "$txt" >> $makefile - echo "# End dependencies" >> $makefile -fi - -# -# Outer makefile generation -#for target in $list_of_targets -#do - #echo >> $makefile_outer - #echo "$target: " >> $makefile_outer - #echo " cd $STDDIR_SOURCE ; make $target " >> $makefile_outer -#done -# -## -## directly added Makefile lines in outer Makefile -## keyword HOME_MAKEFILE in OPTIONS -## - #echo >> $makefile_outer - #txt=`echo "$options" | $PADIR/IDE/getoption HOME_MAKEFILE` - #if [ ! -z "$txt" ] ; then - #echo "# Directly added lines" >> $makefile_outer - #echo "$txt" >> $makefile_outer - #echo >> $makefile_outer - #fi -# -## -# now copy the created makefile in the right positions -rm -f $directory/$STDDIR_SOURCE/Makefile $directory/$STDDIR_SOURCE/Makefile.* -mv $makefile $directory/$STDDIR_SOURCE/Makefile -[ "$(echo $tmpdir/Makefile.*)" ] && cp $tmpdir/Makefile.* $directory/$STDDIR_SOURCE -$PADIR/IDE/makeouter.sh $STDDIR_SOURCE < $directory/$STDDIR_SOURCE/Makefile > $directory/Makefile - -exit 0 - diff --git a/quantum_espresso/kcp/iotk/IDE/makeouter.sh b/quantum_espresso/kcp/iotk/IDE/makeouter.sh deleted file mode 100755 index 5c073d0e8..000000000 --- a/quantum_espresso/kcp/iotk/IDE/makeouter.sh +++ /dev/null @@ -1,23 +0,0 @@ -#!/bin/bash -# Generates outer makefile form inner makefile -# Usage: makeouter.sh PATH -# where PATH is the relative path of the inner makefile -# with respect to the outer makefile -# inner makefile is read on stdin -# outer makefile is written on stdout - -shopt -s extglob - -[ $# -ne 1 ] && { echo "Incorrect usage" ; exit 1 ; } - -while read LINE ; do - if [[ $LINE == +([^=#\"]):* ]] ; then - TARGET="${LINE%%*([[:space:]]):*}" - [[ $TARGET == *.o ]] && continue - echo "$TARGET:" - echo " cd $1 ; make $TARGET" - echo - fi -done - - diff --git a/quantum_espresso/kcp/iotk/IDE/makeversion.sh b/quantum_espresso/kcp/iotk/IDE/makeversion.sh deleted file mode 100755 index 51f000b2d..000000000 --- a/quantum_espresso/kcp/iotk/IDE/makeversion.sh +++ /dev/null @@ -1,41 +0,0 @@ -#!/bin/bash - -PADIR=iotk - -source $PADIR/IDE/IDE.conf - -shopt -s extglob - -directory=$1 -DIRECTORY=$(echo $directory | tr "[a-z]" "[A-Z]") -version="$($PADIR/IDE/getoption -c VERSION < $directory/README)" -if [ -r $directory/include/${directory}_version.sh ] ; then - . $directory/include/${directory}_version.sh - eval written_version=\$__${DIRECTORY}_VERSION - test $version = $written_version && exit -fi -test -z "$version" && exit -[[ "$version" != $VERSRULE ]] && exit - -version_major="${version%%.*}" -version_minor="${version#+([[:alnum:]]).}" -version_minor="${version_minor%%.*}" -version_patch="${version#+([[:alnum:]]).+([[:alnum:]]).}" -version_patch="${version_patch%%[[:alpha:]]*}" -version_extra="${version#+([[:alnum:]]).+([[:alnum:]]).+([[:alnum:]])}" - -echo > $directory/include/${directory}_version.h "\ -#define __${DIRECTORY}_VERSION \"$version\" -#define __${DIRECTORY}_VERSION_MAJOR $version_major -#define __${DIRECTORY}_VERSION_MINOR $version_minor -#define __${DIRECTORY}_VERSION_PATCH $version_patch -#define __${DIRECTORY}_VERSION_EXTRA \"$version_extra\"" - -echo > $directory/include/${directory}_version.sh "\ -__${DIRECTORY}_VERSION=$version -__${DIRECTORY}_VERSION_MAJOR=$version_major -__${DIRECTORY}_VERSION_MINOR=$version_minor -__${DIRECTORY}_VERSION_PATCH=$version_patch -__${DIRECTORY}_VERSION_EXTRA=$version_extra" - - diff --git a/quantum_espresso/kcp/iotk/IDE/moduledep.sh b/quantum_espresso/kcp/iotk/IDE/moduledep.sh deleted file mode 100755 index 36e7e2d13..000000000 --- a/quantum_espresso/kcp/iotk/IDE/moduledep.sh +++ /dev/null @@ -1,117 +0,0 @@ -#!/bin/sh -# moduledep.sh -- script that computes dependencies on Fortran 90 modules -# 13.08.04 -- also dipendencies on #include files are serched - -# files whose dependencies must be computed -touch __tmp__.f90 -sources=`ls *.f90 ` -if [ "$sources" = "" ] ; then - exit 0 -fi - -# files that may contain modules -# extra directories can be specified on the command line -touch __tmp__.h -sources_all="$sources `ls *.h`" -for dir in $* -do - touch $dir/__tmp__.f90 - touch $dir/__tmp__.h - sources_all="$sources_all `ls $dir/*.f90 $dir/*.h `" -done - -# remove previous contents -rm -f moduledep.tmp1 moduledep.tmp2 - - -# create list of module dependencies -# each line is of the form: -# file_name.o : @module_name@ -# cast all module names to lowercase because Fortran is case insensitive -egrep -i "^ *use " $sources | # look for "USE name" -sed 's/f90:/o / - s/,/ /' | # replace extension, insert space -# # and remove trailing comma -awk '{print $1 " : @" tolower($3) "@"}' | # create dependency entry -sort | uniq > moduledep.tmp1 # remove duplicates - - -# create alist of dependencies on .h files -# the form is as before : -# filename.o : @include_file.h@ -# case is mantained for include file names -egrep -i "^# *include" $sources | # look for #include statement -egrep -v "<.*>" | # avoid lines like "#include " -sed 's/f90:/o / - s/,/ / - s/\"/ /g - s/#/ / - s/include/ /' | tr -d "\'" | -# # replace extension, insert space -# # remove trailing comma -# # remove double and single quotes -# # remove '# include' statements -# -awk '{print $1 " : @" $2 "@"}' | # create dependency entry -sort | uniq >> moduledep.tmp1 # remove duplicates - - -# create list of available modules -# for each module, create a line of the form: -# s/@module_name@/file_name/ -egrep -i "^ *module " $sources_all | # look for "MODULE name" -sed 's/f90:/o / - s/\//\\\//g' | # replace extension, insert -# # space and escape slashes -awk '{print "s/@" tolower($3) "@/" $1 "/" }' | # create substitution line -sort | uniq > moduledep.tmp2 # remove duplicates - -# The line is the following for include files: -# s/@include_file.h@/complete_file_name/ - -rm -rf moduledep.pathnames moduledep.names -LIST=` -echo $sources_all | -tr " " "\n" | # everithing on a different line -grep -v "\.f90" | # delete all f90 files -grep -v "__tmp__.h"` # delete __tmp__.h from the LIST -echo "$LIST" | # insert space and escape slashes -sed 's/\//\\\//g' > moduledep.pathnames - -echo "$LIST" | -tr "\/" "\n" | # all the / become new-line -grep "\.h" > moduledep.names # get the simple names of the include files - -paste moduledep.names moduledep.pathnames | # merging the names and the names+path -awk '{print "s/@" $1 "@/" $2 "/" }' | -sort | uniq >> moduledep.tmp2 - -rm -f moduledep.names moduledep.pathnames - -# replace module names with file names -# by applying the file of substitution patterns just created -sed -f moduledep.tmp2 moduledep.tmp1 | -awk '{if ($1 != $3) print}' | # remove self dependencies -sort | uniq # remove duplicates - - -# remove false module names arosen from -# MODULE PROCEDURE interfaces - -egrep -v "@procedure@" moduledep.tmp2 > __tmp__ -mv __tmp__ moduledep.tmp2 - - -# removing __tmp__.f90 __tmp__.h from all dirs -# including the current dir -test -e __tmp__.f90 && rm __tmp__.f90 -test -e __tmp__.h && rm __tmp__.h -for dir in $* -do - test -e $dir/__tmp__.f90 && rm $dir/__tmp__.f90 - test -e $dir/__tmp__.h && rm $dir/__tmp__.h -done - - -rm -f moduledep.tmp1 moduledep.tmp2 # remove temporary files - diff --git a/quantum_espresso/kcp/iotk/IDE/packls.sh b/quantum_espresso/kcp/iotk/IDE/packls.sh deleted file mode 100755 index 9e86796b8..000000000 --- a/quantum_espresso/kcp/iotk/IDE/packls.sh +++ /dev/null @@ -1,54 +0,0 @@ -#!/bin/bash - -MANUAL="\ - USAGE - packls.sh [-h] - returns the list of available packages l -" -shopt -s extglob - -while getopts :h OPT -do - case $OPT in - (h) echo "$MANUAL" ; exit 0 ;; - (:) echo "error: $OPTARG requires an argument" ; exit 1 ;; - (?) echo "error: unkwown option $OPTARG" ; exit 1 ;; - esac -done - -# -# load DEFAULTS -if [ ! -e ./IDE/IDE.conf ] ; then - echo "ERROR: Unable to find ./IDE/IDE.conf" ; exit 1 -fi -. ./IDE/IDE.conf - - -# -# load OPTIONS -options= -test -r OPTIONS && options="$(cat OPTIONS)" - -# -# load dir list and skip selected dir -skip_dirs="$(echo "$options" | IDE/getoption -c SKIP ) -IDE -CVS -CVSROOT -CONFIG" -for lib in $NAMERULE -do - found= - for lib2 in $skip_dirs ; do - [[ $lib = $lib2 ]] && { found=yes ; break ; } - done - test -z "$found" && - test -d $lib && - [[ $lib != @(IDE|CONFIG|tmp) ]] && - IDE_LIBS="$IDE_LIBS$lib -" -done - -echo "$IDE_LIBS" -exit 0 - diff --git a/quantum_espresso/kcp/iotk/IDE/reverse b/quantum_espresso/kcp/iotk/IDE/reverse deleted file mode 100755 index a75074580..000000000 --- a/quantum_espresso/kcp/iotk/IDE/reverse +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/sh - -# Writes in output the list of command-line arguments reversed. - -echo $* | tr " " "\n" | sed '1!G;h;$!d' | tr "\n" " " -echo - diff --git a/quantum_espresso/kcp/iotk/IDE/split_line b/quantum_espresso/kcp/iotk/IDE/split_line deleted file mode 100755 index 8627d7220..000000000 --- a/quantum_espresso/kcp/iotk/IDE/split_line +++ /dev/null @@ -1,67 +0,0 @@ -#!/bin/bash - -MAXLEN=$1 - -IFS=" -" -while read -r LINE ; do - comment= - escape= - space= - if [ ${LINE::1} == "#" ] ; then - comment='#' - LINE="${LINE#?}" - else - escape='\' - fi - while [ ${#LINE} -gt $MAXLEN ] ; do - PIECE="${LINE::$MAXLEN}" - PIECE="${PIECE% *}" - echo -E "$comment$space$PIECE$escape" - LINE="${LINE#"$PIECE"}" - space= - if [[ ${LINE::1} == " " ]] ; then - space=" " - LINE="${LINE#" "}" - fi - done - echo -E "$comment$space$LINE" -done - - - -exit -# old version follows - -while read LONG_LINE -do - -LINE="" -TOTLEN=0 -FIRST=yes -for WORD in $LONG_LINE -do - LEN=`echo $WORD | wc -c ` - EXPECTED_LEN=`expr $TOTLEN + $LEN` - if(test $EXPECTED_LEN -gt $MAXLEN) - then - if(test $FIRST = yes) then - echo $LINE \\ - FIRST=no - else - echo ' ' $LINE \\ - fi - LINE="" - TOTLEN=3 - fi - LINE="$LINE $WORD" - TOTLEN=`expr $TOTLEN + $LEN` -done -if(test $FIRST = yes) then - echo $LINE - FIRST=no -else - echo ' ' $LINE -fi -done - diff --git a/quantum_espresso/kcp/iotk/IDE/tarlist.sh b/quantum_espresso/kcp/iotk/IDE/tarlist.sh deleted file mode 100755 index 35a2560d8..000000000 --- a/quantum_espresso/kcp/iotk/IDE/tarlist.sh +++ /dev/null @@ -1,24 +0,0 @@ -#!/bin/bash - -source IDE/IDE.conf - -shopt -s extglob - -directory=$1 - -tarlist="$(find $directory -type f -o -type l)" -newtarlist= -#cleanlist=$(cd $directory/src ; ls $SUFFIXES_CLEAN 2>/dev/null) -for file in $tarlist ; do - found= - for expression in $SUFFIXES_CLEAN ; do - [[ $file == $directory/src/$expression ]] && found=yes && break - done - [ $found ] || { [[ $file == $directory/tmp/[^.]* ]] && found=yes ; } - [ $found ] || { [[ $file == $directory/bin/*.x ]] && found=yes ; } - [ $found ] || newtarlist="$newtarlist $file" -done -tarlist="$newtarlist" - -echo "$tarlist" - diff --git a/quantum_espresso/kcp/iotk/IDE/used b/quantum_espresso/kcp/iotk/IDE/used deleted file mode 100755 index de119f885..000000000 --- a/quantum_espresso/kcp/iotk/IDE/used +++ /dev/null @@ -1,75 +0,0 @@ -#!/bin/bash - -PADIR=iotk - -MANUAL="\ - returns list of used libraries - used [-r] [-s] [-i] [DIR] - -r) acts recursively, eliminating duplicated names - -s) like -r, but also order by number of inclusions. - this is the correct compilation order. - -i) takes from stdin the OPTION file directly -" - -recursive= -sort= -interactive= -directory= -level=0 - -while getopts :rsid:n: OPT -do - case $OPT in - (h) echo "$MANUAL" ; exit 0 ;; - (r) recursive=yes ;; - (s) recursive=yes ; sort=yes ;; - (i) interactive=yes ;; - (d) directory=$OPTARG ;; - (n) level=$OPTARG ;; - (:) echo "error: $OPTARG requires an argument" ; exit 1 ;; - (?) echo "error: unkwown option $OPTARG" ; exit 1 ;; - esac -done - -if [ $level -gt 40 ] ; then - echo "Probable recursion" 1>&2 - exit 1 -fi - -# se c'e' un uso ricorsivo si pianta -newlevel=`expr $level + 1` - -if [ -z "$interactive" ] ; then - - test -d $directory || exit 1 - test -r $directory/OPTIONS && - list="$($PADIR/IDE/getoption -c USE < $directory/OPTIONS)" -else - stdin=$(cat) - list="$(echo "$stdin" | $PADIR/IDE/getoption -c USE)" -fi - -if [ "$recursive" ] ; then - glist="" - for element in $list - do - glist="$glist -$element -`$PADIR/IDE/used -r -d $element -n $newlevel`" - done - output="`echo "$glist" | grep -v "^$" | sort | uniq`" - if [ -n "$sort" ] ; then - newoutput="" - for element in $output - do - newoutput="$newoutput`$PADIR/IDE/used -r -d $element | wc -l` $element -" - done - output="`echo "$newoutput" | grep -v "^$" | sort -n | sed 's/^ *[0-9]* *//'`" - fi - test "$output" && echo "$output" -else - test "$list" && echo "$list" -fi - - diff --git a/quantum_espresso/kcp/iotk/License b/quantum_espresso/kcp/iotk/License deleted file mode 100644 index 92b8903ff..000000000 --- a/quantum_espresso/kcp/iotk/License +++ /dev/null @@ -1,481 +0,0 @@ - GNU LIBRARY GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1991 Free Software Foundation, Inc. - 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - -[This is the first released version of the library GPL. It is - numbered 2 because it goes with version 2 of the ordinary GPL.] - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -Licenses are intended to guarantee your freedom to share and change -free software--to make sure the software is free for all its users. - - This license, the Library General Public License, applies to some -specially designated Free Software Foundation software, and to any -other libraries whose authors decide to use it. You can use it for -your libraries, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if -you distribute copies of the library, or if you modify it. - - For example, if you distribute copies of the library, whether gratis -or for a fee, you must give the recipients all the rights that we gave -you. You must make sure that they, too, receive or can get the source -code. If you link a program with the library, you must provide -complete object files to the recipients so that they can relink them -with the library, after making changes to the library and recompiling -it. And you must show them these terms so they know their rights. - - Our method of protecting your rights has two steps: (1) copyright -the library, and (2) offer you this license which gives you legal -permission to copy, distribute and/or modify the library. - - Also, for each distributor's protection, we want to make certain -that everyone understands that there is no warranty for this free -library. If the library is modified by someone else and passed on, we -want its recipients to know that what they have is not the original -version, so that any problems introduced by others will not reflect on -the original authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that companies distributing free -software will individually obtain patent licenses, thus in effect -transforming the program into proprietary software. To prevent this, -we have made it clear that any patent must be licensed for everyone's -free use or not licensed at all. - - Most GNU software, including some libraries, is covered by the ordinary -GNU General Public License, which was designed for utility programs. This -license, the GNU Library General Public License, applies to certain -designated libraries. This license is quite different from the ordinary -one; be sure to read it in full, and don't assume that anything in it is -the same as in the ordinary license. - - The reason we have a separate public license for some libraries is that -they blur the distinction we usually make between modifying or adding to a -program and simply using it. Linking a program with a library, without -changing the library, is in some sense simply using the library, and is -analogous to running a utility program or application program. However, in -a textual and legal sense, the linked executable is a combined work, a -derivative of the original library, and the ordinary General Public License -treats it as such. - - Because of this blurred distinction, using the ordinary General -Public License for libraries did not effectively promote software -sharing, because most developers did not use the libraries. We -concluded that weaker conditions might promote sharing better. - - However, unrestricted linking of non-free programs would deprive the -users of those programs of all benefit from the free status of the -libraries themselves. This Library General Public License is intended to -permit developers of non-free programs to use free libraries, while -preserving your freedom as a user of such programs to change the free -libraries that are incorporated in them. (We have not seen how to achieve -this as regards changes in header files, but we have achieved it as regards -changes in the actual functions of the Library.) The hope is that this -will lead to faster development of free libraries. - - The precise terms and conditions for copying, distribution and -modification follow. Pay close attention to the difference between a -"work based on the library" and a "work that uses the library". The -former contains code derived from the library, while the latter only -works together with the library. - - Note that it is possible for a library to be covered by the ordinary -General Public License rather than by this special one. - - GNU LIBRARY GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License Agreement applies to any software library which -contains a notice placed by the copyright holder or other authorized -party saying it may be distributed under the terms of this Library -General Public License (also called "this License"). Each licensee is -addressed as "you". - - A "library" means a collection of software functions and/or data -prepared so as to be conveniently linked with application programs -(which use some of those functions and data) to form executables. - - The "Library", below, refers to any such software library or work -which has been distributed under these terms. A "work based on the -Library" means either the Library or any derivative work under -copyright law: that is to say, a work containing the Library or a -portion of it, either verbatim or with modifications and/or translated -straightforwardly into another language. (Hereinafter, translation is -included without limitation in the term "modification".) - - "Source code" for a work means the preferred form of the work for -making modifications to it. For a library, complete source code means -all the source code for all modules it contains, plus any associated -interface definition files, plus the scripts used to control compilation -and installation of the library. - - Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running a program using the Library is not restricted, and output from -such a program is covered only if its contents constitute a work based -on the Library (independent of the use of the Library in a tool for -writing it). Whether that is true depends on what the Library does -and what the program that uses the Library does. - - 1. You may copy and distribute verbatim copies of the Library's -complete source code as you receive it, in any medium, provided that -you conspicuously and appropriately publish on each copy an -appropriate copyright notice and disclaimer of warranty; keep intact -all the notices that refer to this License and to the absence of any -warranty; and distribute a copy of this License along with the -Library. - - You may charge a fee for the physical act of transferring a copy, -and you may at your option offer warranty protection in exchange for a -fee. - - 2. You may modify your copy or copies of the Library or any portion -of it, thus forming a work based on the Library, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) The modified work must itself be a software library. - - b) You must cause the files modified to carry prominent notices - stating that you changed the files and the date of any change. - - c) You must cause the whole of the work to be licensed at no - charge to all third parties under the terms of this License. - - d) If a facility in the modified Library refers to a function or a - table of data to be supplied by an application program that uses - the facility, other than as an argument passed when the facility - is invoked, then you must make a good faith effort to ensure that, - in the event an application does not supply such function or - table, the facility still operates, and performs whatever part of - its purpose remains meaningful. - - (For example, a function in a library to compute square roots has - a purpose that is entirely well-defined independent of the - application. Therefore, Subsection 2d requires that any - application-supplied function or table used by this function must - be optional: if the application does not supply it, the square - root function must still compute square roots.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Library, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Library, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote -it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Library. - -In addition, mere aggregation of another work not based on the Library -with the Library (or with a work based on the Library) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may opt to apply the terms of the ordinary GNU General Public -License instead of this License to a given copy of the Library. To do -this, you must alter all the notices that refer to this License, so -that they refer to the ordinary GNU General Public License, version 2, -instead of to this License. (If a newer version than version 2 of the -ordinary GNU General Public License has appeared, then you can specify -that version instead if you wish.) Do not make any other change in -these notices. - - Once this change is made in a given copy, it is irreversible for -that copy, so the ordinary GNU General Public License applies to all -subsequent copies and derivative works made from that copy. - - This option is useful when you wish to copy part of the code of -the Library into a program that is not a library. - - 4. You may copy and distribute the Library (or a portion or -derivative of it, under Section 2) in object code or executable form -under the terms of Sections 1 and 2 above provided that you accompany -it with the complete corresponding machine-readable source code, which -must be distributed under the terms of Sections 1 and 2 above on a -medium customarily used for software interchange. - - If distribution of object code is made by offering access to copy -from a designated place, then offering equivalent access to copy the -source code from the same place satisfies the requirement to -distribute the source code, even though third parties are not -compelled to copy the source along with the object code. - - 5. A program that contains no derivative of any portion of the -Library, but is designed to work with the Library by being compiled or -linked with it, is called a "work that uses the Library". Such a -work, in isolation, is not a derivative work of the Library, and -therefore falls outside the scope of this License. - - However, linking a "work that uses the Library" with the Library -creates an executable that is a derivative of the Library (because it -contains portions of the Library), rather than a "work that uses the -library". The executable is therefore covered by this License. -Section 6 states terms for distribution of such executables. - - When a "work that uses the Library" uses material from a header file -that is part of the Library, the object code for the work may be a -derivative work of the Library even though the source code is not. -Whether this is true is especially significant if the work can be -linked without the Library, or if the work is itself a library. The -threshold for this to be true is not precisely defined by law. - - If such an object file uses only numerical parameters, data -structure layouts and accessors, and small macros and small inline -functions (ten lines or less in length), then the use of the object -file is unrestricted, regardless of whether it is legally a derivative -work. (Executables containing this object code plus portions of the -Library will still fall under Section 6.) - - Otherwise, if the work is a derivative of the Library, you may -distribute the object code for the work under the terms of Section 6. -Any executables containing that work also fall under Section 6, -whether or not they are linked directly with the Library itself. - - 6. As an exception to the Sections above, you may also compile or -link a "work that uses the Library" with the Library to produce a -work containing portions of the Library, and distribute that work -under terms of your choice, provided that the terms permit -modification of the work for the customer's own use and reverse -engineering for debugging such modifications. - - You must give prominent notice with each copy of the work that the -Library is used in it and that the Library and its use are covered by -this License. You must supply a copy of this License. If the work -during execution displays copyright notices, you must include the -copyright notice for the Library among them, as well as a reference -directing the user to the copy of this License. Also, you must do one -of these things: - - a) Accompany the work with the complete corresponding - machine-readable source code for the Library including whatever - changes were used in the work (which must be distributed under - Sections 1 and 2 above); and, if the work is an executable linked - with the Library, with the complete machine-readable "work that - uses the Library", as object code and/or source code, so that the - user can modify the Library and then relink to produce a modified - executable containing the modified Library. (It is understood - that the user who changes the contents of definitions files in the - Library will not necessarily be able to recompile the application - to use the modified definitions.) - - b) Accompany the work with a written offer, valid for at - least three years, to give the same user the materials - specified in Subsection 6a, above, for a charge no more - than the cost of performing this distribution. - - c) If distribution of the work is made by offering access to copy - from a designated place, offer equivalent access to copy the above - specified materials from the same place. - - d) Verify that the user has already received a copy of these - materials or that you have already sent this user a copy. - - For an executable, the required form of the "work that uses the -Library" must include any data and utility programs needed for -reproducing the executable from it. However, as a special exception, -the source code distributed need not include anything that is normally -distributed (in either source or binary form) with the major -components (compiler, kernel, and so on) of the operating system on -which the executable runs, unless that component itself accompanies -the executable. - - It may happen that this requirement contradicts the license -restrictions of other proprietary libraries that do not normally -accompany the operating system. Such a contradiction means you cannot -use both them and the Library together in an executable that you -distribute. - - 7. You may place library facilities that are a work based on the -Library side-by-side in a single library together with other library -facilities not covered by this License, and distribute such a combined -library, provided that the separate distribution of the work based on -the Library and of the other library facilities is otherwise -permitted, and provided that you do these two things: - - a) Accompany the combined library with a copy of the same work - based on the Library, uncombined with any other library - facilities. This must be distributed under the terms of the - Sections above. - - b) Give prominent notice with the combined library of the fact - that part of it is a work based on the Library, and explaining - where to find the accompanying uncombined form of the same work. - - 8. You may not copy, modify, sublicense, link with, or distribute -the Library except as expressly provided under this License. Any -attempt otherwise to copy, modify, sublicense, link with, or -distribute the Library is void, and will automatically terminate your -rights under this License. However, parties who have received copies, -or rights, from you under this License will not have their licenses -terminated so long as such parties remain in full compliance. - - 9. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Library or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Library (or any work based on the -Library), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Library or works based on it. - - 10. Each time you redistribute the Library (or any work based on the -Library), the recipient automatically receives a license from the -original licensor to copy, distribute, link with or modify the Library -subject to these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 11. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Library at all. For example, if a patent -license would not permit royalty-free redistribution of the Library by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Library. - -If any portion of this section is held invalid or unenforceable under any -particular circumstance, the balance of the section is intended to apply, -and the section as a whole is intended to apply in other circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 12. If the distribution and/or use of the Library is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Library under this License may add -an explicit geographical distribution limitation excluding those countries, -so that distribution is permitted only in or among countries not thus -excluded. In such case, this License incorporates the limitation as if -written in the body of this License. - - 13. The Free Software Foundation may publish revised and/or new -versions of the Library General Public License from time to time. -Such new versions will be similar in spirit to the present version, -but may differ in detail to address new problems or concerns. - -Each version is given a distinguishing version number. If the Library -specifies a version number of this License which applies to it and -"any later version", you have the option of following the terms and -conditions either of that version or of any later version published by -the Free Software Foundation. If the Library does not specify a -license version number, you may choose any version ever published by -the Free Software Foundation. - - 14. If you wish to incorporate parts of the Library into other free -programs whose distribution conditions are incompatible with these, -write to the author to ask for permission. For software which is -copyrighted by the Free Software Foundation, write to the Free -Software Foundation; we sometimes make exceptions for this. Our -decision will be guided by the two goals of preserving the free status -of all derivatives of our free software and of promoting the sharing -and reuse of software generally. - - NO WARRANTY - - 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO -WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. -EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR -OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY -KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE -LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME -THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN -WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY -AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU -FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR -CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE -LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING -RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A -FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF -SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Libraries - - If you develop a new library, and you want it to be of the greatest -possible use to the public, we recommend making it free software that -everyone can redistribute and change. You can do so by permitting -redistribution under these terms (or, alternatively, under the terms of the -ordinary General Public License). - - To apply these terms, attach the following notices to the library. It is -safest to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least the -"copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -Also add information on how to contact you by electronic and paper mail. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the library, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the - library `Frob' (a library for tweaking knobs) written by James Random Hacker. - - , 1 April 1990 - Ty Coon, President of Vice - -That's all there is to it! diff --git a/quantum_espresso/kcp/iotk/Makefile b/quantum_espresso/kcp/iotk/Makefile deleted file mode 100644 index 22826ac69..000000000 --- a/quantum_espresso/kcp/iotk/Makefile +++ /dev/null @@ -1,99 +0,0 @@ -info: - cd src ; make info - -all: - cd src ; make all - -loclib: - cd src ; make loclib - -loclib_only: - cd src ; make loclib_only - -ide_internal: - cd src ; make ide_internal - -ide_external: - cd src ; make ide_external - -fake_external.a: - cd src ; make fake_external.a - -example1.x: - cd src ; make example1.x - -example2.x: - cd src ; make example2.x - -example3.x: - cd src ; make example3.x - -example4.x: - cd src ; make example4.x - -iotk_copy.x: - cd src ; make iotk_copy.x - -iotk.x: - cd src ; make iotk.x - -iotk_print_kinds.x: - cd src ; make iotk_print_kinds.x - -test2.x: - cd src ; make test2.x - -test3.x: - cd src ; make test3.x - -test4.x: - cd src ; make test4.x - -test5.x: - cd src ; make test5.x - -test6.x: - cd src ; make test6.x - -test7.x: - cd src ; make test7.x - -test8.x: - cd src ; make test8.x - -test9.x: - cd src ; make test9.x - -test.x: - cd src ; make test.x - -libiotk.a: - cd src ; make libiotk.a - -libs: - cd src ; make libs - -make: - cd src ; make make - -clean_: - cd src ; make clean_ - -clean: - cd src ; make clean - -update: - cd src ; make update - -update-compare: - cd src ; make update-compare - -export: - cd src ; make export - -lib+util: - cd src ; make lib+util - -print_info: - cd src ; make print_info - diff --git a/quantum_espresso/kcp/iotk/OPTIONS b/quantum_espresso/kcp/iotk/OPTIONS deleted file mode 100644 index 0b6f9752f..000000000 --- a/quantum_espresso/kcp/iotk/OPTIONS +++ /dev/null @@ -1,34 +0,0 @@ - -begin MAKEFILE - -# INFO updates all *.f90 files with preprocessor -update: - cd ../include ; ../IDE/bin/sprep --autodep iotk_auxmacros.spp --include . --suffix .h - ../IDE/bin/sprep --autodep *.spp --include ../include - -# INFO similar to update, with --compare-first (still unstable) -update-compare: - cd ../include ; ../IDE/bin/sprep --compare-first --autodep iotk_auxmacros.spp --include . --suffix .h - ../IDE/bin/sprep --autodep *.spp --compare-first --include ../include - -# INFO creates a directory tmp/export containing few source files -export: - cd .. ; tools/export - -# INFO builds the local library and some utilities -lib+util: loclib iotk_print_kinds.x iotk.x - - ( cd ../../bin ; ln -sf ../iotk/src/iotk_print_kinds.x . ) - - ( cd ../../bin ; ln -sf ../iotk/src/iotk.x . ) - - ( cd ../../bin ; ln -sf ../iotk/tools/iotk . ) - -end MAKEFILE - -begin BEFORE_MAKEMAKE -cd include/ -../IDE/bin/sprep --autodep iotk_auxmacros.spp --include . --suffix .h -cd ../ -cd src/ -../IDE/bin/sprep --autodep *.spp --include ../include -end BEFORE_MAKEMAKE - - diff --git a/quantum_espresso/kcp/iotk/README b/quantum_espresso/kcp/iotk/README deleted file mode 100644 index d93808c53..000000000 --- a/quantum_espresso/kcp/iotk/README +++ /dev/null @@ -1,131 +0,0 @@ -PACKAGE Input/Output Tool Kit -VERSION 1.1.0development -AUTHORS Giovanni Bussi -LICENSE GNU LIBRARY GENERAL PUBLIC LICENSE --------------------------------- -CONTACT -gbussi@unimore.it or gbussi@phys.chem.ethz.ch - -DESCRIPTION -This kit is a Fortran90 library intended to provide an easy access to tagged -files formatted using some specific rule. -A tagged file is a file containing tags and data. -Tagged files can be textual, in which case a XML-like format is used, -or binary, in which case a special format is used. -Note that this is not an XML parser, but it can be used as a writer/parser -for a limited subset of XML language. - -STRONG POINTS -* This library is very simple to use (in author's opinion). -* The interaction with files is obtained with an interface some-what - similar to standard Fortran I/O. - As an example, files are accessed through Fortran units, with the - consequences that the library can be easily integrated with other - formatting tools. -* A well-written tagged file can be translated form binary to textual - or vice-versa using a simple translation tool independent from the file - structure. -* The library handles directly any intrinsic Fortran datatype. - Kind conversions are performed transparently. -* The library handles data of any rank, the maximum rank is configurable. -* Textual files conform to XML standard, and can be browsed using an XML browser. -* The library is very easy to compile and to integrate into other environments: - the distribution consists in fortran files plus a configuration file. -* Access is fast. No overhead should be expected in writing/reading binary files - with respect to usual fortran I/O. However, this is not true if one stores - a large number of very small data. -* Files are small. Waste of space is related to tag size, so that if - one stores large data the waste is usually negligible. -* Aspect of data in textual files is controllable with a format string. - Then the library can be used also for log files. -* Objects and complex structures can be easily represented. -* Multiple-files can be linked together. - -WEAK POINTS -* This library cannot read standard XML. - Main lacks are listed here - - contents are processed only if they are written as data, using the proper format - - DTD are not processed at all - - ... -* The binary format is not compatible with any standard format. -* This library has a serial access. If data are written in a given order - and read in a different order, performance overheads are expected. -* This library does not provide parallel I/O functionalities. -* There is presently no feature to list the tags in a file. To found a tag, its - name has to be known. - -DOCUMENTATION -A short reference manual can be found in doc/ - -CONFIGURATION FILES -The library is configured through C preprocessor directives. -Preset configurations can be found in include/iotk_config.h file. -This file can be modified to satisfy user's needs or to add new -machines. -Note that in the iotk_config.h file there are definitions needed -as workaround for buggy compilers. -Smaller number of kinds and smaller maxrank mean shorter -compilation time. -An optimal iotk_config.h file can also be generated using the -script tools/auto_config (try auto_config --help). -Moreover, if you want to distribute the code and you would like -also smaller source files, you can edit the file -include/iotk_config.sh and modify the number of available kinds -(valid for each type except characters) and the maximum -rank. After editing this file, run "make update". - -PORTABILITY -The library is written in standard fortran 90, with no extensions. -It has been tested on g95 (latest version), ifort (8.1), -pgf90, xlf90 (9.1), mips f90, nag f90. For some of these compilers -workarounds are needed. The list of workarounds can be generated -with tools/auto_config. -Please signal other portability issues. - -IN-PLACE COMPILATION -The library is part of the S3 Development Environment. -To compile the library in place simple type 'make all'. -The file ../CONFIG/make.sys has to be adapted to the actual machine. - -EXPORTING THE LIBRARY -The source files are all written in standard f90 with cpp directives/macros. -Then, you need a C preprocessor and a f90 compiler. -Be sure that your C preprocessor is able to preprocess Fortran files -and that it expands macros. -Since the number of source files in the src directory -is quite high, it is generally convenient to pack them. -This can be done automatically typing 'make export' -(equivalently, running tools/export from the iotk home directory). -The needed files are created in tmp/export. -The correct order for compilation is alphabetic, usually obtainable as: -f90 iotk_*.f90 - -CONTRIBUTING -The easiest way to contribute is to report bugs (see BUG REPORTING). -Also discussions about the programmer interface or the file formats -are welcome. -Finally, one can directly edit the library. In this case, -he should keep in account the fact that the .f90 files are obtained -from smaller .spp files using the sprep preprocessor. -If you modify the .spp files, run "make update". - -BUG REPORTING -When reporting a bug, include everything necessary to reproduce it, plus: -- version number -- date, if taken from CVS -- if an error is issued, the complete error message -If possible, produce a small testcase which will be eventually -included in the test suite. - -BINARY FILES -Binary files cannot be edited manually. -However, opening them with vi (at least with vim) shows their -tag structure. The following command can be used to extract -all the tags from a binary files -sed -n '/^ *<[^<>]*>$/p' filename -Note that in some case also non-tag data are extracted. - -ACKNOWLEDGEMENTS -Andrea Ferretti, for useful discussions and testing -Carlo Cavazzoni, for useful discussions - diff --git a/quantum_espresso/kcp/iotk/TODO b/quantum_espresso/kcp/iotk/TODO deleted file mode 100644 index 4c02dbebe..000000000 --- a/quantum_espresso/kcp/iotk/TODO +++ /dev/null @@ -1,78 +0,0 @@ -FOR VERSION 1.0 -* Testing on other machines/compilers (at least Lahey). -* More debug. - -FOR VERSION 1.1 -* Integration with the automatic configurator. -* Provide instructions and some automatization to run tests for bugs - outside configure. Since configure can have some problem on - particular systems (or with cross-compiling), an user should - be able to produce the configuration file by hand. -* Documentation: better reference manual. -* Better examples and better test suite. -* Arrive to a stable version of the S3DE and of sprep preprocessor. -* Improvement of the iotk tool -* Check the implementation of columns. Add the possibility of specifying the - delimiter, forcing the compatibility with the reading conventions, - so that the delimiter itself is not needed for reading - but is used just for cosmetic reasons. - -SHORT TERM - Modifications not involving file format -* Code cleaning: - + generic clean-up. - + clean the iotk_unit object; possibly use sprep to define a kind of - object container for the linked-list. The same structure could be used - for errors (pay attention to memory leakage due to distract users.) - + clean format related routines. -* Possibility of opening a unit in a safe mode. Unit opened in safe mode - should be locked (user cannot access directly to the physical unit number) - and should forbid some writing features, to ensure complete - portability and transformability from binary to textual and viceversa. - For example, fmt should not be allowed. -* Direct handling of ASCII/binary conversions also for real and complex data. -* Write down an exact specification of the fortran format used. It can be useful - for external non-fortran programs that need to read textual files. -* Implement double interfaces with errors and integers. -* Transform some of the global options in unit parameter, possibly with - an hereditary mechanism. -* Allow real-time control of WORKAROUND1; even the check for its need could be posticipated - to the run-time situation (think about this). -* Allow real-time control of stream/sequential access and of the stream kind - It could be very interesting to find a way to use streams to overcome little-endian/big-endian - portability problems (think about this). A nice way would be to detect endianness automatically - when opening a file. However, it will not be easy to be systematic on every machine. -* Routines to count/list attributes. -* Documentation: a tutorial. (parola grossa!) -* Documentation: man pages for individual routines. -* Add some tools for system installation. -* Add a "default" keyword also in writing routines. If the dat (or attr) is - equal to the default, then DO NOT write it. - This improves the simmetry in reading/writing. -* Search through some XPATH inspired approach. - Example: iotk_scan_begin(unit,"name[@type='real']") should search the first tag named name - with an attribute type set to real. - Example: iotk_scan_begin(unit,"*[@type='real']") should search the first tag - with an attribute type set to real. -* Interface with C I/O. -* Interface with f2003 streams. -* Possibility of scanning with multiple tags, i.e. iotk_scan_begin(unit,"uno/due/tre") - should search uno then due then tre. Attributes should come from the last tag. - Also possibility of specifying the starting tag in the iotk_open_read subroutine. - -MEDIUM TERM - Modifications involving file format -* In textual data, add informations about the number of significant digits - and the maximum allowed number. Can be used to select the kind when going - from textual to binary. -* Arrays of character are now written with one item per line, newline separated. - Try to find a more flexible approach. -* More flexible iotk commands inside files. -* Substitute iotk_link with xinclude (?). Maybe a better idea is to keep both. - -LONG TERM - Just ideas -* Direct access to block files. -* Tables. -* Some smarter way to read/write objects. -* Interface with other libraries (HDF,...) -* Documentation: a complete and rigorous definition of the file formats, both - textual and binary. - diff --git a/quantum_espresso/kcp/iotk/configure b/quantum_espresso/kcp/iotk/configure deleted file mode 100755 index 868ac4e02..000000000 --- a/quantum_espresso/kcp/iotk/configure +++ /dev/null @@ -1,15 +0,0 @@ -#! /bin/sh -# wrapper for tools/configure - -# run from directory where this script is -auxdir=`echo $0 | sed 's/\(.*\)\/.*/\1/'` # extract pathname -if [ "$auxdir" != "configure" ] ; then cd $auxdir ; fi - -# pass the arguments to the real configure script -if test $# -eq 0 -then - tools/configure -else - tools/configure "$@" -fi - diff --git a/quantum_espresso/kcp/iotk/doc/binary_format.tex b/quantum_espresso/kcp/iotk/doc/binary_format.tex deleted file mode 100755 index 45955cd97..000000000 --- a/quantum_espresso/kcp/iotk/doc/binary_format.tex +++ /dev/null @@ -1,264 +0,0 @@ -\documentclass[12pt]{article} -\author{Giovanni Bussi} -\title{IOTK binary files} -\begin{document} - -\maketitle - -The input/output tool kit (IOTK) is a Fortran 90 -library designed to help input/output formatting. -The library is able to handle textual files and -binary files with an identical interface. -The syntax of textual files is based on XML. -In this short document I explain how to map -the syntax of the binary files onto the textual -format. -This translational rules are used inside the -IOTK library, but could be easily implemented -in other parsers. - -Of course these binary files are not portable across -platforms. However, since there is a one-to-one -correspondence between this format and -textual XML files, they can be -converted to text and compressed for porting or -archiving, -while they can be used directly when the -I/O performance is an issue, e.g. for restart files. - -\section{Fortran binary files} -A IOTK binary file is a sequential-access, binary -Fortran file. -It is basically a sequence of binary records, -each of them accessed through a single Fortran -I/O statement. -When reading a Fortran file, one is able to skip -a record using an empty {\tt read} command, -or even to read just the beginning of a record -of unknown length. -That is, if one writes a file with -\begin{verbatim} -write(10) a,b -write(10) c,d -\end{verbatim} -and is interested in retrieving the value of -{\tt a} and {\tt c} only, they can be read from -the file with -\begin{verbatim} -read(10) a -read(10) c -\end{verbatim} -To obtain this flexibility, the Fortran I/O -library writes two record markers, one before the record -and one after it. -This record markers are usually 4 bytes integers indicating -the length of the record, expressed in bytes. -In the following, I will describe the file format -in term of Fortran statements, and I -will never include in the description these implicit -record markers. The only effect of these markers is -the Fortran ability to skip part of the data in a record. - -\section{Tags in IOTK binary files} -Tags are represented in IOTK binary files directly -as character strings. That is, the tag -{\tt } will be written -as a string {\tt ''}. -The only additional information which is required to -be stored in the file is the length of the tag itself, -so that it can be read back. The IOTK library -also stores informations about the type of -the written tag (begin tag, end tag, -comment tag, etc.). These informations are useful -to know the type of a tag without the need of parsing -the tag string. - -Each tag is written to a file as a pair of records.% -\footnote{The decision of writing two successive records -is motivated by the observation that (a) Fortran needs to -know in advance the length of a record to read it entirely -and (b) backspace operations are to be avoid to not -affect the performance of the I/O action.} -The two records representing a tag are written as -\begin{verbatim} -integer(iotk_header_kind) :: header1,header2 -write(unit) header1 -write(unit) header2,trim(tag) -\end{verbatim} -The kind of the headers is chosen to have 4 bytes integers.% -\footnote{ -It can be configured in the IOTK configuration file, -the default being {\tt selected\_int\_kind(8)}} -The information about the type of tag is represented -as a control code, defined using the following -conventions: -\\[0.5cm] -\begin{tabular}{lll} -\hline -control code & meaning & example tag \\ -\hline -1 & begin & {\tt } \\ -2 & end & {\tt } \\ -3 & empty & {\tt } \\ -4 & comment & {\tt } \\ -5 & processing instruction & {\tt } \\ -128 & (used for {\tt header2}) & --- \\ -\hline -\end{tabular} -\\[0.5cm] -The integer values of {\tt header1} and {\tt header2} -incorporate both the control code and the tag length as -\begin{verbatim} -header1 = control + 256*len_trim(tag) -header2 = 128 + 256*len_trim(tag) -\end{verbatim} -so that the tag length and the control code can be -extracted from the first header as -\begin{verbatim} -control = modulo(header1,256) -taglen = header1/256 -\end{verbatim} -and can be used to properly read the second record. -The second header can be used for a check. - -Note that the {\tt taglen} variable represents the length of -the string written on the file, so that the length of -the second record will be {\tt taglen} \emph{plus} the -four bytes for the header. -This string can be longer than the real tag, since -the library allows additional arbitrary characters -before and after the tag. -Any character before the {\tt <} symbol and after the -{\tt >} symbol is removed on reading. This allows -to put extra characters to help formatting before -and after the tag itself. The library presently adds -a newline character plus a variable number of space before -the tag and an additional newline character after the tag. -That is, the tag {\tt } will -be written as -\begin{verbatim} -tag='' -tagwrite='\n '//trim(tag)//'\n' -! the number of spaces before the tag is arbitrary -write(unit) 1 + 256*len_trim(tagwrite) -! 1 is the control code for a begin tag -write(unit) 128 + 256*len_trim(tagwrite),trim(tagwrite) -\end{verbatim} -The newlines help if one wants to use line-based tools like grep and sed to scan the binary files.% -\footnote{Inside the IOTK library, the newline is represented as {\tt achar(10)}. -However, since it is skipped on reading, any character other then {\tt <} -or {\tt >} could be used.} -The extra spaces can be used for tag indentation. -Reading that tag is easily done with -\begin{verbatim} -read(unit) header1 -control = modulo(header1,256) -! the control code carries the information concerning the type of the tag -taglen = header1/256 -read(unit) header2,tagread(1:taglen) -select case(control) -case(1) - predelim="<" ; postdelim=">" -case(2) - predelim="" -case(3) - predelim="<" ; postdelim="/>" -case(4) - predelim="" -case(5) - predelim="" -end select -tag=tagread((index(tagread,trim(predelim))): & - (index(tagread,trim(postdelim)))) -\end{verbatim} -The tag now is ready to be parsed with a standard XML parser. - -\section{Data in IOTK files} - -The representation of data in IOTK files is self-describing. -That is, any intrinsic Fortran object written in the file -should carry informations about its type and kind, plus -size for arrays and length for strings. -Using these informations, an external tool which does not -know anything about the content should be able -to reformat the data, that is to bring them from the binary -representation to the XML textual one. -Moreover, when the IOTK library is used to read the data back, -it is able to check size consistency and to -perform transparent kind conversion. - -In this context an intrinsic Fortran object is a scalar -or an array of an intrinsic type and of any possible kind. -In the textual representation it is written as -the value surrounded by a pair of tags: -\begin{verbatim} - - 1.0 2.0 3.0 - -\end{verbatim} -Note that in this textual representation there is no need to include -kind informations. -In the binary format, the tags are written explicitly as strings, -as explained in the previous section, -while the data are written in binary format, gaining a factor -of approximately 3 in the size of the file and also with -a strong speed improvement (there is no need of conversions). -The same object as before is written as -\begin{verbatim} -! begin tag: -begin_tag='\n \n' -write(unit) 1+256*len_trim(begin_tag) -write(unit) 128+256*len_trim(begin_tag),begin_tag - -! data itself, note the 0 preceding the data -write(unit) 0 , (/1.0,2.0,3.0/) - -! end tag: -end_tag='\n \n' -write(unit) 2+256*len_trim(end_tag) -! 2 is the control code for end tags -write(unit) 128+256*len_trim(end_tag),end_tag -\end{verbatim} -Note the 0 written in front of the data itself. -This is needed when the library scans the file to distinguish -between tags (which have a header always different from 0) -and data. - -When dealing with strings, the iotk library stores also its length\footnote{ -The number of characters in a string array is length times size.}, -as in the following -\begin{verbatim} - -uno -due -tre -quattro - -\end{verbatim} -The Fortran instructions to write its binary representation are -\begin{verbatim} -! begin tag: -begin_tag='\n \n' -write(unit) 1+256*len_trim(begin_tag) -write(unit) 128+256*len_trim(begin_tag),begin_tag - -! data itself, note the 0 preceding the data -write(unit) 0 , (/"uno ","due ", & - "tre ","quattro"/) -! end tag: -end_tag='\n \n' -write(unit) 2+256*len_trim(end_tag) -write(unit) 128+256*len_trim(end_tag),end_tag -\end{verbatim} - -To read these objects one has first to read the begin tag, -then to parse it to obtain the informations about the -type and size (for checking), kind (for eventual transparent conversion). -For characters, also the len is read. -The parsing needs to be done with some XML parser, then the reading -of the data record can be done directly from Fortran, just keeping -in mind to skip the dummy integer. -In the IOTK library, all these operations are hidden inside -a single library call. - -\end{document} diff --git a/quantum_espresso/kcp/iotk/doc/file_format.txt b/quantum_espresso/kcp/iotk/doc/file_format.txt deleted file mode 100644 index 851b0885e..000000000 --- a/quantum_espresso/kcp/iotk/doc/file_format.txt +++ /dev/null @@ -1,27 +0,0 @@ -This file documents the format of the files handled by the iotk library. - -TEXTUAL FILES -... - -BINARY FILES -Iotk binary files are standard serial access Fortran binary files. -A binary file is then a collection of records, and each read/write -statement acts exactly on one of them. -Informations about the lengths of the tags are stored as integers -of kind equal to __IOTK_HEADER_KIND, which is predefined -to selected_int_kind(8). This should map to 32-bit integers. - -Each tag is written on a pair of records. -The first record contains an header, the second one another header -and the tag, written as follows -write(unit) header -write -only an integer of kind equal to the macro __IOTK_HEADER_KIND. -If this macro is undefined, the default choice is selected_int_kind(8). -This usually leads to a 32 bit integer. - -header = control + taglenp*(iotk_ncontrol+1) - - - - diff --git a/quantum_espresso/kcp/iotk/doc/manpages b/quantum_espresso/kcp/iotk/doc/manpages deleted file mode 100644 index 4dff8d37d..000000000 --- a/quantum_espresso/kcp/iotk/doc/manpages +++ /dev/null @@ -1,414 +0,0 @@ -@ intro - -IOTK: INTRODUCTION - -The input/output tool kit (IOTK) is a FORTRAN90 library intended -to provide an easy access to tagged files formatted using some specific rule. -In this context, a tagged file is a file containing tags and data. -Tagged files can be textual, in which case a XML-like format is used, -or binary, in which case a special format is used. -Note that IOTK is not an XML parser, but it can be used as a writer/parser -for a limited subset of the XML language. - -To use the IOTK library from a FORTRAN90 source, the user should -use the module 'iotk_module'. -To minimize the possibility of name clashes, all public names exported -from this module has the "iotk_" prefix. -Communication between user and library is based on -integers, characters and logicals of the default kind (notice that -these kinds can be changed using proper compiler options, so that -the actual kinds depend on how the library was compiled on your machine). -However, the library can handle formatted input/output for -all intrinsic datatypes, kinds and ranks if properly configured. -This is obtained interfacing procedures which acts on all kinds, -types and (in almost all cases) ranks. Thus, a single generic -name has to be remembered for each subroutine, and the compiler will -link the correct one dependening on type, kind and rank of the arguments. -Backward API compatibility will be mantained (as long as it is possible) -in future versions. -Backward file compatibility will be mantained (as long as it is possible) in -future versions. -The library writes on files informations about the version of the library. -It also writes informations about the version of the file format (file_version). -The later has to be older or equal to the format supported in the actual library. - -@ error_handling - -IOTK: ERROR HANDLING -The way iotk handles error is sophisticated and allows for a trace back -of the error condition inside the library. -Every iotk routines which possibly leads to an error condition has an optional -intent(out) integer argument ierr. The returned value is conventionally -0 when the routine returns correctly, and different from 0 when the routines -raise an error. The value is effectively a handler for a more complex -object containing the error message. When an error is raised in a low-level -iotk routine, a message is written on the error object. Any intermediate routine -can add other messages to the error object, at least the number of the line in -the source file. In this way, the error message contains a complete trace of -the error plus some additional information. -At any point in the chain the messages can be exctracted from the error object. -At some point in the chain the error is really handled, usually by writing the -message on the appropriate unit and aborting the execution. - -Scanning routines (iotk_scan_*) have an optional logical argument "found" -which returns true or false. When scanning for data, also a "default" argument -can be used. If one of these two argument is present, the searched -object is considered as an optional object. Otherwise, it is considered as a needed object. - -If the ierr optional argument is absent, the error handling is leaved to the iotk library. -In this case, if a needed object is not present, the library handles the error with a -forced stop. - -If the ierr optional argument is present, it returns an error code. -ierr = 0 means that no error has occurred -ierr > 0 means that an error has occurred probably related to file corruption -ierr < 0 means that the item that was searched for has not been found - (it is possible only for scanning routines and only if the - found and the default keywords are both missing, i.e. only for no-optional objetcs) -In scanning routines, if the argument "found" is present it returns .true. -if the item has been found, .false. otherwise. -If a library routine returns an ierr /= 0 it is STRONGLY RECOMMENDED to -clear that error with "call iotk_error_clear(ierr)" before proceeding. -Thus, the final recipe is: -* if you want to handle errors, always use the 'ierr' optional argument. - looking at the sign, you will discern between lacking data and file corruption. - with iotk_error_print you can obtain a description of the error. -* if you want to leave the error handling to the library, don't use - the 'ierr' optional argument. - - if the object you are searching is optional, use 'found' or 'default' optional arguments. - - if the object you are searching is non-optional, don't use 'found' nor 'default' optional arguments. - -@ binary_and_textual_files - -IOTK: BINARY AND TEXTUAL FILES -Units can be opened on textual or binary files. -The word 'binary' is used instead of the fortran 'unformatted' since -using this libray also binary files have a degree of formattation. -After a unit has been opened, the library automatically detects -its format through an INQUIRE and acts consequently. -Note that the iotk routines check for necessary properties of an opened unit -access="sequential" -blank ="null" (only textual i/o) -pad ="yes" (only textual i/o) -Moreover, a textual or binary unit can be designed as raw. -In that case, no tags are placed on the file and everything -has to be read and written in the same order. -This feature is provided for compatibility reasons but it should be -used as few as possible. - -@ optional_arguments - -IOTK: OPTIONAL ARGUMENTS - -Most iotk routines accept optional arguments. -The calling routine will not compile if the names of the -arguments are not indicated. For instance, use -call iotk_scan_dat(10,"pippo",aa(:),ierr=ii) -and NOT: -call iotk_scan_dat(10,"pippo",aa(:),ii) -The only exeption is the attr argument, for which the name can be -omitted if it is placed as the first of the optional arguments. -In any case, it is better to always explicitly label optional arguments. - -@ basic_writing_routines iotk_write_begin iotk_write_end iotk_write_empty iotk_write_pi iotk_write_comment - -IOTK: BASIC WRITING ROUTINES -iotk_write_begin (unit,name[,attr][,ierr]) -iotk_write_end (unit,name[,ierr]) -iotk_write_empty (unit,name[,attr][,ierr]) -iotk_write_pi (unit,name[,attr][,ierr]) -iotk_write_comment(unit,text[,ierr]) -integer, intent(in) :: unit -character(len=*), intent(in) :: name -character(len=*), intent(in) :: text -character(len=*), intent(in) :: attr -integer, intent(out):: ierr ! see error_handling page -These routines write a tag named 'name' on fortran unit 'unit'. -The type of the tag is determined from the name of the routine: -iotk_write_begin => -iotk_write_end => -iotk_write_empty => -iotk_write_pi => -iotk_write_comment => -An optional attribute string can be supplied in 'attr' -In end tags, no attribute is allowed. -To build the attribute string, use iotk_write_attr. -DON'T TRY TO MANIPULATE THE ATTRIBUTE STRING DIRECTLY! - -@ basic_scanning_routines iotk_scan_begin iotk_scan_end iotk_scan_empty iotk_scan_pi - -IOTK: BASIC SCANNING ROUTINES -iotk_scan_begin(unit,name[,attr][,found][,ierr]) -iotk_scan_end (unit,name[,found][,ierr]) -iotk_scan_empty(unit,name[,attr][,found][,ierr]) -iotk_scan_pi (unit,name[,attr][,found][,ierr]) -integer, intent(in) :: unit -character(len=*), intent(in) :: name ! len less or equal iotk_namlenx -character(len=*), intent(out):: attr ! len possibily equal iotk_attlenx -logical, intent(out):: found ! see error_handling page -integer, intent(out):: ierr ! see error_handling page -These routines scan for a tag named 'name' on fortran unit 'unit'. -The type of the tag is determined from the name of the routine: -iotk_scan_begin => -iotk_scan_end => -iotk_scan_empty => -iotk_scan_pi => -These routines (except for iotk_scan_end) also fills the -attr string, which can be subsequently decoded with iotk_scan_attr. -DON'T TRY TO MANIPULATE THE ATTRIBUTE STRING DIRECTLY! - -@ writing_attributes iotk_write_attr - -IOTK: WRITING ATTRIBUTES -iotk_write_attr (attr,name,val[,first][,ierr]) -character(len=*), intent(out):: attr ! len less or equal iotk_namlenx -character(len=*), intent(in) :: name ! len less or equal iotk_attlenx -TYPE(KIND), intent(in) :: val ! any type, any kind, any rank [but only scalars for character] -logical, intent(in) :: first -integer, intent(out):: ierr -This routine adds one attribute to the 'attr' string. -To clean the string (for the first attribute) use first=.true. -Example: - call iotk_write_attr(attr,"pippo",1,first=.true.) - call iotk_write_attr(attr,"paperino",2) - call iotk_write_attr(attr,"pluto",3) -This is equivalent to attr="" before the call, but more efficient. -The attribute is added in the form name="value", -where "value" is a string containing a textual representation -of the val variable. -If one of <>&"' appears in val, it is automatically escaped. - -@ scanning_attributes iotk_scan_attr - -IOTK: SCANNING ATTRIBUTES -iotk_scan_attr (attr,name,val[,found][,default][,eos][,ierr]) -character(len=*), intent(in) :: attr ! len possibily equal iotk_attlenx -character(len=*), intent(in) :: name ! len less or equal iotk_namlenx -TYPE(KIND), intent(out):: val ! any type, any kind, any rank [but only scalars for character] -logical, intent(out):: found ! see error_handling page -TYPE(KIND), intent(in) :: default ! same type, kind and rank as val -logical, intent(in) :: eos -integer, intent(out):: ierr ! see error_handling page -This routine scans for one attribute named 'name' from the 'attr' string. -If the attribute is found, it is read to variable 'val'. -If it is not found and default is present, default is copied onto val. -If TYPE is character and eos is present and true, -an end-of-string terminator will be attached at the end of the read string, -and the following bytes will not be touched. This is faster, but requires -the user to take care directly of the end-of-string. Thus, it is discouraged. -The attribute can be delimited with "" or with '' - -@ writing_data iotk_write_dat - -IOTK: WRITING DATA -iotk_write_dat (unit,name,dat[,fmt][,columns][,ierr]) -integer, intent(in) :: unit -character(len=*), intent(in) :: name ! len less or equal iotk_namlenx -TYPE(KIND), intent(in) :: dat ! any type, any kind, any rank -character(len=*), intent(in) :: fmt -integer, intent(in) :: columns -integer, intent(out):: ierr ! see error_handling page -This routines write a data object, that is a self-described -object containg fortran data. -A single data object has the following form - -.. DATA ... - -where -TYPE is the intrinsic type (logical,integer,real,complex or character), -KIND is the data kind (stored in binary files only) -SIZE is the array size (shape informations are not stored) -COLUMNS is the number of data per line -LEN is the string length -FMT is a fortran format string used to write data -If the optional 'fmt' is not passed, default format ('columns' element per line) -is used and the fmt attribute is not written. Otherwise, the string -fmt is used as a FORTRAN format specifierfor the write statement. In this -case it is also written on the file (and used for reading the data back). -fmt="*" can be used and correspond to the "write(unit,*)" statement. -If the optional 'columns' is not passed, it is assumed to be 1 and -the columns attribute is not written. Note that this attribute is completely -ininfluent when reading. -columns and fmt arguments are incompatible. -For complex data, one element is a couple of comma separated real numbers. -If one of <>& appears in dat, it is escaped. - -@ scanning_data iotk_scan_dat - -IOTK: SCANNING DATA -iotk_scan_dat (unit,name,dat[,found][,default][,ierr]) -integer, intent(in) :: unit -character(len=*), intent(in) :: name ! len less or equal iotk_namlenx -TYPE(KIND), intent(out):: dat ! any type, any kind, any rank -logical, intent(out):: found ! see error_handling page -TYPE(KIND), intent(in) :: default ! same type, kind and rank as dat -integer, intent(out):: ierr ! see error_handling page -A data object written with iotk_write_dat is read. -If it is not found and default is present, default is copied onto dat. -If a keyword is absent in the file, the value is deduced from the -dat argument and no check is performed. This allows to write -rapidly by hand data objects. For instance - 1.0 -can be read with - real :: val - call iotk_scan_dat(unit,"datum",val) -If fmt is not present on file, the default format is used. -Types and sizes are checked. -Different kinds (for binary i/o) are automatically converted. -Length (for characters) are not checked. If strings on files -are longer then len(dat), only the first characters are read; if strings -on files are shorter, dat is padded with blanks. - -@ opening_files iotk_open_write iotk_open_read - -IOTK: OPENING FILES - -iotk_open_write(unit[,file][,attr][,binary][,raw][,new][,root][,ierr]) -integer, intent(in) :: unit -character(len=*), intent(in) :: file -character(len=*), intent(in) :: attr -logical, intent(in) :: binary -logical, intent(in) :: new -logical, intent(in) :: raw -character(len=*), intent(in) :: root ! len less or equal iotk_namlenx -integer, intent(out) :: ierr ! see error_handling page -If file is present, this routines opens file 'file' on -unit 'unit' with the proper options. -If binary is present and true, the file is binary. -If new is present and true, the file must not exist already. -If raw is present and true, the file is considered as a raw data file -(use of raw data files is discouraged). -If file is not present, unit is assumed to be already connected. -If root is present, it is used as the name of the root begin/end tag. -If it is absent, the default "Root" is used. -An optional attribute string can be supplied in 'attr', and will be used -as an attribute list for the begin root tag. -Also informations about iotk version and binary format are written as -pi informations. - -iotk_open_read(unit[,file][,attr][,binary][,raw][,root][,ierr]) -integer, intent(in) :: unit -character(len=*), intent(in) :: file -character(len=*), intent(out) :: attr -logical, intent(in) :: binary -logical, intent(in) :: raw -character(len=*), intent(out) :: root ! len possibly equal iotk_namlenx -integer, intent(out) :: ierr ! see error_handling page -If file is present, this routines opens file 'file' on -unit 'unit' with the proper options. -If binary is present and true, the file is binary. -If raw is present and true, the file is considered as a raw data file -(use of raw data files is discouraged). -If file is not present, unit is assumed to be already connected. -If root is present, the name of root in file is read onto that variable. -If attr is present, the attributes of the root tag are read onto that variable, -which can be subsequently decoded with iotk_scan_attr. -DON'T TRY TO MANIPULATE THE ATTRIBUTE STRING DIRECTLY! - -@ closing_files iotk_close_write iotk_close_read - -IOTK: CLOSING FILES - -iotk_close_write(unit[,ierr]) -iotk_close_read(unit[,ierr]) -integer, intent(in) :: unit -integer, intent(out) :: ierr ! see error_handling page -This routines close a file opened with iotk_open_* -Note that if the units were already connected before iotk_open_*, they -are left connected here. - -@ multiple_files iotk_link - -IOTK: MULTIPLE FILES - -When reading, if a begin tag with an attribute iotk_link="FILENAME" is found, -file FILENAME is mounted in its place -If FILENAME begins with a "/", the path is absolute, otherwise it is relative -to the original file. -Note that the mounting is completely transparent for users, which can access -the new file using the old unit. However, if the user wants to access -directly the new file, iotk_physical_unit should be used. - -When writing, the user can switch a logical unit to a different file using -the following routine - -iotk_link(unit,name,file,dummy[,binary][,raw][,create][,ierr]) -integer, intent(in) :: unit -character(len=*), intent(in) :: name -character(len=*), intent(in) :: file -logical, intent(in) :: binary -logical, intent(in) :: raw -logical, intent(in) :: create -integer, intent(out) :: ierr -name is the name of the tag which represents the link. -file is the name of the new file -if binary is present and true, the new file will be binary -if raw is present and true, the new file will be raw -if create is present and true, the new file is actually created -and the next write statement will act on this new file automatically. -Otherwise, only the symbolic link is created. - -@ utilities - -IOTK: OTHER UTILITIES - -Here a number of additional routines/parameters available -from the iotk_module is listed - -character(len=*) :: iotk_index (index) -integer, intent(in) :: index ! scalar or rank 1 -Returns a string representing the index in an array. -Example: index = (/1,2,3/) => iotk_index = ".1.2.3" -The correct way for writing an array of derived types is -to build the names as follows -! ONE-DIMENSIONAL ARRAY -do i = 1 , n - call iotk_write_begin(unit,"dummy"//iotk_index(i)) -! WRITE THE OBJECT HERE - call iotk_write_end (unit,"dummy"//iotk_index(i)) -end do -do i = 1 , n - do j = 1 , m -! NOTE THE ORDER OF INDEXES, THE FASTER IS THE LAST - call iotk_write_begin(unit,"dummy"//iotk_index((/i,j/))) -! WRITE THE OBJECT HERE - call iotk_write_end (unit,"dummy"//iotk_index((/i,j/))) - end do -end do - -iotk_free_unit(unit[,ierr]) -integer, intent(out) :: unit -integer, intent(out) :: ierr -This routine returns the number of a free FORTRAN unit. - -character(len=*) :: iotk_version -version string of iotk - -character :: iotk_newline -newline sequence - -character :: iotk_eos -end-of-string character - -integer :: iotk_taglenx -max length of a tag - -integer :: iotk_namlenx -max length of a tag or attribute name - -integer :: iotk_attlenx -max length of the attribute string - -integer :: iotk_vallenx -max length of the value of an attribute - -integer :: iotk_linlenx -max length of a line in textual files - -integer :: iotk_fillenx -max length of a file name - -integer :: iotk_header_kind -integer kind of headers in binary files - - diff --git a/quantum_espresso/kcp/iotk/doc/manual.txt b/quantum_espresso/kcp/iotk/doc/manual.txt deleted file mode 100644 index 395aca4f5..000000000 --- a/quantum_espresso/kcp/iotk/doc/manual.txt +++ /dev/null @@ -1,418 +0,0 @@ - -Input/Output Tool Kit (IOTK) -Copyright (C) 2004 Giovanni Bussi - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 2.1 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - ------------------------------------------------------------------------------ -Input/Output Tool Kit (IOTK) ------------------------------------------------------------------------------ - -The module 'iotk_module' should be included in the calling routines. -All public names exported from this module has the "iotk_" prefix. -All macros used in configuration has the "__IOTK_" prefix. -Communication between users and library is based on -integers, characters and logicals of the default kind; -these kinds can be changed using proper compiler options. -However, the library can handle formatted i/o for -all intrinsic datatypes, kinds and ranks if properly configured. -This is obtained interfacing procedures which acts on all kinds, -types and (in almost all cases) ranks. -The large number of needed functions is obtained using a simple -loop preprocessor (sprep), so that the maximum number of types, kinds and -ranks has to be known before preprocessing. However, configuration of -kinds is obtained with standard C preprocessor, so that they can -be easily configured editing file iotk_config.h . -Backward API compatibility will be mantained (as long as it is possible) -in future versions. However, order of optional arguments is not fixed and -one should always use keywords. -Backward file compatibility will be mantained (as long as it is possible) in -future versions. -The library writes on files informations about the version of the library. -It also writes informations about the version of the file format (file_version). -The later has to be older or equal to the format supported in the actual library. - -ERROR HANDLING -The way iotk handles error is sophisticated and allows for a trace back -of the error condition inside the library. -Every iotk routines which possibly leads to an error condition has an -intent(out) integer argument ierr. The returned value is conventionally -0 when the routine returns correctly, and different from 0 when the routines -raise an error. The value is effectively a handler for a more complex -object containing the error message. When an error is raised in a low-level -iotk routine, a message is written on the error object. Any intermediate routine -can add other messages to the error object, at least the number of the line in -the source file. In this way, the error message contains a complete trace of -the error plus some additional information. -At any point in the chain the messages can be exctracted from the error object. -At some point in the chain the error is really handled, usually by writing the -message on the appropriate unit and aborting the execution. - -Scanning routines (iotk_scan_*) have an optional logical argument "found" -which returns true or false. When scanning for data, also a "default" argument -can be used. If one of these two argument is present, the searched -object is considered as an optional object. Otherwise, it is considered as a needed object. - -If the ierr optional argument is absent, the error handling is leaved to the iotk library. -In this case, if a needed object is not present, the library handles the error with a -forced stop. - -If the ierr optional argument is present, it returns an error code. -ierr = 0 means that no error has occurred -ierr > 0 means that an error has occurred probably related to file corruption -ierr < 0 means that the item that was searched for has not been found - (it is possible only for scanning routines and only if the - found and the default keywords are both missing, i.e. only for no-optional objetcs) -In scanning routines, if the argument "found" is present it returns .true. -if the item has been found, .false. otherwise. -If a library routine returns an ierr /= 0 it is STRONGLY RECOMMENDED to -clear that error with iotk_error_clear(ierr) before proceeding. -So, the final recipe is: -* if you want to handle errors, always use the 'ierr' optional argument. - looking at the sign, you will discern between lacking data and file corruption. - with iotk_error_print you can obtain a description of the error. -* if you want to leave the error handling to the library, don't use - the 'ierr' optional argument. - - if the object you are searching is optional, use 'found' or 'default' optional arguments. - - if the object you are searching is non-optional, don't use 'found' nor 'default' optional arguments. - -BINARY/TEXTUAL FILES -Units can be opened on textual or binary files. -The word 'binary' is used instead of the fortran 'unformatted' since -using this libray also binary files have a degree of formattation. -After a unit has been opened, the library automatically detects -its format through an INQUIRE and acts consequently. -Note that the iotk routines check for necessary properties of an opened unit -access="sequential" -blank ="null" (only textual i/o) -pad ="yes" (only textual i/o) -Moreover, a textual or binary unit can be designed as raw. -In that case, no tags are placed on the file and everything -has to be read and written in the same order. -This feature is provided for compatibility reasons but it should be -used as few as possible. - -OPTIONAL ARGUMENTS -Most iotk routines accept optional arguments. -They will not compile if the names of the arguments are not indicated. -The only exeption is for "attr" and "val" arguments. - -BASIC WRITING ROUTINES -iotk_write_begin (unit,name[,attr][,ierr]) -iotk_write_end (unit,name[,ierr]) -iotk_write_empty (unit,name[,attr][,ierr]) -iotk_write_pi (unit,name[,attr][,ierr]) -iotk_write_comment(unit,text[,ierr]) -integer, intent(in) :: unit -character(len=*), intent(in) :: name -character(len=*), intent(in) :: text -character(len=*), intent(in) :: attr -integer, intent(out):: ierr -These routines write a tag named 'name' on fortran unit 'unit'. -The type of the tag is determined from the name of the routine: -iotk_write_begin => -iotk_write_end => -iotk_write_empty => -iotk_write_pi => -iotk_write_comment => -An optional attribute string can be supplied in 'attr' -In end tags, no attribute is allowed. -To build the attribute string, use iotk_write_attr. -DON'T TRY TO MANIPULATE THE ATTRIBUTE STRING DIRECTLY! - -BASIC SCANNING ROUTINES -iotk_scan_begin(unit,name[,attr][,found][,ierr]) -iotk_scan_end (unit,name[,found][,ierr]) -iotk_scan_empty(unit,name[,attr][,found][,ierr]) -iotk_scan_pi (unit,name[,attr][,found][,ierr]) -integer, intent(in) :: unit -character(len=*), intent(in) :: name ! len less or equal iotk_namlenx -character(len=*), intent(out):: attr ! len possibily equal iotk_attlenx -logical, intent(out):: found -integer, intent(out):: ierr -These routines scan for a tag named 'name' on fortran unit 'unit'. -The type of the tag is determined from the name of the routine: -iotk_scan_begin => -iotk_scan_end => -iotk_scan_empty => -iotk_scan_pi => -These routines (except for iotk_scan_end) also fills the -attr string, which can be subsequently decoded with iotk_scan_attr. -DON'T TRY TO MANIPULATE THE ATTRIBUTE STRING DIRECTLY! - -WRITING ATTRIBUTES -iotk_write_attr (attr,name,val[,first][,ierr]) -character(len=*), intent(out):: attr ! len less or equal iotk_namlenx -character(len=*), intent(in) :: name ! len less or equal iotk_attlenx -TYPE(KIND), intent(in) :: val !any type, any kind, any rank [but only scalars for character] -logical, intent(in) :: first -integer, intent(out):: ierr -This routine adds one attribute to the 'attr' string. -To clean the string (for the first attribute) use first=.true. -This is equivalent to attr="" before the call, but more efficient. -The attribute is added in the form -name="value", where "value" is a string containing a textual representation -of the val variable. -If one of <>&"' appears in val, it is automatically escaped. - -SCANNING ATTRIBUTES -iotk_scan_attr (attr,name,val[,found][,default][,eos][,ierr]) -character(len=*), intent(in) :: attr ! len possibily equal iotk_attlenx -character(len=*), intent(in) :: name ! len less or equal iotk_namlenx -TYPE(KIND), intent(out):: val !any type, any kind, any rank [but only scalars for character] -logical, intent(out):: found -TYPE(KIND), intent(in) :: default RANK !same type, kind and rank as val -logical, intent(in) :: eos -integer, intent(out):: ierr -This routine scans for one attribute named 'name' from the 'attr' string. -If the attribute is found, it is read to variable 'val'. -If it is not found and default is present, default is copied onto val. -If TYPE is character and eos is present and true, -an end-of-string terminator will be attached at the end of the read string, -and the following bytes will not be touched. This is faster, but requires -the user to take care directly of the end-of-string. Thus, it is discouraged. -The attribute can be delimited with "" or with '' - -WRITING DATA -iotk_write_dat (unit,name,dat[,fmt][,columns][,ierr]) -integer, intent(in) :: unit -character(len=*), intent(in) :: name ! len less or equal iotk_namlenx -TYPE(KIND), intent(in) :: dat RANK !any type, any kind, any rank -character(len=*), intent(in) :: fmt -integer, intent(in) :: columns -integer, intent(out):: ierr -This routines write a data object, that is a self-described -object containg fortran data. -A single data object has the following form - -.. DATA ... - -where -TYPE is the intrinsic type (logical,integer,real,complex or character), -KIND is the data kind (stored in binary files only) -SIZE is the array size (shape informations are not stored) -COLUMNS is the number of data per line -LEN is the string length -FMT is a fortran format string used to write data -If the optional 'fmt' is not passed, default format is used and the fmt attribute -is not written. -Default format means one element per line. -If the optional 'columns' is not passed, one datum per line is written and -the columns attribute is not written. Note that this attribute is completely -ininfluent when reading. -columns and fmt are incompatible. -For complex, two comma separated elements per line are written. -Otherwise, 'fmt' is used as a formatting string. Note that fmt="*" means -an usual write(unit,*) statement. -If one of <>& appears in dat, it is escaped. - -SCANNING DATA -iotk_scan_dat (unit,name,dat[,found][,default][,ierr]) -integer, intent(in) :: unit -character(len=*), intent(in) :: name ! len less or equal iotk_namlenx -TYPE(KIND), intent(out):: dat RANK !any type, any kind, any rank -logical, intent(out):: found -TYPE(KIND), intent(in) :: default RANK !same type, kinad and rank as dat -integer, intent(out):: ierr -A data object written with iotk_write_dat is read. -If it is not found and default is present, default is copied onto dat. -If a keyword is absent in the file, the value is deduced from the -dat formal argument and no check is performed. This allows to write -rapidly by hand data objects. -If fmt is not present on file, the default format is used. -Types and sizes are checked. Different kinds (for binary i/o) are automatically -converted. -Length (for characters) are not checked. If strings on files -are longer then len(dat), only the first characters are read; if strings -on files are shorter, dat is padded with blanks. - -OPENING AND CLOSING FILES -iotk_open_write(unit[,file][,attr][,binary][,raw][,new][,root][,ierr]) -integer, intent(in) :: unit -character(len=*), intent(in) :: file -character(len=*), intent(in) :: attr -logical, intent(in) :: binary -logical, intent(in) :: new -logical, intent(in) :: raw -character(len=*), intent(in) :: root ! len less or equal iotk_namlenx -integer, intent(out) :: ierr -If file is present, this routines opens file 'file' on -unit 'unit' with the proper options. -If binary is present and true, the file is binary. -If new is present and true, the file must not exist -If raw is present and true, the file is considered as a raw data file. -If file is not present, unit is assumed to be already connected; -If root is present, it is used as the name of the root -begin/end pair. If it is absent, the default "Root" is used. -An optional attribute string can be supplied in 'attr' -Also informations about iotk version and binary format are written as -pi informations. - -iotk_open_read(unit[,file][,attr][,binary][,raw][,root][,ierr]) -integer, intent(in) :: unit -character(len=*), intent(in) :: file -character(len=*), intent(out) :: attr -logical, intent(in) :: binary -logical, intent(in) :: new -logical, intent(in) :: raw -character(len=*), intent(out) :: root ! len possibly equal iotk_namlenx -integer, intent(out) :: ierr -If file is present, this routines opens file 'file' on -unit 'unit' with the proper options. -If binary is present and true, the file is binary. -If new is present and true, the file is considered as a raw data file. -If file is not present, unit is assumed to be already connected. -If root is present, the name of root in file is read onto that variable. -If attr is present, the attributes of the root tag are read onto that variable. - -iotk_close_write(unit[,ierr]) -iotk_close_read(unit[,ierr]) -integer, intent(in) :: unit -integer, intent(out) :: ierr -This routines close a file opened with iotk_open_* -Note that if the units were already connected before iotk_open_*, they -are left connected here. - -MULTIPLE FILES - -When reading, if a begin tag with an attribute iotk_link="FILENAME" is found, -file FILENAME is mounted in its place -If FILENAME begins with a "/", the path is absolute, otherwise it is relative -to the original file. -Note that the mounting is completely transparent for users, which can access -the new file using the old unit. However, if the user wants to access -directly the new file, iotk_physical_unit should be used. - -When writing, the user can switch a logical unit to a different file using -the following routine - -iotk_link(unit,name,file,dummy[,binary][,raw][,create][,ierr]) -integer, intent(in) :: unit -character(len=*), intent(in) :: name -character(len=*), intent(in) :: file -logical, intent(in) :: binary -logical, intent(in) :: raw -logical, intent(in) :: create -integer, intent(out) :: ierr -name is the name of the tag which represents the link. -file is the name of the new file -if binary is present and true, the new file will be binary -if raw is present and true, the new file will be raw -if create is present and true, the new file is actually created -and the next write statement will act on this new file automatically. -Otherwise, only the symbolic link is created. - -OTHER UTILITIES - -character(len=*) iotk_index (index) -integer, intent(in) :: index ! scalar or rank 1 -Returns a string representing the index in an array. -Example: index = (/1,2,3/) => iotk_index = ".1.2.3" -The correct way for writing an array of derived types is -to build the names as follows -! ONE-DIMENSIONAL ARRAY -do i = 1 , n - call iotk_write_begin(unit,"dummy"//iotk_index(i)) -! WRITE THE OBJECT HERE - call iotk_write_end (unit,"dummy"//iotk_index(i)) -end do -do i = 1 , n - do j = 1 , m -! NOTE THE ORDER OF INDEXES, THE FASTER IS THE LAST - call iotk_write_begin(unit,"dummy"//iotk_index((/i,j/))) -! WRITE THE OBJECT HERE - call iotk_write_end (unit,"dummy"//iotk_index((/i,j/))) - end do -end do - -iotk_free_unit(unit[,ierr]) -integer, intent(out) :: unit -integer, intent(out) :: ierr -This routine returns the number of a free fortran unit. - -character(len=*) iotk_version -it is a character variable containing the version string of iotk - -character iotk_newline -it is a character variable defined in iotk_config.h which -maps in to the newline sequence. - -3 IOTK MACROS -The IOTK macros are used to change the way the library is compiled. -Every macro has a default, so in principle the library compiles -even if all the macros are unset. -However, additional features are available using them. - -__IOTK_HEADER_KIND -defines the fortran kind for integer used as header in binary files. -default is selected_int_kind(8). -Note that changing this value can compromise the library usage. - -__IOTK_{LOGICAL,INTEGER,REAL}{1,2,3,4} -define the kinds for the multi-kind library. -These options are system dependent, and are better configured -in the iotk_config.h file. -If no kind is set for a given type, only the default kind is used. -Only default characters are implemented. -Complex are treated as reals. - -__IOTK_MPI_ABORT -If it is defined, the internal error handler calls mpi_abort to exit -This option is system dependent, and is better configured -in the iotk_config.h file. - -__IOTK_ERROR_UNIT -The unit where errors are written when the library handles them. -Default is 0. - -__IOTK_OUTPUT_UNIT -The unit for standard output, used by the 'iotk' tool. -Default is 6. - -__IOTK_MAXARGS -The maximum number of argument for the 'iotk' tool. -Default is 256. - -__IOTK_MAXRANK -Controls the maximum rank implemented in the library. Default is 7. -It can be in the range 1 to 7. - -__IOTK_UNITMIN and __IOTK_UNITMAX -They control the range where iotk_free_unit searches. -These units are used for hidden features in the iotk library. -If the user performs i/o on a unit in this range, the functionalities -of the library can be compromised. -Defaults are 90000 and 99999 - -__IOTK_EOS -It is a charater used internally to delimit strings. -Default is achar(0) (it should be ok on any machine). - -__IOTK_NEWLINE -It is a charater used in binary files to surround tags so that they can -be grepped. -Default is achar(10) (it should be ok on any machine). - -__IOTK_WORKAROUND{1,2,3,4,5,6,7,8,9} -When one of them is defined, library uses a workaround for a -known bug in the compiler. Bugs are automatically found with the -tools/configure script. Note that the use of these definitions -can affect the final speed of the library. - -__IOTK_SAFEST -If it is defined, all __IOTK_WORKAROUND are automatically defined. -It can be used with unknown compilers. - - diff --git a/quantum_espresso/kcp/iotk/include/iotk_auxmacros.h b/quantum_espresso/kcp/iotk/include/iotk_auxmacros.h deleted file mode 100644 index 700b6f910..000000000 --- a/quantum_espresso/kcp/iotk/include/iotk_auxmacros.h +++ /dev/null @@ -1,244 +0,0 @@ -# 5 "iotk_auxmacros.spp" - -#ifndef __IOTK_AUXMACROS_H -#define __IOTK_AUXMACROS_H - -! The macros are defined with -D option or inside iotk_config.h -! The default values are set here - -! Maximum rank of an array -#ifndef __IOTK_MAXRANK -# define __IOTK_MAXRANK 7 -#endif - -! Minimum value used in iotk_free_unit -#ifndef __IOTK_UNITMIN -# define __IOTK_UNITMIN 90000 -#endif - -! Maximum value used in iotk_free_unit -#ifndef __IOTK_UNITMAX -# define __IOTK_UNITMAX 99999 -#endif - -! Unit for errors -#ifndef __IOTK_ERROR_UNIT -# define __IOTK_ERROR_UNIT 0 -#endif - -! Unit for output -#ifndef __IOTK_OUTPUT_UNIT -# define __IOTK_OUTPUT_UNIT 6 -#endif - -! Kind for header in binary files -#ifndef __IOTK_HEADER_KIND -# define __IOTK_HEADER_KIND selected_int_kind(8) -#endif - -! Maximum number of arguments to the iotk tool -#ifndef __IOTK_MAXARGS -# define __IOTK_MAXARGS 256 -#endif - -! Character (or eventually string) for newline -! It may be adjusted for particular systems -! It is used only in binary files, surrounding the tags so that they can -! be easily isolated with grep -! Unix achar(10) -! Mac-OS achar(13) -! Windows ? (now it should be a single byte) -#ifndef __IOTK_NEWLINE -# define __IOTK_NEWLINE achar(10) -#endif - -! Character for EOS -#ifndef __IOTK_EOS -# define __IOTK_EOS achar(0) -#endif - -! These are the default kinds, which depend on the options used -! during the library compilation -! Only default characters are implemented -#define __IOTK_CHARACTER1 iotk_character_defkind -! For logical, integer and real types, the c precompiler -! looks for defined kinds. If no kind is found, the default -! is used as __IOTK_type1 -# 74 "iotk_auxmacros.spp" -#ifndef __IOTK_LOGICAL1 -# 74 "iotk_auxmacros.spp" -#ifndef __IOTK_LOGICAL2 -# 74 "iotk_auxmacros.spp" -#ifndef __IOTK_LOGICAL3 -# 74 "iotk_auxmacros.spp" -#ifndef __IOTK_LOGICAL4 -# 76 "iotk_auxmacros.spp" -#define __IOTK_LOGICAL1 iotk_LOGICAL_defkind -# 79 "iotk_auxmacros.spp" -#endif -# 79 "iotk_auxmacros.spp" -#endif -# 79 "iotk_auxmacros.spp" -#endif -# 79 "iotk_auxmacros.spp" -#endif -# 74 "iotk_auxmacros.spp" -#ifndef __IOTK_INTEGER1 -# 74 "iotk_auxmacros.spp" -#ifndef __IOTK_INTEGER2 -# 74 "iotk_auxmacros.spp" -#ifndef __IOTK_INTEGER3 -# 74 "iotk_auxmacros.spp" -#ifndef __IOTK_INTEGER4 -# 76 "iotk_auxmacros.spp" -#define __IOTK_INTEGER1 iotk_INTEGER_defkind -# 79 "iotk_auxmacros.spp" -#endif -# 79 "iotk_auxmacros.spp" -#endif -# 79 "iotk_auxmacros.spp" -#endif -# 79 "iotk_auxmacros.spp" -#endif -# 74 "iotk_auxmacros.spp" -#ifndef __IOTK_REAL1 -# 74 "iotk_auxmacros.spp" -#ifndef __IOTK_REAL2 -# 74 "iotk_auxmacros.spp" -#ifndef __IOTK_REAL3 -# 74 "iotk_auxmacros.spp" -#ifndef __IOTK_REAL4 -# 76 "iotk_auxmacros.spp" -#define __IOTK_REAL1 iotk_REAL_defkind -# 79 "iotk_auxmacros.spp" -#endif -# 79 "iotk_auxmacros.spp" -#endif -# 79 "iotk_auxmacros.spp" -#endif -# 79 "iotk_auxmacros.spp" -#endif -# 82 "iotk_auxmacros.spp" - -! Complex are treated indentically to reals -! These lines map the definitions. -# 86 "iotk_auxmacros.spp" -#ifdef __IOTK_REAL1 -# define __IOTK_COMPLEX1 __IOTK_REAL1 -#else -# undef __IOTK_COMPLEX1 -#endif -# 86 "iotk_auxmacros.spp" -#ifdef __IOTK_REAL2 -# define __IOTK_COMPLEX2 __IOTK_REAL2 -#else -# undef __IOTK_COMPLEX2 -#endif -# 86 "iotk_auxmacros.spp" -#ifdef __IOTK_REAL3 -# define __IOTK_COMPLEX3 __IOTK_REAL3 -#else -# undef __IOTK_COMPLEX3 -#endif -# 86 "iotk_auxmacros.spp" -#ifdef __IOTK_REAL4 -# define __IOTK_COMPLEX4 __IOTK_REAL4 -#else -# undef __IOTK_COMPLEX4 -#endif -# 92 "iotk_auxmacros.spp" - -! Some useful check follow -#if __IOTK_MAXRANK > 7 - #error -#endif -#if __IOTK_MAXRANK < 1 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_LOGICAL5 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_LOGICAL6 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_LOGICAL7 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_LOGICAL8 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_LOGICAL9 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_LOGICAL10 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_INTEGER5 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_INTEGER6 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_INTEGER7 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_INTEGER8 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_INTEGER9 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_INTEGER10 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_REAL5 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_REAL6 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_REAL7 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_REAL8 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_REAL9 - #error -#endif -# 102 "iotk_auxmacros.spp" -#ifdef __IOTK_REAL10 - #error -#endif -# 107 "iotk_auxmacros.spp" - -#ifdef __IOTK_SAFEST -# define __IOTK_WORKAROUND1 -# define __IOTK_WORKAROUND2 -# define __IOTK_WORKAROUND3 -# define __IOTK_WORKAROUND4 -# define __IOTK_WORKAROUND5 -# define __IOTK_WORKAROUND6 -# define __IOTK_WORKAROUND7 -# define __IOTK_WORKAROUND8 -# define __IOTK_WORKAROUND9 -#endif - -#endif diff --git a/quantum_espresso/kcp/iotk/include/iotk_auxmacros.spp b/quantum_espresso/kcp/iotk/include/iotk_auxmacros.spp deleted file mode 100644 index 186fe5740..000000000 --- a/quantum_espresso/kcp/iotk/include/iotk_auxmacros.spp +++ /dev/null @@ -1,121 +0,0 @@ ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< - -#ifndef __IOTK_AUXMACROS_H -#define __IOTK_AUXMACROS_H - -! The macros are defined with -D option or inside iotk_config.h -! The default values are set here - -! Maximum rank of an array -#ifndef __IOTK_MAXRANK -# define __IOTK_MAXRANK $maxrank -#endif - -! Minimum value used in iotk_free_unit -#ifndef __IOTK_UNITMIN -# define __IOTK_UNITMIN 90000 -#endif - -! Maximum value used in iotk_free_unit -#ifndef __IOTK_UNITMAX -# define __IOTK_UNITMAX 99999 -#endif - -! Unit for errors -#ifndef __IOTK_ERROR_UNIT -# define __IOTK_ERROR_UNIT 0 -#endif - -! Unit for output -#ifndef __IOTK_OUTPUT_UNIT -# define __IOTK_OUTPUT_UNIT 6 -#endif - -! Kind for header in binary files -#ifndef __IOTK_HEADER_KIND -# define __IOTK_HEADER_KIND selected_int_kind(8) -#endif - -! Maximum number of arguments to the iotk tool -#ifndef __IOTK_MAXARGS -# define __IOTK_MAXARGS 256 -#endif - -! Character (or eventually string) for newline -! It may be adjusted for particular systems -! It is used only in binary files, surrounding the tags so that they can -! be easily isolated with grep -! Unix achar(10) -! Mac-OS achar(13) -! Windows ? (now it should be a single byte) -#ifndef __IOTK_NEWLINE -# define __IOTK_NEWLINE achar(10) -#endif - -! Character for EOS -#ifndef __IOTK_EOS -# define __IOTK_EOS achar(0) -#endif - -! These are the default kinds, which depend on the options used -! during the library compilation -! Only default characters are implemented -#define __IOTK_CHARACTER1 iotk_character_defkind -! For logical, integer and real types, the c precompiler -! looks for defined kinds. If no kind is found, the default -! is used as __IOTK_type1 ->for type in LOGICAL INTEGER REAL ->do -> for kind in $kinds -> do -#ifndef __IOTK_${type}${kind} -> done -#define __IOTK_${type}1 iotk_${type}_defkind -> for kind in $kinds -> do -#endif -> done ->done - -! Complex are treated indentically to reals -! These lines map the definitions. ->for kind in $kinds ; do -#ifdef __IOTK_REAL$kind -# define __IOTK_COMPLEX$kind __IOTK_REAL$kind -#else -# undef __IOTK_COMPLEX$kind -#endif ->done - -! Some useful check follow -#if __IOTK_MAXRANK > $maxrank - #error -#endif -#if __IOTK_MAXRANK < 1 - #error -#endif ->for type in LOGICAL INTEGER REAL ; do -> for((kind=nkinds+1 ; $kind <= 10 ; kind++)) ; do -#ifdef __IOTK_${type}${kind} - #error -#endif -> done ->done - -#ifdef __IOTK_SAFEST -# define __IOTK_WORKAROUND1 -# define __IOTK_WORKAROUND2 -# define __IOTK_WORKAROUND3 -# define __IOTK_WORKAROUND4 -# define __IOTK_WORKAROUND5 -# define __IOTK_WORKAROUND6 -# define __IOTK_WORKAROUND7 -# define __IOTK_WORKAROUND8 -# define __IOTK_WORKAROUND9 -#endif - -#endif - diff --git a/quantum_espresso/kcp/iotk/include/iotk_config.h b/quantum_espresso/kcp/iotk/include/iotk_config.h deleted file mode 100644 index 81716ef84..000000000 --- a/quantum_espresso/kcp/iotk/include/iotk_config.h +++ /dev/null @@ -1,103 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -! -!------------------------------------------------------------------------------! -! CONFIGURATION FILE FOR IOTK 1.1.0 for Quantum-Espresso -!------------------------------------------------------------------------------! -! The following lines map some commonly defined system macro to the internal -! iotk macros. -! Iotk macros which are not defined take their default values. -! See the manual for a list of iotk macros. - -#ifndef __IOTK_CONFIG_H -#define __IOTK_CONFIG_H - -! Generic options valid for quantum-espresso -! QE uses ranks up to four and default integer/logicals only - -#define __IOTK_MAXRANK 4 - -! some compilers do not like the following -! #define __IOTK_REAL1 selected_real_kind(6,30) -! #define __IOTK_REAL2 selected_real_kind(14,200) -! so we use explicit kinds -#if defined(__NAG) -# define __IOTK_REAL1 1 -# define __IOTK_REAL2 2 -#elif defined(__SX6) -# define __IOTK_REAL2 8 -#else -# define __IOTK_REAL1 4 -# define __IOTK_REAL2 8 -#endif -! Machine-dependent options -! Only for compilers that require some special tricks - -#ifdef __IOTK_SAFEST - ! - ! force to define all the workarounds - ! -# define __IOTK_WORKAROUND1 -# define __IOTK_WORKAROUND2 -# define __IOTK_WORKAROUND3 -# define __IOTK_WORKAROUND4 -# define __IOTK_WORKAROUND5 -# define __IOTK_WORKAROUND6 -# define __IOTK_WORKAROUND7 -# define __IOTK_WORKAROUND9 -#else - ! - ! proceed with a machine dependent def where available - ! -# if defined(__XLF) -# define __IOTK_WORKAROUND5 -# define __IOTK_WORKAROUND9 -# elif defined(__INTEL) -# define __IOTK_WORKAROUND1 -# define __IOTK_WORKAROUND3 -# define __IOTK_WORKAROUND5 -# elif defined(__PGI) -# define __IOTK_WORKAROUND2 -# define __IOTK_WORKAROUND4 -# elif defined(__NAG) -# define __IOTK_WORKAROUND4 -# elif defined(__ALPHA) -# define __IOTK_WORKAROUND1 -# define __IOTK_WORKAROUND6 -# define __IOTK_WORKAROUND8 -# elif defined(__SX6) -# define __IOTK_WORKAROUND5 -# define __IOTK_WORKAROUND7 -# else -# define __IOTK_WORKAROUND1 -# define __IOTK_WORKAROUND2 -# define __IOTK_WORKAROUND3 -# define __IOTK_WORKAROUND4 -# define __IOTK_WORKAROUND5 -# define __IOTK_WORKAROUND6 -# define __IOTK_WORKAROUND7 -# endif -#endif - - -#if defined(__PARA) -# define __IOTK_MPI_ABORT -#endif - -#endif - - diff --git a/quantum_espresso/kcp/iotk/include/iotk_config.h.in b/quantum_espresso/kcp/iotk/include/iotk_config.h.in deleted file mode 100644 index 19b419b2f..000000000 --- a/quantum_espresso/kcp/iotk/include/iotk_config.h.in +++ /dev/null @@ -1,55 +0,0 @@ -#ifndef __IOTK_CONFIG_H -#define __IOTK_CONFIG_H - -! Type definitions: -@IOTK_INTEGER1@ -@IOTK_INTEGER2@ -@IOTK_INTEGER3@ -@IOTK_INTEGER4@ -@IOTK_LOGICAL1@ -@IOTK_LOGICAL2@ -@IOTK_LOGICAL3@ -@IOTK_LOGICAL4@ -@IOTK_REAL1@ -@IOTK_REAL2@ -@IOTK_REAL3@ -@IOTK_REAL4@ -! End of type definitions - - -!! -!! NOTE: iotk_configure seems not to be able to detect all -!! workaround's. We impose them automatically. -!! -#if defined(__XLF) -# define __IOTK_WORKAROUND5 -# define __IOTK_WORKAROUND9 -#elif defined(__INTEL) -# define __IOTK_WORKAROUND1 -# define __IOTK_WORKAROUND3 -# define __IOTK_WORKAROUND5 -#elif defined(__PGI) -# define __IOTK_WORKAROUND2 -# define __IOTK_WORKAROUND4 -#elif defined(__NAG) -# define __IOTK_WORKAROUND4 -#elif defined(__ALPHA) -# define __IOTK_WORKAROUND1 -# define __IOTK_WORKAROUND6 -#elif defined(__SX6) -# define __IOTK_WORKAROUND5 -#endif - -!! Workarounds for bugs: -!@IOTK_WORKAROUND1@ -!@IOTK_WORKAROUND2@ -!@IOTK_WORKAROUND3@ -!@IOTK_WORKAROUND4@ -!@IOTK_WORKAROUND5@ -!@IOTK_WORKAROUND6@ -!@IOTK_WORKAROUND7@ -!@IOTK_WORKAROUND8@ -!@IOTK_WORKAROUND9@ - -#endif - diff --git a/quantum_espresso/kcp/iotk/include/iotk_config.h.save b/quantum_espresso/kcp/iotk/include/iotk_config.h.save deleted file mode 100644 index ae23e53a0..000000000 --- a/quantum_espresso/kcp/iotk/include/iotk_config.h.save +++ /dev/null @@ -1,150 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -! -!------------------------------------------------------------------------------! -! CONFIGURATION FILE FOR IOTK 1.1.0 -!------------------------------------------------------------------------------! -! The following lines map some commonly defined system macro to the internal -! iotk macros. -! Iotk macros which are not defined take their default values. -! See the manual for a list of iotk macros. - -#ifndef __IOTK_CONFIG_H -#define __IOTK_CONFIG_H - -! Uncomment the following line to enable stream read of unformatted files. -! It will work only if fortran 2003 streams are available. -!#define __IOTK_STREAMS - -#if defined(__AIX) -# define __IOTK_RECORD_KIND 4 -# define __IOTK_RECORD_LENGTH 4 -# define __IOTK_LOGICAL1 1 -# define __IOTK_LOGICAL2 2 -# define __IOTK_LOGICAL3 4 -# define __IOTK_LOGICAL4 8 -# define __IOTK_INTEGER1 1 -# define __IOTK_INTEGER2 2 -# define __IOTK_INTEGER3 4 -# define __IOTK_INTEGER4 8 -# define __IOTK_REAL1 4 -# define __IOTK_REAL2 8 -# define __IOTK_REAL3 16 -#elif defined(__MAC) -# define __IOTK_LOGICAL1 1 -# define __IOTK_LOGICAL2 2 -# define __IOTK_LOGICAL3 4 -# define __IOTK_LOGICAL4 8 -# define __IOTK_INTEGER1 1 -# define __IOTK_INTEGER2 2 -# define __IOTK_INTEGER3 4 -# define __IOTK_INTEGER4 8 -# define __IOTK_REAL1 4 -# define __IOTK_REAL2 8 -# define __IOTK_REAL3 16 -# define __IOTK_WORKAROUND5 -#elif defined(__LINUX) || defined (__LINUX64) -# if defined(__INTEL) -# define __IOTK_LOGICAL1 1 -# define __IOTK_LOGICAL2 2 -# define __IOTK_LOGICAL3 4 -# define __IOTK_LOGICAL4 8 -# define __IOTK_INTEGER1 1 -# define __IOTK_INTEGER2 2 -# define __IOTK_INTEGER3 4 -# define __IOTK_INTEGER4 8 -# define __IOTK_REAL1 4 -# define __IOTK_REAL2 8 -# define __IOTK_REAL3 16 -# define __IOTK_WORKAROUND1 -# define __IOTK_WORKAROUND3 -# define __IOTK_WORKAROUND5 -# elif defined(__G95) -# define __IOTK_RECORD_KIND 4 -# define __IOTK_RECORD_LENGTH 4 -# define __IOTK_LOGICAL1 1 -# define __IOTK_LOGICAL2 2 -# define __IOTK_LOGICAL3 4 -# define __IOTK_LOGICAL4 8 -# define __IOTK_INTEGER1 1 -# define __IOTK_INTEGER2 2 -# define __IOTK_INTEGER3 4 -# define __IOTK_INTEGER4 8 -# define __IOTK_REAL1 4 -# define __IOTK_REAL2 8 -# define __IOTK_REAL3 10 -# elif defined(__PGI) -# define __IOTK_LOGICAL1 1 -# define __IOTK_LOGICAL2 2 -# define __IOTK_LOGICAL3 4 -# define __IOTK_LOGICAL4 8 -# define __IOTK_INTEGER1 1 -# define __IOTK_INTEGER2 2 -# define __IOTK_INTEGER3 4 -# define __IOTK_INTEGER4 8 -# define __IOTK_REAL1 4 -# define __IOTK_REAL2 8 -# define __IOTK_WORKAROUND2 -# define __IOTK_WORKAROUND4 -# elif defined(__NAG) -# define __IOTK_INTEGER1 1 -# define __IOTK_INTEGER2 2 -# define __IOTK_INTEGER3 3 -# define __IOTK_INTEGER4 4 -# define __IOTK_LOGICAL1 1 -# define __IOTK_LOGICAL2 2 -# define __IOTK_LOGICAL3 3 -# define __IOTK_LOGICAL4 4 -# define __IOTK_REAL1 1 -# define __IOTK_REAL2 2 -# define __IOTK_WORKAROUND4 -# endif -#elif defined(__ALPHA) -# define __IOTK_LOGICAL1 1 -# define __IOTK_LOGICAL2 2 -# define __IOTK_LOGICAL3 4 -# define __IOTK_LOGICAL4 8 -# define __IOTK_INTEGER1 1 -# define __IOTK_INTEGER2 2 -# define __IOTK_INTEGER3 4 -# define __IOTK_INTEGER4 8 -# define __IOTK_REAL1 4 -# define __IOTK_REAL2 8 -# define __IOTK_REAL3 16 -# define __IOTK_WORKAROUND1 -# define __IOTK_WORKAROUND6 -#elif defined(__SGI) -# define __IOTK_LOGICAL1 1 -# define __IOTK_LOGICAL2 2 -# define __IOTK_LOGICAL3 4 -# define __IOTK_LOGICAL4 8 -# define __IOTK_INTEGER1 1 -# define __IOTK_INTEGER2 2 -# define __IOTK_INTEGER3 4 -# define __IOTK_INTEGER4 8 -# define __IOTK_REAL1 4 -# define __IOTK_REAL2 8 -# define __IOTK_REAL3 16 -#endif - -#ifdef __PARA -# define __IOTK_MPI_ABORT -#endif - -#endif - - diff --git a/quantum_espresso/kcp/iotk/include/iotk_config.sh b/quantum_espresso/kcp/iotk/include/iotk_config.sh deleted file mode 100644 index ea01d26ea..000000000 --- a/quantum_espresso/kcp/iotk/include/iotk_config.sh +++ /dev/null @@ -1,4 +0,0 @@ -# Configurations on maximum number of kinds and maximum value for IOTK_MAXRANK - nkinds=4 - maxrank=7 - diff --git a/quantum_espresso/kcp/iotk/include/iotk_include.sh b/quantum_espresso/kcp/iotk/include/iotk_include.sh deleted file mode 100644 index 991705423..000000000 --- a/quantum_espresso/kcp/iotk/include/iotk_include.sh +++ /dev/null @@ -1,67 +0,0 @@ - include iotk_version.sh - __IOTK_FILE_VERSION="1.0" -# List of types - types='LOGICAL INTEGER REAL COMPLEX CHARACTER' - include iotk_config.sh - - kinds='' - for ((kind = 1 ; $kind <= $nkinds ; kind++)) ; do - kinds="$kinds $kind" - done - ranks='' - for ((rank = 0 ; $rank <= $maxrank ; rank++)) ; do - ranks="$ranks $rank" - done - - SHAPE[0]='' - for ((rank = 1 ; $rank <= $maxrank ; rank++)) ; do - SHAPE[$rank]='(:' - for ((rank1 = 2 ; $rank1 <= $rank ; rank1++)) ; do - SHAPE[$rank]="${SHAPE[$rank]},:" - done - SHAPE[$rank]="${SHAPE[$rank]})" - done - - function BOUNDS () { - local index - local rank - local argument - local output - rank=$1 - argument=$2 - (($rank==0)) && return - output="(lbound($argument,1):ubound($argument,1)" - for ((index=2;$index<=$rank;index++)) ; do - output="${output}," - if ((${#output}>60)) ; then - echo "${output} &" - output="" - fi - output="${output}lbound($argument,$index):ubound($argument,$index)" - done - output="${output})" - echo "$output" - } - - LENSTAR_LOGICAL='' - LENSTAR_INTEGER='' - LENSTAR_REAL='' - LENSTAR_COMPLEX='' - LENSTAR_CHARACTER=',len=*' - - function ERROR () { - local ierr="$1" - echo "call iotk_error_issue($ierr,\"$PROCEDURE\",__FILE__,__LINE__)" - [ "$REVISION" ] && echo "call iotk_error_msg($ierr,\"CVS $REVISION\")" - if [ $# -gt 1 ] ; then - echo "call iotk_error_msg($ierr,'$2')" - fi - if [ $# -gt 2 ] ; then - shift ; shift - for var in $* ; do - echo "call iotk_error_write($ierr,\"${var%=*}\",${var#*=})" - done - fi - } - - diff --git a/quantum_espresso/kcp/iotk/include/iotk_list.sh b/quantum_espresso/kcp/iotk/include/iotk_list.sh deleted file mode 100644 index 8f336712d..000000000 --- a/quantum_espresso/kcp/iotk/include/iotk_list.sh +++ /dev/null @@ -1,135 +0,0 @@ - -function LIST_TYPE () { - local arg - local type_name - local type_declare="" - for arg - do - case "$arg" in - (--type=*) type_name="${arg#--type=}" ;; - (--type-declare=*) type_declare="${arg#--type-declare=}" ;; - esac - done - [ "$type_declare" ] || type_declare="type ($type_name)" - echo " -type ${type_name}_list - type (${type_name}_list), pointer :: next - $type_declare, pointer :: ptr -end type ${type_name}_list -" -} - -function LIST_IMPLEMENTATION () { - local arg - local type_name - local type_declare="" - for arg - do - case "$arg" in - (--type=*) type_name="${arg#--type=}" ;; - (--type-declare=*) type_declare="${arg#--type-declare=}" ;; - (--search=*) search="${arg#--search=}" ;; - esac - done - [ "$type_declare" ] || type_declare="type ($type_name)" -echo " -subroutine ${type_name}_list_init(list) - type (${type_name}_list), intent(out) :: list - nullify(list%ptr) - nullify(list%next) -end subroutine ${type_name}_list_init - -subroutine ${type_name}_list_destroy(list) - type (${type_name}_list), intent(inout) :: list - type (${type_name}_list), pointer :: this,next - if(.not.associated(list%next)) return - this=>list%next - do - if(associated(this%ptr))deallocate(this%ptr) - next=>this%next - deallocate(this) - if(.not.associated(next)) exit - this=>next - end do -end subroutine ${type_name}_list_destroy - -subroutine ${type_name}_list_add(list,ptr) - type (${type_name}_list), intent(inout) :: list - $type_declare, pointer :: ptr - type (${type_name}_list), pointer :: this - allocate(this) - this%next => list%next - list%next => this - allocate(this%ptr) - ptr => this%ptr -end subroutine ${type_name}_list_add - -subroutine ${type_name}_list_del(list,ptr) - type (${type_name}_list), intent(inout) :: list - $type_declare, pointer :: ptr - type (${type_name}_list), pointer :: this,next_save - if(.not.associated(list%next)) return - if(associated(list%next%ptr,ptr)) then - deallocate(list%next%ptr) - next_save => list%next%next - deallocate(list%next) - list%next => next_save - nullify(ptr) - return - end if - this => list%next - do - if(.not.associated(this%next)) return - if(associated(this%next%ptr,ptr)) exit - this => this%next - end do - deallocate(this%next%ptr) - next_save => this%next%next - deallocate(this%next) - this%next => next_save - nullify(ptr) -end subroutine ${type_name}_list_del -" - -if [ "$search" ] ; then -search="${search//::/@}" -IFS=";" -args= -for ss in $search ; do - args="$args${ss#*@}," -done -args="${args%,}" - - echo " - subroutine ${type_name}_list_search(list,ptr,$args) - type (${type_name}_list), intent(in) :: list - $type_declare, pointer :: ptr - " - for ss in $search ; do echo " ${ss%@*}, optional,intent(in) :: ${ss#*@}" ; done - echo " - type (${type_name}_list), pointer :: this - nullify(ptr) - this => list%next - if(.not.associated(this)) return - do - if(.not.associated(this%ptr)) goto 1000 -" - for ss in $search ; do echo " - if(present(${ss#*@})) then - if(this%ptr%${ss#*@} /= ${ss#*@}) goto 1000 - end if -" ; done -echo " - ptr => this%ptr - exit -1000 continue - if(.not.associated(this%next)) exit - this => this%next - end do - end subroutine ${type_name}_list_search - " - -fi - -} - diff --git a/quantum_espresso/kcp/iotk/include/iotk_mangen.sh b/quantum_espresso/kcp/iotk/include/iotk_mangen.sh deleted file mode 100644 index f0fce8b8e..000000000 --- a/quantum_espresso/kcp/iotk/include/iotk_mangen.sh +++ /dev/null @@ -1,26 +0,0 @@ - depends ../doc/manpages - - function mangen () { - local dslash="//" - local amp="&" - local LINE - while read LINE - do - if [[ $LINE == @* ]] - then - echo "if(printlist) write(iotk_output_unit,\"(a)\") &" - echo "\"${LINE//@/}\"" - echo "printme=.false." - echo "if(iotk_strcomp(keyword,\"all\")) printme=.true." - for name in $LINE - do - [[ $name == @ ]] && continue - echo "if(iotk_strcomp(keyword,'$name')) printme=.true." - done - else - echo "if(printme) write(iotk_output_unit,\"(a)\") &" - echo "\"${LINE//\"/\"$dslash'\"'$dslash$amp$newline\"}\"" - fi - done < ../doc/manpages - } - diff --git a/quantum_espresso/kcp/iotk/include/iotk_version.h b/quantum_espresso/kcp/iotk/include/iotk_version.h deleted file mode 100644 index 24a075c3d..000000000 --- a/quantum_espresso/kcp/iotk/include/iotk_version.h +++ /dev/null @@ -1,5 +0,0 @@ -#define __IOTK_VERSION "1.1.0development" -#define __IOTK_VERSION_MAJOR 1 -#define __IOTK_VERSION_MINOR 1 -#define __IOTK_VERSION_PATCH 0 -#define __IOTK_VERSION_EXTRA "development" diff --git a/quantum_espresso/kcp/iotk/include/iotk_version.sh b/quantum_espresso/kcp/iotk/include/iotk_version.sh deleted file mode 100644 index d0d27fb93..000000000 --- a/quantum_espresso/kcp/iotk/include/iotk_version.sh +++ /dev/null @@ -1,5 +0,0 @@ -__IOTK_VERSION=1.1.0development -__IOTK_VERSION_MAJOR=1 -__IOTK_VERSION_MINOR=1 -__IOTK_VERSION_PATCH=0 -__IOTK_VERSION_EXTRA=development diff --git a/quantum_espresso/kcp/iotk/src/Makefile b/quantum_espresso/kcp/iotk/src/Makefile deleted file mode 100644 index 67ef7a550..000000000 --- a/quantum_espresso/kcp/iotk/src/Makefile +++ /dev/null @@ -1,1502 +0,0 @@ -# -# DO NOT EDIT THIS FILE MANUALLY -# This makefile was automatically generated -# Directory : iotk -# Package : Input/Output Tool Kit -# Version : 1.1.0development -# Authors : Giovanni Bussi -# -# Today is Thu Mar 20 09:48:09 CET 2008 -# -# Global OPTIONS file has NOT been found -# Local OPTIONS file has been used in generation -# -# Sources defined by: *.f90 *.c *.f -# -# List of MAIN source files -# (Fortran files containing a program statement): -# example1.f90 example2.f90 example3.f90 example4.f90 iotk_copy.f90 iotk.f90 -# iotk_print_kinds.f90 test2.f90 test3.f90 test4.f90 test5.f90 test6.f90 -# test7.f90 test8.f90 test9.f90 test.f90 -# -# List of LIB source files -# (Fortran files NOT containing a program statement and c files): -# iotk_attr+CHARACTER1_0.f90 iotk_attr+COMPLEX1_0.f90 iotk_attr+COMPLEX1_3.f90 -# iotk_attr+COMPLEX1_6.f90 iotk_attr+COMPLEX2_0.f90 iotk_attr+COMPLEX2_3.f90 -# iotk_attr+COMPLEX2_6.f90 iotk_attr+COMPLEX3_0.f90 iotk_attr+COMPLEX3_3.f90 -# iotk_attr+COMPLEX3_6.f90 iotk_attr+COMPLEX4_0.f90 iotk_attr+COMPLEX4_3.f90 -# iotk_attr+COMPLEX4_6.f90 iotk_attr.f90 iotk_attr+INTEGER1_0.f90 -# iotk_attr+INTEGER1_3.f90 iotk_attr+INTEGER1_6.f90 iotk_attr+INTEGER2_0.f90 -# iotk_attr+INTEGER2_3.f90 iotk_attr+INTEGER2_6.f90 iotk_attr+INTEGER3_0.f90 -# iotk_attr+INTEGER3_3.f90 iotk_attr+INTEGER3_6.f90 iotk_attr+INTEGER4_0.f90 -# iotk_attr+INTEGER4_3.f90 iotk_attr+INTEGER4_6.f90 iotk_attr_interf.f90 -# iotk_attr+LOGICAL1_0.f90 iotk_attr+LOGICAL1_3.f90 iotk_attr+LOGICAL1_6.f90 -# iotk_attr+LOGICAL2_0.f90 iotk_attr+LOGICAL2_3.f90 iotk_attr+LOGICAL2_6.f90 -# iotk_attr+LOGICAL3_0.f90 iotk_attr+LOGICAL3_3.f90 iotk_attr+LOGICAL3_6.f90 -# iotk_attr+LOGICAL4_0.f90 iotk_attr+LOGICAL4_3.f90 iotk_attr+LOGICAL4_6.f90 -# iotk_attr+REAL1_0.f90 iotk_attr+REAL1_3.f90 iotk_attr+REAL1_6.f90 -# iotk_attr+REAL2_0.f90 iotk_attr+REAL2_3.f90 iotk_attr+REAL2_6.f90 -# iotk_attr+REAL3_0.f90 iotk_attr+REAL3_3.f90 iotk_attr+REAL3_6.f90 -# iotk_attr+REAL4_0.f90 iotk_attr+REAL4_3.f90 iotk_attr+REAL4_6.f90 iotk_base.f90 -# iotk_dat+CHARACTER1_0.f90 iotk_dat+CHARACTER1_3.f90 iotk_dat+CHARACTER1_6.f90 -# iotk_dat+COMPLEX1_0.f90 iotk_dat+COMPLEX1_3.f90 iotk_dat+COMPLEX1_6.f90 -# iotk_dat+COMPLEX2_0.f90 iotk_dat+COMPLEX2_3.f90 iotk_dat+COMPLEX2_6.f90 -# iotk_dat+COMPLEX3_0.f90 iotk_dat+COMPLEX3_3.f90 iotk_dat+COMPLEX3_6.f90 -# iotk_dat+COMPLEX4_0.f90 iotk_dat+COMPLEX4_3.f90 iotk_dat+COMPLEX4_6.f90 -# iotk_dat.f90 iotk_dat+INTEGER1_0.f90 iotk_dat+INTEGER1_3.f90 -# iotk_dat+INTEGER1_6.f90 iotk_dat+INTEGER2_0.f90 iotk_dat+INTEGER2_3.f90 -# iotk_dat+INTEGER2_6.f90 iotk_dat+INTEGER3_0.f90 iotk_dat+INTEGER3_3.f90 -# iotk_dat+INTEGER3_6.f90 iotk_dat+INTEGER4_0.f90 iotk_dat+INTEGER4_3.f90 -# iotk_dat+INTEGER4_6.f90 iotk_dat_interf.f90 iotk_dat+LOGICAL1_0.f90 -# iotk_dat+LOGICAL1_3.f90 iotk_dat+LOGICAL1_6.f90 iotk_dat+LOGICAL2_0.f90 -# iotk_dat+LOGICAL2_3.f90 iotk_dat+LOGICAL2_6.f90 iotk_dat+LOGICAL3_0.f90 -# iotk_dat+LOGICAL3_3.f90 iotk_dat+LOGICAL3_6.f90 iotk_dat+LOGICAL4_0.f90 -# iotk_dat+LOGICAL4_3.f90 iotk_dat+LOGICAL4_6.f90 iotk_dat+REAL1_0.f90 -# iotk_dat+REAL1_3.f90 iotk_dat+REAL1_6.f90 iotk_dat+REAL2_0.f90 -# iotk_dat+REAL2_3.f90 iotk_dat+REAL2_6.f90 iotk_dat+REAL3_0.f90 -# iotk_dat+REAL3_3.f90 iotk_dat+REAL3_6.f90 iotk_dat+REAL4_0.f90 -# iotk_dat+REAL4_3.f90 iotk_dat+REAL4_6.f90 iotk_error.f90 iotk_error_interf.f90 -# iotk_files.f90 iotk_files_interf.f90 iotk_fmt.f90 iotk_fmt_interf.f90 -# iotk_misc.f90 iotk_misc_interf.f90 iotk_module.f90 iotk_scan.f90 -# iotk_scan_interf.f90 iotk_stream.f90 iotk_stream_interf.f90 iotk_str.f90 -# iotk_str_interf.f90 iotk_tool.f90 iotk_tool_interf.f90 iotk_unit.f90 -# iotk_unit_interf.f90 iotk_unit_list.f90 iotk_write.f90 iotk_write_interf.f90 -# iotk_xtox.f90 iotk_xtox_interf.f90 -# -# Used libraries -# -# -# Linked libraries -# -# -# The real Makefile starts here -# -# IDE HOME variable set to DEFAULT -IDEHOME=../.. -# Default configuratione file -CONFIG_FILE=../../make.sys -# -# Objects to be linked in the library -OBJ_LIB= iotk_attr+CHARACTER1_0.o iotk_attr+COMPLEX1_0.o iotk_attr+COMPLEX1_3.o\ - iotk_attr+COMPLEX1_6.o iotk_attr+COMPLEX2_0.o iotk_attr+COMPLEX2_3.o\ - iotk_attr+COMPLEX2_6.o iotk_attr+COMPLEX3_0.o iotk_attr+COMPLEX3_3.o\ - iotk_attr+COMPLEX3_6.o iotk_attr+COMPLEX4_0.o iotk_attr+COMPLEX4_3.o\ - iotk_attr+COMPLEX4_6.o iotk_attr.o iotk_attr+INTEGER1_0.o\ - iotk_attr+INTEGER1_3.o iotk_attr+INTEGER1_6.o iotk_attr+INTEGER2_0.o\ - iotk_attr+INTEGER2_3.o iotk_attr+INTEGER2_6.o iotk_attr+INTEGER3_0.o\ - iotk_attr+INTEGER3_3.o iotk_attr+INTEGER3_6.o iotk_attr+INTEGER4_0.o\ - iotk_attr+INTEGER4_3.o iotk_attr+INTEGER4_6.o iotk_attr_interf.o\ - iotk_attr+LOGICAL1_0.o iotk_attr+LOGICAL1_3.o iotk_attr+LOGICAL1_6.o\ - iotk_attr+LOGICAL2_0.o iotk_attr+LOGICAL2_3.o iotk_attr+LOGICAL2_6.o\ - iotk_attr+LOGICAL3_0.o iotk_attr+LOGICAL3_3.o iotk_attr+LOGICAL3_6.o\ - iotk_attr+LOGICAL4_0.o iotk_attr+LOGICAL4_3.o iotk_attr+LOGICAL4_6.o\ - iotk_attr+REAL1_0.o iotk_attr+REAL1_3.o iotk_attr+REAL1_6.o iotk_attr+REAL2_0.o\ - iotk_attr+REAL2_3.o iotk_attr+REAL2_6.o iotk_attr+REAL3_0.o iotk_attr+REAL3_3.o\ - iotk_attr+REAL3_6.o iotk_attr+REAL4_0.o iotk_attr+REAL4_3.o iotk_attr+REAL4_6.o\ - iotk_base.o iotk_dat+CHARACTER1_0.o iotk_dat+CHARACTER1_3.o\ - iotk_dat+CHARACTER1_6.o iotk_dat+COMPLEX1_0.o iotk_dat+COMPLEX1_3.o\ - iotk_dat+COMPLEX1_6.o iotk_dat+COMPLEX2_0.o iotk_dat+COMPLEX2_3.o\ - iotk_dat+COMPLEX2_6.o iotk_dat+COMPLEX3_0.o iotk_dat+COMPLEX3_3.o\ - iotk_dat+COMPLEX3_6.o iotk_dat+COMPLEX4_0.o iotk_dat+COMPLEX4_3.o\ - iotk_dat+COMPLEX4_6.o iotk_dat.o iotk_dat+INTEGER1_0.o iotk_dat+INTEGER1_3.o\ - iotk_dat+INTEGER1_6.o iotk_dat+INTEGER2_0.o iotk_dat+INTEGER2_3.o\ - iotk_dat+INTEGER2_6.o iotk_dat+INTEGER3_0.o iotk_dat+INTEGER3_3.o\ - iotk_dat+INTEGER3_6.o iotk_dat+INTEGER4_0.o iotk_dat+INTEGER4_3.o\ - iotk_dat+INTEGER4_6.o iotk_dat_interf.o iotk_dat+LOGICAL1_0.o\ - iotk_dat+LOGICAL1_3.o iotk_dat+LOGICAL1_6.o iotk_dat+LOGICAL2_0.o\ - iotk_dat+LOGICAL2_3.o iotk_dat+LOGICAL2_6.o iotk_dat+LOGICAL3_0.o\ - iotk_dat+LOGICAL3_3.o iotk_dat+LOGICAL3_6.o iotk_dat+LOGICAL4_0.o\ - iotk_dat+LOGICAL4_3.o iotk_dat+LOGICAL4_6.o iotk_dat+REAL1_0.o\ - iotk_dat+REAL1_3.o iotk_dat+REAL1_6.o iotk_dat+REAL2_0.o iotk_dat+REAL2_3.o\ - iotk_dat+REAL2_6.o iotk_dat+REAL3_0.o iotk_dat+REAL3_3.o iotk_dat+REAL3_6.o\ - iotk_dat+REAL4_0.o iotk_dat+REAL4_3.o iotk_dat+REAL4_6.o iotk_error.o\ - iotk_error_interf.o iotk_files.o iotk_files_interf.o iotk_fmt.o\ - iotk_fmt_interf.o iotk_misc.o iotk_misc_interf.o iotk_module.o iotk_scan.o\ - iotk_scan_interf.o iotk_stream.o iotk_stream_interf.o iotk_str.o\ - iotk_str_interf.o iotk_tool.o iotk_tool_interf.o iotk_unit.o iotk_unit_interf.o\ - iotk_unit_list.o iotk_write.o iotk_write_interf.o iotk_xtox.o iotk_xtox_interf.o - -# - -# Macros to link the present library -# (may be change by make.sys to the path of installed library) -LIB_IOTK=libiotk.a -LIB_IOTK_INCLUDE=-I. -I$(IDEHOME)/iotk/include - -# Switch to enable actual compilation -# (may be change by make.sys to "external") -LIB_IOTK_SWITCH=internal -# Path for include -AUTO_INCLUDE=$(LIB_IOTK_INCLUDE) - -# List of used library files -AUTO_LIBS=$(LIB_IOTK) -# Inclusion of system dependent files -include $(CONFIG_FILE) -# Macro (re)definitions from OPTIONS file (keyword DEFINITION) -# Nothing found - -# Main target -# INFO print a short help -info: - @make print_info -# INFO make local library and all executables -all: - make loclib - make example1.x - make example2.x - make example3.x - make example4.x - make iotk_copy.x - make iotk.x - make iotk_print_kinds.x - make test2.x - make test3.x - make test4.x - make test5.x - make test6.x - make test7.x - make test8.x - make test9.x - make test.x - -# INFO make local library -loclib: libs loclib_only - -loclib_only: ide_$(LIB_IOTK_SWITCH) - -ide_internal: libiotk.a - -ide_external: fake_external.a - -fake_external.a: - touch $(OBJ_LIB) - touch libiotk.a - touch fake_external.a -# Targets for executables -# INFO make program example1.x -example1.x: example1.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o example1.x example1.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) -# INFO make program example2.x -example2.x: example2.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o example2.x example2.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) -# INFO make program example3.x -example3.x: example3.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o example3.x example3.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) -# INFO make program example4.x -example4.x: example4.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o example4.x example4.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) -# INFO make program iotk_copy.x -iotk_copy.x: iotk_copy.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o iotk_copy.x iotk_copy.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) -# INFO make program iotk.x -iotk.x: iotk.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o iotk.x iotk.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) -# INFO make program iotk_print_kinds.x -iotk_print_kinds.x: iotk_print_kinds.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o iotk_print_kinds.x iotk_print_kinds.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) -# INFO make program test2.x -test2.x: test2.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o test2.x test2.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) -# INFO make program test3.x -test3.x: test3.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o test3.x test3.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) -# INFO make program test4.x -test4.x: test4.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o test4.x test4.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) -# INFO make program test5.x -test5.x: test5.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o test5.x test5.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) -# INFO make program test6.x -test6.x: test6.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o test6.x test6.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) -# INFO make program test7.x -test7.x: test7.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o test7.x test7.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) -# INFO make program test8.x -test8.x: test8.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o test8.x test8.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) -# INFO make program test9.x -test9.x: test9.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o test9.x test9.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) -# INFO make program test.x -test.x: test.o libiotk.a - make loclib_only - $(LD) $(LDFLAGS) -o test.x test.o $(AUTO_LIBS) $(MPI_LIBS) $(LD_LIBS) - - -# Targets for libraries -# INFO make local library (without the used libraries) -libiotk.a: $(OBJ_LIB) - $(AR) $(ARFLAGS) libiotk.a $(OBJ_LIB) - $(RANLIB) libiotk.a - -# INFO make all the used libs -libs: - - -# target for making Makefile -# INFO make local Makefile -make: - cd $(IDEHOME) ; iotk/IDE/makemake.sh iotk - -# target for cleaning -clean_: clean -# INFO cleanup -clean: - - rm -f *.a *.o *.mod *.d *.pc *.pcl *.x *.F90 - - rm -rf $(IDEHOME)/iotk/tmp/* - - rm -f $(IDEHOME)/iotk/bin/*.x - -# Directly added lines from OPTIONS file (keyword MAKEFILE) -# Directly added lines - -# INFO updates all *.f90 files with preprocessor -update: - cd ../include ; ../IDE/bin/sprep --autodep iotk_auxmacros.spp --include . --suffix .h - ../IDE/bin/sprep --autodep *.spp --include ../include - -# INFO similar to update, with --compare-first (still unstable) -update-compare: - cd ../include ; ../IDE/bin/sprep --compare-first --autodep iotk_auxmacros.spp --include . --suffix .h - ../IDE/bin/sprep --autodep *.spp --compare-first --include ../include - -# INFO creates a directory tmp/export containing few source files -export: - cd .. ; tools/export - -# INFO builds the local library and some utilities -lib+util: loclib iotk_print_kinds.x iotk.x - - ( cd ../../bin ; ln -sf ../iotk/src/iotk_print_kinds.x . ) - - ( cd ../../bin ; ln -sf ../iotk/src/iotk.x . ) - -# Special rules for selected files (keyword DEFINITION.filebase) -# Nothing found - -print_info: - @echo " Package : Input/Output Tool Kit" - @echo " Version : 1.1.0development" - @echo " Authors : Giovanni Bussi" - @echo - @echo " type: make " - @echo " Possible 's are:" - @echo " info print a short help" - @echo " all make local library and all executables" - @echo " loclib make local library" - @echo " example1.x make program example1.x" - @echo " example2.x make program example2.x" - @echo " example3.x make program example3.x" - @echo " example4.x make program example4.x" - @echo " iotk_copy.x make program iotk_copy.x" - @echo " iotk.x make program iotk.x" - @echo " iotk_print_kinds.x make program iotk_print_kinds.x" - @echo " test2.x make program test2.x" - @echo " test3.x make program test3.x" - @echo " test4.x make program test4.x" - @echo " test5.x make program test5.x" - @echo " test6.x make program test6.x" - @echo " test7.x make program test7.x" - @echo " test8.x make program test8.x" - @echo " test9.x make program test9.x" - @echo " test.x make program test.x" - @echo " libiotk.a make local library (without the used libraries)" - @echo " libs make all the used libs" - @echo " make make local Makefile" - @echo " clean cleanup" - @echo " update updates all *.f90 files with preprocessor" - @echo " update-compare similar to update, with --compare-first (still unstable)" - @echo " export creates a directory tmp/export containing few source files" - @echo " lib+util builds the local library and some utilities" - @echo # Dependencies -example1.o : iotk_module.o -example2.o : iotk_module.o -example3.o : iotk_module.o -example4.o : iotk_module.o -iotk_attr+CHARACTER1_0.o : ../include/iotk_auxmacros.h -iotk_attr+CHARACTER1_0.o : ../include/iotk_config.h -iotk_attr+CHARACTER1_0.o : iotk_attr_interf.o -iotk_attr+CHARACTER1_0.o : iotk_base.o -iotk_attr+CHARACTER1_0.o : iotk_error_interf.o -iotk_attr+CHARACTER1_0.o : iotk_misc_interf.o -iotk_attr+CHARACTER1_0.o : iotk_str_interf.o -iotk_attr+COMPLEX1_0.o : ../include/iotk_auxmacros.h -iotk_attr+COMPLEX1_0.o : ../include/iotk_config.h -iotk_attr+COMPLEX1_0.o : iotk_attr_interf.o -iotk_attr+COMPLEX1_0.o : iotk_base.o -iotk_attr+COMPLEX1_0.o : iotk_error_interf.o -iotk_attr+COMPLEX1_0.o : iotk_fmt_interf.o -iotk_attr+COMPLEX1_0.o : iotk_misc_interf.o -iotk_attr+COMPLEX1_0.o : iotk_str_interf.o -iotk_attr+COMPLEX1_0.o : iotk_xtox_interf.o -iotk_attr+COMPLEX1_3.o : ../include/iotk_auxmacros.h -iotk_attr+COMPLEX1_3.o : ../include/iotk_config.h -iotk_attr+COMPLEX1_3.o : iotk_attr_interf.o -iotk_attr+COMPLEX1_3.o : iotk_base.o -iotk_attr+COMPLEX1_3.o : iotk_error_interf.o -iotk_attr+COMPLEX1_3.o : iotk_misc_interf.o -iotk_attr+COMPLEX1_3.o : iotk_str_interf.o -iotk_attr+COMPLEX1_6.o : ../include/iotk_auxmacros.h -iotk_attr+COMPLEX1_6.o : ../include/iotk_config.h -iotk_attr+COMPLEX1_6.o : iotk_attr_interf.o -iotk_attr+COMPLEX1_6.o : iotk_base.o -iotk_attr+COMPLEX1_6.o : iotk_error_interf.o -iotk_attr+COMPLEX1_6.o : iotk_misc_interf.o -iotk_attr+COMPLEX1_6.o : iotk_str_interf.o -iotk_attr+COMPLEX2_0.o : ../include/iotk_auxmacros.h -iotk_attr+COMPLEX2_0.o : ../include/iotk_config.h -iotk_attr+COMPLEX2_0.o : iotk_attr_interf.o -iotk_attr+COMPLEX2_0.o : iotk_base.o -iotk_attr+COMPLEX2_0.o : iotk_error_interf.o -iotk_attr+COMPLEX2_0.o : iotk_fmt_interf.o -iotk_attr+COMPLEX2_0.o : iotk_misc_interf.o -iotk_attr+COMPLEX2_0.o : iotk_str_interf.o -iotk_attr+COMPLEX2_0.o : iotk_xtox_interf.o -iotk_attr+COMPLEX2_3.o : ../include/iotk_auxmacros.h -iotk_attr+COMPLEX2_3.o : ../include/iotk_config.h -iotk_attr+COMPLEX2_3.o : iotk_attr_interf.o -iotk_attr+COMPLEX2_3.o : iotk_base.o -iotk_attr+COMPLEX2_3.o : iotk_error_interf.o -iotk_attr+COMPLEX2_3.o : iotk_misc_interf.o -iotk_attr+COMPLEX2_3.o : iotk_str_interf.o -iotk_attr+COMPLEX2_6.o : ../include/iotk_auxmacros.h -iotk_attr+COMPLEX2_6.o : ../include/iotk_config.h -iotk_attr+COMPLEX2_6.o : iotk_attr_interf.o -iotk_attr+COMPLEX2_6.o : iotk_base.o -iotk_attr+COMPLEX2_6.o : iotk_error_interf.o -iotk_attr+COMPLEX2_6.o : iotk_misc_interf.o -iotk_attr+COMPLEX2_6.o : iotk_str_interf.o -iotk_attr+COMPLEX3_0.o : ../include/iotk_auxmacros.h -iotk_attr+COMPLEX3_0.o : ../include/iotk_config.h -iotk_attr+COMPLEX3_0.o : iotk_attr_interf.o -iotk_attr+COMPLEX3_0.o : iotk_base.o -iotk_attr+COMPLEX3_0.o : iotk_error_interf.o -iotk_attr+COMPLEX3_0.o : iotk_fmt_interf.o -iotk_attr+COMPLEX3_0.o : iotk_misc_interf.o -iotk_attr+COMPLEX3_0.o : iotk_str_interf.o -iotk_attr+COMPLEX3_0.o : iotk_xtox_interf.o -iotk_attr+COMPLEX3_3.o : ../include/iotk_auxmacros.h -iotk_attr+COMPLEX3_3.o : ../include/iotk_config.h -iotk_attr+COMPLEX3_3.o : iotk_attr_interf.o -iotk_attr+COMPLEX3_3.o : iotk_base.o -iotk_attr+COMPLEX3_3.o : iotk_error_interf.o -iotk_attr+COMPLEX3_3.o : iotk_misc_interf.o -iotk_attr+COMPLEX3_3.o : iotk_str_interf.o -iotk_attr+COMPLEX3_6.o : ../include/iotk_auxmacros.h -iotk_attr+COMPLEX3_6.o : ../include/iotk_config.h -iotk_attr+COMPLEX3_6.o : iotk_attr_interf.o -iotk_attr+COMPLEX3_6.o : iotk_base.o -iotk_attr+COMPLEX3_6.o : iotk_error_interf.o -iotk_attr+COMPLEX3_6.o : iotk_misc_interf.o -iotk_attr+COMPLEX3_6.o : iotk_str_interf.o -iotk_attr+COMPLEX4_0.o : ../include/iotk_auxmacros.h -iotk_attr+COMPLEX4_0.o : ../include/iotk_config.h -iotk_attr+COMPLEX4_0.o : iotk_attr_interf.o -iotk_attr+COMPLEX4_0.o : iotk_base.o -iotk_attr+COMPLEX4_0.o : iotk_error_interf.o -iotk_attr+COMPLEX4_0.o : iotk_fmt_interf.o -iotk_attr+COMPLEX4_0.o : iotk_misc_interf.o -iotk_attr+COMPLEX4_0.o : iotk_str_interf.o -iotk_attr+COMPLEX4_0.o : iotk_xtox_interf.o -iotk_attr+COMPLEX4_3.o : ../include/iotk_auxmacros.h -iotk_attr+COMPLEX4_3.o : ../include/iotk_config.h -iotk_attr+COMPLEX4_3.o : iotk_attr_interf.o -iotk_attr+COMPLEX4_3.o : iotk_base.o -iotk_attr+COMPLEX4_3.o : iotk_error_interf.o -iotk_attr+COMPLEX4_3.o : iotk_misc_interf.o -iotk_attr+COMPLEX4_3.o : iotk_str_interf.o -iotk_attr+COMPLEX4_6.o : ../include/iotk_auxmacros.h -iotk_attr+COMPLEX4_6.o : ../include/iotk_config.h -iotk_attr+COMPLEX4_6.o : iotk_attr_interf.o -iotk_attr+COMPLEX4_6.o : iotk_base.o -iotk_attr+COMPLEX4_6.o : iotk_error_interf.o -iotk_attr+COMPLEX4_6.o : iotk_misc_interf.o -iotk_attr+COMPLEX4_6.o : iotk_str_interf.o -iotk_attr+INTEGER1_0.o : ../include/iotk_auxmacros.h -iotk_attr+INTEGER1_0.o : ../include/iotk_config.h -iotk_attr+INTEGER1_0.o : iotk_attr_interf.o -iotk_attr+INTEGER1_0.o : iotk_base.o -iotk_attr+INTEGER1_0.o : iotk_error_interf.o -iotk_attr+INTEGER1_0.o : iotk_fmt_interf.o -iotk_attr+INTEGER1_0.o : iotk_misc_interf.o -iotk_attr+INTEGER1_0.o : iotk_str_interf.o -iotk_attr+INTEGER1_0.o : iotk_xtox_interf.o -iotk_attr+INTEGER1_3.o : ../include/iotk_auxmacros.h -iotk_attr+INTEGER1_3.o : ../include/iotk_config.h -iotk_attr+INTEGER1_3.o : iotk_attr_interf.o -iotk_attr+INTEGER1_3.o : iotk_base.o -iotk_attr+INTEGER1_3.o : iotk_error_interf.o -iotk_attr+INTEGER1_3.o : iotk_misc_interf.o -iotk_attr+INTEGER1_3.o : iotk_str_interf.o -iotk_attr+INTEGER1_6.o : ../include/iotk_auxmacros.h -iotk_attr+INTEGER1_6.o : ../include/iotk_config.h -iotk_attr+INTEGER1_6.o : iotk_attr_interf.o -iotk_attr+INTEGER1_6.o : iotk_base.o -iotk_attr+INTEGER1_6.o : iotk_error_interf.o -iotk_attr+INTEGER1_6.o : iotk_misc_interf.o -iotk_attr+INTEGER1_6.o : iotk_str_interf.o -iotk_attr+INTEGER2_0.o : ../include/iotk_auxmacros.h -iotk_attr+INTEGER2_0.o : ../include/iotk_config.h -iotk_attr+INTEGER2_0.o : iotk_attr_interf.o -iotk_attr+INTEGER2_0.o : iotk_base.o -iotk_attr+INTEGER2_0.o : iotk_error_interf.o -iotk_attr+INTEGER2_0.o : iotk_fmt_interf.o -iotk_attr+INTEGER2_0.o : iotk_misc_interf.o -iotk_attr+INTEGER2_0.o : iotk_str_interf.o -iotk_attr+INTEGER2_0.o : iotk_xtox_interf.o -iotk_attr+INTEGER2_3.o : ../include/iotk_auxmacros.h -iotk_attr+INTEGER2_3.o : ../include/iotk_config.h -iotk_attr+INTEGER2_3.o : iotk_attr_interf.o -iotk_attr+INTEGER2_3.o : iotk_base.o -iotk_attr+INTEGER2_3.o : iotk_error_interf.o -iotk_attr+INTEGER2_3.o : iotk_misc_interf.o -iotk_attr+INTEGER2_3.o : iotk_str_interf.o -iotk_attr+INTEGER2_6.o : ../include/iotk_auxmacros.h -iotk_attr+INTEGER2_6.o : ../include/iotk_config.h -iotk_attr+INTEGER2_6.o : iotk_attr_interf.o -iotk_attr+INTEGER2_6.o : iotk_base.o -iotk_attr+INTEGER2_6.o : iotk_error_interf.o -iotk_attr+INTEGER2_6.o : iotk_misc_interf.o -iotk_attr+INTEGER2_6.o : iotk_str_interf.o -iotk_attr+INTEGER3_0.o : ../include/iotk_auxmacros.h -iotk_attr+INTEGER3_0.o : ../include/iotk_config.h -iotk_attr+INTEGER3_0.o : iotk_attr_interf.o -iotk_attr+INTEGER3_0.o : iotk_base.o -iotk_attr+INTEGER3_0.o : iotk_error_interf.o -iotk_attr+INTEGER3_0.o : iotk_fmt_interf.o -iotk_attr+INTEGER3_0.o : iotk_misc_interf.o -iotk_attr+INTEGER3_0.o : iotk_str_interf.o -iotk_attr+INTEGER3_0.o : iotk_xtox_interf.o -iotk_attr+INTEGER3_3.o : ../include/iotk_auxmacros.h -iotk_attr+INTEGER3_3.o : ../include/iotk_config.h -iotk_attr+INTEGER3_3.o : iotk_attr_interf.o -iotk_attr+INTEGER3_3.o : iotk_base.o -iotk_attr+INTEGER3_3.o : iotk_error_interf.o -iotk_attr+INTEGER3_3.o : iotk_misc_interf.o -iotk_attr+INTEGER3_3.o : iotk_str_interf.o -iotk_attr+INTEGER3_6.o : ../include/iotk_auxmacros.h -iotk_attr+INTEGER3_6.o : ../include/iotk_config.h -iotk_attr+INTEGER3_6.o : iotk_attr_interf.o -iotk_attr+INTEGER3_6.o : iotk_base.o -iotk_attr+INTEGER3_6.o : iotk_error_interf.o -iotk_attr+INTEGER3_6.o : iotk_misc_interf.o -iotk_attr+INTEGER3_6.o : iotk_str_interf.o -iotk_attr+INTEGER4_0.o : ../include/iotk_auxmacros.h -iotk_attr+INTEGER4_0.o : ../include/iotk_config.h -iotk_attr+INTEGER4_0.o : iotk_attr_interf.o -iotk_attr+INTEGER4_0.o : iotk_base.o -iotk_attr+INTEGER4_0.o : iotk_error_interf.o -iotk_attr+INTEGER4_0.o : iotk_fmt_interf.o -iotk_attr+INTEGER4_0.o : iotk_misc_interf.o -iotk_attr+INTEGER4_0.o : iotk_str_interf.o -iotk_attr+INTEGER4_0.o : iotk_xtox_interf.o -iotk_attr+INTEGER4_3.o : ../include/iotk_auxmacros.h -iotk_attr+INTEGER4_3.o : ../include/iotk_config.h -iotk_attr+INTEGER4_3.o : iotk_attr_interf.o -iotk_attr+INTEGER4_3.o : iotk_base.o -iotk_attr+INTEGER4_3.o : iotk_error_interf.o -iotk_attr+INTEGER4_3.o : iotk_misc_interf.o -iotk_attr+INTEGER4_3.o : iotk_str_interf.o -iotk_attr+INTEGER4_6.o : ../include/iotk_auxmacros.h -iotk_attr+INTEGER4_6.o : ../include/iotk_config.h -iotk_attr+INTEGER4_6.o : iotk_attr_interf.o -iotk_attr+INTEGER4_6.o : iotk_base.o -iotk_attr+INTEGER4_6.o : iotk_error_interf.o -iotk_attr+INTEGER4_6.o : iotk_misc_interf.o -iotk_attr+INTEGER4_6.o : iotk_str_interf.o -iotk_attr_interf.o : ../include/iotk_auxmacros.h -iotk_attr_interf.o : ../include/iotk_config.h -iotk_attr_interf.o : iotk_base.o -iotk_attr+LOGICAL1_0.o : ../include/iotk_auxmacros.h -iotk_attr+LOGICAL1_0.o : ../include/iotk_config.h -iotk_attr+LOGICAL1_0.o : iotk_attr_interf.o -iotk_attr+LOGICAL1_0.o : iotk_base.o -iotk_attr+LOGICAL1_0.o : iotk_error_interf.o -iotk_attr+LOGICAL1_0.o : iotk_fmt_interf.o -iotk_attr+LOGICAL1_0.o : iotk_misc_interf.o -iotk_attr+LOGICAL1_0.o : iotk_str_interf.o -iotk_attr+LOGICAL1_0.o : iotk_xtox_interf.o -iotk_attr+LOGICAL1_3.o : ../include/iotk_auxmacros.h -iotk_attr+LOGICAL1_3.o : ../include/iotk_config.h -iotk_attr+LOGICAL1_3.o : iotk_attr_interf.o -iotk_attr+LOGICAL1_3.o : iotk_base.o -iotk_attr+LOGICAL1_3.o : iotk_error_interf.o -iotk_attr+LOGICAL1_3.o : iotk_misc_interf.o -iotk_attr+LOGICAL1_3.o : iotk_str_interf.o -iotk_attr+LOGICAL1_6.o : ../include/iotk_auxmacros.h -iotk_attr+LOGICAL1_6.o : ../include/iotk_config.h -iotk_attr+LOGICAL1_6.o : iotk_attr_interf.o -iotk_attr+LOGICAL1_6.o : iotk_base.o -iotk_attr+LOGICAL1_6.o : iotk_error_interf.o -iotk_attr+LOGICAL1_6.o : iotk_misc_interf.o -iotk_attr+LOGICAL1_6.o : iotk_str_interf.o -iotk_attr+LOGICAL2_0.o : ../include/iotk_auxmacros.h -iotk_attr+LOGICAL2_0.o : ../include/iotk_config.h -iotk_attr+LOGICAL2_0.o : iotk_attr_interf.o -iotk_attr+LOGICAL2_0.o : iotk_base.o -iotk_attr+LOGICAL2_0.o : iotk_error_interf.o -iotk_attr+LOGICAL2_0.o : iotk_fmt_interf.o -iotk_attr+LOGICAL2_0.o : iotk_misc_interf.o -iotk_attr+LOGICAL2_0.o : iotk_str_interf.o -iotk_attr+LOGICAL2_0.o : iotk_xtox_interf.o -iotk_attr+LOGICAL2_3.o : ../include/iotk_auxmacros.h -iotk_attr+LOGICAL2_3.o : ../include/iotk_config.h -iotk_attr+LOGICAL2_3.o : iotk_attr_interf.o -iotk_attr+LOGICAL2_3.o : iotk_base.o -iotk_attr+LOGICAL2_3.o : iotk_error_interf.o -iotk_attr+LOGICAL2_3.o : iotk_misc_interf.o -iotk_attr+LOGICAL2_3.o : iotk_str_interf.o -iotk_attr+LOGICAL2_6.o : ../include/iotk_auxmacros.h -iotk_attr+LOGICAL2_6.o : ../include/iotk_config.h -iotk_attr+LOGICAL2_6.o : iotk_attr_interf.o -iotk_attr+LOGICAL2_6.o : iotk_base.o -iotk_attr+LOGICAL2_6.o : iotk_error_interf.o -iotk_attr+LOGICAL2_6.o : iotk_misc_interf.o -iotk_attr+LOGICAL2_6.o : iotk_str_interf.o -iotk_attr+LOGICAL3_0.o : ../include/iotk_auxmacros.h -iotk_attr+LOGICAL3_0.o : ../include/iotk_config.h -iotk_attr+LOGICAL3_0.o : iotk_attr_interf.o -iotk_attr+LOGICAL3_0.o : iotk_base.o -iotk_attr+LOGICAL3_0.o : iotk_error_interf.o -iotk_attr+LOGICAL3_0.o : iotk_fmt_interf.o -iotk_attr+LOGICAL3_0.o : iotk_misc_interf.o -iotk_attr+LOGICAL3_0.o : iotk_str_interf.o -iotk_attr+LOGICAL3_0.o : iotk_xtox_interf.o -iotk_attr+LOGICAL3_3.o : ../include/iotk_auxmacros.h -iotk_attr+LOGICAL3_3.o : ../include/iotk_config.h -iotk_attr+LOGICAL3_3.o : iotk_attr_interf.o -iotk_attr+LOGICAL3_3.o : iotk_base.o -iotk_attr+LOGICAL3_3.o : iotk_error_interf.o -iotk_attr+LOGICAL3_3.o : iotk_misc_interf.o -iotk_attr+LOGICAL3_3.o : iotk_str_interf.o -iotk_attr+LOGICAL3_6.o : ../include/iotk_auxmacros.h -iotk_attr+LOGICAL3_6.o : ../include/iotk_config.h -iotk_attr+LOGICAL3_6.o : iotk_attr_interf.o -iotk_attr+LOGICAL3_6.o : iotk_base.o -iotk_attr+LOGICAL3_6.o : iotk_error_interf.o -iotk_attr+LOGICAL3_6.o : iotk_misc_interf.o -iotk_attr+LOGICAL3_6.o : iotk_str_interf.o -iotk_attr+LOGICAL4_0.o : ../include/iotk_auxmacros.h -iotk_attr+LOGICAL4_0.o : ../include/iotk_config.h -iotk_attr+LOGICAL4_0.o : iotk_attr_interf.o -iotk_attr+LOGICAL4_0.o : iotk_base.o -iotk_attr+LOGICAL4_0.o : iotk_error_interf.o -iotk_attr+LOGICAL4_0.o : iotk_fmt_interf.o -iotk_attr+LOGICAL4_0.o : iotk_misc_interf.o -iotk_attr+LOGICAL4_0.o : iotk_str_interf.o -iotk_attr+LOGICAL4_0.o : iotk_xtox_interf.o -iotk_attr+LOGICAL4_3.o : ../include/iotk_auxmacros.h -iotk_attr+LOGICAL4_3.o : ../include/iotk_config.h -iotk_attr+LOGICAL4_3.o : iotk_attr_interf.o -iotk_attr+LOGICAL4_3.o : iotk_base.o -iotk_attr+LOGICAL4_3.o : iotk_error_interf.o -iotk_attr+LOGICAL4_3.o : iotk_misc_interf.o -iotk_attr+LOGICAL4_3.o : iotk_str_interf.o -iotk_attr+LOGICAL4_6.o : ../include/iotk_auxmacros.h -iotk_attr+LOGICAL4_6.o : ../include/iotk_config.h -iotk_attr+LOGICAL4_6.o : iotk_attr_interf.o -iotk_attr+LOGICAL4_6.o : iotk_base.o -iotk_attr+LOGICAL4_6.o : iotk_error_interf.o -iotk_attr+LOGICAL4_6.o : iotk_misc_interf.o -iotk_attr+LOGICAL4_6.o : iotk_str_interf.o -iotk_attr.o : ../include/iotk_auxmacros.h -iotk_attr.o : ../include/iotk_config.h -iotk_attr+REAL1_0.o : ../include/iotk_auxmacros.h -iotk_attr+REAL1_0.o : ../include/iotk_config.h -iotk_attr+REAL1_0.o : iotk_attr_interf.o -iotk_attr+REAL1_0.o : iotk_base.o -iotk_attr+REAL1_0.o : iotk_error_interf.o -iotk_attr+REAL1_0.o : iotk_fmt_interf.o -iotk_attr+REAL1_0.o : iotk_misc_interf.o -iotk_attr+REAL1_0.o : iotk_str_interf.o -iotk_attr+REAL1_0.o : iotk_xtox_interf.o -iotk_attr+REAL1_3.o : ../include/iotk_auxmacros.h -iotk_attr+REAL1_3.o : ../include/iotk_config.h -iotk_attr+REAL1_3.o : iotk_attr_interf.o -iotk_attr+REAL1_3.o : iotk_base.o -iotk_attr+REAL1_3.o : iotk_error_interf.o -iotk_attr+REAL1_3.o : iotk_misc_interf.o -iotk_attr+REAL1_3.o : iotk_str_interf.o -iotk_attr+REAL1_6.o : ../include/iotk_auxmacros.h -iotk_attr+REAL1_6.o : ../include/iotk_config.h -iotk_attr+REAL1_6.o : iotk_attr_interf.o -iotk_attr+REAL1_6.o : iotk_base.o -iotk_attr+REAL1_6.o : iotk_error_interf.o -iotk_attr+REAL1_6.o : iotk_misc_interf.o -iotk_attr+REAL1_6.o : iotk_str_interf.o -iotk_attr+REAL2_0.o : ../include/iotk_auxmacros.h -iotk_attr+REAL2_0.o : ../include/iotk_config.h -iotk_attr+REAL2_0.o : iotk_attr_interf.o -iotk_attr+REAL2_0.o : iotk_base.o -iotk_attr+REAL2_0.o : iotk_error_interf.o -iotk_attr+REAL2_0.o : iotk_fmt_interf.o -iotk_attr+REAL2_0.o : iotk_misc_interf.o -iotk_attr+REAL2_0.o : iotk_str_interf.o -iotk_attr+REAL2_0.o : iotk_xtox_interf.o -iotk_attr+REAL2_3.o : ../include/iotk_auxmacros.h -iotk_attr+REAL2_3.o : ../include/iotk_config.h -iotk_attr+REAL2_3.o : iotk_attr_interf.o -iotk_attr+REAL2_3.o : iotk_base.o -iotk_attr+REAL2_3.o : iotk_error_interf.o -iotk_attr+REAL2_3.o : iotk_misc_interf.o -iotk_attr+REAL2_3.o : iotk_str_interf.o -iotk_attr+REAL2_6.o : ../include/iotk_auxmacros.h -iotk_attr+REAL2_6.o : ../include/iotk_config.h -iotk_attr+REAL2_6.o : iotk_attr_interf.o -iotk_attr+REAL2_6.o : iotk_base.o -iotk_attr+REAL2_6.o : iotk_error_interf.o -iotk_attr+REAL2_6.o : iotk_misc_interf.o -iotk_attr+REAL2_6.o : iotk_str_interf.o -iotk_attr+REAL3_0.o : ../include/iotk_auxmacros.h -iotk_attr+REAL3_0.o : ../include/iotk_config.h -iotk_attr+REAL3_0.o : iotk_attr_interf.o -iotk_attr+REAL3_0.o : iotk_base.o -iotk_attr+REAL3_0.o : iotk_error_interf.o -iotk_attr+REAL3_0.o : iotk_fmt_interf.o -iotk_attr+REAL3_0.o : iotk_misc_interf.o -iotk_attr+REAL3_0.o : iotk_str_interf.o -iotk_attr+REAL3_0.o : iotk_xtox_interf.o -iotk_attr+REAL3_3.o : ../include/iotk_auxmacros.h -iotk_attr+REAL3_3.o : ../include/iotk_config.h -iotk_attr+REAL3_3.o : iotk_attr_interf.o -iotk_attr+REAL3_3.o : iotk_base.o -iotk_attr+REAL3_3.o : iotk_error_interf.o -iotk_attr+REAL3_3.o : iotk_misc_interf.o -iotk_attr+REAL3_3.o : iotk_str_interf.o -iotk_attr+REAL3_6.o : ../include/iotk_auxmacros.h -iotk_attr+REAL3_6.o : ../include/iotk_config.h -iotk_attr+REAL3_6.o : iotk_attr_interf.o -iotk_attr+REAL3_6.o : iotk_base.o -iotk_attr+REAL3_6.o : iotk_error_interf.o -iotk_attr+REAL3_6.o : iotk_misc_interf.o -iotk_attr+REAL3_6.o : iotk_str_interf.o -iotk_attr+REAL4_0.o : ../include/iotk_auxmacros.h -iotk_attr+REAL4_0.o : ../include/iotk_config.h -iotk_attr+REAL4_0.o : iotk_attr_interf.o -iotk_attr+REAL4_0.o : iotk_base.o -iotk_attr+REAL4_0.o : iotk_error_interf.o -iotk_attr+REAL4_0.o : iotk_fmt_interf.o -iotk_attr+REAL4_0.o : iotk_misc_interf.o -iotk_attr+REAL4_0.o : iotk_str_interf.o -iotk_attr+REAL4_0.o : iotk_xtox_interf.o -iotk_attr+REAL4_3.o : ../include/iotk_auxmacros.h -iotk_attr+REAL4_3.o : ../include/iotk_config.h -iotk_attr+REAL4_3.o : iotk_attr_interf.o -iotk_attr+REAL4_3.o : iotk_base.o -iotk_attr+REAL4_3.o : iotk_error_interf.o -iotk_attr+REAL4_3.o : iotk_misc_interf.o -iotk_attr+REAL4_3.o : iotk_str_interf.o -iotk_attr+REAL4_6.o : ../include/iotk_auxmacros.h -iotk_attr+REAL4_6.o : ../include/iotk_config.h -iotk_attr+REAL4_6.o : iotk_attr_interf.o -iotk_attr+REAL4_6.o : iotk_base.o -iotk_attr+REAL4_6.o : iotk_error_interf.o -iotk_attr+REAL4_6.o : iotk_misc_interf.o -iotk_attr+REAL4_6.o : iotk_str_interf.o -iotk_base.o : ../include/iotk_auxmacros.h -iotk_base.o : ../include/iotk_config.h -iotk_copy.o : iotk_files_interf.o -iotk_copy.o : iotk_module.o -iotk_dat+CHARACTER1_0.o : ../include/iotk_auxmacros.h -iotk_dat+CHARACTER1_0.o : ../include/iotk_config.h -iotk_dat+CHARACTER1_0.o : iotk_attr_interf.o -iotk_dat+CHARACTER1_0.o : iotk_base.o -iotk_dat+CHARACTER1_0.o : iotk_dat_interf.o -iotk_dat+CHARACTER1_0.o : iotk_error_interf.o -iotk_dat+CHARACTER1_0.o : iotk_fmt_interf.o -iotk_dat+CHARACTER1_0.o : iotk_misc_interf.o -iotk_dat+CHARACTER1_0.o : iotk_scan_interf.o -iotk_dat+CHARACTER1_0.o : iotk_stream_interf.o -iotk_dat+CHARACTER1_0.o : iotk_str_interf.o -iotk_dat+CHARACTER1_0.o : iotk_unit_interf.o -iotk_dat+CHARACTER1_0.o : iotk_write_interf.o -iotk_dat+CHARACTER1_3.o : ../include/iotk_auxmacros.h -iotk_dat+CHARACTER1_3.o : ../include/iotk_config.h -iotk_dat+CHARACTER1_3.o : iotk_attr_interf.o -iotk_dat+CHARACTER1_3.o : iotk_base.o -iotk_dat+CHARACTER1_3.o : iotk_dat_interf.o -iotk_dat+CHARACTER1_3.o : iotk_error_interf.o -iotk_dat+CHARACTER1_3.o : iotk_fmt_interf.o -iotk_dat+CHARACTER1_3.o : iotk_misc_interf.o -iotk_dat+CHARACTER1_3.o : iotk_scan_interf.o -iotk_dat+CHARACTER1_3.o : iotk_str_interf.o -iotk_dat+CHARACTER1_3.o : iotk_unit_interf.o -iotk_dat+CHARACTER1_3.o : iotk_write_interf.o -iotk_dat+CHARACTER1_6.o : ../include/iotk_auxmacros.h -iotk_dat+CHARACTER1_6.o : ../include/iotk_config.h -iotk_dat+CHARACTER1_6.o : iotk_attr_interf.o -iotk_dat+CHARACTER1_6.o : iotk_base.o -iotk_dat+CHARACTER1_6.o : iotk_dat_interf.o -iotk_dat+CHARACTER1_6.o : iotk_error_interf.o -iotk_dat+CHARACTER1_6.o : iotk_fmt_interf.o -iotk_dat+CHARACTER1_6.o : iotk_misc_interf.o -iotk_dat+CHARACTER1_6.o : iotk_scan_interf.o -iotk_dat+CHARACTER1_6.o : iotk_str_interf.o -iotk_dat+CHARACTER1_6.o : iotk_unit_interf.o -iotk_dat+CHARACTER1_6.o : iotk_write_interf.o -iotk_dat+COMPLEX1_0.o : ../include/iotk_auxmacros.h -iotk_dat+COMPLEX1_0.o : ../include/iotk_config.h -iotk_dat+COMPLEX1_0.o : iotk_attr_interf.o -iotk_dat+COMPLEX1_0.o : iotk_base.o -iotk_dat+COMPLEX1_0.o : iotk_dat_interf.o -iotk_dat+COMPLEX1_0.o : iotk_error_interf.o -iotk_dat+COMPLEX1_0.o : iotk_fmt_interf.o -iotk_dat+COMPLEX1_0.o : iotk_misc_interf.o -iotk_dat+COMPLEX1_0.o : iotk_scan_interf.o -iotk_dat+COMPLEX1_0.o : iotk_stream_interf.o -iotk_dat+COMPLEX1_0.o : iotk_str_interf.o -iotk_dat+COMPLEX1_0.o : iotk_unit_interf.o -iotk_dat+COMPLEX1_0.o : iotk_write_interf.o -iotk_dat+COMPLEX1_3.o : ../include/iotk_auxmacros.h -iotk_dat+COMPLEX1_3.o : ../include/iotk_config.h -iotk_dat+COMPLEX1_3.o : iotk_attr_interf.o -iotk_dat+COMPLEX1_3.o : iotk_base.o -iotk_dat+COMPLEX1_3.o : iotk_dat_interf.o -iotk_dat+COMPLEX1_3.o : iotk_error_interf.o -iotk_dat+COMPLEX1_3.o : iotk_fmt_interf.o -iotk_dat+COMPLEX1_3.o : iotk_misc_interf.o -iotk_dat+COMPLEX1_3.o : iotk_scan_interf.o -iotk_dat+COMPLEX1_3.o : iotk_str_interf.o -iotk_dat+COMPLEX1_3.o : iotk_unit_interf.o -iotk_dat+COMPLEX1_3.o : iotk_write_interf.o -iotk_dat+COMPLEX1_6.o : ../include/iotk_auxmacros.h -iotk_dat+COMPLEX1_6.o : ../include/iotk_config.h -iotk_dat+COMPLEX1_6.o : iotk_attr_interf.o -iotk_dat+COMPLEX1_6.o : iotk_base.o -iotk_dat+COMPLEX1_6.o : iotk_dat_interf.o -iotk_dat+COMPLEX1_6.o : iotk_error_interf.o -iotk_dat+COMPLEX1_6.o : iotk_fmt_interf.o -iotk_dat+COMPLEX1_6.o : iotk_misc_interf.o -iotk_dat+COMPLEX1_6.o : iotk_scan_interf.o -iotk_dat+COMPLEX1_6.o : iotk_str_interf.o -iotk_dat+COMPLEX1_6.o : iotk_unit_interf.o -iotk_dat+COMPLEX1_6.o : iotk_write_interf.o -iotk_dat+COMPLEX2_0.o : ../include/iotk_auxmacros.h -iotk_dat+COMPLEX2_0.o : ../include/iotk_config.h -iotk_dat+COMPLEX2_0.o : iotk_attr_interf.o -iotk_dat+COMPLEX2_0.o : iotk_base.o -iotk_dat+COMPLEX2_0.o : iotk_dat_interf.o -iotk_dat+COMPLEX2_0.o : iotk_error_interf.o -iotk_dat+COMPLEX2_0.o : iotk_fmt_interf.o -iotk_dat+COMPLEX2_0.o : iotk_misc_interf.o -iotk_dat+COMPLEX2_0.o : iotk_scan_interf.o -iotk_dat+COMPLEX2_0.o : iotk_stream_interf.o -iotk_dat+COMPLEX2_0.o : iotk_str_interf.o -iotk_dat+COMPLEX2_0.o : iotk_unit_interf.o -iotk_dat+COMPLEX2_0.o : iotk_write_interf.o -iotk_dat+COMPLEX2_3.o : ../include/iotk_auxmacros.h -iotk_dat+COMPLEX2_3.o : ../include/iotk_config.h -iotk_dat+COMPLEX2_3.o : iotk_attr_interf.o -iotk_dat+COMPLEX2_3.o : iotk_base.o -iotk_dat+COMPLEX2_3.o : iotk_dat_interf.o -iotk_dat+COMPLEX2_3.o : iotk_error_interf.o -iotk_dat+COMPLEX2_3.o : iotk_fmt_interf.o -iotk_dat+COMPLEX2_3.o : iotk_misc_interf.o -iotk_dat+COMPLEX2_3.o : iotk_scan_interf.o -iotk_dat+COMPLEX2_3.o : iotk_str_interf.o -iotk_dat+COMPLEX2_3.o : iotk_unit_interf.o -iotk_dat+COMPLEX2_3.o : iotk_write_interf.o -iotk_dat+COMPLEX2_6.o : ../include/iotk_auxmacros.h -iotk_dat+COMPLEX2_6.o : ../include/iotk_config.h -iotk_dat+COMPLEX2_6.o : iotk_attr_interf.o -iotk_dat+COMPLEX2_6.o : iotk_base.o -iotk_dat+COMPLEX2_6.o : iotk_dat_interf.o -iotk_dat+COMPLEX2_6.o : iotk_error_interf.o -iotk_dat+COMPLEX2_6.o : iotk_fmt_interf.o -iotk_dat+COMPLEX2_6.o : iotk_misc_interf.o -iotk_dat+COMPLEX2_6.o : iotk_scan_interf.o -iotk_dat+COMPLEX2_6.o : iotk_str_interf.o -iotk_dat+COMPLEX2_6.o : iotk_unit_interf.o -iotk_dat+COMPLEX2_6.o : iotk_write_interf.o -iotk_dat+COMPLEX3_0.o : ../include/iotk_auxmacros.h -iotk_dat+COMPLEX3_0.o : ../include/iotk_config.h -iotk_dat+COMPLEX3_0.o : iotk_attr_interf.o -iotk_dat+COMPLEX3_0.o : iotk_base.o -iotk_dat+COMPLEX3_0.o : iotk_dat_interf.o -iotk_dat+COMPLEX3_0.o : iotk_error_interf.o -iotk_dat+COMPLEX3_0.o : iotk_fmt_interf.o -iotk_dat+COMPLEX3_0.o : iotk_misc_interf.o -iotk_dat+COMPLEX3_0.o : iotk_scan_interf.o -iotk_dat+COMPLEX3_0.o : iotk_stream_interf.o -iotk_dat+COMPLEX3_0.o : iotk_str_interf.o -iotk_dat+COMPLEX3_0.o : iotk_unit_interf.o -iotk_dat+COMPLEX3_0.o : iotk_write_interf.o -iotk_dat+COMPLEX3_3.o : ../include/iotk_auxmacros.h -iotk_dat+COMPLEX3_3.o : ../include/iotk_config.h -iotk_dat+COMPLEX3_3.o : iotk_attr_interf.o -iotk_dat+COMPLEX3_3.o : iotk_base.o -iotk_dat+COMPLEX3_3.o : iotk_dat_interf.o -iotk_dat+COMPLEX3_3.o : iotk_error_interf.o -iotk_dat+COMPLEX3_3.o : iotk_fmt_interf.o -iotk_dat+COMPLEX3_3.o : iotk_misc_interf.o -iotk_dat+COMPLEX3_3.o : iotk_scan_interf.o -iotk_dat+COMPLEX3_3.o : iotk_str_interf.o -iotk_dat+COMPLEX3_3.o : iotk_unit_interf.o -iotk_dat+COMPLEX3_3.o : iotk_write_interf.o -iotk_dat+COMPLEX3_6.o : ../include/iotk_auxmacros.h -iotk_dat+COMPLEX3_6.o : ../include/iotk_config.h -iotk_dat+COMPLEX3_6.o : iotk_attr_interf.o -iotk_dat+COMPLEX3_6.o : iotk_base.o -iotk_dat+COMPLEX3_6.o : iotk_dat_interf.o -iotk_dat+COMPLEX3_6.o : iotk_error_interf.o -iotk_dat+COMPLEX3_6.o : iotk_fmt_interf.o -iotk_dat+COMPLEX3_6.o : iotk_misc_interf.o -iotk_dat+COMPLEX3_6.o : iotk_scan_interf.o -iotk_dat+COMPLEX3_6.o : iotk_str_interf.o -iotk_dat+COMPLEX3_6.o : iotk_unit_interf.o -iotk_dat+COMPLEX3_6.o : iotk_write_interf.o -iotk_dat+COMPLEX4_0.o : ../include/iotk_auxmacros.h -iotk_dat+COMPLEX4_0.o : ../include/iotk_config.h -iotk_dat+COMPLEX4_0.o : iotk_attr_interf.o -iotk_dat+COMPLEX4_0.o : iotk_base.o -iotk_dat+COMPLEX4_0.o : iotk_dat_interf.o -iotk_dat+COMPLEX4_0.o : iotk_error_interf.o -iotk_dat+COMPLEX4_0.o : iotk_fmt_interf.o -iotk_dat+COMPLEX4_0.o : iotk_misc_interf.o -iotk_dat+COMPLEX4_0.o : iotk_scan_interf.o -iotk_dat+COMPLEX4_0.o : iotk_stream_interf.o -iotk_dat+COMPLEX4_0.o : iotk_str_interf.o -iotk_dat+COMPLEX4_0.o : iotk_unit_interf.o -iotk_dat+COMPLEX4_0.o : iotk_write_interf.o -iotk_dat+COMPLEX4_3.o : ../include/iotk_auxmacros.h -iotk_dat+COMPLEX4_3.o : ../include/iotk_config.h -iotk_dat+COMPLEX4_3.o : iotk_attr_interf.o -iotk_dat+COMPLEX4_3.o : iotk_base.o -iotk_dat+COMPLEX4_3.o : iotk_dat_interf.o -iotk_dat+COMPLEX4_3.o : iotk_error_interf.o -iotk_dat+COMPLEX4_3.o : iotk_fmt_interf.o -iotk_dat+COMPLEX4_3.o : iotk_misc_interf.o -iotk_dat+COMPLEX4_3.o : iotk_scan_interf.o -iotk_dat+COMPLEX4_3.o : iotk_str_interf.o -iotk_dat+COMPLEX4_3.o : iotk_unit_interf.o -iotk_dat+COMPLEX4_3.o : iotk_write_interf.o -iotk_dat+COMPLEX4_6.o : ../include/iotk_auxmacros.h -iotk_dat+COMPLEX4_6.o : ../include/iotk_config.h -iotk_dat+COMPLEX4_6.o : iotk_attr_interf.o -iotk_dat+COMPLEX4_6.o : iotk_base.o -iotk_dat+COMPLEX4_6.o : iotk_dat_interf.o -iotk_dat+COMPLEX4_6.o : iotk_error_interf.o -iotk_dat+COMPLEX4_6.o : iotk_fmt_interf.o -iotk_dat+COMPLEX4_6.o : iotk_misc_interf.o -iotk_dat+COMPLEX4_6.o : iotk_scan_interf.o -iotk_dat+COMPLEX4_6.o : iotk_str_interf.o -iotk_dat+COMPLEX4_6.o : iotk_unit_interf.o -iotk_dat+COMPLEX4_6.o : iotk_write_interf.o -iotk_dat+INTEGER1_0.o : ../include/iotk_auxmacros.h -iotk_dat+INTEGER1_0.o : ../include/iotk_config.h -iotk_dat+INTEGER1_0.o : iotk_attr_interf.o -iotk_dat+INTEGER1_0.o : iotk_base.o -iotk_dat+INTEGER1_0.o : iotk_dat_interf.o -iotk_dat+INTEGER1_0.o : iotk_error_interf.o -iotk_dat+INTEGER1_0.o : iotk_fmt_interf.o -iotk_dat+INTEGER1_0.o : iotk_misc_interf.o -iotk_dat+INTEGER1_0.o : iotk_scan_interf.o -iotk_dat+INTEGER1_0.o : iotk_stream_interf.o -iotk_dat+INTEGER1_0.o : iotk_str_interf.o -iotk_dat+INTEGER1_0.o : iotk_unit_interf.o -iotk_dat+INTEGER1_0.o : iotk_write_interf.o -iotk_dat+INTEGER1_3.o : ../include/iotk_auxmacros.h -iotk_dat+INTEGER1_3.o : ../include/iotk_config.h -iotk_dat+INTEGER1_3.o : iotk_attr_interf.o -iotk_dat+INTEGER1_3.o : iotk_base.o -iotk_dat+INTEGER1_3.o : iotk_dat_interf.o -iotk_dat+INTEGER1_3.o : iotk_error_interf.o -iotk_dat+INTEGER1_3.o : iotk_fmt_interf.o -iotk_dat+INTEGER1_3.o : iotk_misc_interf.o -iotk_dat+INTEGER1_3.o : iotk_scan_interf.o -iotk_dat+INTEGER1_3.o : iotk_str_interf.o -iotk_dat+INTEGER1_3.o : iotk_unit_interf.o -iotk_dat+INTEGER1_3.o : iotk_write_interf.o -iotk_dat+INTEGER1_6.o : ../include/iotk_auxmacros.h -iotk_dat+INTEGER1_6.o : ../include/iotk_config.h -iotk_dat+INTEGER1_6.o : iotk_attr_interf.o -iotk_dat+INTEGER1_6.o : iotk_base.o -iotk_dat+INTEGER1_6.o : iotk_dat_interf.o -iotk_dat+INTEGER1_6.o : iotk_error_interf.o -iotk_dat+INTEGER1_6.o : iotk_fmt_interf.o -iotk_dat+INTEGER1_6.o : iotk_misc_interf.o -iotk_dat+INTEGER1_6.o : iotk_scan_interf.o -iotk_dat+INTEGER1_6.o : iotk_str_interf.o -iotk_dat+INTEGER1_6.o : iotk_unit_interf.o -iotk_dat+INTEGER1_6.o : iotk_write_interf.o -iotk_dat+INTEGER2_0.o : ../include/iotk_auxmacros.h -iotk_dat+INTEGER2_0.o : ../include/iotk_config.h -iotk_dat+INTEGER2_0.o : iotk_attr_interf.o -iotk_dat+INTEGER2_0.o : iotk_base.o -iotk_dat+INTEGER2_0.o : iotk_dat_interf.o -iotk_dat+INTEGER2_0.o : iotk_error_interf.o -iotk_dat+INTEGER2_0.o : iotk_fmt_interf.o -iotk_dat+INTEGER2_0.o : iotk_misc_interf.o -iotk_dat+INTEGER2_0.o : iotk_scan_interf.o -iotk_dat+INTEGER2_0.o : iotk_stream_interf.o -iotk_dat+INTEGER2_0.o : iotk_str_interf.o -iotk_dat+INTEGER2_0.o : iotk_unit_interf.o -iotk_dat+INTEGER2_0.o : iotk_write_interf.o -iotk_dat+INTEGER2_3.o : ../include/iotk_auxmacros.h -iotk_dat+INTEGER2_3.o : ../include/iotk_config.h -iotk_dat+INTEGER2_3.o : iotk_attr_interf.o -iotk_dat+INTEGER2_3.o : iotk_base.o -iotk_dat+INTEGER2_3.o : iotk_dat_interf.o -iotk_dat+INTEGER2_3.o : iotk_error_interf.o -iotk_dat+INTEGER2_3.o : iotk_fmt_interf.o -iotk_dat+INTEGER2_3.o : iotk_misc_interf.o -iotk_dat+INTEGER2_3.o : iotk_scan_interf.o -iotk_dat+INTEGER2_3.o : iotk_str_interf.o -iotk_dat+INTEGER2_3.o : iotk_unit_interf.o -iotk_dat+INTEGER2_3.o : iotk_write_interf.o -iotk_dat+INTEGER2_6.o : ../include/iotk_auxmacros.h -iotk_dat+INTEGER2_6.o : ../include/iotk_config.h -iotk_dat+INTEGER2_6.o : iotk_attr_interf.o -iotk_dat+INTEGER2_6.o : iotk_base.o -iotk_dat+INTEGER2_6.o : iotk_dat_interf.o -iotk_dat+INTEGER2_6.o : iotk_error_interf.o -iotk_dat+INTEGER2_6.o : iotk_fmt_interf.o -iotk_dat+INTEGER2_6.o : iotk_misc_interf.o -iotk_dat+INTEGER2_6.o : iotk_scan_interf.o -iotk_dat+INTEGER2_6.o : iotk_str_interf.o -iotk_dat+INTEGER2_6.o : iotk_unit_interf.o -iotk_dat+INTEGER2_6.o : iotk_write_interf.o -iotk_dat+INTEGER3_0.o : ../include/iotk_auxmacros.h -iotk_dat+INTEGER3_0.o : ../include/iotk_config.h -iotk_dat+INTEGER3_0.o : iotk_attr_interf.o -iotk_dat+INTEGER3_0.o : iotk_base.o -iotk_dat+INTEGER3_0.o : iotk_dat_interf.o -iotk_dat+INTEGER3_0.o : iotk_error_interf.o -iotk_dat+INTEGER3_0.o : iotk_fmt_interf.o -iotk_dat+INTEGER3_0.o : iotk_misc_interf.o -iotk_dat+INTEGER3_0.o : iotk_scan_interf.o -iotk_dat+INTEGER3_0.o : iotk_stream_interf.o -iotk_dat+INTEGER3_0.o : iotk_str_interf.o -iotk_dat+INTEGER3_0.o : iotk_unit_interf.o -iotk_dat+INTEGER3_0.o : iotk_write_interf.o -iotk_dat+INTEGER3_3.o : ../include/iotk_auxmacros.h -iotk_dat+INTEGER3_3.o : ../include/iotk_config.h -iotk_dat+INTEGER3_3.o : iotk_attr_interf.o -iotk_dat+INTEGER3_3.o : iotk_base.o -iotk_dat+INTEGER3_3.o : iotk_dat_interf.o -iotk_dat+INTEGER3_3.o : iotk_error_interf.o -iotk_dat+INTEGER3_3.o : iotk_fmt_interf.o -iotk_dat+INTEGER3_3.o : iotk_misc_interf.o -iotk_dat+INTEGER3_3.o : iotk_scan_interf.o -iotk_dat+INTEGER3_3.o : iotk_str_interf.o -iotk_dat+INTEGER3_3.o : iotk_unit_interf.o -iotk_dat+INTEGER3_3.o : iotk_write_interf.o -iotk_dat+INTEGER3_6.o : ../include/iotk_auxmacros.h -iotk_dat+INTEGER3_6.o : ../include/iotk_config.h -iotk_dat+INTEGER3_6.o : iotk_attr_interf.o -iotk_dat+INTEGER3_6.o : iotk_base.o -iotk_dat+INTEGER3_6.o : iotk_dat_interf.o -iotk_dat+INTEGER3_6.o : iotk_error_interf.o -iotk_dat+INTEGER3_6.o : iotk_fmt_interf.o -iotk_dat+INTEGER3_6.o : iotk_misc_interf.o -iotk_dat+INTEGER3_6.o : iotk_scan_interf.o -iotk_dat+INTEGER3_6.o : iotk_str_interf.o -iotk_dat+INTEGER3_6.o : iotk_unit_interf.o -iotk_dat+INTEGER3_6.o : iotk_write_interf.o -iotk_dat+INTEGER4_0.o : ../include/iotk_auxmacros.h -iotk_dat+INTEGER4_0.o : ../include/iotk_config.h -iotk_dat+INTEGER4_0.o : iotk_attr_interf.o -iotk_dat+INTEGER4_0.o : iotk_base.o -iotk_dat+INTEGER4_0.o : iotk_dat_interf.o -iotk_dat+INTEGER4_0.o : iotk_error_interf.o -iotk_dat+INTEGER4_0.o : iotk_fmt_interf.o -iotk_dat+INTEGER4_0.o : iotk_misc_interf.o -iotk_dat+INTEGER4_0.o : iotk_scan_interf.o -iotk_dat+INTEGER4_0.o : iotk_stream_interf.o -iotk_dat+INTEGER4_0.o : iotk_str_interf.o -iotk_dat+INTEGER4_0.o : iotk_unit_interf.o -iotk_dat+INTEGER4_0.o : iotk_write_interf.o -iotk_dat+INTEGER4_3.o : ../include/iotk_auxmacros.h -iotk_dat+INTEGER4_3.o : ../include/iotk_config.h -iotk_dat+INTEGER4_3.o : iotk_attr_interf.o -iotk_dat+INTEGER4_3.o : iotk_base.o -iotk_dat+INTEGER4_3.o : iotk_dat_interf.o -iotk_dat+INTEGER4_3.o : iotk_error_interf.o -iotk_dat+INTEGER4_3.o : iotk_fmt_interf.o -iotk_dat+INTEGER4_3.o : iotk_misc_interf.o -iotk_dat+INTEGER4_3.o : iotk_scan_interf.o -iotk_dat+INTEGER4_3.o : iotk_str_interf.o -iotk_dat+INTEGER4_3.o : iotk_unit_interf.o -iotk_dat+INTEGER4_3.o : iotk_write_interf.o -iotk_dat+INTEGER4_6.o : ../include/iotk_auxmacros.h -iotk_dat+INTEGER4_6.o : ../include/iotk_config.h -iotk_dat+INTEGER4_6.o : iotk_attr_interf.o -iotk_dat+INTEGER4_6.o : iotk_base.o -iotk_dat+INTEGER4_6.o : iotk_dat_interf.o -iotk_dat+INTEGER4_6.o : iotk_error_interf.o -iotk_dat+INTEGER4_6.o : iotk_fmt_interf.o -iotk_dat+INTEGER4_6.o : iotk_misc_interf.o -iotk_dat+INTEGER4_6.o : iotk_scan_interf.o -iotk_dat+INTEGER4_6.o : iotk_str_interf.o -iotk_dat+INTEGER4_6.o : iotk_unit_interf.o -iotk_dat+INTEGER4_6.o : iotk_write_interf.o -iotk_dat_interf.o : ../include/iotk_auxmacros.h -iotk_dat_interf.o : ../include/iotk_config.h -iotk_dat_interf.o : iotk_base.o -iotk_dat+LOGICAL1_0.o : ../include/iotk_auxmacros.h -iotk_dat+LOGICAL1_0.o : ../include/iotk_config.h -iotk_dat+LOGICAL1_0.o : iotk_attr_interf.o -iotk_dat+LOGICAL1_0.o : iotk_base.o -iotk_dat+LOGICAL1_0.o : iotk_dat_interf.o -iotk_dat+LOGICAL1_0.o : iotk_error_interf.o -iotk_dat+LOGICAL1_0.o : iotk_fmt_interf.o -iotk_dat+LOGICAL1_0.o : iotk_misc_interf.o -iotk_dat+LOGICAL1_0.o : iotk_scan_interf.o -iotk_dat+LOGICAL1_0.o : iotk_stream_interf.o -iotk_dat+LOGICAL1_0.o : iotk_str_interf.o -iotk_dat+LOGICAL1_0.o : iotk_unit_interf.o -iotk_dat+LOGICAL1_0.o : iotk_write_interf.o -iotk_dat+LOGICAL1_3.o : ../include/iotk_auxmacros.h -iotk_dat+LOGICAL1_3.o : ../include/iotk_config.h -iotk_dat+LOGICAL1_3.o : iotk_attr_interf.o -iotk_dat+LOGICAL1_3.o : iotk_base.o -iotk_dat+LOGICAL1_3.o : iotk_dat_interf.o -iotk_dat+LOGICAL1_3.o : iotk_error_interf.o -iotk_dat+LOGICAL1_3.o : iotk_fmt_interf.o -iotk_dat+LOGICAL1_3.o : iotk_misc_interf.o -iotk_dat+LOGICAL1_3.o : iotk_scan_interf.o -iotk_dat+LOGICAL1_3.o : iotk_str_interf.o -iotk_dat+LOGICAL1_3.o : iotk_unit_interf.o -iotk_dat+LOGICAL1_3.o : iotk_write_interf.o -iotk_dat+LOGICAL1_6.o : ../include/iotk_auxmacros.h -iotk_dat+LOGICAL1_6.o : ../include/iotk_config.h -iotk_dat+LOGICAL1_6.o : iotk_attr_interf.o -iotk_dat+LOGICAL1_6.o : iotk_base.o -iotk_dat+LOGICAL1_6.o : iotk_dat_interf.o -iotk_dat+LOGICAL1_6.o : iotk_error_interf.o -iotk_dat+LOGICAL1_6.o : iotk_fmt_interf.o -iotk_dat+LOGICAL1_6.o : iotk_misc_interf.o -iotk_dat+LOGICAL1_6.o : iotk_scan_interf.o -iotk_dat+LOGICAL1_6.o : iotk_str_interf.o -iotk_dat+LOGICAL1_6.o : iotk_unit_interf.o -iotk_dat+LOGICAL1_6.o : iotk_write_interf.o -iotk_dat+LOGICAL2_0.o : ../include/iotk_auxmacros.h -iotk_dat+LOGICAL2_0.o : ../include/iotk_config.h -iotk_dat+LOGICAL2_0.o : iotk_attr_interf.o -iotk_dat+LOGICAL2_0.o : iotk_base.o -iotk_dat+LOGICAL2_0.o : iotk_dat_interf.o -iotk_dat+LOGICAL2_0.o : iotk_error_interf.o -iotk_dat+LOGICAL2_0.o : iotk_fmt_interf.o -iotk_dat+LOGICAL2_0.o : iotk_misc_interf.o -iotk_dat+LOGICAL2_0.o : iotk_scan_interf.o -iotk_dat+LOGICAL2_0.o : iotk_stream_interf.o -iotk_dat+LOGICAL2_0.o : iotk_str_interf.o -iotk_dat+LOGICAL2_0.o : iotk_unit_interf.o -iotk_dat+LOGICAL2_0.o : iotk_write_interf.o -iotk_dat+LOGICAL2_3.o : ../include/iotk_auxmacros.h -iotk_dat+LOGICAL2_3.o : ../include/iotk_config.h -iotk_dat+LOGICAL2_3.o : iotk_attr_interf.o -iotk_dat+LOGICAL2_3.o : iotk_base.o -iotk_dat+LOGICAL2_3.o : iotk_dat_interf.o -iotk_dat+LOGICAL2_3.o : iotk_error_interf.o -iotk_dat+LOGICAL2_3.o : iotk_fmt_interf.o -iotk_dat+LOGICAL2_3.o : iotk_misc_interf.o -iotk_dat+LOGICAL2_3.o : iotk_scan_interf.o -iotk_dat+LOGICAL2_3.o : iotk_str_interf.o -iotk_dat+LOGICAL2_3.o : iotk_unit_interf.o -iotk_dat+LOGICAL2_3.o : iotk_write_interf.o -iotk_dat+LOGICAL2_6.o : ../include/iotk_auxmacros.h -iotk_dat+LOGICAL2_6.o : ../include/iotk_config.h -iotk_dat+LOGICAL2_6.o : iotk_attr_interf.o -iotk_dat+LOGICAL2_6.o : iotk_base.o -iotk_dat+LOGICAL2_6.o : iotk_dat_interf.o -iotk_dat+LOGICAL2_6.o : iotk_error_interf.o -iotk_dat+LOGICAL2_6.o : iotk_fmt_interf.o -iotk_dat+LOGICAL2_6.o : iotk_misc_interf.o -iotk_dat+LOGICAL2_6.o : iotk_scan_interf.o -iotk_dat+LOGICAL2_6.o : iotk_str_interf.o -iotk_dat+LOGICAL2_6.o : iotk_unit_interf.o -iotk_dat+LOGICAL2_6.o : iotk_write_interf.o -iotk_dat+LOGICAL3_0.o : ../include/iotk_auxmacros.h -iotk_dat+LOGICAL3_0.o : ../include/iotk_config.h -iotk_dat+LOGICAL3_0.o : iotk_attr_interf.o -iotk_dat+LOGICAL3_0.o : iotk_base.o -iotk_dat+LOGICAL3_0.o : iotk_dat_interf.o -iotk_dat+LOGICAL3_0.o : iotk_error_interf.o -iotk_dat+LOGICAL3_0.o : iotk_fmt_interf.o -iotk_dat+LOGICAL3_0.o : iotk_misc_interf.o -iotk_dat+LOGICAL3_0.o : iotk_scan_interf.o -iotk_dat+LOGICAL3_0.o : iotk_stream_interf.o -iotk_dat+LOGICAL3_0.o : iotk_str_interf.o -iotk_dat+LOGICAL3_0.o : iotk_unit_interf.o -iotk_dat+LOGICAL3_0.o : iotk_write_interf.o -iotk_dat+LOGICAL3_3.o : ../include/iotk_auxmacros.h -iotk_dat+LOGICAL3_3.o : ../include/iotk_config.h -iotk_dat+LOGICAL3_3.o : iotk_attr_interf.o -iotk_dat+LOGICAL3_3.o : iotk_base.o -iotk_dat+LOGICAL3_3.o : iotk_dat_interf.o -iotk_dat+LOGICAL3_3.o : iotk_error_interf.o -iotk_dat+LOGICAL3_3.o : iotk_fmt_interf.o -iotk_dat+LOGICAL3_3.o : iotk_misc_interf.o -iotk_dat+LOGICAL3_3.o : iotk_scan_interf.o -iotk_dat+LOGICAL3_3.o : iotk_str_interf.o -iotk_dat+LOGICAL3_3.o : iotk_unit_interf.o -iotk_dat+LOGICAL3_3.o : iotk_write_interf.o -iotk_dat+LOGICAL3_6.o : ../include/iotk_auxmacros.h -iotk_dat+LOGICAL3_6.o : ../include/iotk_config.h -iotk_dat+LOGICAL3_6.o : iotk_attr_interf.o -iotk_dat+LOGICAL3_6.o : iotk_base.o -iotk_dat+LOGICAL3_6.o : iotk_dat_interf.o -iotk_dat+LOGICAL3_6.o : iotk_error_interf.o -iotk_dat+LOGICAL3_6.o : iotk_fmt_interf.o -iotk_dat+LOGICAL3_6.o : iotk_misc_interf.o -iotk_dat+LOGICAL3_6.o : iotk_scan_interf.o -iotk_dat+LOGICAL3_6.o : iotk_str_interf.o -iotk_dat+LOGICAL3_6.o : iotk_unit_interf.o -iotk_dat+LOGICAL3_6.o : iotk_write_interf.o -iotk_dat+LOGICAL4_0.o : ../include/iotk_auxmacros.h -iotk_dat+LOGICAL4_0.o : ../include/iotk_config.h -iotk_dat+LOGICAL4_0.o : iotk_attr_interf.o -iotk_dat+LOGICAL4_0.o : iotk_base.o -iotk_dat+LOGICAL4_0.o : iotk_dat_interf.o -iotk_dat+LOGICAL4_0.o : iotk_error_interf.o -iotk_dat+LOGICAL4_0.o : iotk_fmt_interf.o -iotk_dat+LOGICAL4_0.o : iotk_misc_interf.o -iotk_dat+LOGICAL4_0.o : iotk_scan_interf.o -iotk_dat+LOGICAL4_0.o : iotk_stream_interf.o -iotk_dat+LOGICAL4_0.o : iotk_str_interf.o -iotk_dat+LOGICAL4_0.o : iotk_unit_interf.o -iotk_dat+LOGICAL4_0.o : iotk_write_interf.o -iotk_dat+LOGICAL4_3.o : ../include/iotk_auxmacros.h -iotk_dat+LOGICAL4_3.o : ../include/iotk_config.h -iotk_dat+LOGICAL4_3.o : iotk_attr_interf.o -iotk_dat+LOGICAL4_3.o : iotk_base.o -iotk_dat+LOGICAL4_3.o : iotk_dat_interf.o -iotk_dat+LOGICAL4_3.o : iotk_error_interf.o -iotk_dat+LOGICAL4_3.o : iotk_fmt_interf.o -iotk_dat+LOGICAL4_3.o : iotk_misc_interf.o -iotk_dat+LOGICAL4_3.o : iotk_scan_interf.o -iotk_dat+LOGICAL4_3.o : iotk_str_interf.o -iotk_dat+LOGICAL4_3.o : iotk_unit_interf.o -iotk_dat+LOGICAL4_3.o : iotk_write_interf.o -iotk_dat+LOGICAL4_6.o : ../include/iotk_auxmacros.h -iotk_dat+LOGICAL4_6.o : ../include/iotk_config.h -iotk_dat+LOGICAL4_6.o : iotk_attr_interf.o -iotk_dat+LOGICAL4_6.o : iotk_base.o -iotk_dat+LOGICAL4_6.o : iotk_dat_interf.o -iotk_dat+LOGICAL4_6.o : iotk_error_interf.o -iotk_dat+LOGICAL4_6.o : iotk_fmt_interf.o -iotk_dat+LOGICAL4_6.o : iotk_misc_interf.o -iotk_dat+LOGICAL4_6.o : iotk_scan_interf.o -iotk_dat+LOGICAL4_6.o : iotk_str_interf.o -iotk_dat+LOGICAL4_6.o : iotk_unit_interf.o -iotk_dat+LOGICAL4_6.o : iotk_write_interf.o -iotk_dat.o : ../include/iotk_auxmacros.h -iotk_dat.o : ../include/iotk_config.h -iotk_dat+REAL1_0.o : ../include/iotk_auxmacros.h -iotk_dat+REAL1_0.o : ../include/iotk_config.h -iotk_dat+REAL1_0.o : iotk_attr_interf.o -iotk_dat+REAL1_0.o : iotk_base.o -iotk_dat+REAL1_0.o : iotk_dat_interf.o -iotk_dat+REAL1_0.o : iotk_error_interf.o -iotk_dat+REAL1_0.o : iotk_fmt_interf.o -iotk_dat+REAL1_0.o : iotk_misc_interf.o -iotk_dat+REAL1_0.o : iotk_scan_interf.o -iotk_dat+REAL1_0.o : iotk_stream_interf.o -iotk_dat+REAL1_0.o : iotk_str_interf.o -iotk_dat+REAL1_0.o : iotk_unit_interf.o -iotk_dat+REAL1_0.o : iotk_write_interf.o -iotk_dat+REAL1_3.o : ../include/iotk_auxmacros.h -iotk_dat+REAL1_3.o : ../include/iotk_config.h -iotk_dat+REAL1_3.o : iotk_attr_interf.o -iotk_dat+REAL1_3.o : iotk_base.o -iotk_dat+REAL1_3.o : iotk_dat_interf.o -iotk_dat+REAL1_3.o : iotk_error_interf.o -iotk_dat+REAL1_3.o : iotk_fmt_interf.o -iotk_dat+REAL1_3.o : iotk_misc_interf.o -iotk_dat+REAL1_3.o : iotk_scan_interf.o -iotk_dat+REAL1_3.o : iotk_str_interf.o -iotk_dat+REAL1_3.o : iotk_unit_interf.o -iotk_dat+REAL1_3.o : iotk_write_interf.o -iotk_dat+REAL1_6.o : ../include/iotk_auxmacros.h -iotk_dat+REAL1_6.o : ../include/iotk_config.h -iotk_dat+REAL1_6.o : iotk_attr_interf.o -iotk_dat+REAL1_6.o : iotk_base.o -iotk_dat+REAL1_6.o : iotk_dat_interf.o -iotk_dat+REAL1_6.o : iotk_error_interf.o -iotk_dat+REAL1_6.o : iotk_fmt_interf.o -iotk_dat+REAL1_6.o : iotk_misc_interf.o -iotk_dat+REAL1_6.o : iotk_scan_interf.o -iotk_dat+REAL1_6.o : iotk_str_interf.o -iotk_dat+REAL1_6.o : iotk_unit_interf.o -iotk_dat+REAL1_6.o : iotk_write_interf.o -iotk_dat+REAL2_0.o : ../include/iotk_auxmacros.h -iotk_dat+REAL2_0.o : ../include/iotk_config.h -iotk_dat+REAL2_0.o : iotk_attr_interf.o -iotk_dat+REAL2_0.o : iotk_base.o -iotk_dat+REAL2_0.o : iotk_dat_interf.o -iotk_dat+REAL2_0.o : iotk_error_interf.o -iotk_dat+REAL2_0.o : iotk_fmt_interf.o -iotk_dat+REAL2_0.o : iotk_misc_interf.o -iotk_dat+REAL2_0.o : iotk_scan_interf.o -iotk_dat+REAL2_0.o : iotk_stream_interf.o -iotk_dat+REAL2_0.o : iotk_str_interf.o -iotk_dat+REAL2_0.o : iotk_unit_interf.o -iotk_dat+REAL2_0.o : iotk_write_interf.o -iotk_dat+REAL2_3.o : ../include/iotk_auxmacros.h -iotk_dat+REAL2_3.o : ../include/iotk_config.h -iotk_dat+REAL2_3.o : iotk_attr_interf.o -iotk_dat+REAL2_3.o : iotk_base.o -iotk_dat+REAL2_3.o : iotk_dat_interf.o -iotk_dat+REAL2_3.o : iotk_error_interf.o -iotk_dat+REAL2_3.o : iotk_fmt_interf.o -iotk_dat+REAL2_3.o : iotk_misc_interf.o -iotk_dat+REAL2_3.o : iotk_scan_interf.o -iotk_dat+REAL2_3.o : iotk_str_interf.o -iotk_dat+REAL2_3.o : iotk_unit_interf.o -iotk_dat+REAL2_3.o : iotk_write_interf.o -iotk_dat+REAL2_6.o : ../include/iotk_auxmacros.h -iotk_dat+REAL2_6.o : ../include/iotk_config.h -iotk_dat+REAL2_6.o : iotk_attr_interf.o -iotk_dat+REAL2_6.o : iotk_base.o -iotk_dat+REAL2_6.o : iotk_dat_interf.o -iotk_dat+REAL2_6.o : iotk_error_interf.o -iotk_dat+REAL2_6.o : iotk_fmt_interf.o -iotk_dat+REAL2_6.o : iotk_misc_interf.o -iotk_dat+REAL2_6.o : iotk_scan_interf.o -iotk_dat+REAL2_6.o : iotk_str_interf.o -iotk_dat+REAL2_6.o : iotk_unit_interf.o -iotk_dat+REAL2_6.o : iotk_write_interf.o -iotk_dat+REAL3_0.o : ../include/iotk_auxmacros.h -iotk_dat+REAL3_0.o : ../include/iotk_config.h -iotk_dat+REAL3_0.o : iotk_attr_interf.o -iotk_dat+REAL3_0.o : iotk_base.o -iotk_dat+REAL3_0.o : iotk_dat_interf.o -iotk_dat+REAL3_0.o : iotk_error_interf.o -iotk_dat+REAL3_0.o : iotk_fmt_interf.o -iotk_dat+REAL3_0.o : iotk_misc_interf.o -iotk_dat+REAL3_0.o : iotk_scan_interf.o -iotk_dat+REAL3_0.o : iotk_stream_interf.o -iotk_dat+REAL3_0.o : iotk_str_interf.o -iotk_dat+REAL3_0.o : iotk_unit_interf.o -iotk_dat+REAL3_0.o : iotk_write_interf.o -iotk_dat+REAL3_3.o : ../include/iotk_auxmacros.h -iotk_dat+REAL3_3.o : ../include/iotk_config.h -iotk_dat+REAL3_3.o : iotk_attr_interf.o -iotk_dat+REAL3_3.o : iotk_base.o -iotk_dat+REAL3_3.o : iotk_dat_interf.o -iotk_dat+REAL3_3.o : iotk_error_interf.o -iotk_dat+REAL3_3.o : iotk_fmt_interf.o -iotk_dat+REAL3_3.o : iotk_misc_interf.o -iotk_dat+REAL3_3.o : iotk_scan_interf.o -iotk_dat+REAL3_3.o : iotk_str_interf.o -iotk_dat+REAL3_3.o : iotk_unit_interf.o -iotk_dat+REAL3_3.o : iotk_write_interf.o -iotk_dat+REAL3_6.o : ../include/iotk_auxmacros.h -iotk_dat+REAL3_6.o : ../include/iotk_config.h -iotk_dat+REAL3_6.o : iotk_attr_interf.o -iotk_dat+REAL3_6.o : iotk_base.o -iotk_dat+REAL3_6.o : iotk_dat_interf.o -iotk_dat+REAL3_6.o : iotk_error_interf.o -iotk_dat+REAL3_6.o : iotk_fmt_interf.o -iotk_dat+REAL3_6.o : iotk_misc_interf.o -iotk_dat+REAL3_6.o : iotk_scan_interf.o -iotk_dat+REAL3_6.o : iotk_str_interf.o -iotk_dat+REAL3_6.o : iotk_unit_interf.o -iotk_dat+REAL3_6.o : iotk_write_interf.o -iotk_dat+REAL4_0.o : ../include/iotk_auxmacros.h -iotk_dat+REAL4_0.o : ../include/iotk_config.h -iotk_dat+REAL4_0.o : iotk_attr_interf.o -iotk_dat+REAL4_0.o : iotk_base.o -iotk_dat+REAL4_0.o : iotk_dat_interf.o -iotk_dat+REAL4_0.o : iotk_error_interf.o -iotk_dat+REAL4_0.o : iotk_fmt_interf.o -iotk_dat+REAL4_0.o : iotk_misc_interf.o -iotk_dat+REAL4_0.o : iotk_scan_interf.o -iotk_dat+REAL4_0.o : iotk_stream_interf.o -iotk_dat+REAL4_0.o : iotk_str_interf.o -iotk_dat+REAL4_0.o : iotk_unit_interf.o -iotk_dat+REAL4_0.o : iotk_write_interf.o -iotk_dat+REAL4_3.o : ../include/iotk_auxmacros.h -iotk_dat+REAL4_3.o : ../include/iotk_config.h -iotk_dat+REAL4_3.o : iotk_attr_interf.o -iotk_dat+REAL4_3.o : iotk_base.o -iotk_dat+REAL4_3.o : iotk_dat_interf.o -iotk_dat+REAL4_3.o : iotk_error_interf.o -iotk_dat+REAL4_3.o : iotk_fmt_interf.o -iotk_dat+REAL4_3.o : iotk_misc_interf.o -iotk_dat+REAL4_3.o : iotk_scan_interf.o -iotk_dat+REAL4_3.o : iotk_str_interf.o -iotk_dat+REAL4_3.o : iotk_unit_interf.o -iotk_dat+REAL4_3.o : iotk_write_interf.o -iotk_dat+REAL4_6.o : ../include/iotk_auxmacros.h -iotk_dat+REAL4_6.o : ../include/iotk_config.h -iotk_dat+REAL4_6.o : iotk_attr_interf.o -iotk_dat+REAL4_6.o : iotk_base.o -iotk_dat+REAL4_6.o : iotk_dat_interf.o -iotk_dat+REAL4_6.o : iotk_error_interf.o -iotk_dat+REAL4_6.o : iotk_fmt_interf.o -iotk_dat+REAL4_6.o : iotk_misc_interf.o -iotk_dat+REAL4_6.o : iotk_scan_interf.o -iotk_dat+REAL4_6.o : iotk_str_interf.o -iotk_dat+REAL4_6.o : iotk_unit_interf.o -iotk_dat+REAL4_6.o : iotk_write_interf.o -iotk_error_interf.o : ../include/iotk_auxmacros.h -iotk_error_interf.o : ../include/iotk_config.h -iotk_error_interf.o : iotk_base.o -iotk_error.o : ../include/iotk_auxmacros.h -iotk_error.o : ../include/iotk_config.h -iotk_error.o : iotk_base.o -iotk_error.o : iotk_error_interf.o -iotk_error.o : iotk_misc_interf.o -iotk_error.o : iotk_xtox_interf.o -iotk_files_interf.o : ../include/iotk_auxmacros.h -iotk_files_interf.o : ../include/iotk_config.h -iotk_files_interf.o : iotk_base.o -iotk_files.o : ../include/iotk_auxmacros.h -iotk_files.o : ../include/iotk_config.h -iotk_files.o : iotk_attr_interf.o -iotk_files.o : iotk_base.o -iotk_files.o : iotk_error_interf.o -iotk_files.o : iotk_files_interf.o -iotk_files.o : iotk_misc_interf.o -iotk_files.o : iotk_scan_interf.o -iotk_files.o : iotk_str_interf.o -iotk_files.o : iotk_unit_interf.o -iotk_files.o : iotk_write_interf.o -iotk_fmt_interf.o : ../include/iotk_auxmacros.h -iotk_fmt_interf.o : ../include/iotk_config.h -iotk_fmt_interf.o : iotk_base.o -iotk_fmt.o : ../include/iotk_auxmacros.h -iotk_fmt.o : ../include/iotk_config.h -iotk_fmt.o : iotk_base.o -iotk_fmt.o : iotk_fmt_interf.o -iotk_fmt.o : iotk_misc_interf.o -iotk_fmt.o : iotk_str_interf.o -iotk_fmt.o : iotk_xtox_interf.o -iotk_misc_interf.o : ../include/iotk_auxmacros.h -iotk_misc_interf.o : ../include/iotk_config.h -iotk_misc_interf.o : iotk_base.o -iotk_misc.o : ../include/iotk_auxmacros.h -iotk_misc.o : ../include/iotk_config.h -iotk_misc.o : iotk_attr_interf.o -iotk_misc.o : iotk_base.o -iotk_misc.o : iotk_dat_interf.o -iotk_misc.o : iotk_error_interf.o -iotk_misc.o : iotk_misc_interf.o -iotk_misc.o : iotk_scan_interf.o -iotk_misc.o : iotk_str_interf.o -iotk_misc.o : iotk_unit_interf.o -iotk_misc.o : iotk_write_interf.o -iotk_misc.o : iotk_xtox_interf.o -iotk_module.o : iotk_attr_interf.o -iotk_module.o : iotk_base.o -iotk_module.o : iotk_dat_interf.o -iotk_module.o : iotk_error_interf.o -iotk_module.o : iotk_files_interf.o -iotk_module.o : iotk_fmt_interf.o -iotk_module.o : iotk_misc_interf.o -iotk_module.o : iotk_scan_interf.o -iotk_module.o : iotk_tool_interf.o -iotk_module.o : iotk_unit_interf.o -iotk_module.o : iotk_write_interf.o -iotk_module.o : iotk_xtox_interf.o -iotk.o : iotk_base.o -iotk.o : iotk_error_interf.o -iotk.o : iotk_module.o -iotk_print_kinds.o : iotk_module.o -iotk_scan_interf.o : ../include/iotk_auxmacros.h -iotk_scan_interf.o : ../include/iotk_config.h -iotk_scan_interf.o : iotk_base.o -iotk_scan.o : ../include/iotk_auxmacros.h -iotk_scan.o : ../include/iotk_config.h -iotk_scan.o : iotk_attr_interf.o -iotk_scan.o : iotk_base.o -iotk_scan.o : iotk_error_interf.o -iotk_scan.o : iotk_files_interf.o -iotk_scan.o : iotk_misc_interf.o -iotk_scan.o : iotk_scan_interf.o -iotk_scan.o : iotk_stream_interf.o -iotk_scan.o : iotk_str_interf.o -iotk_scan.o : iotk_unit_interf.o -iotk_stream_interf.o : ../include/iotk_auxmacros.h -iotk_stream_interf.o : ../include/iotk_config.h -iotk_stream_interf.o : iotk_base.o -iotk_stream.o : ../include/iotk_auxmacros.h -iotk_stream.o : ../include/iotk_config.h -iotk_stream.o : iotk_base.o -iotk_stream.o : iotk_error_interf.o -iotk_stream.o : iotk_stream_interf.o -iotk_str_interf.o : ../include/iotk_auxmacros.h -iotk_str_interf.o : ../include/iotk_config.h -iotk_str_interf.o : iotk_base.o -iotk_str.o : ../include/iotk_auxmacros.h -iotk_str.o : ../include/iotk_config.h -iotk_str.o : iotk_base.o -iotk_str.o : iotk_error_interf.o -iotk_str.o : iotk_misc_interf.o -iotk_str.o : iotk_str_interf.o -iotk_tool_interf.o : ../include/iotk_auxmacros.h -iotk_tool_interf.o : ../include/iotk_config.h -iotk_tool.o : ../include/iotk_auxmacros.h -iotk_tool.o : ../include/iotk_config.h -iotk_tool.o : iotk_base.o -iotk_tool.o : iotk_error_interf.o -iotk_tool.o : iotk_files_interf.o -iotk_tool.o : iotk_misc_interf.o -iotk_tool.o : iotk_str_interf.o -iotk_tool.o : iotk_tool_interf.o -iotk_tool.o : iotk_xtox_interf.o -iotk_unit_interf.o : ../include/iotk_auxmacros.h -iotk_unit_interf.o : ../include/iotk_config.h -iotk_unit_interf.o : iotk_base.o -iotk_unit_list.o : ../include/iotk_auxmacros.h -iotk_unit_list.o : ../include/iotk_config.h -iotk_unit_list.o : iotk_base.o -iotk_unit.o : ../include/iotk_auxmacros.h -iotk_unit.o : ../include/iotk_config.h -iotk_unit.o : iotk_base.o -iotk_unit.o : iotk_error_interf.o -iotk_unit.o : iotk_misc_interf.o -iotk_unit.o : iotk_str_interf.o -iotk_unit.o : iotk_unit_interf.o -iotk_unit.o : iotk_unit_list.o -iotk_write_interf.o : ../include/iotk_auxmacros.h -iotk_write_interf.o : ../include/iotk_config.h -iotk_write_interf.o : iotk_base.o -iotk_write.o : ../include/iotk_auxmacros.h -iotk_write.o : ../include/iotk_config.h -iotk_write.o : iotk_base.o -iotk_write.o : iotk_error_interf.o -iotk_write.o : iotk_files_interf.o -iotk_write.o : iotk_misc_interf.o -iotk_write.o : iotk_str_interf.o -iotk_write.o : iotk_unit_interf.o -iotk_write.o : iotk_write_interf.o -iotk_xtox_interf.o : ../include/iotk_auxmacros.h -iotk_xtox_interf.o : ../include/iotk_config.h -iotk_xtox_interf.o : iotk_base.o -iotk_xtox.o : ../include/iotk_auxmacros.h -iotk_xtox.o : ../include/iotk_config.h -iotk_xtox.o : iotk_base.o -iotk_xtox.o : iotk_misc_interf.o -test2.o : iotk_module.o -test3.o : iotk_module.o -test4.o : iotk_base.o -test4.o : iotk_error_interf.o -test5.o : iotk_module.o -test5.o : iotk_xtox_interf.o -test6.o : iotk_module.o -test7.o : iotk_misc_interf.o -test7.o : iotk_module.o -test7.o : iotk_str_interf.o -test8.o : iotk_module.o -test8.o : iotk_stream_interf.o -test9.o : iotk_module.o -test9.o : iotk_unit_list.o -test.o : iotk_module.o -# End dependencies diff --git a/quantum_espresso/kcp/iotk/src/example1.f90 b/quantum_espresso/kcp/iotk/src/example1.f90 deleted file mode 100644 index 290999f5c..000000000 --- a/quantum_espresso/kcp/iotk/src/example1.f90 +++ /dev/null @@ -1,49 +0,0 @@ -program example1 -use iotk_module -implicit none - -logical :: tmp_logical -real :: tmp_real4(4) - -! WRITING A FILE: - -call iotk_open_write(unit=10,file="example1.xml") - call iotk_write_comment(10,"This is an example file for iotk library") - call iotk_write_begin(10,"First_set") - write(iotk_phys_unit(10),*) 0.0,1.0,2.0,3.0 -! In this example Fortran IO is used for data. -! However, keep in mind that it is preferred to use the library -! for that, see later examples -! Note also that you should use the iotk_phys_unit function to have -! the physical unit for Fortran IO. - call iotk_write_end (10,"First_set") - call iotk_write_begin(10,"Second_set_more_complex") - write(iotk_phys_unit(10),*) 1.0,2.0,3.0,4.0 - call iotk_write_begin(10,"First_set") - write(iotk_phys_unit(10),*) .true. - call iotk_write_end (10,"First_set") - call iotk_write_end (10,"Second_set_more_complex") -call iotk_close_write(10) - -! READING FILE BACK: - -! Note that order is changed -! Note also that the library works right even if tags in -! different points of the hierarchy have the same name - -call iotk_open_read(10,"example1.xml") - call iotk_scan_begin(10,"Second_set_more_complex") - call iotk_scan_begin(10,"First_set") - read(iotk_phys_unit(10),*) tmp_logical - call iotk_scan_end (10,"First_set") - call iotk_scan_end (10,"Second_set_more_complex") - call iotk_scan_begin(10,"First_set") - read(iotk_phys_unit(10),*) tmp_real4 - call iotk_scan_end (10,"First_set") -call iotk_close_read(10) - -! Just for debug: -write(0,*) tmp_logical -write(0,*) tmp_real4 - -end program example1 diff --git a/quantum_espresso/kcp/iotk/src/example2.f90 b/quantum_espresso/kcp/iotk/src/example2.f90 deleted file mode 100644 index 4d720a804..000000000 --- a/quantum_espresso/kcp/iotk/src/example2.f90 +++ /dev/null @@ -1,47 +0,0 @@ -program example1 -use iotk_module -implicit none - -character(iotk_attlenx) :: attr -character(100) :: type -integer :: i,age,isize -logical :: found - -! WRITING FILE: - -call iotk_open_write(10,"example2.xml") - call iotk_write_attr (attr,"size",2,first=.true.) - call iotk_write_begin(10,"Animals",attr=attr) -! attributes are written on string attr BEFORE writing the tag - call iotk_write_attr (attr,"name","Anna",first=.true.) - call iotk_write_attr (attr,"age",1) - call iotk_write_attr (attr,"type","cat") - call iotk_write_empty(10,"Animal"//iotk_index(1),attr) - call iotk_write_attr (attr,"name","Peggy",first=.true.) - call iotk_write_attr (attr,"age",6) - call iotk_write_attr (attr,"type","dog") - call iotk_write_empty(10,"Animal"//iotk_index(2),attr) - call iotk_write_end (10,"Animals") -call iotk_close_write(10) - -! READING FILE: - -call iotk_open_read(10,"example2.xml") - call iotk_scan_begin(10,"Animals",attr=attr) - ! attributes are read from string attr AFTER reading the tag - call iotk_scan_attr (attr,"size",isize) - do i = 1,isize - call iotk_scan_empty(10,"Animal"//iotk_index(i),attr=attr) - call iotk_scan_attr (attr,"type",type) - write(0,*) trim(type) ! this is for debug - call iotk_scan_attr (attr,"age",age,found=found) - ! the 'found' keyword can be used for optional attributes - if(.not.found) write (0,*) "ERRATO!" - write(0,*) age !this is for debug - call iotk_scan_attr (attr,"notes",age,found=found) - if(found) write (0,*) "ERRATO!" - end do - call iotk_scan_end(10,"Animals") -call iotk_close_read(10) - -end program example1 diff --git a/quantum_espresso/kcp/iotk/src/example3.f90 b/quantum_espresso/kcp/iotk/src/example3.f90 deleted file mode 100644 index d73318dfc..000000000 --- a/quantum_espresso/kcp/iotk/src/example3.f90 +++ /dev/null @@ -1,26 +0,0 @@ -program example3 -use iotk_module -implicit none - -real(KIND=4) :: dat1(10) -real(KIND=8) :: dat2(10) - -dat1 = real( (/0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0/) , kind=kind(dat1) ) - -! WRITING FILE: (a binary one) - -call iotk_open_write(10,"example3.dat",binary=.true.) - call iotk_write_dat(10, "dat1", dat1) -call iotk_close_write(10) - -! READING FILE: -! there is no need to say the library that the file is binary -call iotk_open_read(10,"example3.dat") - ! kind conversion is transparent - call iotk_scan_dat (10,"dat1", dat2) - write(0,*) dat2 -call iotk_close_read(10) - -write(0,*) kind(dat1),kind(dat2) - -end program example3 diff --git a/quantum_espresso/kcp/iotk/src/example4.f90 b/quantum_espresso/kcp/iotk/src/example4.f90 deleted file mode 100644 index b97a7939c..000000000 --- a/quantum_espresso/kcp/iotk/src/example4.f90 +++ /dev/null @@ -1,87 +0,0 @@ - -program example4 -use iotk_module -implicit none - -type person_type - integer :: age - complex :: height - complex, pointer :: scores(:) -end type person_type - -type(person_type) :: person -type(person_type) :: person_read - -call person_init(person,5) -person%age = 26 -person%height = 1.88 -person%scores = (/5.0,5.0,6.0,6.0,4.0/) - -call iotk_open_write(10,file="example4.xml",binary=.false.) - call person_write(person,"Giovanni",10) -call iotk_close_write(10) - -call person_finalize(person) - -call person_init(person_read,0) -call iotk_open_read(10,file="example4.xml",binary=.false.) - call person_scan(person_read,"Giovanni ",10) -call iotk_close_read(10) - -! just for debug: -write(*,*) person_read%age,person_read%height -write(*,*) person_read%scores - -call person_finalize(person_read) - -contains - -subroutine person_init(person,nscores) - type (person_type), intent(out) :: person - integer, intent(in) :: nscores - person%age=0 - person%height=0.0 - allocate(person%scores(nscores)) -end subroutine person_init - -subroutine person_finalize(person) - type (person_type), intent(inout) :: person - deallocate(person%scores) -end subroutine person_finalize - -subroutine person_write(person,name,unit) - type (person_type), intent(in) :: person - character(len=*), intent(in) :: name - integer, intent(in) :: unit - character(iotk_attlenx) :: attr - call iotk_write_attr(attr,"type","person",first=.true.) - call iotk_write_begin(unit,name,attr=attr) - call iotk_write_attr(attr,"age",person%age,first=.true.) - call iotk_write_attr(attr,"height",person%height) - call iotk_write_attr(attr,"nscores",size(person%scores)) - call iotk_write_empty(unit,"vals",attr=attr) - call iotk_write_dat (unit,"scores",person%scores) - call iotk_write_end (unit,name) -end subroutine person_write - -subroutine person_scan(person,name,unit) - type (person_type), intent(out) :: person - character(len=*), intent(in) :: name - integer, intent(in) :: unit - character(iotk_attlenx) :: attr - character(iotk_vallenx) :: rtype - integer :: nscores - call iotk_scan_begin(unit,name,attr=attr) - call iotk_scan_attr(attr,"type",rtype) - if(rtype/="person") stop - call iotk_scan_empty(unit,"vals",attr=attr) - call iotk_scan_attr(attr,"age",person%age) - call iotk_scan_attr(attr,"height",person%height) - call iotk_scan_attr(attr,"nscores",nscores) - deallocate(person%scores) - allocate(person%scores(nscores)) - call iotk_scan_dat (unit,"scores",person%scores) - call iotk_scan_end (unit,name) -end subroutine person_scan - -end program example4 diff --git a/quantum_espresso/kcp/iotk/src/iotk.f90 b/quantum_espresso/kcp/iotk/src/iotk.f90 deleted file mode 100644 index aafee8472..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk.f90 +++ /dev/null @@ -1,16 +0,0 @@ -# 2 "iotk.spp" - -program iotk - use iotk_module - use iotk_base - use iotk_error_interf - implicit none - integer :: nargs,ierrl - character(iotk_linlenx) :: args(iotk_maxargs) - - call iotk_readcmdline(args,nargs,eos=.true.,ierr=ierrl) - if(ierrl/=0) goto 1 - call iotk_tool(args(1:nargs)) -1 continue - if(ierrl/=0) call iotk_error_handler(ierrl) -end program iotk diff --git a/quantum_espresso/kcp/iotk/src/iotk.spp b/quantum_espresso/kcp/iotk/src/iotk.spp deleted file mode 100644 index 49c648a5e..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk.spp +++ /dev/null @@ -1,16 +0,0 @@ ->include iotk_include.sh - -program iotk - use iotk_module - use iotk_base - use iotk_error_interf - implicit none - integer :: nargs,ierrl - character(iotk_linlenx) :: args(iotk_maxargs) - - call iotk_readcmdline(args,nargs,eos=.true.,ierr=ierrl) - if(ierrl/=0) goto 1 - call iotk_tool(args(1:nargs)) -1 continue - if(ierrl/=0) call iotk_error_handler(ierrl) -end program iotk diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+CHARACTER1_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+CHARACTER1_0.f90 deleted file mode 100644 index e02d5b514..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+CHARACTER1_0.f90 +++ /dev/null @@ -1,280 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_CHARACTER1 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_CHARACTER1(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 89 "iotk_attr.spp" - CHARACTER (kind=iotk_CHARACTER1,len=l), intent(out) :: out(n) - CHARACTER (kind=iotk_CHARACTER1,len=l), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_CHARACTER1 - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_CHARACTER1_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - CHARACTER(kind=iotk_CHARACTER1,len=*), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 269 "iotk_attr.spp" - logical :: lquot,lapos -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 289 "iotk_attr.spp" - lquot=iotk_strscan(val,'"')>0 - lapos=iotk_strscan(val,"'")>0 - if(.not.lquot) then - delim='"' - call iotk_deescape(tmpval,val) - else if(.not.lapos) then - delim="'" - call iotk_deescape(tmpval,val) - else - delim='"' - call iotk_deescape(tmpval,val,quot=.true.,apos=.true.) - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_CHARACTER1_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_CHARACTER1_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=iotk_CHARACTER1,len=*) :: val -#else - CHARACTER(kind=iotk_CHARACTER1,len=*), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - CHARACTER(kind=iotk_CHARACTER1,len=*), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 358 "iotk_attr.spp" - character(iotk_vallenx) :: valctmp - integer :: vallen,defaultlen - logical :: leos - leos=.false. - if(present(eos)) leos=eos -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 412 "iotk_attr.spp" - call iotk_escape(valctmp,valc) - vallen = iotk_strlen(valctmp) - if(len(val) < vallen) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 415 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - val(1:vallen) = valctmp(1:vallen) - if(len(val) > vallen) then - val(vallen+1:vallen+1) = iotk_eos - if(.not.leos) then - val(vallen+1:)=" " - end if - end if -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 458 "iotk_attr.spp" - if(leos) then - defaultlen = min(iotk_strlen(default),len(val)) - val(1:defaultlen) = default(1:defaultlen) - if(defaultlenmaxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 217 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - tmpstr = TRIM( string(pos+1:pos1-1) ) - read( tmpstr,"(G100.95)",iostat=iostat) tmpreal -#else - read(string(pos+1:pos1-1),"(G100.95)",iostat=iostat) tmpreal -#endif - if(modulo(index,2)==1) then - tmpcomplex = cmplx(tmpreal,aimag((val((index+1)/2))),kind=iotk_COMPLEX1) - else - tmpcomplex = cmplx(real(val((index+1)/2)),tmpreal,kind=iotk_COMPLEX1) - end if - val((index+1)/2) = tmpcomplex -# 236 "iotk_attr.spp" - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,'Error reading a COMPLEX number from string') -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_COMPLEX1 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX1_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX1), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX1_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX1_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX1) :: val -#else - COMPLEX(kind=iotk_COMPLEX1), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX1), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX1_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX1_0 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX1_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX1 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX1_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX1), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX1_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX1_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX1) :: val (:) -#else - COMPLEX(kind=iotk_COMPLEX1), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX1), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX1_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX1_1 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX1_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX1 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX1_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX1), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX1_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX1_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX1) :: val (:,:) -#else - COMPLEX(kind=iotk_COMPLEX1), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX1), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX1_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX1_2 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX1_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX1_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX1_3.f90 deleted file mode 100644 index 060c5d8c6..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX1_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX1 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX1_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX1), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX1_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX1_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX1) :: val (:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX1), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX1), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX1_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX1_3 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX1_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX1 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX1_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX1), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX1_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX1_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX1) :: val (:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX1), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX1), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX1_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX1_4 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX1_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX1 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX1_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX1), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX1_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX1_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX1) :: val (:,:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX1), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX1), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX1_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX1_5 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX1_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX1_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX1_6.f90 deleted file mode 100644 index 2f4d2ac25..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX1_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX1 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX1_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX1), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX1_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX1_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX1) :: val (:,:,:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX1), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX1), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX1_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX1_6 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX1_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX1 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX1_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX1), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX1_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX1_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX1) :: val (:,:,:,:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX1), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX1), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX1_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX1_7 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX1_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX2_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX2_0.f90 deleted file mode 100644 index 7231af4bb..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX2_0.f90 +++ /dev/null @@ -1,915 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX2 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_COMPLEX2(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 92 "iotk_attr.spp" - COMPLEX (kind=iotk_COMPLEX2), intent(out) :: out(n) - COMPLEX (kind=iotk_COMPLEX2), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_COMPLEX2 - -# 100 "iotk_attr.spp" -subroutine iotk_write_COMPLEX2(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - COMPLEX(kind=iotk_COMPLEX2), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -# 116 "iotk_attr.spp" - character(len=100) :: tmpval -# 118 "iotk_attr.spp" - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 124 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - do index=1,size(val) -# 141 "iotk_attr.spp" - write(tmpval,trim(iotk_wfmt("COMPLEX",kind(val),1,-1," ")),iostat=iostat) val(index) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 143 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 143 "iotk_attr.spp" -call iotk_error_msg(ierr,' ') -# 143 "iotk_attr.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_strcat(string,trim(adjustl(tmpval))//" ",ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 148 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -# 152 "iotk_attr.spp" - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_COMPLEX2 -# 158 "iotk_attr.spp" - -# 162 "iotk_attr.spp" -subroutine iotk_read_COMPLEX2(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - COMPLEX(kind=iotk_COMPLEX2), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -# 175 "iotk_attr.spp" - integer :: pos,pos1,iostat - integer :: maxindex -# 178 "iotk_attr.spp" - real(kind=iotk_COMPLEX2) :: tmpreal - complex(kind=iotk_COMPLEX2) :: tmpcomplex -# 181 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -# 189 "iotk_attr.spp" - maxindex = 2 * size(val) -# 193 "iotk_attr.spp" -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 217 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - tmpstr = TRIM( string(pos+1:pos1-1) ) - read( tmpstr,"(G100.95)",iostat=iostat) tmpreal -#else - read(string(pos+1:pos1-1),"(G100.95)",iostat=iostat) tmpreal -#endif - if(modulo(index,2)==1) then - tmpcomplex = cmplx(tmpreal,aimag((val((index+1)/2))),kind=iotk_COMPLEX2) - else - tmpcomplex = cmplx(real(val((index+1)/2)),tmpreal,kind=iotk_COMPLEX2) - end if - val((index+1)/2) = tmpcomplex -# 236 "iotk_attr.spp" - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,'Error reading a COMPLEX number from string') -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_COMPLEX2 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX2_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX2), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX2_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX2_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX2) :: val -#else - COMPLEX(kind=iotk_COMPLEX2), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX2), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX2_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX2_0 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX2_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX2 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX2_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX2), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX2_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX2_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX2) :: val (:) -#else - COMPLEX(kind=iotk_COMPLEX2), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX2), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX2_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX2_1 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX2_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX2 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX2_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX2), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX2_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX2_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX2) :: val (:,:) -#else - COMPLEX(kind=iotk_COMPLEX2), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX2), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX2_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX2_2 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX2_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX2_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX2_3.f90 deleted file mode 100644 index 5377f0907..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX2_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX2 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX2_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX2), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX2_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX2_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX2) :: val (:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX2), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX2), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX2_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX2_3 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX2_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX2 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX2_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX2), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX2_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX2_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX2) :: val (:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX2), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX2), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX2_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX2_4 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX2_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX2 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX2_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX2), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX2_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX2_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX2) :: val (:,:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX2), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX2), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX2_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX2_5 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX2_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX2_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX2_6.f90 deleted file mode 100644 index 1b00e7cc1..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX2_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX2 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX2_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX2), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX2_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX2_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX2) :: val (:,:,:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX2), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX2), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX2_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX2_6 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX2_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX2 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX2_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX2), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX2_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX2_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX2) :: val (:,:,:,:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX2), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX2), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX2_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX2_7 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX2_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX3_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX3_0.f90 deleted file mode 100644 index 47cc23db9..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX3_0.f90 +++ /dev/null @@ -1,915 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX3 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_COMPLEX3(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 92 "iotk_attr.spp" - COMPLEX (kind=iotk_COMPLEX3), intent(out) :: out(n) - COMPLEX (kind=iotk_COMPLEX3), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_COMPLEX3 - -# 100 "iotk_attr.spp" -subroutine iotk_write_COMPLEX3(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - COMPLEX(kind=iotk_COMPLEX3), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -# 116 "iotk_attr.spp" - character(len=100) :: tmpval -# 118 "iotk_attr.spp" - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 124 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - do index=1,size(val) -# 141 "iotk_attr.spp" - write(tmpval,trim(iotk_wfmt("COMPLEX",kind(val),1,-1," ")),iostat=iostat) val(index) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 143 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 143 "iotk_attr.spp" -call iotk_error_msg(ierr,' ') -# 143 "iotk_attr.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_strcat(string,trim(adjustl(tmpval))//" ",ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 148 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -# 152 "iotk_attr.spp" - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_COMPLEX3 -# 158 "iotk_attr.spp" - -# 162 "iotk_attr.spp" -subroutine iotk_read_COMPLEX3(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - COMPLEX(kind=iotk_COMPLEX3), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -# 175 "iotk_attr.spp" - integer :: pos,pos1,iostat - integer :: maxindex -# 178 "iotk_attr.spp" - real(kind=iotk_COMPLEX3) :: tmpreal - complex(kind=iotk_COMPLEX3) :: tmpcomplex -# 181 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -# 189 "iotk_attr.spp" - maxindex = 2 * size(val) -# 193 "iotk_attr.spp" -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 217 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - tmpstr = TRIM( string(pos+1:pos1-1) ) - read( tmpstr,"(G100.95)",iostat=iostat) tmpreal -#else - read(string(pos+1:pos1-1),"(G100.95)",iostat=iostat) tmpreal -#endif - if(modulo(index,2)==1) then - tmpcomplex = cmplx(tmpreal,aimag((val((index+1)/2))),kind=iotk_COMPLEX3) - else - tmpcomplex = cmplx(real(val((index+1)/2)),tmpreal,kind=iotk_COMPLEX3) - end if - val((index+1)/2) = tmpcomplex -# 236 "iotk_attr.spp" - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,'Error reading a COMPLEX number from string') -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_COMPLEX3 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX3_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX3), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX3_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX3_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX3) :: val -#else - COMPLEX(kind=iotk_COMPLEX3), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX3), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX3_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX3_0 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX3_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX3 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX3_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX3), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX3_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX3_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX3) :: val (:) -#else - COMPLEX(kind=iotk_COMPLEX3), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX3), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX3_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX3_1 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX3_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX3 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX3_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX3), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX3_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX3_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX3) :: val (:,:) -#else - COMPLEX(kind=iotk_COMPLEX3), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX3), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX3_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX3_2 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX3_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX3_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX3_3.f90 deleted file mode 100644 index 7e61bc27f..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX3_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX3 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX3_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX3), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX3_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX3_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX3) :: val (:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX3), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX3), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX3_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX3_3 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX3_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX3 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX3_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX3), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX3_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX3_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX3) :: val (:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX3), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX3), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX3_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX3_4 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX3_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX3 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX3_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX3), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX3_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX3_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX3) :: val (:,:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX3), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX3), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX3_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX3_5 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX3_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX3_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX3_6.f90 deleted file mode 100644 index 402de9e66..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX3_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX3 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX3_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX3), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX3_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX3_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX3) :: val (:,:,:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX3), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX3), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX3_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX3_6 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX3_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX3 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX3_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX3), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX3_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX3_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX3) :: val (:,:,:,:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX3), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX3), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX3_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX3_7 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX3_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX4_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX4_0.f90 deleted file mode 100644 index dc1bac8b9..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX4_0.f90 +++ /dev/null @@ -1,915 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX4 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_COMPLEX4(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 92 "iotk_attr.spp" - COMPLEX (kind=iotk_COMPLEX4), intent(out) :: out(n) - COMPLEX (kind=iotk_COMPLEX4), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_COMPLEX4 - -# 100 "iotk_attr.spp" -subroutine iotk_write_COMPLEX4(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - COMPLEX(kind=iotk_COMPLEX4), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -# 116 "iotk_attr.spp" - character(len=100) :: tmpval -# 118 "iotk_attr.spp" - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 124 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - do index=1,size(val) -# 141 "iotk_attr.spp" - write(tmpval,trim(iotk_wfmt("COMPLEX",kind(val),1,-1," ")),iostat=iostat) val(index) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 143 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 143 "iotk_attr.spp" -call iotk_error_msg(ierr,' ') -# 143 "iotk_attr.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_strcat(string,trim(adjustl(tmpval))//" ",ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 148 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -# 152 "iotk_attr.spp" - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_COMPLEX4 -# 158 "iotk_attr.spp" - -# 162 "iotk_attr.spp" -subroutine iotk_read_COMPLEX4(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - COMPLEX(kind=iotk_COMPLEX4), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -# 175 "iotk_attr.spp" - integer :: pos,pos1,iostat - integer :: maxindex -# 178 "iotk_attr.spp" - real(kind=iotk_COMPLEX4) :: tmpreal - complex(kind=iotk_COMPLEX4) :: tmpcomplex -# 181 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -# 189 "iotk_attr.spp" - maxindex = 2 * size(val) -# 193 "iotk_attr.spp" -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 217 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - tmpstr = TRIM( string(pos+1:pos1-1) ) - read( tmpstr,"(G100.95)",iostat=iostat) tmpreal -#else - read(string(pos+1:pos1-1),"(G100.95)",iostat=iostat) tmpreal -#endif - if(modulo(index,2)==1) then - tmpcomplex = cmplx(tmpreal,aimag((val((index+1)/2))),kind=iotk_COMPLEX4) - else - tmpcomplex = cmplx(real(val((index+1)/2)),tmpreal,kind=iotk_COMPLEX4) - end if - val((index+1)/2) = tmpcomplex -# 236 "iotk_attr.spp" - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,'Error reading a COMPLEX number from string') -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_COMPLEX4 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX4_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX4), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX4_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX4_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX4) :: val -#else - COMPLEX(kind=iotk_COMPLEX4), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX4), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX4_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX4_0 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX4_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX4 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX4_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX4), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX4_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX4_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX4) :: val (:) -#else - COMPLEX(kind=iotk_COMPLEX4), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX4), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX4_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX4_1 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX4_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX4 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX4_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX4), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX4_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX4_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX4) :: val (:,:) -#else - COMPLEX(kind=iotk_COMPLEX4), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX4), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX4_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX4_2 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX4_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX4_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX4_3.f90 deleted file mode 100644 index 3d0b1742a..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX4_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX4 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX4_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX4), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX4_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX4_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX4) :: val (:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX4), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX4), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX4_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX4_3 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX4_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX4 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX4_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX4), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX4_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX4_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX4) :: val (:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX4), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX4), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX4_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX4_4 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX4_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX4 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX4_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX4), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX4_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX4_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX4) :: val (:,:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX4), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX4), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX4_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX4_5 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX4_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX4_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX4_6.f90 deleted file mode 100644 index cc801d4be..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+COMPLEX4_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX4 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX4_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX4), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX4_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX4_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX4) :: val (:,:,:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX4), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX4), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX4_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX4_6 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX4_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_COMPLEX4 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_COMPLEX4_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - COMPLEX(kind=iotk_COMPLEX4), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_COMPLEX4_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_COMPLEX4_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=iotk_COMPLEX4) :: val (:,:,:,:,:,:,:) -#else - COMPLEX(kind=iotk_COMPLEX4), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=iotk_COMPLEX4), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - COMPLEX(kind=iotk_COMPLEX4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 435 "iotk_attr.spp" - if(index/=2*size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_COMPLEX4_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_COMPLEX4_7 - write(0,*) -end subroutine iotk_attr_dummy_COMPLEX4_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER1_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER1_0.f90 deleted file mode 100644 index e96980fc1..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER1_0.f90 +++ /dev/null @@ -1,888 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER1 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_INTEGER1(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 92 "iotk_attr.spp" - INTEGER (kind=iotk_INTEGER1), intent(out) :: out(n) - INTEGER (kind=iotk_INTEGER1), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_INTEGER1 - -# 100 "iotk_attr.spp" -subroutine iotk_write_INTEGER1(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - INTEGER(kind=iotk_INTEGER1), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -# 118 "iotk_attr.spp" - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 124 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - do index=1,size(val) -# 135 "iotk_attr.spp" - call iotk_strcat(string,trim(iotk_itoa(val(index)))//" ",ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 137 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -# 152 "iotk_attr.spp" - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_INTEGER1 -# 158 "iotk_attr.spp" - -# 162 "iotk_attr.spp" -subroutine iotk_read_INTEGER1(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - INTEGER(kind=iotk_INTEGER1), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -# 173 "iotk_attr.spp" - logical :: check -# 175 "iotk_attr.spp" - integer :: pos,pos1,iostat - integer :: maxindex -# 181 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -# 191 "iotk_attr.spp" - maxindex = size(val) -# 193 "iotk_attr.spp" -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 206 "iotk_attr.spp" - call iotk_atoi(val(index),string(pos+1:pos1-1),check=check) -# 231 "iotk_attr.spp" - if(.not.check) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,'Wrong string') -# 232 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_INTEGER1 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER1_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER1), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER1_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER1_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER1) :: val -#else - INTEGER(kind=iotk_INTEGER1), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER1), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER1_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER1_0 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER1_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER1 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER1_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER1), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER1_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER1_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER1) :: val (:) -#else - INTEGER(kind=iotk_INTEGER1), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER1), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER1_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER1_1 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER1_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER1 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER1_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER1), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER1_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER1_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER1) :: val (:,:) -#else - INTEGER(kind=iotk_INTEGER1), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER1), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER1_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER1_2 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER1_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER1_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER1_3.f90 deleted file mode 100644 index d53f2dcd7..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER1_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER1 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER1_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER1), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER1_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER1_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER1) :: val (:,:,:) -#else - INTEGER(kind=iotk_INTEGER1), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER1), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER1_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER1_3 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER1_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER1 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER1_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER1), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER1_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER1_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER1) :: val (:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER1), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER1), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER1_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER1_4 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER1_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER1 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER1_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER1), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER1_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER1_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER1) :: val (:,:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER1), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER1), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER1_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER1_5 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER1_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER1_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER1_6.f90 deleted file mode 100644 index 57ddba605..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER1_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER1 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER1_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER1), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER1_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER1_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER1) :: val (:,:,:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER1), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER1), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER1_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER1_6 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER1_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER1 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER1_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER1), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER1_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER1_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER1) :: val (:,:,:,:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER1), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER1), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER1_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER1_7 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER1_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER2_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER2_0.f90 deleted file mode 100644 index 10a180866..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER2_0.f90 +++ /dev/null @@ -1,888 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER2 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_INTEGER2(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 92 "iotk_attr.spp" - INTEGER (kind=iotk_INTEGER2), intent(out) :: out(n) - INTEGER (kind=iotk_INTEGER2), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_INTEGER2 - -# 100 "iotk_attr.spp" -subroutine iotk_write_INTEGER2(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - INTEGER(kind=iotk_INTEGER2), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -# 118 "iotk_attr.spp" - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 124 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - do index=1,size(val) -# 135 "iotk_attr.spp" - call iotk_strcat(string,trim(iotk_itoa(val(index)))//" ",ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 137 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -# 152 "iotk_attr.spp" - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_INTEGER2 -# 158 "iotk_attr.spp" - -# 162 "iotk_attr.spp" -subroutine iotk_read_INTEGER2(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - INTEGER(kind=iotk_INTEGER2), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -# 173 "iotk_attr.spp" - logical :: check -# 175 "iotk_attr.spp" - integer :: pos,pos1,iostat - integer :: maxindex -# 181 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -# 191 "iotk_attr.spp" - maxindex = size(val) -# 193 "iotk_attr.spp" -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 206 "iotk_attr.spp" - call iotk_atoi(val(index),string(pos+1:pos1-1),check=check) -# 231 "iotk_attr.spp" - if(.not.check) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,'Wrong string') -# 232 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_INTEGER2 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER2_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER2), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER2_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER2_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER2) :: val -#else - INTEGER(kind=iotk_INTEGER2), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER2), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER2_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER2_0 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER2_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER2 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER2_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER2), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER2_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER2_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER2) :: val (:) -#else - INTEGER(kind=iotk_INTEGER2), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER2), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER2_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER2_1 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER2_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER2 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER2_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER2), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER2_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER2_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER2) :: val (:,:) -#else - INTEGER(kind=iotk_INTEGER2), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER2), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER2_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER2_2 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER2_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER2_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER2_3.f90 deleted file mode 100644 index ab3186e09..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER2_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER2 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER2_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER2), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER2_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER2_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER2) :: val (:,:,:) -#else - INTEGER(kind=iotk_INTEGER2), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER2), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER2_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER2_3 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER2_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER2 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER2_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER2), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER2_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER2_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER2) :: val (:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER2), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER2), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER2_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER2_4 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER2_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER2 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER2_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER2), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER2_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER2_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER2) :: val (:,:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER2), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER2), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER2_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER2_5 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER2_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER2_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER2_6.f90 deleted file mode 100644 index 08e42efaa..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER2_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER2 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER2_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER2), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER2_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER2_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER2) :: val (:,:,:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER2), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER2), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER2_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER2_6 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER2_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER2 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER2_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER2), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER2_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER2_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER2) :: val (:,:,:,:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER2), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER2), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER2_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER2_7 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER2_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER3_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER3_0.f90 deleted file mode 100644 index f339ea1b1..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER3_0.f90 +++ /dev/null @@ -1,888 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER3 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_INTEGER3(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 92 "iotk_attr.spp" - INTEGER (kind=iotk_INTEGER3), intent(out) :: out(n) - INTEGER (kind=iotk_INTEGER3), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_INTEGER3 - -# 100 "iotk_attr.spp" -subroutine iotk_write_INTEGER3(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - INTEGER(kind=iotk_INTEGER3), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -# 118 "iotk_attr.spp" - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 124 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - do index=1,size(val) -# 135 "iotk_attr.spp" - call iotk_strcat(string,trim(iotk_itoa(val(index)))//" ",ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 137 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -# 152 "iotk_attr.spp" - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_INTEGER3 -# 158 "iotk_attr.spp" - -# 162 "iotk_attr.spp" -subroutine iotk_read_INTEGER3(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - INTEGER(kind=iotk_INTEGER3), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -# 173 "iotk_attr.spp" - logical :: check -# 175 "iotk_attr.spp" - integer :: pos,pos1,iostat - integer :: maxindex -# 181 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -# 191 "iotk_attr.spp" - maxindex = size(val) -# 193 "iotk_attr.spp" -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 206 "iotk_attr.spp" - call iotk_atoi(val(index),string(pos+1:pos1-1),check=check) -# 231 "iotk_attr.spp" - if(.not.check) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,'Wrong string') -# 232 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_INTEGER3 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER3_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER3), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER3_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER3_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER3) :: val -#else - INTEGER(kind=iotk_INTEGER3), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER3), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER3_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER3_0 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER3_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER3 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER3_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER3), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER3_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER3_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER3) :: val (:) -#else - INTEGER(kind=iotk_INTEGER3), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER3), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER3_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER3_1 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER3_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER3 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER3_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER3), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER3_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER3_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER3) :: val (:,:) -#else - INTEGER(kind=iotk_INTEGER3), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER3), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER3_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER3_2 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER3_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER3_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER3_3.f90 deleted file mode 100644 index a7ff33f06..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER3_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER3 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER3_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER3), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER3_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER3_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER3) :: val (:,:,:) -#else - INTEGER(kind=iotk_INTEGER3), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER3), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER3_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER3_3 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER3_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER3 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER3_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER3), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER3_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER3_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER3) :: val (:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER3), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER3), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER3_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER3_4 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER3_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER3 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER3_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER3), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER3_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER3_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER3) :: val (:,:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER3), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER3), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER3_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER3_5 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER3_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER3_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER3_6.f90 deleted file mode 100644 index 8c871d0b2..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER3_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER3 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER3_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER3), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER3_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER3_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER3) :: val (:,:,:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER3), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER3), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER3_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER3_6 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER3_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER3 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER3_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER3), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER3_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER3_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER3) :: val (:,:,:,:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER3), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER3), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER3_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER3_7 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER3_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER4_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER4_0.f90 deleted file mode 100644 index 130121ca0..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER4_0.f90 +++ /dev/null @@ -1,888 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER4 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_INTEGER4(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 92 "iotk_attr.spp" - INTEGER (kind=iotk_INTEGER4), intent(out) :: out(n) - INTEGER (kind=iotk_INTEGER4), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_INTEGER4 - -# 100 "iotk_attr.spp" -subroutine iotk_write_INTEGER4(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - INTEGER(kind=iotk_INTEGER4), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -# 118 "iotk_attr.spp" - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 124 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - do index=1,size(val) -# 135 "iotk_attr.spp" - call iotk_strcat(string,trim(iotk_itoa(val(index)))//" ",ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 137 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -# 152 "iotk_attr.spp" - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_INTEGER4 -# 158 "iotk_attr.spp" - -# 162 "iotk_attr.spp" -subroutine iotk_read_INTEGER4(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - INTEGER(kind=iotk_INTEGER4), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -# 173 "iotk_attr.spp" - logical :: check -# 175 "iotk_attr.spp" - integer :: pos,pos1,iostat - integer :: maxindex -# 181 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -# 191 "iotk_attr.spp" - maxindex = size(val) -# 193 "iotk_attr.spp" -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 206 "iotk_attr.spp" - call iotk_atoi(val(index),string(pos+1:pos1-1),check=check) -# 231 "iotk_attr.spp" - if(.not.check) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,'Wrong string') -# 232 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_INTEGER4 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER4_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER4), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER4_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER4_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER4) :: val -#else - INTEGER(kind=iotk_INTEGER4), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER4), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER4_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER4_0 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER4_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER4 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER4_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER4), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER4_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER4_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER4) :: val (:) -#else - INTEGER(kind=iotk_INTEGER4), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER4), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER4_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER4_1 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER4_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER4 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER4_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER4), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER4_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER4_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER4) :: val (:,:) -#else - INTEGER(kind=iotk_INTEGER4), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER4), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER4_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER4_2 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER4_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER4_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER4_3.f90 deleted file mode 100644 index 12b3ca747..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER4_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER4 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER4_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER4), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER4_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER4_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER4) :: val (:,:,:) -#else - INTEGER(kind=iotk_INTEGER4), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER4), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER4_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER4_3 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER4_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER4 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER4_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER4), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER4_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER4_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER4) :: val (:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER4), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER4), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER4_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER4_4 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER4_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER4 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER4_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER4), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER4_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER4_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER4) :: val (:,:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER4), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER4), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER4_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER4_5 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER4_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER4_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER4_6.f90 deleted file mode 100644 index f6bf2e20b..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+INTEGER4_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER4 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER4_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER4), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER4_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER4_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER4) :: val (:,:,:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER4), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER4), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER4_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER4_6 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER4_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_INTEGER4 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_INTEGER4_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - INTEGER(kind=iotk_INTEGER4), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_INTEGER4_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_INTEGER4_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=iotk_INTEGER4) :: val (:,:,:,:,:,:,:) -#else - INTEGER(kind=iotk_INTEGER4), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=iotk_INTEGER4), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - INTEGER(kind=iotk_INTEGER4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_INTEGER4_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_INTEGER4_7 - write(0,*) -end subroutine iotk_attr_dummy_INTEGER4_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL1_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL1_0.f90 deleted file mode 100644 index 7ce89681e..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL1_0.f90 +++ /dev/null @@ -1,888 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL1 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_LOGICAL1(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 92 "iotk_attr.spp" - LOGICAL (kind=iotk_LOGICAL1), intent(out) :: out(n) - LOGICAL (kind=iotk_LOGICAL1), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_LOGICAL1 - -# 100 "iotk_attr.spp" -subroutine iotk_write_LOGICAL1(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - LOGICAL(kind=iotk_LOGICAL1), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -# 118 "iotk_attr.spp" - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 124 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - do index=1,size(val) -# 129 "iotk_attr.spp" - call iotk_strcat(string,iotk_ltoa(val(index))//" ",ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 131 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -# 152 "iotk_attr.spp" - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_LOGICAL1 -# 158 "iotk_attr.spp" - -# 162 "iotk_attr.spp" -subroutine iotk_read_LOGICAL1(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - LOGICAL(kind=iotk_LOGICAL1), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -# 173 "iotk_attr.spp" - logical :: check -# 175 "iotk_attr.spp" - integer :: pos,pos1,iostat - integer :: maxindex -# 181 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -# 191 "iotk_attr.spp" - maxindex = size(val) -# 193 "iotk_attr.spp" -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 208 "iotk_attr.spp" - val(index) = iotk_atol(string(pos+1:pos1-1),check=check) -# 231 "iotk_attr.spp" - if(.not.check) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,'Wrong string') -# 232 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_LOGICAL1 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL1_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL1), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL1_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL1_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL1) :: val -#else - LOGICAL(kind=iotk_LOGICAL1), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL1), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL1_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL1_0 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL1_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL1 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL1_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL1), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL1_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL1_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL1) :: val (:) -#else - LOGICAL(kind=iotk_LOGICAL1), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL1), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL1_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL1_1 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL1_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL1 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL1_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL1), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL1_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL1_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL1) :: val (:,:) -#else - LOGICAL(kind=iotk_LOGICAL1), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL1), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL1_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL1_2 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL1_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL1_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL1_3.f90 deleted file mode 100644 index 97f328a0d..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL1_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL1 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL1_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL1), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL1_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL1_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL1) :: val (:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL1), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL1), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL1_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL1_3 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL1_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL1 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL1_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL1), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL1_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL1_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL1) :: val (:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL1), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL1), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL1_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL1_4 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL1_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL1 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL1_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL1), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL1_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL1_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL1) :: val (:,:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL1), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL1), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL1_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL1_5 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL1_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL1_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL1_6.f90 deleted file mode 100644 index 79fe669e2..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL1_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL1 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL1_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL1), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL1_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL1_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL1) :: val (:,:,:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL1), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL1), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL1_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL1_6 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL1_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL1 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL1_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL1), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL1_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL1_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL1) :: val (:,:,:,:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL1), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL1), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL1_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL1_7 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL1_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL2_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL2_0.f90 deleted file mode 100644 index eea519b3c..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL2_0.f90 +++ /dev/null @@ -1,888 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL2 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_LOGICAL2(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 92 "iotk_attr.spp" - LOGICAL (kind=iotk_LOGICAL2), intent(out) :: out(n) - LOGICAL (kind=iotk_LOGICAL2), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_LOGICAL2 - -# 100 "iotk_attr.spp" -subroutine iotk_write_LOGICAL2(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - LOGICAL(kind=iotk_LOGICAL2), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -# 118 "iotk_attr.spp" - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 124 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - do index=1,size(val) -# 129 "iotk_attr.spp" - call iotk_strcat(string,iotk_ltoa(val(index))//" ",ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 131 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -# 152 "iotk_attr.spp" - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_LOGICAL2 -# 158 "iotk_attr.spp" - -# 162 "iotk_attr.spp" -subroutine iotk_read_LOGICAL2(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - LOGICAL(kind=iotk_LOGICAL2), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -# 173 "iotk_attr.spp" - logical :: check -# 175 "iotk_attr.spp" - integer :: pos,pos1,iostat - integer :: maxindex -# 181 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -# 191 "iotk_attr.spp" - maxindex = size(val) -# 193 "iotk_attr.spp" -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 208 "iotk_attr.spp" - val(index) = iotk_atol(string(pos+1:pos1-1),check=check) -# 231 "iotk_attr.spp" - if(.not.check) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,'Wrong string') -# 232 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_LOGICAL2 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL2_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL2), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL2_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL2_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL2) :: val -#else - LOGICAL(kind=iotk_LOGICAL2), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL2), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL2_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL2_0 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL2_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL2 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL2_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL2), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL2_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL2_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL2) :: val (:) -#else - LOGICAL(kind=iotk_LOGICAL2), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL2), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL2_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL2_1 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL2_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL2 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL2_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL2), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL2_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL2_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL2) :: val (:,:) -#else - LOGICAL(kind=iotk_LOGICAL2), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL2), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL2_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL2_2 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL2_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL2_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL2_3.f90 deleted file mode 100644 index 99f9ce869..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL2_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL2 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL2_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL2), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL2_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL2_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL2) :: val (:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL2), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL2), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL2_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL2_3 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL2_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL2 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL2_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL2), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL2_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL2_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL2) :: val (:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL2), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL2), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL2_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL2_4 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL2_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL2 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL2_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL2), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL2_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL2_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL2) :: val (:,:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL2), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL2), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL2_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL2_5 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL2_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL2_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL2_6.f90 deleted file mode 100644 index dd3e80a58..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL2_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL2 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL2_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL2), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL2_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL2_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL2) :: val (:,:,:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL2), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL2), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL2_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL2_6 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL2_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL2 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL2_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL2), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL2_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL2_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL2) :: val (:,:,:,:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL2), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL2), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL2_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL2_7 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL2_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL3_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL3_0.f90 deleted file mode 100644 index 804b7dc59..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL3_0.f90 +++ /dev/null @@ -1,888 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL3 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_LOGICAL3(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 92 "iotk_attr.spp" - LOGICAL (kind=iotk_LOGICAL3), intent(out) :: out(n) - LOGICAL (kind=iotk_LOGICAL3), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_LOGICAL3 - -# 100 "iotk_attr.spp" -subroutine iotk_write_LOGICAL3(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - LOGICAL(kind=iotk_LOGICAL3), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -# 118 "iotk_attr.spp" - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 124 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - do index=1,size(val) -# 129 "iotk_attr.spp" - call iotk_strcat(string,iotk_ltoa(val(index))//" ",ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 131 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -# 152 "iotk_attr.spp" - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_LOGICAL3 -# 158 "iotk_attr.spp" - -# 162 "iotk_attr.spp" -subroutine iotk_read_LOGICAL3(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - LOGICAL(kind=iotk_LOGICAL3), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -# 173 "iotk_attr.spp" - logical :: check -# 175 "iotk_attr.spp" - integer :: pos,pos1,iostat - integer :: maxindex -# 181 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -# 191 "iotk_attr.spp" - maxindex = size(val) -# 193 "iotk_attr.spp" -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 208 "iotk_attr.spp" - val(index) = iotk_atol(string(pos+1:pos1-1),check=check) -# 231 "iotk_attr.spp" - if(.not.check) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,'Wrong string') -# 232 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_LOGICAL3 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL3_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL3), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL3_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL3_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL3) :: val -#else - LOGICAL(kind=iotk_LOGICAL3), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL3), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL3_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL3_0 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL3_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL3 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL3_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL3), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL3_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL3_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL3) :: val (:) -#else - LOGICAL(kind=iotk_LOGICAL3), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL3), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL3_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL3_1 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL3_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL3 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL3_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL3), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL3_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL3_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL3) :: val (:,:) -#else - LOGICAL(kind=iotk_LOGICAL3), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL3), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL3_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL3_2 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL3_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL3_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL3_3.f90 deleted file mode 100644 index b7a7a67b6..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL3_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL3 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL3_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL3), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL3_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL3_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL3) :: val (:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL3), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL3), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL3_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL3_3 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL3_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL3 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL3_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL3), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL3_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL3_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL3) :: val (:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL3), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL3), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL3_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL3_4 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL3_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL3 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL3_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL3), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL3_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL3_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL3) :: val (:,:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL3), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL3), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL3_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL3_5 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL3_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL3_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL3_6.f90 deleted file mode 100644 index 8537bb9cd..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL3_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL3 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL3_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL3), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL3_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL3_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL3) :: val (:,:,:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL3), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL3), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL3_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL3_6 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL3_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL3 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL3_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL3), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL3_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL3_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL3) :: val (:,:,:,:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL3), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL3), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL3_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL3_7 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL3_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL4_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL4_0.f90 deleted file mode 100644 index ad8e0e97c..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL4_0.f90 +++ /dev/null @@ -1,888 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL4 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_LOGICAL4(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 92 "iotk_attr.spp" - LOGICAL (kind=iotk_LOGICAL4), intent(out) :: out(n) - LOGICAL (kind=iotk_LOGICAL4), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_LOGICAL4 - -# 100 "iotk_attr.spp" -subroutine iotk_write_LOGICAL4(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - LOGICAL(kind=iotk_LOGICAL4), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -# 118 "iotk_attr.spp" - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 124 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - do index=1,size(val) -# 129 "iotk_attr.spp" - call iotk_strcat(string,iotk_ltoa(val(index))//" ",ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 131 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -# 152 "iotk_attr.spp" - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_LOGICAL4 -# 158 "iotk_attr.spp" - -# 162 "iotk_attr.spp" -subroutine iotk_read_LOGICAL4(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - LOGICAL(kind=iotk_LOGICAL4), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -# 173 "iotk_attr.spp" - logical :: check -# 175 "iotk_attr.spp" - integer :: pos,pos1,iostat - integer :: maxindex -# 181 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -# 191 "iotk_attr.spp" - maxindex = size(val) -# 193 "iotk_attr.spp" -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 208 "iotk_attr.spp" - val(index) = iotk_atol(string(pos+1:pos1-1),check=check) -# 231 "iotk_attr.spp" - if(.not.check) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 232 "iotk_attr.spp" -call iotk_error_msg(ierr,'Wrong string') -# 232 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_LOGICAL4 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL4_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL4), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL4_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL4_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL4) :: val -#else - LOGICAL(kind=iotk_LOGICAL4), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL4), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL4_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL4_0 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL4_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL4 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL4_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL4), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL4_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL4_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL4) :: val (:) -#else - LOGICAL(kind=iotk_LOGICAL4), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL4), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL4_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL4_1 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL4_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL4 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL4_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL4), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL4_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL4_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL4) :: val (:,:) -#else - LOGICAL(kind=iotk_LOGICAL4), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL4), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL4_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL4_2 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL4_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL4_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL4_3.f90 deleted file mode 100644 index 4867a9102..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL4_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL4 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL4_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL4), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL4_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL4_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL4) :: val (:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL4), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL4), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL4_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL4_3 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL4_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL4 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL4_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL4), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL4_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL4_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL4) :: val (:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL4), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL4), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL4_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL4_4 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL4_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL4 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL4_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL4), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL4_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL4_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL4) :: val (:,:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL4), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL4), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL4_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL4_5 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL4_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL4_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL4_6.f90 deleted file mode 100644 index b8e37cdd6..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+LOGICAL4_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL4 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL4_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL4), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL4_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL4_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL4) :: val (:,:,:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL4), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL4), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL4_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL4_6 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL4_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_LOGICAL4 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_LOGICAL4_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - LOGICAL(kind=iotk_LOGICAL4), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_LOGICAL4_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_LOGICAL4_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=iotk_LOGICAL4) :: val (:,:,:,:,:,:,:) -#else - LOGICAL(kind=iotk_LOGICAL4), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=iotk_LOGICAL4), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - LOGICAL(kind=iotk_LOGICAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_LOGICAL4_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_LOGICAL4_7 - write(0,*) -end subroutine iotk_attr_dummy_LOGICAL4_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL1_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+REAL1_0.f90 deleted file mode 100644 index 51d03c2fa..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL1_0.f90 +++ /dev/null @@ -1,906 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL1 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_REAL1(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 92 "iotk_attr.spp" - REAL (kind=iotk_REAL1), intent(out) :: out(n) - REAL (kind=iotk_REAL1), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_REAL1 - -# 100 "iotk_attr.spp" -subroutine iotk_write_REAL1(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - REAL(kind=iotk_REAL1), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -# 116 "iotk_attr.spp" - character(len=100) :: tmpval -# 118 "iotk_attr.spp" - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 124 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - do index=1,size(val) -# 141 "iotk_attr.spp" - write(tmpval,trim(iotk_wfmt("REAL",kind(val),1,-1," ")),iostat=iostat) val(index) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 143 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 143 "iotk_attr.spp" -call iotk_error_msg(ierr,' ') -# 143 "iotk_attr.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_strcat(string,trim(adjustl(tmpval))//" ",ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 148 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -# 152 "iotk_attr.spp" - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_REAL1 -# 158 "iotk_attr.spp" - -# 162 "iotk_attr.spp" -subroutine iotk_read_REAL1(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - REAL(kind=iotk_REAL1), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -# 175 "iotk_attr.spp" - integer :: pos,pos1,iostat - integer :: maxindex -# 181 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -# 191 "iotk_attr.spp" - maxindex = size(val) -# 193 "iotk_attr.spp" -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 210 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - tmpstr = TRIM( string(pos+1:pos1-1) ) - read( tmpstr, "(G100.95)",iostat=iostat) val(index) -#else - read( string(pos+1:pos1-1), "(G100.95)",iostat=iostat) val(index) -#endif -# 236 "iotk_attr.spp" - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,'Error reading a REAL number from string') -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_REAL1 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL1_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL1), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL1_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL1_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL1) :: val -#else - REAL(kind=iotk_REAL1), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL1), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL1_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL1_0 - write(0,*) -end subroutine iotk_attr_dummy_REAL1_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL1 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL1_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL1), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL1_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL1_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL1) :: val (:) -#else - REAL(kind=iotk_REAL1), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL1), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL1_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL1_1 - write(0,*) -end subroutine iotk_attr_dummy_REAL1_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL1 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL1_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL1), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL1_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL1_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL1) :: val (:,:) -#else - REAL(kind=iotk_REAL1), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL1), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL1_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL1_2 - write(0,*) -end subroutine iotk_attr_dummy_REAL1_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL1_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+REAL1_3.f90 deleted file mode 100644 index b015ddfb0..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL1_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL1 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL1_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL1), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL1_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL1_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL1) :: val (:,:,:) -#else - REAL(kind=iotk_REAL1), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL1), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL1_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL1_3 - write(0,*) -end subroutine iotk_attr_dummy_REAL1_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL1 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL1_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL1), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL1_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL1_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL1) :: val (:,:,:,:) -#else - REAL(kind=iotk_REAL1), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL1), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL1_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL1_4 - write(0,*) -end subroutine iotk_attr_dummy_REAL1_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL1 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL1_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL1), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL1_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL1_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL1) :: val (:,:,:,:,:) -#else - REAL(kind=iotk_REAL1), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL1), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL1_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL1_5 - write(0,*) -end subroutine iotk_attr_dummy_REAL1_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL1_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+REAL1_6.f90 deleted file mode 100644 index 2a4a51d11..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL1_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL1 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL1_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL1), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL1_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL1_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL1) :: val (:,:,:,:,:,:) -#else - REAL(kind=iotk_REAL1), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL1), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL1_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL1_6 - write(0,*) -end subroutine iotk_attr_dummy_REAL1_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL1 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL1_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL1), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL1_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL1_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL1) :: val (:,:,:,:,:,:,:) -#else - REAL(kind=iotk_REAL1), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL1), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL1), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL1_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL1_7 - write(0,*) -end subroutine iotk_attr_dummy_REAL1_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL2_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+REAL2_0.f90 deleted file mode 100644 index cf9cc5c1f..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL2_0.f90 +++ /dev/null @@ -1,906 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL2 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_REAL2(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 92 "iotk_attr.spp" - REAL (kind=iotk_REAL2), intent(out) :: out(n) - REAL (kind=iotk_REAL2), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_REAL2 - -# 100 "iotk_attr.spp" -subroutine iotk_write_REAL2(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - REAL(kind=iotk_REAL2), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -# 116 "iotk_attr.spp" - character(len=100) :: tmpval -# 118 "iotk_attr.spp" - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 124 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - do index=1,size(val) -# 141 "iotk_attr.spp" - write(tmpval,trim(iotk_wfmt("REAL",kind(val),1,-1," ")),iostat=iostat) val(index) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 143 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 143 "iotk_attr.spp" -call iotk_error_msg(ierr,' ') -# 143 "iotk_attr.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_strcat(string,trim(adjustl(tmpval))//" ",ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 148 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -# 152 "iotk_attr.spp" - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_REAL2 -# 158 "iotk_attr.spp" - -# 162 "iotk_attr.spp" -subroutine iotk_read_REAL2(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - REAL(kind=iotk_REAL2), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -# 175 "iotk_attr.spp" - integer :: pos,pos1,iostat - integer :: maxindex -# 181 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -# 191 "iotk_attr.spp" - maxindex = size(val) -# 193 "iotk_attr.spp" -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 210 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - tmpstr = TRIM( string(pos+1:pos1-1) ) - read( tmpstr, "(G100.95)",iostat=iostat) val(index) -#else - read( string(pos+1:pos1-1), "(G100.95)",iostat=iostat) val(index) -#endif -# 236 "iotk_attr.spp" - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,'Error reading a REAL number from string') -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_REAL2 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL2_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL2), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL2_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL2_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL2) :: val -#else - REAL(kind=iotk_REAL2), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL2), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL2_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL2_0 - write(0,*) -end subroutine iotk_attr_dummy_REAL2_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL2 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL2_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL2), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL2_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL2_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL2) :: val (:) -#else - REAL(kind=iotk_REAL2), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL2), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL2_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL2_1 - write(0,*) -end subroutine iotk_attr_dummy_REAL2_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL2 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL2_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL2), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL2_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL2_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL2) :: val (:,:) -#else - REAL(kind=iotk_REAL2), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL2), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL2_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL2_2 - write(0,*) -end subroutine iotk_attr_dummy_REAL2_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL2_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+REAL2_3.f90 deleted file mode 100644 index 68266d020..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL2_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL2 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL2_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL2), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL2_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL2_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL2) :: val (:,:,:) -#else - REAL(kind=iotk_REAL2), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL2), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL2_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL2_3 - write(0,*) -end subroutine iotk_attr_dummy_REAL2_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL2 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL2_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL2), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL2_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL2_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL2) :: val (:,:,:,:) -#else - REAL(kind=iotk_REAL2), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL2), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL2_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL2_4 - write(0,*) -end subroutine iotk_attr_dummy_REAL2_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL2 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL2_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL2), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL2_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL2_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL2) :: val (:,:,:,:,:) -#else - REAL(kind=iotk_REAL2), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL2), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL2_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL2_5 - write(0,*) -end subroutine iotk_attr_dummy_REAL2_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL2_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+REAL2_6.f90 deleted file mode 100644 index f07599f21..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL2_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL2 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL2_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL2), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL2_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL2_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL2) :: val (:,:,:,:,:,:) -#else - REAL(kind=iotk_REAL2), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL2), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL2_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL2_6 - write(0,*) -end subroutine iotk_attr_dummy_REAL2_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL2 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL2_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL2), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL2_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL2_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL2) :: val (:,:,:,:,:,:,:) -#else - REAL(kind=iotk_REAL2), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL2), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL2), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL2_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL2_7 - write(0,*) -end subroutine iotk_attr_dummy_REAL2_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL3_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+REAL3_0.f90 deleted file mode 100644 index b4bcfb61f..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL3_0.f90 +++ /dev/null @@ -1,906 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL3 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_REAL3(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 92 "iotk_attr.spp" - REAL (kind=iotk_REAL3), intent(out) :: out(n) - REAL (kind=iotk_REAL3), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_REAL3 - -# 100 "iotk_attr.spp" -subroutine iotk_write_REAL3(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - REAL(kind=iotk_REAL3), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -# 116 "iotk_attr.spp" - character(len=100) :: tmpval -# 118 "iotk_attr.spp" - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 124 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - do index=1,size(val) -# 141 "iotk_attr.spp" - write(tmpval,trim(iotk_wfmt("REAL",kind(val),1,-1," ")),iostat=iostat) val(index) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 143 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 143 "iotk_attr.spp" -call iotk_error_msg(ierr,' ') -# 143 "iotk_attr.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_strcat(string,trim(adjustl(tmpval))//" ",ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 148 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -# 152 "iotk_attr.spp" - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_REAL3 -# 158 "iotk_attr.spp" - -# 162 "iotk_attr.spp" -subroutine iotk_read_REAL3(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - REAL(kind=iotk_REAL3), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -# 175 "iotk_attr.spp" - integer :: pos,pos1,iostat - integer :: maxindex -# 181 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -# 191 "iotk_attr.spp" - maxindex = size(val) -# 193 "iotk_attr.spp" -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 210 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - tmpstr = TRIM( string(pos+1:pos1-1) ) - read( tmpstr, "(G100.95)",iostat=iostat) val(index) -#else - read( string(pos+1:pos1-1), "(G100.95)",iostat=iostat) val(index) -#endif -# 236 "iotk_attr.spp" - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,'Error reading a REAL number from string') -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_REAL3 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL3_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL3), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL3_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL3_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL3) :: val -#else - REAL(kind=iotk_REAL3), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL3), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL3_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL3_0 - write(0,*) -end subroutine iotk_attr_dummy_REAL3_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL3 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL3_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL3), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL3_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL3_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL3) :: val (:) -#else - REAL(kind=iotk_REAL3), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL3), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL3_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL3_1 - write(0,*) -end subroutine iotk_attr_dummy_REAL3_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL3 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL3_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL3), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL3_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL3_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL3) :: val (:,:) -#else - REAL(kind=iotk_REAL3), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL3), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL3_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL3_2 - write(0,*) -end subroutine iotk_attr_dummy_REAL3_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL3_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+REAL3_3.f90 deleted file mode 100644 index 34586ac6e..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL3_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL3 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL3_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL3), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL3_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL3_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL3) :: val (:,:,:) -#else - REAL(kind=iotk_REAL3), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL3), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL3_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL3_3 - write(0,*) -end subroutine iotk_attr_dummy_REAL3_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL3 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL3_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL3), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL3_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL3_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL3) :: val (:,:,:,:) -#else - REAL(kind=iotk_REAL3), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL3), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL3_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL3_4 - write(0,*) -end subroutine iotk_attr_dummy_REAL3_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL3 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL3_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL3), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL3_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL3_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL3) :: val (:,:,:,:,:) -#else - REAL(kind=iotk_REAL3), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL3), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL3_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL3_5 - write(0,*) -end subroutine iotk_attr_dummy_REAL3_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL3_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+REAL3_6.f90 deleted file mode 100644 index 205d51a83..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL3_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL3 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL3_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL3), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL3_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL3_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL3) :: val (:,:,:,:,:,:) -#else - REAL(kind=iotk_REAL3), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL3), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL3_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL3_6 - write(0,*) -end subroutine iotk_attr_dummy_REAL3_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL3 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL3_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL3), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL3_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL3_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL3) :: val (:,:,:,:,:,:,:) -#else - REAL(kind=iotk_REAL3), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL3), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL3), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL3_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL3_7 - write(0,*) -end subroutine iotk_attr_dummy_REAL3_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL4_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+REAL4_0.f90 deleted file mode 100644 index 803914204..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL4_0.f90 +++ /dev/null @@ -1,906 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL4 -#if 0 <= __IOTK_MAXRANK - -# 83 "iotk_attr.spp" -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_REAL4(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -# 92 "iotk_attr.spp" - REAL (kind=iotk_REAL4), intent(out) :: out(n) - REAL (kind=iotk_REAL4), intent(in) :: in(n) -# 95 "iotk_attr.spp" - out = in -end subroutine iotk_private_pack_REAL4 - -# 100 "iotk_attr.spp" -subroutine iotk_write_REAL4(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - REAL(kind=iotk_REAL4), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -# 116 "iotk_attr.spp" - character(len=100) :: tmpval -# 118 "iotk_attr.spp" - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 124 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - do index=1,size(val) -# 141 "iotk_attr.spp" - write(tmpval,trim(iotk_wfmt("REAL",kind(val),1,-1," ")),iostat=iostat) val(index) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 143 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 143 "iotk_attr.spp" -call iotk_error_msg(ierr,' ') -# 143 "iotk_attr.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_strcat(string,trim(adjustl(tmpval))//" ",ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_write",__FILE__,__LINE__) -# 148 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -# 152 "iotk_attr.spp" - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_REAL4 -# 158 "iotk_attr.spp" - -# 162 "iotk_attr.spp" -subroutine iotk_read_REAL4(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - REAL(kind=iotk_REAL4), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -# 175 "iotk_attr.spp" - integer :: pos,pos1,iostat - integer :: maxindex -# 181 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -# 191 "iotk_attr.spp" - maxindex = size(val) -# 193 "iotk_attr.spp" -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 203 "iotk_attr.spp" -call iotk_error_msg(ierr,'Too many data') - end if -# 210 "iotk_attr.spp" -#ifdef __IOTK_WORKAROUND9 - tmpstr = TRIM( string(pos+1:pos1-1) ) - read( tmpstr, "(G100.95)",iostat=iostat) val(index) -#else - read( string(pos+1:pos1-1), "(G100.95)",iostat=iostat) val(index) -#endif -# 236 "iotk_attr.spp" - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_read",__FILE__,__LINE__) -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 237 "iotk_attr.spp" -call iotk_error_msg(ierr,'Error reading a REAL number from string') -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"string",string(pos+1:pos1-1)) -# 237 "iotk_attr.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if -# 241 "iotk_attr.spp" - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_REAL4 -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL4_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL4), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 304 "iotk_attr.spp" - call iotk_write((/val/),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL4_0 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL4_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL4) :: val -#else - REAL(kind=iotk_REAL4), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL4), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(1)) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=1) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 443 "iotk_attr.spp" - val = tmpval(1) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL4_0 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL4_0 - write(0,*) -end subroutine iotk_attr_dummy_REAL4_0 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL4 -#if 1 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL4_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL4), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL4_1 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL4_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL4) :: val (:) -#else - REAL(kind=iotk_REAL4), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL4), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL4_1 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL4_1 - write(0,*) -end subroutine iotk_attr_dummy_REAL4_1 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL4 -#if 2 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL4_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL4), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL4_2 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL4_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL4) :: val (:,:) -#else - REAL(kind=iotk_REAL4), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL4), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL4_2 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL4_2 - write(0,*) -end subroutine iotk_attr_dummy_REAL4_2 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL4_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+REAL4_3.f90 deleted file mode 100644 index 6920c304c..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL4_3.f90 +++ /dev/null @@ -1,773 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL4 -#if 3 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL4_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL4), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL4_3 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL4_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL4) :: val (:,:,:) -#else - REAL(kind=iotk_REAL4), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL4), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL4_3 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL4_3 - write(0,*) -end subroutine iotk_attr_dummy_REAL4_3 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL4 -#if 4 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL4_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL4), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL4_4 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL4_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL4) :: val (:,:,:,:) -#else - REAL(kind=iotk_REAL4), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL4), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL4_4 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL4_4 - write(0,*) -end subroutine iotk_attr_dummy_REAL4_4 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL4 -#if 5 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL4_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL4), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL4_5 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL4_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL4) :: val (:,:,:,:,:) -#else - REAL(kind=iotk_REAL4), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL4), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL4_5 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL4_5 - write(0,*) -end subroutine iotk_attr_dummy_REAL4_5 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL4_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr+REAL4_6.f90 deleted file mode 100644 index 9d4648c01..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr+REAL4_6.f90 +++ /dev/null @@ -1,521 +0,0 @@ -# 48 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL4 -#if 6 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL4_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL4), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL4_6 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL4_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL4) :: val (:,:,:,:,:,:) -#else - REAL(kind=iotk_REAL4), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL4), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL4_6 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL4_6 - write(0,*) -end subroutine iotk_attr_dummy_REAL4_6 - -# 45 "iotk_attr.spp" - -# 65 "iotk_attr.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_attr.spp" - -# 78 "iotk_attr.spp" - -#ifdef __IOTK_REAL4 -#if 7 <= __IOTK_MAXRANK - -# 158 "iotk_attr.spp" - -# 246 "iotk_attr.spp" - -# 249 "iotk_attr.spp" -subroutine iotk_write_attr_REAL4_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - REAL(kind=iotk_REAL4), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -# 271 "iotk_attr.spp" - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 285 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 285 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name(1:namlen)) - goto 1 - end if -# 302 "iotk_attr.spp" - delim = '"' -# 306 "iotk_attr.spp" - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -# 308 "iotk_attr.spp" - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 309 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 313 "iotk_attr.spp" - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - call iotk_error_issue(ierrl,"iotk_write_attr",__FILE__,__LINE__) -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 315 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_REAL4_7 - -# 333 "iotk_attr.spp" -subroutine iotk_scan_attr_REAL4_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=iotk_REAL4) :: val (:,:,:,:,:,:,:) -#else - REAL(kind=iotk_REAL4), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=iotk_REAL4), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -# 364 "iotk_attr.spp" - integer :: index - REAL(kind=iotk_REAL4), allocatable :: tmpval (:) -# 367 "iotk_attr.spp" - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 378 "iotk_attr.spp" -call iotk_error_msg(ierrl,'') -# 378 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",attr(equal+1:attlen)) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 385 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 391 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 396 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 405 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - else - goto 1 - end if -# 426 "iotk_attr.spp" - allocate(tmpval(size(val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 431 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -# 437 "iotk_attr.spp" - if(index/=size(val)) then -# 439 "iotk_attr.spp" - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 439 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute size does not match') -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"attr",valc) -# 439 "iotk_attr.spp" -call iotk_error_write(ierrl,"size",size(tmpval)) - goto 1 - end if -# 445 "iotk_attr.spp" - val = reshape (source=tmpval,shape=shape(val)) -# 447 "iotk_attr.spp" - deallocate(tmpval) -# 449 "iotk_attr.spp" -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_attr",__FILE__,__LINE__) -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 453 "iotk_attr.spp" -call iotk_error_msg(ierrl,'Attribute not found') -# 453 "iotk_attr.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -# 466 "iotk_attr.spp" - val = default -# 468 "iotk_attr.spp" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_REAL4_7 -# 476 "iotk_attr.spp" - -#endif -#endif - -subroutine iotk_attr_dummy_REAL4_7 - write(0,*) -end subroutine iotk_attr_dummy_REAL4_7 - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr.f90 deleted file mode 100644 index c383655da..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr.f90 +++ /dev/null @@ -1,36 +0,0 @@ -# 1 "iotk_attr.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_attr.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_attr.spp" - -# 33 "iotk_attr.spp" - - -subroutine iotk_attr_dummy() - write(0,*) -end subroutine iotk_attr_dummy - -# 45 "iotk_attr.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr.spp b/quantum_espresso/kcp/iotk/src/iotk_attr.spp deleted file mode 100644 index 3d2267bb8..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr.spp +++ /dev/null @@ -1,488 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -> REVISION='$Revision: 1.1.1.1 $' -> REVISION="${REVISION//${dol}/}" - - -subroutine iotk_attr_dummy() - write(0,*) -end subroutine iotk_attr_dummy - -> function SIZE () { if ((rank<1)) ; then echo -n "1" ; else echo -n "size($1)" ; fi ; } -> for type in $types ; do -> type_string="\"$type\"" -> for kind in $kinds ; do -> for rank in $ranks ; do -> if [ $type != CHARACTER ] || [ $rank -eq 0 -a $kind -eq 1 ] ; then - -> if((rank%3==0)); then -> auxfile ${type}${kind}_${rank} -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ->fi - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion if the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -> eval "LENSTAR=\$LENSTAR_$type" - -#ifdef __IOTK_${type}${kind} -#if $rank <= __IOTK_MAXRANK - -> if [ $rank -eq 0 ] ; then -! This is needed as a workaround for bugged pack -subroutine iotk_private_pack_$type$kind(out,in,n,l) - use iotk_base - implicit none - integer, intent(in) :: n,l -> if [ $type = CHARACTER ] ; then - ${type} (kind=iotk_${type}${kind},len=l), intent(out) :: out(n) - ${type} (kind=iotk_${type}${kind},len=l), intent(in) :: in(n) -> else - ${type} (kind=iotk_${type}${kind}), intent(out) :: out(n) - ${type} (kind=iotk_${type}${kind}), intent(in) :: in(n) -> fi - out = in -end subroutine iotk_private_pack_$type$kind - -> if [ $type != CHARACTER ] ; then ->PROCEDURE=iotk_write -subroutine iotk_write_${type}${kind}(val,string,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - ${type}(kind=iotk_${type}${kind}), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -> if [ $type = REAL -o $type = COMPLEX ] ; then - character(len=100) :: tmpval -> fi - integer :: index,iostat - ierr = 0 - iostat = 0 - string(1:1) = iotk_eos - if(size(val)==0) return - if(len(string)==0) then - $(ERROR ierr) - return - end if - do index=1,size(val) -> if [ $type = LOGICAL ] ; then - call iotk_strcat(string,iotk_ltoa(val(index))//" ",ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if -> elif [ $type = INTEGER ] ; then - call iotk_strcat(string,trim(iotk_itoa(val(index)))//" ",ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if -> else - write(tmpval,trim(iotk_wfmt("${type}",kind(val),1,-1," ")),iostat=iostat) val(index) - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - call iotk_strcat(string,trim(adjustl(tmpval))//" ",ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if -> fi - end do -! the last blank is deleted - string(iotk_strlen(string):iotk_strlen(string)) = iotk_eos -end subroutine iotk_write_${type}${kind} -> fi -> fi - -> if [ $rank -eq 0 ] ; then -> if [ $type != CHARACTER ] ; then ->PROCEDURE=iotk_read -subroutine iotk_read_${type}${kind}(val,string,index,ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - ${type}(kind=iotk_${type}${kind}), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -> if [ $type = INTEGER -o $type = LOGICAL ] ; then - logical :: check -> fi - integer :: pos,pos1,iostat - integer :: maxindex -> if [ $type = COMPLEX ] ; then - real(kind=iotk_${type}${kind}) :: tmpreal - complex(kind=iotk_${type}${kind}) :: tmpcomplex -> fi -#ifdef __IOTK_WORKAROUND9 - character(len=100) :: tmpstr ! debug -#endif - pos = 0 - pos1= 0 - ierr = 0 - iostat = 0 -> if [ $type = COMPLEX ] ; then - maxindex = 2 * size(val) -> else - maxindex = size(val) -> fi -! for the moment, commas are considered as blanks - do - pos = verify(string(pos1+1:)," ,")+pos1 - if(pos==pos1) exit - pos = pos - 1 - pos1 = scan(string(pos+1:)," ,")+pos - if(pos1==pos) pos1 = len(string) + 1 -!READ string(pos+1:pos1-1) - index = index+1 - if(index>maxindex) then - $(ERROR ierr 'Too many data') - end if -> if [ $type = INTEGER ] ; then - call iotk_atoi(val(index),string(pos+1:pos1-1),check=check) -> elif [ $type = LOGICAL ] ; then - val(index) = iotk_atol(string(pos+1:pos1-1),check=check) -> elif [ $type = REAL ] ; then -#ifdef __IOTK_WORKAROUND9 - tmpstr = TRIM( string(pos+1:pos1-1) ) - read( tmpstr, "(G100.95)",iostat=iostat) val(index) -#else - read( string(pos+1:pos1-1), "(G100.95)",iostat=iostat) val(index) -#endif -> elif [ $type = COMPLEX ] ; then -#ifdef __IOTK_WORKAROUND9 - tmpstr = TRIM( string(pos+1:pos1-1) ) - read( tmpstr,"(G100.95)",iostat=iostat) tmpreal -#else - read(string(pos+1:pos1-1),"(G100.95)",iostat=iostat) tmpreal -#endif - if(modulo(index,2)==1) then - tmpcomplex = cmplx(tmpreal,aimag((val((index+1)/2))),kind=iotk_${type}${kind}) - else - tmpcomplex = cmplx(real(val((index+1)/2)),tmpreal,kind=iotk_${type}${kind}) - end if - val((index+1)/2) = tmpcomplex -> fi -> if [ $type = INTEGER -o $type = LOGICAL ] ; then - if(.not.check) then - $(ERROR ierr 'Wrong string' 'string=string(pos+1:pos1-1)' ) - return - end if -> else - if(iostat/=0) then - $(ERROR ierr 'Error reading a '${type}' number from string' 'string=string(pos+1:pos1-1)' iostat) - return - end if -> fi - if(pos1>=len(string)) exit - end do -end subroutine iotk_read_${type}${kind} -> fi -> fi - -> if [ $type != CHARACTER -o $rank -eq 0 ] ; then ->PROCEDURE=iotk_write_attr -subroutine iotk_write_attr_${type}${kind}_${rank}(attr,name,val,dummy,first,newline,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(inout) :: attr - character(*), intent(in) :: name - ${type}(kind=iotk_${type}${kind}$LENSTAR), intent(in) :: val ${SHAPE[$rank]} - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen - integer :: vallen - integer :: namlen - character :: delim -> if [ $type = CHARACTER ] ; then - logical :: lquot,lapos -> fi - character(iotk_vallenx) :: tmpval - logical :: nl - if(present(newline)) then - nl = newline - else - nl = .false. - endif - ierrl = 0 - if(present(first)) then - if(first) attr(1:1) = iotk_eos - end if - attlen = iotk_strlen_trim(attr) - namlen = iotk_strlen_trim(name) - if(.not.iotk_check_name(name)) then - $(ERROR ierrl 'Wrong tag name' name='name(1:namlen)') - goto 1 - end if -> if [ $type = CHARACTER ] ; then - lquot=iotk_strscan(val,'"')>0 - lapos=iotk_strscan(val,"'")>0 - if(.not.lquot) then - delim='"' - call iotk_deescape(tmpval,val) - else if(.not.lapos) then - delim="'" - call iotk_deescape(tmpval,val) - else - delim='"' - call iotk_deescape(tmpval,val,quot=.true.,apos=.true.) - end if -> else - delim = '"' -> if [ $rank -eq 0 ] ; then - call iotk_write((/val/),tmpval,ierrl) -> else - call iotk_write(pack(val,mask=.true.),tmpval,ierrl) -> fi - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if -> fi - vallen = iotk_strlen(tmpval) - if(attlen+vallen+namlen+5>len(attr)) then - $(ERROR ierrl 'Attribute dummy argument is too short') - goto 1 - end if - if(.not. nl) then - attr(attlen+1:attlen+vallen+namlen+5) = " "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - else - attr(attlen+1:attlen+vallen+namlen+len(iotk_newline)+5) & - = iotk_newline//" "//name(1:namlen)//"="//delim//tmpval(1:vallen)//delim//iotk_eos - endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_attr_${type}${kind}_${rank} - ->PROCEDURE=iotk_scan_attr -subroutine iotk_scan_attr_${type}${kind}_${rank}(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_read - use iotk_str_interf - use iotk_misc_interf - implicit none - character(*), intent(in) :: attr - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - ${type}(kind=iotk_${type}${kind}$LENSTAR) :: val ${SHAPE[$rank]} -#else - ${type}(kind=iotk_${type}${kind}$LENSTAR), intent(out) :: val ${SHAPE[$rank]} -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - ${type}(kind=iotk_${type}${kind}$LENSTAR), optional, intent(in) :: default ${SHAPE[$rank]} - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: attlen,pos,equal,namlen - character :: delim - logical :: foundl - character(iotk_vallenx) :: valc -> if [ $type = CHARACTER ] ; then - character(iotk_vallenx) :: valctmp - integer :: vallen,defaultlen - logical :: leos - leos=.false. - if(present(eos)) leos=eos -> else - integer :: index - ${type}(kind=iotk_${type}${kind}), allocatable :: tmpval (:) -> fi - ierrl = 0 - attlen=iotk_strlen(attr) - namlen=iotk_strlen_trim(name) - foundl = .false. - equal = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - $(ERROR ierrl '' attr='attr(equal+1:attlen)' ) - goto 1 - end if - equal = equal + pos - if(trim(attr(equal-pos:equal-1))==name(1:namlen)) foundl = .true. - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - $(ERROR ierrl) - goto 1 - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - $(ERROR ierrl) - goto 1 - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - $(ERROR ierrl) - goto 1 - end if - if(foundl) exit - equal = equal + pos - end do - if(foundl) then - call iotk_strcpy(valc,attr(equal+1:equal+pos-1),ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - else - goto 1 - end if -> if [ $type = CHARACTER ] ; then - call iotk_escape(valctmp,valc) - vallen = iotk_strlen(valctmp) - if(len(val) < vallen) then - $(ERROR ierrl) - goto 1 - end if - val(1:vallen) = valctmp(1:vallen) - if(len(val) > vallen) then - val(vallen+1:vallen+1) = iotk_eos - if(.not.leos) then - val(vallen+1:)=" " - end if - end if -> else - allocate(tmpval($(SIZE val))) - index = 0 - call iotk_str_clean(valc) - call iotk_read(tmpval,valc(1:iotk_strlen(valc)),index,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if -> if [ $type = COMPLEX ] ; then - if(index/=2*$(SIZE val)) then -> else - if(index/=$(SIZE val)) then -> fi - $(ERROR ierrl 'Attribute size does not match' attr=valc size='size(tmpval)') - goto 1 - end if -> if [ $rank -eq 0 ] ; then - val = tmpval(1) -> else - val = reshape (source=tmpval,shape=shape(val)) -> fi - deallocate(tmpval) -> fi -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - $(ERROR ierrl 'Attribute not found' name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then -> if [ $type = CHARACTER ] ; then - if(leos) then - defaultlen = min(iotk_strlen(default),len(val)) - val(1:defaultlen) = default(1:defaultlen) - if(defaultlen else - val = default -> fi - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_attr_${type}${kind}_${rank} -> fi - -#endif -#endif - -subroutine iotk_attr_dummy_${type}${kind}_${rank} - write(0,*) -end subroutine iotk_attr_dummy_${type}${kind}_${rank} - -> fi -> done -> done -> done - diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr_interf.f90 b/quantum_espresso/kcp/iotk/src/iotk_attr_interf.f90 deleted file mode 100644 index f4af0fa23..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr_interf.f90 +++ /dev/null @@ -1,5137 +0,0 @@ -# 1 "iotk_attr_interf.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_attr_interf.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_attr_interf.spp" - -module iotk_attr_interf -implicit none -private - -public :: iotk_read -public :: iotk_write -public :: iotk_write_attr -public :: iotk_scan_attr - - -interface iotk_read -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL1 -subroutine iotk_read_LOGICAL1(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - LOGICAL(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_LOGICAL1 -#endif -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL2 -subroutine iotk_read_LOGICAL2(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - LOGICAL(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_LOGICAL2 -#endif -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL3 -subroutine iotk_read_LOGICAL3(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - LOGICAL(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_LOGICAL3 -#endif -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL4 -subroutine iotk_read_LOGICAL4(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - LOGICAL(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_LOGICAL4 -#endif -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER1 -subroutine iotk_read_INTEGER1(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - INTEGER(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_INTEGER1 -#endif -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER2 -subroutine iotk_read_INTEGER2(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - INTEGER(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_INTEGER2 -#endif -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER3 -subroutine iotk_read_INTEGER3(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - INTEGER(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_INTEGER3 -#endif -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER4 -subroutine iotk_read_INTEGER4(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - INTEGER(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_INTEGER4 -#endif -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL1 -subroutine iotk_read_REAL1(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - REAL(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_REAL1 -#endif -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL2 -subroutine iotk_read_REAL2(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - REAL(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_REAL2 -#endif -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL3 -subroutine iotk_read_REAL3(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - REAL(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_REAL3 -#endif -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL4 -subroutine iotk_read_REAL4(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - REAL(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_REAL4 -#endif -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX1 -subroutine iotk_read_COMPLEX1(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - COMPLEX(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_COMPLEX1 -#endif -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX2 -subroutine iotk_read_COMPLEX2(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - COMPLEX(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_COMPLEX2 -#endif -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX3 -subroutine iotk_read_COMPLEX3(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - COMPLEX(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_COMPLEX3 -#endif -# 45 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX4 -subroutine iotk_read_COMPLEX4(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - COMPLEX(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_COMPLEX4 -#endif -# 58 "iotk_attr_interf.spp" -end interface - -interface iotk_write -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL1 -subroutine iotk_write_LOGICAL1(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - LOGICAL(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_LOGICAL1 -#endif -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL2 -subroutine iotk_write_LOGICAL2(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - LOGICAL(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_LOGICAL2 -#endif -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL3 -subroutine iotk_write_LOGICAL3(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - LOGICAL(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_LOGICAL3 -#endif -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL4 -subroutine iotk_write_LOGICAL4(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - LOGICAL(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_LOGICAL4 -#endif -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER1 -subroutine iotk_write_INTEGER1(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - INTEGER(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_INTEGER1 -#endif -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER2 -subroutine iotk_write_INTEGER2(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - INTEGER(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_INTEGER2 -#endif -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER3 -subroutine iotk_write_INTEGER3(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - INTEGER(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_INTEGER3 -#endif -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER4 -subroutine iotk_write_INTEGER4(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - INTEGER(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_INTEGER4 -#endif -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL1 -subroutine iotk_write_REAL1(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - REAL(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_REAL1 -#endif -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL2 -subroutine iotk_write_REAL2(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - REAL(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_REAL2 -#endif -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL3 -subroutine iotk_write_REAL3(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - REAL(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_REAL3 -#endif -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL4 -subroutine iotk_write_REAL4(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - REAL(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_REAL4 -#endif -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX1 -subroutine iotk_write_COMPLEX1(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - COMPLEX(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_COMPLEX1 -#endif -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX2 -subroutine iotk_write_COMPLEX2(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - COMPLEX(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_COMPLEX2 -#endif -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX3 -subroutine iotk_write_COMPLEX3(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - COMPLEX(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_COMPLEX3 -#endif -# 64 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX4 -subroutine iotk_write_COMPLEX4(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - COMPLEX(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_COMPLEX4 -#endif -# 80 "iotk_attr_interf.spp" -end interface - -interface iotk_write_attr -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL1 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL1_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL1_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL1_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL1_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL1_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL1_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL1_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL1_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL1_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL1_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL1_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL1_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL1_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL1_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL1_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL1_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL2 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL2_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL2_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL2_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL2_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL2_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL2_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL2_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL2_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL2_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL2_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL2_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL2_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL2_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL2_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL2_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL2_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL3 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL3_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL3_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL3_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL3_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL3_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL3_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL3_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL3_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL3_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL3_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL3_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL3_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL3_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL3_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL3_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL3_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL4 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL4_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL4_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL4_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL4_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL4_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL4_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL4_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL4_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL4_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL4_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL4_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL4_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL4_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL4_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_LOGICAL4_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_LOGICAL4_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER1 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER1_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER1_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER1_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER1_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER1_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER1_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER1_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER1_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER1_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER1_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER1_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER1_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER1_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER1_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER1_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER1_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER2 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER2_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER2_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER2_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER2_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER2_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER2_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER2_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER2_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER2_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER2_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER2_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER2_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER2_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER2_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER2_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER2_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER3 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER3_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER3_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER3_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER3_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER3_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER3_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER3_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER3_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER3_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER3_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER3_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER3_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER3_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER3_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER3_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER3_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER4 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER4_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER4_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER4_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER4_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER4_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER4_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER4_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER4_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER4_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER4_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER4_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER4_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER4_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER4_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_INTEGER4_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_INTEGER4_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL1 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL1_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL1_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL1_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL1_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL1_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL1_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL1_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL1_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL1_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL1_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL1_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL1_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL1_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL1_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL1_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL1_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL2 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL2_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL2_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL2_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL2_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL2_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL2_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL2_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL2_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL2_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL2_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL2_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL2_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL2_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL2_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL2_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL2_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL3 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL3_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL3_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL3_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL3_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL3_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL3_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL3_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL3_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL3_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL3_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL3_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL3_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL3_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL3_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL3_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL3_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL4 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL4_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL4_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL4_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL4_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL4_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL4_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL4_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL4_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL4_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL4_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL4_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL4_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL4_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL4_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_REAL4_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_REAL4_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX1 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX1_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX1_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX1_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX1_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX1_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX1_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX1_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX1_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX1_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX1_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX1_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX1_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX1_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX1_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX1_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX1_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX2 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX2_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX2_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX2_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX2_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX2_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX2_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX2_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX2_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX2_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX2_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX2_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX2_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX2_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX2_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX2_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX2_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX3 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX3_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX3_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX3_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX3_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX3_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX3_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX3_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX3_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX3_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX3_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX3_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX3_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX3_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX3_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX3_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX3_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX4 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX4_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX4_0 -#endif -# 90 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX4_1(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX4_1 -#endif -# 90 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX4_2(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX4_2 -#endif -# 90 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX4_3(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX4_3 -#endif -# 90 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX4_4(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX4_4 -#endif -# 90 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX4_5(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX4_5 -#endif -# 90 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX4_6(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX4_6 -#endif -# 90 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_attr_COMPLEX4_7(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: val (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_COMPLEX4_7 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 87 "iotk_attr_interf.spp" -#ifdef __IOTK_CHARACTER1 -# 90 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_attr_CHARACTER1_0(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - CHARACTER(kind=this_kind,len=*), intent(in) :: val - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_CHARACTER1_0 -#endif -# 105 "iotk_attr_interf.spp" -#endif -# 108 "iotk_attr_interf.spp" -end interface - -interface iotk_scan_attr -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL1 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL1_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val -#else - LOGICAL(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL1_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL1_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL1_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL1_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL1_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL1_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL1_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL1_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL1_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL1_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL1_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL1_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL1_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL1_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL1_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL2 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL2_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val -#else - LOGICAL(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL2_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL2_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL2_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL2_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL2_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL2_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL2_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL2_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL2_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL2_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL2_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL2_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL2_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL2_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL2_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL3 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL3_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val -#else - LOGICAL(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL3_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL3_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL3_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL3_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL3_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL3_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL3_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL3_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL3_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL3_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL3_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL3_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL3_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL3_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL3_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_LOGICAL4 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL4_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val -#else - LOGICAL(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL4_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL4_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL4_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL4_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL4_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL4_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL4_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL4_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL4_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL4_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL4_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL4_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL4_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_LOGICAL4_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_LOGICAL4_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER1 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER1_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val -#else - INTEGER(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER1_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER1_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER1_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER1_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER1_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER1_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER1_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER1_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER1_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER1_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER1_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER1_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER1_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER1_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER1_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER2 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER2_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val -#else - INTEGER(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER2_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER2_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER2_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER2_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER2_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER2_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER2_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER2_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER2_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER2_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER2_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER2_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER2_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER2_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER2_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER3 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER3_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val -#else - INTEGER(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER3_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER3_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER3_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER3_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER3_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER3_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER3_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER3_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER3_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER3_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER3_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER3_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER3_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER3_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER3_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_INTEGER4 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER4_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val -#else - INTEGER(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER4_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER4_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER4_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER4_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER4_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER4_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER4_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER4_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER4_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER4_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER4_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER4_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER4_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_INTEGER4_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_INTEGER4_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL1 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL1_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val -#else - REAL(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL1_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL1_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:) -#else - REAL(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL1_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL1_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL1_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL1_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL1_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL1_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL1_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL1_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL1_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL1_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL1_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL1_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL1_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL2 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL2_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val -#else - REAL(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL2_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL2_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:) -#else - REAL(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL2_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL2_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL2_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL2_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL2_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL2_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL2_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL2_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL2_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL2_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL2_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL2_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL2_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL3 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL3_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val -#else - REAL(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL3_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL3_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:) -#else - REAL(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL3_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL3_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL3_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL3_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL3_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL3_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL3_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL3_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL3_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL3_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL3_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL3_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL3_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_REAL4 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL4_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val -#else - REAL(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL4_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL4_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:) -#else - REAL(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL4_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL4_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL4_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL4_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL4_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL4_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL4_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL4_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL4_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL4_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL4_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_REAL4_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_REAL4_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX1 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX1_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val -#else - COMPLEX(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX1_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX1_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX1_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX1_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX1_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX1_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX1_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX1_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX1_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX1_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX1_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX1_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX1_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX1_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX1_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX2 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX2_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val -#else - COMPLEX(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX2_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX2_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX2_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX2_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX2_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX2_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX2_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX2_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX2_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX2_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX2_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX2_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX2_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX2_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX2_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX3 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX3_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val -#else - COMPLEX(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX3_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX3_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX3_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX3_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX3_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX3_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX3_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX3_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX3_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX3_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX3_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX3_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX3_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX3_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX3_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_COMPLEX4 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX4_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val -#else - COMPLEX(kind=this_kind), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX4_0 -#endif -# 118 "iotk_attr_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX4_1(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX4_1 -#endif -# 118 "iotk_attr_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX4_2(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX4_2 -#endif -# 118 "iotk_attr_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX4_3(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX4_3 -#endif -# 118 "iotk_attr_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX4_4(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX4_4 -#endif -# 118 "iotk_attr_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX4_5(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX4_5 -#endif -# 118 "iotk_attr_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX4_6(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX4_6 -#endif -# 118 "iotk_attr_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_COMPLEX4_7(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: val (:,:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: val (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_COMPLEX4_7 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 115 "iotk_attr_interf.spp" -#ifdef __IOTK_CHARACTER1 -# 118 "iotk_attr_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_attr_CHARACTER1_0(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: val -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: val -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_CHARACTER1_0 -#endif -# 138 "iotk_attr_interf.spp" -#endif -# 141 "iotk_attr_interf.spp" -end interface - -end module iotk_attr_interf diff --git a/quantum_espresso/kcp/iotk/src/iotk_attr_interf.spp b/quantum_espresso/kcp/iotk/src/iotk_attr_interf.spp deleted file mode 100644 index 594dea427..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_attr_interf.spp +++ /dev/null @@ -1,144 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -module iotk_attr_interf -implicit none -private - -public :: iotk_read -public :: iotk_write -public :: iotk_write_attr -public :: iotk_scan_attr - - -interface iotk_read ->for type in $types ; do -> [[ $type == CHARACTER ]] && continue -> for kind in $kinds ; do -#ifdef __IOTK_${type}${kind} -subroutine iotk_read_${type}${kind}(val,string,index,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_${type}${kind} - ${type}(kind=this_kind), intent(inout) :: val(:) - character(len=*), intent(in) :: string - integer, intent(inout) :: index - integer, intent(out) :: ierr -end subroutine iotk_read_${type}${kind} -#endif -> done ->done -end interface - -interface iotk_write ->for type in $types ; do -> [[ $type == CHARACTER ]] && continue -> for kind in $kinds ; do -#ifdef __IOTK_${type}${kind} -subroutine iotk_write_${type}${kind}(val,string,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_${type}${kind} - ${type}(kind=this_kind), intent(in) :: val(:) -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: string -#else - character(len=*), intent(out) :: string -#endif - integer, intent(out) :: ierr -end subroutine iotk_write_${type}${kind} -#endif -> done ->done -end interface - -interface iotk_write_attr ->for type in $types ; do -> eval "LENSTAR=\$LENSTAR_$type" -> for kind in $kinds ; do -> [[ $type == CHARACTER ]] && (( kind != 1 )) && continue -#ifdef __IOTK_${type}${kind} -> for rank in $ranks ; do -> [[ $type == CHARACTER ]] && (( rank != 0 )) && continue -#if $rank <= __IOTK_MAXRANK -subroutine iotk_write_attr_${type}${kind}_${rank}(attr,name,val,dummy,first,newline,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_${type}${kind} - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - ${type}(kind=this_kind$LENSTAR), intent(in) :: val ${SHAPE[$rank]} - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: first - logical, optional, intent(in) :: newline - integer, optional, intent(out) :: ierr -end subroutine iotk_write_attr_${type}${kind}_${rank} -#endif -> done -#endif -> done ->done -end interface - -interface iotk_scan_attr ->for type in $types ; do -> eval "LENSTAR=\$LENSTAR_$type" -> for kind in $kinds ; do -> [[ $type == CHARACTER ]] && (( kind != 1 )) && continue -#ifdef __IOTK_${type}${kind} -> for rank in $ranks ; do -> [[ $type == CHARACTER ]] && (( rank != 0 )) && continue -#if $rank <= __IOTK_MAXRANK -subroutine iotk_scan_attr_${type}${kind}_${rank}(attr,name,val,dummy,found,default,eos,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_${type}${kind} - character(len=*), intent(in) :: attr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - ${type}(kind=this_kind$LENSTAR) :: val ${SHAPE[$rank]} -#else - ${type}(kind=this_kind$LENSTAR), intent(out) :: val ${SHAPE[$rank]} -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - ${type}(kind=this_kind$LENSTAR), optional, intent(in) :: default ${SHAPE[$rank]} - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_attr_${type}${kind}_${rank} -#endif -> done -#endif -> done ->done -end interface - -end module iotk_attr_interf - diff --git a/quantum_espresso/kcp/iotk/src/iotk_base.f90 b/quantum_espresso/kcp/iotk/src/iotk_base.f90 deleted file mode 100644 index e11a6686c..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_base.f90 +++ /dev/null @@ -1,316 +0,0 @@ -# 1 "iotk_base.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 27 "iotk_base.spp" - -!------------------------------------------------------------------------------! -! Inclusion of the auxiliary macros -#include "iotk_auxmacros.h" -!------------------------------------------------------------------------------! - -module iotk_base -implicit none -save - -!------------------------------------------------------------------------------! -! In this module, all names are public -! For this reason, it should not be used directly by the end user. -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Version strings and integer constants -character(16), parameter :: iotk_version = "1.1.0development" -integer, parameter :: iotk_version_major = 1 -integer, parameter :: iotk_version_minor = 1 -integer, parameter :: iotk_version_patch = 0 -character(3), parameter :: iotk_file_version = "1.0" -integer, parameter :: iotk_file_version_major = 1 -integer, parameter :: iotk_file_version_minor = 0 -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Maximum allowed rank -integer, parameter :: iotk_maxrank_hard = 7 ! Controlled by sprep preprocessing -integer, parameter :: iotk_maxrank = __IOTK_MAXRANK ! Controlled by cpp -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Default kinds, depending on compilers and compilation options for the library source -integer, parameter :: iotk_character_defkind = kind("a") -integer, parameter :: iotk_logical_defkind = kind(.true.) -integer, parameter :: iotk_integer_defkind = kind(1) -integer, parameter :: iotk_real_defkind = kind(1.0) -integer, parameter :: iotk_complex_defkind = kind(1.0) -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Kinds for the multiple interfaces -# 72 "iotk_base.spp" -#ifdef __IOTK_LOGICAL1 -integer, parameter :: iotk_LOGICAL1 = __IOTK_LOGICAL1 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_LOGICAL2 -integer, parameter :: iotk_LOGICAL2 = __IOTK_LOGICAL2 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_LOGICAL3 -integer, parameter :: iotk_LOGICAL3 = __IOTK_LOGICAL3 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_LOGICAL4 -integer, parameter :: iotk_LOGICAL4 = __IOTK_LOGICAL4 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_INTEGER1 -integer, parameter :: iotk_INTEGER1 = __IOTK_INTEGER1 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_INTEGER2 -integer, parameter :: iotk_INTEGER2 = __IOTK_INTEGER2 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_INTEGER3 -integer, parameter :: iotk_INTEGER3 = __IOTK_INTEGER3 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_INTEGER4 -integer, parameter :: iotk_INTEGER4 = __IOTK_INTEGER4 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_REAL1 -integer, parameter :: iotk_REAL1 = __IOTK_REAL1 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_REAL2 -integer, parameter :: iotk_REAL2 = __IOTK_REAL2 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_REAL3 -integer, parameter :: iotk_REAL3 = __IOTK_REAL3 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_REAL4 -integer, parameter :: iotk_REAL4 = __IOTK_REAL4 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_COMPLEX1 -integer, parameter :: iotk_COMPLEX1 = __IOTK_COMPLEX1 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_COMPLEX2 -integer, parameter :: iotk_COMPLEX2 = __IOTK_COMPLEX2 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_COMPLEX3 -integer, parameter :: iotk_COMPLEX3 = __IOTK_COMPLEX3 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_COMPLEX4 -integer, parameter :: iotk_COMPLEX4 = __IOTK_COMPLEX4 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_CHARACTER1 -integer, parameter :: iotk_CHARACTER1 = __IOTK_CHARACTER1 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_CHARACTER2 -integer, parameter :: iotk_CHARACTER2 = __IOTK_CHARACTER2 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_CHARACTER3 -integer, parameter :: iotk_CHARACTER3 = __IOTK_CHARACTER3 -#endif -# 72 "iotk_base.spp" -#ifdef __IOTK_CHARACTER4 -integer, parameter :: iotk_CHARACTER4 = __IOTK_CHARACTER4 -#endif -# 77 "iotk_base.spp" -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Kind for the header integer (number of digits in (iotk_ncontrol+1)*(iotk_taglenx+1)) -integer, parameter :: iotk_header_kind = __IOTK_HEADER_KIND -!------------------------------------------------------------------------------! - -#ifdef __IOTK_STREAMS -!------------------------------------------------------------------------------! -! Kinds for stream i/o compatibility -integer, parameter :: iotk_record_kind = __IOTK_RECORD_KIND -integer, parameter :: iotk_record_length = __IOTK_RECORD_LENGTH -!------------------------------------------------------------------------------! -#endif - -!------------------------------------------------------------------------------! -! Special characters -character, parameter :: iotk_newline = __IOTK_NEWLINE -character, parameter :: iotk_eos = __IOTK_EOS -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Max number of controls -integer, parameter :: iotk_ncontrol = 255 ! (2**8-1) -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Map of controls into XML tags -! control = 1 < > -! control = 2 -! control = 3 < /> -! control = 4 -! control = 5 -! control = 128 is a special tag for binary files (continuation tag) -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Max lengths for strings -integer, parameter :: iotk_taglenx = 65535 ! (2**16-1) -integer, parameter :: iotk_namlenx = 256 -integer, parameter :: iotk_attlenx = iotk_taglenx - iotk_namlenx - 1 ! for space -integer, parameter :: iotk_vallenx = 32768 -integer, parameter :: iotk_linlenx = 4096 -integer, parameter :: iotk_fillenx = 1024 -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Max number of arguments for the iotk tool -integer, parameter :: iotk_maxargs = __IOTK_MAXARGS -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Alphabet -character(26), parameter :: lowalphabet = "abcdefghijklmnopqrstuvwxyz" -character(26), parameter :: upalphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" -character(52), parameter :: alphabet = lowalphabet//upalphabet -character(53), parameter :: alphabet_ = alphabet//"_" -character(10), parameter :: numbers = "0123456789" -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! List of characters which are not separators in a dat or attribute array -character(66), parameter :: not_separator = alphabet_//numbers//"+-." -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Rules for names -character(54), parameter :: iotk_namcharfirst = alphabet//"_:" -character(66), parameter :: iotk_namchar = iotk_namcharfirst//numbers//".-" -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Internal type dealing with io units -type iotk_unit - integer :: unit ! fortran unit - character(iotk_namlenx) :: root ! name of the root tag - logical :: skip_root ! if true, root tag is not written automatically - logical :: raw ! if true, the file is raw data - integer :: level ! the hierarchical level inside the file - logical :: close_at_end ! if true, the file has to be fortran-closed when iotk_close_* is called - type (iotk_unit), pointer :: son ! a pointer to the son in the multi-file model - type (iotk_unit), pointer :: parent ! a pointer to the parent in the multi-file model -end type iotk_unit -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Special type used to force optional argument labelling. -type iotk_dummytype - integer :: dummy -end type iotk_dummytype -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Internal type dealing with error messages -type iotk_error - character, pointer :: str(:) -end type iotk_error -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Max length of a line in the error message. Any longer line will be cut -integer, parameter :: iotk_error_linelength = 120 -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Maximum number of errors which can be handled at the same time -integer, parameter :: iotk_error_pool_size = 100 -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Static pool of errors -type(iotk_error) :: iotk_error_pool (iotk_error_pool_size) -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Flags concerning the error pool: -! If true, that element of the pool is in usage -logical :: iotk_error_pool_used (iotk_error_pool_size) = .false. -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! These integers are set in increasing order to trace the order errors are raised -! They are then used to eliminate old errors if the user forgets to do that -integer :: iotk_error_pool_order (iotk_error_pool_size) = 0 -!------------------------------------------------------------------------------! - -! The following options can be modified runtime -! X_def is the default value for variable X - -!------------------------------------------------------------------------------! -! Margins for unit search -integer, parameter :: iotk_unitmin_def = __IOTK_UNITMIN -integer :: iotk_unitmin = iotk_unitmin_def -integer, parameter :: iotk_unitmax_def = __IOTK_UNITMAX -integer :: iotk_unitmax = iotk_unitmax_def -integer, parameter :: iotk_error_unit_def = __IOTK_ERROR_UNIT -integer :: iotk_error_unit = iotk_error_unit_def -integer, parameter :: iotk_output_unit_def = __IOTK_OUTPUT_UNIT -integer :: iotk_output_unit = iotk_output_unit_def -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Size of the buffer for iotk_getline -! (it is intended for efficiency; the total length of a line should be <= iotk_linlenx) -integer, parameter :: iotk_getline_buffer_def = 1024 -integer :: iotk_getline_buffer = iotk_getline_buffer_def -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Parameters for text file beautyfier -! Length of a line: -integer, parameter :: iotk_linlen_def = 128 -integer :: iotk_linlen = iotk_linlen_def -! Number of spaces for each indentation -integer, parameter :: iotk_indent_def = 2 -integer :: iotk_indent = iotk_indent_def -! Maximum number of spaces in indentation -integer, parameter :: iotk_maxindent_def = 12 -integer :: iotk_maxindent = iotk_maxindent_def -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! If true, exhausting the error pool causes an overflow warning -logical, parameter :: iotk_error_warn_overflow_def = .false. -logical :: iotk_error_warn_overflow = iotk_error_warn_overflow_def -!------------------------------------------------------------------------------! - -end module iotk_base diff --git a/quantum_espresso/kcp/iotk/src/iotk_base.spp b/quantum_espresso/kcp/iotk/src/iotk_base.spp deleted file mode 100644 index 0c6c215de..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_base.spp +++ /dev/null @@ -1,244 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< - -!------------------------------------------------------------------------------! -! Inclusion of the auxiliary macros -#include "iotk_auxmacros.h" -!------------------------------------------------------------------------------! - -module iotk_base -implicit none -save - -!------------------------------------------------------------------------------! -! In this module, all names are public -! For this reason, it should not be used directly by the end user. -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Version strings and integer constants -character(${#__IOTK_VERSION}), parameter :: iotk_version = "$__IOTK_VERSION" -integer, parameter :: iotk_version_major = $__IOTK_VERSION_MAJOR -integer, parameter :: iotk_version_minor = $__IOTK_VERSION_MINOR -integer, parameter :: iotk_version_patch = $__IOTK_VERSION_PATCH -character(${#__IOTK_FILE_VERSION}), parameter :: iotk_file_version = "$__IOTK_FILE_VERSION" -integer, parameter :: iotk_file_version_major = ${__IOTK_FILE_VERSION%.*} -integer, parameter :: iotk_file_version_minor = ${__IOTK_FILE_VERSION#*.} -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Maximum allowed rank -integer, parameter :: iotk_maxrank_hard = $maxrank ! Controlled by sprep preprocessing -integer, parameter :: iotk_maxrank = __IOTK_MAXRANK ! Controlled by cpp -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Default kinds, depending on compilers and compilation options for the library source -integer, parameter :: iotk_character_defkind = kind("a") -integer, parameter :: iotk_logical_defkind = kind(.true.) -integer, parameter :: iotk_integer_defkind = kind(1) -integer, parameter :: iotk_real_defkind = kind(1.0) -integer, parameter :: iotk_complex_defkind = kind(1.0) -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Kinds for the multiple interfaces -> for type in $types ; do -> for kind in $kinds ; do -#ifdef __IOTK_${type}${kind} -integer, parameter :: iotk_${type}${kind} = __IOTK_${type}${kind} -#endif -> done -> done -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Kind for the header integer (number of digits in (iotk_ncontrol+1)*(iotk_taglenx+1)) -integer, parameter :: iotk_header_kind = __IOTK_HEADER_KIND -!------------------------------------------------------------------------------! - -#ifdef __IOTK_STREAMS -!------------------------------------------------------------------------------! -! Kinds for stream i/o compatibility -integer, parameter :: iotk_record_kind = __IOTK_RECORD_KIND -integer, parameter :: iotk_record_length = __IOTK_RECORD_LENGTH -!------------------------------------------------------------------------------! -#endif - -!------------------------------------------------------------------------------! -! Special characters -character, parameter :: iotk_newline = __IOTK_NEWLINE -character, parameter :: iotk_eos = __IOTK_EOS -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Max number of controls -integer, parameter :: iotk_ncontrol = 255 ! (2**8-1) -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Map of controls into XML tags -! control = 1 < > -! control = 2 -! control = 3 < /> -! control = 4 -! control = 5 -! control = 128 is a special tag for binary files (continuation tag) -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Max lengths for strings -integer, parameter :: iotk_taglenx = 65535 ! (2**16-1) -integer, parameter :: iotk_namlenx = 256 -integer, parameter :: iotk_attlenx = iotk_taglenx - iotk_namlenx - 1 ! for space -integer, parameter :: iotk_vallenx = 32768 -integer, parameter :: iotk_linlenx = 4096 -integer, parameter :: iotk_fillenx = 1024 -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Max number of arguments for the iotk tool -integer, parameter :: iotk_maxargs = __IOTK_MAXARGS -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Alphabet -character(26), parameter :: lowalphabet = "abcdefghijklmnopqrstuvwxyz" -character(26), parameter :: upalphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" -character(52), parameter :: alphabet = lowalphabet//upalphabet -character(53), parameter :: alphabet_ = alphabet//"_" -character(10), parameter :: numbers = "0123456789" -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! List of characters which are not separators in a dat or attribute array -character(66), parameter :: not_separator = alphabet_//numbers//"+-." -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Rules for names -character(54), parameter :: iotk_namcharfirst = alphabet//"_:" -character(66), parameter :: iotk_namchar = iotk_namcharfirst//numbers//".-" -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Internal type dealing with io units -type iotk_unit - integer :: unit ! fortran unit - character(iotk_namlenx) :: root ! name of the root tag - logical :: skip_root ! if true, root tag is not written automatically - logical :: raw ! if true, the file is raw data - integer :: level ! the hierarchical level inside the file - logical :: close_at_end ! if true, the file has to be fortran-closed when iotk_close_* is called - type (iotk_unit), pointer :: son ! a pointer to the son in the multi-file model - type (iotk_unit), pointer :: parent ! a pointer to the parent in the multi-file model -end type iotk_unit -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Special type used to force optional argument labelling. -type iotk_dummytype - integer :: dummy -end type iotk_dummytype -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Internal type dealing with error messages -type iotk_error - character, pointer :: str(:) -end type iotk_error -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Max length of a line in the error message. Any longer line will be cut -integer, parameter :: iotk_error_linelength = 120 -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Maximum number of errors which can be handled at the same time -integer, parameter :: iotk_error_pool_size = 100 -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Static pool of errors -type(iotk_error) :: iotk_error_pool (iotk_error_pool_size) -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Flags concerning the error pool: -! If true, that element of the pool is in usage -logical :: iotk_error_pool_used (iotk_error_pool_size) = .false. -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! These integers are set in increasing order to trace the order errors are raised -! They are then used to eliminate old errors if the user forgets to do that -integer :: iotk_error_pool_order (iotk_error_pool_size) = 0 -!------------------------------------------------------------------------------! - -! The following options can be modified runtime -! X_def is the default value for variable X - -!------------------------------------------------------------------------------! -! Margins for unit search -integer, parameter :: iotk_unitmin_def = __IOTK_UNITMIN -integer :: iotk_unitmin = iotk_unitmin_def -integer, parameter :: iotk_unitmax_def = __IOTK_UNITMAX -integer :: iotk_unitmax = iotk_unitmax_def -integer, parameter :: iotk_error_unit_def = __IOTK_ERROR_UNIT -integer :: iotk_error_unit = iotk_error_unit_def -integer, parameter :: iotk_output_unit_def = __IOTK_OUTPUT_UNIT -integer :: iotk_output_unit = iotk_output_unit_def -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Size of the buffer for iotk_getline -! (it is intended for efficiency; the total length of a line should be <= iotk_linlenx) -integer, parameter :: iotk_getline_buffer_def = 1024 -integer :: iotk_getline_buffer = iotk_getline_buffer_def -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! Parameters for text file beautyfier -! Length of a line: -integer, parameter :: iotk_linlen_def = 128 -integer :: iotk_linlen = iotk_linlen_def -! Number of spaces for each indentation -integer, parameter :: iotk_indent_def = 2 -integer :: iotk_indent = iotk_indent_def -! Maximum number of spaces in indentation -integer, parameter :: iotk_maxindent_def = 12 -integer :: iotk_maxindent = iotk_maxindent_def -!------------------------------------------------------------------------------! - -!------------------------------------------------------------------------------! -! If true, exhausting the error pool causes an overflow warning -logical, parameter :: iotk_error_warn_overflow_def = .false. -logical :: iotk_error_warn_overflow = iotk_error_warn_overflow_def -!------------------------------------------------------------------------------! - -end module iotk_base diff --git a/quantum_espresso/kcp/iotk/src/iotk_copy.f90 b/quantum_espresso/kcp/iotk/src/iotk_copy.f90 deleted file mode 100644 index c400d7d77..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_copy.f90 +++ /dev/null @@ -1,50 +0,0 @@ -program main -use iotk_module -use iotk_files_interf -implicit none - -character(500) :: source,dest -character(iotk_namlenx) :: root -character(iotk_attlenx) :: attr -character :: key - -logical :: binary_dest,binary_source -integer :: maxsize -#ifdef __MPI -integer :: ierr -#endif - -#ifdef __MPI -call MPI_init(ierr) -#endif - -write(*,*) "Name of input file:" -read(*,*) source -!write(*,*) "Textual or Binary:" -!read(*,*) key -binary_source = .false. -!if(key=="B" .or. key=="b") binary_source = .true. -call iotk_magic(trim(source),binary=binary_source) -write(*,*) "Name of output file:" -read(*,*) dest -write(*,*) "Textual or Binary:" -read(*,*) key -binary_dest = .false. -maxsize = -1 -if(key=="B" .or. key=="b") then - binary_dest = .true. -else - write(*,*) "Maximum data size (-1 for unlimited size)" - read(*,*) maxsize -end if - -call iotk_open_read(60, trim(source),binary=binary_source,root=root,attr=attr) -call iotk_open_write(61,trim(dest), binary=binary_dest, root=root,attr=attr) -call iotk_copy_tag(60,61,maxsize=maxsize) -call iotk_close_write(61) -call iotk_close_read(60) - -#ifdef __MPI -call MPI_Finalize(ierr) -#endif -end program main diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+CHARACTER1_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+CHARACTER1_0.f90 deleted file mode 100644 index 808b67b53..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+CHARACTER1_0.f90 +++ /dev/null @@ -1,1568 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_CHARACTER1 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_CHARACTER1_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER (kind=this_kind,len=*), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 112 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)),allocatable :: dattmp(:) - character(len=iotk_linlenx) :: linetmp -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("CHARACTER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 166 "iotk_dat.spp" - call iotk_write_attr(lattr,"len",len(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 168 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 271 "iotk_dat.spp" - write(lunit,"(a)",iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 287 "iotk_dat.spp" - do itmp = 1 , size(dattmp) - call iotk_deescape(linetmp,dattmp(itmp)) - write(lunit,"(a)",iostat=iostat) linetmp(1:iotk_strlen(linetmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 291 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end do -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_CHARACTER1_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_CHARACTER1_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 697 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"CHARACTER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","CHARACTER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 734 "iotk_dat.spp" - if(rlen ==-1) rlen = len(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_CHARACTER1_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_CHARACTER1_0 - write(0,*) -end subroutine iotk_dat_dummy_CHARACTER1_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_CHARACTER1 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_CHARACTER1_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER (kind=this_kind,len=*), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 112 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)),allocatable :: dattmp(:) - character(len=iotk_linlenx) :: linetmp -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("CHARACTER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 166 "iotk_dat.spp" - call iotk_write_attr(lattr,"len",len(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 168 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 245 "iotk_dat.spp" - call iotk_private_pack_CHARACTER1(dattmp,dat,size(dattmp),len(dattmp)) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 271 "iotk_dat.spp" - write(lunit,"(a)",iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 287 "iotk_dat.spp" - do itmp = 1 , size(dattmp) - call iotk_deescape(linetmp,dattmp(itmp)) - write(lunit,"(a)",iostat=iostat) linetmp(1:iotk_strlen(linetmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 291 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end do -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_CHARACTER1_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_CHARACTER1(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 361 "iotk_dat.spp" - CHARACTER (kind=this_kind, len=rlen) :: dattmp(ubound(dat,1)) -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 386 "iotk_dat.spp" - if(binary) then - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dattmp(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dattmp -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 394 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 394 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 394 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dattmp,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 401 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dattmp(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dattmp -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 412 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 412 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 412 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,"(a)",iostat=iostat) ( dattmp(j), j=1,ubound(dat,1) ) -#else - read(lunit,"(a)",iostat=iostat) dattmp -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 424 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 424 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 424 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*, iostat=iostat) ( dattmp(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*, iostat=iostat) dattmp -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 434 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 434 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 434 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - iostat = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 443 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 454 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 454 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 454 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 459 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 464 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 464 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 464 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 469 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 469 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 469 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - index = index + 1 - call iotk_escape(to=dattmp(index),from=line(1:nexttag - 1)) - if(iotk_strlen(dattmp(index)) < len(dattmp)) dattmp(index)(iotk_strlen(dattmp(index))+1:) = " " - if(index == size(dat)) exit - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 478 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 478 "iotk_dat.spp" -call iotk_error_msg(ierr,'Missing dat') - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dattmp(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dattmp -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 489 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 489 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 489 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if - if(len(dattmp) <= len(dat)) then - dat (:) = dattmp (:) - else - dat (:) = dattmp (:) (1:len(dat)) - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_CHARACTER1 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_CHARACTER1_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 697 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"CHARACTER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","CHARACTER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 734 "iotk_dat.spp" - if(rlen ==-1) rlen = len(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 748 "iotk_dat.spp" - call iotk_private_pack_CHARACTER1(dat,tmpdat,size(tmpdat),len(tmpdat)) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_CHARACTER1_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_CHARACTER1_1 - write(0,*) -end subroutine iotk_dat_dummy_CHARACTER1_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_CHARACTER1 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_CHARACTER1_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER (kind=this_kind,len=*), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 112 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)),allocatable :: dattmp(:) - character(len=iotk_linlenx) :: linetmp -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("CHARACTER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 166 "iotk_dat.spp" - call iotk_write_attr(lattr,"len",len(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 168 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 245 "iotk_dat.spp" - call iotk_private_pack_CHARACTER1(dattmp,dat,size(dattmp),len(dattmp)) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 271 "iotk_dat.spp" - write(lunit,"(a)",iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 287 "iotk_dat.spp" - do itmp = 1 , size(dattmp) - call iotk_deescape(linetmp,dattmp(itmp)) - write(lunit,"(a)",iostat=iostat) linetmp(1:iotk_strlen(linetmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 291 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end do -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_CHARACTER1_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_CHARACTER1_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:,:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 697 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"CHARACTER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","CHARACTER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 734 "iotk_dat.spp" - if(rlen ==-1) rlen = len(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 748 "iotk_dat.spp" - call iotk_private_pack_CHARACTER1(dat,tmpdat,size(tmpdat),len(tmpdat)) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_CHARACTER1_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_CHARACTER1_2 - write(0,*) -end subroutine iotk_dat_dummy_CHARACTER1_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+CHARACTER1_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+CHARACTER1_3.f90 deleted file mode 100644 index 7b4417aea..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+CHARACTER1_3.f90 +++ /dev/null @@ -1,1349 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_CHARACTER1 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_CHARACTER1_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER (kind=this_kind,len=*), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 112 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)),allocatable :: dattmp(:) - character(len=iotk_linlenx) :: linetmp -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("CHARACTER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 166 "iotk_dat.spp" - call iotk_write_attr(lattr,"len",len(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 168 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 245 "iotk_dat.spp" - call iotk_private_pack_CHARACTER1(dattmp,dat,size(dattmp),len(dattmp)) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 271 "iotk_dat.spp" - write(lunit,"(a)",iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 287 "iotk_dat.spp" - do itmp = 1 , size(dattmp) - call iotk_deescape(linetmp,dattmp(itmp)) - write(lunit,"(a)",iostat=iostat) linetmp(1:iotk_strlen(linetmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 291 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end do -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_CHARACTER1_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_CHARACTER1_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:,:,:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 697 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"CHARACTER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","CHARACTER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 734 "iotk_dat.spp" - if(rlen ==-1) rlen = len(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 748 "iotk_dat.spp" - call iotk_private_pack_CHARACTER1(dat,tmpdat,size(tmpdat),len(tmpdat)) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_CHARACTER1_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_CHARACTER1_3 - write(0,*) -end subroutine iotk_dat_dummy_CHARACTER1_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_CHARACTER1 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_CHARACTER1_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER (kind=this_kind,len=*), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 112 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)),allocatable :: dattmp(:) - character(len=iotk_linlenx) :: linetmp -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("CHARACTER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 166 "iotk_dat.spp" - call iotk_write_attr(lattr,"len",len(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 168 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 245 "iotk_dat.spp" - call iotk_private_pack_CHARACTER1(dattmp,dat,size(dattmp),len(dattmp)) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 271 "iotk_dat.spp" - write(lunit,"(a)",iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 287 "iotk_dat.spp" - do itmp = 1 , size(dattmp) - call iotk_deescape(linetmp,dattmp(itmp)) - write(lunit,"(a)",iostat=iostat) linetmp(1:iotk_strlen(linetmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 291 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end do -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_CHARACTER1_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_CHARACTER1_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:,:,:,:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 697 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"CHARACTER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","CHARACTER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 734 "iotk_dat.spp" - if(rlen ==-1) rlen = len(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 748 "iotk_dat.spp" - call iotk_private_pack_CHARACTER1(dat,tmpdat,size(tmpdat),len(tmpdat)) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_CHARACTER1_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_CHARACTER1_4 - write(0,*) -end subroutine iotk_dat_dummy_CHARACTER1_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_CHARACTER1 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_CHARACTER1_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER (kind=this_kind,len=*), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 112 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)),allocatable :: dattmp(:) - character(len=iotk_linlenx) :: linetmp -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("CHARACTER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 166 "iotk_dat.spp" - call iotk_write_attr(lattr,"len",len(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 168 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 245 "iotk_dat.spp" - call iotk_private_pack_CHARACTER1(dattmp,dat,size(dattmp),len(dattmp)) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 271 "iotk_dat.spp" - write(lunit,"(a)",iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 287 "iotk_dat.spp" - do itmp = 1 , size(dattmp) - call iotk_deescape(linetmp,dattmp(itmp)) - write(lunit,"(a)",iostat=iostat) linetmp(1:iotk_strlen(linetmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 291 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end do -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_CHARACTER1_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_CHARACTER1_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:,:,:,:,:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 697 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"CHARACTER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","CHARACTER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 734 "iotk_dat.spp" - if(rlen ==-1) rlen = len(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 748 "iotk_dat.spp" - call iotk_private_pack_CHARACTER1(dat,tmpdat,size(tmpdat),len(tmpdat)) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_CHARACTER1_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_CHARACTER1_5 - write(0,*) -end subroutine iotk_dat_dummy_CHARACTER1_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+CHARACTER1_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+CHARACTER1_6.f90 deleted file mode 100644 index 42fa7af2a..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+CHARACTER1_6.f90 +++ /dev/null @@ -1,903 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_CHARACTER1 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_CHARACTER1_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER (kind=this_kind,len=*), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 112 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)),allocatable :: dattmp(:) - character(len=iotk_linlenx) :: linetmp -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("CHARACTER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 166 "iotk_dat.spp" - call iotk_write_attr(lattr,"len",len(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 168 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 245 "iotk_dat.spp" - call iotk_private_pack_CHARACTER1(dattmp,dat,size(dattmp),len(dattmp)) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 271 "iotk_dat.spp" - write(lunit,"(a)",iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 287 "iotk_dat.spp" - do itmp = 1 , size(dattmp) - call iotk_deescape(linetmp,dattmp(itmp)) - write(lunit,"(a)",iostat=iostat) linetmp(1:iotk_strlen(linetmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 291 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end do -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_CHARACTER1_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_CHARACTER1_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:,:,:,:,:,:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 697 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"CHARACTER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","CHARACTER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 734 "iotk_dat.spp" - if(rlen ==-1) rlen = len(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 748 "iotk_dat.spp" - call iotk_private_pack_CHARACTER1(dat,tmpdat,size(tmpdat),len(tmpdat)) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_CHARACTER1_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_CHARACTER1_6 - write(0,*) -end subroutine iotk_dat_dummy_CHARACTER1_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_CHARACTER1 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_CHARACTER1_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER (kind=this_kind,len=*), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 112 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)),allocatable :: dattmp(:) - character(len=iotk_linlenx) :: linetmp -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("CHARACTER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 166 "iotk_dat.spp" - call iotk_write_attr(lattr,"len",len(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 168 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 245 "iotk_dat.spp" - call iotk_private_pack_CHARACTER1(dattmp,dat,size(dattmp),len(dattmp)) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 271 "iotk_dat.spp" - write(lunit,"(a)",iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 287 "iotk_dat.spp" - do itmp = 1 , size(dattmp) - call iotk_deescape(linetmp,dattmp(itmp)) - write(lunit,"(a)",iostat=iostat) linetmp(1:iotk_strlen(linetmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 291 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end do -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_CHARACTER1_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_CHARACTER1_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:,:,:,:,:,:,:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 697 "iotk_dat.spp" - CHARACTER (kind=this_kind,len=len(dat)), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"CHARACTER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","CHARACTER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 734 "iotk_dat.spp" - if(rlen ==-1) rlen = len(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 748 "iotk_dat.spp" - call iotk_private_pack_CHARACTER1(dat,tmpdat,size(tmpdat),len(tmpdat)) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_CHARACTER1_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_CHARACTER1_7 - write(0,*) -end subroutine iotk_dat_dummy_CHARACTER1_7 - - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX1_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX1_0.f90 deleted file mode 100644 index 447b897d1..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX1_0.f90 +++ /dev/null @@ -1,1713 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX1 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX1_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX1_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX1_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat -#else - COMPLEX(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX1_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX1_0 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX1_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX1 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX1_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX1_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_COMPLEX1(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX2 - COMPLEX (kind=iotk_COMPLEX2), allocatable :: dat2 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX3 - COMPLEX (kind=iotk_COMPLEX3), allocatable :: dat3 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX4 - COMPLEX (kind=iotk_COMPLEX4), allocatable :: dat4 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX2 - case(kind(dat2)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat2(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat2,ierr=ierr) - if(ierr/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat2(i), i=1,ubound(dat2,1) ) - if(iostat/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 565 "iotk_dat.spp" - dat = cmplx(dat2,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat2) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX3 - case(kind(dat3)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat3(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat3,ierr=ierr) - if(ierr/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat3(i), i=1,ubound(dat3,1) ) - if(iostat/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 565 "iotk_dat.spp" - dat = cmplx(dat3,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat3) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX4 - case(kind(dat4)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat4(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat4,ierr=ierr) - if(ierr/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat4(i), i=1,ubound(dat4,1) ) - if(iostat/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 565 "iotk_dat.spp" - dat = cmplx(dat4,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat4) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading COMPLEX data') - return - end if -# 641 "iotk_dat.spp" - if(index == 2 * size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_COMPLEX1 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX1_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX1_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX1_1 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX1_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX1 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX1_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX1_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX1_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX1_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX1_2 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX1_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX1_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX1_3.f90 deleted file mode 100644 index 6f6d3e3d3..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX1_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX1 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX1_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX1_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX1_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX1_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX1_3 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX1_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX1 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX1_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX1_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX1_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX1_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX1_4 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX1_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX1 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX1_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX1_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX1_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX1_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX1_5 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX1_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX1_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX1_6.f90 deleted file mode 100644 index 81c239f9b..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX1_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX1 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX1_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX1_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX1_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX1_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX1_6 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX1_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX1 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX1_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX1_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX1_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX1_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX1_7 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX1_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX2_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX2_0.f90 deleted file mode 100644 index 9973601ef..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX2_0.f90 +++ /dev/null @@ -1,1713 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX2 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX2_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX2_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX2_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat -#else - COMPLEX(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX2_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX2_0 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX2_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX2 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX2_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX2_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_COMPLEX2(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX1 - COMPLEX (kind=iotk_COMPLEX1), allocatable :: dat1 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX3 - COMPLEX (kind=iotk_COMPLEX3), allocatable :: dat3 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX4 - COMPLEX (kind=iotk_COMPLEX4), allocatable :: dat4 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX1 - case(kind(dat1)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat1(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat1,ierr=ierr) - if(ierr/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat1(i), i=1,ubound(dat1,1) ) - if(iostat/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 565 "iotk_dat.spp" - dat = cmplx(dat1,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat1) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX3 - case(kind(dat3)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat3(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat3,ierr=ierr) - if(ierr/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat3(i), i=1,ubound(dat3,1) ) - if(iostat/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 565 "iotk_dat.spp" - dat = cmplx(dat3,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat3) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX4 - case(kind(dat4)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat4(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat4,ierr=ierr) - if(ierr/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat4(i), i=1,ubound(dat4,1) ) - if(iostat/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 565 "iotk_dat.spp" - dat = cmplx(dat4,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat4) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading COMPLEX data') - return - end if -# 641 "iotk_dat.spp" - if(index == 2 * size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_COMPLEX2 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX2_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX2_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX2_1 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX2_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX2 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX2_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX2_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX2_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX2_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX2_2 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX2_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX2_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX2_3.f90 deleted file mode 100644 index 6c550760a..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX2_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX2 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX2_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX2_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX2_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX2_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX2_3 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX2_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX2 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX2_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX2_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX2_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX2_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX2_4 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX2_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX2 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX2_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX2_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX2_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX2_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX2_5 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX2_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX2_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX2_6.f90 deleted file mode 100644 index f821bd8df..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX2_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX2 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX2_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX2_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX2_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX2_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX2_6 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX2_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX2 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX2_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX2_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX2_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX2_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX2_7 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX2_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX3_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX3_0.f90 deleted file mode 100644 index ea8a525cd..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX3_0.f90 +++ /dev/null @@ -1,1713 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX3 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX3_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX3_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX3_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat -#else - COMPLEX(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX3_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX3_0 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX3_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX3 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX3_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX3_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_COMPLEX3(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX1 - COMPLEX (kind=iotk_COMPLEX1), allocatable :: dat1 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX2 - COMPLEX (kind=iotk_COMPLEX2), allocatable :: dat2 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX4 - COMPLEX (kind=iotk_COMPLEX4), allocatable :: dat4 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX1 - case(kind(dat1)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat1(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat1,ierr=ierr) - if(ierr/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat1(i), i=1,ubound(dat1,1) ) - if(iostat/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 565 "iotk_dat.spp" - dat = cmplx(dat1,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat1) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX2 - case(kind(dat2)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat2(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat2,ierr=ierr) - if(ierr/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat2(i), i=1,ubound(dat2,1) ) - if(iostat/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 565 "iotk_dat.spp" - dat = cmplx(dat2,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat2) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX4 - case(kind(dat4)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat4(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat4,ierr=ierr) - if(ierr/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat4(i), i=1,ubound(dat4,1) ) - if(iostat/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 565 "iotk_dat.spp" - dat = cmplx(dat4,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat4) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading COMPLEX data') - return - end if -# 641 "iotk_dat.spp" - if(index == 2 * size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_COMPLEX3 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX3_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX3_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX3_1 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX3_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX3 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX3_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX3_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX3_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX3_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX3_2 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX3_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX3_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX3_3.f90 deleted file mode 100644 index 641dd79f7..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX3_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX3 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX3_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX3_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX3_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX3_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX3_3 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX3_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX3 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX3_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX3_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX3_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX3_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX3_4 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX3_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX3 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX3_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX3_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX3_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX3_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX3_5 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX3_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX3_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX3_6.f90 deleted file mode 100644 index 59134cf3c..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX3_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX3 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX3_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX3_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX3_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX3_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX3_6 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX3_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX3 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX3_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX3_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX3_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX3_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX3_7 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX3_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX4_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX4_0.f90 deleted file mode 100644 index d9f0386d4..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX4_0.f90 +++ /dev/null @@ -1,1713 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX4 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX4_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX4_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX4_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat -#else - COMPLEX(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX4_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX4_0 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX4_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX4 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX4_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX4_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_COMPLEX4(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX1 - COMPLEX (kind=iotk_COMPLEX1), allocatable :: dat1 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX2 - COMPLEX (kind=iotk_COMPLEX2), allocatable :: dat2 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX3 - COMPLEX (kind=iotk_COMPLEX3), allocatable :: dat3 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX1 - case(kind(dat1)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat1(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat1,ierr=ierr) - if(ierr/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat1(i), i=1,ubound(dat1,1) ) - if(iostat/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 565 "iotk_dat.spp" - dat = cmplx(dat1,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat1) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX2 - case(kind(dat2)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat2(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat2,ierr=ierr) - if(ierr/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat2(i), i=1,ubound(dat2,1) ) - if(iostat/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 565 "iotk_dat.spp" - dat = cmplx(dat2,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat2) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_COMPLEX3 - case(kind(dat3)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat3(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat3,ierr=ierr) - if(ierr/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat3(i), i=1,ubound(dat3,1) ) - if(iostat/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 565 "iotk_dat.spp" - dat = cmplx(dat3,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat3) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading COMPLEX data') - return - end if -# 641 "iotk_dat.spp" - if(index == 2 * size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_COMPLEX4 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX4_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX4_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX4_1 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX4_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX4 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX4_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX4_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX4_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX4_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX4_2 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX4_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX4_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX4_3.f90 deleted file mode 100644 index 72da7720e..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX4_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX4 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX4_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX4_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX4_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX4_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX4_3 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX4_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX4 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX4_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX4_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX4_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX4_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX4_4 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX4_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX4 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX4_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX4_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX4_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX4_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX4_5 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX4_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX4_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX4_6.f90 deleted file mode 100644 index b7d50afa5..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+COMPLEX4_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX4 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX4_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX4_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX4_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX4_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX4_6 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX4_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_COMPLEX4 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_COMPLEX4_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - COMPLEX (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("COMPLEX"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_COMPLEX4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("COMPLEX",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_COMPLEX4_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_COMPLEX4_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - COMPLEX (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"COMPLEX") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","COMPLEX") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_COMPLEX4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_COMPLEX4_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_COMPLEX4_7 - write(0,*) -end subroutine iotk_dat_dummy_COMPLEX4_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER1_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER1_0.f90 deleted file mode 100644 index f0801e397..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER1_0.f90 +++ /dev/null @@ -1,1713 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER1 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER1_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER1_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER1_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat -#else - INTEGER(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER1_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER1_0 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER1_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER1 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER1_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER1_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_INTEGER1(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_INTEGER2 - INTEGER (kind=iotk_INTEGER2), allocatable :: dat2 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_INTEGER3 - INTEGER (kind=iotk_INTEGER3), allocatable :: dat3 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_INTEGER4 - INTEGER (kind=iotk_INTEGER4), allocatable :: dat4 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_INTEGER2 - case(kind(dat2)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat2(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat2,ierr=ierr) - if(ierr/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat2(i), i=1,ubound(dat2,1) ) - if(iostat/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 569 "iotk_dat.spp" - dat = int(dat2,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat2) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_INTEGER3 - case(kind(dat3)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat3(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat3,ierr=ierr) - if(ierr/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat3(i), i=1,ubound(dat3,1) ) - if(iostat/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 569 "iotk_dat.spp" - dat = int(dat3,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat3) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_INTEGER4 - case(kind(dat4)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat4(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat4,ierr=ierr) - if(ierr/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat4(i), i=1,ubound(dat4,1) ) - if(iostat/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 569 "iotk_dat.spp" - dat = int(dat4,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat4) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading INTEGER data') - return - end if -# 643 "iotk_dat.spp" - if(index == size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_INTEGER1 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER1_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER1_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER1_1 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER1_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER1 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER1_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER1_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER1_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER1_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER1_2 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER1_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER1_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER1_3.f90 deleted file mode 100644 index 00b24dfe2..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER1_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER1 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER1_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER1_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER1_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER1_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER1_3 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER1_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER1 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER1_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER1_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER1_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER1_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER1_4 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER1_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER1 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER1_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER1_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER1_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER1_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER1_5 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER1_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER1_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER1_6.f90 deleted file mode 100644 index acab6f2e2..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER1_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER1 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER1_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER1_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER1_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER1_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER1_6 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER1_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER1 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER1_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER1_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER1_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER1_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER1_7 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER1_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER2_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER2_0.f90 deleted file mode 100644 index 3653d8fba..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER2_0.f90 +++ /dev/null @@ -1,1713 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER2 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER2_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER2_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER2_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat -#else - INTEGER(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER2_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER2_0 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER2_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER2 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER2_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER2_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_INTEGER2(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_INTEGER1 - INTEGER (kind=iotk_INTEGER1), allocatable :: dat1 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_INTEGER3 - INTEGER (kind=iotk_INTEGER3), allocatable :: dat3 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_INTEGER4 - INTEGER (kind=iotk_INTEGER4), allocatable :: dat4 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_INTEGER1 - case(kind(dat1)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat1(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat1,ierr=ierr) - if(ierr/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat1(i), i=1,ubound(dat1,1) ) - if(iostat/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 569 "iotk_dat.spp" - dat = int(dat1,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat1) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_INTEGER3 - case(kind(dat3)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat3(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat3,ierr=ierr) - if(ierr/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat3(i), i=1,ubound(dat3,1) ) - if(iostat/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 569 "iotk_dat.spp" - dat = int(dat3,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat3) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_INTEGER4 - case(kind(dat4)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat4(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat4,ierr=ierr) - if(ierr/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat4(i), i=1,ubound(dat4,1) ) - if(iostat/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 569 "iotk_dat.spp" - dat = int(dat4,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat4) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading INTEGER data') - return - end if -# 643 "iotk_dat.spp" - if(index == size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_INTEGER2 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER2_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER2_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER2_1 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER2_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER2 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER2_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER2_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER2_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER2_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER2_2 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER2_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER2_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER2_3.f90 deleted file mode 100644 index b8d33cfdb..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER2_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER2 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER2_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER2_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER2_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER2_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER2_3 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER2_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER2 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER2_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER2_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER2_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER2_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER2_4 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER2_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER2 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER2_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER2_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER2_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER2_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER2_5 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER2_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER2_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER2_6.f90 deleted file mode 100644 index 3ad457245..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER2_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER2 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER2_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER2_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER2_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER2_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER2_6 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER2_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER2 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER2_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER2_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER2_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER2_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER2_7 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER2_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER3_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER3_0.f90 deleted file mode 100644 index f1e6c066d..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER3_0.f90 +++ /dev/null @@ -1,1713 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER3 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER3_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER3_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER3_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat -#else - INTEGER(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER3_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER3_0 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER3_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER3 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER3_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER3_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_INTEGER3(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_INTEGER1 - INTEGER (kind=iotk_INTEGER1), allocatable :: dat1 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_INTEGER2 - INTEGER (kind=iotk_INTEGER2), allocatable :: dat2 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_INTEGER4 - INTEGER (kind=iotk_INTEGER4), allocatable :: dat4 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_INTEGER1 - case(kind(dat1)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat1(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat1,ierr=ierr) - if(ierr/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat1(i), i=1,ubound(dat1,1) ) - if(iostat/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 569 "iotk_dat.spp" - dat = int(dat1,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat1) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_INTEGER2 - case(kind(dat2)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat2(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat2,ierr=ierr) - if(ierr/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat2(i), i=1,ubound(dat2,1) ) - if(iostat/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 569 "iotk_dat.spp" - dat = int(dat2,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat2) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_INTEGER4 - case(kind(dat4)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat4(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat4,ierr=ierr) - if(ierr/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat4(i), i=1,ubound(dat4,1) ) - if(iostat/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 569 "iotk_dat.spp" - dat = int(dat4,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat4) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading INTEGER data') - return - end if -# 643 "iotk_dat.spp" - if(index == size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_INTEGER3 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER3_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER3_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER3_1 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER3_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER3 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER3_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER3_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER3_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER3_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER3_2 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER3_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER3_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER3_3.f90 deleted file mode 100644 index 0d227ca44..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER3_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER3 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER3_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER3_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER3_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER3_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER3_3 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER3_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER3 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER3_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER3_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER3_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER3_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER3_4 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER3_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER3 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER3_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER3_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER3_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER3_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER3_5 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER3_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER3_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER3_6.f90 deleted file mode 100644 index da0230eff..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER3_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER3 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER3_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER3_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER3_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER3_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER3_6 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER3_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER3 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER3_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER3_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER3_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER3_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER3_7 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER3_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER4_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER4_0.f90 deleted file mode 100644 index f0a6477df..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER4_0.f90 +++ /dev/null @@ -1,1713 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER4 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER4_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER4_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER4_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat -#else - INTEGER(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER4_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER4_0 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER4_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER4 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER4_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER4_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_INTEGER4(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_INTEGER1 - INTEGER (kind=iotk_INTEGER1), allocatable :: dat1 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_INTEGER2 - INTEGER (kind=iotk_INTEGER2), allocatable :: dat2 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_INTEGER3 - INTEGER (kind=iotk_INTEGER3), allocatable :: dat3 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_INTEGER1 - case(kind(dat1)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat1(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat1,ierr=ierr) - if(ierr/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat1(i), i=1,ubound(dat1,1) ) - if(iostat/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 569 "iotk_dat.spp" - dat = int(dat1,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat1) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_INTEGER2 - case(kind(dat2)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat2(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat2,ierr=ierr) - if(ierr/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat2(i), i=1,ubound(dat2,1) ) - if(iostat/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 569 "iotk_dat.spp" - dat = int(dat2,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat2) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_INTEGER3 - case(kind(dat3)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat3(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat3,ierr=ierr) - if(ierr/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat3(i), i=1,ubound(dat3,1) ) - if(iostat/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 569 "iotk_dat.spp" - dat = int(dat3,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat3) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading INTEGER data') - return - end if -# 643 "iotk_dat.spp" - if(index == size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_INTEGER4 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER4_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER4_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER4_1 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER4_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER4 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER4_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER4_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER4_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER4_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER4_2 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER4_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER4_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER4_3.f90 deleted file mode 100644 index 55a098b0a..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER4_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER4 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER4_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER4_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER4_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER4_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER4_3 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER4_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER4 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER4_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER4_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER4_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER4_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER4_4 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER4_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER4 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER4_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER4_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER4_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER4_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER4_5 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER4_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER4_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER4_6.f90 deleted file mode 100644 index 3029e224b..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+INTEGER4_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER4 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER4_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER4_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER4_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER4_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER4_6 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER4_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_INTEGER4 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_INTEGER4_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - INTEGER (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("INTEGER"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_INTEGER4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("INTEGER",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_INTEGER4_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_INTEGER4_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - INTEGER (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"INTEGER") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","INTEGER") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_INTEGER4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_INTEGER4_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_INTEGER4_7 - write(0,*) -end subroutine iotk_dat_dummy_INTEGER4_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL1_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL1_0.f90 deleted file mode 100644 index 422838b03..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL1_0.f90 +++ /dev/null @@ -1,1725 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL1 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL1_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL1_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL1_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat -#else - LOGICAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL1_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL1_0 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL1_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL1 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL1_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL1_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_LOGICAL1(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL2 - LOGICAL (kind=iotk_LOGICAL2), allocatable :: dat2 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL3 - LOGICAL (kind=iotk_LOGICAL3), allocatable :: dat3 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL4 - LOGICAL (kind=iotk_LOGICAL4), allocatable :: dat4 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL2 - case(kind(dat2)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat2(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat2,ierr=ierr) - if(ierr/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat2(i), i=1,ubound(dat2,1) ) - if(iostat/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 559 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND2 - dat = dat2 .and. .true. -#else - dat = dat2 -#endif -# 571 "iotk_dat.spp" - deallocate(dat2) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL3 - case(kind(dat3)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat3(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat3,ierr=ierr) - if(ierr/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat3(i), i=1,ubound(dat3,1) ) - if(iostat/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 559 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND2 - dat = dat3 .and. .true. -#else - dat = dat3 -#endif -# 571 "iotk_dat.spp" - deallocate(dat3) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL4 - case(kind(dat4)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat4(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat4,ierr=ierr) - if(ierr/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat4(i), i=1,ubound(dat4,1) ) - if(iostat/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 559 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND2 - dat = dat4 .and. .true. -#else - dat = dat4 -#endif -# 571 "iotk_dat.spp" - deallocate(dat4) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading LOGICAL data') - return - end if -# 643 "iotk_dat.spp" - if(index == size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_LOGICAL1 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL1_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL1_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL1_1 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL1_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL1 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL1_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL1_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL1_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL1_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL1_2 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL1_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL1_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL1_3.f90 deleted file mode 100644 index 69cead3fe..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL1_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL1 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL1_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL1_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL1_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL1_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL1_3 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL1_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL1 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL1_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL1_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL1_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL1_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL1_4 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL1_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL1 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL1_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL1_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL1_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL1_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL1_5 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL1_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL1_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL1_6.f90 deleted file mode 100644 index 5efbb8d60..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL1_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL1 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL1_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL1_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL1_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL1_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL1_6 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL1_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL1 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL1_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL1_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL1_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL1_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL1_7 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL1_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL2_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL2_0.f90 deleted file mode 100644 index 8633a39bb..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL2_0.f90 +++ /dev/null @@ -1,1725 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL2 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL2_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL2_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL2_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat -#else - LOGICAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL2_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL2_0 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL2_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL2 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL2_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL2_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_LOGICAL2(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL1 - LOGICAL (kind=iotk_LOGICAL1), allocatable :: dat1 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL3 - LOGICAL (kind=iotk_LOGICAL3), allocatable :: dat3 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL4 - LOGICAL (kind=iotk_LOGICAL4), allocatable :: dat4 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL1 - case(kind(dat1)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat1(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat1,ierr=ierr) - if(ierr/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat1(i), i=1,ubound(dat1,1) ) - if(iostat/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 559 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND2 - dat = dat1 .and. .true. -#else - dat = dat1 -#endif -# 571 "iotk_dat.spp" - deallocate(dat1) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL3 - case(kind(dat3)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat3(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat3,ierr=ierr) - if(ierr/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat3(i), i=1,ubound(dat3,1) ) - if(iostat/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 559 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND2 - dat = dat3 .and. .true. -#else - dat = dat3 -#endif -# 571 "iotk_dat.spp" - deallocate(dat3) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL4 - case(kind(dat4)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat4(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat4,ierr=ierr) - if(ierr/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat4(i), i=1,ubound(dat4,1) ) - if(iostat/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 559 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND2 - dat = dat4 .and. .true. -#else - dat = dat4 -#endif -# 571 "iotk_dat.spp" - deallocate(dat4) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading LOGICAL data') - return - end if -# 643 "iotk_dat.spp" - if(index == size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_LOGICAL2 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL2_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL2_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL2_1 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL2_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL2 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL2_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL2_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL2_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL2_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL2_2 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL2_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL2_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL2_3.f90 deleted file mode 100644 index f76d24605..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL2_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL2 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL2_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL2_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL2_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL2_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL2_3 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL2_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL2 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL2_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL2_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL2_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL2_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL2_4 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL2_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL2 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL2_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL2_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL2_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL2_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL2_5 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL2_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL2_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL2_6.f90 deleted file mode 100644 index 11666a2e5..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL2_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL2 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL2_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL2_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL2_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL2_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL2_6 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL2_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL2 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL2_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL2_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL2_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL2_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL2_7 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL2_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL3_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL3_0.f90 deleted file mode 100644 index 1f6e715a8..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL3_0.f90 +++ /dev/null @@ -1,1725 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL3 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL3_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL3_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL3_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat -#else - LOGICAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL3_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL3_0 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL3_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL3 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL3_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL3_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_LOGICAL3(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL1 - LOGICAL (kind=iotk_LOGICAL1), allocatable :: dat1 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL2 - LOGICAL (kind=iotk_LOGICAL2), allocatable :: dat2 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL4 - LOGICAL (kind=iotk_LOGICAL4), allocatable :: dat4 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL1 - case(kind(dat1)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat1(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat1,ierr=ierr) - if(ierr/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat1(i), i=1,ubound(dat1,1) ) - if(iostat/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 559 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND2 - dat = dat1 .and. .true. -#else - dat = dat1 -#endif -# 571 "iotk_dat.spp" - deallocate(dat1) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL2 - case(kind(dat2)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat2(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat2,ierr=ierr) - if(ierr/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat2(i), i=1,ubound(dat2,1) ) - if(iostat/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 559 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND2 - dat = dat2 .and. .true. -#else - dat = dat2 -#endif -# 571 "iotk_dat.spp" - deallocate(dat2) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL4 - case(kind(dat4)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat4(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat4,ierr=ierr) - if(ierr/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat4(i), i=1,ubound(dat4,1) ) - if(iostat/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 559 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND2 - dat = dat4 .and. .true. -#else - dat = dat4 -#endif -# 571 "iotk_dat.spp" - deallocate(dat4) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading LOGICAL data') - return - end if -# 643 "iotk_dat.spp" - if(index == size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_LOGICAL3 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL3_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL3_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL3_1 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL3_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL3 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL3_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL3_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL3_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL3_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL3_2 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL3_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL3_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL3_3.f90 deleted file mode 100644 index 7188279f9..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL3_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL3 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL3_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL3_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL3_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL3_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL3_3 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL3_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL3 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL3_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL3_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL3_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL3_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL3_4 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL3_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL3 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL3_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL3_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL3_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL3_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL3_5 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL3_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL3_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL3_6.f90 deleted file mode 100644 index 2a2b2a99f..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL3_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL3 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL3_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL3_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL3_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL3_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL3_6 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL3_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL3 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL3_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL3_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL3_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL3_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL3_7 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL3_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL4_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL4_0.f90 deleted file mode 100644 index e3bc0d25e..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL4_0.f90 +++ /dev/null @@ -1,1725 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL4 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL4_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL4_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL4_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat -#else - LOGICAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL4_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL4_0 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL4_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL4 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL4_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL4_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_LOGICAL4(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL1 - LOGICAL (kind=iotk_LOGICAL1), allocatable :: dat1 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL2 - LOGICAL (kind=iotk_LOGICAL2), allocatable :: dat2 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL3 - LOGICAL (kind=iotk_LOGICAL3), allocatable :: dat3 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL1 - case(kind(dat1)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat1(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat1,ierr=ierr) - if(ierr/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat1(i), i=1,ubound(dat1,1) ) - if(iostat/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 559 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND2 - dat = dat1 .and. .true. -#else - dat = dat1 -#endif -# 571 "iotk_dat.spp" - deallocate(dat1) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL2 - case(kind(dat2)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat2(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat2,ierr=ierr) - if(ierr/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat2(i), i=1,ubound(dat2,1) ) - if(iostat/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 559 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND2 - dat = dat2 .and. .true. -#else - dat = dat2 -#endif -# 571 "iotk_dat.spp" - deallocate(dat2) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_LOGICAL3 - case(kind(dat3)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat3(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat3,ierr=ierr) - if(ierr/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat3(i), i=1,ubound(dat3,1) ) - if(iostat/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 559 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND2 - dat = dat3 .and. .true. -#else - dat = dat3 -#endif -# 571 "iotk_dat.spp" - deallocate(dat3) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading LOGICAL data') - return - end if -# 643 "iotk_dat.spp" - if(index == size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_LOGICAL4 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL4_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL4_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL4_1 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL4_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL4 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL4_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL4_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL4_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL4_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL4_2 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL4_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL4_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL4_3.f90 deleted file mode 100644 index 8191da9cf..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL4_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL4 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL4_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL4_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL4_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL4_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL4_3 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL4_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL4 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL4_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL4_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL4_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL4_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL4_4 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL4_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL4 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL4_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL4_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL4_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL4_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL4_5 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL4_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL4_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL4_6.f90 deleted file mode 100644 index a0e569656..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+LOGICAL4_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL4 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL4_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL4_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL4_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL4_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL4_6 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL4_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_LOGICAL4 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_LOGICAL4_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - LOGICAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("LOGICAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_LOGICAL4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("LOGICAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_LOGICAL4_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_LOGICAL4_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - LOGICAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"LOGICAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","LOGICAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_LOGICAL4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_LOGICAL4_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_LOGICAL4_7 - write(0,*) -end subroutine iotk_dat_dummy_LOGICAL4_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL1_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+REAL1_0.f90 deleted file mode 100644 index 88e450039..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL1_0.f90 +++ /dev/null @@ -1,1713 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL1 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL1_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL1_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL1_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat -#else - REAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL1_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL1_0 - write(0,*) -end subroutine iotk_dat_dummy_REAL1_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL1 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL1_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL1_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_REAL1(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_REAL2 - REAL (kind=iotk_REAL2), allocatable :: dat2 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_REAL3 - REAL (kind=iotk_REAL3), allocatable :: dat3 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_REAL4 - REAL (kind=iotk_REAL4), allocatable :: dat4 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_REAL2 - case(kind(dat2)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat2(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat2,ierr=ierr) - if(ierr/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat2(i), i=1,ubound(dat2,1) ) - if(iostat/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 567 "iotk_dat.spp" - dat = real(dat2,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat2) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_REAL3 - case(kind(dat3)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat3(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat3,ierr=ierr) - if(ierr/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat3(i), i=1,ubound(dat3,1) ) - if(iostat/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 567 "iotk_dat.spp" - dat = real(dat3,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat3) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_REAL4 - case(kind(dat4)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat4(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat4,ierr=ierr) - if(ierr/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat4(i), i=1,ubound(dat4,1) ) - if(iostat/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 567 "iotk_dat.spp" - dat = real(dat4,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat4) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading REAL data') - return - end if -# 643 "iotk_dat.spp" - if(index == size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_REAL1 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL1_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL1_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL1_1 - write(0,*) -end subroutine iotk_dat_dummy_REAL1_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL1 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL1_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL1_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL1_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL1_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL1_2 - write(0,*) -end subroutine iotk_dat_dummy_REAL1_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL1_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+REAL1_3.f90 deleted file mode 100644 index dbf86ff2f..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL1_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL1 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL1_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL1_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL1_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL1_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL1_3 - write(0,*) -end subroutine iotk_dat_dummy_REAL1_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL1 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL1_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL1_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL1_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL1_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL1_4 - write(0,*) -end subroutine iotk_dat_dummy_REAL1_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL1 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL1_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL1_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL1_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL1_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL1_5 - write(0,*) -end subroutine iotk_dat_dummy_REAL1_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL1_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+REAL1_6.f90 deleted file mode 100644 index c311d70f4..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL1_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL1 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL1_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL1_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL1_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL1_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL1_6 - write(0,*) -end subroutine iotk_dat_dummy_REAL1_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL1 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL1_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL1(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL1_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL1_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL1(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL1_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL1_7 - write(0,*) -end subroutine iotk_dat_dummy_REAL1_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL2_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+REAL2_0.f90 deleted file mode 100644 index c42ab9c73..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL2_0.f90 +++ /dev/null @@ -1,1713 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL2 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL2_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL2_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL2_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat -#else - REAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL2_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL2_0 - write(0,*) -end subroutine iotk_dat_dummy_REAL2_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL2 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL2_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL2_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_REAL2(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_REAL1 - REAL (kind=iotk_REAL1), allocatable :: dat1 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_REAL3 - REAL (kind=iotk_REAL3), allocatable :: dat3 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_REAL4 - REAL (kind=iotk_REAL4), allocatable :: dat4 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_REAL1 - case(kind(dat1)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat1(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat1,ierr=ierr) - if(ierr/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat1(i), i=1,ubound(dat1,1) ) - if(iostat/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 567 "iotk_dat.spp" - dat = real(dat1,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat1) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_REAL3 - case(kind(dat3)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat3(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat3,ierr=ierr) - if(ierr/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat3(i), i=1,ubound(dat3,1) ) - if(iostat/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 567 "iotk_dat.spp" - dat = real(dat3,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat3) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_REAL4 - case(kind(dat4)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat4(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat4,ierr=ierr) - if(ierr/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat4(i), i=1,ubound(dat4,1) ) - if(iostat/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 567 "iotk_dat.spp" - dat = real(dat4,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat4) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading REAL data') - return - end if -# 643 "iotk_dat.spp" - if(index == size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_REAL2 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL2_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL2_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL2_1 - write(0,*) -end subroutine iotk_dat_dummy_REAL2_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL2 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL2_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL2_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL2_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL2_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL2_2 - write(0,*) -end subroutine iotk_dat_dummy_REAL2_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL2_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+REAL2_3.f90 deleted file mode 100644 index bc53a08cb..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL2_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL2 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL2_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL2_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL2_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL2_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL2_3 - write(0,*) -end subroutine iotk_dat_dummy_REAL2_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL2 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL2_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL2_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL2_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL2_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL2_4 - write(0,*) -end subroutine iotk_dat_dummy_REAL2_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL2 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL2_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL2_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL2_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL2_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL2_5 - write(0,*) -end subroutine iotk_dat_dummy_REAL2_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL2_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+REAL2_6.f90 deleted file mode 100644 index 0ae39cec0..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL2_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL2 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL2_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL2_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL2_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL2_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL2_6 - write(0,*) -end subroutine iotk_dat_dummy_REAL2_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL2 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL2_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL2(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL2_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL2_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL2(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL2_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL2_7 - write(0,*) -end subroutine iotk_dat_dummy_REAL2_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL3_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+REAL3_0.f90 deleted file mode 100644 index 1c07f4346..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL3_0.f90 +++ /dev/null @@ -1,1713 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL3 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL3_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL3_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL3_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat -#else - REAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL3_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL3_0 - write(0,*) -end subroutine iotk_dat_dummy_REAL3_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL3 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL3_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL3_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_REAL3(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_REAL1 - REAL (kind=iotk_REAL1), allocatable :: dat1 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_REAL2 - REAL (kind=iotk_REAL2), allocatable :: dat2 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_REAL4 - REAL (kind=iotk_REAL4), allocatable :: dat4 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_REAL1 - case(kind(dat1)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat1(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat1,ierr=ierr) - if(ierr/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat1(i), i=1,ubound(dat1,1) ) - if(iostat/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 567 "iotk_dat.spp" - dat = real(dat1,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat1) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_REAL2 - case(kind(dat2)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat2(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat2,ierr=ierr) - if(ierr/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat2(i), i=1,ubound(dat2,1) ) - if(iostat/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 567 "iotk_dat.spp" - dat = real(dat2,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat2) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_REAL4 - case(kind(dat4)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat4(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat4,ierr=ierr) - if(ierr/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat4(i), i=1,ubound(dat4,1) ) - if(iostat/=0) then - deallocate(dat4) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 567 "iotk_dat.spp" - dat = real(dat4,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat4) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading REAL data') - return - end if -# 643 "iotk_dat.spp" - if(index == size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_REAL3 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL3_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL3_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL3_1 - write(0,*) -end subroutine iotk_dat_dummy_REAL3_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL3 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL3_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL3_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL3_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL3_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL3_2 - write(0,*) -end subroutine iotk_dat_dummy_REAL3_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL3_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+REAL3_3.f90 deleted file mode 100644 index 73194adfe..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL3_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL3 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL3_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL3_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL3_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL3_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL3_3 - write(0,*) -end subroutine iotk_dat_dummy_REAL3_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL3 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL3_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL3_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL3_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL3_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL3_4 - write(0,*) -end subroutine iotk_dat_dummy_REAL3_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL3 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL3_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL3_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL3_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL3_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL3_5 - write(0,*) -end subroutine iotk_dat_dummy_REAL3_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL3_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+REAL3_6.f90 deleted file mode 100644 index 5be57bec4..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL3_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL3 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL3_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL3_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL3_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL3_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL3_6 - write(0,*) -end subroutine iotk_dat_dummy_REAL3_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL3 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL3_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL3(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL3_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL3_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL3(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL3_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL3_7 - write(0,*) -end subroutine iotk_dat_dummy_REAL3_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL4_0.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+REAL4_0.f90 deleted file mode 100644 index af5772c5f..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL4_0.f90 +++ /dev/null @@ -1,1713 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL4 -#if 0 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL4_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(1)) -# 241 "iotk_dat.spp" - dattmp(1) = dat -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL4_0 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL4_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat -#else - REAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==1) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(1)) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 744 "iotk_dat.spp" - dat = tmpdat(1) -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL4_0 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL4_0 - write(0,*) -end subroutine iotk_dat_dummy_REAL4_0 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL4 -#if 1 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL4_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL4_1 - - -# 327 "iotk_dat.spp" -recursive subroutine iotk_scan_dat_aux_REAL4(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -# 352 "iotk_dat.spp" - integer :: i -# 354 "iotk_dat.spp" -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -# 365 "iotk_dat.spp" -#ifdef __IOTK_REAL1 - REAL (kind=iotk_REAL1), allocatable :: dat1 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_REAL2 - REAL (kind=iotk_REAL2), allocatable :: dat2 (:) -#endif -# 365 "iotk_dat.spp" -#ifdef __IOTK_REAL3 - REAL (kind=iotk_REAL3), allocatable :: dat3 (:) -#endif -# 371 "iotk_dat.spp" - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 382 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -# 500 "iotk_dat.spp" - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 510 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 510 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 517 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 528 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 534 "iotk_dat.spp" -#ifdef __IOTK_REAL1 - case(kind(dat1)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat1(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat1,ierr=ierr) - if(ierr/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat1(i), i=1,ubound(dat1,1) ) - if(iostat/=0) then - deallocate(dat1) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 567 "iotk_dat.spp" - dat = real(dat1,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat1) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_REAL2 - case(kind(dat2)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat2(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat2,ierr=ierr) - if(ierr/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat2(i), i=1,ubound(dat2,1) ) - if(iostat/=0) then - deallocate(dat2) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 567 "iotk_dat.spp" - dat = real(dat2,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat2) -#endif -# 534 "iotk_dat.spp" -#ifdef __IOTK_REAL3 - case(kind(dat3)) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 539 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - allocate(dat3(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat3,ierr=ierr) - if(ierr/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 547 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 547 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat3(i), i=1,ubound(dat3,1) ) - if(iostat/=0) then - deallocate(dat3) - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 554 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 554 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -# 567 "iotk_dat.spp" - dat = real(dat3,kind=kind(dat)) -# 571 "iotk_dat.spp" - deallocate(dat3) -#endif -# 575 "iotk_dat.spp" - case default - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_dat.spp" -call iotk_error_msg(ierr,'Kind incompatibility') -# 576 "iotk_dat.spp" -call iotk_error_write(ierr,"kind",rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 586 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 586 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 596 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 596 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 604 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 615 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 615 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 620 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 625 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 630 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 630 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 637 "iotk_dat.spp" -call iotk_error_msg(ierr,'Error reading REAL data') - return - end if -# 643 "iotk_dat.spp" - if(index == size(dat)) exit -# 645 "iotk_dat.spp" - if(nexttag/=length + 1) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 646 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 657 "iotk_dat.spp" -call iotk_error_msg(ierr,' ') -# 657 "iotk_dat.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - end if -# 663 "iotk_dat.spp" - if(idummy/=0) then - call iotk_error_issue(ierr,"iotk_scan_dat_aux",__FILE__,__LINE__) -# 664 "iotk_dat.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_scan_dat_aux_REAL4 -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL4_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL4_1 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL4_1 - write(0,*) -end subroutine iotk_dat_dummy_REAL4_1 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL4 -#if 2 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL4_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL4_2 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL4_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL4_2 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL4_2 - write(0,*) -end subroutine iotk_dat_dummy_REAL4_2 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL4_3.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+REAL4_3.f90 deleted file mode 100644 index 3bb471e77..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL4_3.f90 +++ /dev/null @@ -1,1337 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL4 -#if 3 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL4_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL4_3 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL4_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL4_3 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL4_3 - write(0,*) -end subroutine iotk_dat_dummy_REAL4_3 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL4 -#if 4 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL4_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL4_4 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL4_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL4_4 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL4_4 - write(0,*) -end subroutine iotk_dat_dummy_REAL4_4 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL4 -#if 5 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL4_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL4_5 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL4_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL4_5 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL4_5 - write(0,*) -end subroutine iotk_dat_dummy_REAL4_5 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL4_6.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat+REAL4_6.f90 deleted file mode 100644 index 480ba301a..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat+REAL4_6.f90 +++ /dev/null @@ -1,897 +0,0 @@ -# 48 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL4 -#if 6 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL4_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL4_6 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL4_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL4_6 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL4_6 - write(0,*) -end subroutine iotk_dat_dummy_REAL4_6 - - -# 45 "iotk_dat.spp" - -# 65 "iotk_dat.spp" - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 74 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 76 "iotk_dat.spp" - -# 78 "iotk_dat.spp" - -#ifdef __IOTK_REAL4 -#if 7 <= __IOTK_MAXRANK -# 82 "iotk_dat.spp" -subroutine iotk_write_dat_REAL4_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL (kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -# 115 "iotk_dat.spp" - REAL (kind=this_kind),allocatable :: dattmp(:) -# 117 "iotk_dat.spp" - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 126 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 138 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 143 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 148 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 152 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Special characters (<>&) found in fmt string') -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"unit",unit) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 152 "iotk_dat.spp" -call iotk_error_write(ierrl,"fmt",trim(fmt)) - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("REAL"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 157 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_attr(lattr,"size",size(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 162 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 172 "iotk_dat.spp" - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 175 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if -# 180 "iotk_dat.spp" - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 182 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 187 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 194 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 199 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 204 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 209 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 214 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 219 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 224 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 230 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 235 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - - allocate(dattmp(size(dat))) -# 243 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 247 "iotk_dat.spp" - call iotk_private_pack_REAL4(dattmp,dat,size(dattmp),1) -# 249 "iotk_dat.spp" -#else - dattmp = pack(dat,mask=.true.) -#endif -# 253 "iotk_dat.spp" - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 258 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 264 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - else - if(raw) then -# 273 "iotk_dat.spp" - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -# 275 "iotk_dat.spp" - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 276 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 282 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -# 296 "iotk_dat.spp" - write(lunit,fmt=trim(iotk_wfmt("REAL",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 298 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -# 302 "iotk_dat.spp" - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 305 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_dat",__FILE__,__LINE__) -# 312 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_REAL4_7 - - -# 669 "iotk_dat.spp" - -# 671 "iotk_dat.spp" -subroutine iotk_scan_dat_REAL4_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -# 699 "iotk_dat.spp" - REAL (kind=this_kind), allocatable :: tmpdat(:) -# 701 "iotk_dat.spp" - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 718 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"REAL") ) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 725 "iotk_dat.spp" -call iotk_error_msg(ierrl,' ') -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"rtype",rtype(1:iotk_strlen(rtype))) -# 725 "iotk_dat.spp" -call iotk_error_write(ierrl,"type","REAL") - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==size(dat)) ) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 729 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -# 736 "iotk_dat.spp" - - allocate(tmpdat(size(dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 740 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Error reading data') -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rkind",rkind) -# 740 "iotk_dat.spp" -call iotk_error_write(ierrl,"rlen",rlen) - goto 1 - end if -# 746 "iotk_dat.spp" -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -# 750 "iotk_dat.spp" - call iotk_private_pack_REAL4(dat,tmpdat,size(tmpdat),1) -# 752 "iotk_dat.spp" -#else - dat = reshape(tmpdat,shape(dat)) -#endif -# 756 "iotk_dat.spp" - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_dat",__FILE__,__LINE__) -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 768 "iotk_dat.spp" -call iotk_error_msg(ierrl,'Dat not found') -# 768 "iotk_dat.spp" -call iotk_error_write(ierrl,"name",name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_REAL4_7 - - -#endif -#endif - -subroutine iotk_dat_dummy_REAL4_7 - write(0,*) -end subroutine iotk_dat_dummy_REAL4_7 - - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat.f90 deleted file mode 100644 index c17ad65df..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat.f90 +++ /dev/null @@ -1,36 +0,0 @@ -# 1 "iotk_dat.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_dat.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_dat.spp" - -# 33 "iotk_dat.spp" - - -subroutine iotk_dat_dummy() - write(0,*) -end subroutine iotk_dat_dummy - -# 45 "iotk_dat.spp" - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat.spp b/quantum_espresso/kcp/iotk/src/iotk_dat.spp deleted file mode 100644 index c8ed52211..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat.spp +++ /dev/null @@ -1,794 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -> REVISION='$Revision: 1.1.1.1 $' -> REVISION="${REVISION//${dol}/}" - - -subroutine iotk_dat_dummy() - write(0,*) -end subroutine iotk_dat_dummy - -> function SIZE () { if ((rank<1)) ; then echo -n "1" ; else echo -n "size($1)" ; fi ; } -> for type in $types ; do -> type_string="\"$type\"" -> for kind in $kinds ; do -> if [ $type != CHARACTER -o $kind -eq 1 ] ; then -> for rank in $ranks ; do - -> if((rank%3==0)); then -> auxfile ${type}${kind}_${rank} -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ->fi - - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion if the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -> eval "LENSTAR=\$LENSTAR_$type" - -#ifdef __IOTK_${type}${kind} -#if $rank <= __IOTK_MAXRANK ->PROCEDURE=iotk_write_dat -subroutine iotk_write_dat_${type}${kind}_${rank}(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only : iotk_write_attr - use iotk_write_interf - use iotk_fmt_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_${type}${kind} - integer, intent(in) :: unit - character(len=*), intent(in) :: name - ${type} (kind=this_kind$LENSTAR), intent(in) :: dat ${SHAPE[$rank]} - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit,iostat - logical :: binary,raw,stream - integer :: lcolumns - integer(iotk_header_kind), parameter :: idummy=0 - character(100) :: lsep - character(300) :: usefmt - character(iotk_attlenx) :: lattr - character(iotk_attlenx) :: attr_tmp - type (iotk_unit), pointer :: this -> if [ "$type" = CHARACTER ] ; then - ${type} (kind=this_kind,len=len(dat)),allocatable :: dattmp(:) - character(len=iotk_linlenx) :: linetmp -> else - ${type} (kind=this_kind),allocatable :: dattmp(:) -> fi - integer :: itmp - ierrl = 0 - iostat = 0 - lcolumns = 1 - lsep(1:2) = " "//iotk_eos - if(present(columns)) lcolumns = columns - if(present(sep)) then - call iotk_strcpy(lsep,sep,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_strcpy(usefmt,"!",ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(present(fmt) .and. .not. raw) call iotk_strcpy(usefmt,iotk_strtrim(fmt),ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(iotk_strscan(usefmt,"<>&")/=0) then - $(ERROR ierrl 'Special characters (<>&) found in fmt string' unit name='trim(name)' fmt='trim(fmt)') - goto 1 - end if - call iotk_write_attr(lattr,"type",iotk_tolower("${type}"),first=.true.,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_write_attr(lattr,"size",$(SIZE dat),ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if -> if [ "$type" = CHARACTER ] ; then - call iotk_write_attr(lattr,"len",len(dat),ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if -> else - if(binary) then - call iotk_write_attr(lattr,"kind",kind(dat),ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if -> fi - if(.not.iotk_strcomp(usefmt,"!")) call iotk_write_attr(lattr,"fmt",iotk_strtrim(usefmt),ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(lcolumns/=1) call iotk_write_attr(lattr,"columns",lcolumns,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(present(attr)) then - attr_tmp(1:1)=iotk_eos - call iotk_strcpy(attr_tmp,attr,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_delete_attr(attr_tmp,"type",ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_delete_attr(attr_tmp,"kind",ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_delete_attr(attr_tmp,"size",ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_delete_attr(attr_tmp,"fmt",ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_delete_attr(attr_tmp,"columns",ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_delete_attr(attr_tmp,"len",ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(iotk_strlen_trim(attr_tmp)>0) call iotk_strcat(lattr,iotk_strtrim(attr_tmp),ierr=ierrl) - end if - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_write_begin(unit,name,lattr,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - - allocate(dattmp($(SIZE dat))) -> if [ $rank -eq 0 ] ; then - dattmp(1) = dat -> else -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -> if [ $type == CHARACTER ] ; then - call iotk_private_pack_$type$kind(dattmp,dat,size(dattmp),len(dattmp)) -> else - call iotk_private_pack_$type$kind(dattmp,dat,size(dattmp),1) -> fi -#else - dattmp = pack(dat,mask=.true.) -#endif -> fi - - if(binary) then - if(raw) then - write(lunit,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - $(ERROR ierrl) - goto 1 - end if - else - write(lunit,iostat=iostat) idummy,(dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - else - if(raw) then -> if [ $type = CHARACTER ] ;then - write(lunit,"(a)",iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) -> else - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) ->fi - if(iostat/=0) then - $(ERROR ierrl) - goto 1 - end if - else if(iotk_strcomp(usefmt,"*")) then - write(lunit,*,iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - $(ERROR ierrl) - goto 1 - end if - else if(iotk_strcomp(usefmt,"!")) then -> if [ $type = CHARACTER ] ;then - do itmp = 1 , size(dattmp) - call iotk_deescape(linetmp,dattmp(itmp)) - write(lunit,"(a)",iostat=iostat) linetmp(1:iotk_strlen(linetmp)) - if(iostat/=0) then - $(ERROR ierrl) - goto 1 - end if - end do -> else - write(lunit,fmt=trim(iotk_wfmt("${type}",kind(dattmp),lcolumns,-1,lsep)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - $(ERROR ierrl) - goto 1 - end if -> fi - else - write(lunit,fmt=usefmt(1:iotk_strlen(usefmt)),iostat=iostat) (dattmp(itmp),itmp=1,size(dattmp)) - if(iostat/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - end if - call iotk_write_end(unit,name,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if -1 continue - if(allocated(dattmp)) deallocate(dattmp) - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_dat_${type}${kind}_${rank} - - -> if [ $rank -eq 1 ] ; then ->PROCEDURE=iotk_scan_dat_aux -recursive subroutine iotk_scan_dat_aux_${type}${kind}(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf, only: iotk_read - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_stream_interf - implicit none - integer, parameter :: this_kind = iotk_${type}${kind} - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - ${type}(kind=this_kind$LENSTAR) :: dat (:) -#else - ${type}(kind=this_kind$LENSTAR), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr - integer(iotk_header_kind) :: idummy - logical :: raw,binary,stream - integer :: lunit -> if [ $type != CHARACTER ] ; then - integer :: i -> fi -#ifdef __IOTK_WORKAROUND3 - integer :: j -#endif - integer :: index,length,nexttag,iostat,altlength - type(iotk_unit), pointer :: this - character(len=iotk_linlenx) :: line,altline -> if [ $type = CHARACTER ] ; then - ${type} (kind=this_kind, len=rlen) :: dattmp(ubound(dat,1)) -> else -> for altkind in $kinds ; do -> if (( $altkind != $kind )) ; then -#ifdef __IOTK_${type}${altkind} - ${type} (kind=iotk_${type}${altkind}), allocatable :: dat${altkind} (:) -#endif -> fi -> done -> fi - lunit = iotk_phys_unit(unit) - ierr = 0 - iostat = 0 - idummy = 0 - call iotk_unit_get(lunit,pointer=this) - raw = .false. - if(associated(this)) then - raw = this%raw - end if - call iotk_inquire(lunit,binary,stream,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if -> if [ $type = CHARACTER ] ; then - if(binary) then - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dattmp(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dattmp -#endif - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dattmp,ierr=ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dattmp(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dattmp -#endif - end if - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - end if - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,"(a)",iostat=iostat) ( dattmp(j), j=1,ubound(dat,1) ) -#else - read(lunit,"(a)",iostat=iostat) dattmp -#endif - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*, iostat=iostat) ( dattmp(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*, iostat=iostat) dattmp -#endif - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - iostat = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - end if - index = index + 1 - call iotk_escape(to=dattmp(index),from=line(1:nexttag - 1)) - if(iotk_strlen(dattmp(index)) < len(dattmp)) dattmp(index)(iotk_strlen(dattmp(index))+1:) = " " - if(index == size(dat)) exit - if(nexttag/=length + 1) then - $(ERROR ierr 'Missing dat') - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dattmp(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dattmp -#endif - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - end if - end if - if(len(dattmp) <= len(dat)) then - dat (:) = dattmp (:) - else - dat (:) = dattmp (:) (1:len(dat)) - end if -> else - if(binary) then - select case(rkind) - case(kind(dat)) - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) dat -#endif - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - else - if(stream) then - call iotk_stream_read(lunit,idummy,dat,ierr=ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,iostat=iostat) idummy, ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,iostat=iostat) idummy, dat -#endif - end if - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - end if -> for altkind in $kinds ; do -> if [ $altkind -ne $kind ] ; then -#ifdef __IOTK_${type}${altkind} - case(kind(dat${altkind})) - ! for the sake of completeness: if the file is raw, there is no - ! information about kind and this line cannot be reached - if(raw) then - $(ERROR ierr) - return - end if - allocate(dat${altkind}(ubound(dat,1))) - if(stream) then - call iotk_stream_read(lunit,idummy,dat${altkind},ierr=ierr) - if(ierr/=0) then - deallocate(dat${altkind}) - $(ERROR ierr ' ' iostat) - return - end if - else - read(lunit,iostat=iostat) idummy,( dat${altkind}(i), i=1,ubound(dat${altkind},1) ) - if(iostat/=0) then - deallocate(dat${altkind}) - $(ERROR ierr ' ' iostat) - return - end if - end if -> if [ $type = LOGICAL ] ; then -#ifdef __IOTK_WORKAROUND2 - dat = dat${altkind} .and. .true. -#else - dat = dat${altkind} -#endif -> elif [ $type = COMPLEX ] ; then - dat = cmplx(dat${altkind},kind=kind(dat)) -> elif [ $type = REAL ] ; then - dat = real(dat${altkind},kind=kind(dat)) -> elif [ $type = INTEGER ] ; then - dat = int(dat${altkind},kind=kind(dat)) -> fi - deallocate(dat${altkind}) -#endif -> fi -> done - case default - $(ERROR ierr 'Kind incompatibility' kind=rkind) - end select - else - if(raw) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - else if(iotk_strcomp(fmt,"*")) then -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=*,iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=*,iostat=iostat) dat -#endif - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - else if(iotk_strcomp(fmt,"!")) then - index = 0 - do - call iotk_getline(lunit,line,length,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - nexttag = scan(line(1:length),"<") - if(nexttag==0) then - nexttag = length + 1 - else -! adjust the positioning if there is a tag on this line -! implementation to be improved - backspace(lunit,iostat=iostat) - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - call iotk_getline(lunit,altline,altlength,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - backspace(lunit,iostat=iostat) - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - read(lunit,"(a)",advance="no",iostat=iostat) altline(1:nexttag-1 + altlength - length) - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - end if - call iotk_str_clean(line(1:nexttag - 1)) - call iotk_read(dat,line(1:nexttag - 1),index,ierr) - if(ierr/=0) then - $(ERROR ierr 'Error reading '${type}' data') - return - end if -> if [ $type = COMPLEX ] ; then - if(index == 2 * size(dat)) exit -> else - if(index == size(dat)) exit -> fi - if(nexttag/=length + 1) then - $(ERROR ierr) - return - end if - end do - else -#ifdef __IOTK_WORKAROUND3 - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) ( dat(j), j=1,ubound(dat,1) ) -#else - read(lunit,fmt=fmt(1:iotk_strlen(fmt)),iostat=iostat) dat -#endif - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - end if - end if -> fi - if(idummy/=0) then - $(ERROR ierr) - return - end if -end subroutine iotk_scan_dat_aux_${type}${kind} -> fi - ->PROCEDURE=iotk_scan_dat -subroutine iotk_scan_dat_${type}${kind}_${rank}(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf, only: iotk_scan_dat_aux - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_${type}${kind} - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - ${type}(kind=this_kind$LENSTAR) :: dat ${SHAPE[$rank]} -#else - ${type}(kind=this_kind$LENSTAR), intent(out) :: dat ${SHAPE[$rank]} -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - ${type}(kind=this_kind$LENSTAR), optional, intent(in) :: default ${SHAPE[$rank]} - integer, optional, intent(out) :: ierr -> if [ $type = CHARACTER ] ; then - ${type} (kind=this_kind,len=len(dat)), allocatable :: tmpdat(:) -> else - ${type} (kind=this_kind), allocatable :: tmpdat(:) -> fi - integer :: ierrl,ierrl2 - integer :: rkind,rsize,rlen - character(iotk_vallenx) :: rtype - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: lattr - integer :: columns - logical :: inside,foundl - inside = .false. - ierrl = 0 - ierrl2 = 0 - foundl=.false. - call iotk_scan_begin(unit,name,lattr,found=foundl,ierr=ierrl) - if(.not. foundl) goto 1 - foundl = .true. - inside = .true. - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_parse_dat(lattr,rtype,rkind,rsize,rlen,fmt,columns,ierrl) -! Note that columns is not effectively used - if(ierrl/=0) goto 1 - if(.not. (iotk_strcomp(rtype,iotk_eos) .or. iotk_strcomp(rtype,"${type}") ) ) then - $(ERROR ierrl ' ' rtype='rtype(1:iotk_strlen(rtype))' type=$type_string) - goto 1 - end if - if(.not. (rsize==-1 .or. rsize==$(SIZE dat)) ) then - $(ERROR ierrl) - goto 1 - end if - if(rkind==-1) rkind = kind(dat) -> if [ $type = CHARACTER ] ; then - if(rlen ==-1) rlen = len(dat) -> fi - - allocate(tmpdat($(SIZE dat))) - call iotk_scan_dat_aux(unit,tmpdat,rkind,rlen,fmt(1:iotk_strlen(fmt)),ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error reading data' name rkind rlen) - goto 1 - end if -> if [ $rank -eq 0 ] ; then - dat = tmpdat(1) -> else -#if defined(__IOTK_WORKAROUND3) || defined(__IOTK_WORKAROUND4) -> if [ $type == CHARACTER ] ; then - call iotk_private_pack_$type$kind(dat,tmpdat,size(tmpdat),len(tmpdat)) -> else - call iotk_private_pack_$type$kind(dat,tmpdat,size(tmpdat),1) -> fi -#else - dat = reshape(tmpdat,shape(dat)) -#endif -> fi - deallocate(tmpdat) -1 continue - if(inside) then - call iotk_scan_end(unit,name,ierr=ierrl2) - if(ierrl2/=0) then - call iotk_error_clear(ierrl) - ierrl=ierrl2 - end if - end if - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. present(default) .and. .not. foundl) then - $(ERROR ierrl 'Dat not found' name) - ierrl = - ierrl - end if - if(present(default) .and. .not. foundl) then - dat=default - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. (.not.present(found) .and. .not.present(default))) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_dat_${type}${kind}_${rank} - - -#endif -#endif - -subroutine iotk_dat_dummy_${type}${kind}_${rank} - write(0,*) -end subroutine iotk_dat_dummy_${type}${kind}_${rank} - - -> done -> fi -> done -> done - diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat_interf.f90 b/quantum_espresso/kcp/iotk/src/iotk_dat_interf.f90 deleted file mode 100644 index 466b50419..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat_interf.f90 +++ /dev/null @@ -1,6067 +0,0 @@ -# 1 "iotk_dat_interf.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_dat_interf.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_dat_interf.spp" - -module iotk_dat_interf -implicit none -private - -public :: iotk_write_dat -public :: iotk_scan_dat -public :: iotk_scan_dat_aux - - -interface iotk_write_dat -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_LOGICAL1 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL1_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL1_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL1_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL1_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL1_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL1_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL1_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL1_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL1_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL1_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL1_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL1_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL1_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL1_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL1_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL1_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_LOGICAL2 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL2_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL2_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL2_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL2_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL2_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL2_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL2_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL2_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL2_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL2_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL2_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL2_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL2_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL2_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL2_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL2_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_LOGICAL3 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL3_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL3_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL3_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL3_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL3_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL3_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL3_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL3_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL3_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL3_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL3_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL3_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL3_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL3_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL3_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL3_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_LOGICAL4 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL4_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL4_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL4_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL4_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL4_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL4_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL4_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL4_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL4_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL4_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL4_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL4_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL4_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL4_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_LOGICAL4_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - LOGICAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_LOGICAL4_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_INTEGER1 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER1_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER1_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER1_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER1_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER1_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER1_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER1_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER1_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER1_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER1_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER1_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER1_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER1_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER1_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER1_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER1_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_INTEGER2 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER2_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER2_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER2_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER2_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER2_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER2_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER2_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER2_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER2_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER2_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER2_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER2_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER2_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER2_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER2_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER2_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_INTEGER3 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER3_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER3_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER3_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER3_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER3_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER3_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER3_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER3_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER3_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER3_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER3_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER3_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER3_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER3_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER3_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER3_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_INTEGER4 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER4_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER4_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER4_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER4_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER4_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER4_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER4_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER4_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER4_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER4_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER4_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER4_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER4_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER4_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_INTEGER4_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - INTEGER(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_INTEGER4_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_REAL1 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL1_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL1_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL1_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL1_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL1_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL1_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL1_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL1_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL1_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL1_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL1_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL1_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL1_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL1_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL1_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL1_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_REAL2 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL2_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL2_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL2_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL2_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL2_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL2_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL2_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL2_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL2_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL2_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL2_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL2_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL2_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL2_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL2_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL2_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_REAL3 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL3_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL3_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL3_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL3_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL3_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL3_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL3_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL3_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL3_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL3_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL3_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL3_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL3_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL3_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL3_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL3_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_REAL4 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL4_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL4_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL4_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL4_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL4_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL4_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL4_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL4_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL4_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL4_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL4_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL4_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL4_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL4_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_REAL4_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - REAL(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_REAL4_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_COMPLEX1 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX1_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX1_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX1_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX1_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX1_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX1_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX1_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX1_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX1_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX1_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX1_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX1_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX1_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX1_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX1_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX1_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_COMPLEX2 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX2_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX2_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX2_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX2_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX2_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX2_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX2_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX2_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX2_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX2_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX2_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX2_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX2_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX2_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX2_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX2_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_COMPLEX3 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX3_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX3_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX3_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX3_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX3_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX3_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX3_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX3_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX3_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX3_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX3_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX3_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX3_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX3_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX3_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX3_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_COMPLEX4 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX4_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX4_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX4_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX4_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX4_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX4_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX4_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX4_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX4_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX4_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX4_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX4_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX4_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX4_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_COMPLEX4_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - COMPLEX(kind=this_kind), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_COMPLEX4_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 45 "iotk_dat_interf.spp" -#ifdef __IOTK_CHARACTER1 -# 47 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_write_dat_CHARACTER1_0(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER(kind=this_kind,len=*), intent(in) :: dat - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_CHARACTER1_0 -#endif -# 47 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_write_dat_CHARACTER1_1(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER(kind=this_kind,len=*), intent(in) :: dat (:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_CHARACTER1_1 -#endif -# 47 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_write_dat_CHARACTER1_2(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER(kind=this_kind,len=*), intent(in) :: dat (:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_CHARACTER1_2 -#endif -# 47 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_write_dat_CHARACTER1_3(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER(kind=this_kind,len=*), intent(in) :: dat (:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_CHARACTER1_3 -#endif -# 47 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_write_dat_CHARACTER1_4(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER(kind=this_kind,len=*), intent(in) :: dat (:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_CHARACTER1_4 -#endif -# 47 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_write_dat_CHARACTER1_5(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER(kind=this_kind,len=*), intent(in) :: dat (:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_CHARACTER1_5 -#endif -# 47 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_write_dat_CHARACTER1_6(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER(kind=this_kind,len=*), intent(in) :: dat (:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_CHARACTER1_6 -#endif -# 47 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_write_dat_CHARACTER1_7(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name - CHARACTER(kind=this_kind,len=*), intent(in) :: dat (:,:,:,:,:,:,:) - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_CHARACTER1_7 -#endif -# 64 "iotk_dat_interf.spp" -#endif -# 67 "iotk_dat_interf.spp" -end interface - -interface iotk_scan_dat -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_LOGICAL1 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL1_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat -#else - LOGICAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL1_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL1_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL1_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL1_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL1_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL1_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL1_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL1_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL1_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL1_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL1_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL1_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL1_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL1_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL1_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_LOGICAL2 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL2_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat -#else - LOGICAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL2_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL2_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL2_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL2_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL2_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL2_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL2_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL2_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL2_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL2_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL2_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL2_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL2_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL2_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL2_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_LOGICAL3 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL3_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat -#else - LOGICAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL3_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL3_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL3_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL3_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL3_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL3_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL3_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL3_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL3_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL3_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL3_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL3_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL3_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL3_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL3_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_LOGICAL4 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL4_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat -#else - LOGICAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL4_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL4_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL4_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL4_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL4_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL4_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL4_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL4_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL4_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL4_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL4_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL4_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL4_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_LOGICAL4_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - LOGICAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_LOGICAL4_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_INTEGER1 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER1_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat -#else - INTEGER(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER1_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER1_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER1_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER1_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER1_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER1_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER1_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER1_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER1_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER1_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER1_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER1_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER1_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER1_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER1_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_INTEGER2 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER2_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat -#else - INTEGER(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER2_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER2_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER2_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER2_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER2_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER2_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER2_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER2_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER2_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER2_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER2_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER2_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER2_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER2_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER2_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_INTEGER3 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER3_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat -#else - INTEGER(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER3_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER3_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER3_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER3_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER3_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER3_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER3_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER3_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER3_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER3_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER3_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER3_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER3_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER3_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER3_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_INTEGER4 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER4_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat -#else - INTEGER(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER4_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER4_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER4_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER4_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER4_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER4_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER4_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER4_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER4_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER4_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER4_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER4_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER4_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_INTEGER4_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - INTEGER(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_INTEGER4_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_REAL1 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL1_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat -#else - REAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL1_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL1_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL1_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL1_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL1_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL1_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL1_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL1_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL1_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL1_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL1_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL1_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL1_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL1_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL1_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_REAL2 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL2_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat -#else - REAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL2_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL2_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL2_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL2_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL2_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL2_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL2_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL2_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL2_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL2_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL2_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL2_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL2_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL2_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL2_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_REAL3 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL3_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat -#else - REAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL3_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL3_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL3_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL3_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL3_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL3_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL3_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL3_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL3_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL3_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL3_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL3_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL3_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL3_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL3_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_REAL4 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL4_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat -#else - REAL(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL4_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL4_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL4_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL4_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL4_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL4_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL4_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL4_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL4_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL4_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL4_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL4_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL4_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_REAL4_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - REAL(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - REAL(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_REAL4_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_COMPLEX1 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX1_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat -#else - COMPLEX(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX1_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX1_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX1_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX1_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX1_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX1_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX1_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX1_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX1_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX1_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX1_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX1_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX1_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX1_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX1_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_COMPLEX2 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX2_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat -#else - COMPLEX(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX2_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX2_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX2_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX2_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX2_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX2_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX2_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX2_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX2_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX2_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX2_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX2_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX2_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX2_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX2_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_COMPLEX3 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX3_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat -#else - COMPLEX(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX3_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX3_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX3_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX3_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX3_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX3_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX3_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX3_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX3_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX3_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX3_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX3_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX3_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX3_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX3_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_COMPLEX4 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX4_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat -#else - COMPLEX(kind=this_kind), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX4_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX4_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX4_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX4_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX4_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX4_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX4_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX4_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX4_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX4_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX4_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX4_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX4_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_COMPLEX4_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:,:,:,:,:,:,:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - COMPLEX(kind=this_kind), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_COMPLEX4_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 74 "iotk_dat_interf.spp" -#ifdef __IOTK_CHARACTER1 -# 76 "iotk_dat_interf.spp" -#if 0 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_CHARACTER1_0(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_CHARACTER1_0 -#endif -# 76 "iotk_dat_interf.spp" -#if 1 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_CHARACTER1_1(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default (:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_CHARACTER1_1 -#endif -# 76 "iotk_dat_interf.spp" -#if 2 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_CHARACTER1_2(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:,:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default (:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_CHARACTER1_2 -#endif -# 76 "iotk_dat_interf.spp" -#if 3 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_CHARACTER1_3(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:,:,:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default (:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_CHARACTER1_3 -#endif -# 76 "iotk_dat_interf.spp" -#if 4 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_CHARACTER1_4(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:,:,:,:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default (:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_CHARACTER1_4 -#endif -# 76 "iotk_dat_interf.spp" -#if 5 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_CHARACTER1_5(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:,:,:,:,:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default (:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_CHARACTER1_5 -#endif -# 76 "iotk_dat_interf.spp" -#if 6 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_CHARACTER1_6(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:,:,:,:,:,:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default (:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_CHARACTER1_6 -#endif -# 76 "iotk_dat_interf.spp" -#if 7 <= __IOTK_MAXRANK -subroutine iotk_scan_dat_CHARACTER1_7(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:,:,:,:,:,:,:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:,:,:,:,:,:,:) -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - CHARACTER(kind=this_kind,len=*), optional, intent(in) :: default (:,:,:,:,:,:,:) - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_CHARACTER1_7 -#endif -# 100 "iotk_dat_interf.spp" -#endif -# 103 "iotk_dat_interf.spp" -end interface - -interface iotk_scan_dat_aux -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_LOGICAL1 -subroutine iotk_scan_dat_aux_LOGICAL1(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL1 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_LOGICAL1 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_LOGICAL2 -subroutine iotk_scan_dat_aux_LOGICAL2(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL2 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_LOGICAL2 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_LOGICAL3 -subroutine iotk_scan_dat_aux_LOGICAL3(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL3 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_LOGICAL3 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_LOGICAL4 -subroutine iotk_scan_dat_aux_LOGICAL4(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_LOGICAL4 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - LOGICAL(kind=this_kind) :: dat (:) -#else - LOGICAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_LOGICAL4 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_INTEGER1 -subroutine iotk_scan_dat_aux_INTEGER1(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER1 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_INTEGER1 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_INTEGER2 -subroutine iotk_scan_dat_aux_INTEGER2(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER2 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_INTEGER2 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_INTEGER3 -subroutine iotk_scan_dat_aux_INTEGER3(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER3 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_INTEGER3 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_INTEGER4 -subroutine iotk_scan_dat_aux_INTEGER4(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_INTEGER4 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - INTEGER(kind=this_kind) :: dat (:) -#else - INTEGER(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_INTEGER4 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_REAL1 -subroutine iotk_scan_dat_aux_REAL1(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL1 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_REAL1 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_REAL2 -subroutine iotk_scan_dat_aux_REAL2(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL2 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_REAL2 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_REAL3 -subroutine iotk_scan_dat_aux_REAL3(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL3 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_REAL3 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_REAL4 -subroutine iotk_scan_dat_aux_REAL4(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_REAL4 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - REAL(kind=this_kind) :: dat (:) -#else - REAL(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_REAL4 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_COMPLEX1 -subroutine iotk_scan_dat_aux_COMPLEX1(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX1 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_COMPLEX1 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_COMPLEX2 -subroutine iotk_scan_dat_aux_COMPLEX2(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX2 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_COMPLEX2 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_COMPLEX3 -subroutine iotk_scan_dat_aux_COMPLEX3(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX3 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_COMPLEX3 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_COMPLEX4 -subroutine iotk_scan_dat_aux_COMPLEX4(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_COMPLEX4 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - COMPLEX(kind=this_kind) :: dat (:) -#else - COMPLEX(kind=this_kind), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_COMPLEX4 -#endif -# 110 "iotk_dat_interf.spp" -#ifdef __IOTK_CHARACTER1 -subroutine iotk_scan_dat_aux_CHARACTER1(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_CHARACTER1 - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - CHARACTER(kind=this_kind,len=*) :: dat (:) -#else - CHARACTER(kind=this_kind,len=*), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_CHARACTER1 -#endif -# 129 "iotk_dat_interf.spp" -end interface - -end module iotk_dat_interf diff --git a/quantum_espresso/kcp/iotk/src/iotk_dat_interf.spp b/quantum_espresso/kcp/iotk/src/iotk_dat_interf.spp deleted file mode 100644 index efebb0c14..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_dat_interf.spp +++ /dev/null @@ -1,132 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -module iotk_dat_interf -implicit none -private - -public :: iotk_write_dat -public :: iotk_scan_dat -public :: iotk_scan_dat_aux - - -interface iotk_write_dat ->for type in $types ; do -> eval "LENSTAR=\$LENSTAR_$type" -> for kind in $kinds ; do -> [[ $type == CHARACTER ]] && [[ $kind != 1 ]] && continue -#ifdef __IOTK_${type}${kind} -> for rank in $ranks ; do -#if $rank <= __IOTK_MAXRANK -subroutine iotk_write_dat_${type}${kind}_${rank}(unit,name,dat,dummy,attr,columns,sep,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_${type}${kind} - integer, intent(in) :: unit - character(len=*), intent(in) :: name - ${type}(kind=this_kind$LENSTAR), intent(in) :: dat ${SHAPE[$rank]} - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: sep - character(len=*), optional, intent(in) :: fmt - character(len=*), optional, intent(in) :: attr - integer, optional, intent(in) :: columns - integer, optional, intent(out) :: ierr -end subroutine iotk_write_dat_${type}${kind}_${rank} -#endif -> done -#endif -> done ->done -end interface - -interface iotk_scan_dat ->for type in $types ; do -> eval "LENSTAR=\$LENSTAR_$type" -> for kind in $kinds ; do -> [[ $type == CHARACTER ]] && [[ $kind != 1 ]] && continue -#ifdef __IOTK_${type}${kind} -> for rank in $ranks ; do -#if $rank <= __IOTK_MAXRANK -subroutine iotk_scan_dat_${type}${kind}_${rank}(unit,name,dat,dummy,attr,found,default,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_${type}${kind} - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - ${type}(kind=this_kind$LENSTAR) :: dat ${SHAPE[$rank]} -#else - ${type}(kind=this_kind$LENSTAR), intent(out) :: dat ${SHAPE[$rank]} -#endif - type(iotk_dummytype), optional :: dummy -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - logical, optional, intent(out) :: found - ${type}(kind=this_kind$LENSTAR), optional, intent(in) :: default ${SHAPE[$rank]} - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_dat_${type}${kind}_${rank} -#endif -> done -#endif -> done ->done -end interface - -interface iotk_scan_dat_aux ->for type in $types ; do -> eval "LENSTAR=\$LENSTAR_$type" -> for kind in $kinds ; do -> [[ $type == CHARACTER ]] && [[ $kind != 1 ]] && continue -#ifdef __IOTK_${type}${kind} -subroutine iotk_scan_dat_aux_${type}${kind}(unit,dat,rkind,rlen,fmt,ierr) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_${type}${kind} - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - ${type}(kind=this_kind$LENSTAR) :: dat (:) -#else - ${type}(kind=this_kind$LENSTAR), intent(out) :: dat (:) -#endif - integer, intent(in) :: rkind - integer, intent(in) :: rlen - character(len=*), intent(in) :: fmt - integer, intent(out) :: ierr -end subroutine iotk_scan_dat_aux_${type}${kind} -#endif -> done ->done -end interface - -end module iotk_dat_interf - diff --git a/quantum_espresso/kcp/iotk/src/iotk_error.f90 b/quantum_espresso/kcp/iotk/src/iotk_error.f90 deleted file mode 100644 index fed1a4233..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_error.f90 +++ /dev/null @@ -1,507 +0,0 @@ -# 1 "iotk_error.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_error.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_error.spp" - -# 33 "iotk_error.spp" - -! ERROR ROUTINES -subroutine iotk_error_init_e(error) - use iotk_base - implicit none - type(iotk_error), intent(out) :: error - nullify(error%str) -end subroutine iotk_error_init_e - -subroutine iotk_error_init_i(ierr) - implicit none - integer, intent(out) :: ierr - ierr = 0 -end subroutine iotk_error_init_i - -subroutine iotk_error_clear_e(error) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error - if(associated(error%str)) deallocate(error%str) -end subroutine iotk_error_clear_e - -subroutine iotk_error_clear_i(ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(inout) :: ierr - if(abs(ierr)>0 .and. abs(ierr)<=iotk_error_pool_size) then - if(iotk_error_pool_used(abs(ierr))) then - call iotk_error_clear(iotk_error_pool(abs(ierr))) - iotk_error_pool_used(abs(ierr)) = .false. - iotk_error_pool_order(abs(ierr)) = 0 - end if - end if - ierr = 0 -end subroutine iotk_error_clear_i - -function iotk_error_add_x() - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer :: i,ii(1),order - integer :: iotk_error_add_x - do i = 1 , iotk_error_pool_size - if(.not. iotk_error_pool_used(i)) exit - end do - if(i>iotk_error_pool_size) then - order=0 - do order=1,iotk_error_pool_size - ii = minloc(iotk_error_pool_order,iotk_error_pool_order>=order) - iotk_error_pool_order(ii(1)) = order - end do - if(iotk_error_warn_overflow) then - write(iotk_error_unit,*) "Warning: ERROR OVERFLOW" - call iotk_error_print(iotk_error_pool(iotk_error_pool_size),iotk_error_unit) - end if - ii = minloc(iotk_error_pool_order) - i = ii(1) - call iotk_error_clear(iotk_error_pool(i)) - end if - iotk_error_pool_order(i) = maxval(iotk_error_pool_order)+1 - iotk_error_pool_used(i) = .true. - call iotk_error_init(iotk_error_pool(i)) - iotk_error_add_x=i -end function iotk_error_add_x - - -subroutine iotk_error_append_e(error,str) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: str - character, pointer :: tmp(:) - integer :: i,strlen - strlen = min(len(str),iotk_error_linelength) - if(.not.associated(error%str)) then - allocate(error%str(strlen+1)) - do i = 1 , strlen - error%str(i) = str(i:i) - end do - error%str(strlen+1) = iotk_eos - else - tmp => error%str - allocate(error%str(size(tmp)+strlen+1)) - error%str (1:size(tmp)) = tmp - do i = 1 , strlen - error%str (size(tmp)+i) = str(i:i) - end do - error%str(size(tmp)+strlen+1) = iotk_eos - deallocate(tmp) - end if -end subroutine iotk_error_append_e - -subroutine iotk_error_append_i(ierr,str) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: str - if(ierr==0) ierr = iotk_error_add() - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_append(iotk_error_pool(abs(ierr)),str) -end subroutine iotk_error_append_i - -subroutine iotk_error_print_e(error,unit) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(in) :: error - integer, intent(in) :: unit - integer :: i - if(.not.associated(error%str)) return - do i=1,size(error%str) - if(error%str(i)==iotk_eos) then - write(unit,"(a)") - else - write(unit,"(a)",advance='no') error%str(i) - end if - end do -end subroutine iotk_error_print_e - -subroutine iotk_error_print_i(ierr,unit) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: ierr - integer, intent(in) :: unit - if(ierr==0) return - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_print(iotk_error_pool(abs(ierr)),unit) -end subroutine iotk_error_print_i - -subroutine iotk_error_issue_e(error,sub,file,line) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: sub - character(len=*), intent(in) :: file - integer, intent(in) :: line - call iotk_error_append(error,"# ERROR IN: "//trim(sub)//" ("//trim(file)//":"//trim(iotk_itoa(line))//")") -end subroutine iotk_error_issue_e - -subroutine iotk_error_issue_i(ierr,sub,file,line) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: sub - character(len=*), intent(in) :: file - integer, intent(in) :: line - if(ierr==0) ierr = iotk_error_add() - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_issue(iotk_error_pool(abs(ierr)),sub,file,line) -end subroutine iotk_error_issue_i - -subroutine iotk_error_msg_e(error,msg) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: msg - call iotk_error_append(error,"# "//msg) -end subroutine iotk_error_msg_e - -subroutine iotk_error_msg_i(ierr,msg) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: msg - if(ierr==0) ierr = iotk_error_add() - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_msg(iotk_error_pool(abs(ierr)),msg) -end subroutine iotk_error_msg_i - -function iotk_error_check_e(error) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(in) :: error - logical :: iotk_error_check_e - iotk_error_check_e = .false. - if(associated(error%str)) iotk_error_check_e = .true. -end function iotk_error_check_e - -function iotk_error_check_i(ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: ierr - logical :: iotk_error_check_i - iotk_error_check_i = .false. - if(ierr==0) return - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - iotk_error_check_i = .true. -end function iotk_error_check_i - -subroutine iotk_error_write_character_e(error,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: name - character(len=*), intent(in) :: val - integer :: namelen,vallen - namelen=verify(name,alphabet_//numbers//".()%")-1 - if(namelen<0) namelen=len(name) - vallen =scan (val,iotk_eos)-1 - if(vallen<0) vallen=len(val) - call iotk_error_append(error,name(1:namelen)//"="//val(1:vallen)) -end subroutine iotk_error_write_character_e - -subroutine iotk_error_write_character_i(ierr,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: name - character(len=*), intent(in) :: val - if(ierr==0) ierr = iotk_error_add() - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_write(iotk_error_pool(abs(ierr)),name,val) -end subroutine iotk_error_write_character_i - -subroutine iotk_error_write_logical_e(error,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: name - logical, intent(in) :: val - integer :: namelen - character :: valc - namelen=verify(name,alphabet_//numbers//".()%")-1 - if(namelen<0) namelen=len(name) - valc="F" - if(val) valc="T" - call iotk_error_append(error,name(1:namelen)//"="//valc) -end subroutine iotk_error_write_logical_e - -subroutine iotk_error_write_logical_i(ierr,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: name - logical, intent(in) :: val - if(ierr==0) ierr = iotk_error_add() - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_write(iotk_error_pool(abs(ierr)),name,val) -end subroutine iotk_error_write_logical_i - -subroutine iotk_error_write_integer_e(error,name,val) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: name - integer, intent(in) :: val - integer :: namelen - namelen=verify(name,alphabet_//numbers//".()%")-1 - if(namelen<0) namelen=len(name) - call iotk_error_append(error,name(1:namelen)//"="//trim(iotk_itoa(val))) -end subroutine iotk_error_write_integer_e - -subroutine iotk_error_write_integer_i(ierr,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: name - integer, intent(in) :: val - if(ierr==0) ierr = iotk_error_add() - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_write(iotk_error_pool(abs(ierr)),name,val) -end subroutine iotk_error_write_integer_i - -subroutine iotk_error_scan_character_e(error,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(in) :: error - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: val -#else - character(len=*), intent(out):: val -#endif - integer :: i1,i2,i3 - logical :: eos,found - i2 = 0 - val="" - found = .false. - if(.not.associated(error%str)) return - do i1 = size(error%str) , 0 , -1 - eos = .false. - if(i1==0) eos = .true. - if(.not.eos) then - if(error%str(i1)==iotk_eos) eos = .true. - end if - if(eos) then - do i2=1,len(name) - if(i1+i2 > size(error%str)) goto 1 - if(error%str(i1+i2)/=name(i2:i2)) goto 1 - end do - if(i1+i2 > size(error%str)) goto 1 - if(error%str(i1+i2)/="=") goto 1 - found=.true. - exit - end if -1 continue - end do - val="" - if(found) then - do i3=1,len(val) - if(i1+i2+i3>size(error%str)) exit - if(error%str(i1+i2+i3)==iotk_eos) exit - val(i3:i3)=error%str(i1+i2+i3) - end do - end if -end subroutine iotk_error_scan_character_e - -subroutine iotk_error_scan_character_i(ierr,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: ierr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: val -#else - character(len=*), intent(out):: val -#endif - val = "" - if(ierr==0) return - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_scan(iotk_error_pool(abs(ierr)),name,val) -end subroutine iotk_error_scan_character_i - -subroutine iotk_error_scan_logical_e(error,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(in) :: error - character(len=*), intent(in) :: name - logical, intent(out):: val - character :: valc - val = .false. - call iotk_error_scan(error,name,valc) - if(valc=="T" .or. valc=="t") val=.true. -end subroutine iotk_error_scan_logical_e - -subroutine iotk_error_scan_logical_i(ierr,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: ierr - character(len=*), intent(in) :: name - logical, intent(out):: val - val = .false. - if(ierr==0) return - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_scan(iotk_error_pool(abs(ierr)),name,val) -end subroutine iotk_error_scan_logical_i - -subroutine iotk_error_scan_integer_e(error,name,val) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(in) :: error - character(len=*), intent(in) :: name - integer, intent(out):: val - character(range(val)+2) :: valc - call iotk_error_scan(error,name,valc) - call iotk_atoi(val,valc) -end subroutine iotk_error_scan_integer_e - -subroutine iotk_error_scan_integer_i(ierr,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: ierr - character(len=*), intent(in) :: name - integer, intent(out):: val - val = 0 - if(ierr==0) return - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_scan(iotk_error_pool(abs(ierr)),name,val) -end subroutine iotk_error_scan_integer_i - -function iotk_error_pool_pending_x() - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer :: iotk_error_pool_pending_x - iotk_error_pool_pending_x = count (iotk_error_pool_used) -end function iotk_error_pool_pending_x - -subroutine iotk_error_handler_x(ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: ierr - integer :: pending,i -#ifdef __IOTK_MPI_ABORT - include 'mpif.h' - integer :: ierrx -#endif - if(ierr==0) return - do i = 1 , iotk_error_linelength - write(iotk_error_unit,"(a)",advance='no') "#" - end do - write(iotk_error_unit,*) - pending = iotk_error_pool_pending() - if(pending>1) then - write(iotk_error_unit,"(a)") "# WARNING: there are pending errors" - do i = 1 , iotk_error_pool_size - if(iotk_error_pool_used(i) .and. i/=abs(ierr)) then - write(iotk_error_unit,"(a)") "# PENDING ERROR (ierr="//trim(iotk_itoa(i))//")" - call iotk_error_print(i,iotk_error_unit) - end if - end do - end if - write(iotk_error_unit,"(a)") "# FROM IOTK LIBRARY, VERSION "//trim(iotk_version) - write(iotk_error_unit,"(a)") "# UNRECOVERABLE ERROR (ierr="//trim(iotk_itoa(ierr))//")" - call iotk_error_print(ierr,0) - do i = 1 , iotk_error_linelength - write(iotk_error_unit,"(a)",advance='no') "#" - end do - write(iotk_error_unit,*) -#ifdef __IOTK_MPI_ABORT - call MPI_Abort(MPI_COMM_WORLD,1,ierrx) -#else - stop -#endif -end subroutine iotk_error_handler_x diff --git a/quantum_espresso/kcp/iotk/src/iotk_error.spp b/quantum_espresso/kcp/iotk/src/iotk_error.spp deleted file mode 100644 index 40545eaa7..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_error.spp +++ /dev/null @@ -1,512 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -> REVISION='$Revision: 1.1.1.1 $' -> REVISION="${REVISION//${dol}/}" - -! ERROR ROUTINES -subroutine iotk_error_init_e(error) - use iotk_base - implicit none - type(iotk_error), intent(out) :: error - nullify(error%str) -end subroutine iotk_error_init_e - -subroutine iotk_error_init_i(ierr) - implicit none - integer, intent(out) :: ierr - ierr = 0 -end subroutine iotk_error_init_i - -subroutine iotk_error_clear_e(error) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error - if(associated(error%str)) deallocate(error%str) -end subroutine iotk_error_clear_e - -subroutine iotk_error_clear_i(ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(inout) :: ierr - if(abs(ierr)>0 .and. abs(ierr)<=iotk_error_pool_size) then - if(iotk_error_pool_used(abs(ierr))) then - call iotk_error_clear(iotk_error_pool(abs(ierr))) - iotk_error_pool_used(abs(ierr)) = .false. - iotk_error_pool_order(abs(ierr)) = 0 - end if - end if - ierr = 0 -end subroutine iotk_error_clear_i - -function iotk_error_add_x() - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer :: i,ii(1),order - integer :: iotk_error_add_x - do i = 1 , iotk_error_pool_size - if(.not. iotk_error_pool_used(i)) exit - end do - if(i>iotk_error_pool_size) then - order=0 - do order=1,iotk_error_pool_size - ii = minloc(iotk_error_pool_order,iotk_error_pool_order>=order) - iotk_error_pool_order(ii(1)) = order - end do - if(iotk_error_warn_overflow) then - write(iotk_error_unit,*) "Warning: ERROR OVERFLOW" - call iotk_error_print(iotk_error_pool(iotk_error_pool_size),iotk_error_unit) - end if - ii = minloc(iotk_error_pool_order) - i = ii(1) - call iotk_error_clear(iotk_error_pool(i)) - end if - iotk_error_pool_order(i) = maxval(iotk_error_pool_order)+1 - iotk_error_pool_used(i) = .true. - call iotk_error_init(iotk_error_pool(i)) - iotk_error_add_x=i -end function iotk_error_add_x - - -subroutine iotk_error_append_e(error,str) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: str - character, pointer :: tmp(:) - integer :: i,strlen - strlen = min(len(str),iotk_error_linelength) - if(.not.associated(error%str)) then - allocate(error%str(strlen+1)) - do i = 1 , strlen - error%str(i) = str(i:i) - end do - error%str(strlen+1) = iotk_eos - else - tmp => error%str - allocate(error%str(size(tmp)+strlen+1)) - error%str (1:size(tmp)) = tmp - do i = 1 , strlen - error%str (size(tmp)+i) = str(i:i) - end do - error%str(size(tmp)+strlen+1) = iotk_eos - deallocate(tmp) - end if -end subroutine iotk_error_append_e - -subroutine iotk_error_append_i(ierr,str) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: str - if(ierr==0) ierr = iotk_error_add() - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_append(iotk_error_pool(abs(ierr)),str) -end subroutine iotk_error_append_i - -subroutine iotk_error_print_e(error,unit) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(in) :: error - integer, intent(in) :: unit - integer :: i - if(.not.associated(error%str)) return - do i=1,size(error%str) - if(error%str(i)==iotk_eos) then - write(unit,"(a)") - else - write(unit,"(a)",advance='no') error%str(i) - end if - end do -end subroutine iotk_error_print_e - -subroutine iotk_error_print_i(ierr,unit) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: ierr - integer, intent(in) :: unit - if(ierr==0) return - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_print(iotk_error_pool(abs(ierr)),unit) -end subroutine iotk_error_print_i - -subroutine iotk_error_issue_e(error,sub,file,line) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: sub - character(len=*), intent(in) :: file - integer, intent(in) :: line - call iotk_error_append(error,"# ERROR IN: "//trim(sub)//" ("//trim(file)//":"//trim(iotk_itoa(line))//")") -end subroutine iotk_error_issue_e - -subroutine iotk_error_issue_i(ierr,sub,file,line) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: sub - character(len=*), intent(in) :: file - integer, intent(in) :: line - if(ierr==0) ierr = iotk_error_add() - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_issue(iotk_error_pool(abs(ierr)),sub,file,line) -end subroutine iotk_error_issue_i - -subroutine iotk_error_msg_e(error,msg) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: msg - call iotk_error_append(error,"# "//msg) -end subroutine iotk_error_msg_e - -subroutine iotk_error_msg_i(ierr,msg) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: msg - if(ierr==0) ierr = iotk_error_add() - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_msg(iotk_error_pool(abs(ierr)),msg) -end subroutine iotk_error_msg_i - -function iotk_error_check_e(error) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(in) :: error - logical :: iotk_error_check_e - iotk_error_check_e = .false. - if(associated(error%str)) iotk_error_check_e = .true. -end function iotk_error_check_e - -function iotk_error_check_i(ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: ierr - logical :: iotk_error_check_i - iotk_error_check_i = .false. - if(ierr==0) return - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - iotk_error_check_i = .true. -end function iotk_error_check_i - -subroutine iotk_error_write_character_e(error,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: name - character(len=*), intent(in) :: val - integer :: namelen,vallen - namelen=verify(name,alphabet_//numbers//".()%")-1 - if(namelen<0) namelen=len(name) - vallen =scan (val,iotk_eos)-1 - if(vallen<0) vallen=len(val) - call iotk_error_append(error,name(1:namelen)//"="//val(1:vallen)) -end subroutine iotk_error_write_character_e - -subroutine iotk_error_write_character_i(ierr,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: name - character(len=*), intent(in) :: val - if(ierr==0) ierr = iotk_error_add() - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_write(iotk_error_pool(abs(ierr)),name,val) -end subroutine iotk_error_write_character_i - -subroutine iotk_error_write_logical_e(error,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: name - logical, intent(in) :: val - integer :: namelen - character :: valc - namelen=verify(name,alphabet_//numbers//".()%")-1 - if(namelen<0) namelen=len(name) - valc="F" - if(val) valc="T" - call iotk_error_append(error,name(1:namelen)//"="//valc) -end subroutine iotk_error_write_logical_e - -subroutine iotk_error_write_logical_i(ierr,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: name - logical, intent(in) :: val - if(ierr==0) ierr = iotk_error_add() - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_write(iotk_error_pool(abs(ierr)),name,val) -end subroutine iotk_error_write_logical_i - -subroutine iotk_error_write_integer_e(error,name,val) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: name - integer, intent(in) :: val - integer :: namelen - namelen=verify(name,alphabet_//numbers//".()%")-1 - if(namelen<0) namelen=len(name) - call iotk_error_append(error,name(1:namelen)//"="//trim(iotk_itoa(val))) -end subroutine iotk_error_write_integer_e - -subroutine iotk_error_write_integer_i(ierr,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: name - integer, intent(in) :: val - if(ierr==0) ierr = iotk_error_add() - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_write(iotk_error_pool(abs(ierr)),name,val) -end subroutine iotk_error_write_integer_i - -subroutine iotk_error_scan_character_e(error,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(in) :: error - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: val -#else - character(len=*), intent(out):: val -#endif - integer :: i1,i2,i3 - logical :: eos,found - i2 = 0 - val="" - found = .false. - if(.not.associated(error%str)) return - do i1 = size(error%str) , 0 , -1 - eos = .false. - if(i1==0) eos = .true. - if(.not.eos) then - if(error%str(i1)==iotk_eos) eos = .true. - end if - if(eos) then - do i2=1,len(name) - if(i1+i2 > size(error%str)) goto 1 - if(error%str(i1+i2)/=name(i2:i2)) goto 1 - end do - if(i1+i2 > size(error%str)) goto 1 - if(error%str(i1+i2)/="=") goto 1 - found=.true. - exit - end if -1 continue - end do - val="" - if(found) then - do i3=1,len(val) - if(i1+i2+i3>size(error%str)) exit - if(error%str(i1+i2+i3)==iotk_eos) exit - val(i3:i3)=error%str(i1+i2+i3) - end do - end if -end subroutine iotk_error_scan_character_e - -subroutine iotk_error_scan_character_i(ierr,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: ierr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: val -#else - character(len=*), intent(out):: val -#endif - val = "" - if(ierr==0) return - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_scan(iotk_error_pool(abs(ierr)),name,val) -end subroutine iotk_error_scan_character_i - -subroutine iotk_error_scan_logical_e(error,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(in) :: error - character(len=*), intent(in) :: name - logical, intent(out):: val - character :: valc - val = .false. - call iotk_error_scan(error,name,valc) - if(valc=="T" .or. valc=="t") val=.true. -end subroutine iotk_error_scan_logical_e - -subroutine iotk_error_scan_logical_i(ierr,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: ierr - character(len=*), intent(in) :: name - logical, intent(out):: val - val = .false. - if(ierr==0) return - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_scan(iotk_error_pool(abs(ierr)),name,val) -end subroutine iotk_error_scan_logical_i - -subroutine iotk_error_scan_integer_e(error,name,val) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - type(iotk_error), intent(in) :: error - character(len=*), intent(in) :: name - integer, intent(out):: val - character(range(val)+2) :: valc - call iotk_error_scan(error,name,valc) - call iotk_atoi(val,valc) -end subroutine iotk_error_scan_integer_e - -subroutine iotk_error_scan_integer_i(ierr,name,val) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: ierr - character(len=*), intent(in) :: name - integer, intent(out):: val - val = 0 - if(ierr==0) return - if(abs(ierr)>iotk_error_pool_size) return - if(.not. iotk_error_pool_used(abs(ierr))) return - call iotk_error_scan(iotk_error_pool(abs(ierr)),name,val) -end subroutine iotk_error_scan_integer_i - -function iotk_error_pool_pending_x() - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer :: iotk_error_pool_pending_x - iotk_error_pool_pending_x = count (iotk_error_pool_used) -end function iotk_error_pool_pending_x - -subroutine iotk_error_handler_x(ierr) - use iotk_base - use iotk_error_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: ierr - integer :: pending,i -#ifdef __IOTK_MPI_ABORT - include 'mpif.h' - integer :: ierrx -#endif - if(ierr==0) return - do i = 1 , iotk_error_linelength - write(iotk_error_unit,"(a)",advance='no') "#" - end do - write(iotk_error_unit,*) - pending = iotk_error_pool_pending() - if(pending>1) then - write(iotk_error_unit,"(a)") "# WARNING: there are pending errors" - do i = 1 , iotk_error_pool_size - if(iotk_error_pool_used(i) .and. i/=abs(ierr)) then - write(iotk_error_unit,"(a)") "# PENDING ERROR (ierr="//trim(iotk_itoa(i))//")" - call iotk_error_print(i,iotk_error_unit) - end if - end do - end if - write(iotk_error_unit,"(a)") "# FROM IOTK LIBRARY, VERSION "//trim(iotk_version) - write(iotk_error_unit,"(a)") "# UNRECOVERABLE ERROR (ierr="//trim(iotk_itoa(ierr))//")" - call iotk_error_print(ierr,0) - do i = 1 , iotk_error_linelength - write(iotk_error_unit,"(a)",advance='no') "#" - end do - write(iotk_error_unit,*) -#ifdef __IOTK_MPI_ABORT - call MPI_Abort(MPI_COMM_WORLD,1,ierrx) -#else - stop -#endif -end subroutine iotk_error_handler_x - diff --git a/quantum_espresso/kcp/iotk/src/iotk_error_interf.f90 b/quantum_espresso/kcp/iotk/src/iotk_error_interf.f90 deleted file mode 100644 index 87e3b0325..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_error_interf.f90 +++ /dev/null @@ -1,272 +0,0 @@ -# 1 "iotk_error_interf.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_error_interf.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_error_interf.spp" - -module iotk_error_interf -implicit none -private - -public :: iotk_error_init -public :: iotk_error_clear -public :: iotk_error_append -public :: iotk_error_add -public :: iotk_error_print -public :: iotk_error_issue -public :: iotk_error_check -public :: iotk_error_msg -public :: iotk_error_write -public :: iotk_error_scan -public :: iotk_error_handler -public :: iotk_error_pool_pending - -interface iotk_error_init -subroutine iotk_error_init_e(error) - use iotk_base - implicit none - type(iotk_error), intent(out) :: error -end subroutine iotk_error_init_e -subroutine iotk_error_init_i(ierr) - use iotk_base - implicit none - integer, intent(out) :: ierr -end subroutine iotk_error_init_i -end interface - -interface iotk_error_clear -subroutine iotk_error_clear_e(error) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error -end subroutine iotk_error_clear_e -subroutine iotk_error_clear_i(ierr) - use iotk_base - implicit none - integer, intent(inout) :: ierr -end subroutine iotk_error_clear_i -end interface - -interface iotk_error_add -function iotk_error_add_x() - use iotk_base - implicit none - integer :: iotk_error_add_x -end function iotk_error_add_x -end interface - -interface iotk_error_append -subroutine iotk_error_append_e(error,str) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: str -end subroutine iotk_error_append_e -subroutine iotk_error_append_i(ierr,str) - use iotk_base - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: str -end subroutine iotk_error_append_i -end interface - -interface iotk_error_print -subroutine iotk_error_print_e(error,unit) - use iotk_base - implicit none - type(iotk_error), intent(in) :: error - integer, intent(in) :: unit -end subroutine iotk_error_print_e -subroutine iotk_error_print_i(ierr,unit) - use iotk_base - implicit none - integer, intent(in) :: ierr - integer, intent(in) :: unit -end subroutine iotk_error_print_i -end interface - -interface iotk_error_issue -subroutine iotk_error_issue_e(error,sub,file,line) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: sub - character(len=*), intent(in) :: file - integer, intent(in) :: line -end subroutine iotk_error_issue_e -subroutine iotk_error_issue_i(ierr,sub,file,line) - use iotk_base - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: sub - character(len=*), intent(in) :: file - integer, intent(in) :: line -end subroutine iotk_error_issue_i -end interface - -interface iotk_error_msg -subroutine iotk_error_msg_e(error,msg) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: msg -end subroutine iotk_error_msg_e -subroutine iotk_error_msg_i(ierr,msg) - use iotk_base - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: msg -end subroutine iotk_error_msg_i -end interface - -interface iotk_error_check -function iotk_error_check_e(error) - use iotk_base - implicit none - type(iotk_error), intent(in) :: error - logical :: iotk_error_check_e -end function iotk_error_check_e -function iotk_error_check_i(ierr) - use iotk_base - implicit none - integer, intent(in) :: ierr - logical :: iotk_error_check_i -end function iotk_error_check_i -end interface - -interface iotk_error_write -subroutine iotk_error_write_character_e(error,name,val) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: name - character(len=*), intent(in) :: val -end subroutine iotk_error_write_character_e -subroutine iotk_error_write_character_i(ierr,name,val) - use iotk_base - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: name - character(len=*), intent(in) :: val -end subroutine iotk_error_write_character_i -subroutine iotk_error_write_logical_e(error,name,val) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: name - logical, intent(in) :: val -end subroutine iotk_error_write_logical_e -subroutine iotk_error_write_logical_i(ierr,name,val) - use iotk_base - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: name - logical, intent(in) :: val -end subroutine iotk_error_write_logical_i -subroutine iotk_error_write_integer_e(error,name,val) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: name - integer, intent(in) :: val -end subroutine iotk_error_write_integer_e -subroutine iotk_error_write_integer_i(ierr,name,val) - use iotk_base - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: name - integer, intent(in) :: val -end subroutine iotk_error_write_integer_i -end interface - -interface iotk_error_scan -subroutine iotk_error_scan_character_e(error,name,val) - use iotk_base - implicit none - type(iotk_error), intent(in) :: error - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: val -#else - character(len=*), intent(out):: val -#endif -end subroutine iotk_error_scan_character_e -subroutine iotk_error_scan_character_i(ierr,name,val) - use iotk_base - implicit none - integer, intent(in) :: ierr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: val -#else - character(len=*), intent(out):: val -#endif -end subroutine iotk_error_scan_character_i -subroutine iotk_error_scan_logical_e(error,name,val) - use iotk_base - implicit none - type(iotk_error), intent(in) :: error - character(len=*), intent(in) :: name - logical, intent(out):: val -end subroutine iotk_error_scan_logical_e -subroutine iotk_error_scan_logical_i(ierr,name,val) - use iotk_base - implicit none - integer, intent(in) :: ierr - character(len=*), intent(in) :: name - logical, intent(out):: val -end subroutine iotk_error_scan_logical_i -subroutine iotk_error_scan_integer_e(error,name,val) - use iotk_base - implicit none - type(iotk_error), intent(in) :: error - character(len=*), intent(in) :: name - integer, intent(out):: val -end subroutine iotk_error_scan_integer_e -subroutine iotk_error_scan_integer_i(ierr,name,val) - use iotk_base - implicit none - integer, intent(in) :: ierr - character(len=*), intent(in) :: name - integer, intent(out):: val -end subroutine iotk_error_scan_integer_i -end interface - -interface iotk_error_pool_pending -function iotk_error_pool_pending_x() - use iotk_base - implicit none - integer :: iotk_error_pool_pending_x -end function iotk_error_pool_pending_x -end interface - -interface iotk_error_handler -subroutine iotk_error_handler_x(ierr) - use iotk_base - implicit none - integer, intent(in) :: ierr -end subroutine iotk_error_handler_x -end interface - -end module iotk_error_interf diff --git a/quantum_espresso/kcp/iotk/src/iotk_error_interf.spp b/quantum_espresso/kcp/iotk/src/iotk_error_interf.spp deleted file mode 100644 index 4a36260a3..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_error_interf.spp +++ /dev/null @@ -1,276 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -module iotk_error_interf -implicit none -private - -public :: iotk_error_init -public :: iotk_error_clear -public :: iotk_error_append -public :: iotk_error_add -public :: iotk_error_print -public :: iotk_error_issue -public :: iotk_error_check -public :: iotk_error_msg -public :: iotk_error_write -public :: iotk_error_scan -public :: iotk_error_handler -public :: iotk_error_pool_pending - -interface iotk_error_init -subroutine iotk_error_init_e(error) - use iotk_base - implicit none - type(iotk_error), intent(out) :: error -end subroutine iotk_error_init_e -subroutine iotk_error_init_i(ierr) - use iotk_base - implicit none - integer, intent(out) :: ierr -end subroutine iotk_error_init_i -end interface - -interface iotk_error_clear -subroutine iotk_error_clear_e(error) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error -end subroutine iotk_error_clear_e -subroutine iotk_error_clear_i(ierr) - use iotk_base - implicit none - integer, intent(inout) :: ierr -end subroutine iotk_error_clear_i -end interface - -interface iotk_error_add -function iotk_error_add_x() - use iotk_base - implicit none - integer :: iotk_error_add_x -end function iotk_error_add_x -end interface - -interface iotk_error_append -subroutine iotk_error_append_e(error,str) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: str -end subroutine iotk_error_append_e -subroutine iotk_error_append_i(ierr,str) - use iotk_base - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: str -end subroutine iotk_error_append_i -end interface - -interface iotk_error_print -subroutine iotk_error_print_e(error,unit) - use iotk_base - implicit none - type(iotk_error), intent(in) :: error - integer, intent(in) :: unit -end subroutine iotk_error_print_e -subroutine iotk_error_print_i(ierr,unit) - use iotk_base - implicit none - integer, intent(in) :: ierr - integer, intent(in) :: unit -end subroutine iotk_error_print_i -end interface - -interface iotk_error_issue -subroutine iotk_error_issue_e(error,sub,file,line) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: sub - character(len=*), intent(in) :: file - integer, intent(in) :: line -end subroutine iotk_error_issue_e -subroutine iotk_error_issue_i(ierr,sub,file,line) - use iotk_base - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: sub - character(len=*), intent(in) :: file - integer, intent(in) :: line -end subroutine iotk_error_issue_i -end interface - -interface iotk_error_msg -subroutine iotk_error_msg_e(error,msg) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: msg -end subroutine iotk_error_msg_e -subroutine iotk_error_msg_i(ierr,msg) - use iotk_base - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: msg -end subroutine iotk_error_msg_i -end interface - -interface iotk_error_check -function iotk_error_check_e(error) - use iotk_base - implicit none - type(iotk_error), intent(in) :: error - logical :: iotk_error_check_e -end function iotk_error_check_e -function iotk_error_check_i(ierr) - use iotk_base - implicit none - integer, intent(in) :: ierr - logical :: iotk_error_check_i -end function iotk_error_check_i -end interface - -interface iotk_error_write -subroutine iotk_error_write_character_e(error,name,val) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: name - character(len=*), intent(in) :: val -end subroutine iotk_error_write_character_e -subroutine iotk_error_write_character_i(ierr,name,val) - use iotk_base - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: name - character(len=*), intent(in) :: val -end subroutine iotk_error_write_character_i -subroutine iotk_error_write_logical_e(error,name,val) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: name - logical, intent(in) :: val -end subroutine iotk_error_write_logical_e -subroutine iotk_error_write_logical_i(ierr,name,val) - use iotk_base - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: name - logical, intent(in) :: val -end subroutine iotk_error_write_logical_i -subroutine iotk_error_write_integer_e(error,name,val) - use iotk_base - implicit none - type(iotk_error), intent(inout) :: error - character(len=*), intent(in) :: name - integer, intent(in) :: val -end subroutine iotk_error_write_integer_e -subroutine iotk_error_write_integer_i(ierr,name,val) - use iotk_base - implicit none - integer, intent(inout) :: ierr - character(len=*), intent(in) :: name - integer, intent(in) :: val -end subroutine iotk_error_write_integer_i -end interface - -interface iotk_error_scan -subroutine iotk_error_scan_character_e(error,name,val) - use iotk_base - implicit none - type(iotk_error), intent(in) :: error - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: val -#else - character(len=*), intent(out):: val -#endif -end subroutine iotk_error_scan_character_e -subroutine iotk_error_scan_character_i(ierr,name,val) - use iotk_base - implicit none - integer, intent(in) :: ierr - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: val -#else - character(len=*), intent(out):: val -#endif -end subroutine iotk_error_scan_character_i -subroutine iotk_error_scan_logical_e(error,name,val) - use iotk_base - implicit none - type(iotk_error), intent(in) :: error - character(len=*), intent(in) :: name - logical, intent(out):: val -end subroutine iotk_error_scan_logical_e -subroutine iotk_error_scan_logical_i(ierr,name,val) - use iotk_base - implicit none - integer, intent(in) :: ierr - character(len=*), intent(in) :: name - logical, intent(out):: val -end subroutine iotk_error_scan_logical_i -subroutine iotk_error_scan_integer_e(error,name,val) - use iotk_base - implicit none - type(iotk_error), intent(in) :: error - character(len=*), intent(in) :: name - integer, intent(out):: val -end subroutine iotk_error_scan_integer_e -subroutine iotk_error_scan_integer_i(ierr,name,val) - use iotk_base - implicit none - integer, intent(in) :: ierr - character(len=*), intent(in) :: name - integer, intent(out):: val -end subroutine iotk_error_scan_integer_i -end interface - -interface iotk_error_pool_pending -function iotk_error_pool_pending_x() - use iotk_base - implicit none - integer :: iotk_error_pool_pending_x -end function iotk_error_pool_pending_x -end interface - -interface iotk_error_handler -subroutine iotk_error_handler_x(ierr) - use iotk_base - implicit none - integer, intent(in) :: ierr -end subroutine iotk_error_handler_x -end interface - -end module iotk_error_interf - diff --git a/quantum_espresso/kcp/iotk/src/iotk_files.f90 b/quantum_espresso/kcp/iotk/src/iotk_files.f90 deleted file mode 100644 index fb84bd7e2..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_files.f90 +++ /dev/null @@ -1,871 +0,0 @@ -# 1 "iotk_files.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_files.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_files.spp" - -# 33 "iotk_files.spp" - -# 35 "iotk_files.spp" -subroutine iotk_copyfile_x(dummy,source,dest,source_unit,dest_unit,ierr) - use iotk_base - use iotk_error_interf - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: source - character(len=*), optional, intent(in) :: dest - integer, optional, intent(in) :: source_unit - integer, optional, intent(in) :: dest_unit - integer, optional, intent(out):: ierr - integer :: ierrl,unit1,unit2 - integer :: iostat,length - character(len=iotk_linlenx) :: line - iostat = 0 - ierrl = 0 - if(present(source) .eqv. present(source_unit)) then - call iotk_error_issue(ierrl,"iotk_copyfile_x",__FILE__,__LINE__) -# 55 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 55 "iotk_files.spp" -call iotk_error_msg(ierrl,'Use exactly one between source and source_unit') - goto 1 - end if - if(present(dest) .eqv. present(dest_unit)) then - call iotk_error_issue(ierrl,"iotk_copyfile_x",__FILE__,__LINE__) -# 59 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 59 "iotk_files.spp" -call iotk_error_msg(ierrl,'Use exactly one between dest and dest_unit') - goto 1 - end if - if(present(source)) then - call iotk_free_unit(unit1,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_copyfile_x",__FILE__,__LINE__) -# 65 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 65 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error searching for a free unit') - goto 1 - end if - open(unit1,file=trim(iotk_strpad(source)),iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_copyfile_x",__FILE__,__LINE__) -# 70 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 70 "iotk_files.spp" -call iotk_error_msg(ierrl,'messaggio') -# 70 "iotk_files.spp" -call iotk_error_write(ierrl,"sourcefile",trim(iotk_strpad(source))) -# 70 "iotk_files.spp" -call iotk_error_write(ierrl,"sourceunit",unit1) -# 70 "iotk_files.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - else - unit1=source_unit - end if - if(present(dest)) then - call iotk_free_unit(unit2,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_copyfile_x",__FILE__,__LINE__) -# 79 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - open(unit2,file=trim(iotk_strpad(dest)),iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_copyfile_x",__FILE__,__LINE__) -# 84 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 84 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error opening destination file') -# 84 "iotk_files.spp" -call iotk_error_write(ierrl,"destfile",trim(iotk_strpad(dest))) -# 84 "iotk_files.spp" -call iotk_error_write(ierrl,"destunit",unit2) -# 84 "iotk_files.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - else - unit2=dest_unit - end if - do - call iotk_getline(unit1,line,length,ierrl) - if(ierrl/=0) then - call iotk_error_scan(ierrl,"iostat",iostat) - if(iostat<0) then - call iotk_error_clear(ierrl) - exit - end if - call iotk_error_issue(ierrl,"iotk_copyfile_x",__FILE__,__LINE__) -# 98 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 98 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error reading source file') -# 98 "iotk_files.spp" -call iotk_error_write(ierrl,"sourceunit",unit1) - goto 1 - end if - write(unit2,"(a)",iostat=iostat) line(1:length) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_copyfile_x",__FILE__,__LINE__) -# 103 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 103 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error writing destination file') -# 103 "iotk_files.spp" -call iotk_error_write(ierrl,"destunit",unit2) -# 103 "iotk_files.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end do - iostat=0 - if(present(source)) then - close(unit1,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_copyfile_x",__FILE__,__LINE__) -# 111 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 111 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error closing source file') -# 111 "iotk_files.spp" -call iotk_error_write(ierrl,"sourcefile",trim(iotk_strpad(source))) -# 111 "iotk_files.spp" -call iotk_error_write(ierrl,"sourceunit",unit1) -# 111 "iotk_files.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(dest)) then - close(unit2,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_copyfile_x",__FILE__,__LINE__) -# 118 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 118 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error closing destination file') -# 118 "iotk_files.spp" -call iotk_error_write(ierrl,"destfile",trim(iotk_strpad(dest))) -# 118 "iotk_files.spp" -call iotk_error_write(ierrl,"destunit",unit2) -# 118 "iotk_files.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_copyfile_x - -# 131 "iotk_files.spp" -subroutine iotk_link_x(unit,name,file,dummy,binary,raw,create,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_files_interf - use iotk_str_interf - use iotk_write_interf - use iotk_misc_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - character(*), intent(in) :: file - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: binary - logical, optional, intent(in) :: raw - logical, optional, intent(in) :: create - integer, optional, intent(out) :: ierr - logical :: lbinary,lraw,lcreate - integer :: ierrl,iostat - integer :: lunit,link_unit - type(iotk_unit), pointer :: this_unit - character(iotk_attlenx) :: attr - character(iotk_fillenx) :: oldfile - ierrl = 0 - iostat = 0 - lbinary=.false. - lraw =.false. - lcreate=.false. - if(present(binary)) lbinary = binary - if(present(raw)) lraw = raw - if(present(create)) lcreate = create - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this_unit) - if(.not.associated(this_unit)) then - call iotk_error_issue(ierrl,"iotk_link",__FILE__,__LINE__) -# 166 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 166 "iotk_files.spp" -call iotk_error_msg(ierrl,'Links do not apply to units which are not explicitly connected') - goto 1 - end if - call iotk_write_attr(attr,"iotk_link",iotk_strtrim(file),ierr=ierrl,first=.true.) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_link",__FILE__,__LINE__) -# 171 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - if(lraw) then - if(lbinary) then - call iotk_write_attr(attr,"iotk_binary",lbinary,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_link",__FILE__,__LINE__) -# 178 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - end if - call iotk_write_attr(attr,"iotk_raw",lraw,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_link",__FILE__,__LINE__) -# 184 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - end if - call iotk_write_begin(unit,name,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_link",__FILE__,__LINE__) -# 190 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - call iotk_write_comment(unit,"This is a link to the file indicated in the iotk_link attribute",ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_link",__FILE__,__LINE__) -# 195 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - call iotk_write_end (unit,name,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_link",__FILE__,__LINE__) -# 200 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - if(lcreate) then - call iotk_free_unit(link_unit,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_link",__FILE__,__LINE__) -# 206 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - inquire(unit=lunit,name=oldfile,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_link",__FILE__,__LINE__) -# 211 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 211 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error inquiring') -# 211 "iotk_files.spp" -call iotk_error_write(ierrl,"unit",lunit) -# 211 "iotk_files.spp" -call iotk_error_write(ierrl,"file",trim(oldfile)) -# 211 "iotk_files.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - call iotk_open_write(link_unit,file=iotk_complete_filepath(file,trim(oldfile)), & - binary=lbinary,raw=lraw,skip_root=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_link",__FILE__,__LINE__) -# 217 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - call iotk_unit_parent(parent=lunit,son=link_unit,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_link",__FILE__,__LINE__) -# 222 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_link_x - -# 235 "iotk_files.spp" -subroutine iotk_open_write_x(unit,file,dummy,attr,binary,new,raw,root,skip_root,skip_head,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_write_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: unit - character(*), optional, intent(in) :: file - type(iotk_dummytype), optional :: dummy - character(*), optional, intent(in) :: attr - logical, optional, intent(in) :: binary - logical, optional, intent(in) :: new - logical, optional, intent(in) :: raw - character(*), optional, intent(in) :: root - logical, optional, intent(in) :: skip_root - logical, optional, intent(in) :: skip_head - integer, optional, intent(out) :: ierr -! Opens a file properly - integer :: iostat - character(50) :: status,form - character(iotk_namlenx) :: lroot - character(iotk_attlenx) :: lattr - integer :: ierrl - logical :: lbinary,lraw,lnew,lskip_root,lskip_head,lstream - type (iotk_unit), pointer :: this - ierrl = 0 - iostat = 0 - lroot = "Root" - lraw = .false. - lnew = .false. - lbinary = .false. - lskip_root = .false. - lskip_head = .false. - if(present(root)) lroot = root - if(present(raw)) lraw=raw - if(present(binary)) lbinary = binary - if(present(new)) lnew = new - if(present(skip_root)) lskip_root = skip_root - if(lskip_root) lroot="" - if(present(skip_head)) lskip_head = skip_head - if(present(file)) then - form = "formatted" - if(lbinary) form = "unformatted" - status = "unknown" - if(lnew) status = "new" - open(unit=unit,file=file,status=status,form=form,position="rewind",iostat=iostat,action="write") - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_open_write",__FILE__,__LINE__) -# 285 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 285 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error opening file') -# 285 "iotk_files.spp" -call iotk_error_write(ierrl,"unit",unit) -# 285 "iotk_files.spp" -call iotk_error_write(ierrl,"file",file) -# 285 "iotk_files.spp" -call iotk_error_write(ierrl,"binary",lbinary) -# 285 "iotk_files.spp" -call iotk_error_write(ierrl,"new",lnew) -# 285 "iotk_files.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - else - call iotk_inquire(unit,lbinary,lstream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_write",__FILE__,__LINE__) -# 291 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - end if - if(.not.lraw) then - if(.not.lskip_head) then - if(.not. lbinary) then - write(unit,"(a)",iostat=iostat) '' - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_open_write",__FILE__,__LINE__) -# 300 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 300 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error writing XML tag') -# 300 "iotk_files.spp" -call iotk_error_write(ierrl,"unit",unit) -# 300 "iotk_files.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - call iotk_write_attr(lattr,"version",trim(iotk_version),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_write",__FILE__,__LINE__) -# 306 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 306 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error writing version attribute') - goto 1 - end if - call iotk_write_pi(unit,"iotk",lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_write",__FILE__,__LINE__) -# 311 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 311 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error writing version tag') - goto 1 - end if - call iotk_write_attr(lattr,"file_version",trim(iotk_file_version),first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_write",__FILE__,__LINE__) -# 316 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 316 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error writing file_version attribute') - goto 1 - end if - call iotk_write_pi(unit,"iotk",lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_write",__FILE__,__LINE__) -# 321 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 321 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error writing version tag') - goto 1 - end if - call iotk_write_attr(lattr,"binary",lbinary,first=.true.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_write",__FILE__,__LINE__) -# 326 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 326 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error writing binary attribute') - goto 1 - end if - call iotk_write_pi(unit,"iotk",lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_write",__FILE__,__LINE__) -# 331 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 331 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error writing binary tag') - goto 1 - end if - end if - if(.not.lskip_root) then - lattr(1:1) = iotk_eos - if(present(attr)) then - call iotk_strcpy(lattr,attr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_write",__FILE__,__LINE__) -# 340 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 340 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error writing attributes from the root tag') - goto 1 - end if - end if - call iotk_write_begin(unit,lroot,attr=lattr,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_write",__FILE__,__LINE__) -# 346 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 346 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error writing the root tag') - goto 1 - end if - end if - end if - call iotk_unit_add(unit,this,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_write",__FILE__,__LINE__) -# 353 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 353 "iotk_files.spp" -call iotk_error_msg(ierrl,'Error adding the unit to the list') - goto 1 - end if - this%root=lroot - this%raw=lraw - this%close_at_end=present(file) - this%skip_root=lskip_root - if(lskip_root) this%level = -1 -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_open_write_x - -# 370 "iotk_files.spp" -recursive subroutine iotk_close_write_x(unit,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_write_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: unit - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -! Closes a file properly - logical :: binary,stream - integer :: ierrl,iostat - type(iotk_unit), pointer :: this - nullify(this) - ierrl = 0 - iostat = 0 - call iotk_unit_get(unit,pointer=this) - if(.not.associated(this)) then - call iotk_error_issue(ierrl,"iotk_close_write",__FILE__,__LINE__) -# 389 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - call iotk_inquire(unit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_close_write",__FILE__,__LINE__) -# 394 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - if(.not.this%raw) then - if(.not.this%skip_root) then - call iotk_write_end(unit,this%root,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_close_write",__FILE__,__LINE__) -# 401 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - end if - end if - if(this%close_at_end) then - if(.not.binary) then - write(unit,*,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_close_write",__FILE__,__LINE__) -# 410 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 410 "iotk_files.spp" -call iotk_error_msg(ierrl,'unit') -# 410 "iotk_files.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - close(unit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_close_write",__FILE__,__LINE__) -# 416 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 416 "iotk_files.spp" -call iotk_error_msg(ierrl,'unit') -# 416 "iotk_files.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - call iotk_unit_del(unit,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_close_write",__FILE__,__LINE__) -# 422 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_close_write_x - - -# 435 "iotk_files.spp" -subroutine iotk_open_read_x(unit,file,dummy,attr,binary,stream,raw,root,ierr) - use iotk_base - use iotk_error_interf - use iotk_str_interf - use iotk_attr_interf - use iotk_scan_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_files_interf - implicit none - integer, intent(in) :: unit - character(*), optional, intent(in) :: file - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: binary - logical, optional, intent(in) :: stream - logical, optional, intent(in) :: raw -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr - character(len=*), optional :: root -#else - character(len=*), optional, intent(out) :: attr - character(len=*), optional, intent(out) :: root -#endif - integer, optional, intent(out) :: ierr - character(50) :: form,access - character(iotk_attlenx) :: lattr - character(iotk_taglenx) :: tag - character(iotk_namlenx) :: lroot - type(iotk_unit),pointer :: this - integer :: ierrl,control,iostat - logical :: lbinary,lraw,lstream - ierrl = 0 - iostat = 0 - lbinary=.false. - lstream=.false. - lraw=.false. - lroot = " " - lattr(1:1) = iotk_eos - if(present(raw)) lraw=raw - if(present(file)) then - if(present(binary)) lbinary = binary - if(present(stream)) lstream = stream - if(.not.lbinary .and. .not. lraw) call iotk_magic(file,lbinary) - form = "formatted" - if(lbinary) form = "unformatted" - access="sequential" -#ifdef __IOTK_STREAMS - if(lstream .and. lbinary) access= "stream" -#endif - open(unit=unit,file=trim(file(1:iotk_strlen(file))),status="old",form=form,position="rewind",iostat=iostat,action="read", & - access=access) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_open_read",__FILE__,__LINE__) -# 487 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 487 "iotk_files.spp" -call iotk_error_msg(ierrl,'unit') -# 487 "iotk_files.spp" -call iotk_error_write(ierrl,"file",file) -# 487 "iotk_files.spp" -call iotk_error_write(ierrl,"binary",lbinary) -# 487 "iotk_files.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - else - call iotk_inquire(unit,lbinary,lstream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_read",__FILE__,__LINE__) -# 493 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - end if - if(.not.lraw) then - do - call iotk_scan_tag(unit,+1,control,tag,lbinary,lstream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_read",__FILE__,__LINE__) -# 501 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - select case(control) - case(1) - call iotk_tag_parse(tag,lroot,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_read",__FILE__,__LINE__) -# 508 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - exit - case(2:3) - call iotk_error_issue(ierrl,"iotk_open_read",__FILE__,__LINE__) -# 513 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 513 "iotk_files.spp" -call iotk_error_msg(ierrl,'End or empty tag at the beginning of a file') -# 513 "iotk_files.spp" -call iotk_error_write(ierrl,"unit",unit) -# 513 "iotk_files.spp" -call iotk_error_write(ierrl,"file",trim(file(1:iotk_strlen(file)))) -# 513 "iotk_files.spp" -call iotk_error_write(ierrl,"binary",lbinary) -# 513 "iotk_files.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - case(5) - call iotk_tag_parse(tag,lroot,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_read",__FILE__,__LINE__) -# 518 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - if(iotk_strcomp(lroot,"iotk")) then - call iotk_check_iotk_attr(unit,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_read",__FILE__,__LINE__) -# 524 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - end if - end select - end do - end if - if(present(root)) root = lroot - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_read",__FILE__,__LINE__) -# 534 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - call iotk_unit_add(unit,this,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_open_read",__FILE__,__LINE__) -# 539 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - this%root=lroot - this%raw=lraw - this%close_at_end=present(file) - this%skip_root=.false. -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_open_read_x - -# 555 "iotk_files.spp" -subroutine iotk_close_read_x(unit,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_scan_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: unit - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: iostat - type(iotk_unit), pointer :: this - character(iotk_namlenx) :: root - logical :: raw - logical :: close_at_end - ierrl = 0 - iostat = 0 - call iotk_unit_get(unit,pointer=this) - if(.not.associated(this)) then - call iotk_error_issue(ierrl,"iotk_close_read",__FILE__,__LINE__) -# 575 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - root = this%root - close_at_end = this%close_at_end - raw = this%raw - call iotk_unit_del(unit,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_close_read",__FILE__,__LINE__) -# 583 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - if(.not.raw) then - call iotk_scan_end(unit,root,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_close_read",__FILE__,__LINE__) -# 589 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") - goto 1 - end if - end if - if(close_at_end) then - close(unit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_close_read",__FILE__,__LINE__) -# 596 "iotk_files.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 596 "iotk_files.spp" -call iotk_error_msg(ierrl,'unit') -# 596 "iotk_files.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_close_read_x - -subroutine iotk_magic_x(file,binary) - use iotk_base - use iotk_str_interf - use iotk_error_interf - use iotk_scan_interf - use iotk_misc_interf - use iotk_unit_interf - use iotk_attr_interf - character(len=*), intent(in) :: file - logical, intent(out):: binary - integer :: iostat,unit,control,ierrl - logical :: found,opened - character(len=iotk_taglenx) :: tag - character(len=iotk_namlenx) :: name - character(len=iotk_attlenx) :: attr - ierrl=0 - binary=.false. - call iotk_free_unit(unit) - open(unit=unit,file=trim(file(1:iotk_strlen(file))),status="old",form="unformatted", & - position="rewind",iostat=iostat,action="read") - if(iostat/=0) goto 1 - do - call iotk_scan_tag(unit,+1,control,tag,.true.,.false.,ierrl) - if(ierrl/=0) goto 1 - if(control==1) then - exit - else if(control==5) then - call iotk_tag_parse(tag,name,attr,ierrl) - if(iotk_strcomp(name,"iotk")) then - call iotk_scan_attr(attr,"binary",binary,found=found,ierr=ierrl) - if(ierrl/=0) goto 1 - if(found) goto 1 - end if - end if - end do -1 continue - if(ierrl/=0) call iotk_error_clear(ierrl) - inquire(unit=unit,opened=opened) - if(opened) close(unit,iostat=iostat) -end subroutine iotk_magic_x diff --git a/quantum_espresso/kcp/iotk/src/iotk_files.spp b/quantum_espresso/kcp/iotk/src/iotk_files.spp deleted file mode 100644 index bdfbbac5a..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_files.spp +++ /dev/null @@ -1,648 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -> REVISION='$Revision: 1.1.1.1 $' -> REVISION="${REVISION//${dol}/}" - -> PROCEDURE="iotk_copyfile_x" -subroutine iotk_copyfile_x(dummy,source,dest,source_unit,dest_unit,ierr) - use iotk_base - use iotk_error_interf - use iotk_scan_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: source - character(len=*), optional, intent(in) :: dest - integer, optional, intent(in) :: source_unit - integer, optional, intent(in) :: dest_unit - integer, optional, intent(out):: ierr - integer :: ierrl,unit1,unit2 - integer :: iostat,length - character(len=iotk_linlenx) :: line - iostat = 0 - ierrl = 0 - if(present(source) .eqv. present(source_unit)) then - $(ERROR ierrl 'Use exactly one between source and source_unit') - goto 1 - end if - if(present(dest) .eqv. present(dest_unit)) then - $(ERROR ierrl 'Use exactly one between dest and dest_unit') - goto 1 - end if - if(present(source)) then - call iotk_free_unit(unit1,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error searching for a free unit') - goto 1 - end if - open(unit1,file=trim(iotk_strpad(source)),iostat=iostat) - if(iostat/=0) then - $(ERROR ierrl 'messaggio' 'sourcefile=trim(iotk_strpad(source))' sourceunit=unit1 iostat) - goto 1 - end if - else - unit1=source_unit - end if - if(present(dest)) then - call iotk_free_unit(unit2,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - open(unit2,file=trim(iotk_strpad(dest)),iostat=iostat) - if(iostat/=0) then - $(ERROR ierrl 'Error opening destination file' destfile='trim(iotk_strpad(dest))' destunit=unit2 iostat) - goto 1 - end if - else - unit2=dest_unit - end if - do - call iotk_getline(unit1,line,length,ierrl) - if(ierrl/=0) then - call iotk_error_scan(ierrl,"iostat",iostat) - if(iostat<0) then - call iotk_error_clear(ierrl) - exit - end if - $(ERROR ierrl 'Error reading source file' sourceunit=unit1) - goto 1 - end if - write(unit2,"(a)",iostat=iostat) line(1:length) - if(iostat/=0) then - $(ERROR ierrl 'Error writing destination file' destunit=unit2 iostat) - goto 1 - end if - end do - iostat=0 - if(present(source)) then - close(unit1,iostat=iostat) - if(iostat/=0) then - $(ERROR ierrl 'Error closing source file' sourcefile='trim(iotk_strpad(source))' sourceunit=unit1 iostat) - goto 1 - end if - end if - if(present(dest)) then - close(unit2,iostat=iostat) - if(iostat/=0) then - $(ERROR ierrl 'Error closing destination file' 'destfile=trim(iotk_strpad(dest))' destunit=unit2 iostat) - goto 1 - end if - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_copyfile_x - ->PROCEDURE="iotk_link" -subroutine iotk_link_x(unit,name,file,dummy,binary,raw,create,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_files_interf - use iotk_str_interf - use iotk_write_interf - use iotk_misc_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - character(*), intent(in) :: file - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: binary - logical, optional, intent(in) :: raw - logical, optional, intent(in) :: create - integer, optional, intent(out) :: ierr - logical :: lbinary,lraw,lcreate - integer :: ierrl,iostat - integer :: lunit,link_unit - type(iotk_unit), pointer :: this_unit - character(iotk_attlenx) :: attr - character(iotk_fillenx) :: oldfile - ierrl = 0 - iostat = 0 - lbinary=.false. - lraw =.false. - lcreate=.false. - if(present(binary)) lbinary = binary - if(present(raw)) lraw = raw - if(present(create)) lcreate = create - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this_unit) - if(.not.associated(this_unit)) then - $(ERROR ierrl 'Links do not apply to units which are not explicitly connected') - goto 1 - end if - call iotk_write_attr(attr,"iotk_link",iotk_strtrim(file),ierr=ierrl,first=.true.) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(lraw) then - if(lbinary) then - call iotk_write_attr(attr,"iotk_binary",lbinary,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - call iotk_write_attr(attr,"iotk_raw",lraw,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - call iotk_write_begin(unit,name,attr,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_write_comment(unit,"This is a link to the file indicated in the iotk_link attribute",ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_write_end (unit,name,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(lcreate) then - call iotk_free_unit(link_unit,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - inquire(unit=lunit,name=oldfile,iostat=iostat) - if(iostat/=0) then - $(ERROR ierrl 'Error inquiring' unit=lunit file='trim(oldfile)' iostat) - goto 1 - end if - call iotk_open_write(link_unit,file=iotk_complete_filepath(file,trim(oldfile)), & - binary=lbinary,raw=lraw,skip_root=.true.,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_unit_parent(parent=lunit,son=link_unit,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_link_x - ->PROCEDURE="iotk_open_write" -subroutine iotk_open_write_x(unit,file,dummy,attr,binary,new,raw,root,skip_root,skip_head,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_str_interf - use iotk_write_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: unit - character(*), optional, intent(in) :: file - type(iotk_dummytype), optional :: dummy - character(*), optional, intent(in) :: attr - logical, optional, intent(in) :: binary - logical, optional, intent(in) :: new - logical, optional, intent(in) :: raw - character(*), optional, intent(in) :: root - logical, optional, intent(in) :: skip_root - logical, optional, intent(in) :: skip_head - integer, optional, intent(out) :: ierr -! Opens a file properly - integer :: iostat - character(50) :: status,form - character(iotk_namlenx) :: lroot - character(iotk_attlenx) :: lattr - integer :: ierrl - logical :: lbinary,lraw,lnew,lskip_root,lskip_head,lstream - type (iotk_unit), pointer :: this - ierrl = 0 - iostat = 0 - lroot = "Root" - lraw = .false. - lnew = .false. - lbinary = .false. - lskip_root = .false. - lskip_head = .false. - if(present(root)) lroot = root - if(present(raw)) lraw=raw - if(present(binary)) lbinary = binary - if(present(new)) lnew = new - if(present(skip_root)) lskip_root = skip_root - if(lskip_root) lroot="" - if(present(skip_head)) lskip_head = skip_head - if(present(file)) then - form = "formatted" - if(lbinary) form = "unformatted" - status = "unknown" - if(lnew) status = "new" - open(unit=unit,file=file,status=status,form=form,position="rewind",iostat=iostat,action="write") - if(iostat/=0) then - $(ERROR ierrl 'Error opening file' unit file binary=lbinary new=lnew iostat) - goto 1 - end if - else - call iotk_inquire(unit,lbinary,lstream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - if(.not.lraw) then - if(.not.lskip_head) then - if(.not. lbinary) then - write(unit,"(a)",iostat=iostat) '' - if(iostat/=0) then - $(ERROR ierrl 'Error writing XML tag' unit iostat) - goto 1 - end if - end if - call iotk_write_attr(lattr,"version",trim(iotk_version),first=.true.,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error writing version attribute') - goto 1 - end if - call iotk_write_pi(unit,"iotk",lattr,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error writing version tag') - goto 1 - end if - call iotk_write_attr(lattr,"file_version",trim(iotk_file_version),first=.true.,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error writing file_version attribute') - goto 1 - end if - call iotk_write_pi(unit,"iotk",lattr,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error writing version tag') - goto 1 - end if - call iotk_write_attr(lattr,"binary",lbinary,first=.true.,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error writing binary attribute') - goto 1 - end if - call iotk_write_pi(unit,"iotk",lattr,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error writing binary tag') - goto 1 - end if - end if - if(.not.lskip_root) then - lattr(1:1) = iotk_eos - if(present(attr)) then - call iotk_strcpy(lattr,attr,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error writing attributes from the root tag') - goto 1 - end if - end if - call iotk_write_begin(unit,lroot,attr=lattr,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error writing the root tag') - goto 1 - end if - end if - end if - call iotk_unit_add(unit,this,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error adding the unit to the list') - goto 1 - end if - this%root=lroot - this%raw=lraw - this%close_at_end=present(file) - this%skip_root=lskip_root - if(lskip_root) this%level = -1 -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_open_write_x - ->PROCEDURE=iotk_close_write -recursive subroutine iotk_close_write_x(unit,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_write_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: unit - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -! Closes a file properly - logical :: binary,stream - integer :: ierrl,iostat - type(iotk_unit), pointer :: this - nullify(this) - ierrl = 0 - iostat = 0 - call iotk_unit_get(unit,pointer=this) - if(.not.associated(this)) then - $(ERROR ierrl) - goto 1 - end if - call iotk_inquire(unit,binary,stream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(.not.this%raw) then - if(.not.this%skip_root) then - call iotk_write_end(unit,this%root,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - end if - if(this%close_at_end) then - if(.not.binary) then - write(unit,*,iostat=iostat) - if(iostat/=0) then - $(ERROR ierrl unit iostat) - goto 1 - end if - end if - close(unit,iostat=iostat) - if(iostat/=0) then - $(ERROR ierrl unit iostat) - goto 1 - end if - end if - call iotk_unit_del(unit,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_close_write_x - - ->PROCEDURE="iotk_open_read" -subroutine iotk_open_read_x(unit,file,dummy,attr,binary,stream,raw,root,ierr) - use iotk_base - use iotk_error_interf - use iotk_str_interf - use iotk_attr_interf - use iotk_scan_interf - use iotk_unit_interf - use iotk_misc_interf - use iotk_files_interf - implicit none - integer, intent(in) :: unit - character(*), optional, intent(in) :: file - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: binary - logical, optional, intent(in) :: stream - logical, optional, intent(in) :: raw -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr - character(len=*), optional :: root -#else - character(len=*), optional, intent(out) :: attr - character(len=*), optional, intent(out) :: root -#endif - integer, optional, intent(out) :: ierr - character(50) :: form,access - character(iotk_attlenx) :: lattr - character(iotk_taglenx) :: tag - character(iotk_namlenx) :: lroot - type(iotk_unit),pointer :: this - integer :: ierrl,control,iostat - logical :: lbinary,lraw,lstream - ierrl = 0 - iostat = 0 - lbinary=.false. - lstream=.false. - lraw=.false. - lroot = " " - lattr(1:1) = iotk_eos - if(present(raw)) lraw=raw - if(present(file)) then - if(present(binary)) lbinary = binary - if(present(stream)) lstream = stream - if(.not.lbinary .and. .not. lraw) call iotk_magic(file,lbinary) - form = "formatted" - if(lbinary) form = "unformatted" - access="sequential" -#ifdef __IOTK_STREAMS - if(lstream .and. lbinary) access= "stream" -#endif - open(unit=unit,file=trim(file(1:iotk_strlen(file))),status="old",form=form,position="rewind",iostat=iostat,action="read", & - access=access) - if(iostat/=0) then - $(ERROR ierrl unit file binary=lbinary iostat) - goto 1 - end if - else - call iotk_inquire(unit,lbinary,lstream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - if(.not.lraw) then - do - call iotk_scan_tag(unit,+1,control,tag,lbinary,lstream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - select case(control) - case(1) - call iotk_tag_parse(tag,lroot,lattr,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - exit - case(2:3) - $(ERROR ierrl 'End or empty tag at the beginning of a file' unit file='trim(file(1:iotk_strlen(file)))' binary=lbinary iostat) - goto 1 - case(5) - call iotk_tag_parse(tag,lroot,lattr,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(iotk_strcomp(lroot,"iotk")) then - call iotk_check_iotk_attr(unit,lattr,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - end select - end do - end if - if(present(root)) root = lroot - if(present(attr)) call iotk_strcpy(attr,lattr,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_unit_add(unit,this,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - this%root=lroot - this%raw=lraw - this%close_at_end=present(file) - this%skip_root=.false. -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_open_read_x - ->PROCEDURE="iotk_close_read" -subroutine iotk_close_read_x(unit,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_scan_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: unit - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr - integer :: ierrl - integer :: iostat - type(iotk_unit), pointer :: this - character(iotk_namlenx) :: root - logical :: raw - logical :: close_at_end - ierrl = 0 - iostat = 0 - call iotk_unit_get(unit,pointer=this) - if(.not.associated(this)) then - $(ERROR ierrl) - goto 1 - end if - root = this%root - close_at_end = this%close_at_end - raw = this%raw - call iotk_unit_del(unit,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(.not.raw) then - call iotk_scan_end(unit,root,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - if(close_at_end) then - close(unit,iostat=iostat) - if(iostat/=0) then - $(ERROR ierrl unit iostat) - goto 1 - end if - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_close_read_x - -subroutine iotk_magic_x(file,binary) - use iotk_base - use iotk_str_interf - use iotk_error_interf - use iotk_scan_interf - use iotk_misc_interf - use iotk_unit_interf - use iotk_attr_interf - character(len=*), intent(in) :: file - logical, intent(out):: binary - integer :: iostat,unit,control,ierrl - logical :: found,opened - character(len=iotk_taglenx) :: tag - character(len=iotk_namlenx) :: name - character(len=iotk_attlenx) :: attr - ierrl=0 - binary=.false. - call iotk_free_unit(unit) - open(unit=unit,file=trim(file(1:iotk_strlen(file))),status="old",form="unformatted", & - position="rewind",iostat=iostat,action="read") - if(iostat/=0) goto 1 - do - call iotk_scan_tag(unit,+1,control,tag,.true.,.false.,ierrl) - if(ierrl/=0) goto 1 - if(control==1) then - exit - else if(control==5) then - call iotk_tag_parse(tag,name,attr,ierrl) - if(iotk_strcomp(name,"iotk")) then - call iotk_scan_attr(attr,"binary",binary,found=found,ierr=ierrl) - if(ierrl/=0) goto 1 - if(found) goto 1 - end if - end if - end do -1 continue - if(ierrl/=0) call iotk_error_clear(ierrl) - inquire(unit=unit,opened=opened) - if(opened) close(unit,iostat=iostat) -end subroutine iotk_magic_x - diff --git a/quantum_espresso/kcp/iotk/src/iotk_files_interf.f90 b/quantum_espresso/kcp/iotk/src/iotk_files_interf.f90 deleted file mode 100644 index 63a69f5f5..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_files_interf.f90 +++ /dev/null @@ -1,136 +0,0 @@ -# 1 "iotk_files_interf.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_files_interf.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_files_interf.spp" - -module iotk_files_interf -use iotk_base -implicit none -private - -public :: iotk_copyfile -public :: iotk_link -public :: iotk_open_write -public :: iotk_close_write -public :: iotk_open_read -public :: iotk_close_read -public :: iotk_magic - -interface iotk_copyfile -subroutine iotk_copyfile_x(dummy,source,dest,source_unit,dest_unit,ierr) - use iotk_base - implicit none - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: source - character(len=*), optional, intent(in) :: dest - integer, optional, intent(in) :: source_unit - integer, optional, intent(in) :: dest_unit - integer, optional, intent(out):: ierr -end subroutine iotk_copyfile_x -end interface - -interface iotk_link -subroutine iotk_link_x(unit,name,file,dummy,binary,raw,create,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name - character(len=*), intent(in) :: file - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: binary - logical, optional, intent(in) :: raw - logical, optional, intent(in) :: create - integer, optional, intent(out) :: ierr -end subroutine iotk_link_x -end interface - -interface iotk_open_write -subroutine iotk_open_write_x(unit,file,dummy,attr,binary,new,raw,root,skip_root,skip_head,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: file - character(len=*), optional, intent(in) :: attr - logical, optional, intent(in) :: binary - logical, optional, intent(in) :: new - logical, optional, intent(in) :: raw - character(len=*), optional, intent(in) :: root - logical, optional, intent(in) :: skip_root - logical, optional, intent(in) :: skip_head - integer, optional, intent(out) :: ierr -end subroutine iotk_open_write_x -end interface - -interface iotk_close_write -subroutine iotk_close_write_x(unit,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_close_write_x -end interface - -interface iotk_open_read -subroutine iotk_open_read_x(unit,file,dummy,attr,binary,stream,raw,root,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(len=*), optional, intent(in) :: file - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: binary - logical, optional, intent(in) :: stream - logical, optional, intent(in) :: raw -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr - character(len=*), optional :: root -#else - character(len=*), optional, intent(out) :: attr - character(len=*), optional, intent(out) :: root -#endif - integer, optional, intent(out) :: ierr -end subroutine iotk_open_read_x -end interface - -interface iotk_close_read -subroutine iotk_close_read_x(unit,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_close_read_x -end interface - -interface iotk_magic -subroutine iotk_magic_x(file,binary) - implicit none - character(len=*), intent(in) :: file - logical, intent(out) :: binary -end subroutine iotk_magic_x -end interface - -end module iotk_files_interf diff --git a/quantum_espresso/kcp/iotk/src/iotk_files_interf.spp b/quantum_espresso/kcp/iotk/src/iotk_files_interf.spp deleted file mode 100644 index e612ffe8b..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_files_interf.spp +++ /dev/null @@ -1,140 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -module iotk_files_interf -use iotk_base -implicit none -private - -public :: iotk_copyfile -public :: iotk_link -public :: iotk_open_write -public :: iotk_close_write -public :: iotk_open_read -public :: iotk_close_read -public :: iotk_magic - -interface iotk_copyfile -subroutine iotk_copyfile_x(dummy,source,dest,source_unit,dest_unit,ierr) - use iotk_base - implicit none - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: source - character(len=*), optional, intent(in) :: dest - integer, optional, intent(in) :: source_unit - integer, optional, intent(in) :: dest_unit - integer, optional, intent(out):: ierr -end subroutine iotk_copyfile_x -end interface - -interface iotk_link -subroutine iotk_link_x(unit,name,file,dummy,binary,raw,create,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name - character(len=*), intent(in) :: file - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: binary - logical, optional, intent(in) :: raw - logical, optional, intent(in) :: create - integer, optional, intent(out) :: ierr -end subroutine iotk_link_x -end interface - -interface iotk_open_write -subroutine iotk_open_write_x(unit,file,dummy,attr,binary,new,raw,root,skip_root,skip_head,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - type(iotk_dummytype), optional :: dummy - character(len=*), optional, intent(in) :: file - character(len=*), optional, intent(in) :: attr - logical, optional, intent(in) :: binary - logical, optional, intent(in) :: new - logical, optional, intent(in) :: raw - character(len=*), optional, intent(in) :: root - logical, optional, intent(in) :: skip_root - logical, optional, intent(in) :: skip_head - integer, optional, intent(out) :: ierr -end subroutine iotk_open_write_x -end interface - -interface iotk_close_write -subroutine iotk_close_write_x(unit,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_close_write_x -end interface - -interface iotk_open_read -subroutine iotk_open_read_x(unit,file,dummy,attr,binary,stream,raw,root,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(len=*), optional, intent(in) :: file - type(iotk_dummytype), optional :: dummy - logical, optional, intent(in) :: binary - logical, optional, intent(in) :: stream - logical, optional, intent(in) :: raw -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr - character(len=*), optional :: root -#else - character(len=*), optional, intent(out) :: attr - character(len=*), optional, intent(out) :: root -#endif - integer, optional, intent(out) :: ierr -end subroutine iotk_open_read_x -end interface - -interface iotk_close_read -subroutine iotk_close_read_x(unit,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_close_read_x -end interface - -interface iotk_magic -subroutine iotk_magic_x(file,binary) - implicit none - character(len=*), intent(in) :: file - logical, intent(out) :: binary -end subroutine iotk_magic_x -end interface - -end module iotk_files_interf - diff --git a/quantum_espresso/kcp/iotk/src/iotk_fmt.f90 b/quantum_espresso/kcp/iotk/src/iotk_fmt.f90 deleted file mode 100644 index 55b4b8365..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_fmt.f90 +++ /dev/null @@ -1,261 +0,0 @@ -# 1 "iotk_fmt.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_fmt.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_fmt.spp" - -# 33 "iotk_fmt.spp" - -function iotk_basefmt_x(type,ikind,ilen) - use iotk_base - use iotk_xtox_interf - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: type - integer, intent(in) :: ikind - integer, intent(in) :: ilen - character(100) :: iotk_basefmt_x - integer :: nexp,exp,ndig,baselen - logical, save :: first_call = .true. -# 46 "iotk_fmt.spp" -#ifdef __IOTK_INTEGER1 - integer (kind=iotk_integer1) :: example_integer1 = 0 - character(46), save :: save_basefmt_integer1 = "" -#endif -#ifdef __IOTK_REAL1 - real (kind=iotk_real1) :: example_real1 = 0.0 - character(46), save :: save_basefmt_real1 = "" -#endif -# 46 "iotk_fmt.spp" -#ifdef __IOTK_INTEGER2 - integer (kind=iotk_integer2) :: example_integer2 = 0 - character(46), save :: save_basefmt_integer2 = "" -#endif -#ifdef __IOTK_REAL2 - real (kind=iotk_real2) :: example_real2 = 0.0 - character(46), save :: save_basefmt_real2 = "" -#endif -# 46 "iotk_fmt.spp" -#ifdef __IOTK_INTEGER3 - integer (kind=iotk_integer3) :: example_integer3 = 0 - character(46), save :: save_basefmt_integer3 = "" -#endif -#ifdef __IOTK_REAL3 - real (kind=iotk_real3) :: example_real3 = 0.0 - character(46), save :: save_basefmt_real3 = "" -#endif -# 46 "iotk_fmt.spp" -#ifdef __IOTK_INTEGER4 - integer (kind=iotk_integer4) :: example_integer4 = 0 - character(46), save :: save_basefmt_integer4 = "" -#endif -#ifdef __IOTK_REAL4 - real (kind=iotk_real4) :: example_real4 = 0.0 - character(46), save :: save_basefmt_real4 = "" -#endif -# 55 "iotk_fmt.spp" - if(first_call) then -# 57 "iotk_fmt.spp" -#ifdef __IOTK_INTEGER1 - baselen = range(example_integer1) + 1 - save_basefmt_integer1 = "(i"//trim(iotk_itoa(baselen))//")" -#endif -#ifdef __IOTK_REAL1 - ndig = precision(example_real1)+1 - exp = range(example_real1)+1 - nexp = 1 - do - if(exp < 10) exit - exp = exp / 10 - nexp = nexp + 1 - end do - baselen = nexp+ndig-1+5 - save_basefmt_real1 = "(ES"//trim(iotk_itoa(baselen))//"." & - //trim(iotk_itoa(ndig-1))//"E"//trim(iotk_itoa(nexp))//")" - -#endif -# 57 "iotk_fmt.spp" -#ifdef __IOTK_INTEGER2 - baselen = range(example_integer2) + 1 - save_basefmt_integer2 = "(i"//trim(iotk_itoa(baselen))//")" -#endif -#ifdef __IOTK_REAL2 - ndig = precision(example_real2)+1 - exp = range(example_real2)+1 - nexp = 1 - do - if(exp < 10) exit - exp = exp / 10 - nexp = nexp + 1 - end do - baselen = nexp+ndig-1+5 - save_basefmt_real2 = "(ES"//trim(iotk_itoa(baselen))//"." & - //trim(iotk_itoa(ndig-1))//"E"//trim(iotk_itoa(nexp))//")" - -#endif -# 57 "iotk_fmt.spp" -#ifdef __IOTK_INTEGER3 - baselen = range(example_integer3) + 1 - save_basefmt_integer3 = "(i"//trim(iotk_itoa(baselen))//")" -#endif -#ifdef __IOTK_REAL3 - ndig = precision(example_real3)+1 - exp = range(example_real3)+1 - nexp = 1 - do - if(exp < 10) exit - exp = exp / 10 - nexp = nexp + 1 - end do - baselen = nexp+ndig-1+5 - save_basefmt_real3 = "(ES"//trim(iotk_itoa(baselen))//"." & - //trim(iotk_itoa(ndig-1))//"E"//trim(iotk_itoa(nexp))//")" - -#endif -# 57 "iotk_fmt.spp" -#ifdef __IOTK_INTEGER4 - baselen = range(example_integer4) + 1 - save_basefmt_integer4 = "(i"//trim(iotk_itoa(baselen))//")" -#endif -#ifdef __IOTK_REAL4 - ndig = precision(example_real4)+1 - exp = range(example_real4)+1 - nexp = 1 - do - if(exp < 10) exit - exp = exp / 10 - nexp = nexp + 1 - end do - baselen = nexp+ndig-1+5 - save_basefmt_real4 = "(ES"//trim(iotk_itoa(baselen))//"." & - //trim(iotk_itoa(ndig-1))//"E"//trim(iotk_itoa(nexp))//")" - -#endif -# 76 "iotk_fmt.spp" - first_call = .false. - end if - select case(type) - case("LOGICAL") - iotk_basefmt_x = "(l1)" - case("INTEGER") - select case(ikind) -# 84 "iotk_fmt.spp" -#ifdef __IOTK_INTEGER1 - case(iotk_integer1) - iotk_basefmt_x = save_basefmt_integer1 -#endif -# 84 "iotk_fmt.spp" -#ifdef __IOTK_INTEGER2 - case(iotk_integer2) - iotk_basefmt_x = save_basefmt_integer2 -#endif -# 84 "iotk_fmt.spp" -#ifdef __IOTK_INTEGER3 - case(iotk_integer3) - iotk_basefmt_x = save_basefmt_integer3 -#endif -# 84 "iotk_fmt.spp" -#ifdef __IOTK_INTEGER4 - case(iotk_integer4) - iotk_basefmt_x = save_basefmt_integer4 -#endif -# 89 "iotk_fmt.spp" - end select - case("REAL") - select case(ikind) -# 93 "iotk_fmt.spp" -#ifdef __IOTK_REAL1 - case(iotk_real1) - iotk_basefmt_x = save_basefmt_real1 -#endif -# 93 "iotk_fmt.spp" -#ifdef __IOTK_REAL2 - case(iotk_real2) - iotk_basefmt_x = save_basefmt_real2 -#endif -# 93 "iotk_fmt.spp" -#ifdef __IOTK_REAL3 - case(iotk_real3) - iotk_basefmt_x = save_basefmt_real3 -#endif -# 93 "iotk_fmt.spp" -#ifdef __IOTK_REAL4 - case(iotk_real4) - iotk_basefmt_x = save_basefmt_real4 -#endif -# 98 "iotk_fmt.spp" - end select - case("COMPLEX") - select case(ikind) -# 102 "iotk_fmt.spp" -#ifdef __IOTK_REAL1 - case(iotk_real1) - iotk_basefmt_x = "("//trim(save_basefmt_real1)//",',',"//trim(save_basefmt_real1)//")" -#endif -# 102 "iotk_fmt.spp" -#ifdef __IOTK_REAL2 - case(iotk_real2) - iotk_basefmt_x = "("//trim(save_basefmt_real2)//",',',"//trim(save_basefmt_real2)//")" -#endif -# 102 "iotk_fmt.spp" -#ifdef __IOTK_REAL3 - case(iotk_real3) - iotk_basefmt_x = "("//trim(save_basefmt_real3)//",',',"//trim(save_basefmt_real3)//")" -#endif -# 102 "iotk_fmt.spp" -#ifdef __IOTK_REAL4 - case(iotk_real4) - iotk_basefmt_x = "("//trim(save_basefmt_real4)//",',',"//trim(save_basefmt_real4)//")" -#endif -# 107 "iotk_fmt.spp" - end select - case("CHARACTER") - if(ilen>=0) then - iotk_basefmt_x = "(a"//trim(iotk_itoa(ilen))//")" - else - iotk_basefmt_x = "(a)" - end if - end select -end function iotk_basefmt_x - -function iotk_wfmt_x(type,ikind,isize,ilen,sep) - use iotk_base - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_misc_interf - use iotk_str_interf - implicit none - character(len=*), intent(in) :: type - integer, intent(in) :: ikind - integer, intent(in) :: isize - integer, intent(in) :: ilen - character(len=*), intent(in) :: sep - character(150) :: iotk_wfmt_x - if(isize==1) then - iotk_wfmt_x = "("//trim(iotk_basefmt(type,ikind,ilen))//")" - else - iotk_wfmt_x = "("//trim(iotk_itoa(isize))//"("//trim(iotk_basefmt(type,ikind,ilen)) & - //",:,'"//sep(1:iotk_strlen(sep))//"'))" - end if -end function iotk_wfmt_x diff --git a/quantum_espresso/kcp/iotk/src/iotk_fmt.spp b/quantum_espresso/kcp/iotk/src/iotk_fmt.spp deleted file mode 100644 index 541989271..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_fmt.spp +++ /dev/null @@ -1,137 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -> REVISION='$Revision: 1.1.1.1 $' -> REVISION="${REVISION//${dol}/}" - -function iotk_basefmt_x(type,ikind,ilen) - use iotk_base - use iotk_xtox_interf - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: type - integer, intent(in) :: ikind - integer, intent(in) :: ilen - character(100) :: iotk_basefmt_x - integer :: nexp,exp,ndig,baselen - logical, save :: first_call = .true. ->for kind in $kinds ; do -#ifdef __IOTK_INTEGER${kind} - integer (kind=iotk_integer${kind}) :: example_integer${kind} = 0 - character(46), save :: save_basefmt_integer$kind = "" -#endif -#ifdef __IOTK_REAL${kind} - real (kind=iotk_real${kind}) :: example_real${kind} = 0.0 - character(46), save :: save_basefmt_real$kind = "" -#endif ->done - if(first_call) then ->for kind in $kinds ; do -#ifdef __IOTK_INTEGER${kind} - baselen = range(example_integer${kind}) + 1 - save_basefmt_integer$kind = "(i"//trim(iotk_itoa(baselen))//")" -#endif -#ifdef __IOTK_REAL${kind} - ndig = precision(example_real${kind})+1 - exp = range(example_real${kind})+1 - nexp = 1 - do - if(exp < 10) exit - exp = exp / 10 - nexp = nexp + 1 - end do - baselen = nexp+ndig-1+5 - save_basefmt_real$kind = "(ES"//trim(iotk_itoa(baselen))//"." & - //trim(iotk_itoa(ndig-1))//"E"//trim(iotk_itoa(nexp))//")" - -#endif ->done - first_call = .false. - end if - select case(type) - case("LOGICAL") - iotk_basefmt_x = "(l1)" - case("INTEGER") - select case(ikind) -> for kind in $kinds ; do -#ifdef __IOTK_INTEGER${kind} - case(iotk_integer${kind}) - iotk_basefmt_x = save_basefmt_integer$kind -#endif -> done - end select - case("REAL") - select case(ikind) -> for kind in $kinds ; do -#ifdef __IOTK_REAL${kind} - case(iotk_real${kind}) - iotk_basefmt_x = save_basefmt_real$kind -#endif -> done - end select - case("COMPLEX") - select case(ikind) -> for kind in $kinds ; do -#ifdef __IOTK_REAL${kind} - case(iotk_real${kind}) - iotk_basefmt_x = "("//trim(save_basefmt_real$kind)//",',',"//trim(save_basefmt_real$kind)//")" -#endif -> done - end select - case("CHARACTER") - if(ilen>=0) then - iotk_basefmt_x = "(a"//trim(iotk_itoa(ilen))//")" - else - iotk_basefmt_x = "(a)" - end if - end select -end function iotk_basefmt_x - -function iotk_wfmt_x(type,ikind,isize,ilen,sep) - use iotk_base - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_misc_interf - use iotk_str_interf - implicit none - character(len=*), intent(in) :: type - integer, intent(in) :: ikind - integer, intent(in) :: isize - integer, intent(in) :: ilen - character(len=*), intent(in) :: sep - character(150) :: iotk_wfmt_x - if(isize==1) then - iotk_wfmt_x = "("//trim(iotk_basefmt(type,ikind,ilen))//")" - else - iotk_wfmt_x = "("//trim(iotk_itoa(isize))//"("//trim(iotk_basefmt(type,ikind,ilen)) & - //",:,'"//sep(1:iotk_strlen(sep))//"'))" - end if -end function iotk_wfmt_x - diff --git a/quantum_espresso/kcp/iotk/src/iotk_fmt_interf.f90 b/quantum_espresso/kcp/iotk/src/iotk_fmt_interf.f90 deleted file mode 100644 index bea00555a..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_fmt_interf.f90 +++ /dev/null @@ -1,58 +0,0 @@ -# 1 "iotk_fmt_interf.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_fmt_interf.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_fmt_interf.spp" - -module iotk_fmt_interf -use iotk_base -implicit none -private - -public :: iotk_basefmt -public :: iotk_wfmt - -interface iotk_basefmt -function iotk_basefmt_x(type,ikind,ilen) - implicit none - character(len=*), intent(in) :: type - integer, intent(in) :: ikind - integer, intent(in) :: ilen - character(100) :: iotk_basefmt_x -end function iotk_basefmt_x -end interface - -interface iotk_wfmt -function iotk_wfmt_x(type,ikind,isize,ilen,sep) - implicit none - character(len=*), intent(in) :: type - integer, intent(in) :: ikind - integer, intent(in) :: isize - integer, intent(in) :: ilen - character(len=*), intent(in) :: sep - character(150) :: iotk_wfmt_x -end function iotk_wfmt_x -end interface - -end module iotk_fmt_interf diff --git a/quantum_espresso/kcp/iotk/src/iotk_fmt_interf.spp b/quantum_espresso/kcp/iotk/src/iotk_fmt_interf.spp deleted file mode 100644 index f090d3689..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_fmt_interf.spp +++ /dev/null @@ -1,62 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -module iotk_fmt_interf -use iotk_base -implicit none -private - -public :: iotk_basefmt -public :: iotk_wfmt - -interface iotk_basefmt -function iotk_basefmt_x(type,ikind,ilen) - implicit none - character(len=*), intent(in) :: type - integer, intent(in) :: ikind - integer, intent(in) :: ilen - character(100) :: iotk_basefmt_x -end function iotk_basefmt_x -end interface - -interface iotk_wfmt -function iotk_wfmt_x(type,ikind,isize,ilen,sep) - implicit none - character(len=*), intent(in) :: type - integer, intent(in) :: ikind - integer, intent(in) :: isize - integer, intent(in) :: ilen - character(len=*), intent(in) :: sep - character(150) :: iotk_wfmt_x -end function iotk_wfmt_x -end interface - -end module iotk_fmt_interf - diff --git a/quantum_espresso/kcp/iotk/src/iotk_misc.f90 b/quantum_espresso/kcp/iotk/src/iotk_misc.f90 deleted file mode 100644 index fd4614b95..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_misc.f90 +++ /dev/null @@ -1,1460 +0,0 @@ -# 1 "iotk_misc.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_misc.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_misc.spp" - -# 33 "iotk_misc.spp" - -# 35 "iotk_misc.spp" -subroutine iotk_copy_tag_x(source,dest,dummy,maxsize,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_scan_interf - use iotk_write_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: source - integer, intent(in) :: dest - type(iotk_dummytype),optional :: dummy - integer, optional, intent(in) :: maxsize - integer, optional, intent(out) :: ierr - logical :: source_binary,dest_binary,source_stream,dest_stream - integer :: ierrl,control,maxsizel - character(iotk_taglenx) :: tag - character(iotk_namlenx) :: name - character(iotk_attlenx) :: attr - character(iotk_vallenx) :: type - type(iotk_unit), pointer :: this - ierrl = 0 - maxsizel = -1 - if(present(maxsize)) maxsizel = maxsize - call iotk_inquire(source,source_binary,source_stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_copy_tag",__FILE__,__LINE__) -# 62 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_inquire(dest,dest_binary,dest_stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_copy_tag",__FILE__,__LINE__) -# 67 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_unit_get(source,pointer=this) - if(.not.associated(this)) then - call iotk_error_issue(ierrl,"iotk_copy_tag",__FILE__,__LINE__) -# 72 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 72 "iotk_misc.spp" -call iotk_error_msg(ierrl,'unit') - goto 1 - end if - do - call iotk_scan_tag(source,+1,control,tag,source_binary,source_stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_copy_tag",__FILE__,__LINE__) -# 78 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(control/=4) then ! SKIP FOR COMMENTS - call iotk_tag_parse(tag,name,attr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_copy_tag",__FILE__,__LINE__) -# 84 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - if(iotk_strcomp(name,this%root)) then - call iotk_scan_tag(source,-1,control,tag,source_binary,source_stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_copy_tag",__FILE__,__LINE__) -# 91 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - return - end if - select case(control) - case(1) - call iotk_scan_attr(attr,"type",type,ierr=ierrl,eos=.true.,default=" ") - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_copy_tag",__FILE__,__LINE__) -# 100 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if((iotk_strcomp(type,"real") .or. iotk_strcomp(type,"integer") .or. iotk_strcomp(type,"logical") & - .or. iotk_strcomp(type,"character") .or. iotk_strcomp(type,"complex")) .and. control==1) then - call iotk_copy_dat(source,dest,source_binary,dest_binary,name,attr,maxsize=maxsizel,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_copy_tag",__FILE__,__LINE__) -# 107 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_scan_tag(source,+1,control,tag,source_binary,source_stream,ierrl) - else - call iotk_write_begin(dest,name,attr,ierr=ierrl) - end if - case(2) - call iotk_write_end(dest,name,ierr=ierrl) - case(3) - call iotk_write_empty(dest,name,attr,ierr=ierrl) - case(4) - call iotk_write_comment(dest,tag,ierr=ierrl) - case(5) - call iotk_write_pi(dest,name,attr,ierr=ierrl) - end select - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_copy_tag",__FILE__,__LINE__) -# 124 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end do -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_copy_tag_x - -# 137 "iotk_misc.spp" -subroutine iotk_parse_dat_x(attr,type,ikind,isize,ilen,fmt,columns,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: attr -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: type -#else - character(len=*), intent(out) :: type -#endif - integer, intent(out) :: ikind - integer, intent(out) :: isize - integer, intent(out) :: ilen -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: fmt -#else - character(len=*), intent(out) :: fmt -#endif - integer, intent(out) :: columns - integer, intent(out) :: ierr - character(iotk_vallenx) :: typename - ierr = 0 - call iotk_scan_attr(attr,"type",typename,ierr=ierr,eos=.true.,default=iotk_eos) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_parse_dat",__FILE__,__LINE__) -# 165 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - type = iotk_toupper(typename) - call iotk_scan_attr(attr,"kind",ikind,ierr=ierr,default=-1) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_parse_dat",__FILE__,__LINE__) -# 171 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - call iotk_scan_attr(attr,"size",isize,ierr=ierr,default=-1) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_parse_dat",__FILE__,__LINE__) -# 176 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - call iotk_scan_attr(attr,"len", ilen, ierr=ierr,default=-1) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_parse_dat",__FILE__,__LINE__) -# 181 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - call iotk_scan_attr(attr,"fmt", fmt, ierr=ierr,eos=.true.,default="!"//iotk_eos) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_parse_dat",__FILE__,__LINE__) -# 186 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - call iotk_scan_attr(attr,"columns",columns,ierr=ierr,default=1) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_parse_dat",__FILE__,__LINE__) -# 191 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if -end subroutine iotk_parse_dat_x - -# 197 "iotk_misc.spp" -subroutine iotk_set_x(dummy,unitmin,unitmax,getline_buffer,error_warn_overflow, & - linlen,indent,maxindent,error_unit,output_unit,ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_dummytype),optional :: dummy - integer, optional, intent(in) :: unitmin - integer, optional, intent(in) :: unitmax - integer, optional, intent(in) :: getline_buffer - logical, optional, intent(in) :: error_warn_overflow - integer, optional, intent(in) :: linlen - integer, optional, intent(in) :: indent - integer, optional, intent(in) :: maxindent - integer, optional, intent(in) :: error_unit - integer, optional, intent(in) :: output_unit - integer, optional, intent(out) :: ierr - integer :: ierrl - ierrl = 0 - if(present(error_warn_overflow)) then - iotk_error_warn_overflow = error_warn_overflow - end if - if(present(unitmin)) then - if(unitmin<0) then - call iotk_error_issue(ierrl,"iotk_set",__FILE__,__LINE__) -# 221 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 221 "iotk_misc.spp" -call iotk_error_msg(ierrl,'Wrong value for unitmin') -# 221 "iotk_misc.spp" -call iotk_error_write(ierrl,"unitmin",unitmin) - goto 1 - end if - iotk_unitmin = unitmin - end if - if(present(unitmax)) then - if(unitmax<0) then - call iotk_error_issue(ierrl,"iotk_set",__FILE__,__LINE__) -# 228 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 228 "iotk_misc.spp" -call iotk_error_msg(ierrl,'Wrong value for unitmax') -# 228 "iotk_misc.spp" -call iotk_error_write(ierrl,"unitmax",unitmax) - goto 1 - end if - iotk_unitmax = unitmax - end if - if(iotk_unitmin>iotk_unitmax) then - call iotk_error_issue(ierrl,"iotk_set",__FILE__,__LINE__) -# 234 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 234 "iotk_misc.spp" -call iotk_error_msg(ierrl,'Inconsistency: unitmin should be less then unitmax') -# 234 "iotk_misc.spp" -call iotk_error_write(ierrl,"iotk_unitmin",iotk_unitmin) -# 234 "iotk_misc.spp" -call iotk_error_write(ierrl,"iotk_unitmax",iotk_unitmax) - goto 1 - end if - if(present(getline_buffer)) then - if(getline_buffer<1) then - call iotk_error_issue(ierrl,"iotk_set",__FILE__,__LINE__) -# 239 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 239 "iotk_misc.spp" -call iotk_error_msg(ierrl,'Wrong value for getline_buffer') -# 239 "iotk_misc.spp" -call iotk_error_write(ierrl,"getline_buffer",getline_buffer) - goto 1 - end if - iotk_getline_buffer = getline_buffer - end if - if(present(linlen)) then - if(linlen<1) then - call iotk_error_issue(ierrl,"iotk_set",__FILE__,__LINE__) -# 246 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 246 "iotk_misc.spp" -call iotk_error_msg(ierrl,'Wrong value for linlen') -# 246 "iotk_misc.spp" -call iotk_error_write(ierrl,"linlen",linlen) - goto 1 - end if - iotk_linlen = linlen - end if - if(present(indent)) then - if(indent<0) then - call iotk_error_issue(ierrl,"iotk_set",__FILE__,__LINE__) -# 253 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 253 "iotk_misc.spp" -call iotk_error_msg(ierrl,'Wrong value for indent') -# 253 "iotk_misc.spp" -call iotk_error_write(ierrl,"indent",indent) - goto 1 - end if - iotk_indent = indent - end if - if(present(maxindent)) then - if(maxindent<0 .or. maxindent>iotk_linlenx) then - call iotk_error_issue(ierrl,"iotk_set",__FILE__,__LINE__) -# 260 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 260 "iotk_misc.spp" -call iotk_error_msg(ierrl,'Wrong value for maxindent, should be between 0 and iotk_linlenx') -# 260 "iotk_misc.spp" -call iotk_error_write(ierrl,"maxindent",maxindent) -# 260 "iotk_misc.spp" -call iotk_error_write(ierrl,"iotk_linlenx",iotk_linlenx) - goto 1 - end if - iotk_maxindent = maxindent - end if - if(present(error_unit)) then - if(error_unit<0) then - call iotk_error_issue(ierrl,"iotk_set",__FILE__,__LINE__) -# 267 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 267 "iotk_misc.spp" -call iotk_error_msg(ierrl,'Wrong value for error_unit') -# 267 "iotk_misc.spp" -call iotk_error_write(ierrl,"error_unit",error_unit) - goto 1 - end if - iotk_error_unit = error_unit - end if - if(present(output_unit)) then - if(output_unit<0) then - call iotk_error_issue(ierrl,"iotk_set",__FILE__,__LINE__) -# 274 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 274 "iotk_misc.spp" -call iotk_error_msg(ierrl,'Wrong value for output_unit') -# 274 "iotk_misc.spp" -call iotk_error_write(ierrl,"output_unit",output_unit) - goto 1 - end if - iotk_output_unit = output_unit - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_set_x - -# 288 "iotk_misc.spp" -subroutine iotk_get_x(dummy,unitmin,unitmax,getline_buffer,error_warn_overflow, & - linlen,indent,maxindent,error_unit,output_unit) - use iotk_base - use iotk_misc_interf - implicit none - type(iotk_dummytype),optional :: dummy - integer, optional, intent(out) :: unitmin - integer, optional, intent(out) :: unitmax - integer, optional, intent(out) :: getline_buffer - logical, optional, intent(out) :: error_warn_overflow - integer, optional, intent(out) :: linlen - integer, optional, intent(out) :: indent - integer, optional, intent(out) :: maxindent - integer, optional, intent(out) :: error_unit - integer, optional, intent(out) :: output_unit - if(present(unitmin)) unitmin = iotk_unitmin - if(present(unitmax)) unitmax = iotk_unitmax - if(present(getline_buffer)) getline_buffer = iotk_getline_buffer - if(present(error_warn_overflow)) error_warn_overflow = iotk_error_warn_overflow - if(present(linlen)) linlen = iotk_linlen - if(present(indent)) indent = iotk_indent - if(present(maxindent)) maxindent = iotk_maxindent - if(present(error_unit)) error_unit = iotk_error_unit - if(present(output_unit)) output_unit = iotk_output_unit -end subroutine iotk_get_x - -# 315 "iotk_misc.spp" -subroutine iotk_print_kinds_x - use iotk_base - use iotk_misc_interf - use iotk_xtox_interf - implicit none - character(100) :: string - write(*,"(a,i5)") "Maximum rank : ", iotk_maxrank - write(*,"(a,i5)") "Maximum rank hard limit : ", iotk_maxrank -# 324 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL1 - string = "logical(kind="//trim(iotk_itoa(iotk_LOGICAL1))//")" - write(*,"(a)") trim(string) -#endif -# 324 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL2 - string = "logical(kind="//trim(iotk_itoa(iotk_LOGICAL2))//")" - write(*,"(a)") trim(string) -#endif -# 324 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL3 - string = "logical(kind="//trim(iotk_itoa(iotk_LOGICAL3))//")" - write(*,"(a)") trim(string) -#endif -# 324 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL4 - string = "logical(kind="//trim(iotk_itoa(iotk_LOGICAL4))//")" - write(*,"(a)") trim(string) -#endif -# 330 "iotk_misc.spp" -#ifdef __IOTK_INTEGER1 - string = "integer(kind="//trim(iotk_itoa(iotk_INTEGER1))//")" - write(*,"(a)") trim(string) -#endif -# 330 "iotk_misc.spp" -#ifdef __IOTK_INTEGER2 - string = "integer(kind="//trim(iotk_itoa(iotk_INTEGER2))//")" - write(*,"(a)") trim(string) -#endif -# 330 "iotk_misc.spp" -#ifdef __IOTK_INTEGER3 - string = "integer(kind="//trim(iotk_itoa(iotk_INTEGER3))//")" - write(*,"(a)") trim(string) -#endif -# 330 "iotk_misc.spp" -#ifdef __IOTK_INTEGER4 - string = "integer(kind="//trim(iotk_itoa(iotk_INTEGER4))//")" - write(*,"(a)") trim(string) -#endif -# 336 "iotk_misc.spp" -#ifdef __IOTK_REAL1 - string = "real(kind="//trim(iotk_itoa(iotk_REAL1))//")" - write(*,"(a)") trim(string) -#endif -# 336 "iotk_misc.spp" -#ifdef __IOTK_REAL2 - string = "real(kind="//trim(iotk_itoa(iotk_REAL2))//")" - write(*,"(a)") trim(string) -#endif -# 336 "iotk_misc.spp" -#ifdef __IOTK_REAL3 - string = "real(kind="//trim(iotk_itoa(iotk_REAL3))//")" - write(*,"(a)") trim(string) -#endif -# 336 "iotk_misc.spp" -#ifdef __IOTK_REAL4 - string = "real(kind="//trim(iotk_itoa(iotk_REAL4))//")" - write(*,"(a)") trim(string) -#endif -# 341 "iotk_misc.spp" - string = "character(kind="//trim(iotk_itoa(iotk_CHARACTER1))//")" - write(*,"(a)") trim(string) -end subroutine iotk_print_kinds_x - - -# 347 "iotk_misc.spp" -subroutine iotk_copy_dat_aux_x(source,dest,source_binary,dest_binary,name,type,ikind,isize, & - ilen,fmt,columns,attr,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: source - integer, intent(in) :: dest - logical, intent(in) :: source_binary - logical, intent(in) :: dest_binary - character(*), intent(in) :: name - character(*), intent(in) :: type - integer, intent(in) :: ikind - integer, intent(in) :: isize - integer, intent(in) :: ilen - character(*), intent(in) :: fmt - integer, intent(in) :: columns - character(*), intent(in) :: attr - integer, intent(out) :: ierr - - integer :: tmpkind -# 374 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL1 -# 378 "iotk_misc.spp" - LOGICAL (kind=iotk_LOGICAL1), allocatable :: dat_LOGICAL1 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL2 -# 378 "iotk_misc.spp" - LOGICAL (kind=iotk_LOGICAL2), allocatable :: dat_LOGICAL2 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL3 -# 378 "iotk_misc.spp" - LOGICAL (kind=iotk_LOGICAL3), allocatable :: dat_LOGICAL3 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL4 -# 378 "iotk_misc.spp" - LOGICAL (kind=iotk_LOGICAL4), allocatable :: dat_LOGICAL4 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_INTEGER1 -# 378 "iotk_misc.spp" - INTEGER (kind=iotk_INTEGER1), allocatable :: dat_INTEGER1 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_INTEGER2 -# 378 "iotk_misc.spp" - INTEGER (kind=iotk_INTEGER2), allocatable :: dat_INTEGER2 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_INTEGER3 -# 378 "iotk_misc.spp" - INTEGER (kind=iotk_INTEGER3), allocatable :: dat_INTEGER3 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_INTEGER4 -# 378 "iotk_misc.spp" - INTEGER (kind=iotk_INTEGER4), allocatable :: dat_INTEGER4 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_REAL1 -# 378 "iotk_misc.spp" - REAL (kind=iotk_REAL1), allocatable :: dat_REAL1 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_REAL2 -# 378 "iotk_misc.spp" - REAL (kind=iotk_REAL2), allocatable :: dat_REAL2 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_REAL3 -# 378 "iotk_misc.spp" - REAL (kind=iotk_REAL3), allocatable :: dat_REAL3 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_REAL4 -# 378 "iotk_misc.spp" - REAL (kind=iotk_REAL4), allocatable :: dat_REAL4 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_COMPLEX1 -# 378 "iotk_misc.spp" - COMPLEX (kind=iotk_COMPLEX1), allocatable :: dat_COMPLEX1 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_COMPLEX2 -# 378 "iotk_misc.spp" - COMPLEX (kind=iotk_COMPLEX2), allocatable :: dat_COMPLEX2 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_COMPLEX3 -# 378 "iotk_misc.spp" - COMPLEX (kind=iotk_COMPLEX3), allocatable :: dat_COMPLEX3 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_COMPLEX4 -# 378 "iotk_misc.spp" - COMPLEX (kind=iotk_COMPLEX4), allocatable :: dat_COMPLEX4 (:) -# 380 "iotk_misc.spp" -#endif -# 374 "iotk_misc.spp" -#ifdef __IOTK_CHARACTER1 -# 376 "iotk_misc.spp" - CHARACTER (kind=iotk_CHARACTER1,len=ilen), allocatable :: dat_CHARACTER1 (:) -# 380 "iotk_misc.spp" -#endif -# 384 "iotk_misc.spp" - -! Here is the rule: -! IF SOURCE IS BINARY: use the kind of source -! IF SOURCE IS TEXTUAL: use the default kind if available -! otherwise use the first kind found -! anyway, kind is computed runtime and in a future implementation -! it might be also asked to the user -! - ierr=0 - select case(type(1:iotk_strlen(type))) -# 395 "iotk_misc.spp" - case("LOGICAL") -# 399 "iotk_misc.spp" - if(source_binary) then - tmpkind=ikind - else - tmpkind=0 -# 404 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL1 - if(tmpkind==0) tmpkind=iotk_LOGICAL1 - if(iotk_LOGICAL1 == iotk_LOGICAL_defkind) then - tmpkind=iotk_LOGICAL_defkind - end if -#endif -# 404 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL2 - if(tmpkind==0) tmpkind=iotk_LOGICAL2 - if(iotk_LOGICAL2 == iotk_LOGICAL_defkind) then - tmpkind=iotk_LOGICAL_defkind - end if -#endif -# 404 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL3 - if(tmpkind==0) tmpkind=iotk_LOGICAL3 - if(iotk_LOGICAL3 == iotk_LOGICAL_defkind) then - tmpkind=iotk_LOGICAL_defkind - end if -#endif -# 404 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL4 - if(tmpkind==0) tmpkind=iotk_LOGICAL4 - if(iotk_LOGICAL4 == iotk_LOGICAL_defkind) then - tmpkind=iotk_LOGICAL_defkind - end if -#endif -# 411 "iotk_misc.spp" - end if -# 413 "iotk_misc.spp" - select case(tmpkind) -# 416 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL1 - case(iotk_LOGICAL1) - allocate(dat_LOGICAL1(isize)) - call iotk_scan_dat_aux(source,dat_LOGICAL1,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_LOGICAL1,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_LOGICAL1) -#endif -# 416 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL2 - case(iotk_LOGICAL2) - allocate(dat_LOGICAL2(isize)) - call iotk_scan_dat_aux(source,dat_LOGICAL2,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_LOGICAL2,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_LOGICAL2) -#endif -# 416 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL3 - case(iotk_LOGICAL3) - allocate(dat_LOGICAL3(isize)) - call iotk_scan_dat_aux(source,dat_LOGICAL3,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_LOGICAL3,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_LOGICAL3) -#endif -# 416 "iotk_misc.spp" -#ifdef __IOTK_LOGICAL4 - case(iotk_LOGICAL4) - allocate(dat_LOGICAL4(isize)) - call iotk_scan_dat_aux(source,dat_LOGICAL4,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_LOGICAL4,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_LOGICAL4) -#endif -# 425 "iotk_misc.spp" - case default - call iotk_error_issue(ierr,"iotk_copy_dat_aux",__FILE__,__LINE__) -# 426 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 426 "iotk_misc.spp" -call iotk_error_msg(ierr,'internal error') - end select -# 395 "iotk_misc.spp" - case("INTEGER") -# 399 "iotk_misc.spp" - if(source_binary) then - tmpkind=ikind - else - tmpkind=0 -# 404 "iotk_misc.spp" -#ifdef __IOTK_INTEGER1 - if(tmpkind==0) tmpkind=iotk_INTEGER1 - if(iotk_INTEGER1 == iotk_INTEGER_defkind) then - tmpkind=iotk_INTEGER_defkind - end if -#endif -# 404 "iotk_misc.spp" -#ifdef __IOTK_INTEGER2 - if(tmpkind==0) tmpkind=iotk_INTEGER2 - if(iotk_INTEGER2 == iotk_INTEGER_defkind) then - tmpkind=iotk_INTEGER_defkind - end if -#endif -# 404 "iotk_misc.spp" -#ifdef __IOTK_INTEGER3 - if(tmpkind==0) tmpkind=iotk_INTEGER3 - if(iotk_INTEGER3 == iotk_INTEGER_defkind) then - tmpkind=iotk_INTEGER_defkind - end if -#endif -# 404 "iotk_misc.spp" -#ifdef __IOTK_INTEGER4 - if(tmpkind==0) tmpkind=iotk_INTEGER4 - if(iotk_INTEGER4 == iotk_INTEGER_defkind) then - tmpkind=iotk_INTEGER_defkind - end if -#endif -# 411 "iotk_misc.spp" - end if -# 413 "iotk_misc.spp" - select case(tmpkind) -# 416 "iotk_misc.spp" -#ifdef __IOTK_INTEGER1 - case(iotk_INTEGER1) - allocate(dat_INTEGER1(isize)) - call iotk_scan_dat_aux(source,dat_INTEGER1,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_INTEGER1,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_INTEGER1) -#endif -# 416 "iotk_misc.spp" -#ifdef __IOTK_INTEGER2 - case(iotk_INTEGER2) - allocate(dat_INTEGER2(isize)) - call iotk_scan_dat_aux(source,dat_INTEGER2,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_INTEGER2,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_INTEGER2) -#endif -# 416 "iotk_misc.spp" -#ifdef __IOTK_INTEGER3 - case(iotk_INTEGER3) - allocate(dat_INTEGER3(isize)) - call iotk_scan_dat_aux(source,dat_INTEGER3,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_INTEGER3,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_INTEGER3) -#endif -# 416 "iotk_misc.spp" -#ifdef __IOTK_INTEGER4 - case(iotk_INTEGER4) - allocate(dat_INTEGER4(isize)) - call iotk_scan_dat_aux(source,dat_INTEGER4,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_INTEGER4,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_INTEGER4) -#endif -# 425 "iotk_misc.spp" - case default - call iotk_error_issue(ierr,"iotk_copy_dat_aux",__FILE__,__LINE__) -# 426 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 426 "iotk_misc.spp" -call iotk_error_msg(ierr,'internal error') - end select -# 395 "iotk_misc.spp" - case("REAL") -# 399 "iotk_misc.spp" - if(source_binary) then - tmpkind=ikind - else - tmpkind=0 -# 404 "iotk_misc.spp" -#ifdef __IOTK_REAL1 - if(tmpkind==0) tmpkind=iotk_REAL1 - if(iotk_REAL1 == iotk_REAL_defkind) then - tmpkind=iotk_REAL_defkind - end if -#endif -# 404 "iotk_misc.spp" -#ifdef __IOTK_REAL2 - if(tmpkind==0) tmpkind=iotk_REAL2 - if(iotk_REAL2 == iotk_REAL_defkind) then - tmpkind=iotk_REAL_defkind - end if -#endif -# 404 "iotk_misc.spp" -#ifdef __IOTK_REAL3 - if(tmpkind==0) tmpkind=iotk_REAL3 - if(iotk_REAL3 == iotk_REAL_defkind) then - tmpkind=iotk_REAL_defkind - end if -#endif -# 404 "iotk_misc.spp" -#ifdef __IOTK_REAL4 - if(tmpkind==0) tmpkind=iotk_REAL4 - if(iotk_REAL4 == iotk_REAL_defkind) then - tmpkind=iotk_REAL_defkind - end if -#endif -# 411 "iotk_misc.spp" - end if -# 413 "iotk_misc.spp" - select case(tmpkind) -# 416 "iotk_misc.spp" -#ifdef __IOTK_REAL1 - case(iotk_REAL1) - allocate(dat_REAL1(isize)) - call iotk_scan_dat_aux(source,dat_REAL1,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_REAL1,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_REAL1) -#endif -# 416 "iotk_misc.spp" -#ifdef __IOTK_REAL2 - case(iotk_REAL2) - allocate(dat_REAL2(isize)) - call iotk_scan_dat_aux(source,dat_REAL2,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_REAL2,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_REAL2) -#endif -# 416 "iotk_misc.spp" -#ifdef __IOTK_REAL3 - case(iotk_REAL3) - allocate(dat_REAL3(isize)) - call iotk_scan_dat_aux(source,dat_REAL3,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_REAL3,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_REAL3) -#endif -# 416 "iotk_misc.spp" -#ifdef __IOTK_REAL4 - case(iotk_REAL4) - allocate(dat_REAL4(isize)) - call iotk_scan_dat_aux(source,dat_REAL4,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_REAL4,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_REAL4) -#endif -# 425 "iotk_misc.spp" - case default - call iotk_error_issue(ierr,"iotk_copy_dat_aux",__FILE__,__LINE__) -# 426 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 426 "iotk_misc.spp" -call iotk_error_msg(ierr,'internal error') - end select -# 395 "iotk_misc.spp" - case("COMPLEX") -# 399 "iotk_misc.spp" - if(source_binary) then - tmpkind=ikind - else - tmpkind=0 -# 404 "iotk_misc.spp" -#ifdef __IOTK_COMPLEX1 - if(tmpkind==0) tmpkind=iotk_COMPLEX1 - if(iotk_COMPLEX1 == iotk_COMPLEX_defkind) then - tmpkind=iotk_COMPLEX_defkind - end if -#endif -# 404 "iotk_misc.spp" -#ifdef __IOTK_COMPLEX2 - if(tmpkind==0) tmpkind=iotk_COMPLEX2 - if(iotk_COMPLEX2 == iotk_COMPLEX_defkind) then - tmpkind=iotk_COMPLEX_defkind - end if -#endif -# 404 "iotk_misc.spp" -#ifdef __IOTK_COMPLEX3 - if(tmpkind==0) tmpkind=iotk_COMPLEX3 - if(iotk_COMPLEX3 == iotk_COMPLEX_defkind) then - tmpkind=iotk_COMPLEX_defkind - end if -#endif -# 404 "iotk_misc.spp" -#ifdef __IOTK_COMPLEX4 - if(tmpkind==0) tmpkind=iotk_COMPLEX4 - if(iotk_COMPLEX4 == iotk_COMPLEX_defkind) then - tmpkind=iotk_COMPLEX_defkind - end if -#endif -# 411 "iotk_misc.spp" - end if -# 413 "iotk_misc.spp" - select case(tmpkind) -# 416 "iotk_misc.spp" -#ifdef __IOTK_COMPLEX1 - case(iotk_COMPLEX1) - allocate(dat_COMPLEX1(isize)) - call iotk_scan_dat_aux(source,dat_COMPLEX1,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_COMPLEX1,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_COMPLEX1) -#endif -# 416 "iotk_misc.spp" -#ifdef __IOTK_COMPLEX2 - case(iotk_COMPLEX2) - allocate(dat_COMPLEX2(isize)) - call iotk_scan_dat_aux(source,dat_COMPLEX2,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_COMPLEX2,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_COMPLEX2) -#endif -# 416 "iotk_misc.spp" -#ifdef __IOTK_COMPLEX3 - case(iotk_COMPLEX3) - allocate(dat_COMPLEX3(isize)) - call iotk_scan_dat_aux(source,dat_COMPLEX3,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_COMPLEX3,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_COMPLEX3) -#endif -# 416 "iotk_misc.spp" -#ifdef __IOTK_COMPLEX4 - case(iotk_COMPLEX4) - allocate(dat_COMPLEX4(isize)) - call iotk_scan_dat_aux(source,dat_COMPLEX4,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_COMPLEX4,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_COMPLEX4) -#endif -# 425 "iotk_misc.spp" - case default - call iotk_error_issue(ierr,"iotk_copy_dat_aux",__FILE__,__LINE__) -# 426 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 426 "iotk_misc.spp" -call iotk_error_msg(ierr,'internal error') - end select -# 395 "iotk_misc.spp" - case("CHARACTER") -# 397 "iotk_misc.spp" - tmpkind=iotk_CHARACTER_defkind -# 413 "iotk_misc.spp" - select case(tmpkind) -# 416 "iotk_misc.spp" -#ifdef __IOTK_CHARACTER1 - case(iotk_CHARACTER1) - allocate(dat_CHARACTER1(isize)) - call iotk_scan_dat_aux(source,dat_CHARACTER1,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_CHARACTER1,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_CHARACTER1) -#endif -# 425 "iotk_misc.spp" - case default - call iotk_error_issue(ierr,"iotk_copy_dat_aux",__FILE__,__LINE__) -# 426 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 426 "iotk_misc.spp" -call iotk_error_msg(ierr,'internal error') - end select -# 429 "iotk_misc.spp" - case default - call iotk_error_issue(ierr,"iotk_copy_dat_aux",__FILE__,__LINE__) -# 430 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 430 "iotk_misc.spp" -call iotk_error_msg(ierr,'internal error') - end select - -end subroutine iotk_copy_dat_aux_x - - -# 437 "iotk_misc.spp" -subroutine iotk_copy_dat_x(source,dest,source_binary,dest_binary,name,attr,maxsize,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_write_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: source - integer, intent(in) :: dest - logical, intent(in) :: source_binary - logical, intent(in) :: dest_binary - character(*), intent(in) :: name - character(*), intent(in) :: attr - integer, intent(in) :: maxsize - integer, intent(out) :: ierr - character(9) :: type - integer :: ikind,isize,ilen,columns - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: attr1 - ierr = 0 - call iotk_parse_dat(attr,type,ikind,isize,ilen,fmt,columns,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_copy_dat",__FILE__,__LINE__) -# 460 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - if(iotk_strcomp(type,iotk_eos)) then - call iotk_error_issue(ierr,"iotk_copy_dat",__FILE__,__LINE__) -# 464 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - if(isize==-1) then - call iotk_error_issue(ierr,"iotk_copy_dat",__FILE__,__LINE__) -# 468 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - if(ilen==-1 .and. iotk_strcomp(type,"CHARACTER")) then - call iotk_error_issue(ierr,"iotk_copy_dat",__FILE__,__LINE__) -# 472 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - if(isize<=maxsize .or. maxsize==-1 .or. dest_binary) then - call iotk_copy_dat_aux(source,dest,source_binary,dest_binary,name,type,ikind,isize, & - ilen,fmt,columns,attr,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_copy_dat",__FILE__,__LINE__) -# 479 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - else - call iotk_strcpy(attr1,attr,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_copy_dat",__FILE__,__LINE__) -# 485 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - call iotk_write_attr (attr1,"trunc",.true.,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_copy_dat",__FILE__,__LINE__) -# 490 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - call iotk_write_empty(dest,name,attr=attr1,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_copy_dat",__FILE__,__LINE__) -# 495 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end if -end subroutine iotk_copy_dat_x - -# 502 "iotk_misc.spp" -subroutine iotk_check_iotk_attr_x(unit,attr,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_scan_interf - use iotk_str_interf - use iotk_xtox_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: unit - character(iotk_attlenx), intent(in) :: attr - integer, intent(out) :: ierr - character(iotk_vallenx) :: file_version,extensions - logical :: binary,rbinary,check,found,stream - integer :: pos1,pos2,attlen,itmp_major,itmp_minor - ierr = 0 - call iotk_scan_attr(attr,"file_version",file_version,eos=.true.,ierr=ierr,found=found) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_check_iotk_attr",__FILE__,__LINE__) -# 521 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - if(found) then - attlen = iotk_strlen(file_version) - pos1 = iotk_strscan(file_version,".") - if(pos1<=1 .or. pos1>=attlen) then - call iotk_error_issue(ierr,"iotk_check_iotk_attr",__FILE__,__LINE__) -# 528 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 528 "iotk_misc.spp" -call iotk_error_msg(ierr,'Problems reading file version') -# 528 "iotk_misc.spp" -call iotk_error_write(ierr,"file_version",file_version) -# 528 "iotk_misc.spp" -call iotk_error_write(ierr,"attlen",attlen) -# 528 "iotk_misc.spp" -call iotk_error_write(ierr,"pos1",pos1) - return - end if - pos2 = pos1 + verify(file_version(pos1+1:attlen),numbers) - if(pos2==pos1+1) then - call iotk_error_issue(ierr,"iotk_check_iotk_attr",__FILE__,__LINE__) -# 533 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 533 "iotk_misc.spp" -call iotk_error_msg(ierr,'Problems reading file version') -# 533 "iotk_misc.spp" -call iotk_error_write(ierr,"file_version",file_version) -# 533 "iotk_misc.spp" -call iotk_error_write(ierr,"attlen",attlen) -# 533 "iotk_misc.spp" -call iotk_error_write(ierr,"pos1",pos1) -# 533 "iotk_misc.spp" -call iotk_error_write(ierr,"pos2",pos2) - return - end if - if(pos2==pos1) pos2 = attlen+1 - call iotk_atoi(itmp_major,file_version(1:pos1-1),check) - if(.not.check) then - call iotk_error_issue(ierr,"iotk_check_iotk_attr",__FILE__,__LINE__) -# 539 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 539 "iotk_misc.spp" -call iotk_error_msg(ierr,'Problems reading file version') -# 539 "iotk_misc.spp" -call iotk_error_write(ierr,"file_version",file_version) - return - end if - call iotk_atoi(itmp_minor,file_version(pos1+1:pos2-1),check) - if(.not.check) then - call iotk_error_issue(ierr,"iotk_check_iotk_attr",__FILE__,__LINE__) -# 544 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 544 "iotk_misc.spp" -call iotk_error_msg(ierr,'Problems reading file version') -# 544 "iotk_misc.spp" -call iotk_error_write(ierr,"file_version",file_version) - return - end if - if(itmp_major > iotk_file_version_major .or. & - (itmp_major==iotk_file_version_major .and. itmp_minor > iotk_file_version_minor) ) then - call iotk_error_issue(ierr,"iotk_check_iotk_attr",__FILE__,__LINE__) -# 549 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 549 "iotk_misc.spp" -call iotk_error_msg(ierr,'File version is newer than internal version') -# 549 "iotk_misc.spp" -call iotk_error_write(ierr,"file_version",file_version) -# 549 "iotk_misc.spp" -call iotk_error_write(ierr,"internal_version",iotk_file_version) - return - end if - end if - call iotk_scan_attr(attr,"binary",rbinary,ierr=ierr,found=found) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_check_iotk_attr",__FILE__,__LINE__) -# 555 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - if(found) then - call iotk_inquire(unit,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_check_iotk_attr",__FILE__,__LINE__) -# 561 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - if(rbinary .neqv. binary) then - call iotk_error_issue(ierr,"iotk_check_iotk_attr",__FILE__,__LINE__) -# 565 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - end if - call iotk_scan_attr(attr,"extensions",extensions,ierr=ierr,found=found,eos=.true.) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_check_iotk_attr",__FILE__,__LINE__) -# 571 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - if(found) then - if(iotk_strlen(extensions) > 0) then - call iotk_error_issue(ierr,"iotk_check_iotk_attr",__FILE__,__LINE__) -# 576 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 576 "iotk_misc.spp" -call iotk_error_msg(ierr,'Extensions are not supported in this version') -# 576 "iotk_misc.spp" -call iotk_error_write(ierr,"extensions",extensions) - return - end if - end if -end subroutine iotk_check_iotk_attr_x - -# 583 "iotk_misc.spp" -function iotk_index_scal(index) - use iotk_base - use iotk_xtox_interf - use iotk_misc_interf - integer, intent(in) :: index - character(len=range(index)+3) :: iotk_index_scal - iotk_index_scal="."//iotk_itoa(index) -end function iotk_index_scal - -# 593 "iotk_misc.spp" -function iotk_index_vec(index) - use iotk_base - use iotk_xtox_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: index(:) - character(len=(range(index)+3)*size(index)) :: iotk_index_vec - integer :: length,i - length = 0 - iotk_index_vec = " " - do i = 1,size(index) - iotk_index_vec(length+1:length+1+(range(index)+3)) = "."//iotk_itoa(index(i)) - length = len_trim(iotk_index_vec) - end do -end function iotk_index_vec - - -# 611 "iotk_misc.spp" -subroutine iotk_tag_parse_x(tag,name,attr,ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - use iotk_str_interf - implicit none - character(iotk_taglenx), intent(in) :: tag - character(iotk_namlenx), intent(out) :: name - character(iotk_attlenx), intent(out) :: attr - integer, intent(out) :: ierr - integer :: pos,lenatt,lentag - ierr = 0 - lentag=iotk_strlen(tag) - if(verify(tag(1:1),iotk_namcharfirst)/=0) then - call iotk_error_issue(ierr,"iotk_tag_parse",__FILE__,__LINE__) -# 625 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 625 "iotk_misc.spp" -call iotk_error_msg(ierr,'Wrong syntax in tag') - call iotk_error_write(ierr,"tag",tag(1:lentag)) - return - end if - pos = scan(tag(1:lentag)," ") - if(pos==0) pos=lentag+1 - if(pos>len(name)+1) then - call iotk_error_issue(ierr,"iotk_tag_parse",__FILE__,__LINE__) -# 632 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 632 "iotk_misc.spp" -call iotk_error_msg(ierr,'Tag name too long') - return - end if - name = tag(1:pos-1) - if(pos<=len(name)) name(pos:pos) = iotk_eos - lenatt = len_trim(tag(pos:lentag)) - if(lenatt>iotk_attlenx) then - call iotk_error_issue(ierr,"iotk_tag_parse",__FILE__,__LINE__) -# 639 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 639 "iotk_misc.spp" -call iotk_error_msg(ierr,'Attribute string too long') - return - end if - if(lenatt>0) then - attr(1:lenatt) = tag(pos:pos+lenatt-1) - if(lenatt+1<=len(attr)) attr(lenatt+1:lenatt+1)=iotk_eos - else - attr(1:1)=iotk_eos - end if -end subroutine iotk_tag_parse_x - -# 651 "iotk_misc.spp" -function iotk_complete_filepath_x(newfile,oldfile) - use iotk_base - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: newfile - character(len=*), intent(in) :: oldfile - character(len=len(newfile)+len(oldfile)) :: iotk_complete_filepath_x - character(len=len(oldfile)) :: prefix - integer :: pos - if(newfile(1:1)=="/") then - iotk_complete_filepath_x = newfile - else - pos = scan(oldfile,"/",back=.true.) - prefix = " " - if(pos>0) prefix = oldfile(1:pos) - iotk_complete_filepath_x = trim(prefix)//trim(newfile) - end if -end function iotk_complete_filepath_x - -# 671 "iotk_misc.spp" -function iotk_check_name_x(name) - use iotk_base - use iotk_misc_interf - use iotk_str_interf - implicit none - character(len=*), intent(in) :: name - logical :: iotk_check_name_x -! Checks a single name - integer :: len_name - iotk_check_name_x = .true. - len_name = iotk_strlen_trim(name) - if(len_name>iotk_namlenx) iotk_check_name_x = .false. - if(verify(name(1:1),iotk_namcharfirst)/=0) iotk_check_name_x = .false. - if(len_name>1) then - if(verify(name(2:len_name),iotk_namchar)/=0) iotk_check_name_x = .false. - end if -end function iotk_check_name_x - -# 690 "iotk_misc.spp" -subroutine iotk_delete_attr_x(attr,name,ierr) - use iotk_base - use iotk_str_interf - use iotk_error_interf - implicit none - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - integer, intent(out) :: ierr - integer :: attlen,pos,equal,begin - logical :: foundl - character :: delim - ierr = 0 - attlen=iotk_strlen(attr) - foundl = .false. - equal = 0 - begin = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - call iotk_error_issue(ierr,"iotk_delete_attr",__FILE__,__LINE__) -# 712 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 712 "iotk_misc.spp" -call iotk_error_msg(ierr,'') -# 712 "iotk_misc.spp" -call iotk_error_write(ierr,"attr",attr) -# 712 "iotk_misc.spp" -call iotk_error_write(ierr,"equal",equal) - return - end if - if(trim(attr(equal:equal+pos-1))==trim(name)) foundl = .true. - begin = equal - equal = equal + pos - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - call iotk_error_issue(ierr,"iotk_delete_attr",__FILE__,__LINE__) -# 720 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - call iotk_error_issue(ierr,"iotk_delete_attr",__FILE__,__LINE__) -# 726 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 726 "iotk_misc.spp" -call iotk_error_msg(ierr,'delim') - return - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - call iotk_error_issue(ierr,"iotk_delete_attr",__FILE__,__LINE__) -# 731 "iotk_misc.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") - return - end if - equal = equal + pos - if(foundl) exit - end do - if(foundl) then - if(equalsize(args)) then - call iotk_error_issue(ierrl,"iotk_delete_attr",__FILE__,__LINE__) -# 774 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - read(*,"(a)",iostat=iostat) args(iarg) - if(iostat<0) exit - if(iostat>0) then - call iotk_error_issue(ierrl,"iotk_delete_attr",__FILE__,__LINE__) -# 780 "iotk_misc.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - pos = scan(args(iarg),"|",back=.true.) - if(pos>0) then - if(args(iarg)(pos:)=="|") then - args(iarg)(pos:pos) = iotk_eos - end if - else - pos = len_trim(args(iarg)) + 1 - if(pos<=len(args)) args(iarg)(pos:pos) = iotk_eos - end if - if(.not. leos) then - pos = iotk_strlen(args(iarg)) - if(pos##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -> REVISION='$Revision: 1.1.1.1 $' -> REVISION="${REVISION//${dol}/}" - ->PROCEDURE=iotk_copy_tag -subroutine iotk_copy_tag_x(source,dest,dummy,maxsize,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_scan_interf - use iotk_write_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: source - integer, intent(in) :: dest - type(iotk_dummytype),optional :: dummy - integer, optional, intent(in) :: maxsize - integer, optional, intent(out) :: ierr - logical :: source_binary,dest_binary,source_stream,dest_stream - integer :: ierrl,control,maxsizel - character(iotk_taglenx) :: tag - character(iotk_namlenx) :: name - character(iotk_attlenx) :: attr - character(iotk_vallenx) :: type - type(iotk_unit), pointer :: this - ierrl = 0 - maxsizel = -1 - if(present(maxsize)) maxsizel = maxsize - call iotk_inquire(source,source_binary,source_stream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_inquire(dest,dest_binary,dest_stream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_unit_get(source,pointer=this) - if(.not.associated(this)) then - $(ERROR ierrl unit) - goto 1 - end if - do - call iotk_scan_tag(source,+1,control,tag,source_binary,source_stream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(control/=4) then ! SKIP FOR COMMENTS - call iotk_tag_parse(tag,name,attr,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - if(iotk_strcomp(name,this%root)) then - call iotk_scan_tag(source,-1,control,tag,source_binary,source_stream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - return - end if - select case(control) - case(1) - call iotk_scan_attr(attr,"type",type,ierr=ierrl,eos=.true.,default=" ") - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if((iotk_strcomp(type,"real") .or. iotk_strcomp(type,"integer") .or. iotk_strcomp(type,"logical") & - .or. iotk_strcomp(type,"character") .or. iotk_strcomp(type,"complex")) .and. control==1) then - call iotk_copy_dat(source,dest,source_binary,dest_binary,name,attr,maxsize=maxsizel,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_scan_tag(source,+1,control,tag,source_binary,source_stream,ierrl) - else - call iotk_write_begin(dest,name,attr,ierr=ierrl) - end if - case(2) - call iotk_write_end(dest,name,ierr=ierrl) - case(3) - call iotk_write_empty(dest,name,attr,ierr=ierrl) - case(4) - call iotk_write_comment(dest,tag,ierr=ierrl) - case(5) - call iotk_write_pi(dest,name,attr,ierr=ierrl) - end select - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end do -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_copy_tag_x - ->PROCEDURE=iotk_parse_dat -subroutine iotk_parse_dat_x(attr,type,ikind,isize,ilen,fmt,columns,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: attr -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: type -#else - character(len=*), intent(out) :: type -#endif - integer, intent(out) :: ikind - integer, intent(out) :: isize - integer, intent(out) :: ilen -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: fmt -#else - character(len=*), intent(out) :: fmt -#endif - integer, intent(out) :: columns - integer, intent(out) :: ierr - character(iotk_vallenx) :: typename - ierr = 0 - call iotk_scan_attr(attr,"type",typename,ierr=ierr,eos=.true.,default=iotk_eos) - if(ierr/=0) then - $(ERROR ierr) - return - end if - type = iotk_toupper(typename) - call iotk_scan_attr(attr,"kind",ikind,ierr=ierr,default=-1) - if(ierr/=0) then - $(ERROR ierr) - return - end if - call iotk_scan_attr(attr,"size",isize,ierr=ierr,default=-1) - if(ierr/=0) then - $(ERROR ierr) - return - end if - call iotk_scan_attr(attr,"len", ilen, ierr=ierr,default=-1) - if(ierr/=0) then - $(ERROR ierr) - return - end if - call iotk_scan_attr(attr,"fmt", fmt, ierr=ierr,eos=.true.,default="!"//iotk_eos) - if(ierr/=0) then - $(ERROR ierr) - return - end if - call iotk_scan_attr(attr,"columns",columns,ierr=ierr,default=1) - if(ierr/=0) then - $(ERROR ierr) - return - end if -end subroutine iotk_parse_dat_x - ->PROCEDURE=iotk_set -subroutine iotk_set_x(dummy,unitmin,unitmax,getline_buffer,error_warn_overflow, & - linlen,indent,maxindent,error_unit,output_unit,ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - type(iotk_dummytype),optional :: dummy - integer, optional, intent(in) :: unitmin - integer, optional, intent(in) :: unitmax - integer, optional, intent(in) :: getline_buffer - logical, optional, intent(in) :: error_warn_overflow - integer, optional, intent(in) :: linlen - integer, optional, intent(in) :: indent - integer, optional, intent(in) :: maxindent - integer, optional, intent(in) :: error_unit - integer, optional, intent(in) :: output_unit - integer, optional, intent(out) :: ierr - integer :: ierrl - ierrl = 0 - if(present(error_warn_overflow)) then - iotk_error_warn_overflow = error_warn_overflow - end if - if(present(unitmin)) then - if(unitmin<0) then - $(ERROR ierrl 'Wrong value for unitmin' unitmin) - goto 1 - end if - iotk_unitmin = unitmin - end if - if(present(unitmax)) then - if(unitmax<0) then - $(ERROR ierrl 'Wrong value for unitmax' unitmax) - goto 1 - end if - iotk_unitmax = unitmax - end if - if(iotk_unitmin>iotk_unitmax) then - $(ERROR ierrl 'Inconsistency: unitmin should be less then unitmax' iotk_unitmin iotk_unitmax) - goto 1 - end if - if(present(getline_buffer)) then - if(getline_buffer<1) then - $(ERROR ierrl 'Wrong value for getline_buffer' getline_buffer) - goto 1 - end if - iotk_getline_buffer = getline_buffer - end if - if(present(linlen)) then - if(linlen<1) then - $(ERROR ierrl 'Wrong value for linlen' linlen) - goto 1 - end if - iotk_linlen = linlen - end if - if(present(indent)) then - if(indent<0) then - $(ERROR ierrl 'Wrong value for indent' indent) - goto 1 - end if - iotk_indent = indent - end if - if(present(maxindent)) then - if(maxindent<0 .or. maxindent>iotk_linlenx) then - $(ERROR ierrl 'Wrong value for maxindent, should be between 0 and iotk_linlenx' maxindent iotk_linlenx) - goto 1 - end if - iotk_maxindent = maxindent - end if - if(present(error_unit)) then - if(error_unit<0) then - $(ERROR ierrl 'Wrong value for error_unit' error_unit) - goto 1 - end if - iotk_error_unit = error_unit - end if - if(present(output_unit)) then - if(output_unit<0) then - $(ERROR ierrl 'Wrong value for output_unit' output_unit) - goto 1 - end if - iotk_output_unit = output_unit - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_set_x - ->PROCEDURE=iotk_get -subroutine iotk_get_x(dummy,unitmin,unitmax,getline_buffer,error_warn_overflow, & - linlen,indent,maxindent,error_unit,output_unit) - use iotk_base - use iotk_misc_interf - implicit none - type(iotk_dummytype),optional :: dummy - integer, optional, intent(out) :: unitmin - integer, optional, intent(out) :: unitmax - integer, optional, intent(out) :: getline_buffer - logical, optional, intent(out) :: error_warn_overflow - integer, optional, intent(out) :: linlen - integer, optional, intent(out) :: indent - integer, optional, intent(out) :: maxindent - integer, optional, intent(out) :: error_unit - integer, optional, intent(out) :: output_unit - if(present(unitmin)) unitmin = iotk_unitmin - if(present(unitmax)) unitmax = iotk_unitmax - if(present(getline_buffer)) getline_buffer = iotk_getline_buffer - if(present(error_warn_overflow)) error_warn_overflow = iotk_error_warn_overflow - if(present(linlen)) linlen = iotk_linlen - if(present(indent)) indent = iotk_indent - if(present(maxindent)) maxindent = iotk_maxindent - if(present(error_unit)) error_unit = iotk_error_unit - if(present(output_unit)) output_unit = iotk_output_unit -end subroutine iotk_get_x - ->PROCEDURE=iotk_print_kinds -subroutine iotk_print_kinds_x - use iotk_base - use iotk_misc_interf - use iotk_xtox_interf - implicit none - character(100) :: string - write(*,"(a,i5)") "Maximum rank : ", iotk_maxrank - write(*,"(a,i5)") "Maximum rank hard limit : ", iotk_maxrank -> for kind in $kinds ; do -#ifdef __IOTK_LOGICAL${kind} - string = "logical(kind="//trim(iotk_itoa(iotk_LOGICAL${kind}))//")" - write(*,"(a)") trim(string) -#endif -> done -> for kind in $kinds ; do -#ifdef __IOTK_INTEGER${kind} - string = "integer(kind="//trim(iotk_itoa(iotk_INTEGER${kind}))//")" - write(*,"(a)") trim(string) -#endif -> done -> for kind in $kinds ; do -#ifdef __IOTK_REAL${kind} - string = "real(kind="//trim(iotk_itoa(iotk_REAL${kind}))//")" - write(*,"(a)") trim(string) -#endif -> done - string = "character(kind="//trim(iotk_itoa(iotk_CHARACTER1))//")" - write(*,"(a)") trim(string) -end subroutine iotk_print_kinds_x - - ->PROCEDURE=iotk_copy_dat_aux -subroutine iotk_copy_dat_aux_x(source,dest,source_binary,dest_binary,name,type,ikind,isize, & - ilen,fmt,columns,attr,ierr) - use iotk_base - use iotk_error_interf - use iotk_dat_interf - use iotk_scan_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: source - integer, intent(in) :: dest - logical, intent(in) :: source_binary - logical, intent(in) :: dest_binary - character(*), intent(in) :: name - character(*), intent(in) :: type - integer, intent(in) :: ikind - integer, intent(in) :: isize - integer, intent(in) :: ilen - character(*), intent(in) :: fmt - integer, intent(in) :: columns - character(*), intent(in) :: attr - integer, intent(out) :: ierr - - integer :: tmpkind -> for type in $types ; do -> for kind in $kinds ; do -> if [ $type != CHARACTER -o $kind -eq 1 ] ; then -#ifdef __IOTK_$type$kind -> if [ $type = CHARACTER ] ; then - $type (kind=iotk_$type$kind,len=ilen), allocatable :: dat_$type$kind (:) -> else - $type (kind=iotk_$type$kind), allocatable :: dat_$type$kind (:) -> fi -#endif -> fi -> done -> done - -! Here is the rule: -! IF SOURCE IS BINARY: use the kind of source -! IF SOURCE IS TEXTUAL: use the default kind if available -! otherwise use the first kind found -! anyway, kind is computed runtime and in a future implementation -! it might be also asked to the user -! - ierr=0 - select case(type(1:iotk_strlen(type))) -> for type in $types ; do - case("$type") -> if [ $type = CHARACTER ] ; then - tmpkind=iotk_${type}_defkind -> else - if(source_binary) then - tmpkind=ikind - else - tmpkind=0 -> for kind in $kinds ; do -#ifdef __IOTK_$type$kind - if(tmpkind==0) tmpkind=iotk_$type$kind - if(iotk_$type$kind == iotk_${type}_defkind) then - tmpkind=iotk_${type}_defkind - end if -#endif -> done - end if -> fi - select case(tmpkind) -> for kind in $kinds ; do -> if [ $type != CHARACTER -o $kind -eq 1 ] ; then -#ifdef __IOTK_$type$kind - case(iotk_$type$kind) - allocate(dat_$type$kind(isize)) - call iotk_scan_dat_aux(source,dat_$type$kind,ikind,ilen,fmt,ierr) - if(ierr==0) call iotk_write_dat(dest,name,dat_$type$kind,attr=attr,ierr=ierr,fmt=fmt,columns=columns) - deallocate(dat_$type$kind) -#endif -> fi -> done - case default - $(ERROR ierr 'internal error' ) - end select -> done - case default - $(ERROR ierr 'internal error') - end select - -end subroutine iotk_copy_dat_aux_x - - ->PROCEDURE=iotk_copy_dat -subroutine iotk_copy_dat_x(source,dest,source_binary,dest_binary,name,attr,maxsize,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_write_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: source - integer, intent(in) :: dest - logical, intent(in) :: source_binary - logical, intent(in) :: dest_binary - character(*), intent(in) :: name - character(*), intent(in) :: attr - integer, intent(in) :: maxsize - integer, intent(out) :: ierr - character(9) :: type - integer :: ikind,isize,ilen,columns - character(iotk_vallenx) :: fmt - character(iotk_attlenx) :: attr1 - ierr = 0 - call iotk_parse_dat(attr,type,ikind,isize,ilen,fmt,columns,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - if(iotk_strcomp(type,iotk_eos)) then - $(ERROR ierr) - return - end if - if(isize==-1) then - $(ERROR ierr) - return - end if - if(ilen==-1 .and. iotk_strcomp(type,"CHARACTER")) then - $(ERROR ierr) - return - end if - if(isize<=maxsize .or. maxsize==-1 .or. dest_binary) then - call iotk_copy_dat_aux(source,dest,source_binary,dest_binary,name,type,ikind,isize, & - ilen,fmt,columns,attr,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - else - call iotk_strcpy(attr1,attr,ierr=ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - call iotk_write_attr (attr1,"trunc",.true.,ierr=ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - call iotk_write_empty(dest,name,attr=attr1,ierr=ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - end if -end subroutine iotk_copy_dat_x - ->PROCEDURE=iotk_check_iotk_attr -subroutine iotk_check_iotk_attr_x(unit,attr,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_scan_interf - use iotk_str_interf - use iotk_xtox_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: unit - character(iotk_attlenx), intent(in) :: attr - integer, intent(out) :: ierr - character(iotk_vallenx) :: file_version,extensions - logical :: binary,rbinary,check,found,stream - integer :: pos1,pos2,attlen,itmp_major,itmp_minor - ierr = 0 - call iotk_scan_attr(attr,"file_version",file_version,eos=.true.,ierr=ierr,found=found) - if(ierr/=0) then - $(ERROR ierr) - return - end if - if(found) then - attlen = iotk_strlen(file_version) - pos1 = iotk_strscan(file_version,".") - if(pos1<=1 .or. pos1>=attlen) then - $(ERROR ierr 'Problems reading file version' file_version attlen pos1) - return - end if - pos2 = pos1 + verify(file_version(pos1+1:attlen),numbers) - if(pos2==pos1+1) then - $(ERROR ierr 'Problems reading file version' file_version attlen pos1 pos2) - return - end if - if(pos2==pos1) pos2 = attlen+1 - call iotk_atoi(itmp_major,file_version(1:pos1-1),check) - if(.not.check) then - $(ERROR ierr 'Problems reading file version' file_version) - return - end if - call iotk_atoi(itmp_minor,file_version(pos1+1:pos2-1),check) - if(.not.check) then - $(ERROR ierr 'Problems reading file version' file_version) - return - end if - if(itmp_major > iotk_file_version_major .or. & - (itmp_major==iotk_file_version_major .and. itmp_minor > iotk_file_version_minor) ) then - $(ERROR ierr 'File version is newer than internal version' file_version internal_version=iotk_file_version) - return - end if - end if - call iotk_scan_attr(attr,"binary",rbinary,ierr=ierr,found=found) - if(ierr/=0) then - $(ERROR ierr) - return - end if - if(found) then - call iotk_inquire(unit,binary,stream,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - if(rbinary .neqv. binary) then - $(ERROR ierr) - return - end if - end if - call iotk_scan_attr(attr,"extensions",extensions,ierr=ierr,found=found,eos=.true.) - if(ierr/=0) then - $(ERROR ierr) - return - end if - if(found) then - if(iotk_strlen(extensions) > 0) then - $(ERROR ierr 'Extensions are not supported in this version' extensions) - return - end if - end if -end subroutine iotk_check_iotk_attr_x - ->PROCEDURE=iotk_index -function iotk_index_scal(index) - use iotk_base - use iotk_xtox_interf - use iotk_misc_interf - integer, intent(in) :: index - character(len=range(index)+3) :: iotk_index_scal - iotk_index_scal="."//iotk_itoa(index) -end function iotk_index_scal - ->PROCEDURE=iotk_index -function iotk_index_vec(index) - use iotk_base - use iotk_xtox_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: index(:) - character(len=(range(index)+3)*size(index)) :: iotk_index_vec - integer :: length,i - length = 0 - iotk_index_vec = " " - do i = 1,size(index) - iotk_index_vec(length+1:length+1+(range(index)+3)) = "."//iotk_itoa(index(i)) - length = len_trim(iotk_index_vec) - end do -end function iotk_index_vec - - ->PROCEDURE=iotk_tag_parse -subroutine iotk_tag_parse_x(tag,name,attr,ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - use iotk_str_interf - implicit none - character(iotk_taglenx), intent(in) :: tag - character(iotk_namlenx), intent(out) :: name - character(iotk_attlenx), intent(out) :: attr - integer, intent(out) :: ierr - integer :: pos,lenatt,lentag - ierr = 0 - lentag=iotk_strlen(tag) - if(verify(tag(1:1),iotk_namcharfirst)/=0) then - $(ERROR ierr 'Wrong syntax in tag') - call iotk_error_write(ierr,"tag",tag(1:lentag)) - return - end if - pos = scan(tag(1:lentag)," ") - if(pos==0) pos=lentag+1 - if(pos>len(name)+1) then - $(ERROR ierr 'Tag name too long') - return - end if - name = tag(1:pos-1) - if(pos<=len(name)) name(pos:pos) = iotk_eos - lenatt = len_trim(tag(pos:lentag)) - if(lenatt>iotk_attlenx) then - $(ERROR ierr 'Attribute string too long') - return - end if - if(lenatt>0) then - attr(1:lenatt) = tag(pos:pos+lenatt-1) - if(lenatt+1<=len(attr)) attr(lenatt+1:lenatt+1)=iotk_eos - else - attr(1:1)=iotk_eos - end if -end subroutine iotk_tag_parse_x - ->PROCEDURE=iotk_complete_filepath -function iotk_complete_filepath_x(newfile,oldfile) - use iotk_base - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: newfile - character(len=*), intent(in) :: oldfile - character(len=len(newfile)+len(oldfile)) :: iotk_complete_filepath_x - character(len=len(oldfile)) :: prefix - integer :: pos - if(newfile(1:1)=="/") then - iotk_complete_filepath_x = newfile - else - pos = scan(oldfile,"/",back=.true.) - prefix = " " - if(pos>0) prefix = oldfile(1:pos) - iotk_complete_filepath_x = trim(prefix)//trim(newfile) - end if -end function iotk_complete_filepath_x - ->PROCEDURE=iotk_check_name -function iotk_check_name_x(name) - use iotk_base - use iotk_misc_interf - use iotk_str_interf - implicit none - character(len=*), intent(in) :: name - logical :: iotk_check_name_x -! Checks a single name - integer :: len_name - iotk_check_name_x = .true. - len_name = iotk_strlen_trim(name) - if(len_name>iotk_namlenx) iotk_check_name_x = .false. - if(verify(name(1:1),iotk_namcharfirst)/=0) iotk_check_name_x = .false. - if(len_name>1) then - if(verify(name(2:len_name),iotk_namchar)/=0) iotk_check_name_x = .false. - end if -end function iotk_check_name_x - ->PROCEDURE=iotk_delete_attr -subroutine iotk_delete_attr_x(attr,name,ierr) - use iotk_base - use iotk_str_interf - use iotk_error_interf - implicit none - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - integer, intent(out) :: ierr - integer :: attlen,pos,equal,begin - logical :: foundl - character :: delim - ierr = 0 - attlen=iotk_strlen(attr) - foundl = .false. - equal = 0 - begin = 0 - do - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) exit - equal = equal + pos - pos = scan(attr(equal+1:attlen),"=") - if(pos<=0) then - $(ERROR ierr '' attr equal) - return - end if - if(trim(attr(equal:equal+pos-1))==trim(name)) foundl = .true. - begin = equal - equal = equal + pos - pos = verify(attr(equal+1:attlen)," ") - if(pos<=0) then - $(ERROR ierr) - return - end if - equal = equal + pos - delim = attr(equal:equal) - if(delim/="'" .and. delim/='"') then - $(ERROR ierr delim) - return - end if - pos = scan(attr(equal+1:attlen),delim) - if(pos<=0) then - $(ERROR ierr) - return - end if - equal = equal + pos - if(foundl) exit - end do - if(foundl) then - if(equalsize(args)) then - $(ERROR ierrl) - goto 1 - end if - read(*,"(a)",iostat=iostat) args(iarg) - if(iostat<0) exit - if(iostat>0) then - $(ERROR ierrl) - goto 1 - end if - pos = scan(args(iarg),"|",back=.true.) - if(pos>0) then - if(args(iarg)(pos:)=="|") then - args(iarg)(pos:pos) = iotk_eos - end if - else - pos = len_trim(args(iarg)) + 1 - if(pos<=len(args)) args(iarg)(pos:pos) = iotk_eos - end if - if(.not. leos) then - pos = iotk_strlen(args(iarg)) - if(pos##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -module iotk_misc_interf -implicit none -private - -public :: iotk_copy_tag -public :: iotk_parse_dat -public :: iotk_set -public :: iotk_get -public :: iotk_copy_dat_aux -public :: iotk_copy_dat -public :: iotk_print_kinds -public :: iotk_check_iotk_attr -public :: iotk_index -public :: iotk_check_name -public :: iotk_tag_parse -public :: iotk_complete_filepath -public :: iotk_delete_attr -public :: iotk_readcmdline -public :: iotk_init_static_vars - -! This module contains the interfaces to all iotk routines - -interface iotk_copy_tag -subroutine iotk_copy_tag_x(source,dest,dummy,maxsize,ierr) - use iotk_base - implicit none - integer, intent(in) :: source - integer, intent(in) :: dest - type(iotk_dummytype), optional :: dummy - integer, optional, intent(in) :: maxsize - integer, optional, intent(out) :: ierr -end subroutine iotk_copy_tag_x -end interface - -interface iotk_parse_dat -subroutine iotk_parse_dat_x(attr,type,kind,isize,len,fmt,columns,ierr) - implicit none - character(len=*), intent(in) :: attr -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: type -#else - character(len=*), intent(out) :: type -#endif - integer, intent(out) :: kind - integer, intent(out) :: isize - integer, intent(out) :: len -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: fmt -#else - character(len=*), intent(out) :: fmt -#endif - integer, intent(out) :: columns - integer, intent(out) :: ierr -end subroutine iotk_parse_dat_x -end interface - -interface iotk_set -subroutine iotk_set_x(dummy,unitmin,unitmax,getline_buffer,error_warn_overflow, & - linlen,indent,maxindent,error_unit,output_unit,ierr) - use iotk_base - implicit none - type(iotk_dummytype),optional :: dummy - integer, optional, intent(in) :: unitmin - integer, optional, intent(in) :: unitmax - integer, optional, intent(in) :: getline_buffer - logical, optional, intent(in) :: error_warn_overflow - integer, optional, intent(in) :: linlen - integer, optional, intent(in) :: indent - integer, optional, intent(in) :: maxindent - integer, optional, intent(in) :: error_unit - integer, optional, intent(in) :: output_unit - integer, optional, intent(out) :: ierr -end subroutine iotk_set_x -end interface - -interface iotk_get -subroutine iotk_get_x(dummy,unitmin,unitmax,getline_buffer,error_warn_overflow, & - linlen,indent,maxindent,error_unit,output_unit) - use iotk_base - implicit none - type(iotk_dummytype),optional :: dummy - integer, optional, intent(out) :: unitmin - integer, optional, intent(out) :: unitmax - integer, optional, intent(out) :: getline_buffer - logical, optional, intent(out) :: error_warn_overflow - integer, optional, intent(out) :: linlen - integer, optional, intent(out) :: indent - integer, optional, intent(out) :: maxindent - integer, optional, intent(out) :: error_unit - integer, optional, intent(out) :: output_unit -end subroutine iotk_get_x -end interface - -interface iotk_copy_dat_aux -subroutine iotk_copy_dat_aux_x(source,dest,source_binary,dest_binary,name,type,ikind,isize, & - len,fmt,columns,attr,ierr) - implicit none - integer, intent(in) :: source - integer, intent(in) :: dest - logical, intent(in) :: source_binary - logical, intent(in) :: dest_binary - character(*), intent(in) :: name - character(*), intent(in) :: type - integer, intent(in) :: ikind - integer, intent(in) :: isize - integer, intent(in) :: len - character(*), intent(in) :: fmt - integer, intent(in) :: columns - character(*), intent(in) :: attr - integer, intent(out) :: ierr -end subroutine iotk_copy_dat_aux_x -end interface - -interface iotk_copy_dat -subroutine iotk_copy_dat_x(source,dest,source_binary,dest_binary,name,attr,maxsize,ierr) - implicit none - integer, intent(in) :: source - integer, intent(in) :: dest - logical, intent(in) :: source_binary - logical, intent(in) :: dest_binary - character(*), intent(in) :: name - character(*), intent(in) :: attr - integer, intent(in) :: maxsize - integer, intent(out) :: ierr -end subroutine iotk_copy_dat_x -end interface - -interface iotk_print_kinds -subroutine iotk_print_kinds_x -end subroutine iotk_print_kinds_x -end interface - -interface iotk_check_iotk_attr -subroutine iotk_check_iotk_attr_x(unit,attr,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(iotk_attlenx), intent(in) :: attr - integer, intent(out) :: ierr -end subroutine iotk_check_iotk_attr_x -end interface - - -interface iotk_index -function iotk_index_scal(index) - implicit none - integer, intent(in) :: index - character(len=range(index)+3) :: iotk_index_scal -end function iotk_index_scal -function iotk_index_vec(index) - implicit none - integer, intent(in) :: index(:) - character(len=(range(index)+3)*size(index)) :: iotk_index_vec -end function iotk_index_vec -end interface - -interface iotk_tag_parse -subroutine iotk_tag_parse_x(tag,name,attr,ierr) - use iotk_base - implicit none - character(iotk_taglenx), intent(in) :: tag - character(iotk_namlenx), intent(out) :: name - character(iotk_attlenx), intent(out) :: attr - integer, intent(out) :: ierr -end subroutine iotk_tag_parse_x -end interface - -interface iotk_complete_filepath -function iotk_complete_filepath_x(newfile,oldfile) - implicit none - character(len=*), intent(in) :: newfile - character(len=*), intent(in) :: oldfile - character(len=len(newfile)+len(oldfile)) :: iotk_complete_filepath_x -end function iotk_complete_filepath_x -end interface - -interface iotk_check_name -function iotk_check_name_x(name) - implicit none - character(len=*), intent(in) :: name - logical :: iotk_check_name_x -end function iotk_check_name_x -end interface - -interface iotk_delete_attr -subroutine iotk_delete_attr_x(attr,name,ierr) - implicit none - character(len=*), intent(inout) :: attr - character(len=*), intent(in) :: name - integer, intent(out) :: ierr -end subroutine iotk_delete_attr_x -end interface - -interface iotk_readcmdline -subroutine iotk_readcmdline_x(args,nargs,eos,ierr) - implicit none - character(len=*), intent(out) :: args(:) - integer, intent(out) :: nargs - logical, optional, intent(in) :: eos - integer, optional, intent(out) :: ierr -end subroutine iotk_readcmdline_x -end interface - -interface iotk_init_static_vars -subroutine iotk_init_static_vars_x() -end subroutine iotk_init_static_vars_x -end interface - -end module iotk_misc_interf - diff --git a/quantum_espresso/kcp/iotk/src/iotk_module.f90 b/quantum_espresso/kcp/iotk/src/iotk_module.f90 deleted file mode 100644 index 021ad3e5c..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_module.f90 +++ /dev/null @@ -1,95 +0,0 @@ -# 1 "iotk_module.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -module iotk_module -! The end user should use this module. This is a wrapper for the entities defined -! across the library. - use iotk_base - use iotk_misc_interf - use iotk_error_interf - use iotk_attr_interf - use iotk_dat_interf - use iotk_files_interf - use iotk_write_interf - use iotk_scan_interf - use iotk_unit_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_tool_interf - implicit none - -! All names are private ... - private - -! ... except the names listed below - public :: iotk_open_write - public :: iotk_open_read - public :: iotk_close_write - public :: iotk_close_read - public :: iotk_write_begin - public :: iotk_write_end - public :: iotk_write_pi - public :: iotk_write_comment - public :: iotk_write_empty - public :: iotk_write_dat - public :: iotk_write_attr - public :: iotk_scan_begin - public :: iotk_scan_end - public :: iotk_scan_pi - public :: iotk_scan_empty - public :: iotk_scan_dat - public :: iotk_scan_attr - public :: iotk_taglenx - public :: iotk_attlenx - public :: iotk_vallenx - public :: iotk_namlenx - public :: iotk_fillenx - public :: iotk_index - public :: iotk_version - public :: iotk_header_kind - public :: iotk_copy_tag - public :: iotk_unit_print - public :: iotk_unit_get - public :: iotk_free_unit - public :: iotk_basefmt - public :: iotk_character_defkind - public :: iotk_logical_defkind - public :: iotk_integer_defkind - public :: iotk_real_defkind - public :: iotk_complex_defkind - public :: iotk_maxrank - public :: iotk_maxrank_hard - public :: iotk_print_kinds - public :: iotk_set - public :: iotk_get - public :: iotk_getline - public :: iotk_phys_unit - public :: iotk_link - public :: iotk_read - public :: iotk_copyfile - public :: iotk_newline - public :: iotk_eos - public :: iotk_error_clear - public :: iotk_error_print - public :: iotk_error_pool_pending - public :: iotk_tool - public :: iotk_readcmdline - public :: iotk_init_static_vars - public :: iotk_dummytype ! CHECK IF EVERY COMPILER ALLOW TO OMIT THIS TYPE -end module iotk_module - diff --git a/quantum_espresso/kcp/iotk/src/iotk_module.spp b/quantum_espresso/kcp/iotk/src/iotk_module.spp deleted file mode 100644 index 0f20127da..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_module.spp +++ /dev/null @@ -1,95 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -module iotk_module -! The end user should use this module. This is a wrapper for the entities defined -! across the library. - use iotk_base - use iotk_misc_interf - use iotk_error_interf - use iotk_attr_interf - use iotk_dat_interf - use iotk_files_interf - use iotk_write_interf - use iotk_scan_interf - use iotk_unit_interf - use iotk_xtox_interf - use iotk_fmt_interf - use iotk_tool_interf - implicit none - -! All names are private ... - private - -! ... except the names listed below - public :: iotk_open_write - public :: iotk_open_read - public :: iotk_close_write - public :: iotk_close_read - public :: iotk_write_begin - public :: iotk_write_end - public :: iotk_write_pi - public :: iotk_write_comment - public :: iotk_write_empty - public :: iotk_write_dat - public :: iotk_write_attr - public :: iotk_scan_begin - public :: iotk_scan_end - public :: iotk_scan_pi - public :: iotk_scan_empty - public :: iotk_scan_dat - public :: iotk_scan_attr - public :: iotk_taglenx - public :: iotk_attlenx - public :: iotk_vallenx - public :: iotk_namlenx - public :: iotk_fillenx - public :: iotk_index - public :: iotk_version - public :: iotk_header_kind - public :: iotk_copy_tag - public :: iotk_unit_print - public :: iotk_unit_get - public :: iotk_free_unit - public :: iotk_basefmt - public :: iotk_character_defkind - public :: iotk_logical_defkind - public :: iotk_integer_defkind - public :: iotk_real_defkind - public :: iotk_complex_defkind - public :: iotk_maxrank - public :: iotk_maxrank_hard - public :: iotk_print_kinds - public :: iotk_set - public :: iotk_get - public :: iotk_getline - public :: iotk_phys_unit - public :: iotk_link - public :: iotk_read - public :: iotk_copyfile - public :: iotk_newline - public :: iotk_eos - public :: iotk_error_clear - public :: iotk_error_print - public :: iotk_error_pool_pending - public :: iotk_tool - public :: iotk_readcmdline - public :: iotk_init_static_vars - public :: iotk_dummytype ! CHECK IF EVERY COMPILER ALLOW TO OMIT THIS TYPE -end module iotk_module - - diff --git a/quantum_espresso/kcp/iotk/src/iotk_print_kinds.f90 b/quantum_espresso/kcp/iotk/src/iotk_print_kinds.f90 deleted file mode 100644 index ca4c14b28..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_print_kinds.f90 +++ /dev/null @@ -1,4 +0,0 @@ -program main - use iotk_module - call iotk_print_kinds() -end program main diff --git a/quantum_espresso/kcp/iotk/src/iotk_scan.f90 b/quantum_espresso/kcp/iotk/src/iotk_scan.f90 deleted file mode 100644 index 3425e8315..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_scan.f90 +++ /dev/null @@ -1,1084 +0,0 @@ -# 1 "iotk_scan.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_scan.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_scan.spp" - -! -! Implementation of RAW I/O should be improved -! - -# 37 "iotk_scan.spp" - -# 39 "iotk_scan.spp" -recursive subroutine iotk_scan_begin_x(unit,name,attr,dummy,found,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_scan_interf - use iotk_files_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - integer, optional, intent(out) :: ierr - character(iotk_namlenx) :: namel - character(iotk_attlenx) :: attrl - character(iotk_vallenx) :: link - logical :: link_binary,link_raw - integer :: link_unit - logical :: binary,stream - integer :: ierrl,iostat - logical :: link_found,foundl - type(iotk_unit), pointer :: this_unit - integer :: lunit - character(iotk_fillenx) :: oldfile - ierrl = 0 - if(present(attr)) attr(1:1)=iotk_eos - foundl = .false. - call iotk_strcpy(namel,iotk_strtrim(name),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_begin",__FILE__,__LINE__) -# 75 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - iostat = 0 - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this_unit) - if(associated(this_unit)) then - if(this_unit%raw) then - foundl = .true. - goto 1 - end if - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_begin",__FILE__,__LINE__) -# 89 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - call iotk_scan(lunit, 1,1,namel,attrl,binary,stream,foundl,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_begin",__FILE__,__LINE__) -# 94 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(.not.foundl) then - call iotk_scan(lunit,-1,1,namel,attrl,binary,stream,foundl,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_begin",__FILE__,__LINE__) -# 100 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 100 "iotk_scan.spp" -call iotk_error_msg(ierrl,'') -# 100 "iotk_scan.spp" -call iotk_error_write(ierrl,"namel",namel) - goto 1 - end if - if(.not.foundl) goto 1 - end if - call iotk_scan_attr(attrl,"iotk_link",link,found=link_found,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_begin",__FILE__,__LINE__) -# 107 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - link_binary=.false. - if(link_found) then - call iotk_scan_attr(attrl,"iotk_raw",link_raw,default=.false.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_begin",__FILE__,__LINE__) -# 114 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(link_raw) then - call iotk_scan_attr(attrl,"iotk_binary",link_binary,default=.false.,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_begin",__FILE__,__LINE__) -# 120 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - end if - call iotk_free_unit(link_unit,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_begin",__FILE__,__LINE__) -# 126 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - inquire(unit=lunit,name=oldfile,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_scan_begin",__FILE__,__LINE__) -# 131 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - call iotk_open_read(link_unit,file=iotk_complete_filepath(link,oldfile),attr=attrl, & - binary=link_binary,raw=link_raw,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_begin",__FILE__,__LINE__) -# 137 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - call iotk_unit_parent(parent=lunit,son=link_unit,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_begin",__FILE__,__LINE__) -# 142 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - end if - if(present(attr)) call iotk_strcpy(attr,attrl,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_begin",__FILE__,__LINE__) -# 148 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_begin",__FILE__,__LINE__) -# 155 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 155 "iotk_scan.spp" -call iotk_error_msg(ierrl,'Tag not found') -# 155 "iotk_scan.spp" -call iotk_error_write(ierrl,"namel",namel) - ierrl = - ierrl - end if - if(ierrl==0 .and. foundl .and. associated(this_unit)) then - this_unit%level = this_unit%level + 1 -!write(0,*) "LEVEL=",this_unit%level,"incremented" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. .not.present(found)) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_begin_x - -# 170 "iotk_scan.spp" -recursive subroutine iotk_scan_end_x(unit,name,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_files_interf - use iotk_scan_interf - use iotk_misc_interf - use iotk_str_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr - character(iotk_namlenx) :: namel - logical :: binary,foundl,raw,stream - character(iotk_attlenx) :: attrl - integer :: ierrl - integer :: lunit - type(iotk_unit), pointer :: this_unit - ierrl = 0 - raw = .false. - call iotk_strcpy(namel,iotk_strtrim(name),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_end",__FILE__,__LINE__) -# 193 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this_unit) - if(associated(this_unit)) then - if(associated(this_unit%parent) .and. this_unit%level == 0) then - this_unit => this_unit%parent - call iotk_close_read(lunit,ierr=ierrl) - if(ierrl/=0) goto 1 - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this_unit) - end if - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) goto 1 - call iotk_scan(lunit,1,2,namel,attrl,binary,stream,foundl,ierrl) - if(ierrl/=0 .or. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_end",__FILE__,__LINE__) -# 211 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 211 "iotk_scan.spp" -call iotk_error_msg(ierrl,'foundl') - goto 1 - end if - if(iotk_strlen(attrl)/=0) then - call iotk_error_issue(ierrl,"iotk_scan_end",__FILE__,__LINE__) -# 215 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 215 "iotk_scan.spp" -call iotk_error_msg(ierrl,'An end tag should not contain attributes') -# 215 "iotk_scan.spp" -call iotk_error_write(ierrl,"name",trim(name)) -# 215 "iotk_scan.spp" -call iotk_error_write(ierrl,"attr",attrl) - goto 1 - end if - if(associated(this_unit)) this_unit%level = this_unit%level - 1 -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_end_x - -# 228 "iotk_scan.spp" -subroutine iotk_scan_pi_x(unit,name,attr,dummy,found,ierr) - use iotk_base - use iotk_error_interf - use iotk_scan_interf - use iotk_misc_interf - use iotk_unit_interf - use iotk_str_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - integer, optional, intent(out) :: ierr - character(iotk_namlenx) :: namel - character(iotk_attlenx) :: attrl - type(iotk_unit), pointer :: this - logical :: binary,foundl,stream - integer :: ierrl,lunit - ierrl = 0 - if(present(attr)) attr(1:1)=iotk_eos - call iotk_strcpy(namel,iotk_strtrim(name),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_pi",__FILE__,__LINE__) -# 255 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - if(associated(this)) then - if(this%raw) then - foundl=.true. - goto 1 - end if - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) goto 1 - call iotk_scan(lunit,1,5,namel,attrl,binary,stream,foundl,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_pi",__FILE__,__LINE__) -# 270 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(.not.foundl) then - call iotk_scan(lunit,-1,5,namel,attrl,binary,stream,foundl,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_pi",__FILE__,__LINE__) -# 276 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 276 "iotk_scan.spp" -call iotk_error_msg(ierrl,'') -# 276 "iotk_scan.spp" -call iotk_error_write(ierrl,"namel",namel) - goto 1 - end if - if(.not.foundl) goto 1 - end if - if(present(attr)) call iotk_strcpy(attr,attrl,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_pi",__FILE__,__LINE__) -# 283 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - end if -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_pi",__FILE__,__LINE__) -# 289 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 289 "iotk_scan.spp" -call iotk_error_msg(ierrl,'Tag not found') -# 289 "iotk_scan.spp" -call iotk_error_write(ierrl,"namel",namel) - ierrl = - ierrl - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. .not.present(found)) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_pi_x - -# 300 "iotk_scan.spp" -subroutine iotk_scan_empty_x(unit,name,attr,dummy,found,ierr) - use iotk_base - use iotk_error_interf - use iotk_scan_interf - use iotk_misc_interf - use iotk_str_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - integer, optional, intent(out) :: ierr - character(iotk_namlenx) :: namel - character(iotk_attlenx) :: attrl - type(iotk_unit),pointer :: this - logical :: binary,foundl,stream - integer :: ierrl,lunit - ierrl = 0 - if(present(attr)) attr(1:1)=iotk_eos - call iotk_strcpy(namel,iotk_strtrim(name),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_empty",__FILE__,__LINE__) -# 327 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - if(associated(this)) then - if(this%raw) then - foundl=.true. - goto 1 - end if - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_empty",__FILE__,__LINE__) -# 340 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - call iotk_scan(lunit,1,3,namel,attrl,binary,stream,foundl,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_empty",__FILE__,__LINE__) -# 345 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - goto 1 - end if - if(.not.foundl) then - call iotk_scan(lunit,-1,3,namel,attrl,binary,stream,foundl,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_empty",__FILE__,__LINE__) -# 351 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 351 "iotk_scan.spp" -call iotk_error_msg(ierrl,'') -# 351 "iotk_scan.spp" -call iotk_error_write(ierrl,"namel",(namel(1:iotk_strlen(namel)))) - goto 1 - end if - if(.not.foundl) goto 1 - end if - if(present(attr)) call iotk_strcpy(attr,attrl,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_scan_empty",__FILE__,__LINE__) -# 358 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - end if -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. foundl) then - call iotk_error_issue(ierrl,"iotk_scan_empty",__FILE__,__LINE__) -# 364 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 364 "iotk_scan.spp" -call iotk_error_msg(ierrl,'Tag not found') -# 364 "iotk_scan.spp" -call iotk_error_write(ierrl,"namel",namel) - ierrl = - ierrl - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. .not.present(found)) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_empty_x - -# 375 "iotk_scan.spp" -subroutine iotk_scan_tag_x(unit,direction,control,tag,binary,stream,ierr) - use iotk_base - use iotk_error_interf - use iotk_scan_interf - use iotk_misc_interf - use iotk_str_interf - use iotk_stream_interf - implicit none - integer, intent(in) :: unit - integer, intent(in) :: direction - integer, intent(out) :: control - character(iotk_taglenx), intent(out) :: tag - logical, intent(in) :: binary - logical, intent(in) :: stream - integer, intent(out) :: ierr - - character(iotk_taglenx) :: tagtmp(1) - integer(iotk_header_kind) :: header - integer :: taglen,pos,pos1,res,length,iostat - character(iotk_linlenx) :: line - character(4) :: predelim - character(3) :: postdelim - logical :: found - ierr = 0 - iostat = 0 - tag = " " - if(binary) then - found = .false. - do - if(direction<0) then - backspace(unit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 407 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 407 "iotk_scan.spp" -call iotk_error_msg(ierr,' ') -# 407 "iotk_scan.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - if(stream) then - call iotk_stream_read(unit,header,ierr=ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 414 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 414 "iotk_scan.spp" -call iotk_error_msg(ierr,'') - return - end if - else - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 420 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 420 "iotk_scan.spp" -call iotk_error_msg(ierr,' ') -# 420 "iotk_scan.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if - control = modulo(header,int(iotk_ncontrol+1,kind=kind(header))) - if(control/=0 .and. control/=128) then - found = .true. -#ifdef __IOTK_WORKAROUND7 - taglen=header/(iotk_ncontrol+1) - taglen = modulo(taglen,int(iotk_taglenx+1,kind=kind(taglen))) -#else - taglen = modulo(header/(iotk_ncontrol+1),int(iotk_taglenx+1, & - kind=kind(header/(iotk_ncontrol+1)))) -#endif - if(stream) then - call iotk_stream_read(unit,header,tagtmp(:)(1:taglen),ierr=ierr) - tag(1:taglen) = tagtmp(1)(1:taglen) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 438 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 438 "iotk_scan.spp" -call iotk_error_msg(ierr,'""') - return - end if - else - read(unit,iostat=iostat) header,tag(1:taglen) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 444 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 444 "iotk_scan.spp" -call iotk_error_msg(ierr,' ') -# 444 "iotk_scan.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -! -! the following lines are added to avoid the use of tag delimiters -! this enables the possibility to use them optionally in the binary files -! - select case(control) - case(1) - predelim="<" ; postdelim=">" - case(2) - predelim="" - case(3) - predelim="<" ; postdelim="/>" - case(4) - predelim="" - case(5) - predelim="" - end select - pos = index(tag(1:taglen),trim(predelim)) - if(pos/=0) pos=pos+len(trim(predelim)) - if(pos==0) pos=1 - pos1= index(tag(1:taglen),trim(postdelim),back=.true.) - if(pos1/=0) pos1=pos1-1 - if(pos1==0) pos1=taglen - tag(1:1+pos1-pos) = tag(pos:pos1) - taglen=1+pos1-pos -!!!!!! - if(taglen in the tag -! - if(direction>=0) then - taglen = 0 - do - call iotk_getline(unit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 516 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -! pos = scan(line(1:length),"<") - pos = iotk_strscan(line,"<") - if(pos/=0) exit - end do - do -! pos1 = scan(line(pos+1:length),">") + pos - pos1 = iotk_strscan(line(pos+1:),">") + pos - if(pos1/=pos) exit - if(taglen+length-pos+1>len(tag)) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 528 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 528 "iotk_scan.spp" -call iotk_error_msg(ierr,'Tag too long') - return - end if - tag(taglen+1:taglen+1) = " " - tag(taglen+2:taglen+length-pos+1) = line(pos+1:length) - taglen = taglen+length-pos+1 - pos = 0 - call iotk_getline(unit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 537 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - end do - if(taglen+pos1-pos>len(tag)) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 542 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 542 "iotk_scan.spp" -call iotk_error_msg(ierr,'Tag too long') - return - end if - tag(taglen+1:taglen+1) = " " - tag(taglen+2:taglen+pos1-pos) = line(pos+1:pos1-1) - taglen =taglen+pos1-pos - res = len_trim(line(1:length))-pos1 ! We use the length of the trimmed string. - ! this allows to change line if we have only blanks - if(res>0) then - backspace(unit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 553 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 553 "iotk_scan.spp" -call iotk_error_msg(ierr,' ') -# 553 "iotk_scan.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - call iotk_getline(unit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 558 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - backspace(unit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 563 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 563 "iotk_scan.spp" -call iotk_error_msg(ierr,' ') -# 563 "iotk_scan.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - res = length-res - read(unit,"(a)",iostat=iostat,advance='no') line(1:res) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 569 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 569 "iotk_scan.spp" -call iotk_error_msg(ierr,'length') -# 569 "iotk_scan.spp" -call iotk_error_write(ierr,"res",res) -# 569 "iotk_scan.spp" -call iotk_error_write(ierr,"iostat",iostat) - return - end if - end if -! pos = verify(tag," ") -! pos1 = len_trim(tag(1:taglen)) -! pos1 = taglen - pos = 2 - pos1=taglen - else - call iotk_getline(unit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 581 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - res = length -!write(0,*) ">>>",res - do - backspace(unit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 589 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - call iotk_getline(unit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 594 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -!write(0,*) ">>>%",length,res - pos = length - res - pos = scan(line(1:pos),">",back=.true.) - backspace(unit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 602 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - if(pos/=0) exit - res = 0 - end do - taglen=len(tag)+1 - do - pos1 = scan(line(1:pos-1),"<",back=.true.) - res = taglen - if(pos1>0) exit -!CHECK - tag(res-1:res-1) = " " - tag(res-pos:res-2) = line(1:pos-1) - taglen=taglen-pos - backspace(unit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 619 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - call iotk_getline(unit,line,length,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 624 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - backspace(unit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 629 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - pos = length+1 - end do -!CHECK - tag(res-1:res-1) = " " - tag(res-pos+pos1:res-2) = line(pos1+1:pos-1) - tag(1:len(tag)-res+pos-pos1+1) =tag(res-pos+pos1:len(tag)) -!write(0,*) "%%%%"//tag(1:len(tag)-res+pos-pos1+1)//"%%%%" - read(unit,"(a)",iostat=iostat,advance="no") line(1:pos1-1) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_scan_tag",__FILE__,__LINE__) -# 641 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -! pos1 = len_trim(tag(1:len(tag)-res+pos-pos1+1)) - pos1 = len(tag)-res+pos-pos1+1-1 -! pos = verify(tag," ") - pos = 1 - end if - tag(pos1+1:pos1+1) = iotk_eos -! write(0,*) "**",direction,"%"//(tag(1:iotk_strlen(tag)))//"%",pos,pos1 -! ONCE IMPROVED ABOVE, ADD MORE CONTROLS HERE - if(tag(pos:pos)=="/" .and. tag(pos1:pos1)/="/") then - control = 2 - tag = tag(pos+1:pos1)//iotk_eos - else if(tag(pos:pos)/="/" .and. tag(pos1:pos1)=="/") then - control = 3 - tag = tag(pos:pos1-1)//iotk_eos - else if(tag(pos:pos)=="?" .and. tag(pos1:pos1)=="?") then - control = 5 - tag = tag(pos+1:pos1-1)//iotk_eos - else if(tag(pos:pos+2)=="!--" .and. tag(pos1-1:pos1)=="--") then - control = 4 - tag = tag(pos+3:pos1-2)//iotk_eos - else - control = 1 - tag = tag(pos:pos1)//iotk_eos - end if -! write(0,*) "**",control,"%"//(tag(1:iotk_strlen(tag)))//"%" - end if -end subroutine iotk_scan_tag_x - -# 673 "iotk_scan.spp" -subroutine iotk_scan_x(unit,direction,control,name,attr,binary,stream,found,ierr) - use iotk_base - use iotk_error_interf - use iotk_scan_interf - use iotk_misc_interf - use iotk_str_interf - implicit none - integer, intent(in) :: unit - integer, intent(in) :: direction - integer, intent(in) :: control - character(iotk_namlenx), intent(in) :: name - character(iotk_attlenx), intent(out) :: attr - logical, intent(in) :: binary - logical, intent(in) :: stream - logical, intent(out) :: found - integer, intent(out) :: ierr - - character(iotk_taglenx) :: tag - character(iotk_namlenx) :: r_name - integer :: level,r_control,iostat - logical :: lall,match - - found=.false. - ierr = 0 - if(control==2 .and. direction<0) then - call iotk_error_issue(ierr,"iotk_scan",__FILE__,__LINE__) -# 698 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - level = 0 - ierr = 0 - do - lall=.false. - if(direction>=0 .and. level==0) lall=.true. - if(direction<0 .and. level==0 .and. control/=1) lall=.true. - if(direction<0 .and. level==1 .and. control==1) lall=.true. - call iotk_scan_tag(unit,direction,r_control,tag,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan",__FILE__,__LINE__) -# 710 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - if(r_control==4) cycle - if(lall .or. r_control==5) then - call iotk_tag_parse(tag,r_name,attr,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan",__FILE__,__LINE__) -# 717 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") -# 717 "iotk_scan.spp" -call iotk_error_msg(ierr,'direction') -# 717 "iotk_scan.spp" -call iotk_error_write(ierr,"control",control) - return - end if - end if - match = lall .and. r_control==control .and. iotk_strcomp(r_name,iotk_strtrim(name)) - if(r_control==5) then - if(r_name=="iotk") then - call iotk_check_iotk_attr(unit,attr,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan",__FILE__,__LINE__) -# 726 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - end if - end if - select case(direction) - case(0:) - select case(r_control) - case(1) - if(level==0 .and. match) exit - level = level + 1 - case(2) - if(level==0 .and. match) exit - if(level==0) then -!-< -! ... line to solve a bug : before are needed two lines at the end of the files -! ... to get right scanning - if (.not.binary) THEN - backspace(unit,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(iostat,"iotk_scan",__FILE__,__LINE__) -call iotk_error_msg(iostat,"CVS Revision: 1.23 ") -call iotk_error_msg(iostat,' ') -call iotk_error_write(iostat,"iostat",iostat) - return - end if - else -!-> - call iotk_scan_tag(unit,-1,r_control,tag,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan",__FILE__,__LINE__) -# 742 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if -!-< - end if -!-> - return - end if - level = level - 1 - case(3) - if(level==0 .and. match) exit - case(5) - if(level==0 .and. match) exit - end select - case(:-1) - select case(r_control) - case(2) - level = level + 1 - case(1) - if(level==1 .and. match) exit - if(level==0) then - call iotk_scan_tag(unit,+1,r_control,tag,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan",__FILE__,__LINE__) -# 762 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - return - end if - return - end if - level = level - 1 - case(3) - if(level==0 .and. match) exit - case(5) - if(level==0 .and. match) exit - end select - end select - end do - if(direction<0) then - call iotk_scan_tag(unit,+1,r_control,tag,binary,stream,ierr) - if(ierr/=0) then - call iotk_error_issue(ierr,"iotk_scan",__FILE__,__LINE__) -# 778 "iotk_scan.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.7 ") - end if - end if - found=.true. -end subroutine iotk_scan_x - -# 785 "iotk_scan.spp" -subroutine iotk_getline_x(unit,line,length,ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: line -#else - character(len=*), intent(out) :: line -#endif - integer, optional, intent(out) :: length - integer, optional, intent(out) :: ierr - integer :: iostat -#if defined __IOTK_WORKAROUND1 - character(len=iotk_linlenx) :: buffer -#else - character(len=iotk_getline_buffer) :: buffer -#endif - integer :: pos,buflen,ierrl,pos1 - logical :: eor - pos = 0 - ierrl=0 -#ifdef __IOTK_WORKAROUND1 -! First solution: advancing read - read(unit,"(a)",iostat=iostat) buffer - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_getline",__FILE__,__LINE__) -# 812 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 812 "iotk_scan.spp" -call iotk_error_msg(ierrl,'') -# 812 "iotk_scan.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 2 - end if - buflen = len_trim(buffer) - line(1:buflen) = buffer(1:buflen) - line(buflen+1:buflen+1) = iotk_eos - if(present(length)) length = buflen -#else - do - eor = .true. - read(unit,"(a)",iostat=iostat,eor=1,size=buflen,advance="no") buffer -3 continue - eor = .false. - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_getline",__FILE__,__LINE__) -# 826 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") - call iotk_error_write(ierrl,"iostat",iostat) - goto 2 - end if -1 continue - if(buflen==0) exit - pos1 = min(pos+buflen,len(line)) - line(pos+1:pos1) = buffer(1:pos1-pos) - pos = pos1 - if(eor .or. pos>=len(line)) exit - end do - if(pos=len(line)) then - call iotk_error_issue(ierrl,"iotk_getline",__FILE__,__LINE__) -# 840 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 840 "iotk_scan.spp" -call iotk_error_msg(ierrl,'Line too long') - read(unit,*,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_getline",__FILE__,__LINE__) -# 843 "iotk_scan.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.7 ") -# 843 "iotk_scan.spp" -call iotk_error_msg(ierrl,'iostat') - goto 2 - end if - end if -#endif -2 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if - -end subroutine iotk_getline_x diff --git a/quantum_espresso/kcp/iotk/src/iotk_scan.spp b/quantum_espresso/kcp/iotk/src/iotk_scan.spp deleted file mode 100644 index 426013700..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_scan.spp +++ /dev/null @@ -1,855 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -! -! Implementation of RAW I/O should be improved -! - -> REVISION='$Revision: 1.1.1.1 $' -> REVISION="${REVISION//${dol}/}" - ->PROCEDURE=iotk_scan_begin -recursive subroutine iotk_scan_begin_x(unit,name,attr,dummy,found,ierr) - use iotk_base - use iotk_error_interf - use iotk_attr_interf - use iotk_scan_interf - use iotk_files_interf - use iotk_str_interf - use iotk_unit_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - integer, optional, intent(out) :: ierr - character(iotk_namlenx) :: namel - character(iotk_attlenx) :: attrl - character(iotk_vallenx) :: link - logical :: link_binary,link_raw - integer :: link_unit - logical :: binary,stream - integer :: ierrl,iostat - logical :: link_found,foundl - type(iotk_unit), pointer :: this_unit - integer :: lunit - character(iotk_fillenx) :: oldfile - ierrl = 0 - if(present(attr)) attr(1:1)=iotk_eos - foundl = .false. - call iotk_strcpy(namel,iotk_strtrim(name),ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - iostat = 0 - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this_unit) - if(associated(this_unit)) then - if(this_unit%raw) then - foundl = .true. - goto 1 - end if - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_scan(lunit, 1,1,namel,attrl,binary,stream,foundl,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(.not.foundl) then - call iotk_scan(lunit,-1,1,namel,attrl,binary,stream,foundl,ierrl) - if(ierrl/=0) then - $(ERROR ierrl '' namel) - goto 1 - end if - if(.not.foundl) goto 1 - end if - call iotk_scan_attr(attrl,"iotk_link",link,found=link_found,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - link_binary=.false. - if(link_found) then - call iotk_scan_attr(attrl,"iotk_raw",link_raw,default=.false.,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(link_raw) then - call iotk_scan_attr(attrl,"iotk_binary",link_binary,default=.false.,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - call iotk_free_unit(link_unit,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - inquire(unit=lunit,name=oldfile,iostat=iostat) - if(iostat/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_open_read(link_unit,file=iotk_complete_filepath(link,oldfile),attr=attrl, & - binary=link_binary,raw=link_raw,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_unit_parent(parent=lunit,son=link_unit,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - if(present(attr)) call iotk_strcpy(attr,attrl,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. foundl) then - $(ERROR ierrl 'Tag not found' namel) - ierrl = - ierrl - end if - if(ierrl==0 .and. foundl .and. associated(this_unit)) then - this_unit%level = this_unit%level + 1 -!write(0,*) "LEVEL=",this_unit%level,"incremented" - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. .not.present(found)) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_begin_x - ->PROCEDURE="iotk_scan_end" -recursive subroutine iotk_scan_end_x(unit,name,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_files_interf - use iotk_scan_interf - use iotk_misc_interf - use iotk_str_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr - character(iotk_namlenx) :: namel - logical :: binary,foundl,raw,stream - character(iotk_attlenx) :: attrl - integer :: ierrl - integer :: lunit - type(iotk_unit), pointer :: this_unit - ierrl = 0 - raw = .false. - call iotk_strcpy(namel,iotk_strtrim(name),ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this_unit) - if(associated(this_unit)) then - if(associated(this_unit%parent) .and. this_unit%level == 0) then - this_unit => this_unit%parent - call iotk_close_read(lunit,ierr=ierrl) - if(ierrl/=0) goto 1 - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this_unit) - end if - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) goto 1 - call iotk_scan(lunit,1,2,namel,attrl,binary,stream,foundl,ierrl) - if(ierrl/=0 .or. .not. foundl) then - $(ERROR ierrl foundl) - goto 1 - end if - if(iotk_strlen(attrl)/=0) then - $(ERROR ierrl 'An end tag should not contain attributes' name='trim(name)' attr=attrl) - goto 1 - end if - if(associated(this_unit)) this_unit%level = this_unit%level - 1 -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_end_x - ->PROCEDURE=iotk_scan_pi -subroutine iotk_scan_pi_x(unit,name,attr,dummy,found,ierr) - use iotk_base - use iotk_error_interf - use iotk_scan_interf - use iotk_misc_interf - use iotk_unit_interf - use iotk_str_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - integer, optional, intent(out) :: ierr - character(iotk_namlenx) :: namel - character(iotk_attlenx) :: attrl - type(iotk_unit), pointer :: this - logical :: binary,foundl,stream - integer :: ierrl,lunit - ierrl = 0 - if(present(attr)) attr(1:1)=iotk_eos - call iotk_strcpy(namel,iotk_strtrim(name),ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - if(associated(this)) then - if(this%raw) then - foundl=.true. - goto 1 - end if - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) goto 1 - call iotk_scan(lunit,1,5,namel,attrl,binary,stream,foundl,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(.not.foundl) then - call iotk_scan(lunit,-1,5,namel,attrl,binary,stream,foundl,ierrl) - if(ierrl/=0) then - $(ERROR ierrl '' namel) - goto 1 - end if - if(.not.foundl) goto 1 - end if - if(present(attr)) call iotk_strcpy(attr,attrl,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - end if -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. foundl) then - $(ERROR ierrl 'Tag not found' namel) - ierrl = - ierrl - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. .not.present(found)) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_pi_x - ->PROCEDURE=iotk_scan_empty -subroutine iotk_scan_empty_x(unit,name,attr,dummy,found,ierr) - use iotk_base - use iotk_error_interf - use iotk_scan_interf - use iotk_misc_interf - use iotk_str_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - integer, optional, intent(out) :: ierr - character(iotk_namlenx) :: namel - character(iotk_attlenx) :: attrl - type(iotk_unit),pointer :: this - logical :: binary,foundl,stream - integer :: ierrl,lunit - ierrl = 0 - if(present(attr)) attr(1:1)=iotk_eos - call iotk_strcpy(namel,iotk_strtrim(name),ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this) - if(associated(this)) then - if(this%raw) then - foundl=.true. - goto 1 - end if - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_scan(lunit,1,3,namel,attrl,binary,stream,foundl,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(.not.foundl) then - call iotk_scan(lunit,-1,3,namel,attrl,binary,stream,foundl,ierrl) - if(ierrl/=0) then - $(ERROR ierrl '' namel='(namel(1:iotk_strlen(namel)))') - goto 1 - end if - if(.not.foundl) goto 1 - end if - if(present(attr)) call iotk_strcpy(attr,attrl,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - end if -1 continue - if(ierrl/=0) foundl=.false. - if(present(found)) found = foundl - if(ierrl==0 .and. .not. present(found) .and. .not. foundl) then - $(ERROR ierrl 'Tag not found' namel) - ierrl = - ierrl - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl>0 .or. .not.present(found)) call iotk_error_handler(ierrl) - end if -end subroutine iotk_scan_empty_x - ->PROCEDURE=iotk_scan_tag -subroutine iotk_scan_tag_x(unit,direction,control,tag,binary,stream,ierr) - use iotk_base - use iotk_error_interf - use iotk_scan_interf - use iotk_misc_interf - use iotk_str_interf - use iotk_stream_interf - implicit none - integer, intent(in) :: unit - integer, intent(in) :: direction - integer, intent(out) :: control - character(iotk_taglenx), intent(out) :: tag - logical, intent(in) :: binary - logical, intent(in) :: stream - integer, intent(out) :: ierr - - character(iotk_taglenx) :: tagtmp(1) - integer(iotk_header_kind) :: header - integer :: taglen,pos,pos1,res,length,iostat - character(iotk_linlenx) :: line - character(4) :: predelim - character(3) :: postdelim - logical :: found - ierr = 0 - iostat = 0 - tag = " " - if(binary) then - found = .false. - do - if(direction<0) then - backspace(unit,iostat=iostat) - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - end if - if(stream) then - call iotk_stream_read(unit,header,ierr=ierr) - if(ierr/=0) then - $(ERROR ierr '') - return - end if - else - read(unit,iostat=iostat) header - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - end if - control = modulo(header,int(iotk_ncontrol+1,kind=kind(header))) - if(control/=0 .and. control/=128) then - found = .true. -#ifdef __IOTK_WORKAROUND7 - taglen=header/(iotk_ncontrol+1) - taglen = modulo(taglen,int(iotk_taglenx+1,kind=kind(taglen))) -#else - taglen = modulo(header/(iotk_ncontrol+1),int(iotk_taglenx+1, & - kind=kind(header/(iotk_ncontrol+1)))) -#endif - if(stream) then - call iotk_stream_read(unit,header,tagtmp(:)(1:taglen),ierr=ierr) - tag(1:taglen) = tagtmp(1)(1:taglen) - if(ierr/=0) then - $(ERROR ierr "") - return - end if - else - read(unit,iostat=iostat) header,tag(1:taglen) - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - end if -! -! the following lines are added to avoid the use of tag delimiters -! this enables the possibility to use them optionally in the binary files -! - select case(control) - case(1) - predelim="<" ; postdelim=">" - case(2) - predelim="" - case(3) - predelim="<" ; postdelim="/>" - case(4) - predelim="" - case(5) - predelim="" - end select - pos = index(tag(1:taglen),trim(predelim)) - if(pos/=0) pos=pos+len(trim(predelim)) - if(pos==0) pos=1 - pos1= index(tag(1:taglen),trim(postdelim),back=.true.) - if(pos1/=0) pos1=pos1-1 - if(pos1==0) pos1=taglen - tag(1:1+pos1-pos) = tag(pos:pos1) - taglen=1+pos1-pos -!!!!!! - if(taglen in the tag -! - if(direction>=0) then - taglen = 0 - do - call iotk_getline(unit,line,length,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if -! pos = scan(line(1:length),"<") - pos = iotk_strscan(line,"<") - if(pos/=0) exit - end do - do -! pos1 = scan(line(pos+1:length),">") + pos - pos1 = iotk_strscan(line(pos+1:),">") + pos - if(pos1/=pos) exit - if(taglen+length-pos+1>len(tag)) then - $(ERROR ierr 'Tag too long') - return - end if - tag(taglen+1:taglen+1) = " " - tag(taglen+2:taglen+length-pos+1) = line(pos+1:length) - taglen = taglen+length-pos+1 - pos = 0 - call iotk_getline(unit,line,length,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - end do - if(taglen+pos1-pos>len(tag)) then - $(ERROR ierr 'Tag too long') - return - end if - tag(taglen+1:taglen+1) = " " - tag(taglen+2:taglen+pos1-pos) = line(pos+1:pos1-1) - taglen =taglen+pos1-pos - res = len_trim(line(1:length))-pos1 ! We use the length of the trimmed string. - ! this allows to change line if we have only blanks - if(res>0) then - backspace(unit,iostat=iostat) - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - call iotk_getline(unit,line,length,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - backspace(unit,iostat=iostat) - if(iostat/=0) then - $(ERROR ierr ' ' iostat) - return - end if - res = length-res - read(unit,"(a)",iostat=iostat,advance='no') line(1:res) - if(iostat/=0) then - $(ERROR ierr length res iostat) - return - end if - end if -! pos = verify(tag," ") -! pos1 = len_trim(tag(1:taglen)) -! pos1 = taglen - pos = 2 - pos1=taglen - else - call iotk_getline(unit,line,length,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - res = length -!write(0,*) ">>>",res - do - backspace(unit,iostat=iostat) - if(iostat/=0) then - $(ERROR ierr) - return - end if - call iotk_getline(unit,line,length,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if -!write(0,*) ">>>%",length,res - pos = length - res - pos = scan(line(1:pos),">",back=.true.) - backspace(unit,iostat=iostat) - if(iostat/=0) then - $(ERROR ierr) - return - end if - if(pos/=0) exit - res = 0 - end do - taglen=len(tag)+1 - do - pos1 = scan(line(1:pos-1),"<",back=.true.) - res = taglen - if(pos1>0) exit -!CHECK - tag(res-1:res-1) = " " - tag(res-pos:res-2) = line(1:pos-1) - taglen=taglen-pos - backspace(unit,iostat=iostat) - if(iostat/=0) then - $(ERROR ierr) - return - end if - call iotk_getline(unit,line,length,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - backspace(unit,iostat=iostat) - if(iostat/=0) then - $(ERROR ierr) - return - end if - pos = length+1 - end do -!CHECK - tag(res-1:res-1) = " " - tag(res-pos+pos1:res-2) = line(pos1+1:pos-1) - tag(1:len(tag)-res+pos-pos1+1) =tag(res-pos+pos1:len(tag)) -!write(0,*) "%%%%"//tag(1:len(tag)-res+pos-pos1+1)//"%%%%" - read(unit,"(a)",iostat=iostat,advance="no") line(1:pos1-1) - if(iostat/=0) then - $(ERROR ierr) - return - end if -! pos1 = len_trim(tag(1:len(tag)-res+pos-pos1+1)) - pos1 = len(tag)-res+pos-pos1+1-1 -! pos = verify(tag," ") - pos = 1 - end if - tag(pos1+1:pos1+1) = iotk_eos -! write(0,*) "**",direction,"%"//(tag(1:iotk_strlen(tag)))//"%",pos,pos1 -! ONCE IMPROVED ABOVE, ADD MORE CONTROLS HERE - if(tag(pos:pos)=="/" .and. tag(pos1:pos1)/="/") then - control = 2 - tag = tag(pos+1:pos1)//iotk_eos - else if(tag(pos:pos)/="/" .and. tag(pos1:pos1)=="/") then - control = 3 - tag = tag(pos:pos1-1)//iotk_eos - else if(tag(pos:pos)=="?" .and. tag(pos1:pos1)=="?") then - control = 5 - tag = tag(pos+1:pos1-1)//iotk_eos - else if(tag(pos:pos+2)=="!--" .and. tag(pos1-1:pos1)=="--") then - control = 4 - tag = tag(pos+3:pos1-2)//iotk_eos - else - control = 1 - tag = tag(pos:pos1)//iotk_eos - end if -! write(0,*) "**",control,"%"//(tag(1:iotk_strlen(tag)))//"%" - end if -end subroutine iotk_scan_tag_x - ->PROCEDURE=iotk_scan -subroutine iotk_scan_x(unit,direction,control,name,attr,binary,stream,found,ierr) - use iotk_base - use iotk_error_interf - use iotk_scan_interf - use iotk_misc_interf - use iotk_str_interf - implicit none - integer, intent(in) :: unit - integer, intent(in) :: direction - integer, intent(in) :: control - character(iotk_namlenx), intent(in) :: name - character(iotk_attlenx), intent(out) :: attr - logical, intent(in) :: binary - logical, intent(in) :: stream - logical, intent(out) :: found - integer, intent(out) :: ierr - - character(iotk_taglenx) :: tag - character(iotk_namlenx) :: r_name - integer :: level,r_control - logical :: lall,match - - found=.false. - ierr = 0 - if(control==2 .and. direction<0) then - $(ERROR ierr) - return - end if - level = 0 - ierr = 0 - do - lall=.false. - if(direction>=0 .and. level==0) lall=.true. - if(direction<0 .and. level==0 .and. control/=1) lall=.true. - if(direction<0 .and. level==1 .and. control==1) lall=.true. - call iotk_scan_tag(unit,direction,r_control,tag,binary,stream,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - if(r_control==4) cycle - if(lall .or. r_control==5) then - call iotk_tag_parse(tag,r_name,attr,ierr) - if(ierr/=0) then - $(ERROR ierr direction control) - return - end if - end if - match = lall .and. r_control==control .and. iotk_strcomp(r_name,iotk_strtrim(name)) - if(r_control==5) then - if(r_name=="iotk") then - call iotk_check_iotk_attr(unit,attr,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - end if - end if - select case(direction) - case(0:) - select case(r_control) - case(1) - if(level==0 .and. match) exit - level = level + 1 - case(2) - if(level==0 .and. match) exit - if(level==0) then - call iotk_scan_tag(unit,-1,r_control,tag,binary,stream,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - return - end if - level = level - 1 - case(3) - if(level==0 .and. match) exit - case(5) - if(level==0 .and. match) exit - end select - case(:-1) - select case(r_control) - case(2) - level = level + 1 - case(1) - if(level==1 .and. match) exit - if(level==0) then - call iotk_scan_tag(unit,+1,r_control,tag,binary,stream,ierr) - if(ierr/=0) then - $(ERROR ierr) - return - end if - return - end if - level = level - 1 - case(3) - if(level==0 .and. match) exit - case(5) - if(level==0 .and. match) exit - end select - end select - end do - if(direction<0) then - call iotk_scan_tag(unit,+1,r_control,tag,binary,stream,ierr) - if(ierr/=0) then - $(ERROR ierr) - end if - end if - found=.true. -end subroutine iotk_scan_x - ->PROCEDURE=iotk_getline -subroutine iotk_getline_x(unit,line,length,ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: line -#else - character(len=*), intent(out) :: line -#endif - integer, optional, intent(out) :: length - integer, optional, intent(out) :: ierr - integer :: iostat -#if defined __IOTK_WORKAROUND1 - character(len=iotk_linlenx) :: buffer -#else - character(len=iotk_getline_buffer) :: buffer -#endif - integer :: pos,buflen,ierrl,pos1 - logical :: eor - pos = 0 - ierrl=0 -#ifdef __IOTK_WORKAROUND1 -! First solution: advancing read - read(unit,"(a)",iostat=iostat) buffer - if(iostat/=0) then - $(ERROR ierrl '' iostat) - goto 2 - end if - buflen = len_trim(buffer) - line(1:buflen) = buffer(1:buflen) - line(buflen+1:buflen+1) = iotk_eos - if(present(length)) length = buflen -#else - do - eor = .true. - read(unit,"(a)",iostat=iostat,eor=1,size=buflen,advance="no") buffer -3 continue - eor = .false. - if(iostat/=0) then - $(ERROR ierrl) - call iotk_error_write(ierrl,"iostat",iostat) - goto 2 - end if -1 continue - if(buflen==0) exit - pos1 = min(pos+buflen,len(line)) - line(pos+1:pos1) = buffer(1:pos1-pos) - pos = pos1 - if(eor .or. pos>=len(line)) exit - end do - if(pos=len(line)) then - $(ERROR ierrl 'Line too long') - read(unit,*,iostat=iostat) - if(iostat/=0) then - $(ERROR ierrl iostat) - goto 2 - end if - end if -#endif -2 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if - -end subroutine iotk_getline_x diff --git a/quantum_espresso/kcp/iotk/src/iotk_scan_interf.f90 b/quantum_espresso/kcp/iotk/src/iotk_scan_interf.f90 deleted file mode 100644 index 0f86daa3b..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_scan_interf.f90 +++ /dev/null @@ -1,146 +0,0 @@ -# 1 "iotk_scan_interf.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_scan_interf.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_scan_interf.spp" - -module iotk_scan_interf -implicit none -private - -public :: iotk_scan_begin -public :: iotk_scan_end -public :: iotk_scan_pi -public :: iotk_scan_empty -public :: iotk_scan_tag -public :: iotk_scan -public :: iotk_getline - -interface iotk_scan_begin -subroutine iotk_scan_begin_x(unit,name,attr,dummy,found,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_begin_x -end interface - -interface iotk_scan_end -subroutine iotk_scan_end_x(unit,name,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_end_x -end interface - -interface iotk_scan_pi -subroutine iotk_scan_pi_x(unit,name,attr,dummy,found,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_pi_x -end interface - -interface iotk_scan_empty -subroutine iotk_scan_empty_x(unit,name,attr,dummy,found,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_empty_x -end interface - -interface iotk_scan_tag -subroutine iotk_scan_tag_x(unit,direction,control,tag,binary,stream,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer, intent(in) :: direction - integer, intent(out) :: control - character(iotk_taglenx), intent(out) :: tag - logical, intent(in) :: binary - logical, intent(in) :: stream - integer, intent(out) :: ierr -end subroutine iotk_scan_tag_x -end interface - -interface iotk_scan -subroutine iotk_scan_x(unit,direction,control,name,attr,binary,stream,found,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer, intent(in) :: direction - integer, intent(in) :: control - character(iotk_namlenx), intent(in) :: name - character(iotk_attlenx), intent(out) :: attr - logical, intent(in) :: binary - logical, intent(in) :: stream - logical, intent(out) :: found - integer, intent(out) :: ierr -end subroutine iotk_scan_x -end interface - -interface iotk_getline -subroutine iotk_getline_x(unit,line,length,ierr) - implicit none - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: line -#else - character(len=*), intent(out) :: line -#endif - integer, optional, intent(out) :: length - integer, optional, intent(out) :: ierr -end subroutine iotk_getline_x -end interface - -end module iotk_scan_interf diff --git a/quantum_espresso/kcp/iotk/src/iotk_scan_interf.spp b/quantum_espresso/kcp/iotk/src/iotk_scan_interf.spp deleted file mode 100644 index d92de2b3c..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_scan_interf.spp +++ /dev/null @@ -1,150 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -module iotk_scan_interf -implicit none -private - -public :: iotk_scan_begin -public :: iotk_scan_end -public :: iotk_scan_pi -public :: iotk_scan_empty -public :: iotk_scan_tag -public :: iotk_scan -public :: iotk_getline - -interface iotk_scan_begin -subroutine iotk_scan_begin_x(unit,name,attr,dummy,found,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_begin_x -end interface - -interface iotk_scan_end -subroutine iotk_scan_end_x(unit,name,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_end_x -end interface - -interface iotk_scan_pi -subroutine iotk_scan_pi_x(unit,name,attr,dummy,found,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_pi_x -end interface - -interface iotk_scan_empty -subroutine iotk_scan_empty_x(unit,name,attr,dummy,found,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name -#ifdef __IOTK_WORKAROUND6 - character(len=*), optional :: attr -#else - character(len=*), optional, intent(out) :: attr -#endif - type(iotk_dummytype), optional :: dummy - logical, optional, intent(out) :: found - integer, optional, intent(out) :: ierr -end subroutine iotk_scan_empty_x -end interface - -interface iotk_scan_tag -subroutine iotk_scan_tag_x(unit,direction,control,tag,binary,stream,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer, intent(in) :: direction - integer, intent(out) :: control - character(iotk_taglenx), intent(out) :: tag - logical, intent(in) :: binary - logical, intent(in) :: stream - integer, intent(out) :: ierr -end subroutine iotk_scan_tag_x -end interface - -interface iotk_scan -subroutine iotk_scan_x(unit,direction,control,name,attr,binary,stream,found,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer, intent(in) :: direction - integer, intent(in) :: control - character(iotk_namlenx), intent(in) :: name - character(iotk_attlenx), intent(out) :: attr - logical, intent(in) :: binary - logical, intent(in) :: stream - logical, intent(out) :: found - integer, intent(out) :: ierr -end subroutine iotk_scan_x -end interface - -interface iotk_getline -subroutine iotk_getline_x(unit,line,length,ierr) - implicit none - integer, intent(in) :: unit -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: line -#else - character(len=*), intent(out) :: line -#endif - integer, optional, intent(out) :: length - integer, optional, intent(out) :: ierr -end subroutine iotk_getline_x -end interface - -end module iotk_scan_interf - diff --git a/quantum_espresso/kcp/iotk/src/iotk_str.f90 b/quantum_espresso/kcp/iotk/src/iotk_str.f90 deleted file mode 100644 index 22339fbef..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_str.f90 +++ /dev/null @@ -1,323 +0,0 @@ -# 1 "iotk_str.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_str.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_str.spp" - -# 33 "iotk_str.spp" - -function iotk_toupper_x(str) - use iotk_base - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_toupper_x - integer :: i,pos - do i = 1,len(str) - if(str(i:i)==iotk_eos) exit - pos=scan(lowalphabet,str(i:i)) - if(pos==0) then - iotk_toupper_x(i:i) = str(i:i) - else - iotk_toupper_x(i:i) = upalphabet(pos:pos) - end if - end do - if(i<=len(iotk_toupper_x)) iotk_toupper_x(i:i) = iotk_eos -end function iotk_toupper_x - -function iotk_tolower_x(str) - use iotk_base - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_tolower_x - integer :: i,pos - do i = 1,len(str) - if(str(i:i)==iotk_eos) exit - pos=scan(upalphabet,str(i:i)) - if(pos==0) then - iotk_tolower_x(i:i) = str(i:i) - else - iotk_tolower_x(i:i) = lowalphabet(pos:pos) - end if - end do - if(i<=len(iotk_tolower_x)) iotk_tolower_x(i:i) = iotk_eos -end function iotk_tolower_x - -subroutine iotk_escape_x(to,from) - use iotk_base - use iotk_misc_interf - use iotk_str_interf - implicit none - character(len=*), intent(in) :: from -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: to -#else - character(len=*), intent(out) :: to -#endif - integer :: pos,pos1,semic,fromlen - pos = 1 - pos1 = 1 - fromlen = iotk_strlen(from) - do - if(pos>fromlen) exit - if(from(pos:pos)=="&" .and. pos/=fromlen) then - semic = scan(from(pos+1:fromlen),";") - if(semic<=1) to(pos1:pos1)="&" - select case(from(pos+1:pos+semic-1)) - case("amp") - to(pos1:pos1)="&" - case("lt") - to(pos1:pos1)="<" - case("gt") - to(pos1:pos1)=">" - case("quot") - to(pos1:pos1)='"' - case("apos") - to(pos1:pos1)="'" - case default - to(pos1:pos1+semic) = from(pos:pos+semic) - pos1 = pos1 + semic - end select - pos = pos + semic - else - to(pos1:pos1)=from(pos:pos) - end if - pos = pos + 1 - pos1 = pos1 + 1 - if(pos1>len(to)) exit - end do - if(pos1<=len(to)) to(pos1:pos1)=iotk_eos -end subroutine iotk_escape_x - -subroutine iotk_deescape_x(to,from,quot,apos) - use iotk_base - use iotk_misc_interf - use iotk_str_interf - implicit none - character(len=*), intent(in) :: from -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: to -#else - character(len=*), intent(out) :: to -#endif - logical, optional, intent(in) :: quot,apos - logical :: lquot,lapos - integer :: pos,pos1 - lquot=.false. - lapos=.false. - if(present(quot)) lquot = quot - if(present(apos)) lapos = apos - pos = 1 - pos1 = 1 - do - if(pos>len(from) .or. pos1>len(to)) exit ! The two checks must be separated - if(from(pos:pos)==iotk_eos) exit - select case(from(pos:pos)) - case("&") - if(pos1+4<=len(to)) to(pos1:pos1+4)="&" - pos1=pos1+4 - case("<") - if(pos1+3<=len(to)) to(pos1:pos1+3)="<" - pos1=pos1+3 - case(">") - if(pos1+3<=len(to)) to(pos1:pos1+3)=">" - pos1=pos1+3 - case('"') - if(lquot) then - if(pos1+5<=len(to)) to(pos1:pos1+5)=""" - pos1=pos1+5 - else - to(pos1:pos1) = from(pos:pos) - end if - case("'") - if(lapos) then - if(pos1+5<=len(to)) to(pos1:pos1+5)="'" - pos1=pos1+5 - else - to(pos1:pos1) = from(pos:pos) - end if - case default - to(pos1:pos1) = from(pos:pos) - end select - pos = pos + 1 - pos1 = pos1 + 1 - end do - if(pos1<=len(to)) to(pos1:pos1)=iotk_eos -end subroutine iotk_deescape_x - -function iotk_strtrim_x(str) - use iotk_base - use iotk_str_interf - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_strtrim_x - integer :: lentrim - lentrim = len_trim(str(1:iotk_strlen(str))) - iotk_strtrim_x(1:lentrim) = str(1:lentrim) - if(lentrim=0) then - iotk_strlen_x = pos - else - iotk_strlen_x = len(str) - end if -end function iotk_strlen_x - -function iotk_strpad_x(str) - use iotk_base - use iotk_misc_interf - use iotk_str_interf - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_strpad_x - integer :: strlen - strlen = iotk_strlen(str) - iotk_strpad_x(1:strlen) = str(1:strlen) - if(strlenlen(to) .and. i<=len(from)) then - if(from(i:i)/=iotk_eos) then - call iotk_error_issue(ierr,"iotk_strcpy",__FILE__,__LINE__) -# 259 "iotk_str.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.4 ") - return - end if - end if - if(i<=len(to)) to(i:i) = iotk_eos -end subroutine iotk_strcpy_x - -# 267 "iotk_str.spp" -subroutine iotk_strcat_x(to,from,ierr) - use iotk_base - use iotk_error_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(len=*), intent(inout):: to - character(len=*), intent(in) :: from - integer, intent(out):: ierr - integer :: tolen,fromlen - ierr = 0 - tolen = iotk_strlen(to) - fromlen = iotk_strlen(from) - if(tolen+fromlen>len(to)) then - call iotk_error_issue(ierr,"iotk_strcat",__FILE__,__LINE__) -# 281 "iotk_str.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.4 ") - end if - if(ierr/=0) return - to(tolen+1:tolen+fromlen) = from(1:fromlen) - if(tolen+fromlen+1<=len(to)) to(tolen+fromlen+1:tolen+fromlen+1)=iotk_eos -end subroutine iotk_strcat_x - -# 289 "iotk_str.spp" -function iotk_strcomp_x(str1,str2) - use iotk_base - implicit none - logical :: iotk_strcomp_x - character(len=*), intent(in) :: str1,str2 - integer :: i - iotk_strcomp_x = .false. - do i=1,min(len(str1),len(str2)) - if(str1(i:i)/=str2(i:i)) return - if(str1(i:i)==iotk_eos) exit - end do - if(i>len(str1)) then - if(i<=len(str2)) then - if(str2(i:i)/=iotk_eos) return - end if - else if(i>len(str2)) then - if(i<=len(str1)) then - if(str1(i:i)/=iotk_eos) return - end if - end if - iotk_strcomp_x = .true. -end function iotk_strcomp_x - -# 313 "iotk_str.spp" -subroutine iotk_str_clean_x(str) -! transforms all characters which are separators in blanks - use iotk_base - implicit none - character(len=*), intent(inout) :: str - integer :: i - do i = 1 , len(str) - if(str(i:i)==iotk_eos) exit - if(scan(not_separator,str(i:i))==0) str(i:i)=" " - end do -end subroutine iotk_str_clean_x diff --git a/quantum_espresso/kcp/iotk/src/iotk_str.spp b/quantum_espresso/kcp/iotk/src/iotk_str.spp deleted file mode 100644 index 155940d85..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_str.spp +++ /dev/null @@ -1,324 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -> REVISION='$Revision: 1.1.1.1 $' -> REVISION="${REVISION//${dol}/}" - -function iotk_toupper_x(str) - use iotk_base - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_toupper_x - integer :: i,pos - do i = 1,len(str) - if(str(i:i)==iotk_eos) exit - pos=scan(lowalphabet,str(i:i)) - if(pos==0) then - iotk_toupper_x(i:i) = str(i:i) - else - iotk_toupper_x(i:i) = upalphabet(pos:pos) - end if - end do - if(i<=len(iotk_toupper_x)) iotk_toupper_x(i:i) = iotk_eos -end function iotk_toupper_x - -function iotk_tolower_x(str) - use iotk_base - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_tolower_x - integer :: i,pos - do i = 1,len(str) - if(str(i:i)==iotk_eos) exit - pos=scan(upalphabet,str(i:i)) - if(pos==0) then - iotk_tolower_x(i:i) = str(i:i) - else - iotk_tolower_x(i:i) = lowalphabet(pos:pos) - end if - end do - if(i<=len(iotk_tolower_x)) iotk_tolower_x(i:i) = iotk_eos -end function iotk_tolower_x - -subroutine iotk_escape_x(to,from) - use iotk_base - use iotk_misc_interf - use iotk_str_interf - implicit none - character(len=*), intent(in) :: from -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: to -#else - character(len=*), intent(out) :: to -#endif - integer :: pos,pos1,semic,fromlen - pos = 1 - pos1 = 1 - fromlen = iotk_strlen(from) - do - if(pos>fromlen) exit - if(from(pos:pos)=="&" .and. pos/=fromlen) then - semic = scan(from(pos+1:fromlen),";") - if(semic<=1) to(pos1:pos1)="&" - select case(from(pos+1:pos+semic-1)) - case("amp") - to(pos1:pos1)="&" - case("lt") - to(pos1:pos1)="<" - case("gt") - to(pos1:pos1)=">" - case("quot") - to(pos1:pos1)='"' - case("apos") - to(pos1:pos1)="'" - case default - to(pos1:pos1+semic) = from(pos:pos+semic) - pos1 = pos1 + semic - end select - pos = pos + semic - else - to(pos1:pos1)=from(pos:pos) - end if - pos = pos + 1 - pos1 = pos1 + 1 - if(pos1>len(to)) exit - end do - if(pos1<=len(to)) to(pos1:pos1)=iotk_eos -end subroutine iotk_escape_x - -subroutine iotk_deescape_x(to,from,quot,apos) - use iotk_base - use iotk_misc_interf - use iotk_str_interf - implicit none - character(len=*), intent(in) :: from -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: to -#else - character(len=*), intent(out) :: to -#endif - logical, optional, intent(in) :: quot,apos - logical :: lquot,lapos - integer :: pos,pos1 - lquot=.false. - lapos=.false. - if(present(quot)) lquot = quot - if(present(apos)) lapos = apos - pos = 1 - pos1 = 1 - do - if(pos>len(from) .or. pos1>len(to)) exit ! The two checks must be separated - if(from(pos:pos)==iotk_eos) exit - select case(from(pos:pos)) - case("&") - if(pos1+4<=len(to)) to(pos1:pos1+4)="&" - pos1=pos1+4 - case("<") - if(pos1+3<=len(to)) to(pos1:pos1+3)="<" - pos1=pos1+3 - case(">") - if(pos1+3<=len(to)) to(pos1:pos1+3)=">" - pos1=pos1+3 - case('"') - if(lquot) then - if(pos1+5<=len(to)) to(pos1:pos1+5)=""" - pos1=pos1+5 - else - to(pos1:pos1) = from(pos:pos) - end if - case("'") - if(lapos) then - if(pos1+5<=len(to)) to(pos1:pos1+5)="'" - pos1=pos1+5 - else - to(pos1:pos1) = from(pos:pos) - end if - case default - to(pos1:pos1) = from(pos:pos) - end select - pos = pos + 1 - pos1 = pos1 + 1 - end do - if(pos1<=len(to)) to(pos1:pos1)=iotk_eos -end subroutine iotk_deescape_x - -function iotk_strtrim_x(str) - use iotk_base - use iotk_str_interf - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_strtrim_x - integer :: lentrim - lentrim = len_trim(str(1:iotk_strlen(str))) - iotk_strtrim_x(1:lentrim) = str(1:lentrim) - if(lentrim=0) then - iotk_strlen_x = pos - else - iotk_strlen_x = len(str) - end if -end function iotk_strlen_x - -function iotk_strpad_x(str) - use iotk_base - use iotk_misc_interf - use iotk_str_interf - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_strpad_x - integer :: strlen - strlen = iotk_strlen(str) - iotk_strpad_x(1:strlen) = str(1:strlen) - if(strlenPROCEDURE=iotk_strcpy -subroutine iotk_strcpy_x(to,from,ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - implicit none -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: to -#else - character(len=*), intent(out) :: to -#endif - character(len=*), intent(in) :: from - integer, intent(out) :: ierr - integer :: i - ierr = 0 - do i=1,min(len(from),len(to)) - if(from(i:i)==iotk_eos) exit - to(i:i)=from(i:i) - end do - if(i>len(to) .and. i<=len(from)) then - if(from(i:i)/=iotk_eos) then - $(ERROR ierr) - return - end if - end if - if(i<=len(to)) to(i:i) = iotk_eos -end subroutine iotk_strcpy_x - ->PROCEDURE=iotk_strcat -subroutine iotk_strcat_x(to,from,ierr) - use iotk_base - use iotk_error_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - character(len=*), intent(inout):: to - character(len=*), intent(in) :: from - integer, intent(out):: ierr - integer :: tolen,fromlen - ierr = 0 - tolen = iotk_strlen(to) - fromlen = iotk_strlen(from) - if(tolen+fromlen>len(to)) then - $(ERROR ierr) - end if - if(ierr/=0) return - to(tolen+1:tolen+fromlen) = from(1:fromlen) - if(tolen+fromlen+1<=len(to)) to(tolen+fromlen+1:tolen+fromlen+1)=iotk_eos -end subroutine iotk_strcat_x - ->PROCEDURE=iotk_strcomp -function iotk_strcomp_x(str1,str2) - use iotk_base - implicit none - logical :: iotk_strcomp_x - character(len=*), intent(in) :: str1,str2 - integer :: i - iotk_strcomp_x = .false. - do i=1,min(len(str1),len(str2)) - if(str1(i:i)/=str2(i:i)) return - if(str1(i:i)==iotk_eos) exit - end do - if(i>len(str1)) then - if(i<=len(str2)) then - if(str2(i:i)/=iotk_eos) return - end if - else if(i>len(str2)) then - if(i<=len(str1)) then - if(str1(i:i)/=iotk_eos) return - end if - end if - iotk_strcomp_x = .true. -end function iotk_strcomp_x - ->PROCEDURE=iotk_str_clean -subroutine iotk_str_clean_x(str) -! transforms all characters which are separators in blanks - use iotk_base - implicit none - character(len=*), intent(inout) :: str - integer :: i - do i = 1 , len(str) - if(str(i:i)==iotk_eos) exit - if(scan(not_separator,str(i:i))==0) str(i:i)=" " - end do -end subroutine iotk_str_clean_x - diff --git a/quantum_espresso/kcp/iotk/src/iotk_str_interf.f90 b/quantum_espresso/kcp/iotk/src/iotk_str_interf.f90 deleted file mode 100644 index fc04100cf..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_str_interf.f90 +++ /dev/null @@ -1,169 +0,0 @@ -# 1 "iotk_str_interf.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_str_interf.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_str_interf.spp" - -module iotk_str_interf -use iotk_base -implicit none -private - -public :: iotk_escape -public :: iotk_deescape -public :: iotk_strcpy -public :: iotk_strcat -public :: iotk_strlen -public :: iotk_strpad -public :: iotk_strscan -public :: iotk_strcomp -public :: iotk_strtrim -public :: iotk_strlen_trim -public :: iotk_toupper -public :: iotk_tolower -public :: iotk_str_clean - -interface iotk_toupper -function iotk_toupper_x(str) - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_toupper_x -end function iotk_toupper_x -end interface - -interface iotk_tolower -function iotk_tolower_x(str) - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_tolower_x -end function -end interface - -interface iotk_escape -subroutine iotk_escape_x(to,from) - implicit none - character(len=*), intent(in) :: from -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: to -#else - character(len=*), intent(out) :: to -#endif -end subroutine -end interface - -interface iotk_deescape -subroutine iotk_deescape_x(to,from,quot,apos) - implicit none - character(len=*), intent(in) :: from -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: to -#else - character(len=*), intent(out) :: to -#endif - logical, optional, intent(in) :: quot,apos -end subroutine iotk_deescape_x -end interface - -interface iotk_strscan -function iotk_strscan_x(string,set,back) - implicit none - character(len=*), intent(in) :: string - character(len=*), intent(in) :: set - logical, optional, intent(in) :: back - integer :: iotk_strscan_x -end function iotk_strscan_x -end interface - - -interface iotk_strtrim -function iotk_strtrim_x(str) - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_strtrim_x -end function iotk_strtrim_x -end interface - -interface iotk_strlen_trim -function iotk_strlen_trim_x(str) - implicit none - character(len=*), intent(in) :: str - integer :: iotk_strlen_trim_x -end function iotk_strlen_trim_x -end interface - -interface iotk_strlen -function iotk_strlen_x(str) - implicit none - character(len=*), intent(in) :: str - integer :: iotk_strlen_x -end function iotk_strlen_x -end interface - -interface iotk_strpad -function iotk_strpad_x(str) - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_strpad_x -end function iotk_strpad_x -end interface - -interface iotk_strcpy -subroutine iotk_strcpy_x(to,from,ierr) - implicit none -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: to -#else - character(len=*), intent(out) :: to -#endif - character(len=*), intent(in) :: from - integer, intent(out) :: ierr -end subroutine iotk_strcpy_x -end interface - -interface iotk_strcat -subroutine iotk_strcat_x(to,from,ierr) - implicit none - character(len=*), intent(inout):: to - character(len=*), intent(in) :: from - integer, intent(out):: ierr -end subroutine iotk_strcat_x -end interface - -interface iotk_strcomp -function iotk_strcomp_x(str1,str2) - implicit none - logical :: iotk_strcomp_x - character(len=*), intent(in) :: str1,str2 -end function iotk_strcomp_x -end interface - -interface iotk_str_clean -subroutine iotk_str_clean_x(str) -! transforms all characters which are separators in blanks - implicit none - character(len=*), intent(inout) :: str -end subroutine iotk_str_clean_x -end interface - -end module iotk_str_interf diff --git a/quantum_espresso/kcp/iotk/src/iotk_str_interf.spp b/quantum_espresso/kcp/iotk/src/iotk_str_interf.spp deleted file mode 100644 index 0c80671ed..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_str_interf.spp +++ /dev/null @@ -1,173 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -module iotk_str_interf -use iotk_base -implicit none -private - -public :: iotk_escape -public :: iotk_deescape -public :: iotk_strcpy -public :: iotk_strcat -public :: iotk_strlen -public :: iotk_strpad -public :: iotk_strscan -public :: iotk_strcomp -public :: iotk_strtrim -public :: iotk_strlen_trim -public :: iotk_toupper -public :: iotk_tolower -public :: iotk_str_clean - -interface iotk_toupper -function iotk_toupper_x(str) - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_toupper_x -end function iotk_toupper_x -end interface - -interface iotk_tolower -function iotk_tolower_x(str) - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_tolower_x -end function -end interface - -interface iotk_escape -subroutine iotk_escape_x(to,from) - implicit none - character(len=*), intent(in) :: from -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: to -#else - character(len=*), intent(out) :: to -#endif -end subroutine -end interface - -interface iotk_deescape -subroutine iotk_deescape_x(to,from,quot,apos) - implicit none - character(len=*), intent(in) :: from -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: to -#else - character(len=*), intent(out) :: to -#endif - logical, optional, intent(in) :: quot,apos -end subroutine iotk_deescape_x -end interface - -interface iotk_strscan -function iotk_strscan_x(string,set,back) - implicit none - character(len=*), intent(in) :: string - character(len=*), intent(in) :: set - logical, optional, intent(in) :: back - integer :: iotk_strscan_x -end function iotk_strscan_x -end interface - - -interface iotk_strtrim -function iotk_strtrim_x(str) - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_strtrim_x -end function iotk_strtrim_x -end interface - -interface iotk_strlen_trim -function iotk_strlen_trim_x(str) - implicit none - character(len=*), intent(in) :: str - integer :: iotk_strlen_trim_x -end function iotk_strlen_trim_x -end interface - -interface iotk_strlen -function iotk_strlen_x(str) - implicit none - character(len=*), intent(in) :: str - integer :: iotk_strlen_x -end function iotk_strlen_x -end interface - -interface iotk_strpad -function iotk_strpad_x(str) - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: iotk_strpad_x -end function iotk_strpad_x -end interface - -interface iotk_strcpy -subroutine iotk_strcpy_x(to,from,ierr) - implicit none -#ifdef __IOTK_WORKAROUND6 - character(len=*) :: to -#else - character(len=*), intent(out) :: to -#endif - character(len=*), intent(in) :: from - integer, intent(out) :: ierr -end subroutine iotk_strcpy_x -end interface - -interface iotk_strcat -subroutine iotk_strcat_x(to,from,ierr) - implicit none - character(len=*), intent(inout):: to - character(len=*), intent(in) :: from - integer, intent(out):: ierr -end subroutine iotk_strcat_x -end interface - -interface iotk_strcomp -function iotk_strcomp_x(str1,str2) - implicit none - logical :: iotk_strcomp_x - character(len=*), intent(in) :: str1,str2 -end function iotk_strcomp_x -end interface - -interface iotk_str_clean -subroutine iotk_str_clean_x(str) -! transforms all characters which are separators in blanks - implicit none - character(len=*), intent(inout) :: str -end subroutine iotk_str_clean_x -end interface - -end module iotk_str_interf - diff --git a/quantum_espresso/kcp/iotk/src/iotk_stream.f90 b/quantum_espresso/kcp/iotk/src/iotk_stream.f90 deleted file mode 100644 index 57b9d9013..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_stream.f90 +++ /dev/null @@ -1,2347 +0,0 @@ -# 1 "iotk_stream.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_stream.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_stream.spp" - -# 33 "iotk_stream.spp" - -subroutine iotk_stream_read_x(unit,header,setpos,getpos,ierr) - use iotk_base - use iotk_stream_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - integer, optional, intent(out) :: ierr - integer :: aa(1) - call iotk_stream_read(unit,header,aa,setpos,getpos,.true.,ierr) -end subroutine iotk_stream_read_x - - -# 51 "iotk_stream.spp" - -#ifdef __IOTK_LOGICAL1 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_LOGICAL1(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - LOGICAL(kind=iotk_LOGICAL1), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_LOGICAL1 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_LOGICAL2 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_LOGICAL2(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - LOGICAL(kind=iotk_LOGICAL2), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_LOGICAL2 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_LOGICAL3 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_LOGICAL3(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - LOGICAL(kind=iotk_LOGICAL3), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_LOGICAL3 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_LOGICAL4 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_LOGICAL4(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - LOGICAL(kind=iotk_LOGICAL4), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_LOGICAL4 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_INTEGER1 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_INTEGER1(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - INTEGER(kind=iotk_INTEGER1), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_INTEGER1 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_INTEGER2 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_INTEGER2(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - INTEGER(kind=iotk_INTEGER2), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_INTEGER2 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_INTEGER3 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_INTEGER3(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - INTEGER(kind=iotk_INTEGER3), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_INTEGER3 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_INTEGER4 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_INTEGER4(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - INTEGER(kind=iotk_INTEGER4), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_INTEGER4 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_REAL1 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_REAL1(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - REAL(kind=iotk_REAL1), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_REAL1 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_REAL2 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_REAL2(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - REAL(kind=iotk_REAL2), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_REAL2 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_REAL3 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_REAL3(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - REAL(kind=iotk_REAL3), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_REAL3 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_REAL4 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_REAL4(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - REAL(kind=iotk_REAL4), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_REAL4 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_COMPLEX1 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_COMPLEX1(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - COMPLEX(kind=iotk_COMPLEX1), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_COMPLEX1 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_COMPLEX2 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_COMPLEX2(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - COMPLEX(kind=iotk_COMPLEX2), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_COMPLEX2 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_COMPLEX3 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_COMPLEX3(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - COMPLEX(kind=iotk_COMPLEX3), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_COMPLEX3 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_COMPLEX4 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_COMPLEX4(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - COMPLEX(kind=iotk_COMPLEX4), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_COMPLEX4 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_CHARACTER1 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_CHARACTER1(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - CHARACTER(kind=iotk_CHARACTER1,len=*), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_CHARACTER1 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_CHARACTER2 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_CHARACTER2(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - CHARACTER(kind=iotk_CHARACTER2,len=*), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_CHARACTER2 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_CHARACTER3 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_CHARACTER3(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - CHARACTER(kind=iotk_CHARACTER3,len=*), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_CHARACTER3 -#endif -# 51 "iotk_stream.spp" - -#ifdef __IOTK_CHARACTER4 -# 54 "iotk_stream.spp" -subroutine iotk_stream_read_CHARACTER4(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - CHARACTER(kind=iotk_CHARACTER4,len=*), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 80 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 80 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 87 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 87 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 92 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 92 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 98 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 98 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 104 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 104 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if(rec1/=rec) then - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 108 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') - goto 1 - end if -#else - header = 0 - getpos = 0 - call iotk_error_issue(ierrl,"iotk_stream_read",__FILE__,__LINE__) -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 114 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_CHARACTER4 -#endif -# 126 "iotk_stream.spp" - -# 128 "iotk_stream.spp" -subroutine iotk_stream_backspace_x(unit,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec - integer :: pos,iostat -#endif - integer :: ierrl - ierrl=0 -#ifdef __IOTK_STREAMS - inquire(unit,pos=pos,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_backspace",__FILE__,__LINE__) -# 143 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 143 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 143 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,pos=pos-iotk_record_length,iostat=iostat) rec - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_backspace",__FILE__,__LINE__) -# 148 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 148 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 148 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - read(unit,pos=pos-2*iotk_record_length-rec,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_stream_backspace",__FILE__,__LINE__) -# 153 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 153 "iotk_stream.spp" -call iotk_error_msg(ierrl,'""') -# 153 "iotk_stream.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if -#else - call iotk_error_issue(ierrl,"iotk_stream_backspace",__FILE__,__LINE__) -# 157 "iotk_stream.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.1 ") -# 157 "iotk_stream.spp" -call iotk_error_msg(ierrl,'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_backspace_x - diff --git a/quantum_espresso/kcp/iotk/src/iotk_stream.spp b/quantum_espresso/kcp/iotk/src/iotk_stream.spp deleted file mode 100644 index b964adbbf..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_stream.spp +++ /dev/null @@ -1,167 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -> REVISION='$Revision: 1.1.1.1 $' -> REVISION="${REVISION//${dol}/}" - -subroutine iotk_stream_read_x(unit,header,setpos,getpos,ierr) - use iotk_base - use iotk_stream_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - integer, optional, intent(out) :: ierr - integer :: aa(1) - call iotk_stream_read(unit,header,aa,setpos,getpos,.true.,ierr) -end subroutine iotk_stream_read_x - - -> for type in $types ; do -> eval "LENSTAR=\$LENSTAR_$type" -> for kind in $kinds ; do - -#ifdef __IOTK_$type$kind ->PROCEDURE=iotk_stream_read -subroutine iotk_stream_read_${type}${kind}(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - ${type}(kind=iotk_$type$kind$LENSTAR), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec,rec1 - integer :: iostat,lpos -#endif - logical :: lnoval - integer :: ierrl - lnoval = .false. - if(present(noval)) lnoval = noval - ierrl = 0 -#ifdef __IOTK_STREAMS - if(present(setpos)) then - lpos=setpos - else - inquire(unit,pos=lpos,iostat=iostat) - if(iostat/=0) then - $(ERROR ierrl "" iostat) - goto 1 - end if - end if - if(present(getpos)) getpos = lpos - read(unit,pos=lpos,iostat=iostat) rec - if(iostat/=0) then - $(ERROR ierrl "" iostat) - goto 1 - end if - read(unit,iostat=iostat) header - if(iostat/=0) then - $(ERROR ierrl "" iostat) - goto 1 - end if - if(.not.lnoval) then - read(unit,iostat=iostat) val - if(iostat/=0) then - $(ERROR ierrl "" iostat) - goto 1 - end if - end if - read(unit,pos=lpos+iotk_record_length+rec,iostat=iostat) rec1 - if(iostat/=0) then - $(ERROR ierrl "" iostat) - goto 1 - end if - if(rec1/=rec) then - $(ERROR ierrl "") - goto 1 - end if -#else - header = 0 - getpos = 0 - $(ERROR ierrl 'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_read_${type}${kind} -#endif -> done -> done - ->PROCEDURE=iotk_stream_backspace -subroutine iotk_stream_backspace_x(unit,ierr) - use iotk_base - use iotk_error_interf - implicit none - integer, intent(in) :: unit - integer, optional, intent(out) :: ierr -#ifdef __IOTK_STREAMS - integer(iotk_record_kind) :: rec - integer :: pos,iostat -#endif - integer :: ierrl - ierrl=0 -#ifdef __IOTK_STREAMS - inquire(unit,pos=pos,iostat=iostat) - if(iostat/=0) then - $(ERROR ierrl "" iostat) - goto 1 - end if - read(unit,pos=pos-iotk_record_length,iostat=iostat) rec - if(iostat/=0) then - $(ERROR ierrl "" iostat) - goto 1 - end if - read(unit,pos=pos-2*iotk_record_length-rec,iostat=iostat) - if(iostat/=0) then - $(ERROR ierrl "" iostat) - goto 1 - end if -#else - $(ERROR ierrl 'Streams are not implemented') -#endif -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_stream_backspace_x - - diff --git a/quantum_espresso/kcp/iotk/src/iotk_stream_interf.f90 b/quantum_espresso/kcp/iotk/src/iotk_stream_interf.f90 deleted file mode 100644 index d99f47250..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_stream_interf.f90 +++ /dev/null @@ -1,339 +0,0 @@ -# 1 "iotk_stream_interf.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_stream_interf.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_stream_interf.spp" - -# 33 "iotk_stream_interf.spp" - - -module iotk_stream_interf -implicit none -private - -public :: iotk_stream_read -public :: iotk_stream_backspace - -interface iotk_stream_read - subroutine iotk_stream_read_x(unit,header,setpos,getpos,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_x -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_LOGICAL1 - subroutine iotk_stream_read_LOGICAL1(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - LOGICAL(kind=iotk_LOGICAL1), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_LOGICAL1 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_LOGICAL2 - subroutine iotk_stream_read_LOGICAL2(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - LOGICAL(kind=iotk_LOGICAL2), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_LOGICAL2 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_LOGICAL3 - subroutine iotk_stream_read_LOGICAL3(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - LOGICAL(kind=iotk_LOGICAL3), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_LOGICAL3 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_LOGICAL4 - subroutine iotk_stream_read_LOGICAL4(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - LOGICAL(kind=iotk_LOGICAL4), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_LOGICAL4 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_INTEGER1 - subroutine iotk_stream_read_INTEGER1(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - INTEGER(kind=iotk_INTEGER1), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_INTEGER1 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_INTEGER2 - subroutine iotk_stream_read_INTEGER2(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - INTEGER(kind=iotk_INTEGER2), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_INTEGER2 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_INTEGER3 - subroutine iotk_stream_read_INTEGER3(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - INTEGER(kind=iotk_INTEGER3), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_INTEGER3 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_INTEGER4 - subroutine iotk_stream_read_INTEGER4(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - INTEGER(kind=iotk_INTEGER4), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_INTEGER4 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_REAL1 - subroutine iotk_stream_read_REAL1(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - REAL(kind=iotk_REAL1), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_REAL1 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_REAL2 - subroutine iotk_stream_read_REAL2(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - REAL(kind=iotk_REAL2), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_REAL2 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_REAL3 - subroutine iotk_stream_read_REAL3(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - REAL(kind=iotk_REAL3), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_REAL3 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_REAL4 - subroutine iotk_stream_read_REAL4(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - REAL(kind=iotk_REAL4), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_REAL4 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_COMPLEX1 - subroutine iotk_stream_read_COMPLEX1(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - COMPLEX(kind=iotk_COMPLEX1), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_COMPLEX1 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_COMPLEX2 - subroutine iotk_stream_read_COMPLEX2(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - COMPLEX(kind=iotk_COMPLEX2), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_COMPLEX2 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_COMPLEX3 - subroutine iotk_stream_read_COMPLEX3(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - COMPLEX(kind=iotk_COMPLEX3), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_COMPLEX3 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_COMPLEX4 - subroutine iotk_stream_read_COMPLEX4(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - COMPLEX(kind=iotk_COMPLEX4), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_COMPLEX4 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_CHARACTER1 - subroutine iotk_stream_read_CHARACTER1(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - CHARACTER(kind=iotk_CHARACTER1,len=*), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_CHARACTER1 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_CHARACTER2 - subroutine iotk_stream_read_CHARACTER2(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - CHARACTER(kind=iotk_CHARACTER2,len=*), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_CHARACTER2 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_CHARACTER3 - subroutine iotk_stream_read_CHARACTER3(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - CHARACTER(kind=iotk_CHARACTER3,len=*), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_CHARACTER3 -#endif -# 55 "iotk_stream_interf.spp" -#ifdef __IOTK_CHARACTER4 - subroutine iotk_stream_read_CHARACTER4(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - CHARACTER(kind=iotk_CHARACTER4,len=*), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_CHARACTER4 -#endif -# 70 "iotk_stream_interf.spp" -end interface - -interface iotk_stream_backspace - subroutine iotk_stream_backspace_x(unit,ierr) - implicit none - integer, intent(in) :: unit - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_backspace_x -end interface - -end module iotk_stream_interf diff --git a/quantum_espresso/kcp/iotk/src/iotk_stream_interf.spp b/quantum_espresso/kcp/iotk/src/iotk_stream_interf.spp deleted file mode 100644 index 7d4c9356b..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_stream_interf.spp +++ /dev/null @@ -1,81 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -> REVISION='$Revision: 1.1.1.1 $' -> REVISION="${REVISION//${dol}/}" - - -module iotk_stream_interf -implicit none -private - -public :: iotk_stream_read -public :: iotk_stream_backspace - -interface iotk_stream_read - subroutine iotk_stream_read_x(unit,header,setpos,getpos,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_x -> for type in $types ; do -> eval "LENSTAR=\$LENSTAR_$type" -> for kind in $kinds ; do -#ifdef __IOTK_$type$kind - subroutine iotk_stream_read_${type}${kind}(unit,header,val,setpos,getpos,noval,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer(iotk_header_kind), intent(out) :: header - ${type}(kind=iotk_$type$kind$LENSTAR), intent(out) :: val(:) - integer, optional, intent(in) :: setpos - integer, optional, intent(out) :: getpos - logical, optional, intent(in) :: noval - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_read_${type}${kind} -#endif -> done -> done -end interface - -interface iotk_stream_backspace - subroutine iotk_stream_backspace_x(unit,ierr) - implicit none - integer, intent(in) :: unit - integer, optional, intent(out) :: ierr - end subroutine iotk_stream_backspace_x -end interface - -end module iotk_stream_interf - diff --git a/quantum_espresso/kcp/iotk/src/iotk_tool.f90 b/quantum_espresso/kcp/iotk/src/iotk_tool.f90 deleted file mode 100644 index 47c3b8325..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_tool.f90 +++ /dev/null @@ -1,2517 +0,0 @@ -# 1 "iotk_tool.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_tool.spp" -#include "iotk_auxmacros.h" -# 33 "iotk_tool.spp" - -# 36 "iotk_tool.spp" - -# 38 "iotk_tool.spp" -subroutine iotk_tool_x(args) - use iotk_base - use iotk_error_interf - use iotk_str_interf - use iotk_tool_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: args(:) - integer :: iarg,ierrl - character(iotk_linlenx) :: arg - logical :: print_help_options,print_help_commands,print_help_basic,print_copyright,print_version - logical :: check - integer :: linlen,indent,maxindent - ierrl = 0 - iarg = 1 - - print_version = .false. - print_help_options = .false. - print_help_commands = .false. - print_help_basic = .false. - print_copyright = .false. - - if(size(args)==0) then - print_help_basic = .true. - end if - - do iarg = 1 , size(args) - arg = args(iarg) - if(iotk_strcomp(arg(1:1),"-")) then -! options here - if(iotk_strcomp(arg,"--help") .or. iotk_strcomp(arg,"-H")) then - print_help_basic = .true. - exit - else if(iotk_strcomp(arg,"--version")) then - print_version = .true. - exit - else if(iotk_strcomp(arg,"--do-nothing")) then - exit - else if(iotk_strcomp(arg,"--copyright")) then - print_copyright = .true. - exit - else if(iotk_strcomp(arg,"--help-options")) then - print_help_options = .true. - exit - else if(iotk_strcomp(arg,"--help-commands")) then - print_help_commands = .true. - exit - else if(arg(1:13)=="--set-linlen=") then - call iotk_atoi(linlen,arg(14:iotk_strlen(arg)),check=check) - if(.not.check) then - call iotk_error_issue(ierrl,"iotk_tool",__FILE__,__LINE__) -# 89 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 89 "iotk_tool.spp" -call iotk_error_msg(ierrl,'') - goto 1 - end if - call iotk_set(linlen=linlen,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_tool",__FILE__,__LINE__) -# 94 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 94 "iotk_tool.spp" -call iotk_error_msg(ierrl,'') - goto 1 - end if - else if(arg(1:13)=="--set-indent=") then - call iotk_atoi(indent,arg(14:iotk_strlen(arg)),check=check) - if(.not.check) then - call iotk_error_issue(ierrl,"iotk_tool",__FILE__,__LINE__) -# 100 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 100 "iotk_tool.spp" -call iotk_error_msg(ierrl,'') - goto 1 - end if - call iotk_set(indent=indent,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_tool",__FILE__,__LINE__) -# 105 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 105 "iotk_tool.spp" -call iotk_error_msg(ierrl,'') - goto 1 - end if - else if(arg(1:16)=="--set-maxindent=") then - call iotk_atoi(maxindent,arg(17:iotk_strlen(arg)),check=check) - if(.not.check) then - call iotk_error_issue(ierrl,"iotk_tool",__FILE__,__LINE__) -# 111 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 111 "iotk_tool.spp" -call iotk_error_msg(ierrl,'') - goto 1 - end if - call iotk_set(maxindent=maxindent,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_tool",__FILE__,__LINE__) -# 116 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 116 "iotk_tool.spp" -call iotk_error_msg(ierrl,'') - goto 1 - end if - else - write(iotk_error_unit,"(a)") "unrecognized option `"//arg(1:iotk_strlen(arg))//"'" - print_help_basic = .true. - exit - end if - else -! commands here - if(iotk_strcomp(arg,"convert")) then - call iotk_tool_convert(args(iarg+1:),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_tool",__FILE__,__LINE__) -# 129 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 129 "iotk_tool.spp" -call iotk_error_msg(ierrl,'Error converting file') - goto 1 - end if - else if(iotk_strcomp(arg,"dump")) then - call iotk_tool_dump(args(iarg+1:),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_tool",__FILE__,__LINE__) -# 135 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 135 "iotk_tool.spp" -call iotk_error_msg(ierrl,'Error dumping file') - goto 1 - end if - else if(iotk_strcomp(arg,"info")) then - call iotk_tool_info(args(iarg+1:),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_tool",__FILE__,__LINE__) -# 141 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 141 "iotk_tool.spp" -call iotk_error_msg(ierrl,'Error') - goto 1 - end if - else if(iotk_strcomp(arg,"man")) then - call iotk_tool_man(args(iarg+1:),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_tool",__FILE__,__LINE__) -# 147 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 147 "iotk_tool.spp" -call iotk_error_msg(ierrl,'Error') - goto 1 - end if - else - write(iotk_error_unit,"(a)") "Unknown command: `"//arg(1:iotk_strlen(arg))//"'" - write(iotk_error_unit,"(a)") "" - print_help_commands = .true. - end if - exit - end if - end do - - if(print_help_basic) then - write(iotk_error_unit,"(a)") "Usage: iotk [iotk-options] command [command-options-and-arguments]" - write(iotk_error_unit,"(a)") " where iotk-options are ..." - write(iotk_error_unit,"(a)") " (specify --help-options for a list of options)" - write(iotk_error_unit,"(a)") " where command is convert, dump, etc." - write(iotk_error_unit,"(a)") " (specify --help-commands for a list of commands)" - write(iotk_error_unit,"(a)") " where command-options-and-arguments depend on the specific command" - write(iotk_error_unit,"(a)") " (specify a command followed by --help for command-specific help)" - write(iotk_error_unit,"(a)") " Specify --help to receive this message" - end if - - if(print_help_commands) then - write(iotk_error_unit,"(a)") "IOTK commands are:" - write(iotk_error_unit,"(a)") " convert to convert a file" - write(iotk_error_unit,"(a)") " dump to dump a file" - write(iotk_error_unit,"(a)") " info to obtain informations about how iotk was compiled" - write(iotk_error_unit,"(a)") " man to print manual pages" - end if - - if(print_help_options) then - write(iotk_error_unit,"(a)") "IOTK options are:" - write(iotk_error_unit,"(a)") " --copyright print copyright informations" - write(iotk_error_unit,"(a)") " --version print version informations" - write(iotk_error_unit,"(a)") " --help print a short, generic help" - write(iotk_error_unit,"(a)") " --help-options print a list of options (this list)" - write(iotk_error_unit,"(a)") " --help-commands print a list of commands" - write(iotk_error_unit,"(a)") " --set-linlen=N to set the length of an output line" - write(iotk_error_unit,"(a)") " --set-indent=N to set the number of spaces for an indent level" - write(iotk_error_unit,"(a)") " --set-maxindent=N to set the maximum number of spaces when indenting" - end if - - if(print_version) then - write(*,"(a)") "Input/Output Tool Kit (IOTK) version: "//trim(iotk_version) - end if - - if(print_copyright) then - write(iotk_error_unit,"(a)") "Input/Output Tool Kit (IOTK)" - write(iotk_error_unit,"(a)") "Copyright (C) 2004-2006 Giovanni Bussi" - write(iotk_error_unit,"(a)") "" - write(iotk_error_unit,"(a)") "This library is free software; you can redistribute it and/or" - write(iotk_error_unit,"(a)") "modify it under the terms of the GNU Lesser General Public" - write(iotk_error_unit,"(a)") "License as published by the Free Software Foundation; either" - write(iotk_error_unit,"(a)") "version 2.1 of the License, or (at your option) any later version." - write(iotk_error_unit,"(a)") "" - write(iotk_error_unit,"(a)") "This library is distributed in the hope that it will be useful," - write(iotk_error_unit,"(a)") "but WITHOUT ANY WARRANTY; without even the implied warranty of" - write(iotk_error_unit,"(a)") "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU" - write(iotk_error_unit,"(a)") "Lesser General Public License for more details." - write(iotk_error_unit,"(a)") "" - write(iotk_error_unit,"(a)") "You should have received a copy of the GNU Lesser General Public" - write(iotk_error_unit,"(a)") "License along with this library; if not, write to the Free Software" - write(iotk_error_unit,"(a)") "Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA" - end if - -1 continue - if(ierrl/=0) call iotk_error_handler(ierrl) - -end subroutine iotk_tool_x - -# 219 "iotk_tool.spp" -subroutine iotk_tool_convert_x(args,ierr) - use iotk_base - use iotk_error_interf - use iotk_str_interf - use iotk_misc_interf - use iotk_files_interf - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr - integer :: iarg,ierrl,outfile_len - character(len=iotk_fillenx) :: infile,outfile - logical :: binary - character(len=iotk_attlenx) :: attr - character(len=iotk_taglenx) :: root - integer :: maxsize - logical :: autofmt - infile="" - outfile="" - binary=.true. - maxsize=-1 - ierrl = 0 - autofmt = .true. - do iarg = 1 , size(args) - if(iotk_strcomp(args(iarg)(1:1),"-")) then - if(iotk_strcomp(args(iarg),"--help")) then - write(iotk_error_unit,"(a)") "Usage: iotk convert [OPTIONS] infile outfile" - write(iotk_error_unit,"(a)") "Options:" - write(iotk_error_unit,"(a)") " --mode=X set the output file to be X, where X can be" - write(iotk_error_unit,"(a)") " 'textual', 'binary' or 'auto'." - write(iotk_error_unit,"(a)") " -b equivalent to --mode=binary" - write(iotk_error_unit,"(a)") " -t equivalent to --mode=textual" - write(iotk_error_unit,"(a)") "This command converts a iotk data file into another iotk data file." - write(iotk_error_unit,"(a)") "The infile can be textual or binary, and its format is automatically detected." - write(iotk_error_unit,"(a)") "The outfile can be textual or binary depending on the --mode option." - write(iotk_error_unit,"(a)") "If the mode is 'auto', the decision is driven by outfile extension," - write(iotk_error_unit,"(a)") "i.e. a file matching *.txt of *.xml will be considered textual, otherwise binary" - goto 1 - else if(iotk_strcomp(args(iarg),"-b") .or. iotk_strcomp(args(iarg),"--mode=binary")) then - binary = .true. - autofmt = .false. - else if(iotk_strcomp(args(iarg),"-t") .or. iotk_strcomp(args(iarg),"--mode=textual")) then - binary = .false. - autofmt = .false. - else if(iotk_strcomp(args(iarg),"--mode=auto")) then - binary = .true. - autofmt = .true. - else - call iotk_error_issue(ierrl,"iotk_tool_convert",__FILE__,__LINE__) -# 266 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 266 "iotk_tool.spp" -call iotk_error_msg(ierrl,'Unknown option') - goto 1 - end if - else - if(infile=="") then - call iotk_strcpy(infile,args(iarg),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_tool_convert",__FILE__,__LINE__) -# 273 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 273 "iotk_tool.spp" -call iotk_error_msg(ierrl,'File name too long') - goto 1 - end if - else if(outfile=="") then - call iotk_strcpy(outfile,args(iarg),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_tool_convert",__FILE__,__LINE__) -# 279 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 279 "iotk_tool.spp" -call iotk_error_msg(ierrl,'File name too long') - goto 1 - end if - else - call iotk_error_issue(ierrl,"iotk_tool_convert",__FILE__,__LINE__) -# 283 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 283 "iotk_tool.spp" -call iotk_error_msg(ierrl,'Three files. What do you mean?') - goto 1 - end if - end if - end do - if(outfile=="") then - call iotk_error_issue(ierrl,"iotk_tool_convert",__FILE__,__LINE__) -# 289 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 289 "iotk_tool.spp" -call iotk_error_msg(ierrl,'Convert: bad usage') - goto 1 - end if - - outfile_len = iotk_strlen(outfile) - if(outfile_len>3) then - select case(outfile(outfile_len-3:outfile_len)) - case(".xml") - binary = .false. - case(".txt") - binary = .false. - case default - binary = .true. - end select - end if - - call iotk_open_read(60,infile,root=root,attr=attr) - call iotk_open_write(61,outfile,binary=binary,root=root,attr=attr) - call iotk_copy_tag(60,61,maxsize=-1) - call iotk_close_write(61) - call iotk_close_read(60) - -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_tool_convert_x - - -# 321 "iotk_tool.spp" -subroutine iotk_tool_dump_x(args,ierr) - use iotk_base - use iotk_error_interf - use iotk_str_interf - use iotk_misc_interf - use iotk_files_interf - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr - integer :: iarg,ierrl - character(len=iotk_fillenx) :: infile - character(len=iotk_attlenx) :: attr - character(len=iotk_taglenx) :: root - integer :: maxsize - infile="" - maxsize=-1 - ierrl = 0 - do iarg = 1 , size(args) - if(iotk_strcomp(args(iarg)(1:1),"-")) then - if(iotk_strcomp(args(iarg),"--help")) then - write(iotk_error_unit,"(a)") "Usage: iotk dump file" - write(iotk_error_unit,"(a)") "This command dumps a iotk data file on standard out." - write(iotk_error_unit,"(a)") "The file can be textual or binary, and its format is automatically detected." - goto 1 - else - call iotk_error_issue(ierrl,"iotk_tool_dump",__FILE__,__LINE__) -# 346 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 346 "iotk_tool.spp" -call iotk_error_msg(ierrl,'Unknown option') - goto 1 - end if - else - if(infile=="") then - call iotk_strcpy(infile,args(iarg),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_tool_dump",__FILE__,__LINE__) -# 353 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 353 "iotk_tool.spp" -call iotk_error_msg(ierrl,'File name too long') - goto 1 - end if - else - call iotk_error_issue(ierrl,"iotk_tool_dump",__FILE__,__LINE__) -# 357 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 357 "iotk_tool.spp" -call iotk_error_msg(ierrl,'Two files. What do you mean?') - goto 1 - end if - end if - end do - - call iotk_open_read(60, trim(infile),root=root,attr=attr) - call iotk_open_write(iotk_output_unit,root=root,attr=attr) - call iotk_copy_tag(60,iotk_output_unit,maxsize=-1) - call iotk_close_write(iotk_output_unit) - call iotk_close_read(60) - -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_tool_dump_x - -subroutine iotk_tool_info_x(args,ierr) - use iotk_base - use iotk_misc_interf - use iotk_xtox_interf - use iotk_error_interf - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr - integer :: ierrl - ierrl = 0 - write(*,"(a)") "IOTK (Input/Output Tool Kit) version: "//trim(iotk_version) - write(*,"(a)") "Limits:" - write(*,"(a)") " maximum rank (soft limit): "//trim(iotk_itoa(iotk_maxrank)) - write(*,"(a)") " maximum rank (hard limit): "//trim(iotk_itoa(iotk_maxrank_hard)) - write(*,"(a)") "Special kinds:" - write(*,"(a)") " headers in binary files are integer(kind="//trim(iotk_itoa(iotk_header_kind))//")" - write(*,"(a)") " default integers are integer(kind="//trim(iotk_itoa(iotk_integer_defkind))//")" - write(*,"(a)") " default logicals are logical(kind="//trim(iotk_itoa(iotk_logical_defkind))//")" - write(*,"(a)") " default characters are character(kind="//trim(iotk_itoa(iotk_character_defkind))//")" - write(*,"(a)") "Kinds configured for i/o operations:" -# 398 "iotk_tool.spp" -#ifdef __IOTK_LOGICAL1 - write(*,"(a)") " logical(kind="//trim(iotk_itoa(iotk_logical1))//")" -#endif -# 398 "iotk_tool.spp" -#ifdef __IOTK_LOGICAL2 - write(*,"(a)") " logical(kind="//trim(iotk_itoa(iotk_logical2))//")" -#endif -# 398 "iotk_tool.spp" -#ifdef __IOTK_LOGICAL3 - write(*,"(a)") " logical(kind="//trim(iotk_itoa(iotk_logical3))//")" -#endif -# 398 "iotk_tool.spp" -#ifdef __IOTK_LOGICAL4 - write(*,"(a)") " logical(kind="//trim(iotk_itoa(iotk_logical4))//")" -#endif -# 403 "iotk_tool.spp" -#ifdef __IOTK_INTEGER1 - write(*,"(a)") " integer(kind="//trim(iotk_itoa(iotk_integer1))//")" -#endif -# 403 "iotk_tool.spp" -#ifdef __IOTK_INTEGER2 - write(*,"(a)") " integer(kind="//trim(iotk_itoa(iotk_integer2))//")" -#endif -# 403 "iotk_tool.spp" -#ifdef __IOTK_INTEGER3 - write(*,"(a)") " integer(kind="//trim(iotk_itoa(iotk_integer3))//")" -#endif -# 403 "iotk_tool.spp" -#ifdef __IOTK_INTEGER4 - write(*,"(a)") " integer(kind="//trim(iotk_itoa(iotk_integer4))//")" -#endif -# 408 "iotk_tool.spp" -#ifdef __IOTK_REAL1 - write(*,"(a)") " real(kind="//trim(iotk_itoa(iotk_real1))//")" -#endif -# 408 "iotk_tool.spp" -#ifdef __IOTK_REAL2 - write(*,"(a)") " real(kind="//trim(iotk_itoa(iotk_real2))//")" -#endif -# 408 "iotk_tool.spp" -#ifdef __IOTK_REAL3 - write(*,"(a)") " real(kind="//trim(iotk_itoa(iotk_real3))//")" -#endif -# 408 "iotk_tool.spp" -#ifdef __IOTK_REAL4 - write(*,"(a)") " real(kind="//trim(iotk_itoa(iotk_real4))//")" -#endif -# 413 "iotk_tool.spp" -#ifdef __IOTK_REAL1 - write(*,"(a)") " complex(kind="//trim(iotk_itoa(iotk_real1))//")" -#endif -# 413 "iotk_tool.spp" -#ifdef __IOTK_REAL2 - write(*,"(a)") " complex(kind="//trim(iotk_itoa(iotk_real2))//")" -#endif -# 413 "iotk_tool.spp" -#ifdef __IOTK_REAL3 - write(*,"(a)") " complex(kind="//trim(iotk_itoa(iotk_real3))//")" -#endif -# 413 "iotk_tool.spp" -#ifdef __IOTK_REAL4 - write(*,"(a)") " complex(kind="//trim(iotk_itoa(iotk_real4))//")" -#endif -# 417 "iotk_tool.spp" - write(*,"(a)") " character(kind="//trim(iotk_itoa(iotk_character1))//")" - -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_tool_info_x - -subroutine iotk_tool_man_x(args,ierr) - use iotk_base - use iotk_misc_interf - use iotk_xtox_interf - use iotk_error_interf - use iotk_str_interf - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr - character(len=iotk_linlenx) :: keyword - integer :: ierrl,iarg - logical :: printme,printlist - - ierrl = 0 - printme = .false. - printlist = .false. - keyword(1:1) = iotk_eos - - do iarg = 1 , size(args) - if(iotk_strcomp(args(iarg)(1:1),"-")) then - if(iotk_strcomp(args(iarg),"--help")) then - write(iotk_error_unit,"(a)") "Usage: iotk man [keyword]" - write(iotk_error_unit,"(a)") "This command prints on stdout the page of the built-in manual associated with the keyword." - write(iotk_error_unit,"(a)") "If the keyword is not given a list of all the available keywords will be printed." - goto 1 - else - call iotk_error_issue(ierrl,"iotk_tool_dump",__FILE__,__LINE__) -# 453 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 453 "iotk_tool.spp" -call iotk_error_msg(ierrl,'Unknown option') - goto 1 - end if - else - if(iotk_strcomp(keyword,"")) then - call iotk_strcpy(keyword,args(iarg),ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_tool_dump",__FILE__,__LINE__) -# 460 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") - goto 1 - end if - else - call iotk_error_issue(ierrl,"iotk_tool_dump",__FILE__,__LINE__) -# 464 "iotk_tool.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.2 ") -# 464 "iotk_tool.spp" -call iotk_error_msg(ierrl,'Two keywords. What do you mean?') - goto 1 - end if - end if - end do - - if(iotk_strcomp(keyword,"")) then - write(iotk_output_unit,"(a)") "List of available pages:" - printlist = .true. - end if -#ifndef __IOTK_WORKAROUND8 - if(printlist) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -" intro" -# 475 "iotk_tool.spp" -printme=.false. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,"all")) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'intro')) printme=.true. -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"IOTK: INTRODUCTION" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"The input/output tool kit (IOTK) is a FORTRAN90 library intended" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"to provide an easy access to tagged files formatted using some specific rule." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"In this context, a tagged file is a file containing tags and data." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Tagged files can be textual, in which case a XML-like format is used," -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"or binary, in which case a special format is used." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Note that IOTK is not an XML parser, but it can be used as a writer/parser" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"for a limited subset of the XML language." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"To use the IOTK library from a FORTRAN90 source, the user should" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"use the module 'iotk_module'." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"To minimize the possibility of name clashes, all public names exported" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"from this module has the "//'"'//& -# 475 "iotk_tool.spp" -"iotk_"//'"'//& -# 475 "iotk_tool.spp" -" prefix." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Communication between user and library is based on" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integers, characters and logicals of the default kind (notice that" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"these kinds can be changed using proper compiler options, so that" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"the actual kinds depend on how the library was compiled on your machine)." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"However, the library can handle formatted input/output for" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"all intrinsic datatypes, kinds and ranks if properly configured." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"This is obtained interfacing procedures which acts on all kinds," -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"types and (in almost all cases) ranks. Thus, a single generic" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"name has to be remembered for each subroutine, and the compiler will" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"link the correct one dependening on type, kind and rank of the arguments." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Backward API compatibility will be mantained (as long as it is possible)" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"in future versions." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Backward file compatibility will be mantained (as long as it is possible) in" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"future versions." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"The library writes on files informations about the version of the library." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"It also writes informations about the version of the file format (file_version)." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"The later has to be older or equal to the format supported in the actual library." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printlist) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -" error_handling" -# 475 "iotk_tool.spp" -printme=.false. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,"all")) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'error_handling')) printme=.true. -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"IOTK: ERROR HANDLING" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"The way iotk handles error is sophisticated and allows for a trace back" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"of the error condition inside the library." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Every iotk routines which possibly leads to an error condition has an optional" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"intent(out) integer argument ierr. The returned value is conventionally" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"0 when the routine returns correctly, and different from 0 when the routines" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"raise an error. The value is effectively a handler for a more complex" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"object containing the error message. When an error is raised in a low-level" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk routine, a message is written on the error object. Any intermediate routine" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"can add other messages to the error object, at least the number of the line in" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"the source file. In this way, the error message contains a complete trace of" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"the error plus some additional information." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"At any point in the chain the messages can be exctracted from the error object." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"At some point in the chain the error is really handled, usually by writing the" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"message on the appropriate unit and aborting the execution." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Scanning routines (iotk_scan_*) have an optional logical argument "//'"'//& -# 475 "iotk_tool.spp" -"found"//'"'//& -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"which returns true or false. When scanning for data, also a "//'"'//& -# 475 "iotk_tool.spp" -"default"//'"'//& -# 475 "iotk_tool.spp" -" argument" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"can be used. If one of these two argument is present, the searched" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"object is considered as an optional object. Otherwise, it is considered as a needed object." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If the ierr optional argument is absent, the error handling is leaved to the iotk library." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"In this case, if a needed object is not present, the library handles the error with a" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"forced stop." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If the ierr optional argument is present, it returns an error code." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"ierr = 0 means that no error has occurred" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"ierr > 0 means that an error has occurred probably related to file corruption" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"ierr < 0 means that the item that was searched for has not been found" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"(it is possible only for scanning routines and only if the" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"found and the default keywords are both missing, i.e. only for no-optional objetcs)" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"In scanning routines, if the argument "//'"'//& -# 475 "iotk_tool.spp" -"found"//'"'//& -# 475 "iotk_tool.spp" -" is present it returns .true." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"if the item has been found, .false. otherwise." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If a library routine returns an ierr /= 0 it is STRONGLY RECOMMENDED to" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"clear that error with "//'"'//& -# 475 "iotk_tool.spp" -"call iotk_error_clear(ierr)"//'"'//& -# 475 "iotk_tool.spp" -" before proceeding." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Thus, the final recipe is:" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"* if you want to handle errors, always use the 'ierr' optional argument." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"looking at the sign, you will discern between lacking data and file corruption." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"with iotk_error_print you can obtain a description of the error." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"* if you want to leave the error handling to the library, don't use" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"the 'ierr' optional argument." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"- if the object you are searching is optional, use 'found' or 'default' optional arguments." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"- if the object you are searching is non-optional, don't use 'found' nor 'default' optional arguments." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printlist) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -" binary_and_textual_files" -# 475 "iotk_tool.spp" -printme=.false. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,"all")) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'binary_and_textual_files')) printme=.true. -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"IOTK: BINARY AND TEXTUAL FILES" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Units can be opened on textual or binary files." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"The word 'binary' is used instead of the fortran 'unformatted' since" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"using this libray also binary files have a degree of formattation." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"After a unit has been opened, the library automatically detects" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"its format through an INQUIRE and acts consequently." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Note that the iotk routines check for necessary properties of an opened unit" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"access="//'"'//& -# 475 "iotk_tool.spp" -"sequential"//'"'//& -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"blank ="//'"'//& -# 475 "iotk_tool.spp" -"null"//'"'//& -# 475 "iotk_tool.spp" -" (only textual i/o)" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"pad ="//'"'//& -# 475 "iotk_tool.spp" -"yes"//'"'//& -# 475 "iotk_tool.spp" -" (only textual i/o)" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Moreover, a textual or binary unit can be designed as raw." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"In that case, no tags are placed on the file and everything" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"has to be read and written in the same order." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"This feature is provided for compatibility reasons but it should be" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"used as few as possible." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printlist) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -" optional_arguments" -# 475 "iotk_tool.spp" -printme=.false. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,"all")) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'optional_arguments')) printme=.true. -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"IOTK: OPTIONAL ARGUMENTS" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Most iotk routines accept optional arguments." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"The calling routine will not compile if the names of the" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"arguments are not indicated. For instance, use" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"call iotk_scan_dat(10,"//'"'//& -# 475 "iotk_tool.spp" -"pippo"//'"'//& -# 475 "iotk_tool.spp" -",aa(:),ierr=ii)" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"and NOT:" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"call iotk_scan_dat(10,"//'"'//& -# 475 "iotk_tool.spp" -"pippo"//'"'//& -# 475 "iotk_tool.spp" -",aa(:),ii)" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"The only exeption is the attr argument, for which the name can be" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"omitted if it is placed as the first of the optional arguments." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"In any case, it is better to always explicitly label optional arguments." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printlist) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -" basic_writing_routines iotk_write_begin iotk_write_end iotk_write_empty iotk_write_pi iotk_write_comment" -# 475 "iotk_tool.spp" -printme=.false. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,"all")) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'basic_writing_routines')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_write_begin')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_write_end')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_write_empty')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_write_pi')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_write_comment')) printme=.true. -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"IOTK: BASIC WRITING ROUTINES" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_write_begin (unit,name[,attr][,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_write_end (unit,name[,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_write_empty (unit,name[,attr][,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_write_pi (unit,name[,attr][,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_write_comment(unit,text[,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(in) :: unit" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: name" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: text" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: attr" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(out):: ierr ! see error_handling page" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"These routines write a tag named 'name' on fortran unit 'unit'." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"The type of the tag is determined from the name of the routine:" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_write_begin => " -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_write_end => " -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_write_empty => " -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_write_pi => " -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_write_comment => " -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"An optional attribute string can be supplied in 'attr'" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"In end tags, no attribute is allowed." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"To build the attribute string, use iotk_write_attr." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"DON'T TRY TO MANIPULATE THE ATTRIBUTE STRING DIRECTLY!" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printlist) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -" basic_scanning_routines iotk_scan_begin iotk_scan_end iotk_scan_empty iotk_scan_pi" -# 475 "iotk_tool.spp" -printme=.false. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,"all")) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'basic_scanning_routines')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_scan_begin')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_scan_end')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_scan_empty')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_scan_pi')) printme=.true. -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"IOTK: BASIC SCANNING ROUTINES" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_scan_begin(unit,name[,attr][,found][,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_scan_end (unit,name[,found][,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_scan_empty(unit,name[,attr][,found][,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_scan_pi (unit,name[,attr][,found][,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(in) :: unit" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: name ! len less or equal iotk_namlenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(out):: attr ! len possibily equal iotk_attlenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"logical, intent(out):: found ! see error_handling page" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(out):: ierr ! see error_handling page" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"These routines scan for a tag named 'name' on fortran unit 'unit'." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"The type of the tag is determined from the name of the routine:" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_scan_begin => " -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_scan_end => " -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_scan_empty => " -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_scan_pi => " -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"These routines (except for iotk_scan_end) also fills the" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"attr string, which can be subsequently decoded with iotk_scan_attr." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"DON'T TRY TO MANIPULATE THE ATTRIBUTE STRING DIRECTLY!" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printlist) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -" writing_attributes iotk_write_attr" -# 475 "iotk_tool.spp" -printme=.false. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,"all")) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'writing_attributes')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_write_attr')) printme=.true. -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"IOTK: WRITING ATTRIBUTES" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_write_attr (attr,name,val[,first][,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(out):: attr ! len less or equal iotk_namlenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: name ! len less or equal iotk_attlenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"TYPE(KIND), intent(in) :: val ! any type, any kind, any rank [but only scalars for character]" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"logical, intent(in) :: first" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(out):: ierr" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"This routine adds one attribute to the 'attr' string." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"To clean the string (for the first attribute) use first=.true." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Example:" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"call iotk_write_attr(attr,"//'"'//& -# 475 "iotk_tool.spp" -"pippo"//'"'//& -# 475 "iotk_tool.spp" -",1,first=.true.)" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"call iotk_write_attr(attr,"//'"'//& -# 475 "iotk_tool.spp" -"paperino"//'"'//& -# 475 "iotk_tool.spp" -",2)" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"call iotk_write_attr(attr,"//'"'//& -# 475 "iotk_tool.spp" -"pluto"//'"'//& -# 475 "iotk_tool.spp" -",3)" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"This is equivalent to attr="//'"'//& -# 475 "iotk_tool.spp" -""//'"'//& -# 475 "iotk_tool.spp" -" before the call, but more efficient." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"The attribute is added in the form name="//'"'//& -# 475 "iotk_tool.spp" -"value"//'"'//& -# 475 "iotk_tool.spp" -"," -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"where "//'"'//& -# 475 "iotk_tool.spp" -"value"//'"'//& -# 475 "iotk_tool.spp" -" is a string containing a textual representation" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"of the val variable." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If one of <>&"//'"'//& -# 475 "iotk_tool.spp" -"' appears in val, it is automatically escaped." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printlist) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -" scanning_attributes iotk_scan_attr" -# 475 "iotk_tool.spp" -printme=.false. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,"all")) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'scanning_attributes')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_scan_attr')) printme=.true. -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"IOTK: SCANNING ATTRIBUTES" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_scan_attr (attr,name,val[,found][,default][,eos][,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: attr ! len possibily equal iotk_attlenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: name ! len less or equal iotk_namlenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"TYPE(KIND), intent(out):: val ! any type, any kind, any rank [but only scalars for character]" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"logical, intent(out):: found ! see error_handling page" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"TYPE(KIND), intent(in) :: default ! same type, kind and rank as val" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"logical, intent(in) :: eos" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(out):: ierr ! see error_handling page" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"This routine scans for one attribute named 'name' from the 'attr' string." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If the attribute is found, it is read to variable 'val'." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If it is not found and default is present, default is copied onto val." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If TYPE is character and eos is present and true," -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"an end-of-string terminator will be attached at the end of the read string," -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"and the following bytes will not be touched. This is faster, but requires" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"the user to take care directly of the end-of-string. Thus, it is discouraged." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"The attribute can be delimited with "//'"'//& -# 475 "iotk_tool.spp" -""//'"'//& -# 475 "iotk_tool.spp" -" or with ''" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printlist) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -" writing_data iotk_write_dat" -# 475 "iotk_tool.spp" -printme=.false. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,"all")) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'writing_data')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_write_dat')) printme=.true. -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"IOTK: WRITING DATA" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_write_dat (unit,name,dat[,fmt][,columns][,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(in) :: unit" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: name ! len less or equal iotk_namlenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"TYPE(KIND), intent(in) :: dat ! any type, any kind, any rank" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: fmt" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(in) :: columns" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(out):: ierr ! see error_handling page" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"This routines write a data object, that is a self-described" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"object containg fortran data." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"A single data object has the following form" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -".. DATA ..." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"where" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"TYPE is the intrinsic type (logical,integer,real,complex or character)," -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"KIND is the data kind (stored in binary files only)" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"SIZE is the array size (shape informations are not stored)" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"COLUMNS is the number of data per line" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"LEN is the string length" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"FMT is a fortran format string used to write data" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If the optional 'fmt' is not passed, default format ('columns' element per line)" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"is used and the fmt attribute is not written. Otherwise, the string" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"fmt is used as a FORTRAN format specifierfor the write statement. In this" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"case it is also written on the file (and used for reading the data back)." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"fmt="//'"'//& -# 475 "iotk_tool.spp" -"*"//'"'//& -# 475 "iotk_tool.spp" -" can be used and correspond to the "//'"'//& -# 475 "iotk_tool.spp" -"write(unit,*)"//'"'//& -# 475 "iotk_tool.spp" -" statement." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If the optional 'columns' is not passed, it is assumed to be 1 and" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"the columns attribute is not written. Note that this attribute is completely" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"ininfluent when reading." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"columns and fmt arguments are incompatible." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"For complex data, one element is a couple of comma separated real numbers." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If one of <>& appears in dat, it is escaped." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printlist) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -" scanning_data iotk_scan_dat" -# 475 "iotk_tool.spp" -printme=.false. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,"all")) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'scanning_data')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_scan_dat')) printme=.true. -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"IOTK: SCANNING DATA" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_scan_dat (unit,name,dat[,found][,default][,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(in) :: unit" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: name ! len less or equal iotk_namlenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"TYPE(KIND), intent(out):: dat ! any type, any kind, any rank" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"logical, intent(out):: found ! see error_handling page" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"TYPE(KIND), intent(in) :: default ! same type, kind and rank as dat" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(out):: ierr ! see error_handling page" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"A data object written with iotk_write_dat is read." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If it is not found and default is present, default is copied onto dat." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If a keyword is absent in the file, the value is deduced from the" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"dat argument and no check is performed. This allows to write" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"rapidly by hand data objects. For instance" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -" 1.0 " -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"can be read with" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"real :: val" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"call iotk_scan_dat(unit,"//'"'//& -# 475 "iotk_tool.spp" -"datum"//'"'//& -# 475 "iotk_tool.spp" -",val)" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If fmt is not present on file, the default format is used." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Types and sizes are checked." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Different kinds (for binary i/o) are automatically converted." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Length (for characters) are not checked. If strings on files" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"are longer then len(dat), only the first characters are read; if strings" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"on files are shorter, dat is padded with blanks." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printlist) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -" opening_files iotk_open_write iotk_open_read" -# 475 "iotk_tool.spp" -printme=.false. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,"all")) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'opening_files')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_open_write')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_open_read')) printme=.true. -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"IOTK: OPENING FILES" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_open_write(unit[,file][,attr][,binary][,raw][,new][,root][,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(in) :: unit" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: file" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: attr" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"logical, intent(in) :: binary" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"logical, intent(in) :: new" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"logical, intent(in) :: raw" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: root ! len less or equal iotk_namlenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(out) :: ierr ! see error_handling page" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If file is present, this routines opens file 'file' on" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"unit 'unit' with the proper options." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If binary is present and true, the file is binary." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If new is present and true, the file must not exist already." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If raw is present and true, the file is considered as a raw data file" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"(use of raw data files is discouraged)." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If file is not present, unit is assumed to be already connected." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If root is present, it is used as the name of the root begin/end tag." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If it is absent, the default "//'"'//& -# 475 "iotk_tool.spp" -"Root"//'"'//& -# 475 "iotk_tool.spp" -" is used." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"An optional attribute string can be supplied in 'attr', and will be used" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"as an attribute list for the begin root tag." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Also informations about iotk version and binary format are written as" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"pi informations." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_open_read(unit[,file][,attr][,binary][,raw][,root][,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(in) :: unit" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: file" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(out) :: attr" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"logical, intent(in) :: binary" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"logical, intent(in) :: raw" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(out) :: root ! len possibly equal iotk_namlenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(out) :: ierr ! see error_handling page" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If file is present, this routines opens file 'file' on" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"unit 'unit' with the proper options." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If binary is present and true, the file is binary." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If raw is present and true, the file is considered as a raw data file" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"(use of raw data files is discouraged)." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If file is not present, unit is assumed to be already connected." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If root is present, the name of root in file is read onto that variable." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If attr is present, the attributes of the root tag are read onto that variable," -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"which can be subsequently decoded with iotk_scan_attr." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"DON'T TRY TO MANIPULATE THE ATTRIBUTE STRING DIRECTLY!" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printlist) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -" closing_files iotk_close_write iotk_close_read" -# 475 "iotk_tool.spp" -printme=.false. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,"all")) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'closing_files')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_close_write')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_close_read')) printme=.true. -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"IOTK: CLOSING FILES" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_close_write(unit[,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_close_read(unit[,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(in) :: unit" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(out) :: ierr ! see error_handling page" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"This routines close a file opened with iotk_open_*" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Note that if the units were already connected before iotk_open_*, they" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"are left connected here." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printlist) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -" multiple_files iotk_link" -# 475 "iotk_tool.spp" -printme=.false. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,"all")) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'multiple_files')) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'iotk_link')) printme=.true. -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"IOTK: MULTIPLE FILES" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"When reading, if a begin tag with an attribute iotk_link="//'"'//& -# 475 "iotk_tool.spp" -"FILENAME"//'"'//& -# 475 "iotk_tool.spp" -" is found," -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"file FILENAME is mounted in its place" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"If FILENAME begins with a "//'"'//& -# 475 "iotk_tool.spp" -"/"//'"'//& -# 475 "iotk_tool.spp" -", the path is absolute, otherwise it is relative" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"to the original file." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Note that the mounting is completely transparent for users, which can access" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"the new file using the old unit. However, if the user wants to access" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"directly the new file, iotk_physical_unit should be used." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"When writing, the user can switch a logical unit to a different file using" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"the following routine" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_link(unit,name,file,dummy[,binary][,raw][,create][,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(in) :: unit" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: name" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*), intent(in) :: file" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"logical, intent(in) :: binary" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"logical, intent(in) :: raw" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"logical, intent(in) :: create" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(out) :: ierr" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"name is the name of the tag which represents the link." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"file is the name of the new file" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"if binary is present and true, the new file will be binary" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"if raw is present and true, the new file will be raw" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"if create is present and true, the new file is actually created" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"and the next write statement will act on this new file automatically." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Otherwise, only the symbolic link is created." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printlist) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -" utilities" -# 475 "iotk_tool.spp" -printme=.false. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,"all")) printme=.true. -# 475 "iotk_tool.spp" -if(iotk_strcomp(keyword,'utilities')) printme=.true. -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"IOTK: OTHER UTILITIES" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Here a number of additional routines/parameters available" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"from the iotk_module is listed" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*) :: iotk_index (index)" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(in) :: index ! scalar or rank 1" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Returns a string representing the index in an array." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"Example: index = (/1,2,3/) => iotk_index = "//'"'//& -# 475 "iotk_tool.spp" -".1.2.3"//'"'//& -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"The correct way for writing an array of derived types is" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"to build the names as follows" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"! ONE-DIMENSIONAL ARRAY" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"do i = 1 , n" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"call iotk_write_begin(unit,"//'"'//& -# 475 "iotk_tool.spp" -"dummy"//'"'//& -# 475 "iotk_tool.spp" -"//iotk_index(i))" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"! WRITE THE OBJECT HERE" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"call iotk_write_end (unit,"//'"'//& -# 475 "iotk_tool.spp" -"dummy"//'"'//& -# 475 "iotk_tool.spp" -"//iotk_index(i))" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"end do" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"do i = 1 , n" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"do j = 1 , m" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"! NOTE THE ORDER OF INDEXES, THE FASTER IS THE LAST" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"call iotk_write_begin(unit,"//'"'//& -# 475 "iotk_tool.spp" -"dummy"//'"'//& -# 475 "iotk_tool.spp" -"//iotk_index((/i,j/)))" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"! WRITE THE OBJECT HERE" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"call iotk_write_end (unit,"//'"'//& -# 475 "iotk_tool.spp" -"dummy"//'"'//& -# 475 "iotk_tool.spp" -"//iotk_index((/i,j/)))" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"end do" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"end do" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"iotk_free_unit(unit[,ierr])" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(out) :: unit" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer, intent(out) :: ierr" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"This routine returns the number of a free FORTRAN unit." -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character(len=*) :: iotk_version" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"version string of iotk" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character :: iotk_newline" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"newline sequence" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"character :: iotk_eos" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"end-of-string character" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer :: iotk_taglenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"max length of a tag" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer :: iotk_namlenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"max length of a tag or attribute name" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer :: iotk_attlenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"max length of the attribute string" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer :: iotk_vallenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"max length of the value of an attribute" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer :: iotk_linlenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"max length of a line in textual files" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer :: iotk_fillenx" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"max length of a file name" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer :: iotk_header_kind" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"integer kind of headers in binary files" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -# 475 "iotk_tool.spp" -if(printme) write(iotk_output_unit,"(a)") & -# 475 "iotk_tool.spp" -"" -#endif - 1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_tool_man_x - - diff --git a/quantum_espresso/kcp/iotk/src/iotk_tool.spp b/quantum_espresso/kcp/iotk/src/iotk_tool.spp deleted file mode 100644 index 22e4e9075..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_tool.spp +++ /dev/null @@ -1,486 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## -># inclusion of the tool to generate man pages ->include iotk_mangen.sh ->############################################################################## - -> REVISION='$Revision: 1.1.1.1 $' -> REVISION="${REVISION//${dol}/}" - ->PROCEDURE=iotk_tool -subroutine iotk_tool_x(args) - use iotk_base - use iotk_error_interf - use iotk_str_interf - use iotk_tool_interf - use iotk_xtox_interf - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: args(:) - integer :: iarg,ierrl - character(iotk_linlenx) :: arg - logical :: print_help_options,print_help_commands,print_help_basic,print_copyright,print_version - logical :: check - integer :: linlen,indent,maxindent - ierrl = 0 - iarg = 1 - - print_version = .false. - print_help_options = .false. - print_help_commands = .false. - print_help_basic = .false. - print_copyright = .false. - - if(size(args)==0) then - print_help_basic = .true. - end if - - do iarg = 1 , size(args) - arg = args(iarg) - if(iotk_strcomp(arg(1:1),"-")) then -! options here - if(iotk_strcomp(arg,"--help") .or. iotk_strcomp(arg,"-H")) then - print_help_basic = .true. - exit - else if(iotk_strcomp(arg,"--version")) then - print_version = .true. - exit - else if(iotk_strcomp(arg,"--do-nothing")) then - exit - else if(iotk_strcomp(arg,"--copyright")) then - print_copyright = .true. - exit - else if(iotk_strcomp(arg,"--help-options")) then - print_help_options = .true. - exit - else if(iotk_strcomp(arg,"--help-commands")) then - print_help_commands = .true. - exit - else if(arg(1:13)=="--set-linlen=") then - call iotk_atoi(linlen,arg(14:iotk_strlen(arg)),check=check) - if(.not.check) then - $(ERROR ierrl '') - goto 1 - end if - call iotk_set(linlen=linlen,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl '') - goto 1 - end if - else if(arg(1:13)=="--set-indent=") then - call iotk_atoi(indent,arg(14:iotk_strlen(arg)),check=check) - if(.not.check) then - $(ERROR ierrl '') - goto 1 - end if - call iotk_set(indent=indent,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl '') - goto 1 - end if - else if(arg(1:16)=="--set-maxindent=") then - call iotk_atoi(maxindent,arg(17:iotk_strlen(arg)),check=check) - if(.not.check) then - $(ERROR ierrl '') - goto 1 - end if - call iotk_set(maxindent=maxindent,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl '') - goto 1 - end if - else - write(iotk_error_unit,"(a)") "unrecognized option `"//arg(1:iotk_strlen(arg))//"'" - print_help_basic = .true. - exit - end if - else -! commands here - if(iotk_strcomp(arg,"convert")) then - call iotk_tool_convert(args(iarg+1:),ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error converting file') - goto 1 - end if - else if(iotk_strcomp(arg,"dump")) then - call iotk_tool_dump(args(iarg+1:),ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error dumping file') - goto 1 - end if - else if(iotk_strcomp(arg,"info")) then - call iotk_tool_info(args(iarg+1:),ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error') - goto 1 - end if - else if(iotk_strcomp(arg,"man")) then - call iotk_tool_man(args(iarg+1:),ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error') - goto 1 - end if - else - write(iotk_error_unit,"(a)") "Unknown command: `"//arg(1:iotk_strlen(arg))//"'" - write(iotk_error_unit,"(a)") "" - print_help_commands = .true. - end if - exit - end if - end do - - if(print_help_basic) then - write(iotk_error_unit,"(a)") "Usage: iotk [iotk-options] command [command-options-and-arguments]" - write(iotk_error_unit,"(a)") " where iotk-options are ..." - write(iotk_error_unit,"(a)") " (specify --help-options for a list of options)" - write(iotk_error_unit,"(a)") " where command is convert, dump, etc." - write(iotk_error_unit,"(a)") " (specify --help-commands for a list of commands)" - write(iotk_error_unit,"(a)") " where command-options-and-arguments depend on the specific command" - write(iotk_error_unit,"(a)") " (specify a command followed by --help for command-specific help)" - write(iotk_error_unit,"(a)") " Specify --help to receive this message" - end if - - if(print_help_commands) then - write(iotk_error_unit,"(a)") "IOTK commands are:" - write(iotk_error_unit,"(a)") " convert to convert a file" - write(iotk_error_unit,"(a)") " dump to dump a file" - write(iotk_error_unit,"(a)") " info to obtain informations about how iotk was compiled" - write(iotk_error_unit,"(a)") " man to print manual pages" - end if - - if(print_help_options) then - write(iotk_error_unit,"(a)") "IOTK options are:" - write(iotk_error_unit,"(a)") " --copyright print copyright informations" - write(iotk_error_unit,"(a)") " --version print version informations" - write(iotk_error_unit,"(a)") " --help print a short, generic help" - write(iotk_error_unit,"(a)") " --help-options print a list of options (this list)" - write(iotk_error_unit,"(a)") " --help-commands print a list of commands" - write(iotk_error_unit,"(a)") " --set-linlen=N to set the length of an output line" - write(iotk_error_unit,"(a)") " --set-indent=N to set the number of spaces for an indent level" - write(iotk_error_unit,"(a)") " --set-maxindent=N to set the maximum number of spaces when indenting" - end if - - if(print_version) then - write(*,"(a)") "Input/Output Tool Kit (IOTK) version: "//trim(iotk_version) - end if - - if(print_copyright) then - write(iotk_error_unit,"(a)") "Input/Output Tool Kit (IOTK)" - write(iotk_error_unit,"(a)") "Copyright (C) 2004-2006 Giovanni Bussi" - write(iotk_error_unit,"(a)") "" - write(iotk_error_unit,"(a)") "This library is free software; you can redistribute it and/or" - write(iotk_error_unit,"(a)") "modify it under the terms of the GNU Lesser General Public" - write(iotk_error_unit,"(a)") "License as published by the Free Software Foundation; either" - write(iotk_error_unit,"(a)") "version 2.1 of the License, or (at your option) any later version." - write(iotk_error_unit,"(a)") "" - write(iotk_error_unit,"(a)") "This library is distributed in the hope that it will be useful," - write(iotk_error_unit,"(a)") "but WITHOUT ANY WARRANTY; without even the implied warranty of" - write(iotk_error_unit,"(a)") "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU" - write(iotk_error_unit,"(a)") "Lesser General Public License for more details." - write(iotk_error_unit,"(a)") "" - write(iotk_error_unit,"(a)") "You should have received a copy of the GNU Lesser General Public" - write(iotk_error_unit,"(a)") "License along with this library; if not, write to the Free Software" - write(iotk_error_unit,"(a)") "Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA" - end if - -1 continue - if(ierrl/=0) call iotk_error_handler(ierrl) - -end subroutine iotk_tool_x - ->PROCEDURE="iotk_tool_convert" -subroutine iotk_tool_convert_x(args,ierr) - use iotk_base - use iotk_error_interf - use iotk_str_interf - use iotk_misc_interf - use iotk_files_interf - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr - integer :: iarg,ierrl,outfile_len - character(len=iotk_fillenx) :: infile,outfile - logical :: binary - character(len=iotk_attlenx) :: attr - character(len=iotk_taglenx) :: root - integer :: maxsize - logical :: autofmt - infile="" - outfile="" - binary=.true. - maxsize=-1 - ierrl = 0 - autofmt = .true. - do iarg = 1 , size(args) - if(iotk_strcomp(args(iarg)(1:1),"-")) then - if(iotk_strcomp(args(iarg),"--help")) then - write(iotk_error_unit,"(a)") "Usage: iotk convert [OPTIONS] infile outfile" - write(iotk_error_unit,"(a)") "Options:" - write(iotk_error_unit,"(a)") " --mode=X set the output file to be X, where X can be" - write(iotk_error_unit,"(a)") " 'textual', 'binary' or 'auto'." - write(iotk_error_unit,"(a)") " -b equivalent to --mode=binary" - write(iotk_error_unit,"(a)") " -t equivalent to --mode=textual" - write(iotk_error_unit,"(a)") "This command converts a iotk data file into another iotk data file." - write(iotk_error_unit,"(a)") "The infile can be textual or binary, and its format is automatically detected." - write(iotk_error_unit,"(a)") "The outfile can be textual or binary depending on the --mode option." - write(iotk_error_unit,"(a)") "If the mode is 'auto', the decision is driven by outfile extension," - write(iotk_error_unit,"(a)") "i.e. a file matching *.txt of *.xml will be considered textual, otherwise binary" - goto 1 - else if(iotk_strcomp(args(iarg),"-b") .or. iotk_strcomp(args(iarg),"--mode=binary")) then - binary = .true. - autofmt = .false. - else if(iotk_strcomp(args(iarg),"-t") .or. iotk_strcomp(args(iarg),"--mode=textual")) then - binary = .false. - autofmt = .false. - else if(iotk_strcomp(args(iarg),"--mode=auto")) then - binary = .true. - autofmt = .true. - else - $(ERROR ierrl 'Unknown option') - goto 1 - end if - else - if(infile=="") then - call iotk_strcpy(infile,args(iarg),ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'File name too long') - goto 1 - end if - else if(outfile=="") then - call iotk_strcpy(outfile,args(iarg),ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'File name too long') - goto 1 - end if - else - $(ERROR ierrl 'Three files. What do you mean?') - goto 1 - end if - end if - end do - if(outfile=="") then - $(ERROR ierrl 'Convert: bad usage') - goto 1 - end if - - outfile_len = iotk_strlen(outfile) - if(outfile_len>3) then - select case(outfile(outfile_len-3:outfile_len)) - case(".xml") - binary = .false. - case(".txt") - binary = .false. - case default - binary = .true. - end select - end if - - call iotk_open_read(60,infile,root=root,attr=attr) - call iotk_open_write(61,outfile,binary=binary,root=root,attr=attr) - call iotk_copy_tag(60,61,maxsize=-1) - call iotk_close_write(61) - call iotk_close_read(60) - -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_tool_convert_x - - ->PROCEDURE="iotk_tool_dump" -subroutine iotk_tool_dump_x(args,ierr) - use iotk_base - use iotk_error_interf - use iotk_str_interf - use iotk_misc_interf - use iotk_files_interf - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr - integer :: iarg,ierrl - character(len=iotk_fillenx) :: infile - character(len=iotk_attlenx) :: attr - character(len=iotk_taglenx) :: root - integer :: maxsize - infile="" - maxsize=-1 - ierrl = 0 - do iarg = 1 , size(args) - if(iotk_strcomp(args(iarg)(1:1),"-")) then - if(iotk_strcomp(args(iarg),"--help")) then - write(iotk_error_unit,"(a)") "Usage: iotk dump file" - write(iotk_error_unit,"(a)") "This command dumps a iotk data file on standard out." - write(iotk_error_unit,"(a)") "The file can be textual or binary, and its format is automatically detected." - goto 1 - else - $(ERROR ierrl 'Unknown option') - goto 1 - end if - else - if(infile=="") then - call iotk_strcpy(infile,args(iarg),ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'File name too long') - goto 1 - end if - else - $(ERROR ierrl 'Two files. What do you mean?') - goto 1 - end if - end if - end do - - call iotk_open_read(60, trim(infile),root=root,attr=attr) - call iotk_open_write(iotk_output_unit,root=root,attr=attr) - call iotk_copy_tag(60,iotk_output_unit,maxsize=-1) - call iotk_close_write(iotk_output_unit) - call iotk_close_read(60) - -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_tool_dump_x - -subroutine iotk_tool_info_x(args,ierr) - use iotk_base - use iotk_misc_interf - use iotk_xtox_interf - use iotk_error_interf - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr - integer :: ierrl - ierrl = 0 - write(*,"(a)") "IOTK (Input/Output Tool Kit) version: "//trim(iotk_version) - write(*,"(a)") "Limits:" - write(*,"(a)") " maximum rank (soft limit): "//trim(iotk_itoa(iotk_maxrank)) - write(*,"(a)") " maximum rank (hard limit): "//trim(iotk_itoa(iotk_maxrank_hard)) - write(*,"(a)") "Special kinds:" - write(*,"(a)") " headers in binary files are integer(kind="//trim(iotk_itoa(iotk_header_kind))//")" - write(*,"(a)") " default integers are integer(kind="//trim(iotk_itoa(iotk_integer_defkind))//")" - write(*,"(a)") " default logicals are logical(kind="//trim(iotk_itoa(iotk_logical_defkind))//")" - write(*,"(a)") " default characters are character(kind="//trim(iotk_itoa(iotk_character_defkind))//")" - write(*,"(a)") "Kinds configured for i/o operations:" -> for kind in $kinds ; do -#ifdef __IOTK_LOGICAL${kind} - write(*,"(a)") " logical(kind="//trim(iotk_itoa(iotk_logical${kind}))//")" -#endif -> done -> for kind in $kinds ; do -#ifdef __IOTK_INTEGER${kind} - write(*,"(a)") " integer(kind="//trim(iotk_itoa(iotk_integer${kind}))//")" -#endif -> done -> for kind in $kinds ; do -#ifdef __IOTK_REAL${kind} - write(*,"(a)") " real(kind="//trim(iotk_itoa(iotk_real${kind}))//")" -#endif -> done -> for kind in $kinds ; do -#ifdef __IOTK_REAL${kind} - write(*,"(a)") " complex(kind="//trim(iotk_itoa(iotk_real${kind}))//")" -#endif -> done - write(*,"(a)") " character(kind="//trim(iotk_itoa(iotk_character1))//")" - -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_tool_info_x - -subroutine iotk_tool_man_x(args,ierr) - use iotk_base - use iotk_misc_interf - use iotk_xtox_interf - use iotk_error_interf - use iotk_str_interf - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr - character(len=iotk_linlenx) :: keyword - integer :: ierrl,iarg - logical :: printme,printlist - - ierrl = 0 - printme = .false. - printlist = .false. - keyword(1:1) = iotk_eos - - do iarg = 1 , size(args) - if(iotk_strcomp(args(iarg)(1:1),"-")) then - if(iotk_strcomp(args(iarg),"--help")) then - write(iotk_error_unit,"(a)") "Usage: iotk man [keyword]" - write(iotk_error_unit,"(a)") "This command prints on stdout the page of the built-in manual associated with the keyword." - write(iotk_error_unit,"(a)") "If the keyword is not given a list of all the available keywords will be printed." - goto 1 - else - $(ERROR ierrl 'Unknown option') - goto 1 - end if - else - if(iotk_strcomp(keyword,"")) then - call iotk_strcpy(keyword,args(iarg),ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - else - $(ERROR ierrl 'Two keywords. What do you mean?') - goto 1 - end if - end if - end do - - if(iotk_strcomp(keyword,"")) then - write(iotk_output_unit,"(a)") "List of available pages:" - printlist = .true. - end if -#ifndef __IOTK_WORKAROUND8 - $(mangen) -#endif - 1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_tool_man_x - - - diff --git a/quantum_espresso/kcp/iotk/src/iotk_tool_interf.f90 b/quantum_espresso/kcp/iotk/src/iotk_tool_interf.f90 deleted file mode 100644 index 0d58303fb..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_tool_interf.f90 +++ /dev/null @@ -1,75 +0,0 @@ -# 1 "iotk_tool_interf.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_tool_interf.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_tool_interf.spp" - -module iotk_tool_interf -private -public :: iotk_tool -public :: iotk_tool_convert -public :: iotk_tool_dump -public :: iotk_tool_info -public :: iotk_tool_man - -interface iotk_tool -subroutine iotk_tool_x(args) - implicit none - character(len=*), intent(in) :: args(:) -end subroutine iotk_tool_x -end interface - -interface iotk_tool_convert -subroutine iotk_tool_convert_x(args,ierr) - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr -end subroutine iotk_tool_convert_x -end interface - -interface iotk_tool_dump -subroutine iotk_tool_dump_x(args,ierr) - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr -end subroutine iotk_tool_dump_x -end interface - -interface iotk_tool_info -subroutine iotk_tool_info_x(args,ierr) - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr -end subroutine iotk_tool_info_x -end interface - -interface iotk_tool_man -subroutine iotk_tool_man_x(args,ierr) - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr -end subroutine iotk_tool_man_x -end interface - -end module iotk_tool_interf diff --git a/quantum_espresso/kcp/iotk/src/iotk_tool_interf.spp b/quantum_espresso/kcp/iotk/src/iotk_tool_interf.spp deleted file mode 100644 index 80f233006..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_tool_interf.spp +++ /dev/null @@ -1,79 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -module iotk_tool_interf -private -public :: iotk_tool -public :: iotk_tool_convert -public :: iotk_tool_dump -public :: iotk_tool_info -public :: iotk_tool_man - -interface iotk_tool -subroutine iotk_tool_x(args) - implicit none - character(len=*), intent(in) :: args(:) -end subroutine iotk_tool_x -end interface - -interface iotk_tool_convert -subroutine iotk_tool_convert_x(args,ierr) - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr -end subroutine iotk_tool_convert_x -end interface - -interface iotk_tool_dump -subroutine iotk_tool_dump_x(args,ierr) - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr -end subroutine iotk_tool_dump_x -end interface - -interface iotk_tool_info -subroutine iotk_tool_info_x(args,ierr) - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr -end subroutine iotk_tool_info_x -end interface - -interface iotk_tool_man -subroutine iotk_tool_man_x(args,ierr) - implicit none - character(len=*), intent(in) :: args(:) - integer, optional, intent(out) :: ierr -end subroutine iotk_tool_man_x -end interface - -end module iotk_tool_interf - diff --git a/quantum_espresso/kcp/iotk/src/iotk_unit.f90 b/quantum_espresso/kcp/iotk/src/iotk_unit.f90 deleted file mode 100644 index d0e423cd9..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_unit.f90 +++ /dev/null @@ -1,318 +0,0 @@ -# 1 "iotk_unit.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_unit.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_unit.spp" - -# 33 "iotk_unit.spp" - -# 35 "iotk_unit.spp" -subroutine iotk_free_unit_x(unit,ierr) - use iotk_base - use iotk_error_interf - implicit none -! This subroutine sets 'unit' to the number of -! an I/O unit which is free (i.e. not already opened). -! The search is carried out starting from unit -! 'unitmin' in a range of 'nsearch' units. -! The starting unit for the search is increased at each -! call, so that a number of subsequent ask can be done -! obtaining different units. - integer, intent(out) :: unit - integer, optional, intent(out) :: ierr - integer, save :: offset = 0 - logical :: opened,exist - integer :: isearch,nsearch,unitmin - integer :: ierrl - integer :: iostat - iostat = 0 - unitmin = iotk_unitmin - nsearch = iotk_unitmax - iotk_unitmin + 1 - ierrl = 0 - do isearch=0,nsearch-1 - unit = modulo(isearch+offset,nsearch) + unitmin - inquire(unit=unit,opened=opened,exist=exist,iostat=iostat) - if(iostat/=0) then - call iotk_error_issue(ierrl,"iotk_free_unit",__FILE__,__LINE__) -# 61 "iotk_unit.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 61 "iotk_unit.spp" -call iotk_error_msg(ierrl,'Error inquiring') -# 61 "iotk_unit.spp" -call iotk_error_write(ierrl,"unit",unit) -# 61 "iotk_unit.spp" -call iotk_error_write(ierrl,"iostat",iostat) - goto 1 - end if - if((.not.opened .and. exist) .or. iostat/=0) exit - end do - if(isearch>=nsearch) then - call iotk_error_issue(ierrl,"iotk_free_unit",__FILE__,__LINE__) -# 67 "iotk_unit.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.3 ") -# 67 "iotk_unit.spp" -call iotk_error_msg(ierrl,'There are no units left') -# 67 "iotk_unit.spp" -call iotk_error_write(ierrl,"iotk_unitmin",iotk_unitmin) -# 67 "iotk_unit.spp" -call iotk_error_write(ierrl,"iotk_unitmax",iotk_unitmax) -# 67 "iotk_unit.spp" -call iotk_error_write(ierrl,"offset",offset) - goto 1 - end if - offset = modulo(unit - unitmin + 1,nsearch) -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_free_unit_x - -# 80 "iotk_unit.spp" -function iotk_phys_unit_x(unit) result(result) - use iotk_base - use iotk_unit_interf - use iotk_unit_list_module - implicit none - integer, intent(in) :: unit - integer :: result - type(iotk_unit), pointer :: this - result = unit - if(.not. iotk_units_init) then - iotk_units_init = .true. - call iotk_unit_list_init(iotk_units) - end if - call iotk_unit_get(unit,pointer=this) - if(.not.associated(this)) return - do - if(.not. associated(this%son)) exit - this => this%son - end do - result = this%unit -end function iotk_phys_unit_x - -# 103 "iotk_unit.spp" -subroutine iotk_unit_print_x(unit) - use iotk_base - use iotk_str_interf - implicit none - integer, intent(in) :: unit -! type (iotk_unit), pointer :: this -! stop -! this => iotk_units -! write(unit,"(a)") "IOTK units" -! do -! if(.not. associated(this)) exit -! write(unit,"(a,i8)") "Unit :",this%unit -! write(unit,"(a,a,a,i8)") "Root :",this%root(1:iotk_strlen_trim(this%root)),"Level:",this%level -! write(unit,"(a,l8)") "Raw :",this%raw -! if(associated(this%son)) then -! write(unit,"(a,i8)") "Son :",this%son%unit -! end if -! if(associated(this%parent)) then -! write(unit,"(a,i8)") "Parent :",this%parent%unit -! end if -!! this => this%next -! end do -! write(unit,"(a)") "end IOTK units" -end subroutine iotk_unit_print_x - - -# 130 "iotk_unit.spp" -subroutine iotk_unit_add_x(unit,this,ierr) - use iotk_base - use iotk_error_interf - use iotk_unit_list_module - implicit none - integer, intent(in) :: unit - type (iotk_unit), pointer :: this - integer, intent(out) :: ierr - ierr = 0 - if(.not. iotk_units_init) then - iotk_units_init = .true. - call iotk_unit_list_init(iotk_units) - end if - call iotk_unit_list_search(iotk_units,this,unit=unit) - if(associated(this)) then - call iotk_error_issue(ierr,"iotk_unit_add",__FILE__,__LINE__) -# 145 "iotk_unit.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.3 ") -# 145 "iotk_unit.spp" -call iotk_error_msg(ierr,'unit') - return - end if - call iotk_unit_list_add(iotk_units,this) - this%unit = unit - this%root = "" - this%skip_root = .false. - this%raw = .false. - this%level = 0 - this%close_at_end = .false. - nullify(this%son) - nullify(this%parent) -end subroutine iotk_unit_add_x - -# 160 "iotk_unit.spp" -subroutine iotk_inquire_x(unit,binary,stream,ierr) - use iotk_base - use iotk_error_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: unit - logical, intent(out) :: binary - logical, intent(out) :: stream - integer, intent(out) :: ierr - character(50) :: form,access,pad,blank - logical :: opened - integer :: iostat - iostat = 0 - ierr = 0 - inquire(unit=unit,form=form,iostat=iostat,access=access,pad=pad,blank=blank,opened=opened) - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_inquire",__FILE__,__LINE__) -# 177 "iotk_unit.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.3 ") -# 177 "iotk_unit.spp" -call iotk_error_msg(ierr,'Error inquiring') - return - end if - if(opened .and. iotk_toupper(form)=="UNFORMATTED") then - binary = .true. - else - binary = .false. - end if - stream = .false. - if(opened) then - select case(iotk_toupper(access)) - case("SEQUENTIAL") - case("STREAM") - stream = .true. - case default - call iotk_error_issue(ierr,"iotk_inquire",__FILE__,__LINE__) -# 192 "iotk_unit.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.3 ") -# 192 "iotk_unit.spp" -call iotk_error_msg(ierr,'Direct-access files are not allowed') - return - end select - end if - if(.not. binary) then - if(opened .and. iotk_toupper(blank)/="NULL") then - call iotk_error_issue(ierr,"iotk_inquire",__FILE__,__LINE__) -# 198 "iotk_unit.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.3 ") - return - end if - if(opened .and. iotk_toupper(pad) /="YES") then - call iotk_error_issue(ierr,"iotk_inquire",__FILE__,__LINE__) -# 202 "iotk_unit.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.3 ") - return - end if - end if -end subroutine iotk_inquire_x - -# 209 "iotk_unit.spp" -subroutine iotk_unit_del_x(unit,ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - use iotk_unit_list_module - implicit none - integer, intent(in) :: unit - integer, intent(out) :: ierr - type (iotk_unit), pointer :: this - ierr = 0 - if(.not. iotk_units_init) then - iotk_units_init = .true. - call iotk_unit_list_init(iotk_units) - end if - call iotk_unit_list_search(iotk_units,unit=unit,ptr=this) - if(.not.associated(this)) then - call iotk_error_issue(ierr,"iotk_unit_del",__FILE__,__LINE__) -# 225 "iotk_unit.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.3 ") - return - end if - if(associated(this%parent)) nullify(this%parent%son) - call iotk_unit_list_del(iotk_units,ptr=this) -end subroutine iotk_unit_del_x - -# 233 "iotk_unit.spp" -subroutine iotk_unit_parent_x(parent,son,ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: parent,son - integer, intent(out) :: ierr - type(iotk_unit), pointer :: this_parent,this_son - ierr = 0 - call iotk_unit_get(parent,pointer=this_parent) - if(.not.associated(this_parent)) then - call iotk_error_issue(ierr,"iotk_unit_parent",__FILE__,__LINE__) -# 245 "iotk_unit.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.3 ") - return - end if - call iotk_unit_get(son,pointer=this_son) - if(.not.associated(this_son)) then - call iotk_error_issue(ierr,"iotk_unit_parent",__FILE__,__LINE__) -# 250 "iotk_unit.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.3 ") - return - end if - if(associated(this_parent%son)) then - call iotk_error_issue(ierr,"iotk_unit_parent",__FILE__,__LINE__) -# 254 "iotk_unit.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.3 ") - return - end if - if(associated(this_son%parent)) then - call iotk_error_issue(ierr,"iotk_unit_parent",__FILE__,__LINE__) -# 258 "iotk_unit.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.3 ") - return - end if - this_parent%son => this_son - this_son%parent => this_parent -end subroutine iotk_unit_parent_x - -# 266 "iotk_unit.spp" -subroutine iotk_unit_get_x(unit,pointer) - use iotk_base - use iotk_misc_interf - use iotk_unit_list_module - implicit none - integer, intent(in) :: unit - type(iotk_unit), pointer :: pointer - if(.not. iotk_units_init) then - iotk_units_init = .true. - call iotk_unit_list_init(iotk_units) - end if - call iotk_unit_list_search(iotk_units,unit=unit,ptr=pointer) -end subroutine iotk_unit_get_x diff --git a/quantum_espresso/kcp/iotk/src/iotk_unit.spp b/quantum_espresso/kcp/iotk/src/iotk_unit.spp deleted file mode 100644 index 04b9aebbc..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_unit.spp +++ /dev/null @@ -1,279 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -> REVISION='$Revision: 1.1.1.1 $' -> REVISION="${REVISION//${dol}/}" - ->PROCEDURE=iotk_free_unit -subroutine iotk_free_unit_x(unit,ierr) - use iotk_base - use iotk_error_interf - implicit none -! This subroutine sets 'unit' to the number of -! an I/O unit which is free (i.e. not already opened). -! The search is carried out starting from unit -! 'unitmin' in a range of 'nsearch' units. -! The starting unit for the search is increased at each -! call, so that a number of subsequent ask can be done -! obtaining different units. - integer, intent(out) :: unit - integer, optional, intent(out) :: ierr - integer, save :: offset = 0 - logical :: opened,exist - integer :: isearch,nsearch,unitmin - integer :: ierrl - integer :: iostat - iostat = 0 - unitmin = iotk_unitmin - nsearch = iotk_unitmax - iotk_unitmin + 1 - ierrl = 0 - do isearch=0,nsearch-1 - unit = modulo(isearch+offset,nsearch) + unitmin - inquire(unit=unit,opened=opened,exist=exist,iostat=iostat) - if(iostat/=0) then - $(ERROR ierrl 'Error inquiring' unit iostat) - goto 1 - end if - if((.not.opened .and. exist) .or. iostat/=0) exit - end do - if(isearch>=nsearch) then - $(ERROR ierrl 'There are no units left' iotk_unitmin iotk_unitmax offset) - goto 1 - end if - offset = modulo(unit - unitmin + 1,nsearch) -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_free_unit_x - ->PROCEDURE=iotk_phys_unit -function iotk_phys_unit_x(unit) result(result) - use iotk_base - use iotk_unit_interf - use iotk_unit_list_module - implicit none - integer, intent(in) :: unit - integer :: result - type(iotk_unit), pointer :: this - result = unit - if(.not. iotk_units_init) then - iotk_units_init = .true. - call iotk_unit_list_init(iotk_units) - end if - call iotk_unit_get(unit,pointer=this) - if(.not.associated(this)) return - do - if(.not. associated(this%son)) exit - this => this%son - end do - result = this%unit -end function iotk_phys_unit_x - ->PROCEDURE=iotk_unit_print -subroutine iotk_unit_print_x(unit) - use iotk_base - use iotk_str_interf - implicit none - integer, intent(in) :: unit -! type (iotk_unit), pointer :: this -! stop -! this => iotk_units -! write(unit,"(a)") "IOTK units" -! do -! if(.not. associated(this)) exit -! write(unit,"(a,i8)") "Unit :",this%unit -! write(unit,"(a,a,a,i8)") "Root :",this%root(1:iotk_strlen_trim(this%root)),"Level:",this%level -! write(unit,"(a,l8)") "Raw :",this%raw -! if(associated(this%son)) then -! write(unit,"(a,i8)") "Son :",this%son%unit -! end if -! if(associated(this%parent)) then -! write(unit,"(a,i8)") "Parent :",this%parent%unit -! end if -!! this => this%next -! end do -! write(unit,"(a)") "end IOTK units" -end subroutine iotk_unit_print_x - - ->PROCEDURE=iotk_unit_add -subroutine iotk_unit_add_x(unit,this,ierr) - use iotk_base - use iotk_error_interf - use iotk_unit_list_module - implicit none - integer, intent(in) :: unit - type (iotk_unit), pointer :: this - integer, intent(out) :: ierr - ierr = 0 - if(.not. iotk_units_init) then - iotk_units_init = .true. - call iotk_unit_list_init(iotk_units) - end if - call iotk_unit_list_search(iotk_units,this,unit=unit) - if(associated(this)) then - $(ERROR ierr unit) - return - end if - call iotk_unit_list_add(iotk_units,this) - this%unit = unit - this%root = "" - this%skip_root = .false. - this%raw = .false. - this%level = 0 - this%close_at_end = .false. - nullify(this%son) - nullify(this%parent) -end subroutine iotk_unit_add_x - ->PROCEDURE=iotk_inquire -subroutine iotk_inquire_x(unit,binary,stream,ierr) - use iotk_base - use iotk_error_interf - use iotk_str_interf - use iotk_misc_interf - implicit none - integer, intent(in) :: unit - logical, intent(out) :: binary - logical, intent(out) :: stream - integer, intent(out) :: ierr - character(50) :: form,access,pad,blank - logical :: opened - integer :: iostat - iostat = 0 - ierr = 0 - inquire(unit=unit,form=form,iostat=iostat,access=access,pad=pad,blank=blank,opened=opened) - if(iostat/=0) then - $(ERROR ierr 'Error inquiring') - return - end if - if(opened .and. iotk_toupper(form)=="UNFORMATTED") then - binary = .true. - else - binary = .false. - end if - stream = .false. - if(opened) then - select case(iotk_toupper(access)) - case("SEQUENTIAL") - case("STREAM") - stream = .true. - case default - $(ERROR ierr 'Direct-access files are not allowed') - return - end select - end if - if(.not. binary) then - if(opened .and. iotk_toupper(blank)/="NULL") then - $(ERROR ierr) - return - end if - if(opened .and. iotk_toupper(pad) /="YES") then - $(ERROR ierr) - return - end if - end if -end subroutine iotk_inquire_x - ->PROCEDURE=iotk_unit_del -subroutine iotk_unit_del_x(unit,ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - use iotk_unit_list_module - implicit none - integer, intent(in) :: unit - integer, intent(out) :: ierr - type (iotk_unit), pointer :: this - ierr = 0 - if(.not. iotk_units_init) then - iotk_units_init = .true. - call iotk_unit_list_init(iotk_units) - end if - call iotk_unit_list_search(iotk_units,unit=unit,ptr=this) - if(.not.associated(this)) then - $(ERROR ierr) - return - end if - if(associated(this%parent)) nullify(this%parent%son) - call iotk_unit_list_del(iotk_units,ptr=this) -end subroutine iotk_unit_del_x - ->PROCEDURE=iotk_unit_parent -subroutine iotk_unit_parent_x(parent,son,ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: parent,son - integer, intent(out) :: ierr - type(iotk_unit), pointer :: this_parent,this_son - ierr = 0 - call iotk_unit_get(parent,pointer=this_parent) - if(.not.associated(this_parent)) then - $(ERROR ierr) - return - end if - call iotk_unit_get(son,pointer=this_son) - if(.not.associated(this_son)) then - $(ERROR ierr) - return - end if - if(associated(this_parent%son)) then - $(ERROR ierr) - return - end if - if(associated(this_son%parent)) then - $(ERROR ierr) - return - end if - this_parent%son => this_son - this_son%parent => this_parent -end subroutine iotk_unit_parent_x - ->PROCEDURE=iotk_unit_get -subroutine iotk_unit_get_x(unit,pointer) - use iotk_base - use iotk_misc_interf - use iotk_unit_list_module - implicit none - integer, intent(in) :: unit - type(iotk_unit), pointer :: pointer - if(.not. iotk_units_init) then - iotk_units_init = .true. - call iotk_unit_list_init(iotk_units) - end if - call iotk_unit_list_search(iotk_units,unit=unit,ptr=pointer) -end subroutine iotk_unit_get_x - diff --git a/quantum_espresso/kcp/iotk/src/iotk_unit_interf.f90 b/quantum_espresso/kcp/iotk/src/iotk_unit_interf.f90 deleted file mode 100644 index 69e39c3a9..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_unit_interf.f90 +++ /dev/null @@ -1,112 +0,0 @@ -# 1 "iotk_unit_interf.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_unit_interf.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_unit_interf.spp" - -module iotk_unit_interf -use iotk_base -implicit none -private - -public :: iotk_free_unit -public :: iotk_phys_unit -public :: iotk_unit_print -public :: iotk_unit_add -public :: iotk_inquire -public :: iotk_unit_del -public :: iotk_unit_parent -public :: iotk_unit_get - -! This module contains the interfaces to all iotk routines - -interface iotk_free_unit -subroutine iotk_free_unit_x(unit,ierr) - implicit none - integer, intent(out) :: unit - integer, optional, intent(out) :: ierr -end subroutine iotk_free_unit_x -end interface - -interface iotk_phys_unit -function iotk_phys_unit_x(unit) - implicit none - integer, intent(in) :: unit - integer :: iotk_phys_unit_x -end function iotk_phys_unit_x -end interface - -interface iotk_unit_print -subroutine iotk_unit_print_x(unit) - implicit none - integer, intent(in) :: unit -end subroutine iotk_unit_print_x -end interface - -interface iotk_unit_add -subroutine iotk_unit_add_x(unit,this,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - type(iotk_unit), pointer :: this - integer, intent(out) :: ierr -end subroutine iotk_unit_add_x -end interface - -interface iotk_inquire -subroutine iotk_inquire_x(unit,binary,stream,ierr) - implicit none - integer, intent(in) :: unit - logical, intent(out) :: binary - logical, intent(out) :: stream - integer, intent(out) :: ierr -end subroutine iotk_inquire_x -end interface - -interface iotk_unit_del -subroutine iotk_unit_del_x(unit,ierr) - implicit none - integer, intent(in) :: unit - integer, intent(out) :: ierr -end subroutine iotk_unit_del_x -end interface - -interface iotk_unit_parent -subroutine iotk_unit_parent_x(parent,son,ierr) - implicit none - integer, intent(in) :: parent,son - integer, intent(out) :: ierr -end subroutine iotk_unit_parent_x -end interface - -interface iotk_unit_get -subroutine iotk_unit_get_x(unit,pointer) - use iotk_base - implicit none - integer, intent(in) :: unit - type(iotk_unit), pointer :: pointer -end subroutine iotk_unit_get_x -end interface - -end module iotk_unit_interf diff --git a/quantum_espresso/kcp/iotk/src/iotk_unit_interf.spp b/quantum_espresso/kcp/iotk/src/iotk_unit_interf.spp deleted file mode 100644 index 9bed36fbb..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_unit_interf.spp +++ /dev/null @@ -1,116 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -module iotk_unit_interf -use iotk_base -implicit none -private - -public :: iotk_free_unit -public :: iotk_phys_unit -public :: iotk_unit_print -public :: iotk_unit_add -public :: iotk_inquire -public :: iotk_unit_del -public :: iotk_unit_parent -public :: iotk_unit_get - -! This module contains the interfaces to all iotk routines - -interface iotk_free_unit -subroutine iotk_free_unit_x(unit,ierr) - implicit none - integer, intent(out) :: unit - integer, optional, intent(out) :: ierr -end subroutine iotk_free_unit_x -end interface - -interface iotk_phys_unit -function iotk_phys_unit_x(unit) - implicit none - integer, intent(in) :: unit - integer :: iotk_phys_unit_x -end function iotk_phys_unit_x -end interface - -interface iotk_unit_print -subroutine iotk_unit_print_x(unit) - implicit none - integer, intent(in) :: unit -end subroutine iotk_unit_print_x -end interface - -interface iotk_unit_add -subroutine iotk_unit_add_x(unit,this,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - type(iotk_unit), pointer :: this - integer, intent(out) :: ierr -end subroutine iotk_unit_add_x -end interface - -interface iotk_inquire -subroutine iotk_inquire_x(unit,binary,stream,ierr) - implicit none - integer, intent(in) :: unit - logical, intent(out) :: binary - logical, intent(out) :: stream - integer, intent(out) :: ierr -end subroutine iotk_inquire_x -end interface - -interface iotk_unit_del -subroutine iotk_unit_del_x(unit,ierr) - implicit none - integer, intent(in) :: unit - integer, intent(out) :: ierr -end subroutine iotk_unit_del_x -end interface - -interface iotk_unit_parent -subroutine iotk_unit_parent_x(parent,son,ierr) - implicit none - integer, intent(in) :: parent,son - integer, intent(out) :: ierr -end subroutine iotk_unit_parent_x -end interface - -interface iotk_unit_get -subroutine iotk_unit_get_x(unit,pointer) - use iotk_base - implicit none - integer, intent(in) :: unit - type(iotk_unit), pointer :: pointer -end subroutine iotk_unit_get_x -end interface - -end module iotk_unit_interf - diff --git a/quantum_espresso/kcp/iotk/src/iotk_unit_list.f90 b/quantum_espresso/kcp/iotk/src/iotk_unit_list.f90 deleted file mode 100644 index 7dc78b1cc..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_unit_list.f90 +++ /dev/null @@ -1,218 +0,0 @@ -# 1 "iotk_unit_list.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 29 "iotk_unit_list.spp" -#include "iotk_auxmacros.h" -# 31 "iotk_unit_list.spp" - -module iotk_unit_list_module -use iotk_base -implicit none - -# 35 "iotk_unit_list.spp" -type iotk_unit_list -# 35 "iotk_unit_list.spp" - type (iotk_unit_list), pointer :: next -# 35 "iotk_unit_list.spp" - type (iotk_unit), pointer :: ptr -# 35 "iotk_unit_list.spp" -end type iotk_unit_list - -logical, save :: iotk_units_init = .false. -type(iotk_unit_list), save :: iotk_units - -contains - - -# 42 "iotk_unit_list.spp" -subroutine iotk_unit_list_init(list) -# 42 "iotk_unit_list.spp" - type (iotk_unit_list), intent(out) :: list -# 42 "iotk_unit_list.spp" - nullify(list%ptr) -# 42 "iotk_unit_list.spp" - nullify(list%next) -# 42 "iotk_unit_list.spp" -end subroutine iotk_unit_list_init -# 42 "iotk_unit_list.spp" - -# 42 "iotk_unit_list.spp" -subroutine iotk_unit_list_destroy(list) -# 42 "iotk_unit_list.spp" - type (iotk_unit_list), intent(inout) :: list -# 42 "iotk_unit_list.spp" - type (iotk_unit_list), pointer :: this,next -# 42 "iotk_unit_list.spp" - if(.not.associated(list%next)) return -# 42 "iotk_unit_list.spp" - this=>list%next -# 42 "iotk_unit_list.spp" - do -# 42 "iotk_unit_list.spp" - if(associated(this%ptr))deallocate(this%ptr) -# 42 "iotk_unit_list.spp" - next=>this%next -# 42 "iotk_unit_list.spp" - deallocate(this) -# 42 "iotk_unit_list.spp" - if(.not.associated(next)) exit -# 42 "iotk_unit_list.spp" - this=>next -# 42 "iotk_unit_list.spp" - end do -# 42 "iotk_unit_list.spp" -end subroutine iotk_unit_list_destroy -# 42 "iotk_unit_list.spp" - -# 42 "iotk_unit_list.spp" -subroutine iotk_unit_list_add(list,ptr) -# 42 "iotk_unit_list.spp" - type (iotk_unit_list), intent(inout) :: list -# 42 "iotk_unit_list.spp" - type (iotk_unit), pointer :: ptr -# 42 "iotk_unit_list.spp" - type (iotk_unit_list), pointer :: this -# 42 "iotk_unit_list.spp" - allocate(this) -# 42 "iotk_unit_list.spp" - this%next => list%next -# 42 "iotk_unit_list.spp" - list%next => this -# 42 "iotk_unit_list.spp" - allocate(this%ptr) -# 42 "iotk_unit_list.spp" - ptr => this%ptr -# 42 "iotk_unit_list.spp" -end subroutine iotk_unit_list_add -# 42 "iotk_unit_list.spp" - -# 42 "iotk_unit_list.spp" -subroutine iotk_unit_list_del(list,ptr) -# 42 "iotk_unit_list.spp" - type (iotk_unit_list), intent(inout) :: list -# 42 "iotk_unit_list.spp" - type (iotk_unit), pointer :: ptr -# 42 "iotk_unit_list.spp" - type (iotk_unit_list), pointer :: this,next_save -# 42 "iotk_unit_list.spp" - if(.not.associated(list%next)) return -# 42 "iotk_unit_list.spp" - if(associated(list%next%ptr,ptr)) then -# 42 "iotk_unit_list.spp" - deallocate(list%next%ptr) -# 42 "iotk_unit_list.spp" - next_save => list%next%next -# 42 "iotk_unit_list.spp" - deallocate(list%next) -# 42 "iotk_unit_list.spp" - list%next => next_save -# 42 "iotk_unit_list.spp" - nullify(ptr) -# 42 "iotk_unit_list.spp" - return -# 42 "iotk_unit_list.spp" - end if -# 42 "iotk_unit_list.spp" - this => list%next -# 42 "iotk_unit_list.spp" - do -# 42 "iotk_unit_list.spp" - if(.not.associated(this%next)) return -# 42 "iotk_unit_list.spp" - if(associated(this%next%ptr,ptr)) exit -# 42 "iotk_unit_list.spp" - this => this%next -# 42 "iotk_unit_list.spp" - end do -# 42 "iotk_unit_list.spp" - deallocate(this%next%ptr) -# 42 "iotk_unit_list.spp" - next_save => this%next%next -# 42 "iotk_unit_list.spp" - deallocate(this%next) -# 42 "iotk_unit_list.spp" - this%next => next_save -# 42 "iotk_unit_list.spp" - nullify(ptr) -# 42 "iotk_unit_list.spp" -end subroutine iotk_unit_list_del -# 42 "iotk_unit_list.spp" - -# 42 "iotk_unit_list.spp" - -# 42 "iotk_unit_list.spp" - subroutine iotk_unit_list_search(list,ptr,unit) -# 42 "iotk_unit_list.spp" - type (iotk_unit_list), intent(in) :: list -# 42 "iotk_unit_list.spp" - type (iotk_unit), pointer :: ptr -# 42 "iotk_unit_list.spp" - -# 42 "iotk_unit_list.spp" - integer, optional,intent(in) :: unit -# 42 "iotk_unit_list.spp" - -# 42 "iotk_unit_list.spp" - type (iotk_unit_list), pointer :: this -# 42 "iotk_unit_list.spp" - nullify(ptr) -# 42 "iotk_unit_list.spp" - this => list%next -# 42 "iotk_unit_list.spp" - if(.not.associated(this)) return -# 42 "iotk_unit_list.spp" - do -# 42 "iotk_unit_list.spp" - if(.not.associated(this%ptr)) goto 1000 -# 42 "iotk_unit_list.spp" - -# 42 "iotk_unit_list.spp" - -# 42 "iotk_unit_list.spp" - if(present(unit)) then -# 42 "iotk_unit_list.spp" - if(this%ptr%unit /= unit) goto 1000 -# 42 "iotk_unit_list.spp" - end if -# 42 "iotk_unit_list.spp" - -# 42 "iotk_unit_list.spp" - -# 42 "iotk_unit_list.spp" - ptr => this%ptr -# 42 "iotk_unit_list.spp" - exit -# 42 "iotk_unit_list.spp" -1000 continue -# 42 "iotk_unit_list.spp" - if(.not.associated(this%next)) exit -# 42 "iotk_unit_list.spp" - this => this%next -# 42 "iotk_unit_list.spp" - end do -# 42 "iotk_unit_list.spp" - end subroutine iotk_unit_list_search -# 42 "iotk_unit_list.spp" - - -end module iotk_unit_list_module diff --git a/quantum_espresso/kcp/iotk/src/iotk_unit_list.spp b/quantum_espresso/kcp/iotk/src/iotk_unit_list.spp deleted file mode 100644 index 3cc0fda03..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_unit_list.spp +++ /dev/null @@ -1,45 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->include iotk_list.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -module iotk_unit_list_module -use iotk_base -implicit none -$(LIST_TYPE --type=iotk_unit) - -logical, save :: iotk_units_init = .false. -type(iotk_unit_list), save :: iotk_units - -contains - -$(LIST_IMPLEMENTATION --type=iotk_unit --search=integer::unit) - -end module iotk_unit_list_module - diff --git a/quantum_espresso/kcp/iotk/src/iotk_write.f90 b/quantum_espresso/kcp/iotk/src/iotk_write.f90 deleted file mode 100644 index 13a85ba7d..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_write.f90 +++ /dev/null @@ -1,526 +0,0 @@ -# 1 "iotk_write.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_write.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_write.spp" - -# 33 "iotk_write.spp" - -# 35 "iotk_write.spp" -subroutine iotk_write_begin_x(unit,name,attr,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - use iotk_write_interf - use iotk_str_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - character(*), optional, intent(in) :: attr - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr - character(iotk_taglenx) :: tag - character(iotk_attlenx) :: attrl - type(iotk_unit), pointer :: this_unit - integer :: indent - logical :: binary,stream - integer :: ierrl,lunit,iostat - ierrl = 0 - iostat = 0 - lunit = iotk_phys_unit(unit) - ierrl=0 - indent=0 - call iotk_unit_get(lunit,pointer=this_unit) - if(associated(this_unit)) then - if(this_unit%raw) goto 1 - end if - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_begin",__FILE__,__LINE__) -# 64 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 64 "iotk_write.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 64 "iotk_write.spp" -call iotk_error_write(ierrl,"name",name) - goto 1 - end if - attrl(1:1)=iotk_eos - if(present(attr)) then - call iotk_strcpy(attrl,attr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_begin",__FILE__,__LINE__) -# 71 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - call iotk_strcpy(tag,iotk_strtrim(name),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_begin",__FILE__,__LINE__) -# 77 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcat(tag,attrl,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_begin",__FILE__,__LINE__) -# 82 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_begin",__FILE__,__LINE__) -# 87 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(associated(this_unit)) indent = iotk_indent*(this_unit%level+1) - call iotk_write_tag(lunit,1,tag,binary,indent,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_begin",__FILE__,__LINE__) -# 93 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 93 "iotk_write.spp" -call iotk_error_msg(ierrl,'Error writing tag') -# 93 "iotk_write.spp" -call iotk_error_write(ierrl,"name",name) - goto 1 - end if -1 continue - if(ierrl==0 .and. associated(this_unit)) then - this_unit%level = this_unit%level + 1 - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_begin_x - -# 108 "iotk_write.spp" -subroutine iotk_write_end_x(unit,name,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_files_interf - use iotk_write_interf - use iotk_misc_interf - use iotk_str_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr - character(iotk_taglenx) :: tag - logical :: binary,stream - integer :: ierrl,lunit,indent - type(iotk_unit), pointer :: this_unit - ierrl = 0 - lunit = iotk_phys_unit(unit) - ierrl=0 - indent=0 - call iotk_unit_get(lunit,pointer=this_unit) - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_end",__FILE__,__LINE__) -# 131 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 131 "iotk_write.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 131 "iotk_write.spp" -call iotk_error_write(ierrl,"name",iotk_strtrim(name)) - goto 1 - end if - call iotk_strcpy(tag,iotk_strtrim(name),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_end",__FILE__,__LINE__) -# 136 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(associated(this_unit)) then - if(this_unit%raw) goto 2 - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_end",__FILE__,__LINE__) -# 144 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(associated(this_unit)) indent = iotk_indent * this_unit%level - call iotk_write_tag(lunit,2,tag,binary,indent,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_end",__FILE__,__LINE__) -# 150 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -2 continue - if(ierrl==0 .and. associated(this_unit)) then - this_unit%level = this_unit%level - 1 - end if - if(associated(this_unit) .and. unit/=lunit) then - if(associated(this_unit%parent) .and. this_unit%level == -1 .and. this_unit%skip_root) then - call iotk_close_write(lunit,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_end",__FILE__,__LINE__) -# 161 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this_unit) - if(.not.associated(this_unit)) then - call iotk_error_issue(ierrl,"iotk_write_end",__FILE__,__LINE__) -# 167 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_end_x - -# 181 "iotk_write.spp" -subroutine iotk_write_pi_x(unit,name,attr,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_write_interf - use iotk_misc_interf - use iotk_str_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - character(*), optional, intent(in) :: attr - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr - character(iotk_taglenx) :: tag - character(iotk_attlenx) :: attrl - logical :: binary,stream - integer :: ierrl,lunit,indent - type(iotk_unit), pointer :: this_unit - ierrl = 0 - lunit = iotk_phys_unit(unit) - ierrl=0 - indent=0 - call iotk_unit_get(lunit,pointer=this_unit) - if(associated(this_unit)) then - if(this_unit%raw) goto 1 - end if - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_pi",__FILE__,__LINE__) -# 208 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 208 "iotk_write.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 208 "iotk_write.spp" -call iotk_error_write(ierrl,"name",iotk_strtrim(name)) - goto 1 - end if - attrl(1:1)=iotk_eos - if(present(attr)) then - call iotk_strcpy(attrl,attr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_pi",__FILE__,__LINE__) -# 215 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - call iotk_strcpy(tag,iotk_strtrim(name),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_pi",__FILE__,__LINE__) -# 221 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcat(tag,attrl,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_pi",__FILE__,__LINE__) -# 226 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_pi",__FILE__,__LINE__) -# 231 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(associated(this_unit)) indent = iotk_indent*(this_unit%level+1) - call iotk_write_tag(lunit,5,tag,binary,indent,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_pi",__FILE__,__LINE__) -# 237 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_pi_x - -# 249 "iotk_write.spp" -subroutine iotk_write_comment_x(unit,text,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_write_interf - use iotk_misc_interf - use iotk_str_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: text - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit - integer :: indent - logical :: binary,stream - character(iotk_taglenx) :: tag - type(iotk_unit), pointer :: this - ierrl = 0 - lunit = iotk_phys_unit(unit) - ierrl=0 - indent = 0 - call iotk_unit_get(lunit,pointer=this) - if(associated(this)) then - if(this%raw) goto 1 - end if - call iotk_deescape(tag,text) - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_comment",__FILE__,__LINE__) -# 277 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(associated(this)) indent = iotk_indent*(this%level+1) - call iotk_write_tag(lunit,4,tag,binary,indent,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_comment",__FILE__,__LINE__) -# 283 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_comment_x - -# 295 "iotk_write.spp" -subroutine iotk_write_empty_x(unit,name,attr,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_write_interf - use iotk_misc_interf - use iotk_str_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - character(*), optional, intent(in) :: attr - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr - character(iotk_taglenx) :: tag - character(iotk_attlenx) :: attrl - type(iotk_unit), pointer :: this_unit - logical :: binary,stream - integer :: ierrl,lunit,indent - indent = 0 - ierrl = 0 - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this_unit) - if(associated(this_unit)) then - if(this_unit%raw) goto 1 - end if - if(.not.iotk_check_name(name)) then - call iotk_error_issue(ierrl,"iotk_write_empty",__FILE__,__LINE__) -# 321 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") -# 321 "iotk_write.spp" -call iotk_error_msg(ierrl,'Wrong tag name') -# 321 "iotk_write.spp" -call iotk_error_write(ierrl,"name",trim(name)) - goto 1 - end if - attrl(1:1)=iotk_eos - if(present(attr)) then - call iotk_strcpy(attrl,attr,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_empty",__FILE__,__LINE__) -# 328 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - end if - call iotk_strcpy(tag,iotk_strtrim(name),ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_empty",__FILE__,__LINE__) -# 334 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_strcat(tag,attrl,ierr=ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_empty",__FILE__,__LINE__) -# 339 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_empty",__FILE__,__LINE__) -# 344 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if - if(associated(this_unit)) indent = iotk_indent*(this_unit%level+1) - call iotk_write_tag(lunit,3,tag,binary,indent,ierrl) - if(ierrl/=0) then - call iotk_error_issue(ierrl,"iotk_write_empty",__FILE__,__LINE__) -# 350 "iotk_write.spp" -call iotk_error_msg(ierrl,"CVS Revision: 1.5 ") - goto 1 - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_empty_x - -# 362 "iotk_write.spp" -subroutine iotk_write_tag_x(unit,control,tag,binary,indent,ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - use iotk_str_interf - implicit none - integer, intent(in) :: unit - integer, intent(in) :: control - character(iotk_taglenx), intent(in) :: tag - logical, intent(in) :: binary - integer, intent(in) :: indent - integer, intent(out) :: ierr - integer(iotk_header_kind) :: header,header2 - integer :: taglen,taglenp - integer :: iostat,pos1,pos2 - integer :: lindent - integer :: mannl, lname - character(iotk_linlenx), parameter :: indentstr="" - character(4) :: begin,end - lindent = min(len(indentstr),indent,iotk_maxindent) - iostat = 0 - ierr = 0 - taglen = iotk_strlen(tag) - select case(control) - case(1) - begin = "<" - end = ">" - case(2) - begin = "" - case(3) - begin = "<" - end = "/>" - case(4) - begin = "" - case(5) - begin = "" - end select - if(binary) then - taglenp = taglen + len_trim(begin) + len_trim(end) + 2 + lindent - header = control + taglenp*(iotk_ncontrol+1) - header2 = 128 + taglenp*(iotk_ncontrol+1) -! taglenp is the TOTAL length (including tag delimiters and newlines) - write(unit,iostat=iostat) header - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_write_tag",__FILE__,__LINE__) -# 409 "iotk_write.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 409 "iotk_write.spp" -call iotk_error_msg(ierr,'error writing the header record') -# 409 "iotk_write.spp" -call iotk_error_write(ierr,"iostat",iostat) - end if - write(unit,iostat=iostat) header2,iotk_newline//indentstr(1:lindent)// & - trim(begin)//tag(1:taglen)//trim(end)//iotk_newline - else - pos1=0 - lname = min(lindent+1+scan(tag," "),len(indentstr)) - write(unit,"(a)",iostat=iostat,advance="no") indentstr(1:lindent)//trim(begin) - do - if(pos1+iotk_linlen >= taglen ) then - pos2 = taglen+1 - else - pos2 = pos1 + scan(tag(pos1+1:pos1+iotk_linlen)," ",back=.true.) - if(pos2<=pos1) then - pos2 = pos1+iotk_linlen + scan(tag(pos1+iotk_linlen+1:taglen)," ") - if(pos2<=pos1+iotk_linlen) pos2=taglen+1 - end if - end if - ! Look for a manual newline between pos1 and pos2 - mannl = scan(tag(pos1+1:pos2-1),iotk_newline) - if ( mannl > 0 ) then - pos2 = pos1+mannl+1 - write(unit,"(a)",iostat=iostat,advance="no") & - tag(pos1+1:pos2-1)//indentstr(1:lname) - else - write(unit,"(a)",iostat=iostat,advance="no") tag(pos1+1:pos2-1) - endif - pos1=pos2 - if(pos1>taglen) exit - if(mannl>0) cycle - write(unit,*,iostat=iostat) - end do - write(unit,"(a)",iostat=iostat) trim(end) - end if - if(iostat/=0) then - call iotk_error_issue(ierr,"iotk_write_tag",__FILE__,__LINE__) -# 444 "iotk_write.spp" -call iotk_error_msg(ierr,"CVS Revision: 1.5 ") -# 444 "iotk_write.spp" -call iotk_error_msg(ierr,'error writing') -# 444 "iotk_write.spp" -call iotk_error_write(ierr,"iostat",iostat) - end if -end subroutine iotk_write_tag_x diff --git a/quantum_espresso/kcp/iotk/src/iotk_write.spp b/quantum_espresso/kcp/iotk/src/iotk_write.spp deleted file mode 100644 index 22e3ff6d2..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_write.spp +++ /dev/null @@ -1,447 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -> REVISION='$Revision: 1.1.1.1 $' -> REVISION="${REVISION//${dol}/}" - ->PROCEDURE="iotk_write_begin" -subroutine iotk_write_begin_x(unit,name,attr,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - use iotk_write_interf - use iotk_str_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - character(*), optional, intent(in) :: attr - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr - character(iotk_taglenx) :: tag - character(iotk_attlenx) :: attrl - type(iotk_unit), pointer :: this_unit - integer :: indent - logical :: binary,stream - integer :: ierrl,lunit,iostat - ierrl = 0 - iostat = 0 - lunit = iotk_phys_unit(unit) - ierrl=0 - indent=0 - call iotk_unit_get(lunit,pointer=this_unit) - if(associated(this_unit)) then - if(this_unit%raw) goto 1 - end if - if(.not.iotk_check_name(name)) then - $(ERROR ierrl 'Wrong tag name' name) - goto 1 - end if - attrl(1:1)=iotk_eos - if(present(attr)) then - call iotk_strcpy(attrl,attr,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - call iotk_strcpy(tag,iotk_strtrim(name),ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_strcat(tag,attrl,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(associated(this_unit)) indent = iotk_indent*(this_unit%level+1) - call iotk_write_tag(lunit,1,tag,binary,indent,ierrl) - if(ierrl/=0) then - $(ERROR ierrl 'Error writing tag' name) - goto 1 - end if -1 continue - if(ierrl==0 .and. associated(this_unit)) then - this_unit%level = this_unit%level + 1 - end if - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_begin_x - ->PROCEDURE="iotk_write_end" -subroutine iotk_write_end_x(unit,name,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_files_interf - use iotk_write_interf - use iotk_misc_interf - use iotk_str_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr - character(iotk_taglenx) :: tag - logical :: binary,stream - integer :: ierrl,lunit,indent - type(iotk_unit), pointer :: this_unit - ierrl = 0 - lunit = iotk_phys_unit(unit) - ierrl=0 - indent=0 - call iotk_unit_get(lunit,pointer=this_unit) - if(.not.iotk_check_name(name)) then - $(ERROR ierrl 'Wrong tag name' name='iotk_strtrim(name)') - goto 1 - end if - call iotk_strcpy(tag,iotk_strtrim(name),ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(associated(this_unit)) then - if(this_unit%raw) goto 2 - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(associated(this_unit)) indent = iotk_indent * this_unit%level - call iotk_write_tag(lunit,2,tag,binary,indent,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if -2 continue - if(ierrl==0 .and. associated(this_unit)) then - this_unit%level = this_unit%level - 1 - end if - if(associated(this_unit) .and. unit/=lunit) then - if(associated(this_unit%parent) .and. this_unit%level == -1 .and. this_unit%skip_root) then - call iotk_close_write(lunit,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this_unit) - if(.not.associated(this_unit)) then - $(ERROR ierrl) - goto 1 - end if - end if - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_end_x - ->PROCEDURE="iotk_write_pi" -subroutine iotk_write_pi_x(unit,name,attr,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_write_interf - use iotk_misc_interf - use iotk_str_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - character(*), optional, intent(in) :: attr - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr - character(iotk_taglenx) :: tag - character(iotk_attlenx) :: attrl - logical :: binary,stream - integer :: ierrl,lunit,indent - type(iotk_unit), pointer :: this_unit - ierrl = 0 - lunit = iotk_phys_unit(unit) - ierrl=0 - indent=0 - call iotk_unit_get(lunit,pointer=this_unit) - if(associated(this_unit)) then - if(this_unit%raw) goto 1 - end if - if(.not.iotk_check_name(name)) then - $(ERROR ierrl 'Wrong tag name' name='iotk_strtrim(name)') - goto 1 - end if - attrl(1:1)=iotk_eos - if(present(attr)) then - call iotk_strcpy(attrl,attr,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - call iotk_strcpy(tag,iotk_strtrim(name),ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_strcat(tag,attrl,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(associated(this_unit)) indent = iotk_indent*(this_unit%level+1) - call iotk_write_tag(lunit,5,tag,binary,indent,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_pi_x - ->PROCEDURE=iotk_write_comment -subroutine iotk_write_comment_x(unit,text,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_write_interf - use iotk_misc_interf - use iotk_str_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: text - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr - integer :: ierrl,lunit - integer :: indent - logical :: binary,stream - character(iotk_taglenx) :: tag - type(iotk_unit), pointer :: this - ierrl = 0 - lunit = iotk_phys_unit(unit) - ierrl=0 - indent = 0 - call iotk_unit_get(lunit,pointer=this) - if(associated(this)) then - if(this%raw) goto 1 - end if - call iotk_deescape(tag,text) - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(associated(this)) indent = iotk_indent*(this%level+1) - call iotk_write_tag(lunit,4,tag,binary,indent,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_comment_x - ->PROCEDURE="iotk_write_empty" -subroutine iotk_write_empty_x(unit,name,attr,dummy,ierr) - use iotk_base - use iotk_error_interf - use iotk_write_interf - use iotk_misc_interf - use iotk_str_interf - use iotk_unit_interf - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - character(*), optional, intent(in) :: attr - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr - character(iotk_taglenx) :: tag - character(iotk_attlenx) :: attrl - type(iotk_unit), pointer :: this_unit - logical :: binary,stream - integer :: ierrl,lunit,indent - indent = 0 - ierrl = 0 - lunit = iotk_phys_unit(unit) - call iotk_unit_get(lunit,pointer=this_unit) - if(associated(this_unit)) then - if(this_unit%raw) goto 1 - end if - if(.not.iotk_check_name(name)) then - $(ERROR ierrl 'Wrong tag name' name='trim(name)') - goto 1 - end if - attrl(1:1)=iotk_eos - if(present(attr)) then - call iotk_strcpy(attrl,attr,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - end if - call iotk_strcpy(tag,iotk_strtrim(name),ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_strcat(tag,attrl,ierr=ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - call iotk_inquire(lunit,binary,stream,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if - if(associated(this_unit)) indent = iotk_indent*(this_unit%level+1) - call iotk_write_tag(lunit,3,tag,binary,indent,ierrl) - if(ierrl/=0) then - $(ERROR ierrl) - goto 1 - end if -1 continue - if(present(ierr)) then - ierr = ierrl - else - if(ierrl/=0) call iotk_error_handler(ierrl) - end if -end subroutine iotk_write_empty_x - ->PROCEDURE=iotk_write_tag -subroutine iotk_write_tag_x(unit,control,tag,binary,indent,ierr) - use iotk_base - use iotk_error_interf - use iotk_misc_interf - use iotk_str_interf - implicit none - integer, intent(in) :: unit - integer, intent(in) :: control - character(iotk_taglenx), intent(in) :: tag - logical, intent(in) :: binary - integer, intent(in) :: indent - integer, intent(out) :: ierr - integer(iotk_header_kind) :: header,header2 - integer :: taglen,taglenp - integer :: iostat,pos1,pos2 - integer :: lindent - integer :: mannl, lname - character(iotk_linlenx), parameter :: indentstr="" - character(4) :: begin,end - lindent = min(len(indentstr),indent,iotk_maxindent) - iostat = 0 - ierr = 0 - taglen = iotk_strlen(tag) - select case(control) - case(1) - begin = "<" - end = ">" - case(2) - begin = "" - case(3) - begin = "<" - end = "/>" - case(4) - begin = "" - case(5) - begin = "" - end select - if(binary) then - taglenp = taglen + len_trim(begin) + len_trim(end) + 2 + lindent - header = control + taglenp*(iotk_ncontrol+1) - header2 = 128 + taglenp*(iotk_ncontrol+1) -! taglenp is the TOTAL length (including tag delimiters and newlines) - write(unit,iostat=iostat) header - if(iostat/=0) then - $(ERROR ierr 'error writing the header record' iostat) - end if - write(unit,iostat=iostat) header2,iotk_newline//indentstr(1:lindent)// & - trim(begin)//tag(1:taglen)//trim(end)//iotk_newline - else - pos1=0 - lname = min(lindent+1+scan(tag," "),len(indentstr)) - write(unit,"(a)",iostat=iostat,advance="no") indentstr(1:lindent)//trim(begin) - do - if(pos1+iotk_linlen >= taglen ) then - pos2 = taglen+1 - else - pos2 = pos1 + scan(tag(pos1+1:pos1+iotk_linlen)," ",back=.true.) - if(pos2<=pos1) then - pos2 = pos1+iotk_linlen + scan(tag(pos1+iotk_linlen+1:taglen)," ") - if(pos2<=pos1+iotk_linlen) pos2=taglen+1 - end if - end if - ! Look for a manual newline between pos1 and pos2 - mannl = scan(tag(pos1+1:pos2-1),iotk_newline) - if ( mannl > 0 ) then - pos2 = pos1+mannl+1 - write(unit,"(a)",iostat=iostat,advance="no") & - tag(pos1+1:pos2-1)//indentstr(1:lname) - else - write(unit,"(a)",iostat=iostat,advance="no") tag(pos1+1:pos2-1) - endif - pos1=pos2 - if(pos1>taglen) exit - if(mannl>0) cycle - write(unit,*,iostat=iostat) - end do - write(unit,"(a)",iostat=iostat) trim(end) - end if - if(iostat/=0) then - $(ERROR ierr 'error writing' iostat) - end if -end subroutine iotk_write_tag_x - diff --git a/quantum_espresso/kcp/iotk/src/iotk_write_interf.f90 b/quantum_espresso/kcp/iotk/src/iotk_write_interf.f90 deleted file mode 100644 index 07068b82c..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_write_interf.f90 +++ /dev/null @@ -1,110 +0,0 @@ -# 1 "iotk_write_interf.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_write_interf.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_write_interf.spp" - -module iotk_write_interf -implicit none -private - -public :: iotk_write_begin -public :: iotk_write_end -public :: iotk_write_pi -public :: iotk_write_comment -public :: iotk_write_empty -public :: iotk_write_tag - -interface iotk_write_begin -subroutine iotk_write_begin_x(unit,name,attr,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name - character(len=*), optional, intent(in) :: attr - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_write_begin_x -end interface - -interface iotk_write_end -subroutine iotk_write_end_x(unit,name,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_write_end_x -end interface - -interface iotk_write_pi -subroutine iotk_write_pi_x(unit,name,attr,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name - character(len=*), optional, intent(in) :: attr - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_write_pi_x -end interface - -interface iotk_write_comment -subroutine iotk_write_comment_x(unit,text,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: text - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_write_comment_x -end interface - -interface iotk_write_empty -subroutine iotk_write_empty_x(unit,name,attr,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - character(*), optional, intent(in) :: attr - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_write_empty_x -end interface - -interface iotk_write_tag -subroutine iotk_write_tag_x(unit,control,tag,binary,indent,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer, intent(in) :: control - character(iotk_taglenx), intent(in) :: tag - logical, intent(in) :: binary - integer, intent(in) :: indent - integer, intent(out) :: ierr -end subroutine iotk_write_tag_x -end interface - -end module iotk_write_interf diff --git a/quantum_espresso/kcp/iotk/src/iotk_write_interf.spp b/quantum_espresso/kcp/iotk/src/iotk_write_interf.spp deleted file mode 100644 index d4e1f0998..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_write_interf.spp +++ /dev/null @@ -1,113 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion if the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion if the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -module iotk_write_interf -implicit none -private - -public :: iotk_write_begin -public :: iotk_write_end -public :: iotk_write_pi -public :: iotk_write_comment -public :: iotk_write_empty -public :: iotk_write_tag - -interface iotk_write_begin -subroutine iotk_write_begin_x(unit,name,attr,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name - character(len=*), optional, intent(in) :: attr - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_write_begin_x -end interface - -interface iotk_write_end -subroutine iotk_write_end_x(unit,name,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_write_end_x -end interface - -interface iotk_write_pi -subroutine iotk_write_pi_x(unit,name,attr,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(len=*), intent(in) :: name - character(len=*), optional, intent(in) :: attr - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_write_pi_x -end interface - -interface iotk_write_comment -subroutine iotk_write_comment_x(unit,text,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: text - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_write_comment_x -end interface - -interface iotk_write_empty -subroutine iotk_write_empty_x(unit,name,attr,dummy,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - character(*), intent(in) :: name - character(*), optional, intent(in) :: attr - type(iotk_dummytype), optional :: dummy - integer, optional, intent(out) :: ierr -end subroutine iotk_write_empty_x -end interface - -interface iotk_write_tag -subroutine iotk_write_tag_x(unit,control,tag,binary,indent,ierr) - use iotk_base - implicit none - integer, intent(in) :: unit - integer, intent(in) :: control - character(iotk_taglenx), intent(in) :: tag - logical, intent(in) :: binary - integer, intent(in) :: indent - integer, intent(out) :: ierr -end subroutine iotk_write_tag_x -end interface - -end module iotk_write_interf diff --git a/quantum_espresso/kcp/iotk/src/iotk_xtox.f90 b/quantum_espresso/kcp/iotk/src/iotk_xtox.f90 deleted file mode 100644 index de9873054..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_xtox.f90 +++ /dev/null @@ -1,471 +0,0 @@ -# 1 "iotk_xtox.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_xtox.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_xtox.spp" - -# 33 "iotk_xtox.spp" - -# 35 "iotk_xtox.spp" -function iotk_atol_x(a,check) - use iotk_base - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: a - logical, optional, intent(out) :: check - logical :: iotk_atol_x - integer :: i - iotk_atol_x = .false. - if(present(check)) check = .false. - if(len(a)==0) return - do i = 1 , len(a) - if(a(i:i)/=" " .and. a(i:i)/=".") exit - end do - if(i>len(a)) return - if(present(check)) check = .true. - if(a(i:i)=="T" .or. a(i:i)=="t") then - iotk_atol_x = .true. - else if(a(i:i)=="F" .or. a(i:i)=="f") then - iotk_atol_x = .false. - else - if(present(check)) check = .false. - end if -end function iotk_atol_x - -# 61 "iotk_xtox.spp" -#ifdef __IOTK_INTEGER1 -subroutine iotk_atoi1(i,a,check) - use iotk_base - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_integer1 - integer(kind=this_kind), intent(out) :: i - character(len=*), intent(in) :: a - logical, optional, intent(out) :: check - logical :: minus - integer :: pos,ii - integer(kind=this_kind) :: j - integer :: index -#ifdef __IOTK_WORKAROUND5 - integer(kind=this_kind) :: limit(0:9) - integer(kind=this_kind) :: hug - hug = huge(j) - limit(0:9) = (/ ((hug-j)/10,j=0,9) /) -#else - integer(kind=this_kind), parameter :: limit(0:9) = (/ ((huge(j)-j)/10_this_kind,j=0,9) /) -#endif - minus = .false. - i = 0 - if(present(check)) check = .false. - if(len(a)==0) return - do ii = 1 , len(a) - if(a(ii:ii)/=" ") exit - end do - if(ii>len(a)) return - if(a(ii:ii)=="-") then - minus = .true. - ii = ii + 1 - else if(a(ii:ii)=="+") then - ii = ii + 1 - end if - if(ii>len(a)) return - pos = ii - do ii=pos,len(a) - index = int( iachar(a(ii:ii)) - iachar("0") ) - if(index<0 .or. index>9) exit - if(i>limit(index)) exit ! Check sull'overflow - i = i*10_this_kind + int(index,kind=this_kind) - end do - if(minus) i = - i - if(present(check)) then - pos = ii - do ii=pos,len(a) - if(a(ii:ii)/=" ") return - end do - check = .true. - end if -end subroutine iotk_atoi1 -#endif -# 61 "iotk_xtox.spp" -#ifdef __IOTK_INTEGER2 -subroutine iotk_atoi2(i,a,check) - use iotk_base - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_integer2 - integer(kind=this_kind), intent(out) :: i - character(len=*), intent(in) :: a - logical, optional, intent(out) :: check - logical :: minus - integer :: pos,ii - integer(kind=this_kind) :: j - integer :: index -#ifdef __IOTK_WORKAROUND5 - integer(kind=this_kind) :: limit(0:9) - integer(kind=this_kind) :: hug - hug = huge(j) - limit(0:9) = (/ ((hug-j)/10,j=0,9) /) -#else - integer(kind=this_kind), parameter :: limit(0:9) = (/ ((huge(j)-j)/10_this_kind,j=0,9) /) -#endif - minus = .false. - i = 0 - if(present(check)) check = .false. - if(len(a)==0) return - do ii = 1 , len(a) - if(a(ii:ii)/=" ") exit - end do - if(ii>len(a)) return - if(a(ii:ii)=="-") then - minus = .true. - ii = ii + 1 - else if(a(ii:ii)=="+") then - ii = ii + 1 - end if - if(ii>len(a)) return - pos = ii - do ii=pos,len(a) - index = int( iachar(a(ii:ii)) - iachar("0") ) - if(index<0 .or. index>9) exit - if(i>limit(index)) exit ! Check sull'overflow - i = i*10_this_kind + int(index,kind=this_kind) - end do - if(minus) i = - i - if(present(check)) then - pos = ii - do ii=pos,len(a) - if(a(ii:ii)/=" ") return - end do - check = .true. - end if -end subroutine iotk_atoi2 -#endif -# 61 "iotk_xtox.spp" -#ifdef __IOTK_INTEGER3 -subroutine iotk_atoi3(i,a,check) - use iotk_base - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_integer3 - integer(kind=this_kind), intent(out) :: i - character(len=*), intent(in) :: a - logical, optional, intent(out) :: check - logical :: minus - integer :: pos,ii - integer(kind=this_kind) :: j - integer :: index -#ifdef __IOTK_WORKAROUND5 - integer(kind=this_kind) :: limit(0:9) - integer(kind=this_kind) :: hug - hug = huge(j) - limit(0:9) = (/ ((hug-j)/10,j=0,9) /) -#else - integer(kind=this_kind), parameter :: limit(0:9) = (/ ((huge(j)-j)/10_this_kind,j=0,9) /) -#endif - minus = .false. - i = 0 - if(present(check)) check = .false. - if(len(a)==0) return - do ii = 1 , len(a) - if(a(ii:ii)/=" ") exit - end do - if(ii>len(a)) return - if(a(ii:ii)=="-") then - minus = .true. - ii = ii + 1 - else if(a(ii:ii)=="+") then - ii = ii + 1 - end if - if(ii>len(a)) return - pos = ii - do ii=pos,len(a) - index = int( iachar(a(ii:ii)) - iachar("0") ) - if(index<0 .or. index>9) exit - if(i>limit(index)) exit ! Check sull'overflow - i = i*10_this_kind + int(index,kind=this_kind) - end do - if(minus) i = - i - if(present(check)) then - pos = ii - do ii=pos,len(a) - if(a(ii:ii)/=" ") return - end do - check = .true. - end if -end subroutine iotk_atoi3 -#endif -# 61 "iotk_xtox.spp" -#ifdef __IOTK_INTEGER4 -subroutine iotk_atoi4(i,a,check) - use iotk_base - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_integer4 - integer(kind=this_kind), intent(out) :: i - character(len=*), intent(in) :: a - logical, optional, intent(out) :: check - logical :: minus - integer :: pos,ii - integer(kind=this_kind) :: j - integer :: index -#ifdef __IOTK_WORKAROUND5 - integer(kind=this_kind) :: limit(0:9) - integer(kind=this_kind) :: hug - hug = huge(j) - limit(0:9) = (/ ((hug-j)/10,j=0,9) /) -#else - integer(kind=this_kind), parameter :: limit(0:9) = (/ ((huge(j)-j)/10_this_kind,j=0,9) /) -#endif - minus = .false. - i = 0 - if(present(check)) check = .false. - if(len(a)==0) return - do ii = 1 , len(a) - if(a(ii:ii)/=" ") exit - end do - if(ii>len(a)) return - if(a(ii:ii)=="-") then - minus = .true. - ii = ii + 1 - else if(a(ii:ii)=="+") then - ii = ii + 1 - end if - if(ii>len(a)) return - pos = ii - do ii=pos,len(a) - index = int( iachar(a(ii:ii)) - iachar("0") ) - if(index<0 .or. index>9) exit - if(i>limit(index)) exit ! Check sull'overflow - i = i*10_this_kind + int(index,kind=this_kind) - end do - if(minus) i = - i - if(present(check)) then - pos = ii - do ii=pos,len(a) - if(a(ii:ii)/=" ") return - end do - check = .true. - end if -end subroutine iotk_atoi4 -#endif -# 115 "iotk_xtox.spp" - -# 117 "iotk_xtox.spp" -#ifdef __IOTK_INTEGER1 -function iotk_itoa1(i,length) - use iotk_base - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_integer1 - integer(kind=this_kind), intent(in) :: i - integer, optional, intent(out) :: length - character(len=range(i)+2) :: iotk_itoa1 - integer(kind=this_kind) :: itmp - integer :: pos,pos1 - character(len=range(i)+2) :: tmp - itmp = abs(i) - do pos = 1 , len(tmp) - tmp(pos:pos) = achar( modulo(itmp,int(10,kind(itmp))) + iachar("0") ) - itmp = itmp/10_this_kind - if(itmp==0) exit - if(pos==len(tmp)) exit - end do - if(i<0) then - tmp(pos+1:pos+1)="-" - pos = pos + 1 - end if - do pos1=1,pos - iotk_itoa1(pos1:pos1) = tmp(pos-pos1+1:pos-pos1+1) - end do - if(present(length)) length = pos - do pos1=pos+1,len(iotk_itoa1) - iotk_itoa1(pos1:pos1) = " " - end do -end function iotk_itoa1 -#endif -# 117 "iotk_xtox.spp" -#ifdef __IOTK_INTEGER2 -function iotk_itoa2(i,length) - use iotk_base - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_integer2 - integer(kind=this_kind), intent(in) :: i - integer, optional, intent(out) :: length - character(len=range(i)+2) :: iotk_itoa2 - integer(kind=this_kind) :: itmp - integer :: pos,pos1 - character(len=range(i)+2) :: tmp - itmp = abs(i) - do pos = 1 , len(tmp) - tmp(pos:pos) = achar( modulo(itmp,int(10,kind(itmp))) + iachar("0") ) - itmp = itmp/10_this_kind - if(itmp==0) exit - if(pos==len(tmp)) exit - end do - if(i<0) then - tmp(pos+1:pos+1)="-" - pos = pos + 1 - end if - do pos1=1,pos - iotk_itoa2(pos1:pos1) = tmp(pos-pos1+1:pos-pos1+1) - end do - if(present(length)) length = pos - do pos1=pos+1,len(iotk_itoa2) - iotk_itoa2(pos1:pos1) = " " - end do -end function iotk_itoa2 -#endif -# 117 "iotk_xtox.spp" -#ifdef __IOTK_INTEGER3 -function iotk_itoa3(i,length) - use iotk_base - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_integer3 - integer(kind=this_kind), intent(in) :: i - integer, optional, intent(out) :: length - character(len=range(i)+2) :: iotk_itoa3 - integer(kind=this_kind) :: itmp - integer :: pos,pos1 - character(len=range(i)+2) :: tmp - itmp = abs(i) - do pos = 1 , len(tmp) - tmp(pos:pos) = achar( modulo(itmp,int(10,kind(itmp))) + iachar("0") ) - itmp = itmp/10_this_kind - if(itmp==0) exit - if(pos==len(tmp)) exit - end do - if(i<0) then - tmp(pos+1:pos+1)="-" - pos = pos + 1 - end if - do pos1=1,pos - iotk_itoa3(pos1:pos1) = tmp(pos-pos1+1:pos-pos1+1) - end do - if(present(length)) length = pos - do pos1=pos+1,len(iotk_itoa3) - iotk_itoa3(pos1:pos1) = " " - end do -end function iotk_itoa3 -#endif -# 117 "iotk_xtox.spp" -#ifdef __IOTK_INTEGER4 -function iotk_itoa4(i,length) - use iotk_base - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_integer4 - integer(kind=this_kind), intent(in) :: i - integer, optional, intent(out) :: length - character(len=range(i)+2) :: iotk_itoa4 - integer(kind=this_kind) :: itmp - integer :: pos,pos1 - character(len=range(i)+2) :: tmp - itmp = abs(i) - do pos = 1 , len(tmp) - tmp(pos:pos) = achar( modulo(itmp,int(10,kind(itmp))) + iachar("0") ) - itmp = itmp/10_this_kind - if(itmp==0) exit - if(pos==len(tmp)) exit - end do - if(i<0) then - tmp(pos+1:pos+1)="-" - pos = pos + 1 - end if - do pos1=1,pos - iotk_itoa4(pos1:pos1) = tmp(pos-pos1+1:pos-pos1+1) - end do - if(present(length)) length = pos - do pos1=pos+1,len(iotk_itoa4) - iotk_itoa4(pos1:pos1) = " " - end do -end function iotk_itoa4 -#endif -# 150 "iotk_xtox.spp" - -# 152 "iotk_xtox.spp" -#ifdef __IOTK_LOGICAL1 -function iotk_ltoa1(l) - use iotk_base - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_integer1 - logical(kind=this_kind), intent(in) :: l - character :: iotk_ltoa1 - if(l) then - iotk_ltoa1 = "T" - else - iotk_ltoa1 = "F" - end if -end function iotk_ltoa1 -#endif -# 152 "iotk_xtox.spp" -#ifdef __IOTK_LOGICAL2 -function iotk_ltoa2(l) - use iotk_base - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_integer2 - logical(kind=this_kind), intent(in) :: l - character :: iotk_ltoa2 - if(l) then - iotk_ltoa2 = "T" - else - iotk_ltoa2 = "F" - end if -end function iotk_ltoa2 -#endif -# 152 "iotk_xtox.spp" -#ifdef __IOTK_LOGICAL3 -function iotk_ltoa3(l) - use iotk_base - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_integer3 - logical(kind=this_kind), intent(in) :: l - character :: iotk_ltoa3 - if(l) then - iotk_ltoa3 = "T" - else - iotk_ltoa3 = "F" - end if -end function iotk_ltoa3 -#endif -# 152 "iotk_xtox.spp" -#ifdef __IOTK_LOGICAL4 -function iotk_ltoa4(l) - use iotk_base - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_integer4 - logical(kind=this_kind), intent(in) :: l - character :: iotk_ltoa4 - if(l) then - iotk_ltoa4 = "T" - else - iotk_ltoa4 = "F" - end if -end function iotk_ltoa4 -#endif diff --git a/quantum_espresso/kcp/iotk/src/iotk_xtox.spp b/quantum_espresso/kcp/iotk/src/iotk_xtox.spp deleted file mode 100644 index 733f96594..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_xtox.spp +++ /dev/null @@ -1,168 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -> REVISION='$Revision: 1.1.1.1 $' -> REVISION="${REVISION//${dol}/}" - ->PROCEDURE=iotk_atol -function iotk_atol_x(a,check) - use iotk_base - use iotk_misc_interf - implicit none - character(len=*), intent(in) :: a - logical, optional, intent(out) :: check - logical :: iotk_atol_x - integer :: i - iotk_atol_x = .false. - if(present(check)) check = .false. - if(len(a)==0) return - do i = 1 , len(a) - if(a(i:i)/=" " .and. a(i:i)/=".") exit - end do - if(i>len(a)) return - if(present(check)) check = .true. - if(a(i:i)=="T" .or. a(i:i)=="t") then - iotk_atol_x = .true. - else if(a(i:i)=="F" .or. a(i:i)=="f") then - iotk_atol_x = .false. - else - if(present(check)) check = .false. - end if -end function iotk_atol_x - ->for kind in $kinds ; do -#ifdef __IOTK_INTEGER${kind} -subroutine iotk_atoi$kind(i,a,check) - use iotk_base - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_integer$kind - integer(kind=this_kind), intent(out) :: i - character(len=*), intent(in) :: a - logical, optional, intent(out) :: check - logical :: minus - integer :: pos,ii - integer(kind=this_kind) :: j - integer :: index -#ifdef __IOTK_WORKAROUND5 - integer(kind=this_kind) :: limit(0:9) - integer(kind=this_kind) :: hug - hug = huge(j) - limit(0:9) = (/ ((hug-j)/10,j=0,9) /) -#else - integer(kind=this_kind), parameter :: limit(0:9) = (/ ((huge(j)-j)/10_this_kind,j=0,9) /) -#endif - minus = .false. - i = 0 - if(present(check)) check = .false. - if(len(a)==0) return - do ii = 1 , len(a) - if(a(ii:ii)/=" ") exit - end do - if(ii>len(a)) return - if(a(ii:ii)=="-") then - minus = .true. - ii = ii + 1 - else if(a(ii:ii)=="+") then - ii = ii + 1 - end if - if(ii>len(a)) return - pos = ii - do ii=pos,len(a) - index = int( iachar(a(ii:ii)) - iachar("0") ) - if(index<0 .or. index>9) exit - if(i>limit(index)) exit ! Check sull'overflow - i = i*10_this_kind + int(index,kind=this_kind) - end do - if(minus) i = - i - if(present(check)) then - pos = ii - do ii=pos,len(a) - if(a(ii:ii)/=" ") return - end do - check = .true. - end if -end subroutine iotk_atoi$kind -#endif ->done - ->for kind in $kinds ; do -#ifdef __IOTK_INTEGER${kind} -function iotk_itoa$kind(i,length) - use iotk_base - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_integer$kind - integer(kind=this_kind), intent(in) :: i - integer, optional, intent(out) :: length - character(len=range(i)+2) :: iotk_itoa$kind - integer(kind=this_kind) :: itmp - integer :: pos,pos1 - character(len=range(i)+2) :: tmp - itmp = abs(i) - do pos = 1 , len(tmp) - tmp(pos:pos) = achar( modulo(itmp,int(10,kind(itmp))) + iachar("0") ) - itmp = itmp/10_this_kind - if(itmp==0) exit - if(pos==len(tmp)) exit - end do - if(i<0) then - tmp(pos+1:pos+1)="-" - pos = pos + 1 - end if - do pos1=1,pos - iotk_itoa$kind(pos1:pos1) = tmp(pos-pos1+1:pos-pos1+1) - end do - if(present(length)) length = pos - do pos1=pos+1,len(iotk_itoa$kind) - iotk_itoa$kind(pos1:pos1) = " " - end do -end function iotk_itoa$kind -#endif ->done - ->for kind in $kinds ; do -#ifdef __IOTK_LOGICAL${kind} -function iotk_ltoa$kind(l) - use iotk_base - use iotk_misc_interf - implicit none - integer, parameter :: this_kind = iotk_integer$kind - logical(kind=this_kind), intent(in) :: l - character :: iotk_ltoa$kind - if(l) then - iotk_ltoa$kind = "T" - else - iotk_ltoa$kind = "F" - end if -end function iotk_ltoa$kind -#endif ->done - diff --git a/quantum_espresso/kcp/iotk/src/iotk_xtox_interf.f90 b/quantum_espresso/kcp/iotk/src/iotk_xtox_interf.f90 deleted file mode 100644 index 4e24e8941..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_xtox_interf.f90 +++ /dev/null @@ -1,186 +0,0 @@ -# 1 "iotk_xtox_interf.spp" -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - -# 28 "iotk_xtox_interf.spp" -#include "iotk_auxmacros.h" -# 30 "iotk_xtox_interf.spp" - -module iotk_xtox_interf -use iotk_base -implicit none -private - -public :: iotk_atol -public :: iotk_ltoa -public :: iotk_atoi -public :: iotk_itoa - -interface iotk_atol -function iotk_atol_x(a,check) - character(len=*), intent(in) :: a - logical, optional, intent(out) :: check - logical :: iotk_atol_x -end function iotk_atol_x -end interface - -interface iotk_atoi -# 51 "iotk_xtox_interf.spp" -#ifdef __IOTK_INTEGER1 -subroutine iotk_atoi1(i,a,check) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_integer1 - integer(kind=this_kind), intent(out) :: i - character(len=*), intent(in) :: a - logical, optional, intent(out) :: check -end subroutine iotk_atoi1 -#endif -# 51 "iotk_xtox_interf.spp" -#ifdef __IOTK_INTEGER2 -subroutine iotk_atoi2(i,a,check) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_integer2 - integer(kind=this_kind), intent(out) :: i - character(len=*), intent(in) :: a - logical, optional, intent(out) :: check -end subroutine iotk_atoi2 -#endif -# 51 "iotk_xtox_interf.spp" -#ifdef __IOTK_INTEGER3 -subroutine iotk_atoi3(i,a,check) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_integer3 - integer(kind=this_kind), intent(out) :: i - character(len=*), intent(in) :: a - logical, optional, intent(out) :: check -end subroutine iotk_atoi3 -#endif -# 51 "iotk_xtox_interf.spp" -#ifdef __IOTK_INTEGER4 -subroutine iotk_atoi4(i,a,check) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_integer4 - integer(kind=this_kind), intent(out) :: i - character(len=*), intent(in) :: a - logical, optional, intent(out) :: check -end subroutine iotk_atoi4 -#endif -# 62 "iotk_xtox_interf.spp" -end interface - -interface iotk_itoa -# 66 "iotk_xtox_interf.spp" -#ifdef __IOTK_INTEGER1 -function iotk_itoa1(i,length) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_integer1 - integer(kind=this_kind), intent(in) :: i - integer, optional, intent(out) :: length - character(len=range(i)+2) :: iotk_itoa1 -end function iotk_itoa1 -#endif -# 66 "iotk_xtox_interf.spp" -#ifdef __IOTK_INTEGER2 -function iotk_itoa2(i,length) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_integer2 - integer(kind=this_kind), intent(in) :: i - integer, optional, intent(out) :: length - character(len=range(i)+2) :: iotk_itoa2 -end function iotk_itoa2 -#endif -# 66 "iotk_xtox_interf.spp" -#ifdef __IOTK_INTEGER3 -function iotk_itoa3(i,length) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_integer3 - integer(kind=this_kind), intent(in) :: i - integer, optional, intent(out) :: length - character(len=range(i)+2) :: iotk_itoa3 -end function iotk_itoa3 -#endif -# 66 "iotk_xtox_interf.spp" -#ifdef __IOTK_INTEGER4 -function iotk_itoa4(i,length) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_integer4 - integer(kind=this_kind), intent(in) :: i - integer, optional, intent(out) :: length - character(len=range(i)+2) :: iotk_itoa4 -end function iotk_itoa4 -#endif -# 77 "iotk_xtox_interf.spp" -end interface - -interface iotk_ltoa -# 81 "iotk_xtox_interf.spp" -#ifdef __IOTK_LOGICAL1 -function iotk_ltoa1(l) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_logical1 - logical(kind=this_kind), intent(in) :: l - character :: iotk_ltoa1 -end function iotk_ltoa1 -#endif -# 81 "iotk_xtox_interf.spp" -#ifdef __IOTK_LOGICAL2 -function iotk_ltoa2(l) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_logical2 - logical(kind=this_kind), intent(in) :: l - character :: iotk_ltoa2 -end function iotk_ltoa2 -#endif -# 81 "iotk_xtox_interf.spp" -#ifdef __IOTK_LOGICAL3 -function iotk_ltoa3(l) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_logical3 - logical(kind=this_kind), intent(in) :: l - character :: iotk_ltoa3 -end function iotk_ltoa3 -#endif -# 81 "iotk_xtox_interf.spp" -#ifdef __IOTK_LOGICAL4 -function iotk_ltoa4(l) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_logical4 - logical(kind=this_kind), intent(in) :: l - character :: iotk_ltoa4 -end function iotk_ltoa4 -#endif -# 91 "iotk_xtox_interf.spp" -end interface - -end module iotk_xtox_interf diff --git a/quantum_espresso/kcp/iotk/src/iotk_xtox_interf.spp b/quantum_espresso/kcp/iotk/src/iotk_xtox_interf.spp deleted file mode 100644 index 37c5aaeac..000000000 --- a/quantum_espresso/kcp/iotk/src/iotk_xtox_interf.spp +++ /dev/null @@ -1,94 +0,0 @@ -! Input/Output Tool Kit (IOTK) -! Copyright (C) 2004-2006 Giovanni Bussi -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Lesser General Public -! License as published by the Free Software Foundation; either -! version 2.1 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public -! License along with this library; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -!------------------------------------------------------------------------------! -! Inclusion of configuration file -#include "iotk_config.h" -!------------------------------------------------------------------------------! - ->##############################################################################< -># inclusion of the spp definitions ->include iotk_include.sh ->##############################################################################< -># inclusion of the auxiliary macros -#include "iotk_auxmacros.h" ->############################################################################## - -module iotk_xtox_interf -use iotk_base -implicit none -private - -public :: iotk_atol -public :: iotk_ltoa -public :: iotk_atoi -public :: iotk_itoa - -interface iotk_atol -function iotk_atol_x(a,check) - character(len=*), intent(in) :: a - logical, optional, intent(out) :: check - logical :: iotk_atol_x -end function iotk_atol_x -end interface - -interface iotk_atoi -> for kind in $kinds ; do -#ifdef __IOTK_INTEGER${kind} -subroutine iotk_atoi${kind}(i,a,check) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_integer${kind} - integer(kind=this_kind), intent(out) :: i - character(len=*), intent(in) :: a - logical, optional, intent(out) :: check -end subroutine iotk_atoi${kind} -#endif -> done -end interface - -interface iotk_itoa ->for kind in $kinds ; do -#ifdef __IOTK_INTEGER${kind} -function iotk_itoa$kind(i,length) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_integer${kind} - integer(kind=this_kind), intent(in) :: i - integer, optional, intent(out) :: length - character(len=range(i)+2) :: iotk_itoa$kind -end function iotk_itoa$kind -#endif -> done -end interface - -interface iotk_ltoa ->for kind in $kinds ; do -#ifdef __IOTK_LOGICAL${kind} -function iotk_ltoa$kind(l) - use iotk_base - implicit none - integer, parameter :: this_kind = iotk_logical$kind - logical(kind=this_kind), intent(in) :: l - character :: iotk_ltoa$kind -end function iotk_ltoa$kind -#endif -> done -end interface - -end module iotk_xtox_interf - diff --git a/quantum_espresso/kcp/iotk/src/test.f90 b/quantum_espresso/kcp/iotk/src/test.f90 deleted file mode 100644 index c68c11cb7..000000000 --- a/quantum_espresso/kcp/iotk/src/test.f90 +++ /dev/null @@ -1,218 +0,0 @@ -program test -use iotk_module -implicit none - -integer :: i -call iotk_set(error_warn_overflow=.true.) - -do i = 1 , 1 - -write(0,*) "Test for IOTK library" - -call test1(.false.,"test1.xml") -write(0,*) "Textual OK" -call test1(.true., "test1.dat") -write(0,*) "Binary OK" - -call test1(.false.,"test1l.xml",link=.true.) -write(0,*) "Textual with links OK" -call test1(.true., "test1l.dat",link=.true.) -write(0,*) "Binary with links OK" - - -call test1(.false.,"test1dl.xml",link=.true.,deferred=.true.) -write(0,*) "Textual with deferred links OK" -call test1(.true., "test1dl.dat",link=.true.,deferred=.true.) -write(0,*) "Binary with deferred links OK" - -call test1(.false.,"test1lr.xml",link=.true.,raw=.true.) -write(0,*) "Textual with raw links OK" -call test1(.true., "test1lr.dat",link=.true.,raw=.true.) -write(0,*) "Binary with raw links OK" - -call test1(.false.,"test1dlr.xml",link=.true.,raw=.true.,deferred=.true.) -write(0,*) "Textual with raw deferred links OK" -call test1(.true., "test1dlr.dat",link=.true.,raw=.true.,deferred=.true.) -write(0,*) "Binary with raw deferred links OK" - - -end do - - -contains - -subroutine test1(binary,file,link,deferred,raw) - logical, intent(in) :: binary - character(*), intent(in) :: file - logical, optional, intent(in) :: link - logical, optional, intent(in) :: deferred - logical, optional, intent(in) :: raw - logical :: lraw,ldeferred,llink -! integer, parameter :: dp=selected_real_kind(10),i8=selected_int_kind(10) - integer, parameter :: dp=selected_real_kind(5),i8=selected_int_kind(5) - character(30) :: char_array(3) - character(25) :: char_array_read(3) - logical :: logical_array(30),logical_array_read(30) - integer :: integer_array(30) - integer(i8) :: integer_array_read(30) - real(dp) :: real_array(30) - real :: real_array_read(30) - complex :: complex_array(10,2) - complex(dp) :: complex_array_read(10,2) - character(iotk_attlenx) :: attr - character(100):: escapes,escapes_read - character(100):: escapes1,escapes1_read - character(100):: escapes2,escapes2_read - character(100):: value - - logical :: logical_att(3),logical_att_read(3) - integer :: integer_att(3),integer_att_read(3) - real :: real_att(2,2),real_att_read(2,2) - complex :: complex_att(3),complex_att_read(3) - - logical :: stream - - llink=.false. - ldeferred=.false. - lraw=.false. - if(present(raw)) lraw=raw - if(present(deferred)) ldeferred=deferred - if(present(link)) llink=link - - char_array(1) = "First && <<>line" - char_array(2) = "Second line'''" // '"' // " ss" - char_array(3) = "Third line" - logical_array = .true. - integer_array = 7 - real_array = real( 3.14 , kind=kind(real_array) ) - complex_array = (2.0,1.0) - escapes = "try&trytry'"//'"' - escapes1 = "'ert'" - escapes2 = '"ert"' - logical_att=(/.true.,.false.,.true./) - integer_att=(/1,2,-443/) - real_att=reshape((/1.0,2.0,5.0,7.0/),(/2,2/)) - complex_att=(-1.0,-2.0) - - - call iotk_open_write(unit=10,file=file,binary=binary) - call iotk_write_begin(10,"Outer") - if(ldeferred) then - call iotk_link(10,name="Inner1",file="Inner1.xml",binary=.false.) - else - call iotk_write_attr(attr,"escapes",trim(escapes),first=.true.) - call iotk_write_attr(attr,"escapes1",trim(escapes1)) - call iotk_write_attr(attr,"escapes2",trim(escapes2)) - if(llink) call iotk_link(10,"Inner1",file="Inner1.xml",binary=.false.,create=.true.) - call iotk_write_begin(10,"Inner1",attr) - if(llink) call iotk_link(10,"Dat1",file="Dat1.xml",create=.true.,raw=lraw) - call iotk_write_dat (10,"Dat1",char_array) - if(llink) call iotk_link(10,"Dat2",file="Dat2.xml",create=.true.,raw=lraw) - call iotk_write_dat (10,"Dat2",logical_array,columns=4,sep="^^") - if(llink) call iotk_link(10,"Dat3",file="Dat3.xml",create=.true.,raw=lraw) - call iotk_write_dat (10,"Dat3",integer_array) - if(llink) call iotk_link(10,"Dat4",file="Dat4.xml",create=.true.,raw=lraw) - call iotk_write_dat (10,"Dat4",real_array) - if(llink) call iotk_link(10,"Dat5",file="Dat5.xml",create=.true.,raw=lraw) - call iotk_write_dat (10,"Dat5",complex_array,columns=3) - call iotk_write_end (10,"Inner1") - end if - attr=" " - call iotk_write_attr(attr,"log",logical_att) - call iotk_write_attr(attr,"int",integer_att) - call iotk_write_attr(attr,"rea",real_att) - call iotk_write_attr(attr,"com",complex_att) - call iotk_write_begin(10,"Inner2",attr) - if(llink) call iotk_link(10,"Dat5",file="Dat5.dat",binary=.true.,create=.true.) - call iotk_write_dat (10,"Dat5",char_array) - if(llink) call iotk_link(10,"Dat4",file="Dat4.dat",binary=.true.,create=.true.) - call iotk_write_dat (10,"Dat4",logical_array,fmt="(10l1)") - if(ldeferred) then - call iotk_link(10,name="Dat3",file="Dat3.dat",binary=.true.,raw=lraw) - else - if(llink) call iotk_link(10,"Dat3",file="Dat3.dat",binary=.true.,create=.true.,raw=lraw) - call iotk_write_dat (10,"Dat3",integer_array,fmt="(3i8)") - end if - if(llink) call iotk_link(10,"Dat2",file="Dat2.dat",binary=.true.,create=.true.) - call iotk_write_dat (10,"Dat2",real_array,fmt="(f25.14)") - if(llink) call iotk_link(10,"Dat1",file="Dat1.dat",binary=.true.,create=.true.) - call iotk_write_attr (attr,"attribute","value",first=.true.) - call iotk_write_dat (10,"Dat1",complex_array,fmt="(f25.14)",attr=attr) - call iotk_write_end (10,"Inner2") - call iotk_write_end (10,"Outer") - call iotk_close_write(10) - - - stream=.false. -#ifdef __IOTK_STREAM - stream=.true. -#endif - - call iotk_open_read(unit=10,file=file,stream=stream) - call iotk_scan_begin(10,"Outer") - call iotk_scan_begin(10,"Inner2",attr) - logical_att_read = .false. - integer_att_read = 0 - real_att_read = 0.0 - complex_att_read = 0.0 - call iotk_scan_attr(attr,"log",logical_att_read) - call iotk_scan_attr(attr,"int",integer_att_read) - call iotk_scan_attr(attr,"rea",real_att_read) - call iotk_scan_attr(attr,"com",complex_att_read) - if(any(logical_att_read.neqv.logical_att)) stop "logical_att" - if(any(integer_att_read/=integer_att)) stop "integer_att" - if(any(abs(real_att_read-real_att)>0.00001)) stop "real_att" - if(any(complex_att_read/=complex_att)) stop "complex_att" - char_array_read = " " - logical_array_read = .false. - integer_array_read = -1 - real_array_read = 0.0 - complex_array_read = 0.0 - attr = " " - call iotk_scan_dat (10,"Dat1",complex_array_read,attr=attr) - call iotk_scan_attr (attr,"attribute",value) - if(value/="value") stop "value" - call iotk_scan_dat (10,"Dat2",real_array_read) - call iotk_scan_dat (10,"Dat3",integer_array_read) - call iotk_scan_dat (10,"Dat4",logical_array_read) - call iotk_scan_dat (10,"Dat5",char_array_read) - if(any(char_array_read/=char_array)) stop "char" - if(any(logical_array_read.neqv.logical_array)) stop "logical" - if(any(integer_array_read/=integer_array)) stop "integer" - if(any(abs(real_array_read-real_array)>0.00001)) stop "real" - if(any(complex_array_read/=complex_array)) stop "complex" - call iotk_scan_end (10,"Inner2") - attr=" " - escapes_read="" - escapes1_read="" - escapes2_read="" - call iotk_scan_begin(10,"Inner1",attr) - call iotk_scan_attr(attr,"escapes",escapes_read) - call iotk_scan_attr(attr,"escapes1",escapes1_read) - call iotk_scan_attr(attr,"escapes2",escapes2_read) - if(escapes/=escapes_read) stop "escape" - if(escapes1/=escapes1_read) stop "escape1" - if(escapes2/=escapes2_read) stop "escape2" - char_array_read = " " - logical_array_read = .false. - integer_array_read = -1 - real_array_read = 0.0 - complex_array_read = 0.0 - call iotk_scan_dat (10,"Dat5",complex_array_read) - call iotk_scan_dat (10,"Dat4",real_array_read) - call iotk_scan_dat (10,"Dat3",integer_array_read) - call iotk_scan_dat (10,"Dat2",logical_array_read) - call iotk_scan_dat (10,"Dat1",char_array_read) - if(any(char_array_read/=char_array)) stop "char1" - if(any(logical_array_read.neqv.logical_array)) stop "logical1" - if(any(integer_array_read/=integer_array)) stop "integer1" - if(any(abs(real_array_read-real_array)>0.00001)) stop "real1" - if(any(complex_array_read/=complex_array)) stop "complex1" - call iotk_scan_end (10,"Inner1") - call iotk_scan_end (10,"Outer") - call iotk_close_read(10) -end subroutine test1 - -end program test - - diff --git a/quantum_espresso/kcp/iotk/src/test2.f90 b/quantum_espresso/kcp/iotk/src/test2.f90 deleted file mode 100644 index b2d1cc469..000000000 --- a/quantum_espresso/kcp/iotk/src/test2.f90 +++ /dev/null @@ -1,18 +0,0 @@ -program main -use iotk_module -implicit none -character(iotk_attlenx) :: attr -real :: try(2,2) - - -open(unit=10,file="test2.txt") -write(10,"(a)") '' -close(10) - -open(unit=10,file="test2.txt") -call iotk_scan_empty(10,"tag",attr) -call iotk_scan_attr(attr,"try",try) -write(0,*) try - - -end program main diff --git a/quantum_espresso/kcp/iotk/src/test3.f90 b/quantum_espresso/kcp/iotk/src/test3.f90 deleted file mode 100644 index 34439e8ce..000000000 --- a/quantum_espresso/kcp/iotk/src/test3.f90 +++ /dev/null @@ -1,14 +0,0 @@ -program test3 -use iotk_module -implicit none - -!complex*16, pointer :: dat(:,:,:,:) -!complex, pointer :: dat(:,:,:,:) - -!allocate(dat(16,16,12,64)) -! -!dat=0.0 -! -!call iotk_write_dat(77,"dato",dat) -! -end program test3 diff --git a/quantum_espresso/kcp/iotk/src/test4.f90 b/quantum_espresso/kcp/iotk/src/test4.f90 deleted file mode 100644 index b0df2bed1..000000000 --- a/quantum_espresso/kcp/iotk/src/test4.f90 +++ /dev/null @@ -1,57 +0,0 @@ -program test4 -use iotk_base -use iotk_error_interf - - -integer :: ierr,ierr1,ierr2,ierr3,ierr4 -ierr = 0 -ierr1= 0 -ierr2= 0 -ierr3= 0 -ierr3= 4 - - -write(0,*) "#########################################" -call iotk_error_issue(ierr,"main",__FILE__,__LINE__) -call iotk_error_msg (ierr,"Error in IOTK") -call iotk_error_issue(ierr1,"main",__FILE__,__LINE__) -call iotk_error_msg (ierr1,"IO error") -call iotk_error_write(ierr1,"iostat",30) -call iotk_error_issue(ierr2,"main",__FILE__,__LINE__) -call iotk_error_msg (ierr2,"Other error") -call iotk_error_write(ierr2,"iostat",32) -call iotk_error_issue(ierr3,"main",__FILE__,__LINE__) -call iotk_error_msg (ierr3,"Ultimo") -call iotk_error_write(ierr3,"iostat",34) -call iotk_error_issue(ierr4,"main",__FILE__,__LINE__) -call iotk_error_msg (ierr4,"Ultimissimo") - -write(0,*) "===",ierr,iotk_error_pool_order(ierr) -call iotk_error_print(ierr,0) -write(0,*) "===",ierr1,iotk_error_pool_order(ierr1) -call iotk_error_print(ierr1,0) -write(0,*) "===",ierr2,iotk_error_pool_order(ierr2) -call iotk_error_print(ierr2,0) -write(0,*) "===",ierr3,iotk_error_pool_order(ierr3) -call iotk_error_print(ierr3,0) -write(0,*) "===",ierr4,iotk_error_pool_order(ierr4) -call iotk_error_print(ierr4,0) - -write(0,*) iotk_error_pool_pending(),ierr,ierr2 - -call iotk_error_clear(ierr) - -write(0,*) iotk_error_pool_pending() - -call iotk_error_print(16,0) -call iotk_error_print(17,0) -write(0,*) iotk_error_check(0) -write(0,*) iotk_error_check(1) -write(0,*) iotk_error_check(2) -write(0,*) iotk_error_check(3) -write(0,*) iotk_error_check(16) -write(0,*) iotk_error_check(17) - -call iotk_error_handler(ierr2) - -end program test4 diff --git a/quantum_espresso/kcp/iotk/src/test5.f90 b/quantum_espresso/kcp/iotk/src/test5.f90 deleted file mode 100644 index b96d4f2d9..000000000 --- a/quantum_espresso/kcp/iotk/src/test5.f90 +++ /dev/null @@ -1,61 +0,0 @@ -program test5 -use iotk_module -use iotk_xtox_interf -implicit none -integer :: i,j -character(2) :: c -character(30) :: str - -goto 2 - -open(10,file="pippo.txt") -write(10,"(a)") "" -write(10,"(a)") "" -write(10,"(a)") "" -write(10,"(a)") "" -close(10) -goto 1 - -call iotk_open_write(10,"pippo1.txt",root="ee~~") -call iotk_close_write(10) - -call iotk_open_read(10,"pippo.txt") -write(0,*) "-" -call iotk_scan_begin(10,"prova") -write(0,*) "-" -call iotk_scan_end(10,"prova") -write(0,*) "-" -call iotk_close_read(10) -write(0,*) "-" - -1 continue -do j = 1 , 10 -write(0,*) j -call iotk_open_write(11,file="pippo.txt") -write(0,*) j,"+" -do i = 1 ,100 -call iotk_write_dat(11,"pippo","aa") -end do -write(0,*) j,"+" -call iotk_close_write(11) - -write(0,*) j -call iotk_open_read(11,file="pippo.txt") -do i = 1 ,100 -call iotk_scan_dat(11,"pippo",c) -end do -call iotk_close_read(11) -end do - -2 continue - -do i = 1 , 1000000 - str = iotk_itoa(i) -end do -write(0,*) str - -write(0,*) "A"//iotk_index(-123)//"B" -write(0,*) "A"//iotk_index((/1,-2,-4524254/))//"B" - - -end program test5 diff --git a/quantum_espresso/kcp/iotk/src/test6.f90 b/quantum_espresso/kcp/iotk/src/test6.f90 deleted file mode 100644 index 509586c3a..000000000 --- a/quantum_espresso/kcp/iotk/src/test6.f90 +++ /dev/null @@ -1,103 +0,0 @@ -program test6 -use iotk_module -implicit none -character(32000) :: line -integer :: ierr,l -integer :: index,n(3) -logical :: ll(3) -real :: rr(3) -complex :: cc(3) -character(20) :: words(3),words2(3),stringa,stringa2 -character(iotk_attlenx) :: attr - -call iotk_copyfile(source="uno",dest="due") - -stop - -words(1) = "Primo" -words(2) = "Secondo" -words(3) = "Contorno" -stringa = " WER R " - -call iotk_open_write(10,"test6b.txt") -call iotk_write_attr(attr,"prova",stringa,first=.true.) -call iotk_write_empty(10,"empty",attr) -call iotk_write_dat(10,"menu",words) -call iotk_close_write(10) - -call iotk_open_read(10,"test6.txt") -call iotk_scan_dat(10,"menu",words2) -call iotk_scan_empty(10,"empty",attr) -call iotk_scan_attr(attr,"prova",stringa2) -call iotk_close_read(10) - -write(0,"(a)") words(1)//"%" -write(0,"(a)") words(2)//"%" -write(0,"(a)") words(3)//"%" -write(0,"(a)") "#"//stringa//"#" -write(0,"(a)") words2(1)//"%" -write(0,"(a)") words2(2)//"%" -write(0,"(a)") words2(3)//"%" -write(0,"(a)") "#"//stringa2//"#" - -stop - -n=255 -index = 0 -call iotk_read(n,"10000 1, , ",index,ierr) -write(0,*) n -write(0,*) index,ierr - -ll = .false. -index = 0 -call iotk_read(ll," .true. false ",index,ierr) -write(0,*) ll -write(0,*) index,ierr - -rr = 0.0 -index = 0 -call iotk_read(rr," ,,,, -3.01 4.2222E3, 1.2",index,ierr) -write(0,*) rr -write(0,*) index,ierr -call iotk_error_print(ierr,0) - -cc = 0.0 -index = 0 -call iotk_read(cc,"1.0 2.0 3.0 4.0 5.0 ",index,ierr) -write(0,*) cc -write(0,*) index,ierr -call iotk_error_print(ierr,0) - -stop - -open(10,file="test6.in") -open(11,file="test6.out") - -#if 0 -do - call iotk_getline(10,line,length=l) - write(11,"(i5,a)") l,line(1:l) -end do -#else - -l=1 -call iotk_getline(10,line,length=l) -write(11,"(a)") line(1:l) - -call iotk_getline(10,line,length=l) -write(11,"(a)") line(1:l) - -backspace(10) -backspace(10) - -call iotk_getline(10,line,length=l) -write(11,"(a)") line(1:l) - -call iotk_getline(10,line,length=l) -write(11,"(a)") line(1:l) -#endif - -close(10) -close(11) - -end program test6 diff --git a/quantum_espresso/kcp/iotk/src/test7.f90 b/quantum_espresso/kcp/iotk/src/test7.f90 deleted file mode 100644 index 17ab9d550..000000000 --- a/quantum_espresso/kcp/iotk/src/test7.f90 +++ /dev/null @@ -1,24 +0,0 @@ -PROGRAM test -USE iotk_module -USE iotk_misc_interf -USE iotk_str_interf -IMPLICIT NONE -character(iotk_attlenx) :: attr -integer :: ierr - -call iotk_write_attr(attr,"ciccio",1,first=.true.) -call iotk_write_attr(attr,"pippo","sei") -call iotk_write_attr(attr,"aa","nove") -call iotk_write_attr(attr,"WWWW","nove") - -attr='cc= "s" ee = "qqqq" arg ="ee" '//iotk_eos -write(*,"(a)") "%"//attr(1:iotk_strlen(attr))//"%" - -call iotk_delete_attr(attr,"cc",ierr) -if(ierr/=0) write (*,*) "ARG" -write(*,"(a)") "%"//attr(1:iotk_strlen(attr))//"%" - - -END PROGRAM - - diff --git a/quantum_espresso/kcp/iotk/src/test8.f90 b/quantum_espresso/kcp/iotk/src/test8.f90 deleted file mode 100644 index 34a74bd6f..000000000 --- a/quantum_espresso/kcp/iotk/src/test8.f90 +++ /dev/null @@ -1,89 +0,0 @@ -program test8 -use iotk_module -use iotk_stream_interf -implicit none -integer, allocatable :: val(:,:) -integer, allocatable :: val1(:,:) -integer :: i,rate,ttt1,ttt2,j -logical :: stream - -integer :: rsize -integer :: rnum - -rsize = 2500000 -rnum = 20 - -allocate(val(rsize,rnum)) -allocate(val1(rsize,rnum)) - -call system_clock(count_rate=rate) - -call system_clock(count=ttt1) - -do i=1,rnum - val(:,i)=(/ (i,j,j=1,rsize) /) -end do -val=77 - -!call write() - -call system_clock(count=ttt2) -write(0,*) "WRITE:",(ttt2-ttt1)/real(rate) -ttt1=ttt2 - -!call read1() - -call system_clock(count=ttt2) -write(0,*) "READ1:",(ttt2-ttt1)/real(rate) -ttt1=ttt2 - -call read2() - -call system_clock(count=ttt2) -write(0,*) "READ2:",(ttt2-ttt1)/real(rate) -ttt1=ttt2 - -contains - -subroutine write() - -call iotk_open_write(10,file="aaa.dat",binary=.true.) -do i=1,rnum - call iotk_write_dat(10,"vv"//iotk_index(i),val(:,i)) -end do -call iotk_close_write(10) - -end subroutine write - -subroutine read1() - -val1=0.0 -call iotk_open_read(10,file="aaa.dat",binary=.true.) -do i=1,rnum - call iotk_scan_dat(10,"vv"//iotk_index(i),val1(:,i)) -end do -call iotk_close_read(10) -if(any(val1/=val)) stop "EE" - -end subroutine read1 - -subroutine read2() - -val1=0.0 -stream=.false. -#ifdef __IOTK_STREAMS -stream=.true. -#endif - -call iotk_open_read(10,file="aaa.dat",binary=.true.,stream=.true.) -do i=rnum,1,-1 - call iotk_scan_dat(10,"vv"//iotk_index(i),val1(:,i)) -end do -call iotk_close_read(10) -if(any(val1/=val)) stop "AA" - -end subroutine read2 - - - -end program test8 diff --git a/quantum_espresso/kcp/iotk/src/test9.f90 b/quantum_espresso/kcp/iotk/src/test9.f90 deleted file mode 100644 index 74b52ab9e..000000000 --- a/quantum_espresso/kcp/iotk/src/test9.f90 +++ /dev/null @@ -1,37 +0,0 @@ -program test9 -use iotk_unit_list_module -use iotk_module -implicit none - -type(iotk_unit_list) :: unit_list -type(iotk_unit), pointer :: ptr - -call iotk_unit_list_init(unit_list) - -call iotk_unit_list_search(unit_list,ptr,unit=10) -write(0,*) "should be false",associated(ptr) - -call iotk_unit_list_add(unit_list,ptr) -ptr%unit=10 -ptr%root="aa" - -call iotk_unit_list_add(unit_list,ptr) -ptr%unit=11 -ptr%root="aa" - -nullify(ptr) - -call iotk_unit_list_search(unit_list,ptr,unit=10) - -write(0,*) ptr%unit -write(0,*) ptr%root - -call iotk_unit_list_del(unit_list,ptr) - -call iotk_unit_list_destroy(unit_list) - - - - - -end program test9 diff --git a/quantum_espresso/kcp/iotk/tools/auto_config b/quantum_espresso/kcp/iotk/tools/auto_config deleted file mode 100755 index e842a216d..000000000 --- a/quantum_espresso/kcp/iotk/tools/auto_config +++ /dev/null @@ -1,439 +0,0 @@ -#! /bin/sh - -newline=" -" - -MANUAL="\ -usage: $0 [options]"' -options is: ---fc=X (environment:FC) - to set the fortran compiler - suggested values: - "xlf90 -qsuffix=f=f90" "ifort" "g95" "pgf90" ---fcflags=X (environment:FCFLAGS) - to set the flags for the fortran compiler ---enable-mpi - to enable mpi_abort in error handling ---disable-mpi - to enable mpi_abort in error handling ---maxrank=N - to set the maximum rank to N ---maxrank-all - to compile all ranks (up to nranks in iotk_config.sh) ---logical-clear - to reset the list of kinds for logical ---integer-clear - to reset the list of kinds for integer ---real-clear - to reset the list of kinds for real ---logical-all - to enable logical of any possible kind (repeatable) ---integer-all - to enable logical of any possible kind (repeatable) ---real-all - to enable logical of any possible kind (repeatable) ---logical-kind=X - to enable logical of X kind (repeatable) ---integer-kind=X - to enable integer of X kind (repeatable) ---real-kind=X - to enable real of X kind (repeatable) ---tmpdir=X - to set the temporary directory (default is /tmp/\$\$) ---target - to use in cross-compiling environment ---no-clean - to avoid final cleanup of directory -NOTE: X can be a string (such as "kind(1.0)" or "selected_int_kind(3)") - -Prior to the command line options, the environment variable -IOTK_CONFIGURE is scanned for a list of newline separated -options. Single options cannot contain newlines. -Repeatable options can be repeated adding other kinds. -Other options override the previously defined values. -For integers and logicals, the following rule holds: -if the user specifies at least one kind, the default -kind (kind(1) or kind(.true.)) is automatically added. -If no kind is written in the iotk_config.h file, -the defaults will be included at compilation time. -' - -for OPT -do - LINES=`echo "$OPT" | wc -l` - if test "$LINES" -ne 1 - then - echo "An option cannot contain newlines" - exit 1 - fi - - IOTK_CONFIGURE="$IOTK_CONFIGURE$newline$OPT" -done - - - -ENABLE_MPI= -TRY_INTEGER= -TRY_LOGICAL= -TRY_REAL= -ALLKINDS="1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13 -14 -15 -16 -17 -18 -19 -20" -MAXRANK= -NOCLEAN= -IFSBCK="$IFS" -IFS="$newline" -for OPT in $IOTK_CONFIGURE -do - case $OPT in - --enable-mpi) ENABLE_MPI=yes ;; - --disable-mpi) ENABLE_MPI= ;; - --maxrank=*) RANK=`echo "$OPT" | sed -n 's/--maxrank=//p'` ; - MAXRANK=$RANK ;; - --maxrank-all) MAXRANK= ;; - --fc=*) FC=`echo "$OPT" | sed -n 's/--fc=//p'` ;; - --fcflags=*) FCFLAGS=`echo "$OPT" | sed -n 's/--fcflags=//p'` ;; - --logical-clear) TRY_LOGICAL= ;; - --logical-all) TRY_LOGICAL="$TRY_LOGICAL$newline$ALLKINDS" ;; - --logical-kind=*) ADD=`echo "$OPT" | sed -n 's/--logical-kind=//p'` ; - TRY_LOGICAL="$TRY_LOGICAL$newline$ADD" ;; - --real-clear) TRY_REAL= ;; - --real-all) TRY_REAL="$TRY_REAL$newline$ALLKINDS" ;; - --real-kind=*) ADD=`echo "$OPT" | sed -n 's/--real-kind=//p'` ; - TRY_REAL="$TRY_REAL$newline$ADD" ;; - --integer-clear) TRY_INTEGER= ;; - --integer-all) TRY_INTEGER="$TRY_INTEGER$newline$ALLKINDS" ;; - --integer-kind=*) ADD=`echo "$OPT" | sed -n 's/--integer-kind=//p'` ; - TRY_INTEGER="$TRY_INTEGER$newline$ADD" ;; - --help) echo "$MANUAL" ; exit 0 ;; - --no-clean) NOCLEAN=true ;; - --tmpdir=*) TMPDIR=`echo "$OPT" | sed -n 's/--tmpdir=//p'` ;; - --target=*) TARGET=`echo "$OPT" | sed -n 's/--target=//p'` ;; - *) echo "Unknown option $OPT${newline}Try: $0 --help" ; exit 1 ;; - esac -done -IFS="$IFSBCK" - -test -n "$TRY_INTEGER" && TRY_INTEGER="kind(1)$newline$TRY_INTEGER" -test -n "$TRY_LOGICAL" && TRY_LOGICAL="kind(.true.)$newline$TRY_LOGICAL" -#TRY_REAL="kind(1.0)$newline$TRY_REAL" - - - -if test -z "$FC" -then - echo "Specify the fortran compiler" - echo "Try: $0 --help" - exit 1 -fi - -if test -n "$TARGET" -then - if test -z $TMPDIR - then - echo "Specify --tmpdir if --target is defined" - exit 1 - fi - EXEC="ssh $TARGET" -fi - -if test -z "$TMPDIR" -then - NUM=$$ - while echo > /dev/null - do - TMPDIR=/tmp/$NUM - if [ -e $TMPDIR ] ; then - NUM=`expr $NUM + 1` - else - break - fi - done -fi - -test -e $TMPDIR || mkdir $TMPDIR -OLDPWD=`pwd` -cd $TMPDIR - -cat << EOF > iotk_config.h -! Automatically generated config file for iotk -! Fortran compiler : $FC -! Fortran compiler options : $FCFLAGS -#ifndef __IOTK_CONFIG_H -#define __IOTK_CONFIG_H - -EOF - -NLIST= - -echo "Checking if $FC $FCFLAGS works ..." -OK= -cat > tmp.f90 << \EOF -program test -write(*,*) "OK" -end program test -EOF -$FC $FCFLAGS tmp.f90 -o tmp.x 2>/dev/null 1>/dev/null -OUTPUT=`$EXEC $TMPDIR/tmp.x 2>/dev/null` -echo "$OUTPUT" | grep -q OK && OK=yes -rm tmp.x 2>/dev/null -if test -z "$OK" -then - echo "COMPILER DOES NOT WORK" - cd $OLDPWD - mv $TMPDIR/iotk_config.h . - rm -fr $TMPDIR - exit 1 -fi - -echo "Finding list of available kinds ..." -for type in INTEGER LOGICAL REAL -do - eval TO_TRY=\"\$TRY_$type\" - LIST= - IFS="$newline" - for kind in $TO_TRY - do - IFS="$IFSBCK" - OK= - cat > tmp.f90 << EOF -program test - $type (kind=$kind) :: try - if(kind(try)==$kind) then - write(*,*) "OK" - write(*,"(a,i5)") "KIND",kind(try) - end if -end program test -EOF - $FC $FCFLAGS tmp.f90 -o tmp.x 2>/dev/null 1>/dev/null - OUTPUT=`$EXEC $TMPDIR/tmp.x 2>/dev/null` - echo "$OUTPUT" | grep -q OK && OK=yes - rm tmp.x 2>/dev/null - if test -n "$OK" ; then - ikind=`echo "$OUTPUT" | sed -n 's/KIND *//p'` - echo "$LIST" | grep -q "$type:$ikind" || - LIST="$LIST$type:$ikind$newline" - fi - done - IFS="$IFSBCK" - COUNT=0 - for WORD in $LIST - do - COUNT=`expr $COUNT + 1` - NLIST=$NLIST`echo $WORD | sed "s/:/$COUNT:/"`$newline - done -done - -LIST="$NLIST" - -echo "$LIST" | grep -v '^$' | -sed 's/^/#define __IOTK_/ - s/:/ /' >> iotk_config.h -echo "$LIST" | grep -v '^$' - -#################################################### -echo "Testing for bug 1 (non advancing input) ..." -cat << \EOF > bug1.f90 -program bug1 -implicit none -character(10) :: line - -open(file="bug1.txt",unit=10) -write(10,"(a)") "A" -write(10,"(a)") "B" -write(10,"(a)") "C" -close(10) - -open(file="bug1.txt",unit=10) -read(10,*) -read(10,"(a)",advance="no",eor=1) line -write(*,*) "FAILED" ! This line should not be reached -stop -1 continue -if(line /= "B") then - write(*,*) "FAILED" ! This line should not be reached - stop -end if -backspace(10) -read(10,"(a)",advance="no",eor=2) line -write(*,*) "FAILED" ! This line should not be reached -stop -2 continue -if(line /= "B") then - write(*,*) "FAILED" ! This line should not be reached - stop -end if -close(10) -write(*,*) "PASSED" - -end program bug1 -EOF - -$FC $FCFLAGS bug1.f90 -o bug1.x 2>/dev/null 1>/dev/null -PASSED= -$EXEC $TMPDIR/bug1.x 2>/dev/null | grep -q "PASSED" && PASSED=yes -if test -n "$PASSED" -then - echo "... test passed" -else - echo "... test failed, defining __IOTK_WORKAROUND1" - echo '#define __IOTK_WORKAROUND1' >> iotk_config.h -fi -#################################################### -DO_TEST2= -{ echo "$LIST" | grep -q 'LOGICAL.*:2$' ; } && -{ echo "$LIST" | grep -q 'LOGICAL.*:8$' ; } && -DO_TEST2=yes -if test -n "$DO_TEST2" ; then - echo 'Testing for bug 2 (converting between logical(2) and logical(8)) ...' -cat << \EOF > bug2.f90 -program main -implicit none -logical(2) :: l2 -logical(8) :: l8 -l8 = .true. -l2 = l8 -write(*,*) l2 -write(*,*) "PASSED" -end program main -EOF - -$FC $FCFLAGS bug2.f90 -o bug2.x 2>/dev/null 1>/dev/null -PASSED= -$EXEC $TMPDIR/bug2.x 2>/dev/null | grep -q "PASSED" && PASSED=yes -if test -n "$PASSED" -then - echo "... test passed" -else - echo "... test failed, defining __IOTK_WORKAROUND2" - echo '#define __IOTK_WORKAROUND2' >> iotk_config.h -fi - -fi - -#################################################### -echo 'Testing for bug 3 (pack) ...' - -cat << \EOF > bug3.f90 -program bug3 -implicit none - -integer, parameter :: size1 = 10000 -integer, parameter :: size2 = 1000 -integer :: out1(size1*size2) -integer :: out2(size1*size2) -integer :: in(size1,size2) -in=1 -call mypack(out1,in,size(in)) -out2=pack(in,mask=.true.) -if(all(out1==out2)) write(*,*) "PASSED" -end program bug3 - -subroutine mypack(out,in,n) -implicit none -integer, intent(in) :: n -integer, intent(in) :: in(n) -integer, intent(out) :: out(n) - out = in -end subroutine mypack -EOF - -$FC $FCFLAGS bug3.f90 -o bug3.x 2>/dev/null 1>/dev/null -PASSED= -$EXEC $TMPDIR/bug3.x 2>/dev/null | grep -q "PASSED" && PASSED=yes -if test -n "$PASSED" -then - echo "... test passed" -else - echo "... test failed, defining __IOTK_WORKAROUND3" - echo '#define __IOTK_WORKAROUND3' >> iotk_config.h -fi - -echo 'Testing for bug 4 (pack) ...' -cat << \EOF > bug4.f90 -program bug4 -implicit none -call sub((/"a","b","c"/)) -write(*,*) "PASSED" -contains - -subroutine sub(str) -character(len=*), intent(in) :: str(:) -write(*,*) pack(str,mask=.true.) -end subroutine sub - -end program bug4 -EOF - -$FC $FCFLAGS bug4.f90 -o bug4.x 2>/dev/null 1>/dev/null -PASSED= -$EXEC $TMPDIR/bug4.x 2>/dev/null | grep -q "PASSED" && PASSED=yes -if test -n "$PASSED" -then - echo "... test passed" -else - echo "... test failed, defining __IOTK_WORKAROUND4" - echo '#define __IOTK_WORKAROUND4' >> iotk_config.h -fi - -echo 'Testing for bug 5 [huge(1_1) does not compile as a parameter]' -cat << \EOF > bug5.f90 -program bug5 -integer, parameter :: i=huge(1_1) -write(*,*) "PASSED",i -end program bug5 -EOF - -$FC $FCFLAGS bug5.f90 -o bug5.x 2>/dev/null 1>/dev/null -PASSED= -$EXEC $TMPDIR/bug5.x 2>/dev/null | grep -q "PASSED" && PASSED=yes -if test -n "$PASSED" -then - echo "... test passed" -else - echo "... test failed, defining __IOTK_WORKAROUND5" - echo '#define __IOTK_WORKAROUND5' >> iotk_config.h -fi - - -if test -n "$ENABLE_MPI" -then - echo >> iotk_config.h - echo '#define __IOTK_MPI_ABORT' >> iotk_config.h -fi - -if test -n "$MAXRANK" -then - echo >> iotk_config.h - echo "#define __IOTK_MAXRANK $MAXRANK" >> iotk_config.h -fi - - -cat << EOF >> iotk_config.h - -#endif - -EOF - -cd $OLDPWD -mv $TMPDIR/iotk_config.h . -test -z "$NOCLEAN" && rm -fr $TMPDIR - - diff --git a/quantum_espresso/kcp/iotk/tools/configure b/quantum_espresso/kcp/iotk/tools/configure deleted file mode 100755 index 38a403ec1..000000000 --- a/quantum_espresso/kcp/iotk/tools/configure +++ /dev/null @@ -1,3265 +0,0 @@ -#! /bin/sh -# Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.59 for IOTK 0.1. -# -# Copyright (C) 2003 Free Software Foundation, Inc. -# This configure script is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. -## --------------------- ## -## M4sh Initialization. ## -## --------------------- ## - -# Be Bourne compatible -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then - emulate sh - NULLCMD=: - # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which - # is contrary to our usage. Disable this feature. - alias -g '${1+"$@"}'='"$@"' -elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then - set -o posix -fi -DUALCASE=1; export DUALCASE # for MKS sh - -# Support unset when possible. -if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then - as_unset=unset -else - as_unset=false -fi - - -# Work around bugs in pre-3.0 UWIN ksh. -$as_unset ENV MAIL MAILPATH -PS1='$ ' -PS2='> ' -PS4='+ ' - -# NLS nuisances. -for as_var in \ - LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ - LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ - LC_TELEPHONE LC_TIME -do - if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then - eval $as_var=C; export $as_var - else - $as_unset $as_var - fi -done - -# Required to use basename. -if expr a : '\(a\)' >/dev/null 2>&1; then - as_expr=expr -else - as_expr=false -fi - -if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then - as_basename=basename -else - as_basename=false -fi - - -# Name of the executable. -as_me=`$as_basename "$0" || -$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)$' \| \ - . : '\(.\)' 2>/dev/null || -echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } - /^X\/\(\/\/\)$/{ s//\1/; q; } - /^X\/\(\/\).*/{ s//\1/; q; } - s/.*/./; q'` - - -# PATH needs CR, and LINENO needs CR and PATH. -# Avoid depending upon Character Ranges. -as_cr_letters='abcdefghijklmnopqrstuvwxyz' -as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' -as_cr_Letters=$as_cr_letters$as_cr_LETTERS -as_cr_digits='0123456789' -as_cr_alnum=$as_cr_Letters$as_cr_digits - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - echo "#! /bin/sh" >conf$$.sh - echo "exit 0" >>conf$$.sh - chmod +x conf$$.sh - if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then - PATH_SEPARATOR=';' - else - PATH_SEPARATOR=: - fi - rm -f conf$$.sh -fi - - - as_lineno_1=$LINENO - as_lineno_2=$LINENO - as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` - test "x$as_lineno_1" != "x$as_lineno_2" && - test "x$as_lineno_3" = "x$as_lineno_2" || { - # Find who we are. Look in the path if we contain no path at all - # relative or not. - case $0 in - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break -done - - ;; - esac - # We did not find ourselves, most probably we were run as `sh COMMAND' - # in which case we are not to be found in the path. - if test "x$as_myself" = x; then - as_myself=$0 - fi - if test ! -f "$as_myself"; then - { echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2 - { (exit 1); exit 1; }; } - fi - case $CONFIG_SHELL in - '') - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for as_base in sh bash ksh sh5; do - case $as_dir in - /*) - if ("$as_dir/$as_base" -c ' - as_lineno_1=$LINENO - as_lineno_2=$LINENO - as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` - test "x$as_lineno_1" != "x$as_lineno_2" && - test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then - $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } - $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } - CONFIG_SHELL=$as_dir/$as_base - export CONFIG_SHELL - exec "$CONFIG_SHELL" "$0" ${1+"$@"} - fi;; - esac - done -done -;; - esac - - # Create $as_me.lineno as a copy of $as_myself, but with $LINENO - # uniformly replaced by the line number. The first 'sed' inserts a - # line-number line before each line; the second 'sed' does the real - # work. The second script uses 'N' to pair each line-number line - # with the numbered line, and appends trailing '-' during - # substitution so that $LINENO is not a special case at line end. - # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the - # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) - sed '=' <$as_myself | - sed ' - N - s,$,-, - : loop - s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, - t loop - s,-$,, - s,^['$as_cr_digits']*\n,, - ' >$as_me.lineno && - chmod +x $as_me.lineno || - { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 - { (exit 1); exit 1; }; } - - # Don't try to exec as it changes $[0], causing all sort of problems - # (the dirname of $[0] is not the place where we might find the - # original and so on. Autoconf is especially sensible to this). - . ./$as_me.lineno - # Exit status is that of the last command. - exit -} - - -case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in - *c*,-n*) ECHO_N= ECHO_C=' -' ECHO_T=' ' ;; - *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; - *) ECHO_N= ECHO_C='\c' ECHO_T= ;; -esac - -if expr a : '\(a\)' >/dev/null 2>&1; then - as_expr=expr -else - as_expr=false -fi - -rm -f conf$$ conf$$.exe conf$$.file -echo >conf$$.file -if ln -s conf$$.file conf$$ 2>/dev/null; then - # We could just check for DJGPP; but this test a) works b) is more generic - # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). - if test -f conf$$.exe; then - # Don't use ln at all; we don't have any links - as_ln_s='cp -p' - else - as_ln_s='ln -s' - fi -elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln -else - as_ln_s='cp -p' -fi -rm -f conf$$ conf$$.exe conf$$.file - -if mkdir -p . 2>/dev/null; then - as_mkdir_p=: -else - test -d ./-p && rmdir ./-p - as_mkdir_p=false -fi - -as_executable_p="test -f" - -# Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" - -# Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" - - -# IFS -# We need space, tab and new line, in precisely that order. -as_nl=' -' -IFS=" $as_nl" - -# CDPATH. -$as_unset CDPATH - - -# Name of the host. -# hostname on some systems (SVR3.2, Linux) returns a bogus exit status, -# so uname gets run too. -ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` - -exec 6>&1 - -# -# Initializations. -# -ac_default_prefix=/usr/local -ac_config_libobj_dir=. -cross_compiling=no -subdirs= -MFLAGS= -MAKEFLAGS= -SHELL=${CONFIG_SHELL-/bin/sh} - -# Maximum number of lines to put in a shell here document. -# This variable seems obsolete. It should probably be removed, and -# only ac_max_sed_lines should be used. -: ${ac_max_here_lines=38} - -# Identity of this package. -PACKAGE_NAME='IOTK' -PACKAGE_TARNAME='iotk' -PACKAGE_VERSION='0.1' -PACKAGE_STRING='IOTK 0.1' -PACKAGE_BUGREPORT='' - -ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS FC FCFLAGS LDFLAGS ac_ct_FC EXEEXT OBJEXT FCFLAGS_f90 IOTK_INTEGER IOTK_LOGICAL IOTK_REAL IOTK_BUGS IOTK_INTEGER1 IOTK_INTEGER2 IOTK_INTEGER3 IOTK_INTEGER4 IOTK_LOGICAL1 IOTK_LOGICAL2 IOTK_LOGICAL3 IOTK_LOGICAL4 IOTK_REAL1 IOTK_REAL2 IOTK_REAL3 IOTK_REAL4 IOTK_WORKAROUND1 IOTK_WORKAROUND2 IOTK_WORKAROUND3 IOTK_WORKAROUND4 IOTK_WORKAROUND5 IOTK_WORKAROUND6 IOTK_WORKAROUND7 IOTK_WORKAROUND8 IOTK_WORKAROUND9 LIBOBJS LTLIBOBJS' -ac_subst_files='' - -# Initialize some variables set by options. -ac_init_help= -ac_init_version=false -# The variables have the same names as the options, with -# dashes changed to underlines. -cache_file=/dev/null -exec_prefix=NONE -no_create= -no_recursion= -prefix=NONE -program_prefix=NONE -program_suffix=NONE -program_transform_name=s,x,x, -silent= -site= -srcdir= -verbose= -x_includes=NONE -x_libraries=NONE - -# Installation directory options. -# These are left unexpanded so users can "make install exec_prefix=/foo" -# and all the variables that are supposed to be based on exec_prefix -# by default will actually change. -# Use braces instead of parens because sh, perl, etc. also accept them. -bindir='${exec_prefix}/bin' -sbindir='${exec_prefix}/sbin' -libexecdir='${exec_prefix}/libexec' -datadir='${prefix}/share' -sysconfdir='${prefix}/etc' -sharedstatedir='${prefix}/com' -localstatedir='${prefix}/var' -libdir='${exec_prefix}/lib' -includedir='${prefix}/include' -oldincludedir='/usr/include' -infodir='${prefix}/info' -mandir='${prefix}/man' - -ac_prev= -for ac_option -do - # If the previous option needs an argument, assign it. - if test -n "$ac_prev"; then - eval "$ac_prev=\$ac_option" - ac_prev= - continue - fi - - ac_optarg=`expr "x$ac_option" : 'x[^=]*=\(.*\)'` - - # Accept the important Cygnus configure options, so we can diagnose typos. - - case $ac_option in - - -bindir | --bindir | --bindi | --bind | --bin | --bi) - ac_prev=bindir ;; - -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) - bindir=$ac_optarg ;; - - -build | --build | --buil | --bui | --bu) - ac_prev=build_alias ;; - -build=* | --build=* | --buil=* | --bui=* | --bu=*) - build_alias=$ac_optarg ;; - - -cache-file | --cache-file | --cache-fil | --cache-fi \ - | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) - ac_prev=cache_file ;; - -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ - | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) - cache_file=$ac_optarg ;; - - --config-cache | -C) - cache_file=config.cache ;; - - -datadir | --datadir | --datadi | --datad | --data | --dat | --da) - ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ - | --da=*) - datadir=$ac_optarg ;; - - -disable-* | --disable-*) - ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && - { echo "$as_me: error: invalid feature name: $ac_feature" >&2 - { (exit 1); exit 1; }; } - ac_feature=`echo $ac_feature | sed 's/-/_/g'` - eval "enable_$ac_feature=no" ;; - - -enable-* | --enable-*) - ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && - { echo "$as_me: error: invalid feature name: $ac_feature" >&2 - { (exit 1); exit 1; }; } - ac_feature=`echo $ac_feature | sed 's/-/_/g'` - case $ac_option in - *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; - *) ac_optarg=yes ;; - esac - eval "enable_$ac_feature='$ac_optarg'" ;; - - -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ - | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ - | --exec | --exe | --ex) - ac_prev=exec_prefix ;; - -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ - | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ - | --exec=* | --exe=* | --ex=*) - exec_prefix=$ac_optarg ;; - - -gas | --gas | --ga | --g) - # Obsolete; use --with-gas. - with_gas=yes ;; - - -help | --help | --hel | --he | -h) - ac_init_help=long ;; - -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) - ac_init_help=recursive ;; - -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) - ac_init_help=short ;; - - -host | --host | --hos | --ho) - ac_prev=host_alias ;; - -host=* | --host=* | --hos=* | --ho=*) - host_alias=$ac_optarg ;; - - -includedir | --includedir | --includedi | --included | --include \ - | --includ | --inclu | --incl | --inc) - ac_prev=includedir ;; - -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ - | --includ=* | --inclu=* | --incl=* | --inc=*) - includedir=$ac_optarg ;; - - -infodir | --infodir | --infodi | --infod | --info | --inf) - ac_prev=infodir ;; - -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) - infodir=$ac_optarg ;; - - -libdir | --libdir | --libdi | --libd) - ac_prev=libdir ;; - -libdir=* | --libdir=* | --libdi=* | --libd=*) - libdir=$ac_optarg ;; - - -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ - | --libexe | --libex | --libe) - ac_prev=libexecdir ;; - -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ - | --libexe=* | --libex=* | --libe=*) - libexecdir=$ac_optarg ;; - - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst \ - | --locals | --local | --loca | --loc | --lo) - ac_prev=localstatedir ;; - -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* \ - | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) - localstatedir=$ac_optarg ;; - - -mandir | --mandir | --mandi | --mand | --man | --ma | --m) - ac_prev=mandir ;; - -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) - mandir=$ac_optarg ;; - - -nfp | --nfp | --nf) - # Obsolete; use --without-fp. - with_fp=no ;; - - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c | -n) - no_create=yes ;; - - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) - no_recursion=yes ;; - - -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ - | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ - | --oldin | --oldi | --old | --ol | --o) - ac_prev=oldincludedir ;; - -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ - | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ - | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) - oldincludedir=$ac_optarg ;; - - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - prefix=$ac_optarg ;; - - -program-prefix | --program-prefix | --program-prefi | --program-pref \ - | --program-pre | --program-pr | --program-p) - ac_prev=program_prefix ;; - -program-prefix=* | --program-prefix=* | --program-prefi=* \ - | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) - program_prefix=$ac_optarg ;; - - -program-suffix | --program-suffix | --program-suffi | --program-suff \ - | --program-suf | --program-su | --program-s) - ac_prev=program_suffix ;; - -program-suffix=* | --program-suffix=* | --program-suffi=* \ - | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) - program_suffix=$ac_optarg ;; - - -program-transform-name | --program-transform-name \ - | --program-transform-nam | --program-transform-na \ - | --program-transform-n | --program-transform- \ - | --program-transform | --program-transfor \ - | --program-transfo | --program-transf \ - | --program-trans | --program-tran \ - | --progr-tra | --program-tr | --program-t) - ac_prev=program_transform_name ;; - -program-transform-name=* | --program-transform-name=* \ - | --program-transform-nam=* | --program-transform-na=* \ - | --program-transform-n=* | --program-transform-=* \ - | --program-transform=* | --program-transfor=* \ - | --program-transfo=* | --program-transf=* \ - | --program-trans=* | --program-tran=* \ - | --progr-tra=* | --program-tr=* | --program-t=*) - program_transform_name=$ac_optarg ;; - - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - silent=yes ;; - - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) - ac_prev=sbindir ;; - -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ - | --sbi=* | --sb=*) - sbindir=$ac_optarg ;; - - -sharedstatedir | --sharedstatedir | --sharedstatedi \ - | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ - | --sharedst | --shareds | --shared | --share | --shar \ - | --sha | --sh) - ac_prev=sharedstatedir ;; - -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ - | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ - | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ - | --sha=* | --sh=*) - sharedstatedir=$ac_optarg ;; - - -site | --site | --sit) - ac_prev=site ;; - -site=* | --site=* | --sit=*) - site=$ac_optarg ;; - - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - srcdir=$ac_optarg ;; - - -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ - | --syscon | --sysco | --sysc | --sys | --sy) - ac_prev=sysconfdir ;; - -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ - | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) - sysconfdir=$ac_optarg ;; - - -target | --target | --targe | --targ | --tar | --ta | --t) - ac_prev=target_alias ;; - -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) - target_alias=$ac_optarg ;; - - -v | -verbose | --verbose | --verbos | --verbo | --verb) - verbose=yes ;; - - -version | --version | --versio | --versi | --vers | -V) - ac_init_version=: ;; - - -with-* | --with-*) - ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && - { echo "$as_me: error: invalid package name: $ac_package" >&2 - { (exit 1); exit 1; }; } - ac_package=`echo $ac_package| sed 's/-/_/g'` - case $ac_option in - *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; - *) ac_optarg=yes ;; - esac - eval "with_$ac_package='$ac_optarg'" ;; - - -without-* | --without-*) - ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && - { echo "$as_me: error: invalid package name: $ac_package" >&2 - { (exit 1); exit 1; }; } - ac_package=`echo $ac_package | sed 's/-/_/g'` - eval "with_$ac_package=no" ;; - - --x) - # Obsolete; use --with-x. - with_x=yes ;; - - -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ - | --x-incl | --x-inc | --x-in | --x-i) - ac_prev=x_includes ;; - -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ - | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) - x_includes=$ac_optarg ;; - - -x-libraries | --x-libraries | --x-librarie | --x-librari \ - | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) - ac_prev=x_libraries ;; - -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ - | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) - x_libraries=$ac_optarg ;; - - -*) { echo "$as_me: error: unrecognized option: $ac_option -Try \`$0 --help' for more information." >&2 - { (exit 1); exit 1; }; } - ;; - - *=*) - ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` - # Reject names that are not valid shell variable names. - expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null && - { echo "$as_me: error: invalid variable name: $ac_envvar" >&2 - { (exit 1); exit 1; }; } - ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` - eval "$ac_envvar='$ac_optarg'" - export $ac_envvar ;; - - *) - # FIXME: should be removed in autoconf 3.0. - echo "$as_me: WARNING: you should use --build, --host, --target" >&2 - expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && - echo "$as_me: WARNING: invalid host type: $ac_option" >&2 - : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} - ;; - - esac -done - -if test -n "$ac_prev"; then - ac_option=--`echo $ac_prev | sed 's/_/-/g'` - { echo "$as_me: error: missing argument to $ac_option" >&2 - { (exit 1); exit 1; }; } -fi - -# Be sure to have absolute paths. -for ac_var in exec_prefix prefix -do - eval ac_val=$`echo $ac_var` - case $ac_val in - [\\/$]* | ?:[\\/]* | NONE | '' ) ;; - *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 - { (exit 1); exit 1; }; };; - esac -done - -# Be sure to have absolute paths. -for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ - localstatedir libdir includedir oldincludedir infodir mandir -do - eval ac_val=$`echo $ac_var` - case $ac_val in - [\\/$]* | ?:[\\/]* ) ;; - *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 - { (exit 1); exit 1; }; };; - esac -done - -# There might be people who depend on the old broken behavior: `$host' -# used to hold the argument of --host etc. -# FIXME: To remove some day. -build=$build_alias -host=$host_alias -target=$target_alias - -# FIXME: To remove some day. -if test "x$host_alias" != x; then - if test "x$build_alias" = x; then - cross_compiling=maybe - echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. - If a cross compiler is detected then cross compile mode will be used." >&2 - elif test "x$build_alias" != "x$host_alias"; then - cross_compiling=yes - fi -fi - -ac_tool_prefix= -test -n "$host_alias" && ac_tool_prefix=$host_alias- - -test "$silent" = yes && exec 6>/dev/null - - -# Find the source files, if location was not specified. -if test -z "$srcdir"; then - ac_srcdir_defaulted=yes - # Try the directory containing this script, then its parent. - ac_confdir=`(dirname "$0") 2>/dev/null || -$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$0" : 'X\(//\)[^/]' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| \ - . : '\(.\)' 2>/dev/null || -echo X"$0" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } - /^X\(\/\/\)[^/].*/{ s//\1/; q; } - /^X\(\/\/\)$/{ s//\1/; q; } - /^X\(\/\).*/{ s//\1/; q; } - s/.*/./; q'` - srcdir=$ac_confdir - if test ! -r $srcdir/$ac_unique_file; then - srcdir=.. - fi -else - ac_srcdir_defaulted=no -fi -if test ! -r $srcdir/$ac_unique_file; then - if test "$ac_srcdir_defaulted" = yes; then - { echo "$as_me: error: cannot find sources ($ac_unique_file) in $ac_confdir or .." >&2 - { (exit 1); exit 1; }; } - else - { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2 - { (exit 1); exit 1; }; } - fi -fi -(cd $srcdir && test -r ./$ac_unique_file) 2>/dev/null || - { echo "$as_me: error: sources are in $srcdir, but \`cd $srcdir' does not work" >&2 - { (exit 1); exit 1; }; } -srcdir=`echo "$srcdir" | sed 's%\([^\\/]\)[\\/]*$%\1%'` -ac_env_build_alias_set=${build_alias+set} -ac_env_build_alias_value=$build_alias -ac_cv_env_build_alias_set=${build_alias+set} -ac_cv_env_build_alias_value=$build_alias -ac_env_host_alias_set=${host_alias+set} -ac_env_host_alias_value=$host_alias -ac_cv_env_host_alias_set=${host_alias+set} -ac_cv_env_host_alias_value=$host_alias -ac_env_target_alias_set=${target_alias+set} -ac_env_target_alias_value=$target_alias -ac_cv_env_target_alias_set=${target_alias+set} -ac_cv_env_target_alias_value=$target_alias -ac_env_FC_set=${FC+set} -ac_env_FC_value=$FC -ac_cv_env_FC_set=${FC+set} -ac_cv_env_FC_value=$FC -ac_env_FCFLAGS_set=${FCFLAGS+set} -ac_env_FCFLAGS_value=$FCFLAGS -ac_cv_env_FCFLAGS_set=${FCFLAGS+set} -ac_cv_env_FCFLAGS_value=$FCFLAGS -ac_env_LDFLAGS_set=${LDFLAGS+set} -ac_env_LDFLAGS_value=$LDFLAGS -ac_cv_env_LDFLAGS_set=${LDFLAGS+set} -ac_cv_env_LDFLAGS_value=$LDFLAGS - -# -# Report the --help message. -# -if test "$ac_init_help" = "long"; then - # Omit some internal or obsolete options to make the list less imposing. - # This message is too long to be a string in the A/UX 3.1 sh. - cat <<_ACEOF -\`configure' configures IOTK 0.1 to adapt to many kinds of systems. - -Usage: $0 [OPTION]... [VAR=VALUE]... - -To assign environment variables (e.g., CC, CFLAGS...), specify them as -VAR=VALUE. See below for descriptions of some of the useful variables. - -Defaults for the options are specified in brackets. - -Configuration: - -h, --help display this help and exit - --help=short display options specific to this package - --help=recursive display the short help of all the included packages - -V, --version display version information and exit - -q, --quiet, --silent do not print \`checking...' messages - --cache-file=FILE cache test results in FILE [disabled] - -C, --config-cache alias for \`--cache-file=config.cache' - -n, --no-create do not create output files - --srcdir=DIR find the sources in DIR [configure dir or \`..'] - -_ACEOF - - cat <<_ACEOF -Installation directories: - --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] - --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [PREFIX] - -By default, \`make install' will install all the files in -\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify -an installation prefix other than \`$ac_default_prefix' using \`--prefix', -for instance \`--prefix=\$HOME'. - -For better control, use the options below. - -Fine tuning of the installation directories: - --bindir=DIR user executables [EPREFIX/bin] - --sbindir=DIR system admin executables [EPREFIX/sbin] - --libexecdir=DIR program executables [EPREFIX/libexec] - --datadir=DIR read-only architecture-independent data [PREFIX/share] - --sysconfdir=DIR read-only single-machine data [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] - --localstatedir=DIR modifiable single-machine data [PREFIX/var] - --libdir=DIR object code libraries [EPREFIX/lib] - --includedir=DIR C header files [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc [/usr/include] - --infodir=DIR info documentation [PREFIX/info] - --mandir=DIR man documentation [PREFIX/man] -_ACEOF - - cat <<\_ACEOF -_ACEOF -fi - -if test -n "$ac_init_help"; then - case $ac_init_help in - short | recursive ) echo "Configuration of IOTK 0.1:";; - esac - cat <<\_ACEOF - -Some influential environment variables: - FC Fortran compiler command - FCFLAGS Fortran compiler flags - LDFLAGS linker flags, e.g. -L if you have libraries in a - nonstandard directory - -Use these variables to override the choices made by `configure' or to help -it to find libraries and programs with nonstandard names/locations. - -_ACEOF -fi - -if test "$ac_init_help" = "recursive"; then - # If there are subdirs, report their specific --help. - ac_popdir=`pwd` - for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue - test -d $ac_dir || continue - ac_builddir=. - -if test "$ac_dir" != .; then - ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` - # A "../" for each directory in $ac_dir_suffix. - ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` -else - ac_dir_suffix= ac_top_builddir= -fi - -case $srcdir in - .) # No --srcdir option. We are building in place. - ac_srcdir=. - if test -z "$ac_top_builddir"; then - ac_top_srcdir=. - else - ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` - fi ;; - [\\/]* | ?:[\\/]* ) # Absolute path. - ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir ;; - *) # Relative path. - ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_builddir$srcdir ;; -esac - -# Do not use `cd foo && pwd` to compute absolute paths, because -# the directories may not exist. -case `pwd` in -.) ac_abs_builddir="$ac_dir";; -*) - case "$ac_dir" in - .) ac_abs_builddir=`pwd`;; - [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; - *) ac_abs_builddir=`pwd`/"$ac_dir";; - esac;; -esac -case $ac_abs_builddir in -.) ac_abs_top_builddir=${ac_top_builddir}.;; -*) - case ${ac_top_builddir}. in - .) ac_abs_top_builddir=$ac_abs_builddir;; - [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; - *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; - esac;; -esac -case $ac_abs_builddir in -.) ac_abs_srcdir=$ac_srcdir;; -*) - case $ac_srcdir in - .) ac_abs_srcdir=$ac_abs_builddir;; - [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; - *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; - esac;; -esac -case $ac_abs_builddir in -.) ac_abs_top_srcdir=$ac_top_srcdir;; -*) - case $ac_top_srcdir in - .) ac_abs_top_srcdir=$ac_abs_builddir;; - [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; - *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; - esac;; -esac - - cd $ac_dir - # Check for guested configure; otherwise get Cygnus style configure. - if test -f $ac_srcdir/configure.gnu; then - echo - $SHELL $ac_srcdir/configure.gnu --help=recursive - elif test -f $ac_srcdir/configure; then - echo - $SHELL $ac_srcdir/configure --help=recursive - elif test -f $ac_srcdir/configure.ac || - test -f $ac_srcdir/configure.in; then - echo - $ac_configure --help - else - echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 - fi - cd $ac_popdir - done -fi - -test -n "$ac_init_help" && exit 0 -if $ac_init_version; then - cat <<\_ACEOF -IOTK configure 0.1 -generated by GNU Autoconf 2.59 - -Copyright (C) 2003 Free Software Foundation, Inc. -This configure script is free software; the Free Software Foundation -gives unlimited permission to copy, distribute and modify it. -_ACEOF - exit 0 -fi -exec 5>config.log -cat >&5 <<_ACEOF -This file contains any messages produced by compilers while -running configure, to aid debugging if configure makes a mistake. - -It was created by IOTK $as_me 0.1, which was -generated by GNU Autoconf 2.59. Invocation command line was - - $ $0 $@ - -_ACEOF -{ -cat <<_ASUNAME -## --------- ## -## Platform. ## -## --------- ## - -hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` -uname -m = `(uname -m) 2>/dev/null || echo unknown` -uname -r = `(uname -r) 2>/dev/null || echo unknown` -uname -s = `(uname -s) 2>/dev/null || echo unknown` -uname -v = `(uname -v) 2>/dev/null || echo unknown` - -/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` -/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` - -/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` -/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` -/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` -hostinfo = `(hostinfo) 2>/dev/null || echo unknown` -/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` -/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` -/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` - -_ASUNAME - -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - echo "PATH: $as_dir" -done - -} >&5 - -cat >&5 <<_ACEOF - - -## ----------- ## -## Core tests. ## -## ----------- ## - -_ACEOF - - -# Keep a trace of the command line. -# Strip out --no-create and --no-recursion so they do not pile up. -# Strip out --silent because we don't want to record it for future runs. -# Also quote any args containing shell meta-characters. -# Make two passes to allow for proper duplicate-argument suppression. -ac_configure_args= -ac_configure_args0= -ac_configure_args1= -ac_sep= -ac_must_keep_next=false -for ac_pass in 1 2 -do - for ac_arg - do - case $ac_arg in - -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - continue ;; - *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) - ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; - esac - case $ac_pass in - 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; - 2) - ac_configure_args1="$ac_configure_args1 '$ac_arg'" - if test $ac_must_keep_next = true; then - ac_must_keep_next=false # Got value, back to normal. - else - case $ac_arg in - *=* | --config-cache | -C | -disable-* | --disable-* \ - | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ - | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ - | -with-* | --with-* | -without-* | --without-* | --x) - case "$ac_configure_args0 " in - "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; - esac - ;; - -* ) ac_must_keep_next=true ;; - esac - fi - ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'" - # Get rid of the leading space. - ac_sep=" " - ;; - esac - done -done -$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; } -$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; } - -# When interrupted or exit'd, cleanup temporary files, and complete -# config.log. We remove comments because anyway the quotes in there -# would cause problems or look ugly. -# WARNING: Be sure not to use single quotes in there, as some shells, -# such as our DU 5.0 friend, will then `close' the trap. -trap 'exit_status=$? - # Save into config.log some information that might help in debugging. - { - echo - - cat <<\_ASBOX -## ---------------- ## -## Cache variables. ## -## ---------------- ## -_ASBOX - echo - # The following way of writing the cache mishandles newlines in values, -{ - (set) 2>&1 | - case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in - *ac_space=\ *) - sed -n \ - "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" - ;; - *) - sed -n \ - "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" - ;; - esac; -} - echo - - cat <<\_ASBOX -## ----------------- ## -## Output variables. ## -## ----------------- ## -_ASBOX - echo - for ac_var in $ac_subst_vars - do - eval ac_val=$`echo $ac_var` - echo "$ac_var='"'"'$ac_val'"'"'" - done | sort - echo - - if test -n "$ac_subst_files"; then - cat <<\_ASBOX -## ------------- ## -## Output files. ## -## ------------- ## -_ASBOX - echo - for ac_var in $ac_subst_files - do - eval ac_val=$`echo $ac_var` - echo "$ac_var='"'"'$ac_val'"'"'" - done | sort - echo - fi - - if test -s confdefs.h; then - cat <<\_ASBOX -## ----------- ## -## confdefs.h. ## -## ----------- ## -_ASBOX - echo - sed "/^$/d" confdefs.h | sort - echo - fi - test "$ac_signal" != 0 && - echo "$as_me: caught signal $ac_signal" - echo "$as_me: exit $exit_status" - } >&5 - rm -f core *.core && - rm -rf conftest* confdefs* conf$$* $ac_clean_files && - exit $exit_status - ' 0 -for ac_signal in 1 2 13 15; do - trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal -done -ac_signal=0 - -# confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -rf conftest* confdefs.h -# AIX cpp loses on an empty file, so make sure it contains at least a newline. -echo >confdefs.h - -# Predefined preprocessor variables. - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_NAME "$PACKAGE_NAME" -_ACEOF - - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_TARNAME "$PACKAGE_TARNAME" -_ACEOF - - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_VERSION "$PACKAGE_VERSION" -_ACEOF - - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_STRING "$PACKAGE_STRING" -_ACEOF - - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" -_ACEOF - - -# Let the site file select an alternate cache file if it wants to. -# Prefer explicitly selected file to automatically selected ones. -if test -z "$CONFIG_SITE"; then - if test "x$prefix" != xNONE; then - CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" - else - CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" - fi -fi -for ac_site_file in $CONFIG_SITE; do - if test -r "$ac_site_file"; then - { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5 -echo "$as_me: loading site script $ac_site_file" >&6;} - sed 's/^/| /' "$ac_site_file" >&5 - . "$ac_site_file" - fi -done - -if test -r "$cache_file"; then - # Some versions of bash will fail to source /dev/null (special - # files actually), so we avoid doing that. - if test -f "$cache_file"; then - { echo "$as_me:$LINENO: loading cache $cache_file" >&5 -echo "$as_me: loading cache $cache_file" >&6;} - case $cache_file in - [\\/]* | ?:[\\/]* ) . $cache_file;; - *) . ./$cache_file;; - esac - fi -else - { echo "$as_me:$LINENO: creating cache $cache_file" >&5 -echo "$as_me: creating cache $cache_file" >&6;} - >$cache_file -fi - -# Check that the precious variables saved in the cache have kept the same -# value. -ac_cache_corrupted=false -for ac_var in `(set) 2>&1 | - sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do - eval ac_old_set=\$ac_cv_env_${ac_var}_set - eval ac_new_set=\$ac_env_${ac_var}_set - eval ac_old_val="\$ac_cv_env_${ac_var}_value" - eval ac_new_val="\$ac_env_${ac_var}_value" - case $ac_old_set,$ac_new_set in - set,) - { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 -echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} - ac_cache_corrupted=: ;; - ,set) - { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 -echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} - ac_cache_corrupted=: ;; - ,);; - *) - if test "x$ac_old_val" != "x$ac_new_val"; then - { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 -echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} - { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 -echo "$as_me: former value: $ac_old_val" >&2;} - { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 -echo "$as_me: current value: $ac_new_val" >&2;} - ac_cache_corrupted=: - fi;; - esac - # Pass precious variables to config.status. - if test "$ac_new_set" = set; then - case $ac_new_val in - *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) - ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; - *) ac_arg=$ac_var=$ac_new_val ;; - esac - case " $ac_configure_args " in - *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. - *) ac_configure_args="$ac_configure_args '$ac_arg'" ;; - esac - fi -done -if $ac_cache_corrupted; then - { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 -echo "$as_me: error: changes in the environment can compromise the build" >&2;} - { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 -echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;} - { (exit 1); exit 1; }; } -fi - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - - - - - - - - - - - - - - - - - - - - - - - - - - - -# LIST OF USED ENVIRONMENT VARIABLES: -# IOTK_INTEGER_KINDS -# IOTK_LOGICAL_KINDS -# IOTK_REAL_KINDS -# colon separated lists of kinds -# a kind ALL expands to hopefully all kinds - -# Default integer and logical are added by default -IOTK_INTEGER_KINDS="kind(1):$IOTK_INTEGER_KINDS" -IOTK_LOGICAL_KINDS="kind(.true.):$IOTK_LOGICAL_KINDS" - -# Save the default IFS -IFS_BACKUP="$IFS" - -# Define the newline character -NEWLINE=" -" - -# Define the backslash character - -ac_ext=${FC_SRCEXT-f} -ac_compile='$FC -c $FCFLAGS $FCFLAGS_SRCEXT conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $FCFLAGS_SRCEXT conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu -if test -n "$ac_tool_prefix"; then - for ac_prog in ifort g95 f95 pgf90 xlf90 - do - # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. -set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -echo "$as_me:$LINENO: checking for $ac_word" >&5 -echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 -if test "${ac_cv_prog_FC+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - if test -n "$FC"; then - ac_cv_prog_FC="$FC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_FC="$ac_tool_prefix$ac_prog" - echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done -done - -fi -fi -FC=$ac_cv_prog_FC -if test -n "$FC"; then - echo "$as_me:$LINENO: result: $FC" >&5 -echo "${ECHO_T}$FC" >&6 -else - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 -fi - - test -n "$FC" && break - done -fi -if test -z "$FC"; then - ac_ct_FC=$FC - for ac_prog in ifort g95 f95 pgf90 xlf90 -do - # Extract the first word of "$ac_prog", so it can be a program name with args. -set dummy $ac_prog; ac_word=$2 -echo "$as_me:$LINENO: checking for $ac_word" >&5 -echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 -if test "${ac_cv_prog_ac_ct_FC+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - if test -n "$ac_ct_FC"; then - ac_cv_prog_ac_ct_FC="$ac_ct_FC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_FC="$ac_prog" - echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done -done - -fi -fi -ac_ct_FC=$ac_cv_prog_ac_ct_FC -if test -n "$ac_ct_FC"; then - echo "$as_me:$LINENO: result: $ac_ct_FC" >&5 -echo "${ECHO_T}$ac_ct_FC" >&6 -else - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 -fi - - test -n "$ac_ct_FC" && break -done - - FC=$ac_ct_FC -fi - - -# Provide some information about the compiler. -echo "$as_me:1363:" \ - "checking for Fortran compiler version" >&5 -ac_compiler=`set X $ac_compile; echo $2` -{ (eval echo "$as_me:$LINENO: \"$ac_compiler --version &5\"") >&5 - (eval $ac_compiler --version &5) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } -{ (eval echo "$as_me:$LINENO: \"$ac_compiler -v &5\"") >&5 - (eval $ac_compiler -v &5) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } -{ (eval echo "$as_me:$LINENO: \"$ac_compiler -V &5\"") >&5 - (eval $ac_compiler -V &5) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } -rm -f a.out - -cat >conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -ac_clean_files_save=$ac_clean_files -ac_clean_files="$ac_clean_files a.out a.exe b.out" -# Try to create an executable without -o first, disregard a.out. -# It will help us diagnose broken compilers, and finding out an intuition -# of exeext. -echo "$as_me:$LINENO: checking for Fortran compiler default output file name" >&5 -echo $ECHO_N "checking for Fortran compiler default output file name... $ECHO_C" >&6 -ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` -if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5 - (eval $ac_link_default) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; then - # Find the output, starting from the most likely. This scheme is -# not robust to junk in `.', hence go to wildcards (a.*) only as a last -# resort. - -# Be careful to initialize this variable, since it used to be cached. -# Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile. -ac_cv_exeext= -# b.out is created by i960 compilers. -for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out -do - test -f "$ac_file" || continue - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) - ;; - conftest.$ac_ext ) - # This is the source file. - ;; - [ab].out ) - # We found the default executable, but exeext='' is most - # certainly right. - break;; - *.* ) - ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - # FIXME: I believe we export ac_cv_exeext for Libtool, - # but it would be cool to find out if it's true. Does anybody - # maintain Libtool? --akim. - export ac_cv_exeext - break;; - * ) - break;; - esac -done -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -{ { echo "$as_me:$LINENO: error: Fortran compiler cannot create executables -See \`config.log' for more details." >&5 -echo "$as_me: error: Fortran compiler cannot create executables -See \`config.log' for more details." >&2;} - { (exit 77); exit 77; }; } -fi - -ac_exeext=$ac_cv_exeext -echo "$as_me:$LINENO: result: $ac_file" >&5 -echo "${ECHO_T}$ac_file" >&6 - -# Check the compiler produces executables we can run. If not, either -# the compiler is broken, or we cross compile. -echo "$as_me:$LINENO: checking whether the Fortran compiler works" >&5 -echo $ECHO_N "checking whether the Fortran compiler works... $ECHO_C" >&6 -# FIXME: These cross compiler hacks should be removed for Autoconf 3.0 -# If not cross compiling, check that we can run a simple program. -if test "$cross_compiling" != yes; then - if { ac_try='./$ac_file' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - cross_compiling=no - else - if test "$cross_compiling" = maybe; then - cross_compiling=yes - else - { { echo "$as_me:$LINENO: error: cannot run Fortran compiled programs. -If you meant to cross compile, use \`--host'. -See \`config.log' for more details." >&5 -echo "$as_me: error: cannot run Fortran compiled programs. -If you meant to cross compile, use \`--host'. -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; } - fi - fi -fi -echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 - -rm -f a.out a.exe conftest$ac_cv_exeext b.out -ac_clean_files=$ac_clean_files_save -# Check the compiler produces executables we can run. If not, either -# the compiler is broken, or we cross compile. -echo "$as_me:$LINENO: checking whether we are cross compiling" >&5 -echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6 -echo "$as_me:$LINENO: result: $cross_compiling" >&5 -echo "${ECHO_T}$cross_compiling" >&6 - -echo "$as_me:$LINENO: checking for suffix of executables" >&5 -echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6 -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; then - # If both `conftest.exe' and `conftest' are `present' (well, observable) -# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will -# work properly (i.e., refer to `conftest.exe'), while it won't with -# `rm'. -for ac_file in conftest.exe conftest conftest.*; do - test -f "$ac_file" || continue - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; - *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - export ac_cv_exeext - break;; - * ) break;; - esac -done -else - { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link -See \`config.log' for more details." >&5 -echo "$as_me: error: cannot compute suffix of executables: cannot compile and link -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; } -fi - -rm -f conftest$ac_cv_exeext -echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5 -echo "${ECHO_T}$ac_cv_exeext" >&6 - -rm -f conftest.$ac_ext -EXEEXT=$ac_cv_exeext -ac_exeext=$EXEEXT -echo "$as_me:$LINENO: checking for suffix of object files" >&5 -echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 -if test "${ac_cv_objext+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -rm -f conftest.o conftest.obj -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; then - for ac_file in `(ls conftest.o conftest.obj; ls conftest.*) 2>/dev/null`; do - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg ) ;; - *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` - break;; - esac -done -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -{ { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile -See \`config.log' for more details." >&5 -echo "$as_me: error: cannot compute suffix of object files: cannot compile -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; } -fi - -rm -f conftest.$ac_cv_objext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: $ac_cv_objext" >&5 -echo "${ECHO_T}$ac_cv_objext" >&6 -OBJEXT=$ac_cv_objext -ac_objext=$OBJEXT -# If we don't use `.F' as extension, the preprocessor is not run on the -# input file. (Note that this only needs to work for GNU compilers.) -ac_save_ext=$ac_ext -ac_ext=F -echo "$as_me:$LINENO: checking whether we are using the GNU Fortran compiler" >&5 -echo $ECHO_N "checking whether we are using the GNU Fortran compiler... $ECHO_C" >&6 -if test "${ac_cv_fc_compiler_gnu+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF - program main -#ifndef __GNUC__ - choke me -#endif - - end -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_fc_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_compiler_gnu=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_compiler_gnu=no -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -ac_cv_fc_compiler_gnu=$ac_compiler_gnu - -fi -echo "$as_me:$LINENO: result: $ac_cv_fc_compiler_gnu" >&5 -echo "${ECHO_T}$ac_cv_fc_compiler_gnu" >&6 -ac_ext=$ac_save_ext -ac_test_FFLAGS=${FCFLAGS+set} -ac_save_FFLAGS=$FCFLAGS -FCFLAGS= -echo "$as_me:$LINENO: checking whether $FC accepts -g" >&5 -echo $ECHO_N "checking whether $FC accepts -g... $ECHO_C" >&6 -if test "${ac_cv_prog_fc_g+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - FCFLAGS=-g -cat >conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_fc_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_cv_prog_fc_g=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_cv_prog_fc_g=no -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext - -fi -echo "$as_me:$LINENO: result: $ac_cv_prog_fc_g" >&5 -echo "${ECHO_T}$ac_cv_prog_fc_g" >&6 -if test "$ac_test_FFLAGS" = set; then - FCFLAGS=$ac_save_FFLAGS -elif test $ac_cv_prog_fc_g = yes; then - if test "x$ac_cv_fc_compiler_gnu" = xyes; then - FCFLAGS="-g -O2" - else - FCFLAGS="-g" - fi -else - if test "x$ac_cv_fc_compiler_gnu" = xyes; then - FCFLAGS="-O2" - else - FCFLAGS= - fi -fi - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -# Selecting the language -ac_ext=${FC_SRCEXT-f} -ac_compile='$FC -c $FCFLAGS $FCFLAGS_SRCEXT conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $FCFLAGS_SRCEXT conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - - -# Selecting the source extension - -echo "$as_me:$LINENO: checking for Fortran flag to compile .f90 files" >&5 -echo $ECHO_N "checking for Fortran flag to compile .f90 files... $ECHO_C" >&6 -if test "${ac_cv_fc_srcext_f90+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - ac_ext=f90 -ac_fc_srcext_FCFLAGS_SRCEXT_save=$FCFLAGS_SRCEXT -FCFLAGS_SRCEXT="" -ac_cv_fc_srcext_f90=unknown -for ac_flag in none -qsuffix=f=f90 -Tf; do - test "x$ac_flag" != xnone && FCFLAGS_SRCEXT="$ac_flag" - cat >conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_fc_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_cv_fc_srcext_f90=$ac_flag; break -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -done -rm -f conftest.$ac_objext conftest.f90 -FCFLAGS_SRCEXT=$ac_fc_srcext_FCFLAGS_SRCEXT_save - -fi -echo "$as_me:$LINENO: result: $ac_cv_fc_srcext_f90" >&5 -echo "${ECHO_T}$ac_cv_fc_srcext_f90" >&6 -if test "x$ac_cv_fc_srcext_f90" = xunknown; then - { { echo "$as_me:$LINENO: error: Fortran could not compile .f90 files" >&5 -echo "$as_me: error: Fortran could not compile .f90 files" >&2;} - { (exit 1); exit 1; }; } -else - FC_SRCEXT=f90 - if test "x$ac_cv_fc_srcext_f90" = xnone; then - FCFLAGS_SRCEXT="" - FCFLAGS_f90="" - else - FCFLAGS_SRCEXT=$ac_cv_fc_srcext_f90 - FCFLAGS_f90=$ac_cv_fc_srcext_f90 - fi - - -fi - - -{ echo "$as_me:$LINENO: checking intrinsic FORTRAN kinds" >&5 -echo "$as_me: checking intrinsic FORTRAN kinds" >&6;} - -# Loop over types -for TYPE in INTEGER LOGICAL REAL -do - eval LIST=\"\$IOTK_${TYPE}_KINDS\" - -# Expansion of the 'ALL' keyword - NLIST="" - IFS=":" - for KIND in $LIST - do - case "$KIND" in - ALL) NLIST="$NLIST:1:2:3:4:5:6:7:8:10:12:16:24:32" ;; - *) NLIST="$NLIST:$KIND" ;; - esac - done - IFS="$IFS_BACKUP" - LIST="$NLIST" - - NLIST="" - IFS=":" - for KIND in $LIST - do - IFS="$IFS_BACKUP" - - if test -n "$KIND" - then - echo "$as_me:$LINENO: checking intrinsic type $TYPE(kind=$KIND)" >&5 -echo $ECHO_N "checking intrinsic type $TYPE(kind=$KIND)... $ECHO_C" >&6 - if test "$cross_compiling" = yes; then - { { echo "$as_me:$LINENO: error: cannot run test program while cross compiling -See \`config.log' for more details." >&5 -echo "$as_me: error: cannot run test program while cross compiling -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; } -else - cat >conftest.$ac_ext <<_ACEOF - - program pippo - implicit none - $TYPE (kind=$KIND) :: try - open(10,file="test.txt") - if(kind(try)==$KIND) write(10,"(a,i8)") "KIND=",kind(try) - close(10) - end program pippo - -_ACEOF -rm -f conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - DONE=yes -else - echo "$as_me: program exited with status $ac_status" >&5 -echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -( exit $ac_status ) -DONE="" - -fi -rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext -fi - - if test -n "$DONE" - then - if grep -q KIND= < test.txt - then - echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 - NLIST="$NLIST:"`sed -n 's/KIND= *//p' < test.txt` - else - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 - fi - else - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 - fi - if test -f test.txt ; then rm test.txt ; fi - fi - - done - IFS="$IFS_BACKUP" - LIST="$NLIST" - - { echo "$as_me:$LINENO: Eliminating duplicates" >&5 -echo "$as_me: Eliminating duplicates" >&6;} - - NLIST="" - IFS=":" - for KIND in $LIST - do - if test -n "$KIND" - then - WAS_FOUND="" - for KIND1 in $NLIST - do - if test -n "$KIND1" - then - test "$KIND1" -eq "$KIND" && WAS_FOUND=yes - fi - done - test -n "$WAS_FOUND" || NLIST="$NLIST:$KIND" - fi - done - IFS="$IFS_BACKUP" - LIST="$NLIST" - - IFS=":" - COUNT=0 - for KIND in $LIST - do - if test -n "$KIND" - then - COUNT=`expr $COUNT + 1` - eval "IOTK_$TYPE$COUNT='#define __IOTK_$TYPE$COUNT $KIND'" - fi - done - IFS="$IFS_BACKUP" -done - -############## -# KNOWN BUGS # -############## - -IOTK_BUGS="" -{ echo "$as_me:$LINENO: checking for known bugs" >&5 -echo "$as_me: checking for known bugs" >&6;} - -# BUG 1 -echo "$as_me:$LINENO: checking bug in non-advancing read" >&5 -echo $ECHO_N "checking bug in non-advancing read... $ECHO_C" >&6 -if test "$cross_compiling" = yes; then - { { echo "$as_me:$LINENO: error: cannot run test program while cross compiling -See \`config.log' for more details." >&5 -echo "$as_me: error: cannot run test program while cross compiling -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; } -else - cat >conftest.$ac_ext <<_ACEOF - -program bug1 -implicit none -character(10) :: line -open(file="bug1.txt",unit=10) -open(file="result.txt",unit=11) -write(10,"(a)") "A" -write(10,"(a)") "B" -write(10,"(a)") "C" -close(10) -open(file="bug1.txt",unit=10) -read(10,*) -read(10,"(a)",advance="no",eor=1) line -write(11,*) "FAILED" ! This line should not be reached -stop -1 continue -if(line /= "B") then - write(11,*) "FAILED" ! This line should not be reached - stop -end if -backspace(10) -read(10,"(a)",advance="no",eor=2) line -write(11,*) "FAILED" ! This line should not be reached -stop -2 continue -if(line /= "B") then - write(11,*) "FAILED" ! This line should not be reached - stop -end if -close(10) -write(11,*) "PASSED" -close(11) -end program bug1 - -_ACEOF -rm -f conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - DONE=yes -else - echo "$as_me: program exited with status $ac_status" >&5 -echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -( exit $ac_status ) -DONE="" -fi -rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext -fi - -if test -n "$DONE" -then - if grep -q PASSED < result.txt - then - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 - else - echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 - IOTK_WORKAROUND1='#define __IOTK_WORKAROUND1' - fi - rm bug1.txt result.txt -else - echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 - IOTK_WORKAROUND1='#define __IOTK_WORKAROUND1' -fi - -# BUG 2 -echo "$as_me:$LINENO: checking bug in converting between logical(2) and logical(8) (if they exist)" >&5 -echo $ECHO_N "checking bug in converting between logical(2) and logical(8) (if they exist)... $ECHO_C" >&6 - -cat >conftest.$ac_ext <<_ACEOF - -program main -implicit none -logical(2) :: l2 -logical(8) :: l8 -l8 = .true. -l2 = l8 -write(*,*) l2 -end program - -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_fc_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - DONE="yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -DONE="" -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext - -if test -n "$DONE" -then - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 -else - echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 - IOTK_WORKAROUND2='#define __IOTK_WORKAROUND2' -fi - -# BUG 3 -# to do - -echo "$as_me:$LINENO: checking bug in pack" >&5 -echo $ECHO_N "checking bug in pack... $ECHO_C" >&6 -if test "$cross_compiling" = yes; then - { { echo "$as_me:$LINENO: error: cannot run test program while cross compiling -See \`config.log' for more details." >&5 -echo "$as_me: error: cannot run test program while cross compiling -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; } -else - cat >conftest.$ac_ext <<_ACEOF - -program bug3 -implicit none -integer, parameter :: size1 = 10000 -integer, parameter :: size2 = 1000 -integer :: out1(size1*size2) -integer :: out2(size1*size2) -integer :: in(size1,size2) -in=1 -call mypack(out1,in,size(in)) -out2=pack(in,mask=.true.) -open(10,file="test.txt") -if(all(out1==out2)) write(10,*) "PASSED" -close(10) -end program bug3 - -subroutine mypack(out,in,n) -implicit none -integer, intent(in) :: n -integer, intent(in) :: in(n) -integer, intent(out) :: out(n) - out = in -end subroutine mypack - -_ACEOF -rm -f conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - DONE="yes" -else - echo "$as_me: program exited with status $ac_status" >&5 -echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -( exit $ac_status ) -DONE="" -fi -rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext -fi - -if test -n "$DONE" -then - if grep -q PASSED test.txt - then - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 - else - echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 - IOTK_WORKAROUND3='#define __IOTK_WORKAROUND3' - fi -else - echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 - IOTK_WORKAROUND3='#define __IOTK_WORKAROUND3' -fi -if test -f test.txt ; then rm test.txt ; fi - - -# BUG 4 -# to do - -echo "$as_me:$LINENO: checking other bug in pack" >&5 -echo $ECHO_N "checking other bug in pack... $ECHO_C" >&6 -cat >conftest.$ac_ext <<_ACEOF - -program bug4 -implicit none -call sub((/"a","b","c"/)) -write(*,*) "PASSED" -contains - -subroutine sub(str) -character(len=*), intent(in) :: str(:) -write(*,*) pack(str,mask=.true.) -end subroutine sub - -end program bug4 - -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_fc_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - DONE="yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -DONE="" -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext - -if test -n "$DONE" -then - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 -else - echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 - IOTK_WORKAROUND4='#define __IOTK_WORKAROUND4' -fi - - -# BUG 5 -echo "$as_me:$LINENO: checking huge(1_1) does not compile as a parameter" >&5 -echo $ECHO_N "checking huge(1_1) does not compile as a parameter... $ECHO_C" >&6 - -cat >conftest.$ac_ext <<_ACEOF - -program bug5 -integer, parameter :: i=huge(1_1) -write(*,*) "PASSED",i -end program bug5 - -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_fc_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - DONE="yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -DONE="" -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext - -if test -n "$DONE" -then - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 -else - echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 - IOTK_WORKAROUND5='#define __IOTK_WORKAROUND5' -fi - -# BUG 6 -echo "$as_me:$LINENO: checking bug in intent" >&5 -echo $ECHO_N "checking bug in intent... $ECHO_C" >&6 -cat >conftest.$ac_ext <<_ACEOF - -subroutine pippo(arg) -implicit none -character(len=*), intent(out) :: arg -character(len=len(arg)), allocatable :: cc(:) -arg="ss" -end subroutine pippo - -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_fc_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - DONE="yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -DONE="" -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -if test -n "$DONE" -then - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 -else - echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 - IOTK_WORKAROUND6='#define __IOTK_WORKAROUND6' -fi - - - - - - - - - - - - - - - - - - - - - - - - - - - - -for outfile in `find . -name iotk_config.h.in` -do - file=`echo $outfile | sed 's/.in$//'` - ac_config_files="$ac_config_files $file" - -done - - -cat >confcache <<\_ACEOF -# This file is a shell script that caches the results of configure -# tests run on this system so they can be shared between configure -# scripts and configure runs, see configure's option --config-cache. -# It is not useful on other systems. If it contains results you don't -# want to keep, you may remove or edit it. -# -# config.status only pays attention to the cache file if you give it -# the --recheck option to rerun configure. -# -# `ac_cv_env_foo' variables (set or unset) will be overridden when -# loading this file, other *unset* `ac_cv_foo' will be assigned the -# following values. - -_ACEOF - -# The following way of writing the cache mishandles newlines in values, -# but we know of no workaround that is simple, portable, and efficient. -# So, don't put newlines in cache variables' values. -# Ultrix sh set writes to stderr and can't be redirected directly, -# and sets the high bit in the cache file unless we assign to the vars. -{ - (set) 2>&1 | - case `(ac_space=' '; set | grep ac_space) 2>&1` in - *ac_space=\ *) - # `set' does not quote correctly, so add quotes (double-quote - # substitution turns \\\\ into \\, and sed turns \\ into \). - sed -n \ - "s/'/'\\\\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" - ;; - *) - # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n \ - "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" - ;; - esac; -} | - sed ' - t clear - : clear - s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ - t end - /^ac_cv_env/!s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ - : end' >>confcache -if diff $cache_file confcache >/dev/null 2>&1; then :; else - if test -w $cache_file; then - test "x$cache_file" != "x/dev/null" && echo "updating cache $cache_file" - cat confcache >$cache_file - else - echo "not updating unwritable cache $cache_file" - fi -fi -rm -f confcache - -test "x$prefix" = xNONE && prefix=$ac_default_prefix -# Let make expand exec_prefix. -test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' - -# VPATH may cause trouble with some makes, so we remove $(srcdir), -# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and -# trailing colons and then remove the whole line if VPATH becomes empty -# (actually we leave an empty line to preserve line numbers). -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=/{ -s/:*\$(srcdir):*/:/; -s/:*\${srcdir}:*/:/; -s/:*@srcdir@:*/:/; -s/^\([^=]*=[ ]*\):*/\1/; -s/:*$//; -s/^[^=]*=[ ]*$//; -}' -fi - -# Transform confdefs.h into DEFS. -# Protect against shell expansion while executing Makefile rules. -# Protect against Makefile macro expansion. -# -# If the first sed substitution is executed (which looks for macros that -# take arguments), then we branch to the quote section. Otherwise, -# look for a macro that doesn't take arguments. -cat >confdef2opt.sed <<\_ACEOF -t clear -: clear -s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g -t quote -s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g -t quote -d -: quote -s,[ `~#$^&*(){}\\|;'"<>?],\\&,g -s,\[,\\&,g -s,\],\\&,g -s,\$,$$,g -p -_ACEOF -# We use echo to avoid assuming a particular line-breaking character. -# The extra dot is to prevent the shell from consuming trailing -# line-breaks from the sub-command output. A line-break within -# single-quotes doesn't work because, if this script is created in a -# platform that uses two characters for line-breaks (e.g., DOS), tr -# would break. -ac_LF_and_DOT=`echo; echo .` -DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'` -rm -f confdef2opt.sed - - -ac_libobjs= -ac_ltlibobjs= -for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue - # 1. Remove the extension, and $U if already installed. - ac_i=`echo "$ac_i" | - sed 's/\$U\././;s/\.o$//;s/\.obj$//'` - # 2. Add them. - ac_libobjs="$ac_libobjs $ac_i\$U.$ac_objext" - ac_ltlibobjs="$ac_ltlibobjs $ac_i"'$U.lo' -done -LIBOBJS=$ac_libobjs - -LTLIBOBJS=$ac_ltlibobjs - - - -: ${CONFIG_STATUS=./config.status} -ac_clean_files_save=$ac_clean_files -ac_clean_files="$ac_clean_files $CONFIG_STATUS" -{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5 -echo "$as_me: creating $CONFIG_STATUS" >&6;} -cat >$CONFIG_STATUS <<_ACEOF -#! $SHELL -# Generated by $as_me. -# Run this file to recreate the current configuration. -# Compiler output produced by configure, useful for debugging -# configure, is in config.log if it exists. - -debug=false -ac_cs_recheck=false -ac_cs_silent=false -SHELL=\${CONFIG_SHELL-$SHELL} -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF -## --------------------- ## -## M4sh Initialization. ## -## --------------------- ## - -# Be Bourne compatible -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then - emulate sh - NULLCMD=: - # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which - # is contrary to our usage. Disable this feature. - alias -g '${1+"$@"}'='"$@"' -elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then - set -o posix -fi -DUALCASE=1; export DUALCASE # for MKS sh - -# Support unset when possible. -if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then - as_unset=unset -else - as_unset=false -fi - - -# Work around bugs in pre-3.0 UWIN ksh. -$as_unset ENV MAIL MAILPATH -PS1='$ ' -PS2='> ' -PS4='+ ' - -# NLS nuisances. -for as_var in \ - LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ - LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ - LC_TELEPHONE LC_TIME -do - if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then - eval $as_var=C; export $as_var - else - $as_unset $as_var - fi -done - -# Required to use basename. -if expr a : '\(a\)' >/dev/null 2>&1; then - as_expr=expr -else - as_expr=false -fi - -if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then - as_basename=basename -else - as_basename=false -fi - - -# Name of the executable. -as_me=`$as_basename "$0" || -$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)$' \| \ - . : '\(.\)' 2>/dev/null || -echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } - /^X\/\(\/\/\)$/{ s//\1/; q; } - /^X\/\(\/\).*/{ s//\1/; q; } - s/.*/./; q'` - - -# PATH needs CR, and LINENO needs CR and PATH. -# Avoid depending upon Character Ranges. -as_cr_letters='abcdefghijklmnopqrstuvwxyz' -as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' -as_cr_Letters=$as_cr_letters$as_cr_LETTERS -as_cr_digits='0123456789' -as_cr_alnum=$as_cr_Letters$as_cr_digits - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - echo "#! /bin/sh" >conf$$.sh - echo "exit 0" >>conf$$.sh - chmod +x conf$$.sh - if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then - PATH_SEPARATOR=';' - else - PATH_SEPARATOR=: - fi - rm -f conf$$.sh -fi - - - as_lineno_1=$LINENO - as_lineno_2=$LINENO - as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` - test "x$as_lineno_1" != "x$as_lineno_2" && - test "x$as_lineno_3" = "x$as_lineno_2" || { - # Find who we are. Look in the path if we contain no path at all - # relative or not. - case $0 in - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break -done - - ;; - esac - # We did not find ourselves, most probably we were run as `sh COMMAND' - # in which case we are not to be found in the path. - if test "x$as_myself" = x; then - as_myself=$0 - fi - if test ! -f "$as_myself"; then - { { echo "$as_me:$LINENO: error: cannot find myself; rerun with an absolute path" >&5 -echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2;} - { (exit 1); exit 1; }; } - fi - case $CONFIG_SHELL in - '') - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for as_base in sh bash ksh sh5; do - case $as_dir in - /*) - if ("$as_dir/$as_base" -c ' - as_lineno_1=$LINENO - as_lineno_2=$LINENO - as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` - test "x$as_lineno_1" != "x$as_lineno_2" && - test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then - $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } - $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } - CONFIG_SHELL=$as_dir/$as_base - export CONFIG_SHELL - exec "$CONFIG_SHELL" "$0" ${1+"$@"} - fi;; - esac - done -done -;; - esac - - # Create $as_me.lineno as a copy of $as_myself, but with $LINENO - # uniformly replaced by the line number. The first 'sed' inserts a - # line-number line before each line; the second 'sed' does the real - # work. The second script uses 'N' to pair each line-number line - # with the numbered line, and appends trailing '-' during - # substitution so that $LINENO is not a special case at line end. - # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the - # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) - sed '=' <$as_myself | - sed ' - N - s,$,-, - : loop - s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, - t loop - s,-$,, - s,^['$as_cr_digits']*\n,, - ' >$as_me.lineno && - chmod +x $as_me.lineno || - { { echo "$as_me:$LINENO: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&5 -echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2;} - { (exit 1); exit 1; }; } - - # Don't try to exec as it changes $[0], causing all sort of problems - # (the dirname of $[0] is not the place where we might find the - # original and so on. Autoconf is especially sensible to this). - . ./$as_me.lineno - # Exit status is that of the last command. - exit -} - - -case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in - *c*,-n*) ECHO_N= ECHO_C=' -' ECHO_T=' ' ;; - *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; - *) ECHO_N= ECHO_C='\c' ECHO_T= ;; -esac - -if expr a : '\(a\)' >/dev/null 2>&1; then - as_expr=expr -else - as_expr=false -fi - -rm -f conf$$ conf$$.exe conf$$.file -echo >conf$$.file -if ln -s conf$$.file conf$$ 2>/dev/null; then - # We could just check for DJGPP; but this test a) works b) is more generic - # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). - if test -f conf$$.exe; then - # Don't use ln at all; we don't have any links - as_ln_s='cp -p' - else - as_ln_s='ln -s' - fi -elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln -else - as_ln_s='cp -p' -fi -rm -f conf$$ conf$$.exe conf$$.file - -if mkdir -p . 2>/dev/null; then - as_mkdir_p=: -else - test -d ./-p && rmdir ./-p - as_mkdir_p=false -fi - -as_executable_p="test -f" - -# Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" - -# Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" - - -# IFS -# We need space, tab and new line, in precisely that order. -as_nl=' -' -IFS=" $as_nl" - -# CDPATH. -$as_unset CDPATH - -exec 6>&1 - -# Open the log real soon, to keep \$[0] and so on meaningful, and to -# report actual input values of CONFIG_FILES etc. instead of their -# values after options handling. Logging --version etc. is OK. -exec 5>>config.log -{ - echo - sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX -## Running $as_me. ## -_ASBOX -} >&5 -cat >&5 <<_CSEOF - -This file was extended by IOTK $as_me 0.1, which was -generated by GNU Autoconf 2.59. Invocation command line was - - CONFIG_FILES = $CONFIG_FILES - CONFIG_HEADERS = $CONFIG_HEADERS - CONFIG_LINKS = $CONFIG_LINKS - CONFIG_COMMANDS = $CONFIG_COMMANDS - $ $0 $@ - -_CSEOF -echo "on `(hostname || uname -n) 2>/dev/null | sed 1q`" >&5 -echo >&5 -_ACEOF - -# Files that config.status was made for. -if test -n "$ac_config_files"; then - echo "config_files=\"$ac_config_files\"" >>$CONFIG_STATUS -fi - -if test -n "$ac_config_headers"; then - echo "config_headers=\"$ac_config_headers\"" >>$CONFIG_STATUS -fi - -if test -n "$ac_config_links"; then - echo "config_links=\"$ac_config_links\"" >>$CONFIG_STATUS -fi - -if test -n "$ac_config_commands"; then - echo "config_commands=\"$ac_config_commands\"" >>$CONFIG_STATUS -fi - -cat >>$CONFIG_STATUS <<\_ACEOF - -ac_cs_usage="\ -\`$as_me' instantiates files from templates according to the -current configuration. - -Usage: $0 [OPTIONS] [FILE]... - - -h, --help print this help, then exit - -V, --version print version number, then exit - -q, --quiet do not print progress messages - -d, --debug don't remove temporary files - --recheck update $as_me by reconfiguring in the same conditions - --file=FILE[:TEMPLATE] - instantiate the configuration file FILE - -Configuration files: -$config_files - -Report bugs to ." -_ACEOF - -cat >>$CONFIG_STATUS <<_ACEOF -ac_cs_version="\\ -IOTK config.status 0.1 -configured by $0, generated by GNU Autoconf 2.59, - with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" - -Copyright (C) 2003 Free Software Foundation, Inc. -This config.status script is free software; the Free Software Foundation -gives unlimited permission to copy, distribute and modify it." -srcdir=$srcdir -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF -# If no file are specified by the user, then we need to provide default -# value. By we need to know if files were specified by the user. -ac_need_defaults=: -while test $# != 0 -do - case $1 in - --*=*) - ac_option=`expr "x$1" : 'x\([^=]*\)='` - ac_optarg=`expr "x$1" : 'x[^=]*=\(.*\)'` - ac_shift=: - ;; - -*) - ac_option=$1 - ac_optarg=$2 - ac_shift=shift - ;; - *) # This is not an option, so the user has probably given explicit - # arguments. - ac_option=$1 - ac_need_defaults=false;; - esac - - case $ac_option in - # Handling of the options. -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF - -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) - ac_cs_recheck=: ;; - --version | --vers* | -V ) - echo "$ac_cs_version"; exit 0 ;; - --he | --h) - # Conflict between --help and --header - { { echo "$as_me:$LINENO: error: ambiguous option: $1 -Try \`$0 --help' for more information." >&5 -echo "$as_me: error: ambiguous option: $1 -Try \`$0 --help' for more information." >&2;} - { (exit 1); exit 1; }; };; - --help | --hel | -h ) - echo "$ac_cs_usage"; exit 0 ;; - --debug | --d* | -d ) - debug=: ;; - --file | --fil | --fi | --f ) - $ac_shift - CONFIG_FILES="$CONFIG_FILES $ac_optarg" - ac_need_defaults=false;; - --header | --heade | --head | --hea ) - $ac_shift - CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg" - ac_need_defaults=false;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil | --si | --s) - ac_cs_silent=: ;; - - # This is an error. - -*) { { echo "$as_me:$LINENO: error: unrecognized option: $1 -Try \`$0 --help' for more information." >&5 -echo "$as_me: error: unrecognized option: $1 -Try \`$0 --help' for more information." >&2;} - { (exit 1); exit 1; }; } ;; - - *) ac_config_targets="$ac_config_targets $1" ;; - - esac - shift -done - -ac_configure_extra_args= - -if $ac_cs_silent; then - exec 6>/dev/null - ac_configure_extra_args="$ac_configure_extra_args --silent" -fi - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF -if \$ac_cs_recheck; then - echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6 - exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion -fi - -_ACEOF - - - - - -cat >>$CONFIG_STATUS <<\_ACEOF -for ac_config_target in $ac_config_targets -do - case "$ac_config_target" in - # Handling of arguments. - "$file" ) CONFIG_FILES="$CONFIG_FILES $file" ;; - *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 -echo "$as_me: error: invalid argument: $ac_config_target" >&2;} - { (exit 1); exit 1; }; };; - esac -done - -# If the user did not use the arguments to specify the items to instantiate, -# then the envvar interface is used. Set only those that are not. -# We use the long form for the default assignment because of an extremely -# bizarre bug on SunOS 4.1.3. -if $ac_need_defaults; then - test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files -fi - -# Have a temporary directory for convenience. Make it in the build tree -# simply because there is no reason to put it here, and in addition, -# creating and moving files from /tmp can sometimes cause problems. -# Create a temporary directory, and hook for its removal unless debugging. -$debug || -{ - trap 'exit_status=$?; rm -rf $tmp && exit $exit_status' 0 - trap '{ (exit 1); exit 1; }' 1 2 13 15 -} - -# Create a (secure) tmp directory for tmp files. - -{ - tmp=`(umask 077 && mktemp -d -q "./confstatXXXXXX") 2>/dev/null` && - test -n "$tmp" && test -d "$tmp" -} || -{ - tmp=./confstat$$-$RANDOM - (umask 077 && mkdir $tmp) -} || -{ - echo "$me: cannot create a temporary directory in ." >&2 - { (exit 1); exit 1; } -} - -_ACEOF - -cat >>$CONFIG_STATUS <<_ACEOF - -# -# CONFIG_FILES section. -# - -# No need to generate the scripts if there are no CONFIG_FILES. -# This happens for instance when ./config.status config.h -if test -n "\$CONFIG_FILES"; then - # Protect against being on the right side of a sed subst in config.status. - sed 's/,@/@@/; s/@,/@@/; s/,;t t\$/@;t t/; /@;t t\$/s/[\\\\&,]/\\\\&/g; - s/@@/,@/; s/@@/@,/; s/@;t t\$/,;t t/' >\$tmp/subs.sed <<\\CEOF -s,@SHELL@,$SHELL,;t t -s,@PATH_SEPARATOR@,$PATH_SEPARATOR,;t t -s,@PACKAGE_NAME@,$PACKAGE_NAME,;t t -s,@PACKAGE_TARNAME@,$PACKAGE_TARNAME,;t t -s,@PACKAGE_VERSION@,$PACKAGE_VERSION,;t t -s,@PACKAGE_STRING@,$PACKAGE_STRING,;t t -s,@PACKAGE_BUGREPORT@,$PACKAGE_BUGREPORT,;t t -s,@exec_prefix@,$exec_prefix,;t t -s,@prefix@,$prefix,;t t -s,@program_transform_name@,$program_transform_name,;t t -s,@bindir@,$bindir,;t t -s,@sbindir@,$sbindir,;t t -s,@libexecdir@,$libexecdir,;t t -s,@datadir@,$datadir,;t t -s,@sysconfdir@,$sysconfdir,;t t -s,@sharedstatedir@,$sharedstatedir,;t t -s,@localstatedir@,$localstatedir,;t t -s,@libdir@,$libdir,;t t -s,@includedir@,$includedir,;t t -s,@oldincludedir@,$oldincludedir,;t t -s,@infodir@,$infodir,;t t -s,@mandir@,$mandir,;t t -s,@build_alias@,$build_alias,;t t -s,@host_alias@,$host_alias,;t t -s,@target_alias@,$target_alias,;t t -s,@DEFS@,$DEFS,;t t -s,@ECHO_C@,$ECHO_C,;t t -s,@ECHO_N@,$ECHO_N,;t t -s,@ECHO_T@,$ECHO_T,;t t -s,@LIBS@,$LIBS,;t t -s,@FC@,$FC,;t t -s,@FCFLAGS@,$FCFLAGS,;t t -s,@LDFLAGS@,$LDFLAGS,;t t -s,@ac_ct_FC@,$ac_ct_FC,;t t -s,@EXEEXT@,$EXEEXT,;t t -s,@OBJEXT@,$OBJEXT,;t t -s,@FCFLAGS_f90@,$FCFLAGS_f90,;t t -s,@IOTK_INTEGER@,$IOTK_INTEGER,;t t -s,@IOTK_LOGICAL@,$IOTK_LOGICAL,;t t -s,@IOTK_REAL@,$IOTK_REAL,;t t -s,@IOTK_BUGS@,$IOTK_BUGS,;t t -s,@IOTK_INTEGER1@,$IOTK_INTEGER1,;t t -s,@IOTK_INTEGER2@,$IOTK_INTEGER2,;t t -s,@IOTK_INTEGER3@,$IOTK_INTEGER3,;t t -s,@IOTK_INTEGER4@,$IOTK_INTEGER4,;t t -s,@IOTK_LOGICAL1@,$IOTK_LOGICAL1,;t t -s,@IOTK_LOGICAL2@,$IOTK_LOGICAL2,;t t -s,@IOTK_LOGICAL3@,$IOTK_LOGICAL3,;t t -s,@IOTK_LOGICAL4@,$IOTK_LOGICAL4,;t t -s,@IOTK_REAL1@,$IOTK_REAL1,;t t -s,@IOTK_REAL2@,$IOTK_REAL2,;t t -s,@IOTK_REAL3@,$IOTK_REAL3,;t t -s,@IOTK_REAL4@,$IOTK_REAL4,;t t -s,@IOTK_WORKAROUND1@,$IOTK_WORKAROUND1,;t t -s,@IOTK_WORKAROUND2@,$IOTK_WORKAROUND2,;t t -s,@IOTK_WORKAROUND3@,$IOTK_WORKAROUND3,;t t -s,@IOTK_WORKAROUND4@,$IOTK_WORKAROUND4,;t t -s,@IOTK_WORKAROUND5@,$IOTK_WORKAROUND5,;t t -s,@IOTK_WORKAROUND6@,$IOTK_WORKAROUND6,;t t -s,@IOTK_WORKAROUND7@,$IOTK_WORKAROUND7,;t t -s,@IOTK_WORKAROUND8@,$IOTK_WORKAROUND8,;t t -s,@IOTK_WORKAROUND9@,$IOTK_WORKAROUND9,;t t -s,@LIBOBJS@,$LIBOBJS,;t t -s,@LTLIBOBJS@,$LTLIBOBJS,;t t -CEOF - -_ACEOF - - cat >>$CONFIG_STATUS <<\_ACEOF - # Split the substitutions into bite-sized pieces for seds with - # small command number limits, like on Digital OSF/1 and HP-UX. - ac_max_sed_lines=48 - ac_sed_frag=1 # Number of current file. - ac_beg=1 # First line for current file. - ac_end=$ac_max_sed_lines # Line after last line for current file. - ac_more_lines=: - ac_sed_cmds= - while $ac_more_lines; do - if test $ac_beg -gt 1; then - sed "1,${ac_beg}d; ${ac_end}q" $tmp/subs.sed >$tmp/subs.frag - else - sed "${ac_end}q" $tmp/subs.sed >$tmp/subs.frag - fi - if test ! -s $tmp/subs.frag; then - ac_more_lines=false - else - # The purpose of the label and of the branching condition is to - # speed up the sed processing (if there are no `@' at all, there - # is no need to browse any of the substitutions). - # These are the two extra sed commands mentioned above. - (echo ':t - /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed - if test -z "$ac_sed_cmds"; then - ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" - else - ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" - fi - ac_sed_frag=`expr $ac_sed_frag + 1` - ac_beg=$ac_end - ac_end=`expr $ac_end + $ac_max_sed_lines` - fi - done - if test -z "$ac_sed_cmds"; then - ac_sed_cmds=cat - fi -fi # test -n "$CONFIG_FILES" - -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF -for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue - # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". - case $ac_file in - - | *:- | *:-:* ) # input from stdin - cat >$tmp/stdin - ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` - ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; - *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` - ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; - * ) ac_file_in=$ac_file.in ;; - esac - - # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories. - ac_dir=`(dirname "$ac_file") 2>/dev/null || -$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$ac_file" : 'X\(//\)[^/]' \| \ - X"$ac_file" : 'X\(//\)$' \| \ - X"$ac_file" : 'X\(/\)' \| \ - . : '\(.\)' 2>/dev/null || -echo X"$ac_file" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } - /^X\(\/\/\)[^/].*/{ s//\1/; q; } - /^X\(\/\/\)$/{ s//\1/; q; } - /^X\(\/\).*/{ s//\1/; q; } - s/.*/./; q'` - { if $as_mkdir_p; then - mkdir -p "$ac_dir" - else - as_dir="$ac_dir" - as_dirs= - while test ! -d "$as_dir"; do - as_dirs="$as_dir $as_dirs" - as_dir=`(dirname "$as_dir") 2>/dev/null || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| \ - . : '\(.\)' 2>/dev/null || -echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } - /^X\(\/\/\)[^/].*/{ s//\1/; q; } - /^X\(\/\/\)$/{ s//\1/; q; } - /^X\(\/\).*/{ s//\1/; q; } - s/.*/./; q'` - done - test ! -n "$as_dirs" || mkdir $as_dirs - fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 -echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} - { (exit 1); exit 1; }; }; } - - ac_builddir=. - -if test "$ac_dir" != .; then - ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` - # A "../" for each directory in $ac_dir_suffix. - ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` -else - ac_dir_suffix= ac_top_builddir= -fi - -case $srcdir in - .) # No --srcdir option. We are building in place. - ac_srcdir=. - if test -z "$ac_top_builddir"; then - ac_top_srcdir=. - else - ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` - fi ;; - [\\/]* | ?:[\\/]* ) # Absolute path. - ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir ;; - *) # Relative path. - ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_builddir$srcdir ;; -esac - -# Do not use `cd foo && pwd` to compute absolute paths, because -# the directories may not exist. -case `pwd` in -.) ac_abs_builddir="$ac_dir";; -*) - case "$ac_dir" in - .) ac_abs_builddir=`pwd`;; - [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; - *) ac_abs_builddir=`pwd`/"$ac_dir";; - esac;; -esac -case $ac_abs_builddir in -.) ac_abs_top_builddir=${ac_top_builddir}.;; -*) - case ${ac_top_builddir}. in - .) ac_abs_top_builddir=$ac_abs_builddir;; - [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; - *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; - esac;; -esac -case $ac_abs_builddir in -.) ac_abs_srcdir=$ac_srcdir;; -*) - case $ac_srcdir in - .) ac_abs_srcdir=$ac_abs_builddir;; - [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; - *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; - esac;; -esac -case $ac_abs_builddir in -.) ac_abs_top_srcdir=$ac_top_srcdir;; -*) - case $ac_top_srcdir in - .) ac_abs_top_srcdir=$ac_abs_builddir;; - [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; - *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; - esac;; -esac - - - - if test x"$ac_file" != x-; then - { echo "$as_me:$LINENO: creating $ac_file" >&5 -echo "$as_me: creating $ac_file" >&6;} - rm -f "$ac_file" - fi - # Let's still pretend it is `configure' which instantiates (i.e., don't - # use $as_me), people would be surprised to read: - # /* config.h. Generated by config.status. */ - if test x"$ac_file" = x-; then - configure_input= - else - configure_input="$ac_file. " - fi - configure_input=$configure_input"Generated from `echo $ac_file_in | - sed 's,.*/,,'` by configure." - - # First look for the input files in the build tree, otherwise in the - # src tree. - ac_file_inputs=`IFS=: - for f in $ac_file_in; do - case $f in - -) echo $tmp/stdin ;; - [\\/$]*) - # Absolute (can't be DOS-style, as IFS=:) - test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 -echo "$as_me: error: cannot find input file: $f" >&2;} - { (exit 1); exit 1; }; } - echo "$f";; - *) # Relative - if test -f "$f"; then - # Build tree - echo "$f" - elif test -f "$srcdir/$f"; then - # Source tree - echo "$srcdir/$f" - else - # /dev/null tree - { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 -echo "$as_me: error: cannot find input file: $f" >&2;} - { (exit 1); exit 1; }; } - fi;; - esac - done` || { (exit 1); exit 1; } -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF - sed "$ac_vpsub -$extrasub -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF -:t -/@[a-zA-Z_][a-zA-Z_0-9]*@/!b -s,@configure_input@,$configure_input,;t t -s,@srcdir@,$ac_srcdir,;t t -s,@abs_srcdir@,$ac_abs_srcdir,;t t -s,@top_srcdir@,$ac_top_srcdir,;t t -s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t -s,@builddir@,$ac_builddir,;t t -s,@abs_builddir@,$ac_abs_builddir,;t t -s,@top_builddir@,$ac_top_builddir,;t t -s,@abs_top_builddir@,$ac_abs_top_builddir,;t t -" $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out - rm -f $tmp/stdin - if test x"$ac_file" != x-; then - mv $tmp/out $ac_file - else - cat $tmp/out - rm -f $tmp/out - fi - -done -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF - -{ (exit 0); exit 0; } -_ACEOF -chmod +x $CONFIG_STATUS -ac_clean_files=$ac_clean_files_save - - -# configure is writing to config.log, and then calls config.status. -# config.status does its own redirection, appending to config.log. -# Unfortunately, on DOS this fails, as config.log is still kept open -# by configure, so config.status won't be able to write to it; its -# output is simply discarded. So we exec the FD to /dev/null, -# effectively closing config.log, so it can be properly (re)opened and -# appended to by config.status. When coming back to configure, we -# need to make the FD available again. -if test "$no_create" != yes; then - ac_cs_success=: - ac_config_status_args= - test "$silent" = yes && - ac_config_status_args="$ac_config_status_args --quiet" - exec 5>/dev/null - $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false - exec 5>>config.log - # Use ||, not &&, to avoid exiting from the if with $? = 1, which - # would make configure fail if this is the last instruction. - $ac_cs_success || { (exit 1); exit 1; } -fi - - diff --git a/quantum_espresso/kcp/iotk/tools/configure.ac b/quantum_espresso/kcp/iotk/tools/configure.ac deleted file mode 100644 index 954cd24cd..000000000 --- a/quantum_espresso/kcp/iotk/tools/configure.ac +++ /dev/null @@ -1,359 +0,0 @@ -AC_INIT(IOTK, 0.1) - -# LIST OF USED ENVIRONMENT VARIABLES: -# IOTK_INTEGER_KINDS -# IOTK_LOGICAL_KINDS -# IOTK_REAL_KINDS -# colon separated lists of kinds -# a kind ALL expands to hopefully all kinds - -# Default integer and logical are added by default -IOTK_INTEGER_KINDS="kind(1):$IOTK_INTEGER_KINDS" -IOTK_LOGICAL_KINDS="kind(.true.):$IOTK_LOGICAL_KINDS" - -# Save the default IFS -IFS_BACKUP="$IFS" - -# Define the newline character -NEWLINE=" -" - -# Define the backslash character - -AC_PROG_FC(ifort g95 f95 pgf90 xlf90) - -# Selecting the language -AC_LANG(Fortran) - -# Selecting the source extension -AC_FC_SRCEXT(f90) - -AC_MSG_NOTICE([checking intrinsic FORTRAN kinds]) - -# Loop over types -for TYPE in INTEGER LOGICAL REAL -do - eval LIST=\"\$IOTK_${TYPE}_KINDS\" - -# Expansion of the 'ALL' keyword - NLIST="" - IFS=":" - for KIND in $LIST - do - case "$KIND" in - ALL) NLIST="$NLIST:1:2:3:4:5:6:7:8:10:12:16:24:32" ;; - *) NLIST="$NLIST:$KIND" ;; - esac - done - IFS="$IFS_BACKUP" - LIST="$NLIST" - - NLIST="" - IFS=":" - for KIND in $LIST - do - IFS="$IFS_BACKUP" - - if test -n "$KIND" - then - AC_MSG_CHECKING([intrinsic type $TYPE(kind=$KIND)]) - AC_RUN_IFELSE( - [[ - program pippo - implicit none - $TYPE (kind=$KIND) :: try - open(10,file="test.txt") - if(kind(try)==$KIND) write(10,"(a,i8)") "KIND=",kind(try) - close(10) - end program pippo - ]], - DONE=yes, - DONE="" - ) - - if test -n "$DONE" - then - if grep -q KIND= < test.txt - then - AC_MSG_RESULT([yes]) - NLIST="$NLIST:"`sed -n 's/KIND= *//p' < test.txt` - else - AC_MSG_RESULT([no]) - fi - else - AC_MSG_RESULT([no]) - fi - if test -f test.txt ; then rm test.txt ; fi - fi - - done - IFS="$IFS_BACKUP" - LIST="$NLIST" - - AC_MSG_NOTICE([Eliminating duplicates]) - - NLIST="" - IFS=":" - for KIND in $LIST - do - if test -n "$KIND" - then - WAS_FOUND="" - for KIND1 in $NLIST - do - if test -n "$KIND1" - then - test "$KIND1" -eq "$KIND" && WAS_FOUND=yes - fi - done - test -n "$WAS_FOUND" || NLIST="$NLIST:$KIND" - fi - done - IFS="$IFS_BACKUP" - LIST="$NLIST" - - IFS=":" - COUNT=0 - for KIND in $LIST - do - if test -n "$KIND" - then - COUNT=`expr $COUNT + 1` - eval "IOTK_$TYPE$COUNT='#define __IOTK_$TYPE$COUNT $KIND'" - fi - done - IFS="$IFS_BACKUP" -done - -############## -# KNOWN BUGS # -############## - -IOTK_BUGS="" -AC_MSG_NOTICE([checking for known bugs]) - -# BUG 1 -AC_MSG_CHECKING([bug in non-advancing read]) -AC_RUN_IFELSE( -[[ -program bug1 -implicit none -character(10) :: line -open(file="bug1.txt",unit=10) -open(file="result.txt",unit=11) -write(10,"(a)") "A" -write(10,"(a)") "B" -write(10,"(a)") "C" -close(10) -open(file="bug1.txt",unit=10) -read(10,*) -read(10,"(a)",advance="no",eor=1) line -write(11,*) "FAILED" ! This line should not be reached -stop -1 continue -if(line /= "B") then - write(11,*) "FAILED" ! This line should not be reached - stop -end if -backspace(10) -read(10,"(a)",advance="no",eor=2) line -write(11,*) "FAILED" ! This line should not be reached -stop -2 continue -if(line /= "B") then - write(11,*) "FAILED" ! This line should not be reached - stop -end if -close(10) -write(11,*) "PASSED" -close(11) -end program bug1 -]],DONE=yes,DONE="") - -if test -n "$DONE" -then - if grep -q PASSED < result.txt - then - AC_MSG_RESULT([no]) - else - AC_MSG_RESULT([yes]) - IOTK_WORKAROUND1='#define __IOTK_WORKAROUND1' - fi - rm bug1.txt result.txt -else - AC_MSG_RESULT([yes]) - IOTK_WORKAROUND1='#define __IOTK_WORKAROUND1' -fi - -# BUG 2 -AC_MSG_CHECKING([bug in converting between logical(2) and logical(8) (if they exist)]) - -AC_COMPILE_IFELSE( -[[ -program main -implicit none -logical(2) :: l2 -logical(8) :: l8 -l8 = .true. -l2 = l8 -write(*,*) l2 -end program -]],DONE="yes",DONE="") - -if test -n "$DONE" -then - AC_MSG_RESULT([no]) -else - AC_MSG_RESULT([yes]) - IOTK_WORKAROUND2='#define __IOTK_WORKAROUND2' -fi - -# BUG 3 -# to do - -AC_MSG_CHECKING([bug in pack]) -AC_RUN_IFELSE( -[[ -program bug3 -implicit none -integer, parameter :: size1 = 10000 -integer, parameter :: size2 = 1000 -integer :: out1(size1*size2) -integer :: out2(size1*size2) -integer :: in(size1,size2) -in=1 -call mypack(out1,in,size(in)) -out2=pack(in,mask=.true.) -open(10,file="test.txt") -if(all(out1==out2)) write(10,*) "PASSED" -close(10) -end program bug3 - -subroutine mypack(out,in,n) -implicit none -integer, intent(in) :: n -integer, intent(in) :: in(n) -integer, intent(out) :: out(n) - out = in -end subroutine mypack -]],DONE="yes",DONE="") - -if test -n "$DONE" -then - if grep -q PASSED test.txt - then - AC_MSG_RESULT([no]) - else - AC_MSG_RESULT([yes]) - IOTK_WORKAROUND3='#define __IOTK_WORKAROUND3' - fi -else - AC_MSG_RESULT([yes]) - IOTK_WORKAROUND3='#define __IOTK_WORKAROUND3' -fi -if test -f test.txt ; then rm test.txt ; fi - - -# BUG 4 -# to do - -AC_MSG_CHECKING([other bug in pack]) -AC_COMPILE_IFELSE( -[[ -program bug4 -implicit none -call sub((/"a","b","c"/)) -write(*,*) "PASSED" -contains - -subroutine sub(str) -character(len=*), intent(in) :: str(:) -write(*,*) pack(str,mask=.true.) -end subroutine sub - -end program bug4 -]],DONE="yes",DONE="") - -if test -n "$DONE" -then - AC_MSG_RESULT([no]) -else - AC_MSG_RESULT([yes]) - IOTK_WORKAROUND4='#define __IOTK_WORKAROUND4' -fi - - -# BUG 5 -AC_MSG_CHECKING([huge(1_1) does not compile as a parameter]) - -AC_COMPILE_IFELSE( -[[ -program bug5 -integer, parameter :: i=huge(1_1) -write(*,*) "PASSED",i -end program bug5 -]],DONE="yes",DONE="") - -if test -n "$DONE" -then - AC_MSG_RESULT([no]) -else - AC_MSG_RESULT([yes]) - IOTK_WORKAROUND5='#define __IOTK_WORKAROUND5' -fi - -# BUG 6 -AC_MSG_CHECKING([bug in intent]) -AC_COMPILE_IFELSE( -[[ -subroutine pippo(arg) -implicit none -character(len=*), intent(out) :: arg -character(len=len(arg)), allocatable :: cc(:) -arg="ss" -end subroutine pippo -]],DONE="yes",DONE="") -if test -n "$DONE" -then - AC_MSG_RESULT([no]) -else - AC_MSG_RESULT([yes]) - IOTK_WORKAROUND6='#define __IOTK_WORKAROUND6' -fi - -AC_SUBST(IOTK_INTEGER) -AC_SUBST(IOTK_LOGICAL) -AC_SUBST(IOTK_REAL) -AC_SUBST(IOTK_BUGS) - -AC_SUBST(IOTK_INTEGER1) -AC_SUBST(IOTK_INTEGER2) -AC_SUBST(IOTK_INTEGER3) -AC_SUBST(IOTK_INTEGER4) -AC_SUBST(IOTK_LOGICAL1) -AC_SUBST(IOTK_LOGICAL2) -AC_SUBST(IOTK_LOGICAL3) -AC_SUBST(IOTK_LOGICAL4) -AC_SUBST(IOTK_REAL1) -AC_SUBST(IOTK_REAL2) -AC_SUBST(IOTK_REAL3) -AC_SUBST(IOTK_REAL4) -AC_SUBST(IOTK_WORKAROUND1) -AC_SUBST(IOTK_WORKAROUND2) -AC_SUBST(IOTK_WORKAROUND3) -AC_SUBST(IOTK_WORKAROUND4) -AC_SUBST(IOTK_WORKAROUND5) -AC_SUBST(IOTK_WORKAROUND6) -AC_SUBST(IOTK_WORKAROUND7) -AC_SUBST(IOTK_WORKAROUND8) -AC_SUBST(IOTK_WORKAROUND9) - -for outfile in `find . -name iotk_config.h.in` -do - file=`echo $outfile | sed 's/.in$//'` - AC_CONFIG_FILES($file) -done - - -AC_OUTPUT - diff --git a/quantum_espresso/kcp/iotk/tools/export b/quantum_espresso/kcp/iotk/tools/export deleted file mode 100755 index 5e6fda104..000000000 --- a/quantum_espresso/kcp/iotk/tools/export +++ /dev/null @@ -1,39 +0,0 @@ -#! /bin/sh -# This script generates in the directory tmp/export -# a collection of fortran sources and header files which can -# be directly included in another package. - -if [ -e tmp/export ] ; then - rm -fr tmp/export -fi - -mkdir tmp/export - -SRC=' - base - unit_list - attr_interf dat_interf error_interf files_interf fmt_interf misc_interf - str_interf scan_interf stream_interf tool_interf unit_interf write_interf - xtox_interf - module - attr+CHARACTER* attr+COMPLEX* attr+REAL* attr+INTEGER* attr+LOGICAL* - dat+CHARACTER* dat+COMPLEX* dat+REAL* dat+INTEGER* dat+LOGICAL* - error files fmt misc str stream scan tool unit write xtox -' - -COUNT=0 - -cd src -cp ../include/iotk_config.h ../include/iotk_auxmacros.h ../tmp/export - -for file in $SRC -do - COUNT=`expr $COUNT + 1` - case "$COUNT" in - ?) NCOUNT="0$COUNT" ;; - ??) NCOUNT="$COUNT" ;; - esac - OUTFILE=` echo "iotk_${NCOUNT}_${file}.f90" | sed 's/\*//' ` - cat iotk_${file}.f90 > ../tmp/export/$OUTFILE -done - diff --git a/quantum_espresso/kcp/iotk/tools/iotk b/quantum_espresso/kcp/iotk/tools/iotk deleted file mode 100755 index 291ad52b8..000000000 --- a/quantum_espresso/kcp/iotk/tools/iotk +++ /dev/null @@ -1,71 +0,0 @@ -#! /bin/sh -# This script is a generic wrapper for iotk.x -# -# if the first option is --iotk-exe, -# then the second option is assumed to be the iotk.x executable and all the remaining options are passed. -# else, if the IOTK_EXE environment variable is defined, -# then the iotk.x command will be executed as ${IOTK_EXE} . -# else, if the IOTK_ROOTDIR environment variable is defined, -# then the iotk.x command will be executed as ${IOTK_ROOTDIR}/bin/iotk.x . -# else, the execution path is searched for an executable "iotk.x" -# then the iotk.x command will be executed as iotk.x -# else, the directory is guessed based on the location of THIS ($0) script -# then the iotk.x command will be executed properly -# else, an error message is issued -# end if - -# When a single instance of iotk library is available on a given machine, -# the user should define an environment variable IOTK_ROOTDIR as -# the name of the root directory of iotk, e.g. -# export IOTK_ROOTDIR=${HOME}/S3DE/iotk/ - -# When different istances of iotk are available on the same machine -# (e.g. different versions or different compilers), the user can define aliases as: -# alias iotk_g95 "iotk --iotk-exe ${HOME}/g95/S3DE/iotk/bin/iotk.x" -# alias iotk_ifort "iotk --iotk-exe ${HOME}/ifort/S3DE/iotk/bin/iotk.x" - -EXEC= -# first, check --iotk-exe command line option -if test "$1" = --iotk-exe -then - shift - EXEC="$1" - shift -# second, try IOTK_EXE environment variable -elif test -n "${IOTK_EXE}" -then - EXEC="${IOTK_EXE}" -# third, try IOTK_ROOTDIR environment variable -elif test -n "${IOTK_ROOTDIR}" -then - EXEC="${IOTK_ROOTDIR}/bin/iotk.x" -else -# fourth, try to execute using the path - echo "--do-nothing" | iotk.x 2> /dev/null - if [ $? = 0 ] - then - EXEC=iotk.x -# last resort, guess using $0 -# (thanks to Andrea Ferretti) - else - EXEC=`echo $0 | sed 's/\(.*\)\/.*/\1/'`/../bin/iotk.x - echo "--do-nothing" | ${EXEC} 2> /dev/null - if [ $? = 0 ] - then - echo "iotk: using ${EXEC} executable" 1>&2 - else -# very last: surrend - echo "iotk: I cannot find the iotk.x executable" 1>&2 - exit 1 - fi - fi -fi - -# transfer of command-line arguments to standard input -# a pipe (|) is added at the end of each line to recognize line end, -# allowing for single items explicitily ending with one or more spaces -# the pipe is then removed inside the iotk.x parser. -for argument -do - echo "$argument|" -done | ${EXEC} diff --git a/quantum_espresso/kcp/make.sys.in b/quantum_espresso/kcp/make.sys.in deleted file mode 100644 index eb4e56c97..000000000 --- a/quantum_espresso/kcp/make.sys.in +++ /dev/null @@ -1,138 +0,0 @@ -# @configure_input@ - -# compilation rules - -.SUFFIXES : -.SUFFIXES : .o .c .f .f90 - -# most fortran compilers can directly preprocess c-like directives: use -# $(MPIF90) $(F90FLAGS) -c $< -# if explicit preprocessing by the C preprocessor is needed, use: -# $(CPP) $(CPPFLAGS) $< -o $*.F90 -# $(MPIF90) $(F90FLAGS) -c $*.F90 -o $*.o -# remember the tabulator in the first column !!! - -.f90.o: - @f90rule@ - -# .f.o and .c.o: do not modify - -.f.o: - $(F77) $(FFLAGS) -c $< - -.c.o: - $(CC) $(CFLAGS) -c $< - -@SET_MAKE@ -# DFLAGS = precompilation options (possible arguments to -D and -U) -# used by the C compiler and preprocessor -# FDFLAGS = as DFLAGS, for the f90 compiler -# See include/defs.h.README for a list of options and their meaning -# With the exception of IBM xlf, FDFLAGS = $(DFLAGS) -# For IBM xlf, FDFLAGS is the same as DFLAGS with separating commas - -DFLAGS = @dflags@ -FDFLAGS = @fdflags@ - -# IFLAGS = how to locate directories where files to be included are -# In most cases, IFLAGS = -I../include - -IFLAGS = @iflags@ - -# MODFLAGS = flag used by f90 compiler to locate modules -# You need to search for modules in ./, in ../iotk/src, in ../Modules - -MODFLAGS = @imod@./ @imod@../Modules @imod@../iotk/src - -# Compilers: fortran-90, fortran-77, C -# If a parallel compilation is desired, MPIF90 should be a fortran-90 -# compiler that produces executables for parallel execution using MPI -# (such as for instance mpif90, mpf90, mpxlf90,...); -# otherwise, an ordinary fortran-90 compiler (f90, g95, xlf90, ifort,...) -# If you have a parallel machine but no suitable candidate for MPIF90, -# try to specify the directory containing "mpif.h" in IFLAGS -# and to specify the location of MPI libraries in MPI_LIBS - -MPIF90 = @mpif90@ -#F90 = @f90@ -CC = @cc@ -F77 = @f77@ - -# C preprocessor and preprocessing flags - for explicit preprocessing, -# if needed (see the compilation rules above) -# preprocessing flags must include DFLAGS and IFLAGS - -CPP = @cpp@ -CPPFLAGS = @cppflags@ $(DFLAGS) $(IFLAGS) - -# compiler flags: C, F90, F77 -# C flags must include DFLAGS and IFLAGS -# F90 flags must include MODFLAGS, IFLAGS, and FDFLAGS with appropriate syntax - -CFLAGS = @cflags@ $(DFLAGS) $(IFLAGS) -F90FLAGS = @f90flags@ @pre_fdflags@$(FDFLAGS) $(IFLAGS) $(MODFLAGS) -FFLAGS = @fflags@ - -# compiler flags without optimization for fortran-77 -# the latter is NEEDED to properly compile dlamch.f, used by lapack - -FFLAGS_NOOPT = @fflags_noopt@ - -# Linker, linker-specific flags (if any) -# Typically LD coincides with F90 or MPIF90, LD_LIBS is empty - -LD = @ld@ -LDFLAGS = @ldflags@ -LD_LIBS = - -# External Libraries (if any) : blas, lapack, fft, MPI - -# If you have nothing better, use the local copy : ../flib/blas.a - -BLAS_LIBS = @blas_libs@ - -# The following lapack libraries will be available in flib/ : -# ../flib/lapack.a : contains all needed routines -# ../flib/lapack_atlas.a: only routines not present in the Atlas library -# For IBM machines with essl (-D__ESSL): load essl BEFORE lapack ! -# remember that LAPACK_LIBS precedes BLAS_LIBS in loading order - -LAPACK_LIBS = @lapack_libs@ - -# nothing needed here if the the internal copy of FFTW is compiled -# (needs -D__FFTW in DFLAGS) - -FFT_LIBS = @fft_libs@ - -# For parallel execution, the correct path to MPI libraries must -# be specified in MPI_LIBS (except for IBM if you use mpxlf) - -MPI_LIBS = @mpi_libs@ - -# IBM-specific: MASS libraries, if available and if -D__MASS is defined in FDFLAGS - -MASS_LIBS = @mass_libs@ - -# pgplot libraries (used by some post-processing tools) - -PGPLOT_LIBS = @pgplot_libs@ - -# ar command and flags - for most architectures: AR = ar, ARFLAGS = ruv -# ARFLAGS_DYNAMIC is used in iotk to produce a dynamical library, -# for Mac OS-X with PowerPC and xlf compiler. In all other cases -# ARFLAGS_DYNAMIC = $(ARFLAGS) - -AR = @ar@ -ARFLAGS = @arflags@ -ARFLAGS_DYNAMIC= @arflags_dynamic@ - -# ranlib command. If ranlib is not needed (it isn't in most cases) use -# RANLIB = echo - -RANLIB = @ranlib@ - -# all internal and external libraries - do not modify - -LIBOBJS = ../flib/ptools.a ../flib/flib.a ../clib/clib.a ../iotk/src/libiotk.a -LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FFT_LIBS) $(MPI_LIBS) $(MASS_LIBS) $(PGPLOT_LIBS) $(LD_LIBS) - diff --git a/quantum_espresso/kcp/make.sys.intel b/quantum_espresso/kcp/make.sys.intel deleted file mode 100644 index 1970886f7..000000000 --- a/quantum_espresso/kcp/make.sys.intel +++ /dev/null @@ -1,138 +0,0 @@ -# make.sys. Generated from make.sys.in by configure. - -# compilation rules - -.SUFFIXES : -.SUFFIXES : .o .c .f .f90 - -# most fortran compilers can directly preprocess c-like directives: use -# $(MPIF90) $(F90FLAGS) -c $< -# if explicit preprocessing by the C preprocessor is needed, use: -# $(CPP) $(CPPFLAGS) $< -o $*.F90 -# $(MPIF90) $(F90FLAGS) -c $*.F90 -o $*.o -# remember the tabulator in the first column !!! - -.f90.o: - $(MPIF90) $(F90FLAGS) -c $< - -# .f.o and .c.o: do not modify - -.f.o: - $(F77) $(FFLAGS) -c $< - -.c.o: - $(CC) $(CFLAGS) -c $< - - -# DFLAGS = precompilation options (possible arguments to -D and -U) -# used by the C compiler and preprocessor -# FDFLAGS = as DFLAGS, for the f90 compiler -# See include/defs.h.README for a list of options and their meaning -# With the exception of IBM xlf, FDFLAGS = $(DFLAGS) -# For IBM xlf, FDFLAGS is the same as DFLAGS with separating commas - -DFLAGS = -D__INTEL -D__FFTW3 -D__MPI -D__PARA -FDFLAGS = $(DFLAGS) - -# IFLAGS = how to locate directories where files to be included are -# In most cases, IFLAGS = -I../include - -IFLAGS = -I../include - -# MODFLAGS = flag used by f90 compiler to locate modules -# You need to search for modules in ./, in ../iotk/src, in ../Modules - -MODFLAGS = -I./ -I../Modules -I../iotk/src - -# Compilers: fortran-90, fortran-77, C -# If a parallel compilation is desired, MPIF90 should be a fortran-90 -# compiler that produces executables for parallel execution using MPI -# (such as for instance mpif90, mpf90, mpxlf90,...); -# otherwise, an ordinary fortran-90 compiler (f90, g95, xlf90, ifort,...) -# If you have a parallel machine but no suitable candidate for MPIF90, -# try to specify the directory containing "mpif.h" in IFLAGS -# and to specify the location of MPI libraries in MPI_LIBS - -MPIF90 = mpiifort -#F90 = ifort -CC = icc -F77 = ifort - -# C preprocessor and preprocessing flags - for explicit preprocessing, -# if needed (see the compilation rules above) -# preprocessing flags must include DFLAGS and IFLAGS - -CPP = cpp -CPPFLAGS = -P -traditional $(DFLAGS) $(IFLAGS) - -# compiler flags: C, F90, F77 -# C flags must include DFLAGS and IFLAGS -# F90 flags must include MODFLAGS, IFLAGS, and FDFLAGS with appropriate syntax - -CFLAGS = -O3 $(DFLAGS) $(IFLAGS) -F90FLAGS = $(FFLAGS) -nomodule -fpp $(FDFLAGS) $(IFLAGS) $(MODFLAGS) -FFLAGS = -O2 -assume byterecl - -# compiler flags without optimization for fortran-77 -# the latter is NEEDED to properly compile dlamch.f, used by lapack - -FFLAGS_NOOPT = -O0 -assume byterecl - -# Linker, linker-specific flags (if any) -# Typically LD coincides with F90 or MPIF90, LD_LIBS is empty - -LD = mpiifort -LDFLAGS = -LD_LIBS = - -# External Libraries (if any) : blas, lapack, fft, MPI - -# If you have nothing better, use the local copy : ../flib/blas.a - -BLAS_LIBS = -lmkl_intel_lp64 -lmkl_sequential -lmkl_core - -# The following lapack libraries will be available in flib/ : -# ../flib/lapack.a : contains all needed routines -# ../flib/lapack_atlas.a: only routines not present in the Atlas library -# For IBM machines with essl (-D__ESSL): load essl BEFORE lapack ! -# remember that LAPACK_LIBS precedes BLAS_LIBS in loading order - -LAPACK_LIBS = - -# nothing needed here if the the internal copy of FFTW is compiled -# (needs -D__FFTW in DFLAGS) - -FFT_LIBS = - -# For parallel execution, the correct path to MPI libraries must -# be specified in MPI_LIBS (except for IBM if you use mpxlf) - -MPI_LIBS = - -# IBM-specific: MASS libraries, if available and if -D__MASS is defined in FDFLAGS - -MASS_LIBS = - -# pgplot libraries (used by some post-processing tools) - -PGPLOT_LIBS = - -# ar command and flags - for most architectures: AR = ar, ARFLAGS = ruv -# ARFLAGS_DYNAMIC is used in iotk to produce a dynamical library, -# for Mac OS-X with PowerPC and xlf compiler. In all other cases -# ARFLAGS_DYNAMIC = $(ARFLAGS) - -AR = ar -ARFLAGS = ruv -ARFLAGS_DYNAMIC= ruv - -# ranlib command. If ranlib is not needed (it isn't in most cases) use -# RANLIB = echo - -RANLIB = ranlib - -# all internal and external libraries - do not modify - -LIBOBJS = ../flib/ptools.a ../flib/flib.a ../clib/clib.a ../iotk/src/libiotk.a -LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FFT_LIBS) $(MPI_LIBS) $(MASS_LIBS) $(PGPLOT_LIBS) $(LD_LIBS) - From bdca138988bda110ee2bb80eb8e767deffb7e12c Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 20 Sep 2022 10:54:04 +0200 Subject: [PATCH 02/49] Remove test for compiling kcp (this is now performed in the separate koopmans-kcp repository) --- .github/workflows/make_qe4.yml | 40 ---------------------------------- 1 file changed, 40 deletions(-) delete mode 100644 .github/workflows/make_qe4.yml diff --git a/.github/workflows/make_qe4.yml b/.github/workflows/make_qe4.yml deleted file mode 100644 index a38559bd9..000000000 --- a/.github/workflows/make_qe4.yml +++ /dev/null @@ -1,40 +0,0 @@ -name: Build KCP - -on: - pull_request: - branches: - - master - paths: - - 'quantum_espresso/kcp/**' - push: - branches: - - master - paths: - - 'quantum_espresso/kcp/**' - -jobs: - gfortran: - runs-on: ubuntu-latest - steps: - - name: Set up git user - run: | - git config --global user.name "koopmans-tester" - git config --global user.email ${{ secrets.KOOPMANS_TESTER_EMAIL }} - - name: Checkout - uses: actions/checkout@v2 - with: - submodules: true - ssh-known-hosts: 'gitlab.com ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIAfuCHKVTjquxvt6CM6tdG4SLp1Btn/nOeHHE5UOzRdf' - ssh-strict: false - ssh-key: ${{ secrets.KOOPMANS_TESTER_PRIVATE_KEY }} - - name: Install dependencies - run: | - sudo apt-get update - sudo apt-get install gfortran libopenmpi-dev libblas-dev liblapack-dev fftw3-dev - - name: Configure kcp - run: | - make configure_4 MPIF90=mpif90 - - name: Build kcp - run: | - make espresso_4 MPIF90=mpif90 - From 5b73fcafa064d50800dcf81a981a8fd4c81c4cde Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 20 Sep 2022 11:10:08 +0200 Subject: [PATCH 03/49] Removing utils as explicit files --- quantum_espresso/utils/.gitignore | 4 - quantum_espresso/utils/Makefile | 22 - quantum_espresso/utils/README.rst | 16 - quantum_espresso/utils/src/Makefile | 44 - quantum_espresso/utils/src/cp_files.f90 | 250 --- quantum_espresso/utils/src/epsilon.f90 | 1793 ------------------ quantum_espresso/utils/src/fft_supercell.f90 | 718 ------- quantum_espresso/utils/src/make.depend | 130 -- quantum_espresso/utils/src/merge_evc.f90 | 274 --- quantum_espresso/utils/src/plot_wan2kcp.f90 | 199 -- quantum_espresso/utils/src/read_wannier.f90 | 247 --- quantum_espresso/utils/src/scell_wfc.f90 | 193 -- quantum_espresso/utils/src/wann2kcp.f90 | 788 -------- quantum_espresso/utils/src/wannier.f90 | 56 - quantum_espresso/utils/src/wannier2kcp.f90 | 673 ------- 15 files changed, 5407 deletions(-) delete mode 100644 quantum_espresso/utils/.gitignore delete mode 100644 quantum_espresso/utils/Makefile delete mode 100644 quantum_espresso/utils/README.rst delete mode 100644 quantum_espresso/utils/src/Makefile delete mode 100644 quantum_espresso/utils/src/cp_files.f90 delete mode 100644 quantum_espresso/utils/src/epsilon.f90 delete mode 100644 quantum_espresso/utils/src/fft_supercell.f90 delete mode 100644 quantum_espresso/utils/src/make.depend delete mode 100644 quantum_espresso/utils/src/merge_evc.f90 delete mode 100644 quantum_espresso/utils/src/plot_wan2kcp.f90 delete mode 100644 quantum_espresso/utils/src/read_wannier.f90 delete mode 100644 quantum_espresso/utils/src/scell_wfc.f90 delete mode 100644 quantum_espresso/utils/src/wann2kcp.f90 delete mode 100644 quantum_espresso/utils/src/wannier.f90 delete mode 100644 quantum_espresso/utils/src/wannier2kcp.f90 diff --git a/quantum_espresso/utils/.gitignore b/quantum_espresso/utils/.gitignore deleted file mode 100644 index 5203a5317..000000000 --- a/quantum_espresso/utils/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -*.o -*.mod -*.x -bin diff --git a/quantum_espresso/utils/Makefile b/quantum_espresso/utils/Makefile deleted file mode 100644 index d8ae42368..000000000 --- a/quantum_espresso/utils/Makefile +++ /dev/null @@ -1,22 +0,0 @@ -# Makefile for PostProc - -default : all - -all : bindir - if test -d src ; then \ - ( cd src ; $(MAKE) || exit 1 ) ; fi - -bindir : - test -d bin || mkdir bin - -links : bindir - ( cd bin/ ; \ - rm -f *.x ; \ - for exe in ../src/*.x ; do \ - if test ! -L $$exe ; then ln -fs $$exe . ; fi \ - done ; ) - -clean : - if test -d src ; then \ - ( cd src ; $(MAKE) clean ) ; fi - - /bin/rm -f bin/*.x \ No newline at end of file diff --git a/quantum_espresso/utils/README.rst b/quantum_espresso/utils/README.rst deleted file mode 100644 index 6bccd41ae..000000000 --- a/quantum_espresso/utils/README.rst +++ /dev/null @@ -1,16 +0,0 @@ -koopmans utils -============== - -Contains fortran utilities required for performing Koopmans calculations. These are: - -| ``merge_evc.x`` - a program for merging evc wavefunction files -| ``wann2kcp.x`` - a program for converting wannier90 files into a format readable by kcp.x -| ``epsilon.x`` - a modified version of Quantum ESPRESSO's epsilon.x - -These utilities are dependent on the local Quantum ESPRESSO installation. - -Contact -------- -Written and maintained by Edward Linscott, Riccardo De Gennaro, and Nicola Colonna (2020-) - -For help and feedback email edward.linscott@gmail.com diff --git a/quantum_espresso/utils/src/Makefile b/quantum_espresso/utils/src/Makefile deleted file mode 100644 index 0033c75bf..000000000 --- a/quantum_espresso/utils/src/Makefile +++ /dev/null @@ -1,44 +0,0 @@ -# Makefile for Koopmans utils - --include ../../q-e/make.inc - -# location of needed modules and included files (if any) -MODFLAGS= $(BASEMOD_FLAGS) \ - $(MOD_FLAG)../../q-e/PW/src \ - $(MOD_FLAG)../../q-e/Modules/ \ - $(MOD_FLAG)../../q-e/dft-d3/ - - -PWOBJS = ../../q-e/PW/src/libpw.a ../../q-e/KS_Solvers/libks_solvers.a ../../q-e/dft-d3/libdftd3qe.a ../../q-e/PP/src/libpp.a -QEMODS = $(BASEMODS) - -WAN2KCP_OBJS = wannier.o read_wannier.o fft_supercell.o scell_wfc.o plot_wan2kcp.o \ - cp_files.o wannier2kcp.o - -MODULES = $(PWOBJS) $(QEMODS) - -all : pwlib pplib epsilon.x wann2kcp.x merge_evc.x - -pwlib: - cd ../../q-e/ ; $(MAKE) pwlibs || exit 1 -pplib: - cd ../../q-e/PP/src ; if [ ! -e libpp.a ]; then $(MAKE) libpp.a ; fi || exit 1 - -merge_evc.x : merge_evc.o - $(LD) $(LDFLAGS) -o $@ merge_evc.o - - ( cd ../bin ; ln -fs ../src/$@ . ) - -wann2kcp.x : wann2kcp.o $(WAN2KCP_OBJS) $(MODULES) $(LIBOBJS) - $(LD) $(LDFLAGS) -o $@ \ - wann2kcp.o $(WAN2KCP_OBJS) $(MODULES) $(LIBOBJS) $(QELIBS) - - ( cd ../bin ; ln -fs ../src/$@ . ) - -epsilon.x : epsilon.o $(MODULES) $(LIBOBJS) - $(LD) $(LDFLAGS) -o $@ epsilon.o $(MODULES) \ - $(LIBOBJS) $(QELIBS) - - ( cd ../bin ; ln -fs ../src/$@ . ) - -clean : - - /bin/rm -f *.x *.o *~ *_tmp.f90 *.d *.mod *.i *.L *genmod* - -include make.depend diff --git a/quantum_espresso/utils/src/cp_files.f90 b/quantum_espresso/utils/src/cp_files.f90 deleted file mode 100644 index 5364b96ca..000000000 --- a/quantum_espresso/utils/src/cp_files.f90 +++ /dev/null @@ -1,250 +0,0 @@ -! -! Copyright (C) 2003-2013 Quantum ESPRESSO and Wannier90 groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -! Written by Riccardo De Gennaro, EPFL (Sept 2020). -! -! -!--------------------------------------------------------------------- -MODULE cp_files - !------------------------------------------------------------------- - ! - ! - IMPLICIT NONE - ! - PRIVATE - ! - PUBLIC :: write_wannier_cp - ! - CONTAINS - ! - !------------------------------------------------------------------- - SUBROUTINE write_wannier_cp( iun, nword, norb, ispin, ks_only, typ ) - !----------------------------------------------------------------- - ! - ! ... This routine takes the Wannier/KS functions in input and - ! ... writes them into file(2), readable by the CP-Koopmans code. - ! ... The output files are structured as below: - ! ... - ! ... - ks_only=.false. and nspin=2 - ! ... the Wannier functions of the calculated spin component - ! ... are written to a file called evcw.dat - ! ... - ! ... - ks_only=.false. and nspin=1 - ! ... the Wannier functions of the only spin component present - ! ... are written twice into two distinct files called evcw1.dat - ! ... and evcw2.dat - ! ... - ! ... - ks_only=.true. and nspin=2 - ! ... the KS wave functions of each spin component are written - ! ... to two files: evc_occupied1.dat and evc_occupied2.dat (for - ! ... occupied states), evc0_empty1.dat and evc0_empty2.dat (for - ! ... empty states) - ! ... - ! ... - ks_only=.true. and nspin=1 - ! ... the KS wave functions of the spin component are written - ! ... twice into two distinct files: evc_occupied1.dat and - ! ... evc_occupied2.dat (for occupied states), evc0_empty1.dat and - ! ... evc0_empty2.dat (for empty states) - ! - USE kinds, ONLY : DP - USE klist, ONLY : nelec - USE io_global, ONLY : ionode, ionode_id - USE lsda_mod, ONLY : nspin - USE mp_bands, ONLY : intra_bgrp_comm - USE mp_wave, ONLY : mergewf - USE mp_world, ONLY : mpime, nproc - USE mp, ONLY : mp_sum - USE noncollin_module, ONLY : npol - USE buffers, ONLY : get_buffer - USE read_wannier, ONLY : num_kpts - USE fft_supercell, ONLY : npwxcp, ig_l2g_cp - ! - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: iun ! unit to the WFs buffer - INTEGER, INTENT(IN) :: nword ! record length WF file - INTEGER, INTENT(IN) :: norb ! num of (primitive cell) WFs/KS states - INTEGER, INTENT(IN) :: ispin ! spin component - LOGICAL, INTENT(IN) :: ks_only - CHARACTER(LEN=3), OPTIONAL, INTENT(IN) :: typ ! required when ks_only=.true. - ! - CHARACTER(LEN=20) :: filename - INTEGER :: io_level = 1 - INTEGER :: cp_unit = 125 - INTEGER :: num_files - INTEGER :: npw_g ! global number of PWs - INTEGER :: ir, ibnd, ibnd_, ifile, ipw - INTEGER :: norbx, nrtot, nelec_ - COMPLEX(DP), ALLOCATABLE :: evc(:,:) - COMPLEX(DP), ALLOCATABLE :: evc_g(:) - ! - ! - ALLOCATE( evc(npwxcp*npol,norb) ) - nrtot = num_kpts - ! - IF ( ks_only ) THEN - ! - IF ( .not. PRESENT(typ) ) & - CALL errore( 'write_wannier_cp', 'ks_only=.true. needs typ', 1 ) - ! - IF ( nspin == 2 ) THEN - CALL set_nelec( ispin, nrtot, nelec_ ) - ELSE - nelec_ = INT(nelec) / 2 - ENDIF - ! - IF ( typ == 'occ' ) THEN - ! - norbx = nelec_ * nrtot - ! - ELSEIF ( typ == 'emp' ) THEN - ! - norbx = ( norb - nelec_ ) * nrtot - ! - ELSE - ! - CALL errore( 'write_wannier_cp', 'Wrong value for typ', 1 ) - ! - ENDIF - ! - ELSE - ! - norbx = norb * nrtot - ! - ENDIF - ! - npw_g = npwxcp - CALL mp_sum( npw_g, intra_bgrp_comm ) - ALLOCATE( evc_g(npw_g) ) - ! - ! ... the only case where we want to write one file only is when - ! ... we are calculating Wannier functions in the spin polarized - ! ... case, since each spin channel is calculated independently. - ! ... In all the other cases we want two files: - ! ... - ! ... - evcw1.dat and evcw2.dat, which are one the copy of the - ! ... other, when calculating Wannier functions (ks_only=.false.) - ! ... - ! ... - evc_XXX1.dat and evc_XXX2.dat (where XXX is 'occupied' - ! ... or empty) when calculating KS states (ks_only=.true.) - ! ... where evc_XXX2.dat is whether a copy of evc_XXX1.dat - ! ... or a file written independently depending on the value - ! ... of nspin - ! - IF ( nspin == 1 ) THEN - num_files = 2 - ELSE - num_files = 1 - ENDIF - ! - ! ... here we gather the wfc from all the processes - ! ... and we write it to file(s) (in CP Koopmans nspin=2 always!). - ! - DO ifile = 1, num_files - ! - IF ( ks_only ) THEN - ! - IF ( typ == 'occ' ) THEN - WRITE( filename, 101 ) ifile + ispin - 1 - ELSE - WRITE( filename, 102 ) ifile + ispin - 1 - ENDIF - ! - ELSE - ! - IF ( num_files == 1 ) THEN - filename = 'evcw.dat' - ELSE - WRITE( filename, 100 ) ifile - ENDIF - ! - ENDIF - ! - IF ( ionode ) THEN - OPEN( UNIT=cp_unit, FILE=filename, STATUS='unknown', FORM='unformatted' ) - WRITE( cp_unit ) npw_g, norbx - ENDIF - ! - ! - DO ir = 1, nrtot - ! - CALL get_buffer( evc, nword, iun, ir ) - ! - DO ibnd = 1, norbx/nrtot - ! - ibnd_ = ibnd - IF ( ks_only ) THEN - IF ( typ == 'emp' ) ibnd_ = ibnd + nelec_ - ENDIF - ! - evc_g(:) = ( 0.D0, 0.D0 ) - CALL mergewf( evc(:,ibnd_), evc_g, npwxcp, ig_l2g_cp, mpime, & - nproc, ionode_id, intra_bgrp_comm ) - ! - IF ( ionode ) THEN - ! - WRITE( cp_unit ) ( evc_g(ipw), ipw=1,npw_g ) - ! - ENDIF - ! - ENDDO - ! - ENDDO - ! - IF ( ionode ) CLOSE ( cp_unit ) - ! - ENDDO - ! - ! -100 FORMAT( 'evcw', I1, '.dat' ) -101 FORMAT( 'evc_occupied', I1, '.dat' ) -102 FORMAT( 'evc0_empty', I1, '.dat' ) - ! - ! - END SUBROUTINE write_wannier_cp - ! - ! - !------------------------------------------------------------------- - SUBROUTINE set_nelec( ispin, nrtot, nelec ) - !----------------------------------------------------------------- - ! - ! ... This routine calculates the number of electrons in the specified - ! ... spin channel. - ! - USE kinds, ONLY : DP - USE constants, ONLY : eps8 - USE electrons_base, ONLY : nupdwn - USE wvfct, ONLY : wg - ! - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ispin, nrtot - INTEGER, INTENT(OUT) :: nelec - ! - INTEGER :: ibnd, ik - INTEGER :: counter - ! - ! - counter = 0 - ik = nrtot * ( ispin - 1 ) + 1 - ! - DO ibnd = 1, nupdwn(ispin) - ! - IF ( wg(ibnd,ik) .gt. eps8 ) counter = counter + 1 - ! - ENDDO - ! - nelec = counter - ! - ! - END SUBROUTINE set_nelec - ! - ! -END MODULE cp_files diff --git a/quantum_espresso/utils/src/epsilon.f90 b/quantum_espresso/utils/src/epsilon.f90 deleted file mode 100644 index 9661d72d7..000000000 --- a/quantum_espresso/utils/src/epsilon.f90 +++ /dev/null @@ -1,1793 +0,0 @@ -! -! Copyright (C) 2004-2009 Andrea Benassi and Quantum ESPRESSO group -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -!------------------------------ - MODULE grid_module -!------------------------------ - USE kinds, ONLY : DP - IMPLICIT NONE - PRIVATE - - ! - ! general purpose vars - ! - INTEGER :: nw - REAL(DP) :: wmax, wmin - REAL(DP) :: alpha, full_occ - REAL(DP), ALLOCATABLE :: focc(:,:), wgrid(:) - ! - PUBLIC :: grid_build, grid_destroy - PUBLIC :: nw, wmax, wmin - PUBLIC :: focc, wgrid, alpha, full_occ - ! -CONTAINS - -!--------------------------------------------- - SUBROUTINE grid_build(nw_, wmax_, wmin_, metalcalc) - !------------------------------------------- - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout, ionode - USE wvfct, ONLY : nbnd, wg - USE klist, ONLY : nks, wk, nelec - USE lsda_mod, ONLY : nspin - USE uspp, ONLY : okvan - ! - IMPLICIT NONE - ! - ! input vars - INTEGER, INTENT(IN) :: nw_ - REAL(DP), INTENT(IN) :: wmax_ ,wmin_ - LOGICAL, OPTIONAL, INTENT(IN) :: metalcalc - ! - ! local vars - INTEGER :: iw,ik,i,ierr - - ! - ! check on the number of bands: we need to include empty bands in order - ! to compute the transitions - ! - IF ( nspin == 1) full_occ = 2.0d0 - IF ( nspin == 2 .OR. nspin == 4) full_occ = 1.0d0 - ! - IF ( nspin == 2 ) THEN - IF ( nbnd*full_occ <= nelec/2.d0 ) CALL errore('epsilon', 'bad band number', 2) - ELSE - IF ( nbnd*full_occ <= nelec ) CALL errore('epsilon', 'bad band number', 1) - ENDIF - ! - ! USPP are not implemented (dipole matrix elements are not trivial at all) - ! - IF ( okvan ) CALL errore('grid_build','USPP are not implemented',1) - - ! - ! store data in module - ! - nw = nw_ - wmax = wmax_ - wmin = wmin_ - - ! - ! workspace - ! - ALLOCATE ( focc( nbnd, nks), STAT=ierr ) - IF (ierr/=0) CALL errore('grid_build','allocating focc', abs(ierr)) - ! - ALLOCATE( wgrid( nw ), STAT=ierr ) - IF (ierr/=0) CALL errore('grid_build','allocating wgrid', abs(ierr)) - - ! - ! check on k point weights, no symmetry operations are allowed - ! - DO ik = 2, nks - ! - IF ( abs( wk(1) - wk(ik) ) > 1.0d-8 ) & - CALL errore('grid_build','non uniform kpt grid', ik ) - ! - ENDDO - ! - ! occupation numbers, to be normalized differently - ! whether we are spin resolved or not - ! - DO ik = 1, nks - DO i = 1, nbnd - focc(i, ik) = wg(i, ik) * full_occ / wk(ik) - ENDDO - ENDDO - - ! - ! set the energy grid - ! - IF ( metalcalc .AND. ABS(wmin) <= 0.001d0 ) wmin=0.001d0 - IF ( ionode ) WRITE(stdout,"(5x,a,f12.6)") "metallic system: redefining wmin = ", wmin - ! - alpha = (wmax - wmin) / REAL(nw-1, KIND=DP) - ! - DO iw = 1, nw - wgrid(iw) = wmin + (iw-1) * alpha - ENDDO - ! -END SUBROUTINE grid_build -! -! -!---------------------------------- - SUBROUTINE grid_destroy - !---------------------------------- - IMPLICIT NONE - INTEGER :: ierr - ! - IF ( ALLOCATED( focc) ) THEN - ! - DEALLOCATE ( focc, wgrid, STAT=ierr) - CALL errore('grid_destroy','deallocating grid stuff',abs(ierr)) - ! - ENDIF - ! -END SUBROUTINE grid_destroy - -END MODULE grid_module -! -MODULE eps_writer -!------------------------------ - IMPLICIT NONE - ! - PRIVATE - ! - PUBLIC :: eps_writetofile - ! -CONTAINS -! -!-------------------------------------------------------------------- -SUBROUTINE eps_writetofile(namein,desc,nw,wgrid,ncol,var,desc2) - !------------------------------------------------------------------ - ! - USE kinds, ONLY : DP - USE io_files, ONLY : prefix, tmp_dir - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(IN) :: namein - CHARACTER(LEN=*), INTENT(IN) :: desc - INTEGER, INTENT(IN) :: nw, ncol - REAL(DP), INTENT(IN) :: wgrid(nw) - REAL(DP), INTENT(IN) :: var(ncol,nw) - CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: desc2 - ! - CHARACTER(256) :: str - INTEGER :: iw - ! - str = TRIM(namein) // "_" // TRIM(prefix) // ".dat" - OPEN(40,FILE=TRIM(str)) - ! - WRITE(40,"(a)") "# "// TRIM(desc) - ! - IF (PRESENT(desc2)) THEN - WRITE(40, "(a)") "# "// TRIM(desc2) - ELSE - WRITE(40,"(a)") "#" - END IF - ! - DO iw = 1, nw - ! - WRITE(40,"(10f15.9)") wgrid(iw), var(1:ncol,iw) - ! - ENDDO - ! - CLOSE(40) - ! -END SUBROUTINE eps_writetofile -! -END MODULE eps_writer -! -!------------------------------ -PROGRAM epsilon -!------------------------------ - ! - ! Compute the complex macroscopic dielectric function, - ! at the RPA level, neglecting local field effects. - ! Eps is computed both on the real or immaginary axis - ! - ! Authors: - ! 2006 Andrea Benassi, Andrea Ferretti, Carlo Cavazzoni: basic implementation (partly taken from pw2gw.f90) - ! 2007 Andrea Benassi: intraband contribution, nspin=2 - ! 2016 Tae-Yun Kim, Cheol-Hwan Park: bugs fixed - ! 2016 Tae-Yun Kim, Cheol-Hwan Park, Andrea Ferretti: non-collinear magnetism implemented - ! code significantly restructured - ! - USE kinds, ONLY : DP - USE io_global, ONLY : stdout, ionode, ionode_id - USE mp, ONLY : mp_bcast - USE mp_global, ONLY : mp_startup - USE mp_images, ONLY : intra_image_comm - USE io_files, ONLY : tmp_dir, prefix - USE constants, ONLY : RYTOEV - USE ener, ONLY : ef - USE klist, ONLY : lgauss, ltetra - USE wvfct, ONLY : nbnd - USE lsda_mod, ONLY : nspin - USE environment, ONLY : environment_start, environment_end - USE grid_module, ONLY : grid_build, grid_destroy - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256), EXTERNAL :: trimcheck - CHARACTER(LEN=256) :: outdir - ! - ! input variables - ! - INTEGER :: nw,nbndmin,nbndmax - REAL(DP) :: intersmear,intrasmear,wmax,wmin,shift, & - ekin_eout, ekin_error , photon_ener, & - polar_angle, azimuthal_angle, & - photon_angle, e_fermi - CHARACTER(10) :: calculation,smeartype - LOGICAL :: metalcalc, homo_gas, wfc_real, & - modified_pw, othor_pw - ! - NAMELIST / inputpp / prefix, outdir, calculation - NAMELIST / energy_grid / smeartype, intersmear, intrasmear, nw, wmax, wmin, & - nbndmin,nbndmax,shift,ekin_eout,ekin_error, & - polar_angle, azimuthal_angle, photon_angle, & - photon_ener, homo_gas, wfc_real, e_fermi, & - modified_pw, othor_pw - - ! - ! local variables - ! - INTEGER :: ios - LOGICAL :: needwf = .TRUE. - -!--------------------------------------------- -! program body -!--------------------------------------------- -! - ! initialise environment - ! -#if defined(__MPI) - CALL mp_startup ( ) -#endif - CALL environment_start ( 'epsilon' ) - ! - ! Set default values for variables in namelist - ! - calculation = 'eps' - prefix = 'pwscf' - shift = 0.0d0 - CALL get_environment_variable( 'ESPRESSO_TMPDIR', outdir ) - IF ( trim( outdir ) == ' ' ) outdir = './' - intersmear = 0.136 - wmin = 0.0d0 - wmax = 30.0d0 - nbndmin = 1 - nbndmax = 0 - nw = 600 - smeartype = 'gauss' - intrasmear = 0.0d0 - metalcalc = .FALSE. - ! - ! PHOTOSPEC additional variables - ekin_eout = 30.0d0 - ekin_error = 1.0d0 - polar_angle = 30 - azimuthal_angle = 30 - photon_angle = 50 - photon_ener = 80 - e_fermi = 4.0 - wfc_real = .true. - homo_gas = .true. - modified_pw = .true. - othor_pw = .false. - ! - ! this routine allows the user to redirect the input using -input - ! instead of < - ! - CALL input_from_file( ) - - ! - ! read input file - ! - IF (ionode) WRITE( stdout, "( 2/, 5x, 'Reading input file...' ) " ) - ios = 0 - ! - IF ( ionode ) READ (5, inputpp, IOSTAT=ios) - ! - CALL mp_bcast ( ios, ionode_id, intra_image_comm ) - IF (ios/=0) CALL errore('epsilon', 'reading namelist INPUTPP', abs(ios)) - ! - IF ( ionode ) THEN - ! - READ (5, energy_grid, IOSTAT=ios) - ! - tmp_dir = trimcheck(outdir) - ! - ENDIF - ! - CALL mp_bcast ( ios, ionode_id, intra_image_comm ) - IF (ios/=0) CALL errore('epsilon', 'reading namelist ENERGY_GRID', abs(ios)) - ! - ! ... Broadcast variables - ! - IF (ionode) WRITE( stdout, "( 5x, 'Broadcasting variables...' ) " ) - - CALL mp_bcast( smeartype, ionode_id, intra_image_comm ) - CALL mp_bcast( calculation, ionode_id, intra_image_comm ) - CALL mp_bcast( prefix, ionode_id, intra_image_comm ) - CALL mp_bcast( tmp_dir, ionode_id, intra_image_comm ) - CALL mp_bcast( shift, ionode_id, intra_image_comm ) - CALL mp_bcast( intrasmear, ionode_id, intra_image_comm ) - CALL mp_bcast( intersmear, ionode_id, intra_image_comm) - CALL mp_bcast( wmax, ionode_id, intra_image_comm ) - CALL mp_bcast( wmin, ionode_id, intra_image_comm ) - CALL mp_bcast( nw, ionode_id, intra_image_comm ) - CALL mp_bcast( nbndmin, ionode_id, intra_image_comm ) - CALL mp_bcast( nbndmax, ionode_id, intra_image_comm ) - ! - CALL mp_bcast( ekin_eout, ionode_id, intra_image_comm ) - CALL mp_bcast( ekin_error, ionode_id, intra_image_comm) - CALL mp_bcast( polar_angle, ionode_id, intra_image_comm) - CALL mp_bcast( azimuthal_angle, ionode_id, intra_image_comm ) - CALL mp_bcast( photon_angle, ionode_id, intra_image_comm ) - CALL mp_bcast( photon_ener, ionode_id, intra_image_comm ) - CALL mp_bcast( homo_gas, ionode_id, intra_image_comm ) - CALL mp_bcast( wfc_real, ionode_id, intra_image_comm ) - CALL mp_bcast( e_fermi, ionode_id, intra_image_comm ) - CALL mp_bcast( modified_pw, ionode_id, intra_image_comm ) - CALL mp_bcast( othor_pw, ionode_id, intra_image_comm ) - ! - ! read PW simulation parameters from prefix.save/data-file.xml - ! - IF (ionode) WRITE( stdout, "( 5x, 'Reading PW restart file...' ) " ) - - CALL read_file_new( needwf ) - ! - ! few conversions - ! - - IF (ionode) WRITE(stdout,"(2/, 5x, 'Fermi energy [eV] is: ',f8.5)") ef *RYTOEV - - IF (lgauss .or. ltetra) THEN - metalcalc=.TRUE. - IF (ionode) WRITE( stdout, "( 5x, 'The system is a metal (occupations are not fixed)...' ) " ) - ELSE - IF (ionode) WRITE( stdout, "( 5x, 'The system is a dielectric...' ) " ) - ENDIF - - IF (nbndmax == 0) nbndmax = nbnd - - ! - ! perform some consistency checks, - ! setup w-grid and occupation numbers - ! - CALL grid_build(nw, wmax, wmin, metalcalc) - ! - ! ... run the specific pp calculation - ! - IF (ionode) WRITE(stdout,"(/, 5x, 'Performing ',a,' calculation...')") trim(calculation) - CALL start_clock(trim(calculation)) - SELECT CASE ( trim(calculation) ) - ! - CASE ( 'eps' ) - ! - CALL eps_calc ( intersmear, intrasmear, nbndmin, nbndmax, shift, metalcalc, nspin ) - ! - CASE ( 'jdos' ) - ! - CALL jdos_calc ( smeartype, intersmear, nbndmin, nbndmax, shift, nspin ) - ! - CASE ( 'photospec' ) - ! - IF (nspin > 2) CALL errore ('epsilon', 'photospec NOT implemented for non-collinear spin', 1) - CALL photoemission_spectr_pw ( intersmear,intrasmear,nbndmin,nbndmax, & - shift,nspin,metalcalc,polar_angle, azimuthal_angle,& - photon_angle,photon_ener,homo_gas,wfc_real,e_fermi, & - modified_pw, othor_pw) - ! - CASE ( 'offdiag' ) - ! - CALL offdiag_calc ( intersmear, intrasmear, nbndmin, nbndmax, shift, metalcalc, nspin ) - ! - CASE DEFAULT - ! - CALL errore('epsilon','invalid CALCULATION = '//trim(calculation),1) - ! - END SELECT - ! - CALL stop_clock(trim(calculation)) - IF ( ionode ) WRITE( stdout , "(/)" ) - ! - CALL print_clock( trim(calculation) ) - CALL print_clock( 'dipole_calc' ) - IF ( ionode ) WRITE( stdout, * ) - ! - ! cleaning - ! - CALL grid_destroy() - ! - CALL environment_end ( 'epsilon' ) - ! - CALL stop_pp () - -END PROGRAM epsilon - - -!----------------------------------------------------------------------------- -SUBROUTINE eps_calc ( intersmear,intrasmear, nbndmin, nbndmax, shift, metalcalc , nspin) - !----------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE constants, ONLY : PI, RYTOEV - USE cell_base, ONLY : tpiba2, omega - USE wvfct, ONLY : nbnd, et - USE ener, ONLY : efermi => ef - USE klist, ONLY : nks, nkstot, degauss, ngauss - USE io_global, ONLY : ionode, stdout - ! - USE grid_module, ONLY : alpha, focc, full_occ, nw, wgrid, grid_destroy - USE eps_writer, ONLY : eps_writetofile - USE mp_pools, ONLY : inter_pool_comm - USE mp, ONLY : mp_sum - ! - IMPLICIT NONE - - ! - ! input variables - ! - INTEGER, INTENT(in) :: nbndmin, nbndmax, nspin - REAL(DP), INTENT(in) :: intersmear, intrasmear, shift - LOGICAL, INTENT(in) :: metalcalc - ! - ! local variables - ! - INTEGER :: i, ik, iband1, iband2,is - INTEGER :: iw, iwp, ierr - REAL(DP) :: etrans, const, w, renorm(3) - CHARACTER(128):: desc(4), desc2 - ! - REAL(DP), ALLOCATABLE :: epsr(:,:), epsi(:,:), epsrc(:,:,:), epsic(:,:,:) - REAL(DP), ALLOCATABLE :: ieps(:,:), eels(:,:), iepsc(:,:,:), eelsc(:,:,:) - REAL(DP), ALLOCATABLE :: dipole(:,:,:) - COMPLEX(DP), ALLOCATABLE :: dipole_aux(:,:,:) - ! - REAL(DP) , EXTERNAL :: w0gauss -! -!-------------------------- -! main routine body -!-------------------------- -! - ! - ! allocate main spectral and auxiliary quantities - ! - ALLOCATE( dipole(3, nbnd, nbnd), STAT=ierr ) - IF (ierr/=0) CALL errore('epsilon','allocating dipole', abs(ierr) ) - ! - ALLOCATE( dipole_aux(3, nbnd, nbnd), STAT=ierr ) - IF (ierr/=0) CALL errore('epsilon','allocating dipole_aux', abs(ierr) ) - ! - ALLOCATE( epsr( 3, nw), epsi( 3, nw), eels( 3, nw), ieps(3,nw ), STAT=ierr ) - IF (ierr/=0) CALL errore('epsilon','allocating eps', abs(ierr)) - - ! - ! initialize response functions - ! - epsr(:,:) = 0.0_DP - epsi(:,:) = 0.0_DP - ieps(:,:) = 0.0_DP - - ! - ! main kpt loop - ! - kpt_loop: & - DO ik = 1, nks - ! - ! For every single k-point: order k+G for - ! read and distribute wavefunctions - ! compute dipole matrix 3 x nbnd x nbnd parallel over g - ! recover g parallelism getting the total dipole matrix - ! - CALL dipole_calc( ik, dipole_aux, metalcalc , nbndmin, nbndmax) - ! - dipole(:,:,:)= tpiba2 * REAL( dipole_aux(:,:,:) * conjg(dipole_aux(:,:,:)), DP ) - - ! - ! Calculation of real and immaginary parts - ! of the macroscopic dielettric function from dipole - ! approximation. - ! 'intersmear' is the brodening parameter - ! - !Interband - ! - DO iband2 = nbndmin,nbndmax - ! - IF ( focc(iband2,ik) < full_occ) THEN - DO iband1 = nbndmin,nbndmax - ! - IF (iband1==iband2) CYCLE - IF ( focc(iband1,ik) >= 0.5d-4*full_occ ) THEN - IF (abs(focc(iband2,ik)-focc(iband1,ik))< 1.0d-3*full_occ) CYCLE - ! - ! transition energy - ! - etrans = ( et(iband2,ik) -et(iband1,ik) ) * RYTOEV + shift - ! - ! loop over frequencies - ! - DO iw = 1, nw - ! - w = wgrid(iw) - ! - epsi(:,iw) = epsi(:,iw) + dipole(:,iband1,iband2) * intersmear * w* & - RYTOEV**3 * (focc(iband1,ik))/ & - (( (etrans**2 -w**2 )**2 + intersmear**2 * w**2 )* etrans ) - - epsr(:,iw) = epsr(:,iw) + dipole(:,iband1,iband2) * RYTOEV**3 * & - (focc(iband1,ik)) * & - (etrans**2 - w**2 ) / & - (( (etrans**2 -w**2 )**2 + intersmear**2 * w**2 )* etrans ) - ENDDO - ENDIF - ENDDO - ENDIF - ENDDO - - ! - !Intraband (only if metalcalc is true) - ! - IF (metalcalc) THEN - DO iband1 = nbndmin,nbndmax - ! - ! loop over frequencies - ! - DO iw = 1, nw - ! - w = wgrid(iw) - ! - epsi(:,iw) = epsi(:,iw) + dipole(:,iband1,iband1) * intrasmear * w * & - RYTOEV**2 * w0gauss((et(iband1,ik)-efermi)/degauss, ngauss) / & - (( w**4 + intrasmear**2 * w**2 )*degauss ) * (0.5d0 * full_occ) - epsr(:,iw) = epsr(:,iw) - dipole(:,iband1,iband1) * RYTOEV**2 * & - w0gauss((et(iband1,ik)-efermi)/degauss, ngauss) * w**2 / & - (( w**4 + intrasmear**2 * w**2 )*degauss ) * (0.5d0 * full_occ) - ENDDO - ! - ENDDO - ENDIF - ! - ENDDO kpt_loop - - ! - ! recover over kpt parallelization (inter_pool) - ! - CALL mp_sum( epsr, inter_pool_comm ) - CALL mp_sum( epsi, inter_pool_comm ) - - ! - ! impose the correct normalization - ! - IF ( nspin == 1 .OR. nspin == 4) const = 64.0d0 * PI / ( omega * REAL(nkstot, DP) ) - IF ( nspin == 2) const = 128.0d0 * PI / ( omega * REAL(nkstot, DP) ) - ! - epsr(:,:) = 1.0_DP + epsr(:,:) * const - epsi(:,:) = epsi(:,:) * const - - ! - ! Calculation of eels spectrum - ! - DO iw = 1, nw - ! - eels(:,iw) = epsi(:,iw) / ( epsr(:,iw)**2 + epsi(:,iw)**2 ) - ! - ENDDO - - ! - ! calculation of dielectric function on the immaginary frequency axe - ! - DO iw = 1, nw - DO iwp = 2, nw - ! - ieps(:,iw) = ieps(:,iw) + wgrid(iwp) * epsi(:,iwp) / ( wgrid(iwp)**2 + wgrid(iw)**2) - ! - ENDDO - ENDDO - ! - ieps(:,:) = 1.0d0 + 2.0d0/PI * ieps(:,:) * alpha - - ! - ! check dielectric function normalizzation via sumrule - ! - DO i=1,3 - renorm(i) = alpha * SUM( epsi(i,:) * wgrid(:) ) - ENDDO - renorm(:) = SQRT( renorm(:) * 2.0d0/PI) - ! - IF ( ionode ) THEN - ! - WRITE(stdout,"(/,5x, 'xx,yy,zz plasmon frequences [eV] are: ',3f15.9 )") renorm(:) - WRITE(stdout,"(/,5x, 'Writing output on file...' )") - - ! - ! write results on data files - ! - desc(1) = "energy grid [eV] epsr_x epsr_y epsr_z" - WRITE(desc2, "('plasmon frequences [eV]: ',3f15.9)") renorm (:) - ! - desc(2) = "energy grid [eV] epsi_x epsi_y epsi_z" - desc(3) = "energy grid [eV] eels components [arbitrary units]" - desc(4) = "energy grid [eV] ieps_x ieps_y ieps_z" - ! - CALL eps_writetofile("epsr",desc(1),nw,wgrid,3,epsr,desc2) - CALL eps_writetofile("epsi",desc(2),nw,wgrid,3,epsi) - CALL eps_writetofile("eels",desc(3),nw,wgrid,3,eels) - CALL eps_writetofile("ieps",desc(4),nw,wgrid,3,ieps) - ! - ENDIF - - DEALLOCATE ( epsr, epsi, eels, ieps) - ! - ! local cleaning - ! - DEALLOCATE ( dipole, dipole_aux ) - -END SUBROUTINE eps_calc - - -!---------------------------------------------------------------------------------------- -SUBROUTINE jdos_calc ( smeartype, intersmear, nbndmin, nbndmax, shift, nspin ) - !-------------------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE constants, ONLY : PI, RYTOEV - USE wvfct, ONLY : nbnd, et - USE klist, ONLY : nks - USE io_global, ONLY : ionode, stdout - USE grid_module, ONLY : alpha, focc, nw, wgrid - USE eps_writer, ONLY : eps_writetofile - ! - IMPLICIT NONE - - ! - ! input variables - ! - INTEGER, INTENT(IN) :: nbndmin, nbndmax, nspin - REAL(DP), INTENT(IN) :: intersmear, shift - CHARACTER(*), INTENT(IN) :: smeartype - ! - ! local variables - ! - INTEGER :: ik, is, iband1, iband2 - INTEGER :: iw, ierr - REAL(DP) :: etrans, w, renorm, count, srcount(0:1), renormzero,renormuno - ! - CHARACTER(128) :: desc - REAL(DP), ALLOCATABLE :: jdos(:),srjdos(:,:) - - ! - !-------------------------- - ! main routine body - !-------------------------- - ! - ! No wavefunctions are needed in order to compute jdos, only eigenvalues, - ! they are distributed to each task so - ! no mpi calls are necessary in this routine - ! - -! -! spin unresolved calculation -! -IF (nspin == 1) THEN - ! - ! allocate main spectral and auxiliary quantities - ! - ALLOCATE( jdos(nw), STAT=ierr ) - IF (ierr/=0) CALL errore('epsilon','allocating jdos',abs(ierr)) - ! - ! initialize jdos - ! - jdos(:)=0.0_DP - - ! Initialising a counter for the number of transition - count=0.0_DP - - ! - ! main kpt loop - ! - - IF (smeartype=='lorentz') THEN - - kpt_lor: & - DO ik = 1, nks - ! - ! Calculation of joint density of states - ! 'intersmear' is the brodening parameter - ! - DO iband2 = 1,nbnd - IF ( focc(iband2,ik) < 2.0d0) THEN - DO iband1 = 1,nbnd - ! - IF ( focc(iband1,ik) >= 1.0d-4 ) THEN - ! - ! transition energy - ! - etrans = ( et(iband2,ik) -et(iband1,ik) ) * RYTOEV + shift - ! - IF( etrans < 1.0d-10 ) CYCLE - - count = count + (focc(iband1,ik)-focc(iband2,ik)) - ! - ! loop over frequencies - ! - DO iw = 1, nw - ! - w = wgrid(iw) - ! - jdos(iw) = jdos(iw) + intersmear * (focc(iband1,ik)-focc(iband2,ik)) & - / ( PI * ( (etrans -w )**2 + (intersmear)**2 ) ) - - ENDDO - - ENDIF - ENDDO - ENDIF - ENDDO - - ENDDO kpt_lor - - ELSEIF (smeartype=='gauss') THEN - - kpt_gauss: & - DO ik = 1, nks - - ! - ! Calculation of joint density of states - ! 'intersmear' is the brodening parameter - ! - DO iband2 = 1,nbnd - DO iband1 = 1,nbnd - ! - IF ( focc(iband2,ik) < 2.0d0) THEN - IF ( focc(iband1,ik) >= 1.0d-4 ) THEN - ! - ! transition energy - ! - etrans = ( et(iband2,ik) -et(iband1,ik) ) * RYTOEV + shift - ! - IF( etrans < 1.0d-10 ) CYCLE - - ! loop over frequencies - ! - - count=count+ (focc(iband1,ik)-focc(iband2,ik)) - - DO iw = 1, nw - ! - w = wgrid(iw) - ! - jdos(iw) = jdos(iw) + (focc(iband1,ik)-focc(iband2,ik)) * & - exp(-(etrans-w)**2/intersmear**2) & - / (intersmear * sqrt(PI)) - - ENDDO - - ENDIF - ENDIF - ENDDO - ENDDO - - ENDDO kpt_gauss - - ELSE - - CALL errore('epsilon', 'invalid SMEARTYPE = '//trim(smeartype), 1) - - ENDIF - - ! - ! jdos normalizzation - ! - jdos(:)=jdos(:)/count - renorm = alpha * sum( jdos(:) ) - - ! - ! write results on data files - ! - IF (ionode) THEN - WRITE(stdout,"(/,5x, 'Integration over JDOS gives: ',f15.9,' instead of 1.0d0' )") renorm - WRITE(stdout,"(/,5x, 'Writing output on file...' )") - ! - desc = "energy grid [eV] JDOS [1/eV]" - CALL eps_writetofile('jdos',desc,nw,wgrid,1,jdos) - ! - ENDIF - ! - ! local cleaning - ! - DEALLOCATE ( jdos ) - -! -! collinear spin calculation -! -ELSEIF(nspin==2) THEN - ! - ! allocate main spectral and auxiliary quantities - ! - ALLOCATE( srjdos(0:1,nw), STAT=ierr ) - IF (ierr/=0) CALL errore('epsilon','allocating spin resolved jdos',abs(ierr)) - ! - ! initialize jdos - ! - srjdos(:,:)=0.0_DP - - ! Initialising a counter for the number of transition - srcount(:)=0.0_DP - - ! - ! main kpt loop - ! - - IF (smeartype=='lorentz') THEN - - DO is=0,1 - ! if nspin=2 the number of nks must be even (even if the calculation - ! is performed at gamma point only), so nks must be always a multiple of 2 - DO ik = 1 + is * int(nks/2), int(nks/2) + is * int(nks/2) - ! - ! Calculation of joint density of states - ! 'intersmear' is the brodening parameter - ! - DO iband2 = 1,nbnd - IF ( focc(iband2,ik) < 2.0d0) THEN - DO iband1 = 1,nbnd - ! - IF ( focc(iband1,ik) >= 1.0d-4 ) THEN - ! - ! transition energy - ! - etrans = ( et(iband2,ik) -et(iband1,ik) ) * RYTOEV + shift - ! - IF( etrans < 1.0d-10 ) CYCLE - - ! loop over frequencies - ! - srcount(is)=srcount(is)+ (focc(iband1,ik)-focc(iband2,ik)) - - DO iw = 1, nw - ! - w = wgrid(iw) - ! - srjdos(is,iw) = srjdos(is,iw) + intersmear * (focc(iband1,ik)-focc(iband2,ik)) & - / ( PI * ( (etrans -w )**2 + (intersmear)**2 ) ) - - ENDDO - - ENDIF - ENDDO - ENDIF - ENDDO - - ENDDO - ENDDO - - ELSEIF (smeartype=='gauss') THEN - - DO is=0,1 - ! if nspin=2 the number of nks must be even (even if the calculation - ! is performed at gamma point only), so nks must be always a multiple of 2 - DO ik = 1 + is * int(nks/2), int(nks/2) + is * int(nks/2) - ! - ! Calculation of joint density of states - ! 'intersmear' is the brodening parameter - ! - DO iband2 = 1,nbnd - DO iband1 = 1,nbnd - ! - IF ( focc(iband2,ik) < 2.0d0) THEN - IF ( focc(iband1,ik) >= 1.0d-4 ) THEN - ! - ! transition energy - ! - etrans = ( et(iband2,ik) -et(iband1,ik) ) * RYTOEV + shift - ! - IF( etrans < 1.0d-10 ) CYCLE - - ! loop over frequencies - ! - - srcount(is)=srcount(is)+ (focc(iband1,ik)-focc(iband2,ik)) - - DO iw = 1, nw - ! - w = wgrid(iw) - ! - srjdos(is,iw) = srjdos(is,iw) + (focc(iband1,ik)-focc(iband2,ik)) * & - exp(-(etrans-w)**2/intersmear**2) & - / (intersmear * sqrt(PI)) - - ENDDO - - ENDIF - ENDIF - ENDDO - ENDDO - - ENDDO - ENDDO - - ELSE - - CALL errore('epsilon', 'invalid SMEARTYPE = '//trim(smeartype), 1) - - ENDIF - - ! - ! jdos normalizzation - ! - DO is = 0,1 - srjdos(is,:)=srjdos(is,:)/srcount(is) - ENDDO - ! - renormzero = alpha * sum( srjdos(0,:) ) - renormuno = alpha * sum( srjdos(1,:) ) - - ! - ! write results on data files - ! - IF (ionode) THEN - ! - WRITE(stdout,"(/,5x, 'Integration over spin UP JDOS gives: ',f15.9,' instead of 1.0d0' )") renormzero - WRITE(stdout,"(/,5x, 'Integration over spin DOWN JDOS gives: ',f15.9,' instead of 1.0d0' )") renormuno - WRITE(stdout,"(/,5x, 'Writing output on file...' )") - ! - desc = "energy grid [eV] UJDOS [1/eV] DJDOS[1/eV]" - CALL eps_writetofile('jdos',desc,nw,wgrid,2,srjdos(0:1,:)) - ! - ENDIF - - DEALLOCATE ( srjdos ) -ENDIF - -END SUBROUTINE jdos_calc - -!----------------------------------------------------------------------------- -SUBROUTINE offdiag_calc ( intersmear, intrasmear, nbndmin, nbndmax, shift, metalcalc, nspin ) - !----------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE constants, ONLY : PI, RYTOEV - USE cell_base, ONLY : tpiba2, omega - USE wvfct, ONLY : nbnd, et - USE ener, ONLY : efermi => ef - USE klist, ONLY : nks, nkstot, degauss - USE grid_module, ONLY : focc, wgrid, grid_build, grid_destroy - USE io_global, ONLY : ionode, stdout - USE mp_pools, ONLY : inter_pool_comm - USE mp, ONLY : mp_sum - USE grid_module, ONLY : focc, nw, wgrid - - ! - IMPLICIT NONE - - ! - ! input variables - ! - INTEGER, INTENT(IN) :: nbndmin, nbndmax, nspin - REAL(DP), INTENT(IN) :: intersmear, intrasmear, shift - LOGICAL, INTENT(IN) :: metalcalc - ! - ! local variables - ! - INTEGER :: ik, iband1, iband2 - INTEGER :: iw, ierr, it1, it2 - REAL(DP) :: etrans, const, w - ! - COMPLEX(DP), ALLOCATABLE :: dipole_aux(:,:,:) - COMPLEX(DP), ALLOCATABLE :: epstot(:,:,:),dipoletot(:,:,:,:) - - ! - !-------------------------- - ! main routine body - !-------------------------- - ! - ! allocate main spectral and auxiliary quantities - ! - ALLOCATE( dipoletot(3,3, nbnd, nbnd), STAT=ierr ) - IF (ierr/=0) CALL errore('epsilon','allocating dipoletot', abs(ierr) ) - ! - ALLOCATE( dipole_aux(3, nbnd, nbnd), STAT=ierr ) - IF (ierr/=0) CALL errore('epsilon','allocating dipole_aux', abs(ierr) ) - ! - ALLOCATE(epstot( 3,3, nw),STAT=ierr ) - IF (ierr/=0) CALL errore('epsilon','allocating epstot', abs(ierr)) - - ! - ! initialize response functions - ! - epstot = (0.0_DP,0.0_DP) - ! - ! main kpt loop - ! - DO ik = 1, nks - ! - ! For every single k-point: order k+G for - ! read and distribute wavefunctions - ! compute dipole matrix 3 x nbnd x nbnd parallel over g - ! recover g parallelism getting the total dipole matrix - ! - CALL dipole_calc( ik, dipole_aux, metalcalc, nbndmin, nbndmax) - ! - DO it2 = 1, 3 - DO it1 = 1, 3 - dipoletot(it1,it2,:,:) = tpiba2 * dipole_aux(it1,:,:) * conjg( dipole_aux(it2,:,:) ) - ENDDO - ENDDO - ! - ! Calculation of real and immaginary parts - ! of the macroscopic dielettric function from dipole - ! approximation. - ! 'intersmear' is the brodening parameter - ! - DO iband2 = 1,nbnd - IF ( focc(iband2,ik) < 2.0d0) THEN - DO iband1 = 1,nbnd - ! - IF ( focc(iband1,ik) >= 1e-4 ) THEN - ! - ! transition energy - ! - etrans = ( et(iband2,ik) -et(iband1,ik) ) * RYTOEV + shift - ! - IF (abs(focc(iband2,ik)-focc(iband1,ik))< 1e-4) CYCLE - ! - ! loop over frequencies - ! - DO iw = 1, nw - ! - w = wgrid(iw) - ! - epstot(:,:,iw) = epstot(:,:,iw) + dipoletot(:,:,iband1,iband2)*RYTOEV**3/(etrans) *& - focc(iband1,ik)/(etrans**2 - w**2 - (0,1)*intersmear*w) - ENDDO - ! - ENDIF - ENDDO - ENDIF - ENDDO - ! - !Intraband (only if metalcalc is true) - ! - IF (metalcalc) THEN - DO iband1 = 1,nbnd - ! - IF ( focc(iband1,ik) < 2.0d0) THEN - IF ( focc(iband1,ik) >= 1e-4 ) THEN - ! - ! loop over frequencies - ! - DO iw = 1, nw - ! - w = wgrid(iw) - ! - epstot(:,:,iw) = epstot(:,:,iw) - dipoletot(:,:,iband1,iband1)* & - RYTOEV**2 * (exp((et(iband1,ik)-efermi)/degauss ))/ & - (( w**2 + (0,1)*intrasmear*w)*(1+exp((et(iband1,ik)-efermi)/ & - degauss))**2*degauss ) - ENDDO - - ENDIF - ENDIF - - ENDDO - ENDIF - ENDDO - - ! - ! recover over kpt parallelization (inter_pool) - ! - CALL mp_sum( epstot, inter_pool_comm ) - ! - ! impose the correct normalization - ! - const = 64.0d0 * PI / ( omega * REAL(nkstot, DP) ) - epstot(:,:,:) = epstot(:,:,:) * const - ! - ! add diagonal term - ! - epstot(1,1,:) = 1.0_DP + epstot(1,1,:) - epstot(2,2,:) = 1.0_DP + epstot(2,2,:) - epstot(3,3,:) = 1.0_DP + epstot(3,3,:) - ! - ! write results on data files - ! - IF (ionode) THEN - ! - WRITE(stdout,"(/,5x, 'Writing output on file...' )") - ! - OPEN (41, FILE='epsxx.dat', FORM='FORMATTED' ) - OPEN (42, FILE='epsxy.dat', FORM='FORMATTED' ) - OPEN (43, FILE='epsxz.dat', FORM='FORMATTED' ) - OPEN (44, FILE='epsyx.dat', FORM='FORMATTED' ) - OPEN (45, FILE='epsyy.dat', FORM='FORMATTED' ) - OPEN (46, FILE='epsyz.dat', FORM='FORMATTED' ) - OPEN (47, FILE='epszx.dat', FORM='FORMATTED' ) - OPEN (48, FILE='epszy.dat', FORM='FORMATTED' ) - OPEN (49, FILE='epszz.dat', FORM='FORMATTED' ) - ! - WRITE(41, "(2x,'# energy grid [eV] epsr epsi')" ) - WRITE(42, "(2x,'# energy grid [eV] epsr epsi')" ) - WRITE(43, "(2x,'# energy grid [eV] epsr epsi')" ) - WRITE(44, "(2x,'# energy grid [eV] epsr epsi')" ) - WRITE(45, "(2x,'# energy grid [eV] epsr epsi')" ) - WRITE(46, "(2x,'# energy grid [eV] epsr epsi')" ) - WRITE(47, "(2x,'# energy grid [eV] epsr epsi')" ) - WRITE(48, "(2x,'# energy grid [eV] epsr epsi')" ) - WRITE(49, "(2x,'# energy grid [eV] epsr epsi')" ) - ! - DO iw =1, nw - ! - WRITE(41,"(4f15.6)") wgrid(iw), REAL(epstot(1,1, iw)), aimag(epstot(1,1, iw)) - WRITE(42,"(4f15.6)") wgrid(iw), REAL(epstot(1,2, iw)), aimag(epstot(1,2, iw)) - WRITE(43,"(4f15.6)") wgrid(iw), REAL(epstot(1,3, iw)), aimag(epstot(1,3, iw)) - WRITE(44,"(4f15.6)") wgrid(iw), REAL(epstot(2,1, iw)), aimag(epstot(2,1, iw)) - WRITE(45,"(4f15.6)") wgrid(iw), REAL(epstot(2,2, iw)), aimag(epstot(2,2, iw)) - WRITE(46,"(4f15.6)") wgrid(iw), REAL(epstot(2,3, iw)), aimag(epstot(2,3, iw)) - WRITE(47,"(4f15.6)") wgrid(iw), REAL(epstot(3,1, iw)), aimag(epstot(3,1, iw)) - WRITE(48,"(4f15.6)") wgrid(iw), REAL(epstot(3,2, iw)), aimag(epstot(3,2, iw)) - WRITE(49,"(4f15.6)") wgrid(iw), REAL(epstot(3,3, iw)), aimag(epstot(3,3, iw)) - ! - ENDDO - ! - CLOSE(30) - CLOSE(40) - CLOSE(41) - CLOSE(42) - ! - ENDIF - - ! - ! local cleaning - ! - DEALLOCATE ( dipoletot, dipole_aux, epstot ) - -END SUBROUTINE offdiag_calc - - -!-------------------------------------------------------------------- -SUBROUTINE dipole_calc( ik, dipole_aux, metalcalc, nbndmin, nbndmax ) - !------------------------------------------------------------------ - ! - USE kinds, ONLY : DP - USE wvfct, ONLY : nbnd, npwx - USE wavefunctions, ONLY : evc - USE klist, ONLY : xk, ngk, igk_k - USE gvect, ONLY : ngm, g - USE io_files, ONLY : restart_dir - USE pw_restart_new, ONLY : read_collected_wfc - USE grid_module, ONLY : focc, full_occ - USE mp_bands, ONLY : intra_bgrp_comm - USE mp, ONLY : mp_sum - USE lsda_mod, ONLY : nspin - ! - IMPLICIT NONE - ! - ! global variables - INTEGER, INTENT(IN) :: ik,nbndmin,nbndmax - COMPLEX(DP), INTENT(INOUT) :: dipole_aux(3,nbnd,nbnd) - LOGICAL, INTENT(IN) :: metalcalc - ! - ! local variables - INTEGER :: iband1,iband2,ig,npw - COMPLEX(DP) :: caux - - ! - ! Routine Body - ! - CALL start_clock( 'dipole_calc' ) - ! - ! read wfc for the given kpt - ! - CALL read_collected_wfc ( restart_dir(), ik, evc ) - ! - ! compute matrix elements - ! - dipole_aux(:,:,:) = (0.0_DP,0.0_DP) - ! - npw = ngk(ik) - ! - DO iband2 = nbndmin,nbndmax - IF ( focc(iband2,ik) < full_occ) THEN - DO iband1 = nbndmin,nbndmax - ! - IF ( iband1==iband2 ) CYCLE - IF ( focc(iband1,ik) >= 0.5e-4*full_occ ) THEN - ! - DO ig=1,npw - ! - caux= conjg(evc(ig,iband1))*evc(ig,iband2) - ! - ! Non collinear case - IF ( nspin == 4 ) THEN - caux = caux + conjg(evc(ig+npwx,iband1))*evc(ig+npwx,iband2) - ENDIF - ! - dipole_aux(:,iband1,iband2) = dipole_aux(:,iband1,iband2) + & - ( g(:,igk_k(ig,ik)) ) * caux - ! - ENDDO - ENDIF - ! - ENDDO - ENDIF - ENDDO - ! - ! The diagonal terms are taken into account only if the system is treated like a metal, not - ! in the intraband therm. Because of this we can recalculate the diagonal component of the dipole - ! tensor directly as we need it for the intraband term, without interference with interband one. - ! - IF (metalcalc) THEN - ! - DO iband1 = nbndmin,nbndmax - DO ig=1,npw - ! - caux= conjg(evc(ig,iband1))*evc(ig,iband1) - ! - ! Non collinear case - IF ( nspin == 4 ) THEN - caux = caux + conjg(evc(ig+npwx,iband1))*evc(ig+npwx,iband1) - ENDIF - ! - dipole_aux(:,iband1,iband1) = dipole_aux(:,iband1,iband1) + & - ( g(:,igk_k(ig,ik))+ xk(:,ik) ) * caux - ! - ENDDO - ENDDO - ! - ENDIF - ! - ! recover over G parallelization (intra_bgrp) - ! - CALL mp_sum( dipole_aux, intra_bgrp_comm ) - ! - CALL stop_clock( 'dipole_calc' ) - ! -END SUBROUTINE dipole_calc - -!---------------------------------------------------------------------------------------- -SUBROUTINE photoemission_spectr_pw ( intersmear,intrasmear,nbndmin,nbndmax, & - shift,nspin,metalcalc,polar_angle, azimuthal_angle,& - photon_angle,photon_ener,homo_gas,wfc_real,e_fermi,& - modified_pw,othor_pw) - !-------------------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE constants, ONLY : PI, RYTOEV - USE wvfct, ONLY : npwx - USE cell_base, ONLY : tpiba2 - USE wvfct, ONLY : et - USE gvect, ONLY : g - USE klist, ONLY : nks, xk, igk_k, ngk - USE io_global, ONLY : ionode, stdout - USE grid_module, ONLY : nw, wgrid, grid_build, grid_destroy - USE mp_global, ONLY : intra_pool_comm - USE mp, ONLY : mp_sum - ! - USE lsda_mod, ONLY : lsda, current_spin, isk - ! - IMPLICIT NONE - - ! - ! input variables - ! - INTEGER, INTENT(IN) :: nbndmin,nbndmax,nspin - REAL(DP), INTENT(IN) :: intersmear, shift, photon_ener, & - polar_angle, azimuthal_angle, photon_angle, & - e_fermi, intrasmear - LOGICAL, INTENT(IN) :: metalcalc, homo_gas, wfc_real, modified_pw, & - othor_pw - ! - ! local variables - ! - INTEGER :: ik, iband1, ipol, ig - INTEGER :: iw, ierr - INTEGER :: npw - REAL(DP) :: etrans, w - REAL(DP) :: polar_angle_radial, azimuthal_angle_radial, photon_angle_radial - REAL(DP) :: ekin_eout - REAL(DP) :: module_k, kx, ky, kz, delta_ecut_G, & - delta_kx_Gx, delta_ky_Gy, delta_kz_Gz, constant, & - max_sigma_tot - - REAL(DP) :: ssigma_tot (2, nbndmax) - REAL(DP) :: ssigma_2 (2,nbndmax) - REAL(DP) :: sbeta (2,nbndmax) - REAL(DP) :: seigen_mol (2,nbndmax) - ! - REAL(DP), ALLOCATABLE :: srphotospec(:,:) - REAL(DP), ALLOCATABLE :: g2kin (:) - REAL(DP), ALLOCATABLE :: dipole_2(:,:) - REAL(DP), ALLOCATABLE :: gamma_2_opw(:,:) - REAL(DP), ALLOCATABLE :: lambda_2_opw(:,:) - COMPLEX(DP),ALLOCATABLE :: dipole_aux(:,:,:) - COMPLEX(DP),ALLOCATABLE :: dipole_opw_gamma(:,:,:) - COMPLEX(DP),ALLOCATABLE :: scala_opw_lambda(:,:) - ! - INTEGER :: iss - ! - !-------------------------- - ! main routine body - !-------------------------- - ! - ! change angles from degree to radial unit - ! - polar_angle_radial = (polar_angle/180.0)*PI - azimuthal_angle_radial = (azimuthal_angle/180.0)*PI - photon_angle_radial = (photon_angle/180.0)*PI - ! - ! allocate main spectral and auxiliary quantities - ! - ALLOCATE( g2kin(npwx), STAT=ierr ) - IF (ierr/=0) CALL errore('epsilon','allocating photoemission_spectr',ABS(ierr)) - ! - ALLOCATE( dipole_2(nbndmax, npwx), STAT=ierr ) - IF (ierr/=0) CALL errore('epsilon','allocating dipole', ABS(ierr) ) - ! - ALLOCATE( dipole_aux(3, nbndmax, npwx), STAT=ierr ) - IF (ierr/=0) CALL errore('epsilon','allocating dipole_aux', ABS(ierr) ) - ! - IF (othor_pw) THEN - ALLOCATE( dipole_opw_gamma(3, nbndmax, npwx) ) - ALLOCATE( scala_opw_lambda(nbndmax, npwx) ) - ALLOCATE( gamma_2_opw(nbndmax, npwx) ) - ALLOCATE( lambda_2_opw(nbndmax, npwx) ) - ENDIF - ! - ! allocate main spectral and auxiliary quantities - ! - ALLOCATE( srphotospec(nspin,nw), STAT=ierr ) - IF (ierr/=0) CALL errore('epsilon','allocating photospectra',ABS(ierr)) - ! - ! initialize - ! - srphotospec(:,:)=0.0_DP - ! - constant = 1.0_DP - ! - IF (homo_gas) THEN - ssigma_tot(:, :) = 0.0_DP - ssigma_2(:, :) = 0.0_DP - ENDIF - ! - ! main kpt loop - ! - ! - DO ik = 1, nks - ! - current_spin = 1 - IF (lsda) current_spin = isk(ik) - ! - ! For every single k-point: order k+G for - ! read and distribute wavefunctions - ! compute dipole matrix 3 x nbnd x nbnd - ! parallel over g - ! recover g parallelism getting the total - ! dipole matrix - ! - npw = ngk(ik) - ! - CALL dipole_calc_pw( ik, dipole_aux, dipole_opw_gamma, scala_opw_lambda, metalcalc, nbndmin, nbndmax, & - photon_angle_radial, azimuthal_angle_radial, & - homo_gas, othor_pw) - ! - dipole_2(:,:) = 0.0_DP - DO ipol = 1, 3 - dipole_2(:,:) = dipole_2(:,:) + tpiba2 * ( (REAL(dipole_aux(ipol,:,:)))**2 + (AIMAG(dipole_aux(ipol,:,:)))**2 ) - ENDDO - ! - IF (othor_pw) THEN - ! - gamma_2_opw(:,:) = 0.0_DP - lambda_2_opw(:,:) = 0.0_DP - DO ipol = 1, 3 - gamma_2_opw(:,:) = gamma_2_opw(:,:) + tpiba2 * & - ( (REAL(dipole_opw_gamma(ipol,:,:)))**2 + (AIMAG(dipole_opw_gamma(ipol,:,:)))**2 ) - ENDDO - ! - lambda_2_opw(:,:) = lambda_2_opw(:,:) + tpiba2 * & - scala_opw_lambda(:,:) * conjg(scala_opw_lambda(:,:)) - ! - ENDIF - ! - ! Calculation of photoemission spectra - ! 'intersmear' is the brodening parameter - ! - DO iband1 = nbndmin, nbndmax - ! - IF (homo_gas) THEN - ! - seigen_mol(current_spin, iband1) = (0.0_DP - et(iband1, ik) )*RYTOEV - ! - IF (modified_pw ) THEN - ekin_eout = photon_ener - ELSE - ekin_eout = photon_ener - (0.0_DP - et(iband1, ik) )*RYTOEV - ENDIF - ! - ELSE - ! - ekin_eout = photon_ener -((0.0_DP - et(iband1, ik) )*RYTOEV + e_fermi) - ! - ENDIF - ! - IF (ekin_eout > photon_ener .or. ekin_eout <=0.0_DP ) CYCLE - ! - module_k = sqrt ((ekin_eout/13.6056923)/tpiba2) - ! - kx = module_k * cos(azimuthal_angle_radial) * sin(polar_angle_radial) - ky = module_k * sin(azimuthal_angle_radial) * sin(polar_angle_radial) - kz = module_k * cos(polar_angle_radial) - ! - ! compute the total cross-section - ! and ansymmetry parameter - ! - IF (homo_gas) THEN - ! - DO ig = 1, npw - ! - g2kin(ig) = tpiba2*((xk(1,ik)+g(1,igk_k(ig,ik)))**2 + (xk(2,ik)+g(2,igk_k(ig,ik))) **2 + (xk(3,ik)+g(3,igk_k(ig,ik)))**2) - delta_ecut_G = intrasmear/( PI * (( g2kin(ig)*13.6056923 - ekin_eout )**2 + (intrasmear)**2 )) - ! - ssigma_tot(current_spin, iband1) = ssigma_tot(current_spin, iband1) + constant*module_k*dipole_2(iband1, ig)*delta_ecut_G - ! - IF (othor_pw ) THEN - ssigma_2(current_spin, iband1) = ssigma_2(current_spin, iband1) + 1.5*constant*module_k & - * (gamma_2_opw(iband1,ig) - lambda_2_opw(iband1,ig))*delta_ecut_G - ENDIF - ! - ENDDO - ! - ENDIF - ! - DO ig = 1, npw - g2kin(ig) = tpiba2*((xk(1,ik)+g(1,igk_k(ig,ik)))**2 + (xk(2,ik)+g(2,igk_k(ig,ik))) **2 + (xk(3,ik)+g(3,igk_k(ig,ik)))**2) - delta_ecut_G = intrasmear/( PI * (( g2kin(ig)*13.6056923 - ekin_eout )**2 + (intrasmear)**2 )) - ! - delta_kx_Gx = intrasmear/( PI * (( ( kx - ( xk(1,ik) + g(1,igk_k(ig,ik)))) *sqrt(tpiba2))**2 + (intrasmear)**2 ) ) - delta_ky_Gy = intrasmear/( PI * (( ( ky - ( xk(2,ik) + g(2,igk_k(ig,ik)))) *sqrt(tpiba2))**2 + (intrasmear)**2 ) ) - delta_kz_Gz = intrasmear/( PI * (( ( kz - ( xk(3,ik) + g(3,igk_k(ig,ik)))) *sqrt(tpiba2))**2 + (intrasmear)**2 ) ) - ! - ! transition energy - ! - etrans = (0.0d0 - et(iband1, ik) ) * RYTOEV + shift ! g2kin were called in the dipole_pw routine - ! - IF( etrans < 1.0d-10 ) CYCLE - ! - ! loop over frequencies - ! - DO iw = 1, nw - ! - w = wgrid(iw) - ! - IF (homo_gas) THEN - ! - IF (wfc_real) THEN - ! - srphotospec(current_spin, iw) = srphotospec(current_spin, iw) + 2.0D0 * module_k* intersmear & - * dipole_2(iband1, ig) * delta_ecut_G & - / ( PI * ( (etrans - w )**2 + (intersmear)**2 ) ) - ! - ELSE - ! - srphotospec(current_spin, iw) = srphotospec(current_spin, iw) + module_k * intersmear & - * dipole_2(iband1, ig) * delta_ecut_G & - / ( PI * ( (etrans - w )**2 + (intersmear)**2 ) ) - ! - ENDIF - ! - ELSE - ! - srphotospec(current_spin, iw) = srphotospec(current_spin, iw) + dipole_2(iband1, ig) * delta_ecut_G & - * delta_kx_Gx * delta_ky_Gy * delta_kz_Gz * intersmear & - / ( PI * ( (etrans - w )**2 + (intersmear)**2 ) ) - ! - ENDIF - ! - ENDDO - ! - ENDDO - ! - ENDDO - ! - ENDDO ! kpt_loop - ! - ! recover over G parallelization (intra_pool) - ! - DO iss = 1, nspin - ! - CALL mp_sum( srphotospec(iss,:), intra_pool_comm ) - ! - IF(homo_gas) THEN - ! - CALL mp_sum( ssigma_tot(iss,:), intra_pool_comm ) - CALL mp_sum( ssigma_2(iss,:), intra_pool_comm ) - ! - max_sigma_tot = maxval(ssigma_tot(iss, :)) - ! - IF (othor_pw) THEN - ! - DO iband1 = nbndmin, nbndmax - sbeta(iss, iband1)= 2.0_DP*(1.0_DP-ssigma_2(iss, iband1)/ssigma_tot(iss, iband1) ) - ENDDO - ! - ELSE - ! - sbeta(iss,:) = 2.0_DP - ! - ENDIF - ! - IF (ionode) THEN - IF (nspin == 1) THEN - WRITE(stdout,"(/,5x, 'Writing the molecule gas properties' )") - ELSE - IF (iss == 0) WRITE(stdout,"(/,5x, 'Writing the molecule gas properties with spin up' )") - IF (iss == 1) WRITE(stdout,"(/,5x, 'Writing the molecule gas properties with spin down' )") - ENDIF - DO iband1 = nbndmin, nbndmax - WRITE(stdout,"(4f15.6)") seigen_mol(iss, iband1), ssigma_tot(iss, iband1)/max_sigma_tot, sbeta(iss, iband1) - ENDDO - ENDIF - ! - ENDIF - ! - ENDDO - ! - ! write results on data files - ! - IF (ionode) THEN - WRITE(stdout,"(/,5x, 'Writing output on file...' )") - - OPEN (30, FILE='photospectra.dat', FORM='FORMATTED' ) - ! - IF( nspin == 1) WRITE(30, "(2x,'# energy grid [eV] photospectra ')" ) - IF( nspin == 2) WRITE(30, "(2x,'# energy grid [eV] photospectra spin_up [ab.] photospectra spin_dw [ab.] ')" ) - ! - DO iw =1, nw - ! - IF (nspin == 1 ) WRITE(30,"(4f15.10)") wgrid(iw), srphotospec(1, iw) - IF (nspin == 2 ) WRITE(30,"(4f15.10)") wgrid(iw), srphotospec(1, iw), srphotospec(2,iw) - ! - ENDDO - ! - CLOSE(30) - ! - ENDIF - ! - ! local cleaning - ! - DEALLOCATE (g2kin,STAT=ierr) - DEALLOCATE (srphotospec,STAT=ierr) - DEALLOCATE (dipole_2, STAT=ierr) - DEALLOCATE (dipole_aux, STAT=ierr) - ! - IF (othor_pw) THEN - DEALLOCATE( dipole_opw_gamma ) - DEALLOCATE( scala_opw_lambda ) - DEALLOCATE( gamma_2_opw ) - DEALLOCATE( lambda_2_opw ) - ENDIF - ! - CALL grid_destroy() - ! - return -END SUBROUTINE photoemission_spectr_pw - -!-------------------------------------------------------------------- -SUBROUTINE dipole_calc_pw ( ik, dipole_aux, dipole_opw_gamma, scala_opw_lambda, metalcalc, & - nbndmin, nbndmax, photon_angle, azimuthal_angle, homo_gas, othor_pw) - !------------------------------------------------------------------ - USE kinds, ONLY : DP - USE wvfct, ONLY : npwx - USE wavefunctions, ONLY : evc - USE klist, ONLY : xk, igk_k, ngk - USE gvect, ONLY : g - USE io_files, ONLY : restart_dir - USE mp_global, ONLY : intra_pool_comm - USE mp, ONLY : mp_sum - USE pw_restart_new, ONLY : read_collected_wfc - -IMPLICIT NONE - ! - ! global variables - INTEGER, INTENT(IN) :: ik,nbndmin, nbndmax - REAL(DP),INTENT(IN) :: photon_angle, azimuthal_angle - COMPLEX(DP), INTENT(INOUT) :: dipole_aux(3, nbndmax, npwx) - COMPLEX(DP), INTENT(INOUT) :: dipole_opw_gamma(3, nbndmax, npwx) - COMPLEX(DP), INTENT(INOUT) :: scala_opw_lambda(nbndmax, npwx) - LOGICAL, INTENT(IN) :: metalcalc, homo_gas, othor_pw - ! - ! local variables - INTEGER :: npw - INTEGER :: iband1, iband2, ig - REAL(DP):: sqrtk2 - COMPLEX(DP) :: caux1, caux2 - COMPLEX(DP) :: sumx, sumy, sumz - COMPLEX(DP) :: ax(npwx), ay(npwx), az(npwx) - COMPLEX(DP) :: ax_add(npwx), ay_add(npwx), az_add(npwx) - ! - ! Routine Body - ! - CALL start_clock( 'dipole_calc' ) - ! - ! setup k+G grids for each kpt - ! - !CALL gk_sort (xk (1, ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin) - ! - ! read wfc for the given kpt - ! - !CALL davcio (evc, nwordwfc, iunwfc, ik, - 1) - CALL read_collected_wfc ( restart_dir(), ik, evc ) - ! - ! compute matrix elements - ! - dipole_aux(:,:,:) = (0.0_DP,0.0_DP) - npw = ngk(ik) - ! - IF (othor_pw) THEN - dipole_opw_gamma(:,:,:) = (0.0_DP,0.0_DP) - scala_opw_lambda(:,:) = (0.0_DP,0.0_DP) - ENDIF - ! - DO iband1 = nbndmin, nbndmax - ! - DO ig = 1, npw - ! - caux1 = evc(ig,iband1) - ! - IF (homo_gas) then - dipole_aux(1,iband1,ig) = dipole_aux(1,iband1,ig) + & - ( g(1,igk_k(ig,ik)) ) * caux1 - dipole_aux(2,iband1,ig) = dipole_aux(2,iband1,ig) + & - ( g(2,igk_k(ig,ik)) ) * caux1 - dipole_aux(3,iband1,ig) = dipole_aux(3,iband1,ig) + & - ( g(3,igk_k(ig,ik)) ) * caux1 - ELSE - dipole_aux(1,iband1,ig) = dipole_aux(1,iband1,ig) + & - ( g(1,igk_k(ig, ik)) )* cos(photon_angle) & - * cos(azimuthal_angle) * caux1 - dipole_aux(2,iband1,ig) = dipole_aux(2,iband1,ig) + & - ( g(2,igk_k(ig,ik)) )* cos(photon_angle) & - * sin(azimuthal_angle) * caux1 - dipole_aux(3,iband1,ig) = dipole_aux(3,iband1,ig) + & - ( g(3,igk_k(ig, ik)) )* sin(photon_angle) * caux1 - ENDIF - ! - ENDDO - ! - IF (othor_pw) THEN - ! - ax(:) = (0.0_DP,0.0_DP) - ay(:) = (0.0_DP,0.0_DP) - az(:) = (0.0_DP,0.0_DP) - ax_add(:) = (0.0_DP,0.0_DP) - ay_add(:) = (0.0_DP,0.0_DP) - az_add(:) = (0.0_DP,0.0_DP) - ! - DO iband2 = nbndmin, nbndmax - ! - sumx = (0.0_DP,0.0_DP) - sumy = (0.0_DP,0.0_DP) - sumz = (0.0_DP,0.0_DP) - ! - DO ig = 1, npw - caux1 = evc(ig,iband1) - caux2 = evc(ig,iband2) - if (homo_gas) then - sumx = sumx + g(1,igk_k(ig,ik)) * conjg(caux1)*caux2 - sumy = sumy + g(2,igk_k(ig,ik)) * conjg(caux1)*caux2 - sumz = sumz + g(3,igk_k(ig,ik)) * conjg(caux1)*caux2 - else - sumx = sumx + g(1,igk_k(ig,ik)) * conjg(caux1)*caux2 * & - cos(photon_angle) * cos(azimuthal_angle) - sumy = sumy + g(2,igk_k(ig,ik)) * conjg(caux1)*caux2 * & - cos(photon_angle) * sin(azimuthal_angle) - sumz = sumz + g(3,igk_k(ig,ik)) * conjg(caux1)*caux2 * & - sin(photon_angle) - endif - ENDDO - ! - CALL mp_sum( sumx, intra_pool_comm ) - CALL mp_sum( sumy, intra_pool_comm ) - CALL mp_sum( sumz, intra_pool_comm ) - ! - DO ig = 1, npw - caux2 = evc(ig,iband2) - ax(ig) = ax(ig) + conjg(caux2)*sumx - ay(ig) = ay(ig) + conjg(caux2)*sumy - az(ig) = az(ig) + conjg(caux2)*sumz - ENDDO - ! - DO ig = 1, npw - caux2 = evc(ig,iband2) - ax_add(ig) = ax_add(ig) + conjg(caux2)*sumx*g(1,igk_k(ig,ik)) - ay_add(ig) = ay_add(ig) + conjg(caux2)*sumy*g(2,igk_k(ig,ik)) - az_add(ig) = az_add(ig) + conjg(caux2)*sumz*g(3,igk_k(ig,ik)) - ENDDO - ! - ENDDO - ! - DO ig = 1, npw - ! - ! gradient component of total sigma - ! - dipole_aux(1,iband1,ig) = dipole_aux(1,iband1,ig) - ax(ig) - dipole_aux(2,iband1,ig) = dipole_aux(2,iband1,ig) - ay(ig) - dipole_aux(3,iband1,ig) = dipole_aux(3,iband1,ig) - az(ig) - ! - ! gradient component of Gamma - ! - dipole_opw_gamma(1,iband1,ig) = dipole_opw_gamma(1,iband1,ig) + (ax(ig)) - dipole_opw_gamma(2,iband1,ig) = dipole_opw_gamma(2,iband1,ig) + (ay(ig)) - dipole_opw_gamma(3,iband1,ig) = dipole_opw_gamma(3,iband1,ig) + (az(ig)) - ! - sqrtk2 = sqrt((xk(1,ik)+g(1,igk_k(ig,ik)))**2 + (xk(2,ik)+g(2,igk_k(ig,ik))) **2 + (xk(3,ik)+g(3,igk_k(ig,ik)))**2) - ! - IF (sqrtk2 > 1.0E-05) THEN - ! - ! scala component of Lambda - ! - scala_opw_lambda(iband1,ig) = scala_opw_lambda(iband1,ig) + & - (ax_add(ig) + ay_add(ig) + az_add(ig))/sqrtk2 - ! - ENDIF - ! - ENDDO - ! - ENDIF - ! - ENDDO - ! - CALL stop_clock( 'dipole_calc' ) - ! - return - ! -END SUBROUTINE dipole_calc_pw - - - - - - - -!-------------------------------------------------------------------- -SUBROUTINE eps_writetofile(namein,desc,nw,wgrid,ncol,var) - !------------------------------------------------------------------ - ! - USE kinds, ONLY : DP - USE io_files, ONLY : prefix, tmp_dir - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(IN) :: namein - CHARACTER(LEN=*), INTENT(IN) :: desc - INTEGER, INTENT(IN) :: nw, ncol - REAL(DP), INTENT(IN) :: wgrid(nw) - REAL(DP), INTENT(IN) :: var(ncol,nw) - ! - CHARACTER(256) :: str - INTEGER :: iw - - str = TRIM(namein) // "_" // TRIM(prefix) // ".dat" - OPEN(40,FILE=TRIM(str)) - ! - WRITE(40,"(a)") "# "// TRIM(desc) - WRITE(40,"(a)") "#" - ! - DO iw = 1, nw - ! - WRITE(40,"(10f15.9)") wgrid(iw), var(1:ncol,iw) - ! - ENDDO - ! - CLOSE(40) - ! -END SUBROUTINE eps_writetofile diff --git a/quantum_espresso/utils/src/fft_supercell.f90 b/quantum_espresso/utils/src/fft_supercell.f90 deleted file mode 100644 index cccd67074..000000000 --- a/quantum_espresso/utils/src/fft_supercell.f90 +++ /dev/null @@ -1,718 +0,0 @@ -! -! Copyright (C) 2003-2013 Quantum ESPRESSO and Wannier90 groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -! Written by Riccardo De Gennaro, EPFL (Sept 2020). -! -! -!----------------------------------------------------------------------- -MODULE fft_supercell - !--------------------------------------------------------------------- - ! - ! ... This module contains all the quantities and routines - ! ... related to the supercell FFT. - ! - USE kinds, ONLY : DP - USE fft_types, ONLY : fft_type_descriptor - USE stick_base, ONLY : sticks_map, sticks_map_deallocate - ! - ! - IMPLICIT NONE - ! - SAVE - ! - PUBLIC - ! - PRIVATE :: fftcp_base_info, gveccp_init, gshells_cp, compare_dfft - ! - TYPE( fft_type_descriptor ) :: dfftcp - TYPE( sticks_map ) :: smap_cp - ! - REAL(DP) :: at_cp(3,3) - REAL(DP) :: bg_cp(3,3) - REAL(DP) :: omega_cp - LOGICAL :: gamma_only_x ! CHECK ALSO npwxcp WHEN USING GAMMA TRICK - ! - INTEGER :: nat_cp - INTEGER, ALLOCATABLE :: ityp_cp(:) - REAL(DP), ALLOCATABLE :: tau_cp(:,:) - ! - ! in the following all the G-vectors related quantities - ! connected to the dfftcp are defined - ! - INTEGER :: npwxcp = 0 ! eq to npwx (in wvfct) - INTEGER :: ngmcp = 0 ! eq to ngm (in gvect) - INTEGER :: ngmcpx = 0 ! eq to ngmx (in gvect) - INTEGER :: ngmcp_g = 0 ! eq to ngm_g (in gvect) - INTEGER :: nglcp = 0 ! eq to ngl (in gvect) - INTEGER :: gstart_cp = 2 ! eq to gstart (in gvect) - REAL(DP), ALLOCATABLE, TARGET :: gg_cp(:) ! eq to gg (in gvect) - REAL(DP), ALLOCATABLE, TARGET :: g_cp(:,:) ! eq to g (in gvect) - REAL(DP), POINTER, PROTECTED :: gl_cp(:) ! eq to gl (in gvect) - INTEGER, ALLOCATABLE, TARGET :: mill_cp(:,:) ! eq to mill (in gvect) - INTEGER, ALLOCATABLE, TARGET :: ig_l2g_cp(:) ! eq to ig_l2g (in gvect) - INTEGER, ALLOCATABLE, TARGET, PROTECTED :: igtongl_cp(:) ! eq to igtongl (in gvect) - ! - INTEGER :: iunwann=224 ! unit for supercell Wannier functions - INTEGER :: nwordwann ! record length for Wannier functions - ! - LOGICAL :: check_fft=.false. ! if .true. dfftcp is built with the same inputs - ! of dffts. Useful for comparison and to check errors - ! - ! ... end of module-scope declarations - ! -CONTAINS - ! - !--------------------------------------------------------------------- - SUBROUTINE setup_scell_fft - !------------------------------------------------------------------- - ! - ! ... Here we set up the fft descriptor (dfftcp) for the supercell - ! ... commensurate to the Brillouin zone sampling. - ! - USE io_global, ONLY : stdout, ionode - USE fft_base, ONLY : dffts - USE fft_types, ONLY : fft_type_init - USE mp_bands, ONLY : nproc_bgrp, intra_bgrp_comm, nyfft, & - ntask_groups - USE mp_pools, ONLY : inter_pool_comm - USE mp, ONLY : mp_max - USE gvect, ONLY : gcutm - USE gvecs, ONLY : gcutms - USE gvecw, ONLY : gcutw, gkcut - USE ions_base, ONLY : nat, tau, ityp - USE parameters, ONLY : ntypx - USE recvec_subs, ONLY : ggen, ggens - USE klist, ONLY : nks, xk - USE control_flags, ONLY : gamma_only - USE cell_base, ONLY : at, bg, omega - USE cellmd, ONLY : lmovecell - USE realus, ONLY : real_space - USE symm_base, ONLY : fft_fact - USE read_wannier, ONLY : num_kpts, kgrid - USE command_line_options, ONLY : nmany_ - ! - ! - IMPLICIT NONE - ! - INTEGER, EXTERNAL :: n_plane_waves - INTEGER :: i, j, k, ir, ik, iat - INTEGER :: ngmcp_ - INTEGER :: nkscp - REAL(DP) :: rvec(3) - REAL(DP), ALLOCATABLE :: xkcp(:,:) - LOGICAL :: lpara - ! - ! - CALL dealloc_sc_fft - ! - ! ... we find the supercell lattice vectors and volume - ! - DO i = 1, 3 - at_cp(:,i) = at(:,i) * kgrid(i) - bg_cp(:,i) = bg(:,i) / kgrid(i) - ENDDO - omega_cp = omega * num_kpts - ! - lpara = ( nproc_bgrp > 1 ) - gkcut = gcutw - ! - ! ... determine atomic positions and types in the supercell - ! - nat_cp = nat * num_kpts - IF ( .not. ALLOCATED(tau_cp) ) ALLOCATE( tau_cp(3,nat_cp) ) - IF ( .not. ALLOCATED(ityp_cp) ) ALLOCATE( ityp_cp(nat_cp) ) - ! - ir = 0 - ! - DO i = 1, kgrid(1) - DO j = 1, kgrid(2) - DO k = 1, kgrid(3) - ! - rvec(:) = (/ i-1, j-1, k-1 /) - CALL cryst_to_cart( 1, rvec, at, 1 ) - ! - DO iat = 1, nat - ! - ityp_cp( ir*nat + iat ) = ityp( iat ) - ! - tau_cp(:, ir*nat + iat ) = tau(:,iat) + rvec(:) - ! - ENDDO - ! - ir = ir + 1 - ! - ENDDO - ENDDO - ENDDO - ! - ! - ! ... uncomment the following line in order to realize dfftcp in the - ! ... same way of dffts and check possible errors or incosistencies - !check_fft = .true. - ! - IF ( check_fft ) THEN - ! - gamma_only_x = gamma_only - at_cp(:,:) = at(:,:) - bg_cp(:,:) = bg(:,:) - omega_cp = omega - ! - nkscp = nks - IF ( .not. ALLOCATED(xkcp) ) ALLOCATE( xkcp(3,nkscp) ) - xkcp(:,:) = xk(:,:) - ! - nat_cp = nat - DEALLOCATE( tau_cp, ityp_cp ) - ALLOCATE( tau_cp(3,nat_cp) ) - ALLOCATE( ityp_cp(nat_cp) ) - ityp_cp(:) = ityp(:) - tau_cp(:,:) = tau(:,:) - ! - ! ... calculate gkcut = max |k+G|^2, in (2pi/a)^2 units - ! - IF (nks == 0) THEN - ! - ! k-point list not available: - ! use max(bg)/2 as an estimate of the largest k-point - ! - gkcut = 0.5d0 * max ( & - sqrt (sum(bg_cp (1:3, 1)**2) ), & - sqrt (sum(bg_cp (1:3, 2)**2) ), & - sqrt (sum(bg_cp (1:3, 3)**2) ) ) - ELSE - gkcut = 0.0d0 - DO ik = 1, nks - gkcut = max (gkcut, sqrt ( sum(xk (1:3, ik)**2) ) ) - ENDDO - ENDIF - gkcut = (sqrt (gcutw) + gkcut)**2 - ! - ! ... find maximum value among all the processors - ! - CALL mp_max (gkcut, inter_pool_comm ) - ! - ELSE - ! - nkscp = 1 - IF ( .not. ALLOCATED(xkcp) ) ALLOCATE( xkcp(3,nkscp) ) - xkcp(:,1) = (/ 0.D0, 0.D0, 0.D0 /) - ! - ! force the supercell FFT grid to be a multiple of the - ! primitive cell FFT grid - ! - dfftcp%nr1 = dffts%nr1 * kgrid(1) - dfftcp%nr2 = dffts%nr2 * kgrid(2) - dfftcp%nr3 = dffts%nr3 * kgrid(3) - ! - ENDIF - ! - ! ... set up the supercell fft descriptor, including parallel - ! ... stuff: sticks, planes, etc. - ! - ! task group are disabled if real_space calculation of calbec is used - dfftcp%has_task_groups = (ntask_groups >1) .and. .not. real_space - CALL fft_type_init( dfftcp, smap_cp, "wave", gamma_only_x, lpara, intra_bgrp_comm,& - at_cp, bg_cp, gkcut, gcutms/gkcut, fft_fact=fft_fact, nyfft=nyfft, nmany=nmany_ ) - dfftcp%rho_clock_label='ffts' ; dfftcp%wave_clock_label='fftw' - ! - ngmcp_ = dfftcp%ngl( dfftcp%mype + 1 ) - IF ( gamma_only_x ) ngmcp_ = ( ngmcp_ + 1 ) / 2 - CALL gveccp_init( ngmcp_, intra_bgrp_comm ) - ! - ! - ! Some checks (done normally in allocate_fft) - ! - IF (dfftcp%nnr < ngmcp) THEN - WRITE( stdout, '(/,4x," nr1cp=",i4," nr2cp= ", i4, " nr3cp=",i4, & - &" nnrcp= ",i8," ngmcp=",i8)') dfftcp%nr1, dfftcp%nr2, dfftcp%nr3, dfftcp%nnr, ngmcp - CALL errore( 'setup_scell_fft', 'the nrs"s are too small!', 1 ) - ENDIF - ! - IF (ngmcp <= 0) CALL errore( 'setup_scell_fft', 'wrong ngmcp' , 1 ) - IF (dfftcp%nnr <= 0) CALL errore( 'setup_scell_fft', 'wrong nnr', 1 ) - ! - ! NB: ggen normally would have dfftp and ggens dffts... here I put dfftcp in both !!! - CALL ggen ( dfftcp, gamma_only_x, at_cp, bg_cp, gcutm, ngmcp_g, ngmcp, & - g_cp, gg_cp, mill_cp, ig_l2g_cp, gstart_cp ) - CALL ggens( dfftcp, gamma_only_x, at_cp, g_cp, gg_cp, mill_cp, gcutms, ngmcp ) - CALL gshells_cp( lmovecell ) - CALL fftcp_base_info( ionode, stdout ) - ! - ! - ! find the number of PWs for the supercell wfc - npwxcp = n_plane_waves( gcutw, nkscp, xkcp, g_cp, ngmcp ) - ! - IF ( check_fft ) CALL compare_dfft( dffts, dfftcp ) - ! - ! - END SUBROUTINE setup_scell_fft - ! - ! - !--------------------------------------------------------------------- - SUBROUTINE fftcp_base_info( ionode, stdout ) - !------------------------------------------------------------------- - ! - LOGICAL, INTENT(IN) :: ionode - INTEGER, INTENT(IN) :: stdout - ! - ! Display fftcp basic information - ! - IF (ionode) THEN - WRITE( stdout,*) - IF ( check_fft ) THEN - WRITE( stdout, '(5X,"Info about the pcell FFT")') - WRITE( stdout, '(5X,"------------------------")') - ELSE - WRITE( stdout, '(5X,"Info about the supercell FFT")') - WRITE( stdout, '(5X,"----------------------------")') - ENDIF - WRITE( stdout, '(5X,"sticks: smooth PW", & - & 5X,"G-vecs: smooth PW")') - IF ( dfftcp%nproc > 1 ) THEN - WRITE( stdout,'(5X,"Min",5X,I8,I7,13X,I9,I8)') & - minval(dfftcp%nsp), minval(dfftcp%nsw), & - minval(dfftcp%ngl), minval(dfftcp%nwl) - WRITE( stdout,'(5X,"Max",5X,I8,I7,13X,I9,I8)') & - maxval(dfftcp%nsp), maxval(dfftcp%nsw), & - maxval(dfftcp%ngl), maxval(dfftcp%nwl) - END IF - WRITE( stdout,'(5X,"Sum",5X,I8,I7,13X,I9,I8)') & - sum(dfftcp%nsp), sum(dfftcp%nsw), & - sum(dfftcp%ngl), sum(dfftcp%nwl) - WRITE( stdout, '(/5x,"grid: ",i10," G-vectors", 5x, & - & "FFT dimensions: (",i4,",",i4,",",i4,")")') & - & ngmcp_g, dfftcp%nr1, dfftcp%nr2, dfftcp%nr3 - IF ( .not. check_fft ) THEN - IF ( gamma_only_x ) THEN - WRITE( stdout, '(/5X,"Gamma-only algorithm is used & - --> real wavefunctions")') - ELSE - WRITE( stdout, '(/5X,"Gamma-only algorithm is not used & - --> complex wavefunctions")') - ENDIF - ENDIF - ENDIF - ! - IF(ionode) WRITE( stdout,*) - ! - RETURN - ! - ! - END SUBROUTINE fftcp_base_info - ! - ! - !--------------------------------------------------------------------- - SUBROUTINE gveccp_init( ngmcp_ , comm ) - !------------------------------------------------------------------- - ! - ! Set local and global dimensions, allocate arrays - ! - USE mp, ONLY : mp_max, mp_sum - ! - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ngmcp_ - INTEGER, INTENT(IN) :: comm ! communicator of the group on which g-vecs are distributed - ! - ! - ngmcp = ngmcp_ - ! - ! calculate maximum over all processors - ! - ngmcpx = ngmcp - CALL mp_max( ngmcpx, comm ) - ! - ! calculate sum over all processors - ! - ngmcp_g = ngmcp - CALL mp_sum( ngmcp_g, comm ) - ! - ! allocate arrays - only those that are always kept until the end - ! - ALLOCATE( gg_cp(ngmcp) ) - ALLOCATE( g_cp(3, ngmcp) ) - ALLOCATE( mill_cp(3, ngmcp) ) - ALLOCATE( ig_l2g_cp(ngmcp) ) - ALLOCATE( igtongl_cp(ngmcp) ) - ! - RETURN - ! - ! - END SUBROUTINE gveccp_init - ! - ! - !----------------------------------------------------------------------- - SUBROUTINE gshells_cp ( vc ) - !---------------------------------------------------------------------- - ! - ! calculate number of G shells for the supercell: nglcp, and the - ! index ng = igtongl_cp(ig) that gives the shell index ng for - ! (local) G-vector of index ig - ! - USE constants, ONLY : eps8 - ! - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(IN) :: vc - ! - INTEGER :: ng, igl - ! - ! - IF ( vc ) THEN - ! - ! in case of a variable cell run each G vector has its shell - ! - nglcp = ngmcp - gl_cp => gg_cp - ! - DO ng = 1, ngmcp - igtongl_cp (ng) = ng - ENDDO - ! - ELSE - ! - ! G vectors are grouped in shells with the same norm - ! - nglcp = 1 - igtongl_cp (1) = 1 - ! - DO ng = 2, ngmcp - IF (gg_cp (ng) > gg_cp (ng - 1) + eps8) THEN - nglcp = nglcp + 1 - ENDIF - igtongl_cp (ng) = nglcp - ENDDO - ! - ALLOCATE ( gl_cp(nglcp) ) - gl_cp (1) = gg_cp (1) - igl = 1 - ! - DO ng = 2, ngmcp - IF (gg_cp (ng) > gg_cp (ng - 1) + eps8) THEN - igl = igl + 1 - gl_cp (igl) = gg_cp (ng) - ENDIF - ENDDO - ! - IF (igl /= nglcp) CALL errore ('gshells_cp', 'igl <> ngl', nglcp) - ! - ENDIF - ! - ! - END SUBROUTINE gshells_cp - ! - ! - !----------------------------------------------------------------------- - SUBROUTINE dealloc_sc_fft - !---------------------------------------------------------------------- - ! - ! - IMPLICIT NONE - ! - ! - IF ( ALLOCATED(gg_cp) ) DEALLOCATE( gg_cp ) - IF ( ALLOCATED(g_cp) ) DEALLOCATE( g_cp ) - IF ( ALLOCATED(mill_cp) ) DEALLOCATE( mill_cp ) - IF ( ALLOCATED(ig_l2g_cp) ) DEALLOCATE( ig_l2g_cp ) - IF ( ALLOCATED(igtongl_cp) ) DEALLOCATE( igtongl_cp ) - ! - ! - END SUBROUTINE dealloc_sc_fft - ! - ! - !--------------------------------------------------------------------- - SUBROUTINE compare_dfft( dfft1, dfft2 ) - !------------------------------------------------------------------- - ! - USE io_global, ONLY : stdout - ! - ! - IMPLICIT NONE - ! - TYPE( fft_type_descriptor ), INTENT(IN) :: dfft1, dfft2 - ! - ! - IF ( dfft1%nr1 .ne. dfft2%nr1 ) THEN - WRITE(stdout,*) "Mismatch in nr1", dfft1%nr1, dfft2%nr1 - ENDIF - ! - IF ( dfft1%nr2 .ne. dfft2%nr2 ) THEN - WRITE(stdout,*) "Mismatch in nr2", dfft1%nr2, dfft2%nr2 - ENDIF - ! - IF ( dfft1%nr3 .ne. dfft2%nr3 ) THEN - WRITE(stdout,*) "Mismatch in nr3", dfft1%nr3, dfft2%nr3 - ENDIF - ! - IF ( dfft1%nr1x .ne. dfft2%nr1x ) THEN - WRITE(stdout,*) "Mismatch in nr1x", dfft1%nr1x, dfft2%nr1x - ENDIF - ! - IF ( dfft1%nr2x .ne. dfft2%nr2x ) THEN - WRITE(stdout,*) "Mismatch in nr2x", dfft1%nr2x, dfft2%nr2x - ENDIF - ! - IF ( dfft1%nr3x .ne. dfft2%nr3x ) THEN - WRITE(stdout,*) "Mismatch in nr3x", dfft1%nr3x, dfft2%nr3x - ENDIF - ! - IF ( dfft1%lpara .neqv. dfft2%lpara ) THEN - WRITE(stdout,*) "Mismatch in lpara", dfft1%lpara, dfft2%lpara - ENDIF - ! - IF ( dfft1%lgamma .neqv. dfft2%lgamma ) THEN - WRITE(stdout,*) "Mismatch in lgamma", dfft1%lgamma, dfft2%lgamma - ENDIF - ! - IF ( dfft1%root .ne. dfft2%root ) THEN - WRITE(stdout,*) "Mismatch in root", dfft1%root, dfft2%root - ENDIF - ! - IF ( dfft1%comm .ne. dfft2%comm ) THEN - WRITE(stdout,*) "Mismatch in comm", dfft1%comm, dfft2%comm - ENDIF - ! - IF ( dfft1%comm2 .ne. dfft2%comm2 ) THEN - WRITE(stdout,*) "Mismatch in comm2", dfft1%comm2, dfft2%comm2 - ENDIF - ! - IF ( dfft1%comm3 .ne. dfft2%comm3 ) THEN - WRITE(stdout,*) "Mismatch in comm3", dfft1%comm3, dfft2%comm3 - ENDIF - ! - IF ( dfft1%nproc .ne. dfft2%nproc ) THEN - WRITE(stdout,*) "Mismatch in nproc", dfft1%nproc, dfft2%nproc - ENDIF - ! - IF ( dfft1%nproc2 .ne. dfft2%nproc2 ) THEN - WRITE(stdout,*) "Mismatch in nproc2", dfft1%nproc2, dfft2%nproc2 - ENDIF - ! - IF ( dfft1%nproc3 .ne. dfft2%nproc3 ) THEN - WRITE(stdout,*) "Mismatch in nproc3", dfft1%nproc3, dfft2%nproc3 - ENDIF - ! - IF ( dfft1%mype .ne. dfft2%mype ) THEN - WRITE(stdout,*) "Mismatch in mype", dfft1%mype, dfft2%mype - ENDIF - ! - IF ( dfft1%mype2 .ne. dfft2%mype2 ) THEN - WRITE(stdout,*) "Mismatch in mype2", dfft1%mype2, dfft2%mype2 - ENDIF - ! - IF ( dfft1%mype3 .ne. dfft2%mype3 ) THEN - WRITE(stdout,*) "Mismatch in mype3", dfft1%mype3, dfft2%mype3 - ENDIF - ! - IF ( ANY(dfft1%iproc .ne. dfft2%iproc) ) THEN - WRITE(stdout,*) "Mismatch in iproc", dfft1%iproc, dfft2%iproc - ENDIF - ! - IF ( ANY(dfft1%iproc2 .ne. dfft2%iproc2) ) THEN - WRITE(stdout,*) "Mismatch in iproc2", dfft1%iproc2, dfft2%iproc2 - ENDIF - ! - IF ( ANY(dfft1%iproc3 .ne. dfft2%iproc3) ) THEN - WRITE(stdout,*) "Mismatch in iproc3", dfft1%iproc3, dfft2%iproc3 - ENDIF - ! - IF ( dfft1%my_nr3p .ne. dfft2%my_nr3p ) THEN - WRITE(stdout,*) "Mismatch in my_nr3p", dfft1%my_nr3p, dfft2%my_nr3p - ENDIF - ! - IF ( dfft1%my_nr2p .ne. dfft2%my_nr2p ) THEN - WRITE(stdout,*) "Mismatch in my_nr2p", dfft1%my_nr2p, dfft2%my_nr2p - ENDIF - ! - IF ( dfft1%my_i0r3p .ne. dfft2%my_i0r3p ) THEN - WRITE(stdout,*) "Mismatch in my_i0r3p", dfft1%my_i0r3p, dfft2%my_i0r3p - ENDIF - ! - IF ( dfft1%my_i0r2p .ne. dfft2%my_i0r2p ) THEN - WRITE(stdout,*) "Mismatch in my_i0r2p", dfft1%my_i0r2p, dfft2%my_i0r2p - ENDIF - ! - IF ( ANY(dfft1%nr3p .ne. dfft2%nr3p) ) THEN - WRITE(stdout,*) "Mismatch in nr3p", dfft1%nr3p, dfft2%nr3p - ENDIF - ! - IF ( ANY(dfft1%nr3p_offset .ne. dfft2%nr3p_offset) ) THEN - WRITE(stdout,*) "Mismatch in nr3p_offset", dfft1%nr3p_offset, dfft2%nr3p_offset - ENDIF - ! - IF ( ANY(dfft1%nr2p .ne. dfft2%nr2p) ) THEN - WRITE(stdout,*) "Mismatch in nr2p", dfft1%nr2p, dfft2%nr2p - ENDIF - ! - IF ( ANY(dfft1%nr2p_offset .ne. dfft2%nr2p_offset) ) THEN - WRITE(stdout,*) "Mismatch in nr2p_offset", dfft1%nr2p_offset, dfft2%nr2p_offset - ENDIF - ! - IF ( ANY(dfft1%nr1p .ne. dfft2%nr1p) ) THEN - WRITE(stdout,*) "Mismatch in nr1p", dfft1%nr1p, dfft2%nr1p - ENDIF - ! - IF ( ANY(dfft1%nr1w .ne. dfft2%nr1w) ) THEN - WRITE(stdout,*) "Mismatch in nr1w", dfft1%nr1w, dfft2%nr1w - ENDIF - ! - IF ( dfft1%nr1w_tg .ne. dfft2%nr1w_tg ) THEN - WRITE(stdout,*) "Mismatch in nr1w_tg", dfft1%nr1w_tg, dfft2%nr1w_tg - ENDIF - ! - IF ( ANY(dfft1%i0r3p .ne. dfft2%i0r3p) ) THEN - WRITE(stdout,*) "Mismatch in i0r3p", dfft1%i0r3p, dfft2%i0r3p - ENDIF - ! - IF ( ANY(dfft1%i0r2p .ne. dfft2%i0r2p) ) THEN - WRITE(stdout,*) "Mismatch in i0r2p", dfft1%i0r2p, dfft2%i0r2p - ENDIF - ! - IF ( ANY(dfft1%ir1p .ne. dfft2%ir1p) ) THEN - WRITE(stdout,*) "Mismatch in ir1p", dfft1%ir1p, dfft2%ir1p - ENDIF - ! - IF ( ANY(dfft1%indp .ne. dfft2%indp) ) THEN - WRITE(stdout,*) "Mismatch in indp", dfft1%indp, dfft2%indp - ENDIF - ! - IF ( ANY(dfft1%ir1w .ne. dfft2%ir1w) ) THEN - WRITE(stdout,*) "Mismatch in ir1w", dfft1%ir1w, dfft2%ir1w - ENDIF - ! - IF ( ANY(dfft1%indw .ne. dfft2%indw) ) THEN - WRITE(stdout,*) "Mismatch in indw", dfft1%indw, dfft2%indw - ENDIF - ! - IF ( ANY(dfft1%ir1w_tg .ne. dfft2%ir1w_tg) ) THEN - WRITE(stdout,*) "Mismatch in ir1w_tg", dfft1%ir1w_tg, dfft2%ir1w_tg - ENDIF - ! - IF ( ANY(dfft1%indw_tg .ne. dfft2%indw_tg) ) THEN - WRITE(stdout,*) "Mismatch in indw_tg", dfft1%indw_tg, dfft2%indw_tg - ENDIF - ! - IF ( dfft1%nst .ne. dfft2%nst ) THEN - WRITE(stdout,*) "Mismatch in nst", dfft1%nst, dfft2%nst - ENDIF - ! - IF ( ANY(dfft1%nsp .ne. dfft2%nsp) ) THEN - WRITE(stdout,*) "Mismatch in nsp", dfft1%nsp, dfft2%nsp - ENDIF - ! - IF ( ANY(dfft1%nsp_offset .ne. dfft2%nsp_offset) ) THEN - WRITE(stdout,*) "Mismatch in nsp_offset", dfft1%nsp_offset, dfft2%nsp_offset - ENDIF - ! - IF ( ANY(dfft1%nsw .ne. dfft2%nsw) ) THEN - WRITE(stdout,*) "Mismatch in nsw", dfft1%nsw, dfft2%nsw - ENDIF - ! - IF ( ANY(dfft1%nsw_offset .ne. dfft2%nsw_offset) ) THEN - WRITE(stdout,*) "Mismatch in nsw_offset", dfft1%nsw_offset, dfft2%nsw_offset - ENDIF - ! - IF ( ANY(dfft1%nsw_tg .ne. dfft2%nsw_tg) ) THEN - WRITE(stdout,*) "Mismatch in nsw_tg", dfft1%nsw_tg, dfft2%nsw_tg - ENDIF - ! - IF ( ANY(dfft1%ngl .ne. dfft2%ngl) ) THEN - WRITE(stdout,*) "Mismatch in ngl", dfft1%ngl, dfft2%ngl - ENDIF - ! - IF ( ANY(dfft1%nwl .ne. dfft2%nwl) ) THEN - WRITE(stdout,*) "Mismatch in nwl", dfft1%nwl, dfft2%nwl - ENDIF - ! - IF ( dfft1%ngm .ne. dfft2%ngm ) THEN - WRITE(stdout,*) "Mismatch in ngm", dfft1%ngm, dfft2%ngm - ENDIF - ! - IF ( dfft1%ngw .ne. dfft2%ngw ) THEN - WRITE(stdout,*) "Mismatch in ngw", dfft1%ngw, dfft2%ngw - ENDIF - ! - IF ( ANY(dfft1%iplp .ne. dfft2%iplp) ) THEN - WRITE(stdout,*) "Mismatch in iplp", dfft1%iplp, dfft2%iplp - ENDIF - ! - IF ( ANY(dfft1%iplw .ne. dfft2%iplw) ) THEN - WRITE(stdout,*) "Mismatch in iplw", dfft1%iplw, dfft2%iplw - ENDIF - ! - IF ( dfft1%nnp .ne. dfft2%nnp ) THEN - WRITE(stdout,*) "Mismatch in nnp", dfft1%nnp, dfft2%nnp - ENDIF - ! - IF ( dfft1%nnr .ne. dfft2%nnr ) THEN - WRITE(stdout,*) "Mismatch in nnr", dfft1%nnr, dfft2%nnr - ENDIF - ! - IF ( dfft1%nnr_tg .ne. dfft2%nnr_tg ) THEN - WRITE(stdout,*) "Mismatch in nnr_tg", dfft1%nnr_tg, dfft2%nnr_tg - ENDIF - ! - IF ( ANY(dfft1%iss .ne. dfft2%iss) ) THEN - WRITE(stdout,*) "Mismatch in iss", dfft1%iss, dfft2%iss - ENDIF - ! - IF ( ANY(dfft1%isind .ne. dfft2%isind) ) THEN - WRITE(stdout,*) "Mismatch in isind", dfft1%isind, dfft2%isind - ENDIF - ! - IF ( ANY(dfft1%ismap .ne. dfft2%ismap) ) THEN - WRITE(stdout,*) "Mismatch in ismap", dfft1%ismap, dfft2%ismap - ENDIF - ! - IF ( ANY(dfft1%nl .ne. dfft2%nl) ) THEN - WRITE(stdout,*) "Mismatch in nl", dfft1%nl, dfft2%nl - ENDIF - ! - IF ( ANY(dfft1%nlm .ne. dfft2%nlm) ) THEN - WRITE(stdout,*) "Mismatch in nlm", dfft1%nlm, dfft2%nlm - ENDIF - ! - IF ( ANY(dfft1%tg_snd .ne. dfft2%tg_snd) ) THEN - WRITE(stdout,*) "Mismatch in tg_snd", dfft1%tg_snd, dfft2%tg_snd - ENDIF - ! - IF ( ANY(dfft1%tg_rcv .ne. dfft2%tg_rcv) ) THEN - WRITE(stdout,*) "Mismatch in tg_rcv", dfft1%tg_rcv, dfft2%tg_rcv - ENDIF - ! - IF ( ANY(dfft1%tg_sdsp .ne. dfft2%tg_sdsp) ) THEN - WRITE(stdout,*) "Mismatch in tg_sdsp", dfft1%tg_sdsp, dfft2%tg_sdsp - ENDIF - ! - IF ( ANY(dfft1%tg_rdsp .ne. dfft2%tg_rdsp) ) THEN - WRITE(stdout,*) "Mismatch in tg_rdsp", dfft1%tg_rdsp, dfft2%tg_rdsp - ENDIF - ! - IF ( dfft1%has_task_groups .neqv. dfft2%has_task_groups ) THEN - WRITE(stdout,*) "Mismatch in has_task_groups", dfft1%has_task_groups, dfft2%has_task_groups - ENDIF - ! - IF ( dfft1%rho_clock_label .ne. dfft2%rho_clock_label ) THEN - WRITE(stdout,*) "Mismatch in rho_clock_label", dfft1%rho_clock_label, dfft2%rho_clock_label - ENDIF - ! - IF ( dfft1%wave_clock_label .ne. dfft2%wave_clock_label ) THEN - WRITE(stdout,*) "Mismatch in wave_clock_label", dfft1%wave_clock_label, dfft2%wave_clock_label - ENDIF - ! - IF ( dfft1%grid_id .ne. dfft2%grid_id ) THEN - WRITE(stdout,*) "Mismatch in grid_id", dfft1%grid_id, dfft2%grid_id - ENDIF - ! - ! - END SUBROUTINE compare_dfft - ! - ! -END MODULE fft_supercell diff --git a/quantum_espresso/utils/src/make.depend b/quantum_espresso/utils/src/make.depend deleted file mode 100644 index cacabd814..000000000 --- a/quantum_espresso/utils/src/make.depend +++ /dev/null @@ -1,130 +0,0 @@ -epsilon.o : ../../q-e/Modules/cell_base.o -epsilon.o : ../../q-e/Modules/constants.o -epsilon.o : ../../q-e/Modules/environment.o -epsilon.o : ../../q-e/Modules/io_files.o -epsilon.o : ../../q-e/Modules/io_global.o -epsilon.o : ../../q-e/Modules/kind.o -epsilon.o : ../../q-e/Modules/mp_bands.o -epsilon.o : ../../q-e/Modules/mp_global.o -epsilon.o : ../../q-e/Modules/mp_images.o -epsilon.o : ../../q-e/Modules/mp_pools.o -epsilon.o : ../../q-e/Modules/recvec.o -epsilon.o : ../../q-e/Modules/wavefunctions.o -epsilon.o : ../../q-e/PW/src/pw_restart_new.o -epsilon.o : ../../q-e/PW/src/pwcom.o -epsilon.o : ../../q-e/UtilXlib/mp.o -epsilon.o : ../../q-e/upflib/uspp.o -cp_files.o : ../../q-e/Modules/io_global.o -cp_files.o : ../../q-e/Modules/kind.o -cp_files.o : ../../q-e/Modules/mp_bands.o -cp_files.o : ../../q-e/Modules/mp_wave.o -cp_files.o : ../../q-e/Modules/mp_world.o -cp_files.o : ../../q-e/Modules/noncol.o -cp_files.o : ../../q-e/PW/src/buffers.o -cp_files.o : ../../q-e/PW/src/pwcom.o -cp_files.o : ../../q-e/UtilXlib/mp.o -cp_files.o : fft_supercell.o -cp_files.o : read_wannier.o -fft_supercell.o : ../../q-e/FFTXlib/src/fft_types.o -fft_supercell.o : ../../q-e/FFTXlib/src/stick_base.o -fft_supercell.o : ../../q-e/Modules/cell_base.o -fft_supercell.o : ../../q-e/Modules/command_line_options.o -fft_supercell.o : ../../q-e/Modules/constants.o -fft_supercell.o : ../../q-e/Modules/control_flags.o -fft_supercell.o : ../../q-e/Modules/fft_base.o -fft_supercell.o : ../../q-e/Modules/gvecw.o -fft_supercell.o : ../../q-e/Modules/io_global.o -fft_supercell.o : ../../q-e/Modules/ions_base.o -fft_supercell.o : ../../q-e/Modules/kind.o -fft_supercell.o : ../../q-e/Modules/mp_bands.o -fft_supercell.o : ../../q-e/Modules/mp_pools.o -fft_supercell.o : ../../q-e/Modules/parameters.o -fft_supercell.o : ../../q-e/Modules/recvec.o -fft_supercell.o : ../../q-e/Modules/recvec_subs.o -fft_supercell.o : ../../q-e/PW/src/pwcom.o -fft_supercell.o : ../../q-e/PW/src/realus.o -fft_supercell.o : ../../q-e/PW/src/symm_base.o -fft_supercell.o : ../../q-e/UtilXlib/mp.o -fft_supercell.o : read_wannier.o -plot_wan2kcp.o : ../../q-e/FFTXlib/src/fft_interfaces.o -plot_wan2kcp.o : ../../q-e/Modules/cell_base.o -plot_wan2kcp.o : ../../q-e/Modules/constants.o -plot_wan2kcp.o : ../../q-e/Modules/io_global.o -plot_wan2kcp.o : ../../q-e/Modules/ions_base.o -plot_wan2kcp.o : ../../q-e/Modules/kind.o -plot_wan2kcp.o : ../../q-e/Modules/mp_bands.o -plot_wan2kcp.o : ../../q-e/Modules/noncol.o -plot_wan2kcp.o : ../../q-e/Modules/parameters.o -plot_wan2kcp.o : ../../q-e/PW/src/buffers.o -plot_wan2kcp.o : ../../q-e/UtilXlib/mp.o -plot_wan2kcp.o : fft_supercell.o -plot_wan2kcp.o : scell_wfc.o -read_wannier.o : ../../q-e/Modules/constants.o -read_wannier.o : ../../q-e/Modules/io_global.o -read_wannier.o : ../../q-e/Modules/kind.o -read_wannier.o : ../../q-e/Modules/mp_global.o -read_wannier.o : ../../q-e/PW/src/pwcom.o -read_wannier.o : ../../q-e/UtilXlib/mp.o -read_wannier.o : wannier.o -scell_wfc.o : ../../q-e/FFTXlib/src/fft_support.o -scell_wfc.o : ../../q-e/FFTXlib/src/fft_types.o -scell_wfc.o : ../../q-e/Modules/cell_base.o -scell_wfc.o : ../../q-e/Modules/constants.o -scell_wfc.o : ../../q-e/Modules/fft_base.o -scell_wfc.o : ../../q-e/Modules/kind.o -scell_wfc.o : ../../q-e/Modules/mp_bands.o -scell_wfc.o : ../../q-e/UtilXlib/mp.o -wann2kcp.o : ../../q-e/FFTXlib/src/fft_interfaces.o -wann2kcp.o : ../../q-e/FFTXlib/src/scatter_mod.o -wann2kcp.o : ../../q-e/Modules/becmod.o -wann2kcp.o : ../../q-e/Modules/cell_base.o -wann2kcp.o : ../../q-e/Modules/constants.o -wann2kcp.o : ../../q-e/Modules/control_flags.o -wann2kcp.o : ../../q-e/Modules/environment.o -wann2kcp.o : ../../q-e/Modules/fft_base.o -wann2kcp.o : ../../q-e/Modules/gvecw.o -wann2kcp.o : ../../q-e/Modules/invmat.o -wann2kcp.o : ../../q-e/Modules/io_files.o -wann2kcp.o : ../../q-e/Modules/io_global.o -wann2kcp.o : ../../q-e/Modules/ions_base.o -wann2kcp.o : ../../q-e/Modules/kind.o -wann2kcp.o : ../../q-e/Modules/mp_bands.o -wann2kcp.o : ../../q-e/Modules/mp_global.o -wann2kcp.o : ../../q-e/Modules/mp_pools.o -wann2kcp.o : ../../q-e/Modules/mp_world.o -wann2kcp.o : ../../q-e/Modules/noncol.o -wann2kcp.o : ../../q-e/Modules/random_numbers.o -wann2kcp.o : ../../q-e/Modules/recvec.o -wann2kcp.o : ../../q-e/Modules/wavefunctions.o -wann2kcp.o : ../../q-e/PW/src/pwcom.o -wann2kcp.o : ../../q-e/PW/src/scf_mod.o -wann2kcp.o : ../../q-e/PW/src/symm_base.o -wann2kcp.o : ../../q-e/UtilXlib/mp.o -wann2kcp.o : ../../q-e/upflib/uspp.o -wann2kcp.o : plot_wan2kcp.o -wann2kcp.o : wannier2kcp.o -wann2kcp.o : wannier.o -wannier.o : ../../q-e/Modules/kind.o -wannier2kcp.o : ../../q-e/FFTXlib/src/fft_interfaces.o -wannier2kcp.o : ../../q-e/Modules/cell_base.o -wannier2kcp.o : ../../q-e/Modules/constants.o -wannier2kcp.o : ../../q-e/Modules/control_flags.o -wannier2kcp.o : ../../q-e/Modules/fft_base.o -wannier2kcp.o : ../../q-e/Modules/io_base.o -wannier2kcp.o : ../../q-e/Modules/io_files.o -wannier2kcp.o : ../../q-e/Modules/io_global.o -wannier2kcp.o : ../../q-e/Modules/kind.o -wannier2kcp.o : ../../q-e/Modules/mp_bands.o -wannier2kcp.o : ../../q-e/Modules/mp_pools.o -wannier2kcp.o : ../../q-e/Modules/noncol.o -wannier2kcp.o : ../../q-e/Modules/recvec.o -wannier2kcp.o : ../../q-e/Modules/wavefunctions.o -wannier2kcp.o : ../../q-e/PW/src/buffers.o -wannier2kcp.o : ../../q-e/PW/src/pwcom.o -wannier2kcp.o : ../../q-e/PW/src/scf_mod.o -wannier2kcp.o : ../../q-e/UtilXlib/mp.o -wannier2kcp.o : cp_files.o -wannier2kcp.o : fft_supercell.o -wannier2kcp.o : read_wannier.o -wannier2kcp.o : scell_wfc.o -wannier2kcp.o : wannier.o diff --git a/quantum_espresso/utils/src/merge_evc.f90 b/quantum_espresso/utils/src/merge_evc.f90 deleted file mode 100644 index 2c09ceffd..000000000 --- a/quantum_espresso/utils/src/merge_evc.f90 +++ /dev/null @@ -1,274 +0,0 @@ -! -! Copyright (C) 2003-2013 Quantum ESPRESSO and Wannier90 groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -! Written by Riccardo De Gennaro, EPFL (Nov 2021). -! -! -!--------------------------------------------------------------------- -MODULE merge_evc_module - !----------------------------------------------------------------- - ! - IMPLICIT NONE - ! - SAVE - ! - PRIVATE - ! - INTEGER, PARAMETER, PUBLIC :: stdout = 6 - INTEGER, PARAMETER, PUBLIC :: DP = selected_real_kind(14,200) - ! - PUBLIC :: parse_args, error_stop - ! - CONTAINS - ! - !--------------------------------------------------------------------- - SUBROUTINE parse_args( io_files, nrtot, output_exst ) - !----------------------------------------------------------------- - ! - ! ... routine parsing arguments passed in input - ! - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256), ALLOCATABLE, INTENT(OUT) :: io_files(:) - INTEGER, INTENT(OUT) :: nrtot - LOGICAL, INTENT(OUT) :: output_exst - ! - INTEGER :: nargs, iarg, n_files - INTEGER :: counter, ios - CHARACTER(LEN=256) :: arg - LOGICAL :: input_exst = .false. - LOGICAL :: nrtot_exst = .false. - ! - ! - nargs = command_argument_count() - ! - IF ( nargs < 2 .or. mod( nargs, 2 ) /= 0 ) & - CALL error_stop( 'wrong number of positional arguments', 1 ) - ! - output_exst = .false. - n_files = nargs / 2 - 1 - ALLOCATE( io_files(n_files) ) - io_files(:) = ' ' - iarg = 1 - counter = 0 - ! - DO WHILE ( iarg < nargs ) - ! - CALL get_command_argument( iarg, arg ) - iarg = iarg + 1 - ! - SELECT CASE ( trim(arg) ) - ! - CASE ( '-nr' ) - CALL get_command_argument( iarg, arg ) - READ( arg, *, IOSTAT=ios ) nrtot - IF ( ios .ne. 0 ) & - CALL error_stop( 'error while reading number of R-vectors', abs(ios) ) - IF ( nrtot_exst ) & - CALL error_stop( 'nrtot can be defined only once', 1 ) - nrtot_exst = .true. - ! - CASE ( '-i', '-in', '-input' ) - CALL get_command_argument( iarg, arg ) - counter = counter + 1 - IF ( counter > n_files ) & - CALL error_stop( 'something wrong in input. Did you provide -nr ?', 1 ) - io_files(counter) = trim(arg) - IF ( .not. input_exst ) input_exst = .true. - ! - CASE ( '-o', '-out', '-output' ) - CALL get_command_argument( iarg, arg ) - IF ( output_exst ) & - CALL error_stop( 'only one output file can be defined', 1 ) - output_exst = .true. - io_files(n_files) = trim(arg) - ! - CASE DEFAULT - CALL error_stop( 'unrecognised argument option', abs(iarg-1) ) - ! - END SELECT - ! - iarg = iarg + 1 - ! - ENDDO - ! - IF ( .not. nrtot_exst ) CALL error_stop( 'nrtot was not provided', 1) - ! - IF ( .not. input_exst ) CALL error_stop( 'no input files provided', 1 ) - IF ( nrtot .le. 0 ) CALL error_stop( 'wrong number of R-vectors', abs(nrtot) ) - ! - ! - END SUBROUTINE parse_args - ! - !!--------------------------------------------------------------------- - SUBROUTINE error_stop( message, ierr ) - !----------------------------------------------------------------- - ! - ! ... error handler - ! - ! - IMPLICIT NONE - ! - CHARACTER(LEN=*), INTENT(IN) :: message - INTEGER, INTENT(IN) :: ierr - ! - LOGICAL :: opnd - ! - ! - IF ( ierr <= 0 ) RETURN - ! - ! ... the error message is written un the "*" unit - ! - WRITE (UNIT=*, FMT='(/,1X,78("%"))') - WRITE (UNIT=*, FMT='(5X,"from ",A," : error #",I10)') 'merge_evc', ierr - WRITE (UNIT=*, FMT='(5X,A)') message - WRITE (UNIT=*, FMT='(1X,78("%"),/)') - WRITE (*, '(" stopping ...")') - ! - INQUIRE( UNIT = stdout, OPENED = opnd ) - ! - IF ( opnd ) CALL flush( stdout ) - ! - ERROR STOP 1 - ! - RETURN - ! - END SUBROUTINE error_stop - ! - ! -END MODULE merge_evc_module -! -! -!--------------------------------------------------------------------- -PROGRAM merge_evc - !----------------------------------------------------------------- - ! - ! This program merges all the wavefunction files passed as - ! standard input arguments. The program can be run as below: - ! - ! merge_evc.x -nr 4 -i path/to/file1 -i path/to/file2 -o output - ! - ! The -nr argument is mandatory and it is followed by an integer - ! specifying the number of R-vectors, i.e. the number of - ! repetitions of the unit cell within the supercell - ! - ! The -i argument is followed by the path to the input file(s) - ! to be merged - ! - ! The -o argument is optional and it can be used to specify - ! the output file; if not present the default output name is - ! evcw.dat - ! - ! For the moment the format of the files is that defined in - ! cp_files.f90, used by the Koopmans-CP code. - ! - ! NB: since this is just a read/write program there is no - ! parallelization - ! - ! - USE merge_evc_module - ! - IMPLICIT NONE - ! - CHARACTER(LEN=20) :: arg - CHARACTER(LEN=256), ALLOCATABLE :: io_files(:) - CHARACTER(LEN=256) :: filename, ofilename, nfile - LOGICAL :: output_exst - INTEGER :: ifile, ios, n_files - INTEGER :: iunit = 8 - INTEGER :: ounit = 24 - INTEGER :: iunit_ - INTEGER :: npw, npw_ref - INTEGER :: ipw, ibnd, ir - INTEGER :: nbnd, nrtot - INTEGER, ALLOCATABLE :: nbnd_i(:) - COMPLEX(DP), ALLOCATABLE :: evc(:) - ! - ! - CALL get_command_argument( 1, arg ) - ! - CALL parse_args( io_files, nrtot, output_exst ) - ! - IF ( output_exst ) THEN - ofilename = trim( io_files(size(io_files)) ) - n_files = size( io_files ) - 1 - ELSE - ofilename = 'evcw.dat' - n_files = size( io_files ) - ENDIF - ! - ! ... reading number of PWs and number of bands from each file - ! - nbnd = 0 - ALLOCATE( nbnd_i(n_files) ) - ! - DO ifile = 1, n_files - ! - iunit_ = iunit + ifile - filename = trim(io_files(ifile)) - OPEN( UNIT=iunit_, FILE=trim(filename), STATUS='old', FORM='unformatted', IOSTAT=ios ) - ! - IF ( ios .ne. 0 ) THEN - CLOSE( UNIT=ounit, STATUS='delete' ) - CALL error_stop( 'problem opening the input files', ifile ) - ENDIF - ! - READ( iunit_ ) npw, nbnd_i(ifile) - ! - IF ( mod( nbnd_i(ifile), nrtot ) .ne. 0 ) & - CALL error_stop( 'incosistent number of R-vectors', mod( nbnd_i(ifile), nrtot ) ) - ! - IF ( ifile == 1 ) npw_ref = npw - ! - IF ( npw .ne. npw_ref ) THEN - CLOSE( UNIT=ounit, STATUS='delete' ) - CALL error_stop( 'unconsistent number of PW between files', ifile ) - ENDIF - ! - ENDDO - ! - nbnd = SUM( nbnd_i ) - OPEN( UNIT=ounit, FILE=trim(ofilename), STATUS='unknown', FORM='unformatted' ) - WRITE( ounit ) npw, nbnd - ALLOCATE( evc(npw) ) - ! - ! ... reading wave functions and writing them to a single file - ! - DO ir = 1, nrtot - ! - DO ifile = 1, n_files - ! - iunit_ = iunit + ifile - ! - IF ( ir == 1 ) WRITE( nfile, 100 ) ifile - ! - DO ibnd = 1, nbnd_i(ifile)/nrtot - ! - evc(:) = ( 0.d0, 0.d0 ) - READ ( iunit_ ) ( evc(ipw), ipw = 1, npw ) - WRITE( ounit ) ( evc(ipw), ipw = 1, npw ) - ! - ENDDO - ! - IF ( ir == nrtot ) THEN - CLOSE( UNIT=iunit_ ) - WRITE( nfile, 100 ) ifile - ENDIF - ! - ENDDO - ! - ENDDO - ! - CLOSE( UNIT=ounit ) - ! - ! -100 FORMAT( 'r/w file', 1X, I2 ) - ! - ! -END PROGRAM merge_evc diff --git a/quantum_espresso/utils/src/plot_wan2kcp.f90 b/quantum_espresso/utils/src/plot_wan2kcp.f90 deleted file mode 100644 index 56ed3fba8..000000000 --- a/quantum_espresso/utils/src/plot_wan2kcp.f90 +++ /dev/null @@ -1,199 +0,0 @@ -! -! Copyright (C) 2003-2013 Quantum ESPRESSO and Wannier90 groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -! Written by Riccardo De Gennaro, EPFL (Sept 2020). -! -! -!--------------------------------------------------------------------- -MODULE plot_wan2odd - !------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - ! - ! - IMPLICIT NONE - ! - PRIVATE - ! - PUBLIC :: plot_wann - ! - CONTAINS - ! - !--------------------------------------------------------------------- - SUBROUTINE plot_wann( list, nrtot, nwann ) - !------------------------------------------------------------------- - ! - ! ... This routine generates a XSF file, in a format readable - ! ... by XCrySDen, with the plot of the Wannier functions in list - ! - USE io_global, ONLY : ionode, stdout - USE mp, ONLY : mp_sum - USE mp_bands, ONLY : intra_bgrp_comm - USE fft_interfaces, ONLY : invfft - USE buffers, ONLY : get_buffer, close_buffer - USE cell_base, ONLY : alat - USE constants, ONLY : BOHR_RADIUS_ANGS - USE ions_base, ONLY : atm - USE noncollin_module, ONLY : npol - USE parameters, ONLY : ntypx - USE scell_wfc, ONLY : bcast_psic - USE fft_supercell, ONLY : dfftcp, at_cp, nat_cp, tau_cp, ityp_cp, & - npwxcp, iunwann, nwordwann, gamma_only_x - ! - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: list(:) ! list of WFs to plot - INTEGER, INTENT(IN) :: nrtot ! number of R-vectors - INTEGER, INTENT(IN) :: nwann ! number of WFs - ! - CHARACTER(LEN=30) :: filename - INTEGER :: fileunit=324 - INTEGER :: ir, ibnd, iw - INTEGER :: i, j, rr - INTEGER :: nnrg - REAL(DP) :: alang - REAL(DP) :: orig(3), dirs(3,3) - COMPLEX(DP) :: evc(npwxcp*npol,nwann) ! Wannier function to plot (plane waves) - COMPLEX(DP) :: psic(dfftcp%nnr) - COMPLEX(DP), ALLOCATABLE :: psicg(:) - ! - ! - CALL start_clock( 'plot_wann' ) - ! - nnrg = dfftcp%nnr - CALL mp_sum( nnrg, intra_bgrp_comm ) - ALLOCATE( psicg(nnrg) ) - ! - IF ( ionode ) THEN - WRITE(stdout,*) "Plot of Wannier functions: iw ir ibnd" - ENDIF - ! - iw = 0 - ! - DO ir = 1, nrtot - ! - CALL get_buffer( evc, nwordwann, iunwann, ir ) - ! - DO ibnd = 1, nwann - ! - iw = iw + 1 - ! - DO j = 1, SIZE( list ) - IF ( list(j) == iw ) GOTO 500 - ENDDO - ! - CYCLE - ! - ! -500 psic(:) = ( 0.D0, 0.D0 ) - ! - IF ( ionode ) THEN - WRITE(stdout,'(10x, "Wannier function:", 3I6)') iw, ir, ibnd - ENDIF - ! - WRITE( filename, 100 ) ir, ibnd - evc(:,ibnd) = evc(:,ibnd) / SQRT(DBLE(nrtot)) - psic(dfftcp%nl(1:npwxcp)) = evc(1:npwxcp,ibnd) - IF ( gamma_only_x ) psic(dfftcp%nlm(1:npwxcp)) = CONJG( evc(1:npwxcp,ibnd) ) - CALL invfft( 'Wave', psic, dfftcp ) - CALL bcast_psic( psic, psicg, dfftcp ) - CALL real_wann_max_mod( psicg, nnrg ) - ! - alang = alat * BOHR_RADIUS_ANGS ! alat in angstrom - ! - orig(:) = (/ 0.0, 0.0, 0.0 /) ! origin of the datagrid - dirs(:,1) = at_cp(:,1) * alang ! 1st spanning vector datagrid - dirs(:,2) = at_cp(:,2) * alang ! 2nd spanning vector datagrid - dirs(:,3) = at_cp(:,3) * alang ! 3rd spanning vector datagrid - ! - ! - IF ( ionode ) THEN - ! - OPEN( UNIT=fileunit, FILE=trim(filename), STATUS='unknown', FORM='formatted' ) - ! - WRITE( fileunit, 201 ) at_cp(:,1)*alang, at_cp(:,2)*alang, at_cp(:,3)*alang - WRITE( fileunit, 202 ) at_cp(:,1)*alang, at_cp(:,2)*alang, at_cp(:,3)*alang - WRITE( fileunit, 203 ) nat_cp - WRITE( fileunit, 204 ) ( atm(ityp_cp(i)), tau_cp(:,i)*alang, i=1,nat_cp ) - WRITE( fileunit, 205 ) - WRITE( fileunit, 206 ) dfftcp%nr1, dfftcp%nr2, dfftcp%nr3, & - orig, dirs(:,1), dirs(:,2), dirs(:,3) - WRITE( fileunit, 207 ) ( REAL(psicg(rr)), rr=1,nnrg ) - WRITE( fileunit, 208 ) - ! - CLOSE( fileunit ) - ! - ENDIF - ! - ENDDO - ENDDO - ! - ! - CALL close_buffer( iunwann, 'delete' ) - CALL stop_clock( 'plot_wann' ) - ! - ! -100 FORMAT( 'WF_R', I4.4, '_B', I4.4, '.xsf' ) ! ex: WF_R0001_B0002.xsf - ! -201 FORMAT( 'CRYSTAL', /,'PRIMVEC', /, 3F12.7, /, 3F12.7, /, 3F12.7 ) -202 FORMAT( 'CONVVEC', /, 3F12.7, /, 3F12.7, /, 3F12.7 ) -203 FORMAT( 'PRIMCOORD', /, I6, ' 1' ) -204 FORMAT( A2, 3X, 3F12.7 ) -205 FORMAT( /, 'BEGIN_BLOCK_DATAGRID_3D', /, '3D_field', /, 'BEGIN_DATAGRID_3D_WANNIER' ) -206 FORMAT( 3I6, /, 3F12.6, /, 3F12.7, /, 3F12.7, /, 3F12.7 ) -207 FORMAT( 6E13.5 ) -208 FORMAT( 'END_DATAGRID_3D', /, 'END_BLOCK_DATAGRID_3D' ) - ! - ! - END SUBROUTINE plot_wann - ! - ! - !--------------------------------------------------------------------- - SUBROUTINE real_wann_max_mod( psi, nnr ) - !------------------------------------------------------------------- - ! - ! ... This routine normalizes the input Wannier function in - ! ... order to be real at the point where it has the max. - ! ... modulus - ! - ! - IMPLICIT NONE - ! - COMPLEX(DP), INTENT(INOUT) :: psi(:) - INTEGER, INTENT(IN) :: nnr - ! - INTEGER :: ir - COMPLEX(DP) :: wmod - REAL(DP) :: tmax, tmax_ - ! - ! - tmax = 0.D0 - wmod = ( 0.D0, 1.D0 ) - ! - DO ir = 1, nnr - ! - tmax_ = DBLE( psi(ir) )**2 + AIMAG( psi(ir) )**2 - ! - IF ( tmax_ > tmax ) THEN - ! - tmax = tmax_ - wmod = psi(ir) - ! - ENDIF - ! - ENDDO - ! - wmod = wmod / SQRT( DBLE(wmod)**2 + AIMAG(wmod)**2 ) - psi(:) = psi(:) / wmod - ! - ! - END SUBROUTINE real_wann_max_mod - ! - ! -END MODULE plot_wan2odd diff --git a/quantum_espresso/utils/src/read_wannier.f90 b/quantum_espresso/utils/src/read_wannier.f90 deleted file mode 100644 index 67657a446..000000000 --- a/quantum_espresso/utils/src/read_wannier.f90 +++ /dev/null @@ -1,247 +0,0 @@ -! -! Copyright (C) 2003-2013 Quantum ESPRESSO and Wannier90 groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -! Written by Riccardo De Gennaro, EPFL (Sept 2020). -! -! -!----------------------------------------------------------------------- -MODULE read_wannier - !--------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - ! - ! - IMPLICIT NONE - ! - SAVE - ! - PRIVATE - ! - PUBLIC :: read_wannier_chk - ! - ! Remember to broadcast possible additions - ! - INTEGER, PUBLIC :: num_bands ! num of PC bands for wannierization - INTEGER, PUBLIC :: num_wann ! num of PC Wannier functions - INTEGER, PUBLIC :: num_kpts ! num of k-points - INTEGER, PUBLIC :: kgrid(3) ! MP grid - LOGICAL, ALLOCATABLE, PUBLIC :: excluded_band(:) - LOGICAL, ALLOCATABLE, PUBLIC :: lwindow(:,:) ! disentanglement parameters - INTEGER, ALLOCATABLE, PUBLIC :: ndimwin(:) ! disentanglement parameters - COMPLEX(DP), ALLOCATABLE, PUBLIC :: u_mat(:,:,:) - COMPLEX(DP), ALLOCATABLE, PUBLIC :: u_mat_opt(:,:,:) - LOGICAL, PUBLIC :: have_disentangled - ! - CONTAINS - ! - !--------------------------------------------------------------------- - SUBROUTINE read_wannier_chk( ) - !------------------------------------------------------------------- - ! - ! ... parser for the Wannier90 chk file - ! - USE io_global, ONLY : ionode, ionode_id - USE mp_global, ONLY : intra_image_comm - USE mp, ONLY : mp_bcast - USE klist, ONLY : nkstot - USE wvfct, ONLY : nbnd - USE lsda_mod, ONLY : nspin - USE wannier, ONLY : seedname - ! - ! - IMPLICIT NONE - ! - CHARACTER(LEN=33) :: header - INTEGER :: i, j, nkp, nn - INTEGER :: chk_unit=124 - INTEGER :: num_exclude_bands, nntot - INTEGER, ALLOCATABLE :: exclude_bands(:) - LOGICAL :: exst - LOGICAL :: checkpoint - REAL(DP) :: at_(3,3), bg_(3,3) - REAL(DP), ALLOCATABLE :: kpt_latt(:,:) - REAL(DP), ALLOCATABLE :: centers(:,:) - REAL(DP), ALLOCATABLE :: spreads(:) - REAL(DP) :: omega_invariant - COMPLEX(DP), ALLOCATABLE :: m_mat(:,:,:,:) - ! - ! - ! - IF ( ionode ) THEN - ! - INQUIRE( FILE=trim(seedname)//'.chk', EXIST=exst ) - IF ( .not. exst ) CALL errore( 'read_wannier_chk', 'chk file not found', 1 ) - ! - OPEN( UNIT=chk_unit, FILE=trim(seedname)//'.chk', STATUS='old', FORM='unformatted' ) - ! - READ( chk_unit ) header ! date and time - READ( chk_unit ) num_bands ! number of bands - READ( chk_unit ) num_exclude_bands ! number of excluded bands - ! - IF ( num_exclude_bands .lt. 0 .or. num_exclude_bands .ne. (nbnd - num_bands) ) & - CALL errore( 'read_wannier_chk', 'Invalid value for num_exclude_bands', & - num_exclude_bands ) - ! - ENDIF - ! - CALL mp_bcast( num_bands, ionode_id, intra_image_comm ) - CALL mp_bcast( num_exclude_bands, ionode_id, intra_image_comm ) - ! - ALLOCATE( exclude_bands(num_exclude_bands) ) - ALLOCATE( excluded_band(nbnd) ) - ! - IF ( ionode ) THEN - ! - READ( chk_unit ) ( exclude_bands(i), i=1,num_exclude_bands ) ! list of excluded bands - excluded_band(:) = .false. - DO i = 1, num_exclude_bands - excluded_band( exclude_bands(i) ) = .true. - ENDDO - ! - READ( chk_unit ) (( at_(i,j), i=1,3 ), j=1,3 ) ! prim real latt vectors - READ( chk_unit ) (( bg_(i,j), i=1,3 ), j=1,3 ) ! prim recip latt vectors - READ( chk_unit ) num_kpts ! num of k-points - ! - IF ( nspin == 2 ) THEN - IF ( num_kpts .ne. nkstot/2 ) & - CALL errore( 'read_wannier_chk', 'Invalid value for num_kpts', num_kpts ) - ELSE - IF ( num_kpts .ne. nkstot ) & - CALL errore( 'read_wannier_chk', 'Invalid value for num_kpts', num_kpts ) - ENDIF - ! - READ( chk_unit ) ( kgrid(i), i=1,3 ) ! MP grid - ! - ENDIF - ! - CALL mp_bcast( excluded_band, ionode_id, intra_image_comm ) - CALL mp_bcast( num_kpts, ionode_id, intra_image_comm ) - CALL mp_bcast( kgrid, ionode_id, intra_image_comm ) - ! - ALLOCATE( kpt_latt(3,num_kpts) ) - ! - IF ( ionode ) THEN - ! - READ( chk_unit ) (( kpt_latt(i,nkp), i=1,3 ), nkp=1,num_kpts ) - READ( chk_unit ) nntot ! nntot - READ( chk_unit ) num_wann ! num of WFs - READ( chk_unit ) checkpoint ! checkpoint - READ( chk_unit ) have_disentangled ! .true. if disentanglement has been performed - ! - ENDIF - ! - CALL mp_bcast( num_wann, ionode_id, intra_image_comm ) - CALL mp_bcast( have_disentangled, ionode_id, intra_image_comm ) - ! - IF ( have_disentangled ) THEN - ! - ALLOCATE( lwindow(num_bands,num_kpts) ) - ALLOCATE( ndimwin(num_kpts) ) - ALLOCATE( u_mat_opt(num_bands,num_wann,num_kpts) ) - ! - IF ( ionode ) THEN - ! - READ( chk_unit ) omega_invariant - READ( chk_unit ) (( lwindow(i,nkp), i=1,num_bands ), nkp=1,num_kpts ) - READ( chk_unit ) ( ndimwin(nkp), nkp=1,num_kpts ) - READ( chk_unit ) ((( u_mat_opt(i,j,nkp), i=1,num_bands ), & ! optimal U-matrix - j=1,num_wann ), & - nkp=1,num_kpts ) - ! - ENDIF - ! - CALL mp_bcast( lwindow, ionode_id, intra_image_comm ) - CALL mp_bcast( ndimwin, ionode_id, intra_image_comm ) - CALL mp_bcast( u_mat_opt, ionode_id, intra_image_comm ) - ! - ELSE - ! - IF ( num_wann .ne. num_bands ) & - CALL errore( 'read_wannier_chk', 'mismatch between num_bands and num_wann', & - num_bands-num_wann ) - ! - ENDIF - ! - ALLOCATE( u_mat(num_wann,num_wann,num_kpts) ) - ! - IF ( ionode ) THEN - ! - READ ( chk_unit ) ((( u_mat(i,j,nkp), i=1,num_wann ), & ! U-matrix - j=1,num_wann ), & - nkp=1,num_kpts ) - ! - CALL check_u_unitary ! checks u_mat is unitary - ! - ALLOCATE( m_mat(num_wann,num_wann,nntot,num_kpts) ) - ALLOCATE( centers(3,num_wann) ) ! Wannier centers - ALLOCATE( spreads(num_wann) ) ! Wannier spreads - ! - READ( chk_unit ) (((( m_mat(i,j,nn,nkp), i=1,num_wann ), & - j=1,num_wann ), & - nn=1,nntot ), & - nkp=1,num_kpts ) - ! - READ( chk_unit ) (( centers(i,j), i=1,3 ), j=1,num_wann ) - READ( chk_unit ) ( spreads(i), i=1,num_wann ) - ! - CLOSE( chk_unit ) - ! - ENDIF - ! - CALL mp_bcast( u_mat, ionode_id, intra_image_comm ) - ! - ! - END SUBROUTINE read_wannier_chk - ! - ! - !--------------------------------------------------------------------- - SUBROUTINE check_u_unitary - !------------------------------------------------------------------- - ! - ! ... check that u_mat is unitary - ! - USE constants, ONLY : eps8 - ! - ! - IMPLICIT NONE - ! - INTEGER :: nkp, i, j - COMPLEX(DP) :: uu_prod(num_wann,num_wann) - ! - ! - DO nkp = 1, num_kpts - ! - uu_prod = MATMUL( u_mat(:,:,nkp), CONJG(TRANSPOSE( u_mat(:,:,nkp) )) ) - ! - DO i = 1, num_wann - DO j = 1, num_wann - ! - IF ( i == j ) THEN - ! - IF ( ( ABS(DBLE( uu_prod(i,j) - 1 )) .ge. eps8 ) .or. & - ( ABS(AIMAG( uu_prod(i,j) )) .ge. eps8 ) ) & - CALL errore( 'read_wannier_chk', 'u_mat is not unitary', nkp ) - ! - ELSE - ! - IF ( ( ABS(DBLE( uu_prod(i,j) )) .ge. eps8 ) .or. & - ( ABS(AIMAG( uu_prod(i,j) )) .ge. eps8 ) ) & - CALL errore( 'read_wannier_chk', 'u_mat is not unitary', nkp ) - ! - ENDIF - ! - ENDDO - ENDDO - ! - ENDDO - ! - ! - END SUBROUTINE check_u_unitary - ! - ! -END MODULE read_wannier diff --git a/quantum_espresso/utils/src/scell_wfc.f90 b/quantum_espresso/utils/src/scell_wfc.f90 deleted file mode 100644 index ba99b7406..000000000 --- a/quantum_espresso/utils/src/scell_wfc.f90 +++ /dev/null @@ -1,193 +0,0 @@ -! -! Copyright (C) 2003-2013 Quantum ESPRESSO and Wannier90 groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -! Written by Riccardo De Gennaro, EPFL (Sept 2020). -! -! -!----------------------------------------------------------------------- -MODULE scell_wfc - !--------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - USE fft_support, ONLY : good_fft_dimension - USE fft_types, ONLY : fft_type_descriptor - ! - ! - IMPLICIT NONE - ! - PRIVATE - ! - PUBLIC :: extend_wfc, bcast_psic - ! - CONTAINS - ! - !--------------------------------------------------------------------- - SUBROUTINE extend_wfc( psic, psicx, dfftx, kvec ) - !------------------------------------------------------------------- - ! - ! ... Here we extend in real space the periodic part of the Bloch - ! ... functions from the PW unit cell to the whole extension of - ! ... BVK boundary conditions (supercell). - ! - ! ... psic : input wfc defined on the unit cell - ! ... psicx : output wfc extended to the supercell - ! ... dfftx : fft descriptor of the supercell - ! - USE mp, ONLY : mp_sum - USE mp_bands, ONLY : intra_bgrp_comm - USE fft_base, ONLY : dffts - USE cell_base, ONLY : at - USE constants, ONLY : eps8, tpi - ! - ! - IMPLICIT NONE - ! - COMPLEX(DP), INTENT(IN) :: psic(:) ! input pcell wfc - COMPLEX(DP), INTENT(OUT) :: psicx(:) ! output supercell wfc - TYPE( fft_type_descriptor ) :: dfftx ! fft descriptor for the supercell - REAL(DP), INTENT(IN) :: kvec(3) ! k-vector for the phase factor - ! - COMPLEX(DP), ALLOCATABLE :: psicg(:) ! global pcell wfc - COMPLEX(DP) :: phase ! phase factor e^(ikr) - INTEGER :: nnrg - INTEGER :: i, j, k, ir, ir_end, idx, j0, k0 - INTEGER :: ip, jp, kp - REAL(DP) :: r(3) - REAL(DP) :: dot_prod - ! - ! - ! ... broadcast the unit cell wfc to all the procs - ! - nnrg = dffts%nnr - CALL mp_sum( nnrg, intra_bgrp_comm ) - ALLOCATE( psicg(nnrg) ) - CALL bcast_psic( psic, psicg, dffts ) - ! - ! -#if defined (__MPI) - j0 = dfftx%my_i0r2p - k0 = dfftx%my_i0r3p - IF( dfftx%nr1x == 0 ) dfftx%nr1x = good_fft_dimension( dfftx%nr1 ) - ir_end = MIN( dfftx%nnr, dfftx%nr1x*dfftx%my_nr2p*dfftx%my_nr3p ) -#else - j0 = 0 - k0 = 0 - ir_end = dfftx%nnr -#endif - ! - ! - DO ir = 1, ir_end - ! - ! ... three dimensional indexes - ! - idx = ir - 1 - k = idx / ( dfftx%nr1x * dfftx%my_nr2p ) - idx = idx - ( dfftx%nr1x * dfftx%my_nr2p ) * k - k = k + k0 - IF ( k .GE. dfftx%nr3 ) CYCLE - j = idx / dfftx%nr1x - idx = idx - dfftx%nr1x * j - j = j + j0 - IF ( j .GE. dfftx%nr2 ) CYCLE - i = idx - IF ( i .GE. dfftx%nr1 ) CYCLE - ! - ! ... ip, jp and kp represent the indexes folded into the - ! ... reference unit cell - ! - ip = MOD( i, dffts%nr1 ) - jp = MOD( j, dffts%nr2 ) - kp = MOD( k, dffts%nr3 ) - ! - psicx(ir) = psicg( ip + jp*dffts%nr1x + kp*dffts%nr1x*dffts%my_nr2p + 1 ) - ! - ! - ! ... calculate the phase factor e^(ikr) and applies it to psicx - ! - r(1) = DBLE(i) / dffts%nr1 - r(2) = DBLE(j) / dffts%nr2 - r(3) = DBLE(k) / dffts%nr3 - ! - CALL cryst_to_cart( 1, r, at, 1 ) - ! - dot_prod = tpi * SUM( kvec(:) * r(:) ) - phase = CMPLX( COS(dot_prod), SIN(dot_prod), KIND=DP ) - psicx(ir) = phase * psicx(ir) - ! - ENDDO - ! - ! - END SUBROUTINE extend_wfc - ! - ! - !--------------------------------------------------------------------- - SUBROUTINE bcast_psic( psic, psicg, dfft ) - !------------------------------------------------------------------- - ! - ! ... This routine broadcasts the local wavefunction (psic) - ! ... to all the procs into a global variable psicg indexed - ! ... following the global ordering of the points in the - ! ... FFT grid - ! - USE mp, ONLY : mp_sum - USE mp_bands, ONLY : intra_bgrp_comm - ! - ! - IMPLICIT NONE - ! - COMPLEX(DP), INTENT(IN) :: psic(:) - COMPLEX(DP), INTENT(OUT) :: psicg(:) - TYPE( fft_type_descriptor ) :: dfft - ! - INTEGER :: i, j, k, ir, ir_end, idx, j0, k0, irg - ! - ! - psicg(:) = ( 0.D0, 0.D0 ) - ! -#if defined (__MPI) - j0 = dfft%my_i0r2p - k0 = dfft%my_i0r3p - IF( dfft%nr1x == 0 ) dfft%nr1x = good_fft_dimension( dfft%nr1 ) - ir_end = MIN( dfft%nnr, dfft%nr1x*dfft%my_nr2p*dfft%my_nr3p ) -#else - j0 = 0 - k0 = 0 - ir_end = dfft%nnr -#endif - ! - ! - DO ir = 1, ir_end - ! - ! ... three dimensional indexes - ! - idx = ir - 1 - k = idx / ( dfft%nr1x * dfft%my_nr2p ) - idx = idx - ( dfft%nr1x * dfft%my_nr2p ) * k - k = k + k0 - IF ( k .GE. dfft%nr3 ) CYCLE - j = idx / dfft%nr1x - idx = idx - dfft%nr1x * j - j = j + j0 - IF ( j .GE. dfft%nr2 ) CYCLE - i = idx - IF ( i .GE. dfft%nr1 ) CYCLE - ! - ! ... defining global index and saving psicg - ! - irg = i + j*dfft%nr1x + k*dfft%nr1x*dfft%my_nr2p + 1 - psicg(irg) = psic(ir) - ! - ENDDO - ! - CALL mp_sum( psicg, intra_bgrp_comm ) - ! - ! - END SUBROUTINE bcast_psic - ! - ! -END MODULE scell_wfc diff --git a/quantum_espresso/utils/src/wann2kcp.f90 b/quantum_espresso/utils/src/wann2kcp.f90 deleted file mode 100644 index 30ec3181c..000000000 --- a/quantum_espresso/utils/src/wann2kcp.f90 +++ /dev/null @@ -1,788 +0,0 @@ -! -! Copyright (C) 2003-2013 Quantum ESPRESSO and Wannier90 groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -!------------------------------------------------------------------------ -PROGRAM wann2kcp - !------------------------------------------------------------------------ - ! - ! - USE io_global, ONLY : stdout, ionode, ionode_id - USE mp_global, ONLY : mp_startup - USE mp_pools, ONLY : npool - USE mp_bands, ONLY : nbgrp - USE mp, ONLY : mp_bcast - USE mp_world, ONLY : world_comm - USE cell_base, ONLY : at, bg - USE lsda_mod, ONLY : nspin, isk - USE klist, ONLY : nkstot, xk - USE io_files, ONLY : prefix, tmp_dir - USE noncollin_module, ONLY : noncolin - USE control_flags, ONLY : gamma_only - USE environment, ONLY : environment_start, environment_end - USE wannier2kcp, ONLY : wan2odd - USE plot_wan2odd, ONLY : plot_wann - USE wannier - ! - IMPLICIT NONE - ! - CHARACTER(LEN=256), EXTERNAL :: trimcheck - ! - INTEGER :: ios - CHARACTER(LEN=4) :: spin_component - CHARACTER(LEN=256) :: outdir - ! - NAMELIST / inputpp / outdir, prefix, seedname, wan_mode, & - spin_component, gamma_trick, print_rho, wannier_plot, wannier_plot_list - ! - ! initialise environment - ! -#if defined( __MPI ) - CALL mp_startup( ) -#endif - ! - CALL environment_start( 'WANN2KCP' ) - ! - CALL start_clock( 'init_wann2kcp' ) - ! - ! Read input on i/o node and broadcast to the rest - ! - ios = 0 - IF ( ionode ) THEN - ! - ! Check to see if we are reading from a file - ! - CALL input_from_file( ) - ! - ! set default values for variables in namelist - ! - CALL get_environment_variable( 'ESPRESSO_TMPDIR', outdir ) - IF ( trim(outdir) == ' ' ) outdir = './' - prefix = ' ' - seedname = 'wannier' - wan_mode = 'wannier2kcp' - spin_component = 'none' - gamma_trick = .false. - print_rho = .false. - wannier_plot = .false. - wannier_plot_list = 'all' - ! - ! Reading the namelist inputpp - ! - READ( 5, inputpp, iostat=ios ) - ! - ! Check of namelist variables - ! - tmp_dir = trimcheck( outdir ) - ! - ENDIF - ! - CALL mp_bcast( ios, ionode_id, world_comm ) - IF ( ios /= 0 ) CALL errore( 'wann2kcp', 'reading inputpp namelist', abs( ios ) ) - ! - ! Broadcast input variable to all nodes - ! - CALL mp_bcast( outdir, ionode_id, world_comm ) - CALL mp_bcast( tmp_dir, ionode_id, world_comm ) - CALL mp_bcast( prefix, ionode_id, world_comm ) - CALL mp_bcast( seedname, ionode_id, world_comm ) - CALL mp_bcast( wan_mode, ionode_id, world_comm ) - CALL mp_bcast( spin_component, ionode_id, world_comm ) - CALL mp_bcast( gamma_trick, ionode_id, world_comm ) - CALL mp_bcast( print_rho, ionode_id, world_comm ) - CALL mp_bcast( wannier_plot, ionode_id, world_comm ) - CALL mp_bcast( wannier_plot_list, ionode_id, world_comm ) - ! - ! Check: kpoint distribution with pools not implemented - ! - IF ( npool > 1 ) CALL errore( 'wann2kcp', 'pools not implemented', npool ) - ! - ! Check: bands distribution not implemented - ! - IF ( nbgrp > 1 ) CALL errore( 'wann2kcp', 'bands (-nb) not implemented', nbgrp ) - ! - ! Now allocate space for pwscf variables, read and check them. - ! - WRITE( stdout, * ) - WRITE( stdout, *) ' Reading nscf_save data' - CALL read_file( ) - WRITE( stdout, * ) - ! - SELECT CASE ( trim( spin_component ) ) - CASE ( 'up' ) - WRITE( stdout, * ) ' Spin CASE ( up )' - ispinw = 1 - ikstart = 1 - ikstop = nkstot / 2 - iknum = nkstot / 2 - CASE ( 'down' ) - WRITE( stdout, * ) 'Spin CASE ( down )' - ispinw = 2 - ikstart = nkstot / 2 + 1 - ikstop = nkstot - iknum = nkstot / 2 - CASE DEFAULT - WRITE( stdout, * ) ' Spin CASE ( default = unpolarized )' - ispinw = 0 - ikstart = 1 - ikstop = nkstot - iknum = nkstot - END SELECT - ! - CALL stop_clock( 'init_wann2kcp' ) - ! - WRITE( stdout, * ) - WRITE( stdout, * ) ' Mode is: ', wan_mode - WRITE( stdout, * ) - ! - IF ( wan_mode == 'wannier2kcp' ) THEN - ! - CALL read_nnkp( ) - CALL get_wannier_to_plot( ) - CALL openfil_pp( ) - ! - CALL wan2odd( ks_only = .false. ) - ! - IF ( wannier_plot ) CALL plot_wann( wann_to_plot, iknum, n_wannier ) - ! - IF ( ionode ) WRITE( stdout, * ) - CALL print_clock( 'init_wann2kcp' ) - CALL print_clock( 'wannier2kcp' ) - IF ( wannier_plot ) CALL print_clock( 'plot_wann' ) - CALL environment_end( 'WANN2KCP' ) - IF ( ionode ) WRITE( stdout, * ) - ! - CALL stop_pp( ) - ! - ELSE IF ( wan_mode == 'ks2kcp' ) THEN - ! - CALL openfil_pp( ) - CALL mp_grid_ks2kcp( ) - ! - CALL wan2odd( ks_only = .true. ) - ! - IF ( ionode ) WRITE( stdout, * ) - CALL print_clock( 'init_wannk2kcp' ) - CALL print_clock( 'ks2kcp' ) - CALL environment_end( 'WANN2KCP' ) - IF ( ionode ) WRITE( stdout, * ) - ! - CALL stop_pp( ) - ! - ENDIF - ! - ! -END PROGRAM wann2kcp -! -! -!------------------------------------------------------------------------- -SUBROUTINE find_mp_grid( ) - !----------------------------------------------------------------------- - ! - USE constants, ONLY : eps8 - USE io_global, ONLY : stdout - USE kinds, ONLY : DP - USE wannier - - IMPLICIT NONE - - ! <<>> - INTEGER :: ik,ntemp,ii - real(DP) :: min_k,temp(3,iknum),mpg1 - - min_k=minval(kpt_latt(1,:)) - ii=0 - DO ik=1,iknum - IF (abs(kpt_latt(1,ik) - min_k) < eps8) THEN - ii=ii+1 - temp(:,ii)=kpt_latt(:,ik) - ENDIF - ENDDO - ntemp=ii - - min_k=minval(temp(2,1:ntemp)) - ii=0 - DO ik=1,ntemp - IF (abs(temp(2,ik) - min_k) < eps8) THEN - ii=ii+1 - ENDIF - ENDDO - mp_grid(3)=ii - - min_k=minval(temp(3,1:ntemp)) - ii=0 - DO ik=1,ntemp - IF (abs(temp(3,ik) - min_k) < eps8) THEN - ii=ii+1 - ENDIF - ENDDO - mp_grid(2)=ii - - IF ( (mp_grid(2)==0) .or. (mp_grid(3)==0) ) & - CALL errore('find_mp_grid',' one or more mp_grid dimensions is zero', 1) - - mpg1=iknum/(mp_grid(2)*mp_grid(3)) - - mp_grid(1) = nint(mpg1) - - WRITE(stdout,*) - WRITE(stdout,'(3(a,i3))') ' MP grid is ',mp_grid(1),' x',mp_grid(2),' x',mp_grid(3) - - IF (real(mp_grid(1),kind=DP)/=mpg1) & - CALL errore('find_mp_grid',' determining mp_grid failed', 1) - - RETURN -END SUBROUTINE find_mp_grid -!----------------------------------------------------------------------- -! -! -!------------------------------------------------------------------------- -SUBROUTINE read_nnkp( ) - !----------------------------------------------------------------------- - ! - USE io_global, ONLY : stdout, ionode, ionode_id - USE kinds, ONLY : DP - USE constants, ONLY : eps6, tpi, bohr => BOHR_RADIUS_ANGS - USE cell_base, ONLY : at, bg, alat - USE gvect, ONLY : g, gg - USE klist, ONLY : nkstot, xk - USE mp, ONLY : mp_bcast, mp_sum - USE mp_pools, ONLY : intra_pool_comm - USE mp_world, ONLY : world_comm - USE wvfct, ONLY : npwx, nbnd - USE noncollin_module, ONLY : noncolin - USE wannier - ! - IMPLICIT NONE - ! - INTEGER, EXTERNAL :: find_free_unit - ! - real(DP) :: g_(3), gg_ - INTEGER :: ik, ib, ig, ipol, iw, idum, indexb - INTEGER numk, i, j - INTEGER, ALLOCATABLE :: ig_check(:,:) - real(DP) :: xx(3), xnorm, znorm, coseno - LOGICAL :: have_nnkp,found - INTEGER :: tmp_auto ! vv: Needed for the selection of projections with SCDM - - IF (ionode) THEN ! Read nnkp file on ionode only - - INQUIRE(file=trim(seedname)//".nnkp",exist=have_nnkp) - IF(.not. have_nnkp) THEN - CALL errore( 'pw2wannier90', 'Could not find the file '& - &//trim(seedname)//'.nnkp', 1 ) - ENDIF - - iun_nnkp = find_free_unit() - OPEN (unit=iun_nnkp, file=trim(seedname)//".nnkp",form='formatted', status="old") - - ENDIF - - nnbx=0 - - ! check the information from *.nnkp with the nscf_save data - WRITE(stdout,*) ' Checking info from wannier.nnkp file' - WRITE(stdout,*) - - IF (ionode) THEN ! read from ionode only - - CALL scan_file_to('real_lattice',found) - if(.not.found) then - CALL errore( 'pw2wannier90', 'Could not find real_lattice block in '& - &//trim(seedname)//'.nnkp', 1 ) - endif - DO j=1,3 - READ(iun_nnkp,*) (rlatt(i,j),i=1,3) - DO i = 1,3 - rlatt(i,j) = rlatt(i,j)/(alat*bohr) - ENDDO - ENDDO - DO j=1,3 - DO i=1,3 - IF(abs(rlatt(i,j)-at(i,j))>eps6) THEN - WRITE(stdout,*) ' Something wrong! ' - WRITE(stdout,*) ' rlatt(i,j) =',rlatt(i,j), ' at(i,j)=',at(i,j) - CALL errore( 'pw2wannier90', 'Direct lattice mismatch', 3*j+i ) - ENDIF - ENDDO - ENDDO - WRITE(stdout,*) ' - Real lattice is ok' - - CALL scan_file_to('recip_lattice',found) - if(.not.found) then - CALL errore( 'pw2wannier90', 'Could not find recip_lattice block in '& - &//trim(seedname)//'.nnkp', 1 ) - endif - DO j=1,3 - READ(iun_nnkp,*) (glatt(i,j),i=1,3) - DO i = 1,3 - glatt(i,j) = (alat*bohr)*glatt(i,j)/tpi - ENDDO - ENDDO - DO j=1,3 - DO i=1,3 - IF(abs(glatt(i,j)-bg(i,j))>eps6) THEN - WRITE(stdout,*) ' Something wrong! ' - WRITE(stdout,*) ' glatt(i,j)=',glatt(i,j), ' bg(i,j)=',bg(i,j) - CALL errore( 'pw2wannier90', 'Reciprocal lattice mismatch', 3*j+i ) - ENDIF - ENDDO - ENDDO - WRITE(stdout,*) ' - Reciprocal lattice is ok' - - CALL scan_file_to('kpoints',found) - if(.not.found) then - CALL errore( 'pw2wannier90', 'Could not find kpoints block in '& - &//trim(seedname)//'.nnkp', 1 ) - endif - READ(iun_nnkp,*) numk - IF(numk/=iknum) THEN - WRITE(stdout,*) ' Something wrong! ' - WRITE(stdout,*) ' numk=',numk, ' iknum=',iknum - CALL errore( 'pw2wannier90', 'Wrong number of k-points', numk) - ENDIF - IF(regular_mesh) THEN - DO i=1,numk - READ(iun_nnkp,*) xx(1), xx(2), xx(3) - CALL cryst_to_cart( 1, xx, bg, 1 ) - IF(abs(xx(1)-xk(1,i))>eps6.or. & - abs(xx(2)-xk(2,i))>eps6.or. & - abs(xx(3)-xk(3,i))>eps6) THEN - WRITE(stdout,*) ' Something wrong! ' - WRITE(stdout,*) ' k-point ',i,' is wrong' - WRITE(stdout,*) xx(1), xx(2), xx(3) - WRITE(stdout,*) xk(1,i), xk(2,i), xk(3,i) - CALL errore( 'pw2wannier90', 'problems with k-points', i ) - ENDIF - ENDDO - ENDIF ! regular mesh check - WRITE(stdout,*) ' - K-points are ok' - - ENDIF ! ionode - - ! Broadcast - CALL mp_bcast(rlatt,ionode_id, world_comm) - CALL mp_bcast(glatt,ionode_id, world_comm) - - IF (ionode) THEN ! read from ionode only - if(noncolin) then - old_spinor_proj=.false. - CALL scan_file_to('spinor_projections',found) - if(.not.found) then - !try old style projections - CALL scan_file_to('projections',found) - if(found) then - old_spinor_proj=.true. - else - CALL errore( 'pw2wannier90', 'Could not find projections block in '& - &//trim(seedname)//'.nnkp', 1 ) - endif - end if - else - old_spinor_proj=.false. - CALL scan_file_to('projections',found) - if(.not.found) then - CALL errore( 'pw2wannier90', 'Could not find projections block in '& - &//trim(seedname)//'.nnkp', 1 ) - endif - endif - READ(iun_nnkp,*) n_proj - ENDIF - - ! Broadcast - CALL mp_bcast(n_proj,ionode_id, world_comm) - CALL mp_bcast(old_spinor_proj,ionode_id, world_comm) - - IF(old_spinor_proj)THEN - WRITE(stdout,'(//," ****** begin WARNING ****** ",/)') - WRITE(stdout,'(" The pw.x calculation was done with non-collinear spin ")') - WRITE(stdout,'(" but spinor = T was not specified in the wannier90 .win file!")') - WRITE(stdout,'(" Please set spinor = T and rerun wannier90.x -pp ")') -! WRITE(stdout,'(/," If you are trying to reuse an old nnkp file, you can remove ")') -! WRITE(stdout,'(" this check from pw2wannir90.f90 line 870, and recompile. ")') - WRITE(stdout,'(/," ****** end WARNING ****** ",//)') -! CALL errore("pw2wannier90","Spinorbit without spinor=T",1) - ENDIF - - ! It is not clear if the next instruction is required or not, it probably depend - ! on the version of wannier90 that was used to generate the nnkp file: - IF(old_spinor_proj) THEN - n_wannier=n_proj*2 - ELSE - n_wannier=n_proj - ENDIF - - ALLOCATE( center_w(3,n_proj), alpha_w(n_proj), & - l_w(n_proj), mr_w(n_proj), r_w(n_proj), & - zaxis(3,n_proj), xaxis(3,n_proj) ) - if(noncolin.and..not.old_spinor_proj) then - ALLOCATE( spin_eig(n_proj),spin_qaxis(3,n_proj) ) - endif - - IF (ionode) THEN ! read from ionode only - DO iw=1,n_proj - READ(iun_nnkp,*) (center_w(i,iw), i=1,3), l_w(iw), mr_w(iw), r_w(iw) - READ(iun_nnkp,*) (zaxis(i,iw),i=1,3),(xaxis(i,iw),i=1,3),alpha_w(iw) - xnorm = sqrt(xaxis(1,iw)*xaxis(1,iw) + xaxis(2,iw)*xaxis(2,iw) + & - xaxis(3,iw)*xaxis(3,iw)) - IF (xnorm < eps6) CALL errore ('read_nnkp',' |xaxis| < eps ',1) - znorm = sqrt(zaxis(1,iw)*zaxis(1,iw) + zaxis(2,iw)*zaxis(2,iw) + & - zaxis(3,iw)*zaxis(3,iw)) - IF (znorm < eps6) CALL errore ('read_nnkp',' |zaxis| < eps ',1) - coseno = (xaxis(1,iw)*zaxis(1,iw) + xaxis(2,iw)*zaxis(2,iw) + & - xaxis(3,iw)*zaxis(3,iw))/xnorm/znorm - IF (abs(coseno) > eps6) & - CALL errore('read_nnkp',' xaxis and zaxis are not orthogonal !',1) - IF (alpha_w(iw) < eps6) & - CALL errore('read_nnkp',' zona value must be positive', 1) - ! convert wannier center in cartesian coordinates (in unit of alat) - CALL cryst_to_cart( 1, center_w(:,iw), at, 1 ) - if(noncolin.and..not.old_spinor_proj) then - READ(iun_nnkp,*) spin_eig(iw),(spin_qaxis(i,iw),i=1,3) - xnorm = sqrt(spin_qaxis(1,iw)*spin_qaxis(1,iw) + spin_qaxis(2,iw)*spin_qaxis(2,iw) + & - spin_qaxis(3,iw)*spin_qaxis(3,iw)) - IF (xnorm < eps6) CALL errore ('read_nnkp',' |xaxis| < eps ',1) - spin_qaxis(:,iw)=spin_qaxis(:,iw)/xnorm - endif - ENDDO - ENDIF - - ! automatic projections - IF (ionode) THEN - CALL scan_file_to('auto_projections',found) - IF (found) THEN - READ (iun_nnkp, *) n_wannier - READ (iun_nnkp, *) tmp_auto - - IF (scdm_proj) THEN - IF (n_proj > 0) THEN - WRITE(stdout,'(//, " ****** begin Error message ******",/)') - WRITE(stdout,'(/," Found a projection block, an auto_projections block",/)') - WRITE(stdout,'(/," and scdm_proj = T in the input file. These three options are inconsistent.",/)') - WRITE(stdout,'(/," Please refer to the Wannier90 User guide for correct use of these flags.",/)') - WRITE(stdout,'(/, " ****** end Error message ******",//)') - CALL errore( 'pw2wannier90', 'Inconsistent options for projections.', 1 ) - ELSE - IF (tmp_auto /= 0) CALL errore( 'pw2wannier90', 'Second entry in auto_projections block is not 0. ' // & - 'See Wannier90 User Guide in the auto_projections section for clarifications.', 1 ) - ENDIF - ELSE - ! Fire an error whether or not a projections block is found - CALL errore( 'pw2wannier90', 'scdm_proj = F but found an auto_projections block in '& - &//trim(seedname)//'.nnkp', 1 ) - ENDIF - ELSE - IF (scdm_proj) THEN - ! Fire an error whether or not a projections block is found - CALL errore( 'pw2wannier90', 'scdm_proj = T but cannot find an auto_projections block in '& - &//trim(seedname)//'.nnkp', 1 ) - ENDIF - ENDIF - ENDIF - - ! Broadcast - CALL mp_bcast(n_wannier,ionode_id, world_comm) - CALL mp_bcast(center_w,ionode_id, world_comm) - CALL mp_bcast(l_w,ionode_id, world_comm) - CALL mp_bcast(mr_w,ionode_id, world_comm) - CALL mp_bcast(r_w,ionode_id, world_comm) - CALL mp_bcast(zaxis,ionode_id, world_comm) - CALL mp_bcast(xaxis,ionode_id, world_comm) - CALL mp_bcast(alpha_w,ionode_id, world_comm) - if(noncolin.and..not.old_spinor_proj) then - CALL mp_bcast(spin_eig,ionode_id, world_comm) - CALL mp_bcast(spin_qaxis,ionode_id, world_comm) - end if - - WRITE(stdout,'(" - Number of wannier functions is ok (",i3,")")') n_wannier - - IF (.not. scdm_proj) WRITE(stdout,*) ' - All guiding functions are given ' - ! - WRITE(stdout,*) - WRITE(stdout,*) 'Projections:' - DO iw=1,n_proj - WRITE(stdout,'(3f12.6,3i3,f12.6)') & - center_w(1:3,iw),l_w(iw),mr_w(iw),r_w(iw),alpha_w(iw) - ENDDO - - IF (ionode) THEN ! read from ionode only - CALL scan_file_to('nnkpts',found) - if(.not.found) then - CALL errore( 'pw2wannier90', 'Could not find nnkpts block in '& - &//trim(seedname)//'.nnkp', 1 ) - endif - READ (iun_nnkp,*) nnb - ENDIF - - ! Broadcast - CALL mp_bcast(nnb,ionode_id, world_comm) - ! - nnbx = max (nnbx, nnb ) - ! - ALLOCATE ( kpb(iknum,nnbx), g_kpb(3,iknum,nnbx),& - ig_(iknum,nnbx), ig_check(iknum,nnbx) ) - ALLOCATE( zerophase(iknum,nnbx) ) - zerophase = .false. - - ! read data about neighbours - WRITE(stdout,*) - WRITE(stdout,*) ' Reading data about k-point neighbours ' - WRITE(stdout,*) - - IF (ionode) THEN - DO ik=1, iknum - DO ib = 1, nnb - READ(iun_nnkp,*) idum, kpb(ik,ib), (g_kpb(ipol,ik,ib), ipol =1,3) - ENDDO - ENDDO - ENDIF - - ! Broadcast - CALL mp_bcast(kpb,ionode_id, world_comm) - CALL mp_bcast(g_kpb,ionode_id, world_comm) - - DO ik=1, iknum - DO ib = 1, nnb - IF ( (g_kpb(1,ik,ib).eq.0) .and. & - (g_kpb(2,ik,ib).eq.0) .and. & - (g_kpb(3,ik,ib).eq.0) ) zerophase(ik,ib) = .true. - g_(:) = REAL( g_kpb(:,ik,ib) ) - CALL cryst_to_cart (1, g_, bg, 1) - gg_ = g_(1)*g_(1) + g_(2)*g_(2) + g_(3)*g_(3) - ig_(ik,ib) = 0 - ig = 1 - DO WHILE (gg(ig) <= gg_ + eps6) - IF ( (abs(g(1,ig)-g_(1)) < eps6) .and. & - (abs(g(2,ig)-g_(2)) < eps6) .and. & - (abs(g(3,ig)-g_(3)) < eps6) ) ig_(ik,ib) = ig - ig= ig +1 - ENDDO - ENDDO - ENDDO - ig_check(:,:) = ig_(:,:) - CALL mp_sum( ig_check, intra_pool_comm ) - DO ik=1, iknum - DO ib = 1, nnb - IF (ig_check(ik,ib) ==0) & - CALL errore('read_nnkp', & - ' g_kpb vector is not in the list of Gs', 100*ik+ib ) - ENDDO - ENDDO - DEALLOCATE (ig_check) - - WRITE(stdout,*) ' All neighbours are found ' - WRITE(stdout,*) - - ALLOCATE( excluded_band(nbnd) ) - - IF (ionode) THEN ! read from ionode only - CALL scan_file_to('exclude_bands',found) - if(.not.found) then - CALL errore( 'pw2wannier90', 'Could not find exclude_bands block in '& - &//trim(seedname)//'.nnkp', 1 ) - endif - READ (iun_nnkp,*) nexband - excluded_band(1:nbnd)=.false. - DO i=1,nexband - READ(iun_nnkp,*) indexb - IF (indexb<1 .or. indexb>nbnd) & - CALL errore('read_nnkp',' wrong excluded band index ', 1) - excluded_band(indexb)=.true. - ENDDO - ENDIF - num_bands=nbnd-nexband - - ! Broadcast - CALL mp_bcast(nexband,ionode_id, world_comm) - CALL mp_bcast(excluded_band,ionode_id, world_comm) - CALL mp_bcast(num_bands,ionode_id, world_comm) - - IF (ionode) CLOSE (iun_nnkp) ! ionode only - - RETURN -END SUBROUTINE read_nnkp -! -!----------------------------------------------------------------------- -SUBROUTINE scan_file_to( keyword, found ) - !----------------------------------------------------------------------- - ! - USE wannier, ONLY :iun_nnkp - USE io_global, ONLY : stdout - IMPLICIT NONE - CHARACTER(len=*), intent(in) :: keyword - logical, intent(out) :: found - CHARACTER(len=80) :: line1, line2 -! -! by uncommenting the following line the file scan restarts every time -! from the beginning thus making the reading independent on the order -! of data-blocks -! rewind (iun_nnkp) -! -10 CONTINUE - READ(iun_nnkp,*,end=20) line1, line2 - IF(line1/='begin') GOTO 10 - IF(line2/=keyword) GOTO 10 - found=.true. - RETURN -20 found=.false. - rewind (iun_nnkp) - -END SUBROUTINE scan_file_to -! -! -!------------------------------------------------------------------------- -SUBROUTINE get_wannier_to_plot( ) - !----------------------------------------------------------------------- - ! - ! ... gets the list of Wannier functions to plot - ! - USE kinds, ONLY : DP - USE wannier, ONLY : n_wannier, iknum, wannier_plot_list, wann_to_plot - ! - IMPLICIT NONE - ! - CHARACTER(LEN=1), EXTERNAL :: capital - ! - CHARACTER(LEN=10), PARAMETER :: c_digit = '0123456789' - CHARACTER(LEN=2), PARAMETER :: c_range = '-:' - CHARACTER(LEN=3), PARAMETER :: c_sep = ' ,;' - CHARACTER(LEN=5), PARAMETER :: c_punc = ' ,:-:' - CHARACTER(LEN=5), PARAMETER :: c_punc_nospace = ',:-:' - CHARACTER(LEN=15), PARAMETER :: allchar = '0123456789 ,:-:' - ! - CHARACTER(LEN=255) :: c_wlist, c_iwann - INTEGER :: i, check, iwann, range_size, counter - INTEGER :: i_punc, i_digit - INTEGER :: nwannx - INTEGER, ALLOCATABLE :: aux(:) - ! - ! - nwannx = n_wannier * iknum ! num WFs in the supercell - ALLOCATE( aux(nwannx) ) - ! - c_wlist = wannier_plot_list - ! - IF ( len_trim(c_wlist) == 0 ) & - CALL errore( 'get_wannier_to_plot', 'wannier_plot_list is blank', 1 ) - ! - DO i = 1, len_trim(c_wlist) - c_wlist(i:i) = capital(c_wlist(i:i)) - ENDDO - ! - IF ( trim(c_wlist) == 'ALL' ) THEN - ALLOCATE( wann_to_plot(nwannx) ) - DO i = 1, nwannx - wann_to_plot(i) = i - ENDDO - ! - RETURN - ELSE - check = VERIFY( c_wlist, allchar ) - IF ( check .ne. 0 ) CALL errore( 'get_wannier_to_plot', & - 'Unrecognised character in wannier_plot_list', check ) - ENDIF - ! - c_wlist = ADJUSTL( c_wlist ) - ! - IF ( SCAN( c_wlist, c_punc ) == 0 ) THEN - READ( c_wlist, *, ERR=101, END=101 ) iwann - IF ( iwann > nwannx ) & - CALL errore( 'get_wannier_to_plot', 'wannier_plot_list out of range', iwann ) - ! - ALLOCATE( wann_to_plot(1) ) - wann_to_plot(1) = iwann - ! - RETURN - ENDIF - ! - ! - counter = 0 - DO - i_punc = SCAN( c_wlist, c_punc ) - ! - IF ( i_punc == 1 ) & - CALL errore( 'get_wannier_to_plot', 'Error parsing keyword wannier_plot_list', 2 ) - ! - counter = counter + 1 - c_iwann = c_wlist(1:i_punc-1) - READ( c_iwann, *, ERR=101, END=101 ) iwann - aux(counter) = iwann - IF ( iwann > nwannx ) & - CALL errore( 'get_wannier_to_plot', 'wannier_plot_list out of range', iwann ) - ! - c_wlist = ADJUSTL( c_wlist(i_punc:) ) - ! - IF ( SCAN( c_wlist, c_range ) == 1 ) THEN - i_digit = SCAN( c_wlist, c_digit ) - IF ( SCAN( ADJUSTL( c_wlist(2:i_digit) ), c_punc_nospace ) /= 0 ) & - CALL errore( 'get_wannier_to_plot', 'Error parsing keyword wannier_plot_list', 3 ) - c_wlist = ADJUSTL( c_wlist(i_digit:) ) - i_punc = SCAN( c_wlist, c_punc ) - ! - c_iwann = c_wlist(1:i_punc-1) - READ( c_iwann, *, ERR=101, END=101 ) iwann - IF ( iwann > nwannx ) & - CALL errore( 'get_wannier_to_plot', 'wannier_plot_list out of range', iwann ) - ! - range_size = iwann - aux(counter) - IF ( range_size <= 0 ) CALL errore( 'get_wannier_to_plot', & - 'Error parsing keyword wannier_plot_list: incorrect range', 1) - ! - DO i = 1, range_size - counter = counter + 1 - aux(counter) = aux(counter-1) + 1 - ENDDO - ! - c_wlist = ADJUSTL( c_wlist(i_punc:) ) - ENDIF - ! - IF ( SCAN( c_wlist, c_sep ) == 1 ) c_wlist = ADJUSTL( c_wlist(2:) ) - IF ( SCAN( c_wlist, c_range ) == 1 ) & - CALL errore( 'get_wannier_to_plot', 'Error parsing keyword wannier_plot_list', 4 ) - ! - IF ( INDEX( c_wlist, ' ' ) == 1 ) EXIT - ENDDO - ! - ALLOCATE( wann_to_plot(counter) ) - wann_to_plot(:) = aux(1:counter) - ! - RETURN - ! -101 CALL errore( 'get_wannier_to_plot', 'Error parsing keyword wannier_plot_list', 1 ) - ! - ! -END SUBROUTINE get_wannier_to_plot -! -! -!---------------------------------------------------------------------------- -SUBROUTINE mp_grid_ks2kcp( ) - !--------------------------------------------------------------------------------- - ! - ! ... This routine generate mp_grid for the ks2kcp mode. - ! ... It is necessary to momentarily change the definition of - ! ... iknum in order to properly define mp_grid. - ! - USE wannier, ONLY : kpt_latt, iknum - USE lsda_mod, ONLY : nspin - USE cell_base, ONLY : at - USE klist, ONLY : xk - ! - ! - IMPLICIT NONE - ! - LOGICAL :: ks_only - ! - ! - iknum = iknum / nspin ! momentarily change the value of iknum (needed by find_mp_grid) - ALLOCATE( kpt_latt(3,iknum) ) - kpt_latt(:,1:iknum) = xk(:,1:iknum) - CALL cryst_to_cart( iknum, kpt_latt, at, -1 ) - CALL find_mp_grid( ) - iknum = iknum * nspin ! restore the initial value of iknum - ! - ! - END SUBROUTINE mp_grid_ks2kcp diff --git a/quantum_espresso/utils/src/wannier.f90 b/quantum_espresso/utils/src/wannier.f90 deleted file mode 100644 index 4b56ae058..000000000 --- a/quantum_espresso/utils/src/wannier.f90 +++ /dev/null @@ -1,56 +0,0 @@ -! -! Copyright (C) 2003-2013 Quantum ESPRESSO and Wannier90 groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -! Riccardo De Gennaro: module containing some env variables of wann2kcp -! -! -!------------------------------------------------------------------------ -MODULE wannier - ! - ! - USE kinds, ONLY : DP - ! - ! - INTEGER :: nnb ! #b - INTEGER, ALLOCATABLE :: kpb(:,:) ! k+b (ik,ib) - INTEGER, ALLOCATABLE :: g_kpb(:,:,:) ! G_k+b (ipol,ik,ib) - INTEGER, ALLOCATABLE :: ig_(:,:) ! G_k+b (ipol,ik,ib) - LOGICAL, ALLOCATABLE :: excluded_band(:) - INTEGER :: iun_nnkp, nnbx, nexband - INTEGER :: n_wannier ! number of WF - INTEGER :: n_proj ! number of projection - INTEGER :: ispinw, ikstart, ikstop, iknum - CHARACTER(LEN=15) :: wan_mode ! running mode - LOGICAL :: scdm_proj - LOGICAL :: regular_mesh = .true. - ! input data from nnkp file - REAL(DP), ALLOCATABLE :: center_w(:,:) ! center_w(3,n_wannier) - INTEGER, ALLOCATABLE :: spin_eig(:) - REAL(DP), ALLOCATABLE :: spin_qaxis(:,:) - INTEGER, ALLOCATABLE :: l_w(:), mr_w(:) ! l and mr of wannier (n_wannier) as from table 3.1,3.2 of spec. - INTEGER, ALLOCATABLE :: r_w(:) ! index of radial function (n_wannier) as from table 3.3 of spec. - REAL(DP), ALLOCATABLE :: xaxis(:,:),zaxis(:,:) ! xaxis and zaxis(3,n_wannier) - REAL(DP), ALLOCATABLE :: alpha_w(:) ! alpha_w(n_wannier) ( called zona in wannier spec) - ! - CHARACTER(len=256) :: seedname = 'wannier' ! prepended to file names in wannier90 - ! For implementation of wannier_lib - INTEGER :: mp_grid(3) ! dimensions of MP k-point grid - REAL(DP) :: rlatt(3,3),glatt(3,3) ! real and recip lattices (Cartesian co-ords, units of Angstrom) - REAL(DP), ALLOCATABLE :: kpt_latt(:,:) ! k-points in crystal co-ords. kpt_latt(3,iknum) - INTEGER :: num_bands ! number of bands left after exclusions - LOGICAL :: old_spinor_proj ! for compatability for nnkp files prior to W90v2.0 - LOGICAL,ALLOCATABLE :: zerophase(:,:) - ! wannier2kcp additional variables - LOGICAL :: wannier_plot - CHARACTER(LEN=255) :: wannier_plot_list - INTEGER, ALLOCATABLE :: wann_to_plot(:) - LOGICAL :: gamma_trick ! determines whether or not using SC real wfc (wannier2kcp wan_mode) - LOGICAL :: print_rho ! determines whether or not writing the supercell charge density to file - ! - ! -END MODULE wannier diff --git a/quantum_espresso/utils/src/wannier2kcp.f90 b/quantum_espresso/utils/src/wannier2kcp.f90 deleted file mode 100644 index 21b45ca7c..000000000 --- a/quantum_espresso/utils/src/wannier2kcp.f90 +++ /dev/null @@ -1,673 +0,0 @@ -! -! Copyright (C) 2003-2013 Quantum ESPRESSO and Wannier90 groups -! This file is distributed under the terms of the -! GNU General Public License. See the file `License' -! in the root directory of the present distribution, -! or http://www.gnu.org/copyleft/gpl.txt . -! -! -! Written by Riccardo De Gennaro, EPFL (Sept 2020). -! -! -!---------------------------------------------------------------------------- -MODULE wannier2kcp - !-------------------------------------------------------------------------- - ! - USE kinds, ONLY : DP - ! - ! - IMPLICIT NONE - ! - PRIVATE - ! - PUBLIC :: wan2odd - ! - INTEGER :: nwordwfcx ! record length for supercell wfcs - COMPLEX(DP), ALLOCATABLE :: evcx(:,:) - COMPLEX(DP), ALLOCATABLE :: evcx_dis(:,:) - COMPLEX(DP), ALLOCATABLE :: evcw(:) - COMPLEX(DP), ALLOCATABLE :: ewan(:,:) - COMPLEX(DP), ALLOCATABLE :: psicx(:) - COMPLEX(DP), ALLOCATABLE :: rhor(:,:), rhow(:,:) ! real space supercell density - COMPLEX(DP), ALLOCATABLE :: rhog(:,:), rhowg(:,:) ! G-space supercell density - ! - INTERFACE check_rho - MODULE PROCEDURE :: check_rho_single - MODULE PROCEDURE :: check_rho_double - END INTERFACE check_rho - ! - CONTAINS - ! - !----------------------------------------------------------------------------------- - SUBROUTINE wan2odd( ks_only ) - !--------------------------------------------------------------------------------- - ! - ! ... This routine: - ! - ! ... 1) reads the KS states u_nk(G) from PW and (if ks_only==.false.) - ! ... the rotation matrices U(k) from Wannier90 - ! - ! ... 2) Fourier transforms u_nk to real-space and extends them - ! ... to the supercell defined by the k-points sampling - ! - ! ... 3) (if ks_only==.false.) applies the matrices U(k) and realizes - ! ... the Wannier functions in G-space - ! - ! ... 4) Wannier/KS functions are finally written in a CP-readable - ! ... file - ! - ! ... NB: all the variables containing the keyword 'wan' (or similar) - ! ... refer to KS states when ks_only==.true. - ! - USE io_global, ONLY : stdout - USE io_files, ONLY : nwordwfc, iunwfc, restart_dir - USE io_base, ONLY : write_rhog - USE mp_pools, ONLY : my_pool_id - USE mp_bands, ONLY : my_bgrp_id, root_bgrp_id, & - root_bgrp, intra_bgrp_comm - USE wavefunctions, ONLY : evc, psic - USE fft_base, ONLY : dffts - USE fft_interfaces, ONLY : invfft, fwfft - USE buffers, ONLY : open_buffer, close_buffer, & - save_buffer, get_buffer - USE lsda_mod, ONLY : nspin - USE klist, ONLY : xk, ngk, igk_k, nelec - USE gvect, ONLY : ngm - USE wvfct, ONLY : wg, npwx, nbnd - USE cell_base, ONLY : tpiba, omega, at - USE control_flags, ONLY : gamma_only - USE constants, ONLY : tpi - USE noncollin_module, ONLY : npol - USE scell_wfc, ONLY : extend_wfc - USE fft_supercell, ONLY : dfftcp, setup_scell_fft, bg_cp, at_cp, omega_cp, & - gamma_only_x, npwxcp, ngmcp, mill_cp, ig_l2g_cp, & - iunwann, nwordwann, check_fft - USE cp_files, ONLY : write_wannier_cp - USE wannier, ONLY : seedname, ikstart, wannier_plot, gamma_trick, & - wan_mode, iknum, mp_grid, print_rho - USE read_wannier - ! - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(IN) :: ks_only - ! - CHARACTER(LEN=256) :: dirname - INTEGER :: ik, ikevc, ibnd, iw, ip - INTEGER :: i, j, k, ir, n, counter - INTEGER :: num_inc - INTEGER :: nks - INTEGER :: npw - INTEGER :: iunwfcx = 24 ! unit for supercell wfc file - INTEGER :: io_level = 1 - INTEGER :: is, iss - REAL(DP) :: kvec(3), rvec(3) - REAL(DP) :: dot_prod - REAL(DP) :: ratio - COMPLEX(DP) :: phase - LOGICAL :: exst, opnd - LOGICAL :: calc_rho=.true. - LOGICAL :: wf_is_cmplx - COMPLEX(DP), ALLOCATABLE :: rhog_(:,:) - ! - ! - CALL start_clock( TRIM(wan_mode) ) - ! - ! ... for spin-polarized calculations we deal with one spin-channel at the - ! ... time. The total density cannot be calculated - ! - IF ( nspin == 2 .and. .not. ks_only ) calc_rho = .false. - ! - IF ( .not. ks_only ) THEN - ! - CALL read_wannier_chk( ) - ! - ! ... if any non-occupied state is included the density is not calculated - ! ... NB: for spin-polarized calcs calc_rho is false, so nelec/2 is the actual - ! ... number of occupied bands) - ! - IF ( calc_rho .and. ANY(excluded_band(1:nelec/2)) ) calc_rho = .false. - ! - ELSE - ! - num_bands = nbnd - num_kpts = iknum / nspin - kgrid(:) = mp_grid(:) - ! - ENDIF - ! - gamma_only_x = gamma_trick - IF ( gamma_trick ) WRITE( stdout, 10 ) - CALL setup_scell_fft( ) - ! - CALL alloc_w2odd( ks_only, calc_rho ) - ! - IF ( .not. ks_only .and. have_disentangled ) & - ALLOCATE( evcx_dis(npwxcp*npol,MAXVAL(ndimwin)) ) - ! - IF ( .not. ks_only ) THEN - ! ... in the case of Wannier functions we always deal with - ! ... one spin component at the time - iss = 1 - ELSE - iss = nspin - ENDIF - ! - DO is = 1, iss - ! - ! ... open buffer for direct-access to the extended wavefunctions - ! - CALL open_buffer( iunwfcx, 'wfcx', nwordwfcx, io_level, exst ) - ! - ! ... loop to read the primitive cell wavefunctions and - ! ... extend them to the supercell - ! - DO ik = 1, num_kpts - ! - ikevc = ik + ikstart - 1 - IF ( ks_only ) ikevc = ikevc + ( is - 1 ) * num_kpts - CALL davcio( evc, 2*nwordwfc, iunwfc, ikevc, -1 ) - npw = ngk(ik) - kvec(:) = xk(:,ik) - ! - counter = 0 - ! - DO ibnd = 1, nbnd - ! - IF ( .not. ks_only .and. excluded_band(ibnd) ) CYCLE - ! - counter = counter + 1 - ! - psic(:) = ( 0.D0, 0.D0 ) - psicx(:) = ( 0.D0, 0.D0 ) - psic( dffts%nl(igk_k(1:npw,ik)) ) = evc(1:npw,ibnd) - IF( gamma_only ) psic( dffts%nlm(igk_k(1:npw,ik)) ) = CONJG(evc(1:npw,ibnd)) - CALL invfft( 'Wave', psic, dffts ) - ! - ! ... here we extend the wfc to the whole supercell - ! - ! ... NB: the routine extend_wfc applies also the phase factor - ! ... e^(ikr) so the output wfc (psicx) is a proper Bloch - ! ... function and not just its periodic part - ! - CALL extend_wfc( psic, psicx, dfftcp, kvec ) - ! - ! ... calculate the total density in the supercell - ! - IF ( calc_rho ) & - rhor(:,is) = rhor(:,is) + ( DBLE( psicx(:) )**2 + & - AIMAG( psicx(:) )**2 ) * wg(ibnd,ikevc) / omega - ! - CALL fwfft( 'Wave', psicx, dfftcp ) - evcx(1:npwxcp,counter) = psicx( dfftcp%nl(1:npwxcp) ) - ! - ENDDO ! ibnd - ! - IF ( counter .ne. num_bands ) & - CALL errore( 'wan2odd', 'wrong number of included bands', counter ) - ! - ! ... save the extended wavefunctions into the buffer - ! - CALL save_buffer( evcx, nwordwfcx, iunwfcx, ik ) - ! - ENDDO ! ik - ! - ! - IF ( calc_rho ) THEN - ! - rhog(:,is) = ( 0.D0, 0.D0 ) - CALL fwfft( 'Rho', rhor(:,is), dfftcp ) - rhog(1:ngmcp,is) = rhor( dfftcp%nl(1:ngmcp), is ) - ! - IF ( iss == 1 ) CALL check_rho( is, rhog(:,is) ) - ! - ENDIF - ! - ! - IF ( .not. ks_only ) THEN - ! - ! ... here the Wannier functions are realized - ! w_Rn(G) = sum_k e^(-ikR) sum_m U_mn(k)*psi_km(G) / Nk^(1/2) - ! - CALL open_buffer( iunwann, 'wann', nwordwann, io_level, exst ) - ! - ir = 0 - ! - DO i = 1, kgrid(1) - DO j = 1, kgrid(2) - DO k = 1, kgrid(3) - ! - ir = ir + 1 - ewan(:,:) = ( 0.D0, 0.D0 ) - ! - rvec(:) = (/ i-1, j-1, k-1 /) - CALL cryst_to_cart( 1, rvec, at, 1 ) - ! - DO iw = 1, num_wann - DO ik = 1, num_kpts - ! - ! ... phase factor e^(-ikR) - ! - kvec(:) = xk(:,ik) - dot_prod = tpi * SUM( kvec(:) * rvec(:) ) - phase = CMPLX( COS(dot_prod), -SIN(dot_prod), KIND=DP ) - ! - ! ... read the supercell-extended Bloch functions - ! - evcx(:,:) = ( 0.D0, 0.D0 ) - CALL get_buffer( evcx, nwordwfcx, iunwfcx, ik ) - ! - ! ... selecting disentangled bands - ! - IF ( have_disentangled ) THEN - ! - num_inc = ndimwin(ik) - counter = 0 - ! - DO n = 1, num_bands - IF ( lwindow(n,ik) ) THEN - counter = counter + 1 - evcx_dis(:,counter) = evcx(:,n) - ENDIF - ENDDO - ! - IF ( counter .ne. num_inc ) & - CALL errore( 'wan2odd', 'Wrong number of included bands & - in disentanglement', counter ) - ! - ENDIF - ! - ! ... calculate the Wannier function (ir,iw) - ! - DO ip = 1, num_wann - ! - ! ... applies disentanglement optimal matrix - ! - evcw(:) = ( 0.D0, 0.D0 ) - IF ( have_disentangled ) THEN - DO n = 1, num_inc - evcw(:) = evcw(:) + u_mat_opt(n,ip,ik) * evcx_dis(:,n) - ENDDO - ELSE - evcw(:) = evcx(:,ip) - ENDIF - ! - ewan(:,iw) = ewan(:,iw) + phase * u_mat(ip,iw,ik) * evcw(:) / SQRT(DBLE(num_kpts)) - ! - ENDDO - ! - ENDDO ! ik - ! - ! CALL check_complex_wfc( ewan(:,iw), wf_is_cmplx, ratio ) - ! ! - ! ! ... if gamma_only_x=.true. the Wannier functions must be real; - ! ! ... if one of the realized WFs is found to be complex then the - ! ! ... code will restart without using the gamma-trick (complex wfc) - ! ! - ! IF ( gamma_only_x .and. wf_is_cmplx ) THEN - ! ! - ! WRITE( stdout, 20 ) ir, iw - ! WRITE( stdout, 21 ) ratio - ! CALL errore( 'wan2odd', 'complex Wannier functions are incompatible with gamma_trick=.true.', 1 ) - ! ! - ! ENDIF - ! - ! ... recalculate the total density from the WFs - ! - IF ( calc_rho ) THEN - ! - psicx(:) = ( 0.D0, 0.D0 ) - psicx( dfftcp%nl(1:npwxcp) ) = ewan(1:npwxcp,iw) - IF( gamma_only_x ) psicx( dfftcp%nlm(1:npwxcp) ) = CONJG(ewan(1:npwxcp,iw)) - CALL invfft( 'Wave', psicx, dfftcp ) - rhow(:,is) = rhow(:,is) + DBLE( psicx(:) )**2 + AIMAG( psicx(:) )**2 - ! - ENDIF - ! - ENDDO ! iw - ! - CALL save_buffer( ewan, nwordwann, iunwann, ir ) - ! - ENDDO - ENDDO - ENDDO - ! - ! - CALL close_buffer( iunwfcx, 'delete' ) - ! - ! ... checks the consistency between the Wannier and Bloch - ! ... densities and write the G-space density to file - ! - IF ( calc_rho ) THEN - ! - rhowg(:,is) = ( 0.D0, 0.D0 ) - CALL fwfft( 'Rho', rhow(:,is), dfftcp ) - rhowg(1:ngmcp,is) = rhow( dfftcp%nl(1:ngmcp), is ) / omega_cp - IF ( nspin == 1 ) rhowg(:,is) = rhowg(:,is) * 2 !!! factor 2 for the other spin-component - CALL check_rho( is, rhowg(:,is), rhog(:,is) ) - ! - ENDIF - ! - ! ... write the WFs to CP-Koopmans-readable files - ! - CALL write_wannier_cp( iunwann, nwordwann, num_wann, is, ks_only ) - ! - IF ( .not. wannier_plot ) CALL close_buffer( iunwann, 'delete' ) - ! - ELSE - ! - ! ... write KS orbitals to CP-Koopmans-readable files - ! - CALL write_wannier_cp( iunwfcx, nwordwfcx, num_bands, is, ks_only, 'occ' ) - CALL write_wannier_cp( iunwfcx, nwordwfcx, num_bands, is, ks_only, 'emp' ) - ! - CALL close_buffer( iunwfcx, 'delete' ) - ! - ENDIF - ! - ENDDO ! is - ! - IF ( calc_rho ) THEN - ! - ALLOCATE( rhog_( size(rhog,1), size(rhog,2) ) ) - ! - IF ( iss == 1 ) THEN - ! - rhog_ = rhog - ! - ELSE - ! - CALL check_rho( rhog ) - ! - ! write rhog_ in the PW format: - ! - component 1 contains the total up+down density - ! - component 2 contains the magnetization (rho_up - rho_down) - rhog_(:,1) = rhog(:,1) + rhog(:,2) - rhog_(:,2) = rhog(:,1) - rhog(:,2) - ! - ENDIF - ! - ENDIF - ! - IF ( print_rho ) THEN - ! - IF ( .not. calc_rho ) & - CALL errore( 'wannier2kcp', 'Cannot write charge density when it is not calculated', 1 ) - ! - dirname = './' - IF ( my_pool_id == 0 .AND. my_bgrp_id == root_bgrp_id ) & - CALL write_rhog( TRIM(dirname) // "charge-density-x", & - root_bgrp, intra_bgrp_comm, & - bg_cp(:,1)*tpiba, bg_cp(:,2)*tpiba, bg_cp(:,3)*tpiba, & - gamma_only_x, mill_cp, ig_l2g_cp, rhog_(:,:) ) - ! - ENDIF - ! - CALL stop_clock( TRIM(wan_mode) ) - ! - ! - 10 FORMAT( /, 2X, 'WARNING: gamma_trick=.true. forces the Wannier functions to be real.', /, & - 11X, 'DO THIS WITH CAUTION !', / ) - 20 FORMAT( 5X, 'The Wannier function ( ', I4, ', ', I4, ' ) is found to be complex' ) - 21 FORMAT( 5X, 'Maximum Im/Re ratio = ', E15.8 ) - ! - ! - END SUBROUTINE wan2odd - ! - ! - !--------------------------------------------------------------------- - SUBROUTINE check_rho_single( ispin, rhog, rhogref ) - !------------------------------------------------------------------- - ! - ! ... SPIN UNPOLARISED CASE - ! - ! ... this routine performs some checks on the supercell total density: - ! ... 1) the total charge - ! ... 2) (if rhogref is present) it checks that rhog matches with rhogref - ! - USE mp, ONLY : mp_sum - USE mp_bands, ONLY : intra_bgrp_comm - USE klist, ONLY : nelec - USE scf, ONLY : rho - USE constants, ONLY : eps6 - USE fft_supercell, ONLY : gstart_cp, omega_cp, check_fft, ngmcp - USE read_wannier, ONLY : num_kpts - ! - ! - IMPLICIT NONE - ! - INTEGER, INTENT(IN) :: ispin - COMPLEX(DP), INTENT(IN) :: rhog(:) - COMPLEX(DP), INTENT(IN), OPTIONAL :: rhogref(:) - ! - REAL(DP) :: nelec_, charge - INTEGER :: ik - ! - ! - ! ... check the total charge - ! - charge = 0.D0 - IF ( gstart_cp == 2 ) THEN - charge = rhog(1) * omega_cp - ENDIF - ! - CALL mp_sum( charge, intra_bgrp_comm ) - ! - nelec_ = nelec * num_kpts - IF ( check_fft ) nelec_ = nelec - IF ( ABS( charge - nelec_ ) > 1.D-3 * charge ) & - CALL errore( 'wan2odd', 'wrong total charge', 1 ) - ! - ! - ! ... check rho(G) when dfftcp is taken equal to dffts - ! - IF ( check_fft ) THEN - DO ik = 1, ngmcp - IF ( ABS( DBLE(rhog(ik) - rho%of_g(ik,ispin)) ) .ge. eps6 .or. & - ABS( AIMAG(rhog(ik) - rho%of_g(ik,ispin)) ) .ge. eps6 ) THEN - CALL errore( 'wan2odd', 'rhog and rho%of_g differ', ik ) - ENDIF - ENDDO - ENDIF - ! - ! - ! ... when present, rhogref is compared to rhog - ! - IF ( PRESENT(rhogref) ) THEN - DO ik = 1, ngmcp - IF ( ABS( DBLE(rhog(ik) - rhogref(ik)) ) .ge. eps6 .or. & - ABS( AIMAG(rhog(ik) - rhogref(ik)) ) .ge. eps6 ) THEN - CALL errore( 'wan2odd', 'rhog and rhogref differ', ik ) - ENDIF - ENDDO - ENDIF - ! - ! - END SUBROUTINE check_rho_single - ! - ! - !--------------------------------------------------------------------- - SUBROUTINE check_rho_double( rhog, rhogref ) - !------------------------------------------------------------------- - ! - ! ... SPIN POLARISED CASE - ! - ! ... this routine performs some checks on the supercell total density: - ! ... 1) the total charge - ! ... 2) (if rhogref is present) it checks that rhog matches with rhogref - ! - USE mp, ONLY : mp_sum - USE mp_bands, ONLY : intra_bgrp_comm - USE klist, ONLY : nelec - USE lsda_mod, ONLY : nspin - USE scf, ONLY : rho - USE constants, ONLY : eps6 - USE fft_supercell, ONLY : gstart_cp, omega_cp, check_fft, ngmcp - USE read_wannier, ONLY : num_kpts - ! - ! - IMPLICIT NONE - ! - COMPLEX(DP), INTENT(IN) :: rhog(:,:) - COMPLEX(DP), INTENT(IN), OPTIONAL :: rhogref(:,:) - ! - REAL(DP) :: nelec_, charge - INTEGER :: ik, is - ! - ! - ! ... check the total charge - ! - charge = 0.D0 - IF ( gstart_cp == 2 ) THEN - charge = SUM(rhog(1,:)) * omega_cp - ENDIF - ! - CALL mp_sum( charge, intra_bgrp_comm ) - ! - nelec_ = nelec * num_kpts - IF ( check_fft ) nelec_ = nelec - IF ( ABS( charge - nelec_ ) > 1.D-3 * charge ) & - CALL errore( 'wan2odd', 'wrong total charge', 1 ) - ! - ! - ! ... check rho(G) when dfftcp is taken equal to dffts - ! - IF ( check_fft ) THEN - DO is = 1, nspin - DO ik = 1, ngmcp - IF ( ABS( DBLE(rhog(ik,is) - rho%of_g(ik,is)) ) .ge. eps6 .or. & - ABS( AIMAG(rhog(ik,is) - rho%of_g(ik,is)) ) .ge. eps6 ) THEN - CALL errore( 'wan2odd', 'rhog and rho%of_g differ', ik ) - ENDIF - ENDDO - ENDDO - ENDIF - ! - ! - ! ... when present, rhogref is compared to rhog - ! - IF ( PRESENT(rhogref) ) THEN - DO is = 1, nspin - DO ik = 1, ngmcp - IF ( ABS( DBLE(rhog(ik,is) - rhogref(ik,is)) ) .ge. eps6 .or. & - ABS( AIMAG(rhog(ik,is) - rhogref(ik,is)) ) .ge. eps6 ) THEN - CALL errore( 'wan2odd', 'rhog and rhogref differ', ik ) - ENDIF - ENDDO - ENDDO - ENDIF - ! - ! - END SUBROUTINE check_rho_double - ! - ! - !--------------------------------------------------------------------- - SUBROUTINE check_complex_wfc( evc, wf_is_cmplx, ratio ) - !------------------------------------------------------------------- - ! - ! ... this routine checks whether the input wavefunction (in PWs) - ! ... is real or complex: if the maximum value of the Im/Re ratio - ! ... of the wavefunction on the real grid is bigger the chosen - ! ... threshold, evc is considered complex - ! - ! ... WIP: NOT ABLE TO REPRODUCE WANNIER90 maximum Im/Re ratio yet !!! - ! - USE mp_bands, ONLY : intra_bgrp_comm - USE mp, ONLY : mp_max - USE fft_interfaces, ONLY : invfft, fwfft - USE fft_supercell, ONLY : dfftcp, npwxcp - ! - ! - IMPLICIT NONE - ! - COMPLEX(DP), INTENT(IN) :: evc(:) - LOGICAL, INTENT(OUT) :: wf_is_cmplx - REAL(DP), INTENT(OUT) :: ratio - ! - COMPLEX(DP), ALLOCATABLE :: psic(:) - REAL(DP) :: thr=1.D-3 - ! - ! - wf_is_cmplx = .false. - ! - ALLOCATE( psic(dfftcp%nnr) ) - psic(:) = ( 0.D0, 0.D0 ) - psic( dfftcp%nl(1:npwxcp) ) = evc(1:npwxcp) - CALL invfft( 'Wave', psic, dfftcp ) - ! - ratio = MAXVAL( ABS( AIMAG(psic(:)) / DBLE(psic(:)) ) ) - CALL mp_max( ratio, intra_bgrp_comm ) - ! - IF ( ratio .gt. thr ) wf_is_cmplx = .true. - ! - ! - END SUBROUTINE check_complex_wfc - ! - ! - !--------------------------------------------------------------------- - SUBROUTINE alloc_w2odd( ks_only, calc_rho ) - !------------------------------------------------------------------- - ! - USE noncollin_module, ONLY : npol - USE fft_supercell, ONLY : dfftcp, npwxcp, ngmcp, nwordwann - USE read_wannier, ONLY : num_bands, num_wann - USE lsda_mod, ONLY : nspin - ! - IMPLICIT NONE - ! - LOGICAL, INTENT(IN) :: ks_only - LOGICAL, INTENT(IN) :: calc_rho - ! - ! - ALLOCATE( evcx(npwxcp*npol,num_bands) ) - ALLOCATE( psicx(dfftcp%nnr) ) - ! - nwordwfcx = num_bands*npwxcp*npol - ! - IF ( .not. ks_only ) THEN - ! - nwordwann = num_wann*npwxcp*npol - ALLOCATE( evcw(npwxcp*npol) ) - ALLOCATE( ewan(npwxcp*npol,num_wann) ) - ! - ENDIF - ! - IF ( calc_rho ) THEN - ! - ALLOCATE( rhor(dfftcp%nnr,nspin) ) - ALLOCATE( rhog(ngmcp,nspin) ) - rhor(:,:) = ( 0.D0, 0.D0 ) - ! - ALLOCATE( rhow(dfftcp%nnr,nspin) ) - ALLOCATE( rhowg(ngmcp,nspin) ) - rhow(:,:) = ( 0.D0, 0.D0 ) - ! - ENDIF - ! - ! - END SUBROUTINE alloc_w2odd - ! - ! - !--------------------------------------------------------------------- - SUBROUTINE dealloc_w2odd - !------------------------------------------------------------------- - ! - ! - IMPLICIT NONE - ! - ! - IF ( ALLOCATED(evcx) ) DEALLOCATE( evcx ) - IF ( ALLOCATED(evcw) ) DEALLOCATE( evcw ) - IF ( ALLOCATED(ewan) ) DEALLOCATE( ewan ) - IF ( ALLOCATED(psicx) ) DEALLOCATE( psicx ) - IF ( ALLOCATED(rhor) ) DEALLOCATE( rhor ) - IF ( ALLOCATED(rhog) ) DEALLOCATE( rhog ) - IF ( ALLOCATED(rhow) ) DEALLOCATE( rhow ) - IF ( ALLOCATED(rhowg) ) DEALLOCATE( rhowg ) - IF ( ALLOCATED(evcx_dis) ) DEALLOCATE( evcx_dis ) - ! - ! - END SUBROUTINE dealloc_w2odd - ! - ! -END MODULE wannier2kcp From 3044ca32d47501e7bbe87e29e907e1f508f13bcd Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 20 Sep 2022 11:11:02 +0200 Subject: [PATCH 04/49] Adding koopmans-qe-utls as a submodule --- .gitmodules | 3 +++ quantum_espresso/utils | 1 + 2 files changed, 4 insertions(+) create mode 160000 quantum_espresso/utils diff --git a/.gitmodules b/.gitmodules index ea955abb8..8b8630f25 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,3 +4,6 @@ [submodule "quantum_espresso/kcp"] path = quantum_espresso/kcp url = ../koopmans-kcp.git +[submodule "quantum_espresso/utils"] + path = quantum_espresso/utils + url = ../koopmans-qe-utils.git diff --git a/quantum_espresso/utils b/quantum_espresso/utils new file mode 160000 index 000000000..4fc846a70 --- /dev/null +++ b/quantum_espresso/utils @@ -0,0 +1 @@ +Subproject commit 4fc846a70312ead270338cc6c334c61848bae9f0 From 03a22efdbf6f6a194e4643ff61bd1764eea7c037 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 20 Sep 2022 11:16:22 +0200 Subject: [PATCH 05/49] Remove tests for compiling qe 7 --- .github/workflows/make_qe6.yml | 40 ---------------------------------- 1 file changed, 40 deletions(-) delete mode 100644 .github/workflows/make_qe6.yml diff --git a/.github/workflows/make_qe6.yml b/.github/workflows/make_qe6.yml deleted file mode 100644 index e4efe1fca..000000000 --- a/.github/workflows/make_qe6.yml +++ /dev/null @@ -1,40 +0,0 @@ -name: Build QE - -on: - pull_request: - branches: - - master - paths: - - 'quantum_espresso/q-e/**' - push: - branches: - - master - paths: - - 'quantum_espresso/q-e/**' - -jobs: - gfortran: - runs-on: ubuntu-latest - steps: - - name: Set up git user - run: | - git config --global user.name "koopmans-tester" - git config --global user.email ${{ secrets.KOOPMANS_TESTER_EMAIL }} - - name: Checkout - uses: actions/checkout@v2 - with: - submodules: true - ssh-known-hosts: 'gitlab.com ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIAfuCHKVTjquxvt6CM6tdG4SLp1Btn/nOeHHE5UOzRdf' - ssh-strict: false - ssh-key: ${{ secrets.KOOPMANS_TESTER_PRIVATE_KEY }} - - name: Install dependencies - run: | - sudo apt-get update - sudo apt-get install gfortran libopenmpi-dev libblas-dev liblapack-dev fftw3-dev - - name: Configure q-e - run: | - make configure_6 MPIF90=mpif90 - - name: Build q-e - run: | - make espresso_6 MPIF90=mpif90 - From ef57cd5879df93cb082ddcb35982a652397d426c Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 20 Sep 2022 19:10:08 +0200 Subject: [PATCH 06/49] Point to updated qe-utils --- quantum_espresso/utils | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/quantum_espresso/utils b/quantum_espresso/utils index 4fc846a70..d129048d2 160000 --- a/quantum_espresso/utils +++ b/quantum_espresso/utils @@ -1 +1 @@ -Subproject commit 4fc846a70312ead270338cc6c334c61848bae9f0 +Subproject commit d129048d2d3d3af92049e73e6c0b94a7c7b4b9a0 From 09f3ac221ef8cc8f9bf30fcf28f57e98b53f3f3f Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 20 Sep 2022 19:17:21 +0200 Subject: [PATCH 07/49] Updated Makefile --- Makefile | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/Makefile b/Makefile index f263b6920..7adf17bd0 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,10 @@ # List of available tasks -.PHONY: help install submodules configure_4 configure_7 configure espresso_4 espresso_7 espresso_utils espresso workflow tests clean clean_espresso clean_tests benchmarks +.PHONY: help install submodules configure_4 configure_7 configure espresso_4 espresso_7 espresso_utils espresso espresso_4_install espresso_7_install espresso_utils_install espresso_install workflow tests clean clean_espresso clean_tests benchmarks MPIF90 = "mpif90" +PREFIX ?= /usr/local + +default: submodules espresso workflow help: @echo ' _ ' @@ -14,8 +17,9 @@ help: @echo ' For performing Koopmans spectral functional calculations with Quantum ESPRESSO' @echo ' See README.rst for more information' @echo '' - @echo ' To install' - @echo ' > make install' + @echo ' To install everything' + @echo ' > make' + @echo ' > sudo make install' @echo ' (For more details, see README.rst)' @echo '' @echo ' To run the test suite' @@ -25,8 +29,6 @@ help: @echo ' > make clean' @echo '' -install: submodules espresso workflow - submodules: git submodule init git submodule update @@ -40,16 +42,27 @@ configure_7: configure: configure_4 configure_7 espresso_4: - @(cd quantum_espresso/kcp; $(MAKE) kcp) + @(cd quantum_espresso/kcp && $(MAKE) kcp) + +espresso_4_install: + @(cd quantum_espresso/kcp && $(MAKE) install PREFIX=$(PREFIX)) espresso_7: - @(cd quantum_espresso/q-e; $(MAKE) pw kcw ph) + @(cd quantum_espresso/q-e && $(MAKE) pw kcw ph) + +espresso_7_install: + @(cd quantum_espresso/q-e && $(MAKE) install PREFIX=$(PREFIX)) espresso_utils: - @(cd quantum_espresso/utils; $(MAKE) all) + @(cd quantum_espresso/utils && $(MAKE) all) + +espresso_utils_install: + @(cd quantum_espresso/utils && $(MAKE) install PREFIX=$(PREFIX)) espresso: configure_4 espresso_4 configure_7 espresso_7 espresso_utils +install: espresso_4_install espresso_7_install espresso_utils_install + workflow: python3 -m pip install --upgrade pip python3 -m pip install -e . From aee7b1b890ed0c86bc27bea618521c991f4cb6d7 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 20 Sep 2022 19:25:05 +0200 Subject: [PATCH 08/49] Updated README to reflect tweaked compilation instructions --- README.rst | 13 ++++++++++++- docs/installation.rst | 2 +- docs/running.rst | 4 ++-- 3 files changed, 15 insertions(+), 4 deletions(-) diff --git a/README.rst b/README.rst index 995efe4cd..f941ab947 100644 --- a/README.rst +++ b/README.rst @@ -24,7 +24,7 @@ Installation Quick installation ^^^^^^^^^^^^^^^^^^ -For a quick installation one can simply run ``make install`` +For a quick installation one can simply run ``make; sudo make install`` Detailed installation ^^^^^^^^^^^^^^^^^^^^^ @@ -68,6 +68,17 @@ Then you need to compile the copies of ``Quantum ESPRESSO``. To do this, run where ```` should be replaced by the name of your chosen MPI Fortran90 compiler e.g. ``MPIF90=mpiifort``. The code should automatically detect and link the requisite libraries. (If this fails you may need to manually compile the two versions of ``Quantum ESPRESSO`` contained in the ``quantum_espresso/`` directory.) +Adding Quantum ESPRESSO to your path +"""""""""""""""""""""""""""""""""""" + +To add all of the Quantum ESPRESSO binaries to your path, run + +.. code-block:: bash + + sudo make install + +By default the binaries will be added to ``usr/bin``. You can override this default by appending ``PREFIX=/path/to/bin/`` to the above command. + Installing the workflow manager """"""""""""""""""""""""""""""" diff --git a/docs/installation.rst b/docs/installation.rst index 3e153548b..0799df3b7 100644 --- a/docs/installation.rst +++ b/docs/installation.rst @@ -14,5 +14,5 @@ Installing .. include:: ../README.rst :start-line: 23 - :end-line: 78 + :end-line: 91 diff --git a/docs/running.rst b/docs/running.rst index 5e5d49663..6f198163f 100644 --- a/docs/running.rst +++ b/docs/running.rst @@ -35,6 +35,6 @@ and fetch their results e.g. total_energy = final_calc.results['energy'] .. include:: ../README.rst - :start-line: 93 - :end-line: 115 + :start-line: 106 + :end-line: 133 From c9b7a09bfa17565172079e8d61fafe368e550b93 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 20 Sep 2022 21:06:36 +0200 Subject: [PATCH 09/49] Stop making koopmans look in bin/ for executables; now rely on the user to have these on their path --- koopmans/calculators/__init__.py | 2 +- koopmans/calculators/_koopmans_cp.py | 12 +++++------- koopmans/calculators/_koopmans_ham.py | 8 +++----- koopmans/calculators/_koopmans_screen.py | 7 +++---- koopmans/calculators/_ph.py | 7 +++---- koopmans/calculators/_projwfc.py | 7 +++---- koopmans/calculators/_pw.py | 7 +++---- koopmans/calculators/_pw2wannier.py | 6 +++--- koopmans/calculators/_utils.py | 11 ++++------- koopmans/calculators/_wann2kc.py | 6 +++--- koopmans/calculators/_wann2kcp.py | 6 +++--- koopmans/calculators/_wannier90.py | 7 +++---- koopmans/utils/_os.py | 23 ++++++++++++----------- koopmans/workflows/_folding.py | 3 +-- koopmans/workflows/_workflow.py | 17 +++-------------- 15 files changed, 53 insertions(+), 76 deletions(-) diff --git a/koopmans/calculators/__init__.py b/koopmans/calculators/__init__.py index c3041dbd9..fd060f3fd 100644 --- a/koopmans/calculators/__init__.py +++ b/koopmans/calculators/__init__.py @@ -11,7 +11,7 @@ from ._pw2wannier import PW2WannierCalculator from ._ui import UnfoldAndInterpolateCalculator from ._utils import (CalculatorCanEnforceSpinSym, CalculatorExt, - ReturnsBandStructure, bin_directory) + ReturnsBandStructure) from ._wann2kc import Wann2KCCalculator from ._wann2kcp import Wann2KCPCalculator from ._wannier90 import Wannier90Calculator diff --git a/koopmans/calculators/_koopmans_cp.py b/koopmans/calculators/_koopmans_cp.py index d8c0cab03..4f6a271f0 100644 --- a/koopmans/calculators/_koopmans_cp.py +++ b/koopmans/calculators/_koopmans_cp.py @@ -17,18 +17,17 @@ from typing import Any, List, Optional, Union import numpy as np -from pandas.core.series import Series -from scipy.linalg import block_diag - from ase import Atoms from ase.calculators.espresso import Espresso_kcp from ase.io.espresso import cell_to_ibrav +from pandas.core.series import Series +from scipy.linalg import block_diag + from koopmans import bands, pseudopotentials, settings, utils from koopmans.cell import cell_follows_qe_conventions, cell_to_parameters from koopmans.commands import ParallelCommand -from ._utils import (CalculatorABC, CalculatorCanEnforceSpinSym, CalculatorExt, - bin_directory) +from ._utils import CalculatorABC, CalculatorCanEnforceSpinSym, CalculatorExt def allowed(nr: int) -> bool: @@ -108,8 +107,7 @@ def __init__(self, atoms: Atoms, alphas: Optional[List[List[float]]] = None, self.parameters.neldw = self.parameters.nelec // 2 if not isinstance(self.command, ParallelCommand): - self.command = ParallelCommand(os.environ.get( - 'ASE_ESPRESSO_KCP_COMMAND', str(bin_directory) + os.path.sep + self.command)) + self.command = ParallelCommand(os.environ.get('ASE_ESPRESSO_KCP_COMMAND', self.command)) if alphas is not None: self.alphas = alphas diff --git a/koopmans/calculators/_koopmans_ham.py b/koopmans/calculators/_koopmans_ham.py index 9051d554b..ebe9ed4f9 100644 --- a/koopmans/calculators/_koopmans_ham.py +++ b/koopmans/calculators/_koopmans_ham.py @@ -10,15 +10,14 @@ from typing import List, Optional import numpy as np - from ase import Atoms from ase.calculators.espresso import KoopmansHam from ase.dft.kpoints import BandPath + from koopmans import settings, utils from koopmans.commands import ParallelCommand -from ._utils import (CalculatorABC, KCWannCalculator, ReturnsBandStructure, - bin_directory) +from ._utils import CalculatorABC, KCWannCalculator, ReturnsBandStructure class KoopmansHamCalculator(KCWannCalculator, KoopmansHam, ReturnsBandStructure, CalculatorABC): @@ -34,8 +33,7 @@ def __init__(self, atoms: Atoms, alphas: Optional[List[int]] = None, *args, **kw KoopmansHam.__init__(self, atoms=atoms) KCWannCalculator.__init__(self, *args, **kwargs) - self.command = ParallelCommand( - f'{bin_directory}{os.path.sep}kcw.x -in PREFIX{self.ext_in} > PREFIX{self.ext_out} 2>&1') + self.command = ParallelCommand(f'kcw.x -in PREFIX{self.ext_in} > PREFIX{self.ext_out} 2>&1') # Store the alphas self.alphas = alphas diff --git a/koopmans/calculators/_koopmans_screen.py b/koopmans/calculators/_koopmans_screen.py index d55dccc9b..4ad3da277 100644 --- a/koopmans/calculators/_koopmans_screen.py +++ b/koopmans/calculators/_koopmans_screen.py @@ -9,13 +9,13 @@ import os import numpy as np - from ase import Atoms from ase.calculators.espresso import KoopmansScreen + from koopmans import settings, utils from koopmans.commands import ParallelCommandWithPostfix -from ._utils import CalculatorABC, KCWannCalculator, bin_directory +from ._utils import CalculatorABC, KCWannCalculator class KoopmansScreenCalculator(KCWannCalculator, KoopmansScreen, CalculatorABC): @@ -32,8 +32,7 @@ def __init__(self, atoms: Atoms, *args, **kwargs): KCWannCalculator.__init__(self, *args, **kwargs) super().__init__(*args, **kwargs) - self.command = ParallelCommandWithPostfix( - f'{bin_directory}{os.path.sep}kcw.x -in PREFIX{self.ext_in} > PREFIX{self.ext_out} 2>&1') + self.command = ParallelCommandWithPostfix(f'kcw.x -in PREFIX{self.ext_in} > PREFIX{self.ext_out} 2>&1') def calculate(self): # Check eps infinity diff --git a/koopmans/calculators/_ph.py b/koopmans/calculators/_ph.py index dced063c3..9b19a1dd2 100644 --- a/koopmans/calculators/_ph.py +++ b/koopmans/calculators/_ph.py @@ -11,13 +11,13 @@ import os import numpy as np - from ase import Atoms from ase.calculators.espresso import EspressoPh + from koopmans.commands import ParallelCommand from koopmans.settings import PhSettingsDict -from ._utils import CalculatorABC, CalculatorExt, bin_directory +from ._utils import CalculatorABC, CalculatorExt class PhCalculator(CalculatorExt, EspressoPh, CalculatorABC): @@ -32,8 +32,7 @@ def __init__(self, atoms: Atoms, *args, **kwargs): EspressoPh.__init__(self, atoms=atoms) CalculatorExt.__init__(self, *args, **kwargs) - self.command = ParallelCommand( - f'{bin_directory}{os.path.sep}ph.x -in PREFIX{self.ext_in} > PREFIX{self.ext_out} 2>&1') + self.command = ParallelCommand(f'ph.x -in PREFIX{self.ext_in} > PREFIX{self.ext_out} 2>&1') def is_converged(self): return True diff --git a/koopmans/calculators/_projwfc.py b/koopmans/calculators/_projwfc.py index f31ac4d1e..1338cdbd1 100644 --- a/koopmans/calculators/_projwfc.py +++ b/koopmans/calculators/_projwfc.py @@ -11,16 +11,16 @@ from typing import Dict, List, Optional import numpy as np - from ase import Atoms from ase.calculators.espresso import Projwfc from ase.spectrum.doscollection import GridDOSCollection from ase.spectrum.dosdata import GridDOSData + from koopmans import pseudopotentials from koopmans.commands import Command, ParallelCommand from koopmans.settings import ProjwfcSettingsDict -from ._utils import CalculatorABC, CalculatorExt, bin_directory +from ._utils import CalculatorABC, CalculatorExt class ProjwfcCalculator(CalculatorExt, Projwfc, CalculatorABC): @@ -37,8 +37,7 @@ def __init__(self, atoms: Atoms, *args, **kwargs): CalculatorExt.__init__(self, *args, **kwargs) if not isinstance(self.command, Command): - self.command = ParallelCommand(os.environ.get( - 'ASE_PROJWFC_COMMAND', str(bin_directory) + os.path.sep + self.command)) + self.command = ParallelCommand(os.environ.get('ASE_PROJWFC_COMMAND', self.command)) # We need pseudopotentials and pseudo dir in order to work out the number of valence electrons for each # element, and therefore what pDOS files to expect. We also need spin-polarized to know if the pDOS files will diff --git a/koopmans/calculators/_pw.py b/koopmans/calculators/_pw.py index 41acadb99..7740d9b6d 100644 --- a/koopmans/calculators/_pw.py +++ b/koopmans/calculators/_pw.py @@ -9,17 +9,16 @@ import os import numpy as np - from ase import Atoms from ase.calculators.espresso import Espresso from ase.dft.kpoints import BandPath + from koopmans.cell import cell_follows_qe_conventions, cell_to_parameters from koopmans.commands import Command, ParallelCommandWithPostfix from koopmans.pseudopotentials import nelec_from_pseudos from koopmans.settings import PWSettingsDict -from ._utils import (CalculatorABC, CalculatorExt, ReturnsBandStructure, - bin_directory) +from ._utils import CalculatorABC, CalculatorExt, ReturnsBandStructure class PWCalculator(CalculatorExt, Espresso, ReturnsBandStructure, CalculatorABC): @@ -37,7 +36,7 @@ def __init__(self, atoms: Atoms, *args, **kwargs): if not isinstance(self.command, Command): self.command = ParallelCommandWithPostfix(os.environ.get( - 'ASE_ESPRESSO_COMMAND', str(bin_directory) + os.path.sep + self.command)) + 'ASE_ESPRESSO_COMMAND', self.command)) def calculate(self): # Update ibrav and celldms diff --git a/koopmans/calculators/_pw2wannier.py b/koopmans/calculators/_pw2wannier.py index c72667bae..506128dc4 100644 --- a/koopmans/calculators/_pw2wannier.py +++ b/koopmans/calculators/_pw2wannier.py @@ -10,10 +10,11 @@ from ase import Atoms from ase.calculators.espresso import PW2Wannier + from koopmans.commands import ParallelCommand from koopmans.settings import PW2WannierSettingsDict -from ._utils import CalculatorABC, CalculatorExt, bin_directory +from ._utils import CalculatorABC, CalculatorExt class PW2WannierCalculator(CalculatorExt, PW2Wannier, CalculatorABC): @@ -28,8 +29,7 @@ def __init__(self, atoms: Atoms, *args, **kwargs): PW2Wannier.__init__(self, atoms=atoms) CalculatorExt.__init__(self, *args, **kwargs) - self.command = ParallelCommand(os.environ.get('ASE_PW2WANNIER_COMMAND', - str(bin_directory) + os.path.sep + self.command)) + self.command = ParallelCommand(os.environ.get('ASE_PW2WANNIER_COMMAND', self.command)) def is_converged(self): return True diff --git a/koopmans/calculators/_utils.py b/koopmans/calculators/_utils.py index 8085a19cb..ced8a8aac 100644 --- a/koopmans/calculators/_utils.py +++ b/koopmans/calculators/_utils.py @@ -26,18 +26,15 @@ class ExtendedCalc(CalculatorExt, ASECalc, CalculatorABC): from pathlib import Path from typing import Any, Dict, Generic, List, Optional, Type, TypeVar, Union -import numpy as np -from numpy import typing as npt - import ase.io as ase_io +import numpy as np from ase import Atoms from ase.calculators.calculator import CalculationFailed, Calculator from ase.dft.kpoints import BandPath from ase.spectrum.band_structure import BandStructure -from koopmans import settings, utils +from numpy import typing as npt -# Directories of the various QE calculators -bin_directory = Path(__file__).parents[2] / 'bin' +from koopmans import settings, utils def sanitize_filenames(filenames: Union[str, Path, List[str], List[Path]], ext_in: str, ext_out: str) -> List[Path]: @@ -185,7 +182,7 @@ def check_code_is_installed(self): executable_with_path = utils.find_executable(self.command.executable) if executable_with_path is None: raise OSError(f'{self.command.executable} is not installed') - self.command.path = executable_with_path.rsplit('/', 1)[0] + '/' + self.command.path = executable_with_path.parent else: if not (self.command.path / self.command.executable).is_file(): raise OSError(f'{self.command.executable} is not installed') diff --git a/koopmans/calculators/_wann2kc.py b/koopmans/calculators/_wann2kc.py index 7cb0b566e..d32ef9af8 100644 --- a/koopmans/calculators/_wann2kc.py +++ b/koopmans/calculators/_wann2kc.py @@ -10,10 +10,11 @@ from ase import Atoms from ase.calculators.espresso import Wann2KC + from koopmans.commands import ParallelCommandWithPostfix from koopmans.settings import Wann2KCSettingsDict -from ._utils import CalculatorABC, KCWannCalculator, bin_directory +from ._utils import CalculatorABC, KCWannCalculator class Wann2KCCalculator(KCWannCalculator, Wann2KC, CalculatorABC): @@ -29,8 +30,7 @@ def __init__(self, atoms: Atoms, *args, **kwargs): Wann2KC.__init__(self, atoms=atoms) KCWannCalculator.__init__(self, *args, **kwargs) - self.command = ParallelCommandWithPostfix( - f'{bin_directory}{os.path.sep}kcw.x -in PREFIX{self.ext_in} > PREFIX{self.ext_out} 2>&1') + self.command = ParallelCommandWithPostfix(f'kcw.x -in PREFIX{self.ext_in} > PREFIX{self.ext_out} 2>&1') def is_converged(self): return True diff --git a/koopmans/calculators/_wann2kcp.py b/koopmans/calculators/_wann2kcp.py index f12ace0f0..3f2cb3337 100644 --- a/koopmans/calculators/_wann2kcp.py +++ b/koopmans/calculators/_wann2kcp.py @@ -10,10 +10,11 @@ from ase import Atoms from ase.calculators.espresso import Wann2KCP + from koopmans.commands import ParallelCommand from koopmans.settings import Wann2KCPSettingsDict -from ._utils import CalculatorABC, CalculatorExt, bin_directory +from ._utils import CalculatorABC, CalculatorExt class Wann2KCPCalculator(CalculatorExt, Wann2KCP, CalculatorABC): @@ -28,8 +29,7 @@ def __init__(self, atoms: Atoms, *args, **kwargs): Wann2KCP.__init__(self, atoms=atoms) CalculatorExt.__init__(self, *args, **kwargs) - self.command = ParallelCommand(os.environ.get('ASE_WANN2KCP_COMMAND', - str(bin_directory) + os.path.sep + self.command)) + self.command = ParallelCommand(os.environ.get('ASE_WANN2KCP_COMMAND', self.command)) def is_converged(self): return True diff --git a/koopmans/calculators/_wannier90.py b/koopmans/calculators/_wannier90.py index 1dd7cf7a9..27b666d2a 100644 --- a/koopmans/calculators/_wannier90.py +++ b/koopmans/calculators/_wannier90.py @@ -9,15 +9,15 @@ import os import numpy as np - from ase import Atoms from ase.calculators.wannier90 import Wannier90 from ase.dft.kpoints import BandPath + from koopmans.commands import Command from koopmans.settings import Wannier90SettingsDict from koopmans.utils import CalculatorNotConvergedWarning, warn -from ._utils import CalculatorABC, CalculatorExt, bin_directory +from ._utils import CalculatorABC, CalculatorExt class Wannier90Calculator(CalculatorExt, Wannier90, CalculatorABC): @@ -33,8 +33,7 @@ def __init__(self, atoms: Atoms, *args, **kwargs): CalculatorExt.__init__(self, *args, **kwargs) # Set up the command for running this calculator - self.command = Command(os.environ.get('ASE_WANNIER90_COMMAND', - str(bin_directory) + os.path.sep + self.command)) + self.command = Command(os.environ.get('ASE_WANNIER90_COMMAND', self.command)) def is_converged(self): return self.results['convergence'] diff --git a/koopmans/utils/_os.py b/koopmans/utils/_os.py index fe6571921..3941f6fa1 100644 --- a/koopmans/utils/_os.py +++ b/koopmans/utils/_os.py @@ -7,11 +7,11 @@ ''' import contextlib -from glob import glob import os -from pathlib import Path import subprocess -from typing import Union +from glob import glob +from pathlib import Path +from typing import Optional, Union def system_call(command: str, check_ierr: bool = True): @@ -106,7 +106,7 @@ def set_env(**environ): os.environ.update(old_environ) -def find_executable(program: Union[Path, str]): +def find_executable(program: Union[Path, str]) -> Optional[Path]: if isinstance(program, str): program = Path(program) @@ -115,13 +115,14 @@ def is_exe(fpath: Path): return fpath.is_file() and os.access(fpath, os.X_OK) fpath = program.parent + if fpath.samefile('.'): - if is_exe(program): - return program - else: - for path in os.environ["PATH"].split(os.pathsep): - exe_file = Path(path) / program - if is_exe(exe_file): - return exe_file + if is_exe(Path(fpath) / program): + return Path(fpath) / program + + for path in os.environ["PATH"].split(os.pathsep): + exe_file = Path(path) / program + if is_exe(exe_file): + return exe_file return None diff --git a/koopmans/workflows/_folding.py b/koopmans/workflows/_folding.py index a7bc9b5ef..b7e423b7d 100644 --- a/koopmans/workflows/_folding.py +++ b/koopmans/workflows/_folding.py @@ -66,8 +66,7 @@ def _run(self): evc_fname = f'evcw.dat' else: evc_fname = f'evcw{evc_index}.dat' - command = ' '.join([f'{calculators.bin_directory}/merge_evc.x -nr ' - f'{np.prod(self.kpoints.grid)}'] + command = ' '.join([f'merge_evc.x -nr {np.prod(self.kpoints.grid)}'] + [f'-i {b.directory}/{evc_fname}' for b in subset] + [f'-o {output_directory}/{evc_fname}']) if occ: diff --git a/koopmans/workflows/_workflow.py b/koopmans/workflows/_workflow.py index 54ca59b09..40d235a65 100644 --- a/koopmans/workflows/_workflow.py +++ b/koopmans/workflows/_workflow.py @@ -1309,18 +1309,8 @@ def _teardown(self): self._remove_tmpdirs() -def get_version(module): - if isinstance(module, ModuleType): - module = module.__path__[0] - with utils.chdir(module): - version_label = subprocess.check_output(["git", "describe", "--always", "--tags"]).strip() - return version_label.decode("utf-8") - - def header(): - - koopmans_version = get_version(os.path.dirname(__file__)) - qe_version = get_version((calculators.bin_directory / 'pw.x').resolve().parents[2]) + from koopmans import __version__ header = [r" _", r" | | _____ ___ _ __ _ __ ___ __ _ _ __ ___", @@ -1331,10 +1321,9 @@ def header(): "", " Koopmans spectral functional calculations with Quantum ESPRESSO", "", - f" {koopmans_version}, using {qe_version} and ase-koopmans v{ase.__version__}", + f" version {__version__}", "", - " Written by Edward Linscott, Riccardo De Gennaro, and Nicola Colonna", - ""] + " Written by Edward Linscott, Riccardo De Gennaro, and Nicola Colonna"] return '\n'.join(header) From fd87fa1af9003fe46d945c2819cf70f9e8fe0e56 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 20 Sep 2022 21:21:33 +0200 Subject: [PATCH 10/49] Updated kcp --- quantum_espresso/kcp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/quantum_espresso/kcp b/quantum_espresso/kcp index e52975af4..17b92ba83 160000 --- a/quantum_espresso/kcp +++ b/quantum_espresso/kcp @@ -1 +1 @@ -Subproject commit e52975af42c54b9983e4f43d0ee93b24662fb7f6 +Subproject commit 17b92ba83446fad795b29e21026d3ef677203ff1 From b3a5c4ded0e4251833cb73a1c011950cd1d0f763 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 20 Sep 2022 21:32:01 +0200 Subject: [PATCH 11/49] Update kcp version --- quantum_espresso/kcp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/quantum_espresso/kcp b/quantum_espresso/kcp index 17b92ba83..b60e30a67 160000 --- a/quantum_espresso/kcp +++ b/quantum_espresso/kcp @@ -1 +1 @@ -Subproject commit 17b92ba83446fad795b29e21026d3ef677203ff1 +Subproject commit b60e30a67431a738ce79cdfc990be95202abbf3c From 97fe5be5ac45760e7cb7716f54e88d173b69bab2 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Wed, 21 Sep 2022 14:50:55 +0200 Subject: [PATCH 12/49] Updated koopmans-qe-utils --- koopmans/__init__.py | 4 ++-- quantum_espresso/utils | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/koopmans/__init__.py b/koopmans/__init__.py index 5e08b3915..cce37fba4 100644 --- a/koopmans/__init__.py +++ b/koopmans/__init__.py @@ -1,5 +1,5 @@ -'Python module for running KI and KIPZ calculations with Quantum Espresso' +'koopmans: a package for performing and automating Koopmans functional calculations' from pathlib import Path -__version__ = '1.0.0-beta.2' +__version__ = '1.0.0-beta.3' base_directory = Path(__path__[0]).parent diff --git a/quantum_espresso/utils b/quantum_espresso/utils index d129048d2..ed334d3b9 160000 --- a/quantum_espresso/utils +++ b/quantum_espresso/utils @@ -1 +1 @@ -Subproject commit d129048d2d3d3af92049e73e6c0b94a7c7b4b9a0 +Subproject commit ed334d3b98f1ac63e57ea9070b271a413420673c From ff7e3d57e608dd896533517ddc6c548f60b5abfb Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Thu, 22 Sep 2022 09:53:45 +0200 Subject: [PATCH 13/49] Updated utils submodule --- quantum_espresso/utils | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/quantum_espresso/utils b/quantum_espresso/utils index ed334d3b9..36f28824b 160000 --- a/quantum_espresso/utils +++ b/quantum_espresso/utils @@ -1 +1 @@ -Subproject commit ed334d3b98f1ac63e57ea9070b271a413420673c +Subproject commit 36f28824b148df0529ff800fa825f50687bf0644 From 7cf4f8a13892eb0f2097fdfea832af6adf0cfab4 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Mon, 26 Sep 2022 17:04:08 +0200 Subject: [PATCH 14/49] Moved koopmans testing into separate directory so that koopmans can be shipped without test infrastructure; updated benchmarks --- codecov.yml | 3 - conftest.py | 101 +- koopmans/testing/__init__.py | 36 - tests/__init__.py | 4 + ...ecutwfc_20d0-cell_size_1d0-dft_nspin1.json | 8 +- ...ecutwfc_20d0-cell_size_1d0-dft_nspin2.json | 8 +- ...c_20d0-cell_size_1d0-dft_nspin2_dummy.json | 8 +- ...ecutwfc_20d0-cell_size_1d1-dft_nspin1.json | 8 +- ...ecutwfc_20d0-cell_size_1d1-dft_nspin2.json | 8 +- ...c_20d0-cell_size_1d1-dft_nspin2_dummy.json | 8 +- ...ecutwfc_20d0-cell_size_1d2-dft_nspin1.json | 8 +- ...ecutwfc_20d0-cell_size_1d2-dft_nspin2.json | 8 +- ...c_20d0-cell_size_1d2-dft_nspin2_dummy.json | 8 +- ...ecutwfc_30d0-cell_size_1d0-dft_nspin1.json | 8 +- ...ecutwfc_30d0-cell_size_1d0-dft_nspin2.json | 8 +- ...c_30d0-cell_size_1d0-dft_nspin2_dummy.json | 8 +- ...ecutwfc_30d0-cell_size_1d1-dft_nspin1.json | 8 +- ...ecutwfc_30d0-cell_size_1d1-dft_nspin2.json | 8 +- ...c_30d0-cell_size_1d1-dft_nspin2_dummy.json | 8 +- ...ecutwfc_30d0-cell_size_1d2-dft_nspin1.json | 8 +- ...ecutwfc_30d0-cell_size_1d2-dft_nspin2.json | 8 +- ...c_30d0-cell_size_1d2-dft_nspin2_dummy.json | 8 +- ...ecutwfc_40d0-cell_size_1d0-dft_nspin1.json | 8 +- ...ecutwfc_40d0-cell_size_1d0-dft_nspin2.json | 8 +- ...c_40d0-cell_size_1d0-dft_nspin2_dummy.json | 8 +- ...ecutwfc_40d0-cell_size_1d1-dft_nspin1.json | 8 +- ...ecutwfc_40d0-cell_size_1d1-dft_nspin2.json | 8 +- ...c_40d0-cell_size_1d1-dft_nspin2_dummy.json | 8 +- ...ecutwfc_40d0-cell_size_1d2-dft_nspin1.json | 8 +- ...ecutwfc_40d0-cell_size_1d2-dft_nspin2.json | 8 +- ...c_40d0-cell_size_1d2-dft_nspin2_dummy.json | 8 +- .../test_dftbands_si0-dft_bands-bands.json | 4 +- .../test_dftbands_si0-dft_bands-projwfc.json | 4 +- .../test_dftbands_si0-dft_bands-scf.json | 4 +- tests/benchmarks/test_dftph_tio20-eps.json | 4 +- tests/benchmarks/test_dftph_tio20-scf.json | 4 +- ...glepoint_gaas_wan2odd0-final-ki_final.json | 1672 ++++++++--------- ...glepoint_gaas_wan2odd0-init-dft_dummy.json | 8 +- ...nglepoint_gaas_wan2odd0-init-dft_init.json | 8 +- ...gaas_wan2odd0-init-wannier-emp-pw2wan.json | 4 +- ..._gaas_wan2odd0-init-wannier-emp-w2kcp.json | 4 +- ...t_gaas_wan2odd0-init-wannier-emp-wann.json | 4 +- ...an2odd0-init-wannier-emp-wann_preproc.json | 4 +- ...point_gaas_wan2odd0-init-wannier-nscf.json | 8 +- ...n2odd0-init-wannier-occ_block1-pw2wan.json | 4 +- ...an2odd0-init-wannier-occ_block1-w2kcp.json | 4 +- ...wan2odd0-init-wannier-occ_block1-wann.json | 4 +- ...-init-wannier-occ_block1-wann_preproc.json | 4 +- ...n2odd0-init-wannier-occ_block2-pw2wan.json | 4 +- ...an2odd0-init-wannier-occ_block2-w2kcp.json | 4 +- ...wan2odd0-init-wannier-occ_block2-wann.json | 4 +- ...-init-wannier-occ_block2-wann_preproc.json | 4 +- ...epoint_gaas_wan2odd0-init-wannier-scf.json | 8 +- ...lepoint_gaas_wan2odd0-postproc-emp-ki.json | 2 +- ...lepoint_gaas_wan2odd0-postproc-occ-ki.json | 2 +- ..._gaas_wan2odd0-postproc-wannier-bands.json | 8 +- ..._wan2odd0-postproc-wannier-emp-pw2wan.json | 4 +- ...as_wan2odd0-postproc-wannier-emp-wann.json | 4 +- ...dd0-postproc-wannier-emp-wann_preproc.json | 4 +- ...t_gaas_wan2odd0-postproc-wannier-nscf.json | 8 +- ...d0-postproc-wannier-occ_block1-pw2wan.json | 4 +- ...odd0-postproc-wannier-occ_block1-wann.json | 4 +- ...tproc-wannier-occ_block1-wann_preproc.json | 4 +- ...d0-postproc-wannier-occ_block2-pw2wan.json | 4 +- ...odd0-postproc-wannier-occ_block2-wann.json | 4 +- ...tproc-wannier-occ_block2-wann_preproc.json | 4 +- ...nt_gaas_wan2odd0-postproc-wannier-scf.json | 8 +- ...ll_dscf0-ki-calc_alpha-iteration_1-ki.json | 88 +- ...c_alpha-iteration_1-orbital_4-dft_n-1.json | 8 +- ...c_alpha-iteration_1-orbital_5-dft_n+1.json | 8 +- ...a-iteration_1-orbital_5-dft_n+1_dummy.json | 8 +- ..._alpha-iteration_1-orbital_5-pz_print.json | 88 +- ...0-ki-calc_alpha-iteration_2-ki_nspin1.json | 48 +- ...alc_alpha-iteration_2-ki_nspin1_dummy.json | 48 +- ...0-ki-calc_alpha-iteration_2-ki_nspin2.json | 88 +- ...alc_alpha-iteration_2-ki_nspin2_dummy.json | 88 +- ...c_alpha-iteration_2-orbital_5-dft_n+1.json | 8 +- ...a-iteration_2-orbital_5-dft_n+1_dummy.json | 8 +- ..._alpha-iteration_2-orbital_5-pz_print.json | 88 +- ...point_h2o_all_dscf0-ki-final-ki_final.json | 88 +- ...h2o_all_dscf0-ki-init-dft_init_nspin1.json | 8 +- ...h2o_all_dscf0-ki-init-dft_init_nspin2.json | 8 +- ...l_dscf0-ki-init-dft_init_nspin2_dummy.json | 8 +- ...o_all_dscf0-ki-init-pz_innerloop_init.json | 88 +- ...scf0-kipz-calc_alpha-iteration_1-kipz.json | 88 +- ..._alpha-iteration_1-orbital_4-kipz_n-1.json | 72 +- ...a-iteration_1-orbital_5-dft_n+1_dummy.json | 8 +- ..._alpha-iteration_1-orbital_5-kipz_n+1.json | 80 +- ...lpha-iteration_1-orbital_5-kipz_print.json | 88 +- ...pz-calc_alpha-iteration_2-kipz_nspin1.json | 48 +- ...c_alpha-iteration_2-kipz_nspin1_dummy.json | 48 +- ...pz-calc_alpha-iteration_2-kipz_nspin2.json | 88 +- ...c_alpha-iteration_2-kipz_nspin2_dummy.json | 88 +- ..._alpha-iteration_2-orbital_4-kipz_n-1.json | 72 +- ..._alpha-iteration_2-orbital_5-kipz_n+1.json | 80 +- ...lpha-iteration_2-orbital_5-kipz_print.json | 88 +- ...t_h2o_all_dscf0-kipz-final-kipz_final.json | 88 +- ...h2o_all_dscf0-pkipz-final-pkipz_final.json | 88 +- ...glepoint_h2o_ki_dscf_e0-calc_alpha-ki.json | 88 +- ..._dscf_e0-calc_alpha-orbital_4-dft_n-1.json | 8 +- ..._dscf_e0-calc_alpha-orbital_5-dft_n+1.json | 8 +- ...e0-calc_alpha-orbital_5-dft_n+1_dummy.json | 8 +- ...dscf_e0-calc_alpha-orbital_5-pz_print.json | 88 +- ...lepoint_h2o_ki_dscf_e0-final-ki_final.json | 88 +- ...t_h2o_ki_dscf_e0-init-dft_init_nspin1.json | 8 +- ...t_h2o_ki_dscf_e0-init-dft_init_nspin2.json | 8 +- ...ki_dscf_e0-init-dft_init_nspin2_dummy.json | 8 +- ...h2o_ki_dscf_e0-init-pz_innerloop_init.json | 88 +- ...lepoint_ozone_ki_dfpt0-hamiltonian-kc.json | 4 +- ...t_singlepoint_ozone_ki_dfpt0-init-dft.json | 4 +- ...st_singlepoint_ozone_ki_dfpt0-init-kc.json | 4 +- ...nglepoint_ozone_ki_dfpt0-screening-kc.json | 4 +- ...inglepoint_si_ki_dfpt0-hamiltonian-kc.json | 4 +- ...nglepoint_si_ki_dfpt0-postproc-emp-ki.json | 2 +- ...nglepoint_si_ki_dfpt0-postproc-occ-ki.json | 2 +- ...nt_si_ki_dfpt0-postproc-wannier-bands.json | 4 +- ..._ki_dfpt0-postproc-wannier-emp-pw2wan.json | 4 +- ...si_ki_dfpt0-postproc-wannier-emp-wann.json | 4 +- ...pt0-postproc-wannier-emp-wann_preproc.json | 4 +- ...int_si_ki_dfpt0-postproc-wannier-nscf.json | 4 +- ..._ki_dfpt0-postproc-wannier-occ-pw2wan.json | 4 +- ...si_ki_dfpt0-postproc-wannier-occ-wann.json | 4 +- ...pt0-postproc-wannier-occ-wann_preproc.json | 4 +- ...oint_si_ki_dfpt0-postproc-wannier-scf.json | 4 +- ..._singlepoint_si_ki_dfpt0-screening-kc.json | 4 +- ...singlepoint_si_ki_dfpt0-wannier-bands.json | 4 +- ...epoint_si_ki_dfpt0-wannier-emp-pw2wan.json | 4 +- ...glepoint_si_ki_dfpt0-wannier-emp-wann.json | 4 +- ..._si_ki_dfpt0-wannier-emp-wann_preproc.json | 4 +- ...st_singlepoint_si_ki_dfpt0-wannier-kc.json | 4 +- ..._singlepoint_si_ki_dfpt0-wannier-nscf.json | 4 +- ...epoint_si_ki_dfpt0-wannier-occ-pw2wan.json | 4 +- ...glepoint_si_ki_dfpt0-wannier-occ-wann.json | 4 +- ..._si_ki_dfpt0-wannier-occ-wann_preproc.json | 4 +- ...t_singlepoint_si_ki_dfpt0-wannier-scf.json | 4 +- ...lepoint_si_ki_dfpt_ex0-hamiltonian-kc.json | 4 +- ...epoint_si_ki_dfpt_ex0-postproc-emp-ki.json | 2 +- ...epoint_si_ki_dfpt_ex0-postproc-occ-ki.json | 2 +- ...si_ki_dfpt_ex0-postproc-wannier-bands.json | 4 +- ..._dfpt_ex0-postproc-wannier-emp-pw2wan.json | 4 +- ...ki_dfpt_ex0-postproc-wannier-emp-wann.json | 4 +- ...ex0-postproc-wannier-emp-wann_preproc.json | 4 +- ..._si_ki_dfpt_ex0-postproc-wannier-nscf.json | 4 +- ..._dfpt_ex0-postproc-wannier-occ-pw2wan.json | 4 +- ...ki_dfpt_ex0-postproc-wannier-occ-wann.json | 4 +- ...ex0-postproc-wannier-occ-wann_preproc.json | 4 +- ...t_si_ki_dfpt_ex0-postproc-wannier-scf.json | 4 +- ...nglepoint_si_ki_dfpt_ex0-screening-kc.json | 4 +- ...glepoint_si_ki_dfpt_ex0-wannier-bands.json | 4 +- ...int_si_ki_dfpt_ex0-wannier-emp-pw2wan.json | 4 +- ...point_si_ki_dfpt_ex0-wannier-emp-wann.json | 4 +- ..._ki_dfpt_ex0-wannier-emp-wann_preproc.json | 4 +- ...singlepoint_si_ki_dfpt_ex0-wannier-kc.json | 4 +- ...nglepoint_si_ki_dfpt_ex0-wannier-nscf.json | 4 +- ...int_si_ki_dfpt_ex0-wannier-occ-pw2wan.json | 4 +- ...point_si_ki_dfpt_ex0-wannier-occ-wann.json | 4 +- ..._ki_dfpt_ex0-wannier-occ-wann_preproc.json | 4 +- ...inglepoint_si_ki_dfpt_ex0-wannier-scf.json | 4 +- ...glepoint_si_ki_dscf_Fa0-calc_alpha-ki.json | 1028 +++++----- ...scf_Fa0-calc_alpha-orbital_32-dft_n-1.json | 4 +- ...scf_Fa0-calc_alpha-orbital_33-dft_n+1.json | 4 +- ...0-calc_alpha-orbital_33-dft_n+1_dummy.json | 4 +- ...cf_Fa0-calc_alpha-orbital_33-pz_print.json | 1028 +++++----- ...lepoint_si_ki_dscf_Fa0-final-ki_final.json | 1028 +++++----- ...lepoint_si_ki_dscf_Fa0-init-dft_dummy.json | 4 +- ...glepoint_si_ki_dscf_Fa0-init-dft_init.json | 4 +- ...i_ki_dscf_Fa0-init-wannier-emp-pw2wan.json | 4 +- ...si_ki_dscf_Fa0-init-wannier-emp-w2kcp.json | 4 +- ..._si_ki_dscf_Fa0-init-wannier-emp-wann.json | 4 +- ...scf_Fa0-init-wannier-emp-wann_preproc.json | 4 +- ...oint_si_ki_dscf_Fa0-init-wannier-nscf.json | 4 +- ...i_ki_dscf_Fa0-init-wannier-occ-pw2wan.json | 4 +- ...si_ki_dscf_Fa0-init-wannier-occ-w2kcp.json | 4 +- ..._si_ki_dscf_Fa0-init-wannier-occ-wann.json | 4 +- ...scf_Fa0-init-wannier-occ-wann_preproc.json | 4 +- ...point_si_ki_dscf_Fa0-init-wannier-scf.json | 4 +- ...epoint_si_ki_dscf_Fa0-postproc-emp-ki.json | 2 +- ...epoint_si_ki_dscf_Fa0-postproc-occ-ki.json | 2 +- ..._si_ki_dscf_Fa0-postproc-pdos-projwfc.json | 4 +- ...si_ki_dscf_Fa0-postproc-wannier-bands.json | 4 +- ..._dscf_Fa0-postproc-wannier-emp-pw2wan.json | 4 +- ...ki_dscf_Fa0-postproc-wannier-emp-wann.json | 4 +- ...Fa0-postproc-wannier-emp-wann_preproc.json | 4 +- ..._si_ki_dscf_Fa0-postproc-wannier-nscf.json | 4 +- ..._dscf_Fa0-postproc-wannier-occ-pw2wan.json | 4 +- ...ki_dscf_Fa0-postproc-wannier-occ-wann.json | 4 +- ...Fa0-postproc-wannier-occ-wann_preproc.json | 4 +- ...t_si_ki_dscf_Fa0-postproc-wannier-scf.json | 4 +- ...glepoint_si_ki_dscf_Tr0-calc_alpha-ki.json | 1028 +++++----- ...-calc_alpha-spin_1-orbital_32-dft_n-1.json | 4 +- ...-calc_alpha-spin_1-orbital_33-dft_n+1.json | 4 +- ...alpha-spin_1-orbital_33-dft_n+1_dummy.json | 4 +- ...calc_alpha-spin_1-orbital_33-pz_print.json | 1028 +++++----- ...-calc_alpha-spin_2-orbital_32-dft_n-1.json | 4 +- ...-calc_alpha-spin_2-orbital_33-dft_n+1.json | 4 +- ...alpha-spin_2-orbital_33-dft_n+1_dummy.json | 4 +- ...calc_alpha-spin_2-orbital_33-pz_print.json | 1028 +++++----- ...lepoint_si_ki_dscf_Tr0-final-ki_final.json | 1028 +++++----- ...lepoint_si_ki_dscf_Tr0-init-dft_dummy.json | 4 +- ...glepoint_si_ki_dscf_Tr0-init-dft_init.json | 4 +- ...dscf_Tr0-init-wannier-emp_down-pw2wan.json | 4 +- ..._dscf_Tr0-init-wannier-emp_down-w2kcp.json | 4 +- ...i_dscf_Tr0-init-wannier-emp_down-wann.json | 4 +- ...r0-init-wannier-emp_down-wann_preproc.json | 4 +- ...i_dscf_Tr0-init-wannier-emp_up-pw2wan.json | 4 +- ...ki_dscf_Tr0-init-wannier-emp_up-w2kcp.json | 4 +- ..._ki_dscf_Tr0-init-wannier-emp_up-wann.json | 4 +- ..._Tr0-init-wannier-emp_up-wann_preproc.json | 4 +- ...oint_si_ki_dscf_Tr0-init-wannier-nscf.json | 4 +- ...dscf_Tr0-init-wannier-occ_down-pw2wan.json | 4 +- ..._dscf_Tr0-init-wannier-occ_down-w2kcp.json | 4 +- ...i_dscf_Tr0-init-wannier-occ_down-wann.json | 4 +- ...r0-init-wannier-occ_down-wann_preproc.json | 4 +- ...i_dscf_Tr0-init-wannier-occ_up-pw2wan.json | 4 +- ...ki_dscf_Tr0-init-wannier-occ_up-w2kcp.json | 4 +- ..._ki_dscf_Tr0-init-wannier-occ_up-wann.json | 4 +- ..._Tr0-init-wannier-occ_up-wann_preproc.json | 4 +- ...point_si_ki_dscf_Tr0-init-wannier-scf.json | 4 +- ...t_si_ki_dscf_Tr0-postproc-emp_down-ki.json | 2 +- ...int_si_ki_dscf_Tr0-postproc-emp_up-ki.json | 2 +- ...t_si_ki_dscf_Tr0-postproc-occ_down-ki.json | 2 +- ...int_si_ki_dscf_Tr0-postproc-occ_up-ki.json | 2 +- ..._si_ki_dscf_Tr0-postproc-pdos-projwfc.json | 4 +- ...si_ki_dscf_Tr0-postproc-wannier-bands.json | 4 +- ..._Tr0-postproc-wannier-emp_down-pw2wan.json | 4 +- ...cf_Tr0-postproc-wannier-emp_down-wann.json | 4 +- ...ostproc-wannier-emp_down-wann_preproc.json | 4 +- ...cf_Tr0-postproc-wannier-emp_up-pw2wan.json | 4 +- ...dscf_Tr0-postproc-wannier-emp_up-wann.json | 4 +- ...-postproc-wannier-emp_up-wann_preproc.json | 4 +- ..._si_ki_dscf_Tr0-postproc-wannier-nscf.json | 4 +- ..._Tr0-postproc-wannier-occ_down-pw2wan.json | 4 +- ...cf_Tr0-postproc-wannier-occ_down-wann.json | 4 +- ...ostproc-wannier-occ_down-wann_preproc.json | 4 +- ...cf_Tr0-postproc-wannier-occ_up-pw2wan.json | 4 +- ...dscf_Tr0-postproc-wannier-occ_up-wann.json | 4 +- ...-postproc-wannier-occ_up-wann_preproc.json | 4 +- ...t_si_ki_dscf_Tr0-postproc-wannier-scf.json | 4 +- tests/benchmarks/test_ui_si0-si_ui.json | 2 +- .../test_wannierize_tio20-pdos-projwfc.json | 4 +- .../test_wannierize_tio20-wannier-bands.json | 4 +- ...t_wannierize_tio20-wannier-emp-pw2wan.json | 4 +- ...est_wannierize_tio20-wannier-emp-wann.json | 4 +- ...ierize_tio20-wannier-emp-wann_preproc.json | 4 +- .../test_wannierize_tio20-wannier-nscf.json | 4 +- ...erize_tio20-wannier-occ_block1-pw2wan.json | 4 +- ...nierize_tio20-wannier-occ_block1-wann.json | 4 +- ...tio20-wannier-occ_block1-wann_preproc.json | 4 +- ...erize_tio20-wannier-occ_block2-pw2wan.json | 4 +- ...nierize_tio20-wannier-occ_block2-wann.json | 4 +- ...tio20-wannier-occ_block2-wann_preproc.json | 4 +- ...erize_tio20-wannier-occ_block3-pw2wan.json | 4 +- ...nierize_tio20-wannier-occ_block3-wann.json | 4 +- ...tio20-wannier-occ_block3-wann_preproc.json | 4 +- ...erize_tio20-wannier-occ_block4-pw2wan.json | 4 +- ...nierize_tio20-wannier-occ_block4-wann.json | 4 +- ...tio20-wannier-occ_block4-wann_preproc.json | 4 +- .../test_wannierize_tio20-wannier-scf.json | 4 +- .../tutorials-tutorial_1-calc_alpha-ki.json | 164 +- ...torial_1-calc_alpha-orbital_1-dft_n-1.json | 4 +- ...orial_1-calc_alpha-orbital_10-dft_n+1.json | 4 +- ...1-calc_alpha-orbital_10-dft_n+1_dummy.json | 4 +- ...rial_1-calc_alpha-orbital_10-pz_print.json | 164 +- ...torial_1-calc_alpha-orbital_2-dft_n-1.json | 4 +- ...torial_1-calc_alpha-orbital_3-dft_n-1.json | 4 +- ...torial_1-calc_alpha-orbital_4-dft_n-1.json | 4 +- ...torial_1-calc_alpha-orbital_5-dft_n-1.json | 4 +- ...torial_1-calc_alpha-orbital_6-dft_n-1.json | 4 +- ...torial_1-calc_alpha-orbital_7-dft_n-1.json | 4 +- ...torial_1-calc_alpha-orbital_8-dft_n-1.json | 4 +- ...torial_1-calc_alpha-orbital_9-dft_n-1.json | 4 +- .../tutorials-tutorial_1-final-ki_final.json | 164 +- ...rials-tutorial_1-init-dft_init_nspin1.json | 4 +- ...rials-tutorial_1-init-dft_init_nspin2.json | 4 +- ...tutorial_1-init-dft_init_nspin2_dummy.json | 4 +- ...torials-tutorial_2-2x2x2-pdos-projwfc.json | 4 +- ...orials-tutorial_2-2x2x2-wannier-bands.json | 4 +- ...s-tutorial_2-2x2x2-wannier-emp-pw2wan.json | 4 +- ...als-tutorial_2-2x2x2-wannier-emp-wann.json | 4 +- ...rial_2-2x2x2-wannier-emp-wann_preproc.json | 4 +- ...torials-tutorial_2-2x2x2-wannier-nscf.json | 4 +- ...s-tutorial_2-2x2x2-wannier-occ-pw2wan.json | 4 +- ...als-tutorial_2-2x2x2-wannier-occ-wann.json | 4 +- ...rial_2-2x2x2-wannier-occ-wann_preproc.json | 4 +- ...utorials-tutorial_2-2x2x2-wannier-scf.json | 4 +- ...torials-tutorial_2-4x4x4-pdos-projwfc.json | 4 +- ...orials-tutorial_2-4x4x4-wannier-bands.json | 4 +- ...s-tutorial_2-4x4x4-wannier-emp-pw2wan.json | 4 +- ...als-tutorial_2-4x4x4-wannier-emp-wann.json | 4 +- ...rial_2-4x4x4-wannier-emp-wann_preproc.json | 4 +- ...torials-tutorial_2-4x4x4-wannier-nscf.json | 4 +- ...s-tutorial_2-4x4x4-wannier-occ-pw2wan.json | 4 +- ...als-tutorial_2-4x4x4-wannier-occ-wann.json | 4 +- ...rial_2-4x4x4-wannier-occ-wann_preproc.json | 4 +- ...utorials-tutorial_2-4x4x4-wannier-scf.json | 4 +- ...torials-tutorial_2-8x8x8-pdos-projwfc.json | 4 +- ...orials-tutorial_2-8x8x8-wannier-bands.json | 4 +- ...s-tutorial_2-8x8x8-wannier-emp-pw2wan.json | 4 +- ...als-tutorial_2-8x8x8-wannier-emp-wann.json | 4 +- ...rial_2-8x8x8-wannier-emp-wann_preproc.json | 4 +- ...torials-tutorial_2-8x8x8-wannier-nscf.json | 4 +- ...s-tutorial_2-8x8x8-wannier-occ-pw2wan.json | 4 +- ...als-tutorial_2-8x8x8-wannier-occ-wann.json | 4 +- ...rial_2-8x8x8-wannier-occ-wann_preproc.json | 4 +- ...utorials-tutorial_2-8x8x8-wannier-scf.json | 4 +- .../tutorials-tutorial_2-calc_alpha-ki.json | 1028 +++++----- ...orial_2-calc_alpha-orbital_32-dft_n-1.json | 4 +- ...orial_2-calc_alpha-orbital_33-dft_n+1.json | 4 +- ...2-calc_alpha-orbital_33-dft_n+1_dummy.json | 4 +- ...rial_2-calc_alpha-orbital_33-pz_print.json | 1028 +++++----- .../tutorials-tutorial_2-final-ki_final.json | 1028 +++++----- .../tutorials-tutorial_2-init-dft_dummy.json | 4 +- .../tutorials-tutorial_2-init-dft_init.json | 4 +- ...ls-tutorial_2-init-wannier-emp-pw2wan.json | 4 +- ...als-tutorial_2-init-wannier-emp-w2kcp.json | 4 +- ...ials-tutorial_2-init-wannier-emp-wann.json | 4 +- ...orial_2-init-wannier-emp-wann_preproc.json | 4 +- ...utorials-tutorial_2-init-wannier-nscf.json | 4 +- ...ls-tutorial_2-init-wannier-occ-pw2wan.json | 4 +- ...als-tutorial_2-init-wannier-occ-w2kcp.json | 4 +- ...ials-tutorial_2-init-wannier-occ-wann.json | 4 +- ...orial_2-init-wannier-occ-wann_preproc.json | 4 +- ...tutorials-tutorial_2-init-wannier-scf.json | 4 +- .../tutorials-tutorial_2-postproc-emp-ki.json | 2 +- .../tutorials-tutorial_2-postproc-occ-ki.json | 2 +- ...ials-tutorial_2-postproc-pdos-projwfc.json | 4 +- ...als-tutorial_2-postproc-wannier-bands.json | 4 +- ...utorial_2-postproc-wannier-emp-pw2wan.json | 4 +- ...-tutorial_2-postproc-wannier-emp-wann.json | 4 +- ...l_2-postproc-wannier-emp-wann_preproc.json | 4 +- ...ials-tutorial_2-postproc-wannier-nscf.json | 4 +- ...utorial_2-postproc-wannier-occ-pw2wan.json | 4 +- ...-tutorial_2-postproc-wannier-occ-wann.json | 4 +- ...l_2-postproc-wannier-occ-wann_preproc.json | 4 +- ...rials-tutorial_2-postproc-wannier-scf.json | 4 +- ...orials-tutorial_3-dfpt-hamiltonian-kc.json | 4 +- ...utorials-tutorial_3-dfpt-pdos-projwfc.json | 8 +- ...torials-tutorial_3-dfpt-wannier-bands.json | 8 +- ...ls-tutorial_3-dfpt-wannier-emp-pw2wan.json | 4 +- ...ials-tutorial_3-dfpt-wannier-emp-wann.json | 4 +- ...orial_3-dfpt-wannier-emp-wann_preproc.json | 4 +- .../tutorials-tutorial_3-dfpt-wannier-kc.json | 4 +- ...utorials-tutorial_3-dfpt-wannier-nscf.json | 8 +- ...rial_3-dfpt-wannier-occ_block1-pw2wan.json | 4 +- ...torial_3-dfpt-wannier-occ_block1-wann.json | 4 +- ...-dfpt-wannier-occ_block1-wann_preproc.json | 4 +- ...rial_3-dfpt-wannier-occ_block2-pw2wan.json | 4 +- ...torial_3-dfpt-wannier-occ_block2-wann.json | 4 +- ...-dfpt-wannier-occ_block2-wann_preproc.json | 4 +- ...rial_3-dfpt-wannier-occ_block3-pw2wan.json | 4 +- ...torial_3-dfpt-wannier-occ_block3-wann.json | 4 +- ...-dfpt-wannier-occ_block3-wann_preproc.json | 4 +- ...rial_3-dfpt-wannier-occ_block4-pw2wan.json | 4 +- ...torial_3-dfpt-wannier-occ_block4-wann.json | 4 +- ...-dfpt-wannier-occ_block4-wann_preproc.json | 4 +- ...tutorials-tutorial_3-dfpt-wannier-scf.json | 8 +- .../tutorials-tutorial_3-dft_bands-bands.json | 8 +- ...utorials-tutorial_3-dft_bands-projwfc.json | 8 +- .../tutorials-tutorial_3-dft_bands-scf.json | 8 +- .../tutorials-tutorial_3-pdos-projwfc.json | 8 +- .../tutorials-tutorial_3-wannier-bands.json | 8 +- ...torials-tutorial_3-wannier-emp-pw2wan.json | 4 +- ...tutorials-tutorial_3-wannier-emp-wann.json | 4 +- ...s-tutorial_3-wannier-emp-wann_preproc.json | 4 +- .../tutorials-tutorial_3-wannier-nscf.json | 8 +- ...-tutorial_3-wannier-occ_block1-pw2wan.json | 4 +- ...ls-tutorial_3-wannier-occ_block1-wann.json | 4 +- ...ial_3-wannier-occ_block1-wann_preproc.json | 4 +- ...-tutorial_3-wannier-occ_block2-pw2wan.json | 4 +- ...ls-tutorial_3-wannier-occ_block2-wann.json | 4 +- ...ial_3-wannier-occ_block2-wann_preproc.json | 4 +- ...-tutorial_3-wannier-occ_block3-pw2wan.json | 4 +- ...ls-tutorial_3-wannier-occ_block3-wann.json | 4 +- ...ial_3-wannier-occ_block3-wann_preproc.json | 4 +- ...-tutorial_3-wannier-occ_block4-pw2wan.json | 4 +- ...ls-tutorial_3-wannier-occ_block4-wann.json | 4 +- ...ial_3-wannier-occ_block4-wann_preproc.json | 4 +- .../tutorials-tutorial_3-wannier-scf.json | 8 +- ...rial_4-ecutwfc_20d0-cell_size_1d0-dft.json | 8 +- ...rial_4-ecutwfc_20d0-cell_size_1d1-dft.json | 8 +- ...rial_4-ecutwfc_20d0-cell_size_1d2-dft.json | 8 +- ...rial_4-ecutwfc_20d0-cell_size_1d3-dft.json | 8 +- ...rial_4-ecutwfc_30d0-cell_size_1d0-dft.json | 8 +- ...rial_4-ecutwfc_30d0-cell_size_1d1-dft.json | 8 +- ...rial_4-ecutwfc_30d0-cell_size_1d2-dft.json | 8 +- ...rial_4-ecutwfc_30d0-cell_size_1d3-dft.json | 8 +- ...rial_4-ecutwfc_40d0-cell_size_1d0-dft.json | 8 +- ...rial_4-ecutwfc_40d0-cell_size_1d1-dft.json | 8 +- ...rial_4-ecutwfc_40d0-cell_size_1d2-dft.json | 8 +- ...rial_4-ecutwfc_40d0-cell_size_1d3-dft.json | 8 +- ...rial_4-ecutwfc_50d0-cell_size_1d0-dft.json | 8 +- ...rial_4-ecutwfc_50d0-cell_size_1d1-dft.json | 8 +- ...rial_4-ecutwfc_50d0-cell_size_1d2-dft.json | 8 +- ...rial_4-ecutwfc_50d0-cell_size_1d3-dft.json | 8 +- ...rial_4-ecutwfc_60d0-cell_size_1d0-dft.json | 8 +- ...rial_4-ecutwfc_60d0-cell_size_1d1-dft.json | 8 +- ...rial_4-ecutwfc_60d0-cell_size_1d2-dft.json | 8 +- ...rial_4-ecutwfc_60d0-cell_size_1d3-dft.json | 8 +- tests/calculators/test_koopmans_cp.py | 1 - tests/calculators/test_ph.py | 6 +- tests/calculators/test_projwfc.py | 6 +- tests/patches/__init__.py | 110 ++ {koopmans/testing => tests/patches}/_check.py | 2 +- .../patches}/_generate_benchmarks.py | 0 {koopmans/testing => tests/patches}/_mock.py | 2 +- .../testing => tests/patches}/_stumble.py | 1 + {koopmans/testing => tests/patches}/_utils.py | 0 {koopmans/testing => tests}/strategies.py | 8 +- tests/test_cell.py | 7 +- tests/test_kpoints.py | 5 +- tests/test_utils.py | 6 +- tests/workflows/test_ui.py | 6 +- 412 files changed, 8269 insertions(+), 8265 deletions(-) delete mode 100644 koopmans/testing/__init__.py create mode 100644 tests/__init__.py create mode 100644 tests/patches/__init__.py rename {koopmans/testing => tests/patches}/_check.py (100%) rename {koopmans/testing => tests/patches}/_generate_benchmarks.py (100%) rename {koopmans/testing => tests/patches}/_mock.py (100%) rename {koopmans/testing => tests/patches}/_stumble.py (99%) rename {koopmans/testing => tests/patches}/_utils.py (100%) rename {koopmans/testing => tests}/strategies.py (100%) diff --git a/codecov.yml b/codecov.yml index 02e8b0151..57b9db045 100644 --- a/codecov.yml +++ b/codecov.yml @@ -11,6 +11,3 @@ coverage: project: off patch: off changes: off - -ignore: - - "koopmans/testing" diff --git a/conftest.py b/conftest.py index 55ad148c5..b1f87fe5b 100644 --- a/conftest.py +++ b/conftest.py @@ -1,13 +1,14 @@ from typing import Any, Dict import pytest - from ase import Atoms from ase.build import bulk, molecule from ase.spacegroup import crystal -from koopmans import base_directory, testing + +from koopmans import base_directory from koopmans.kpoints import Kpoints from koopmans.projections import ProjectionBlocks +from tests import patches def pytest_addoption(parser): @@ -25,92 +26,18 @@ def datadir(): return base_directory / 'tests' / 'data' -def monkeypatch_bench(monkeypatch): - # After each calculation is run, store the results in a json (one json per calculation) - monkeypatch.setattr('koopmans.calculators.Wannier90Calculator', testing.BenchGenWannier90Calculator) - monkeypatch.setattr('koopmans.calculators.PW2WannierCalculator', testing.BenchGenPW2WannierCalculator) - monkeypatch.setattr('koopmans.calculators.Wann2KCPCalculator', testing.BenchGenWann2KCPCalculator) - monkeypatch.setattr('koopmans.calculators.PhCalculator', testing.BenchGenPhCalculator) - monkeypatch.setattr('koopmans.calculators.PWCalculator', testing.BenchGenPWCalculator) - monkeypatch.setattr('koopmans.calculators.KoopmansCPCalculator', testing.BenchGenKoopmansCPCalculator) - monkeypatch.setattr('koopmans.calculators.EnvironCalculator', testing.BenchGenEnvironCalculator) - monkeypatch.setattr('koopmans.calculators.UnfoldAndInterpolateCalculator', - testing.BenchGenUnfoldAndInterpolateCalculator) - monkeypatch.setattr('koopmans.calculators.Wann2KCCalculator', testing.BenchGenWann2KCCalculator) - monkeypatch.setattr('koopmans.calculators.KoopmansScreenCalculator', testing.BenchGenKoopmansScreenCalculator) - monkeypatch.setattr('koopmans.calculators.KoopmansHamCalculator', testing.BenchGenKoopmansHamCalculator) - monkeypatch.setattr('koopmans.calculators.ProjwfcCalculator', testing.BenchGenProjwfcCalculator) - - -def monkeypatch_mock(monkeypatch): - # Replace calculators with mock versions that obtain results from the database - monkeypatch.setattr('koopmans.calculators.KoopmansCPCalculator', testing.MockKoopmansCPCalculator) - monkeypatch.setattr('koopmans.calculators.Wannier90Calculator', testing.MockWannier90Calculator) - monkeypatch.setattr('koopmans.calculators.PW2WannierCalculator', testing.MockPW2WannierCalculator) - monkeypatch.setattr('koopmans.calculators.Wann2KCPCalculator', testing.MockWann2KCPCalculator) - monkeypatch.setattr('koopmans.calculators.PhCalculator', testing.MockPhCalculator) - monkeypatch.setattr('koopmans.calculators.PWCalculator', testing.MockPWCalculator) - monkeypatch.setattr('koopmans.calculators.KoopmansCPCalculator', testing.MockKoopmansCPCalculator) - monkeypatch.setattr('koopmans.calculators.EnvironCalculator', testing.MockEnvironCalculator) - monkeypatch.setattr('koopmans.calculators.UnfoldAndInterpolateCalculator', - testing.MockUnfoldAndInterpolateCalculator) - monkeypatch.setattr('koopmans.calculators.Wann2KCCalculator', testing.MockWann2KCCalculator) - monkeypatch.setattr('koopmans.calculators.KoopmansScreenCalculator', testing.MockKoopmansScreenCalculator) - monkeypatch.setattr('koopmans.calculators.KoopmansHamCalculator', testing.MockKoopmansHamCalculator) - monkeypatch.setattr('koopmans.calculators.ProjwfcCalculator', testing.MockProjwfcCalculator) - - # Workflows - monkeypatch.setattr('koopmans.workflows.KoopmansDSCFWorkflow', testing.MockKoopmansDSCFWorkflow) - monkeypatch.setattr('koopmans.workflows.WannierizeWorkflow', testing.MockWannierizeWorkflow) - - -def monkeypatch_check(monkeypatch): - # Replace calculators with versions that double-check their results against - monkeypatch.setattr('koopmans.calculators.KoopmansCPCalculator', testing.CheckKoopmansCPCalculator) - monkeypatch.setattr('koopmans.calculators.Wannier90Calculator', testing.CheckWannier90Calculator) - monkeypatch.setattr('koopmans.calculators.PW2WannierCalculator', testing.CheckPW2WannierCalculator) - monkeypatch.setattr('koopmans.calculators.Wann2KCPCalculator', testing.CheckWann2KCPCalculator) - monkeypatch.setattr('koopmans.calculators.PhCalculator', testing.CheckPhCalculator) - monkeypatch.setattr('koopmans.calculators.PWCalculator', testing.CheckPWCalculator) - monkeypatch.setattr('koopmans.calculators.KoopmansCPCalculator', testing.CheckKoopmansCPCalculator) - monkeypatch.setattr('koopmans.calculators.EnvironCalculator', testing.CheckEnvironCalculator) - monkeypatch.setattr('koopmans.calculators.UnfoldAndInterpolateCalculator', - testing.CheckUnfoldAndInterpolateCalculator) - monkeypatch.setattr('koopmans.calculators.Wann2KCCalculator', testing.CheckWann2KCCalculator) - monkeypatch.setattr('koopmans.calculators.KoopmansScreenCalculator', testing.CheckKoopmansScreenCalculator) - monkeypatch.setattr('koopmans.calculators.KoopmansHamCalculator', testing.CheckKoopmansHamCalculator) - monkeypatch.setattr('koopmans.calculators.ProjwfcCalculator', testing.CheckProjwfcCalculator) - - -def monkeypatch_stumble(monkeypatch): - monkeypatch.setattr('koopmans.workflows.WannierizeWorkflow', testing.StumblingWannierizeWorkflow) - monkeypatch.setattr('koopmans.workflows.KoopmansDSCFWorkflow', testing.StumblingKoopmansDSCFWorkflow) - monkeypatch.setattr('koopmans.workflows.SinglepointWorkflow', testing.StumblingSinglepointWorkflow) - monkeypatch.setattr('koopmans.workflows.ConvergenceWorkflow', testing.StumblingConvergenceWorkflow) - monkeypatch.setattr('koopmans.workflows.FoldToSupercellWorkflow', testing.StumblingFoldToSupercellWorkflow) - monkeypatch.setattr('koopmans.workflows.DFTCPWorkflow', testing.StumblingDFTCPWorkflow) - monkeypatch.setattr('koopmans.workflows.DFTPhWorkflow', testing.StumblingDFTPhWorkflow) - monkeypatch.setattr('koopmans.workflows.DFTPWWorkflow', testing.StumblingDFTPWWorkflow) - monkeypatch.setattr('koopmans.workflows.DeltaSCFWorkflow', testing.StumblingDeltaSCFWorkflow) - monkeypatch.setattr('koopmans.workflows.KoopmansDFPTWorkflow', testing.StumblingKoopmansDFPTWorkflow) - monkeypatch.setattr('koopmans.workflows.UnfoldAndInterpolateWorkflow', - testing.StumblingUnfoldAndInterpolateWorkflow) - # When running with stumble mode, we want to check our results against the benchmarks by using CheckCalcs - monkeypatch_check(monkeypatch) - - @pytest.fixture def tutorial_patch(monkeypatch, pytestconfig): # For the tutorials... if pytestconfig.getoption('generate_benchmark'): # when generating benchmarks, use BenchCalcs - monkeypatch_bench(monkeypatch) + patches.monkeypatch_bench(monkeypatch) elif pytestconfig.getoption('stumble'): # when testing recovery from a crash, use StumblingWorkflows - monkeypatch_stumble(monkeypatch) + patches.monkeypatch_stumble(monkeypatch) else: # we use MockCalcs when running our tests on github, OR if the user is running locally - monkeypatch_mock(monkeypatch) + patches.monkeypatch_mock(monkeypatch) @pytest.fixture @@ -118,13 +45,13 @@ def workflow_patch(monkeypatch, pytestconfig): # For tests involving the workflow... if pytestconfig.getoption('generate_benchmark'): # when generating benchmarks, use BenchCalcs - monkeypatch_bench(monkeypatch) + patches.monkeypatch_bench(monkeypatch) elif pytestconfig.getoption('stumble'): # when testing recovery from a crash, use StumblingWorkflows - monkeypatch_stumble(monkeypatch) + patches.monkeypatch_stumble(monkeypatch) else: # we use MockCalcs when running our tests on github, OR if the user is running locally - monkeypatch_mock(monkeypatch) + patches.monkeypatch_mock(monkeypatch) @pytest.fixture @@ -132,10 +59,10 @@ def ui_patch(monkeypatch, pytestconfig): # For tests involving the UI python routines only... if pytestconfig.getoption('generate_benchmark'): # when generating benchmarks, use BenchCalcs - monkeypatch_bench(monkeypatch) + patches.monkeypatch_bench(monkeypatch) elif pytestconfig.getoption('stumble'): # when testing recovery from a crash, use StumblingWorkflows - monkeypatch_stumble(monkeypatch) + patches.monkeypatch_stumble(monkeypatch) else: # we can run the calculations directly when running our tests on github, OR if the user is running locally pass @@ -146,16 +73,16 @@ def espresso_patch(monkeypatch, pytestconfig): # For tests involving Quantum ESPRESSO... if pytestconfig.getoption('generate_benchmark'): # when generating benchmarks, use BenchCalcs - monkeypatch_bench(monkeypatch) + patches.monkeypatch_bench(monkeypatch) elif pytestconfig.getoption('stumble'): # when testing recovery from a crash, use StumblingWorkflows - monkeypatch_stumble(monkeypatch) + patches.monkeypatch_stumble(monkeypatch) elif pytestconfig.getoption('ci'): # when running our tests on github, these tests shold not be called! raise ValueError('These tests cannot be run with --ci') else: # when the user is running locally, use CheckCalcs - monkeypatch_check(monkeypatch) + patches.monkeypatch_check(monkeypatch) @pytest.fixture diff --git a/koopmans/testing/__init__.py b/koopmans/testing/__init__.py deleted file mode 100644 index da9572bf2..000000000 --- a/koopmans/testing/__init__.py +++ /dev/null @@ -1,36 +0,0 @@ -from ._check import (CheckEnvironCalculator, CheckKoopmansCPCalculator, - CheckKoopmansHamCalculator, CheckKoopmansScreenCalculator, - CheckPhCalculator, CheckProjwfcCalculator, - CheckPW2WannierCalculator, CheckPWCalculator, - CheckUnfoldAndInterpolateCalculator, - CheckWann2KCCalculator, CheckWann2KCPCalculator, - CheckWannier90Calculator, compare) -from ._generate_benchmarks import (BenchGenEnvironCalculator, - BenchGenKoopmansCPCalculator, - BenchGenKoopmansHamCalculator, - BenchGenKoopmansScreenCalculator, - BenchGenPhCalculator, - BenchGenProjwfcCalculator, - BenchGenPW2WannierCalculator, - BenchGenPWCalculator, - BenchGenUnfoldAndInterpolateCalculator, - BenchGenWann2KCCalculator, - BenchGenWann2KCPCalculator, - BenchGenWannier90Calculator) -from ._mock import (MockEnvironCalculator, MockKoopmansCPCalculator, - MockKoopmansDSCFWorkflow, MockKoopmansHamCalculator, - MockKoopmansScreenCalculator, MockPhCalculator, - MockProjwfcCalculator, MockPW2WannierCalculator, - MockPWCalculator, MockUnfoldAndInterpolateCalculator, - MockWann2KCCalculator, MockWann2KCPCalculator, - MockWannier90Calculator, MockWannierizeWorkflow) -from ._stumble import (StumblingConvergenceWorkflow, StumblingDeltaSCFWorkflow, - StumblingDFTCPWorkflow, StumblingDFTPhWorkflow, - StumblingDFTPWWorkflow, - StumblingFoldToSupercellWorkflow, - StumblingKoopmansDFPTWorkflow, - StumblingKoopmansDSCFWorkflow, - StumblingSinglepointWorkflow, - StumblingUnfoldAndInterpolateWorkflow, - StumblingWannierizeWorkflow) -from ._utils import benchmark_filename diff --git a/tests/__init__.py b/tests/__init__.py new file mode 100644 index 000000000..f8b12021b --- /dev/null +++ b/tests/__init__.py @@ -0,0 +1,4 @@ +""" koopmans testing module + +This is a module in order to allow for pytest plugins to be locally defined as tests. +""" diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin1.json index 2de2ac483..7f1b20368 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin1.json @@ -9,8 +9,8 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -734,7 +734,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -756,5 +756,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2.json index 2070d2ed1..4fc557b80 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -492,7 +492,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -505,5 +505,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2_dummy.json index e5fcef54c..84bc19b52 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2_dummy.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -380,7 +380,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -393,5 +393,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin1.json index c82709d1d..fc541c56c 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin1.json @@ -9,8 +9,8 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -746,7 +746,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -768,5 +768,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2.json index ff86546cc..7112c84f9 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -492,7 +492,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -505,5 +505,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2_dummy.json index c360c10fd..7e16c299a 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2_dummy.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -380,7 +380,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -393,5 +393,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin1.json index b856cfa80..9c79f2fc1 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin1.json @@ -9,8 +9,8 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -740,7 +740,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -762,5 +762,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2.json index 47c9d5312..50e091790 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -492,7 +492,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -505,5 +505,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2_dummy.json index 2d6b7f41f..cff6cf11c 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2_dummy.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -380,7 +380,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -393,5 +393,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin1.json index 17b7a83d8..1ae7c3ecc 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin1.json @@ -9,8 +9,8 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -758,7 +758,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -780,5 +780,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2.json index 7c86cb027..7fbac8d13 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -492,7 +492,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -505,5 +505,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2_dummy.json index 93a04388d..7fae3985d 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2_dummy.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -380,7 +380,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -393,5 +393,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin1.json index 3757d8517..3dc64c63f 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin1.json @@ -9,8 +9,8 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -818,7 +818,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -840,5 +840,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2.json index e2ae0d322..fa959580c 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -492,7 +492,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -505,5 +505,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2_dummy.json index 9a4f844fc..10df58bb4 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2_dummy.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -380,7 +380,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -393,5 +393,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin1.json index 78baff876..e398c7fd0 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin1.json @@ -9,8 +9,8 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -860,7 +860,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -882,5 +882,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2.json index 3f5415e46..e36c10860 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -492,7 +492,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -505,5 +505,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2_dummy.json index d2b879884..22a36ab68 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2_dummy.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -380,7 +380,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -393,5 +393,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin1.json index 4af50316c..bf87d982d 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin1.json @@ -9,8 +9,8 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -830,7 +830,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -852,5 +852,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2.json index e2676acb2..103b784a3 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -492,7 +492,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -505,5 +505,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2_dummy.json index 1cd144334..ad8bf37b5 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2_dummy.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -380,7 +380,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -393,5 +393,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin1.json index 640d3d8df..f2317b74e 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin1.json @@ -9,8 +9,8 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -824,7 +824,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -846,5 +846,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2.json index 89ddf0c70..0bfe37fdb 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -492,7 +492,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -505,5 +505,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2_dummy.json index 806411a5b..d4469b600 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2_dummy.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -380,7 +380,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -393,5 +393,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin1.json index 54f219cf9..aafe3b39b 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin1.json @@ -9,8 +9,8 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -758,7 +758,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -780,5 +780,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2.json index 99b783215..ccfaed96a 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -486,7 +486,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -499,5 +499,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2_dummy.json index 672c71a28..fc5f3ce44 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2_dummy.json @@ -11,8 +11,8 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -380,7 +380,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -393,5 +393,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_dftbands_si0-dft_bands-bands.json b/tests/benchmarks/test_dftbands_si0-dft_bands-bands.json index a3a5a13b2..cad169370 100644 --- a/tests/benchmarks/test_dftbands_si0-dft_bands-bands.json +++ b/tests/benchmarks/test_dftbands_si0-dft_bands-bands.json @@ -726,7 +726,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -1429,5 +1429,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_dftbands_si0-dft_bands-projwfc.json b/tests/benchmarks/test_dftbands_si0-dft_bands-projwfc.json index 10a75b084..d677965bc 100644 --- a/tests/benchmarks/test_dftbands_si0-dft_bands-projwfc.json +++ b/tests/benchmarks/test_dftbands_si0-dft_bands-projwfc.json @@ -22089,7 +22089,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "projwfc.x", "_flags": "", @@ -22107,5 +22107,5 @@ }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_dftbands_si0-dft_bands-scf.json b/tests/benchmarks/test_dftbands_si0-dft_bands-scf.json index 55b505cd9..7a8dca609 100644 --- a/tests/benchmarks/test_dftbands_si0-dft_bands-scf.json +++ b/tests/benchmarks/test_dftbands_si0-dft_bands-scf.json @@ -110,7 +110,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -195,5 +195,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_dftph_tio20-eps.json b/tests/benchmarks/test_dftph_tio20-eps.json index 607e73af1..53c339e7f 100644 --- a/tests/benchmarks/test_dftph_tio20-eps.json +++ b/tests/benchmarks/test_dftph_tio20-eps.json @@ -144,7 +144,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "ph.x", "_flags": "", @@ -155,5 +155,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPhCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_dftph_tio20-scf.json b/tests/benchmarks/test_dftph_tio20-scf.json index d15ab1809..558361d73 100644 --- a/tests/benchmarks/test_dftph_tio20-scf.json +++ b/tests/benchmarks/test_dftph_tio20-scf.json @@ -149,7 +149,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -426,5 +426,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-final-ki_final.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-final-ki_final.json index 9eb396720..a582971a8 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-final-ki_final.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-final-ki_final.json @@ -14,8 +14,8 @@ "ecutwfc": 40.0, "nbnd": 104, "pseudopotentials": { - "Ga": "Ga_ONCV_PBE-1.0.upf", - "As": "As_ONCV_PBE-1.0.upf" + "As": "As_ONCV_PBE-1.0.upf", + "Ga": "Ga_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -600,1261 +600,1261 @@ "centres": [ [ [ - -0.0, - -0.0, - -0.0 + -2.3495468050897235, + -2.3495468050897235, + -2.3495468050897235 ], [ - 0.0, - 0.0, - 0.0 + -2.3389632609226525, + -2.3389632609226525, + -2.3389632609226525 ], [ - 0.0, - 0.0, - 0.0 + -2.3389632609226525, + -2.3389632609226525, + -2.3389632609226525 ], [ - -0.0, - -0.0, - -0.0 + -2.3495468050897235, + -2.3495468050897235, + -2.3495468050897235 ], [ - 0.0, - 0.0, - 0.0 + -2.3389632609226525, + -2.3389632609226525, + -2.3389632609226525 ], [ - 1.4711126392228449, - 1.4711126392228449, - 1.4711126392228449 + -0.7514316358620287, + -0.7514316358620287, + -0.7514316358620287 ], [ - 1.4711126392228449, - 1.1324392258765785, - 1.1324392258765785 + -0.7514316358620287, + -1.0689379608741534, + -1.0689379608741534 ], [ - 1.1324392258765785, - 1.4711126392228449, - 1.1324392258765785 + -1.0689379608741534, + -0.7514316358620287, + -1.0689379608741534 ], [ - 1.1324392258765785, - 1.1324392258765785, - 1.4711126392228449 + -1.0689379608741534, + -1.0689379608741534, + -0.7514316358620287 ], [ - -0.13229430208838533, - -0.13229430208838533, - -0.0 + 0.4762594875181872, + 0.4762594875181872, + -2.3495468050897235 ], [ - -0.2857556925109123, - -0.2857556925109123, - 0.0 + 0.4762594875181872, + 0.4762594875181872, + -2.3389632609226525 ], [ - -0.2857556925109123, - -0.2857556925109123, - 0.0 + 0.4762594875181872, + 0.4762594875181872, + -2.3389632609226525 ], [ - -0.12171075792131451, - -0.12171075792131451, - -0.0 + 0.4762594875181872, + 0.4762594875181872, + -2.3495468050897235 ], [ - -0.23283797167555817, - -0.23283797167555817, - 0.0 + 0.4762594875181872, + 0.4762594875181872, + -2.3389632609226525 ], [ - -0.6614715104419266, - -0.6614715104419266, - 1.4764044113063803 + 0.7990575846138473, + 0.7990575846138473, + -0.7514316358620287 ], [ - -0.6614715104419266, - -1.0054366958717285, - 1.1324392258765785 + 0.7990575846138473, + 0.4815512596017226, + -1.0689379608741534 ], [ - -1.0054366958717285, - -0.6614715104419266, - 1.1324392258765785 + 0.4815512596017226, + 0.7990575846138473, + -1.0689379608741534 ], [ - 0.010583544167070826, - 0.010583544167070826, - 1.4764044113063803 + 0.6350126500242496, + 0.6350126500242496, + -0.7514316358620287 ], [ - -0.11641898583777908, - -0.0, - -0.11641898583777908 + 0.4762594875181872, + -2.3495468050897235, + 0.4762594875181872 ], [ - -0.19050379500727488, - 0.0, - -0.19050379500727488 + 0.4762594875181872, + -2.3389632609226525, + 0.4762594875181872 ], [ - -0.26458860417677066, - 0.0, - -0.26458860417677066 + 0.4762594875181872, + -2.3389632609226525, + 0.4762594875181872 ], [ - -0.11112721375424367, - -0.0, - -0.11112721375424367 + 0.4762594875181872, + -2.3495468050897235, + 0.4762594875181872 ], [ - -0.26458860417677066, - 0.0, - -0.26458860417677066 + 0.4762594875181872, + -2.3389632609226525, + 0.4762594875181872 ], [ - -0.6403044221077849, - 1.4711126392228449, - -0.6350126500242496 + 0.7990575846138473, + -0.7514316358620287, + 0.7990575846138473 ], [ - -0.6350126500242496, - 1.1324392258765785, - -0.9789778354540515 + 0.7990575846138473, + -1.0689379608741534, + 0.4815512596017226 ], [ - 0.0793765812530312, - 1.4711126392228449, - 0.0793765812530312 + 0.6350126500242496, + -0.7514316358620287, + 0.6350126500242496 ], [ - -0.9789778354540515, - 1.1324392258765785, - -0.6350126500242496 + 0.4815512596017226, + -1.0689379608741534, + 0.7990575846138473 ], [ - -0.19579556709081028, - -0.12171075792131451, - -0.0740848091694958 + 3.2967740080425627, + 0.4762594875181872, + 0.4762594875181872 ], [ - -0.4127582225157622, - -0.24342151584262903, - -0.16933670667313322 + 3.2967740080425627, + 0.4762594875181872, + 0.4762594875181872 ], [ - -0.5185936641864705, - -0.30163100876151855, - -0.21696265542495194 + 3.2967740080425627, + 0.4762594875181872, + 0.4762594875181872 ], [ - -0.2487132879261644, - -0.15346139042252696, - -0.09525189750363744 + 3.2967740080425627, + 0.4762594875181872, + 0.4762594875181872 ], [ - -0.47096771543465177, - -0.30163100876151855, - -0.16404493458959782 + 3.2967740080425627, + 0.4762594875181872, + 0.4762594875181872 ], [ - -2.7358461671878085, - -0.6350126500242496, - -0.6191373337736433 + 2.344255033006188, + 0.7990575846138473, + 0.7990575846138473 ], [ - -2.7358461671878085, - -0.9789778354540515, - -0.9631025192034453 + 2.344255033006188, + 0.4815512596017226, + 0.4815512596017226 ], [ - -1.9897063034093152, - -0.6350126500242496, - 0.12171075792131451 + 2.1855018705001257, + 0.7990575846138473, + 0.6350126500242496 ], [ - -2.0055816196599214, - 0.08996012542010202, - -0.6244291058571787 + 2.1855018705001257, + 0.6350126500242496, + 0.7990575846138473 ], [ - -0.0, - -0.11641898583777908, - -0.11641898583777908 + -2.3495468050897235, + 0.4762594875181872, + 0.4762594875181872 ], [ - 0.0, - -0.26458860417677066, - -0.26458860417677066 + -2.3389632609226525, + 0.4762594875181872, + 0.4762594875181872 ], [ - 0.0, - -0.19050379500727488, - -0.19050379500727488 + -2.3389632609226525, + 0.4762594875181872, + 0.4762594875181872 ], [ - -0.0, - -0.11112721375424367, - -0.11112721375424367 + -2.3495468050897235, + 0.4762594875181872, + 0.4762594875181872 ], [ - 0.0, - -0.26458860417677066, - -0.26458860417677066 + -2.3389632609226525, + 0.4762594875181872, + 0.4762594875181872 ], [ - 1.4711126392228449, - -0.6403044221077849, - -0.6350126500242496 + -0.7514316358620287, + 0.7990575846138473, + 0.7990575846138473 ], [ - 1.4711126392228449, - 0.0793765812530312, - 0.0793765812530312 + -0.7514316358620287, + 0.6350126500242496, + 0.6350126500242496 ], [ - 1.1324392258765785, - -0.6350126500242496, - -0.9789778354540515 + -1.0689379608741534, + 0.7990575846138473, + 0.4815512596017226 ], [ - 1.1324392258765785, - -0.9789778354540515, - -0.6350126500242496 + -1.0689379608741534, + 0.4815512596017226, + 0.7990575846138473 ], [ - -0.12171075792131451, - -0.19579556709081028, - -0.0740848091694958 + 0.4762594875181872, + 3.2967740080425627, + 0.4762594875181872 ], [ - -0.30163100876151855, - -0.5185936641864705, - -0.21696265542495194 + 0.4762594875181872, + 3.2967740080425627, + 0.4762594875181872 ], [ - -0.24342151584262903, - -0.4127582225157622, - -0.16933670667313322 + 0.4762594875181872, + 3.2967740080425627, + 0.4762594875181872 ], [ - -0.15346139042252696, - -0.2487132879261644, - -0.09525189750363744 + 0.4762594875181872, + 3.2967740080425627, + 0.4762594875181872 ], [ - -0.30163100876151855, - -0.47096771543465177, - -0.16404493458959782 + 0.4762594875181872, + 3.2967740080425627, + 0.4762594875181872 ], [ - -0.6350126500242496, - -2.7358461671878085, - -0.6191373337736433 + 0.7990575846138473, + 2.344255033006188, + 0.7990575846138473 ], [ - -0.6350126500242496, - -1.9897063034093152, - 0.12171075792131451 + 0.7990575846138473, + 2.1855018705001257, + 0.6350126500242496 ], [ - -0.9789778354540515, - -2.7358461671878085, - -0.9631025192034453 + 0.4815512596017226, + 2.344255033006188, + 0.4815512596017226 ], [ - 0.08996012542010202, - -2.0055816196599214, - -0.6244291058571787 + 0.6350126500242496, + 2.1855018705001257, + 0.7990575846138473 ], [ - -0.11641898583777908, - -0.11641898583777908, - -0.22754619959202277 + 0.4762594875181872, + 0.4762594875181872, + 3.2967740080425627 ], [ - -0.16933670667313322, - -0.16404493458959782, - -0.333381641262731 + 0.4762594875181872, + 0.4762594875181872, + 3.2967740080425627 ], [ - -0.16404493458959782, - -0.16933670667313322, - -0.333381641262731 + 0.4762594875181872, + 0.4762594875181872, + 3.2967740080425627 ], [ - -0.05820949291888954, - -0.05820949291888954, - -0.11112721375424367 + 0.4762594875181872, + 0.4762594875181872, + 3.2967740080425627 ], [ - -0.21696265542495194, - -0.21696265542495194, - -0.4286335387663685 + 0.4762594875181872, + 0.4762594875181872, + 3.2967740080425627 ], [ - -0.6244291058571787, - -0.6244291058571787, - -2.719970850937202 + 0.7990575846138473, + 0.7990575846138473, + 2.344255033006188 ], [ - -0.6244291058571787, - 0.11641898583777908, - -1.9791227592422447 + 0.7990575846138473, + 0.6350126500242496, + 2.1855018705001257 ], [ - 0.11641898583777908, - -0.6244291058571787, - -1.9791227592422447 + 0.6350126500242496, + 0.7990575846138473, + 2.1855018705001257 ], [ - -0.9683942912869806, - -0.9683942912869806, - -2.719970850937202 + 0.4815512596017226, + 0.4815512596017226, + 2.344255033006188 ], [ - -0.19050379500727488, - -0.19050379500727488, - -0.15346139042252696 + 3.2967740080425627, + 3.2967740080425627, + 3.2967740080425627 ], [ - -0.33867341334626644, - -0.4445088550169747, - -0.2540050600096998 + 3.2967740080425627, + 3.2967740080425627, + 3.2967740080425627 ], [ - -0.4445088550169747, - -0.33867341334626644, - -0.2540050600096998 + 3.2967740080425627, + 3.2967740080425627, + 3.2967740080425627 ], [ - -0.18521202292373945, - -0.18521202292373945, - -0.11112721375424367 + 3.2967740080425627, + 3.2967740080425627, + 3.2967740080425627 ], [ - -0.4127582225157622, - -0.4127582225157622, - -0.3598405016804081 + 3.2967740080425627, + 3.2967740080425627, + 3.2967740080425627 ], [ - -2.7464297113548795, - -2.7464297113548795, - -2.714679078853667 + 2.344255033006188, + 2.344255033006188, + 2.344255033006188 ], [ - -2.7464297113548795, - -2.010873391743457, - -1.9791227592422447 + 2.344255033006188, + 2.1855018705001257, + 2.1855018705001257 ], [ - -2.010873391743457, - -2.7464297113548795, - -1.9791227592422447 + 2.1855018705001257, + 2.344255033006188, + 2.1855018705001257 ], [ - -2.058499340495276, - -2.058499340495276, - -2.714679078853667 + 2.1855018705001257, + 2.1855018705001257, + 2.344255033006188 ], [ - 0.5238854362700059, - 0.5238854362700059, - 0.5291772083535413 + -1.4711126392228449, + -1.4711126392228449, + -1.4711126392228449 ], [ - 0.5238854362700059, - 0.2857556925109123, - 0.2857556925109123 + -1.4711126392228449, + -0.70380568711021, + -0.70380568711021 ], [ - 0.2857556925109123, - 0.5238854362700059, - 0.2857556925109123 + -0.70380568711021, + -1.4711126392228449, + -0.70380568711021 ], [ - 0.2751721483438415, - 0.2751721483438415, - 0.5291772083535413 + -0.70380568711021, + -0.70380568711021, + -1.4711126392228449 ], [ - -0.2857556925109123, - -0.2857556925109123, - 0.5291772083535413 + 0.4921348037687934, + 0.4921348037687934, + -1.4711126392228449 ], [ - -0.2698803762603061, - -0.4974265758523288, - 0.2963392366779832 + 0.4921348037687934, + 1.2541499837978929, + -0.70380568711021 ], [ - -0.4974265758523288, - -0.2698803762603061, - 0.2963392366779832 + 1.2541499837978929, + 0.4921348037687934, + -0.70380568711021 ], [ - 0.6773468266925329, - 0.6773468266925329, - 0.5291772083535413 + -0.5185936641864705, + -0.5185936641864705, + -1.4711126392228449 ], [ - -0.26458860417677066, - 0.5291772083535413, - -0.26458860417677066 + 0.4921348037687934, + -1.4711126392228449, + 0.4921348037687934 ], [ - -0.24342151584262903, - 0.2963392366779832, - -0.4762594875181872 + 0.4921348037687934, + -0.70380568711021, + 1.2541499837978929 ], [ - 0.6826385987760684, - 0.5291772083535413, - 0.6879303708596037 + -0.5185936641864705, + -1.4711126392228449, + -0.5185936641864705 ], [ - -0.4815512596017226, - 0.29104746459444775, - -0.24342151584262903 + 1.2541499837978929, + -0.70380568711021, + 0.4921348037687934 ], [ - -1.0424791004564764, - -0.2698803762603061, - -0.24342151584262903 + 2.4500904746768963, + 0.4921348037687934, + 0.4921348037687934 ], [ - -1.0424791004564764, - -0.5080101200193996, - -0.47096771543465177 + 2.4500904746768963, + 1.2541499837978929, + 1.2541499837978929 ], [ - -0.12171075792131451, - -0.2804639204273769, - 0.6879303708596037 + 1.4393620067216324, + 0.4921348037687934, + -0.5185936641864705 ], [ - -0.10054366958717285, - 0.6773468266925329, - -0.2487132879261644 + 1.4393620067216324, + -0.5185936641864705, + 0.4921348037687934 ], [ - 0.5291772083535413, - -0.26458860417677066, - -0.26458860417677066 + -1.4711126392228449, + 0.4921348037687934, + 0.4921348037687934 ], [ - 0.5291772083535413, - 0.6826385987760684, - 0.6879303708596037 + -1.4711126392228449, + -0.5185936641864705, + -0.5185936641864705 ], [ - 0.2963392366779832, - -0.24342151584262903, - -0.4762594875181872 + -0.70380568711021, + 0.4921348037687934, + 1.2541499837978929 ], [ - 0.29104746459444775, - -0.4815512596017226, - -0.24342151584262903 + -0.70380568711021, + 1.2541499837978929, + 0.4921348037687934 ], [ - -0.2698803762603061, - -1.0424791004564764, - -0.24342151584262903 + 0.4921348037687934, + 2.4500904746768963, + 0.4921348037687934 ], [ - -0.2804639204273769, - -0.12171075792131451, - 0.6879303708596037 + 0.4921348037687934, + 1.4393620067216324, + -0.5185936641864705 ], [ - -0.5080101200193996, - -1.0424791004564764, - -0.47096771543465177 + 1.2541499837978929, + 2.4500904746768963, + 1.2541499837978929 ], [ - 0.6773468266925329, - -0.10054366958717285, - -0.2487132879261644 + -0.5185936641864705, + 1.4393620067216324, + 0.4921348037687934 ], [ - -0.24342151584262903, - -0.24342151584262903, - -1.0160202400387992 + 0.4921348037687934, + 0.4921348037687934, + 2.4500904746768963 ], [ - -0.2540050600096998, - 0.6879303708596037, - -0.08996012542010202 + 0.4921348037687934, + -0.5185936641864705, + 1.4393620067216324 ], [ - 0.6879303708596037, - -0.2540050600096998, - -0.08996012542010202 + -0.5185936641864705, + 0.4921348037687934, + 1.4393620067216324 ], [ - -0.48684303168525805, - -0.48684303168525805, - -1.0054366958717285 + 1.2541499837978929, + 1.2541499837978929, + 2.4500904746768963 ], [ - -1.0530626446235472, - -1.0530626446235472, - -1.0160202400387992 + 2.4500904746768963, + 2.4500904746768963, + 2.4500904746768963 ], [ - -1.0318955562894054, - -0.10583544167070827, - -0.0793765812530312 + 2.4500904746768963, + 1.4393620067216324, + 1.4393620067216324 ], [ - -0.10583544167070827, - -1.0318955562894054, - -0.0793765812530312 + 1.4393620067216324, + 2.4500904746768963, + 1.4393620067216324 ], [ - -0.08996012542010202, - -0.08996012542010202, - -1.0054366958717285 + 1.4393620067216324, + 1.4393620067216324, + 2.4500904746768963 ] ], [ [ - -0.0, - -0.0, - -0.0 + -2.3495468050897235, + -2.3495468050897235, + -2.3495468050897235 ], [ - 0.0, - 0.0, - 0.0 + -2.3389632609226525, + -2.3389632609226525, + -2.3389632609226525 ], [ - 0.0, - 0.0, - 0.0 + -2.3389632609226525, + -2.3389632609226525, + -2.3389632609226525 ], [ - -0.0, - -0.0, - -0.0 + -2.3495468050897235, + -2.3495468050897235, + -2.3495468050897235 ], [ - 0.0, - 0.0, - 0.0 + -2.3389632609226525, + -2.3389632609226525, + -2.3389632609226525 ], [ - 1.4711126392228449, - 1.4711126392228449, - 1.4711126392228449 + -0.7514316358620287, + -0.7514316358620287, + -0.7514316358620287 ], [ - 1.4711126392228449, - 1.1324392258765785, - 1.1324392258765785 + -0.7514316358620287, + -1.0689379608741534, + -1.0689379608741534 ], [ - 1.1324392258765785, - 1.4711126392228449, - 1.1324392258765785 + -1.0689379608741534, + -0.7514316358620287, + -1.0689379608741534 ], [ - 1.1324392258765785, - 1.1324392258765785, - 1.4711126392228449 + -1.0689379608741534, + -1.0689379608741534, + -0.7514316358620287 ], [ - -0.13229430208838533, - -0.13229430208838533, - -0.0 + 0.4762594875181872, + 0.4762594875181872, + -2.3495468050897235 ], [ - -0.2857556925109123, - -0.2857556925109123, - 0.0 + 0.4762594875181872, + 0.4762594875181872, + -2.3389632609226525 ], [ - -0.2857556925109123, - -0.2857556925109123, - 0.0 + 0.4762594875181872, + 0.4762594875181872, + -2.3389632609226525 ], [ - -0.12171075792131451, - -0.12171075792131451, - -0.0 + 0.4762594875181872, + 0.4762594875181872, + -2.3495468050897235 ], [ - -0.23283797167555817, - -0.23283797167555817, - 0.0 + 0.4762594875181872, + 0.4762594875181872, + -2.3389632609226525 ], [ - -0.6614715104419266, - -0.6614715104419266, - 1.4764044113063803 + 0.7990575846138473, + 0.7990575846138473, + -0.7514316358620287 ], [ - -0.6614715104419266, - -1.0054366958717285, - 1.1324392258765785 + 0.7990575846138473, + 0.4815512596017226, + -1.0689379608741534 ], [ - -1.0054366958717285, - -0.6614715104419266, - 1.1324392258765785 + 0.4815512596017226, + 0.7990575846138473, + -1.0689379608741534 ], [ - 0.010583544167070826, - 0.010583544167070826, - 1.4764044113063803 + 0.6350126500242496, + 0.6350126500242496, + -0.7514316358620287 ], [ - -0.11641898583777908, - -0.0, - -0.11641898583777908 + 0.4762594875181872, + -2.3495468050897235, + 0.4762594875181872 ], [ - -0.19050379500727488, - 0.0, - -0.19050379500727488 + 0.4762594875181872, + -2.3389632609226525, + 0.4762594875181872 ], [ - -0.26458860417677066, - 0.0, - -0.26458860417677066 + 0.4762594875181872, + -2.3389632609226525, + 0.4762594875181872 ], [ - -0.11112721375424367, - -0.0, - -0.11112721375424367 + 0.4762594875181872, + -2.3495468050897235, + 0.4762594875181872 ], [ - -0.26458860417677066, - 0.0, - -0.26458860417677066 + 0.4762594875181872, + -2.3389632609226525, + 0.4762594875181872 ], [ - -0.6403044221077849, - 1.4711126392228449, - -0.6350126500242496 + 0.7990575846138473, + -0.7514316358620287, + 0.7990575846138473 ], [ - -0.6350126500242496, - 1.1324392258765785, - -0.9789778354540515 + 0.7990575846138473, + -1.0689379608741534, + 0.4815512596017226 ], [ - 0.0793765812530312, - 1.4711126392228449, - 0.0793765812530312 + 0.6350126500242496, + -0.7514316358620287, + 0.6350126500242496 ], [ - -0.9789778354540515, - 1.1324392258765785, - -0.6350126500242496 + 0.4815512596017226, + -1.0689379608741534, + 0.7990575846138473 ], [ - -0.19579556709081028, - -0.12171075792131451, - -0.0740848091694958 + 3.2967740080425627, + 0.4762594875181872, + 0.4762594875181872 ], [ - -0.4127582225157622, - -0.24342151584262903, - -0.16933670667313322 + 3.2967740080425627, + 0.4762594875181872, + 0.4762594875181872 ], [ - -0.5185936641864705, - -0.30163100876151855, - -0.21696265542495194 + 3.2967740080425627, + 0.4762594875181872, + 0.4762594875181872 ], [ - -0.2487132879261644, - -0.15346139042252696, - -0.09525189750363744 + 3.2967740080425627, + 0.4762594875181872, + 0.4762594875181872 ], [ - -0.47096771543465177, - -0.30163100876151855, - -0.16404493458959782 + 3.2967740080425627, + 0.4762594875181872, + 0.4762594875181872 ], [ - -2.7358461671878085, - -0.6350126500242496, - -0.6191373337736433 + 2.344255033006188, + 0.7990575846138473, + 0.7990575846138473 ], [ - -2.7358461671878085, - -0.9789778354540515, - -0.9631025192034453 + 2.344255033006188, + 0.4815512596017226, + 0.4815512596017226 ], [ - -1.9897063034093152, - -0.6350126500242496, - 0.12171075792131451 + 2.1855018705001257, + 0.7990575846138473, + 0.6350126500242496 ], [ - -2.0055816196599214, - 0.08996012542010202, - -0.6244291058571787 + 2.1855018705001257, + 0.6350126500242496, + 0.7990575846138473 ], [ - -0.0, - -0.11641898583777908, - -0.11641898583777908 + -2.3495468050897235, + 0.4762594875181872, + 0.4762594875181872 ], [ - 0.0, - -0.26458860417677066, - -0.26458860417677066 + -2.3389632609226525, + 0.4762594875181872, + 0.4762594875181872 ], [ - 0.0, - -0.19050379500727488, - -0.19050379500727488 + -2.3389632609226525, + 0.4762594875181872, + 0.4762594875181872 ], [ - -0.0, - -0.11112721375424367, - -0.11112721375424367 + -2.3495468050897235, + 0.4762594875181872, + 0.4762594875181872 ], [ - 0.0, - -0.26458860417677066, - -0.26458860417677066 + -2.3389632609226525, + 0.4762594875181872, + 0.4762594875181872 ], [ - 1.4711126392228449, - -0.6403044221077849, - -0.6350126500242496 + -0.7514316358620287, + 0.7990575846138473, + 0.7990575846138473 ], [ - 1.4711126392228449, - 0.0793765812530312, - 0.0793765812530312 + -0.7514316358620287, + 0.6350126500242496, + 0.6350126500242496 ], [ - 1.1324392258765785, - -0.6350126500242496, - -0.9789778354540515 + -1.0689379608741534, + 0.7990575846138473, + 0.4815512596017226 ], [ - 1.1324392258765785, - -0.9789778354540515, - -0.6350126500242496 + -1.0689379608741534, + 0.4815512596017226, + 0.7990575846138473 ], [ - -0.12171075792131451, - -0.19579556709081028, - -0.0740848091694958 + 0.4762594875181872, + 3.2967740080425627, + 0.4762594875181872 ], [ - -0.30163100876151855, - -0.5185936641864705, - -0.21696265542495194 + 0.4762594875181872, + 3.2967740080425627, + 0.4762594875181872 ], [ - -0.24342151584262903, - -0.4127582225157622, - -0.16933670667313322 + 0.4762594875181872, + 3.2967740080425627, + 0.4762594875181872 ], [ - -0.15346139042252696, - -0.2487132879261644, - -0.09525189750363744 + 0.4762594875181872, + 3.2967740080425627, + 0.4762594875181872 ], [ - -0.30163100876151855, - -0.47096771543465177, - -0.16404493458959782 + 0.4762594875181872, + 3.2967740080425627, + 0.4762594875181872 ], [ - -0.6350126500242496, - -2.7358461671878085, - -0.6191373337736433 + 0.7990575846138473, + 2.344255033006188, + 0.7990575846138473 ], [ - -0.6350126500242496, - -1.9897063034093152, - 0.12171075792131451 + 0.7990575846138473, + 2.1855018705001257, + 0.6350126500242496 ], [ - -0.9789778354540515, - -2.7358461671878085, - -0.9631025192034453 + 0.4815512596017226, + 2.344255033006188, + 0.4815512596017226 ], [ - 0.08996012542010202, - -2.0055816196599214, - -0.6244291058571787 + 0.6350126500242496, + 2.1855018705001257, + 0.7990575846138473 ], [ - -0.11641898583777908, - -0.11641898583777908, - -0.22754619959202277 + 0.4762594875181872, + 0.4762594875181872, + 3.2967740080425627 ], [ - -0.16933670667313322, - -0.16404493458959782, - -0.333381641262731 + 0.4762594875181872, + 0.4762594875181872, + 3.2967740080425627 ], [ - -0.16404493458959782, - -0.16933670667313322, - -0.333381641262731 + 0.4762594875181872, + 0.4762594875181872, + 3.2967740080425627 ], [ - -0.05820949291888954, - -0.05820949291888954, - -0.11112721375424367 + 0.4762594875181872, + 0.4762594875181872, + 3.2967740080425627 ], [ - -0.21696265542495194, - -0.21696265542495194, - -0.4286335387663685 + 0.4762594875181872, + 0.4762594875181872, + 3.2967740080425627 ], [ - -0.6244291058571787, - -0.6244291058571787, - -2.719970850937202 + 0.7990575846138473, + 0.7990575846138473, + 2.344255033006188 ], [ - -0.6244291058571787, - 0.11641898583777908, - -1.9791227592422447 + 0.7990575846138473, + 0.6350126500242496, + 2.1855018705001257 ], [ - 0.11641898583777908, - -0.6244291058571787, - -1.9791227592422447 + 0.6350126500242496, + 0.7990575846138473, + 2.1855018705001257 ], [ - -0.9683942912869806, - -0.9683942912869806, - -2.719970850937202 + 0.4815512596017226, + 0.4815512596017226, + 2.344255033006188 ], [ - -0.19050379500727488, - -0.19050379500727488, - -0.15346139042252696 + 3.2967740080425627, + 3.2967740080425627, + 3.2967740080425627 ], [ - -0.33867341334626644, - -0.4445088550169747, - -0.2540050600096998 + 3.2967740080425627, + 3.2967740080425627, + 3.2967740080425627 ], [ - -0.4445088550169747, - -0.33867341334626644, - -0.2540050600096998 + 3.2967740080425627, + 3.2967740080425627, + 3.2967740080425627 ], [ - -0.18521202292373945, - -0.18521202292373945, - -0.11112721375424367 + 3.2967740080425627, + 3.2967740080425627, + 3.2967740080425627 ], [ - -0.4127582225157622, - -0.4127582225157622, - -0.3598405016804081 + 3.2967740080425627, + 3.2967740080425627, + 3.2967740080425627 ], [ - -2.7464297113548795, - -2.7464297113548795, - -2.714679078853667 + 2.344255033006188, + 2.344255033006188, + 2.344255033006188 ], [ - -2.7464297113548795, - -2.010873391743457, - -1.9791227592422447 + 2.344255033006188, + 2.1855018705001257, + 2.1855018705001257 ], [ - -2.010873391743457, - -2.7464297113548795, - -1.9791227592422447 + 2.1855018705001257, + 2.344255033006188, + 2.1855018705001257 ], [ - -2.058499340495276, - -2.058499340495276, - -2.714679078853667 + 2.1855018705001257, + 2.1855018705001257, + 2.344255033006188 ], [ - 0.5238854362700059, - 0.5238854362700059, - 0.5291772083535413 + -1.4711126392228449, + -1.4711126392228449, + -1.4711126392228449 ], [ - 0.5238854362700059, - 0.2857556925109123, - 0.2857556925109123 + -1.4711126392228449, + -0.70380568711021, + -0.70380568711021 ], [ - 0.2857556925109123, - 0.5238854362700059, - 0.2857556925109123 + -0.70380568711021, + -1.4711126392228449, + -0.70380568711021 ], [ - 0.2751721483438415, - 0.2751721483438415, - 0.5291772083535413 + -0.70380568711021, + -0.70380568711021, + -1.4711126392228449 ], [ - -0.2857556925109123, - -0.2857556925109123, - 0.5291772083535413 + 0.4921348037687934, + 0.4921348037687934, + -1.4711126392228449 ], [ - -0.2698803762603061, - -0.4974265758523288, - 0.2963392366779832 + 0.4921348037687934, + 1.2541499837978929, + -0.70380568711021 ], [ - -0.4974265758523288, - -0.2698803762603061, - 0.2963392366779832 + 1.2541499837978929, + 0.4921348037687934, + -0.70380568711021 ], [ - 0.6773468266925329, - 0.6773468266925329, - 0.5291772083535413 + -0.5185936641864705, + -0.5185936641864705, + -1.4711126392228449 ], [ - -0.26458860417677066, - 0.5291772083535413, - -0.26458860417677066 + 0.4921348037687934, + -1.4711126392228449, + 0.4921348037687934 ], [ - -0.24342151584262903, - 0.2963392366779832, - -0.4762594875181872 + 0.4921348037687934, + -0.70380568711021, + 1.2541499837978929 ], [ - 0.6826385987760684, - 0.5291772083535413, - 0.6879303708596037 + -0.5185936641864705, + -1.4711126392228449, + -0.5185936641864705 ], [ - -0.4815512596017226, - 0.29104746459444775, - -0.24342151584262903 + 1.2541499837978929, + -0.70380568711021, + 0.4921348037687934 ], [ - -1.0424791004564764, - -0.2698803762603061, - -0.24342151584262903 + 2.4500904746768963, + 0.4921348037687934, + 0.4921348037687934 ], [ - -1.0424791004564764, - -0.5080101200193996, - -0.47096771543465177 + 2.4500904746768963, + 1.2541499837978929, + 1.2541499837978929 ], [ - -0.12171075792131451, - -0.2804639204273769, - 0.6879303708596037 + 1.4393620067216324, + 0.4921348037687934, + -0.5185936641864705 ], [ - -0.10054366958717285, - 0.6773468266925329, - -0.2487132879261644 + 1.4393620067216324, + -0.5185936641864705, + 0.4921348037687934 ], [ - 0.5291772083535413, - -0.26458860417677066, - -0.26458860417677066 + -1.4711126392228449, + 0.4921348037687934, + 0.4921348037687934 ], [ - 0.5291772083535413, - 0.6826385987760684, - 0.6879303708596037 + -1.4711126392228449, + -0.5185936641864705, + -0.5185936641864705 ], [ - 0.2963392366779832, - -0.24342151584262903, - -0.4762594875181872 + -0.70380568711021, + 0.4921348037687934, + 1.2541499837978929 ], [ - 0.29104746459444775, - -0.4815512596017226, - -0.24342151584262903 + -0.70380568711021, + 1.2541499837978929, + 0.4921348037687934 ], [ - -0.2698803762603061, - -1.0424791004564764, - -0.24342151584262903 + 0.4921348037687934, + 2.4500904746768963, + 0.4921348037687934 ], [ - -0.2804639204273769, - -0.12171075792131451, - 0.6879303708596037 + 0.4921348037687934, + 1.4393620067216324, + -0.5185936641864705 ], [ - -0.5080101200193996, - -1.0424791004564764, - -0.47096771543465177 + 1.2541499837978929, + 2.4500904746768963, + 1.2541499837978929 ], [ - 0.6773468266925329, - -0.10054366958717285, - -0.2487132879261644 + -0.5185936641864705, + 1.4393620067216324, + 0.4921348037687934 ], [ - -0.24342151584262903, - -0.24342151584262903, - -1.0160202400387992 + 0.4921348037687934, + 0.4921348037687934, + 2.4500904746768963 ], [ - -0.2540050600096998, - 0.6879303708596037, - -0.08996012542010202 + 0.4921348037687934, + -0.5185936641864705, + 1.4393620067216324 ], [ - 0.6879303708596037, - -0.2540050600096998, - -0.08996012542010202 + -0.5185936641864705, + 0.4921348037687934, + 1.4393620067216324 ], [ - -0.48684303168525805, - -0.48684303168525805, - -1.0054366958717285 + 1.2541499837978929, + 1.2541499837978929, + 2.4500904746768963 ], [ - -1.0530626446235472, - -1.0530626446235472, - -1.0160202400387992 + 2.4500904746768963, + 2.4500904746768963, + 2.4500904746768963 ], [ - -1.0318955562894054, - -0.10583544167070827, - -0.0793765812530312 + 2.4500904746768963, + 1.4393620067216324, + 1.4393620067216324 ], [ - -0.10583544167070827, - -1.0318955562894054, - -0.0793765812530312 + 1.4393620067216324, + 2.4500904746768963, + 1.4393620067216324 ], [ - -0.08996012542010202, - -0.08996012542010202, - -1.0054366958717285 + 1.4393620067216324, + 1.4393620067216324, + 2.4500904746768963 ] ] ], "spreads": [ [ - 0.351995846925945, - 0.3825189553705974, - 0.3825189553705974, - 0.351995846925945, - 0.3825189553705974, - 3.144720255352715, - 3.1080365195155637, - 3.1080365195155637, - 3.1083165480334043, - 15.146742530011428, - 14.619448830917113, - 14.619448830917113, - 13.674352583204254, - 13.954941158080784, - 6.413493144108925, - 6.954508240577442, - 6.954508240577442, - 12.012943386854507, - 14.045390369343375, - 14.000025749453158, - 14.629529857559383, - 14.782985485336166, - 14.629529857559383, - 6.577869884081502, - 7.144647604191377, - 12.281490735463878, - 7.142967433084332, - 20.226739872162238, - 27.39855024258418, - 22.111611825748984, - 27.578888608073683, - 27.50160073714961, - 10.4635455976411, - 11.651986627357655, - 15.611029812591552, - 15.591147787824852, - 14.045390369343375, - 14.629529857559383, - 14.000025749453158, - 14.782985485336166, - 14.629529857559383, - 6.577869884081502, - 12.281490735463878, - 7.144647604191377, - 7.142967433084332, - 20.226739872162238, - 22.111611825748984, - 27.39855024258418, - 27.578888608073683, - 27.50160073714961, - 10.4635455976411, - 15.611029812591552, - 11.651986627357655, - 15.591147787824852, - 31.321469749016607, - 27.628733684249354, - 27.628733684249354, - 16.659736611905526, - 22.50393177924401, - 10.566876120724372, - 15.682437084640968, - 15.682437084640968, - 11.737955382334794, - 29.418115913252368, - 35.403445453582634, - 35.403445453582634, - 29.214815209299914, - 34.94559882691286, - 14.760863232426741, - 19.300965592180397, - 19.300965592180397, - 19.306846191055055, - 5.764107011236, - 8.136508614383658, - 8.136508614383658, - 8.099264821510825, - 11.351516027714425, - 15.210309003561301, - 15.210309003561301, - 9.724550339059101, - 11.396880647604641, - 15.254553509380155, - 9.707748627988652, - 15.257073766040723, - 19.25812122895075, - 24.525737678054924, - 14.709618013661867, - 14.802587481585027, - 11.396880647604641, - 9.707748627988652, - 15.254553509380155, - 15.257073766040723, - 19.25812122895075, - 14.709618013661867, - 24.525737678054924, - 14.802587481585027, - 19.369572579051404, - 14.803427567138549, - 14.803427567138549, - 24.68983438950966, - 29.377231749647603, - 22.140454763086588, - 22.140454763086588, - 22.211862035136004 + 0.3780384990851438, + 0.4880897065965968, + 0.4880897065965968, + 0.3780384990851438, + 0.4880897065965968, + 2.5000946072830845, + 2.652990178024187, + 2.652990178024187, + 2.652990178024187, + 0.37355804279969024, + 0.46064691184819373, + 0.46064691184819373, + 0.372157900210486, + 0.4682076818298966, + 9.911049331941108, + 10.42126129144713, + 10.42126129144713, + 7.699664126551935, + 0.3724379287283269, + 0.4682076818298966, + 0.46064691184819373, + 0.37327801428184937, + 0.46064691184819373, + 9.911049331941108, + 10.42126129144713, + 7.699664126551935, + 10.42126129144713, + 0.3802787272278706, + 0.4544862844556951, + 0.46624748220501067, + 0.3802787272278706, + 0.4544862844556951, + 15.409129251228302, + 16.276377570981406, + 13.086572724256314, + 13.086572724256314, + 0.3724379287283269, + 0.46064691184819373, + 0.4682076818298966, + 0.37327801428184937, + 0.46064691184819373, + 9.911049331941108, + 7.699664126551935, + 10.42126129144713, + 10.42126129144713, + 0.3802787272278706, + 0.46624748220501067, + 0.4544862844556951, + 0.3802787272278706, + 0.4544862844556951, + 15.409129251228302, + 13.086572724256314, + 16.276377570981406, + 13.086572724256314, + 0.3805587557457114, + 0.4544862844556951, + 0.4544862844556951, + 0.3799986987100297, + 0.46624748220501067, + 15.409129251228302, + 13.086572724256314, + 13.086572724256314, + 16.276377570981406, + 0.40016075199457074, + 0.47408828070455444, + 0.47408828070455444, + 0.40016075199457074, + 0.47408828070455444, + 18.994054336626828, + 16.560606516589868, + 16.560606516589868, + 16.560606516589868, + 6.583470454438319, + 10.832343155637494, + 10.832343155637494, + 10.832343155637494, + 8.426338130348935, + 12.20560300712901, + 12.20560300712901, + 7.669141018107284, + 8.426338130348935, + 12.20560300712901, + 7.669141018107284, + 12.20560300712901, + 10.93623373575645, + 14.246170816635264, + 11.212901911383206, + 11.212901911383206, + 8.426338130348935, + 7.669141018107284, + 12.20560300712901, + 12.20560300712901, + 10.93623373575645, + 11.212901911383206, + 14.246170816635264, + 11.212901911383206, + 10.93623373575645, + 11.212901911383206, + 11.212901911383206, + 14.246170816635264, + 14.113157270660862, + 15.423410705638187, + 15.423410705638187, + 15.423410705638187 ], [ - 0.351995846925945, - 0.3825189553705974, - 0.3825189553705974, - 0.351995846925945, - 0.3825189553705974, - 3.144720255352715, - 3.1080365195155637, - 3.1080365195155637, - 3.1083165480334043, - 15.146742530011428, - 14.619448830917113, - 14.619448830917113, - 13.674352583204254, - 13.954941158080784, - 6.413493144108925, - 6.954508240577442, - 6.954508240577442, - 12.012943386854507, - 14.045390369343375, - 14.000025749453158, - 14.629529857559383, - 14.782985485336166, - 14.629529857559383, - 6.577869884081502, - 7.144647604191377, - 12.281490735463878, - 7.142967433084332, - 20.226739872162238, - 27.39855024258418, - 22.111611825748984, - 27.578888608073683, - 27.50160073714961, - 10.4635455976411, - 11.651986627357655, - 15.611029812591552, - 15.591147787824852, - 14.045390369343375, - 14.629529857559383, - 14.000025749453158, - 14.782985485336166, - 14.629529857559383, - 6.577869884081502, - 12.281490735463878, - 7.144647604191377, - 7.142967433084332, - 20.226739872162238, - 22.111611825748984, - 27.39855024258418, - 27.578888608073683, - 27.50160073714961, - 10.4635455976411, - 15.611029812591552, - 11.651986627357655, - 15.591147787824852, - 31.321469749016607, - 27.628733684249354, - 27.628733684249354, - 16.659736611905526, - 22.50393177924401, - 10.566876120724372, - 15.682437084640968, - 15.682437084640968, - 11.737955382334794, - 29.418115913252368, - 35.403445453582634, - 35.403445453582634, - 29.214815209299914, - 34.94559882691286, - 14.760863232426741, - 19.300965592180397, - 19.300965592180397, - 19.306846191055055, - 5.764107011236, - 8.136508614383658, - 8.136508614383658, - 8.099264821510825, - 11.351516027714425, - 15.210309003561301, - 15.210309003561301, - 9.724550339059101, - 11.396880647604641, - 15.254553509380155, - 9.707748627988652, - 15.257073766040723, - 19.25812122895075, - 24.525737678054924, - 14.709618013661867, - 14.802587481585027, - 11.396880647604641, - 9.707748627988652, - 15.254553509380155, - 15.257073766040723, - 19.25812122895075, - 14.709618013661867, - 24.525737678054924, - 14.802587481585027, - 19.369572579051404, - 14.803427567138549, - 14.803427567138549, - 24.68983438950966, - 29.377231749647603, - 22.140454763086588, - 22.140454763086588, - 22.211862035136004 + 0.3780384990851438, + 0.4880897065965968, + 0.4880897065965968, + 0.3780384990851438, + 0.4880897065965968, + 2.5000946072830845, + 2.652990178024187, + 2.652990178024187, + 2.652990178024187, + 0.37355804279969024, + 0.46064691184819373, + 0.46064691184819373, + 0.372157900210486, + 0.4682076818298966, + 9.911049331941108, + 10.42126129144713, + 10.42126129144713, + 7.699664126551935, + 0.3724379287283269, + 0.4682076818298966, + 0.46064691184819373, + 0.37327801428184937, + 0.46064691184819373, + 9.911049331941108, + 10.42126129144713, + 7.699664126551935, + 10.42126129144713, + 0.3802787272278706, + 0.4544862844556951, + 0.46624748220501067, + 0.3802787272278706, + 0.4544862844556951, + 15.409129251228302, + 16.276377570981406, + 13.086572724256314, + 13.086572724256314, + 0.3724379287283269, + 0.46064691184819373, + 0.4682076818298966, + 0.37327801428184937, + 0.46064691184819373, + 9.911049331941108, + 7.699664126551935, + 10.42126129144713, + 10.42126129144713, + 0.3802787272278706, + 0.46624748220501067, + 0.4544862844556951, + 0.3802787272278706, + 0.4544862844556951, + 15.409129251228302, + 13.086572724256314, + 16.276377570981406, + 13.086572724256314, + 0.3805587557457114, + 0.4544862844556951, + 0.4544862844556951, + 0.3799986987100297, + 0.46624748220501067, + 15.409129251228302, + 13.086572724256314, + 13.086572724256314, + 16.276377570981406, + 0.40016075199457074, + 0.47408828070455444, + 0.47408828070455444, + 0.40016075199457074, + 0.47408828070455444, + 18.994054336626828, + 16.560606516589868, + 16.560606516589868, + 16.560606516589868, + 6.583470454438319, + 10.832343155637494, + 10.832343155637494, + 10.832343155637494, + 8.426338130348935, + 12.20560300712901, + 12.20560300712901, + 7.669141018107284, + 8.426338130348935, + 12.20560300712901, + 7.669141018107284, + 12.20560300712901, + 10.93623373575645, + 14.246170816635264, + 11.212901911383206, + 11.212901911383206, + 8.426338130348935, + 7.669141018107284, + 12.20560300712901, + 12.20560300712901, + 10.93623373575645, + 11.212901911383206, + 14.246170816635264, + 11.212901911383206, + 10.93623373575645, + 11.212901911383206, + 11.212901911383206, + 14.246170816635264, + 14.113157270660862, + 15.423410705638187, + 15.423410705638187, + 15.423410705638187 ] ], "self-Hartree": [ @@ -88674,7 +88674,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -89115,5 +89115,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_dummy.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_dummy.json index 82896865f..07beaf896 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_dummy.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_dummy.json @@ -12,8 +12,8 @@ "neldw": 72, "ecutwfc": 40.0, "pseudopotentials": { - "Ga": "Ga_ONCV_PBE-1.0.upf", - "As": "As_ONCV_PBE-1.0.upf" + "As": "As_ONCV_PBE-1.0.upf", + "Ga": "Ga_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -22267,7 +22267,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -22494,5 +22494,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_init.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_init.json index a8b04db3d..b821fb7ac 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_init.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_init.json @@ -13,8 +13,8 @@ "ecutwfc": 40.0, "nbnd": 104, "pseudopotentials": { - "Ga": "Ga_ONCV_PBE-1.0.upf", - "As": "As_ONCV_PBE-1.0.upf" + "As": "As_ONCV_PBE-1.0.upf", + "Ga": "Ga_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -45406,7 +45406,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -45633,5 +45633,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-pw2wan.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-pw2wan.json index 79daca9df..5aa4f78f0 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-pw2wan.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-w2kcp.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-w2kcp.json index de83cd406..9100a91db 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-w2kcp.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-w2kcp.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "wann2kcp.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWann2KCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-wann.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-wann.json index c56eedf11..34e6db6ce 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-wann.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-wann.json @@ -161,7 +161,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -172,5 +172,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-wann_preproc.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-wann_preproc.json index 3d6e08c24..069ff10a6 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-emp-wann_preproc.json @@ -134,7 +134,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -145,5 +145,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-nscf.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-nscf.json index bacd5905d..b699eb56c 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-nscf.json @@ -17,8 +17,8 @@ 2 ], "pseudopotentials": { - "Ga": "Ga_ONCV_PBE-1.0.upf", - "As": "As_ONCV_PBE-1.0.upf" + "As": "As_ONCV_PBE-1.0.upf", + "Ga": "Ga_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.0/pbe" @@ -114,7 +114,7 @@ "postfix": "-npool 1", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -647,5 +647,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-pw2wan.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-pw2wan.json index b280e84e0..0ec19bf16 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-pw2wan.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-w2kcp.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-w2kcp.json index bf42e637c..bc5194b16 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-w2kcp.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-w2kcp.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "wann2kcp.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWann2KCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-wann.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-wann.json index 357908571..2f876ef0c 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-wann.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-wann.json @@ -164,7 +164,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -175,5 +175,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-wann_preproc.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-wann_preproc.json index 22aaf0819..8e71f11e0 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block1-wann_preproc.json @@ -131,7 +131,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -142,5 +142,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-pw2wan.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-pw2wan.json index c90010606..ec67275e7 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-pw2wan.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-w2kcp.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-w2kcp.json index 5395a9572..b5d488e75 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-w2kcp.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-w2kcp.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "wann2kcp.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWann2KCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-wann.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-wann.json index c86dcc4e7..5261333b1 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-wann.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-wann.json @@ -158,7 +158,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -169,5 +169,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-wann_preproc.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-wann_preproc.json index 0b71814f5..d16fa504c 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-occ_block2-wann_preproc.json @@ -131,7 +131,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -142,5 +142,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-scf.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-scf.json index 15dc5c686..4d1a0da86 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-scf.json @@ -13,8 +13,8 @@ 2 ], "pseudopotentials": { - "Ga": "Ga_ONCV_PBE-1.0.upf", - "As": "As_ONCV_PBE-1.0.upf" + "As": "As_ONCV_PBE-1.0.upf", + "Ga": "Ga_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.0/pbe" @@ -111,7 +111,7 @@ "postfix": "-npool 1", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -211,5 +211,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-emp-ki.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-emp-ki.json index fc3950aa9..6c243ab36 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-emp-ki.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-emp-ki.json @@ -28480,5 +28480,5 @@ ], "command": null, "__koopmans_name__": "BenchGenUnfoldAndInterpolateCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-occ-ki.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-occ-ki.json index b339f30a2..33164a772 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-occ-ki.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-occ-ki.json @@ -128150,5 +128150,5 @@ ], "command": null, "__koopmans_name__": "BenchGenUnfoldAndInterpolateCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-bands.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-bands.json index 6bd9d0d34..79d51f19b 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-bands.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-bands.json @@ -342,8 +342,8 @@ "__ase_objtype__": "bandpath" }, "pseudopotentials": { - "Ga": "Ga_ONCV_PBE-1.0.upf", - "As": "As_ONCV_PBE-1.0.upf" + "As": "As_ONCV_PBE-1.0.upf", + "Ga": "Ga_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.0/pbe" @@ -3981,7 +3981,7 @@ "postfix": "-npool 1", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -8609,5 +8609,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-emp-pw2wan.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-emp-pw2wan.json index 79daca9df..5aa4f78f0 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-emp-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-emp-pw2wan.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-emp-wann.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-emp-wann.json index f78bc46d4..70c42e39f 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-emp-wann.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-emp-wann.json @@ -8355,7 +8355,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -8366,5 +8366,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-emp-wann_preproc.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-emp-wann_preproc.json index 1fa6f6b70..060a4953b 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-emp-wann_preproc.json @@ -1646,7 +1646,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -1657,5 +1657,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-nscf.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-nscf.json index bec396c48..44443a392 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-nscf.json @@ -17,8 +17,8 @@ 8 ], "pseudopotentials": { - "Ga": "Ga_ONCV_PBE-1.0.upf", - "As": "As_ONCV_PBE-1.0.upf" + "As": "As_ONCV_PBE-1.0.upf", + "Ga": "Ga_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.0/pbe" @@ -114,7 +114,7 @@ "postfix": "-npool 1", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -33407,5 +33407,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block1-pw2wan.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block1-pw2wan.json index b280e84e0..0ec19bf16 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block1-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block1-pw2wan.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block1-wann.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block1-wann.json index 60bf3aff0..841892f38 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block1-wann.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block1-wann.json @@ -9001,7 +9001,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -9012,5 +9012,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block1-wann_preproc.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block1-wann_preproc.json index 815a1fb73..8233ddf48 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block1-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block1-wann_preproc.json @@ -1643,7 +1643,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -1654,5 +1654,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block2-pw2wan.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block2-pw2wan.json index c90010606..ec67275e7 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block2-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block2-pw2wan.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block2-wann.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block2-wann.json index 81e8cf5a0..8630933b1 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block2-wann.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block2-wann.json @@ -8352,7 +8352,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -8363,5 +8363,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block2-wann_preproc.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block2-wann_preproc.json index 3b8345d27..e9210b1c2 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block2-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-occ_block2-wann_preproc.json @@ -1643,7 +1643,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -1654,5 +1654,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-scf.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-scf.json index 15dc5c686..4d1a0da86 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-scf.json @@ -13,8 +13,8 @@ 2 ], "pseudopotentials": { - "Ga": "Ga_ONCV_PBE-1.0.upf", - "As": "As_ONCV_PBE-1.0.upf" + "As": "As_ONCV_PBE-1.0.upf", + "Ga": "Ga_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.0/pbe" @@ -111,7 +111,7 @@ "postfix": "-npool 1", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -211,5 +211,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-ki.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-ki.json index e9ec7444e..fa6063b9f 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-ki.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-ki.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" @@ -151,73 +151,73 @@ "centres": [ [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.19050379500727488, - 0.14287784625545616, - 0.8043493566973828 + 0.21696265542495194, + 0.550344296687683, + -0.11112721375424367 ] ], [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.19050379500727488, - 0.14287784625545616, - 0.8043493566973828 + 0.21696265542495194, + 0.550344296687683, + -0.11112721375424367 ] ] ], "spreads": [ [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 38.06343634455284 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 19.59947599219874 ], [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 38.06343634455284 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 19.59947599219874 ] ], "self-Hartree": [ @@ -708,7 +708,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -753,5 +753,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_4-dft_n-1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_4-dft_n-1.json index 44878b4ac..90a9c6300 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_4-dft_n-1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_4-dft_n-1.json @@ -12,8 +12,8 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" @@ -387,7 +387,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -432,5 +432,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1.json index 2652d7957..f4f56831a 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1.json @@ -12,8 +12,8 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" @@ -416,7 +416,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -463,5 +463,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json index 5f7965364..4f1c32474 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json @@ -12,8 +12,8 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" @@ -348,7 +348,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -395,5 +395,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-pz_print.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-pz_print.json index 923b2cb32..8cb2ac76c 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-pz_print.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-pz_print.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" @@ -153,73 +153,73 @@ "centres": [ [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.19050379500727488, - 0.14287784625545616, - 0.8043493566973828 + 0.21696265542495194, + 0.550344296687683, + -0.11112721375424367 ] ], [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.19050379500727488, - 0.14287784625545616, - 0.8043493566973828 + 0.21696265542495194, + 0.550344296687683, + -0.11112721375424367 ] ] ], "spreads": [ [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 38.06343634455284 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 19.59947599219874 ], [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 38.06343634455284 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 19.59947599219874 ] ], "self-Hartree": [ @@ -513,7 +513,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -558,5 +558,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1.json index 85146c154..b2b628fdd 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1.json @@ -11,8 +11,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" @@ -135,39 +135,39 @@ "centres": [ [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.1481696183389916, - 0.10583544167070827, - 0.6403044221077849 + 0.2010873391743457, + 0.3175063250121248, + -0.12171075792131451 ] ] ], "spreads": [ [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 32.83054343166093 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 24.463011290058574 ] ], "self-Hartree": [ @@ -499,7 +499,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -530,5 +530,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1_dummy.json index 009a05d3d..83fa600db 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1_dummy.json @@ -11,8 +11,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" @@ -135,39 +135,39 @@ "centres": [ [ [ - 0.015875316250606238, - 0.052917720835354135, - -0.026458860417677067 + -0.5027183479358642, + -2.407756298008613, + -0.38629936209808513 ], [ - 0.005291772083535413, - 0.10054366958717285, - -0.06350126500242495 + 0.06879303708596038, + -0.40746645043222685, + 0.0740848091694958 ], [ - 0.0740848091694958, - 0.11641898583777908, - -0.09525189750363744 + 0.11112721375424367, + -0.10583544167070827, + 0.2381297437590936 ], [ - 0.042334176668283305, - 0.052917720835354135, - -0.031750632501212475 + 0.15346139042252696, + 0.021167088334141652, + 0.15346139042252696 ], [ - 0.1270025300048499, - 0.16404493458959782, - -0.05820949291888954 + 0.10583544167070827, + 0.13229430208838533, + 0.2698803762603061 ] ] ], "spreads": [ [ - 12.321814842032962, - 25.143760616929676, - 26.86061545981191, - 27.46939745759791, - 28.157427525932874 + 45.756659815194446, + 33.812043386693105, + 31.503768314130998, + 30.41193712306953, + 29.591733594313695 ] ], "self-Hartree": [ @@ -332,7 +332,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -363,5 +363,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2.json index 8971ca77e..16743e610 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" @@ -151,73 +151,73 @@ "centres": [ [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.1481696183389916, - 0.10583544167070827, - 0.6350126500242496 + 0.2010873391743457, + 0.3175063250121248, + -0.12171075792131451 ] ], [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.1481696183389916, - 0.10583544167070827, - 0.6350126500242496 + 0.2010873391743457, + 0.3175063250121248, + -0.12171075792131451 ] ] ], "spreads": [ [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 32.7260927945063 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 24.554860643910374 ], [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 32.7260927945063 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 24.554860643910374 ] ], "self-Hartree": [ @@ -588,7 +588,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -633,5 +633,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2_dummy.json index 1915d0ddc..ece776dd1 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2_dummy.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" @@ -151,73 +151,73 @@ "centres": [ [ [ - 0.015875316250606238, - 0.052917720835354135, - -0.026458860417677067 + -0.5027183479358642, + -2.407756298008613, + -0.38629936209808513 ], [ - 0.005291772083535413, - 0.10054366958717285, - -0.06350126500242495 + 0.06879303708596038, + -0.40746645043222685, + 0.0740848091694958 ], [ - 0.0740848091694958, - 0.11641898583777908, - -0.09525189750363744 + 0.11112721375424367, + -0.10583544167070827, + 0.2381297437590936 ], [ - 0.042334176668283305, - 0.052917720835354135, - -0.031750632501212475 + 0.15346139042252696, + 0.021167088334141652, + 0.15346139042252696 ], [ - 0.010583544167070826, - 0.11112721375424367, - -0.0370424045847479 + 0.16933670667313322, + 0.06879303708596038, + 0.21696265542495194 ] ], [ [ - 0.06879303708596038, - 0.0740848091694958, - -0.021167088334141652 + -0.4921348037687934, + -2.354838577173259, + -0.4286335387663685 ], [ - 0.10583544167070827, - 0.11641898583777908, - -0.10054366958717285 + -0.010583544167070826, + -0.4498006271005101, + 0.2063791112578811 ], [ - 0.08996012542010202, - 0.08466835333656661, - -0.0793765812530312 + 0.09525189750363744, + -0.04762594875181872, + 0.24342151584262903 ], [ - 0.10583544167070827, - 0.06350126500242495, - -0.12171075792131451 + 0.18521202292373945, + 0.08996012542010202, + 0.2381297437590936 ], [ - 0.08996012542010202, - 0.010583544167070826, - -0.06879303708596038 + 0.17992025084020405, + 0.09525189750363744, + 0.21167088334141654 ] ] ], "spreads": [ [ - 12.321814842032962, - 25.143760616929676, - 26.86061545981191, - 27.46939745759791, - 27.94040542460622 + 45.756659815194446, + 33.812043386693105, + 31.503768314130998, + 30.41193712306953, + 29.947089783453727 ], [ - 12.662889576763114, - 24.605825834157407, - 26.932022731861327, - 28.234995425374787, - 28.177589579217415 + 45.486432295478025, + 34.3138544906639, + 31.508808827452132, + 29.733988081376843, + 29.75919064798252 ] ], "self-Hartree": [ @@ -511,7 +511,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -556,5 +556,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1.json index 73595a144..821398165 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1.json @@ -12,8 +12,8 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" @@ -404,7 +404,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -451,5 +451,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1_dummy.json index 4d2463062..2dfd0ec87 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1_dummy.json @@ -12,8 +12,8 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" @@ -348,7 +348,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -395,5 +395,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-pz_print.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-pz_print.json index 542696e89..03a17d2f2 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-pz_print.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-pz_print.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" @@ -153,73 +153,73 @@ "centres": [ [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.1481696183389916, - 0.10583544167070827, - 0.6350126500242496 + 0.2010873391743457, + 0.3175063250121248, + -0.12171075792131451 ] ], [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.1481696183389916, - 0.10583544167070827, - 0.6350126500242496 + 0.2010873391743457, + 0.3175063250121248, + -0.12171075792131451 ] ] ], "spreads": [ [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 32.7260927945063 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 24.554860643910374 ], [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 32.7260927945063 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 24.554860643910374 ] ], "self-Hartree": [ @@ -513,7 +513,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -558,5 +558,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-final-ki_final.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-final-ki_final.json index 7718c8a40..48ad3bd75 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-final-ki_final.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-final-ki_final.json @@ -14,8 +14,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -152,73 +152,73 @@ "centres": [ [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.1481696183389916, - 0.10583544167070827, - 0.6350126500242496 + 0.2010873391743457, + 0.31221455292858935, + -0.12171075792131451 ] ], [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.1481696183389916, - 0.10583544167070827, - 0.6350126500242496 + 0.2010873391743457, + 0.31221455292858935, + -0.12171075792131451 ] ] ], "spreads": [ [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 32.620522043280296 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 24.65343068219035 ], [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 32.620522043280296 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 24.65343068219035 ] ], "self-Hartree": [ @@ -583,7 +583,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -628,5 +628,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin1.json index 8c7956940..3eb2db0af 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin1.json @@ -11,8 +11,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -738,7 +738,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -769,5 +769,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2.json index 3bdda939b..a72bea173 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -496,7 +496,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -525,5 +525,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2_dummy.json index 459e00b8e..2138628ba 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2_dummy.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -384,7 +384,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -413,5 +413,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-pz_innerloop_init.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-pz_innerloop_init.json index 9757e49bc..e41f33cf3 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-pz_innerloop_init.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-pz_innerloop_init.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -150,73 +150,73 @@ "centres": [ [ [ - 1.0742297329576889, - 0.9948531517046576, - -0.4815512596017226 + 0.26458860417677066, + 1.0266037842058702, + 0.5027183479358642 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.116563909625972, - 1.0583544167070826, - -0.6244291058571787 + 0.26458860417677066, + 1.0266037842058702, + 0.6244291058571787 ], [ - -0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.32808986917919564, - 0.2381297437590936, - 1.2276911233802157 + 0.2540050600096998, + 0.9313518867022327, + -0.06879303708596038 ] ], [ [ - 1.0742297329576889, - 0.9948531517046576, - -0.4815512596017226 + 0.26458860417677066, + 1.0266037842058702, + 0.5027183479358642 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.116563909625972, - 1.0583544167070826, - -0.6244291058571787 + 0.26458860417677066, + 1.0266037842058702, + 0.6244291058571787 ], [ - -0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.32808986917919564, - 0.2381297437590936, - 1.2276911233802157 + 0.2540050600096998, + 0.9313518867022327, + -0.06879303708596038 ] ] ], "spreads": [ [ - 74.45090200982823, - 72.07261980780589, - 70.60667051690906, - 69.06455346915952, - 49.72522397003493 + 0.46064691184819373, + 0.8605276353249236, + 0.8924508863587801, + 0.8871303445198041, + 9.382915547293269 ], [ - 74.45090200982823, - 72.07261980780589, - 70.60667051690906, - 69.06455346915952, - 49.72522397003493 + 0.46064691184819373, + 0.8605276353249236, + 0.8924508863587801, + 0.8871303445198041, + 9.382915547293269 ] ], "self-Hartree": [ @@ -510,7 +510,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -555,5 +555,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-kipz.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-kipz.json index 7be53760c..9391e9352 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-kipz.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-kipz.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" @@ -152,73 +152,73 @@ "centres": [ [ [ - 1.1377309979601138, - -3.1856467942883184, - 1.0477708725400119 + 0.26458860417677066, + 1.418194918387491, + 0.3545487295968727 ], [ - 1.090105049208295, - 4.185791718076512, - 1.0477708725400119 + 0.26458860417677066, + 0.6350126500242496, + 0.3545487295968727 ], [ - -1.2223993512966804, - 0.8308082171150599, - -2.4765493350945733 + 0.4498006271005101, + 1.0424791004564764, + 0.7355563196114224 ], [ - 2.3654221213403295, - 1.40761137422042, - -2.4871328792616443 + 0.0793765812530312, + 1.010728467955264, + 0.7355563196114224 ], [ - 0.12171075792131451, - 0.09525189750363744, - 0.550344296687683 + 0.19050379500727488, + 0.26458860417677066, + -0.11112721375424367 ] ], [ [ - 1.1377309979601138, - -3.1856467942883184, - 1.0477708725400119 + 0.26458860417677066, + 1.418194918387491, + 0.3545487295968727 ], [ - 1.090105049208295, - 4.185791718076512, - 1.0477708725400119 + 0.26458860417677066, + 0.6350126500242496, + 0.3545487295968727 ], [ - -1.2223993512966804, - 0.8308082171150599, - -2.4765493350945733 + 0.4498006271005101, + 1.0424791004564764, + 0.7355563196114224 ], [ - 2.3654221213403295, - 1.40761137422042, - -2.4871328792616443 + 0.0793765812530312, + 1.010728467955264, + 0.7355563196114224 ], [ - 0.12171075792131451, - 0.09525189750363744, - 0.550344296687683 + 0.19050379500727488, + 0.26458860417677066, + -0.11112721375424367 ] ] ], "spreads": [ [ - 62.53876888939642, - 55.28771044842552, - 65.268486881309, - 59.838173863339286, - 30.90506734298727 + 0.5466156668253338, + 0.5466156668253338, + 0.7205133764045, + 0.7196732908509774, + 26.19890807215399 ], [ - 62.53876888939642, - 55.28771044842552, - 65.268486881309, - 59.838173863339286, - 30.90506734298727 + 0.5466156668253338, + 0.5466156668253338, + 0.7205133764045, + 0.7196732908509774, + 26.19890807215399 ] ], "self-Hartree": [ @@ -780,7 +780,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -825,5 +825,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_4-kipz_n-1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_4-kipz_n-1.json index f2af9942f..5c2751da7 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_4-kipz_n-1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_4-kipz_n-1.json @@ -12,8 +12,8 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" @@ -146,61 +146,61 @@ "centres": [ [ [ - 1.2276911233802157, - -3.1009784409517525, - 0.8943094821174848 + 0.25929683209323523, + 1.3917360579698137, + 0.37571581793101433 ], [ - 1.1800651746283972, - 4.180499945992977, - 0.8360999891985953 + 0.25929683209323523, + 0.6614715104419266, + 0.38100759001454976 ], [ - -1.190648718795468, - 0.8255164450315244, - -2.614135409266494 + 0.4339253108499039, + 1.0477708725400119, + 0.7461398637784932 ], [ - 2.3654221213403295, - 1.40761137422042, - -2.4871328792616443 + 0.0793765812530312, + 1.010728467955264, + 0.7355563196114224 ] ], [ [ - 1.2382746675472867, - -2.973975910946902, - 0.793765812530312 + 0.2540050600096998, + 1.3758607417192075, + 0.38629936209808513 ], [ - 1.1853569467119327, - 4.03762209973752, - 0.70380568711021 + 0.25929683209323523, + 0.6826385987760684, + 0.396882906265156 ], [ - -1.2753170721320346, - 0.9101847983680911, - -2.7093873067701315 + 0.4445088550169747, + 1.0424791004564764, + 0.756723407945564 ], [ - 2.7993474321902334, - 1.6616164342301198, - -2.841681608858517 + 0.052917720835354135, + 1.000144923788193, + 0.756723407945564 ] ] ], "spreads": [ [ - 63.69948709584673, - 56.0409871614174, - 65.35445563628613, - 59.838173863339286 + 0.49145004881068693, + 0.4903299347393235, + 0.6029013989113442, + 0.7196732908509774 ], [ - 64.74455352442877, - 57.52513830597388, - 64.69694867639583, - 55.9690198323323 + 0.48500939290034745, + 0.49145004881068693, + 0.5594969786460128, + 0.5211330717018168 ] ], "self-Hartree": [ @@ -587,7 +587,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -632,5 +632,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json index 02e935c25..f6e531165 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json @@ -12,8 +12,8 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" @@ -348,7 +348,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -395,5 +395,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_n+1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_n+1.json index 5eac13640..48422a945 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_n+1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_n+1.json @@ -12,8 +12,8 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" @@ -150,67 +150,67 @@ "centres": [ [ [ - 1.1377309979601138, - -3.1856467942883184, - 1.0424791004564764 + 0.26458860417677066, + 1.418194918387491, + 0.3545487295968727 ], [ - 1.0848132771247596, - 4.180499945992977, - 1.0424791004564764 + 0.26458860417677066, + 0.6350126500242496, + 0.3545487295968727 ], [ - -1.2223993512966804, - 0.8255164450315244, - -2.4765493350945733 + 0.4498006271005101, + 1.0424791004564764, + 0.7355563196114224 ], [ - 2.3601303492567944, - 1.40761137422042, - -2.4871328792616443 + 0.0793765812530312, + 1.010728467955264, + 0.7408480916949578 ], [ - 0.12171075792131451, - 0.09525189750363744, - 0.550344296687683 + 0.19050379500727488, + 0.26458860417677066, + -0.11112721375424367 ] ], [ [ - 1.1377309979601138, - -3.1856467942883184, - 1.037187328372941 + 0.26458860417677066, + 1.418194918387491, + 0.3545487295968727 ], [ - 1.090105049208295, - 4.180499945992977, - 1.037187328372941 + 0.26458860417677066, + 0.6350126500242496, + 0.3545487295968727 ], [ - -1.2223993512966804, - 0.8255164450315244, - -2.4871328792616443 + 0.4498006271005101, + 1.0424791004564764, + 0.7408480916949578 ], [ - 2.3654221213403295, - 1.4129031463039552, - -2.4924246513451798 + 0.0793765812530312, + 1.010728467955264, + 0.7408480916949578 ] ] ], "spreads": [ [ - 62.547169744931644, - 55.303112016906766, - 65.22844280325775, - 59.81381138228713, - 30.90506734298727 + 0.5505360660751057, + 0.5505360660751057, + 0.7311544600824522, + 0.7303143745289297, + 26.19890807215399 ], [ - 62.580213110036865, - 55.32887464054812, - 65.21752169106196, - 59.78048798866407 + 0.5471757238610155, + 0.5471757238610155, + 0.7233136615829086, + 0.7227536045472268 ] ], "self-Hartree": [ @@ -508,7 +508,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -555,5 +555,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_print.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_print.json index 32c6f95be..1ab4957a7 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_print.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_print.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" @@ -153,73 +153,73 @@ "centres": [ [ [ - 1.1377309979601138, - -3.1856467942883184, - 1.0477708725400119 + 0.26458860417677066, + 1.418194918387491, + 0.3545487295968727 ], [ - 1.090105049208295, - 4.185791718076512, - 1.0477708725400119 + 0.26458860417677066, + 0.6350126500242496, + 0.3545487295968727 ], [ - -1.2223993512966804, - 0.8308082171150599, - -2.4765493350945733 + 0.4498006271005101, + 1.0424791004564764, + 0.7355563196114224 ], [ - 2.3654221213403295, - 1.40761137422042, - -2.4871328792616443 + 0.0793765812530312, + 1.010728467955264, + 0.7355563196114224 ], [ - 0.12171075792131451, - 0.09525189750363744, - 0.550344296687683 + 0.19050379500727488, + 0.26458860417677066, + -0.11112721375424367 ] ], [ [ - 1.1377309979601138, - -3.1856467942883184, - 1.0477708725400119 + 0.26458860417677066, + 1.418194918387491, + 0.3545487295968727 ], [ - 1.090105049208295, - 4.185791718076512, - 1.0477708725400119 + 0.26458860417677066, + 0.6350126500242496, + 0.3545487295968727 ], [ - -1.2223993512966804, - 0.8308082171150599, - -2.4765493350945733 + 0.4498006271005101, + 1.0424791004564764, + 0.7355563196114224 ], [ - 2.3654221213403295, - 1.40761137422042, - -2.4871328792616443 + 0.0793765812530312, + 1.010728467955264, + 0.7355563196114224 ], [ - 0.12171075792131451, - 0.09525189750363744, - 0.550344296687683 + 0.19050379500727488, + 0.26458860417677066, + -0.11112721375424367 ] ] ], "spreads": [ [ - 62.53876888939642, - 55.28771044842552, - 65.268486881309, - 59.838173863339286, - 30.90506734298727 + 0.5466156668253338, + 0.5466156668253338, + 0.7205133764045, + 0.7196732908509774, + 26.19890807215399 ], [ - 62.53876888939642, - 55.28771044842552, - 65.268486881309, - 59.838173863339286, - 30.90506734298727 + 0.5466156668253338, + 0.5466156668253338, + 0.7205133764045, + 0.7196732908509774, + 26.19890807215399 ] ], "self-Hartree": [ @@ -513,7 +513,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -558,5 +558,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1.json index 990254aeb..de30026e0 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1.json @@ -11,8 +11,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" @@ -136,39 +136,39 @@ "centres": [ [ [ - 1.1377309979601138, - -3.1856467942883184, - 1.0477708725400119 + 0.26458860417677066, + 1.418194918387491, + 0.3545487295968727 ], [ - 1.090105049208295, - 4.185791718076512, - 1.0477708725400119 + 0.26458860417677066, + 0.6350126500242496, + 0.3545487295968727 ], [ - -1.2223993512966804, - 0.8308082171150599, - -2.4765493350945733 + 0.4498006271005101, + 1.0424791004564764, + 0.7355563196114224 ], [ - 2.3654221213403295, - 1.40761137422042, - -2.4871328792616443 + 0.0793765812530312, + 1.010728467955264, + 0.7355563196114224 ], [ - 0.12171075792131451, - 0.09525189750363744, - 0.550344296687683 + 0.19050379500727488, + 0.26458860417677066, + -0.11112721375424367 ] ] ], "spreads": [ [ - 62.54408943123539, - 55.29415110433586, - 65.27464750870149, - 59.84993506108861, - 30.92046891146851 + 0.5468956953431747, + 0.5468956953431747, + 0.7210734334401817, + 0.7202333478866592, + 26.191067273654443 ] ], "self-Hartree": [ @@ -445,7 +445,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -476,5 +476,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1_dummy.json index 5b764d076..f66354117 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1_dummy.json @@ -11,8 +11,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" @@ -136,39 +136,39 @@ "centres": [ [ [ - 0.015875316250606238, - 0.052917720835354135, - -0.026458860417677067 + -0.5027183479358642, + -2.407756298008613, + -0.38629936209808513 ], [ - 0.005291772083535413, - 0.10054366958717285, - -0.06350126500242495 + 0.06879303708596038, + -0.40746645043222685, + 0.0740848091694958 ], [ - 0.0740848091694958, - 0.11641898583777908, - -0.09525189750363744 + 0.11112721375424367, + -0.10583544167070827, + 0.2381297437590936 ], [ - 0.042334176668283305, - 0.052917720835354135, - -0.031750632501212475 + 0.15346139042252696, + 0.021167088334141652, + 0.15346139042252696 ], [ - 0.1270025300048499, - 0.16404493458959782, - -0.05820949291888954 + 0.10583544167070827, + 0.13229430208838533, + 0.2698803762603061 ] ] ], "spreads": [ [ - 12.321814842032962, - 25.143760616929676, - 26.86061545981191, - 27.46939745759791, - 28.157427525932874 + 45.756659815194446, + 33.812043386693105, + 31.503768314130998, + 30.41193712306953, + 29.591733594313695 ] ], "self-Hartree": [ @@ -333,7 +333,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -364,5 +364,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2.json index c67eb3662..f4920b1fc 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" @@ -152,73 +152,73 @@ "centres": [ [ [ - 1.1377309979601138, - -3.1856467942883184, - 1.0477708725400119 + 0.26458860417677066, + 1.418194918387491, + 0.3545487295968727 ], [ - 1.090105049208295, - 4.185791718076512, - 1.0477708725400119 + 0.26458860417677066, + 0.6350126500242496, + 0.3545487295968727 ], [ - -1.2223993512966804, - 0.8308082171150599, - -2.4765493350945733 + 0.4498006271005101, + 1.0424791004564764, + 0.7355563196114224 ], [ - 2.3654221213403295, - 1.40761137422042, - -2.4871328792616443 + 0.0793765812530312, + 1.010728467955264, + 0.7355563196114224 ], [ - 0.12171075792131451, - 0.09525189750363744, - 0.550344296687683 + 0.19050379500727488, + 0.26458860417677066, + -0.11112721375424367 ] ], [ [ - 1.1377309979601138, - -3.1856467942883184, - 1.0477708725400119 + 0.26458860417677066, + 1.418194918387491, + 0.3545487295968727 ], [ - 1.090105049208295, - 4.185791718076512, - 1.0477708725400119 + 0.26458860417677066, + 0.6350126500242496, + 0.3545487295968727 ], [ - -1.2223993512966804, - 0.8308082171150599, - -2.4765493350945733 + 0.4498006271005101, + 1.0424791004564764, + 0.7355563196114224 ], [ - 2.3654221213403295, - 1.40761137422042, - -2.4871328792616443 + 0.0793765812530312, + 1.010728467955264, + 0.7355563196114224 ], [ - 0.12171075792131451, - 0.09525189750363744, - 0.550344296687683 + 0.19050379500727488, + 0.26458860417677066, + -0.11112721375424367 ] ] ], "spreads": [ [ - 62.54408943123539, - 55.293591047300175, - 65.27548759425503, - 59.85105517515996, - 30.868663635667954 + 0.5468956953431747, + 0.5468956953431747, + 0.7210734334401817, + 0.7202333478866592, + 26.23643189354466 ], [ - 62.54408943123539, - 55.293591047300175, - 65.27548759425503, - 59.85105517515996, - 30.868663635667954 + 0.5468956953431747, + 0.5468956953431747, + 0.7210734334401817, + 0.7202333478866592, + 26.23643189354466 ] ], "self-Hartree": [ @@ -606,7 +606,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -651,5 +651,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2_dummy.json index 2a713c41a..95aafa281 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2_dummy.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" @@ -152,73 +152,73 @@ "centres": [ [ [ - 0.015875316250606238, - 0.052917720835354135, - -0.026458860417677067 + -0.5027183479358642, + -2.407756298008613, + -0.38629936209808513 ], [ - 0.005291772083535413, - 0.10054366958717285, - -0.06350126500242495 + 0.06879303708596038, + -0.40746645043222685, + 0.0740848091694958 ], [ - 0.0740848091694958, - 0.11641898583777908, - -0.09525189750363744 + 0.11112721375424367, + -0.10583544167070827, + 0.2381297437590936 ], [ - 0.042334176668283305, - 0.052917720835354135, - -0.031750632501212475 + 0.15346139042252696, + 0.021167088334141652, + 0.15346139042252696 ], [ - 0.010583544167070826, - 0.11112721375424367, - -0.0370424045847479 + 0.16933670667313322, + 0.06879303708596038, + 0.21696265542495194 ] ], [ [ - 0.06879303708596038, - 0.0740848091694958, - -0.021167088334141652 + -0.4921348037687934, + -2.354838577173259, + -0.4286335387663685 ], [ - 0.10583544167070827, - 0.11641898583777908, - -0.10054366958717285 + -0.010583544167070826, + -0.4498006271005101, + 0.2063791112578811 ], [ - 0.08996012542010202, - 0.08466835333656661, - -0.0793765812530312 + 0.09525189750363744, + -0.04762594875181872, + 0.24342151584262903 ], [ - 0.10583544167070827, - 0.06350126500242495, - -0.12171075792131451 + 0.18521202292373945, + 0.08996012542010202, + 0.2381297437590936 ], [ - 0.08996012542010202, - 0.010583544167070826, - -0.06879303708596038 + 0.17992025084020405, + 0.09525189750363744, + 0.21167088334141654 ] ] ], "spreads": [ [ - 12.321814842032962, - 25.143760616929676, - 26.86061545981191, - 27.46939745759791, - 27.94040542460622 + 45.756659815194446, + 33.812043386693105, + 31.503768314130998, + 30.41193712306953, + 29.947089783453727 ], [ - 12.662889576763114, - 24.605825834157407, - 26.932022731861327, - 28.234995425374787, - 28.177589579217415 + 45.486432295478025, + 34.3138544906639, + 31.508808827452132, + 29.733988081376843, + 29.75919064798252 ] ], "self-Hartree": [ @@ -512,7 +512,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -557,5 +557,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_4-kipz_n-1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_4-kipz_n-1.json index ca020bf38..1f3da6a69 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_4-kipz_n-1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_4-kipz_n-1.json @@ -12,8 +12,8 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" @@ -146,61 +146,61 @@ "centres": [ [ [ - 1.2276911233802157, - -3.1062702130352875, - 0.8890177100339494 + 0.25929683209323523, + 1.3917360579698137, + 0.37571581793101433 ], [ - 1.1800651746283972, - 4.180499945992977, - 0.8413917612821308 + 0.25929683209323523, + 0.6614715104419266, + 0.37571581793101433 ], [ - -1.190648718795468, - 0.8308082171150599, - -2.614135409266494 + 0.4339253108499039, + 1.0477708725400119, + 0.7461398637784932 ], [ - 2.3654221213403295, - 1.40761137422042, - -2.4871328792616443 + 0.0793765812530312, + 1.010728467955264, + 0.7355563196114224 ] ], [ [ - 1.2435664396308221, - -2.9845594551139727, - 0.7884740404467766 + 0.2540050600096998, + 1.3758607417192075, + 0.38629936209808513 ], [ - 1.190648718795468, - 4.042913871821056, - 0.7090974591937454 + 0.25929683209323523, + 0.6826385987760684, + 0.396882906265156 ], [ - -1.2647335279649639, - 0.9101847983680911, - -2.714679078853667 + 0.4445088550169747, + 1.0424791004564764, + 0.756723407945564 ], [ - 2.7834721159396274, - 1.6616164342301198, - -2.836389836774982 + 0.052917720835354135, + 1.000144923788193, + 0.756723407945564 ] ] ], "spreads": [ [ - 63.67764487145514, - 56.02474550738263, - 65.34521469519738, - 59.85105517515996 + 0.49145004881068693, + 0.4903299347393235, + 0.6029013989113442, + 0.7202333478866592 ], [ - 64.6947084482531, - 57.44925057763902, - 64.71711072968037, - 56.06002910063057 + 0.48416930734682495, + 0.4903299347393235, + 0.5603370641995353, + 0.5225332142910211 ] ], "self-Hartree": [ @@ -593,7 +593,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -638,5 +638,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_n+1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_n+1.json index 65215335c..d9dca53a7 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_n+1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_n+1.json @@ -12,8 +12,8 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" @@ -150,67 +150,67 @@ "centres": [ [ [ - 1.1377309979601138, - -3.1803550222047834, - 1.0424791004564764 + 0.26458860417677066, + 1.418194918387491, + 0.3545487295968727 ], [ - 1.090105049208295, - 4.180499945992977, - 1.0424791004564764 + 0.26458860417677066, + 0.6350126500242496, + 0.3545487295968727 ], [ - -1.2223993512966804, - 0.8255164450315244, - -2.4765493350945733 + 0.4498006271005101, + 1.0424791004564764, + 0.7355563196114224 ], [ - 2.3601303492567944, - 1.40761137422042, - -2.4871328792616443 + 0.0793765812530312, + 1.010728467955264, + 0.7408480916949578 ], [ - 0.12171075792131451, - 0.09525189750363744, - 0.550344296687683 + 0.19050379500727488, + 0.26458860417677066, + -0.11112721375424367 ] ], [ [ - 1.1377309979601138, - -3.1803550222047834, - 1.037187328372941 + 0.26458860417677066, + 1.418194918387491, + 0.3545487295968727 ], [ - 1.090105049208295, - 4.180499945992977, - 1.037187328372941 + 0.26458860417677066, + 0.6350126500242496, + 0.3545487295968727 ], [ - -1.2223993512966804, - 0.8255164450315244, - -2.4871328792616443 + 0.4498006271005101, + 1.0424791004564764, + 0.7408480916949578 ], [ - 2.3654221213403295, - 1.4129031463039552, - -2.4924246513451798 + 0.0793765812530312, + 1.010728467955264, + 0.7408480916949578 ] ] ], "spreads": [ [ - 62.55277031528846, - 55.309552672817105, - 65.2343234021324, - 59.82529255151861, - 30.90506734298727 + 0.5508160945929466, + 0.5508160945929466, + 0.7317145171181338, + 0.7308744315646113, + 26.19890807215399 ], [ - 62.58637373742936, - 55.335875353494146, - 65.22340228993662, - 59.79168912937771 + 0.5474557523788564, + 0.5474557523788564, + 0.7238737186185902, + 0.7233136615829086 ] ], "self-Hartree": [ @@ -508,7 +508,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -555,5 +555,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_print.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_print.json index 3509032f0..9b26810b3 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_print.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_print.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" @@ -153,73 +153,73 @@ "centres": [ [ [ - 1.1377309979601138, - -3.1856467942883184, - 1.0477708725400119 + 0.26458860417677066, + 1.418194918387491, + 0.3545487295968727 ], [ - 1.090105049208295, - 4.185791718076512, - 1.0477708725400119 + 0.26458860417677066, + 0.6350126500242496, + 0.3545487295968727 ], [ - -1.2223993512966804, - 0.8308082171150599, - -2.4765493350945733 + 0.4498006271005101, + 1.0424791004564764, + 0.7355563196114224 ], [ - 2.3654221213403295, - 1.40761137422042, - -2.4871328792616443 + 0.0793765812530312, + 1.010728467955264, + 0.7355563196114224 ], [ - 0.12171075792131451, - 0.09525189750363744, - 0.550344296687683 + 0.19050379500727488, + 0.26458860417677066, + -0.11112721375424367 ] ], [ [ - 1.1377309979601138, - -3.1856467942883184, - 1.0477708725400119 + 0.26458860417677066, + 1.418194918387491, + 0.3545487295968727 ], [ - 1.090105049208295, - 4.185791718076512, - 1.0477708725400119 + 0.26458860417677066, + 0.6350126500242496, + 0.3545487295968727 ], [ - -1.2223993512966804, - 0.8308082171150599, - -2.4765493350945733 + 0.4498006271005101, + 1.0424791004564764, + 0.7355563196114224 ], [ - 2.3654221213403295, - 1.40761137422042, - -2.4871328792616443 + 0.0793765812530312, + 1.010728467955264, + 0.7355563196114224 ], [ - 0.12171075792131451, - 0.09525189750363744, - 0.550344296687683 + 0.19050379500727488, + 0.26458860417677066, + -0.11112721375424367 ] ] ], "spreads": [ [ - 62.54408943123539, - 55.293591047300175, - 65.27548759425503, - 59.85105517515996, - 30.868663635667954 + 0.5468956953431747, + 0.5468956953431747, + 0.7210734334401817, + 0.7202333478866592, + 26.23643189354466 ], [ - 62.54408943123539, - 55.293591047300175, - 65.27548759425503, - 59.85105517515996, - 30.868663635667954 + 0.5468956953431747, + 0.5468956953431747, + 0.7210734334401817, + 0.7202333478866592, + 26.23643189354466 ] ], "self-Hartree": [ @@ -513,7 +513,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -558,5 +558,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-final-kipz_final.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-final-kipz_final.json index 25819d74a..3f9b0ae49 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-final-kipz_final.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-final-kipz_final.json @@ -14,8 +14,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -153,73 +153,73 @@ "centres": [ [ [ - 1.1377309979601138, - -3.1856467942883184, - 1.0477708725400119 + 0.26458860417677066, + 1.418194918387491, + 0.3545487295968727 ], [ - 1.090105049208295, - 4.185791718076512, - 1.0477708725400119 + 0.26458860417677066, + 0.6350126500242496, + 0.3545487295968727 ], [ - -1.2223993512966804, - 0.8308082171150599, - -2.4765493350945733 + 0.4498006271005101, + 1.0424791004564764, + 0.7355563196114224 ], [ - 2.3654221213403295, - 1.40761137422042, - -2.4871328792616443 + 0.0793765812530312, + 1.010728467955264, + 0.7355563196114224 ], [ - 0.12171075792131451, - 0.09525189750363744, - 0.550344296687683 + 0.19050379500727488, + 0.26458860417677066, + -0.11112721375424367 ] ], [ [ - 1.1377309979601138, - -3.1856467942883184, - 1.0477708725400119 + 0.26458860417677066, + 1.418194918387491, + 0.3545487295968727 ], [ - 1.090105049208295, - 4.185791718076512, - 1.0477708725400119 + 0.26458860417677066, + 0.6350126500242496, + 0.3545487295968727 ], [ - -1.2223993512966804, - 0.8308082171150599, - -2.4765493350945733 + 0.4498006271005101, + 1.0424791004564764, + 0.7355563196114224 ], [ - 2.3654221213403295, - 1.40761137422042, - -2.4871328792616443 + 0.0793765812530312, + 1.010728467955264, + 0.7355563196114224 ], [ - 0.12171075792131451, - 0.09525189750363744, - 0.550344296687683 + 0.19050379500727488, + 0.26458860417677066, + -0.11112721375424367 ] ] ], "spreads": [ [ - 62.543529374199714, - 55.2930309902645, - 65.27576762277286, - 59.851335203677806, - 30.871463920846367 + 0.5468956953431747, + 0.5468956953431747, + 0.7210734334401817, + 0.7202333478866592, + 26.233631608366252 ], [ - 62.543529374199714, - 55.2930309902645, - 65.27576762277286, - 59.851335203677806, - 30.871463920846367 + 0.5468956953431747, + 0.5468956953431747, + 0.7210734334401817, + 0.7202333478866592, + 26.233631608366252 ] ], "self-Hartree": [ @@ -559,7 +559,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -604,5 +604,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-pkipz-final-pkipz_final.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-pkipz-final-pkipz_final.json index 858f9b379..f2b6197c8 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-pkipz-final-pkipz_final.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-pkipz-final-pkipz_final.json @@ -14,8 +14,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -151,73 +151,73 @@ "centres": [ [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.1481696183389916, - 0.10583544167070827, - 0.6350126500242496 + 0.2010873391743457, + 0.31221455292858935, + -0.12171075792131451 ] ], [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.1481696183389916, - 0.10583544167070827, - 0.6350126500242496 + 0.2010873391743457, + 0.31221455292858935, + -0.12171075792131451 ] ] ], "spreads": [ [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 32.620522043280296 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 24.65343068219035 ], [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 32.620522043280296 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 24.65343068219035 ] ], "self-Hartree": [ @@ -511,7 +511,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -556,5 +556,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-ki.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-ki.json index f78cade40..5169df12a 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-ki.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-ki.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.2/pbe" @@ -151,73 +151,73 @@ "centres": [ [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.19050379500727488, - 0.14287784625545616, - 0.8043493566973828 + 0.21696265542495194, + 0.550344296687683, + -0.11112721375424367 ] ], [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.19050379500727488, - 0.14287784625545616, - 0.8043493566973828 + 0.21696265542495194, + 0.550344296687683, + -0.11112721375424367 ] ] ], "spreads": [ [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 38.06343634455284 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 19.59947599219874 ], [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 38.06343634455284 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 19.59947599219874 ] ], "self-Hartree": [ @@ -708,7 +708,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -753,5 +753,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_4-dft_n-1.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_4-dft_n-1.json index 0b1bc4815..909bceb5b 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_4-dft_n-1.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_4-dft_n-1.json @@ -12,8 +12,8 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -387,7 +387,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -432,5 +432,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1.json index 37331769f..1eba08563 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1.json @@ -12,8 +12,8 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -416,7 +416,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -463,5 +463,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1_dummy.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1_dummy.json index cf1ad3689..0ab59e6f6 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1_dummy.json @@ -12,8 +12,8 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -348,7 +348,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -395,5 +395,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-pz_print.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-pz_print.json index cd8ed31d3..4db6746de 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-pz_print.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-pz_print.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../../pseudos/sg15_v1.2/pbe" @@ -153,73 +153,73 @@ "centres": [ [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.19050379500727488, - 0.14287784625545616, - 0.8043493566973828 + 0.21696265542495194, + 0.550344296687683, + -0.11112721375424367 ] ], [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.19050379500727488, - 0.14287784625545616, - 0.8043493566973828 + 0.21696265542495194, + 0.550344296687683, + -0.11112721375424367 ] ] ], "spreads": [ [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 38.06343634455284 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 19.59947599219874 ], [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 38.06343634455284 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 19.59947599219874 ] ], "self-Hartree": [ @@ -513,7 +513,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -558,5 +558,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-final-ki_final.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-final-ki_final.json index 73060619c..01749f3bf 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-final-ki_final.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-final-ki_final.json @@ -14,8 +14,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.2/pbe" @@ -152,73 +152,73 @@ "centres": [ [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.1481696183389916, - 0.10583544167070827, - 0.6350126500242496 + 0.2010873391743457, + 0.3175063250121248, + -0.12171075792131451 ] ], [ [ - 1.1536063142107202, - 0.8996012542010202, - 3.0798113526176105 + 0.26458860417677066, + 1.0266037842058702, + 0.18521202292373945 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.037187328372941, - 1.1483145421271845, - -4.185791718076512 + 0.26458860417677066, + 1.0266037842058702, + 0.9419354308693035 ], [ - 0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.1481696183389916, - 0.10583544167070827, - 0.6350126500242496 + 0.2010873391743457, + 0.3175063250121248, + -0.12171075792131451 ] ] ], "spreads": [ [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 32.72497268043493 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 24.555980757981736 ], [ - 64.67510645200424, - 72.07261980780589, - 53.94525373389649, - 69.06455346915952, - 32.72497268043493 + 0.5768587467521453, + 0.8605276353249236, + 0.49761067620318555, + 0.8871303445198041, + 24.555980757981736 ] ], "self-Hartree": [ @@ -679,7 +679,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -724,5 +724,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin1.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin1.json index 5b3846fb5..7a817583f 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin1.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin1.json @@ -11,8 +11,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.2/pbe" @@ -738,7 +738,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -769,5 +769,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2.json index 073ab7d02..7bf043e24 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.2/pbe" @@ -496,7 +496,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -525,5 +525,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2_dummy.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2_dummy.json index ca834a9aa..8d3395693 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2_dummy.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.2/pbe" @@ -384,7 +384,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -413,5 +413,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-pz_innerloop_init.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-pz_innerloop_init.json index ee5d2c33a..fdaf5bf1b 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-pz_innerloop_init.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-pz_innerloop_init.json @@ -13,8 +13,8 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "O": "O_ONCV_PBE-1.2.upf", - "H": "H_ONCV_PBE-1.2.upf" + "H": "H_ONCV_PBE-1.2.upf", + "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.2/pbe" @@ -150,73 +150,73 @@ "centres": [ [ [ - 1.0742297329576889, - 0.9948531517046576, - -0.4815512596017226 + 0.26458860417677066, + 1.0266037842058702, + 0.5027183479358642 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.116563909625972, - 1.0583544167070826, - -0.6244291058571787 + 0.26458860417677066, + 1.0266037842058702, + 0.6244291058571787 ], [ - -0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.32808986917919564, - 0.2381297437590936, - 1.2276911233802157 + 0.2540050600096998, + 0.9313518867022327, + -0.06879303708596038 ] ], [ [ - 1.0742297329576889, - 0.9948531517046576, - -0.4815512596017226 + 0.26458860417677066, + 1.0266037842058702, + 0.5027183479358642 ], [ - 1.1800651746283972, - 0.0, - 0.0370424045847479 + 0.26458860417677066, + 1.0266037842058702, + 0.4286335387663685 ], [ - 1.116563909625972, - 1.0583544167070826, - -0.6244291058571787 + 0.26458860417677066, + 1.0266037842058702, + 0.6244291058571787 ], [ - -0.0, - 1.1853569467119327, - -1.73040947131608 + 0.26458860417677066, + 1.0266037842058702, + 0.6032620175230371 ], [ - 0.32808986917919564, - 0.2381297437590936, - 1.2276911233802157 + 0.2540050600096998, + 0.9313518867022327, + -0.06879303708596038 ] ] ], "spreads": [ [ - 74.45090200982823, - 72.07261980780589, - 70.60667051690906, - 69.06455346915952, - 49.72522397003493 + 0.46064691184819373, + 0.8605276353249236, + 0.8924508863587801, + 0.8871303445198041, + 9.382915547293269 ], [ - 74.45090200982823, - 72.07261980780589, - 70.60667051690906, - 69.06455346915952, - 49.72522397003493 + 0.46064691184819373, + 0.8605276353249236, + 0.8924508863587801, + 0.8871303445198041, + 9.382915547293269 ] ], "self-Hartree": [ @@ -510,7 +510,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -555,5 +555,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-hamiltonian-kc.json b/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-hamiltonian-kc.json index 57c1aef00..6ab708a46 100644 --- a/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-hamiltonian-kc.json +++ b/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-hamiltonian-kc.json @@ -285,7 +285,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcw.x", "_flags": "", @@ -311,5 +311,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansHamCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-init-dft.json b/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-init-dft.json index 3bb7c1a08..b6fd54c94 100644 --- a/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-init-dft.json +++ b/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-init-dft.json @@ -131,7 +131,7 @@ "postfix": "-npool 1", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -204,5 +204,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-init-kc.json b/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-init-kc.json index 884bf90e3..83ad59039 100644 --- a/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-init-kc.json +++ b/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-init-kc.json @@ -100,7 +100,7 @@ "postfix": "-npool 1", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcw.x", "_flags": "", @@ -112,5 +112,5 @@ "skip_qc": false, "kpts": null, "__koopmans_name__": "BenchGenWann2KCCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-screening-kc.json b/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-screening-kc.json index f4f25c9bf..864f29585 100644 --- a/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-screening-kc.json +++ b/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-screening-kc.json @@ -128,7 +128,7 @@ "postfix": "-npool 1", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcw.x", "_flags": "", @@ -140,5 +140,5 @@ "skip_qc": false, "kpts": null, "__koopmans_name__": "BenchGenKoopmansScreenCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-hamiltonian-kc.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-hamiltonian-kc.json index bd988b1d2..37034cb74 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-hamiltonian-kc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-hamiltonian-kc.json @@ -1061,7 +1061,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcw.x", "_flags": "", @@ -1085,5 +1085,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansHamCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-emp-ki.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-emp-ki.json index f702bdf74..24aae387b 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-emp-ki.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-emp-ki.json @@ -5570,5 +5570,5 @@ ], "command": null, "__koopmans_name__": "BenchGenUnfoldAndInterpolateCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-occ-ki.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-occ-ki.json index fbcf692d9..7966945a6 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-occ-ki.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-occ-ki.json @@ -5570,5 +5570,5 @@ ], "command": null, "__koopmans_name__": "BenchGenUnfoldAndInterpolateCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-bands.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-bands.json index c236dedc8..bc509e68e 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-bands.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-bands.json @@ -727,7 +727,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -1430,5 +1430,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-emp-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-emp-pw2wan.json index 3915ac545..068ab1ff5 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-emp-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-emp-pw2wan.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-emp-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-emp-wann.json index abe45f488..07f6565cd 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-emp-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-emp-wann.json @@ -2597,7 +2597,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -2608,5 +2608,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-emp-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-emp-wann_preproc.json index 80bc900d6..61c0ce663 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-emp-wann_preproc.json @@ -308,7 +308,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -319,5 +319,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-nscf.json index 1b06b7e4c..7e84fed18 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-nscf.json @@ -113,7 +113,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -2046,5 +2046,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-occ-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-occ-pw2wan.json index 751b80f78..ef7906d24 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-occ-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-occ-pw2wan.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-occ-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-occ-wann.json index 7dfd4189e..c31f4c64d 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-occ-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-occ-wann.json @@ -2594,7 +2594,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -2605,5 +2605,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-occ-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-occ-wann_preproc.json index 0e2c51df1..09df9b66c 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-occ-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-occ-wann_preproc.json @@ -305,7 +305,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -316,5 +316,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-scf.json index 680ff7300..842b43036 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-scf.json @@ -110,7 +110,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -195,5 +195,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-screening-kc.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-screening-kc.json index 845662f20..464e4fea5 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-screening-kc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-screening-kc.json @@ -117,7 +117,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcw.x", "_flags": "", @@ -129,5 +129,5 @@ "skip_qc": false, "kpts": null, "__koopmans_name__": "BenchGenKoopmansScreenCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-bands.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-bands.json index bedbf161e..135ecd372 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-bands.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-bands.json @@ -958,7 +958,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -2351,5 +2351,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-emp-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-emp-pw2wan.json index dd96eec68..aef3924c7 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-emp-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-emp-pw2wan.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-emp-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-emp-wann.json index 5d0a1a721..e8b7f6ba9 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-emp-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-emp-wann.json @@ -2429,7 +2429,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -2440,5 +2440,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-emp-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-emp-wann_preproc.json index 863d4791c..aeeb9e27f 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-emp-wann_preproc.json @@ -140,7 +140,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -151,5 +151,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-kc.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-kc.json index 0e8af3214..6dbdc278b 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-kc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-kc.json @@ -92,7 +92,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcw.x", "_flags": "", @@ -104,5 +104,5 @@ "skip_qc": false, "kpts": null, "__koopmans_name__": "BenchGenWann2KCCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-nscf.json index d81f11a48..a6f704ba6 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-nscf.json @@ -114,7 +114,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -607,5 +607,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-occ-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-occ-pw2wan.json index d28f6ba69..4564da692 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-occ-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-occ-pw2wan.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-occ-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-occ-wann.json index ff9a234db..7c189b141 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-occ-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-occ-wann.json @@ -2426,7 +2426,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -2437,5 +2437,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-occ-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-occ-wann_preproc.json index c9356debb..3ea53557e 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-occ-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-occ-wann_preproc.json @@ -137,7 +137,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -148,5 +148,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-scf.json index abc88e4a9..16cb48ec6 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-scf.json @@ -123,7 +123,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -280,5 +280,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-hamiltonian-kc.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-hamiltonian-kc.json index bd988b1d2..37034cb74 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-hamiltonian-kc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-hamiltonian-kc.json @@ -1061,7 +1061,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcw.x", "_flags": "", @@ -1085,5 +1085,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansHamCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-emp-ki.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-emp-ki.json index f702bdf74..24aae387b 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-emp-ki.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-emp-ki.json @@ -5570,5 +5570,5 @@ ], "command": null, "__koopmans_name__": "BenchGenUnfoldAndInterpolateCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-occ-ki.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-occ-ki.json index fbcf692d9..7966945a6 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-occ-ki.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-occ-ki.json @@ -5570,5 +5570,5 @@ ], "command": null, "__koopmans_name__": "BenchGenUnfoldAndInterpolateCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-bands.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-bands.json index c236dedc8..bc509e68e 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-bands.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-bands.json @@ -727,7 +727,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -1430,5 +1430,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-emp-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-emp-pw2wan.json index 3915ac545..068ab1ff5 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-emp-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-emp-pw2wan.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-emp-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-emp-wann.json index abe45f488..07f6565cd 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-emp-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-emp-wann.json @@ -2597,7 +2597,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -2608,5 +2608,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-emp-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-emp-wann_preproc.json index 80bc900d6..61c0ce663 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-emp-wann_preproc.json @@ -308,7 +308,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -319,5 +319,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-nscf.json index 1b06b7e4c..7e84fed18 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-nscf.json @@ -113,7 +113,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -2046,5 +2046,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-occ-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-occ-pw2wan.json index 751b80f78..ef7906d24 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-occ-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-occ-pw2wan.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-occ-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-occ-wann.json index 7dfd4189e..c31f4c64d 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-occ-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-occ-wann.json @@ -2594,7 +2594,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -2605,5 +2605,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-occ-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-occ-wann_preproc.json index 0e2c51df1..09df9b66c 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-occ-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-occ-wann_preproc.json @@ -305,7 +305,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -316,5 +316,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-scf.json index 680ff7300..842b43036 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-scf.json @@ -110,7 +110,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -195,5 +195,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-screening-kc.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-screening-kc.json index 845662f20..464e4fea5 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-screening-kc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-screening-kc.json @@ -117,7 +117,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcw.x", "_flags": "", @@ -129,5 +129,5 @@ "skip_qc": false, "kpts": null, "__koopmans_name__": "BenchGenKoopmansScreenCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-bands.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-bands.json index bedbf161e..135ecd372 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-bands.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-bands.json @@ -958,7 +958,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -2351,5 +2351,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-emp-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-emp-pw2wan.json index dd96eec68..aef3924c7 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-emp-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-emp-pw2wan.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-emp-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-emp-wann.json index 5d0a1a721..e8b7f6ba9 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-emp-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-emp-wann.json @@ -2429,7 +2429,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -2440,5 +2440,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-emp-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-emp-wann_preproc.json index 863d4791c..aeeb9e27f 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-emp-wann_preproc.json @@ -140,7 +140,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -151,5 +151,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-kc.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-kc.json index 0e8af3214..6dbdc278b 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-kc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-kc.json @@ -92,7 +92,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcw.x", "_flags": "", @@ -104,5 +104,5 @@ "skip_qc": false, "kpts": null, "__koopmans_name__": "BenchGenWann2KCCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-nscf.json index d81f11a48..a6f704ba6 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-nscf.json @@ -114,7 +114,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -607,5 +607,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-occ-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-occ-pw2wan.json index d28f6ba69..4564da692 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-occ-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-occ-pw2wan.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-occ-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-occ-wann.json index ff9a234db..7c189b141 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-occ-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-occ-wann.json @@ -2426,7 +2426,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -2437,5 +2437,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-occ-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-occ-wann_preproc.json index c9356debb..3ea53557e 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-occ-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-occ-wann_preproc.json @@ -137,7 +137,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -148,5 +148,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-scf.json index abc88e4a9..16cb48ec6 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-scf.json @@ -123,7 +123,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -280,5 +280,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-ki.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-ki.json index 4afddb653..04f8ac4de 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-ki.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-ki.json @@ -441,781 +441,781 @@ "centres": [ [ [ - 1.3758607417192075, - 1.3758607417192075, - 1.3758607417192075 + -0.756723407945564, + -0.756723407945564, + -0.756723407945564 ], [ - 1.3758607417192075, - 1.1218556817095076, - 1.1218556817095076 + -0.756723407945564, + -0.9842696075375869, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.3758607417192075, - 1.1218556817095076 + -0.9842696075375869, + -0.756723407945564, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.1218556817095076, - 1.3758607417192075 + -0.9842696075375869, + -0.9842696075375869, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.46038417126758097, - 1.3758607417192075 + 0.6032620175230371, + 0.6032620175230371, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.7143892312772808, - 1.1218556817095076 + 0.6032620175230371, + 0.37571581793101433, + -0.9842696075375869 ], [ - -0.7143892312772808, - -0.46038417126758097, - 1.1218556817095076 + 0.37571581793101433, + 0.6032620175230371, + -0.9842696075375869 ], [ - 0.11112721375424367, - 0.11112721375424367, - 1.3758607417192075 + 0.550344296687683, + 0.550344296687683, + -0.756723407945564 ], [ - -0.47096771543465177, - 1.3758607417192075, - -0.47096771543465177 + 0.6032620175230371, + -0.756723407945564, + 0.6032620175230371 ], [ - -0.47096771543465177, - 1.1218556817095076, - -0.7249727754443517 + 0.6032620175230371, + -0.9842696075375869, + 0.37571581793101433 ], [ - 0.08996012542010202, - 1.3758607417192075, - 0.08996012542010202 + 0.550344296687683, + -0.756723407945564, + 0.550344296687683 ], [ - -0.7249727754443517, - 1.1218556817095076, - -0.47096771543465177 + 0.37571581793101433, + -0.9842696075375869, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.45509239918404554, - -0.46038417126758097 + 1.9632474429916382, + 0.6032620175230371, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.7090974591937454, - -0.7090974591937454 + 1.9632474429916382, + 0.37571581793101433, + 0.37571581793101433 ], [ - -1.6986588388148676, - -0.4498006271005101, - 0.13229430208838533 + 1.910329722156284, + 0.6032620175230371, + 0.550344296687683 ], [ - -1.6986588388148676, - 0.13229430208838533, - -0.45509239918404554 + 1.910329722156284, + 0.550344296687683, + 0.6032620175230371 ], [ - 1.3758607417192075, - -0.47096771543465177, - -0.47096771543465177 + -0.756723407945564, + 0.6032620175230371, + 0.6032620175230371 ], [ - 1.3758607417192075, - 0.08996012542010202, - 0.08996012542010202 + -0.756723407945564, + 0.550344296687683, + 0.550344296687683 ], [ - 1.1218556817095076, - -0.47096771543465177, - -0.7249727754443517 + -0.9842696075375869, + 0.6032620175230371, + 0.37571581793101433 ], [ - 1.1218556817095076, - -0.7249727754443517, - -0.47096771543465177 + -0.9842696075375869, + 0.37571581793101433, + 0.6032620175230371 ], [ - -0.45509239918404554, - -2.2860455400872985, - -0.46038417126758097 + 0.6032620175230371, + 1.9632474429916382, + 0.6032620175230371 ], [ - -0.4498006271005101, - -1.6986588388148676, - 0.13229430208838533 + 0.6032620175230371, + 1.910329722156284, + 0.550344296687683 ], [ - -0.7090974591937454, - -2.2860455400872985, - -0.7090974591937454 + 0.37571581793101433, + 1.9632474429916382, + 0.37571581793101433 ], [ - 0.13229430208838533, - -1.6986588388148676, - -0.45509239918404554 + 0.550344296687683, + 1.910329722156284, + 0.6032620175230371 ], [ - -0.46038417126758097, - -0.46038417126758097, - -2.291337312170834 + 0.6032620175230371, + 0.6032620175230371, + 1.9632474429916382 ], [ - -0.45509239918404554, - 0.13229430208838533, - -1.6986588388148676 + 0.6032620175230371, + 0.550344296687683, + 1.910329722156284 ], [ - 0.13229430208838533, - -0.45509239918404554, - -1.6986588388148676 + 0.550344296687683, + 0.6032620175230371, + 1.910329722156284 ], [ - -0.7090974591937454, - -0.7090974591937454, - -2.2860455400872985 + 0.37571581793101433, + 0.37571581793101433, + 1.9632474429916382 ], [ - -2.3125044005049755, - -2.3125044005049755, - -2.3125044005049755 + 1.9632474429916382, + 1.9632474429916382, + 1.9632474429916382 ], [ - -2.3125044005049755, - -1.7515765596502217, - -1.756868331733757 + 1.9632474429916382, + 1.910329722156284, + 1.910329722156284 ], [ - -1.7515765596502217, - -2.3125044005049755, - -1.756868331733757 + 1.910329722156284, + 1.9632474429916382, + 1.910329722156284 ], [ - -1.73040947131608, - -1.73040947131608, - -2.317796172588511 + 1.910329722156284, + 1.910329722156284, + 1.9632474429916382 ], [ - 0.4498006271005101, - 0.4498006271005101, - 0.5397607525206122 + -0.5080101200193996, + -0.5080101200193996, + -1.2700253000484991 ], [ - 0.4498006271005101, - 0.5397607525206122, - 0.4498006271005101 + -0.5080101200193996, + -1.2700253000484991, + -0.5080101200193996 ], [ - 0.5397607525206122, - 0.4498006271005101, - 0.4498006271005101 + -1.2700253000484991, + -0.5080101200193996, + -0.5080101200193996 ], [ - 0.5397607525206122, - 0.5397607525206122, - 0.5397607525206122 + -1.2700253000484991, + -1.2700253000484991, + -1.2700253000484991 ], [ - 0.2751721483438415, - 0.2751721483438415, - 0.5397607525206122 + -0.33867341334626644, + -0.33867341334626644, + -1.2700253000484991 ], [ - -0.2063791112578811, - -0.10583544167070827, - 0.4339253108499039 + 1.1800651746283972, + 0.4127582225157622, + -0.5080101200193996 ], [ - -0.10583544167070827, - -0.2063791112578811, - 0.4339253108499039 + 0.4127582225157622, + 1.1800651746283972, + -0.5080101200193996 ], [ - -0.10583544167070827, - -0.10583544167070827, - 0.5397607525206122 + 0.4127582225157622, + 0.4127582225157622, + -1.2700253000484991 ], [ - -0.21167088334141654, - 0.43921708293343925, - -0.11641898583777908 + 1.1800651746283972, + -0.5080101200193996, + 0.4127582225157622 ], [ - 0.2698803762603061, - 0.5397607525206122, - 0.26458860417677066 + -0.33867341334626644, + -1.2700253000484991, + -0.33867341334626644 ], [ - -0.11641898583777908, - 0.4339253108499039, - -0.21696265542495194 + 0.4127582225157622, + -0.5080101200193996, + 1.1800651746283972 ], [ - -0.10583544167070827, - 0.5397607525206122, - -0.10583544167070827 + 0.4127582225157622, + -1.2700253000484991, + 0.4127582225157622 ], [ - -0.3545487295968727, - 0.2751721483438415, - -0.09525189750363744 + 1.344110109217995, + -0.33867341334626644, + 0.4127582225157622 ], [ - -0.3598405016804081, - -0.10054366958717285, - 0.2804639204273769 + 1.344110109217995, + 0.4127582225157622, + -0.33867341334626644 ], [ - -0.756723407945564, - -0.21167088334141654, - -0.21167088334141654 + 2.0955417450800238, + 1.1800651746283972, + 1.1800651746283972 ], [ - -0.756723407945564, - -0.10583544167070827, - -0.11112721375424367 + 2.0955417450800238, + 0.4127582225157622, + 0.4127582225157622 ], [ - 0.43921708293343925, - -0.21167088334141654, - -0.11641898583777908 + -0.5080101200193996, + 1.1800651746283972, + 0.4127582225157622 ], [ - 0.4339253108499039, - -0.11641898583777908, - -0.21696265542495194 + -0.5080101200193996, + 0.4127582225157622, + 1.1800651746283972 ], [ - 0.5397607525206122, - 0.2698803762603061, - 0.26458860417677066 + -1.2700253000484991, + -0.33867341334626644, + -0.33867341334626644 ], [ - 0.5397607525206122, - -0.10583544167070827, - -0.10583544167070827 + -1.2700253000484991, + 0.4127582225157622, + 0.4127582225157622 ], [ - 0.2751721483438415, - -0.3545487295968727, - -0.09525189750363744 + -0.33867341334626644, + 1.344110109217995, + 0.4127582225157622 ], [ - -0.21167088334141654, - -0.756723407945564, - -0.21167088334141654 + 1.1800651746283972, + 2.0955417450800238, + 1.1800651746283972 ], [ - -0.10054366958717285, - -0.3598405016804081, - 0.2804639204273769 + 0.4127582225157622, + 1.344110109217995, + -0.33867341334626644 ], [ - -0.10583544167070827, - -0.756723407945564, - -0.11112721375424367 + 0.4127582225157622, + 2.0955417450800238, + 0.4127582225157622 ], [ - -0.21167088334141654, - -0.21167088334141654, - -0.7620151800290995 + 1.1800651746283972, + 1.1800651746283972, + 2.0955417450800238 ], [ - 0.2804639204273769, - -0.09525189750363744, - -0.3545487295968727 + -0.33867341334626644, + 0.4127582225157622, + 1.344110109217995 ], [ - -0.09525189750363744, - 0.2804639204273769, - -0.3545487295968727 + 0.4127582225157622, + -0.33867341334626644, + 1.344110109217995 ], [ - -0.11112721375424367, - -0.11112721375424367, - -0.7620151800290995 + 0.4127582225157622, + 0.4127582225157622, + 2.0955417450800238 ], [ - -0.38100759001454976, - -0.38100759001454976, - -0.7778904962797057 + 1.344110109217995, + 1.344110109217995, + 2.0955417450800238 ], [ - -0.38100759001454976, - -0.7673069521126349, - -0.39159113418162056 + 1.344110109217995, + 2.0955417450800238, + 1.344110109217995 ], [ - -0.7673069521126349, - -0.38100759001454976, - -0.39159113418162056 + 2.0955417450800238, + 1.344110109217995, + 1.344110109217995 ], [ - -0.7620151800290995, - -0.7620151800290995, - -0.7831822683632411 + 2.0955417450800238, + 2.0955417450800238, + 2.0955417450800238 ] ], [ [ - 1.3758607417192075, - 1.3758607417192075, - 1.3758607417192075 + -0.756723407945564, + -0.756723407945564, + -0.756723407945564 ], [ - 1.3758607417192075, - 1.1218556817095076, - 1.1218556817095076 + -0.756723407945564, + -0.9842696075375869, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.3758607417192075, - 1.1218556817095076 + -0.9842696075375869, + -0.756723407945564, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.1218556817095076, - 1.3758607417192075 + -0.9842696075375869, + -0.9842696075375869, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.46038417126758097, - 1.3758607417192075 + 0.6032620175230371, + 0.6032620175230371, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.7143892312772808, - 1.1218556817095076 + 0.6032620175230371, + 0.37571581793101433, + -0.9842696075375869 ], [ - -0.7143892312772808, - -0.46038417126758097, - 1.1218556817095076 + 0.37571581793101433, + 0.6032620175230371, + -0.9842696075375869 ], [ - 0.11112721375424367, - 0.11112721375424367, - 1.3758607417192075 + 0.550344296687683, + 0.550344296687683, + -0.756723407945564 ], [ - -0.47096771543465177, - 1.3758607417192075, - -0.47096771543465177 + 0.6032620175230371, + -0.756723407945564, + 0.6032620175230371 ], [ - -0.47096771543465177, - 1.1218556817095076, - -0.7249727754443517 + 0.6032620175230371, + -0.9842696075375869, + 0.37571581793101433 ], [ - 0.08996012542010202, - 1.3758607417192075, - 0.08996012542010202 + 0.550344296687683, + -0.756723407945564, + 0.550344296687683 ], [ - -0.7249727754443517, - 1.1218556817095076, - -0.47096771543465177 + 0.37571581793101433, + -0.9842696075375869, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.45509239918404554, - -0.46038417126758097 + 1.9632474429916382, + 0.6032620175230371, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.7090974591937454, - -0.7090974591937454 + 1.9632474429916382, + 0.37571581793101433, + 0.37571581793101433 ], [ - -1.6986588388148676, - -0.4498006271005101, - 0.13229430208838533 + 1.910329722156284, + 0.6032620175230371, + 0.550344296687683 ], [ - -1.6986588388148676, - 0.13229430208838533, - -0.45509239918404554 + 1.910329722156284, + 0.550344296687683, + 0.6032620175230371 ], [ - 1.3758607417192075, - -0.47096771543465177, - -0.47096771543465177 + -0.756723407945564, + 0.6032620175230371, + 0.6032620175230371 ], [ - 1.3758607417192075, - 0.08996012542010202, - 0.08996012542010202 + -0.756723407945564, + 0.550344296687683, + 0.550344296687683 ], [ - 1.1218556817095076, - -0.47096771543465177, - -0.7249727754443517 + -0.9842696075375869, + 0.6032620175230371, + 0.37571581793101433 ], [ - 1.1218556817095076, - -0.7249727754443517, - -0.47096771543465177 + -0.9842696075375869, + 0.37571581793101433, + 0.6032620175230371 ], [ - -0.45509239918404554, - -2.2860455400872985, - -0.46038417126758097 + 0.6032620175230371, + 1.9632474429916382, + 0.6032620175230371 ], [ - -0.4498006271005101, - -1.6986588388148676, - 0.13229430208838533 + 0.6032620175230371, + 1.910329722156284, + 0.550344296687683 ], [ - -0.7090974591937454, - -2.2860455400872985, - -0.7090974591937454 + 0.37571581793101433, + 1.9632474429916382, + 0.37571581793101433 ], [ - 0.13229430208838533, - -1.6986588388148676, - -0.45509239918404554 + 0.550344296687683, + 1.910329722156284, + 0.6032620175230371 ], [ - -0.46038417126758097, - -0.46038417126758097, - -2.291337312170834 + 0.6032620175230371, + 0.6032620175230371, + 1.9632474429916382 ], [ - -0.45509239918404554, - 0.13229430208838533, - -1.6986588388148676 + 0.6032620175230371, + 0.550344296687683, + 1.910329722156284 ], [ - 0.13229430208838533, - -0.45509239918404554, - -1.6986588388148676 + 0.550344296687683, + 0.6032620175230371, + 1.910329722156284 ], [ - -0.7090974591937454, - -0.7090974591937454, - -2.2860455400872985 + 0.37571581793101433, + 0.37571581793101433, + 1.9632474429916382 ], [ - -2.3125044005049755, - -2.3125044005049755, - -2.3125044005049755 + 1.9632474429916382, + 1.9632474429916382, + 1.9632474429916382 ], [ - -2.3125044005049755, - -1.7515765596502217, - -1.756868331733757 + 1.9632474429916382, + 1.910329722156284, + 1.910329722156284 ], [ - -1.7515765596502217, - -2.3125044005049755, - -1.756868331733757 + 1.910329722156284, + 1.9632474429916382, + 1.910329722156284 ], [ - -1.73040947131608, - -1.73040947131608, - -2.317796172588511 + 1.910329722156284, + 1.910329722156284, + 1.9632474429916382 ], [ - 0.4498006271005101, - 0.4498006271005101, - 0.5397607525206122 + -0.5080101200193996, + -0.5080101200193996, + -1.2700253000484991 ], [ - 0.4498006271005101, - 0.5397607525206122, - 0.4498006271005101 + -0.5080101200193996, + -1.2700253000484991, + -0.5080101200193996 ], [ - 0.5397607525206122, - 0.4498006271005101, - 0.4498006271005101 + -1.2700253000484991, + -0.5080101200193996, + -0.5080101200193996 ], [ - 0.5397607525206122, - 0.5397607525206122, - 0.5397607525206122 + -1.2700253000484991, + -1.2700253000484991, + -1.2700253000484991 ], [ - 0.2751721483438415, - 0.2751721483438415, - 0.5397607525206122 + -0.33867341334626644, + -0.33867341334626644, + -1.2700253000484991 ], [ - -0.2063791112578811, - -0.10583544167070827, - 0.4339253108499039 + 1.1800651746283972, + 0.4127582225157622, + -0.5080101200193996 ], [ - -0.10583544167070827, - -0.2063791112578811, - 0.4339253108499039 + 0.4127582225157622, + 1.1800651746283972, + -0.5080101200193996 ], [ - -0.10583544167070827, - -0.10583544167070827, - 0.5397607525206122 + 0.4127582225157622, + 0.4127582225157622, + -1.2700253000484991 ], [ - -0.21167088334141654, - 0.43921708293343925, - -0.11641898583777908 + 1.1800651746283972, + -0.5080101200193996, + 0.4127582225157622 ], [ - 0.2698803762603061, - 0.5397607525206122, - 0.26458860417677066 + -0.33867341334626644, + -1.2700253000484991, + -0.33867341334626644 ], [ - -0.11641898583777908, - 0.4339253108499039, - -0.21696265542495194 + 0.4127582225157622, + -0.5080101200193996, + 1.1800651746283972 ], [ - -0.10583544167070827, - 0.5397607525206122, - -0.10583544167070827 + 0.4127582225157622, + -1.2700253000484991, + 0.4127582225157622 ], [ - -0.3545487295968727, - 0.2751721483438415, - -0.09525189750363744 + 1.344110109217995, + -0.33867341334626644, + 0.4127582225157622 ], [ - -0.3598405016804081, - -0.10054366958717285, - 0.2804639204273769 + 1.344110109217995, + 0.4127582225157622, + -0.33867341334626644 ], [ - -0.756723407945564, - -0.21167088334141654, - -0.21167088334141654 + 2.0955417450800238, + 1.1800651746283972, + 1.1800651746283972 ], [ - -0.756723407945564, - -0.10583544167070827, - -0.11112721375424367 + 2.0955417450800238, + 0.4127582225157622, + 0.4127582225157622 ], [ - 0.43921708293343925, - -0.21167088334141654, - -0.11641898583777908 + -0.5080101200193996, + 1.1800651746283972, + 0.4127582225157622 ], [ - 0.4339253108499039, - -0.11641898583777908, - -0.21696265542495194 + -0.5080101200193996, + 0.4127582225157622, + 1.1800651746283972 ], [ - 0.5397607525206122, - 0.2698803762603061, - 0.26458860417677066 + -1.2700253000484991, + -0.33867341334626644, + -0.33867341334626644 ], [ - 0.5397607525206122, - -0.10583544167070827, - -0.10583544167070827 + -1.2700253000484991, + 0.4127582225157622, + 0.4127582225157622 ], [ - 0.2751721483438415, - -0.3545487295968727, - -0.09525189750363744 + -0.33867341334626644, + 1.344110109217995, + 0.4127582225157622 ], [ - -0.21167088334141654, - -0.756723407945564, - -0.21167088334141654 + 1.1800651746283972, + 2.0955417450800238, + 1.1800651746283972 ], [ - -0.10054366958717285, - -0.3598405016804081, - 0.2804639204273769 + 0.4127582225157622, + 1.344110109217995, + -0.33867341334626644 ], [ - -0.10583544167070827, - -0.756723407945564, - -0.11112721375424367 + 0.4127582225157622, + 2.0955417450800238, + 0.4127582225157622 ], [ - -0.21167088334141654, - -0.21167088334141654, - -0.7620151800290995 + 1.1800651746283972, + 1.1800651746283972, + 2.0955417450800238 ], [ - 0.2804639204273769, - -0.09525189750363744, - -0.3545487295968727 + -0.33867341334626644, + 0.4127582225157622, + 1.344110109217995 ], [ - -0.09525189750363744, - 0.2804639204273769, - -0.3545487295968727 + 0.4127582225157622, + -0.33867341334626644, + 1.344110109217995 ], [ - -0.11112721375424367, - -0.11112721375424367, - -0.7620151800290995 + 0.4127582225157622, + 0.4127582225157622, + 2.0955417450800238 ], [ - -0.38100759001454976, - -0.38100759001454976, - -0.7778904962797057 + 1.344110109217995, + 1.344110109217995, + 2.0955417450800238 ], [ - -0.38100759001454976, - -0.7673069521126349, - -0.39159113418162056 + 1.344110109217995, + 2.0955417450800238, + 1.344110109217995 ], [ - -0.7673069521126349, - -0.38100759001454976, - -0.39159113418162056 + 2.0955417450800238, + 1.344110109217995, + 1.344110109217995 ], [ - -0.7620151800290995, - -0.7620151800290995, - -0.7831822683632411 + 2.0955417450800238, + 2.0955417450800238, + 2.0955417450800238 ] ] ], "spreads": [ [ - 3.1895248182072504, - 3.188124675618046, - 3.188124675618046, - 3.1884047041358867, - 7.452118916780627, - 7.850599497668153, - 7.850599497668153, - 11.338074658858064, - 7.391072699891322, - 7.788713195225325, - 11.27058778605842, - 7.79011333781453, - 11.794521142938645, - 12.616404842801533, - 15.16382426959972, - 15.15094295777904, - 7.391072699891322, - 11.27058778605842, - 7.788713195225325, - 7.79011333781453, - 11.794521142938645, - 15.16382426959972, - 12.616404842801533, - 15.15094295777904, - 11.79256094331376, - 15.167464640331652, - 15.167464640331652, - 12.630686297211415, - 16.073076867028952, - 18.92264706457741, - 18.92264706457741, - 18.897444497971733, - 9.332790442599759, - 9.330830242974871, - 9.331110271492713, - 6.140465339214099, - 8.700486049315124, - 13.444729198574759, - 13.444449170056918, - 10.512270559745406, - 13.430167715647034, - 8.683964366762513, - 13.43548825748601, - 10.482027479818596, - 14.28453472357946, - 14.276693925079915, - 20.245501782857577, - 17.524184646480222, - 13.430167715647034, - 13.435768286003851, - 8.684244395280356, - 10.481467422782913, - 14.28453472357946, - 20.245501782857577, - 14.276693925079915, - 17.524464674998065, - 20.241861412125644, - 14.28453472357946, - 14.28453472357946, - 17.535665815711695, - 22.479009241156174, - 22.56049753984786, - 22.56105759688354, - 27.245934700360916 + 2.828848087228239, + 2.8008452354441546, + 2.8008452354441546, + 2.8008452354441546, + 9.641941926296054, + 10.086627212627318, + 10.086627212627318, + 7.921726741199729, + 9.642221954813893, + 10.086627212627318, + 7.921726741199729, + 10.086627212627318, + 14.239730160724923, + 15.156543528135858, + 12.280650649910356, + 12.280650649910356, + 9.641941926296054, + 7.921726741199729, + 10.086627212627318, + 10.086627212627318, + 14.239730160724923, + 12.280650649910356, + 15.156543528135858, + 12.280650649910356, + 14.239730160724923, + 12.280650649910356, + 12.280650649910356, + 15.156543528135858, + 16.62165273347917, + 14.4239889254642, + 14.4239889254642, + 14.4239889254642, + 7.7332675486928375, + 7.7332675486928375, + 7.7332675486928375, + 6.848937489351441, + 10.323811367238514, + 11.377278651355782, + 11.377558679873625, + 8.873823701858608, + 11.377558679873625, + 10.323531338720676, + 11.377558679873625, + 8.873823701858608, + 11.940135972215886, + 11.939855943698046, + 15.62363109589439, + 11.500491199205756, + 11.377278651355782, + 11.377278651355782, + 10.324091395756357, + 8.873823701858608, + 11.940416000733727, + 15.623071038858708, + 11.940135972215886, + 11.500491199205756, + 15.62335106737655, + 11.939855943698046, + 11.940416000733727, + 11.500491199205756, + 14.157961833515396, + 14.157961833515396, + 14.158241862033238, + 14.728939981392884 ], [ - 3.1895248182072504, - 3.188124675618046, - 3.188124675618046, - 3.1884047041358867, - 7.452118916780627, - 7.850599497668153, - 7.850599497668153, - 11.338074658858064, - 7.391072699891322, - 7.788713195225325, - 11.27058778605842, - 7.79011333781453, - 11.794521142938645, - 12.616404842801533, - 15.16382426959972, - 15.15094295777904, - 7.391072699891322, - 11.27058778605842, - 7.788713195225325, - 7.79011333781453, - 11.794521142938645, - 15.16382426959972, - 12.616404842801533, - 15.15094295777904, - 11.79256094331376, - 15.167464640331652, - 15.167464640331652, - 12.630686297211415, - 16.073076867028952, - 18.92264706457741, - 18.92264706457741, - 18.897444497971733, - 9.332790442599759, - 9.330830242974871, - 9.331110271492713, - 6.140465339214099, - 8.700486049315124, - 13.444729198574759, - 13.444449170056918, - 10.512270559745406, - 13.430167715647034, - 8.683964366762513, - 13.43548825748601, - 10.482027479818596, - 14.28453472357946, - 14.276693925079915, - 20.245501782857577, - 17.524184646480222, - 13.430167715647034, - 13.435768286003851, - 8.684244395280356, - 10.481467422782913, - 14.28453472357946, - 20.245501782857577, - 14.276693925079915, - 17.524464674998065, - 20.241861412125644, - 14.28453472357946, - 14.28453472357946, - 17.535665815711695, - 22.479009241156174, - 22.56049753984786, - 22.56105759688354, - 27.245934700360916 + 2.828848087228239, + 2.8008452354441546, + 2.8008452354441546, + 2.8008452354441546, + 9.641941926296054, + 10.086627212627318, + 10.086627212627318, + 7.921726741199729, + 9.642221954813893, + 10.086627212627318, + 7.921726741199729, + 10.086627212627318, + 14.239730160724923, + 15.156543528135858, + 12.280650649910356, + 12.280650649910356, + 9.641941926296054, + 7.921726741199729, + 10.086627212627318, + 10.086627212627318, + 14.239730160724923, + 12.280650649910356, + 15.156543528135858, + 12.280650649910356, + 14.239730160724923, + 12.280650649910356, + 12.280650649910356, + 15.156543528135858, + 16.62165273347917, + 14.4239889254642, + 14.4239889254642, + 14.4239889254642, + 7.7332675486928375, + 7.7332675486928375, + 7.7332675486928375, + 6.848937489351441, + 10.323811367238514, + 11.377278651355782, + 11.377558679873625, + 8.873823701858608, + 11.377558679873625, + 10.323531338720676, + 11.377558679873625, + 8.873823701858608, + 11.940135972215886, + 11.939855943698046, + 15.62363109589439, + 11.500491199205756, + 11.377278651355782, + 11.377278651355782, + 10.324091395756357, + 8.873823701858608, + 11.940416000733727, + 15.623071038858708, + 11.940135972215886, + 11.500491199205756, + 15.62335106737655, + 11.939855943698046, + 11.940416000733727, + 11.500491199205756, + 14.157961833515396, + 14.157961833515396, + 14.158241862033238, + 14.728939981392884 ] ], "self-Hartree": [ @@ -34195,7 +34195,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -34476,5 +34476,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_32-dft_n-1.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_32-dft_n-1.json index 62991d9e9..20e4bd7da 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_32-dft_n-1.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_32-dft_n-1.json @@ -5127,7 +5127,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -5408,5 +5408,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1.json index 6156999a3..996f81cdc 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1.json @@ -5250,7 +5250,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -5533,5 +5533,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1_dummy.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1_dummy.json index 8828ff8ac..9aed2e264 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1_dummy.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1_dummy.json @@ -5050,7 +5050,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -5333,5 +5333,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-pz_print.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-pz_print.json index 5f42326de..4b28ce1ff 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-pz_print.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-pz_print.json @@ -443,781 +443,781 @@ "centres": [ [ [ - 1.3758607417192075, - 1.3758607417192075, - 1.3758607417192075 + -0.756723407945564, + -0.756723407945564, + -0.756723407945564 ], [ - 1.3758607417192075, - 1.1218556817095076, - 1.1218556817095076 + -0.756723407945564, + -0.9842696075375869, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.3758607417192075, - 1.1218556817095076 + -0.9842696075375869, + -0.756723407945564, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.1218556817095076, - 1.3758607417192075 + -0.9842696075375869, + -0.9842696075375869, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.46038417126758097, - 1.3758607417192075 + 0.6032620175230371, + 0.6032620175230371, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.7143892312772808, - 1.1218556817095076 + 0.6032620175230371, + 0.37571581793101433, + -0.9842696075375869 ], [ - -0.7143892312772808, - -0.46038417126758097, - 1.1218556817095076 + 0.37571581793101433, + 0.6032620175230371, + -0.9842696075375869 ], [ - 0.11112721375424367, - 0.11112721375424367, - 1.3758607417192075 + 0.550344296687683, + 0.550344296687683, + -0.756723407945564 ], [ - -0.47096771543465177, - 1.3758607417192075, - -0.47096771543465177 + 0.6032620175230371, + -0.756723407945564, + 0.6032620175230371 ], [ - -0.47096771543465177, - 1.1218556817095076, - -0.7249727754443517 + 0.6032620175230371, + -0.9842696075375869, + 0.37571581793101433 ], [ - 0.08996012542010202, - 1.3758607417192075, - 0.08996012542010202 + 0.550344296687683, + -0.756723407945564, + 0.550344296687683 ], [ - -0.7249727754443517, - 1.1218556817095076, - -0.47096771543465177 + 0.37571581793101433, + -0.9842696075375869, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.45509239918404554, - -0.46038417126758097 + 1.9632474429916382, + 0.6032620175230371, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.7090974591937454, - -0.7090974591937454 + 1.9632474429916382, + 0.37571581793101433, + 0.37571581793101433 ], [ - -1.6986588388148676, - -0.4498006271005101, - 0.13229430208838533 + 1.910329722156284, + 0.6032620175230371, + 0.550344296687683 ], [ - -1.6986588388148676, - 0.13229430208838533, - -0.45509239918404554 + 1.910329722156284, + 0.550344296687683, + 0.6032620175230371 ], [ - 1.3758607417192075, - -0.47096771543465177, - -0.47096771543465177 + -0.756723407945564, + 0.6032620175230371, + 0.6032620175230371 ], [ - 1.3758607417192075, - 0.08996012542010202, - 0.08996012542010202 + -0.756723407945564, + 0.550344296687683, + 0.550344296687683 ], [ - 1.1218556817095076, - -0.47096771543465177, - -0.7249727754443517 + -0.9842696075375869, + 0.6032620175230371, + 0.37571581793101433 ], [ - 1.1218556817095076, - -0.7249727754443517, - -0.47096771543465177 + -0.9842696075375869, + 0.37571581793101433, + 0.6032620175230371 ], [ - -0.45509239918404554, - -2.2860455400872985, - -0.46038417126758097 + 0.6032620175230371, + 1.9632474429916382, + 0.6032620175230371 ], [ - -0.4498006271005101, - -1.6986588388148676, - 0.13229430208838533 + 0.6032620175230371, + 1.910329722156284, + 0.550344296687683 ], [ - -0.7090974591937454, - -2.2860455400872985, - -0.7090974591937454 + 0.37571581793101433, + 1.9632474429916382, + 0.37571581793101433 ], [ - 0.13229430208838533, - -1.6986588388148676, - -0.45509239918404554 + 0.550344296687683, + 1.910329722156284, + 0.6032620175230371 ], [ - -0.46038417126758097, - -0.46038417126758097, - -2.291337312170834 + 0.6032620175230371, + 0.6032620175230371, + 1.9632474429916382 ], [ - -0.45509239918404554, - 0.13229430208838533, - -1.6986588388148676 + 0.6032620175230371, + 0.550344296687683, + 1.910329722156284 ], [ - 0.13229430208838533, - -0.45509239918404554, - -1.6986588388148676 + 0.550344296687683, + 0.6032620175230371, + 1.910329722156284 ], [ - -0.7090974591937454, - -0.7090974591937454, - -2.2860455400872985 + 0.37571581793101433, + 0.37571581793101433, + 1.9632474429916382 ], [ - -2.3125044005049755, - -2.3125044005049755, - -2.3125044005049755 + 1.9632474429916382, + 1.9632474429916382, + 1.9632474429916382 ], [ - -2.3125044005049755, - -1.7515765596502217, - -1.756868331733757 + 1.9632474429916382, + 1.910329722156284, + 1.910329722156284 ], [ - -1.7515765596502217, - -2.3125044005049755, - -1.756868331733757 + 1.910329722156284, + 1.9632474429916382, + 1.910329722156284 ], [ - -1.73040947131608, - -1.73040947131608, - -2.317796172588511 + 1.910329722156284, + 1.910329722156284, + 1.9632474429916382 ], [ - 0.4498006271005101, - 0.4498006271005101, - 0.5397607525206122 + -0.5080101200193996, + -0.5080101200193996, + -1.2700253000484991 ], [ - 0.4498006271005101, - 0.5397607525206122, - 0.4498006271005101 + -0.5080101200193996, + -1.2700253000484991, + -0.5080101200193996 ], [ - 0.5397607525206122, - 0.4498006271005101, - 0.4498006271005101 + -1.2700253000484991, + -0.5080101200193996, + -0.5080101200193996 ], [ - 0.5397607525206122, - 0.5397607525206122, - 0.5397607525206122 + -1.2700253000484991, + -1.2700253000484991, + -1.2700253000484991 ], [ - 0.2751721483438415, - 0.2751721483438415, - 0.5397607525206122 + -0.33867341334626644, + -0.33867341334626644, + -1.2700253000484991 ], [ - -0.2063791112578811, - -0.10583544167070827, - 0.4339253108499039 + 1.1800651746283972, + 0.4127582225157622, + -0.5080101200193996 ], [ - -0.10583544167070827, - -0.2063791112578811, - 0.4339253108499039 + 0.4127582225157622, + 1.1800651746283972, + -0.5080101200193996 ], [ - -0.10583544167070827, - -0.10583544167070827, - 0.5397607525206122 + 0.4127582225157622, + 0.4127582225157622, + -1.2700253000484991 ], [ - -0.21167088334141654, - 0.43921708293343925, - -0.11641898583777908 + 1.1800651746283972, + -0.5080101200193996, + 0.4127582225157622 ], [ - 0.2698803762603061, - 0.5397607525206122, - 0.26458860417677066 + -0.33867341334626644, + -1.2700253000484991, + -0.33867341334626644 ], [ - -0.11641898583777908, - 0.4339253108499039, - -0.21696265542495194 + 0.4127582225157622, + -0.5080101200193996, + 1.1800651746283972 ], [ - -0.10583544167070827, - 0.5397607525206122, - -0.10583544167070827 + 0.4127582225157622, + -1.2700253000484991, + 0.4127582225157622 ], [ - -0.3545487295968727, - 0.2751721483438415, - -0.09525189750363744 + 1.344110109217995, + -0.33867341334626644, + 0.4127582225157622 ], [ - -0.3598405016804081, - -0.10054366958717285, - 0.2804639204273769 + 1.344110109217995, + 0.4127582225157622, + -0.33867341334626644 ], [ - -0.756723407945564, - -0.21167088334141654, - -0.21167088334141654 + 2.0955417450800238, + 1.1800651746283972, + 1.1800651746283972 ], [ - -0.756723407945564, - -0.10583544167070827, - -0.11112721375424367 + 2.0955417450800238, + 0.4127582225157622, + 0.4127582225157622 ], [ - 0.43921708293343925, - -0.21167088334141654, - -0.11641898583777908 + -0.5080101200193996, + 1.1800651746283972, + 0.4127582225157622 ], [ - 0.4339253108499039, - -0.11641898583777908, - -0.21696265542495194 + -0.5080101200193996, + 0.4127582225157622, + 1.1800651746283972 ], [ - 0.5397607525206122, - 0.2698803762603061, - 0.26458860417677066 + -1.2700253000484991, + -0.33867341334626644, + -0.33867341334626644 ], [ - 0.5397607525206122, - -0.10583544167070827, - -0.10583544167070827 + -1.2700253000484991, + 0.4127582225157622, + 0.4127582225157622 ], [ - 0.2751721483438415, - -0.3545487295968727, - -0.09525189750363744 + -0.33867341334626644, + 1.344110109217995, + 0.4127582225157622 ], [ - -0.21167088334141654, - -0.756723407945564, - -0.21167088334141654 + 1.1800651746283972, + 2.0955417450800238, + 1.1800651746283972 ], [ - -0.10054366958717285, - -0.3598405016804081, - 0.2804639204273769 + 0.4127582225157622, + 1.344110109217995, + -0.33867341334626644 ], [ - -0.10583544167070827, - -0.756723407945564, - -0.11112721375424367 + 0.4127582225157622, + 2.0955417450800238, + 0.4127582225157622 ], [ - -0.21167088334141654, - -0.21167088334141654, - -0.7620151800290995 + 1.1800651746283972, + 1.1800651746283972, + 2.0955417450800238 ], [ - 0.2804639204273769, - -0.09525189750363744, - -0.3545487295968727 + -0.33867341334626644, + 0.4127582225157622, + 1.344110109217995 ], [ - -0.09525189750363744, - 0.2804639204273769, - -0.3545487295968727 + 0.4127582225157622, + -0.33867341334626644, + 1.344110109217995 ], [ - -0.11112721375424367, - -0.11112721375424367, - -0.7620151800290995 + 0.4127582225157622, + 0.4127582225157622, + 2.0955417450800238 ], [ - -0.38100759001454976, - -0.38100759001454976, - -0.7778904962797057 + 1.344110109217995, + 1.344110109217995, + 2.0955417450800238 ], [ - -0.38100759001454976, - -0.7673069521126349, - -0.39159113418162056 + 1.344110109217995, + 2.0955417450800238, + 1.344110109217995 ], [ - -0.7673069521126349, - -0.38100759001454976, - -0.39159113418162056 + 2.0955417450800238, + 1.344110109217995, + 1.344110109217995 ], [ - -0.7620151800290995, - -0.7620151800290995, - -0.7831822683632411 + 2.0955417450800238, + 2.0955417450800238, + 2.0955417450800238 ] ], [ [ - 1.3758607417192075, - 1.3758607417192075, - 1.3758607417192075 + -0.756723407945564, + -0.756723407945564, + -0.756723407945564 ], [ - 1.3758607417192075, - 1.1218556817095076, - 1.1218556817095076 + -0.756723407945564, + -0.9842696075375869, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.3758607417192075, - 1.1218556817095076 + -0.9842696075375869, + -0.756723407945564, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.1218556817095076, - 1.3758607417192075 + -0.9842696075375869, + -0.9842696075375869, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.46038417126758097, - 1.3758607417192075 + 0.6032620175230371, + 0.6032620175230371, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.7143892312772808, - 1.1218556817095076 + 0.6032620175230371, + 0.37571581793101433, + -0.9842696075375869 ], [ - -0.7143892312772808, - -0.46038417126758097, - 1.1218556817095076 + 0.37571581793101433, + 0.6032620175230371, + -0.9842696075375869 ], [ - 0.11112721375424367, - 0.11112721375424367, - 1.3758607417192075 + 0.550344296687683, + 0.550344296687683, + -0.756723407945564 ], [ - -0.47096771543465177, - 1.3758607417192075, - -0.47096771543465177 + 0.6032620175230371, + -0.756723407945564, + 0.6032620175230371 ], [ - -0.47096771543465177, - 1.1218556817095076, - -0.7249727754443517 + 0.6032620175230371, + -0.9842696075375869, + 0.37571581793101433 ], [ - 0.08996012542010202, - 1.3758607417192075, - 0.08996012542010202 + 0.550344296687683, + -0.756723407945564, + 0.550344296687683 ], [ - -0.7249727754443517, - 1.1218556817095076, - -0.47096771543465177 + 0.37571581793101433, + -0.9842696075375869, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.45509239918404554, - -0.46038417126758097 + 1.9632474429916382, + 0.6032620175230371, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.7090974591937454, - -0.7090974591937454 + 1.9632474429916382, + 0.37571581793101433, + 0.37571581793101433 ], [ - -1.6986588388148676, - -0.4498006271005101, - 0.13229430208838533 + 1.910329722156284, + 0.6032620175230371, + 0.550344296687683 ], [ - -1.6986588388148676, - 0.13229430208838533, - -0.45509239918404554 + 1.910329722156284, + 0.550344296687683, + 0.6032620175230371 ], [ - 1.3758607417192075, - -0.47096771543465177, - -0.47096771543465177 + -0.756723407945564, + 0.6032620175230371, + 0.6032620175230371 ], [ - 1.3758607417192075, - 0.08996012542010202, - 0.08996012542010202 + -0.756723407945564, + 0.550344296687683, + 0.550344296687683 ], [ - 1.1218556817095076, - -0.47096771543465177, - -0.7249727754443517 + -0.9842696075375869, + 0.6032620175230371, + 0.37571581793101433 ], [ - 1.1218556817095076, - -0.7249727754443517, - -0.47096771543465177 + -0.9842696075375869, + 0.37571581793101433, + 0.6032620175230371 ], [ - -0.45509239918404554, - -2.2860455400872985, - -0.46038417126758097 + 0.6032620175230371, + 1.9632474429916382, + 0.6032620175230371 ], [ - -0.4498006271005101, - -1.6986588388148676, - 0.13229430208838533 + 0.6032620175230371, + 1.910329722156284, + 0.550344296687683 ], [ - -0.7090974591937454, - -2.2860455400872985, - -0.7090974591937454 + 0.37571581793101433, + 1.9632474429916382, + 0.37571581793101433 ], [ - 0.13229430208838533, - -1.6986588388148676, - -0.45509239918404554 + 0.550344296687683, + 1.910329722156284, + 0.6032620175230371 ], [ - -0.46038417126758097, - -0.46038417126758097, - -2.291337312170834 + 0.6032620175230371, + 0.6032620175230371, + 1.9632474429916382 ], [ - -0.45509239918404554, - 0.13229430208838533, - -1.6986588388148676 + 0.6032620175230371, + 0.550344296687683, + 1.910329722156284 ], [ - 0.13229430208838533, - -0.45509239918404554, - -1.6986588388148676 + 0.550344296687683, + 0.6032620175230371, + 1.910329722156284 ], [ - -0.7090974591937454, - -0.7090974591937454, - -2.2860455400872985 + 0.37571581793101433, + 0.37571581793101433, + 1.9632474429916382 ], [ - -2.3125044005049755, - -2.3125044005049755, - -2.3125044005049755 + 1.9632474429916382, + 1.9632474429916382, + 1.9632474429916382 ], [ - -2.3125044005049755, - -1.7515765596502217, - -1.756868331733757 + 1.9632474429916382, + 1.910329722156284, + 1.910329722156284 ], [ - -1.7515765596502217, - -2.3125044005049755, - -1.756868331733757 + 1.910329722156284, + 1.9632474429916382, + 1.910329722156284 ], [ - -1.73040947131608, - -1.73040947131608, - -2.317796172588511 + 1.910329722156284, + 1.910329722156284, + 1.9632474429916382 ], [ - 0.4498006271005101, - 0.4498006271005101, - 0.5397607525206122 + -0.5080101200193996, + -0.5080101200193996, + -1.2700253000484991 ], [ - 0.4498006271005101, - 0.5397607525206122, - 0.4498006271005101 + -0.5080101200193996, + -1.2700253000484991, + -0.5080101200193996 ], [ - 0.5397607525206122, - 0.4498006271005101, - 0.4498006271005101 + -1.2700253000484991, + -0.5080101200193996, + -0.5080101200193996 ], [ - 0.5397607525206122, - 0.5397607525206122, - 0.5397607525206122 + -1.2700253000484991, + -1.2700253000484991, + -1.2700253000484991 ], [ - 0.2751721483438415, - 0.2751721483438415, - 0.5397607525206122 + -0.33867341334626644, + -0.33867341334626644, + -1.2700253000484991 ], [ - -0.2063791112578811, - -0.10583544167070827, - 0.4339253108499039 + 1.1800651746283972, + 0.4127582225157622, + -0.5080101200193996 ], [ - -0.10583544167070827, - -0.2063791112578811, - 0.4339253108499039 + 0.4127582225157622, + 1.1800651746283972, + -0.5080101200193996 ], [ - -0.10583544167070827, - -0.10583544167070827, - 0.5397607525206122 + 0.4127582225157622, + 0.4127582225157622, + -1.2700253000484991 ], [ - -0.21167088334141654, - 0.43921708293343925, - -0.11641898583777908 + 1.1800651746283972, + -0.5080101200193996, + 0.4127582225157622 ], [ - 0.2698803762603061, - 0.5397607525206122, - 0.26458860417677066 + -0.33867341334626644, + -1.2700253000484991, + -0.33867341334626644 ], [ - -0.11641898583777908, - 0.4339253108499039, - -0.21696265542495194 + 0.4127582225157622, + -0.5080101200193996, + 1.1800651746283972 ], [ - -0.10583544167070827, - 0.5397607525206122, - -0.10583544167070827 + 0.4127582225157622, + -1.2700253000484991, + 0.4127582225157622 ], [ - -0.3545487295968727, - 0.2751721483438415, - -0.09525189750363744 + 1.344110109217995, + -0.33867341334626644, + 0.4127582225157622 ], [ - -0.3598405016804081, - -0.10054366958717285, - 0.2804639204273769 + 1.344110109217995, + 0.4127582225157622, + -0.33867341334626644 ], [ - -0.756723407945564, - -0.21167088334141654, - -0.21167088334141654 + 2.0955417450800238, + 1.1800651746283972, + 1.1800651746283972 ], [ - -0.756723407945564, - -0.10583544167070827, - -0.11112721375424367 + 2.0955417450800238, + 0.4127582225157622, + 0.4127582225157622 ], [ - 0.43921708293343925, - -0.21167088334141654, - -0.11641898583777908 + -0.5080101200193996, + 1.1800651746283972, + 0.4127582225157622 ], [ - 0.4339253108499039, - -0.11641898583777908, - -0.21696265542495194 + -0.5080101200193996, + 0.4127582225157622, + 1.1800651746283972 ], [ - 0.5397607525206122, - 0.2698803762603061, - 0.26458860417677066 + -1.2700253000484991, + -0.33867341334626644, + -0.33867341334626644 ], [ - 0.5397607525206122, - -0.10583544167070827, - -0.10583544167070827 + -1.2700253000484991, + 0.4127582225157622, + 0.4127582225157622 ], [ - 0.2751721483438415, - -0.3545487295968727, - -0.09525189750363744 + -0.33867341334626644, + 1.344110109217995, + 0.4127582225157622 ], [ - -0.21167088334141654, - -0.756723407945564, - -0.21167088334141654 + 1.1800651746283972, + 2.0955417450800238, + 1.1800651746283972 ], [ - -0.10054366958717285, - -0.3598405016804081, - 0.2804639204273769 + 0.4127582225157622, + 1.344110109217995, + -0.33867341334626644 ], [ - -0.10583544167070827, - -0.756723407945564, - -0.11112721375424367 + 0.4127582225157622, + 2.0955417450800238, + 0.4127582225157622 ], [ - -0.21167088334141654, - -0.21167088334141654, - -0.7620151800290995 + 1.1800651746283972, + 1.1800651746283972, + 2.0955417450800238 ], [ - 0.2804639204273769, - -0.09525189750363744, - -0.3545487295968727 + -0.33867341334626644, + 0.4127582225157622, + 1.344110109217995 ], [ - -0.09525189750363744, - 0.2804639204273769, - -0.3545487295968727 + 0.4127582225157622, + -0.33867341334626644, + 1.344110109217995 ], [ - -0.11112721375424367, - -0.11112721375424367, - -0.7620151800290995 + 0.4127582225157622, + 0.4127582225157622, + 2.0955417450800238 ], [ - -0.38100759001454976, - -0.38100759001454976, - -0.7778904962797057 + 1.344110109217995, + 1.344110109217995, + 2.0955417450800238 ], [ - -0.38100759001454976, - -0.7673069521126349, - -0.39159113418162056 + 1.344110109217995, + 2.0955417450800238, + 1.344110109217995 ], [ - -0.7673069521126349, - -0.38100759001454976, - -0.39159113418162056 + 2.0955417450800238, + 1.344110109217995, + 1.344110109217995 ], [ - -0.7620151800290995, - -0.7620151800290995, - -0.7831822683632411 + 2.0955417450800238, + 2.0955417450800238, + 2.0955417450800238 ] ] ], "spreads": [ [ - 3.1895248182072504, - 3.188124675618046, - 3.188124675618046, - 3.1884047041358867, - 7.452118916780627, - 7.850599497668153, - 7.850599497668153, - 11.338074658858064, - 7.391072699891322, - 7.788713195225325, - 11.27058778605842, - 7.79011333781453, - 11.794521142938645, - 12.616404842801533, - 15.16382426959972, - 15.15094295777904, - 7.391072699891322, - 11.27058778605842, - 7.788713195225325, - 7.79011333781453, - 11.794521142938645, - 15.16382426959972, - 12.616404842801533, - 15.15094295777904, - 11.79256094331376, - 15.167464640331652, - 15.167464640331652, - 12.630686297211415, - 16.073076867028952, - 18.92264706457741, - 18.92264706457741, - 18.897444497971733, - 9.332790442599759, - 9.330830242974871, - 9.331110271492713, - 6.140465339214099, - 8.700486049315124, - 13.444729198574759, - 13.444449170056918, - 10.512270559745406, - 13.430167715647034, - 8.683964366762513, - 13.43548825748601, - 10.482027479818596, - 14.28453472357946, - 14.276693925079915, - 20.245501782857577, - 17.524184646480222, - 13.430167715647034, - 13.435768286003851, - 8.684244395280356, - 10.481467422782913, - 14.28453472357946, - 20.245501782857577, - 14.276693925079915, - 17.524464674998065, - 20.241861412125644, - 14.28453472357946, - 14.28453472357946, - 17.535665815711695, - 22.479009241156174, - 22.56049753984786, - 22.56105759688354, - 27.245934700360916 + 2.828848087228239, + 2.8008452354441546, + 2.8008452354441546, + 2.8008452354441546, + 9.641941926296054, + 10.086627212627318, + 10.086627212627318, + 7.921726741199729, + 9.642221954813893, + 10.086627212627318, + 7.921726741199729, + 10.086627212627318, + 14.239730160724923, + 15.156543528135858, + 12.280650649910356, + 12.280650649910356, + 9.641941926296054, + 7.921726741199729, + 10.086627212627318, + 10.086627212627318, + 14.239730160724923, + 12.280650649910356, + 15.156543528135858, + 12.280650649910356, + 14.239730160724923, + 12.280650649910356, + 12.280650649910356, + 15.156543528135858, + 16.62165273347917, + 14.4239889254642, + 14.4239889254642, + 14.4239889254642, + 7.7332675486928375, + 7.7332675486928375, + 7.7332675486928375, + 6.848937489351441, + 10.323811367238514, + 11.377278651355782, + 11.377558679873625, + 8.873823701858608, + 11.377558679873625, + 10.323531338720676, + 11.377558679873625, + 8.873823701858608, + 11.940135972215886, + 11.939855943698046, + 15.62363109589439, + 11.500491199205756, + 11.377278651355782, + 11.377278651355782, + 10.324091395756357, + 8.873823701858608, + 11.940416000733727, + 15.623071038858708, + 11.940135972215886, + 11.500491199205756, + 15.62335106737655, + 11.939855943698046, + 11.940416000733727, + 11.500491199205756, + 14.157961833515396, + 14.157961833515396, + 14.158241862033238, + 14.728939981392884 ], [ - 3.1895248182072504, - 3.188124675618046, - 3.188124675618046, - 3.1884047041358867, - 7.452118916780627, - 7.850599497668153, - 7.850599497668153, - 11.338074658858064, - 7.391072699891322, - 7.788713195225325, - 11.27058778605842, - 7.79011333781453, - 11.794521142938645, - 12.616404842801533, - 15.16382426959972, - 15.15094295777904, - 7.391072699891322, - 11.27058778605842, - 7.788713195225325, - 7.79011333781453, - 11.794521142938645, - 15.16382426959972, - 12.616404842801533, - 15.15094295777904, - 11.79256094331376, - 15.167464640331652, - 15.167464640331652, - 12.630686297211415, - 16.073076867028952, - 18.92264706457741, - 18.92264706457741, - 18.897444497971733, - 9.332790442599759, - 9.330830242974871, - 9.331110271492713, - 6.140465339214099, - 8.700486049315124, - 13.444729198574759, - 13.444449170056918, - 10.512270559745406, - 13.430167715647034, - 8.683964366762513, - 13.43548825748601, - 10.482027479818596, - 14.28453472357946, - 14.276693925079915, - 20.245501782857577, - 17.524184646480222, - 13.430167715647034, - 13.435768286003851, - 8.684244395280356, - 10.481467422782913, - 14.28453472357946, - 20.245501782857577, - 14.276693925079915, - 17.524464674998065, - 20.241861412125644, - 14.28453472357946, - 14.28453472357946, - 17.535665815711695, - 22.479009241156174, - 22.56049753984786, - 22.56105759688354, - 27.245934700360916 + 2.828848087228239, + 2.8008452354441546, + 2.8008452354441546, + 2.8008452354441546, + 9.641941926296054, + 10.086627212627318, + 10.086627212627318, + 7.921726741199729, + 9.642221954813893, + 10.086627212627318, + 7.921726741199729, + 10.086627212627318, + 14.239730160724923, + 15.156543528135858, + 12.280650649910356, + 12.280650649910356, + 9.641941926296054, + 7.921726741199729, + 10.086627212627318, + 10.086627212627318, + 14.239730160724923, + 12.280650649910356, + 15.156543528135858, + 12.280650649910356, + 14.239730160724923, + 12.280650649910356, + 12.280650649910356, + 15.156543528135858, + 16.62165273347917, + 14.4239889254642, + 14.4239889254642, + 14.4239889254642, + 7.7332675486928375, + 7.7332675486928375, + 7.7332675486928375, + 6.848937489351441, + 10.323811367238514, + 11.377278651355782, + 11.377558679873625, + 8.873823701858608, + 11.377558679873625, + 10.323531338720676, + 11.377558679873625, + 8.873823701858608, + 11.940135972215886, + 11.939855943698046, + 15.62363109589439, + 11.500491199205756, + 11.377278651355782, + 11.377278651355782, + 10.324091395756357, + 8.873823701858608, + 11.940416000733727, + 15.623071038858708, + 11.940135972215886, + 11.500491199205756, + 15.62335106737655, + 11.939855943698046, + 11.940416000733727, + 11.500491199205756, + 14.157961833515396, + 14.157961833515396, + 14.158241862033238, + 14.728939981392884 ] ], "self-Hartree": [ @@ -34197,7 +34197,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -34478,5 +34478,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-final-ki_final.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-final-ki_final.json index 863bfffb1..2cd1bfd6a 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-final-ki_final.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-final-ki_final.json @@ -441,781 +441,781 @@ "centres": [ [ [ - 1.3758607417192075, - 1.3758607417192075, - 1.3758607417192075 + -0.756723407945564, + -0.756723407945564, + -0.756723407945564 ], [ - 1.3758607417192075, - 1.1218556817095076, - 1.1218556817095076 + -0.756723407945564, + -0.9842696075375869, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.3758607417192075, - 1.1218556817095076 + -0.9842696075375869, + -0.756723407945564, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.1218556817095076, - 1.3758607417192075 + -0.9842696075375869, + -0.9842696075375869, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.46038417126758097, - 1.3758607417192075 + 0.6032620175230371, + 0.6032620175230371, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.7143892312772808, - 1.1218556817095076 + 0.6032620175230371, + 0.37571581793101433, + -0.9842696075375869 ], [ - -0.7143892312772808, - -0.46038417126758097, - 1.1218556817095076 + 0.37571581793101433, + 0.6032620175230371, + -0.9842696075375869 ], [ - 0.11112721375424367, - 0.11112721375424367, - 1.3758607417192075 + 0.550344296687683, + 0.550344296687683, + -0.756723407945564 ], [ - -0.47096771543465177, - 1.3758607417192075, - -0.47096771543465177 + 0.6032620175230371, + -0.756723407945564, + 0.6032620175230371 ], [ - -0.47096771543465177, - 1.1218556817095076, - -0.7249727754443517 + 0.6032620175230371, + -0.9842696075375869, + 0.37571581793101433 ], [ - 0.08996012542010202, - 1.3758607417192075, - 0.08996012542010202 + 0.550344296687683, + -0.756723407945564, + 0.550344296687683 ], [ - -0.7249727754443517, - 1.1218556817095076, - -0.47096771543465177 + 0.37571581793101433, + -0.9842696075375869, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.45509239918404554, - -0.46038417126758097 + 1.9632474429916382, + 0.6032620175230371, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.7090974591937454, - -0.7090974591937454 + 1.9632474429916382, + 0.37571581793101433, + 0.37571581793101433 ], [ - -1.6986588388148676, - -0.4498006271005101, - 0.13229430208838533 + 1.910329722156284, + 0.6032620175230371, + 0.550344296687683 ], [ - -1.6986588388148676, - 0.13229430208838533, - -0.45509239918404554 + 1.910329722156284, + 0.550344296687683, + 0.6032620175230371 ], [ - 1.3758607417192075, - -0.47096771543465177, - -0.47096771543465177 + -0.756723407945564, + 0.6032620175230371, + 0.6032620175230371 ], [ - 1.3758607417192075, - 0.08996012542010202, - 0.08996012542010202 + -0.756723407945564, + 0.550344296687683, + 0.550344296687683 ], [ - 1.1218556817095076, - -0.47096771543465177, - -0.7249727754443517 + -0.9842696075375869, + 0.6032620175230371, + 0.37571581793101433 ], [ - 1.1218556817095076, - -0.7249727754443517, - -0.47096771543465177 + -0.9842696075375869, + 0.37571581793101433, + 0.6032620175230371 ], [ - -0.45509239918404554, - -2.2860455400872985, - -0.46038417126758097 + 0.6032620175230371, + 1.9632474429916382, + 0.6032620175230371 ], [ - -0.4498006271005101, - -1.6986588388148676, - 0.13229430208838533 + 0.6032620175230371, + 1.910329722156284, + 0.550344296687683 ], [ - -0.7090974591937454, - -2.2860455400872985, - -0.7090974591937454 + 0.37571581793101433, + 1.9632474429916382, + 0.37571581793101433 ], [ - 0.13229430208838533, - -1.6986588388148676, - -0.45509239918404554 + 0.550344296687683, + 1.910329722156284, + 0.6032620175230371 ], [ - -0.46038417126758097, - -0.46038417126758097, - -2.291337312170834 + 0.6032620175230371, + 0.6032620175230371, + 1.9632474429916382 ], [ - -0.45509239918404554, - 0.13229430208838533, - -1.6986588388148676 + 0.6032620175230371, + 0.550344296687683, + 1.910329722156284 ], [ - 0.13229430208838533, - -0.45509239918404554, - -1.6986588388148676 + 0.550344296687683, + 0.6032620175230371, + 1.910329722156284 ], [ - -0.7090974591937454, - -0.7090974591937454, - -2.2860455400872985 + 0.37571581793101433, + 0.37571581793101433, + 1.9632474429916382 ], [ - -2.3125044005049755, - -2.3125044005049755, - -2.3125044005049755 + 1.9632474429916382, + 1.9632474429916382, + 1.9632474429916382 ], [ - -2.3125044005049755, - -1.7515765596502217, - -1.756868331733757 + 1.9632474429916382, + 1.910329722156284, + 1.910329722156284 ], [ - -1.7515765596502217, - -2.3125044005049755, - -1.756868331733757 + 1.910329722156284, + 1.9632474429916382, + 1.910329722156284 ], [ - -1.73040947131608, - -1.73040947131608, - -2.317796172588511 + 1.910329722156284, + 1.910329722156284, + 1.9632474429916382 ], [ - 0.4498006271005101, - 0.4498006271005101, - 0.5397607525206122 + -0.5080101200193996, + -0.5080101200193996, + -1.2700253000484991 ], [ - 0.4498006271005101, - 0.5397607525206122, - 0.4498006271005101 + -0.5080101200193996, + -1.2700253000484991, + -0.5080101200193996 ], [ - 0.5397607525206122, - 0.4498006271005101, - 0.4498006271005101 + -1.2700253000484991, + -0.5080101200193996, + -0.5080101200193996 ], [ - 0.5397607525206122, - 0.5397607525206122, - 0.5397607525206122 + -1.2700253000484991, + -1.2700253000484991, + -1.2700253000484991 ], [ - 0.2751721483438415, - 0.2751721483438415, - 0.5397607525206122 + -0.33867341334626644, + -0.33867341334626644, + -1.2700253000484991 ], [ - -0.2063791112578811, - -0.10583544167070827, - 0.4339253108499039 + 1.1800651746283972, + 0.4127582225157622, + -0.5080101200193996 ], [ - -0.10583544167070827, - -0.2063791112578811, - 0.4339253108499039 + 0.4127582225157622, + 1.1800651746283972, + -0.5080101200193996 ], [ - -0.10583544167070827, - -0.10583544167070827, - 0.5397607525206122 + 0.4127582225157622, + 0.4127582225157622, + -1.2700253000484991 ], [ - -0.21167088334141654, - 0.43921708293343925, - -0.11641898583777908 + 1.1800651746283972, + -0.5080101200193996, + 0.4127582225157622 ], [ - 0.2698803762603061, - 0.5397607525206122, - 0.26458860417677066 + -0.33867341334626644, + -1.2700253000484991, + -0.33867341334626644 ], [ - -0.11641898583777908, - 0.4339253108499039, - -0.21696265542495194 + 0.4127582225157622, + -0.5080101200193996, + 1.1800651746283972 ], [ - -0.10583544167070827, - 0.5397607525206122, - -0.10583544167070827 + 0.4127582225157622, + -1.2700253000484991, + 0.4127582225157622 ], [ - -0.3545487295968727, - 0.2751721483438415, - -0.09525189750363744 + 1.344110109217995, + -0.33867341334626644, + 0.4127582225157622 ], [ - -0.3598405016804081, - -0.10054366958717285, - 0.2804639204273769 + 1.344110109217995, + 0.4127582225157622, + -0.33867341334626644 ], [ - -0.756723407945564, - -0.21167088334141654, - -0.21167088334141654 + 2.0955417450800238, + 1.1800651746283972, + 1.1800651746283972 ], [ - -0.756723407945564, - -0.10583544167070827, - -0.11112721375424367 + 2.0955417450800238, + 0.4127582225157622, + 0.4127582225157622 ], [ - 0.43921708293343925, - -0.21167088334141654, - -0.11641898583777908 + -0.5080101200193996, + 1.1800651746283972, + 0.4127582225157622 ], [ - 0.4339253108499039, - -0.11641898583777908, - -0.21696265542495194 + -0.5080101200193996, + 0.4127582225157622, + 1.1800651746283972 ], [ - 0.5397607525206122, - 0.2698803762603061, - 0.26458860417677066 + -1.2700253000484991, + -0.33867341334626644, + -0.33867341334626644 ], [ - 0.5397607525206122, - -0.10583544167070827, - -0.10583544167070827 + -1.2700253000484991, + 0.4127582225157622, + 0.4127582225157622 ], [ - 0.2751721483438415, - -0.3545487295968727, - -0.09525189750363744 + -0.33867341334626644, + 1.344110109217995, + 0.4127582225157622 ], [ - -0.21167088334141654, - -0.756723407945564, - -0.21167088334141654 + 1.1800651746283972, + 2.0955417450800238, + 1.1800651746283972 ], [ - -0.10054366958717285, - -0.3598405016804081, - 0.2804639204273769 + 0.4127582225157622, + 1.344110109217995, + -0.33867341334626644 ], [ - -0.10583544167070827, - -0.756723407945564, - -0.11112721375424367 + 0.4127582225157622, + 2.0955417450800238, + 0.4127582225157622 ], [ - -0.21167088334141654, - -0.21167088334141654, - -0.7620151800290995 + 1.1800651746283972, + 1.1800651746283972, + 2.0955417450800238 ], [ - 0.2804639204273769, - -0.09525189750363744, - -0.3545487295968727 + -0.33867341334626644, + 0.4127582225157622, + 1.344110109217995 ], [ - -0.09525189750363744, - 0.2804639204273769, - -0.3545487295968727 + 0.4127582225157622, + -0.33867341334626644, + 1.344110109217995 ], [ - -0.11112721375424367, - -0.11112721375424367, - -0.7620151800290995 + 0.4127582225157622, + 0.4127582225157622, + 2.0955417450800238 ], [ - -0.38100759001454976, - -0.38100759001454976, - -0.7778904962797057 + 1.344110109217995, + 1.344110109217995, + 2.0955417450800238 ], [ - -0.38100759001454976, - -0.7673069521126349, - -0.39159113418162056 + 1.344110109217995, + 2.0955417450800238, + 1.344110109217995 ], [ - -0.7673069521126349, - -0.38100759001454976, - -0.39159113418162056 + 2.0955417450800238, + 1.344110109217995, + 1.344110109217995 ], [ - -0.7620151800290995, - -0.7620151800290995, - -0.7831822683632411 + 2.0955417450800238, + 2.0955417450800238, + 2.0955417450800238 ] ], [ [ - 1.3758607417192075, - 1.3758607417192075, - 1.3758607417192075 + -0.756723407945564, + -0.756723407945564, + -0.756723407945564 ], [ - 1.3758607417192075, - 1.1218556817095076, - 1.1218556817095076 + -0.756723407945564, + -0.9842696075375869, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.3758607417192075, - 1.1218556817095076 + -0.9842696075375869, + -0.756723407945564, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.1218556817095076, - 1.3758607417192075 + -0.9842696075375869, + -0.9842696075375869, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.46038417126758097, - 1.3758607417192075 + 0.6032620175230371, + 0.6032620175230371, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.7143892312772808, - 1.1218556817095076 + 0.6032620175230371, + 0.37571581793101433, + -0.9842696075375869 ], [ - -0.7143892312772808, - -0.46038417126758097, - 1.1218556817095076 + 0.37571581793101433, + 0.6032620175230371, + -0.9842696075375869 ], [ - 0.11112721375424367, - 0.11112721375424367, - 1.3758607417192075 + 0.550344296687683, + 0.550344296687683, + -0.756723407945564 ], [ - -0.47096771543465177, - 1.3758607417192075, - -0.47096771543465177 + 0.6032620175230371, + -0.756723407945564, + 0.6032620175230371 ], [ - -0.47096771543465177, - 1.1218556817095076, - -0.7249727754443517 + 0.6032620175230371, + -0.9842696075375869, + 0.37571581793101433 ], [ - 0.08996012542010202, - 1.3758607417192075, - 0.08996012542010202 + 0.550344296687683, + -0.756723407945564, + 0.550344296687683 ], [ - -0.7249727754443517, - 1.1218556817095076, - -0.47096771543465177 + 0.37571581793101433, + -0.9842696075375869, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.45509239918404554, - -0.46038417126758097 + 1.9632474429916382, + 0.6032620175230371, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.7090974591937454, - -0.7090974591937454 + 1.9632474429916382, + 0.37571581793101433, + 0.37571581793101433 ], [ - -1.6986588388148676, - -0.4498006271005101, - 0.13229430208838533 + 1.910329722156284, + 0.6032620175230371, + 0.550344296687683 ], [ - -1.6986588388148676, - 0.13229430208838533, - -0.45509239918404554 + 1.910329722156284, + 0.550344296687683, + 0.6032620175230371 ], [ - 1.3758607417192075, - -0.47096771543465177, - -0.47096771543465177 + -0.756723407945564, + 0.6032620175230371, + 0.6032620175230371 ], [ - 1.3758607417192075, - 0.08996012542010202, - 0.08996012542010202 + -0.756723407945564, + 0.550344296687683, + 0.550344296687683 ], [ - 1.1218556817095076, - -0.47096771543465177, - -0.7249727754443517 + -0.9842696075375869, + 0.6032620175230371, + 0.37571581793101433 ], [ - 1.1218556817095076, - -0.7249727754443517, - -0.47096771543465177 + -0.9842696075375869, + 0.37571581793101433, + 0.6032620175230371 ], [ - -0.45509239918404554, - -2.2860455400872985, - -0.46038417126758097 + 0.6032620175230371, + 1.9632474429916382, + 0.6032620175230371 ], [ - -0.4498006271005101, - -1.6986588388148676, - 0.13229430208838533 + 0.6032620175230371, + 1.910329722156284, + 0.550344296687683 ], [ - -0.7090974591937454, - -2.2860455400872985, - -0.7090974591937454 + 0.37571581793101433, + 1.9632474429916382, + 0.37571581793101433 ], [ - 0.13229430208838533, - -1.6986588388148676, - -0.45509239918404554 + 0.550344296687683, + 1.910329722156284, + 0.6032620175230371 ], [ - -0.46038417126758097, - -0.46038417126758097, - -2.291337312170834 + 0.6032620175230371, + 0.6032620175230371, + 1.9632474429916382 ], [ - -0.45509239918404554, - 0.13229430208838533, - -1.6986588388148676 + 0.6032620175230371, + 0.550344296687683, + 1.910329722156284 ], [ - 0.13229430208838533, - -0.45509239918404554, - -1.6986588388148676 + 0.550344296687683, + 0.6032620175230371, + 1.910329722156284 ], [ - -0.7090974591937454, - -0.7090974591937454, - -2.2860455400872985 + 0.37571581793101433, + 0.37571581793101433, + 1.9632474429916382 ], [ - -2.3125044005049755, - -2.3125044005049755, - -2.3125044005049755 + 1.9632474429916382, + 1.9632474429916382, + 1.9632474429916382 ], [ - -2.3125044005049755, - -1.7515765596502217, - -1.756868331733757 + 1.9632474429916382, + 1.910329722156284, + 1.910329722156284 ], [ - -1.7515765596502217, - -2.3125044005049755, - -1.756868331733757 + 1.910329722156284, + 1.9632474429916382, + 1.910329722156284 ], [ - -1.73040947131608, - -1.73040947131608, - -2.317796172588511 + 1.910329722156284, + 1.910329722156284, + 1.9632474429916382 ], [ - 0.4498006271005101, - 0.4498006271005101, - 0.5397607525206122 + -0.5080101200193996, + -0.5080101200193996, + -1.2700253000484991 ], [ - 0.4498006271005101, - 0.5397607525206122, - 0.4498006271005101 + -0.5080101200193996, + -1.2700253000484991, + -0.5080101200193996 ], [ - 0.5397607525206122, - 0.4498006271005101, - 0.4498006271005101 + -1.2700253000484991, + -0.5080101200193996, + -0.5080101200193996 ], [ - 0.5397607525206122, - 0.5397607525206122, - 0.5397607525206122 + -1.2700253000484991, + -1.2700253000484991, + -1.2700253000484991 ], [ - 0.2751721483438415, - 0.2751721483438415, - 0.5397607525206122 + -0.33867341334626644, + -0.33867341334626644, + -1.2700253000484991 ], [ - -0.2063791112578811, - -0.10583544167070827, - 0.4339253108499039 + 1.1800651746283972, + 0.4127582225157622, + -0.5080101200193996 ], [ - -0.10583544167070827, - -0.2063791112578811, - 0.4339253108499039 + 0.4127582225157622, + 1.1800651746283972, + -0.5080101200193996 ], [ - -0.10583544167070827, - -0.10583544167070827, - 0.5397607525206122 + 0.4127582225157622, + 0.4127582225157622, + -1.2700253000484991 ], [ - -0.21167088334141654, - 0.43921708293343925, - -0.11641898583777908 + 1.1800651746283972, + -0.5080101200193996, + 0.4127582225157622 ], [ - 0.2698803762603061, - 0.5397607525206122, - 0.26458860417677066 + -0.33867341334626644, + -1.2700253000484991, + -0.33867341334626644 ], [ - -0.11641898583777908, - 0.4339253108499039, - -0.21696265542495194 + 0.4127582225157622, + -0.5080101200193996, + 1.1800651746283972 ], [ - -0.10583544167070827, - 0.5397607525206122, - -0.10583544167070827 + 0.4127582225157622, + -1.2700253000484991, + 0.4127582225157622 ], [ - -0.3545487295968727, - 0.2751721483438415, - -0.09525189750363744 + 1.344110109217995, + -0.33867341334626644, + 0.4127582225157622 ], [ - -0.3598405016804081, - -0.10054366958717285, - 0.2804639204273769 + 1.344110109217995, + 0.4127582225157622, + -0.33867341334626644 ], [ - -0.756723407945564, - -0.21167088334141654, - -0.21167088334141654 + 2.0955417450800238, + 1.1800651746283972, + 1.1800651746283972 ], [ - -0.756723407945564, - -0.10583544167070827, - -0.11112721375424367 + 2.0955417450800238, + 0.4127582225157622, + 0.4127582225157622 ], [ - 0.43921708293343925, - -0.21167088334141654, - -0.11641898583777908 + -0.5080101200193996, + 1.1800651746283972, + 0.4127582225157622 ], [ - 0.4339253108499039, - -0.11641898583777908, - -0.21696265542495194 + -0.5080101200193996, + 0.4127582225157622, + 1.1800651746283972 ], [ - 0.5397607525206122, - 0.2698803762603061, - 0.26458860417677066 + -1.2700253000484991, + -0.33867341334626644, + -0.33867341334626644 ], [ - 0.5397607525206122, - -0.10583544167070827, - -0.10583544167070827 + -1.2700253000484991, + 0.4127582225157622, + 0.4127582225157622 ], [ - 0.2751721483438415, - -0.3545487295968727, - -0.09525189750363744 + -0.33867341334626644, + 1.344110109217995, + 0.4127582225157622 ], [ - -0.21167088334141654, - -0.756723407945564, - -0.21167088334141654 + 1.1800651746283972, + 2.0955417450800238, + 1.1800651746283972 ], [ - -0.10054366958717285, - -0.3598405016804081, - 0.2804639204273769 + 0.4127582225157622, + 1.344110109217995, + -0.33867341334626644 ], [ - -0.10583544167070827, - -0.756723407945564, - -0.11112721375424367 + 0.4127582225157622, + 2.0955417450800238, + 0.4127582225157622 ], [ - -0.21167088334141654, - -0.21167088334141654, - -0.7620151800290995 + 1.1800651746283972, + 1.1800651746283972, + 2.0955417450800238 ], [ - 0.2804639204273769, - -0.09525189750363744, - -0.3545487295968727 + -0.33867341334626644, + 0.4127582225157622, + 1.344110109217995 ], [ - -0.09525189750363744, - 0.2804639204273769, - -0.3545487295968727 + 0.4127582225157622, + -0.33867341334626644, + 1.344110109217995 ], [ - -0.11112721375424367, - -0.11112721375424367, - -0.7620151800290995 + 0.4127582225157622, + 0.4127582225157622, + 2.0955417450800238 ], [ - -0.38100759001454976, - -0.38100759001454976, - -0.7778904962797057 + 1.344110109217995, + 1.344110109217995, + 2.0955417450800238 ], [ - -0.38100759001454976, - -0.7673069521126349, - -0.39159113418162056 + 1.344110109217995, + 2.0955417450800238, + 1.344110109217995 ], [ - -0.7673069521126349, - -0.38100759001454976, - -0.39159113418162056 + 2.0955417450800238, + 1.344110109217995, + 1.344110109217995 ], [ - -0.7620151800290995, - -0.7620151800290995, - -0.7831822683632411 + 2.0955417450800238, + 2.0955417450800238, + 2.0955417450800238 ] ] ], "spreads": [ [ - 3.1895248182072504, - 3.188124675618046, - 3.188124675618046, - 3.1884047041358867, - 7.452118916780627, - 7.850599497668153, - 7.850599497668153, - 11.338074658858064, - 7.391072699891322, - 7.788713195225325, - 11.27058778605842, - 7.79011333781453, - 11.794521142938645, - 12.616404842801533, - 15.16382426959972, - 15.15094295777904, - 7.391072699891322, - 11.27058778605842, - 7.788713195225325, - 7.79011333781453, - 11.794521142938645, - 15.16382426959972, - 12.616404842801533, - 15.15094295777904, - 11.79256094331376, - 15.167464640331652, - 15.167464640331652, - 12.630686297211415, - 16.073076867028952, - 18.92264706457741, - 18.92264706457741, - 18.897444497971733, - 9.332790442599759, - 9.330830242974871, - 9.331110271492713, - 6.140465339214099, - 8.700486049315124, - 13.444729198574759, - 13.444449170056918, - 10.512270559745406, - 13.430167715647034, - 8.683964366762513, - 13.43548825748601, - 10.482027479818596, - 14.28453472357946, - 14.276693925079915, - 20.245501782857577, - 17.524184646480222, - 13.430167715647034, - 13.435768286003851, - 8.684244395280356, - 10.481467422782913, - 14.28453472357946, - 20.245501782857577, - 14.276693925079915, - 17.524464674998065, - 20.241861412125644, - 14.28453472357946, - 14.28453472357946, - 17.535665815711695, - 22.479009241156174, - 22.56049753984786, - 22.56105759688354, - 27.245934700360916 + 2.828848087228239, + 2.8008452354441546, + 2.8008452354441546, + 2.8008452354441546, + 9.641941926296054, + 10.086627212627318, + 10.086627212627318, + 7.921726741199729, + 9.642221954813893, + 10.086627212627318, + 7.921726741199729, + 10.086627212627318, + 14.239730160724923, + 15.156543528135858, + 12.280650649910356, + 12.280650649910356, + 9.641941926296054, + 7.921726741199729, + 10.086627212627318, + 10.086627212627318, + 14.239730160724923, + 12.280650649910356, + 15.156543528135858, + 12.280650649910356, + 14.239730160724923, + 12.280650649910356, + 12.280650649910356, + 15.156543528135858, + 16.62165273347917, + 14.4239889254642, + 14.4239889254642, + 14.4239889254642, + 7.7332675486928375, + 7.7332675486928375, + 7.7332675486928375, + 6.848937489351441, + 10.323811367238514, + 11.377278651355782, + 11.377558679873625, + 8.873823701858608, + 11.377558679873625, + 10.323531338720676, + 11.377558679873625, + 8.873823701858608, + 11.940135972215886, + 11.939855943698046, + 15.62363109589439, + 11.500491199205756, + 11.377278651355782, + 11.377278651355782, + 10.324091395756357, + 8.873823701858608, + 11.940416000733727, + 15.623071038858708, + 11.940135972215886, + 11.500491199205756, + 15.62335106737655, + 11.939855943698046, + 11.940416000733727, + 11.500491199205756, + 14.157961833515396, + 14.157961833515396, + 14.158241862033238, + 14.728939981392884 ], [ - 3.1895248182072504, - 3.188124675618046, - 3.188124675618046, - 3.1884047041358867, - 7.452118916780627, - 7.850599497668153, - 7.850599497668153, - 11.338074658858064, - 7.391072699891322, - 7.788713195225325, - 11.27058778605842, - 7.79011333781453, - 11.794521142938645, - 12.616404842801533, - 15.16382426959972, - 15.15094295777904, - 7.391072699891322, - 11.27058778605842, - 7.788713195225325, - 7.79011333781453, - 11.794521142938645, - 15.16382426959972, - 12.616404842801533, - 15.15094295777904, - 11.79256094331376, - 15.167464640331652, - 15.167464640331652, - 12.630686297211415, - 16.073076867028952, - 18.92264706457741, - 18.92264706457741, - 18.897444497971733, - 9.332790442599759, - 9.330830242974871, - 9.331110271492713, - 6.140465339214099, - 8.700486049315124, - 13.444729198574759, - 13.444449170056918, - 10.512270559745406, - 13.430167715647034, - 8.683964366762513, - 13.43548825748601, - 10.482027479818596, - 14.28453472357946, - 14.276693925079915, - 20.245501782857577, - 17.524184646480222, - 13.430167715647034, - 13.435768286003851, - 8.684244395280356, - 10.481467422782913, - 14.28453472357946, - 20.245501782857577, - 14.276693925079915, - 17.524464674998065, - 20.241861412125644, - 14.28453472357946, - 14.28453472357946, - 17.535665815711695, - 22.479009241156174, - 22.56049753984786, - 22.56105759688354, - 27.245934700360916 + 2.828848087228239, + 2.8008452354441546, + 2.8008452354441546, + 2.8008452354441546, + 9.641941926296054, + 10.086627212627318, + 10.086627212627318, + 7.921726741199729, + 9.642221954813893, + 10.086627212627318, + 7.921726741199729, + 10.086627212627318, + 14.239730160724923, + 15.156543528135858, + 12.280650649910356, + 12.280650649910356, + 9.641941926296054, + 7.921726741199729, + 10.086627212627318, + 10.086627212627318, + 14.239730160724923, + 12.280650649910356, + 15.156543528135858, + 12.280650649910356, + 14.239730160724923, + 12.280650649910356, + 12.280650649910356, + 15.156543528135858, + 16.62165273347917, + 14.4239889254642, + 14.4239889254642, + 14.4239889254642, + 7.7332675486928375, + 7.7332675486928375, + 7.7332675486928375, + 6.848937489351441, + 10.323811367238514, + 11.377278651355782, + 11.377558679873625, + 8.873823701858608, + 11.377558679873625, + 10.323531338720676, + 11.377558679873625, + 8.873823701858608, + 11.940135972215886, + 11.939855943698046, + 15.62363109589439, + 11.500491199205756, + 11.377278651355782, + 11.377278651355782, + 10.324091395756357, + 8.873823701858608, + 11.940416000733727, + 15.623071038858708, + 11.940135972215886, + 11.500491199205756, + 15.62335106737655, + 11.939855943698046, + 11.940416000733727, + 11.500491199205756, + 14.157961833515396, + 14.157961833515396, + 14.158241862033238, + 14.728939981392884 ] ], "self-Hartree": [ @@ -34195,7 +34195,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -34476,5 +34476,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_dummy.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_dummy.json index bea6d90d5..418adc69b 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_dummy.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_dummy.json @@ -4909,7 +4909,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -5056,5 +5056,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_init.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_init.json index 974eb3140..797b0c63b 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_init.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_init.json @@ -17808,7 +17808,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -17955,5 +17955,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-pw2wan.json index 3915ac545..068ab1ff5 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-pw2wan.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-w2kcp.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-w2kcp.json index 1220b4663..a38b64215 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-w2kcp.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-w2kcp.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "wann2kcp.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWann2KCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-wann.json index d44cf20a2..87a05b04f 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-wann.json @@ -165,7 +165,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -176,5 +176,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-wann_preproc.json index 1a9c947b9..7a10dfc10 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-emp-wann_preproc.json @@ -138,7 +138,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -149,5 +149,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-nscf.json index e70f7e82e..efc9c3e86 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-nscf.json @@ -113,7 +113,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -366,5 +366,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-pw2wan.json index 751b80f78..ef7906d24 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-pw2wan.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-w2kcp.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-w2kcp.json index 29d8bffa2..ed39fdc28 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-w2kcp.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-w2kcp.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "wann2kcp.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWann2KCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-wann.json index cb834bf5f..28058ff0d 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-wann.json @@ -162,7 +162,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -173,5 +173,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-wann_preproc.json index 513f6b175..442beff0c 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-occ-wann_preproc.json @@ -135,7 +135,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -146,5 +146,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-scf.json index 8fbdf7b35..72710d417 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-scf.json @@ -110,7 +110,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -195,5 +195,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-emp-ki.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-emp-ki.json index fd0df5f98..4cbc9824d 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-emp-ki.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-emp-ki.json @@ -8631,5 +8631,5 @@ ], "command": null, "__koopmans_name__": "BenchGenUnfoldAndInterpolateCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-occ-ki.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-occ-ki.json index 272937238..aca5d43a0 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-occ-ki.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-occ-ki.json @@ -8631,5 +8631,5 @@ ], "command": null, "__koopmans_name__": "BenchGenUnfoldAndInterpolateCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-pdos-projwfc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-pdos-projwfc.json index 64be0ff5d..1f2687d41 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-pdos-projwfc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-pdos-projwfc.json @@ -21154,7 +21154,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "projwfc.x", "_flags": "", @@ -21172,5 +21172,5 @@ }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-bands.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-bands.json index 1385dfbf3..0f9d9a7a6 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-bands.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-bands.json @@ -1159,7 +1159,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -2672,5 +2672,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-emp-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-emp-pw2wan.json index 3915ac545..068ab1ff5 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-emp-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-emp-pw2wan.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-emp-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-emp-wann.json index 05323e1f8..be28518e3 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-emp-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-emp-wann.json @@ -1595,7 +1595,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -1606,5 +1606,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-emp-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-emp-wann_preproc.json index 563b7a405..3682df61e 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-emp-wann_preproc.json @@ -306,7 +306,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -317,5 +317,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-nscf.json index fda2bb22c..ea4dfdb4b 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-nscf.json @@ -113,7 +113,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -2046,5 +2046,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-occ-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-occ-pw2wan.json index 751b80f78..ef7906d24 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-occ-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-occ-pw2wan.json @@ -82,7 +82,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -93,5 +93,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-occ-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-occ-wann.json index 45f184710..f9cccede1 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-occ-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-occ-wann.json @@ -1592,7 +1592,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -1603,5 +1603,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-occ-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-occ-wann_preproc.json index b69161423..ecfa7061c 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-occ-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-occ-wann_preproc.json @@ -303,7 +303,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -314,5 +314,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-scf.json index 8fbdf7b35..72710d417 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-scf.json @@ -110,7 +110,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -195,5 +195,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-ki.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-ki.json index 21145ccba..4dd1f3637 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-ki.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-ki.json @@ -441,781 +441,781 @@ "centres": [ [ [ - 1.3758607417192075, - 1.3758607417192075, - 1.3758607417192075 + -0.756723407945564, + -0.756723407945564, + -0.756723407945564 ], [ - 1.3758607417192075, - 1.1218556817095076, - 1.1218556817095076 + -0.756723407945564, + -0.9842696075375869, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.3758607417192075, - 1.1218556817095076 + -0.9842696075375869, + -0.756723407945564, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.1218556817095076, - 1.3758607417192075 + -0.9842696075375869, + -0.9842696075375869, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.46038417126758097, - 1.3758607417192075 + 0.6032620175230371, + 0.6032620175230371, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.7143892312772808, - 1.1218556817095076 + 0.6032620175230371, + 0.37571581793101433, + -0.9842696075375869 ], [ - -0.7143892312772808, - -0.46038417126758097, - 1.1218556817095076 + 0.37571581793101433, + 0.6032620175230371, + -0.9842696075375869 ], [ - 0.11112721375424367, - 0.11112721375424367, - 1.3758607417192075 + 0.550344296687683, + 0.550344296687683, + -0.756723407945564 ], [ - -0.47096771543465177, - 1.3758607417192075, - -0.47096771543465177 + 0.6032620175230371, + -0.756723407945564, + 0.6032620175230371 ], [ - -0.47096771543465177, - 1.1218556817095076, - -0.7249727754443517 + 0.6032620175230371, + -0.9842696075375869, + 0.37571581793101433 ], [ - 0.08996012542010202, - 1.3758607417192075, - 0.08996012542010202 + 0.550344296687683, + -0.756723407945564, + 0.550344296687683 ], [ - -0.7249727754443517, - 1.1218556817095076, - -0.47096771543465177 + 0.37571581793101433, + -0.9842696075375869, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.45509239918404554, - -0.46038417126758097 + 1.9632474429916382, + 0.6032620175230371, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.7090974591937454, - -0.7090974591937454 + 1.9632474429916382, + 0.37571581793101433, + 0.37571581793101433 ], [ - -1.6986588388148676, - -0.4498006271005101, - 0.13229430208838533 + 1.910329722156284, + 0.6032620175230371, + 0.550344296687683 ], [ - -1.6986588388148676, - 0.13229430208838533, - -0.45509239918404554 + 1.910329722156284, + 0.550344296687683, + 0.6032620175230371 ], [ - 1.3758607417192075, - -0.47096771543465177, - -0.47096771543465177 + -0.756723407945564, + 0.6032620175230371, + 0.6032620175230371 ], [ - 1.3758607417192075, - 0.08996012542010202, - 0.08996012542010202 + -0.756723407945564, + 0.550344296687683, + 0.550344296687683 ], [ - 1.1218556817095076, - -0.47096771543465177, - -0.7249727754443517 + -0.9842696075375869, + 0.6032620175230371, + 0.37571581793101433 ], [ - 1.1218556817095076, - -0.7249727754443517, - -0.47096771543465177 + -0.9842696075375869, + 0.37571581793101433, + 0.6032620175230371 ], [ - -0.45509239918404554, - -2.2860455400872985, - -0.46038417126758097 + 0.6032620175230371, + 1.9632474429916382, + 0.6032620175230371 ], [ - -0.4498006271005101, - -1.6986588388148676, - 0.13229430208838533 + 0.6032620175230371, + 1.910329722156284, + 0.550344296687683 ], [ - -0.7090974591937454, - -2.2860455400872985, - -0.7090974591937454 + 0.37571581793101433, + 1.9632474429916382, + 0.37571581793101433 ], [ - 0.13229430208838533, - -1.6986588388148676, - -0.45509239918404554 + 0.550344296687683, + 1.910329722156284, + 0.6032620175230371 ], [ - -0.46038417126758097, - -0.46038417126758097, - -2.291337312170834 + 0.6032620175230371, + 0.6032620175230371, + 1.9632474429916382 ], [ - -0.45509239918404554, - 0.13229430208838533, - -1.6986588388148676 + 0.6032620175230371, + 0.550344296687683, + 1.910329722156284 ], [ - 0.13229430208838533, - -0.45509239918404554, - -1.6986588388148676 + 0.550344296687683, + 0.6032620175230371, + 1.910329722156284 ], [ - -0.7090974591937454, - -0.7090974591937454, - -2.2860455400872985 + 0.37571581793101433, + 0.37571581793101433, + 1.9632474429916382 ], [ - -2.3125044005049755, - -2.3125044005049755, - -2.3125044005049755 + 1.9632474429916382, + 1.9632474429916382, + 1.9632474429916382 ], [ - -2.3125044005049755, - -1.7515765596502217, - -1.756868331733757 + 1.9632474429916382, + 1.910329722156284, + 1.910329722156284 ], [ - -1.7515765596502217, - -2.3125044005049755, - -1.756868331733757 + 1.910329722156284, + 1.9632474429916382, + 1.910329722156284 ], [ - -1.73040947131608, - -1.73040947131608, - -2.317796172588511 + 1.910329722156284, + 1.910329722156284, + 1.9632474429916382 ], [ - -1.190648718795468, - -1.217107579213145, - -1.217107579213145 + -0.0, + 0.0370424045847479, + 0.0370424045847479 ], [ - 0.06350126500242495, - -0.05820949291888954, - 0.11112721375424367 + -1.307067704633247, + -1.5081550438075928, + -1.2223993512966804 ], [ - 0.015875316250606238, - 0.052917720835354135, - -0.0740848091694958 + 0.3545487295968727, + 2.254294907586086, + 0.30163100876151855 ], [ - 0.06350126500242495, - 0.11641898583777908, - -0.05820949291888954 + -1.3123594767167825, + 0.5873867012724309, + 0.30163100876151855 ], [ - 0.052917720835354135, - 0.021167088334141652, - -1.2223993512966804 + 0.24342151584262903, + 0.2804639204273769, + 0.0370424045847479 ], [ - 0.19579556709081028, - 0.0740848091694958, - 0.11641898583777908 + 0.6455961941913204, + 0.4445088550169747, + -1.2223993512966804 ], [ - -0.11112721375424367, - -0.05820949291888954, - -0.05820949291888954 + -1.5981151692276947, + 0.3069227808450539, + 0.30163100876151855 ], [ - -0.26458860417677066, - -0.23283797167555817, - -0.0793765812530312 + 0.19050379500727488, + 2.0902499729964883, + 0.30163100876151855 ], [ - 0.042334176668283305, - -1.2223993512966804, - 0.010583544167070826 + 0.24342151584262903, + 0.0370424045847479, + 0.2804639204273769 ], [ - -0.26458860417677066, - -0.05820949291888954, - -0.21167088334141654 + 0.19050379500727488, + -1.5081550438075928, + 0.2804639204273769 ], [ - 0.12171075792131451, - 0.0370424045847479, - 0.0370424045847479 + 2.3072126284214405, + 2.254294907586086, + 2.259586679669621 ], [ - 0.16933670667313322, - 0.08466835333656661, - 0.026458860417677067 + 0.6403044221077849, + 0.5873867012724309, + 2.254294907586086 ], [ - 1.2859006162991056, - 0.015875316250606238, - 0.015875316250606238 + 0.48684303168525805, + 0.2804639204273769, + 0.2804639204273769 ], [ - -0.1481696183389916, - 0.0740848091694958, - -0.22754619959202277 + 2.1431676938318422, + 0.4445088550169747, + 0.2804639204273769 ], [ - 0.010583544167070826, - -0.0740848091694958, - 0.042334176668283305 + 0.3545487295968727, + 0.3069227808450539, + 2.259586679669621 ], [ - -0.1587531625060624, - -0.24342151584262903, - 0.0370424045847479 + 2.1431676938318422, + 2.0902499729964883, + 2.254294907586086 ], [ - -1.190648718795468, - 0.052917720835354135, - 0.052917720835354135 + -0.0, + 0.21696265542495194, + 0.21696265542495194 ], [ - 0.06350126500242495, - -0.05820949291888954, - 0.11641898583777908 + -1.307067704633247, + 0.3069227808450539, + 0.5926784733559664 ], [ - 0.026458860417677067, - 0.0793765812530312, - -0.05820949291888954 + 0.3545487295968727, + 0.4445088550169747, + -1.5081550438075928 ], [ - 0.06350126500242495, - 0.11641898583777908, - -0.05820949291888954 + -1.3123594767167825, + -1.2223993512966804, + -1.5081550438075928 ], [ - 0.04762594875181872, - 1.2964841604661763, - 0.05820949291888954 + 0.24342151584262903, + 0.45509239918404554, + 0.21696265542495194 ], [ - 0.19050379500727488, - 0.04762594875181872, - 0.08466835333656661 + 0.6455961941913204, + 2.259586679669621, + 0.5926784733559664 ], [ - -0.11112721375424367, - -0.05820949291888954, - -0.05820949291888954 + -1.5981151692276947, + -1.5081550438075928, + -1.5081550438075928 ], [ - -0.25929683209323523, - -0.2063791112578811, - -0.05820949291888954 + 0.19050379500727488, + 0.2804639204273769, + -1.5081550438075928 ], [ - 0.04762594875181872, - 0.05820949291888954, - 1.2964841604661763 + 0.24342151584262903, + 0.21696265542495194, + 0.46038417126758097 ], [ - -0.2751721483438415, - -0.0740848091694958, - -0.24342151584262903 + 0.19050379500727488, + 0.3069227808450539, + 2.0902499729964883 ], [ - 0.13229430208838533, - 0.06879303708596038, - 0.05820949291888954 + 2.3072126284214405, + 0.4445088550169747, + 0.4445088550169747 ], [ - 0.2010873391743457, - 0.11641898583777908, - 0.08466835333656661 + 0.6403044221077849, + -1.2223993512966804, + 0.4445088550169747 ], [ - 1.2806088442155699, - 1.2911923883826408, - 1.2859006162991056 + 0.48684303168525805, + 0.45509239918404554, + 0.46038417126758097 ], [ - -0.1587531625060624, - 0.042334176668283305, - -0.24342151584262903 + 2.1431676938318422, + 2.259586679669621, + 2.0902499729964883 ], [ - 0.026458860417677067, - -0.05820949291888954, - 0.0793765812530312 + 0.3545487295968727, + -1.5081550438075928, + 0.4445088550169747 ], [ - -0.15346139042252696, - -0.21696265542495194, - 0.05820949291888954 + 2.1431676938318422, + 0.2804639204273769, + 0.4445088550169747 ] ], [ [ - 1.3758607417192075, - 1.3758607417192075, - 1.3758607417192075 + -0.756723407945564, + -0.756723407945564, + -0.756723407945564 ], [ - 1.3758607417192075, - 1.1218556817095076, - 1.1218556817095076 + -0.756723407945564, + -0.9842696075375869, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.3758607417192075, - 1.1218556817095076 + -0.9842696075375869, + -0.756723407945564, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.1218556817095076, - 1.3758607417192075 + -0.9842696075375869, + -0.9842696075375869, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.46038417126758097, - 1.3758607417192075 + 0.6032620175230371, + 0.6032620175230371, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.7143892312772808, - 1.1218556817095076 + 0.6032620175230371, + 0.37571581793101433, + -0.9842696075375869 ], [ - -0.7143892312772808, - -0.46038417126758097, - 1.1218556817095076 + 0.37571581793101433, + 0.6032620175230371, + -0.9842696075375869 ], [ - 0.11112721375424367, - 0.11112721375424367, - 1.3758607417192075 + 0.550344296687683, + 0.550344296687683, + -0.756723407945564 ], [ - -0.47096771543465177, - 1.3758607417192075, - -0.47096771543465177 + 0.6032620175230371, + -0.756723407945564, + 0.6032620175230371 ], [ - -0.47096771543465177, - 1.1218556817095076, - -0.7249727754443517 + 0.6032620175230371, + -0.9842696075375869, + 0.37571581793101433 ], [ - 0.08996012542010202, - 1.3758607417192075, - 0.08996012542010202 + 0.550344296687683, + -0.756723407945564, + 0.550344296687683 ], [ - -0.7249727754443517, - 1.1218556817095076, - -0.47096771543465177 + 0.37571581793101433, + -0.9842696075375869, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.45509239918404554, - -0.46038417126758097 + 1.9632474429916382, + 0.6032620175230371, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.7090974591937454, - -0.7090974591937454 + 1.9632474429916382, + 0.37571581793101433, + 0.37571581793101433 ], [ - -1.6986588388148676, - -0.4498006271005101, - 0.13229430208838533 + 1.910329722156284, + 0.6032620175230371, + 0.550344296687683 ], [ - -1.6986588388148676, - 0.13229430208838533, - -0.45509239918404554 + 1.910329722156284, + 0.550344296687683, + 0.6032620175230371 ], [ - 1.3758607417192075, - -0.47096771543465177, - -0.47096771543465177 + -0.756723407945564, + 0.6032620175230371, + 0.6032620175230371 ], [ - 1.3758607417192075, - 0.08996012542010202, - 0.08996012542010202 + -0.756723407945564, + 0.550344296687683, + 0.550344296687683 ], [ - 1.1218556817095076, - -0.47096771543465177, - -0.7249727754443517 + -0.9842696075375869, + 0.6032620175230371, + 0.37571581793101433 ], [ - 1.1218556817095076, - -0.7249727754443517, - -0.47096771543465177 + -0.9842696075375869, + 0.37571581793101433, + 0.6032620175230371 ], [ - -0.45509239918404554, - -2.2860455400872985, - -0.46038417126758097 + 0.6032620175230371, + 1.9632474429916382, + 0.6032620175230371 ], [ - -0.4498006271005101, - -1.6986588388148676, - 0.13229430208838533 + 0.6032620175230371, + 1.910329722156284, + 0.550344296687683 ], [ - -0.7090974591937454, - -2.2860455400872985, - -0.7090974591937454 + 0.37571581793101433, + 1.9632474429916382, + 0.37571581793101433 ], [ - 0.13229430208838533, - -1.6986588388148676, - -0.45509239918404554 + 0.550344296687683, + 1.910329722156284, + 0.6032620175230371 ], [ - -0.46038417126758097, - -0.46038417126758097, - -2.291337312170834 + 0.6032620175230371, + 0.6032620175230371, + 1.9632474429916382 ], [ - -0.45509239918404554, - 0.13229430208838533, - -1.6986588388148676 + 0.6032620175230371, + 0.550344296687683, + 1.910329722156284 ], [ - 0.13229430208838533, - -0.45509239918404554, - -1.6986588388148676 + 0.550344296687683, + 0.6032620175230371, + 1.910329722156284 ], [ - -0.7090974591937454, - -0.7090974591937454, - -2.2860455400872985 + 0.37571581793101433, + 0.37571581793101433, + 1.9632474429916382 ], [ - -2.3125044005049755, - -2.3125044005049755, - -2.3125044005049755 + 1.9632474429916382, + 1.9632474429916382, + 1.9632474429916382 ], [ - -2.3125044005049755, - -1.7515765596502217, - -1.756868331733757 + 1.9632474429916382, + 1.910329722156284, + 1.910329722156284 ], [ - -1.7515765596502217, - -2.3125044005049755, - -1.756868331733757 + 1.910329722156284, + 1.9632474429916382, + 1.910329722156284 ], [ - -1.73040947131608, - -1.73040947131608, - -2.317796172588511 + 1.910329722156284, + 1.910329722156284, + 1.9632474429916382 ], [ - 0.0740848091694958, - 0.19579556709081028, - 0.11641898583777908 + 0.4445088550169747, + 0.6403044221077849, + -1.2223993512966804 ], [ - 1.2964841604661763, - 0.04762594875181872, - 0.05820949291888954 + 0.45509239918404554, + 0.24342151584262903, + 0.21696265542495194 ], [ - 0.11641898583777908, - 0.2010873391743457, - 0.08466835333656661 + -1.2223993512966804, + 0.6403044221077849, + 0.4445088550169747 ], [ - -0.05820949291888954, - -0.11112721375424367, - -0.05820949291888954 + -1.5081550438075928, + -1.5981151692276947, + -1.5081550438075928 ], [ - -0.05820949291888954, - 0.06350126500242495, - 0.11112721375424367 + -1.5081550438075928, + -1.3123594767167825, + -1.2223993512966804 ], [ - 0.052917720835354135, - -1.190648718795468, - 0.052917720835354135 + 0.21696265542495194, + -0.0, + 0.21696265542495194 ], [ - -0.21696265542495194, - -0.15346139042252696, - 0.05820949291888954 + 0.2804639204273769, + 2.1431676938318422, + 0.4445088550169747 ], [ - 0.0793765812530312, - 0.026458860417677067, - -0.05820949291888954 + 0.4445088550169747, + 0.3545487295968727, + -1.5081550438075928 ], [ - 0.04762594875181872, - 0.19050379500727488, - 0.08466835333656661 + 2.254294907586086, + 0.6403044221077849, + 0.5926784733559664 ], [ - 0.021167088334141652, - 0.052917720835354135, - -1.2223993512966804 + 0.2804639204273769, + 0.24342151584262903, + 0.0370424045847479 ], [ - 0.08996012542010202, - 0.17462847875666865, - 0.026458860417677067 + 0.5926784733559664, + 0.6403044221077849, + 2.254294907586086 ], [ - -0.05820949291888954, - -0.11112721375424367, - -0.05820949291888954 + 0.30163100876151855, + -1.5981151692276947, + 0.30163100876151855 ], [ - -0.05820949291888954, - 0.06350126500242495, - 0.11641898583777908 + 0.30163100876151855, + -1.3123594767167825, + 0.5926784733559664 ], [ - -1.217107579213145, - -1.190648718795468, - -1.2223993512966804 + 0.0370424045847479, + -0.0, + 0.0370424045847479 ], [ - -0.24342151584262903, - -0.1587531625060624, - 0.0370424045847479 + 2.0902499729964883, + 2.1431676938318422, + 2.254294907586086 ], [ - 0.052917720835354135, - 0.015875316250606238, - -0.0740848091694958 + 2.259586679669621, + 0.3545487295968727, + 0.30163100876151855 ], [ - 0.0740848091694958, - -0.1481696183389916, - -0.22754619959202277 + 0.4445088550169747, + 2.1431676938318422, + 0.2804639204273769 ], [ - 1.2911923883826408, - 1.2806088442155699, - 1.2859006162991056 + 0.45509239918404554, + 0.48684303168525805, + 0.45509239918404554 ], [ - 0.11641898583777908, - 0.06350126500242495, - -0.05820949291888954 + -1.2223993512966804, + -1.3123594767167825, + -1.5081550438075928 ], [ - -0.05820949291888954, - 0.026458860417677067, - 0.0793765812530312 + -1.5081550438075928, + 0.3545487295968727, + 0.4445088550169747 ], [ - -0.052917720835354135, - -0.25929683209323523, - -0.2063791112578811 + -1.5081550438075928, + 0.19050379500727488, + 0.2804639204273769 ], [ - 0.05820949291888954, - 0.04762594875181872, - 1.2964841604661763 + 0.21696265542495194, + 0.24342151584262903, + 0.45509239918404554 ], [ - -0.2063791112578811, - -0.25929683209323523, - -0.05820949291888954 + 0.2804639204273769, + 0.19050379500727488, + -1.5081550438075928 ], [ - 0.06879303708596038, - 0.13229430208838533, - 0.05820949291888954 + 0.4445088550169747, + 2.3072126284214405, + 0.4445088550169747 ], [ - 0.042334176668283305, - -0.1587531625060624, - -0.24342151584262903 + 2.254294907586086, + 2.1431676938318422, + 2.0902499729964883 ], [ - 0.015875316250606238, - 1.2859006162991056, - 0.015875316250606238 + 0.2804639204273769, + 0.48684303168525805, + 0.2804639204273769 ], [ - 0.11641898583777908, - 0.06350126500242495, - -0.05820949291888954 + 0.5926784733559664, + -1.3123594767167825, + 0.30163100876151855 ], [ - -0.0740848091694958, - 0.010583544167070826, - 0.042334176668283305 + 0.30163100876151855, + 0.3545487295968727, + 2.254294907586086 ], [ - -0.0793765812530312, - -0.2751721483438415, - -0.24342151584262903 + 0.30163100876151855, + 0.19050379500727488, + 2.0902499729964883 ], [ - -1.2223993512966804, - 0.042334176668283305, - 0.010583544167070826 + 0.0370424045847479, + 0.24342151584262903, + 0.2804639204273769 ], [ - -0.23283797167555817, - -0.26458860417677066, - -0.0793765812530312 + 2.0902499729964883, + 0.19050379500727488, + 0.30163100876151855 ], [ - 0.0370424045847479, - 0.12171075792131451, - 0.0370424045847479 + 2.259586679669621, + 2.3072126284214405, + 2.254294907586086 ] ] ], "spreads": [ [ - 3.1895248182072504, - 3.188124675618046, - 3.188124675618046, - 3.1884047041358867, - 7.452118916780627, - 7.850599497668153, - 7.850599497668153, - 11.338074658858064, - 7.391072699891322, - 7.788713195225325, - 11.27058778605842, - 7.79011333781453, - 11.794521142938645, - 12.616404842801533, - 15.16382426959972, - 15.15094295777904, - 7.391072699891322, - 11.27058778605842, - 7.788713195225325, - 7.79011333781453, - 11.794521142938645, - 15.16382426959972, - 12.616404842801533, - 15.15094295777904, - 11.79256094331376, - 15.167464640331652, - 15.167464640331652, - 12.630686297211415, - 16.073076867028952, - 18.92264706457741, - 18.92264706457741, - 18.897444497971733, - 12.53967702891314, - 5.166806182681473, - 19.032138215053184, - 13.394604093881247, - 11.269747700504897, - 13.710476262005722, - 12.051587322316543, - 16.33658370231719, - 11.33583443071534, - 12.406943511456578, - 27.357106021943732, - 21.80750085537382, - 12.033385468656888, - 18.050078202985333, - 19.075542635318516, - 22.05868643587706, - 11.183778945527758, - 13.401044749791588, - 12.43718659138339, - 5.168486353788518, - 11.797041399599212, - 21.819542081640975, - 5.364506316277111, - 12.416744509581008, - 11.803762084027394, - 16.355065584494685, - 20.778676080826546, - 13.706835891273792, - 14.500156682316911, - 22.049725523306154, - 12.423185165491347, - 18.083681625126236 + 2.828848087228239, + 2.8008452354441546, + 2.8008452354441546, + 2.8008452354441546, + 9.642221954813893, + 10.086627212627318, + 10.086627212627318, + 7.921726741199729, + 9.642221954813893, + 10.086627212627318, + 7.921726741199729, + 10.086627212627318, + 14.239730160724923, + 15.156543528135858, + 12.280650649910356, + 12.280650649910356, + 9.642221954813893, + 7.921726741199729, + 10.086627212627318, + 10.086627212627318, + 14.239730160724923, + 12.280650649910356, + 15.156543528135858, + 12.280650649910356, + 14.239730160724923, + 12.280650649910356, + 12.280650649910356, + 15.156543528135858, + 16.62165273347917, + 14.4239889254642, + 14.4239889254642, + 14.4239889254642, + 19.9049871051631, + 9.114368198683897, + 8.25272044928761, + 8.81193739941578, + 17.981471216114322, + 8.230878224896024, + 8.648960802032407, + 10.078226357092094, + 17.98287135870353, + 10.158594541712416, + 9.906568875655655, + 9.346791868491799, + 13.679113068007547, + 9.874365596103956, + 8.25244042076977, + 11.216542282115137, + 17.756328287770284, + 8.806616857576806, + 7.9606507051796065, + 9.116328398308783, + 13.513616213963608, + 9.345671754420437, + 9.778875871520228, + 10.154114085426963, + 13.51445629951713, + 10.079346471163456, + 8.189153975737737, + 8.2300381393425, + 6.891501824063251, + 11.217382367668659, + 7.957290362965516, + 9.871285282407706 ], [ - 3.1895248182072504, - 3.188124675618046, - 3.188124675618046, - 3.1884047041358867, - 7.452118916780627, - 7.850599497668153, - 7.850599497668153, - 11.338074658858064, - 7.391072699891322, - 7.788713195225325, - 11.27058778605842, - 7.79011333781453, - 11.794521142938645, - 12.616404842801533, - 15.16382426959972, - 15.15094295777904, - 7.391072699891322, - 11.27058778605842, - 7.788713195225325, - 7.79011333781453, - 11.794521142938645, - 15.16382426959972, - 12.616404842801533, - 15.15094295777904, - 11.79256094331376, - 15.167464640331652, - 15.167464640331652, - 12.630686297211415, - 16.073076867028952, - 18.92264706457741, - 18.92264706457741, - 18.897444497971733, - 13.709916204970042, - 11.798161513670577, - 13.707115919791631, - 5.364506316277111, - 5.167366239717154, - 11.183778945527758, - 18.07192042737692, - 12.438306705454753, - 21.81086119758791, - 11.27058778605842, - 21.816181739426888, - 12.051867350834383, - 13.398244464613176, - 12.5393970003953, - 22.05504606514513, - 19.038578870963523, - 18.061279343698967, - 14.500436710834752, - 5.168206325270677, - 12.422065051419985, - 12.409183739599305, - 11.802641969956031, - 12.414224252920441, - 20.778396052308704, - 22.053085865520245, - 12.033665497174729, - 13.397964436095338, - 19.069101979408174, - 16.354505527459, - 11.334994345161816, - 16.337423787870712, - 27.356545964908047 + 2.828848087228239, + 2.8008452354441546, + 2.8008452354441546, + 2.8008452354441546, + 9.642221954813893, + 10.086627212627318, + 10.086627212627318, + 7.921726741199729, + 9.642221954813893, + 10.086627212627318, + 7.921726741199729, + 10.086627212627318, + 14.239730160724923, + 15.156543528135858, + 12.280650649910356, + 12.280650649910356, + 9.642221954813893, + 7.921726741199729, + 10.086627212627318, + 10.086627212627318, + 14.239730160724923, + 12.280650649910356, + 15.156543528135858, + 12.280650649910356, + 14.239730160724923, + 12.280650649910356, + 12.280650649910356, + 15.156543528135858, + 16.62165273347917, + 14.4239889254642, + 14.4239889254642, + 14.4239889254642, + 8.230598196378182, + 13.514176270999288, + 8.230598196378182, + 9.779155900038067, + 9.1157683412731, + 17.756328287770284, + 9.873525510550433, + 7.958410477036879, + 9.34651183997396, + 17.982311301667846, + 9.345951782938277, + 8.64924083055025, + 8.810537256826578, + 19.9049871051631, + 11.21710233915082, + 8.25272044928761, + 9.87240539647907, + 6.891221795545411, + 9.11520828423742, + 7.959810619626084, + 10.155514228016166, + 13.513896242481447, + 10.157474427641054, + 8.189434004255578, + 11.216822310632978, + 13.678833039489707, + 8.808577057201692, + 8.25300047780545, + 10.078506385609934, + 17.981751244632164, + 10.079066442645615, + 9.906568875655655 ] ], "self-Hartree": [ @@ -34195,7 +34195,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -34476,5 +34476,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_32-dft_n-1.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_32-dft_n-1.json index 510fb2370..1f71f17af 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_32-dft_n-1.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_32-dft_n-1.json @@ -5127,7 +5127,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -5408,5 +5408,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1.json index 3ec1ed333..c29cd11e0 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1.json @@ -5172,7 +5172,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -5455,5 +5455,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1_dummy.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1_dummy.json index 88635fa13..1e3154d64 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1_dummy.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1_dummy.json @@ -5050,7 +5050,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -5333,5 +5333,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-pz_print.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-pz_print.json index 93bc70ae2..714d1b11f 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-pz_print.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-pz_print.json @@ -443,781 +443,781 @@ "centres": [ [ [ - 1.3758607417192075, - 1.3758607417192075, - 1.3758607417192075 + -0.756723407945564, + -0.756723407945564, + -0.756723407945564 ], [ - 1.3758607417192075, - 1.1218556817095076, - 1.1218556817095076 + -0.756723407945564, + -0.9842696075375869, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.3758607417192075, - 1.1218556817095076 + -0.9842696075375869, + -0.756723407945564, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.1218556817095076, - 1.3758607417192075 + -0.9842696075375869, + -0.9842696075375869, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.46038417126758097, - 1.3758607417192075 + 0.6032620175230371, + 0.6032620175230371, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.7143892312772808, - 1.1218556817095076 + 0.6032620175230371, + 0.37571581793101433, + -0.9842696075375869 ], [ - -0.7143892312772808, - -0.46038417126758097, - 1.1218556817095076 + 0.37571581793101433, + 0.6032620175230371, + -0.9842696075375869 ], [ - 0.11112721375424367, - 0.11112721375424367, - 1.3758607417192075 + 0.550344296687683, + 0.550344296687683, + -0.756723407945564 ], [ - -0.47096771543465177, - 1.3758607417192075, - -0.47096771543465177 + 0.6032620175230371, + -0.756723407945564, + 0.6032620175230371 ], [ - -0.47096771543465177, - 1.1218556817095076, - -0.7249727754443517 + 0.6032620175230371, + -0.9842696075375869, + 0.37571581793101433 ], [ - 0.08996012542010202, - 1.3758607417192075, - 0.08996012542010202 + 0.550344296687683, + -0.756723407945564, + 0.550344296687683 ], [ - -0.7249727754443517, - 1.1218556817095076, - -0.47096771543465177 + 0.37571581793101433, + -0.9842696075375869, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.45509239918404554, - -0.46038417126758097 + 1.9632474429916382, + 0.6032620175230371, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.7090974591937454, - -0.7090974591937454 + 1.9632474429916382, + 0.37571581793101433, + 0.37571581793101433 ], [ - -1.6986588388148676, - -0.4498006271005101, - 0.13229430208838533 + 1.910329722156284, + 0.6032620175230371, + 0.550344296687683 ], [ - -1.6986588388148676, - 0.13229430208838533, - -0.45509239918404554 + 1.910329722156284, + 0.550344296687683, + 0.6032620175230371 ], [ - 1.3758607417192075, - -0.47096771543465177, - -0.47096771543465177 + -0.756723407945564, + 0.6032620175230371, + 0.6032620175230371 ], [ - 1.3758607417192075, - 0.08996012542010202, - 0.08996012542010202 + -0.756723407945564, + 0.550344296687683, + 0.550344296687683 ], [ - 1.1218556817095076, - -0.47096771543465177, - -0.7249727754443517 + -0.9842696075375869, + 0.6032620175230371, + 0.37571581793101433 ], [ - 1.1218556817095076, - -0.7249727754443517, - -0.47096771543465177 + -0.9842696075375869, + 0.37571581793101433, + 0.6032620175230371 ], [ - -0.45509239918404554, - -2.2860455400872985, - -0.46038417126758097 + 0.6032620175230371, + 1.9632474429916382, + 0.6032620175230371 ], [ - -0.4498006271005101, - -1.6986588388148676, - 0.13229430208838533 + 0.6032620175230371, + 1.910329722156284, + 0.550344296687683 ], [ - -0.7090974591937454, - -2.2860455400872985, - -0.7090974591937454 + 0.37571581793101433, + 1.9632474429916382, + 0.37571581793101433 ], [ - 0.13229430208838533, - -1.6986588388148676, - -0.45509239918404554 + 0.550344296687683, + 1.910329722156284, + 0.6032620175230371 ], [ - -0.46038417126758097, - -0.46038417126758097, - -2.291337312170834 + 0.6032620175230371, + 0.6032620175230371, + 1.9632474429916382 ], [ - -0.45509239918404554, - 0.13229430208838533, - -1.6986588388148676 + 0.6032620175230371, + 0.550344296687683, + 1.910329722156284 ], [ - 0.13229430208838533, - -0.45509239918404554, - -1.6986588388148676 + 0.550344296687683, + 0.6032620175230371, + 1.910329722156284 ], [ - -0.7090974591937454, - -0.7090974591937454, - -2.2860455400872985 + 0.37571581793101433, + 0.37571581793101433, + 1.9632474429916382 ], [ - -2.3125044005049755, - -2.3125044005049755, - -2.3125044005049755 + 1.9632474429916382, + 1.9632474429916382, + 1.9632474429916382 ], [ - -2.3125044005049755, - -1.7515765596502217, - -1.756868331733757 + 1.9632474429916382, + 1.910329722156284, + 1.910329722156284 ], [ - -1.7515765596502217, - -2.3125044005049755, - -1.756868331733757 + 1.910329722156284, + 1.9632474429916382, + 1.910329722156284 ], [ - -1.73040947131608, - -1.73040947131608, - -2.317796172588511 + 1.910329722156284, + 1.910329722156284, + 1.9632474429916382 ], [ - -1.190648718795468, - -1.217107579213145, - -1.217107579213145 + -0.0, + 0.0370424045847479, + 0.0370424045847479 ], [ - 0.06350126500242495, - -0.05820949291888954, - 0.11112721375424367 + -1.307067704633247, + -1.5081550438075928, + -1.2223993512966804 ], [ - 0.015875316250606238, - 0.052917720835354135, - -0.0740848091694958 + 0.3545487295968727, + 2.254294907586086, + 0.30163100876151855 ], [ - 0.06350126500242495, - 0.11641898583777908, - -0.05820949291888954 + -1.3123594767167825, + 0.5873867012724309, + 0.30163100876151855 ], [ - 0.052917720835354135, - 0.021167088334141652, - -1.2223993512966804 + 0.24342151584262903, + 0.2804639204273769, + 0.0370424045847479 ], [ - 0.19579556709081028, - 0.0740848091694958, - 0.11641898583777908 + 0.6455961941913204, + 0.4445088550169747, + -1.2223993512966804 ], [ - -0.11112721375424367, - -0.05820949291888954, - -0.05820949291888954 + -1.5981151692276947, + 0.3069227808450539, + 0.30163100876151855 ], [ - -0.26458860417677066, - -0.23283797167555817, - -0.0793765812530312 + 0.19050379500727488, + 2.0902499729964883, + 0.30163100876151855 ], [ - 0.042334176668283305, - -1.2223993512966804, - 0.010583544167070826 + 0.24342151584262903, + 0.0370424045847479, + 0.2804639204273769 ], [ - -0.26458860417677066, - -0.05820949291888954, - -0.21167088334141654 + 0.19050379500727488, + -1.5081550438075928, + 0.2804639204273769 ], [ - 0.12171075792131451, - 0.0370424045847479, - 0.0370424045847479 + 2.3072126284214405, + 2.254294907586086, + 2.259586679669621 ], [ - 0.16933670667313322, - 0.08466835333656661, - 0.026458860417677067 + 0.6403044221077849, + 0.5873867012724309, + 2.254294907586086 ], [ - 1.2859006162991056, - 0.015875316250606238, - 0.015875316250606238 + 0.48684303168525805, + 0.2804639204273769, + 0.2804639204273769 ], [ - -0.1481696183389916, - 0.0740848091694958, - -0.22754619959202277 + 2.1431676938318422, + 0.4445088550169747, + 0.2804639204273769 ], [ - 0.010583544167070826, - -0.0740848091694958, - 0.042334176668283305 + 0.3545487295968727, + 0.3069227808450539, + 2.259586679669621 ], [ - -0.1587531625060624, - -0.24342151584262903, - 0.0370424045847479 + 2.1431676938318422, + 2.0902499729964883, + 2.254294907586086 ], [ - -1.190648718795468, - 0.052917720835354135, - 0.052917720835354135 + -0.0, + 0.21696265542495194, + 0.21696265542495194 ], [ - 0.06350126500242495, - -0.05820949291888954, - 0.11641898583777908 + -1.307067704633247, + 0.3069227808450539, + 0.5926784733559664 ], [ - 0.026458860417677067, - 0.0793765812530312, - -0.05820949291888954 + 0.3545487295968727, + 0.4445088550169747, + -1.5081550438075928 ], [ - 0.06350126500242495, - 0.11641898583777908, - -0.05820949291888954 + -1.3123594767167825, + -1.2223993512966804, + -1.5081550438075928 ], [ - 0.04762594875181872, - 1.2964841604661763, - 0.05820949291888954 + 0.24342151584262903, + 0.45509239918404554, + 0.21696265542495194 ], [ - 0.19050379500727488, - 0.04762594875181872, - 0.08466835333656661 + 0.6455961941913204, + 2.259586679669621, + 0.5926784733559664 ], [ - -0.11112721375424367, - -0.05820949291888954, - -0.05820949291888954 + -1.5981151692276947, + -1.5081550438075928, + -1.5081550438075928 ], [ - -0.25929683209323523, - -0.2063791112578811, - -0.05820949291888954 + 0.19050379500727488, + 0.2804639204273769, + -1.5081550438075928 ], [ - 0.04762594875181872, - 0.05820949291888954, - 1.2964841604661763 + 0.24342151584262903, + 0.21696265542495194, + 0.46038417126758097 ], [ - -0.2751721483438415, - -0.0740848091694958, - -0.24342151584262903 + 0.19050379500727488, + 0.3069227808450539, + 2.0902499729964883 ], [ - 0.13229430208838533, - 0.06879303708596038, - 0.05820949291888954 + 2.3072126284214405, + 0.4445088550169747, + 0.4445088550169747 ], [ - 0.2010873391743457, - 0.11641898583777908, - 0.08466835333656661 + 0.6403044221077849, + -1.2223993512966804, + 0.4445088550169747 ], [ - 1.2806088442155699, - 1.2911923883826408, - 1.2859006162991056 + 0.48684303168525805, + 0.45509239918404554, + 0.46038417126758097 ], [ - -0.1587531625060624, - 0.042334176668283305, - -0.24342151584262903 + 2.1431676938318422, + 2.259586679669621, + 2.0902499729964883 ], [ - 0.026458860417677067, - -0.05820949291888954, - 0.0793765812530312 + 0.3545487295968727, + -1.5081550438075928, + 0.4445088550169747 ], [ - -0.15346139042252696, - -0.21696265542495194, - 0.05820949291888954 + 2.1431676938318422, + 0.2804639204273769, + 0.4445088550169747 ] ], [ [ - 1.3758607417192075, - 1.3758607417192075, - 1.3758607417192075 + -0.756723407945564, + -0.756723407945564, + -0.756723407945564 ], [ - 1.3758607417192075, - 1.1218556817095076, - 1.1218556817095076 + -0.756723407945564, + -0.9842696075375869, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.3758607417192075, - 1.1218556817095076 + -0.9842696075375869, + -0.756723407945564, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.1218556817095076, - 1.3758607417192075 + -0.9842696075375869, + -0.9842696075375869, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.46038417126758097, - 1.3758607417192075 + 0.6032620175230371, + 0.6032620175230371, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.7143892312772808, - 1.1218556817095076 + 0.6032620175230371, + 0.37571581793101433, + -0.9842696075375869 ], [ - -0.7143892312772808, - -0.46038417126758097, - 1.1218556817095076 + 0.37571581793101433, + 0.6032620175230371, + -0.9842696075375869 ], [ - 0.11112721375424367, - 0.11112721375424367, - 1.3758607417192075 + 0.550344296687683, + 0.550344296687683, + -0.756723407945564 ], [ - -0.47096771543465177, - 1.3758607417192075, - -0.47096771543465177 + 0.6032620175230371, + -0.756723407945564, + 0.6032620175230371 ], [ - -0.47096771543465177, - 1.1218556817095076, - -0.7249727754443517 + 0.6032620175230371, + -0.9842696075375869, + 0.37571581793101433 ], [ - 0.08996012542010202, - 1.3758607417192075, - 0.08996012542010202 + 0.550344296687683, + -0.756723407945564, + 0.550344296687683 ], [ - -0.7249727754443517, - 1.1218556817095076, - -0.47096771543465177 + 0.37571581793101433, + -0.9842696075375869, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.45509239918404554, - -0.46038417126758097 + 1.9632474429916382, + 0.6032620175230371, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.7090974591937454, - -0.7090974591937454 + 1.9632474429916382, + 0.37571581793101433, + 0.37571581793101433 ], [ - -1.6986588388148676, - -0.4498006271005101, - 0.13229430208838533 + 1.910329722156284, + 0.6032620175230371, + 0.550344296687683 ], [ - -1.6986588388148676, - 0.13229430208838533, - -0.45509239918404554 + 1.910329722156284, + 0.550344296687683, + 0.6032620175230371 ], [ - 1.3758607417192075, - -0.47096771543465177, - -0.47096771543465177 + -0.756723407945564, + 0.6032620175230371, + 0.6032620175230371 ], [ - 1.3758607417192075, - 0.08996012542010202, - 0.08996012542010202 + -0.756723407945564, + 0.550344296687683, + 0.550344296687683 ], [ - 1.1218556817095076, - -0.47096771543465177, - -0.7249727754443517 + -0.9842696075375869, + 0.6032620175230371, + 0.37571581793101433 ], [ - 1.1218556817095076, - -0.7249727754443517, - -0.47096771543465177 + -0.9842696075375869, + 0.37571581793101433, + 0.6032620175230371 ], [ - -0.45509239918404554, - -2.2860455400872985, - -0.46038417126758097 + 0.6032620175230371, + 1.9632474429916382, + 0.6032620175230371 ], [ - -0.4498006271005101, - -1.6986588388148676, - 0.13229430208838533 + 0.6032620175230371, + 1.910329722156284, + 0.550344296687683 ], [ - -0.7090974591937454, - -2.2860455400872985, - -0.7090974591937454 + 0.37571581793101433, + 1.9632474429916382, + 0.37571581793101433 ], [ - 0.13229430208838533, - -1.6986588388148676, - -0.45509239918404554 + 0.550344296687683, + 1.910329722156284, + 0.6032620175230371 ], [ - -0.46038417126758097, - -0.46038417126758097, - -2.291337312170834 + 0.6032620175230371, + 0.6032620175230371, + 1.9632474429916382 ], [ - -0.45509239918404554, - 0.13229430208838533, - -1.6986588388148676 + 0.6032620175230371, + 0.550344296687683, + 1.910329722156284 ], [ - 0.13229430208838533, - -0.45509239918404554, - -1.6986588388148676 + 0.550344296687683, + 0.6032620175230371, + 1.910329722156284 ], [ - -0.7090974591937454, - -0.7090974591937454, - -2.2860455400872985 + 0.37571581793101433, + 0.37571581793101433, + 1.9632474429916382 ], [ - -2.3125044005049755, - -2.3125044005049755, - -2.3125044005049755 + 1.9632474429916382, + 1.9632474429916382, + 1.9632474429916382 ], [ - -2.3125044005049755, - -1.7515765596502217, - -1.756868331733757 + 1.9632474429916382, + 1.910329722156284, + 1.910329722156284 ], [ - -1.7515765596502217, - -2.3125044005049755, - -1.756868331733757 + 1.910329722156284, + 1.9632474429916382, + 1.910329722156284 ], [ - -1.73040947131608, - -1.73040947131608, - -2.317796172588511 + 1.910329722156284, + 1.910329722156284, + 1.9632474429916382 ], [ - 0.0740848091694958, - 0.19579556709081028, - 0.11641898583777908 + 0.4445088550169747, + 0.6403044221077849, + -1.2223993512966804 ], [ - 1.2964841604661763, - 0.04762594875181872, - 0.05820949291888954 + 0.45509239918404554, + 0.24342151584262903, + 0.21696265542495194 ], [ - 0.11641898583777908, - 0.2010873391743457, - 0.08466835333656661 + -1.2223993512966804, + 0.6403044221077849, + 0.4445088550169747 ], [ - -0.05820949291888954, - -0.11112721375424367, - -0.05820949291888954 + -1.5081550438075928, + -1.5981151692276947, + -1.5081550438075928 ], [ - -0.05820949291888954, - 0.06350126500242495, - 0.11112721375424367 + -1.5081550438075928, + -1.3123594767167825, + -1.2223993512966804 ], [ - 0.052917720835354135, - -1.190648718795468, - 0.052917720835354135 + 0.21696265542495194, + -0.0, + 0.21696265542495194 ], [ - -0.21696265542495194, - -0.15346139042252696, - 0.05820949291888954 + 0.2804639204273769, + 2.1431676938318422, + 0.4445088550169747 ], [ - 0.0793765812530312, - 0.026458860417677067, - -0.05820949291888954 + 0.4445088550169747, + 0.3545487295968727, + -1.5081550438075928 ], [ - 0.04762594875181872, - 0.19050379500727488, - 0.08466835333656661 + 2.254294907586086, + 0.6403044221077849, + 0.5926784733559664 ], [ - 0.021167088334141652, - 0.052917720835354135, - -1.2223993512966804 + 0.2804639204273769, + 0.24342151584262903, + 0.0370424045847479 ], [ - 0.08996012542010202, - 0.17462847875666865, - 0.026458860417677067 + 0.5926784733559664, + 0.6403044221077849, + 2.254294907586086 ], [ - -0.05820949291888954, - -0.11112721375424367, - -0.05820949291888954 + 0.30163100876151855, + -1.5981151692276947, + 0.30163100876151855 ], [ - -0.05820949291888954, - 0.06350126500242495, - 0.11641898583777908 + 0.30163100876151855, + -1.3123594767167825, + 0.5926784733559664 ], [ - -1.217107579213145, - -1.190648718795468, - -1.2223993512966804 + 0.0370424045847479, + -0.0, + 0.0370424045847479 ], [ - -0.24342151584262903, - -0.1587531625060624, - 0.0370424045847479 + 2.0902499729964883, + 2.1431676938318422, + 2.254294907586086 ], [ - 0.052917720835354135, - 0.015875316250606238, - -0.0740848091694958 + 2.259586679669621, + 0.3545487295968727, + 0.30163100876151855 ], [ - 0.0740848091694958, - -0.1481696183389916, - -0.22754619959202277 + 0.4445088550169747, + 2.1431676938318422, + 0.2804639204273769 ], [ - 1.2911923883826408, - 1.2806088442155699, - 1.2859006162991056 + 0.45509239918404554, + 0.48684303168525805, + 0.45509239918404554 ], [ - 0.11641898583777908, - 0.06350126500242495, - -0.05820949291888954 + -1.2223993512966804, + -1.3123594767167825, + -1.5081550438075928 ], [ - -0.05820949291888954, - 0.026458860417677067, - 0.0793765812530312 + -1.5081550438075928, + 0.3545487295968727, + 0.4445088550169747 ], [ - -0.052917720835354135, - -0.25929683209323523, - -0.2063791112578811 + -1.5081550438075928, + 0.19050379500727488, + 0.2804639204273769 ], [ - 0.05820949291888954, - 0.04762594875181872, - 1.2964841604661763 + 0.21696265542495194, + 0.24342151584262903, + 0.45509239918404554 ], [ - -0.2063791112578811, - -0.25929683209323523, - -0.05820949291888954 + 0.2804639204273769, + 0.19050379500727488, + -1.5081550438075928 ], [ - 0.06879303708596038, - 0.13229430208838533, - 0.05820949291888954 + 0.4445088550169747, + 2.3072126284214405, + 0.4445088550169747 ], [ - 0.042334176668283305, - -0.1587531625060624, - -0.24342151584262903 + 2.254294907586086, + 2.1431676938318422, + 2.0902499729964883 ], [ - 0.015875316250606238, - 1.2859006162991056, - 0.015875316250606238 + 0.2804639204273769, + 0.48684303168525805, + 0.2804639204273769 ], [ - 0.11641898583777908, - 0.06350126500242495, - -0.05820949291888954 + 0.5926784733559664, + -1.3123594767167825, + 0.30163100876151855 ], [ - -0.0740848091694958, - 0.010583544167070826, - 0.042334176668283305 + 0.30163100876151855, + 0.3545487295968727, + 2.254294907586086 ], [ - -0.0793765812530312, - -0.2751721483438415, - -0.24342151584262903 + 0.30163100876151855, + 0.19050379500727488, + 2.0902499729964883 ], [ - -1.2223993512966804, - 0.042334176668283305, - 0.010583544167070826 + 0.0370424045847479, + 0.24342151584262903, + 0.2804639204273769 ], [ - -0.23283797167555817, - -0.26458860417677066, - -0.0793765812530312 + 2.0902499729964883, + 0.19050379500727488, + 0.30163100876151855 ], [ - 0.0370424045847479, - 0.12171075792131451, - 0.0370424045847479 + 2.259586679669621, + 2.3072126284214405, + 2.254294907586086 ] ] ], "spreads": [ [ - 3.1895248182072504, - 3.188124675618046, - 3.188124675618046, - 3.1884047041358867, - 7.452118916780627, - 7.850599497668153, - 7.850599497668153, - 11.338074658858064, - 7.391072699891322, - 7.788713195225325, - 11.27058778605842, - 7.79011333781453, - 11.794521142938645, - 12.616404842801533, - 15.16382426959972, - 15.15094295777904, - 7.391072699891322, - 11.27058778605842, - 7.788713195225325, - 7.79011333781453, - 11.794521142938645, - 15.16382426959972, - 12.616404842801533, - 15.15094295777904, - 11.79256094331376, - 15.167464640331652, - 15.167464640331652, - 12.630686297211415, - 16.073076867028952, - 18.92264706457741, - 18.92264706457741, - 18.897444497971733, - 12.53967702891314, - 5.166806182681473, - 19.032138215053184, - 13.394604093881247, - 11.269747700504897, - 13.710476262005722, - 12.051587322316543, - 16.33658370231719, - 11.33583443071534, - 12.406943511456578, - 27.357106021943732, - 21.80750085537382, - 12.033385468656888, - 18.050078202985333, - 19.075542635318516, - 22.05868643587706, - 11.183778945527758, - 13.401044749791588, - 12.43718659138339, - 5.168486353788518, - 11.797041399599212, - 21.819542081640975, - 5.364506316277111, - 12.416744509581008, - 11.803762084027394, - 16.355065584494685, - 20.778676080826546, - 13.706835891273792, - 14.500156682316911, - 22.049725523306154, - 12.423185165491347, - 18.083681625126236 + 2.828848087228239, + 2.8008452354441546, + 2.8008452354441546, + 2.8008452354441546, + 9.642221954813893, + 10.086627212627318, + 10.086627212627318, + 7.921726741199729, + 9.642221954813893, + 10.086627212627318, + 7.921726741199729, + 10.086627212627318, + 14.239730160724923, + 15.156543528135858, + 12.280650649910356, + 12.280650649910356, + 9.642221954813893, + 7.921726741199729, + 10.086627212627318, + 10.086627212627318, + 14.239730160724923, + 12.280650649910356, + 15.156543528135858, + 12.280650649910356, + 14.239730160724923, + 12.280650649910356, + 12.280650649910356, + 15.156543528135858, + 16.62165273347917, + 14.4239889254642, + 14.4239889254642, + 14.4239889254642, + 19.9049871051631, + 9.114368198683897, + 8.25272044928761, + 8.81193739941578, + 17.981471216114322, + 8.230878224896024, + 8.648960802032407, + 10.078226357092094, + 17.98287135870353, + 10.158594541712416, + 9.906568875655655, + 9.346791868491799, + 13.679113068007547, + 9.874365596103956, + 8.25244042076977, + 11.216542282115137, + 17.756328287770284, + 8.806616857576806, + 7.9606507051796065, + 9.116328398308783, + 13.513616213963608, + 9.345671754420437, + 9.778875871520228, + 10.154114085426963, + 13.51445629951713, + 10.079346471163456, + 8.189153975737737, + 8.2300381393425, + 6.891501824063251, + 11.217382367668659, + 7.957290362965516, + 9.871285282407706 ], [ - 3.1895248182072504, - 3.188124675618046, - 3.188124675618046, - 3.1884047041358867, - 7.452118916780627, - 7.850599497668153, - 7.850599497668153, - 11.338074658858064, - 7.391072699891322, - 7.788713195225325, - 11.27058778605842, - 7.79011333781453, - 11.794521142938645, - 12.616404842801533, - 15.16382426959972, - 15.15094295777904, - 7.391072699891322, - 11.27058778605842, - 7.788713195225325, - 7.79011333781453, - 11.794521142938645, - 15.16382426959972, - 12.616404842801533, - 15.15094295777904, - 11.79256094331376, - 15.167464640331652, - 15.167464640331652, - 12.630686297211415, - 16.073076867028952, - 18.92264706457741, - 18.92264706457741, - 18.897444497971733, - 13.709916204970042, - 11.798161513670577, - 13.707115919791631, - 5.364506316277111, - 5.167366239717154, - 11.183778945527758, - 18.07192042737692, - 12.438306705454753, - 21.81086119758791, - 11.27058778605842, - 21.816181739426888, - 12.051867350834383, - 13.398244464613176, - 12.5393970003953, - 22.05504606514513, - 19.038578870963523, - 18.061279343698967, - 14.500436710834752, - 5.168206325270677, - 12.422065051419985, - 12.409183739599305, - 11.802641969956031, - 12.414224252920441, - 20.778396052308704, - 22.053085865520245, - 12.033665497174729, - 13.397964436095338, - 19.069101979408174, - 16.354505527459, - 11.334994345161816, - 16.337423787870712, - 27.356545964908047 + 2.828848087228239, + 2.8008452354441546, + 2.8008452354441546, + 2.8008452354441546, + 9.642221954813893, + 10.086627212627318, + 10.086627212627318, + 7.921726741199729, + 9.642221954813893, + 10.086627212627318, + 7.921726741199729, + 10.086627212627318, + 14.239730160724923, + 15.156543528135858, + 12.280650649910356, + 12.280650649910356, + 9.642221954813893, + 7.921726741199729, + 10.086627212627318, + 10.086627212627318, + 14.239730160724923, + 12.280650649910356, + 15.156543528135858, + 12.280650649910356, + 14.239730160724923, + 12.280650649910356, + 12.280650649910356, + 15.156543528135858, + 16.62165273347917, + 14.4239889254642, + 14.4239889254642, + 14.4239889254642, + 8.230598196378182, + 13.514176270999288, + 8.230598196378182, + 9.779155900038067, + 9.1157683412731, + 17.756328287770284, + 9.873525510550433, + 7.958410477036879, + 9.34651183997396, + 17.982311301667846, + 9.345951782938277, + 8.64924083055025, + 8.810537256826578, + 19.9049871051631, + 11.21710233915082, + 8.25272044928761, + 9.87240539647907, + 6.891221795545411, + 9.11520828423742, + 7.959810619626084, + 10.155514228016166, + 13.513896242481447, + 10.157474427641054, + 8.189434004255578, + 11.216822310632978, + 13.678833039489707, + 8.808577057201692, + 8.25300047780545, + 10.078506385609934, + 17.981751244632164, + 10.079066442645615, + 9.906568875655655 ] ], "self-Hartree": [ @@ -34197,7 +34197,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -34478,5 +34478,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_32-dft_n-1.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_32-dft_n-1.json index cff00bcb1..a928bd5ae 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_32-dft_n-1.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_32-dft_n-1.json @@ -5121,7 +5121,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -5402,5 +5402,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1.json index dabf42124..ae408fc2a 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1.json @@ -5184,7 +5184,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -5467,5 +5467,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1_dummy.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1_dummy.json index 76481db92..ce33b67e5 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1_dummy.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1_dummy.json @@ -5050,7 +5050,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -5333,5 +5333,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-pz_print.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-pz_print.json index cb1cfe638..72db0cef2 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-pz_print.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-pz_print.json @@ -443,781 +443,781 @@ "centres": [ [ [ - 1.3758607417192075, - 1.3758607417192075, - 1.3758607417192075 + -0.756723407945564, + -0.756723407945564, + -0.756723407945564 ], [ - 1.3758607417192075, - 1.1218556817095076, - 1.1218556817095076 + -0.756723407945564, + -0.9842696075375869, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.3758607417192075, - 1.1218556817095076 + -0.9842696075375869, + -0.756723407945564, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.1218556817095076, - 1.3758607417192075 + -0.9842696075375869, + -0.9842696075375869, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.46038417126758097, - 1.3758607417192075 + 0.6032620175230371, + 0.6032620175230371, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.7143892312772808, - 1.1218556817095076 + 0.6032620175230371, + 0.37571581793101433, + -0.9842696075375869 ], [ - -0.7143892312772808, - -0.46038417126758097, - 1.1218556817095076 + 0.37571581793101433, + 0.6032620175230371, + -0.9842696075375869 ], [ - 0.11112721375424367, - 0.11112721375424367, - 1.3758607417192075 + 0.550344296687683, + 0.550344296687683, + -0.756723407945564 ], [ - -0.47096771543465177, - 1.3758607417192075, - -0.47096771543465177 + 0.6032620175230371, + -0.756723407945564, + 0.6032620175230371 ], [ - -0.47096771543465177, - 1.1218556817095076, - -0.7249727754443517 + 0.6032620175230371, + -0.9842696075375869, + 0.37571581793101433 ], [ - 0.08996012542010202, - 1.3758607417192075, - 0.08996012542010202 + 0.550344296687683, + -0.756723407945564, + 0.550344296687683 ], [ - -0.7249727754443517, - 1.1218556817095076, - -0.47096771543465177 + 0.37571581793101433, + -0.9842696075375869, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.45509239918404554, - -0.46038417126758097 + 1.9632474429916382, + 0.6032620175230371, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.7090974591937454, - -0.7090974591937454 + 1.9632474429916382, + 0.37571581793101433, + 0.37571581793101433 ], [ - -1.6986588388148676, - -0.4498006271005101, - 0.13229430208838533 + 1.910329722156284, + 0.6032620175230371, + 0.550344296687683 ], [ - -1.6986588388148676, - 0.13229430208838533, - -0.45509239918404554 + 1.910329722156284, + 0.550344296687683, + 0.6032620175230371 ], [ - 1.3758607417192075, - -0.47096771543465177, - -0.47096771543465177 + -0.756723407945564, + 0.6032620175230371, + 0.6032620175230371 ], [ - 1.3758607417192075, - 0.08996012542010202, - 0.08996012542010202 + -0.756723407945564, + 0.550344296687683, + 0.550344296687683 ], [ - 1.1218556817095076, - -0.47096771543465177, - -0.7249727754443517 + -0.9842696075375869, + 0.6032620175230371, + 0.37571581793101433 ], [ - 1.1218556817095076, - -0.7249727754443517, - -0.47096771543465177 + -0.9842696075375869, + 0.37571581793101433, + 0.6032620175230371 ], [ - -0.45509239918404554, - -2.2860455400872985, - -0.46038417126758097 + 0.6032620175230371, + 1.9632474429916382, + 0.6032620175230371 ], [ - -0.4498006271005101, - -1.6986588388148676, - 0.13229430208838533 + 0.6032620175230371, + 1.910329722156284, + 0.550344296687683 ], [ - -0.7090974591937454, - -2.2860455400872985, - -0.7090974591937454 + 0.37571581793101433, + 1.9632474429916382, + 0.37571581793101433 ], [ - 0.13229430208838533, - -1.6986588388148676, - -0.45509239918404554 + 0.550344296687683, + 1.910329722156284, + 0.6032620175230371 ], [ - -0.46038417126758097, - -0.46038417126758097, - -2.291337312170834 + 0.6032620175230371, + 0.6032620175230371, + 1.9632474429916382 ], [ - -0.45509239918404554, - 0.13229430208838533, - -1.6986588388148676 + 0.6032620175230371, + 0.550344296687683, + 1.910329722156284 ], [ - 0.13229430208838533, - -0.45509239918404554, - -1.6986588388148676 + 0.550344296687683, + 0.6032620175230371, + 1.910329722156284 ], [ - -0.7090974591937454, - -0.7090974591937454, - -2.2860455400872985 + 0.37571581793101433, + 0.37571581793101433, + 1.9632474429916382 ], [ - -2.3125044005049755, - -2.3125044005049755, - -2.3125044005049755 + 1.9632474429916382, + 1.9632474429916382, + 1.9632474429916382 ], [ - -2.3125044005049755, - -1.7515765596502217, - -1.756868331733757 + 1.9632474429916382, + 1.910329722156284, + 1.910329722156284 ], [ - -1.7515765596502217, - -2.3125044005049755, - -1.756868331733757 + 1.910329722156284, + 1.9632474429916382, + 1.910329722156284 ], [ - -1.73040947131608, - -1.73040947131608, - -2.317796172588511 + 1.910329722156284, + 1.910329722156284, + 1.9632474429916382 ], [ - -1.190648718795468, - -1.217107579213145, - -1.217107579213145 + -0.0, + 0.0370424045847479, + 0.0370424045847479 ], [ - 0.06350126500242495, - -0.05820949291888954, - 0.11112721375424367 + -1.307067704633247, + -1.5081550438075928, + -1.2223993512966804 ], [ - 0.015875316250606238, - 0.052917720835354135, - -0.0740848091694958 + 0.3545487295968727, + 2.254294907586086, + 0.30163100876151855 ], [ - 0.06350126500242495, - 0.11641898583777908, - -0.05820949291888954 + -1.3123594767167825, + 0.5873867012724309, + 0.30163100876151855 ], [ - 0.052917720835354135, - 0.021167088334141652, - -1.2223993512966804 + 0.24342151584262903, + 0.2804639204273769, + 0.0370424045847479 ], [ - 0.19579556709081028, - 0.0740848091694958, - 0.11641898583777908 + 0.6455961941913204, + 0.4445088550169747, + -1.2223993512966804 ], [ - -0.11112721375424367, - -0.05820949291888954, - -0.05820949291888954 + -1.5981151692276947, + 0.3069227808450539, + 0.30163100876151855 ], [ - -0.26458860417677066, - -0.23283797167555817, - -0.0793765812530312 + 0.19050379500727488, + 2.0902499729964883, + 0.30163100876151855 ], [ - 0.042334176668283305, - -1.2223993512966804, - 0.010583544167070826 + 0.24342151584262903, + 0.0370424045847479, + 0.2804639204273769 ], [ - -0.26458860417677066, - -0.05820949291888954, - -0.21167088334141654 + 0.19050379500727488, + -1.5081550438075928, + 0.2804639204273769 ], [ - 0.12171075792131451, - 0.0370424045847479, - 0.0370424045847479 + 2.3072126284214405, + 2.254294907586086, + 2.259586679669621 ], [ - 0.16933670667313322, - 0.08466835333656661, - 0.026458860417677067 + 0.6403044221077849, + 0.5873867012724309, + 2.254294907586086 ], [ - 1.2859006162991056, - 0.015875316250606238, - 0.015875316250606238 + 0.48684303168525805, + 0.2804639204273769, + 0.2804639204273769 ], [ - -0.1481696183389916, - 0.0740848091694958, - -0.22754619959202277 + 2.1431676938318422, + 0.4445088550169747, + 0.2804639204273769 ], [ - 0.010583544167070826, - -0.0740848091694958, - 0.042334176668283305 + 0.3545487295968727, + 0.3069227808450539, + 2.259586679669621 ], [ - -0.1587531625060624, - -0.24342151584262903, - 0.0370424045847479 + 2.1431676938318422, + 2.0902499729964883, + 2.254294907586086 ], [ - -1.190648718795468, - 0.052917720835354135, - 0.052917720835354135 + -0.0, + 0.21696265542495194, + 0.21696265542495194 ], [ - 0.06350126500242495, - -0.05820949291888954, - 0.11641898583777908 + -1.307067704633247, + 0.3069227808450539, + 0.5926784733559664 ], [ - 0.026458860417677067, - 0.0793765812530312, - -0.05820949291888954 + 0.3545487295968727, + 0.4445088550169747, + -1.5081550438075928 ], [ - 0.06350126500242495, - 0.11641898583777908, - -0.05820949291888954 + -1.3123594767167825, + -1.2223993512966804, + -1.5081550438075928 ], [ - 0.04762594875181872, - 1.2964841604661763, - 0.05820949291888954 + 0.24342151584262903, + 0.45509239918404554, + 0.21696265542495194 ], [ - 0.19050379500727488, - 0.04762594875181872, - 0.08466835333656661 + 0.6455961941913204, + 2.259586679669621, + 0.5926784733559664 ], [ - -0.11112721375424367, - -0.05820949291888954, - -0.05820949291888954 + -1.5981151692276947, + -1.5081550438075928, + -1.5081550438075928 ], [ - -0.25929683209323523, - -0.2063791112578811, - -0.05820949291888954 + 0.19050379500727488, + 0.2804639204273769, + -1.5081550438075928 ], [ - 0.04762594875181872, - 0.05820949291888954, - 1.2964841604661763 + 0.24342151584262903, + 0.21696265542495194, + 0.46038417126758097 ], [ - -0.2751721483438415, - -0.0740848091694958, - -0.24342151584262903 + 0.19050379500727488, + 0.3069227808450539, + 2.0902499729964883 ], [ - 0.13229430208838533, - 0.06879303708596038, - 0.05820949291888954 + 2.3072126284214405, + 0.4445088550169747, + 0.4445088550169747 ], [ - 0.2010873391743457, - 0.11641898583777908, - 0.08466835333656661 + 0.6403044221077849, + -1.2223993512966804, + 0.4445088550169747 ], [ - 1.2806088442155699, - 1.2911923883826408, - 1.2859006162991056 + 0.48684303168525805, + 0.45509239918404554, + 0.46038417126758097 ], [ - -0.1587531625060624, - 0.042334176668283305, - -0.24342151584262903 + 2.1431676938318422, + 2.259586679669621, + 2.0902499729964883 ], [ - 0.026458860417677067, - -0.05820949291888954, - 0.0793765812530312 + 0.3545487295968727, + -1.5081550438075928, + 0.4445088550169747 ], [ - -0.15346139042252696, - -0.21696265542495194, - 0.05820949291888954 + 2.1431676938318422, + 0.2804639204273769, + 0.4445088550169747 ] ], [ [ - 1.3758607417192075, - 1.3758607417192075, - 1.3758607417192075 + -0.756723407945564, + -0.756723407945564, + -0.756723407945564 ], [ - 1.3758607417192075, - 1.1218556817095076, - 1.1218556817095076 + -0.756723407945564, + -0.9842696075375869, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.3758607417192075, - 1.1218556817095076 + -0.9842696075375869, + -0.756723407945564, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.1218556817095076, - 1.3758607417192075 + -0.9842696075375869, + -0.9842696075375869, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.46038417126758097, - 1.3758607417192075 + 0.6032620175230371, + 0.6032620175230371, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.7143892312772808, - 1.1218556817095076 + 0.6032620175230371, + 0.37571581793101433, + -0.9842696075375869 ], [ - -0.7143892312772808, - -0.46038417126758097, - 1.1218556817095076 + 0.37571581793101433, + 0.6032620175230371, + -0.9842696075375869 ], [ - 0.11112721375424367, - 0.11112721375424367, - 1.3758607417192075 + 0.550344296687683, + 0.550344296687683, + -0.756723407945564 ], [ - -0.47096771543465177, - 1.3758607417192075, - -0.47096771543465177 + 0.6032620175230371, + -0.756723407945564, + 0.6032620175230371 ], [ - -0.47096771543465177, - 1.1218556817095076, - -0.7249727754443517 + 0.6032620175230371, + -0.9842696075375869, + 0.37571581793101433 ], [ - 0.08996012542010202, - 1.3758607417192075, - 0.08996012542010202 + 0.550344296687683, + -0.756723407945564, + 0.550344296687683 ], [ - -0.7249727754443517, - 1.1218556817095076, - -0.47096771543465177 + 0.37571581793101433, + -0.9842696075375869, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.45509239918404554, - -0.46038417126758097 + 1.9632474429916382, + 0.6032620175230371, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.7090974591937454, - -0.7090974591937454 + 1.9632474429916382, + 0.37571581793101433, + 0.37571581793101433 ], [ - -1.6986588388148676, - -0.4498006271005101, - 0.13229430208838533 + 1.910329722156284, + 0.6032620175230371, + 0.550344296687683 ], [ - -1.6986588388148676, - 0.13229430208838533, - -0.45509239918404554 + 1.910329722156284, + 0.550344296687683, + 0.6032620175230371 ], [ - 1.3758607417192075, - -0.47096771543465177, - -0.47096771543465177 + -0.756723407945564, + 0.6032620175230371, + 0.6032620175230371 ], [ - 1.3758607417192075, - 0.08996012542010202, - 0.08996012542010202 + -0.756723407945564, + 0.550344296687683, + 0.550344296687683 ], [ - 1.1218556817095076, - -0.47096771543465177, - -0.7249727754443517 + -0.9842696075375869, + 0.6032620175230371, + 0.37571581793101433 ], [ - 1.1218556817095076, - -0.7249727754443517, - -0.47096771543465177 + -0.9842696075375869, + 0.37571581793101433, + 0.6032620175230371 ], [ - -0.45509239918404554, - -2.2860455400872985, - -0.46038417126758097 + 0.6032620175230371, + 1.9632474429916382, + 0.6032620175230371 ], [ - -0.4498006271005101, - -1.6986588388148676, - 0.13229430208838533 + 0.6032620175230371, + 1.910329722156284, + 0.550344296687683 ], [ - -0.7090974591937454, - -2.2860455400872985, - -0.7090974591937454 + 0.37571581793101433, + 1.9632474429916382, + 0.37571581793101433 ], [ - 0.13229430208838533, - -1.6986588388148676, - -0.45509239918404554 + 0.550344296687683, + 1.910329722156284, + 0.6032620175230371 ], [ - -0.46038417126758097, - -0.46038417126758097, - -2.291337312170834 + 0.6032620175230371, + 0.6032620175230371, + 1.9632474429916382 ], [ - -0.45509239918404554, - 0.13229430208838533, - -1.6986588388148676 + 0.6032620175230371, + 0.550344296687683, + 1.910329722156284 ], [ - 0.13229430208838533, - -0.45509239918404554, - -1.6986588388148676 + 0.550344296687683, + 0.6032620175230371, + 1.910329722156284 ], [ - -0.7090974591937454, - -0.7090974591937454, - -2.2860455400872985 + 0.37571581793101433, + 0.37571581793101433, + 1.9632474429916382 ], [ - -2.3125044005049755, - -2.3125044005049755, - -2.3125044005049755 + 1.9632474429916382, + 1.9632474429916382, + 1.9632474429916382 ], [ - -2.3125044005049755, - -1.7515765596502217, - -1.756868331733757 + 1.9632474429916382, + 1.910329722156284, + 1.910329722156284 ], [ - -1.7515765596502217, - -2.3125044005049755, - -1.756868331733757 + 1.910329722156284, + 1.9632474429916382, + 1.910329722156284 ], [ - -1.73040947131608, - -1.73040947131608, - -2.317796172588511 + 1.910329722156284, + 1.910329722156284, + 1.9632474429916382 ], [ - 0.0740848091694958, - 0.19579556709081028, - 0.11641898583777908 + 0.4445088550169747, + 0.6403044221077849, + -1.2223993512966804 ], [ - 1.2964841604661763, - 0.04762594875181872, - 0.05820949291888954 + 0.45509239918404554, + 0.24342151584262903, + 0.21696265542495194 ], [ - 0.11641898583777908, - 0.2010873391743457, - 0.08466835333656661 + -1.2223993512966804, + 0.6403044221077849, + 0.4445088550169747 ], [ - -0.05820949291888954, - -0.11112721375424367, - -0.05820949291888954 + -1.5081550438075928, + -1.5981151692276947, + -1.5081550438075928 ], [ - -0.05820949291888954, - 0.06350126500242495, - 0.11112721375424367 + -1.5081550438075928, + -1.3123594767167825, + -1.2223993512966804 ], [ - 0.052917720835354135, - -1.190648718795468, - 0.052917720835354135 + 0.21696265542495194, + -0.0, + 0.21696265542495194 ], [ - -0.21696265542495194, - -0.15346139042252696, - 0.05820949291888954 + 0.2804639204273769, + 2.1431676938318422, + 0.4445088550169747 ], [ - 0.0793765812530312, - 0.026458860417677067, - -0.05820949291888954 + 0.4445088550169747, + 0.3545487295968727, + -1.5081550438075928 ], [ - 0.04762594875181872, - 0.19050379500727488, - 0.08466835333656661 + 2.254294907586086, + 0.6403044221077849, + 0.5926784733559664 ], [ - 0.021167088334141652, - 0.052917720835354135, - -1.2223993512966804 + 0.2804639204273769, + 0.24342151584262903, + 0.0370424045847479 ], [ - 0.08996012542010202, - 0.17462847875666865, - 0.026458860417677067 + 0.5926784733559664, + 0.6403044221077849, + 2.254294907586086 ], [ - -0.05820949291888954, - -0.11112721375424367, - -0.05820949291888954 + 0.30163100876151855, + -1.5981151692276947, + 0.30163100876151855 ], [ - -0.05820949291888954, - 0.06350126500242495, - 0.11641898583777908 + 0.30163100876151855, + -1.3123594767167825, + 0.5926784733559664 ], [ - -1.217107579213145, - -1.190648718795468, - -1.2223993512966804 + 0.0370424045847479, + -0.0, + 0.0370424045847479 ], [ - -0.24342151584262903, - -0.1587531625060624, - 0.0370424045847479 + 2.0902499729964883, + 2.1431676938318422, + 2.254294907586086 ], [ - 0.052917720835354135, - 0.015875316250606238, - -0.0740848091694958 + 2.259586679669621, + 0.3545487295968727, + 0.30163100876151855 ], [ - 0.0740848091694958, - -0.1481696183389916, - -0.22754619959202277 + 0.4445088550169747, + 2.1431676938318422, + 0.2804639204273769 ], [ - 1.2911923883826408, - 1.2806088442155699, - 1.2859006162991056 + 0.45509239918404554, + 0.48684303168525805, + 0.45509239918404554 ], [ - 0.11641898583777908, - 0.06350126500242495, - -0.05820949291888954 + -1.2223993512966804, + -1.3123594767167825, + -1.5081550438075928 ], [ - -0.05820949291888954, - 0.026458860417677067, - 0.0793765812530312 + -1.5081550438075928, + 0.3545487295968727, + 0.4445088550169747 ], [ - -0.052917720835354135, - -0.25929683209323523, - -0.2063791112578811 + -1.5081550438075928, + 0.19050379500727488, + 0.2804639204273769 ], [ - 0.05820949291888954, - 0.04762594875181872, - 1.2964841604661763 + 0.21696265542495194, + 0.24342151584262903, + 0.45509239918404554 ], [ - -0.2063791112578811, - -0.25929683209323523, - -0.05820949291888954 + 0.2804639204273769, + 0.19050379500727488, + -1.5081550438075928 ], [ - 0.06879303708596038, - 0.13229430208838533, - 0.05820949291888954 + 0.4445088550169747, + 2.3072126284214405, + 0.4445088550169747 ], [ - 0.042334176668283305, - -0.1587531625060624, - -0.24342151584262903 + 2.254294907586086, + 2.1431676938318422, + 2.0902499729964883 ], [ - 0.015875316250606238, - 1.2859006162991056, - 0.015875316250606238 + 0.2804639204273769, + 0.48684303168525805, + 0.2804639204273769 ], [ - 0.11641898583777908, - 0.06350126500242495, - -0.05820949291888954 + 0.5926784733559664, + -1.3123594767167825, + 0.30163100876151855 ], [ - -0.0740848091694958, - 0.010583544167070826, - 0.042334176668283305 + 0.30163100876151855, + 0.3545487295968727, + 2.254294907586086 ], [ - -0.0793765812530312, - -0.2751721483438415, - -0.24342151584262903 + 0.30163100876151855, + 0.19050379500727488, + 2.0902499729964883 ], [ - -1.2223993512966804, - 0.042334176668283305, - 0.010583544167070826 + 0.0370424045847479, + 0.24342151584262903, + 0.2804639204273769 ], [ - -0.23283797167555817, - -0.26458860417677066, - -0.0793765812530312 + 2.0902499729964883, + 0.19050379500727488, + 0.30163100876151855 ], [ - 0.0370424045847479, - 0.12171075792131451, - 0.0370424045847479 + 2.259586679669621, + 2.3072126284214405, + 2.254294907586086 ] ] ], "spreads": [ [ - 3.1895248182072504, - 3.188124675618046, - 3.188124675618046, - 3.1884047041358867, - 7.452118916780627, - 7.850599497668153, - 7.850599497668153, - 11.338074658858064, - 7.391072699891322, - 7.788713195225325, - 11.27058778605842, - 7.79011333781453, - 11.794521142938645, - 12.616404842801533, - 15.16382426959972, - 15.15094295777904, - 7.391072699891322, - 11.27058778605842, - 7.788713195225325, - 7.79011333781453, - 11.794521142938645, - 15.16382426959972, - 12.616404842801533, - 15.15094295777904, - 11.79256094331376, - 15.167464640331652, - 15.167464640331652, - 12.630686297211415, - 16.073076867028952, - 18.92264706457741, - 18.92264706457741, - 18.897444497971733, - 12.53967702891314, - 5.166806182681473, - 19.032138215053184, - 13.394604093881247, - 11.269747700504897, - 13.710476262005722, - 12.051587322316543, - 16.33658370231719, - 11.33583443071534, - 12.406943511456578, - 27.357106021943732, - 21.80750085537382, - 12.033385468656888, - 18.050078202985333, - 19.075542635318516, - 22.05868643587706, - 11.183778945527758, - 13.401044749791588, - 12.43718659138339, - 5.168486353788518, - 11.797041399599212, - 21.819542081640975, - 5.364506316277111, - 12.416744509581008, - 11.803762084027394, - 16.355065584494685, - 20.778676080826546, - 13.706835891273792, - 14.500156682316911, - 22.049725523306154, - 12.423185165491347, - 18.083681625126236 + 2.828848087228239, + 2.8008452354441546, + 2.8008452354441546, + 2.8008452354441546, + 9.642221954813893, + 10.086627212627318, + 10.086627212627318, + 7.921726741199729, + 9.642221954813893, + 10.086627212627318, + 7.921726741199729, + 10.086627212627318, + 14.239730160724923, + 15.156543528135858, + 12.280650649910356, + 12.280650649910356, + 9.642221954813893, + 7.921726741199729, + 10.086627212627318, + 10.086627212627318, + 14.239730160724923, + 12.280650649910356, + 15.156543528135858, + 12.280650649910356, + 14.239730160724923, + 12.280650649910356, + 12.280650649910356, + 15.156543528135858, + 16.62165273347917, + 14.4239889254642, + 14.4239889254642, + 14.4239889254642, + 19.9049871051631, + 9.114368198683897, + 8.25272044928761, + 8.81193739941578, + 17.981471216114322, + 8.230878224896024, + 8.648960802032407, + 10.078226357092094, + 17.98287135870353, + 10.158594541712416, + 9.906568875655655, + 9.346791868491799, + 13.679113068007547, + 9.874365596103956, + 8.25244042076977, + 11.216542282115137, + 17.756328287770284, + 8.806616857576806, + 7.9606507051796065, + 9.116328398308783, + 13.513616213963608, + 9.345671754420437, + 9.778875871520228, + 10.154114085426963, + 13.51445629951713, + 10.079346471163456, + 8.189153975737737, + 8.2300381393425, + 6.891501824063251, + 11.217382367668659, + 7.957290362965516, + 9.871285282407706 ], [ - 3.1895248182072504, - 3.188124675618046, - 3.188124675618046, - 3.1884047041358867, - 7.452118916780627, - 7.850599497668153, - 7.850599497668153, - 11.338074658858064, - 7.391072699891322, - 7.788713195225325, - 11.27058778605842, - 7.79011333781453, - 11.794521142938645, - 12.616404842801533, - 15.16382426959972, - 15.15094295777904, - 7.391072699891322, - 11.27058778605842, - 7.788713195225325, - 7.79011333781453, - 11.794521142938645, - 15.16382426959972, - 12.616404842801533, - 15.15094295777904, - 11.79256094331376, - 15.167464640331652, - 15.167464640331652, - 12.630686297211415, - 16.073076867028952, - 18.92264706457741, - 18.92264706457741, - 18.897444497971733, - 13.709916204970042, - 11.798161513670577, - 13.707115919791631, - 5.364506316277111, - 5.167366239717154, - 11.183778945527758, - 18.07192042737692, - 12.438306705454753, - 21.81086119758791, - 11.27058778605842, - 21.816181739426888, - 12.051867350834383, - 13.398244464613176, - 12.5393970003953, - 22.05504606514513, - 19.038578870963523, - 18.061279343698967, - 14.500436710834752, - 5.168206325270677, - 12.422065051419985, - 12.409183739599305, - 11.802641969956031, - 12.414224252920441, - 20.778396052308704, - 22.053085865520245, - 12.033665497174729, - 13.397964436095338, - 19.069101979408174, - 16.354505527459, - 11.334994345161816, - 16.337423787870712, - 27.356545964908047 + 2.828848087228239, + 2.8008452354441546, + 2.8008452354441546, + 2.8008452354441546, + 9.642221954813893, + 10.086627212627318, + 10.086627212627318, + 7.921726741199729, + 9.642221954813893, + 10.086627212627318, + 7.921726741199729, + 10.086627212627318, + 14.239730160724923, + 15.156543528135858, + 12.280650649910356, + 12.280650649910356, + 9.642221954813893, + 7.921726741199729, + 10.086627212627318, + 10.086627212627318, + 14.239730160724923, + 12.280650649910356, + 15.156543528135858, + 12.280650649910356, + 14.239730160724923, + 12.280650649910356, + 12.280650649910356, + 15.156543528135858, + 16.62165273347917, + 14.4239889254642, + 14.4239889254642, + 14.4239889254642, + 8.230598196378182, + 13.514176270999288, + 8.230598196378182, + 9.779155900038067, + 9.1157683412731, + 17.756328287770284, + 9.873525510550433, + 7.958410477036879, + 9.34651183997396, + 17.982311301667846, + 9.345951782938277, + 8.64924083055025, + 8.810537256826578, + 19.9049871051631, + 11.21710233915082, + 8.25272044928761, + 9.87240539647907, + 6.891221795545411, + 9.11520828423742, + 7.959810619626084, + 10.155514228016166, + 13.513896242481447, + 10.157474427641054, + 8.189434004255578, + 11.216822310632978, + 13.678833039489707, + 8.808577057201692, + 8.25300047780545, + 10.078506385609934, + 17.981751244632164, + 10.079066442645615, + 9.906568875655655 ] ], "self-Hartree": [ @@ -34197,7 +34197,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -34478,5 +34478,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-final-ki_final.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-final-ki_final.json index 76b8882cc..021885166 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-final-ki_final.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-final-ki_final.json @@ -441,781 +441,781 @@ "centres": [ [ [ - 1.3758607417192075, - 1.3758607417192075, - 1.3758607417192075 + -0.756723407945564, + -0.756723407945564, + -0.756723407945564 ], [ - 1.3758607417192075, - 1.1218556817095076, - 1.1218556817095076 + -0.756723407945564, + -0.9842696075375869, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.3758607417192075, - 1.1218556817095076 + -0.9842696075375869, + -0.756723407945564, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.1218556817095076, - 1.3758607417192075 + -0.9842696075375869, + -0.9842696075375869, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.46038417126758097, - 1.3758607417192075 + 0.6032620175230371, + 0.6032620175230371, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.7143892312772808, - 1.1218556817095076 + 0.6032620175230371, + 0.37571581793101433, + -0.9842696075375869 ], [ - -0.7143892312772808, - -0.46038417126758097, - 1.1218556817095076 + 0.37571581793101433, + 0.6032620175230371, + -0.9842696075375869 ], [ - 0.11112721375424367, - 0.11112721375424367, - 1.3758607417192075 + 0.550344296687683, + 0.550344296687683, + -0.756723407945564 ], [ - -0.47096771543465177, - 1.3758607417192075, - -0.47096771543465177 + 0.6032620175230371, + -0.756723407945564, + 0.6032620175230371 ], [ - -0.47096771543465177, - 1.1218556817095076, - -0.7249727754443517 + 0.6032620175230371, + -0.9842696075375869, + 0.37571581793101433 ], [ - 0.08996012542010202, - 1.3758607417192075, - 0.08996012542010202 + 0.550344296687683, + -0.756723407945564, + 0.550344296687683 ], [ - -0.7249727754443517, - 1.1218556817095076, - -0.47096771543465177 + 0.37571581793101433, + -0.9842696075375869, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.45509239918404554, - -0.46038417126758097 + 1.9632474429916382, + 0.6032620175230371, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.7090974591937454, - -0.7090974591937454 + 1.9632474429916382, + 0.37571581793101433, + 0.37571581793101433 ], [ - -1.6986588388148676, - -0.4498006271005101, - 0.13229430208838533 + 1.910329722156284, + 0.6032620175230371, + 0.550344296687683 ], [ - -1.6986588388148676, - 0.13229430208838533, - -0.45509239918404554 + 1.910329722156284, + 0.550344296687683, + 0.6032620175230371 ], [ - 1.3758607417192075, - -0.47096771543465177, - -0.47096771543465177 + -0.756723407945564, + 0.6032620175230371, + 0.6032620175230371 ], [ - 1.3758607417192075, - 0.08996012542010202, - 0.08996012542010202 + -0.756723407945564, + 0.550344296687683, + 0.550344296687683 ], [ - 1.1218556817095076, - -0.47096771543465177, - -0.7249727754443517 + -0.9842696075375869, + 0.6032620175230371, + 0.37571581793101433 ], [ - 1.1218556817095076, - -0.7249727754443517, - -0.47096771543465177 + -0.9842696075375869, + 0.37571581793101433, + 0.6032620175230371 ], [ - -0.45509239918404554, - -2.2860455400872985, - -0.46038417126758097 + 0.6032620175230371, + 1.9632474429916382, + 0.6032620175230371 ], [ - -0.4498006271005101, - -1.6986588388148676, - 0.13229430208838533 + 0.6032620175230371, + 1.910329722156284, + 0.550344296687683 ], [ - -0.7090974591937454, - -2.2860455400872985, - -0.7090974591937454 + 0.37571581793101433, + 1.9632474429916382, + 0.37571581793101433 ], [ - 0.13229430208838533, - -1.6986588388148676, - -0.45509239918404554 + 0.550344296687683, + 1.910329722156284, + 0.6032620175230371 ], [ - -0.46038417126758097, - -0.46038417126758097, - -2.291337312170834 + 0.6032620175230371, + 0.6032620175230371, + 1.9632474429916382 ], [ - -0.45509239918404554, - 0.13229430208838533, - -1.6986588388148676 + 0.6032620175230371, + 0.550344296687683, + 1.910329722156284 ], [ - 0.13229430208838533, - -0.45509239918404554, - -1.6986588388148676 + 0.550344296687683, + 0.6032620175230371, + 1.910329722156284 ], [ - -0.7090974591937454, - -0.7090974591937454, - -2.2860455400872985 + 0.37571581793101433, + 0.37571581793101433, + 1.9632474429916382 ], [ - -2.3125044005049755, - -2.3125044005049755, - -2.3125044005049755 + 1.9632474429916382, + 1.9632474429916382, + 1.9632474429916382 ], [ - -2.3125044005049755, - -1.7515765596502217, - -1.756868331733757 + 1.9632474429916382, + 1.910329722156284, + 1.910329722156284 ], [ - -1.7515765596502217, - -2.3125044005049755, - -1.756868331733757 + 1.910329722156284, + 1.9632474429916382, + 1.910329722156284 ], [ - -1.73040947131608, - -1.73040947131608, - -2.317796172588511 + 1.910329722156284, + 1.910329722156284, + 1.9632474429916382 ], [ - -1.190648718795468, - -1.217107579213145, - -1.217107579213145 + -0.0, + 0.0370424045847479, + 0.0370424045847479 ], [ - 0.06350126500242495, - -0.05820949291888954, - 0.11112721375424367 + -1.307067704633247, + -1.5081550438075928, + -1.2223993512966804 ], [ - 0.015875316250606238, - 0.052917720835354135, - -0.0740848091694958 + 0.3545487295968727, + 2.254294907586086, + 0.30163100876151855 ], [ - 0.06350126500242495, - 0.11641898583777908, - -0.05820949291888954 + -1.3123594767167825, + 0.5873867012724309, + 0.30163100876151855 ], [ - 0.052917720835354135, - 0.021167088334141652, - -1.2223993512966804 + 0.24342151584262903, + 0.2804639204273769, + 0.0370424045847479 ], [ - 0.19579556709081028, - 0.0740848091694958, - 0.11641898583777908 + 0.6455961941913204, + 0.4445088550169747, + -1.2223993512966804 ], [ - -0.11112721375424367, - -0.05820949291888954, - -0.05820949291888954 + -1.5981151692276947, + 0.3069227808450539, + 0.30163100876151855 ], [ - -0.26458860417677066, - -0.23283797167555817, - -0.0793765812530312 + 0.19050379500727488, + 2.0902499729964883, + 0.30163100876151855 ], [ - 0.042334176668283305, - -1.2223993512966804, - 0.010583544167070826 + 0.24342151584262903, + 0.0370424045847479, + 0.2804639204273769 ], [ - -0.26458860417677066, - -0.05820949291888954, - -0.21167088334141654 + 0.19050379500727488, + -1.5081550438075928, + 0.2804639204273769 ], [ - 0.12171075792131451, - 0.0370424045847479, - 0.0370424045847479 + 2.3072126284214405, + 2.254294907586086, + 2.259586679669621 ], [ - 0.16933670667313322, - 0.08466835333656661, - 0.026458860417677067 + 0.6403044221077849, + 0.5873867012724309, + 2.254294907586086 ], [ - 1.2859006162991056, - 0.015875316250606238, - 0.015875316250606238 + 0.48684303168525805, + 0.2804639204273769, + 0.2804639204273769 ], [ - -0.1481696183389916, - 0.0740848091694958, - -0.22754619959202277 + 2.1431676938318422, + 0.4445088550169747, + 0.2804639204273769 ], [ - 0.010583544167070826, - -0.0740848091694958, - 0.042334176668283305 + 0.3545487295968727, + 0.3069227808450539, + 2.259586679669621 ], [ - -0.1587531625060624, - -0.24342151584262903, - 0.0370424045847479 + 2.1431676938318422, + 2.0902499729964883, + 2.254294907586086 ], [ - -1.190648718795468, - 0.052917720835354135, - 0.052917720835354135 + -0.0, + 0.21696265542495194, + 0.21696265542495194 ], [ - 0.06350126500242495, - -0.05820949291888954, - 0.11641898583777908 + -1.307067704633247, + 0.3069227808450539, + 0.5926784733559664 ], [ - 0.026458860417677067, - 0.0793765812530312, - -0.05820949291888954 + 0.3545487295968727, + 0.4445088550169747, + -1.5081550438075928 ], [ - 0.06350126500242495, - 0.11641898583777908, - -0.05820949291888954 + -1.3123594767167825, + -1.2223993512966804, + -1.5081550438075928 ], [ - 0.04762594875181872, - 1.2964841604661763, - 0.05820949291888954 + 0.24342151584262903, + 0.45509239918404554, + 0.21696265542495194 ], [ - 0.19050379500727488, - 0.04762594875181872, - 0.08466835333656661 + 0.6455961941913204, + 2.259586679669621, + 0.5926784733559664 ], [ - -0.11112721375424367, - -0.05820949291888954, - -0.05820949291888954 + -1.5981151692276947, + -1.5081550438075928, + -1.5081550438075928 ], [ - -0.25929683209323523, - -0.2063791112578811, - -0.05820949291888954 + 0.19050379500727488, + 0.2804639204273769, + -1.5081550438075928 ], [ - 0.04762594875181872, - 0.05820949291888954, - 1.2964841604661763 + 0.24342151584262903, + 0.21696265542495194, + 0.46038417126758097 ], [ - -0.2751721483438415, - -0.0740848091694958, - -0.24342151584262903 + 0.19050379500727488, + 0.3069227808450539, + 2.0902499729964883 ], [ - 0.13229430208838533, - 0.06879303708596038, - 0.05820949291888954 + 2.3072126284214405, + 0.4445088550169747, + 0.4445088550169747 ], [ - 0.2010873391743457, - 0.11641898583777908, - 0.08466835333656661 + 0.6403044221077849, + -1.2223993512966804, + 0.4445088550169747 ], [ - 1.2806088442155699, - 1.2911923883826408, - 1.2859006162991056 + 0.48684303168525805, + 0.45509239918404554, + 0.46038417126758097 ], [ - -0.1587531625060624, - 0.042334176668283305, - -0.24342151584262903 + 2.1431676938318422, + 2.259586679669621, + 2.0902499729964883 ], [ - 0.026458860417677067, - -0.05820949291888954, - 0.0793765812530312 + 0.3545487295968727, + -1.5081550438075928, + 0.4445088550169747 ], [ - -0.15346139042252696, - -0.21696265542495194, - 0.05820949291888954 + 2.1431676938318422, + 0.2804639204273769, + 0.4445088550169747 ] ], [ [ - 1.3758607417192075, - 1.3758607417192075, - 1.3758607417192075 + -0.756723407945564, + -0.756723407945564, + -0.756723407945564 ], [ - 1.3758607417192075, - 1.1218556817095076, - 1.1218556817095076 + -0.756723407945564, + -0.9842696075375869, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.3758607417192075, - 1.1218556817095076 + -0.9842696075375869, + -0.756723407945564, + -0.9842696075375869 ], [ - 1.1218556817095076, - 1.1218556817095076, - 1.3758607417192075 + -0.9842696075375869, + -0.9842696075375869, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.46038417126758097, - 1.3758607417192075 + 0.6032620175230371, + 0.6032620175230371, + -0.756723407945564 ], [ - -0.46038417126758097, - -0.7143892312772808, - 1.1218556817095076 + 0.6032620175230371, + 0.37571581793101433, + -0.9842696075375869 ], [ - -0.7143892312772808, - -0.46038417126758097, - 1.1218556817095076 + 0.37571581793101433, + 0.6032620175230371, + -0.9842696075375869 ], [ - 0.11112721375424367, - 0.11112721375424367, - 1.3758607417192075 + 0.550344296687683, + 0.550344296687683, + -0.756723407945564 ], [ - -0.47096771543465177, - 1.3758607417192075, - -0.47096771543465177 + 0.6032620175230371, + -0.756723407945564, + 0.6032620175230371 ], [ - -0.47096771543465177, - 1.1218556817095076, - -0.7249727754443517 + 0.6032620175230371, + -0.9842696075375869, + 0.37571581793101433 ], [ - 0.08996012542010202, - 1.3758607417192075, - 0.08996012542010202 + 0.550344296687683, + -0.756723407945564, + 0.550344296687683 ], [ - -0.7249727754443517, - 1.1218556817095076, - -0.47096771543465177 + 0.37571581793101433, + -0.9842696075375869, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.45509239918404554, - -0.46038417126758097 + 1.9632474429916382, + 0.6032620175230371, + 0.6032620175230371 ], [ - -2.2860455400872985, - -0.7090974591937454, - -0.7090974591937454 + 1.9632474429916382, + 0.37571581793101433, + 0.37571581793101433 ], [ - -1.6986588388148676, - -0.4498006271005101, - 0.13229430208838533 + 1.910329722156284, + 0.6032620175230371, + 0.550344296687683 ], [ - -1.6986588388148676, - 0.13229430208838533, - -0.45509239918404554 + 1.910329722156284, + 0.550344296687683, + 0.6032620175230371 ], [ - 1.3758607417192075, - -0.47096771543465177, - -0.47096771543465177 + -0.756723407945564, + 0.6032620175230371, + 0.6032620175230371 ], [ - 1.3758607417192075, - 0.08996012542010202, - 0.08996012542010202 + -0.756723407945564, + 0.550344296687683, + 0.550344296687683 ], [ - 1.1218556817095076, - -0.47096771543465177, - -0.7249727754443517 + -0.9842696075375869, + 0.6032620175230371, + 0.37571581793101433 ], [ - 1.1218556817095076, - -0.7249727754443517, - -0.47096771543465177 + -0.9842696075375869, + 0.37571581793101433, + 0.6032620175230371 ], [ - -0.45509239918404554, - -2.2860455400872985, - -0.46038417126758097 + 0.6032620175230371, + 1.9632474429916382, + 0.6032620175230371 ], [ - -0.4498006271005101, - -1.6986588388148676, - 0.13229430208838533 + 0.6032620175230371, + 1.910329722156284, + 0.550344296687683 ], [ - -0.7090974591937454, - -2.2860455400872985, - -0.7090974591937454 + 0.37571581793101433, + 1.9632474429916382, + 0.37571581793101433 ], [ - 0.13229430208838533, - -1.6986588388148676, - -0.45509239918404554 + 0.550344296687683, + 1.910329722156284, + 0.6032620175230371 ], [ - -0.46038417126758097, - -0.46038417126758097, - -2.291337312170834 + 0.6032620175230371, + 0.6032620175230371, + 1.9632474429916382 ], [ - -0.45509239918404554, - 0.13229430208838533, - -1.6986588388148676 + 0.6032620175230371, + 0.550344296687683, + 1.910329722156284 ], [ - 0.13229430208838533, - -0.45509239918404554, - -1.6986588388148676 + 0.550344296687683, + 0.6032620175230371, + 1.910329722156284 ], [ - -0.7090974591937454, - -0.7090974591937454, - -2.2860455400872985 + 0.37571581793101433, + 0.37571581793101433, + 1.9632474429916382 ], [ - -2.3125044005049755, - -2.3125044005049755, - -2.3125044005049755 + 1.9632474429916382, + 1.9632474429916382, + 1.9632474429916382 ], [ - -2.3125044005049755, - -1.7515765596502217, - -1.756868331733757 + 1.9632474429916382, + 1.910329722156284, + 1.910329722156284 ], [ - -1.7515765596502217, - -2.3125044005049755, - -1.756868331733757 + 1.910329722156284, + 1.9632474429916382, + 1.910329722156284 ], [ - -1.73040947131608, - -1.73040947131608, - -2.317796172588511 + 1.910329722156284, + 1.910329722156284, + 1.9632474429916382 ], [ - 0.0740848091694958, - 0.19579556709081028, - 0.11641898583777908 + 0.4445088550169747, + 0.6403044221077849, + -1.2223993512966804 ], [ - 1.2964841604661763, - 0.04762594875181872, - 0.05820949291888954 + 0.45509239918404554, + 0.24342151584262903, + 0.21696265542495194 ], [ - 0.11641898583777908, - 0.2010873391743457, - 0.08466835333656661 + -1.2223993512966804, + 0.6403044221077849, + 0.4445088550169747 ], [ - -0.05820949291888954, - -0.11112721375424367, - -0.05820949291888954 + -1.5081550438075928, + -1.5981151692276947, + -1.5081550438075928 ], [ - -0.05820949291888954, - 0.06350126500242495, - 0.11112721375424367 + -1.5081550438075928, + -1.3123594767167825, + -1.2223993512966804 ], [ - 0.052917720835354135, - -1.190648718795468, - 0.052917720835354135 + 0.21696265542495194, + -0.0, + 0.21696265542495194 ], [ - -0.21696265542495194, - -0.15346139042252696, - 0.05820949291888954 + 0.2804639204273769, + 2.1431676938318422, + 0.4445088550169747 ], [ - 0.0793765812530312, - 0.026458860417677067, - -0.05820949291888954 + 0.4445088550169747, + 0.3545487295968727, + -1.5081550438075928 ], [ - 0.04762594875181872, - 0.19050379500727488, - 0.08466835333656661 + 2.254294907586086, + 0.6403044221077849, + 0.5926784733559664 ], [ - 0.021167088334141652, - 0.052917720835354135, - -1.2223993512966804 + 0.2804639204273769, + 0.24342151584262903, + 0.0370424045847479 ], [ - 0.08996012542010202, - 0.17462847875666865, - 0.026458860417677067 + 0.5926784733559664, + 0.6403044221077849, + 2.254294907586086 ], [ - -0.05820949291888954, - -0.11112721375424367, - -0.05820949291888954 + 0.30163100876151855, + -1.5981151692276947, + 0.30163100876151855 ], [ - -0.05820949291888954, - 0.06350126500242495, - 0.11641898583777908 + 0.30163100876151855, + -1.3123594767167825, + 0.5926784733559664 ], [ - -1.217107579213145, - -1.190648718795468, - -1.2223993512966804 + 0.0370424045847479, + -0.0, + 0.0370424045847479 ], [ - -0.24342151584262903, - -0.1587531625060624, - 0.0370424045847479 + 2.0902499729964883, + 2.1431676938318422, + 2.254294907586086 ], [ - 0.052917720835354135, - 0.015875316250606238, - -0.0740848091694958 + 2.259586679669621, + 0.3545487295968727, + 0.30163100876151855 ], [ - 0.0740848091694958, - -0.1481696183389916, - -0.22754619959202277 + 0.4445088550169747, + 2.1431676938318422, + 0.2804639204273769 ], [ - 1.2911923883826408, - 1.2806088442155699, - 1.2859006162991056 + 0.45509239918404554, + 0.48684303168525805, + 0.45509239918404554 ], [ - 0.11641898583777908, - 0.06350126500242495, - -0.05820949291888954 + -1.2223993512966804, + -1.3123594767167825, + -1.5081550438075928 ], [ - -0.05820949291888954, - 0.026458860417677067, - 0.0793765812530312 + -1.5081550438075928, + 0.3545487295968727, + 0.4445088550169747 ], [ - -0.052917720835354135, - -0.25929683209323523, - -0.2063791112578811 + -1.5081550438075928, + 0.19050379500727488, + 0.2804639204273769 ], [ - 0.05820949291888954, - 0.04762594875181872, - 1.2964841604661763 + 0.21696265542495194, + 0.24342151584262903, + 0.45509239918404554 ], [ - -0.2063791112578811, - -0.25929683209323523, - -0.05820949291888954 + 0.2804639204273769, + 0.19050379500727488, + -1.5081550438075928 ], [ - 0.06879303708596038, - 0.13229430208838533, - 0.05820949291888954 + 0.4445088550169747, + 2.3072126284214405, + 0.4445088550169747 ], [ - 0.042334176668283305, - -0.1587531625060624, - -0.24342151584262903 + 2.254294907586086, + 2.1431676938318422, + 2.0902499729964883 ], [ - 0.015875316250606238, - 1.2859006162991056, - 0.015875316250606238 + 0.2804639204273769, + 0.48684303168525805, + 0.2804639204273769 ], [ - 0.11641898583777908, - 0.06350126500242495, - -0.05820949291888954 + 0.5926784733559664, + -1.3123594767167825, + 0.30163100876151855 ], [ - -0.0740848091694958, - 0.010583544167070826, - 0.042334176668283305 + 0.30163100876151855, + 0.3545487295968727, + 2.254294907586086 ], [ - -0.0793765812530312, - -0.2751721483438415, - -0.24342151584262903 + 0.30163100876151855, + 0.19050379500727488, + 2.0902499729964883 ], [ - -1.2223993512966804, - 0.042334176668283305, - 0.010583544167070826 + 0.0370424045847479, + 0.24342151584262903, + 0.2804639204273769 ], [ - -0.23283797167555817, - -0.26458860417677066, - -0.0793765812530312 + 2.0902499729964883, + 0.19050379500727488, + 0.30163100876151855 ], [ - 0.0370424045847479, - 0.12171075792131451, - 0.0370424045847479 + 2.259586679669621, + 2.3072126284214405, + 2.254294907586086 ] ] ], "spreads": [ [ - 3.1895248182072504, - 3.188124675618046, - 3.188124675618046, - 3.1884047041358867, - 7.452118916780627, - 7.850599497668153, - 7.850599497668153, - 11.338074658858064, - 7.391072699891322, - 7.788713195225325, - 11.27058778605842, - 7.79011333781453, - 11.794521142938645, - 12.616404842801533, - 15.16382426959972, - 15.15094295777904, - 7.391072699891322, - 11.27058778605842, - 7.788713195225325, - 7.79011333781453, - 11.794521142938645, - 15.16382426959972, - 12.616404842801533, - 15.15094295777904, - 11.79256094331376, - 15.167464640331652, - 15.167464640331652, - 12.630686297211415, - 16.073076867028952, - 18.92264706457741, - 18.92264706457741, - 18.897444497971733, - 12.53967702891314, - 5.166806182681473, - 19.032138215053184, - 13.394604093881247, - 11.269747700504897, - 13.710476262005722, - 12.051587322316543, - 16.33658370231719, - 11.33583443071534, - 12.406943511456578, - 27.357106021943732, - 21.80750085537382, - 12.033385468656888, - 18.050078202985333, - 19.075542635318516, - 22.05868643587706, - 11.183778945527758, - 13.401044749791588, - 12.43718659138339, - 5.168486353788518, - 11.797041399599212, - 21.819542081640975, - 5.364506316277111, - 12.416744509581008, - 11.803762084027394, - 16.355065584494685, - 20.778676080826546, - 13.706835891273792, - 14.500156682316911, - 22.049725523306154, - 12.423185165491347, - 18.083681625126236 + 2.828848087228239, + 2.8008452354441546, + 2.8008452354441546, + 2.8008452354441546, + 9.642221954813893, + 10.086627212627318, + 10.086627212627318, + 7.921726741199729, + 9.642221954813893, + 10.086627212627318, + 7.921726741199729, + 10.086627212627318, + 14.239730160724923, + 15.156543528135858, + 12.280650649910356, + 12.280650649910356, + 9.642221954813893, + 7.921726741199729, + 10.086627212627318, + 10.086627212627318, + 14.239730160724923, + 12.280650649910356, + 15.156543528135858, + 12.280650649910356, + 14.239730160724923, + 12.280650649910356, + 12.280650649910356, + 15.156543528135858, + 16.62165273347917, + 14.4239889254642, + 14.4239889254642, + 14.4239889254642, + 19.9049871051631, + 9.114368198683897, + 8.25272044928761, + 8.81193739941578, + 17.981471216114322, + 8.230878224896024, + 8.648960802032407, + 10.078226357092094, + 17.98287135870353, + 10.158594541712416, + 9.906568875655655, + 9.346791868491799, + 13.679113068007547, + 9.874365596103956, + 8.25244042076977, + 11.216542282115137, + 17.756328287770284, + 8.806616857576806, + 7.9606507051796065, + 9.116328398308783, + 13.513616213963608, + 9.345671754420437, + 9.778875871520228, + 10.154114085426963, + 13.51445629951713, + 10.079346471163456, + 8.189153975737737, + 8.2300381393425, + 6.891501824063251, + 11.217382367668659, + 7.957290362965516, + 9.871285282407706 ], [ - 3.1895248182072504, - 3.188124675618046, - 3.188124675618046, - 3.1884047041358867, - 7.452118916780627, - 7.850599497668153, - 7.850599497668153, - 11.338074658858064, - 7.391072699891322, - 7.788713195225325, - 11.27058778605842, - 7.79011333781453, - 11.794521142938645, - 12.616404842801533, - 15.16382426959972, - 15.15094295777904, - 7.391072699891322, - 11.27058778605842, - 7.788713195225325, - 7.79011333781453, - 11.794521142938645, - 15.16382426959972, - 12.616404842801533, - 15.15094295777904, - 11.79256094331376, - 15.167464640331652, - 15.167464640331652, - 12.630686297211415, - 16.073076867028952, - 18.92264706457741, - 18.92264706457741, - 18.897444497971733, - 13.709916204970042, - 11.798161513670577, - 13.707115919791631, - 5.364506316277111, - 5.167366239717154, - 11.183778945527758, - 18.07192042737692, - 12.438306705454753, - 21.81086119758791, - 11.27058778605842, - 21.816181739426888, - 12.051867350834383, - 13.398244464613176, - 12.5393970003953, - 22.05504606514513, - 19.038578870963523, - 18.061279343698967, - 14.500436710834752, - 5.168206325270677, - 12.422065051419985, - 12.409183739599305, - 11.802641969956031, - 12.414224252920441, - 20.778396052308704, - 22.053085865520245, - 12.033665497174729, - 13.397964436095338, - 19.069101979408174, - 16.354505527459, - 11.334994345161816, - 16.337423787870712, - 27.356545964908047 + 2.828848087228239, + 2.8008452354441546, + 2.8008452354441546, + 2.8008452354441546, + 9.642221954813893, + 10.086627212627318, + 10.086627212627318, + 7.921726741199729, + 9.642221954813893, + 10.086627212627318, + 7.921726741199729, + 10.086627212627318, + 14.239730160724923, + 15.156543528135858, + 12.280650649910356, + 12.280650649910356, + 9.642221954813893, + 7.921726741199729, + 10.086627212627318, + 10.086627212627318, + 14.239730160724923, + 12.280650649910356, + 15.156543528135858, + 12.280650649910356, + 14.239730160724923, + 12.280650649910356, + 12.280650649910356, + 15.156543528135858, + 16.62165273347917, + 14.4239889254642, + 14.4239889254642, + 14.4239889254642, + 8.230598196378182, + 13.514176270999288, + 8.230598196378182, + 9.779155900038067, + 9.1157683412731, + 17.756328287770284, + 9.873525510550433, + 7.958410477036879, + 9.34651183997396, + 17.982311301667846, + 9.345951782938277, + 8.64924083055025, + 8.810537256826578, + 19.9049871051631, + 11.21710233915082, + 8.25272044928761, + 9.87240539647907, + 6.891221795545411, + 9.11520828423742, + 7.959810619626084, + 10.155514228016166, + 13.513896242481447, + 10.157474427641054, + 8.189434004255578, + 11.216822310632978, + 13.678833039489707, + 8.808577057201692, + 8.25300047780545, + 10.078506385609934, + 17.981751244632164, + 10.079066442645615, + 9.906568875655655 ] ], "self-Hartree": [ @@ -34195,7 +34195,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -34476,5 +34476,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_dummy.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_dummy.json index bea6d90d5..418adc69b 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_dummy.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_dummy.json @@ -4909,7 +4909,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -5056,5 +5056,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_init.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_init.json index e43577d04..bd132ba7a 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_init.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_init.json @@ -17808,7 +17808,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -17955,5 +17955,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-pw2wan.json index 873b757b6..fa2ddc400 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-pw2wan.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-w2kcp.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-w2kcp.json index c11ff84bf..10e3ea043 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-w2kcp.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-w2kcp.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "wann2kcp.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWann2KCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-wann.json index 438399027..ddcf22ed0 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-wann.json @@ -164,7 +164,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -175,5 +175,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-wann_preproc.json index 29a460fc9..9b806492d 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_down-wann_preproc.json @@ -137,7 +137,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -148,5 +148,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-pw2wan.json index bfdc27669..77b537502 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-pw2wan.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-w2kcp.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-w2kcp.json index 92e155f22..98ceb8440 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-w2kcp.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-w2kcp.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "wann2kcp.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWann2KCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-wann.json index ba1e7dff9..7e0e39525 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-wann.json @@ -164,7 +164,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -175,5 +175,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-wann_preproc.json index 9dd856df0..8ee8ddfa9 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-emp_up-wann_preproc.json @@ -137,7 +137,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -148,5 +148,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-nscf.json index 0701969ad..e613b2863 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-nscf.json @@ -114,7 +114,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -607,5 +607,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-pw2wan.json index b569746f3..748a4ba25 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-pw2wan.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-w2kcp.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-w2kcp.json index 31ac2e967..e09ea1658 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-w2kcp.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-w2kcp.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "wann2kcp.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWann2KCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-wann.json index d69746254..7928fc263 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-wann.json @@ -163,7 +163,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -174,5 +174,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-wann_preproc.json index 0eed13dad..aeb1aa163 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_down-wann_preproc.json @@ -136,7 +136,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -147,5 +147,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-pw2wan.json index a9a437c7d..fba32f796 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-pw2wan.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-w2kcp.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-w2kcp.json index b8aca3240..58c43d2c0 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-w2kcp.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-w2kcp.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../../bin" + "__path__": "../../../../../../../../../usr/local/bin" }, "executable": "wann2kcp.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWann2KCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-wann.json index fa5ad4dce..dcd655b50 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-wann.json @@ -163,7 +163,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -174,5 +174,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-wann_preproc.json index 266a09e05..2cf4722ea 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-occ_up-wann_preproc.json @@ -136,7 +136,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -147,5 +147,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-scf.json index 70e377108..d392c64c8 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-scf.json @@ -123,7 +123,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -280,5 +280,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-emp_down-ki.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-emp_down-ki.json index 9b3d983c6..879365dbb 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-emp_down-ki.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-emp_down-ki.json @@ -8631,5 +8631,5 @@ ], "command": null, "__koopmans_name__": "BenchGenUnfoldAndInterpolateCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-emp_up-ki.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-emp_up-ki.json index b8c0612ae..512be7dcd 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-emp_up-ki.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-emp_up-ki.json @@ -8631,5 +8631,5 @@ ], "command": null, "__koopmans_name__": "BenchGenUnfoldAndInterpolateCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-occ_down-ki.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-occ_down-ki.json index 2aafdca21..a3149059e 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-occ_down-ki.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-occ_down-ki.json @@ -8631,5 +8631,5 @@ ], "command": null, "__koopmans_name__": "BenchGenUnfoldAndInterpolateCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-occ_up-ki.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-occ_up-ki.json index 7b7d9730a..e795dab5b 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-occ_up-ki.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-occ_up-ki.json @@ -8631,5 +8631,5 @@ ], "command": null, "__koopmans_name__": "BenchGenUnfoldAndInterpolateCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-pdos-projwfc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-pdos-projwfc.json index 36bf1733e..578219feb 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-pdos-projwfc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-pdos-projwfc.json @@ -39882,7 +39882,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "projwfc.x", "_flags": "", @@ -39900,5 +39900,5 @@ }, "spin_polarized": true, "__koopmans_name__": "BenchGenProjwfcCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-bands.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-bands.json index 1f57fe098..44cd311b8 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-bands.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-bands.json @@ -1660,7 +1660,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -4673,5 +4673,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_down-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_down-pw2wan.json index 873b757b6..fa2ddc400 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_down-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_down-pw2wan.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_down-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_down-wann.json index e0f2291cb..834ba6fd4 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_down-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_down-wann.json @@ -1594,7 +1594,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -1605,5 +1605,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_down-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_down-wann_preproc.json index ff433a084..e9c40ff0b 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_down-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_down-wann_preproc.json @@ -305,7 +305,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -316,5 +316,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_up-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_up-pw2wan.json index bfdc27669..77b537502 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_up-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_up-pw2wan.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_up-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_up-wann.json index 948cb3061..e0b5ee779 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_up-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_up-wann.json @@ -1594,7 +1594,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -1605,5 +1605,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_up-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_up-wann_preproc.json index f5d440c05..82eae23a6 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_up-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-emp_up-wann_preproc.json @@ -305,7 +305,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -316,5 +316,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-nscf.json index cedc48aeb..51b1be396 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-nscf.json @@ -114,7 +114,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -3967,5 +3967,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_down-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_down-pw2wan.json index b569746f3..748a4ba25 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_down-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_down-pw2wan.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_down-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_down-wann.json index cf4c5a2a9..5d97908d6 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_down-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_down-wann.json @@ -1593,7 +1593,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -1604,5 +1604,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_down-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_down-wann_preproc.json index d472648c8..90514f8c4 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_down-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_down-wann_preproc.json @@ -304,7 +304,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -315,5 +315,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_up-pw2wan.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_up-pw2wan.json index a9a437c7d..fba32f796 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_up-pw2wan.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_up-pw2wan.json @@ -83,7 +83,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -94,5 +94,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_up-wann.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_up-wann.json index 129ad420b..6ed26227b 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_up-wann.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_up-wann.json @@ -1593,7 +1593,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -1604,5 +1604,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_up-wann_preproc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_up-wann_preproc.json index 6f29f02d8..bc935510c 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_up-wann_preproc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-occ_up-wann_preproc.json @@ -304,7 +304,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -315,5 +315,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-scf.json index 70e377108..d392c64c8 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-scf.json @@ -123,7 +123,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -280,5 +280,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_ui_si0-si_ui.json b/tests/benchmarks/test_ui_si0-si_ui.json index d0a365c4b..4e5286061 100644 --- a/tests/benchmarks/test_ui_si0-si_ui.json +++ b/tests/benchmarks/test_ui_si0-si_ui.json @@ -6749,5 +6749,5 @@ ], "command": null, "__koopmans_name__": "BenchGenUnfoldAndInterpolateCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-pdos-projwfc.json b/tests/benchmarks/test_wannierize_tio20-pdos-projwfc.json index f6ae9fb23..722ac32bd 100644 --- a/tests/benchmarks/test_wannierize_tio20-pdos-projwfc.json +++ b/tests/benchmarks/test_wannierize_tio20-pdos-projwfc.json @@ -246858,7 +246858,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "projwfc.x", "_flags": "", @@ -246877,5 +246877,5 @@ }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-bands.json b/tests/benchmarks/test_wannierize_tio20-wannier-bands.json index 8997c8d9c..c5922a230 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-bands.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-bands.json @@ -961,7 +961,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -1730,5 +1730,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-emp-pw2wan.json b/tests/benchmarks/test_wannierize_tio20-wannier-emp-pw2wan.json index c8498af1d..3c660c4a9 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-emp-pw2wan.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-emp-pw2wan.json @@ -121,7 +121,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -132,5 +132,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-emp-wann.json b/tests/benchmarks/test_wannierize_tio20-wannier-emp-wann.json index df32439eb..9c35259ca 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-emp-wann.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-emp-wann.json @@ -3702,7 +3702,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -3713,5 +3713,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-emp-wann_preproc.json b/tests/benchmarks/test_wannierize_tio20-wannier-emp-wann_preproc.json index cd000dfb7..2aa735e80 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-emp-wann_preproc.json @@ -171,7 +171,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -182,5 +182,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-nscf.json b/tests/benchmarks/test_wannierize_tio20-wannier-nscf.json index c38fe63db..4796e1eae 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-nscf.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-nscf.json @@ -155,7 +155,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -600,5 +600,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block1-pw2wan.json b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block1-pw2wan.json index a97b70de8..3389e389b 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block1-pw2wan.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block1-pw2wan.json @@ -121,7 +121,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -132,5 +132,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block1-wann.json b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block1-wann.json index d1ed1e1ca..cfbf699ee 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block1-wann.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block1-wann.json @@ -2045,7 +2045,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -2056,5 +2056,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block1-wann_preproc.json b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block1-wann_preproc.json index d06a4ddb3..42e104a61 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block1-wann_preproc.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block1-wann_preproc.json @@ -170,7 +170,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -181,5 +181,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block2-pw2wan.json b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block2-pw2wan.json index e93c12f46..b7396fb4f 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block2-pw2wan.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block2-pw2wan.json @@ -121,7 +121,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -132,5 +132,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block2-wann.json b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block2-wann.json index e0032b360..93ec5ffbf 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block2-wann.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block2-wann.json @@ -2873,7 +2873,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -2884,5 +2884,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block2-wann_preproc.json b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block2-wann_preproc.json index 1c8e689dc..0283812d0 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block2-wann_preproc.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block2-wann_preproc.json @@ -170,7 +170,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -181,5 +181,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block3-pw2wan.json b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block3-pw2wan.json index 45ab84ed2..919898109 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block3-pw2wan.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block3-pw2wan.json @@ -121,7 +121,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -132,5 +132,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block3-wann.json b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block3-wann.json index 2811c3af6..58621d268 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block3-wann.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block3-wann.json @@ -2459,7 +2459,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -2470,5 +2470,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block3-wann_preproc.json b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block3-wann_preproc.json index a19396cb1..786cf7a03 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block3-wann_preproc.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block3-wann_preproc.json @@ -170,7 +170,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -181,5 +181,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block4-pw2wan.json b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block4-pw2wan.json index 756afdab1..c7dc836d1 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block4-pw2wan.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block4-pw2wan.json @@ -121,7 +121,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -132,5 +132,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block4-wann.json b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block4-wann.json index fec5af139..775440862 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block4-wann.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block4-wann.json @@ -4115,7 +4115,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -4126,5 +4126,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block4-wann_preproc.json b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block4-wann_preproc.json index 22932f046..4c728192f 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-occ_block4-wann_preproc.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-occ_block4-wann_preproc.json @@ -170,7 +170,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -181,5 +181,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-scf.json b/tests/benchmarks/test_wannierize_tio20-wannier-scf.json index 955cefce4..f3c231ffa 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-scf.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-scf.json @@ -152,7 +152,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -429,5 +429,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-ki.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-ki.json index 2f1ce6120..592105bfd 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-ki.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-ki.json @@ -183,133 +183,133 @@ "centres": [ [ [ - 0.43921708293343925, - -0.7090974591937454, - 1.7621601038172927 + 0.26458860417677066, + -0.8202246729479891, + -0.6244291058571787 ], [ - 0.0, - -0.7514316358620287, - 0.34396518542980187 + 0.26458860417677066, + -0.8202246729479891, + -0.5133018921029351 ], [ - 0.3069227808450539, - -0.6455961941913204, - -0.9895613796211223 + 0.26458860417677066, + -0.8202246729479891, + -0.47096771543465177 ], [ - 0.6879303708596037, - 0.0, - 2.3495468050897235 + 0.26458860417677066, + -0.8202246729479891, + -0.7090974591937454 ], [ - -0.0, - -0.8519753054492015, - -1.8785790896550716 + 0.26458860417677066, + -0.8202246729479891, + -0.2963392366779832 ], [ - 0.5926784733559664, - -0.8678506216998078, - 1.2118158071296097 + 0.26458860417677066, + -0.8202246729479891, + -0.7620151800290995 ], [ - 0.0, - 0.0, - -3.148604389703571 + 0.26458860417677066, + -0.8202246729479891, + -0.2963392366779832 ], [ - -0.0, - -0.9048930262845556, - -1.6827835225642616 + 0.26458860417677066, + -0.8202246729479891, + -0.32808986917919564 ], [ - 0.21167088334141654, - -0.8890177100339494, - -0.1481696183389916 + 0.26458860417677066, + -0.8202246729479891, + -0.3598405016804081 ], [ - 0.4286335387663685, - 0.0, - -0.883725937950414 + 0.26458860417677066, + -0.8202246729479891, + -0.47096771543465177 ] ], [ [ - 0.43921708293343925, - -0.7090974591937454, - 1.7621601038172927 + 0.26458860417677066, + -0.8202246729479891, + -0.6244291058571787 ], [ - 0.0, - -0.7514316358620287, - 0.34396518542980187 + 0.26458860417677066, + -0.8202246729479891, + -0.5133018921029351 ], [ - 0.3069227808450539, - -0.6455961941913204, - -0.9895613796211223 + 0.26458860417677066, + -0.8202246729479891, + -0.47096771543465177 ], [ - 0.6879303708596037, - 0.0, - 2.3495468050897235 + 0.26458860417677066, + -0.8202246729479891, + -0.7090974591937454 ], [ - -0.0, - -0.8519753054492015, - -1.8785790896550716 + 0.26458860417677066, + -0.8202246729479891, + -0.2963392366779832 ], [ - 0.5926784733559664, - -0.8678506216998078, - 1.2118158071296097 + 0.26458860417677066, + -0.8202246729479891, + -0.7620151800290995 ], [ - 0.0, - 0.0, - -3.148604389703571 + 0.26458860417677066, + -0.8202246729479891, + -0.2963392366779832 ], [ - -0.0, - -0.9048930262845556, - -1.6827835225642616 + 0.26458860417677066, + -0.8202246729479891, + -0.32808986917919564 ], [ - 0.21167088334141654, - -0.8890177100339494, - -0.1481696183389916 + 0.26458860417677066, + -0.8202246729479891, + -0.3598405016804081 ], [ - 0.4286335387663685, - 0.0, - -0.883725937950414 + 0.26458860417677066, + -0.8202246729479891, + -0.47096771543465177 ] ] ], "spreads": [ [ - 108.88264850650312, - 107.85102344677743, - 103.54222464276032, - 103.55286572643827, - 99.65010827329039, - 105.88382310894548, - 92.88097891152358, - 100.32945745757229, - 103.65507613545017, - 104.3215440079114 + 0.639865163266336, + 1.1016321891858931, + 1.637326743815434, + 0.9263343370175227, + 1.8134646815373268, + 1.314733891262778, + 1.7403772383808658, + 1.8319465637148227, + 1.6944525614549668, + 1.543797218856591 ], [ - 108.88264850650312, - 107.85102344677743, - 103.54222464276032, - 103.55286572643827, - 99.65010827329039, - 105.88382310894548, - 92.88097891152358, - 100.32945745757229, - 103.65507613545017, - 104.3215440079114 + 0.639865163266336, + 1.1016321891858931, + 1.637326743815434, + 0.9263343370175227, + 1.8134646815373268, + 1.314733891262778, + 1.7403772383808658, + 1.8319465637148227, + 1.6944525614549668, + 1.543797218856591 ] ], "self-Hartree": [ @@ -1213,7 +1213,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -1278,5 +1278,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_1-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_1-dft_n-1.json index 8ad84fd46..09ff92506 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_1-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_1-dft_n-1.json @@ -774,7 +774,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -839,5 +839,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1.json index 147c148cf..c582b78d1 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1.json @@ -865,7 +865,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -932,5 +932,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1_dummy.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1_dummy.json index f155e8a88..eea740c33 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1_dummy.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1_dummy.json @@ -731,7 +731,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -798,5 +798,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-pz_print.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-pz_print.json index e5d155daf..b3330feb8 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-pz_print.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-pz_print.json @@ -186,133 +186,133 @@ "centres": [ [ [ - 0.43921708293343925, - -0.7090974591937454, - 1.7621601038172927 + 0.26458860417677066, + -0.8202246729479891, + -0.6244291058571787 ], [ - 0.0, - -0.7514316358620287, - 0.34396518542980187 + 0.26458860417677066, + -0.8202246729479891, + -0.5133018921029351 ], [ - 0.3069227808450539, - -0.6455961941913204, - -0.9895613796211223 + 0.26458860417677066, + -0.8202246729479891, + -0.47096771543465177 ], [ - 0.6879303708596037, - 0.0, - 2.3495468050897235 + 0.26458860417677066, + -0.8202246729479891, + -0.7090974591937454 ], [ - -0.0, - -0.8519753054492015, - -1.8785790896550716 + 0.26458860417677066, + -0.8202246729479891, + -0.2963392366779832 ], [ - 0.5926784733559664, - -0.8678506216998078, - 1.2118158071296097 + 0.26458860417677066, + -0.8202246729479891, + -0.7620151800290995 ], [ - 0.0, - 0.0, - -3.148604389703571 + 0.26458860417677066, + -0.8202246729479891, + -0.2963392366779832 ], [ - -0.0, - -0.9048930262845556, - -1.6827835225642616 + 0.26458860417677066, + -0.8202246729479891, + -0.32808986917919564 ], [ - 0.21167088334141654, - -0.8890177100339494, - -0.1481696183389916 + 0.26458860417677066, + -0.8202246729479891, + -0.3598405016804081 ], [ - 0.4286335387663685, - 0.0, - -0.883725937950414 + 0.26458860417677066, + -0.8202246729479891, + -0.47096771543465177 ] ], [ [ - 0.43921708293343925, - -0.7090974591937454, - 1.7621601038172927 + 0.26458860417677066, + -0.8202246729479891, + -0.6244291058571787 ], [ - 0.0, - -0.7514316358620287, - 0.34396518542980187 + 0.26458860417677066, + -0.8202246729479891, + -0.5133018921029351 ], [ - 0.3069227808450539, - -0.6455961941913204, - -0.9895613796211223 + 0.26458860417677066, + -0.8202246729479891, + -0.47096771543465177 ], [ - 0.6879303708596037, - 0.0, - 2.3495468050897235 + 0.26458860417677066, + -0.8202246729479891, + -0.7090974591937454 ], [ - -0.0, - -0.8519753054492015, - -1.8785790896550716 + 0.26458860417677066, + -0.8202246729479891, + -0.2963392366779832 ], [ - 0.5926784733559664, - -0.8678506216998078, - 1.2118158071296097 + 0.26458860417677066, + -0.8202246729479891, + -0.7620151800290995 ], [ - 0.0, - 0.0, - -3.148604389703571 + 0.26458860417677066, + -0.8202246729479891, + -0.2963392366779832 ], [ - -0.0, - -0.9048930262845556, - -1.6827835225642616 + 0.26458860417677066, + -0.8202246729479891, + -0.32808986917919564 ], [ - 0.21167088334141654, - -0.8890177100339494, - -0.1481696183389916 + 0.26458860417677066, + -0.8202246729479891, + -0.3598405016804081 ], [ - 0.4286335387663685, - 0.0, - -0.883725937950414 + 0.26458860417677066, + -0.8202246729479891, + -0.47096771543465177 ] ] ], "spreads": [ [ - 108.88264850650312, - 107.85102344677743, - 103.54222464276032, - 103.55286572643827, - 99.65010827329039, - 105.88382310894548, - 92.88097891152358, - 100.32945745757229, - 103.65507613545017, - 104.3215440079114 + 0.639865163266336, + 1.1016321891858931, + 1.637326743815434, + 0.9263343370175227, + 1.8134646815373268, + 1.314733891262778, + 1.7403772383808658, + 1.8319465637148227, + 1.6944525614549668, + 1.543797218856591 ], [ - 108.88264850650312, - 107.85102344677743, - 103.54222464276032, - 103.55286572643827, - 99.65010827329039, - 105.88382310894548, - 92.88097891152358, - 100.32945745757229, - 103.65507613545017, - 104.3215440079114 + 0.639865163266336, + 1.1016321891858931, + 1.637326743815434, + 0.9263343370175227, + 1.8134646815373268, + 1.314733891262778, + 1.7403772383808658, + 1.8319465637148227, + 1.6944525614549668, + 1.543797218856591 ] ], "self-Hartree": [ @@ -1216,7 +1216,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -1281,5 +1281,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_2-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_2-dft_n-1.json index 1b26ec33d..87beaf891 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_2-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_2-dft_n-1.json @@ -792,7 +792,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -857,5 +857,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_3-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_3-dft_n-1.json index efa7be66a..66a594777 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_3-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_3-dft_n-1.json @@ -768,7 +768,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -833,5 +833,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_4-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_4-dft_n-1.json index 6b2287f95..82271c7b7 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_4-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_4-dft_n-1.json @@ -774,7 +774,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -839,5 +839,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_5-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_5-dft_n-1.json index 5d5121198..acf8d6069 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_5-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_5-dft_n-1.json @@ -780,7 +780,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -845,5 +845,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_6-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_6-dft_n-1.json index 7e21238e9..799af256c 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_6-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_6-dft_n-1.json @@ -780,7 +780,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -845,5 +845,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_7-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_7-dft_n-1.json index 23ad738ae..ecd3888fe 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_7-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_7-dft_n-1.json @@ -780,7 +780,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -845,5 +845,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_8-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_8-dft_n-1.json index cc1027e11..7f6f114ab 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_8-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_8-dft_n-1.json @@ -780,7 +780,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -845,5 +845,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_9-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_9-dft_n-1.json index f01b6d0c9..185a68a29 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_9-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_9-dft_n-1.json @@ -768,7 +768,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -833,5 +833,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-final-ki_final.json b/tests/benchmarks/tutorials-tutorial_1-final-ki_final.json index 855b75268..c0d770071 100644 --- a/tests/benchmarks/tutorials-tutorial_1-final-ki_final.json +++ b/tests/benchmarks/tutorials-tutorial_1-final-ki_final.json @@ -184,133 +184,133 @@ "centres": [ [ [ - 0.43921708293343925, - -0.7090974591937454, - 1.7621601038172927 + 0.26458860417677066, + -0.8202246729479891, + -0.6244291058571787 ], [ - 0.0, - -0.7514316358620287, - 0.34396518542980187 + 0.26458860417677066, + -0.8202246729479891, + -0.5133018921029351 ], [ - 0.3069227808450539, - -0.6455961941913204, - -0.9895613796211223 + 0.26458860417677066, + -0.8202246729479891, + -0.47096771543465177 ], [ - 0.6879303708596037, - 0.0, - 2.3495468050897235 + 0.26458860417677066, + -0.8202246729479891, + -0.7090974591937454 ], [ - -0.0, - -0.8519753054492015, - -1.8785790896550716 + 0.26458860417677066, + -0.8202246729479891, + -0.2963392366779832 ], [ - 0.5926784733559664, - -0.8678506216998078, - 1.2118158071296097 + 0.26458860417677066, + -0.8202246729479891, + -0.7620151800290995 ], [ - 0.0, - 0.0, - -3.148604389703571 + 0.26458860417677066, + -0.8202246729479891, + -0.2963392366779832 ], [ - -0.0, - -0.9048930262845556, - -1.6827835225642616 + 0.26458860417677066, + -0.8202246729479891, + -0.32808986917919564 ], [ - 0.21167088334141654, - -0.8890177100339494, - -0.1481696183389916 + 0.26458860417677066, + -0.8202246729479891, + -0.3598405016804081 ], [ - 0.4286335387663685, - 0.0, - -0.883725937950414 + 0.26458860417677066, + -0.8202246729479891, + -0.47096771543465177 ] ], [ [ - 0.43921708293343925, - -0.7090974591937454, - 1.7621601038172927 + 0.26458860417677066, + -0.8202246729479891, + -0.6244291058571787 ], [ - 0.0, - -0.7514316358620287, - 0.34396518542980187 + 0.26458860417677066, + -0.8202246729479891, + -0.5133018921029351 ], [ - 0.3069227808450539, - -0.6455961941913204, - -0.9895613796211223 + 0.26458860417677066, + -0.8202246729479891, + -0.47096771543465177 ], [ - 0.6879303708596037, - 0.0, - 2.3495468050897235 + 0.26458860417677066, + -0.8202246729479891, + -0.7090974591937454 ], [ - -0.0, - -0.8519753054492015, - -1.8785790896550716 + 0.26458860417677066, + -0.8202246729479891, + -0.2963392366779832 ], [ - 0.5926784733559664, - -0.8678506216998078, - 1.2118158071296097 + 0.26458860417677066, + -0.8202246729479891, + -0.7620151800290995 ], [ - 0.0, - 0.0, - -3.148604389703571 + 0.26458860417677066, + -0.8202246729479891, + -0.2963392366779832 ], [ - -0.0, - -0.9048930262845556, - -1.6827835225642616 + 0.26458860417677066, + -0.8202246729479891, + -0.32808986917919564 ], [ - 0.21167088334141654, - -0.8890177100339494, - -0.1481696183389916 + 0.26458860417677066, + -0.8202246729479891, + -0.3598405016804081 ], [ - 0.4286335387663685, - 0.0, - -0.883725937950414 + 0.26458860417677066, + -0.8202246729479891, + -0.47096771543465177 ] ] ], "spreads": [ [ - 108.88264850650312, - 107.85102344677743, - 103.54222464276032, - 103.55286572643827, - 99.65010827329039, - 105.88382310894548, - 92.88097891152358, - 100.32945745757229, - 103.65507613545017, - 104.3215440079114 + 0.639865163266336, + 1.1016321891858931, + 1.637326743815434, + 0.9263343370175227, + 1.8134646815373268, + 1.314733891262778, + 1.7403772383808658, + 1.8319465637148227, + 1.6944525614549668, + 1.543797218856591 ], [ - 108.88264850650312, - 107.85102344677743, - 103.54222464276032, - 103.55286572643827, - 99.65010827329039, - 105.88382310894548, - 92.88097891152358, - 100.32945745757229, - 103.65507613545017, - 104.3215440079114 + 0.639865163266336, + 1.1016321891858931, + 1.637326743815434, + 0.9263343370175227, + 1.8134646815373268, + 1.314733891262778, + 1.7403772383808658, + 1.8319465637148227, + 1.6944525614549668, + 1.543797218856591 ] ], "self-Hartree": [ @@ -1214,7 +1214,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -1279,5 +1279,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin1.json b/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin1.json index 9323c2174..6635a5196 100644 --- a/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin1.json +++ b/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin1.json @@ -1036,7 +1036,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -1077,5 +1077,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2.json b/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2.json index 6cb197001..5eec78ede 100644 --- a/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2.json +++ b/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2.json @@ -833,7 +833,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -872,5 +872,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2_dummy.json b/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2_dummy.json index de3d6537f..63035a1e2 100644 --- a/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2_dummy.json +++ b/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2_dummy.json @@ -787,7 +787,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -826,5 +826,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-2x2x2-pdos-projwfc.json b/tests/benchmarks/tutorials-tutorial_2-2x2x2-pdos-projwfc.json index 8d066b386..7bad63951 100644 --- a/tests/benchmarks/tutorials-tutorial_2-2x2x2-pdos-projwfc.json +++ b/tests/benchmarks/tutorials-tutorial_2-2x2x2-pdos-projwfc.json @@ -34225,7 +34225,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "projwfc.x", "_flags": "", @@ -34243,5 +34243,5 @@ }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-bands.json b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-bands.json index 080e0a817..9a15f8d8e 100644 --- a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-bands.json +++ b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-bands.json @@ -1490,7 +1490,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -3223,5 +3223,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-emp-pw2wan.json b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-emp-pw2wan.json index 4051c6979..4b44c6b0a 100644 --- a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-emp-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-emp-pw2wan.json @@ -94,7 +94,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -105,5 +105,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-emp-wann.json b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-emp-wann.json index 74819c026..7bd71b5b4 100644 --- a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-emp-wann.json +++ b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-emp-wann.json @@ -4719,7 +4719,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -4730,5 +4730,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-emp-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-emp-wann_preproc.json index c85952b6f..08ea293c3 100644 --- a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-emp-wann_preproc.json @@ -1556,7 +1556,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -1567,5 +1567,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-nscf.json b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-nscf.json index ba839f81c..2c355f482 100644 --- a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-nscf.json +++ b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-nscf.json @@ -126,7 +126,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -459,5 +459,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-occ-pw2wan.json b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-occ-pw2wan.json index c4446f482..c9b7faede 100644 --- a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-occ-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-occ-pw2wan.json @@ -94,7 +94,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -105,5 +105,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-occ-wann.json b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-occ-wann.json index af6c1fb8f..aa5e005b5 100644 --- a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-occ-wann.json +++ b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-occ-wann.json @@ -4716,7 +4716,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -4727,5 +4727,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-occ-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-occ-wann_preproc.json index 8345732c3..2f1c1de0f 100644 --- a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-occ-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-occ-wann_preproc.json @@ -1553,7 +1553,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -1564,5 +1564,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-scf.json b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-scf.json index 17ee71af3..f2bf79c29 100644 --- a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-scf.json +++ b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-scf.json @@ -123,7 +123,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -208,5 +208,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-4x4x4-pdos-projwfc.json b/tests/benchmarks/tutorials-tutorial_2-4x4x4-pdos-projwfc.json index 2836adb39..c8d2902d0 100644 --- a/tests/benchmarks/tutorials-tutorial_2-4x4x4-pdos-projwfc.json +++ b/tests/benchmarks/tutorials-tutorial_2-4x4x4-pdos-projwfc.json @@ -34288,7 +34288,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "projwfc.x", "_flags": "", @@ -34306,5 +34306,5 @@ }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-bands.json b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-bands.json index 6288edb67..8bfed2ac6 100644 --- a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-bands.json +++ b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-bands.json @@ -1490,7 +1490,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -3223,5 +3223,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-emp-pw2wan.json b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-emp-pw2wan.json index 4051c6979..4b44c6b0a 100644 --- a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-emp-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-emp-pw2wan.json @@ -94,7 +94,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -105,5 +105,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-emp-wann.json b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-emp-wann.json index 8f746deb9..b3290eccc 100644 --- a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-emp-wann.json +++ b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-emp-wann.json @@ -4887,7 +4887,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -4898,5 +4898,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-emp-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-emp-wann_preproc.json index b3dbf4a80..5444b74eb 100644 --- a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-emp-wann_preproc.json @@ -1724,7 +1724,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -1735,5 +1735,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-nscf.json b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-nscf.json index 13112958a..df1eb7438 100644 --- a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-nscf.json +++ b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-nscf.json @@ -126,7 +126,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -2699,5 +2699,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-occ-pw2wan.json b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-occ-pw2wan.json index c4446f482..c9b7faede 100644 --- a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-occ-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-occ-pw2wan.json @@ -94,7 +94,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -105,5 +105,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-occ-wann.json b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-occ-wann.json index a5ee5bec3..2ab5ef191 100644 --- a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-occ-wann.json +++ b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-occ-wann.json @@ -4884,7 +4884,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -4895,5 +4895,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-occ-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-occ-wann_preproc.json index cde44ac8c..4a6915cdd 100644 --- a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-occ-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-occ-wann_preproc.json @@ -1721,7 +1721,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -1732,5 +1732,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-scf.json b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-scf.json index a4c679b83..74cd49488 100644 --- a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-scf.json +++ b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-scf.json @@ -123,7 +123,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -328,5 +328,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-8x8x8-pdos-projwfc.json b/tests/benchmarks/tutorials-tutorial_2-8x8x8-pdos-projwfc.json index 3a36d7548..7716d0989 100644 --- a/tests/benchmarks/tutorials-tutorial_2-8x8x8-pdos-projwfc.json +++ b/tests/benchmarks/tutorials-tutorial_2-8x8x8-pdos-projwfc.json @@ -34297,7 +34297,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "projwfc.x", "_flags": "", @@ -34315,5 +34315,5 @@ }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-bands.json b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-bands.json index f762f2a55..018580977 100644 --- a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-bands.json +++ b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-bands.json @@ -1490,7 +1490,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -3223,5 +3223,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-emp-pw2wan.json b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-emp-pw2wan.json index 4051c6979..4b44c6b0a 100644 --- a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-emp-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-emp-pw2wan.json @@ -94,7 +94,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -105,5 +105,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-emp-wann.json b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-emp-wann.json index 3d307d03a..49c3162f2 100644 --- a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-emp-wann.json +++ b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-emp-wann.json @@ -6231,7 +6231,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -6242,5 +6242,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-emp-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-emp-wann_preproc.json index e9503f16c..ac6925ef8 100644 --- a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-emp-wann_preproc.json @@ -3068,7 +3068,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -3079,5 +3079,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-nscf.json b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-nscf.json index 943349829..c5d8ff01a 100644 --- a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-nscf.json +++ b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-nscf.json @@ -126,7 +126,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -20619,5 +20619,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-occ-pw2wan.json b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-occ-pw2wan.json index c4446f482..c9b7faede 100644 --- a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-occ-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-occ-pw2wan.json @@ -94,7 +94,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -105,5 +105,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-occ-wann.json b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-occ-wann.json index 1e4adcebf..8af7b246e 100644 --- a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-occ-wann.json +++ b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-occ-wann.json @@ -6228,7 +6228,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -6239,5 +6239,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-occ-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-occ-wann_preproc.json index 4d4ed48c1..93a3a8b3b 100644 --- a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-occ-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-occ-wann_preproc.json @@ -3065,7 +3065,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -3076,5 +3076,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-scf.json b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-scf.json index ee37ef94e..d29bc63de 100644 --- a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-scf.json +++ b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-scf.json @@ -123,7 +123,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -832,5 +832,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-ki.json b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-ki.json index 8f8086844..0a9f9d8a1 100644 --- a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-ki.json +++ b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-ki.json @@ -468,781 +468,781 @@ "centres": [ [ [ - -0.666763282525462, - 1.8203695967361821, - 1.8203695967361821 + -2.7358461671878085, + 0.015875316250606238, + 0.015875316250606238 ], [ - -0.666763282525462, - 0.666763282525462, - 0.666763282525462 + -2.7358461671878085, + 2.947517050529225, + 2.947517050529225 ], [ - -1.8256613688197176, - 1.8256613688197176, - 0.666763282525462 + -0.8996012542010202, + 1.1112721375424368, + 2.947517050529225 ], [ - -1.8203695967361821, - 0.666763282525462, - 1.8203695967361821 + -0.8996012542010202, + 2.947517050529225, + 1.1112721375424368 ], [ - 0.7778904962797057, - 0.37571581793101433, - 1.8203695967361821 + -0.14287784625545616, + -2.577093004681746, + 0.015875316250606238 ], [ - 0.7831822683632411, - -0.7831822683632411, - 0.666763282525462 + -0.14287784625545616, + 0.3598405016804081, + 2.947517050529225 ], [ - 0.5556360687712184, - -0.5556360687712184, - 0.666763282525462 + -1.4605290950557739, + 1.6721999783971906, + 2.947517050529225 ], [ - -0.37571581793101433, - -0.7778904962797057, - 1.8203695967361821 + 1.6933670667313323, + 0.3598405016804081, + 1.1112721375424368 ], [ - -0.666763282525462, - -0.5556360687712184, - -0.5556360687712184 + -2.7358461671878085, + 2.3336714888391175, + 2.3336714888391175 ], [ - -0.666763282525462, - -0.7831822683632411, - -0.7831822683632411 + -2.7358461671878085, + 1.0795215050412243, + 1.0795215050412243 ], [ - -1.8203695967361821, - 0.3704240458474789, - -0.7831822683632411 + -0.8996012542010202, + -0.756723407945564, + 1.0795215050412243 ], [ - -1.8203695967361821, - -0.7831822683632411, - 0.3704240458474789 + -0.8996012542010202, + 1.0795215050412243, + -0.756723407945564 ], [ - 0.7620151800290995, - -1.9897063034093152, - -0.5556360687712184 + -0.14287784625545616, + -0.25929683209323523, + 2.3336714888391175 ], [ - 0.7725987241961703, - -2.2225442750848736, - -0.7831822683632411 + -0.14287784625545616, + -1.513446815891128, + 1.0795215050412243 ], [ - 0.5556360687712184, - -2.000289847576386, - -0.7725987241961703 + -1.4605290950557739, + -0.19579556709081028, + 1.0795215050412243 ], [ - -0.38629936209808513, - -2.201377186750732, - 0.38629936209808513 + 1.6933670667313323, + -1.513446815891128, + -0.756723407945564 ], [ - 0.7831822683632411, - 1.8203695967361821, - 0.3704240458474789 + -0.14287784625545616, + 0.015875316250606238, + -2.577093004681746 ], [ - 0.7831822683632411, - 0.666763282525462, - -0.7831822683632411 + -0.14287784625545616, + 2.947517050529225, + 0.3598405016804081 ], [ - -0.3704240458474789, - 1.8203695967361821, - -0.7831822683632411 + 1.6933670667313323, + 1.1112721375424368, + 0.3598405016804081 ], [ - 0.5556360687712184, - 0.666763282525462, - -0.5556360687712184 + -1.4605290950557739, + 2.947517050529225, + 1.6721999783971906 ], [ - 2.201377186750732, - 0.38629936209808513, - 0.38629936209808513 + 2.4500904746768963, + -2.577093004681746, + -2.577093004681746 ], [ - 2.2225442750848736, - -0.7725987241961703, - -0.7831822683632411 + 2.4500904746768963, + 0.3598405016804081, + 0.3598405016804081 ], [ - 2.000289847576386, - -0.5556360687712184, - -0.7725987241961703 + 1.1324392258765785, + 1.6721999783971906, + 0.3598405016804081 ], [ - 1.9897063034093152, - -0.7620151800290995, - -0.5556360687712184 + 1.1324392258765785, + 0.3598405016804081, + 1.6721999783971906 ], [ - 0.7725987241961703, - -0.5556360687712184, - -2.000289847576386 + -0.14287784625545616, + 2.3336714888391175, + -0.25929683209323523 ], [ - 0.7831822683632411, - -0.7831822683632411, - -2.233127819251944 + -0.14287784625545616, + 1.0795215050412243, + -1.513446815891128 ], [ - -0.38629936209808513, - 0.38629936209808513, - -2.206668958834267 + 1.6933670667313323, + -0.756723407945564, + -1.513446815891128 ], [ - 0.5556360687712184, - -0.7725987241961703, - -2.000289847576386 + -1.4605290950557739, + 1.0795215050412243, + -0.19579556709081028 ], [ - 2.206668958834267, - -1.98441453132578, - -2.000289847576386 + 2.4500904746768963, + -0.25929683209323523, + -0.25929683209323523 ], [ - 2.201377186750732, - -2.201377186750732, - -2.206668958834267 + 2.4500904746768963, + -1.513446815891128, + -1.513446815891128 ], [ - 2.000289847576386, - -2.000289847576386, - -2.2225442750848736 + 1.1324392258765785, + -0.19579556709081028, + -1.513446815891128 ], [ - 1.98441453132578, - -2.206668958834267, - -2.000289847576386 + 1.1324392258765785, + -1.513446815891128, + -0.19579556709081028 ], [ - -0.5291772083535413, - 0.4021746783486914, - 0.4021746783486914 + -1.98441453132578, + 1.1483145421271845, + 1.1483145421271845 ], [ - -0.5291772083535413, - 0.5291772083535413, - 0.5291772083535413 + -1.98441453132578, + 1.7992025084020404, + 1.7992025084020404 ], [ - -0.40746645043222685, - 0.40746645043222685, - 0.5291772083535413 + -1.0689379608741534, + 0.883725937950414, + 1.7992025084020404 ], [ - -0.4021746783486914, - 0.5291772083535413, - 0.4021746783486914 + -1.0689379608741534, + 1.7992025084020404, + 0.883725937950414 ], [ - 0.1587531625060624, - -0.2857556925109123, - 0.4021746783486914 + 0.015875316250606238, + -0.8519753054492015, + 1.1483145421271845 ], [ - 0.1587531625060624, - -0.1587531625060624, - 0.5291772083535413 + 0.015875316250606238, + -0.2010873391743457, + 1.7992025084020404 ], [ - -0.2540050600096998, - 0.2540050600096998, - 0.5291772083535413 + -0.9578107471199098, + 0.7725987241961703, + 1.7992025084020404 ], [ - 0.2857556925109123, - -0.1587531625060624, - 0.4021746783486914 + 0.9313518867022327, + -0.2010873391743457, + 0.883725937950414 ], [ - -0.5291772083535413, - 0.2540050600096998, - 0.2540050600096998 + -1.98441453132578, + 1.1959404908790032, + 1.1959404908790032 ], [ - -0.5291772083535413, - -0.16404493458959782, - -0.16404493458959782 + -1.98441453132578, + 0.7884740404467766, + 0.7884740404467766 ], [ - -0.40746645043222685, - -0.29104746459444775, - -0.16933670667313322 + -1.0689379608741534, + -0.1270025300048499, + 0.7884740404467766 ], [ - -0.4021746783486914, - -0.16933670667313322, - -0.2963392366779832 + -1.0689379608741534, + 0.7884740404467766, + -0.1270025300048499 ], [ - 0.15346139042252696, - -0.4286335387663685, - 0.25929683209323523 + 0.015875316250606238, + -0.8043493566973828, + 1.1959404908790032 ], [ - 0.1587531625060624, - -0.8519753054492015, - -0.16404493458959782 + 0.015875316250606238, + -1.2118158071296097, + 0.7884740404467766 ], [ - -0.25929683209323523, - -0.4286335387663685, - -0.1587531625060624 + -0.9578107471199098, + -0.2381297437590936, + 0.7884740404467766 ], [ - 0.2804639204273769, - -0.8466835333656662, - -0.2857556925109123 + 0.9313518867022327, + -1.2118158071296097, + -0.1270025300048499 ], [ - 0.16933670667313322, - 0.4021746783486914, - -0.2963392366779832 + 0.015875316250606238, + 1.1483145421271845, + -0.8519753054492015 ], [ - 0.16404493458959782, - 0.5291772083535413, - -0.16404493458959782 + 0.015875316250606238, + 1.7992025084020404, + -0.2010873391743457 ], [ - 0.29104746459444775, - 0.40746645043222685, - -0.16933670667313322 + 0.9313518867022327, + 0.883725937950414, + -0.2010873391743457 ], [ - -0.2540050600096998, - 0.5291772083535413, - 0.2540050600096998 + -0.9578107471199098, + 1.7992025084020404, + 0.7725987241961703 ], [ - 0.8466835333656662, - -0.2804639204273769, - -0.2857556925109123 + 2.0161651638269924, + -0.8519753054492015, + -0.8519753054492015 ], [ - 0.8519753054492015, - -0.1587531625060624, - -0.16404493458959782 + 2.0161651638269924, + -0.2010873391743457, + -0.2010873391743457 ], [ - 0.4286335387663685, - 0.25929683209323523, - -0.1587531625060624 + 1.0424791004564764, + 0.7725987241961703, + -0.2010873391743457 ], [ - 0.4286335387663685, - -0.15346139042252696, - 0.25929683209323523 + 1.0424791004564764, + -0.2010873391743457, + 0.7725987241961703 ], [ - 0.1587531625060624, - 0.25929683209323523, - -0.4339253108499039 + 0.015875316250606238, + 1.1959404908790032, + -0.8043493566973828 ], [ - 0.16404493458959782, - -0.16404493458959782, - -0.857267077532737 + 0.015875316250606238, + 0.7884740404467766, + -1.2118158071296097 ], [ - 0.2804639204273769, - -0.2804639204273769, - -0.8519753054492015 + 0.9313518867022327, + -0.1270025300048499, + -1.2118158071296097 ], [ - -0.25929683209323523, - -0.1587531625060624, - -0.4339253108499039 + -0.9578107471199098, + 0.7884740404467766, + -0.2381297437590936 ], [ - 0.8466835333656662, - -0.4233417666828331, - -0.4339253108499039 + 2.0161651638269924, + -0.8043493566973828, + -0.8043493566973828 ], [ - 0.8466835333656662, - -0.8466835333656662, - -0.8519753054492015 + 2.0161651638269924, + -1.2118158071296097, + -1.2118158071296097 ], [ - 0.4339253108499039, - -0.4339253108499039, - -0.857267077532737 + 1.0424791004564764, + -0.2381297437590936, + -1.2118158071296097 ], [ - 0.4233417666828331, - -0.8466835333656662, - -0.4339253108499039 + 1.0424791004564764, + -1.2118158071296097, + -0.2381297437590936 ] ], [ [ - -0.666763282525462, - 1.8203695967361821, - 1.8203695967361821 + -2.7358461671878085, + 0.015875316250606238, + 0.015875316250606238 ], [ - -0.666763282525462, - 0.666763282525462, - 0.666763282525462 + -2.7358461671878085, + 2.947517050529225, + 2.947517050529225 ], [ - -1.8256613688197176, - 1.8256613688197176, - 0.666763282525462 + -0.8996012542010202, + 1.1112721375424368, + 2.947517050529225 ], [ - -1.8203695967361821, - 0.666763282525462, - 1.8203695967361821 + -0.8996012542010202, + 2.947517050529225, + 1.1112721375424368 ], [ - 0.7778904962797057, - 0.37571581793101433, - 1.8203695967361821 + -0.14287784625545616, + -2.577093004681746, + 0.015875316250606238 ], [ - 0.7831822683632411, - -0.7831822683632411, - 0.666763282525462 + -0.14287784625545616, + 0.3598405016804081, + 2.947517050529225 ], [ - 0.5556360687712184, - -0.5556360687712184, - 0.666763282525462 + -1.4605290950557739, + 1.6721999783971906, + 2.947517050529225 ], [ - -0.37571581793101433, - -0.7778904962797057, - 1.8203695967361821 + 1.6933670667313323, + 0.3598405016804081, + 1.1112721375424368 ], [ - -0.666763282525462, - -0.5556360687712184, - -0.5556360687712184 + -2.7358461671878085, + 2.3336714888391175, + 2.3336714888391175 ], [ - -0.666763282525462, - -0.7831822683632411, - -0.7831822683632411 + -2.7358461671878085, + 1.0795215050412243, + 1.0795215050412243 ], [ - -1.8203695967361821, - 0.3704240458474789, - -0.7831822683632411 + -0.8996012542010202, + -0.756723407945564, + 1.0795215050412243 ], [ - -1.8203695967361821, - -0.7831822683632411, - 0.3704240458474789 + -0.8996012542010202, + 1.0795215050412243, + -0.756723407945564 ], [ - 0.7620151800290995, - -1.9897063034093152, - -0.5556360687712184 + -0.14287784625545616, + -0.25929683209323523, + 2.3336714888391175 ], [ - 0.7725987241961703, - -2.2225442750848736, - -0.7831822683632411 + -0.14287784625545616, + -1.513446815891128, + 1.0795215050412243 ], [ - 0.5556360687712184, - -2.000289847576386, - -0.7725987241961703 + -1.4605290950557739, + -0.19579556709081028, + 1.0795215050412243 ], [ - -0.38629936209808513, - -2.201377186750732, - 0.38629936209808513 + 1.6933670667313323, + -1.513446815891128, + -0.756723407945564 ], [ - 0.7831822683632411, - 1.8203695967361821, - 0.3704240458474789 + -0.14287784625545616, + 0.015875316250606238, + -2.577093004681746 ], [ - 0.7831822683632411, - 0.666763282525462, - -0.7831822683632411 + -0.14287784625545616, + 2.947517050529225, + 0.3598405016804081 ], [ - -0.3704240458474789, - 1.8203695967361821, - -0.7831822683632411 + 1.6933670667313323, + 1.1112721375424368, + 0.3598405016804081 ], [ - 0.5556360687712184, - 0.666763282525462, - -0.5556360687712184 + -1.4605290950557739, + 2.947517050529225, + 1.6721999783971906 ], [ - 2.201377186750732, - 0.38629936209808513, - 0.38629936209808513 + 2.4500904746768963, + -2.577093004681746, + -2.577093004681746 ], [ - 2.2225442750848736, - -0.7725987241961703, - -0.7831822683632411 + 2.4500904746768963, + 0.3598405016804081, + 0.3598405016804081 ], [ - 2.000289847576386, - -0.5556360687712184, - -0.7725987241961703 + 1.1324392258765785, + 1.6721999783971906, + 0.3598405016804081 ], [ - 1.9897063034093152, - -0.7620151800290995, - -0.5556360687712184 + 1.1324392258765785, + 0.3598405016804081, + 1.6721999783971906 ], [ - 0.7725987241961703, - -0.5556360687712184, - -2.000289847576386 + -0.14287784625545616, + 2.3336714888391175, + -0.25929683209323523 ], [ - 0.7831822683632411, - -0.7831822683632411, - -2.233127819251944 + -0.14287784625545616, + 1.0795215050412243, + -1.513446815891128 ], [ - -0.38629936209808513, - 0.38629936209808513, - -2.206668958834267 + 1.6933670667313323, + -0.756723407945564, + -1.513446815891128 ], [ - 0.5556360687712184, - -0.7725987241961703, - -2.000289847576386 + -1.4605290950557739, + 1.0795215050412243, + -0.19579556709081028 ], [ - 2.206668958834267, - -1.98441453132578, - -2.000289847576386 + 2.4500904746768963, + -0.25929683209323523, + -0.25929683209323523 ], [ - 2.201377186750732, - -2.201377186750732, - -2.206668958834267 + 2.4500904746768963, + -1.513446815891128, + -1.513446815891128 ], [ - 2.000289847576386, - -2.000289847576386, - -2.2225442750848736 + 1.1324392258765785, + -0.19579556709081028, + -1.513446815891128 ], [ - 1.98441453132578, - -2.206668958834267, - -2.000289847576386 + 1.1324392258765785, + -1.513446815891128, + -0.19579556709081028 ], [ - -0.5291772083535413, - 0.4021746783486914, - 0.4021746783486914 + -1.98441453132578, + 1.1483145421271845, + 1.1483145421271845 ], [ - -0.5291772083535413, - 0.5291772083535413, - 0.5291772083535413 + -1.98441453132578, + 1.7992025084020404, + 1.7992025084020404 ], [ - -0.40746645043222685, - 0.40746645043222685, - 0.5291772083535413 + -1.0689379608741534, + 0.883725937950414, + 1.7992025084020404 ], [ - -0.4021746783486914, - 0.5291772083535413, - 0.4021746783486914 + -1.0689379608741534, + 1.7992025084020404, + 0.883725937950414 ], [ - 0.1587531625060624, - -0.2857556925109123, - 0.4021746783486914 + 0.015875316250606238, + -0.8519753054492015, + 1.1483145421271845 ], [ - 0.1587531625060624, - -0.1587531625060624, - 0.5291772083535413 + 0.015875316250606238, + -0.2010873391743457, + 1.7992025084020404 ], [ - -0.2540050600096998, - 0.2540050600096998, - 0.5291772083535413 + -0.9578107471199098, + 0.7725987241961703, + 1.7992025084020404 ], [ - 0.2857556925109123, - -0.1587531625060624, - 0.4021746783486914 + 0.9313518867022327, + -0.2010873391743457, + 0.883725937950414 ], [ - -0.5291772083535413, - 0.2540050600096998, - 0.2540050600096998 + -1.98441453132578, + 1.1959404908790032, + 1.1959404908790032 ], [ - -0.5291772083535413, - -0.16404493458959782, - -0.16404493458959782 + -1.98441453132578, + 0.7884740404467766, + 0.7884740404467766 ], [ - -0.40746645043222685, - -0.29104746459444775, - -0.16933670667313322 + -1.0689379608741534, + -0.1270025300048499, + 0.7884740404467766 ], [ - -0.4021746783486914, - -0.16933670667313322, - -0.2963392366779832 + -1.0689379608741534, + 0.7884740404467766, + -0.1270025300048499 ], [ - 0.15346139042252696, - -0.4286335387663685, - 0.25929683209323523 + 0.015875316250606238, + -0.8043493566973828, + 1.1959404908790032 ], [ - 0.1587531625060624, - -0.8519753054492015, - -0.16404493458959782 + 0.015875316250606238, + -1.2118158071296097, + 0.7884740404467766 ], [ - -0.25929683209323523, - -0.4286335387663685, - -0.1587531625060624 + -0.9578107471199098, + -0.2381297437590936, + 0.7884740404467766 ], [ - 0.2804639204273769, - -0.8466835333656662, - -0.2857556925109123 + 0.9313518867022327, + -1.2118158071296097, + -0.1270025300048499 ], [ - 0.16933670667313322, - 0.4021746783486914, - -0.2963392366779832 + 0.015875316250606238, + 1.1483145421271845, + -0.8519753054492015 ], [ - 0.16404493458959782, - 0.5291772083535413, - -0.16404493458959782 + 0.015875316250606238, + 1.7992025084020404, + -0.2010873391743457 ], [ - 0.29104746459444775, - 0.40746645043222685, - -0.16933670667313322 + 0.9313518867022327, + 0.883725937950414, + -0.2010873391743457 ], [ - -0.2540050600096998, - 0.5291772083535413, - 0.2540050600096998 + -0.9578107471199098, + 1.7992025084020404, + 0.7725987241961703 ], [ - 0.8466835333656662, - -0.2804639204273769, - -0.2857556925109123 + 2.0161651638269924, + -0.8519753054492015, + -0.8519753054492015 ], [ - 0.8519753054492015, - -0.1587531625060624, - -0.16404493458959782 + 2.0161651638269924, + -0.2010873391743457, + -0.2010873391743457 ], [ - 0.4286335387663685, - 0.25929683209323523, - -0.1587531625060624 + 1.0424791004564764, + 0.7725987241961703, + -0.2010873391743457 ], [ - 0.4286335387663685, - -0.15346139042252696, - 0.25929683209323523 + 1.0424791004564764, + -0.2010873391743457, + 0.7725987241961703 ], [ - 0.1587531625060624, - 0.25929683209323523, - -0.4339253108499039 + 0.015875316250606238, + 1.1959404908790032, + -0.8043493566973828 ], [ - 0.16404493458959782, - -0.16404493458959782, - -0.857267077532737 + 0.015875316250606238, + 0.7884740404467766, + -1.2118158071296097 ], [ - 0.2804639204273769, - -0.2804639204273769, - -0.8519753054492015 + 0.9313518867022327, + -0.1270025300048499, + -1.2118158071296097 ], [ - -0.25929683209323523, - -0.1587531625060624, - -0.4339253108499039 + -0.9578107471199098, + 0.7884740404467766, + -0.2381297437590936 ], [ - 0.8466835333656662, - -0.4233417666828331, - -0.4339253108499039 + 2.0161651638269924, + -0.8043493566973828, + -0.8043493566973828 ], [ - 0.8466835333656662, - -0.8466835333656662, - -0.8519753054492015 + 2.0161651638269924, + -1.2118158071296097, + -1.2118158071296097 ], [ - 0.4339253108499039, - -0.4339253108499039, - -0.857267077532737 + 1.0424791004564764, + -0.2381297437590936, + -1.2118158071296097 ], [ - 0.4233417666828331, - -0.8466835333656662, - -0.4339253108499039 + 1.0424791004564764, + -1.2118158071296097, + -0.2381297437590936 ] ] ], "spreads": [ [ - 2.585503305224543, - 1.3953821044009418, - 2.5779425352428396, - 2.585503305224543, - 9.937932069653828, - 9.265583598317955, - 1.9638399956178618, - 9.937932069653828, - 1.9624398530286575, - 9.255782600193523, - 9.903208533441564, - 9.909369160834062, - 10.024180853148808, - 15.910100269645579, - 9.981616518437, - 16.073636924064633, - 9.909369160834062, - 9.255782600193523, - 9.903208533441564, - 1.9624398530286575, - 16.073636924064633, - 15.910100269645579, - 9.981616518437, - 10.024180853148808, - 9.980216375847796, - 15.876216818986835, - 16.0699965533327, - 9.980216375847796, - 16.732824055061986, - 21.2712462437086, - 16.665897239298026, - 16.732824055061986, - 9.433600709022462, - 6.218033238656013, - 9.423239653862352, - 9.433600709022462, - 13.362120785811708, - 10.467746025408712, - 8.710567075957396, - 13.362120785811708, - 8.709446961886032, - 10.475306795390415, - 13.365201099507958, - 13.373321926525342, - 14.240010189242764, - 17.276359408191073, - 14.238890075171401, - 19.869423483397316, - 13.373321926525342, - 10.475306795390415, - 13.365201099507958, - 8.709446961886032, - 19.869423483397316, - 17.276359408191073, - 14.238890075171401, - 14.240010189242764, - 14.240290217760606, - 17.274119180048345, - 19.861862713415615, - 14.240290217760606, - 22.231464031384863, - 26.55006383352641, - 22.21690254845714, - 22.231464031384863 + 3.6636130989118048, + 7.869361408363489, + 16.096879291045422, + 16.096879291045422, + 3.641210817484537, + 7.478721625975508, + 7.843598784722132, + 15.941743492161594, + 3.0352291048769438, + 2.3541997494880027, + 12.356818406763068, + 12.356818406763068, + 2.4905736376764955, + 1.9851221629737663, + 2.0358073247029593, + 12.223244803752982, + 3.641210817484537, + 7.478721625975508, + 15.941743492161594, + 7.843598784722132, + 3.6678135266794176, + 7.137366862727514, + 7.417115352050521, + 7.417115352050521, + 2.4905736376764955, + 1.9851221629737663, + 12.223244803752982, + 2.0358073247029593, + 1.9949231610981957, + 1.6650495670816776, + 1.6308860879050944, + 1.6308860879050944, + 11.364397339535104, + 13.345599103259099, + 14.273053554347985, + 14.273053554347985, + 10.816381530120566, + 11.969538966589175, + 16.047594271905435, + 13.339158447348758, + 11.672148680642197, + 8.5604717903947, + 10.882188231813165, + 10.882188231813165, + 10.118550463661174, + 7.644498508537289, + 8.574753244804583, + 10.408660008144293, + 10.816381530120566, + 11.969538966589175, + 13.339158447348758, + 16.047594271905435, + 10.956115760523149, + 11.280668812700691, + 14.52927964817236, + 14.52927964817236, + 10.118550463661174, + 7.644498508537289, + 10.408660008144293, + 8.574753244804583, + 9.251862200943753, + 7.415995237979158, + 7.516805504401863, + 7.516805504401863 ], [ - 2.585503305224543, - 1.3953821044009418, - 2.5779425352428396, - 2.585503305224543, - 9.937932069653828, - 9.265583598317955, - 1.9638399956178618, - 9.937932069653828, - 1.9624398530286575, - 9.255782600193523, - 9.903208533441564, - 9.909369160834062, - 10.024180853148808, - 15.910100269645579, - 9.981616518437, - 16.073636924064633, - 9.909369160834062, - 9.255782600193523, - 9.903208533441564, - 1.9624398530286575, - 16.073636924064633, - 15.910100269645579, - 9.981616518437, - 10.024180853148808, - 9.980216375847796, - 15.876216818986835, - 16.0699965533327, - 9.980216375847796, - 16.732824055061986, - 21.2712462437086, - 16.665897239298026, - 16.732824055061986, - 9.433600709022462, - 6.218033238656013, - 9.423239653862352, - 9.433600709022462, - 13.362120785811708, - 10.467746025408712, - 8.710567075957396, - 13.362120785811708, - 8.709446961886032, - 10.475306795390415, - 13.365201099507958, - 13.373321926525342, - 14.240010189242764, - 17.276359408191073, - 14.238890075171401, - 19.869423483397316, - 13.373321926525342, - 10.475306795390415, - 13.365201099507958, - 8.709446961886032, - 19.869423483397316, - 17.276359408191073, - 14.238890075171401, - 14.240010189242764, - 14.240290217760606, - 17.274119180048345, - 19.861862713415615, - 14.240290217760606, - 22.231464031384863, - 26.55006383352641, - 22.21690254845714, - 22.231464031384863 + 3.6636130989118048, + 7.869361408363489, + 16.096879291045422, + 16.096879291045422, + 3.641210817484537, + 7.478721625975508, + 7.843598784722132, + 15.941743492161594, + 3.0352291048769438, + 2.3541997494880027, + 12.356818406763068, + 12.356818406763068, + 2.4905736376764955, + 1.9851221629737663, + 2.0358073247029593, + 12.223244803752982, + 3.641210817484537, + 7.478721625975508, + 15.941743492161594, + 7.843598784722132, + 3.6678135266794176, + 7.137366862727514, + 7.417115352050521, + 7.417115352050521, + 2.4905736376764955, + 1.9851221629737663, + 12.223244803752982, + 2.0358073247029593, + 1.9949231610981957, + 1.6650495670816776, + 1.6308860879050944, + 1.6308860879050944, + 11.364397339535104, + 13.345599103259099, + 14.273053554347985, + 14.273053554347985, + 10.816381530120566, + 11.969538966589175, + 16.047594271905435, + 13.339158447348758, + 11.672148680642197, + 8.5604717903947, + 10.882188231813165, + 10.882188231813165, + 10.118550463661174, + 7.644498508537289, + 8.574753244804583, + 10.408660008144293, + 10.816381530120566, + 11.969538966589175, + 13.339158447348758, + 16.047594271905435, + 10.956115760523149, + 11.280668812700691, + 14.52927964817236, + 14.52927964817236, + 10.118550463661174, + 7.644498508537289, + 10.408660008144293, + 8.574753244804583, + 9.251862200943753, + 7.415995237979158, + 7.516805504401863, + 7.516805504401863 ] ], "self-Hartree": [ @@ -34222,7 +34222,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -34503,5 +34503,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_32-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_32-dft_n-1.json index f0a355c3f..8f262259b 100644 --- a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_32-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_32-dft_n-1.json @@ -5112,7 +5112,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -5393,5 +5393,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1.json b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1.json index 9be8b542d..cc7314bb9 100644 --- a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1.json +++ b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1.json @@ -5235,7 +5235,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -5518,5 +5518,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1_dummy.json b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1_dummy.json index 9a52affb2..e57a0ea4d 100644 --- a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1_dummy.json +++ b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1_dummy.json @@ -5077,7 +5077,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -5360,5 +5360,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-pz_print.json b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-pz_print.json index 6b5befdee..b5c229319 100644 --- a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-pz_print.json +++ b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-pz_print.json @@ -470,781 +470,781 @@ "centres": [ [ [ - -0.666763282525462, - 1.8203695967361821, - 1.8203695967361821 + -2.7358461671878085, + 0.015875316250606238, + 0.015875316250606238 ], [ - -0.666763282525462, - 0.666763282525462, - 0.666763282525462 + -2.7358461671878085, + 2.947517050529225, + 2.947517050529225 ], [ - -1.8256613688197176, - 1.8256613688197176, - 0.666763282525462 + -0.8996012542010202, + 1.1112721375424368, + 2.947517050529225 ], [ - -1.8203695967361821, - 0.666763282525462, - 1.8203695967361821 + -0.8996012542010202, + 2.947517050529225, + 1.1112721375424368 ], [ - 0.7778904962797057, - 0.37571581793101433, - 1.8203695967361821 + -0.14287784625545616, + -2.577093004681746, + 0.015875316250606238 ], [ - 0.7831822683632411, - -0.7831822683632411, - 0.666763282525462 + -0.14287784625545616, + 0.3598405016804081, + 2.947517050529225 ], [ - 0.5556360687712184, - -0.5556360687712184, - 0.666763282525462 + -1.4605290950557739, + 1.6721999783971906, + 2.947517050529225 ], [ - -0.37571581793101433, - -0.7778904962797057, - 1.8203695967361821 + 1.6933670667313323, + 0.3598405016804081, + 1.1112721375424368 ], [ - -0.666763282525462, - -0.5556360687712184, - -0.5556360687712184 + -2.7358461671878085, + 2.3336714888391175, + 2.3336714888391175 ], [ - -0.666763282525462, - -0.7831822683632411, - -0.7831822683632411 + -2.7358461671878085, + 1.0795215050412243, + 1.0795215050412243 ], [ - -1.8203695967361821, - 0.3704240458474789, - -0.7831822683632411 + -0.8996012542010202, + -0.756723407945564, + 1.0795215050412243 ], [ - -1.8203695967361821, - -0.7831822683632411, - 0.3704240458474789 + -0.8996012542010202, + 1.0795215050412243, + -0.756723407945564 ], [ - 0.7620151800290995, - -1.9897063034093152, - -0.5556360687712184 + -0.14287784625545616, + -0.25929683209323523, + 2.3336714888391175 ], [ - 0.7725987241961703, - -2.2225442750848736, - -0.7831822683632411 + -0.14287784625545616, + -1.513446815891128, + 1.0795215050412243 ], [ - 0.5556360687712184, - -2.000289847576386, - -0.7725987241961703 + -1.4605290950557739, + -0.19579556709081028, + 1.0795215050412243 ], [ - -0.38629936209808513, - -2.201377186750732, - 0.38629936209808513 + 1.6933670667313323, + -1.513446815891128, + -0.756723407945564 ], [ - 0.7831822683632411, - 1.8203695967361821, - 0.3704240458474789 + -0.14287784625545616, + 0.015875316250606238, + -2.577093004681746 ], [ - 0.7831822683632411, - 0.666763282525462, - -0.7831822683632411 + -0.14287784625545616, + 2.947517050529225, + 0.3598405016804081 ], [ - -0.3704240458474789, - 1.8203695967361821, - -0.7831822683632411 + 1.6933670667313323, + 1.1112721375424368, + 0.3598405016804081 ], [ - 0.5556360687712184, - 0.666763282525462, - -0.5556360687712184 + -1.4605290950557739, + 2.947517050529225, + 1.6721999783971906 ], [ - 2.201377186750732, - 0.38629936209808513, - 0.38629936209808513 + 2.4500904746768963, + -2.577093004681746, + -2.577093004681746 ], [ - 2.2225442750848736, - -0.7725987241961703, - -0.7831822683632411 + 2.4500904746768963, + 0.3598405016804081, + 0.3598405016804081 ], [ - 2.000289847576386, - -0.5556360687712184, - -0.7725987241961703 + 1.1324392258765785, + 1.6721999783971906, + 0.3598405016804081 ], [ - 1.9897063034093152, - -0.7620151800290995, - -0.5556360687712184 + 1.1324392258765785, + 0.3598405016804081, + 1.6721999783971906 ], [ - 0.7725987241961703, - -0.5556360687712184, - -2.000289847576386 + -0.14287784625545616, + 2.3336714888391175, + -0.25929683209323523 ], [ - 0.7831822683632411, - -0.7831822683632411, - -2.233127819251944 + -0.14287784625545616, + 1.0795215050412243, + -1.513446815891128 ], [ - -0.38629936209808513, - 0.38629936209808513, - -2.206668958834267 + 1.6933670667313323, + -0.756723407945564, + -1.513446815891128 ], [ - 0.5556360687712184, - -0.7725987241961703, - -2.000289847576386 + -1.4605290950557739, + 1.0795215050412243, + -0.19579556709081028 ], [ - 2.206668958834267, - -1.98441453132578, - -2.000289847576386 + 2.4500904746768963, + -0.25929683209323523, + -0.25929683209323523 ], [ - 2.201377186750732, - -2.201377186750732, - -2.206668958834267 + 2.4500904746768963, + -1.513446815891128, + -1.513446815891128 ], [ - 2.000289847576386, - -2.000289847576386, - -2.2225442750848736 + 1.1324392258765785, + -0.19579556709081028, + -1.513446815891128 ], [ - 1.98441453132578, - -2.206668958834267, - -2.000289847576386 + 1.1324392258765785, + -1.513446815891128, + -0.19579556709081028 ], [ - -0.5291772083535413, - 0.4021746783486914, - 0.4021746783486914 + -1.98441453132578, + 1.1483145421271845, + 1.1483145421271845 ], [ - -0.5291772083535413, - 0.5291772083535413, - 0.5291772083535413 + -1.98441453132578, + 1.7992025084020404, + 1.7992025084020404 ], [ - -0.40746645043222685, - 0.40746645043222685, - 0.5291772083535413 + -1.0689379608741534, + 0.883725937950414, + 1.7992025084020404 ], [ - -0.4021746783486914, - 0.5291772083535413, - 0.4021746783486914 + -1.0689379608741534, + 1.7992025084020404, + 0.883725937950414 ], [ - 0.1587531625060624, - -0.2857556925109123, - 0.4021746783486914 + 0.015875316250606238, + -0.8519753054492015, + 1.1483145421271845 ], [ - 0.1587531625060624, - -0.1587531625060624, - 0.5291772083535413 + 0.015875316250606238, + -0.2010873391743457, + 1.7992025084020404 ], [ - -0.2540050600096998, - 0.2540050600096998, - 0.5291772083535413 + -0.9578107471199098, + 0.7725987241961703, + 1.7992025084020404 ], [ - 0.2857556925109123, - -0.1587531625060624, - 0.4021746783486914 + 0.9313518867022327, + -0.2010873391743457, + 0.883725937950414 ], [ - -0.5291772083535413, - 0.2540050600096998, - 0.2540050600096998 + -1.98441453132578, + 1.1959404908790032, + 1.1959404908790032 ], [ - -0.5291772083535413, - -0.16404493458959782, - -0.16404493458959782 + -1.98441453132578, + 0.7884740404467766, + 0.7884740404467766 ], [ - -0.40746645043222685, - -0.29104746459444775, - -0.16933670667313322 + -1.0689379608741534, + -0.1270025300048499, + 0.7884740404467766 ], [ - -0.4021746783486914, - -0.16933670667313322, - -0.2963392366779832 + -1.0689379608741534, + 0.7884740404467766, + -0.1270025300048499 ], [ - 0.15346139042252696, - -0.4286335387663685, - 0.25929683209323523 + 0.015875316250606238, + -0.8043493566973828, + 1.1959404908790032 ], [ - 0.1587531625060624, - -0.8519753054492015, - -0.16404493458959782 + 0.015875316250606238, + -1.2118158071296097, + 0.7884740404467766 ], [ - -0.25929683209323523, - -0.4286335387663685, - -0.1587531625060624 + -0.9578107471199098, + -0.2381297437590936, + 0.7884740404467766 ], [ - 0.2804639204273769, - -0.8466835333656662, - -0.2857556925109123 + 0.9313518867022327, + -1.2118158071296097, + -0.1270025300048499 ], [ - 0.16933670667313322, - 0.4021746783486914, - -0.2963392366779832 + 0.015875316250606238, + 1.1483145421271845, + -0.8519753054492015 ], [ - 0.16404493458959782, - 0.5291772083535413, - -0.16404493458959782 + 0.015875316250606238, + 1.7992025084020404, + -0.2010873391743457 ], [ - 0.29104746459444775, - 0.40746645043222685, - -0.16933670667313322 + 0.9313518867022327, + 0.883725937950414, + -0.2010873391743457 ], [ - -0.2540050600096998, - 0.5291772083535413, - 0.2540050600096998 + -0.9578107471199098, + 1.7992025084020404, + 0.7725987241961703 ], [ - 0.8466835333656662, - -0.2804639204273769, - -0.2857556925109123 + 2.0161651638269924, + -0.8519753054492015, + -0.8519753054492015 ], [ - 0.8519753054492015, - -0.1587531625060624, - -0.16404493458959782 + 2.0161651638269924, + -0.2010873391743457, + -0.2010873391743457 ], [ - 0.4286335387663685, - 0.25929683209323523, - -0.1587531625060624 + 1.0424791004564764, + 0.7725987241961703, + -0.2010873391743457 ], [ - 0.4286335387663685, - -0.15346139042252696, - 0.25929683209323523 + 1.0424791004564764, + -0.2010873391743457, + 0.7725987241961703 ], [ - 0.1587531625060624, - 0.25929683209323523, - -0.4339253108499039 + 0.015875316250606238, + 1.1959404908790032, + -0.8043493566973828 ], [ - 0.16404493458959782, - -0.16404493458959782, - -0.857267077532737 + 0.015875316250606238, + 0.7884740404467766, + -1.2118158071296097 ], [ - 0.2804639204273769, - -0.2804639204273769, - -0.8519753054492015 + 0.9313518867022327, + -0.1270025300048499, + -1.2118158071296097 ], [ - -0.25929683209323523, - -0.1587531625060624, - -0.4339253108499039 + -0.9578107471199098, + 0.7884740404467766, + -0.2381297437590936 ], [ - 0.8466835333656662, - -0.4233417666828331, - -0.4339253108499039 + 2.0161651638269924, + -0.8043493566973828, + -0.8043493566973828 ], [ - 0.8466835333656662, - -0.8466835333656662, - -0.8519753054492015 + 2.0161651638269924, + -1.2118158071296097, + -1.2118158071296097 ], [ - 0.4339253108499039, - -0.4339253108499039, - -0.857267077532737 + 1.0424791004564764, + -0.2381297437590936, + -1.2118158071296097 ], [ - 0.4233417666828331, - -0.8466835333656662, - -0.4339253108499039 + 1.0424791004564764, + -1.2118158071296097, + -0.2381297437590936 ] ], [ [ - -0.666763282525462, - 1.8203695967361821, - 1.8203695967361821 + -2.7358461671878085, + 0.015875316250606238, + 0.015875316250606238 ], [ - -0.666763282525462, - 0.666763282525462, - 0.666763282525462 + -2.7358461671878085, + 2.947517050529225, + 2.947517050529225 ], [ - -1.8256613688197176, - 1.8256613688197176, - 0.666763282525462 + -0.8996012542010202, + 1.1112721375424368, + 2.947517050529225 ], [ - -1.8203695967361821, - 0.666763282525462, - 1.8203695967361821 + -0.8996012542010202, + 2.947517050529225, + 1.1112721375424368 ], [ - 0.7778904962797057, - 0.37571581793101433, - 1.8203695967361821 + -0.14287784625545616, + -2.577093004681746, + 0.015875316250606238 ], [ - 0.7831822683632411, - -0.7831822683632411, - 0.666763282525462 + -0.14287784625545616, + 0.3598405016804081, + 2.947517050529225 ], [ - 0.5556360687712184, - -0.5556360687712184, - 0.666763282525462 + -1.4605290950557739, + 1.6721999783971906, + 2.947517050529225 ], [ - -0.37571581793101433, - -0.7778904962797057, - 1.8203695967361821 + 1.6933670667313323, + 0.3598405016804081, + 1.1112721375424368 ], [ - -0.666763282525462, - -0.5556360687712184, - -0.5556360687712184 + -2.7358461671878085, + 2.3336714888391175, + 2.3336714888391175 ], [ - -0.666763282525462, - -0.7831822683632411, - -0.7831822683632411 + -2.7358461671878085, + 1.0795215050412243, + 1.0795215050412243 ], [ - -1.8203695967361821, - 0.3704240458474789, - -0.7831822683632411 + -0.8996012542010202, + -0.756723407945564, + 1.0795215050412243 ], [ - -1.8203695967361821, - -0.7831822683632411, - 0.3704240458474789 + -0.8996012542010202, + 1.0795215050412243, + -0.756723407945564 ], [ - 0.7620151800290995, - -1.9897063034093152, - -0.5556360687712184 + -0.14287784625545616, + -0.25929683209323523, + 2.3336714888391175 ], [ - 0.7725987241961703, - -2.2225442750848736, - -0.7831822683632411 + -0.14287784625545616, + -1.513446815891128, + 1.0795215050412243 ], [ - 0.5556360687712184, - -2.000289847576386, - -0.7725987241961703 + -1.4605290950557739, + -0.19579556709081028, + 1.0795215050412243 ], [ - -0.38629936209808513, - -2.201377186750732, - 0.38629936209808513 + 1.6933670667313323, + -1.513446815891128, + -0.756723407945564 ], [ - 0.7831822683632411, - 1.8203695967361821, - 0.3704240458474789 + -0.14287784625545616, + 0.015875316250606238, + -2.577093004681746 ], [ - 0.7831822683632411, - 0.666763282525462, - -0.7831822683632411 + -0.14287784625545616, + 2.947517050529225, + 0.3598405016804081 ], [ - -0.3704240458474789, - 1.8203695967361821, - -0.7831822683632411 + 1.6933670667313323, + 1.1112721375424368, + 0.3598405016804081 ], [ - 0.5556360687712184, - 0.666763282525462, - -0.5556360687712184 + -1.4605290950557739, + 2.947517050529225, + 1.6721999783971906 ], [ - 2.201377186750732, - 0.38629936209808513, - 0.38629936209808513 + 2.4500904746768963, + -2.577093004681746, + -2.577093004681746 ], [ - 2.2225442750848736, - -0.7725987241961703, - -0.7831822683632411 + 2.4500904746768963, + 0.3598405016804081, + 0.3598405016804081 ], [ - 2.000289847576386, - -0.5556360687712184, - -0.7725987241961703 + 1.1324392258765785, + 1.6721999783971906, + 0.3598405016804081 ], [ - 1.9897063034093152, - -0.7620151800290995, - -0.5556360687712184 + 1.1324392258765785, + 0.3598405016804081, + 1.6721999783971906 ], [ - 0.7725987241961703, - -0.5556360687712184, - -2.000289847576386 + -0.14287784625545616, + 2.3336714888391175, + -0.25929683209323523 ], [ - 0.7831822683632411, - -0.7831822683632411, - -2.233127819251944 + -0.14287784625545616, + 1.0795215050412243, + -1.513446815891128 ], [ - -0.38629936209808513, - 0.38629936209808513, - -2.206668958834267 + 1.6933670667313323, + -0.756723407945564, + -1.513446815891128 ], [ - 0.5556360687712184, - -0.7725987241961703, - -2.000289847576386 + -1.4605290950557739, + 1.0795215050412243, + -0.19579556709081028 ], [ - 2.206668958834267, - -1.98441453132578, - -2.000289847576386 + 2.4500904746768963, + -0.25929683209323523, + -0.25929683209323523 ], [ - 2.201377186750732, - -2.201377186750732, - -2.206668958834267 + 2.4500904746768963, + -1.513446815891128, + -1.513446815891128 ], [ - 2.000289847576386, - -2.000289847576386, - -2.2225442750848736 + 1.1324392258765785, + -0.19579556709081028, + -1.513446815891128 ], [ - 1.98441453132578, - -2.206668958834267, - -2.000289847576386 + 1.1324392258765785, + -1.513446815891128, + -0.19579556709081028 ], [ - -0.5291772083535413, - 0.4021746783486914, - 0.4021746783486914 + -1.98441453132578, + 1.1483145421271845, + 1.1483145421271845 ], [ - -0.5291772083535413, - 0.5291772083535413, - 0.5291772083535413 + -1.98441453132578, + 1.7992025084020404, + 1.7992025084020404 ], [ - -0.40746645043222685, - 0.40746645043222685, - 0.5291772083535413 + -1.0689379608741534, + 0.883725937950414, + 1.7992025084020404 ], [ - -0.4021746783486914, - 0.5291772083535413, - 0.4021746783486914 + -1.0689379608741534, + 1.7992025084020404, + 0.883725937950414 ], [ - 0.1587531625060624, - -0.2857556925109123, - 0.4021746783486914 + 0.015875316250606238, + -0.8519753054492015, + 1.1483145421271845 ], [ - 0.1587531625060624, - -0.1587531625060624, - 0.5291772083535413 + 0.015875316250606238, + -0.2010873391743457, + 1.7992025084020404 ], [ - -0.2540050600096998, - 0.2540050600096998, - 0.5291772083535413 + -0.9578107471199098, + 0.7725987241961703, + 1.7992025084020404 ], [ - 0.2857556925109123, - -0.1587531625060624, - 0.4021746783486914 + 0.9313518867022327, + -0.2010873391743457, + 0.883725937950414 ], [ - -0.5291772083535413, - 0.2540050600096998, - 0.2540050600096998 + -1.98441453132578, + 1.1959404908790032, + 1.1959404908790032 ], [ - -0.5291772083535413, - -0.16404493458959782, - -0.16404493458959782 + -1.98441453132578, + 0.7884740404467766, + 0.7884740404467766 ], [ - -0.40746645043222685, - -0.29104746459444775, - -0.16933670667313322 + -1.0689379608741534, + -0.1270025300048499, + 0.7884740404467766 ], [ - -0.4021746783486914, - -0.16933670667313322, - -0.2963392366779832 + -1.0689379608741534, + 0.7884740404467766, + -0.1270025300048499 ], [ - 0.15346139042252696, - -0.4286335387663685, - 0.25929683209323523 + 0.015875316250606238, + -0.8043493566973828, + 1.1959404908790032 ], [ - 0.1587531625060624, - -0.8519753054492015, - -0.16404493458959782 + 0.015875316250606238, + -1.2118158071296097, + 0.7884740404467766 ], [ - -0.25929683209323523, - -0.4286335387663685, - -0.1587531625060624 + -0.9578107471199098, + -0.2381297437590936, + 0.7884740404467766 ], [ - 0.2804639204273769, - -0.8466835333656662, - -0.2857556925109123 + 0.9313518867022327, + -1.2118158071296097, + -0.1270025300048499 ], [ - 0.16933670667313322, - 0.4021746783486914, - -0.2963392366779832 + 0.015875316250606238, + 1.1483145421271845, + -0.8519753054492015 ], [ - 0.16404493458959782, - 0.5291772083535413, - -0.16404493458959782 + 0.015875316250606238, + 1.7992025084020404, + -0.2010873391743457 ], [ - 0.29104746459444775, - 0.40746645043222685, - -0.16933670667313322 + 0.9313518867022327, + 0.883725937950414, + -0.2010873391743457 ], [ - -0.2540050600096998, - 0.5291772083535413, - 0.2540050600096998 + -0.9578107471199098, + 1.7992025084020404, + 0.7725987241961703 ], [ - 0.8466835333656662, - -0.2804639204273769, - -0.2857556925109123 + 2.0161651638269924, + -0.8519753054492015, + -0.8519753054492015 ], [ - 0.8519753054492015, - -0.1587531625060624, - -0.16404493458959782 + 2.0161651638269924, + -0.2010873391743457, + -0.2010873391743457 ], [ - 0.4286335387663685, - 0.25929683209323523, - -0.1587531625060624 + 1.0424791004564764, + 0.7725987241961703, + -0.2010873391743457 ], [ - 0.4286335387663685, - -0.15346139042252696, - 0.25929683209323523 + 1.0424791004564764, + -0.2010873391743457, + 0.7725987241961703 ], [ - 0.1587531625060624, - 0.25929683209323523, - -0.4339253108499039 + 0.015875316250606238, + 1.1959404908790032, + -0.8043493566973828 ], [ - 0.16404493458959782, - -0.16404493458959782, - -0.857267077532737 + 0.015875316250606238, + 0.7884740404467766, + -1.2118158071296097 ], [ - 0.2804639204273769, - -0.2804639204273769, - -0.8519753054492015 + 0.9313518867022327, + -0.1270025300048499, + -1.2118158071296097 ], [ - -0.25929683209323523, - -0.1587531625060624, - -0.4339253108499039 + -0.9578107471199098, + 0.7884740404467766, + -0.2381297437590936 ], [ - 0.8466835333656662, - -0.4233417666828331, - -0.4339253108499039 + 2.0161651638269924, + -0.8043493566973828, + -0.8043493566973828 ], [ - 0.8466835333656662, - -0.8466835333656662, - -0.8519753054492015 + 2.0161651638269924, + -1.2118158071296097, + -1.2118158071296097 ], [ - 0.4339253108499039, - -0.4339253108499039, - -0.857267077532737 + 1.0424791004564764, + -0.2381297437590936, + -1.2118158071296097 ], [ - 0.4233417666828331, - -0.8466835333656662, - -0.4339253108499039 + 1.0424791004564764, + -1.2118158071296097, + -0.2381297437590936 ] ] ], "spreads": [ [ - 2.585503305224543, - 1.3953821044009418, - 2.5779425352428396, - 2.585503305224543, - 9.937932069653828, - 9.265583598317955, - 1.9638399956178618, - 9.937932069653828, - 1.9624398530286575, - 9.255782600193523, - 9.903208533441564, - 9.909369160834062, - 10.024180853148808, - 15.910100269645579, - 9.981616518437, - 16.073636924064633, - 9.909369160834062, - 9.255782600193523, - 9.903208533441564, - 1.9624398530286575, - 16.073636924064633, - 15.910100269645579, - 9.981616518437, - 10.024180853148808, - 9.980216375847796, - 15.876216818986835, - 16.0699965533327, - 9.980216375847796, - 16.732824055061986, - 21.2712462437086, - 16.665897239298026, - 16.732824055061986, - 9.433600709022462, - 6.218033238656013, - 9.423239653862352, - 9.433600709022462, - 13.362120785811708, - 10.467746025408712, - 8.710567075957396, - 13.362120785811708, - 8.709446961886032, - 10.475306795390415, - 13.365201099507958, - 13.373321926525342, - 14.240010189242764, - 17.276359408191073, - 14.238890075171401, - 19.869423483397316, - 13.373321926525342, - 10.475306795390415, - 13.365201099507958, - 8.709446961886032, - 19.869423483397316, - 17.276359408191073, - 14.238890075171401, - 14.240010189242764, - 14.240290217760606, - 17.274119180048345, - 19.861862713415615, - 14.240290217760606, - 22.231464031384863, - 26.55006383352641, - 22.21690254845714, - 22.231464031384863 + 3.6636130989118048, + 7.869361408363489, + 16.096879291045422, + 16.096879291045422, + 3.641210817484537, + 7.478721625975508, + 7.843598784722132, + 15.941743492161594, + 3.0352291048769438, + 2.3541997494880027, + 12.356818406763068, + 12.356818406763068, + 2.4905736376764955, + 1.9851221629737663, + 2.0358073247029593, + 12.223244803752982, + 3.641210817484537, + 7.478721625975508, + 15.941743492161594, + 7.843598784722132, + 3.6678135266794176, + 7.137366862727514, + 7.417115352050521, + 7.417115352050521, + 2.4905736376764955, + 1.9851221629737663, + 12.223244803752982, + 2.0358073247029593, + 1.9949231610981957, + 1.6650495670816776, + 1.6308860879050944, + 1.6308860879050944, + 11.364397339535104, + 13.345599103259099, + 14.273053554347985, + 14.273053554347985, + 10.816381530120566, + 11.969538966589175, + 16.047594271905435, + 13.339158447348758, + 11.672148680642197, + 8.5604717903947, + 10.882188231813165, + 10.882188231813165, + 10.118550463661174, + 7.644498508537289, + 8.574753244804583, + 10.408660008144293, + 10.816381530120566, + 11.969538966589175, + 13.339158447348758, + 16.047594271905435, + 10.956115760523149, + 11.280668812700691, + 14.52927964817236, + 14.52927964817236, + 10.118550463661174, + 7.644498508537289, + 10.408660008144293, + 8.574753244804583, + 9.251862200943753, + 7.415995237979158, + 7.516805504401863, + 7.516805504401863 ], [ - 2.585503305224543, - 1.3953821044009418, - 2.5779425352428396, - 2.585503305224543, - 9.937932069653828, - 9.265583598317955, - 1.9638399956178618, - 9.937932069653828, - 1.9624398530286575, - 9.255782600193523, - 9.903208533441564, - 9.909369160834062, - 10.024180853148808, - 15.910100269645579, - 9.981616518437, - 16.073636924064633, - 9.909369160834062, - 9.255782600193523, - 9.903208533441564, - 1.9624398530286575, - 16.073636924064633, - 15.910100269645579, - 9.981616518437, - 10.024180853148808, - 9.980216375847796, - 15.876216818986835, - 16.0699965533327, - 9.980216375847796, - 16.732824055061986, - 21.2712462437086, - 16.665897239298026, - 16.732824055061986, - 9.433600709022462, - 6.218033238656013, - 9.423239653862352, - 9.433600709022462, - 13.362120785811708, - 10.467746025408712, - 8.710567075957396, - 13.362120785811708, - 8.709446961886032, - 10.475306795390415, - 13.365201099507958, - 13.373321926525342, - 14.240010189242764, - 17.276359408191073, - 14.238890075171401, - 19.869423483397316, - 13.373321926525342, - 10.475306795390415, - 13.365201099507958, - 8.709446961886032, - 19.869423483397316, - 17.276359408191073, - 14.238890075171401, - 14.240010189242764, - 14.240290217760606, - 17.274119180048345, - 19.861862713415615, - 14.240290217760606, - 22.231464031384863, - 26.55006383352641, - 22.21690254845714, - 22.231464031384863 + 3.6636130989118048, + 7.869361408363489, + 16.096879291045422, + 16.096879291045422, + 3.641210817484537, + 7.478721625975508, + 7.843598784722132, + 15.941743492161594, + 3.0352291048769438, + 2.3541997494880027, + 12.356818406763068, + 12.356818406763068, + 2.4905736376764955, + 1.9851221629737663, + 2.0358073247029593, + 12.223244803752982, + 3.641210817484537, + 7.478721625975508, + 15.941743492161594, + 7.843598784722132, + 3.6678135266794176, + 7.137366862727514, + 7.417115352050521, + 7.417115352050521, + 2.4905736376764955, + 1.9851221629737663, + 12.223244803752982, + 2.0358073247029593, + 1.9949231610981957, + 1.6650495670816776, + 1.6308860879050944, + 1.6308860879050944, + 11.364397339535104, + 13.345599103259099, + 14.273053554347985, + 14.273053554347985, + 10.816381530120566, + 11.969538966589175, + 16.047594271905435, + 13.339158447348758, + 11.672148680642197, + 8.5604717903947, + 10.882188231813165, + 10.882188231813165, + 10.118550463661174, + 7.644498508537289, + 8.574753244804583, + 10.408660008144293, + 10.816381530120566, + 11.969538966589175, + 13.339158447348758, + 16.047594271905435, + 10.956115760523149, + 11.280668812700691, + 14.52927964817236, + 14.52927964817236, + 10.118550463661174, + 7.644498508537289, + 10.408660008144293, + 8.574753244804583, + 9.251862200943753, + 7.415995237979158, + 7.516805504401863, + 7.516805504401863 ] ], "self-Hartree": [ @@ -34224,7 +34224,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -34505,5 +34505,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-final-ki_final.json b/tests/benchmarks/tutorials-tutorial_2-final-ki_final.json index 86eeddc0c..c92569cfc 100644 --- a/tests/benchmarks/tutorials-tutorial_2-final-ki_final.json +++ b/tests/benchmarks/tutorials-tutorial_2-final-ki_final.json @@ -468,781 +468,781 @@ "centres": [ [ [ - -0.666763282525462, - 1.8203695967361821, - 1.8203695967361821 + -2.7358461671878085, + 0.015875316250606238, + 0.015875316250606238 ], [ - -0.666763282525462, - 0.666763282525462, - 0.666763282525462 + -2.7358461671878085, + 2.947517050529225, + 2.947517050529225 ], [ - -1.8256613688197176, - 1.8256613688197176, - 0.666763282525462 + -0.8996012542010202, + 1.1112721375424368, + 2.947517050529225 ], [ - -1.8203695967361821, - 0.666763282525462, - 1.8203695967361821 + -0.8996012542010202, + 2.947517050529225, + 1.1112721375424368 ], [ - 0.7778904962797057, - 0.37571581793101433, - 1.8203695967361821 + -0.14287784625545616, + -2.577093004681746, + 0.015875316250606238 ], [ - 0.7831822683632411, - -0.7831822683632411, - 0.666763282525462 + -0.14287784625545616, + 0.3598405016804081, + 2.947517050529225 ], [ - 0.5556360687712184, - -0.5556360687712184, - 0.666763282525462 + -1.4605290950557739, + 1.6721999783971906, + 2.947517050529225 ], [ - -0.37571581793101433, - -0.7778904962797057, - 1.8203695967361821 + 1.6933670667313323, + 0.3598405016804081, + 1.1112721375424368 ], [ - -0.666763282525462, - -0.5556360687712184, - -0.5556360687712184 + -2.7358461671878085, + 2.3336714888391175, + 2.3336714888391175 ], [ - -0.666763282525462, - -0.7831822683632411, - -0.7831822683632411 + -2.7358461671878085, + 1.0795215050412243, + 1.0795215050412243 ], [ - -1.8203695967361821, - 0.3704240458474789, - -0.7831822683632411 + -0.8996012542010202, + -0.756723407945564, + 1.0795215050412243 ], [ - -1.8203695967361821, - -0.7831822683632411, - 0.3704240458474789 + -0.8996012542010202, + 1.0795215050412243, + -0.756723407945564 ], [ - 0.7620151800290995, - -1.9897063034093152, - -0.5556360687712184 + -0.14287784625545616, + -0.25929683209323523, + 2.3336714888391175 ], [ - 0.7725987241961703, - -2.2225442750848736, - -0.7831822683632411 + -0.14287784625545616, + -1.513446815891128, + 1.0795215050412243 ], [ - 0.5556360687712184, - -2.000289847576386, - -0.7725987241961703 + -1.4605290950557739, + -0.19579556709081028, + 1.0795215050412243 ], [ - -0.38629936209808513, - -2.201377186750732, - 0.38629936209808513 + 1.6933670667313323, + -1.513446815891128, + -0.756723407945564 ], [ - 0.7831822683632411, - 1.8203695967361821, - 0.3704240458474789 + -0.14287784625545616, + 0.015875316250606238, + -2.577093004681746 ], [ - 0.7831822683632411, - 0.666763282525462, - -0.7831822683632411 + -0.14287784625545616, + 2.947517050529225, + 0.3598405016804081 ], [ - -0.3704240458474789, - 1.8203695967361821, - -0.7831822683632411 + 1.6933670667313323, + 1.1112721375424368, + 0.3598405016804081 ], [ - 0.5556360687712184, - 0.666763282525462, - -0.5556360687712184 + -1.4605290950557739, + 2.947517050529225, + 1.6721999783971906 ], [ - 2.201377186750732, - 0.38629936209808513, - 0.38629936209808513 + 2.4500904746768963, + -2.577093004681746, + -2.577093004681746 ], [ - 2.2225442750848736, - -0.7725987241961703, - -0.7831822683632411 + 2.4500904746768963, + 0.3598405016804081, + 0.3598405016804081 ], [ - 2.000289847576386, - -0.5556360687712184, - -0.7725987241961703 + 1.1324392258765785, + 1.6721999783971906, + 0.3598405016804081 ], [ - 1.9897063034093152, - -0.7620151800290995, - -0.5556360687712184 + 1.1324392258765785, + 0.3598405016804081, + 1.6721999783971906 ], [ - 0.7725987241961703, - -0.5556360687712184, - -2.000289847576386 + -0.14287784625545616, + 2.3336714888391175, + -0.25929683209323523 ], [ - 0.7831822683632411, - -0.7831822683632411, - -2.233127819251944 + -0.14287784625545616, + 1.0795215050412243, + -1.513446815891128 ], [ - -0.38629936209808513, - 0.38629936209808513, - -2.206668958834267 + 1.6933670667313323, + -0.756723407945564, + -1.513446815891128 ], [ - 0.5556360687712184, - -0.7725987241961703, - -2.000289847576386 + -1.4605290950557739, + 1.0795215050412243, + -0.19579556709081028 ], [ - 2.206668958834267, - -1.98441453132578, - -2.000289847576386 + 2.4500904746768963, + -0.25929683209323523, + -0.25929683209323523 ], [ - 2.201377186750732, - -2.201377186750732, - -2.206668958834267 + 2.4500904746768963, + -1.513446815891128, + -1.513446815891128 ], [ - 2.000289847576386, - -2.000289847576386, - -2.2225442750848736 + 1.1324392258765785, + -0.19579556709081028, + -1.513446815891128 ], [ - 1.98441453132578, - -2.206668958834267, - -2.000289847576386 + 1.1324392258765785, + -1.513446815891128, + -0.19579556709081028 ], [ - -0.5291772083535413, - 0.4021746783486914, - 0.4021746783486914 + -1.98441453132578, + 1.1483145421271845, + 1.1483145421271845 ], [ - -0.5291772083535413, - 0.5291772083535413, - 0.5291772083535413 + -1.98441453132578, + 1.7992025084020404, + 1.7992025084020404 ], [ - -0.40746645043222685, - 0.40746645043222685, - 0.5291772083535413 + -1.0689379608741534, + 0.883725937950414, + 1.7992025084020404 ], [ - -0.4021746783486914, - 0.5291772083535413, - 0.4021746783486914 + -1.0689379608741534, + 1.7992025084020404, + 0.883725937950414 ], [ - 0.1587531625060624, - -0.2857556925109123, - 0.4021746783486914 + 0.015875316250606238, + -0.8519753054492015, + 1.1483145421271845 ], [ - 0.1587531625060624, - -0.1587531625060624, - 0.5291772083535413 + 0.015875316250606238, + -0.2010873391743457, + 1.7992025084020404 ], [ - -0.2540050600096998, - 0.2540050600096998, - 0.5291772083535413 + -0.9578107471199098, + 0.7725987241961703, + 1.7992025084020404 ], [ - 0.2857556925109123, - -0.1587531625060624, - 0.4021746783486914 + 0.9313518867022327, + -0.2010873391743457, + 0.883725937950414 ], [ - -0.5291772083535413, - 0.2540050600096998, - 0.2540050600096998 + -1.98441453132578, + 1.1959404908790032, + 1.1959404908790032 ], [ - -0.5291772083535413, - -0.16404493458959782, - -0.16404493458959782 + -1.98441453132578, + 0.7884740404467766, + 0.7884740404467766 ], [ - -0.40746645043222685, - -0.29104746459444775, - -0.16933670667313322 + -1.0689379608741534, + -0.1270025300048499, + 0.7884740404467766 ], [ - -0.4021746783486914, - -0.16933670667313322, - -0.2963392366779832 + -1.0689379608741534, + 0.7884740404467766, + -0.1270025300048499 ], [ - 0.15346139042252696, - -0.4286335387663685, - 0.25929683209323523 + 0.015875316250606238, + -0.8043493566973828, + 1.1959404908790032 ], [ - 0.1587531625060624, - -0.8519753054492015, - -0.16404493458959782 + 0.015875316250606238, + -1.2118158071296097, + 0.7884740404467766 ], [ - -0.25929683209323523, - -0.4286335387663685, - -0.1587531625060624 + -0.9578107471199098, + -0.2381297437590936, + 0.7884740404467766 ], [ - 0.2804639204273769, - -0.8466835333656662, - -0.2857556925109123 + 0.9313518867022327, + -1.2118158071296097, + -0.1270025300048499 ], [ - 0.16933670667313322, - 0.4021746783486914, - -0.2963392366779832 + 0.015875316250606238, + 1.1483145421271845, + -0.8519753054492015 ], [ - 0.16404493458959782, - 0.5291772083535413, - -0.16404493458959782 + 0.015875316250606238, + 1.7992025084020404, + -0.2010873391743457 ], [ - 0.29104746459444775, - 0.40746645043222685, - -0.16933670667313322 + 0.9313518867022327, + 0.883725937950414, + -0.2010873391743457 ], [ - -0.2540050600096998, - 0.5291772083535413, - 0.2540050600096998 + -0.9578107471199098, + 1.7992025084020404, + 0.7725987241961703 ], [ - 0.8466835333656662, - -0.2804639204273769, - -0.2857556925109123 + 2.0161651638269924, + -0.8519753054492015, + -0.8519753054492015 ], [ - 0.8519753054492015, - -0.1587531625060624, - -0.16404493458959782 + 2.0161651638269924, + -0.2010873391743457, + -0.2010873391743457 ], [ - 0.4286335387663685, - 0.25929683209323523, - -0.1587531625060624 + 1.0424791004564764, + 0.7725987241961703, + -0.2010873391743457 ], [ - 0.4286335387663685, - -0.15346139042252696, - 0.25929683209323523 + 1.0424791004564764, + -0.2010873391743457, + 0.7725987241961703 ], [ - 0.1587531625060624, - 0.25929683209323523, - -0.4339253108499039 + 0.015875316250606238, + 1.1959404908790032, + -0.8043493566973828 ], [ - 0.16404493458959782, - -0.16404493458959782, - -0.857267077532737 + 0.015875316250606238, + 0.7884740404467766, + -1.2118158071296097 ], [ - 0.2804639204273769, - -0.2804639204273769, - -0.8519753054492015 + 0.9313518867022327, + -0.1270025300048499, + -1.2118158071296097 ], [ - -0.25929683209323523, - -0.1587531625060624, - -0.4339253108499039 + -0.9578107471199098, + 0.7884740404467766, + -0.2381297437590936 ], [ - 0.8466835333656662, - -0.4233417666828331, - -0.4339253108499039 + 2.0161651638269924, + -0.8043493566973828, + -0.8043493566973828 ], [ - 0.8466835333656662, - -0.8466835333656662, - -0.8519753054492015 + 2.0161651638269924, + -1.2118158071296097, + -1.2118158071296097 ], [ - 0.4339253108499039, - -0.4339253108499039, - -0.857267077532737 + 1.0424791004564764, + -0.2381297437590936, + -1.2118158071296097 ], [ - 0.4233417666828331, - -0.8466835333656662, - -0.4339253108499039 + 1.0424791004564764, + -1.2118158071296097, + -0.2381297437590936 ] ], [ [ - -0.666763282525462, - 1.8203695967361821, - 1.8203695967361821 + -2.7358461671878085, + 0.015875316250606238, + 0.015875316250606238 ], [ - -0.666763282525462, - 0.666763282525462, - 0.666763282525462 + -2.7358461671878085, + 2.947517050529225, + 2.947517050529225 ], [ - -1.8256613688197176, - 1.8256613688197176, - 0.666763282525462 + -0.8996012542010202, + 1.1112721375424368, + 2.947517050529225 ], [ - -1.8203695967361821, - 0.666763282525462, - 1.8203695967361821 + -0.8996012542010202, + 2.947517050529225, + 1.1112721375424368 ], [ - 0.7778904962797057, - 0.37571581793101433, - 1.8203695967361821 + -0.14287784625545616, + -2.577093004681746, + 0.015875316250606238 ], [ - 0.7831822683632411, - -0.7831822683632411, - 0.666763282525462 + -0.14287784625545616, + 0.3598405016804081, + 2.947517050529225 ], [ - 0.5556360687712184, - -0.5556360687712184, - 0.666763282525462 + -1.4605290950557739, + 1.6721999783971906, + 2.947517050529225 ], [ - -0.37571581793101433, - -0.7778904962797057, - 1.8203695967361821 + 1.6933670667313323, + 0.3598405016804081, + 1.1112721375424368 ], [ - -0.666763282525462, - -0.5556360687712184, - -0.5556360687712184 + -2.7358461671878085, + 2.3336714888391175, + 2.3336714888391175 ], [ - -0.666763282525462, - -0.7831822683632411, - -0.7831822683632411 + -2.7358461671878085, + 1.0795215050412243, + 1.0795215050412243 ], [ - -1.8203695967361821, - 0.3704240458474789, - -0.7831822683632411 + -0.8996012542010202, + -0.756723407945564, + 1.0795215050412243 ], [ - -1.8203695967361821, - -0.7831822683632411, - 0.3704240458474789 + -0.8996012542010202, + 1.0795215050412243, + -0.756723407945564 ], [ - 0.7620151800290995, - -1.9897063034093152, - -0.5556360687712184 + -0.14287784625545616, + -0.25929683209323523, + 2.3336714888391175 ], [ - 0.7725987241961703, - -2.2225442750848736, - -0.7831822683632411 + -0.14287784625545616, + -1.513446815891128, + 1.0795215050412243 ], [ - 0.5556360687712184, - -2.000289847576386, - -0.7725987241961703 + -1.4605290950557739, + -0.19579556709081028, + 1.0795215050412243 ], [ - -0.38629936209808513, - -2.201377186750732, - 0.38629936209808513 + 1.6933670667313323, + -1.513446815891128, + -0.756723407945564 ], [ - 0.7831822683632411, - 1.8203695967361821, - 0.3704240458474789 + -0.14287784625545616, + 0.015875316250606238, + -2.577093004681746 ], [ - 0.7831822683632411, - 0.666763282525462, - -0.7831822683632411 + -0.14287784625545616, + 2.947517050529225, + 0.3598405016804081 ], [ - -0.3704240458474789, - 1.8203695967361821, - -0.7831822683632411 + 1.6933670667313323, + 1.1112721375424368, + 0.3598405016804081 ], [ - 0.5556360687712184, - 0.666763282525462, - -0.5556360687712184 + -1.4605290950557739, + 2.947517050529225, + 1.6721999783971906 ], [ - 2.201377186750732, - 0.38629936209808513, - 0.38629936209808513 + 2.4500904746768963, + -2.577093004681746, + -2.577093004681746 ], [ - 2.2225442750848736, - -0.7725987241961703, - -0.7831822683632411 + 2.4500904746768963, + 0.3598405016804081, + 0.3598405016804081 ], [ - 2.000289847576386, - -0.5556360687712184, - -0.7725987241961703 + 1.1324392258765785, + 1.6721999783971906, + 0.3598405016804081 ], [ - 1.9897063034093152, - -0.7620151800290995, - -0.5556360687712184 + 1.1324392258765785, + 0.3598405016804081, + 1.6721999783971906 ], [ - 0.7725987241961703, - -0.5556360687712184, - -2.000289847576386 + -0.14287784625545616, + 2.3336714888391175, + -0.25929683209323523 ], [ - 0.7831822683632411, - -0.7831822683632411, - -2.233127819251944 + -0.14287784625545616, + 1.0795215050412243, + -1.513446815891128 ], [ - -0.38629936209808513, - 0.38629936209808513, - -2.206668958834267 + 1.6933670667313323, + -0.756723407945564, + -1.513446815891128 ], [ - 0.5556360687712184, - -0.7725987241961703, - -2.000289847576386 + -1.4605290950557739, + 1.0795215050412243, + -0.19579556709081028 ], [ - 2.206668958834267, - -1.98441453132578, - -2.000289847576386 + 2.4500904746768963, + -0.25929683209323523, + -0.25929683209323523 ], [ - 2.201377186750732, - -2.201377186750732, - -2.206668958834267 + 2.4500904746768963, + -1.513446815891128, + -1.513446815891128 ], [ - 2.000289847576386, - -2.000289847576386, - -2.2225442750848736 + 1.1324392258765785, + -0.19579556709081028, + -1.513446815891128 ], [ - 1.98441453132578, - -2.206668958834267, - -2.000289847576386 + 1.1324392258765785, + -1.513446815891128, + -0.19579556709081028 ], [ - -0.5291772083535413, - 0.4021746783486914, - 0.4021746783486914 + -1.98441453132578, + 1.1483145421271845, + 1.1483145421271845 ], [ - -0.5291772083535413, - 0.5291772083535413, - 0.5291772083535413 + -1.98441453132578, + 1.7992025084020404, + 1.7992025084020404 ], [ - -0.40746645043222685, - 0.40746645043222685, - 0.5291772083535413 + -1.0689379608741534, + 0.883725937950414, + 1.7992025084020404 ], [ - -0.4021746783486914, - 0.5291772083535413, - 0.4021746783486914 + -1.0689379608741534, + 1.7992025084020404, + 0.883725937950414 ], [ - 0.1587531625060624, - -0.2857556925109123, - 0.4021746783486914 + 0.015875316250606238, + -0.8519753054492015, + 1.1483145421271845 ], [ - 0.1587531625060624, - -0.1587531625060624, - 0.5291772083535413 + 0.015875316250606238, + -0.2010873391743457, + 1.7992025084020404 ], [ - -0.2540050600096998, - 0.2540050600096998, - 0.5291772083535413 + -0.9578107471199098, + 0.7725987241961703, + 1.7992025084020404 ], [ - 0.2857556925109123, - -0.1587531625060624, - 0.4021746783486914 + 0.9313518867022327, + -0.2010873391743457, + 0.883725937950414 ], [ - -0.5291772083535413, - 0.2540050600096998, - 0.2540050600096998 + -1.98441453132578, + 1.1959404908790032, + 1.1959404908790032 ], [ - -0.5291772083535413, - -0.16404493458959782, - -0.16404493458959782 + -1.98441453132578, + 0.7884740404467766, + 0.7884740404467766 ], [ - -0.40746645043222685, - -0.29104746459444775, - -0.16933670667313322 + -1.0689379608741534, + -0.1270025300048499, + 0.7884740404467766 ], [ - -0.4021746783486914, - -0.16933670667313322, - -0.2963392366779832 + -1.0689379608741534, + 0.7884740404467766, + -0.1270025300048499 ], [ - 0.15346139042252696, - -0.4286335387663685, - 0.25929683209323523 + 0.015875316250606238, + -0.8043493566973828, + 1.1959404908790032 ], [ - 0.1587531625060624, - -0.8519753054492015, - -0.16404493458959782 + 0.015875316250606238, + -1.2118158071296097, + 0.7884740404467766 ], [ - -0.25929683209323523, - -0.4286335387663685, - -0.1587531625060624 + -0.9578107471199098, + -0.2381297437590936, + 0.7884740404467766 ], [ - 0.2804639204273769, - -0.8466835333656662, - -0.2857556925109123 + 0.9313518867022327, + -1.2118158071296097, + -0.1270025300048499 ], [ - 0.16933670667313322, - 0.4021746783486914, - -0.2963392366779832 + 0.015875316250606238, + 1.1483145421271845, + -0.8519753054492015 ], [ - 0.16404493458959782, - 0.5291772083535413, - -0.16404493458959782 + 0.015875316250606238, + 1.7992025084020404, + -0.2010873391743457 ], [ - 0.29104746459444775, - 0.40746645043222685, - -0.16933670667313322 + 0.9313518867022327, + 0.883725937950414, + -0.2010873391743457 ], [ - -0.2540050600096998, - 0.5291772083535413, - 0.2540050600096998 + -0.9578107471199098, + 1.7992025084020404, + 0.7725987241961703 ], [ - 0.8466835333656662, - -0.2804639204273769, - -0.2857556925109123 + 2.0161651638269924, + -0.8519753054492015, + -0.8519753054492015 ], [ - 0.8519753054492015, - -0.1587531625060624, - -0.16404493458959782 + 2.0161651638269924, + -0.2010873391743457, + -0.2010873391743457 ], [ - 0.4286335387663685, - 0.25929683209323523, - -0.1587531625060624 + 1.0424791004564764, + 0.7725987241961703, + -0.2010873391743457 ], [ - 0.4286335387663685, - -0.15346139042252696, - 0.25929683209323523 + 1.0424791004564764, + -0.2010873391743457, + 0.7725987241961703 ], [ - 0.1587531625060624, - 0.25929683209323523, - -0.4339253108499039 + 0.015875316250606238, + 1.1959404908790032, + -0.8043493566973828 ], [ - 0.16404493458959782, - -0.16404493458959782, - -0.857267077532737 + 0.015875316250606238, + 0.7884740404467766, + -1.2118158071296097 ], [ - 0.2804639204273769, - -0.2804639204273769, - -0.8519753054492015 + 0.9313518867022327, + -0.1270025300048499, + -1.2118158071296097 ], [ - -0.25929683209323523, - -0.1587531625060624, - -0.4339253108499039 + -0.9578107471199098, + 0.7884740404467766, + -0.2381297437590936 ], [ - 0.8466835333656662, - -0.4233417666828331, - -0.4339253108499039 + 2.0161651638269924, + -0.8043493566973828, + -0.8043493566973828 ], [ - 0.8466835333656662, - -0.8466835333656662, - -0.8519753054492015 + 2.0161651638269924, + -1.2118158071296097, + -1.2118158071296097 ], [ - 0.4339253108499039, - -0.4339253108499039, - -0.857267077532737 + 1.0424791004564764, + -0.2381297437590936, + -1.2118158071296097 ], [ - 0.4233417666828331, - -0.8466835333656662, - -0.4339253108499039 + 1.0424791004564764, + -1.2118158071296097, + -0.2381297437590936 ] ] ], "spreads": [ [ - 2.585503305224543, - 1.3953821044009418, - 2.5779425352428396, - 2.585503305224543, - 9.937932069653828, - 9.265583598317955, - 1.9638399956178618, - 9.937932069653828, - 1.9624398530286575, - 9.255782600193523, - 9.903208533441564, - 9.909369160834062, - 10.024180853148808, - 15.910100269645579, - 9.981616518437, - 16.073636924064633, - 9.909369160834062, - 9.255782600193523, - 9.903208533441564, - 1.9624398530286575, - 16.073636924064633, - 15.910100269645579, - 9.981616518437, - 10.024180853148808, - 9.980216375847796, - 15.876216818986835, - 16.0699965533327, - 9.980216375847796, - 16.732824055061986, - 21.2712462437086, - 16.665897239298026, - 16.732824055061986, - 9.433600709022462, - 6.218033238656013, - 9.423239653862352, - 9.433600709022462, - 13.362120785811708, - 10.467746025408712, - 8.710567075957396, - 13.362120785811708, - 8.709446961886032, - 10.475306795390415, - 13.365201099507958, - 13.373321926525342, - 14.240010189242764, - 17.276359408191073, - 14.238890075171401, - 19.869423483397316, - 13.373321926525342, - 10.475306795390415, - 13.365201099507958, - 8.709446961886032, - 19.869423483397316, - 17.276359408191073, - 14.238890075171401, - 14.240010189242764, - 14.240290217760606, - 17.274119180048345, - 19.861862713415615, - 14.240290217760606, - 22.231464031384863, - 26.55006383352641, - 22.21690254845714, - 22.231464031384863 + 3.6636130989118048, + 7.869361408363489, + 16.096879291045422, + 16.096879291045422, + 3.641210817484537, + 7.478721625975508, + 7.843598784722132, + 15.941743492161594, + 3.0352291048769438, + 2.3541997494880027, + 12.356818406763068, + 12.356818406763068, + 2.4905736376764955, + 1.9851221629737663, + 2.0358073247029593, + 12.223244803752982, + 3.641210817484537, + 7.478721625975508, + 15.941743492161594, + 7.843598784722132, + 3.6678135266794176, + 7.137366862727514, + 7.417115352050521, + 7.417115352050521, + 2.4905736376764955, + 1.9851221629737663, + 12.223244803752982, + 2.0358073247029593, + 1.9949231610981957, + 1.6650495670816776, + 1.6308860879050944, + 1.6308860879050944, + 11.364397339535104, + 13.345599103259099, + 14.273053554347985, + 14.273053554347985, + 10.816381530120566, + 11.969538966589175, + 16.047594271905435, + 13.339158447348758, + 11.672148680642197, + 8.5604717903947, + 10.882188231813165, + 10.882188231813165, + 10.118550463661174, + 7.644498508537289, + 8.574753244804583, + 10.408660008144293, + 10.816381530120566, + 11.969538966589175, + 13.339158447348758, + 16.047594271905435, + 10.956115760523149, + 11.280668812700691, + 14.52927964817236, + 14.52927964817236, + 10.118550463661174, + 7.644498508537289, + 10.408660008144293, + 8.574753244804583, + 9.251862200943753, + 7.415995237979158, + 7.516805504401863, + 7.516805504401863 ], [ - 2.585503305224543, - 1.3953821044009418, - 2.5779425352428396, - 2.585503305224543, - 9.937932069653828, - 9.265583598317955, - 1.9638399956178618, - 9.937932069653828, - 1.9624398530286575, - 9.255782600193523, - 9.903208533441564, - 9.909369160834062, - 10.024180853148808, - 15.910100269645579, - 9.981616518437, - 16.073636924064633, - 9.909369160834062, - 9.255782600193523, - 9.903208533441564, - 1.9624398530286575, - 16.073636924064633, - 15.910100269645579, - 9.981616518437, - 10.024180853148808, - 9.980216375847796, - 15.876216818986835, - 16.0699965533327, - 9.980216375847796, - 16.732824055061986, - 21.2712462437086, - 16.665897239298026, - 16.732824055061986, - 9.433600709022462, - 6.218033238656013, - 9.423239653862352, - 9.433600709022462, - 13.362120785811708, - 10.467746025408712, - 8.710567075957396, - 13.362120785811708, - 8.709446961886032, - 10.475306795390415, - 13.365201099507958, - 13.373321926525342, - 14.240010189242764, - 17.276359408191073, - 14.238890075171401, - 19.869423483397316, - 13.373321926525342, - 10.475306795390415, - 13.365201099507958, - 8.709446961886032, - 19.869423483397316, - 17.276359408191073, - 14.238890075171401, - 14.240010189242764, - 14.240290217760606, - 17.274119180048345, - 19.861862713415615, - 14.240290217760606, - 22.231464031384863, - 26.55006383352641, - 22.21690254845714, - 22.231464031384863 + 3.6636130989118048, + 7.869361408363489, + 16.096879291045422, + 16.096879291045422, + 3.641210817484537, + 7.478721625975508, + 7.843598784722132, + 15.941743492161594, + 3.0352291048769438, + 2.3541997494880027, + 12.356818406763068, + 12.356818406763068, + 2.4905736376764955, + 1.9851221629737663, + 2.0358073247029593, + 12.223244803752982, + 3.641210817484537, + 7.478721625975508, + 15.941743492161594, + 7.843598784722132, + 3.6678135266794176, + 7.137366862727514, + 7.417115352050521, + 7.417115352050521, + 2.4905736376764955, + 1.9851221629737663, + 12.223244803752982, + 2.0358073247029593, + 1.9949231610981957, + 1.6650495670816776, + 1.6308860879050944, + 1.6308860879050944, + 11.364397339535104, + 13.345599103259099, + 14.273053554347985, + 14.273053554347985, + 10.816381530120566, + 11.969538966589175, + 16.047594271905435, + 13.339158447348758, + 11.672148680642197, + 8.5604717903947, + 10.882188231813165, + 10.882188231813165, + 10.118550463661174, + 7.644498508537289, + 8.574753244804583, + 10.408660008144293, + 10.816381530120566, + 11.969538966589175, + 13.339158447348758, + 16.047594271905435, + 10.956115760523149, + 11.280668812700691, + 14.52927964817236, + 14.52927964817236, + 10.118550463661174, + 7.644498508537289, + 10.408660008144293, + 8.574753244804583, + 9.251862200943753, + 7.415995237979158, + 7.516805504401863, + 7.516805504401863 ] ], "self-Hartree": [ @@ -34222,7 +34222,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -34503,5 +34503,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-init-dft_dummy.json b/tests/benchmarks/tutorials-tutorial_2-init-dft_dummy.json index f8ab8736e..a98fba754 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-dft_dummy.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-dft_dummy.json @@ -4936,7 +4936,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -5083,5 +5083,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-init-dft_init.json b/tests/benchmarks/tutorials-tutorial_2-init-dft_init.json index 7c5a38068..12076a8e8 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-dft_init.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-dft_init.json @@ -17841,7 +17841,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -17988,5 +17988,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-pw2wan.json b/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-pw2wan.json index 610dc9848..05e1a4181 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-pw2wan.json @@ -94,7 +94,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -105,5 +105,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-w2kcp.json b/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-w2kcp.json index 55ea5ed4c..ddcbbebc8 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-w2kcp.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-w2kcp.json @@ -94,7 +94,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wann2kcp.x", "_flags": "", @@ -105,5 +105,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWann2KCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-wann.json b/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-wann.json index 76155ceba..c461e3f88 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-wann.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-wann.json @@ -177,7 +177,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -188,5 +188,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-wann_preproc.json index c85952b6f..08ea293c3 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-wannier-emp-wann_preproc.json @@ -1556,7 +1556,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -1567,5 +1567,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-init-wannier-nscf.json b/tests/benchmarks/tutorials-tutorial_2-init-wannier-nscf.json index a37f7a5cb..5340d1c0f 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-wannier-nscf.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-wannier-nscf.json @@ -126,7 +126,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -459,5 +459,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-pw2wan.json b/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-pw2wan.json index d42421175..99359111e 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-pw2wan.json @@ -94,7 +94,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -105,5 +105,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-w2kcp.json b/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-w2kcp.json index 7d00ed8e3..bcc29b911 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-w2kcp.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-w2kcp.json @@ -94,7 +94,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "wann2kcp.x", "_flags": "", @@ -105,5 +105,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWann2KCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-wann.json b/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-wann.json index a96a7c951..fbbc9bc3d 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-wann.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-wann.json @@ -174,7 +174,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -185,5 +185,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-wann_preproc.json index 8345732c3..2f1c1de0f 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-wannier-occ-wann_preproc.json @@ -1553,7 +1553,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -1564,5 +1564,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-init-wannier-scf.json b/tests/benchmarks/tutorials-tutorial_2-init-wannier-scf.json index 600b36ada..275969b6c 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-wannier-scf.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-wannier-scf.json @@ -123,7 +123,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -208,5 +208,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-emp-ki.json b/tests/benchmarks/tutorials-tutorial_2-postproc-emp-ki.json index 1773126d4..3ee9ec941 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-emp-ki.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-emp-ki.json @@ -27178,5 +27178,5 @@ ], "command": null, "__koopmans_name__": "BenchGenUnfoldAndInterpolateCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-occ-ki.json b/tests/benchmarks/tutorials-tutorial_2-postproc-occ-ki.json index 8871bcd5b..63b6b6542 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-occ-ki.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-occ-ki.json @@ -27178,5 +27178,5 @@ ], "command": null, "__koopmans_name__": "BenchGenUnfoldAndInterpolateCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-pdos-projwfc.json b/tests/benchmarks/tutorials-tutorial_2-postproc-pdos-projwfc.json index 8c11b3bf7..d6a8b140f 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-pdos-projwfc.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-pdos-projwfc.json @@ -34225,7 +34225,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "projwfc.x", "_flags": "", @@ -34243,5 +34243,5 @@ }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-bands.json b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-bands.json index 4b477556d..1dc8313eb 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-bands.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-bands.json @@ -1490,7 +1490,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -3223,5 +3223,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-emp-pw2wan.json b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-emp-pw2wan.json index 610dc9848..05e1a4181 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-emp-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-emp-pw2wan.json @@ -94,7 +94,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -105,5 +105,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-emp-wann.json b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-emp-wann.json index b06c07257..3e2eb8391 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-emp-wann.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-emp-wann.json @@ -6231,7 +6231,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -6242,5 +6242,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-emp-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-emp-wann_preproc.json index e9503f16c..ac6925ef8 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-emp-wann_preproc.json @@ -3068,7 +3068,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -3079,5 +3079,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-nscf.json b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-nscf.json index ea603b898..e98158c0c 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-nscf.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-nscf.json @@ -126,7 +126,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -20619,5 +20619,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-occ-pw2wan.json b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-occ-pw2wan.json index d42421175..99359111e 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-occ-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-occ-pw2wan.json @@ -94,7 +94,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -105,5 +105,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-occ-wann.json b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-occ-wann.json index 94e993f97..d939ae294 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-occ-wann.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-occ-wann.json @@ -6228,7 +6228,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -6239,5 +6239,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-occ-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-occ-wann_preproc.json index 4d4ed48c1..93a3a8b3b 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-occ-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-occ-wann_preproc.json @@ -3065,7 +3065,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -3076,5 +3076,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-scf.json b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-scf.json index 600b36ada..275969b6c 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-scf.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-scf.json @@ -123,7 +123,7 @@ "postfix": "", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -208,5 +208,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-hamiltonian-kc.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-hamiltonian-kc.json index 0153443e8..9006835c1 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-hamiltonian-kc.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-hamiltonian-kc.json @@ -7603,7 +7603,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcw.x", "_flags": "", @@ -7647,5 +7647,5 @@ ], "kpts": null, "__koopmans_name__": "BenchGenKoopmansHamCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-pdos-projwfc.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-pdos-projwfc.json index 4a1e91406..439cec311 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-pdos-projwfc.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-pdos-projwfc.json @@ -474855,7 +474855,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "projwfc.x", "_flags": "", @@ -474866,13 +474866,13 @@ "calc": {}, "skip_qc": false, "pseudopotentials": { - "Zn": "Zn.upf", - "O": "O.upf" + "O": "O.upf", + "Zn": "Zn.upf" }, "pseudo_dir": { "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-bands.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-bands.json index dea028871..365d221dc 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-bands.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-bands.json @@ -289,8 +289,8 @@ "__ase_objtype__": "bandpath" }, "pseudopotentials": { - "Zn": "Zn.upf", - "O": "O.upf" + "O": "O.upf", + "Zn": "Zn.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" @@ -6215,7 +6215,7 @@ "postfix": "-npool 4", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -13860,5 +13860,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-emp-pw2wan.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-emp-pw2wan.json index 4363e6721..4ba1c080a 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-emp-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-emp-pw2wan.json @@ -105,7 +105,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -116,5 +116,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-emp-wann.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-emp-wann.json index d7cfc53e4..760ff3ba0 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-emp-wann.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-emp-wann.json @@ -4417,7 +4417,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -4428,5 +4428,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-emp-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-emp-wann_preproc.json index 4403f9d9c..7479dc741 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-emp-wann_preproc.json @@ -326,7 +326,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -337,5 +337,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-kc.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-kc.json index ed1c191bb..ae0710c52 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-kc.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-kc.json @@ -114,7 +114,7 @@ "postfix": "-npool 4", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "kcw.x", "_flags": "", @@ -126,5 +126,5 @@ "skip_qc": false, "kpts": null, "__koopmans_name__": "BenchGenWann2KCCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-nscf.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-nscf.json index 3bb8b573a..616032050 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-nscf.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-nscf.json @@ -18,8 +18,8 @@ 4 ], "pseudopotentials": { - "Zn": "Zn.upf", - "O": "O.upf" + "O": "O.upf", + "Zn": "Zn.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" @@ -139,7 +139,7 @@ "postfix": "-npool 4", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -9368,5 +9368,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block1-pw2wan.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block1-pw2wan.json index 426d25ad2..3fa0c328d 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block1-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block1-pw2wan.json @@ -105,7 +105,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -116,5 +116,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block1-wann.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block1-wann.json index 81bcd595e..4bd3131d3 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block1-wann.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block1-wann.json @@ -4414,7 +4414,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -4425,5 +4425,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block1-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block1-wann_preproc.json index 18ab785a9..bb327b730 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block1-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block1-wann_preproc.json @@ -323,7 +323,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -334,5 +334,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block2-pw2wan.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block2-pw2wan.json index 1d821afb8..eb89c4983 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block2-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block2-pw2wan.json @@ -105,7 +105,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -116,5 +116,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block2-wann.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block2-wann.json index 332db0b4e..65a87362a 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block2-wann.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block2-wann.json @@ -6350,7 +6350,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -6361,5 +6361,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block2-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block2-wann_preproc.json index b23590999..2ab971ec9 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block2-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block2-wann_preproc.json @@ -323,7 +323,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -334,5 +334,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block3-pw2wan.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block3-pw2wan.json index 9a28003af..ec2cc053c 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block3-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block3-pw2wan.json @@ -105,7 +105,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -116,5 +116,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block3-wann.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block3-wann.json index 06a6737a0..4992982d3 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block3-wann.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block3-wann.json @@ -4414,7 +4414,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -4425,5 +4425,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block3-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block3-wann_preproc.json index a40cbe87d..02fd14264 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block3-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block3-wann_preproc.json @@ -323,7 +323,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -334,5 +334,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block4-pw2wan.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block4-pw2wan.json index 81df0fd86..32fb304a2 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block4-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block4-pw2wan.json @@ -105,7 +105,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -116,5 +116,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block4-wann.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block4-wann.json index 7d23fa4e5..f8e127220 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block4-wann.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block4-wann.json @@ -11194,7 +11194,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -11205,5 +11205,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block4-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block4-wann_preproc.json index 7448c4106..bc6c72421 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block4-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-occ_block4-wann_preproc.json @@ -327,7 +327,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -338,5 +338,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-scf.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-scf.json index f1e2a3647..3819156d8 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-scf.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-scf.json @@ -14,8 +14,8 @@ 4 ], "pseudopotentials": { - "Zn": "Zn.upf", - "O": "O.upf" + "O": "O.upf", + "Zn": "Zn.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" @@ -150,7 +150,7 @@ "postfix": "-npool 4", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -2095,5 +2095,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dft_bands-bands.json b/tests/benchmarks/tutorials-tutorial_3-dft_bands-bands.json index 5e204d300..6db0e82dd 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dft_bands-bands.json +++ b/tests/benchmarks/tutorials-tutorial_3-dft_bands-bands.json @@ -287,8 +287,8 @@ "__ase_objtype__": "bandpath" }, "pseudopotentials": { - "Zn": "Zn.upf", - "O": "O.upf" + "O": "O.upf", + "Zn": "Zn.upf" }, "pseudo_dir": { "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" @@ -3457,7 +3457,7 @@ "postfix": "-npool 4", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -7286,5 +7286,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dft_bands-projwfc.json b/tests/benchmarks/tutorials-tutorial_3-dft_bands-projwfc.json index ae24a6694..adf6b6920 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dft_bands-projwfc.json +++ b/tests/benchmarks/tutorials-tutorial_3-dft_bands-projwfc.json @@ -474854,7 +474854,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "projwfc.x", "_flags": "", @@ -474865,13 +474865,13 @@ "calc": {}, "skip_qc": false, "pseudopotentials": { - "Zn": "Zn.upf", - "O": "O.upf" + "O": "O.upf", + "Zn": "Zn.upf" }, "pseudo_dir": { "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-dft_bands-scf.json b/tests/benchmarks/tutorials-tutorial_3-dft_bands-scf.json index 81625f6e7..024882b58 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dft_bands-scf.json +++ b/tests/benchmarks/tutorials-tutorial_3-dft_bands-scf.json @@ -13,8 +13,8 @@ 4 ], "pseudopotentials": { - "Zn": "Zn.upf", - "O": "O.upf" + "O": "O.upf", + "Zn": "Zn.upf" }, "pseudo_dir": { "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" @@ -135,7 +135,7 @@ "postfix": "-npool 4", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../bin" + "__path__": "../../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -1114,5 +1114,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-pdos-projwfc.json b/tests/benchmarks/tutorials-tutorial_3-pdos-projwfc.json index 54f0f9ffc..00f111d24 100644 --- a/tests/benchmarks/tutorials-tutorial_3-pdos-projwfc.json +++ b/tests/benchmarks/tutorials-tutorial_3-pdos-projwfc.json @@ -474855,7 +474855,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "projwfc.x", "_flags": "", @@ -474866,13 +474866,13 @@ "calc": {}, "skip_qc": false, "pseudopotentials": { - "Zn": "Zn.upf", - "O": "O.upf" + "O": "O.upf", + "Zn": "Zn.upf" }, "pseudo_dir": { "__path__": "../../pseudos/pseudo_dojo_standard_v0.4.1/lda" }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-bands.json b/tests/benchmarks/tutorials-tutorial_3-wannier-bands.json index affb69be6..466181fa7 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-bands.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-bands.json @@ -288,8 +288,8 @@ "__ase_objtype__": "bandpath" }, "pseudopotentials": { - "Zn": "Zn.upf", - "O": "O.upf" + "O": "O.upf", + "Zn": "Zn.upf" }, "pseudo_dir": { "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" @@ -3458,7 +3458,7 @@ "postfix": "-npool 4", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -7287,5 +7287,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-emp-pw2wan.json b/tests/benchmarks/tutorials-tutorial_3-wannier-emp-pw2wan.json index c41855a57..d74db2607 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-emp-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-emp-pw2wan.json @@ -104,7 +104,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -115,5 +115,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-emp-wann.json b/tests/benchmarks/tutorials-tutorial_3-wannier-emp-wann.json index c7c246026..47c108c7f 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-emp-wann.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-emp-wann.json @@ -4415,7 +4415,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -4426,5 +4426,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-emp-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_3-wannier-emp-wann_preproc.json index ddef6f9a0..3ac64058d 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-emp-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-emp-wann_preproc.json @@ -324,7 +324,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -335,5 +335,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-nscf.json b/tests/benchmarks/tutorials-tutorial_3-wannier-nscf.json index 485fd12c4..798203ad9 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-nscf.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-nscf.json @@ -17,8 +17,8 @@ 4 ], "pseudopotentials": { - "Zn": "Zn.upf", - "O": "O.upf" + "O": "O.upf", + "Zn": "Zn.upf" }, "pseudo_dir": { "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" @@ -138,7 +138,7 @@ "postfix": "-npool 4", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -4759,5 +4759,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block1-pw2wan.json b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block1-pw2wan.json index 1174bf78f..4a2d18531 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block1-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block1-pw2wan.json @@ -104,7 +104,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -115,5 +115,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block1-wann.json b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block1-wann.json index 9e29018eb..5186b40a0 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block1-wann.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block1-wann.json @@ -4412,7 +4412,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -4423,5 +4423,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block1-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block1-wann_preproc.json index 8267526dc..528864fc0 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block1-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block1-wann_preproc.json @@ -321,7 +321,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -332,5 +332,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block2-pw2wan.json b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block2-pw2wan.json index 0842a920f..61ca777a0 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block2-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block2-pw2wan.json @@ -104,7 +104,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -115,5 +115,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block2-wann.json b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block2-wann.json index 92b4335aa..f1c05107d 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block2-wann.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block2-wann.json @@ -6348,7 +6348,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -6359,5 +6359,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block2-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block2-wann_preproc.json index 9ddc30c21..1c723c8c0 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block2-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block2-wann_preproc.json @@ -321,7 +321,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -332,5 +332,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block3-pw2wan.json b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block3-pw2wan.json index 6dd02eea9..0e96a2273 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block3-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block3-pw2wan.json @@ -104,7 +104,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -115,5 +115,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block3-wann.json b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block3-wann.json index da0b82f43..cbe069f1d 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block3-wann.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block3-wann.json @@ -4412,7 +4412,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -4423,5 +4423,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block3-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block3-wann_preproc.json index f73933698..77e39fbe9 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block3-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block3-wann_preproc.json @@ -321,7 +321,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -332,5 +332,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block4-pw2wan.json b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block4-pw2wan.json index 3f77ff583..32bc94256 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block4-pw2wan.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block4-pw2wan.json @@ -104,7 +104,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "pw2wannier90.x", "_flags": "", @@ -115,5 +115,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenPW2WannierCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block4-wann.json b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block4-wann.json index 984246e9f..82373082e 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block4-wann.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block4-wann.json @@ -11192,7 +11192,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "", @@ -11203,5 +11203,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block4-wann_preproc.json b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block4-wann_preproc.json index 15482373f..b6215e9dd 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block4-wann_preproc.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-occ_block4-wann_preproc.json @@ -325,7 +325,7 @@ "name": "benchgenwannier90calculator", "command": { "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "wannier90.x", "_flags": "-pp", @@ -336,5 +336,5 @@ "calc": {}, "skip_qc": false, "__koopmans_name__": "BenchGenWannier90Calculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-scf.json b/tests/benchmarks/tutorials-tutorial_3-wannier-scf.json index 343446f5a..add6a1752 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-scf.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-scf.json @@ -13,8 +13,8 @@ 4 ], "pseudopotentials": { - "Zn": "Zn.upf", - "O": "O.upf" + "O": "O.upf", + "Zn": "Zn.upf" }, "pseudo_dir": { "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" @@ -135,7 +135,7 @@ "postfix": "-npool 4", "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../bin" + "__path__": "../../../../../../usr/local/bin" }, "executable": "pw.x", "_flags": "", @@ -1114,5 +1114,5 @@ } ], "__koopmans_name__": "BenchGenPWCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d0-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d0-dft.json index 952842863..f23477fc2 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d0-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d0-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 20.0, "ecutrho": 80.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -503,7 +503,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -516,5 +516,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d1-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d1-dft.json index ee18f6877..2f8a62f40 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d1-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d1-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 20.0, "ecutrho": 80.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -527,7 +527,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -540,5 +540,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d2-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d2-dft.json index 6876a05db..1a4203d90 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d2-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d2-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 20.0, "ecutrho": 80.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -539,7 +539,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -552,5 +552,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d3-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d3-dft.json index 9ce79c977..0c9870c1e 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d3-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d3-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 20.0, "ecutrho": 80.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -509,7 +509,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -522,5 +522,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d0-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d0-dft.json index d761a506e..35fae9ad8 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d0-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d0-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 30.0, "ecutrho": 120.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -527,7 +527,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -540,5 +540,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d1-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d1-dft.json index 73997e591..886cacdbc 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d1-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d1-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 30.0, "ecutrho": 120.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -527,7 +527,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -540,5 +540,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d2-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d2-dft.json index d19c81ab0..d2c7124df 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d2-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d2-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 30.0, "ecutrho": 120.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -509,7 +509,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -522,5 +522,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d3-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d3-dft.json index b15e0cd37..7bae89068 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d3-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d3-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 30.0, "ecutrho": 120.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -515,7 +515,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -528,5 +528,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d0-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d0-dft.json index a0c8f3db2..a5e68505a 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d0-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d0-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 40.0, "ecutrho": 160.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -521,7 +521,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -534,5 +534,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d1-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d1-dft.json index 6a0d38868..3905a072e 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d1-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d1-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 40.0, "ecutrho": 160.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -527,7 +527,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -540,5 +540,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d2-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d2-dft.json index d6612ed0f..95cf10ec2 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d2-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d2-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 40.0, "ecutrho": 160.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -515,7 +515,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -528,5 +528,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d3-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d3-dft.json index 28bbfbf7c..949d3c5c1 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d3-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d3-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 40.0, "ecutrho": 160.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -503,7 +503,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -516,5 +516,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d0-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d0-dft.json index 2f3c835d8..38f2c16c9 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d0-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d0-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 50.0, "ecutrho": 200.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -509,7 +509,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -522,5 +522,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d1-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d1-dft.json index 49b9a6a1e..a0aa0f997 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d1-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d1-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 50.0, "ecutrho": 200.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -527,7 +527,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -540,5 +540,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d2-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d2-dft.json index 5df483e56..c0dfecdce 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d2-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d2-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 50.0, "ecutrho": 200.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -533,7 +533,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -546,5 +546,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d3-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d3-dft.json index a29dfbc0a..7bbbc2973 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d3-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d3-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 50.0, "ecutrho": 200.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -545,7 +545,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -558,5 +558,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d0-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d0-dft.json index 6a68a15f6..705226a9f 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d0-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d0-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 60.0, "ecutrho": 240.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -533,7 +533,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -546,5 +546,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d1-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d1-dft.json index 9b1f5e1c1..0be15233d 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d1-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d1-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 60.0, "ecutrho": 240.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -515,7 +515,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -528,5 +528,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d2-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d2-dft.json index 2c700a562..8494431cb 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d2-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d2-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 60.0, "ecutrho": 240.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -533,7 +533,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -546,5 +546,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d3-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d3-dft.json index 4a68fa47a..772789022 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d3-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d3-dft.json @@ -10,8 +10,8 @@ "ecutwfc": 60.0, "ecutrho": 240.0, "pseudopotentials": { - "O": "O_ONCV_PBE-1.0.upf", - "H": "H_ONCV_PBE-1.0.upf" + "H": "H_ONCV_PBE-1.0.upf", + "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { "__path__": "../../../../pseudos/sg15_v1.0/pbe" @@ -533,7 +533,7 @@ "command": { "mpi_command": "mpirun -np 8", "_path": { - "__path__": "../../../../bin" + "__path__": "../../../../../../../../usr/local/bin" }, "executable": "kcp.x", "_flags": "", @@ -546,5 +546,5 @@ "fixed_band": null, "kpts": null, "__koopmans_name__": "BenchGenKoopmansCPCalculator", - "__koopmans_module__": "koopmans.testing._generate_benchmarks" + "__koopmans_module__": "tests.patches._generate_benchmarks" } \ No newline at end of file diff --git a/tests/calculators/test_koopmans_cp.py b/tests/calculators/test_koopmans_cp.py index 92c807a42..6cc519f12 100644 --- a/tests/calculators/test_koopmans_cp.py +++ b/tests/calculators/test_koopmans_cp.py @@ -9,7 +9,6 @@ from koopmans.calculators._koopmans_cp import (allowed, convert_flat_alphas_for_kcp, good_fft) -from koopmans.testing import benchmark_filename def test_convert_flat_alphas_for_kcp(): diff --git a/tests/calculators/test_ph.py b/tests/calculators/test_ph.py index cf9120668..880af261a 100644 --- a/tests/calculators/test_ph.py +++ b/tests/calculators/test_ph.py @@ -6,7 +6,7 @@ from koopmans import base_directory, utils, workflows from koopmans.io import read_kwf as read_encoded_json from koopmans.io import write_kwf as write_encoded_json -from koopmans.testing import benchmark_filename +from tests import patches def test_read_dynG(tio2, tmp_path, datadir, pytestconfig): @@ -28,10 +28,10 @@ def test_read_dynG(tio2, tmp_path, datadir, pytestconfig): if pytestconfig.getoption('generate_benchmark'): # Write the dielectric tensor to file - with open(benchmark_filename(calc), 'w') as fd: + with open(patches.benchmark_filename(calc), 'w') as fd: write_encoded_json(eps, fd) else: # Compare with the dielectric tensor on file - with open(benchmark_filename(calc), 'r') as fd: + with open(patches.benchmark_filename(calc), 'r') as fd: eps_ref = read_encoded_json(fd) assert np.allclose(eps, eps_ref) diff --git a/tests/calculators/test_projwfc.py b/tests/calculators/test_projwfc.py index 47b99fe67..7ae7bb64a 100644 --- a/tests/calculators/test_projwfc.py +++ b/tests/calculators/test_projwfc.py @@ -5,7 +5,7 @@ from koopmans import base_directory, utils, workflows from koopmans.io import read_kwf as read_encoded_json from koopmans.io import write_kwf as write_encoded_json -from koopmans.testing import benchmark_filename +from tests import patches def test_generate_dos(silicon, tmp_path, datadir, pytestconfig): @@ -28,10 +28,10 @@ def test_generate_dos(silicon, tmp_path, datadir, pytestconfig): if pytestconfig.getoption('generate_benchmark'): # Write the DOS to file - with open(benchmark_filename(calc), 'w') as fd: + with open(patches.benchmark_filename(calc), 'w') as fd: write_encoded_json(dos, fd) else: # Compare with the DOS on file - with open(benchmark_filename(calc), 'r') as fd: + with open(patches.benchmark_filename(calc), 'r') as fd: dos_ref = read_encoded_json(fd) assert dos == dos_ref diff --git a/tests/patches/__init__.py b/tests/patches/__init__.py new file mode 100644 index 000000000..ceefe5dbe --- /dev/null +++ b/tests/patches/__init__.py @@ -0,0 +1,110 @@ +from ._check import (CheckEnvironCalculator, CheckKoopmansCPCalculator, + CheckKoopmansHamCalculator, CheckKoopmansScreenCalculator, + CheckPhCalculator, CheckProjwfcCalculator, + CheckPW2WannierCalculator, CheckPWCalculator, + CheckUnfoldAndInterpolateCalculator, + CheckWann2KCCalculator, CheckWann2KCPCalculator, + CheckWannier90Calculator, compare) +from ._generate_benchmarks import (BenchGenEnvironCalculator, + BenchGenKoopmansCPCalculator, + BenchGenKoopmansHamCalculator, + BenchGenKoopmansScreenCalculator, + BenchGenPhCalculator, + BenchGenProjwfcCalculator, + BenchGenPW2WannierCalculator, + BenchGenPWCalculator, + BenchGenUnfoldAndInterpolateCalculator, + BenchGenWann2KCCalculator, + BenchGenWann2KCPCalculator, + BenchGenWannier90Calculator) +from ._mock import (MockEnvironCalculator, MockKoopmansCPCalculator, + MockKoopmansDSCFWorkflow, MockKoopmansHamCalculator, + MockKoopmansScreenCalculator, MockPhCalculator, + MockProjwfcCalculator, MockPW2WannierCalculator, + MockPWCalculator, MockUnfoldAndInterpolateCalculator, + MockWann2KCCalculator, MockWann2KCPCalculator, + MockWannier90Calculator, MockWannierizeWorkflow) +from ._stumble import (StumblingConvergenceWorkflow, StumblingDeltaSCFWorkflow, + StumblingDFTCPWorkflow, StumblingDFTPhWorkflow, + StumblingDFTPWWorkflow, + StumblingFoldToSupercellWorkflow, + StumblingKoopmansDFPTWorkflow, + StumblingKoopmansDSCFWorkflow, + StumblingSinglepointWorkflow, + StumblingUnfoldAndInterpolateWorkflow, + StumblingWannierizeWorkflow) +from ._utils import benchmark_filename + + +def monkeypatch_bench(monkeypatch): + # After each calculation is run, store the results in a json (one json per calculation) + monkeypatch.setattr('koopmans.calculators.Wannier90Calculator', BenchGenWannier90Calculator) + monkeypatch.setattr('koopmans.calculators.PW2WannierCalculator', BenchGenPW2WannierCalculator) + monkeypatch.setattr('koopmans.calculators.Wann2KCPCalculator', BenchGenWann2KCPCalculator) + monkeypatch.setattr('koopmans.calculators.PhCalculator', BenchGenPhCalculator) + monkeypatch.setattr('koopmans.calculators.PWCalculator', BenchGenPWCalculator) + monkeypatch.setattr('koopmans.calculators.KoopmansCPCalculator', BenchGenKoopmansCPCalculator) + monkeypatch.setattr('koopmans.calculators.EnvironCalculator', BenchGenEnvironCalculator) + monkeypatch.setattr('koopmans.calculators.UnfoldAndInterpolateCalculator', + BenchGenUnfoldAndInterpolateCalculator) + monkeypatch.setattr('koopmans.calculators.Wann2KCCalculator', BenchGenWann2KCCalculator) + monkeypatch.setattr('koopmans.calculators.KoopmansScreenCalculator', BenchGenKoopmansScreenCalculator) + monkeypatch.setattr('koopmans.calculators.KoopmansHamCalculator', BenchGenKoopmansHamCalculator) + monkeypatch.setattr('koopmans.calculators.ProjwfcCalculator', BenchGenProjwfcCalculator) + + +def monkeypatch_mock(monkeypatch): + # Replace calculators with mock versions that obtain results from the database + monkeypatch.setattr('koopmans.calculators.KoopmansCPCalculator', MockKoopmansCPCalculator) + monkeypatch.setattr('koopmans.calculators.Wannier90Calculator', MockWannier90Calculator) + monkeypatch.setattr('koopmans.calculators.PW2WannierCalculator', MockPW2WannierCalculator) + monkeypatch.setattr('koopmans.calculators.Wann2KCPCalculator', MockWann2KCPCalculator) + monkeypatch.setattr('koopmans.calculators.PhCalculator', MockPhCalculator) + monkeypatch.setattr('koopmans.calculators.PWCalculator', MockPWCalculator) + monkeypatch.setattr('koopmans.calculators.KoopmansCPCalculator', MockKoopmansCPCalculator) + monkeypatch.setattr('koopmans.calculators.EnvironCalculator', MockEnvironCalculator) + monkeypatch.setattr('koopmans.calculators.UnfoldAndInterpolateCalculator', + MockUnfoldAndInterpolateCalculator) + monkeypatch.setattr('koopmans.calculators.Wann2KCCalculator', MockWann2KCCalculator) + monkeypatch.setattr('koopmans.calculators.KoopmansScreenCalculator', MockKoopmansScreenCalculator) + monkeypatch.setattr('koopmans.calculators.KoopmansHamCalculator', MockKoopmansHamCalculator) + monkeypatch.setattr('koopmans.calculators.ProjwfcCalculator', MockProjwfcCalculator) + + # Workflows + monkeypatch.setattr('koopmans.workflows.KoopmansDSCFWorkflow', MockKoopmansDSCFWorkflow) + monkeypatch.setattr('koopmans.workflows.WannierizeWorkflow', MockWannierizeWorkflow) + + +def monkeypatch_check(monkeypatch): + # Replace calculators with versions that double-check their results against + monkeypatch.setattr('koopmans.calculators.KoopmansCPCalculator', CheckKoopmansCPCalculator) + monkeypatch.setattr('koopmans.calculators.Wannier90Calculator', CheckWannier90Calculator) + monkeypatch.setattr('koopmans.calculators.PW2WannierCalculator', CheckPW2WannierCalculator) + monkeypatch.setattr('koopmans.calculators.Wann2KCPCalculator', CheckWann2KCPCalculator) + monkeypatch.setattr('koopmans.calculators.PhCalculator', CheckPhCalculator) + monkeypatch.setattr('koopmans.calculators.PWCalculator', CheckPWCalculator) + monkeypatch.setattr('koopmans.calculators.KoopmansCPCalculator', CheckKoopmansCPCalculator) + monkeypatch.setattr('koopmans.calculators.EnvironCalculator', CheckEnvironCalculator) + monkeypatch.setattr('koopmans.calculators.UnfoldAndInterpolateCalculator', + CheckUnfoldAndInterpolateCalculator) + monkeypatch.setattr('koopmans.calculators.Wann2KCCalculator', CheckWann2KCCalculator) + monkeypatch.setattr('koopmans.calculators.KoopmansScreenCalculator', CheckKoopmansScreenCalculator) + monkeypatch.setattr('koopmans.calculators.KoopmansHamCalculator', CheckKoopmansHamCalculator) + monkeypatch.setattr('koopmans.calculators.ProjwfcCalculator', CheckProjwfcCalculator) + + +def monkeypatch_stumble(monkeypatch): + monkeypatch.setattr('koopmans.workflows.WannierizeWorkflow', StumblingWannierizeWorkflow) + monkeypatch.setattr('koopmans.workflows.KoopmansDSCFWorkflow', StumblingKoopmansDSCFWorkflow) + monkeypatch.setattr('koopmans.workflows.SinglepointWorkflow', StumblingSinglepointWorkflow) + monkeypatch.setattr('koopmans.workflows.ConvergenceWorkflow', StumblingConvergenceWorkflow) + monkeypatch.setattr('koopmans.workflows.FoldToSupercellWorkflow', StumblingFoldToSupercellWorkflow) + monkeypatch.setattr('koopmans.workflows.DFTCPWorkflow', StumblingDFTCPWorkflow) + monkeypatch.setattr('koopmans.workflows.DFTPhWorkflow', StumblingDFTPhWorkflow) + monkeypatch.setattr('koopmans.workflows.DFTPWWorkflow', StumblingDFTPWWorkflow) + monkeypatch.setattr('koopmans.workflows.DeltaSCFWorkflow', StumblingDeltaSCFWorkflow) + monkeypatch.setattr('koopmans.workflows.KoopmansDFPTWorkflow', StumblingKoopmansDFPTWorkflow) + monkeypatch.setattr('koopmans.workflows.UnfoldAndInterpolateWorkflow', + StumblingUnfoldAndInterpolateWorkflow) + # When running with stumble mode, we want to check our results against the benchmarks by using CheckCalcs + monkeypatch_check(monkeypatch) diff --git a/koopmans/testing/_check.py b/tests/patches/_check.py similarity index 100% rename from koopmans/testing/_check.py rename to tests/patches/_check.py index 80b6ded1e..c5c4cc8f9 100644 --- a/koopmans/testing/_check.py +++ b/tests/patches/_check.py @@ -5,11 +5,11 @@ from typing import Any, Dict, List, Optional, Set import numpy as np - from ase.calculators.calculator import CalculationFailed from ase.dft.dos import DOS from ase.spectrum.band_structure import BandStructure from ase.spectrum.doscollection import GridDOSCollection + from koopmans import base_directory, utils from koopmans.calculators import (Calc, EnvironCalculator, KoopmansCPCalculator, KoopmansHamCalculator, diff --git a/koopmans/testing/_generate_benchmarks.py b/tests/patches/_generate_benchmarks.py similarity index 100% rename from koopmans/testing/_generate_benchmarks.py rename to tests/patches/_generate_benchmarks.py diff --git a/koopmans/testing/_mock.py b/tests/patches/_mock.py similarity index 100% rename from koopmans/testing/_mock.py rename to tests/patches/_mock.py index 6c53d4a48..9d2bb462a 100644 --- a/koopmans/testing/_mock.py +++ b/tests/patches/_mock.py @@ -5,8 +5,8 @@ from typing import List, Union import numpy as np - from ase.atoms import Atoms + from koopmans import projections, utils from koopmans.calculators import (Calc, EnvironCalculator, KoopmansCPCalculator, KoopmansHamCalculator, diff --git a/koopmans/testing/_stumble.py b/tests/patches/_stumble.py similarity index 99% rename from koopmans/testing/_stumble.py rename to tests/patches/_stumble.py index ada70de88..8c3d53dd5 100644 --- a/koopmans/testing/_stumble.py +++ b/tests/patches/_stumble.py @@ -8,6 +8,7 @@ import copy from ase.calculators.calculator import CalculationFailed + from koopmans import workflows diff --git a/koopmans/testing/_utils.py b/tests/patches/_utils.py similarity index 100% rename from koopmans/testing/_utils.py rename to tests/patches/_utils.py diff --git a/koopmans/testing/strategies.py b/tests/strategies.py similarity index 100% rename from koopmans/testing/strategies.py rename to tests/strategies.py index 714adc68a..c0b825888 100644 --- a/koopmans/testing/strategies.py +++ b/tests/strategies.py @@ -1,14 +1,14 @@ from typing import Callable, List, Optional -from hypothesis import given, settings -from hypothesis.strategies import (booleans, composite, decimals, floats, - integers, lists) - from ase.cell import Cell from ase.dft.kpoints import BandPath from ase.lattice import (BCC, BCT, CUB, FCC, HEX, MCL, MCLC, ORC, ORCC, ORCF, ORCI, RHL, TET, TRI, BravaisLattice, UnconventionalLattice, tri_angles_explanation) +from hypothesis import given, settings +from hypothesis.strategies import (booleans, composite, decimals, floats, + integers, lists) + from koopmans.kpoints import Kpoints diff --git a/tests/test_cell.py b/tests/test_cell.py index 68905a6bf..c7a21f89e 100644 --- a/tests/test_cell.py +++ b/tests/test_cell.py @@ -1,12 +1,13 @@ import numpy as np import pytest -from hypothesis import given, settings, strategies - from ase.cell import Cell from ase.lattice import (BCC, BCT, CUB, FCC, HEX, MCL, MCLC, ORC, ORCC, ORCF, ORCI, RHL, TET, TRI, UnconventionalLattice) +from hypothesis import given, settings, strategies + from koopmans.cell import cell_to_parameters, parameters_to_cell -from koopmans.testing import strategies as kst + +from . import strategies as kst # Reference list of ASE Bravais lattice classes bravais_lattices = {1: CUB, 2: FCC, 3: BCC, 4: HEX, 5: RHL, 6: TET, 7: BCT, diff --git a/tests/test_kpoints.py b/tests/test_kpoints.py index a8a4d04ee..10bdbab1c 100644 --- a/tests/test_kpoints.py +++ b/tests/test_kpoints.py @@ -1,9 +1,10 @@ import numpy as np +from ase.dft.kpoints import BandPath from hypothesis import given, settings -from ase.dft.kpoints import BandPath from koopmans.kpoints import Kpoints, dict_to_kpath, kpath_to_dict -from koopmans.testing import strategies as kst + +from . import strategies as kst @given(bp=kst.bandpaths()) diff --git a/tests/test_utils.py b/tests/test_utils.py index 0dedcda74..032305412 100644 --- a/tests/test_utils.py +++ b/tests/test_utils.py @@ -3,10 +3,10 @@ import numpy as np import pytest -from hypothesis import given -from koopmans import utils, workflows -from koopmans.testing import strategies as kst +from koopmans import utils + +from . import strategies as kst wann_files_dir = Path(__file__).parent / 'w90_example_files' diff --git a/tests/workflows/test_ui.py b/tests/workflows/test_ui.py index d44d98c5c..532a16959 100644 --- a/tests/workflows/test_ui.py +++ b/tests/workflows/test_ui.py @@ -1,10 +1,10 @@ import pytest - from ase.spectrum.band_structure import BandStructure + from koopmans import workflows from koopmans.io import read_kwf as read_encoded_json -from koopmans.testing import benchmark_filename from koopmans.utils import chdir +from tests import patches def test_ui_si(silicon, tmp_path, sys2file, datadir, ui_patch): @@ -39,7 +39,7 @@ def test_ui_si(silicon, tmp_path, sys2file, datadir, ui_patch): calc = wf.calculations[-1] results = calc.results # Save the calculator as an encoded json in the benchmarks directory - with open(benchmark_filename(calc), 'r') as fd: + with open(patches.benchmark_filename(calc), 'r') as fd: calc_ref = read_encoded_json(fd) for key, result in results.items(): # Don't compare walltime From b13827780e6cb8c15724494072324cf3a93551a5 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Mon, 26 Sep 2022 17:05:31 +0200 Subject: [PATCH 15/49] Updated requirements to reflect test restructure --- requirements/requirements.txt | 2 -- requirements/test_requirements.txt | 6 ++++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/requirements/requirements.txt b/requirements/requirements.txt index 42ddd48c7..f1b4ff8b5 100644 --- a/requirements/requirements.txt +++ b/requirements/requirements.txt @@ -3,10 +3,8 @@ scipy>=0.18.1 numpy>=1.21 argparse>=1.1 pandas>=1.0.0 -pytest>=5.4 typing>=3.6 pybtex>=0.24 spglib>=1.9 upf-to-json>=0.9.5 -hypothesis>=6.0.0 ase-koopmans==0.1.0 diff --git a/requirements/test_requirements.txt b/requirements/test_requirements.txt index d52099a50..f5acc23d4 100644 --- a/requirements/test_requirements.txt +++ b/requirements/test_requirements.txt @@ -1,3 +1,5 @@ -pytest-cov>=2.9 -coverage>=4.4 codecov>=2.0 +coverage>=4.4 +hypothesis>=6.0.0 +pytest>=5.4 +pytest-cov>=2.9 From 1cc75ce1516a2704cdc43fe17a64e643fe00dcd5 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 12:07:39 +0200 Subject: [PATCH 16/49] Adding files to enable python build --- MANIFEST.in | 2 ++ setup.py | 3 --- 2 files changed, 2 insertions(+), 3 deletions(-) create mode 100644 MANIFEST.in diff --git a/MANIFEST.in b/MANIFEST.in new file mode 100644 index 000000000..993dfc84d --- /dev/null +++ b/MANIFEST.in @@ -0,0 +1,2 @@ +include requirements/* +exclude tests/* diff --git a/setup.py b/setup.py index 15fb3025a..2f226d4f8 100644 --- a/setup.py +++ b/setup.py @@ -14,9 +14,6 @@ with open('requirements/requirements.txt', 'r') as f: requirements = [line.strip() for line in f.readlines()] -with open('requirements/test_requirements.txt', 'r') as f: - requirements += [line.strip() for line in f.readlines()] - extra_requirements: Dict[str, str] = dict(all=[]) req_files = glob('requirements/*.txt') for _file in req_files: From f9a10077534c509cd1ed05825f013dd4cf1450c3 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 15:32:52 +0200 Subject: [PATCH 17/49] Replace setup.py with pyproject.toml --- koopmans/__init__.py | 8 ++++- mypy.ini | 2 -- pyproject.toml | 73 ++++++++++++++++++++++++++++++++++++++++++++ pytest.ini | 16 ---------- setup.py | 61 ------------------------------------ 5 files changed, 80 insertions(+), 80 deletions(-) delete mode 100644 mypy.ini create mode 100644 pyproject.toml delete mode 100644 pytest.ini delete mode 100644 setup.py diff --git a/koopmans/__init__.py b/koopmans/__init__.py index cce37fba4..4b8908740 100644 --- a/koopmans/__init__.py +++ b/koopmans/__init__.py @@ -1,5 +1,11 @@ 'koopmans: a package for performing and automating Koopmans functional calculations' +import sys from pathlib import Path -__version__ = '1.0.0-beta.3' +if sys.version_info >= (3, 8): + from importlib import metadata +else: + import importlib_metadata as metadata + +__version__ = metadata.version('koopmans') base_directory = Path(__path__[0]).parent diff --git a/mypy.ini b/mypy.ini deleted file mode 100644 index 976ba0294..000000000 --- a/mypy.ini +++ /dev/null @@ -1,2 +0,0 @@ -[mypy] -ignore_missing_imports = True diff --git a/pyproject.toml b/pyproject.toml new file mode 100644 index 000000000..ef20c4a8e --- /dev/null +++ b/pyproject.toml @@ -0,0 +1,73 @@ +[project] +name = "koopmans" +version = "1.0.0-beta.3" +description = "Koopmans spectral functional calculations with python and Quantum ESPRESSO" +readme = "README.rst" +requires-python = ">=3.7" +license = { name = "GPL", file = "LICENSE" } +authors = [{ name = "Edward Linscott", email = "edwardlinscott@gmail.com" }] +classifiers = [ + "Intended Audience :: Science/Research", + "License :: OSI Approved :: MIT License", + "Programming Language :: Python :: 3", + "Programming Language :: Python :: 3.7", + "Programming Language :: Python :: 3.8", + "Programming Language :: Python :: 3.9", + "Programming Language :: Python :: 3.10", + "Topic :: Scientific/Engineering", + "Topic :: Scientific/Engineering :: Chemistry", + "Topic :: Scientific/Engineering :: Physics", +] +dependencies = [ + "matplotlib>=3.5.1", + "scipy>=0.18.1", + "numpy>=1.21", + "argparse>=1.1", + "pandas>=1.0.0", + "typing>=3.6", + "pybtex>=0.24", + "spglib>=1.9", + "upf-to-json>=0.9.5", + "ase-koopmans==0.1.0", +] + +[project.urls] +homepage = "https://koopmans-functionals.org/" +repository = "https://github.com/epfl-theos/koopmans" +google-group = "https://groups.google.com/g/koopmans-users" + +[project.optional-dependencies] +test = [ + "codecov>=2.0", + "coverage>=4.4", + "hypothesis>=6.0.0", + "pytest>=5.4", + "pytest-cov>=2.9", +] + +[project.scripts] +koopmans = "koopmans.cli.main:main" + +[tool.setuptools] +py-modules = ["koopmans"] + +[tool.mypy] +ignore_missing_imports = true + +[tool.pytest.ini_options] +filterwarnings = [ + "ignore:Could not find 2nd order Makov-Payne energy; applying first order only:UserWarning", + "ignore:Martyna-Tuckerman corrections not applied for an aperiodic calculation; do this with caution:UserWarning", + "ignore:Makov-Payne corrections are not being used; do this with caution for periodic systems:UserWarning", + "ignore:eps_inf missing in input; it will default to 1.0. Proceed with caution for periodic systems:UserWarning", + "ignore:Some of the pseudopotentials do not have PP_PSWFC blocks, which means a projected DOS calculation is not possible. Skipping...:UserWarning", + "ignore:Neither a pseudopotential library nor a list of pseudopotentials was provided; defaulting to sg15_v1.2:UserWarning", + "ignore:The screening parameters for a KI calculation with no empty states will converge instantly; to save computational time set n_max_sc_steps == 1:UserWarning", + "ignore:This system is not cubic and will therefore not have a uniform dielectric tensor. However, the image-correction schemes that are currently implemented assume a uniform dielectric. Proceed with caution:UserWarning", + 'ignore:Small box parameters "nrb" not provided in input:UserWarning', +] +addopts = "--show-capture=no --capture=sys --strict-markers --tb=short -rfEs --basetemp=tests/tmp" +markers = [ + "espresso: tests that check Quantum ESPRESSO", + "tutorials: tests that run the tutorial exercises", +] diff --git a/pytest.ini b/pytest.ini deleted file mode 100644 index 6deb6b026..000000000 --- a/pytest.ini +++ /dev/null @@ -1,16 +0,0 @@ -# pytest.ini -[pytest] -addopts=--show-capture=no --capture=sys --strict-markers --tb=short -rfEs --basetemp=tests/tmp -markers= - espresso: tests that check Quantum ESPRESSO - tutorials: tests that run the tutorial exercises -filterwarnings= - ignore:Could not find 2nd order Makov-Payne energy; applying first order only:UserWarning - ignore:Martyna-Tuckerman corrections not applied for an aperiodic calculation; do this with caution:UserWarning - ignore:Makov-Payne corrections are not being used; do this with caution for periodic systems:UserWarning - ignore:eps_inf missing in input; it will default to 1.0. Proceed with caution for periodic systems:UserWarning - ignore:Some of the pseudopotentials do not have PP_PSWFC blocks, which means a projected DOS calculation is not possible. Skipping...:UserWarning - ignore:Neither a pseudopotential library nor a list of pseudopotentials was provided; defaulting to sg15_v1.2:UserWarning - ignore:The screening parameters for a KI calculation with no empty states will converge instantly; to save computational time set n_max_sc_steps == 1:UserWarning - ignore:This system is not cubic and will therefore not have a uniform dielectric tensor. However, the image-correction schemes that are currently implemented assume a uniform dielectric. Proceed with caution:UserWarning - ignore:Small box parameters "nrb" not provided in input:UserWarning diff --git a/setup.py b/setup.py deleted file mode 100644 index 2f226d4f8..000000000 --- a/setup.py +++ /dev/null @@ -1,61 +0,0 @@ -# coding: utf-8 -# Distributed under the terms of the MIT License. - -import os -from glob import glob -from typing import Dict - -from setuptools import find_packages, setup - -with open('koopmans/__init__.py', 'r') as f: - [versionline] = [line for line in f.readlines() if 'version' in line] - version = versionline.split('=')[-1].strip().strip("'") - -with open('requirements/requirements.txt', 'r') as f: - requirements = [line.strip() for line in f.readlines()] - -extra_requirements: Dict[str, str] = dict(all=[]) -req_files = glob('requirements/*.txt') -for _file in req_files: - if _file not in ['requirements/requirements.txt']: - with open(_file, 'r') as f: - subreq = _file.split('/')[-1].split('_')[0] - extra_requirements[subreq] = [line.strip() for line in f.readlines()] - extra_requirements['all'] += extra_requirements[subreq] - -with open("README.rst", "r") as f: - long_description = f.read() - -setup(name='koopmans', - version=version, - description='Koopmans spectral functional calculations with python and Quantum ESPRESSO', - long_description=long_description, - url='https://github.com/epfl-theos/koopmans', - author='Edward Linscott', - author_email='edwardlinscott@gmail.com', - maintainer='Edward Linscott', - maintainer_email='edwardlinscott@gmail.com', - license='MIT', - packages=find_packages(), - package_dir={'': '.'}, - python_requires='>=3.7', - install_requires=requirements, - scripts=[s for s in glob('bin/*') if s[-2:] != '.x'], - test_suite='tests', - include_package_data=True, - setup_requires=["setuptools>=42"], - extras_require=extra_requirements, - classifiers=[ - "Intended Audience :: Science/Research", - "License :: OSI Approved :: MIT License", - "Programming Language :: Python :: 3", - "Programming Language :: Python :: 3.7", - "Programming Language :: Python :: 3.8", - "Programming Language :: Python :: 3.9", - "Programming Language :: Python :: 3.10", - "Topic :: Scientific/Engineering", - "Topic :: Scientific/Engineering :: Chemistry", - "Topic :: Scientific/Engineering :: Physics" - ], - entry_points={'console_scripts': ['koopmans=koopmans.cli.main:main']}, - zip_safe=False) From f94ea1944baa1d91c40eaad13b224b1a747ab6c2 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 15:33:23 +0200 Subject: [PATCH 18/49] Move codecov.yml into a hidden directory --- codecov.yml => .github/codecov.yml | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename codecov.yml => .github/codecov.yml (100%) diff --git a/codecov.yml b/.github/codecov.yml similarity index 100% rename from codecov.yml rename to .github/codecov.yml From e75346c36be16e2e6dea9fef318e02fbfa10db8c Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 15:50:10 +0200 Subject: [PATCH 19/49] Added mypy ignore statement to new_calculator() --- koopmans/workflows/_workflow.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/koopmans/workflows/_workflow.py b/koopmans/workflows/_workflow.py index 40d235a65..f10118929 100644 --- a/koopmans/workflows/_workflow.py +++ b/koopmans/workflows/_workflow.py @@ -511,7 +511,7 @@ def new_calculator(self, calc_type: str, directory: Optional[Path] = None, kpts: Optional[Union[List[int], BandPath]] = None, - **kwargs) -> T: + **kwargs) -> T: # type: ignore[type-var] calc_class: Type[T] From 0ca229aee5073b13a201c47da347d36468b94003 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 15:53:14 +0200 Subject: [PATCH 20/49] Added mypy ignore statement to other instances of new_calculator() --- koopmans/workflows/_dft.py | 2 +- koopmans/workflows/_wannierize.py | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/koopmans/workflows/_dft.py b/koopmans/workflows/_dft.py index c181cb617..4200cbb6e 100644 --- a/koopmans/workflows/_dft.py +++ b/koopmans/workflows/_dft.py @@ -143,7 +143,7 @@ def _run(self): def new_calculator(self, calc_type: str, *args, - **kwargs) -> T: + **kwargs) -> T: # type: ignore[type-var] calc: T = super().new_calculator(calc_type, *args, **kwargs) if calc_type == 'projwfc': assert isinstance(calc, calculators.ProjwfcCalculator) diff --git a/koopmans/workflows/_wannierize.py b/koopmans/workflows/_wannierize.py index 700c9a0b2..9ff04c44b 100644 --- a/koopmans/workflows/_wannierize.py +++ b/koopmans/workflows/_wannierize.py @@ -269,7 +269,7 @@ def _run(self): return - def new_calculator(self, calc_type, *args, **kwargs) -> CalcExtType: + def new_calculator(self, calc_type, *args, **kwargs) -> CalcExtType: # type: ignore[type-var] init_orbs = kwargs.pop('init_orbitals', None) calc: CalcExtType = super().new_calculator(calc_type, *args, **kwargs) From 6800f57798ef8c79700fffc3edf3d0e11ab71ae1 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 17:39:53 +0200 Subject: [PATCH 21/49] Move koopmans to src/koopmans to follow the conventional layout --- MANIFEST.in | 2 -- README.rst | 4 ++-- pyproject.toml | 3 --- requirements/requirements.txt | 10 ---------- requirements/test_requirements.txt | 5 ----- {koopmans => src/koopmans}/__init__.py | 0 {koopmans => src/koopmans}/bands.py | 0 {koopmans => src/koopmans}/calculators/__init__.py | 0 {koopmans => src/koopmans}/calculators/_environ.py | 0 {koopmans => src/koopmans}/calculators/_koopmans_cp.py | 0 .../koopmans}/calculators/_koopmans_ham.py | 0 .../koopmans}/calculators/_koopmans_screen.py | 0 {koopmans => src/koopmans}/calculators/_ph.py | 0 {koopmans => src/koopmans}/calculators/_projwfc.py | 0 {koopmans => src/koopmans}/calculators/_pw.py | 0 {koopmans => src/koopmans}/calculators/_pw2wannier.py | 0 {koopmans => src/koopmans}/calculators/_ui/__init__.py | 0 {koopmans => src/koopmans}/calculators/_ui/_atoms.py | 1 - .../koopmans}/calculators/_ui/_calculator.py | 4 ++-- {koopmans => src/koopmans}/calculators/_ui/_utils.py | 0 {koopmans => src/koopmans}/calculators/_utils.py | 0 {koopmans => src/koopmans}/calculators/_wann2kc.py | 0 {koopmans => src/koopmans}/calculators/_wann2kcp.py | 0 {koopmans => src/koopmans}/calculators/_wannier90.py | 0 {koopmans => src/koopmans}/cell.py | 1 - {koopmans => src/koopmans}/cli/__init__.py | 0 {koopmans => src/koopmans}/cli/main.py | 0 {koopmans => src/koopmans}/commands.py | 0 {koopmans => src/koopmans}/io/__init__.py | 0 {koopmans => src/koopmans}/io/_calculators.py | 0 {koopmans => src/koopmans}/io/_generic.py | 0 {koopmans => src/koopmans}/io/_json.py | 0 {koopmans => src/koopmans}/io/_kwf.py | 3 ++- {koopmans => src/koopmans}/kpoints.py | 1 - {koopmans => src/koopmans}/mpl_config.py | 0 {koopmans => src/koopmans}/projections.py | 7 ++----- {koopmans => src/koopmans}/pseudopotentials.py | 3 +-- {koopmans => src/koopmans}/qei_to_json.py | 1 + {koopmans => src/koopmans}/references.py | 0 {koopmans => src/koopmans}/settings/__init__.py | 2 +- {koopmans => src/koopmans}/settings/_koopmans_cp.py | 0 {koopmans => src/koopmans}/settings/_koopmans_ham.py | 0 .../koopmans}/settings/_koopmans_screen.py | 0 {koopmans => src/koopmans}/settings/_ph.py | 0 {koopmans => src/koopmans}/settings/_plot.py | 0 {koopmans => src/koopmans}/settings/_projwfc.py | 0 {koopmans => src/koopmans}/settings/_pw.py | 0 {koopmans => src/koopmans}/settings/_pw2wannier.py | 0 {koopmans => src/koopmans}/settings/_ui.py | 1 - {koopmans => src/koopmans}/settings/_utils.py | 0 {koopmans => src/koopmans}/settings/_wann2kc.py | 0 {koopmans => src/koopmans}/settings/_wann2kcp.py | 0 {koopmans => src/koopmans}/settings/_wannier90.py | 1 - {koopmans => src/koopmans}/settings/_workflow.py | 0 {koopmans => src/koopmans}/utils/__init__.py | 0 {koopmans => src/koopmans}/utils/_figures.py | 0 {koopmans => src/koopmans}/utils/_io.py | 2 +- {koopmans => src/koopmans}/utils/_misc.py | 0 {koopmans => src/koopmans}/utils/_os.py | 0 {koopmans => src/koopmans}/utils/_units.py | 0 {koopmans => src/koopmans}/utils/_warnings.py | 0 {koopmans => src/koopmans}/workflows/__init__.py | 8 +++----- {koopmans => src/koopmans}/workflows/_anion_dscf.py | 1 + {koopmans => src/koopmans}/workflows/_convergence.py | 0 {koopmans => src/koopmans}/workflows/_dft.py | 0 {koopmans => src/koopmans}/workflows/_folding.py | 0 {koopmans => src/koopmans}/workflows/_koopmans_dfpt.py | 0 {koopmans => src/koopmans}/workflows/_koopmans_dscf.py | 2 +- {koopmans => src/koopmans}/workflows/_singlepoint.py | 0 .../koopmans}/workflows/_unfold_and_interp.py | 2 +- {koopmans => src/koopmans}/workflows/_wannierize.py | 0 {koopmans => src/koopmans}/workflows/_workflow.py | 0 72 files changed, 18 insertions(+), 46 deletions(-) delete mode 100644 MANIFEST.in delete mode 100644 requirements/requirements.txt delete mode 100644 requirements/test_requirements.txt rename {koopmans => src/koopmans}/__init__.py (100%) rename {koopmans => src/koopmans}/bands.py (100%) rename {koopmans => src/koopmans}/calculators/__init__.py (100%) rename {koopmans => src/koopmans}/calculators/_environ.py (100%) rename {koopmans => src/koopmans}/calculators/_koopmans_cp.py (100%) rename {koopmans => src/koopmans}/calculators/_koopmans_ham.py (100%) rename {koopmans => src/koopmans}/calculators/_koopmans_screen.py (100%) rename {koopmans => src/koopmans}/calculators/_ph.py (100%) rename {koopmans => src/koopmans}/calculators/_projwfc.py (100%) rename {koopmans => src/koopmans}/calculators/_pw.py (100%) rename {koopmans => src/koopmans}/calculators/_pw2wannier.py (100%) rename {koopmans => src/koopmans}/calculators/_ui/__init__.py (100%) rename {koopmans => src/koopmans}/calculators/_ui/_atoms.py (99%) rename {koopmans => src/koopmans}/calculators/_ui/_calculator.py (100%) rename {koopmans => src/koopmans}/calculators/_ui/_utils.py (100%) rename {koopmans => src/koopmans}/calculators/_utils.py (100%) rename {koopmans => src/koopmans}/calculators/_wann2kc.py (100%) rename {koopmans => src/koopmans}/calculators/_wann2kcp.py (100%) rename {koopmans => src/koopmans}/calculators/_wannier90.py (100%) rename {koopmans => src/koopmans}/cell.py (99%) rename {koopmans => src/koopmans}/cli/__init__.py (100%) rename {koopmans => src/koopmans}/cli/main.py (100%) rename {koopmans => src/koopmans}/commands.py (100%) rename {koopmans => src/koopmans}/io/__init__.py (100%) rename {koopmans => src/koopmans}/io/_calculators.py (100%) rename {koopmans => src/koopmans}/io/_generic.py (100%) rename {koopmans => src/koopmans}/io/_json.py (100%) rename {koopmans => src/koopmans}/io/_kwf.py (99%) rename {koopmans => src/koopmans}/kpoints.py (99%) rename {koopmans => src/koopmans}/mpl_config.py (100%) rename {koopmans => src/koopmans}/projections.py (98%) rename {koopmans => src/koopmans}/pseudopotentials.py (99%) rename {koopmans => src/koopmans}/qei_to_json.py (99%) rename {koopmans => src/koopmans}/references.py (100%) rename {koopmans => src/koopmans}/settings/__init__.py (100%) rename {koopmans => src/koopmans}/settings/_koopmans_cp.py (100%) rename {koopmans => src/koopmans}/settings/_koopmans_ham.py (100%) rename {koopmans => src/koopmans}/settings/_koopmans_screen.py (100%) rename {koopmans => src/koopmans}/settings/_ph.py (100%) rename {koopmans => src/koopmans}/settings/_plot.py (100%) rename {koopmans => src/koopmans}/settings/_projwfc.py (100%) rename {koopmans => src/koopmans}/settings/_pw.py (100%) rename {koopmans => src/koopmans}/settings/_pw2wannier.py (100%) rename {koopmans => src/koopmans}/settings/_ui.py (99%) rename {koopmans => src/koopmans}/settings/_utils.py (100%) rename {koopmans => src/koopmans}/settings/_wann2kc.py (100%) rename {koopmans => src/koopmans}/settings/_wann2kcp.py (100%) rename {koopmans => src/koopmans}/settings/_wannier90.py (99%) rename {koopmans => src/koopmans}/settings/_workflow.py (100%) rename {koopmans => src/koopmans}/utils/__init__.py (100%) rename {koopmans => src/koopmans}/utils/_figures.py (100%) rename {koopmans => src/koopmans}/utils/_io.py (100%) rename {koopmans => src/koopmans}/utils/_misc.py (100%) rename {koopmans => src/koopmans}/utils/_os.py (100%) rename {koopmans => src/koopmans}/utils/_units.py (100%) rename {koopmans => src/koopmans}/utils/_warnings.py (100%) rename {koopmans => src/koopmans}/workflows/__init__.py (64%) rename {koopmans => src/koopmans}/workflows/_anion_dscf.py (99%) rename {koopmans => src/koopmans}/workflows/_convergence.py (100%) rename {koopmans => src/koopmans}/workflows/_dft.py (100%) rename {koopmans => src/koopmans}/workflows/_folding.py (100%) rename {koopmans => src/koopmans}/workflows/_koopmans_dfpt.py (100%) rename {koopmans => src/koopmans}/workflows/_koopmans_dscf.py (100%) rename {koopmans => src/koopmans}/workflows/_singlepoint.py (100%) rename {koopmans => src/koopmans}/workflows/_unfold_and_interp.py (100%) rename {koopmans => src/koopmans}/workflows/_wannierize.py (100%) rename {koopmans => src/koopmans}/workflows/_workflow.py (100%) diff --git a/MANIFEST.in b/MANIFEST.in deleted file mode 100644 index 993dfc84d..000000000 --- a/MANIFEST.in +++ /dev/null @@ -1,2 +0,0 @@ -include requirements/* -exclude tests/* diff --git a/README.rst b/README.rst index f941ab947..e87f34915 100644 --- a/README.rst +++ b/README.rst @@ -12,7 +12,7 @@ This repository contains... | ``bin/`` executables (N.B. this directory does not need to be added to ``$PATH``) | ``docs/`` documentation (see https://koopmans-functionals.org/) -| ``koopmans/`` source code of the workflow manager +| ``src/`` source code | ``quantum_espresso/`` modified versions of ``Quantum ESPRESSO`` that contain implementations of the Koopmans functionals | ``pseudos/`` pseudopotentials | ``requirements/`` python dependencies @@ -77,7 +77,7 @@ To add all of the Quantum ESPRESSO binaries to your path, run sudo make install -By default the binaries will be added to ``usr/bin``. You can override this default by appending ``PREFIX=/path/to/bin/`` to the above command. +By default the binaries will be added to ``/usr/local/bin``. You can override this default by appending ``PREFIX=/path/to/bin/`` to the above command. Installing the workflow manager """"""""""""""""""""""""""""""" diff --git a/pyproject.toml b/pyproject.toml index ef20c4a8e..61e96bde8 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -48,9 +48,6 @@ test = [ [project.scripts] koopmans = "koopmans.cli.main:main" -[tool.setuptools] -py-modules = ["koopmans"] - [tool.mypy] ignore_missing_imports = true diff --git a/requirements/requirements.txt b/requirements/requirements.txt deleted file mode 100644 index f1b4ff8b5..000000000 --- a/requirements/requirements.txt +++ /dev/null @@ -1,10 +0,0 @@ -matplotlib>=3.5.1 -scipy>=0.18.1 -numpy>=1.21 -argparse>=1.1 -pandas>=1.0.0 -typing>=3.6 -pybtex>=0.24 -spglib>=1.9 -upf-to-json>=0.9.5 -ase-koopmans==0.1.0 diff --git a/requirements/test_requirements.txt b/requirements/test_requirements.txt deleted file mode 100644 index f5acc23d4..000000000 --- a/requirements/test_requirements.txt +++ /dev/null @@ -1,5 +0,0 @@ -codecov>=2.0 -coverage>=4.4 -hypothesis>=6.0.0 -pytest>=5.4 -pytest-cov>=2.9 diff --git a/koopmans/__init__.py b/src/koopmans/__init__.py similarity index 100% rename from koopmans/__init__.py rename to src/koopmans/__init__.py diff --git a/koopmans/bands.py b/src/koopmans/bands.py similarity index 100% rename from koopmans/bands.py rename to src/koopmans/bands.py diff --git a/koopmans/calculators/__init__.py b/src/koopmans/calculators/__init__.py similarity index 100% rename from koopmans/calculators/__init__.py rename to src/koopmans/calculators/__init__.py diff --git a/koopmans/calculators/_environ.py b/src/koopmans/calculators/_environ.py similarity index 100% rename from koopmans/calculators/_environ.py rename to src/koopmans/calculators/_environ.py diff --git a/koopmans/calculators/_koopmans_cp.py b/src/koopmans/calculators/_koopmans_cp.py similarity index 100% rename from koopmans/calculators/_koopmans_cp.py rename to src/koopmans/calculators/_koopmans_cp.py diff --git a/koopmans/calculators/_koopmans_ham.py b/src/koopmans/calculators/_koopmans_ham.py similarity index 100% rename from koopmans/calculators/_koopmans_ham.py rename to src/koopmans/calculators/_koopmans_ham.py diff --git a/koopmans/calculators/_koopmans_screen.py b/src/koopmans/calculators/_koopmans_screen.py similarity index 100% rename from koopmans/calculators/_koopmans_screen.py rename to src/koopmans/calculators/_koopmans_screen.py diff --git a/koopmans/calculators/_ph.py b/src/koopmans/calculators/_ph.py similarity index 100% rename from koopmans/calculators/_ph.py rename to src/koopmans/calculators/_ph.py diff --git a/koopmans/calculators/_projwfc.py b/src/koopmans/calculators/_projwfc.py similarity index 100% rename from koopmans/calculators/_projwfc.py rename to src/koopmans/calculators/_projwfc.py diff --git a/koopmans/calculators/_pw.py b/src/koopmans/calculators/_pw.py similarity index 100% rename from koopmans/calculators/_pw.py rename to src/koopmans/calculators/_pw.py diff --git a/koopmans/calculators/_pw2wannier.py b/src/koopmans/calculators/_pw2wannier.py similarity index 100% rename from koopmans/calculators/_pw2wannier.py rename to src/koopmans/calculators/_pw2wannier.py diff --git a/koopmans/calculators/_ui/__init__.py b/src/koopmans/calculators/_ui/__init__.py similarity index 100% rename from koopmans/calculators/_ui/__init__.py rename to src/koopmans/calculators/_ui/__init__.py diff --git a/koopmans/calculators/_ui/_atoms.py b/src/koopmans/calculators/_ui/_atoms.py similarity index 99% rename from koopmans/calculators/_ui/_atoms.py rename to src/koopmans/calculators/_ui/_atoms.py index bbe8bae64..6638f2ddf 100644 --- a/koopmans/calculators/_ui/_atoms.py +++ b/src/koopmans/calculators/_ui/_atoms.py @@ -10,7 +10,6 @@ from typing import Optional import numpy as np - from ase import Atoms from ase.cell import Cell diff --git a/koopmans/calculators/_ui/_calculator.py b/src/koopmans/calculators/_ui/_calculator.py similarity index 100% rename from koopmans/calculators/_ui/_calculator.py rename to src/koopmans/calculators/_ui/_calculator.py index 227f2cb97..a0227d620 100644 --- a/koopmans/calculators/_ui/_calculator.py +++ b/src/koopmans/calculators/_ui/_calculator.py @@ -13,13 +13,13 @@ from typing import List, Optional, Union import numpy as np -from numpy.typing import ArrayLike, NDArray - from ase import Atoms from ase.calculators.calculator import Calculator from ase.dft.dos import DOS from ase.geometry.cell import crystal_structure_from_cell from ase.spectrum.band_structure import BandStructure +from numpy.typing import ArrayLike, NDArray + from koopmans import utils from koopmans.kpoints import Kpoints, kpath_to_dict from koopmans.settings import (PlotSettingsDict, diff --git a/koopmans/calculators/_ui/_utils.py b/src/koopmans/calculators/_ui/_utils.py similarity index 100% rename from koopmans/calculators/_ui/_utils.py rename to src/koopmans/calculators/_ui/_utils.py diff --git a/koopmans/calculators/_utils.py b/src/koopmans/calculators/_utils.py similarity index 100% rename from koopmans/calculators/_utils.py rename to src/koopmans/calculators/_utils.py diff --git a/koopmans/calculators/_wann2kc.py b/src/koopmans/calculators/_wann2kc.py similarity index 100% rename from koopmans/calculators/_wann2kc.py rename to src/koopmans/calculators/_wann2kc.py diff --git a/koopmans/calculators/_wann2kcp.py b/src/koopmans/calculators/_wann2kcp.py similarity index 100% rename from koopmans/calculators/_wann2kcp.py rename to src/koopmans/calculators/_wann2kcp.py diff --git a/koopmans/calculators/_wannier90.py b/src/koopmans/calculators/_wannier90.py similarity index 100% rename from koopmans/calculators/_wannier90.py rename to src/koopmans/calculators/_wannier90.py diff --git a/koopmans/cell.py b/src/koopmans/cell.py similarity index 99% rename from koopmans/cell.py rename to src/koopmans/cell.py index 89c7a6d67..2ee7139d5 100644 --- a/koopmans/cell.py +++ b/src/koopmans/cell.py @@ -2,7 +2,6 @@ from typing import Dict, Union import numpy as np - from ase.cell import Cell from ase.lattice import (BCC, BCT, CUB, FCC, HEX, MCL, MCLC, ORC, ORCC, ORCF, ORCI, RHL, TET, TRI, BravaisLattice) diff --git a/koopmans/cli/__init__.py b/src/koopmans/cli/__init__.py similarity index 100% rename from koopmans/cli/__init__.py rename to src/koopmans/cli/__init__.py diff --git a/koopmans/cli/main.py b/src/koopmans/cli/main.py similarity index 100% rename from koopmans/cli/main.py rename to src/koopmans/cli/main.py diff --git a/koopmans/commands.py b/src/koopmans/commands.py similarity index 100% rename from koopmans/commands.py rename to src/koopmans/commands.py diff --git a/koopmans/io/__init__.py b/src/koopmans/io/__init__.py similarity index 100% rename from koopmans/io/__init__.py rename to src/koopmans/io/__init__.py diff --git a/koopmans/io/_calculators.py b/src/koopmans/io/_calculators.py similarity index 100% rename from koopmans/io/_calculators.py rename to src/koopmans/io/_calculators.py diff --git a/koopmans/io/_generic.py b/src/koopmans/io/_generic.py similarity index 100% rename from koopmans/io/_generic.py rename to src/koopmans/io/_generic.py diff --git a/koopmans/io/_json.py b/src/koopmans/io/_json.py similarity index 100% rename from koopmans/io/_json.py rename to src/koopmans/io/_json.py diff --git a/koopmans/io/_kwf.py b/src/koopmans/io/_kwf.py similarity index 99% rename from koopmans/io/_kwf.py rename to src/koopmans/io/_kwf.py index 308bac388..4067a3105 100644 --- a/koopmans/io/_kwf.py +++ b/src/koopmans/io/_kwf.py @@ -13,9 +13,10 @@ from pathlib import Path from typing import TextIO, Union -import koopmans.workflows as workflows from ase.io import jsonio as ase_json +import koopmans.workflows as workflows + class KoopmansEncoder(ase_json.MyEncoder): def default(self, obj) -> dict: diff --git a/koopmans/kpoints.py b/src/koopmans/kpoints.py similarity index 99% rename from koopmans/kpoints.py rename to src/koopmans/kpoints.py index f8c181bab..776ba054d 100644 --- a/koopmans/kpoints.py +++ b/src/koopmans/kpoints.py @@ -11,7 +11,6 @@ from typing import Any, Dict, List, Optional, Union import numpy as np - from ase.cell import Cell from ase.dft.kpoints import BandPath, kpoint_convert, resolve_kpt_path_string diff --git a/koopmans/mpl_config.py b/src/koopmans/mpl_config.py similarity index 100% rename from koopmans/mpl_config.py rename to src/koopmans/mpl_config.py diff --git a/koopmans/projections.py b/src/koopmans/projections.py similarity index 98% rename from koopmans/projections.py rename to src/koopmans/projections.py index 23e057a5a..2858a463c 100644 --- a/koopmans/projections.py +++ b/src/koopmans/projections.py @@ -2,11 +2,8 @@ from typing import Any, Dict, List, Optional, Union from ase import Atoms -from ase.io.wannier90 import ( - list_to_formatted_str, - num_wann_from_projections, - proj_string_to_dict, -) +from ase.io.wannier90 import (list_to_formatted_str, num_wann_from_projections, + proj_string_to_dict) class ProjectionBlock(object): diff --git a/koopmans/pseudopotentials.py b/src/koopmans/pseudopotentials.py similarity index 99% rename from koopmans/pseudopotentials.py rename to src/koopmans/pseudopotentials.py index 8971debb0..407d551ee 100644 --- a/koopmans/pseudopotentials.py +++ b/src/koopmans/pseudopotentials.py @@ -16,9 +16,8 @@ from pathlib import Path from typing import Any, Dict, List, Optional -from upf_to_json import upf_to_json - from ase import Atoms +from upf_to_json import upf_to_json @dataclass diff --git a/koopmans/qei_to_json.py b/src/koopmans/qei_to_json.py similarity index 99% rename from koopmans/qei_to_json.py rename to src/koopmans/qei_to_json.py index 6787c8dec..b9348e745 100644 --- a/koopmans/qei_to_json.py +++ b/src/koopmans/qei_to_json.py @@ -2,6 +2,7 @@ from typing import Any, Dict, Union from ase.dft.kpoints import BandPath + from koopmans.io import read, write from koopmans.kpoints import Kpoints from koopmans.settings import WorkflowSettingsDict diff --git a/koopmans/references.py b/src/koopmans/references.py similarity index 100% rename from koopmans/references.py rename to src/koopmans/references.py diff --git a/koopmans/settings/__init__.py b/src/koopmans/settings/__init__.py similarity index 100% rename from koopmans/settings/__init__.py rename to src/koopmans/settings/__init__.py index 24b3bbe6d..041f3869e 100644 --- a/koopmans/settings/__init__.py +++ b/src/koopmans/settings/__init__.py @@ -12,8 +12,8 @@ from ._ph import PhSettingsDict from ._plot import PlotSettingsDict from ._projwfc import ProjwfcSettingsDict -from ._pw2wannier import PW2WannierSettingsDict from ._pw import PWSettingsDict +from ._pw2wannier import PW2WannierSettingsDict from ._ui import UnfoldAndInterpolateSettingsDict from ._utils import Setting, SettingsDict, SettingsDictWithChecks from ._wann2kc import Wann2KCSettingsDict diff --git a/koopmans/settings/_koopmans_cp.py b/src/koopmans/settings/_koopmans_cp.py similarity index 100% rename from koopmans/settings/_koopmans_cp.py rename to src/koopmans/settings/_koopmans_cp.py diff --git a/koopmans/settings/_koopmans_ham.py b/src/koopmans/settings/_koopmans_ham.py similarity index 100% rename from koopmans/settings/_koopmans_ham.py rename to src/koopmans/settings/_koopmans_ham.py diff --git a/koopmans/settings/_koopmans_screen.py b/src/koopmans/settings/_koopmans_screen.py similarity index 100% rename from koopmans/settings/_koopmans_screen.py rename to src/koopmans/settings/_koopmans_screen.py diff --git a/koopmans/settings/_ph.py b/src/koopmans/settings/_ph.py similarity index 100% rename from koopmans/settings/_ph.py rename to src/koopmans/settings/_ph.py diff --git a/koopmans/settings/_plot.py b/src/koopmans/settings/_plot.py similarity index 100% rename from koopmans/settings/_plot.py rename to src/koopmans/settings/_plot.py diff --git a/koopmans/settings/_projwfc.py b/src/koopmans/settings/_projwfc.py similarity index 100% rename from koopmans/settings/_projwfc.py rename to src/koopmans/settings/_projwfc.py diff --git a/koopmans/settings/_pw.py b/src/koopmans/settings/_pw.py similarity index 100% rename from koopmans/settings/_pw.py rename to src/koopmans/settings/_pw.py diff --git a/koopmans/settings/_pw2wannier.py b/src/koopmans/settings/_pw2wannier.py similarity index 100% rename from koopmans/settings/_pw2wannier.py rename to src/koopmans/settings/_pw2wannier.py diff --git a/koopmans/settings/_ui.py b/src/koopmans/settings/_ui.py similarity index 99% rename from koopmans/settings/_ui.py rename to src/koopmans/settings/_ui.py index fc75f0377..c23de2cd8 100644 --- a/koopmans/settings/_ui.py +++ b/src/koopmans/settings/_ui.py @@ -10,7 +10,6 @@ from typing import Any, List import numpy as np - from ase.dft.kpoints import BandPath from ._utils import Setting, SettingsDictWithChecks diff --git a/koopmans/settings/_utils.py b/src/koopmans/settings/_utils.py similarity index 100% rename from koopmans/settings/_utils.py rename to src/koopmans/settings/_utils.py diff --git a/koopmans/settings/_wann2kc.py b/src/koopmans/settings/_wann2kc.py similarity index 100% rename from koopmans/settings/_wann2kc.py rename to src/koopmans/settings/_wann2kc.py diff --git a/koopmans/settings/_wann2kcp.py b/src/koopmans/settings/_wann2kcp.py similarity index 100% rename from koopmans/settings/_wann2kcp.py rename to src/koopmans/settings/_wann2kcp.py diff --git a/koopmans/settings/_wannier90.py b/src/koopmans/settings/_wannier90.py similarity index 99% rename from koopmans/settings/_wannier90.py rename to src/koopmans/settings/_wannier90.py index 7ef6d468c..b405f3c03 100644 --- a/koopmans/settings/_wannier90.py +++ b/src/koopmans/settings/_wannier90.py @@ -1,7 +1,6 @@ from typing import Any import numpy as np - from ase.dft.kpoints import BandPath from ase.io.wannier90 import construct_kpoint_path, proj_string_to_dict diff --git a/koopmans/settings/_workflow.py b/src/koopmans/settings/_workflow.py similarity index 100% rename from koopmans/settings/_workflow.py rename to src/koopmans/settings/_workflow.py diff --git a/koopmans/utils/__init__.py b/src/koopmans/utils/__init__.py similarity index 100% rename from koopmans/utils/__init__.py rename to src/koopmans/utils/__init__.py diff --git a/koopmans/utils/_figures.py b/src/koopmans/utils/_figures.py similarity index 100% rename from koopmans/utils/_figures.py rename to src/koopmans/utils/_figures.py diff --git a/koopmans/utils/_io.py b/src/koopmans/utils/_io.py similarity index 100% rename from koopmans/utils/_io.py rename to src/koopmans/utils/_io.py index a0652e80a..b151b9314 100644 --- a/koopmans/utils/_io.py +++ b/src/koopmans/utils/_io.py @@ -14,10 +14,10 @@ import numpy as np import numpy.typing as npt - from ase.atoms import Atoms from ase.io.espresso import label_to_symbol, label_to_tag from ase.units import Bohr + from koopmans.cell import (cell_follows_qe_conventions, cell_to_parameters, parameters_to_cell) diff --git a/koopmans/utils/_misc.py b/src/koopmans/utils/_misc.py similarity index 100% rename from koopmans/utils/_misc.py rename to src/koopmans/utils/_misc.py diff --git a/koopmans/utils/_os.py b/src/koopmans/utils/_os.py similarity index 100% rename from koopmans/utils/_os.py rename to src/koopmans/utils/_os.py diff --git a/koopmans/utils/_units.py b/src/koopmans/utils/_units.py similarity index 100% rename from koopmans/utils/_units.py rename to src/koopmans/utils/_units.py diff --git a/koopmans/utils/_warnings.py b/src/koopmans/utils/_warnings.py similarity index 100% rename from koopmans/utils/_warnings.py rename to src/koopmans/utils/_warnings.py diff --git a/koopmans/workflows/__init__.py b/src/koopmans/workflows/__init__.py similarity index 64% rename from koopmans/workflows/__init__.py rename to src/koopmans/workflows/__init__.py index dfcd31db7..9d3873a3f 100644 --- a/koopmans/workflows/__init__.py +++ b/src/koopmans/workflows/__init__.py @@ -2,14 +2,12 @@ from ._anion_dscf import DeltaSCFWorkflow from ._convergence import ConvergenceWorkflow -from ._dft import DFTCPWorkflow, DFTPWWorkflow, DFTBandsWorkflow, DFTPhWorkflow +from ._dft import DFTBandsWorkflow, DFTCPWorkflow, DFTPhWorkflow, DFTPWWorkflow from ._folding import FoldToSupercellWorkflow from ._koopmans_dfpt import KoopmansDFPTWorkflow from ._koopmans_dscf import KoopmansDSCFWorkflow from ._singlepoint import SinglepointWorkflow -from ._unfold_and_interp import ( - SingleUnfoldAndInterpolateWorkflow, - UnfoldAndInterpolateWorkflow, -) +from ._unfold_and_interp import (SingleUnfoldAndInterpolateWorkflow, + UnfoldAndInterpolateWorkflow) from ._wannierize import WannierizeWorkflow from ._workflow import Workflow diff --git a/koopmans/workflows/_anion_dscf.py b/src/koopmans/workflows/_anion_dscf.py similarity index 99% rename from koopmans/workflows/_anion_dscf.py rename to src/koopmans/workflows/_anion_dscf.py index 3cc9a9dde..00e99c16c 100644 --- a/koopmans/workflows/_anion_dscf.py +++ b/src/koopmans/workflows/_anion_dscf.py @@ -1,6 +1,7 @@ import os from ase.calculators.calculator import CalculationFailed + from koopmans import utils from koopmans.calculators import EnvironCalculator diff --git a/koopmans/workflows/_convergence.py b/src/koopmans/workflows/_convergence.py similarity index 100% rename from koopmans/workflows/_convergence.py rename to src/koopmans/workflows/_convergence.py diff --git a/koopmans/workflows/_dft.py b/src/koopmans/workflows/_dft.py similarity index 100% rename from koopmans/workflows/_dft.py rename to src/koopmans/workflows/_dft.py diff --git a/koopmans/workflows/_folding.py b/src/koopmans/workflows/_folding.py similarity index 100% rename from koopmans/workflows/_folding.py rename to src/koopmans/workflows/_folding.py diff --git a/koopmans/workflows/_koopmans_dfpt.py b/src/koopmans/workflows/_koopmans_dfpt.py similarity index 100% rename from koopmans/workflows/_koopmans_dfpt.py rename to src/koopmans/workflows/_koopmans_dfpt.py diff --git a/koopmans/workflows/_koopmans_dscf.py b/src/koopmans/workflows/_koopmans_dscf.py similarity index 100% rename from koopmans/workflows/_koopmans_dscf.py rename to src/koopmans/workflows/_koopmans_dscf.py index 139cb89b7..7541a034c 100644 --- a/koopmans/workflows/_koopmans_dscf.py +++ b/src/koopmans/workflows/_koopmans_dscf.py @@ -12,8 +12,8 @@ from typing import List, Optional, Tuple import numpy as np - from ase.dft import DOS + from koopmans import calculators, utils from koopmans.bands import Band, Bands from koopmans.settings import KoopmansCPSettingsDict diff --git a/koopmans/workflows/_singlepoint.py b/src/koopmans/workflows/_singlepoint.py similarity index 100% rename from koopmans/workflows/_singlepoint.py rename to src/koopmans/workflows/_singlepoint.py diff --git a/koopmans/workflows/_unfold_and_interp.py b/src/koopmans/workflows/_unfold_and_interp.py similarity index 100% rename from koopmans/workflows/_unfold_and_interp.py rename to src/koopmans/workflows/_unfold_and_interp.py index 973ddbc25..dffa45578 100644 --- a/koopmans/workflows/_unfold_and_interp.py +++ b/src/koopmans/workflows/_unfold_and_interp.py @@ -14,8 +14,8 @@ from typing import Optional import numpy as np - from ase.spectrum.band_structure import BandStructure + from koopmans import calculators, utils from ._workflow import Workflow diff --git a/koopmans/workflows/_wannierize.py b/src/koopmans/workflows/_wannierize.py similarity index 100% rename from koopmans/workflows/_wannierize.py rename to src/koopmans/workflows/_wannierize.py diff --git a/koopmans/workflows/_workflow.py b/src/koopmans/workflows/_workflow.py similarity index 100% rename from koopmans/workflows/_workflow.py rename to src/koopmans/workflows/_workflow.py From 67c4a83887c3df6492ac6f2c7c3f7c59b943dbaa Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 17:43:49 +0200 Subject: [PATCH 22/49] Updated koopmans.base_directory --- src/koopmans/__init__.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/koopmans/__init__.py b/src/koopmans/__init__.py index 4b8908740..0e5a823bd 100644 --- a/src/koopmans/__init__.py +++ b/src/koopmans/__init__.py @@ -8,4 +8,4 @@ import importlib_metadata as metadata __version__ = metadata.version('koopmans') -base_directory = Path(__path__[0]).parent +base_directory = Path(__path__[0]).parents[1] From e875c155efeac07574bcbc1210d9d69286cc5375 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 18:13:25 +0200 Subject: [PATCH 23/49] Various bugfixes --- .github/workflows/typechecking.yml | 2 +- MANIFEST.in | 2 ++ docs/conf.py | 18 +++++++++--------- src/koopmans/references.py | 2 +- 4 files changed, 13 insertions(+), 11 deletions(-) create mode 100644 MANIFEST.in diff --git a/.github/workflows/typechecking.yml b/.github/workflows/typechecking.yml index 8877bdde1..003f3ba04 100644 --- a/.github/workflows/typechecking.yml +++ b/.github/workflows/typechecking.yml @@ -33,4 +33,4 @@ jobs: pip install mypy - name: Run mypy run: | - mypy koopmans/ --ignore-missing-imports + mypy src/koopmans/ --ignore-missing-imports diff --git a/MANIFEST.in b/MANIFEST.in new file mode 100644 index 000000000..f64e0ebf8 --- /dev/null +++ b/MANIFEST.in @@ -0,0 +1,2 @@ +include docs/refs.bib +graft pseudos/ diff --git a/docs/conf.py b/docs/conf.py index ef7400f5b..278bd5844 100644 --- a/docs/conf.py +++ b/docs/conf.py @@ -6,16 +6,18 @@ # -- Path setup -------------------------------------------------------------- -# If extensions (or modules to document with autodoc) are in another directory, -# add these directories to sys.path here. If the directory is relative to the -# documentation root, use os.path.abspath to make it absolute, like shown here. -# import os import sys import sphinx_rtd_theme -sys.path.insert(0, os.path.abspath('../')) +# If extensions (or modules to document with autodoc) are in another directory, +# add these directories to sys.path here. If the directory is relative to the +# documentation root, use os.path.abspath to make it absolute, like shown here. +# +import koopmans + +sys.path.insert(0, os.path.abspath('../src')) # -- Project information ----------------------------------------------------- @@ -24,10 +26,8 @@ copyright = '2020, Edward Linscott, Riccardo De Gennaro, and Nicola Colonna' author = 'Edward Linscott, Riccardo De Gennaro, and Nicola Colonna' language = None -with open('../koopmans/__init__.py', 'r') as f: - # The full version, including alpha/beta/rc tags - [version_line] = [l for l in f.readlines() if l.startswith('__version__')] -version = version_line.split('=')[-1].strip(" '") + +version = koopmans.__version__ release = version # -- General configuration --------------------------------------------------- diff --git a/src/koopmans/references.py b/src/koopmans/references.py index 96c7a0814..fb7fd32e5 100644 --- a/src/koopmans/references.py +++ b/src/koopmans/references.py @@ -9,5 +9,5 @@ from pybtex.database.input import bibtex parser = bibtex.Parser() -bib_file = Path(__file__).parents[1] / 'docs/refs.bib' +bib_file = Path(__file__).parents[2] / 'docs/refs.bib' bib_data = parser.parse_file(bib_file) From 112e8983d08347e16025ed46de5c3033709e72da Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 18:20:27 +0200 Subject: [PATCH 24/49] Add automated publish to pypi upon release --- .github/workflows/release.yml | 41 +++++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) create mode 100644 .github/workflows/release.yml diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml new file mode 100644 index 000000000..ef1f68334 --- /dev/null +++ b/.github/workflows/release.yml @@ -0,0 +1,41 @@ +name: Publish + +on: + release: + types: + - published + +env: + GIT_USER_NAME: 'koopmans developers' + GIT_USER_EMAIL: ${{ secrets.PUBLISH_EMAIL }} + +jobs: + + publish: + name: Publish koopmans + runs-on: ubuntu-latest + if: github.repository == 'epfl-theos/koopmans' && startsWith(github.ref, 'refs/tags/v') + + steps: + - name: Checkout repository + uses: actions/checkout@v3 + + - name: Set up Python 3.10 + uses: actions/setup-python@v4 + with: + python-version: '3.10' + + - name: Install Python dependencies + run: | + python -m pip install -U pip + pip install -U setuptools wheel build + pip install -e . + + - name: Build source distribution + run: python -m build + + - name: Publish package to PyPI + uses: pypa/gh-action-pypi-publish@release/v1 + with: + user: __token__ + password: ${{ secrets.PYPI_API_TOKEN }} From c21c8dcc8ab2edb8ee15372c61d27281ea612025 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 18:22:30 +0200 Subject: [PATCH 25/49] Correct pseudo directory --- src/koopmans/pseudopotentials.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/koopmans/pseudopotentials.py b/src/koopmans/pseudopotentials.py index 407d551ee..556563e40 100644 --- a/src/koopmans/pseudopotentials.py +++ b/src/koopmans/pseudopotentials.py @@ -33,7 +33,7 @@ class Pseudopotential: cutoff_rho: Optional[float] = None -pseudos_directory = Path(__file__).parents[1] / 'pseudos' +pseudos_directory = Path(__file__).parents[2] / 'pseudos' # A database containing all the available pseudopotentials pseudo_database: List[Pseudopotential] = [] From fa792f64bd422523189895b7fe96dc5501d3d8e6 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 18:30:05 +0200 Subject: [PATCH 26/49] Updated docs to parse project info from pyproject.toml --- docs/conf.py | 13 ++++--------- docs/requirements.txt | 1 + 2 files changed, 5 insertions(+), 9 deletions(-) diff --git a/docs/conf.py b/docs/conf.py index 278bd5844..f7e850139 100644 --- a/docs/conf.py +++ b/docs/conf.py @@ -10,26 +10,21 @@ import sys import sphinx_rtd_theme +from sphinx_pyproject import SphinxConfig + +import koopmans # If extensions (or modules to document with autodoc) are in another directory, # add these directories to sys.path here. If the directory is relative to the # documentation root, use os.path.abspath to make it absolute, like shown here. # -import koopmans sys.path.insert(0, os.path.abspath('../src')) - # -- Project information ----------------------------------------------------- - -project = 'koopmans' -copyright = '2020, Edward Linscott, Riccardo De Gennaro, and Nicola Colonna' -author = 'Edward Linscott, Riccardo De Gennaro, and Nicola Colonna' +config = SphinxConfig("../pyproject.toml", globalns=globals()) language = None -version = koopmans.__version__ -release = version - # -- General configuration --------------------------------------------------- # Add any Sphinx extension module names here, as strings. They can be diff --git a/docs/requirements.txt b/docs/requirements.txt index 76e409010..883f31ac1 100644 --- a/docs/requirements.txt +++ b/docs/requirements.txt @@ -4,3 +4,4 @@ sphinx_toolbox>=2.5.0 sphinx_rtd_theme>=1.0.0 recommonmark>=0.7.1 numpydoc>=1.4.0 +sphinx-pyproject>=0.1.0 From 3a1c13d50e0f33eda5f8ddb9470b8a1448a4016c Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 18:32:48 +0200 Subject: [PATCH 27/49] Adding erroneous import in conf.py --- docs/conf.py | 2 -- 1 file changed, 2 deletions(-) diff --git a/docs/conf.py b/docs/conf.py index f7e850139..a1249abca 100644 --- a/docs/conf.py +++ b/docs/conf.py @@ -12,8 +12,6 @@ import sphinx_rtd_theme from sphinx_pyproject import SphinxConfig -import koopmans - # If extensions (or modules to document with autodoc) are in another directory, # add these directories to sys.path here. If the directory is relative to the # documentation root, use os.path.abspath to make it absolute, like shown here. From 1a8ac2426e97006c676c2e335ffbc4fd857c8bda Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 18:43:42 +0200 Subject: [PATCH 28/49] Updated rtd config --- .readthedocs.yml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/.readthedocs.yml b/.readthedocs.yml index cbca9f595..4eddd1557 100644 --- a/.readthedocs.yml +++ b/.readthedocs.yml @@ -21,5 +21,6 @@ formats: python: version: 3.7 install: - - requirements: docs/requirements.txt - - requirements: requirements/requirements.txt + - method: pip + path: . + extra_requirements: docs/requirements.txt From 3ff9ea62f363de026114e55054dcfefda05851e2 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 18:46:05 +0200 Subject: [PATCH 29/49] Updated rtd config --- .readthedocs.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.readthedocs.yml b/.readthedocs.yml index 4eddd1557..6ebce972e 100644 --- a/.readthedocs.yml +++ b/.readthedocs.yml @@ -19,8 +19,8 @@ formats: # Optionally set the version of Python and requirements required to build your docs python: - version: 3.7 + version: "3.7" install: - method: pip path: . - extra_requirements: docs/requirements.txt + extra_requirements: [docs/requirements.txt] From 07569148a854ed134e100064102b7b9ef436c702 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 18:49:19 +0200 Subject: [PATCH 30/49] Updated rtd config --- .readthedocs.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.readthedocs.yml b/.readthedocs.yml index 6ebce972e..adfec61d4 100644 --- a/.readthedocs.yml +++ b/.readthedocs.yml @@ -23,4 +23,5 @@ python: install: - method: pip path: . - extra_requirements: [docs/requirements.txt] + extra_requirements: + - docs/requirements.txt From ba3a0559feda27e97d72f577aa1521c9167b8587 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 18:56:01 +0200 Subject: [PATCH 31/49] Moved docs requirements into toml --- .readthedocs.yml | 3 +-- pyproject.toml | 9 +++++++++ 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/.readthedocs.yml b/.readthedocs.yml index adfec61d4..24444978e 100644 --- a/.readthedocs.yml +++ b/.readthedocs.yml @@ -19,9 +19,8 @@ formats: # Optionally set the version of Python and requirements required to build your docs python: - version: "3.7" install: - method: pip path: . extra_requirements: - - docs/requirements.txt + - docs diff --git a/pyproject.toml b/pyproject.toml index 61e96bde8..df5c4bbe9 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -44,6 +44,15 @@ test = [ "pytest>=5.4", "pytest-cov>=2.9", ] +docs = [ +sphinx>=3.0 +sphinxcontrib-bibtex>=2.1.4 +sphinx_toolbox>=2.5.0 +sphinx_rtd_theme>=1.0.0 +recommonmark>=0.7.1 +numpydoc>=1.4.0 +sphinx-pyproject>=0.1.0 +] [project.scripts] koopmans = "koopmans.cli.main:main" From d2c7e8709eefc03e0281bd4c9d7833caeb27b19d Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 19:00:13 +0200 Subject: [PATCH 32/49] Moved docs requirements into toml - bugfix --- pyproject.toml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/pyproject.toml b/pyproject.toml index df5c4bbe9..d3f4ee6aa 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -45,13 +45,13 @@ test = [ "pytest-cov>=2.9", ] docs = [ -sphinx>=3.0 -sphinxcontrib-bibtex>=2.1.4 -sphinx_toolbox>=2.5.0 -sphinx_rtd_theme>=1.0.0 -recommonmark>=0.7.1 -numpydoc>=1.4.0 -sphinx-pyproject>=0.1.0 + "sphinx>=3.0", + "sphinxcontrib-bibtex>=2.1.4", + "sphinx_toolbox>=2.5.0", + "sphinx_rtd_theme>=1.0.0", + "recommonmark>=0.7.1", + "numpydoc>=1.4.0", + "sphinx-pyproject>=0.1.0" ] [project.scripts] From 4b13ee6edc1e0cec72fc661bba4711c73e3e3bbb Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 21:08:35 +0200 Subject: [PATCH 33/49] Updated conf so that it obtained project, version, etc --- docs/conf.py | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/docs/conf.py b/docs/conf.py index a1249abca..c8d5045ed 100644 --- a/docs/conf.py +++ b/docs/conf.py @@ -21,7 +21,11 @@ # -- Project information ----------------------------------------------------- config = SphinxConfig("../pyproject.toml", globalns=globals()) -language = None +project = config.name +version = config.version +release = 'v' + version +author = config.author +language = "en" # -- General configuration --------------------------------------------------- From 3c31fd4039315892b922569586726f5933b81e07 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 21:17:39 +0200 Subject: [PATCH 34/49] Add Riccardo and Nicola as authors --- pyproject.toml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/pyproject.toml b/pyproject.toml index d3f4ee6aa..93ea11c21 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -5,7 +5,9 @@ description = "Koopmans spectral functional calculations with python and Quantum readme = "README.rst" requires-python = ">=3.7" license = { name = "GPL", file = "LICENSE" } -authors = [{ name = "Edward Linscott", email = "edwardlinscott@gmail.com" }] +authors = [{ name = "Edward Linscott", email = "edward.linscott@epfl.ch" }, + { name = "Riccardo De Gennaro", email = "riccardo.degennaro@epfl.ch" }, + { name = "Nicola Colonna", email = "nicola.colonna@psi.ch" }] classifiers = [ "Intended Audience :: Science/Research", "License :: OSI Approved :: MIT License", From 9f54289bfd24abe4f53983396adf2491fa162bd1 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 21:50:31 +0200 Subject: [PATCH 35/49] Move bib and pseudos into src/koopmans/ --- conftest.py | 3 +- docs/refs.bib | 317 ------------------ src/koopmans/__init__.py | 1 - src/koopmans/pseudopotentials.py | 4 +- .../koopmans/pseudos}/generate_wfc_psps.py | 0 .../koopmans/pseudos}/pseudo_dojo_standard | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ag.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Al.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ar.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/As.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Au.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/B.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ba.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Be.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Bi.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Br.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/C.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ca.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Cd.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Cl.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Co.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Cr.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Cs.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Cu.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/F.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Fe.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ga.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ge.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/H.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/He.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Hf.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Hg.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/I.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/In.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ir.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/K.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Kr.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Li.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Mg.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Mn.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Mo.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/N.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Na.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Nb.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ne.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ni.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/O.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Os.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/P.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Pb.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Pd.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Po.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Pt.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Rb.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Re.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Rh.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Rn.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ru.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/S.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Sb.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Sc.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Se.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Si.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Sn.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Sr.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ta.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Tc.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Te.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ti.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Tl.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/V.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/W.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Xe.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Y.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Zn.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Zr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ag.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Al.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ar.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/As.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Au.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/B.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ba.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Be.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Bi.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Br.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/C.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ca.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Cd.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Cl.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Co.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Cr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Cs.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Cu.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/F.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Fe.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ga.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ge.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/H.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/He.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Hf.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Hg.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/I.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/In.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ir.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/K.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Kr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/La.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Li.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Lu.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Mg.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Mn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Mo.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/N.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Na.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Nb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ne.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ni.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/O.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Os.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/P.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Pb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Pd.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Po.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Pt.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Rb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Re.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Rh.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Rn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ru.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/S.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Sb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Sc.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Se.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Si.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Sn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Sr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ta.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Tc.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Te.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ti.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Tl.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/V.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/W.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Xe.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Y.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Zn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Zr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ag.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Al.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ar.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/As.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Au.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/B.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ba.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Be.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Bi.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Br.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/C.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ca.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Cd.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Cl.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Co.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Cr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Cs.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Cu.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/F.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Fe.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ga.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ge.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/H.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/He.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Hf.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Hg.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/I.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/In.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ir.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/K.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Kr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/La.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Li.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Lu.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Mg.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Mn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Mo.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/N.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Na.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Nb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ne.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ni.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/O.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Os.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/P.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Pb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Pd.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Po.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Pt.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Rb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Re.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Rh.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Rn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ru.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/S.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Sb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Sc.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Se.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Si.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Sn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Sr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ta.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Tc.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Te.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ti.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Tl.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/V.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/W.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Xe.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Y.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Zn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Zr.upf | 0 .../koopmans/pseudos}/pseudo_dojo_stringent | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ag.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Al.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ar.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/As.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Au.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/B.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ba.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Be.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Bi.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Br.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/C.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ca.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Cd.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Cl.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Co.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Cr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Cs.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Cu.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/F.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Fe.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ga.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ge.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/H.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/He.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Hf.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Hg.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/I.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/In.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ir.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/K.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Kr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Li.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Mg.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Mn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Mo.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/N.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Na.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Nb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ne.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ni.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/O.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Os.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/P.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Pb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Pd.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Po.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Pt.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Rb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Re.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Rh.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Rn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ru.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/S.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Sb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Sc.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Se.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Si.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Sn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Sr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ta.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Tc.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Te.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ti.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Tl.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/V.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/W.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Xe.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Y.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Zn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Zr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ag.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Al.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ar.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/As.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Au.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/B.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ba.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Be.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Bi.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Br.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/C.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ca.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Cd.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Cl.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Co.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Cr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Cs.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Cu.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/F.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Fe.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ga.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ge.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/H.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/He.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Hf.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Hg.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/I.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/In.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ir.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/K.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Kr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/La.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Li.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Lu.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Mg.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Mn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Mo.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/N.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Na.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Nb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ne.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ni.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/O.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Os.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/P.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Pb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Pd.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Po.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Pt.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Rb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Re.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Rh.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Rn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ru.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/S.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Sb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Sc.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Se.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Si.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Sn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Sr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ta.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Tc.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Te.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ti.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Tl.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/V.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/W.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Xe.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Y.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Zn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Zr.upf | 0 .../pbesol/Ag.upf | 0 .../pbesol/Al.upf | 0 .../pbesol/Ar.upf | 0 .../pbesol/As.upf | 0 .../pbesol/Au.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/B.upf | 0 .../pbesol/Ba.upf | 0 .../pbesol/Be.upf | 0 .../pbesol/Bi.upf | 0 .../pbesol/Br.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/C.upf | 0 .../pbesol/Ca.upf | 0 .../pbesol/Cd.upf | 0 .../pbesol/Cl.upf | 0 .../pbesol/Co.upf | 0 .../pbesol/Cr.upf | 0 .../pbesol/Cs.upf | 0 .../pbesol/Cu.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/F.upf | 0 .../pbesol/Fe.upf | 0 .../pbesol/Ga.upf | 0 .../pbesol/Ge.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/H.upf | 0 .../pbesol/He.upf | 0 .../pbesol/Hf.upf | 0 .../pbesol/Hg.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/I.upf | 0 .../pbesol/In.upf | 0 .../pbesol/Ir.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/K.upf | 0 .../pbesol/Kr.upf | 0 .../pbesol/La.upf | 0 .../pbesol/Li.upf | 0 .../pbesol/Lu.upf | 0 .../pbesol/Mg.upf | 0 .../pbesol/Mn.upf | 0 .../pbesol/Mo.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/N.upf | 0 .../pbesol/Na.upf | 0 .../pbesol/Nb.upf | 0 .../pbesol/Ne.upf | 0 .../pbesol/Ni.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/O.upf | 0 .../pbesol/Os.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/P.upf | 0 .../pbesol/Pb.upf | 0 .../pbesol/Pd.upf | 0 .../pbesol/Po.upf | 0 .../pbesol/Pt.upf | 0 .../pbesol/Rb.upf | 0 .../pbesol/Re.upf | 0 .../pbesol/Rh.upf | 0 .../pbesol/Rn.upf | 0 .../pbesol/Ru.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/S.upf | 0 .../pbesol/Sb.upf | 0 .../pbesol/Sc.upf | 0 .../pbesol/Se.upf | 0 .../pbesol/Si.upf | 0 .../pbesol/Sn.upf | 0 .../pbesol/Sr.upf | 0 .../pbesol/Ta.upf | 0 .../pbesol/Tc.upf | 0 .../pbesol/Te.upf | 0 .../pbesol/Ti.upf | 0 .../pbesol/Tl.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/V.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/W.upf | 0 .../pbesol/Xe.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Y.upf | 0 .../pbesol/Zn.upf | 0 .../pbesol/Zr.upf | 0 {pseudos => src/koopmans/pseudos}/sg15 | 0 .../koopmans/pseudos}/sg15_relativistic | 0 .../pbe/Ag_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Al_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Ar_ONCV_PBE_FR-1.1.upf | 0 .../pbe/As_ONCV_PBE_FR-1.1.upf | 0 .../pbe/Au_ONCV_PBE_FR-1.0.upf | 0 .../pbe/B_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Br_ONCV_PBE_FR-1.0.upf | 0 .../pbe/C_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Ca_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Cd_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Cl_ONCV_PBE_FR-1.1.upf | 0 .../pbe/Co_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Cr_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Cs_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Cu_ONCV_PBE_FR-1.0.upf | 0 .../pbe/F_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Fe_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Ga_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Ge_ONCV_PBE_FR-1.0.upf | 0 .../pbe/H_ONCV_PBE_FR-1.0.upf | 0 .../pbe/He_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Hf_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Hg_ONCV_PBE_FR-1.0.upf | 0 .../pbe/I_ONCV_PBE_FR-1.1.upf | 0 .../pbe/In_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Ir_ONCV_PBE_FR-1.0.upf | 0 .../pbe/K_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Kr_ONCV_PBE_FR-1.0.upf | 0 .../pbe/La_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Mg_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Mn_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Mo_ONCV_PBE_FR-1.0.upf | 0 .../pbe/N_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Na_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Nb_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Ni_ONCV_PBE_FR-1.0.upf | 0 .../pbe/O_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Os_ONCV_PBE_FR-1.0.upf | 0 .../pbe/P_ONCV_PBE_FR-1.1.upf | 0 .../pbe/Pb_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Pd_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Pt_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Rb_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Re_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Rh_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Ru_ONCV_PBE_FR-1.0.upf | 0 .../pbe/S_ONCV_PBE_FR-1.1.upf | 0 .../pbe/Sb_ONCV_PBE_FR-1.1.upf | 0 .../pbe/Sc_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Se_ONCV_PBE_FR-1.1.upf | 0 .../pbe/Si_ONCV_PBE_FR-1.1.upf | 0 .../pbe/Sn_ONCV_PBE_FR-1.1.upf | 0 .../pbe/Sr_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Ta_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Tc_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Te_ONCV_PBE_FR-1.1.upf | 0 .../pbe/Ti_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Tl_ONCV_PBE_FR-1.0.upf | 0 .../pbe/V_ONCV_PBE_FR-1.0.upf | 0 .../pbe/W_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Xe_ONCV_PBE_FR-1.1.upf | 0 .../pbe/Y_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Zn_ONCV_PBE_FR-1.0.upf | 0 .../pbe/Zr_ONCV_PBE_FR-1.0.upf | 0 .../sg15_v1.0/pbe/Ag_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Al_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ar_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/As_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Au_ONCV_PBE-1.0.upf | 0 .../pseudos}/sg15_v1.0/pbe/B_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ba_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Be_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Bi_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Br_ONCV_PBE-1.0.upf | 0 .../pseudos}/sg15_v1.0/pbe/C_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ca_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Cd_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Cl_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Co_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Cr_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Cs_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Cu_ONCV_PBE-1.0.upf | 0 .../pseudos}/sg15_v1.0/pbe/F_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Fe_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ga_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ge_ONCV_PBE-1.0.upf | 0 .../pseudos}/sg15_v1.0/pbe/H_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/He_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Hf_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Hg_ONCV_PBE-1.0.upf | 0 .../pseudos}/sg15_v1.0/pbe/I_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/In_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ir_ONCV_PBE-1.0.upf | 0 .../pseudos}/sg15_v1.0/pbe/K_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Kr_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/La_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Li_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Mg_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Mn_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Mo_ONCV_PBE-1.0.upf | 0 .../pseudos}/sg15_v1.0/pbe/N_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Na_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Nb_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ne_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ni_ONCV_PBE-1.0.upf | 0 .../pseudos}/sg15_v1.0/pbe/O_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Os_ONCV_PBE-1.0.upf | 0 .../pseudos}/sg15_v1.0/pbe/P_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Pb_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Pd_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Pt_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Rb_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Re_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Rh_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ru_ONCV_PBE-1.0.upf | 0 .../pseudos}/sg15_v1.0/pbe/S_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Sb_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Sc_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Se_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Si_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Sn_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Sr_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ta_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Tc_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Te_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ti_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Tl_ONCV_PBE-1.0.upf | 0 .../pseudos}/sg15_v1.0/pbe/V_ONCV_PBE-1.0.upf | 0 .../pseudos}/sg15_v1.0/pbe/W_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Xe_ONCV_PBE-1.0.upf | 0 .../pseudos}/sg15_v1.0/pbe/Y_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Zn_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Zr_ONCV_PBE-1.0.upf | 0 .../sg15_v1.2/pbe/Ag_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Al_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ar_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/As_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Au_ONCV_PBE-1.2.upf | 0 .../pseudos}/sg15_v1.2/pbe/B_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ba_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Be_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Bi_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Br_ONCV_PBE-1.2.upf | 0 .../pseudos}/sg15_v1.2/pbe/C_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ca_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Cd_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Cl_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Co_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Cr_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Cs_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Cu_ONCV_PBE-1.2.upf | 0 .../pseudos}/sg15_v1.2/pbe/F_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Fe_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ga_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ge_ONCV_PBE-1.2.upf | 0 .../pseudos}/sg15_v1.2/pbe/H_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/He_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Hf_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Hg_ONCV_PBE-1.2.upf | 0 .../pseudos}/sg15_v1.2/pbe/I_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/In_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ir_ONCV_PBE-1.2.upf | 0 .../pseudos}/sg15_v1.2/pbe/K_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Kr_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/La_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Li_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Mg_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Mn_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Mo_ONCV_PBE-1.2.upf | 0 .../pseudos}/sg15_v1.2/pbe/N_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Na_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Nb_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ne_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ni_ONCV_PBE-1.2.upf | 0 .../pseudos}/sg15_v1.2/pbe/O_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Os_ONCV_PBE-1.2.upf | 0 .../pseudos}/sg15_v1.2/pbe/P_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Pb_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Pd_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Pt_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Rb_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Re_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Rh_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ru_ONCV_PBE-1.2.upf | 0 .../pseudos}/sg15_v1.2/pbe/S_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Sb_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Sc_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Se_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Sn_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Sr_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ta_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Tc_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Te_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ti_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Tl_ONCV_PBE-1.2.upf | 0 .../pseudos}/sg15_v1.2/pbe/V_ONCV_PBE-1.2.upf | 0 .../pseudos}/sg15_v1.2/pbe/W_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Xe_ONCV_PBE-1.2.upf | 0 .../pseudos}/sg15_v1.2/pbe/Y_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Zn_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Zr_ONCV_PBE-1.2.upf | 0 src/koopmans/references.py | 2 +- tests/calculators/test_ph.py | 2 +- tests/calculators/test_projwfc.py | 5 +- tests/patches/_check.py | 4 +- tests/patches/_utils.py | 3 +- tests/tutorials/test_tutorial_1.py | 5 +- tests/tutorials/test_tutorial_2.py | 4 +- tests/tutorials/test_tutorial_3.py | 6 +- tests/tutorials/test_tutorial_4.py | 3 +- 648 files changed, 20 insertions(+), 339 deletions(-) delete mode 100644 docs/refs.bib rename {pseudos => src/koopmans/pseudos}/generate_wfc_psps.py (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Ag.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Al.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Ar.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/As.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Au.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/B.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Ba.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Be.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Bi.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Br.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/C.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Ca.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Cd.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Cl.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Co.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Cr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Cs.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Cu.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/F.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Fe.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Ga.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Ge.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/H.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/He.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Hf.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Hg.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/I.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/In.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Ir.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/K.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Kr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Li.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Mg.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Mn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Mo.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/N.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Na.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Nb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Ne.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Ni.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/O.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Os.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/P.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Pb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Pd.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Po.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Pt.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Rb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Re.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Rh.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Rn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Ru.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/S.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Sb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Sc.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Se.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Si.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Sn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Sr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Ta.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Tc.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Te.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Ti.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Tl.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/V.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/W.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Xe.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Y.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Zn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/lda/Zr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Ag.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Al.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Ar.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/As.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Au.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/B.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Ba.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Be.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Bi.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Br.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/C.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Ca.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Cd.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Cl.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Co.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Cr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Cs.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Cu.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/F.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Fe.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Ga.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Ge.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/H.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/He.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Hf.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Hg.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/I.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/In.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Ir.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/K.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Kr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/La.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Li.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Lu.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Mg.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Mn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Mo.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/N.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Na.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Nb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Ne.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Ni.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/O.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Os.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/P.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Pb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Pd.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Po.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Pt.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Rb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Re.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Rh.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Rn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Ru.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/S.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Sb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Sc.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Se.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Si.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Sn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Sr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Ta.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Tc.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Te.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Ti.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Tl.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/V.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/W.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Xe.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Y.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Zn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbe/Zr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Ag.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Al.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Ar.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/As.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Au.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/B.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Ba.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Be.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Bi.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Br.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/C.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Ca.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Cd.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Cl.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Co.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Cr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Cs.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Cu.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/F.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Fe.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Ga.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Ge.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/H.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/He.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Hf.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Hg.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/I.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/In.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Ir.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/K.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Kr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/La.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Li.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Lu.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Mg.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Mn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Mo.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/N.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Na.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Nb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Ne.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Ni.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/O.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Os.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/P.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Pb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Pd.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Po.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Pt.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Rb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Re.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Rh.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Rn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Ru.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/S.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Sb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Sc.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Se.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Si.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Sn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Sr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Ta.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Tc.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Te.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Ti.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Tl.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/V.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/W.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Xe.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Y.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Zn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_standard_v0.4.1/pbesol/Zr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Ag.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Al.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Ar.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/As.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Au.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/B.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Ba.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Be.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Bi.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Br.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/C.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Ca.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Cd.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Cl.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Co.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Cr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Cs.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Cu.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/F.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Fe.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Ga.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Ge.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/H.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/He.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Hf.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Hg.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/I.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/In.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Ir.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/K.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Kr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Li.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Mg.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Mn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Mo.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/N.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Na.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Nb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Ne.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Ni.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/O.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Os.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/P.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Pb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Pd.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Po.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Pt.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Rb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Re.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Rh.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Rn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Ru.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/S.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Sb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Sc.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Se.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Si.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Sn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Sr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Ta.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Tc.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Te.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Ti.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Tl.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/V.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/W.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Xe.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Y.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Zn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/lda/Zr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Ag.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Al.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Ar.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/As.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Au.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/B.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Ba.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Be.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Bi.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Br.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/C.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Ca.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Cd.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Cl.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Co.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Cr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Cs.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Cu.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/F.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Fe.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Ga.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Ge.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/H.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/He.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Hf.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Hg.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/I.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/In.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Ir.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/K.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Kr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/La.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Li.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Lu.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Mg.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Mn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Mo.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/N.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Na.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Nb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Ne.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Ni.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/O.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Os.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/P.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Pb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Pd.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Po.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Pt.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Rb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Re.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Rh.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Rn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Ru.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/S.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Sb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Sc.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Se.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Si.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Sn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Sr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Ta.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Tc.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Te.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Ti.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Tl.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/V.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/W.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Xe.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Y.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Zn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbe/Zr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Ag.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Al.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Ar.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/As.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Au.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/B.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Ba.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Be.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Bi.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Br.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/C.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Ca.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Cd.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Cl.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Co.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Cr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Cs.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Cu.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/F.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Fe.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Ga.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Ge.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/H.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/He.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Hf.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Hg.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/I.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/In.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Ir.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/K.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Kr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/La.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Li.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Lu.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Mg.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Mn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Mo.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/N.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Na.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Nb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Ne.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Ni.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/O.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Os.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/P.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Pb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Pd.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Po.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Pt.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Rb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Re.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Rh.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Rn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Ru.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/S.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Sb.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Sc.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Se.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Si.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Sn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Sr.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Ta.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Tc.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Te.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Ti.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Tl.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/V.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/W.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Xe.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Y.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Zn.upf (100%) rename {pseudos => src/koopmans/pseudos}/pseudo_dojo_stringent_v0.4.1/pbesol/Zr.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15 (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Ag_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Al_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Ar_ONCV_PBE_FR-1.1.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/As_ONCV_PBE_FR-1.1.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Au_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/B_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Br_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/C_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Ca_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Cd_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Cl_ONCV_PBE_FR-1.1.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Co_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Cr_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Cs_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Cu_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/F_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Fe_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Ga_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Ge_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/H_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/He_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Hf_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Hg_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/I_ONCV_PBE_FR-1.1.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/In_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Ir_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/K_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Kr_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/La_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Mg_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Mn_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Mo_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/N_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Na_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Nb_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Ni_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/O_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Os_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/P_ONCV_PBE_FR-1.1.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Pb_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Pd_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Pt_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Rb_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Re_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Rh_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Ru_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/S_ONCV_PBE_FR-1.1.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Sb_ONCV_PBE_FR-1.1.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Sc_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Se_ONCV_PBE_FR-1.1.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Si_ONCV_PBE_FR-1.1.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Sn_ONCV_PBE_FR-1.1.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Sr_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Ta_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Tc_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Te_ONCV_PBE_FR-1.1.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Ti_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Tl_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/V_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/W_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Xe_ONCV_PBE_FR-1.1.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Y_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Zn_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_relativistic_v1.0/pbe/Zr_ONCV_PBE_FR-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Ag_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Al_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Ar_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/As_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Au_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/B_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Ba_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Be_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Bi_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Br_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/C_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Ca_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Cd_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Cl_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Co_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Cr_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Cs_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Cu_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/F_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Fe_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Ga_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Ge_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/H_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/He_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Hf_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Hg_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/I_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/In_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Ir_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/K_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Kr_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/La_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Li_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Mg_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Mn_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Mo_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/N_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Na_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Nb_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Ne_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Ni_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/O_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Os_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/P_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Pb_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Pd_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Pt_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Rb_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Re_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Rh_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Ru_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/S_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Sb_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Sc_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Se_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Si_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Sn_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Sr_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Ta_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Tc_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Te_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Ti_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Tl_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/V_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/W_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Xe_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Y_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Zn_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.0/pbe/Zr_ONCV_PBE-1.0.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Ag_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Al_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Ar_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/As_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Au_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/B_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Ba_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Be_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Bi_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Br_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/C_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Ca_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Cd_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Cl_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Co_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Cr_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Cs_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Cu_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/F_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Fe_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Ga_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Ge_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/H_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/He_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Hf_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Hg_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/I_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/In_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Ir_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/K_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Kr_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/La_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Li_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Mg_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Mn_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Mo_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/N_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Na_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Nb_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Ne_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Ni_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/O_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Os_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/P_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Pb_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Pd_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Pt_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Rb_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Re_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Rh_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Ru_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/S_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Sb_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Sc_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Se_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Sn_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Sr_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Ta_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Tc_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Te_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Ti_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Tl_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/V_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/W_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Xe_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Y_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Zn_ONCV_PBE-1.2.upf (100%) rename {pseudos => src/koopmans/pseudos}/sg15_v1.2/pbe/Zr_ONCV_PBE-1.2.upf (100%) diff --git a/conftest.py b/conftest.py index b1f87fe5b..423b9774b 100644 --- a/conftest.py +++ b/conftest.py @@ -5,7 +5,6 @@ from ase.build import bulk, molecule from ase.spacegroup import crystal -from koopmans import base_directory from koopmans.kpoints import Kpoints from koopmans.projections import ProjectionBlocks from tests import patches @@ -23,7 +22,7 @@ def pytest_addoption(parser): @pytest.fixture def datadir(): # Returns the directory where various reference QE files are stored - return base_directory / 'tests' / 'data' + return Path(__path__[0]) / 'tests' / 'data' @pytest.fixture diff --git a/docs/refs.bib b/docs/refs.bib deleted file mode 100644 index 7013e365c..000000000 --- a/docs/refs.bib +++ /dev/null @@ -1,317 +0,0 @@ - -@article{Baroni2001, - title = {Phonons and Related Crystal Properties from Density-Functional Perturbation Theory}, - author = {Baroni, Stefano and {de Gironcoli}, Stefano and Dal Corso, Andrea and Giannozzi, Paolo}, - year = {2001}, - month = jul, - journal = {Reviews of Modern Physics}, - volume = {73}, - number = {2}, - pages = {515--562}, - publisher = {{American Physical Society}}, - issn = {0034-6861}, - doi = {10.1103/RevModPhys.73.515} -} - -@article{Borghi2014, - title = {Koopmans-Compliant Functionals and Their Performance against Reference Molecular Data}, - author = {Borghi, Giovanni and Ferretti, Andrea and Nguyen, Ngoc Linh and Dabo, Ismaila and Marzari, Nicola}, - year = {2014}, - month = aug, - journal = {Physical Review B}, - volume = {90}, - number = {7}, - pages = {075135}, - publisher = {{American Physical Society}}, - issn = {1098-0121}, - doi = {10.1103/PhysRevB.90.075135} -} - -@article{Borghi2015, - title = {Variational Minimization of Orbital-Density-Dependent Functionals}, - author = {Borghi, Giovanni and Park, Cheol Hwan and Nguyen, Ngoc Linh and Ferretti, Andrea and Marzari, Nicola}, - year = {2015}, - month = apr, - journal = {Physical Review B - Condensed Matter and Materials Physics}, - volume = {91}, - number = {15}, - pages = {155112}, - publisher = {{American Physical Society}}, - issn = {1550235X}, - doi = {10.1103/PhysRevB.91.155112} -} - -@article{Colonna2018, - title = {Screening in {{Orbital-Density-Dependent Functionals}}}, - author = {Colonna, Nicola and Nguyen, Ngoc Linh and Ferretti, Andrea and Marzari, Nicola}, - year = {2018}, - month = may, - journal = {Journal of Chemical Theory and Computation}, - volume = {14}, - number = {5}, - eprint = {1711.04485}, - eprinttype = {arxiv}, - pages = {2549--2557}, - publisher = {{American Chemical Society}}, - issn = {15499626}, - doi = {10.1021/acs.jctc.7b01116}, - archiveprefix = {arXiv} -} - -@article{Colonna2019, - title = {Koopmans-Compliant Functionals and Potentials and Their Application to the {{GW100}} Test Set}, - author = {Colonna, Nicola and Nguyen, Ngoc Linh and Ferretti, Andrea and Marzari, Nicola}, - year = {2019}, - month = mar, - journal = {Journal of Chemical Theory and Computation}, - volume = {15}, - number = {3}, - pages = {1905--1914}, - publisher = {{American Chemical Society}}, - issn = {1549-9618}, - doi = {10.1021/acs.jctc.8b00976} -} - -@article{Colonna2022, - title = {Koopmans Spectral Functionals in Periodic-Boundary Conditions}, - author = {Colonna, Nicola and De Gennaro, Riccardo and Linscott, Edward and Marzari, Nicola}, - year = {2022}, - month = feb, - journal = {arXiv:2202.08155 [cond-mat, physics:physics]}, - eprint = {2202.08155}, - eprinttype = {arxiv}, - primaryclass = {cond-mat, physics:physics}, - archiveprefix = {arXiv}, - keywords = {Condensed Matter - Materials Science,Physics - Computational Physics} -} - -@misc{Dabo2009, - title = {Non-{{Koopmans Corrections}} in {{Density-functional Theory}}: {{Self-interaction Revisited}}}, - author = {Dabo, I. and Cococcioni, M. and Marzari, N.}, - year = {2009}, - month = jan, - eprint = {0901.2637}, - eprinttype = {arxiv}, - archiveprefix = {arXiv} -} - -@article{Dabo2010, - title = {Koopmans' Condition for Density-Functional Theory}, - author = {Dabo, Ismaila and Ferretti, Andrea and Poilvert, Nicolas and Li, Yanli and Marzari, Nicola and Cococcioni, Matteo}, - year = {2010}, - month = sep, - journal = {Physical Review B}, - volume = {82}, - number = {11}, - pages = {115121}, - publisher = {{American Physical Society}}, - issn = {1098-0121}, - doi = {10.1103/PhysRevB.82.115121} -} - -@article{Dabo2013, - title = {Donor and Acceptor Levels of Organic Photovoltaic Compounds from First Principles}, - author = {Dabo, Ismaila and Ferretti, Andrea and Park, Cheol Hwan and Poilvert, Nicolas and Li, Yanli and Cococcioni, Matteo and Marzari, Nicola}, - year = {2013}, - month = jan, - journal = {Physical Chemistry Chemical Physics}, - volume = {15}, - number = {2}, - eprint = {1210.7973}, - eprinttype = {arxiv}, - pages = {685--695}, - issn = {14639076}, - doi = {10.1039/c2cp43491a}, - archiveprefix = {arXiv} -} - -@article{DeGennaro2022, - title = {Bloch's theorem in orbital-density-dependent functionals: Band structures from Koopmans spectral functionals}, - volume = {106}, - url = {https://link.aps.org/doi/10.1103/PhysRevB.106.035106}, - doi = {10.1103/PhysRevB.106.035106}, - shorttitle = {Bloch's theorem in orbital-density-dependent functionals}, - pages = {035106}, - number = {3}, - journal = {Physical Review B}, - author = {De Gennaro, Riccardo and Colonna, Nicola and Linscott, Edward and Marzari, Nicola}, - year = {2022}, - month = jul -} - -@article{Ferretti2014, - title = {Bridging Density-Functional and Many-Body Perturbation Theory: Orbital-Density Dependence in Electronic-Structure Functionals}, - author = {Ferretti, Andrea and Dabo, Ismaila and Cococcioni, Matteo and Marzari, Nicola}, - year = {2014}, - month = may, - journal = {Physical Review B}, - volume = {89}, - number = {19}, - pages = {195134}, - publisher = {{American Physical Society}}, - issn = {1098-0121}, - doi = {10.1103/PhysRevB.89.195134} -} - -@article{Hamann2013, - title = {Optimized Norm-Conserving {{Vanderbilt}} Pseudopotentials}, - author = {Hamann, D. R.}, - year = {2013}, - month = aug, - journal = {Physical Review B - Condensed Matter and Materials Physics}, - volume = {88}, - number = {8}, - pages = {085117}, - publisher = {{American Physical Society}}, - issn = {10980121}, - doi = {10.1103/PhysRevB.88.085117} -} - -@article{Lejaeghere2016, - title = {Reproducibility in Density Functional Theory Calculations of Solids}, - author = {Lejaeghere, Kurt and Bihlmayer, Gustav and Bj{\"o}rkman, Torbj{\"o}rn and Blaha, Peter and Bl{\"u}gel, Stefan and Blum, Volker and Caliste, Damien and Castelli, Ivano E. and Clark, Stewart J. and Dal Corso, Andrea and {de Gironcoli}, Stefano and Deutsch, Thierry and Dewhurst, John Kay and Di Marco, Igor and Draxl, Claudia and Du{\l}ak, Marcin and Eriksson, Olle and {Flores-Livas}, Jos{\'e} A. and Garrity, Kevin F. and Genovese, Luigi and Giannozzi, Paolo and Giantomassi, Matteo and Goedecker, Stefan and Gonze, Xavier and Gr{\aa}n{\"a}s, Oscar and Gross, E. K. U. and Gulans, Andris and Gygi, Fran{\c c}ois and Hamann, D. R. and Hasnip, Phil J. and Holzwarth, N. A. W. and Iu{\c s}an, Diana and Jochym, Dominik B. and Jollet, Fran{\c c}ois and Jones, Daniel and Kresse, Georg and Koepernik, Klaus and K{\"u}{\c c}{\"u}kbenli, Emine and Kvashnin, Yaroslav O. and Locht, Inka L. M. and Lubeck, Sven and Marsman, Martijn and Marzari, Nicola and Nitzsche, Ulrike and Nordstr{\"o}m, Lars and Ozaki, Taisuke and Paulatto, Lorenzo and Pickard, Chris J. and Poelmans, Ward and Probert, Matt I. J. and Refson, Keith and Richter, Manuel and Rignanese, Gian-Marco and Saha, Santanu and Scheffler, Matthias and Schlipf, Martin and Schwarz, Karlheinz and Sharma, Sangeeta and Tavazza, Francesca and Thunstr{\"o}m, Patrik and Tkatchenko, Alexandre and Torrent, Marc and Vanderbilt, David and {van Setten}, Michiel J. and Van Speybroeck, Veronique and Wills, John M. and Yates, Jonathan R. and Zhang, Guo-Xu and Cottenier, Stefaan}, - year = {2016}, - month = mar, - journal = {Science}, - volume = {351}, - number = {6280}, - pages = {aad3000}, - publisher = {{American Association for the Advancement of Science}}, - doi = {10.1126/science.aad3000} -} - -@article{Marzari2012, - title = {Maximally Localized {{Wannier}} Functions: {{Theory}} and Applications}, - author = {Marzari, Nicola and Mostofi, Arash A. and Yates, Jonathan R. and Souza, Ivo and Vanderbilt, David}, - year = {2012}, - month = oct, - journal = {Reviews of Modern Physics}, - volume = {84}, - number = {4}, - pages = {1419--1475}, - publisher = {{American Physical Society}}, - issn = {0034-6861}, - doi = {10.1103/RevModPhys.84.1419} -} - -@article{Nattino2019, - title = {Functional {{Extrapolations}} to {{Tame Unbound Anions}} in {{Density-Functional Theory Calculations}}}, - author = {Nattino, Francesco and Dupont, C{\'e}line and Marzari, Nicola and Andreussi, Oliviero}, - year = {2019}, - month = nov, - journal = {J. Chem. Theory Comput.}, - volume = {15}, - number = {11}, - eprint = {1906.00822}, - eprinttype = {arxiv}, - pages = {6313--6322}, - publisher = {{American Chemical Society}}, - issn = {15499626}, - doi = {10.1021/acs.jctc.9b00552}, - archiveprefix = {arXiv}, - pmid = {31580667} -} - -@article{Nguyen2016, - title = {First-{{Principles Photoemission Spectroscopy}} of {{DNA}} and {{RNA Nucleobases}} from {{Koopmans-Compliant Functionals}}}, - author = {Nguyen, Ngoc Linh and Borghi, Giovanni and Ferretti, Andrea and Marzari, Nicola}, - year = {2016}, - month = aug, - journal = {Journal of Chemical Theory and Computation}, - volume = {12}, - number = {8}, - pages = {3948--3958}, - publisher = {{American Chemical Society}}, - issn = {15499626}, - doi = {10.1021/acs.jctc.6b00145} -} - -@article{Nguyen2018, - title = {Koopmans-Compliant Spectral Functionals for Extended Systems}, - author = {Nguyen, Ngoc Linh and Colonna, Nicola and Ferretti, Andrea and Marzari, Nicola}, - year = {2018}, - month = may, - journal = {Physical Review X}, - volume = {8}, - number = {2}, - pages = {021051}, - publisher = {{American Physical Society}}, - issn = {2160-3308}, - doi = {10.1103/PhysRevX.8.021051} -} - -@article{Pederson1984, - title = {Local-density {{Hartree}}\textendash{{Fock}} Theory of Electronic States of Molecules with Self-interaction Correction}, - author = {Pederson, Mark R. and Heaton, Richard A. and Lin, Chun C.}, - year = {1984}, - month = mar, - journal = {The Journal of Chemical Physics}, - volume = {80}, - number = {5}, - pages = {1972--1975}, - publisher = {{American Institute of Physics}}, - issn = {0021-9606}, - doi = {10.1063/1.446959}, - keywords = {ELECTRONIC STRUCTURE,HARTREE−FOCK METHOD,MOLECULES,NITROGEN} -} - -@article{Prandini2018, - title = {Precision and Efficiency in Solid-State Pseudopotential Calculations}, - author = {Prandini, Gianluca and Marrazzo, Antimo and Castelli, Ivano E. and Mounet, Nicolas and Marzari, Nicola}, - year = {2018}, - month = dec, - journal = {npj Comput Mater}, - volume = {4}, - number = {1}, - pages = {1--13}, - publisher = {{Nature Publishing Group}}, - issn = {2057-3960}, - doi = {10.1038/s41524-018-0127-2}, - copyright = {2018 The Author(s)}, - langid = {english}, - keywords = {Computational methods,Electronic structure} -} - -@article{Scherpelz2016, - title = {Implementation and {{Validation}} of {{Fully Relativistic GW Calculations}}: {{Spin}}\textendash{{Orbit Coupling}} in {{Molecules}}, {{Nanocrystals}}, and {{Solids}}}, - shorttitle = {Implementation and {{Validation}} of {{Fully Relativistic GW Calculations}}}, - author = {Scherpelz, Peter and Govoni, Marco and Hamada, Ikutaro and Galli, Giulia}, - year = {2016}, - month = aug, - journal = {J. Chem. Theory Comput.}, - volume = {12}, - number = {8}, - pages = {3523--3544}, - publisher = {{American Chemical Society}}, - issn = {1549-9618}, - doi = {10.1021/acs.jctc.6b00114} -} - -@article{Schlipf2015, - title = {Optimization Algorithm for the Generation of {{ONCV}} Pseudopotentials}, - author = {Schlipf, Martin and Gygi, Fran{\c c}ois}, - year = {2015}, - month = nov, - journal = {Computer Physics Communications}, - volume = {196}, - pages = {36--44}, - issn = {0010-4655}, - doi = {10.1016/j.cpc.2015.05.011}, - keywords = {All-electron calculation,Condensed matter,Density functional theory,Plane wave,Pseudopotential} -} - -@article{vanSetten2018, - title = {The {{PseudoDojo}}: {{Training}} and Grading a 85 Element Optimized Norm-Conserving Pseudopotential Table}, - shorttitle = {The {{PseudoDojo}}}, - author = {{van Setten}, M. J. and Giantomassi, M. and Bousquet, E. and Verstraete, M. J. and Hamann, D. R. and Gonze, X. and Rignanese, G. -M.}, - year = {2018}, - month = may, - journal = {Computer Physics Communications}, - volume = {226}, - pages = {39--54}, - issn = {0010-4655}, - doi = {10.1016/j.cpc.2018.01.012}, - langid = {english}, - keywords = {Density functional theory,Electronic structure,First-principles calculation,Pseudopotential} -} - diff --git a/src/koopmans/__init__.py b/src/koopmans/__init__.py index 0e5a823bd..287e160b4 100644 --- a/src/koopmans/__init__.py +++ b/src/koopmans/__init__.py @@ -8,4 +8,3 @@ import importlib_metadata as metadata __version__ = metadata.version('koopmans') -base_directory = Path(__path__[0]).parents[1] diff --git a/src/koopmans/pseudopotentials.py b/src/koopmans/pseudopotentials.py index 556563e40..8dbe15602 100644 --- a/src/koopmans/pseudopotentials.py +++ b/src/koopmans/pseudopotentials.py @@ -33,7 +33,7 @@ class Pseudopotential: cutoff_rho: Optional[float] = None -pseudos_directory = Path(__file__).parents[2] / 'pseudos' +pseudos_directory = Path('pseudos') # A database containing all the available pseudopotentials pseudo_database: List[Pseudopotential] = [] @@ -78,7 +78,7 @@ class Pseudopotential: citations.append('vanSetten2018') pseudo_database.append(Pseudopotential(name, element, pseudo_file.parent, - functional, library, kind, citations, **kwargs)) + functional, library, kind, citations, **kwargs)) def pseudos_library_directory(pseudo_library: str, base_functional: str) -> Path: diff --git a/pseudos/generate_wfc_psps.py b/src/koopmans/pseudos/generate_wfc_psps.py similarity index 100% rename from pseudos/generate_wfc_psps.py rename to src/koopmans/pseudos/generate_wfc_psps.py diff --git a/pseudos/pseudo_dojo_standard b/src/koopmans/pseudos/pseudo_dojo_standard similarity index 100% rename from pseudos/pseudo_dojo_standard rename to src/koopmans/pseudos/pseudo_dojo_standard diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ag.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ag.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Ag.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ag.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Al.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Al.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Al.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Al.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ar.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ar.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Ar.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ar.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/As.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/As.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/As.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/As.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Au.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Au.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Au.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Au.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/B.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/B.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/B.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/B.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ba.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ba.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Ba.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ba.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Be.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Be.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Be.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Be.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Bi.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Bi.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Bi.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Bi.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Br.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Br.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Br.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Br.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/C.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/C.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/C.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/C.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ca.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ca.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Ca.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ca.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cd.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cd.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Cd.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cd.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cl.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cl.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Cl.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cl.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Co.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Co.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Co.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Co.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cr.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cr.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Cr.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cr.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cs.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cs.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Cs.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cs.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cu.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cu.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Cu.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cu.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/F.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/F.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/F.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/F.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Fe.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Fe.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Fe.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Fe.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ga.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ga.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Ga.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ga.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ge.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ge.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Ge.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ge.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/H.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/H.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/H.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/H.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/He.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/He.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/He.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/He.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Hf.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Hf.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Hf.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Hf.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Hg.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Hg.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Hg.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Hg.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/I.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/I.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/I.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/I.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/In.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/In.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/In.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/In.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ir.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ir.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Ir.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ir.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/K.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/K.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/K.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/K.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Kr.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Kr.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Kr.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Kr.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Li.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Li.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Li.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Li.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Mg.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Mg.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Mg.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Mg.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Mn.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Mn.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Mn.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Mn.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Mo.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Mo.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Mo.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Mo.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/N.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/N.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/N.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/N.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Na.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Na.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Na.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Na.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Nb.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Nb.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Nb.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Nb.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ne.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ne.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Ne.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ne.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ni.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ni.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Ni.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ni.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/O.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/O.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/O.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/O.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Os.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Os.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Os.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Os.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/P.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/P.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/P.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/P.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Pb.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Pb.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Pb.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Pb.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Pd.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Pd.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Pd.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Pd.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Po.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Po.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Po.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Po.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Pt.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Pt.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Pt.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Pt.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Rb.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Rb.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Rb.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Rb.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Re.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Re.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Re.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Re.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Rh.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Rh.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Rh.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Rh.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Rn.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Rn.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Rn.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Rn.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ru.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ru.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Ru.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ru.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/S.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/S.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/S.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/S.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sb.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sb.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Sb.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sb.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sc.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sc.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Sc.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sc.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Se.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Se.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Se.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Se.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Si.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Si.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Si.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Si.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sn.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sn.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Sn.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sn.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sr.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sr.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Sr.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sr.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ta.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ta.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Ta.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ta.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Tc.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Tc.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Tc.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Tc.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Te.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Te.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Te.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Te.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ti.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ti.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Ti.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ti.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Tl.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Tl.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Tl.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Tl.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/V.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/V.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/V.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/V.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/W.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/W.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/W.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/W.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Xe.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Xe.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Xe.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Xe.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Y.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Y.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Y.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Y.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Zn.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Zn.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Zn.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Zn.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/lda/Zr.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Zr.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/lda/Zr.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Zr.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ag.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ag.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ag.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ag.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Al.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Al.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Al.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Al.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ar.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ar.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ar.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ar.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/As.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/As.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/As.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/As.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Au.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Au.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Au.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Au.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/B.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/B.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/B.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/B.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ba.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ba.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ba.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ba.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Be.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Be.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Be.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Be.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Bi.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Bi.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Bi.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Bi.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Br.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Br.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Br.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Br.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/C.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/C.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/C.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/C.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ca.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ca.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ca.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ca.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cd.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cd.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cd.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cd.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cl.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cl.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cl.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cl.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Co.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Co.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Co.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Co.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cr.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cr.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cr.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cr.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cs.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cs.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cs.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cs.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cu.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cu.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cu.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cu.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/F.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/F.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/F.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/F.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Fe.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Fe.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Fe.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Fe.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ga.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ga.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ga.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ga.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ge.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ge.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ge.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ge.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/H.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/H.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/H.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/H.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/He.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/He.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/He.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/He.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Hf.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Hf.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Hf.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Hf.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Hg.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Hg.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Hg.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Hg.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/I.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/I.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/I.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/I.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/In.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/In.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/In.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/In.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ir.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ir.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ir.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ir.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/K.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/K.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/K.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/K.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Kr.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Kr.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Kr.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Kr.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/La.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/La.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/La.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/La.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Li.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Li.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Li.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Li.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Lu.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Lu.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Lu.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Lu.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mg.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mg.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mg.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mg.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mn.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mn.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mn.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mn.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mo.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mo.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mo.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mo.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/N.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/N.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/N.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/N.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Na.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Na.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Na.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Na.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Nb.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Nb.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Nb.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Nb.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ne.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ne.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ne.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ne.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ni.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ni.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ni.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ni.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/O.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/O.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/O.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/O.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Os.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Os.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Os.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Os.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/P.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/P.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/P.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/P.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pb.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pb.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pb.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pb.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pd.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pd.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pd.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pd.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Po.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Po.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Po.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Po.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pt.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pt.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pt.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pt.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rb.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rb.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rb.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rb.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Re.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Re.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Re.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Re.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rh.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rh.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rh.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rh.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rn.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rn.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rn.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rn.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ru.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ru.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ru.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ru.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/S.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/S.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/S.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/S.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sb.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sb.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sb.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sb.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sc.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sc.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sc.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sc.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Se.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Se.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Se.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Se.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Si.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Si.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Si.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Si.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sn.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sn.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sn.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sn.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sr.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sr.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sr.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sr.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ta.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ta.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ta.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ta.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Tc.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Tc.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Tc.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Tc.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Te.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Te.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Te.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Te.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ti.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ti.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ti.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ti.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Tl.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Tl.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Tl.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Tl.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/V.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/V.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/V.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/V.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/W.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/W.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/W.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/W.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Xe.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Xe.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Xe.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Xe.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Y.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Y.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Y.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Y.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Zn.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Zn.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Zn.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Zn.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Zr.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Zr.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbe/Zr.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Zr.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ag.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ag.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ag.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ag.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Al.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Al.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Al.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Al.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ar.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ar.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ar.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ar.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/As.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/As.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/As.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/As.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Au.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Au.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Au.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Au.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/B.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/B.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/B.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/B.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ba.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ba.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ba.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ba.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Be.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Be.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Be.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Be.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Bi.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Bi.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Bi.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Bi.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Br.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Br.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Br.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Br.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/C.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/C.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/C.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/C.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ca.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ca.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ca.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ca.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cd.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cd.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cd.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cd.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cl.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cl.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cl.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cl.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Co.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Co.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Co.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Co.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cr.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cr.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cr.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cr.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cs.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cs.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cs.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cs.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cu.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cu.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cu.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cu.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/F.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/F.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/F.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/F.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Fe.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Fe.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Fe.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Fe.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ga.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ga.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ga.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ga.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ge.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ge.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ge.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ge.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/H.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/H.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/H.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/H.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/He.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/He.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/He.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/He.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Hf.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Hf.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Hf.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Hf.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Hg.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Hg.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Hg.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Hg.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/I.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/I.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/I.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/I.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/In.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/In.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/In.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/In.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ir.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ir.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ir.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ir.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/K.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/K.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/K.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/K.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Kr.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Kr.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Kr.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Kr.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/La.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/La.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/La.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/La.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Li.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Li.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Li.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Li.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Lu.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Lu.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Lu.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Lu.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mg.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mg.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mg.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mg.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mn.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mn.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mn.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mn.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mo.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mo.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mo.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mo.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/N.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/N.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/N.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/N.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Na.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Na.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Na.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Na.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Nb.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Nb.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Nb.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Nb.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ne.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ne.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ne.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ne.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ni.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ni.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ni.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ni.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/O.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/O.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/O.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/O.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Os.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Os.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Os.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Os.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/P.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/P.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/P.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/P.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pb.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pb.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pb.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pb.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pd.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pd.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pd.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pd.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Po.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Po.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Po.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Po.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pt.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pt.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pt.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pt.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rb.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rb.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rb.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rb.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Re.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Re.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Re.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Re.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rh.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rh.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rh.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rh.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rn.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rn.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rn.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rn.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ru.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ru.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ru.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ru.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/S.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/S.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/S.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/S.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sb.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sb.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sb.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sb.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sc.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sc.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sc.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sc.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Se.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Se.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Se.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Se.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Si.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Si.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Si.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Si.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sn.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sn.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sn.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sn.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sr.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sr.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sr.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sr.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ta.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ta.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ta.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ta.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Tc.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Tc.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Tc.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Tc.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Te.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Te.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Te.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Te.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ti.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ti.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ti.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ti.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Tl.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Tl.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Tl.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Tl.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/V.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/V.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/V.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/V.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/W.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/W.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/W.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/W.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Xe.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Xe.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Xe.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Xe.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Y.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Y.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Y.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Y.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Zn.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Zn.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Zn.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Zn.upf diff --git a/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Zr.upf b/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Zr.upf similarity index 100% rename from pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Zr.upf rename to src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Zr.upf diff --git a/pseudos/pseudo_dojo_stringent b/src/koopmans/pseudos/pseudo_dojo_stringent similarity index 100% rename from pseudos/pseudo_dojo_stringent rename to src/koopmans/pseudos/pseudo_dojo_stringent diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ag.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ag.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ag.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ag.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Al.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Al.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Al.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Al.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ar.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ar.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ar.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ar.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/As.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/As.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/As.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/As.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Au.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Au.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Au.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Au.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/B.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/B.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/B.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/B.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ba.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ba.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ba.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ba.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Be.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Be.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Be.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Be.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Bi.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Bi.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Bi.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Bi.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Br.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Br.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Br.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Br.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/C.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/C.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/C.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/C.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ca.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ca.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ca.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ca.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cd.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cd.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cd.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cd.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cl.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cl.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cl.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cl.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Co.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Co.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Co.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Co.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cr.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cr.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cr.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cr.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cs.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cs.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cs.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cs.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cu.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cu.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cu.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cu.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/F.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/F.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/F.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/F.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Fe.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Fe.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Fe.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Fe.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ga.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ga.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ga.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ga.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ge.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ge.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ge.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ge.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/H.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/H.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/H.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/H.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/He.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/He.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/He.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/He.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Hf.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Hf.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Hf.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Hf.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Hg.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Hg.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Hg.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Hg.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/I.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/I.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/I.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/I.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/In.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/In.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/In.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/In.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ir.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ir.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ir.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ir.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/K.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/K.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/K.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/K.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Kr.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Kr.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Kr.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Kr.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Li.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Li.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Li.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Li.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mg.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mg.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mg.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mg.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mn.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mn.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mn.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mn.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mo.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mo.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mo.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mo.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/N.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/N.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/N.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/N.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Na.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Na.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Na.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Na.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Nb.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Nb.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Nb.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Nb.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ne.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ne.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ne.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ne.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ni.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ni.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ni.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ni.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/O.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/O.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/O.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/O.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Os.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Os.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Os.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Os.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/P.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/P.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/P.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/P.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pb.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pb.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pb.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pb.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pd.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pd.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pd.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pd.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Po.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Po.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Po.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Po.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pt.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pt.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pt.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pt.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rb.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rb.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rb.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rb.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Re.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Re.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Re.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Re.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rh.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rh.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rh.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rh.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rn.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rn.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rn.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rn.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ru.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ru.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ru.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ru.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/S.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/S.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/S.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/S.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sb.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sb.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sb.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sb.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sc.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sc.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sc.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sc.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Se.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Se.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Se.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Se.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Si.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Si.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Si.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Si.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sn.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sn.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sn.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sn.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sr.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sr.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sr.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sr.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ta.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ta.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ta.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ta.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Tc.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Tc.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Tc.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Tc.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Te.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Te.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Te.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Te.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ti.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ti.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ti.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ti.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Tl.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Tl.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Tl.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Tl.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/V.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/V.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/V.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/V.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/W.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/W.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/W.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/W.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Xe.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Xe.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Xe.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Xe.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Y.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Y.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Y.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Y.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Zn.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Zn.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Zn.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Zn.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Zr.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Zr.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/lda/Zr.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Zr.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ag.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ag.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ag.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ag.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Al.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Al.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Al.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Al.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ar.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ar.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ar.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ar.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/As.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/As.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/As.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/As.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Au.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Au.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Au.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Au.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/B.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/B.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/B.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/B.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ba.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ba.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ba.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ba.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Be.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Be.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Be.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Be.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Bi.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Bi.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Bi.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Bi.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Br.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Br.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Br.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Br.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/C.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/C.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/C.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/C.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ca.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ca.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ca.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ca.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cd.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cd.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cd.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cd.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cl.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cl.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cl.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cl.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Co.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Co.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Co.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Co.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cr.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cr.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cr.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cr.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cs.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cs.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cs.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cs.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cu.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cu.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cu.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cu.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/F.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/F.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/F.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/F.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Fe.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Fe.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Fe.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Fe.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ga.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ga.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ga.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ga.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ge.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ge.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ge.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ge.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/H.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/H.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/H.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/H.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/He.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/He.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/He.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/He.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Hf.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Hf.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Hf.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Hf.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Hg.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Hg.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Hg.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Hg.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/I.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/I.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/I.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/I.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/In.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/In.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/In.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/In.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ir.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ir.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ir.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ir.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/K.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/K.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/K.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/K.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Kr.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Kr.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Kr.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Kr.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/La.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/La.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/La.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/La.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Li.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Li.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Li.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Li.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Lu.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Lu.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Lu.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Lu.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mg.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mg.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mg.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mg.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mn.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mn.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mn.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mn.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mo.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mo.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mo.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mo.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/N.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/N.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/N.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/N.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Na.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Na.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Na.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Na.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Nb.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Nb.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Nb.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Nb.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ne.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ne.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ne.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ne.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ni.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ni.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ni.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ni.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/O.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/O.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/O.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/O.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Os.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Os.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Os.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Os.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/P.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/P.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/P.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/P.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pb.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pb.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pb.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pb.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pd.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pd.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pd.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pd.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Po.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Po.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Po.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Po.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pt.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pt.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pt.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pt.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rb.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rb.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rb.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rb.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Re.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Re.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Re.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Re.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rh.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rh.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rh.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rh.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rn.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rn.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rn.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rn.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ru.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ru.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ru.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ru.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/S.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/S.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/S.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/S.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sb.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sb.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sb.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sb.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sc.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sc.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sc.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sc.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Se.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Se.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Se.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Se.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Si.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Si.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Si.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Si.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sn.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sn.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sn.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sn.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sr.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sr.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sr.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sr.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ta.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ta.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ta.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ta.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Tc.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Tc.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Tc.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Tc.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Te.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Te.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Te.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Te.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ti.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ti.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ti.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ti.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Tl.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Tl.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Tl.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Tl.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/V.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/V.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/V.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/V.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/W.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/W.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/W.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/W.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Xe.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Xe.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Xe.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Xe.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Y.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Y.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Y.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Y.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Zn.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Zn.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Zn.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Zn.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Zr.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Zr.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Zr.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Zr.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ag.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ag.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ag.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ag.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Al.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Al.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Al.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Al.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ar.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ar.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ar.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ar.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/As.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/As.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/As.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/As.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Au.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Au.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Au.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Au.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/B.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/B.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/B.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/B.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ba.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ba.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ba.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ba.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Be.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Be.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Be.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Be.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Bi.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Bi.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Bi.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Bi.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Br.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Br.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Br.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Br.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/C.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/C.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/C.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/C.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ca.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ca.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ca.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ca.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cd.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cd.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cd.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cd.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cl.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cl.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cl.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cl.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Co.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Co.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Co.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Co.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cr.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cr.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cr.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cr.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cs.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cs.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cs.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cs.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cu.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cu.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cu.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cu.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/F.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/F.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/F.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/F.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Fe.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Fe.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Fe.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Fe.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ga.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ga.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ga.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ga.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ge.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ge.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ge.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ge.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/H.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/H.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/H.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/H.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/He.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/He.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/He.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/He.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Hf.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Hf.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Hf.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Hf.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Hg.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Hg.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Hg.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Hg.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/I.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/I.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/I.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/I.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/In.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/In.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/In.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/In.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ir.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ir.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ir.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ir.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/K.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/K.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/K.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/K.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Kr.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Kr.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Kr.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Kr.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/La.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/La.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/La.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/La.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Li.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Li.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Li.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Li.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Lu.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Lu.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Lu.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Lu.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mg.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mg.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mg.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mg.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mn.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mn.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mn.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mn.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mo.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mo.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mo.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mo.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/N.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/N.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/N.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/N.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Na.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Na.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Na.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Na.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Nb.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Nb.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Nb.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Nb.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ne.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ne.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ne.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ne.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ni.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ni.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ni.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ni.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/O.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/O.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/O.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/O.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Os.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Os.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Os.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Os.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/P.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/P.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/P.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/P.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pb.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pb.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pb.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pb.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pd.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pd.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pd.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pd.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Po.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Po.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Po.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Po.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pt.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pt.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pt.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pt.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rb.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rb.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rb.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rb.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Re.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Re.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Re.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Re.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rh.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rh.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rh.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rh.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rn.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rn.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rn.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rn.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ru.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ru.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ru.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ru.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/S.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/S.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/S.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/S.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sb.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sb.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sb.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sb.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sc.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sc.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sc.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sc.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Se.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Se.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Se.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Se.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Si.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Si.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Si.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Si.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sn.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sn.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sn.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sn.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sr.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sr.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sr.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sr.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ta.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ta.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ta.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ta.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Tc.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Tc.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Tc.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Tc.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Te.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Te.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Te.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Te.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ti.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ti.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ti.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ti.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Tl.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Tl.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Tl.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Tl.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/V.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/V.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/V.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/V.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/W.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/W.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/W.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/W.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Xe.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Xe.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Xe.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Xe.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Y.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Y.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Y.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Y.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Zn.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Zn.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Zn.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Zn.upf diff --git a/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Zr.upf b/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Zr.upf similarity index 100% rename from pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Zr.upf rename to src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Zr.upf diff --git a/pseudos/sg15 b/src/koopmans/pseudos/sg15 similarity index 100% rename from pseudos/sg15 rename to src/koopmans/pseudos/sg15 diff --git a/pseudos/sg15_relativistic b/src/koopmans/pseudos/sg15_relativistic similarity index 100% rename from pseudos/sg15_relativistic rename to src/koopmans/pseudos/sg15_relativistic diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Ag_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ag_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Ag_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ag_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Al_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Al_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Al_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Al_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Ar_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ar_ONCV_PBE_FR-1.1.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Ar_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ar_ONCV_PBE_FR-1.1.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/As_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/As_ONCV_PBE_FR-1.1.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/As_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/As_ONCV_PBE_FR-1.1.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Au_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Au_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Au_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Au_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/B_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/B_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/B_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/B_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Br_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Br_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Br_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Br_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/C_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/C_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/C_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/C_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Ca_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ca_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Ca_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ca_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Cd_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cd_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Cd_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cd_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Cl_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cl_ONCV_PBE_FR-1.1.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Cl_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cl_ONCV_PBE_FR-1.1.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Co_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Co_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Co_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Co_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Cr_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cr_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Cr_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cr_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Cs_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cs_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Cs_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cs_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Cu_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cu_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Cu_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cu_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/F_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/F_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/F_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/F_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Fe_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Fe_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Fe_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Fe_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Ga_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ga_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Ga_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ga_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Ge_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ge_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Ge_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ge_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/H_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/H_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/H_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/H_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/He_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/He_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/He_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/He_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Hf_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Hf_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Hf_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Hf_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Hg_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Hg_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Hg_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Hg_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/I_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/I_ONCV_PBE_FR-1.1.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/I_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/I_ONCV_PBE_FR-1.1.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/In_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/In_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/In_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/In_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Ir_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ir_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Ir_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ir_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/K_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/K_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/K_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/K_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Kr_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Kr_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Kr_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Kr_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/La_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/La_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/La_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/La_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Mg_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Mg_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Mg_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Mg_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Mn_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Mn_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Mn_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Mn_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Mo_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Mo_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Mo_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Mo_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/N_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/N_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/N_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/N_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Na_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Na_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Na_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Na_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Nb_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Nb_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Nb_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Nb_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Ni_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ni_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Ni_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ni_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/O_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/O_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/O_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/O_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Os_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Os_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Os_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Os_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/P_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/P_ONCV_PBE_FR-1.1.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/P_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/P_ONCV_PBE_FR-1.1.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Pb_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Pb_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Pb_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Pb_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Pd_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Pd_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Pd_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Pd_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Pt_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Pt_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Pt_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Pt_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Rb_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Rb_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Rb_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Rb_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Re_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Re_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Re_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Re_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Rh_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Rh_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Rh_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Rh_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Ru_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ru_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Ru_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ru_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/S_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/S_ONCV_PBE_FR-1.1.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/S_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/S_ONCV_PBE_FR-1.1.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Sb_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sb_ONCV_PBE_FR-1.1.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Sb_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sb_ONCV_PBE_FR-1.1.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Sc_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sc_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Sc_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sc_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Se_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Se_ONCV_PBE_FR-1.1.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Se_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Se_ONCV_PBE_FR-1.1.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Si_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Si_ONCV_PBE_FR-1.1.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Si_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Si_ONCV_PBE_FR-1.1.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Sn_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sn_ONCV_PBE_FR-1.1.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Sn_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sn_ONCV_PBE_FR-1.1.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Sr_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sr_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Sr_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sr_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Ta_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ta_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Ta_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ta_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Tc_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Tc_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Tc_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Tc_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Te_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Te_ONCV_PBE_FR-1.1.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Te_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Te_ONCV_PBE_FR-1.1.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Ti_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ti_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Ti_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ti_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Tl_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Tl_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Tl_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Tl_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/V_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/V_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/V_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/V_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/W_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/W_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/W_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/W_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Xe_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Xe_ONCV_PBE_FR-1.1.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Xe_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Xe_ONCV_PBE_FR-1.1.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Y_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Y_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Y_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Y_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Zn_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Zn_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Zn_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Zn_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_relativistic_v1.0/pbe/Zr_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Zr_ONCV_PBE_FR-1.0.upf similarity index 100% rename from pseudos/sg15_relativistic_v1.0/pbe/Zr_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Zr_ONCV_PBE_FR-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Ag_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Ag_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Ag_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Ag_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Al_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Al_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Al_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Al_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Ar_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Ar_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Ar_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Ar_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/As_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/As_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/As_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/As_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Au_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Au_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Au_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Au_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/B_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/B_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/B_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/B_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Ba_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Ba_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Ba_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Ba_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Be_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Be_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Be_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Be_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Bi_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Bi_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Bi_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Bi_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Br_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Br_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Br_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Br_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/C_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/C_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/C_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/C_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Ca_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Ca_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Ca_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Ca_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Cd_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Cd_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Cd_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Cd_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Cl_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Cl_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Cl_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Cl_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Co_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Co_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Co_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Co_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Cr_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Cr_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Cr_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Cr_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Cs_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Cs_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Cs_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Cs_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Cu_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Cu_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Cu_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Cu_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/F_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/F_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/F_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/F_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Fe_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Fe_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Fe_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Fe_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Ga_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Ga_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Ga_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Ga_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Ge_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Ge_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Ge_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Ge_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/H_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/H_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/H_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/H_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/He_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/He_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/He_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/He_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Hf_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Hf_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Hf_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Hf_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Hg_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Hg_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Hg_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Hg_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/I_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/I_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/I_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/I_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/In_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/In_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/In_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/In_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Ir_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Ir_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Ir_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Ir_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/K_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/K_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/K_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/K_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Kr_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Kr_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Kr_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Kr_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/La_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/La_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/La_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/La_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Li_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Li_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Li_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Li_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Mg_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Mg_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Mg_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Mg_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Mn_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Mn_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Mn_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Mn_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Mo_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Mo_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Mo_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Mo_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/N_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/N_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/N_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/N_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Na_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Na_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Na_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Na_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Nb_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Nb_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Nb_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Nb_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Ne_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Ne_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Ne_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Ne_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Ni_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Ni_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Ni_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Ni_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/O_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/O_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/O_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/O_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Os_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Os_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Os_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Os_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/P_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/P_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/P_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/P_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Pb_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Pb_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Pb_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Pb_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Pd_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Pd_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Pd_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Pd_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Pt_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Pt_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Pt_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Pt_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Rb_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Rb_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Rb_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Rb_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Re_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Re_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Re_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Re_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Rh_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Rh_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Rh_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Rh_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Ru_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Ru_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Ru_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Ru_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/S_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/S_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/S_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/S_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Sb_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Sb_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Sb_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Sb_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Sc_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Sc_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Sc_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Sc_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Se_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Se_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Se_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Se_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Si_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Si_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Si_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Si_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Sn_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Sn_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Sn_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Sn_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Sr_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Sr_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Sr_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Sr_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Ta_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Ta_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Ta_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Ta_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Tc_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Tc_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Tc_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Tc_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Te_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Te_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Te_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Te_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Ti_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Ti_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Ti_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Ti_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Tl_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Tl_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Tl_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Tl_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/V_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/V_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/V_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/V_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/W_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/W_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/W_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/W_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Xe_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Xe_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Xe_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Xe_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Y_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Y_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Y_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Y_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Zn_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Zn_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Zn_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Zn_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.0/pbe/Zr_ONCV_PBE-1.0.upf b/src/koopmans/pseudos/sg15_v1.0/pbe/Zr_ONCV_PBE-1.0.upf similarity index 100% rename from pseudos/sg15_v1.0/pbe/Zr_ONCV_PBE-1.0.upf rename to src/koopmans/pseudos/sg15_v1.0/pbe/Zr_ONCV_PBE-1.0.upf diff --git a/pseudos/sg15_v1.2/pbe/Ag_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Ag_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Ag_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Ag_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Al_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Al_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Al_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Al_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Ar_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Ar_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Ar_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Ar_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/As_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/As_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/As_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/As_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Au_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Au_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Au_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Au_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/B_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/B_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/B_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/B_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Ba_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Ba_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Ba_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Ba_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Be_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Be_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Be_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Be_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Bi_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Bi_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Bi_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Bi_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Br_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Br_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Br_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Br_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/C_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/C_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/C_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/C_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Ca_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Ca_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Ca_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Ca_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Cd_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Cd_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Cd_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Cd_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Cl_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Cl_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Cl_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Cl_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Co_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Co_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Co_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Co_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Cr_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Cr_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Cr_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Cr_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Cs_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Cs_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Cs_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Cs_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Cu_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Cu_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Cu_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Cu_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/F_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/F_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/F_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/F_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Fe_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Fe_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Fe_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Fe_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Ga_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Ga_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Ga_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Ga_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Ge_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Ge_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Ge_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Ge_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/H_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/H_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/H_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/H_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/He_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/He_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/He_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/He_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Hf_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Hf_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Hf_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Hf_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Hg_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Hg_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Hg_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Hg_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/I_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/I_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/I_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/I_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/In_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/In_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/In_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/In_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Ir_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Ir_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Ir_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Ir_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/K_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/K_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/K_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/K_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Kr_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Kr_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Kr_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Kr_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/La_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/La_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/La_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/La_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Li_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Li_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Li_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Li_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Mg_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Mg_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Mg_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Mg_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Mn_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Mn_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Mn_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Mn_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Mo_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Mo_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Mo_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Mo_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/N_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/N_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/N_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/N_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Na_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Na_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Na_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Na_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Nb_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Nb_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Nb_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Nb_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Ne_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Ne_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Ne_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Ne_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Ni_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Ni_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Ni_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Ni_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/O_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/O_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/O_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/O_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Os_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Os_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Os_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Os_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/P_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/P_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/P_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/P_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Pb_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Pb_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Pb_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Pb_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Pd_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Pd_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Pd_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Pd_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Pt_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Pt_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Pt_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Pt_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Rb_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Rb_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Rb_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Rb_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Re_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Re_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Re_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Re_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Rh_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Rh_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Rh_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Rh_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Ru_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Ru_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Ru_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Ru_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/S_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/S_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/S_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/S_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Sb_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Sb_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Sb_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Sb_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Sc_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Sc_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Sc_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Sc_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Se_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Se_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Se_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Se_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Sn_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Sn_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Sn_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Sn_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Sr_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Sr_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Sr_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Sr_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Ta_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Ta_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Ta_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Ta_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Tc_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Tc_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Tc_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Tc_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Te_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Te_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Te_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Te_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Ti_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Ti_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Ti_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Ti_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Tl_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Tl_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Tl_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Tl_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/V_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/V_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/V_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/V_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/W_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/W_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/W_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/W_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Xe_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Xe_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Xe_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Xe_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Y_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Y_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Y_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Y_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Zn_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Zn_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Zn_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Zn_ONCV_PBE-1.2.upf diff --git a/pseudos/sg15_v1.2/pbe/Zr_ONCV_PBE-1.2.upf b/src/koopmans/pseudos/sg15_v1.2/pbe/Zr_ONCV_PBE-1.2.upf similarity index 100% rename from pseudos/sg15_v1.2/pbe/Zr_ONCV_PBE-1.2.upf rename to src/koopmans/pseudos/sg15_v1.2/pbe/Zr_ONCV_PBE-1.2.upf diff --git a/src/koopmans/references.py b/src/koopmans/references.py index fb7fd32e5..d1e354d15 100644 --- a/src/koopmans/references.py +++ b/src/koopmans/references.py @@ -9,5 +9,5 @@ from pybtex.database.input import bibtex parser = bibtex.Parser() -bib_file = Path(__file__).parents[2] / 'docs/refs.bib' +bib_file = 'references.bib' bib_data = parser.parse_file(bib_file) diff --git a/tests/calculators/test_ph.py b/tests/calculators/test_ph.py index 880af261a..4fdd4feb9 100644 --- a/tests/calculators/test_ph.py +++ b/tests/calculators/test_ph.py @@ -3,7 +3,7 @@ import numpy as np import pytest -from koopmans import base_directory, utils, workflows +from koopmans import utils, workflows from koopmans.io import read_kwf as read_encoded_json from koopmans.io import write_kwf as write_encoded_json from tests import patches diff --git a/tests/calculators/test_projwfc.py b/tests/calculators/test_projwfc.py index 7ae7bb64a..fbfe868ab 100644 --- a/tests/calculators/test_projwfc.py +++ b/tests/calculators/test_projwfc.py @@ -2,7 +2,8 @@ import pytest -from koopmans import base_directory, utils, workflows +from pathlib import Path +from koopmans import __path__ as koopmans_src, utils, workflows from koopmans.io import read_kwf as read_encoded_json from koopmans.io import write_kwf as write_encoded_json from tests import patches @@ -16,7 +17,7 @@ def test_generate_dos(silicon, tmp_path, datadir, pytestconfig): name='si', **silicon) calc = wf.new_calculator('projwfc') - calc.pseudo_dir = base_directory / 'pseudos' / 'pseudo_dojo_standard' / 'pbesol' + calc.pseudo_dir = Path(koopmans_src[0]) / 'pseudos' / 'pseudo_dojo_standard' / 'pbesol' # Copy over pdos files for f in (datadir / 'projwfc').glob('*.pdos*'): diff --git a/tests/patches/_check.py b/tests/patches/_check.py index c5c4cc8f9..d3c5dc0e1 100644 --- a/tests/patches/_check.py +++ b/tests/patches/_check.py @@ -121,8 +121,8 @@ class CheckCalc: @property def _calcname(self) -> Path: - calcname: Path = (self.directory / self.prefix).relative_to(base_directory # type: ignore[attr-defined] - / 'tests' / 'tmp') + # type: ignore[attr-defined] + calcname: Path = (self.directory / self.prefix).relative_to(__path__ + '../../tests/tmp') return calcname.relative_to(calcname.parts[0]) def _check_results(self, benchmark: Calc): diff --git a/tests/patches/_utils.py b/tests/patches/_utils.py index ab825c673..2f0134936 100644 --- a/tests/patches/_utils.py +++ b/tests/patches/_utils.py @@ -2,10 +2,11 @@ from pathlib import Path from typing import Set, Tuple -from koopmans import base_directory, calculators +from koopmans import calculators def benchmark_filename(calc: calculators.CalculatorExt) -> Path: + base_directory = Path(__path__).parents[2] benchmark_dir = base_directory / 'tests' / 'benchmarks' if base_directory / 'tests' / 'tmp' in calc.directory.parents: parent = base_directory / 'tests' / 'tmp' diff --git a/tests/tutorials/test_tutorial_1.py b/tests/tutorials/test_tutorial_1.py index 0c96e29f5..d2bbda025 100644 --- a/tests/tutorials/test_tutorial_1.py +++ b/tests/tutorials/test_tutorial_1.py @@ -1,10 +1,9 @@ import pytest -from koopmans import base_directory -from koopmans.io import read +from pathlib import Path from koopmans.utils import chdir -tutorial_dir = base_directory / 'tutorials' / 'tutorial_1' +tutorial_dir = Path(__path__[0]).parents[2] / 'tutorials' / 'tutorial_1' @pytest.mark.tutorials diff --git a/tests/tutorials/test_tutorial_2.py b/tests/tutorials/test_tutorial_2.py index 90fe25141..a9d04a992 100644 --- a/tests/tutorials/test_tutorial_2.py +++ b/tests/tutorials/test_tutorial_2.py @@ -1,10 +1,10 @@ import pytest -from koopmans import base_directory from koopmans.io import read from koopmans.utils import chdir +from pathlib import Path -tutorial_dir = base_directory / 'tutorials' / 'tutorial_2' +tutorial_dir = Path(__path__[0]).parents[2] / 'tutorials' / 'tutorial_2' @pytest.mark.tutorials diff --git a/tests/tutorials/test_tutorial_3.py b/tests/tutorials/test_tutorial_3.py index 2295cbc8d..79f86844f 100644 --- a/tests/tutorials/test_tutorial_3.py +++ b/tests/tutorials/test_tutorial_3.py @@ -1,12 +1,12 @@ import shutil import pytest +from pathlib import Path -from koopmans import base_directory -from koopmans.io import read, write_json +from koopmans.io import read from koopmans.utils import chdir -tutorial_dir = base_directory / 'tutorials' / 'tutorial_3' +tutorial_dir = Path(__path__[0]).parents[2] / 'tutorials' / 'tutorial_3' @pytest.mark.tutorials diff --git a/tests/tutorials/test_tutorial_4.py b/tests/tutorials/test_tutorial_4.py index 7f4267202..c94dc42a3 100644 --- a/tests/tutorials/test_tutorial_4.py +++ b/tests/tutorials/test_tutorial_4.py @@ -2,11 +2,10 @@ import pytest -from koopmans import base_directory from koopmans.io import read from koopmans.utils import chdir -tutorial_dir = base_directory / 'tutorials' / 'tutorial_4' +tutorial_dir = Path(__path__[0]).parents[2] / 'tutorials' / 'tutorial_4' @pytest.mark.tutorials From d2da03320f0e492678d3c28bb0f760dba3e89f35 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 21:54:31 +0200 Subject: [PATCH 36/49] Tweaks associated with moving bib and pseudos --- README.rst | 2 +- docs/conf.py | 2 +- src/koopmans/pseudopotentials.py | 2 +- src/koopmans/{pseudos => pseudopotentials}/generate_wfc_psps.py | 0 src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ag.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Al.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ar.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/As.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Au.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/B.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ba.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Be.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Bi.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Br.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/C.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ca.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Cd.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Cl.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Co.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Cr.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Cs.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Cu.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/F.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Fe.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ga.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ge.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/H.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/He.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Hf.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Hg.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/I.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/In.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ir.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/K.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Kr.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Li.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Mg.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Mn.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Mo.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/N.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Na.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Nb.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ne.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ni.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/O.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Os.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/P.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Pb.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Pd.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Po.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Pt.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Rb.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Re.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Rh.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Rn.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ru.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/S.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Sb.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Sc.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Se.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Si.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Sn.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Sr.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ta.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Tc.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Te.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Ti.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Tl.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/V.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/W.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Xe.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Y.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Zn.upf | 0 .../pseudo_dojo_standard_v0.4.1/lda/Zr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ag.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Al.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ar.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/As.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Au.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/B.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ba.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Be.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Bi.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Br.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/C.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ca.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Cd.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Cl.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Co.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Cr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Cs.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Cu.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/F.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Fe.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ga.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ge.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/H.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/He.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Hf.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Hg.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/I.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/In.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ir.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/K.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Kr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/La.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Li.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Lu.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Mg.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Mn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Mo.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/N.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Na.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Nb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ne.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ni.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/O.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Os.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/P.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Pb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Pd.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Po.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Pt.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Rb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Re.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Rh.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Rn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ru.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/S.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Sb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Sc.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Se.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Si.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Sn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Sr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ta.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Tc.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Te.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Ti.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Tl.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/V.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/W.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Xe.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Y.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Zn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbe/Zr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ag.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Al.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ar.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/As.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Au.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/B.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ba.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Be.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Bi.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Br.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/C.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ca.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Cd.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Cl.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Co.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Cr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Cs.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Cu.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/F.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Fe.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ga.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ge.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/H.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/He.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Hf.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Hg.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/I.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/In.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ir.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/K.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Kr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/La.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Li.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Lu.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Mg.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Mn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Mo.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/N.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Na.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Nb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ne.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ni.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/O.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Os.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/P.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Pb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Pd.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Po.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Pt.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Rb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Re.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Rh.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Rn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ru.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/S.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Sb.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Sc.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Se.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Si.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Sn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Sr.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ta.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Tc.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Te.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Ti.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Tl.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/V.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/W.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Xe.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Y.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Zn.upf | 0 .../pseudo_dojo_standard_v0.4.1/pbesol/Zr.upf | 0 .../{pseudos => pseudopotentials}/pseudo_dojo_stringent | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ag.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Al.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ar.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/As.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Au.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/B.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ba.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Be.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Bi.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Br.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/C.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ca.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Cd.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Cl.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Co.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Cr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Cs.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Cu.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/F.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Fe.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ga.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ge.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/H.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/He.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Hf.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Hg.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/I.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/In.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ir.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/K.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Kr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Li.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Mg.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Mn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Mo.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/N.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Na.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Nb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ne.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ni.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/O.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Os.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/P.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Pb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Pd.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Po.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Pt.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Rb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Re.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Rh.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Rn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ru.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/S.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Sb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Sc.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Se.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Si.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Sn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Sr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ta.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Tc.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Te.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Ti.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Tl.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/V.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/W.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Xe.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Y.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Zn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/lda/Zr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ag.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Al.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ar.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/As.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Au.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/B.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ba.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Be.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Bi.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Br.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/C.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ca.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Cd.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Cl.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Co.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Cr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Cs.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Cu.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/F.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Fe.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ga.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ge.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/H.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/He.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Hf.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Hg.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/I.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/In.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ir.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/K.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Kr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/La.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Li.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Lu.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Mg.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Mn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Mo.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/N.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Na.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Nb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ne.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ni.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/O.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Os.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/P.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Pb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Pd.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Po.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Pt.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Rb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Re.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Rh.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Rn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ru.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/S.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Sb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Sc.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Se.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Si.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Sn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Sr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ta.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Tc.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Te.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Ti.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Tl.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/V.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/W.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Xe.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Y.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Zn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbe/Zr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Ag.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Al.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Ar.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/As.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Au.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/B.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Ba.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Be.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Bi.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Br.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/C.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Ca.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Cd.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Cl.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Co.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Cr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Cs.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Cu.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/F.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Fe.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Ga.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Ge.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/H.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/He.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Hf.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Hg.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/I.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/In.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Ir.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/K.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Kr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/La.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Li.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Lu.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Mg.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Mn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Mo.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/N.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Na.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Nb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Ne.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Ni.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/O.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Os.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/P.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Pb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Pd.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Po.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Pt.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Rb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Re.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Rh.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Rn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Ru.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/S.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Sb.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Sc.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Se.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Si.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Sn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Sr.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Ta.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Tc.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Te.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Ti.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Tl.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/V.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/W.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Xe.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Y.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Zn.upf | 0 .../pseudo_dojo_stringent_v0.4.1/pbesol/Zr.upf | 0 src/koopmans/{pseudos => pseudopotentials}/sg15 | 0 src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic | 0 .../sg15_relativistic_v1.0/pbe/Ag_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Al_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Ar_ONCV_PBE_FR-1.1.upf | 0 .../sg15_relativistic_v1.0/pbe/As_ONCV_PBE_FR-1.1.upf | 0 .../sg15_relativistic_v1.0/pbe/Au_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/B_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Br_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/C_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Ca_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Cd_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Cl_ONCV_PBE_FR-1.1.upf | 0 .../sg15_relativistic_v1.0/pbe/Co_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Cr_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Cs_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Cu_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/F_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Fe_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Ga_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Ge_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/H_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/He_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Hf_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Hg_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/I_ONCV_PBE_FR-1.1.upf | 0 .../sg15_relativistic_v1.0/pbe/In_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Ir_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/K_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Kr_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/La_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Mg_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Mn_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Mo_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/N_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Na_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Nb_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Ni_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/O_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Os_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/P_ONCV_PBE_FR-1.1.upf | 0 .../sg15_relativistic_v1.0/pbe/Pb_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Pd_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Pt_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Rb_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Re_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Rh_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Ru_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/S_ONCV_PBE_FR-1.1.upf | 0 .../sg15_relativistic_v1.0/pbe/Sb_ONCV_PBE_FR-1.1.upf | 0 .../sg15_relativistic_v1.0/pbe/Sc_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Se_ONCV_PBE_FR-1.1.upf | 0 .../sg15_relativistic_v1.0/pbe/Si_ONCV_PBE_FR-1.1.upf | 0 .../sg15_relativistic_v1.0/pbe/Sn_ONCV_PBE_FR-1.1.upf | 0 .../sg15_relativistic_v1.0/pbe/Sr_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Ta_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Tc_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Te_ONCV_PBE_FR-1.1.upf | 0 .../sg15_relativistic_v1.0/pbe/Ti_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Tl_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/V_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/W_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Xe_ONCV_PBE_FR-1.1.upf | 0 .../sg15_relativistic_v1.0/pbe/Y_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Zn_ONCV_PBE_FR-1.0.upf | 0 .../sg15_relativistic_v1.0/pbe/Zr_ONCV_PBE_FR-1.0.upf | 0 .../sg15_v1.0/pbe/Ag_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Al_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ar_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/As_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Au_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/B_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ba_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Be_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Bi_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Br_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/C_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ca_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Cd_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Cl_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Co_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Cr_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Cs_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Cu_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/F_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Fe_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ga_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ge_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/H_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/He_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Hf_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Hg_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/I_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/In_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ir_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/K_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Kr_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/La_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Li_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Mg_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Mn_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Mo_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/N_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Na_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Nb_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ne_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ni_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/O_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Os_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/P_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Pb_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Pd_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Pt_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Rb_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Re_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Rh_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ru_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/S_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Sb_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Sc_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Se_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Si_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Sn_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Sr_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ta_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Tc_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Te_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Ti_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Tl_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/V_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/W_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Xe_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Y_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Zn_ONCV_PBE-1.0.upf | 0 .../sg15_v1.0/pbe/Zr_ONCV_PBE-1.0.upf | 0 .../sg15_v1.2/pbe/Ag_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Al_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ar_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/As_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Au_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/B_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ba_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Be_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Bi_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Br_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/C_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ca_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Cd_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Cl_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Co_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Cr_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Cs_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Cu_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/F_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Fe_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ga_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ge_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/H_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/He_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Hf_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Hg_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/I_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/In_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ir_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/K_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Kr_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/La_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Li_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Mg_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Mn_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Mo_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/N_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Na_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Nb_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ne_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ni_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/O_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Os_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/P_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Pb_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Pd_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Pt_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Rb_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Re_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Rh_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ru_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/S_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Sb_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Sc_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Se_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Sn_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Sr_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ta_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Tc_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Te_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Ti_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Tl_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/V_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/W_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Xe_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Y_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Zn_ONCV_PBE-1.2.upf | 0 .../sg15_v1.2/pbe/Zr_ONCV_PBE-1.2.upf | 0 638 files changed, 3 insertions(+), 3 deletions(-) rename src/koopmans/{pseudos => pseudopotentials}/generate_wfc_psps.py (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Ag.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Al.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Ar.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/As.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Au.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/B.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Ba.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Be.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Bi.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Br.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/C.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Ca.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Cd.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Cl.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Co.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Cr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Cs.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Cu.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/F.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Fe.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Ga.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Ge.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/H.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/He.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Hf.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Hg.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/I.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/In.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Ir.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/K.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Kr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Li.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Mg.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Mn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Mo.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/N.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Na.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Nb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Ne.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Ni.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/O.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Os.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/P.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Pb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Pd.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Po.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Pt.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Rb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Re.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Rh.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Rn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Ru.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/S.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Sb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Sc.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Se.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Si.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Sn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Sr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Ta.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Tc.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Te.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Ti.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Tl.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/V.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/W.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Xe.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Y.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Zn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/lda/Zr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Ag.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Al.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Ar.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/As.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Au.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/B.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Ba.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Be.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Bi.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Br.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/C.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Ca.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Cd.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Cl.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Co.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Cr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Cs.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Cu.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/F.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Fe.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Ga.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Ge.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/H.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/He.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Hf.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Hg.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/I.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/In.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Ir.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/K.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Kr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/La.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Li.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Lu.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Mg.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Mn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Mo.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/N.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Na.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Nb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Ne.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Ni.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/O.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Os.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/P.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Pb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Pd.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Po.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Pt.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Rb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Re.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Rh.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Rn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Ru.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/S.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Sb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Sc.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Se.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Si.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Sn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Sr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Ta.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Tc.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Te.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Ti.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Tl.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/V.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/W.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Xe.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Y.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Zn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbe/Zr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Ag.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Al.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Ar.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/As.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Au.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/B.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Ba.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Be.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Bi.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Br.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/C.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Ca.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Cd.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Cl.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Co.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Cr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Cs.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Cu.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/F.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Fe.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Ga.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Ge.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/H.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/He.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Hf.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Hg.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/I.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/In.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Ir.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/K.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Kr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/La.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Li.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Lu.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Mg.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Mn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Mo.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/N.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Na.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Nb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Ne.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Ni.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/O.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Os.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/P.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Pb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Pd.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Po.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Pt.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Rb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Re.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Rh.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Rn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Ru.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/S.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Sb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Sc.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Se.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Si.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Sn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Sr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Ta.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Tc.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Te.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Ti.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Tl.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/V.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/W.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Xe.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Y.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Zn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_standard_v0.4.1/pbesol/Zr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Ag.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Al.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Ar.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/As.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Au.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/B.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Ba.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Be.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Bi.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Br.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/C.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Ca.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Cd.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Cl.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Co.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Cr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Cs.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Cu.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/F.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Fe.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Ga.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Ge.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/H.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/He.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Hf.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Hg.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/I.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/In.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Ir.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/K.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Kr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Li.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Mg.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Mn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Mo.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/N.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Na.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Nb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Ne.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Ni.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/O.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Os.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/P.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Pb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Pd.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Po.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Pt.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Rb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Re.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Rh.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Rn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Ru.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/S.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Sb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Sc.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Se.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Si.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Sn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Sr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Ta.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Tc.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Te.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Ti.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Tl.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/V.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/W.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Xe.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Y.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Zn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/lda/Zr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Ag.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Al.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Ar.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/As.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Au.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/B.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Ba.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Be.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Bi.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Br.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/C.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Ca.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Cd.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Cl.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Co.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Cr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Cs.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Cu.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/F.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Fe.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Ga.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Ge.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/H.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/He.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Hf.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Hg.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/I.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/In.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Ir.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/K.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Kr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/La.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Li.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Lu.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Mg.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Mn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Mo.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/N.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Na.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Nb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Ne.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Ni.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/O.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Os.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/P.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Pb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Pd.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Po.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Pt.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Rb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Re.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Rh.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Rn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Ru.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/S.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Sb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Sc.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Se.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Si.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Sn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Sr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Ta.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Tc.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Te.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Ti.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Tl.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/V.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/W.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Xe.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Y.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Zn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbe/Zr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Ag.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Al.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Ar.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/As.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Au.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/B.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Ba.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Be.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Bi.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Br.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/C.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Ca.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Cd.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Cl.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Co.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Cr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Cs.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Cu.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/F.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Fe.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Ga.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Ge.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/H.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/He.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Hf.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Hg.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/I.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/In.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Ir.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/K.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Kr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/La.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Li.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Lu.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Mg.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Mn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Mo.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/N.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Na.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Nb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Ne.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Ni.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/O.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Os.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/P.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Pb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Pd.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Po.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Pt.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Rb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Re.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Rh.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Rn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Ru.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/S.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Sb.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Sc.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Se.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Si.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Sn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Sr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Ta.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Tc.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Te.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Ti.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Tl.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/V.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/W.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Xe.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Y.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Zn.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/pseudo_dojo_stringent_v0.4.1/pbesol/Zr.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15 (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Ag_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Al_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Ar_ONCV_PBE_FR-1.1.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/As_ONCV_PBE_FR-1.1.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Au_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/B_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Br_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/C_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Ca_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Cd_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Cl_ONCV_PBE_FR-1.1.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Co_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Cr_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Cs_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Cu_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/F_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Fe_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Ga_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Ge_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/H_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/He_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Hf_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Hg_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/I_ONCV_PBE_FR-1.1.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/In_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Ir_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/K_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Kr_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/La_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Mg_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Mn_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Mo_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/N_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Na_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Nb_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Ni_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/O_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Os_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/P_ONCV_PBE_FR-1.1.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Pb_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Pd_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Pt_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Rb_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Re_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Rh_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Ru_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/S_ONCV_PBE_FR-1.1.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Sb_ONCV_PBE_FR-1.1.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Sc_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Se_ONCV_PBE_FR-1.1.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Si_ONCV_PBE_FR-1.1.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Sn_ONCV_PBE_FR-1.1.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Sr_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Ta_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Tc_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Te_ONCV_PBE_FR-1.1.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Ti_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Tl_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/V_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/W_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Xe_ONCV_PBE_FR-1.1.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Y_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Zn_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_relativistic_v1.0/pbe/Zr_ONCV_PBE_FR-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Ag_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Al_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Ar_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/As_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Au_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/B_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Ba_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Be_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Bi_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Br_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/C_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Ca_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Cd_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Cl_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Co_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Cr_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Cs_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Cu_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/F_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Fe_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Ga_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Ge_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/H_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/He_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Hf_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Hg_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/I_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/In_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Ir_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/K_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Kr_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/La_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Li_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Mg_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Mn_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Mo_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/N_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Na_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Nb_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Ne_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Ni_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/O_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Os_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/P_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Pb_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Pd_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Pt_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Rb_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Re_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Rh_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Ru_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/S_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Sb_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Sc_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Se_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Si_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Sn_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Sr_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Ta_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Tc_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Te_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Ti_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Tl_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/V_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/W_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Xe_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Y_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Zn_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.0/pbe/Zr_ONCV_PBE-1.0.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Ag_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Al_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Ar_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/As_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Au_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/B_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Ba_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Be_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Bi_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Br_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/C_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Ca_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Cd_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Cl_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Co_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Cr_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Cs_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Cu_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/F_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Fe_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Ga_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Ge_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/H_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/He_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Hf_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Hg_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/I_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/In_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Ir_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/K_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Kr_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/La_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Li_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Mg_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Mn_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Mo_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/N_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Na_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Nb_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Ne_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Ni_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/O_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Os_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/P_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Pb_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Pd_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Pt_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Rb_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Re_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Rh_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Ru_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/S_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Sb_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Sc_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Se_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Sn_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Sr_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Ta_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Tc_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Te_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Ti_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Tl_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/V_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/W_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Xe_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Y_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Zn_ONCV_PBE-1.2.upf (100%) rename src/koopmans/{pseudos => pseudopotentials}/sg15_v1.2/pbe/Zr_ONCV_PBE-1.2.upf (100%) diff --git a/README.rst b/README.rst index e87f34915..7a1ed5ab6 100644 --- a/README.rst +++ b/README.rst @@ -123,7 +123,7 @@ Currently, Koopmans functionals only works with norm-conserving pseudopotentials For convenience, ``koopmans`` already ships with both of these pseudopotential libraries and you can simply select the one you want to use using the ``pseudo_library`` keyword. -If you prefer to use your own pseudopotentials, add them to ``koopmans/pseudopotentials`` in the subdirectory ``/``, where ```` is a name of your choosing and ```` is the functional used to generate your pseudopotentials. You can then direct ``koopmans`` to use these pseudopotentials by setting the keywords ``pseudo_library`` and ``base_functional`` to ```` and ```` respectively. +If you prefer to use your own pseudopotentials, add them to ``src/koopmans/pseudopotentials//``, where ```` is a name of your choosing and ```` is the functional used to generate your pseudopotentials. You can then direct ``koopmans`` to use these pseudopotentials by setting the keywords ``pseudo_library`` and ``base_functional`` to ```` and ```` respectively. Alternatively, you can direct the code to always use your personal pseudopotentials directory by defining the variable diff --git a/docs/conf.py b/docs/conf.py index c8d5045ed..7d8479118 100644 --- a/docs/conf.py +++ b/docs/conf.py @@ -35,7 +35,7 @@ extensions = ['recommonmark', 'sphinx.ext.mathjax', 'sphinx.ext.autosectionlabel', 'sphinxcontrib.bibtex', 'sphinx_toolbox.collapse', 'sphinx.ext.autodoc', 'numpydoc', 'sphinx.ext.autosummary'] -bibtex_bibfiles = ['refs.bib'] +bibtex_bibfiles = ['../src/koopmans/references.bib'] autosectionlabel_prefix_document = True # Add any paths that contain templates here, relative to this directory. diff --git a/src/koopmans/pseudopotentials.py b/src/koopmans/pseudopotentials.py index 8dbe15602..8c8725e78 100644 --- a/src/koopmans/pseudopotentials.py +++ b/src/koopmans/pseudopotentials.py @@ -33,7 +33,7 @@ class Pseudopotential: cutoff_rho: Optional[float] = None -pseudos_directory = Path('pseudos') +pseudos_directory = Path('pseudopotentials') # A database containing all the available pseudopotentials pseudo_database: List[Pseudopotential] = [] diff --git a/src/koopmans/pseudos/generate_wfc_psps.py b/src/koopmans/pseudopotentials/generate_wfc_psps.py similarity index 100% rename from src/koopmans/pseudos/generate_wfc_psps.py rename to src/koopmans/pseudopotentials/generate_wfc_psps.py diff --git a/src/koopmans/pseudos/pseudo_dojo_standard b/src/koopmans/pseudopotentials/pseudo_dojo_standard similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard rename to src/koopmans/pseudopotentials/pseudo_dojo_standard diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ag.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ag.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ag.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ag.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Al.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Al.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Al.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Al.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ar.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ar.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ar.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ar.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/As.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/As.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/As.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/As.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Au.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Au.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Au.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Au.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/B.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/B.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/B.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/B.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ba.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ba.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ba.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ba.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Be.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Be.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Be.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Be.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Bi.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Bi.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Bi.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Bi.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Br.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Br.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Br.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Br.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/C.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/C.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/C.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/C.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ca.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ca.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ca.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ca.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cd.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Cd.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cd.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Cd.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cl.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Cl.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cl.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Cl.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Co.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Co.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Co.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Co.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Cr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Cr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cs.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Cs.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cs.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Cs.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cu.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Cu.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Cu.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Cu.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/F.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/F.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/F.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/F.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Fe.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Fe.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Fe.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Fe.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ga.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ga.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ga.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ga.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ge.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ge.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ge.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ge.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/H.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/H.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/H.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/H.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/He.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/He.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/He.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/He.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Hf.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Hf.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Hf.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Hf.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Hg.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Hg.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Hg.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Hg.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/I.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/I.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/I.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/I.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/In.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/In.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/In.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/In.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ir.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ir.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ir.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ir.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/K.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/K.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/K.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/K.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Kr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Kr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Kr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Kr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Li.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Li.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Li.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Li.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Mg.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Mg.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Mg.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Mg.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Mn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Mn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Mn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Mn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Mo.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Mo.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Mo.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Mo.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/N.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/N.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/N.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/N.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Na.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Na.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Na.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Na.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Nb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Nb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Nb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Nb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ne.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ne.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ne.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ne.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ni.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ni.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ni.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ni.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/O.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/O.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/O.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/O.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Os.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Os.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Os.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Os.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/P.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/P.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/P.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/P.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Pb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Pb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Pb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Pb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Pd.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Pd.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Pd.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Pd.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Po.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Po.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Po.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Po.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Pt.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Pt.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Pt.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Pt.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Rb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Rb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Rb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Rb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Re.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Re.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Re.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Re.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Rh.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Rh.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Rh.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Rh.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Rn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Rn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Rn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Rn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ru.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ru.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ru.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ru.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/S.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/S.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/S.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/S.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Sb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Sb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sc.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Sc.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sc.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Sc.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Se.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Se.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Se.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Se.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Si.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Si.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Si.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Si.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Sn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Sn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Sr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Sr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Sr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ta.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ta.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ta.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ta.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Tc.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Tc.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Tc.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Tc.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Te.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Te.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Te.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Te.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ti.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ti.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Ti.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Ti.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Tl.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Tl.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Tl.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Tl.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/V.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/V.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/V.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/V.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/W.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/W.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/W.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/W.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Xe.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Xe.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Xe.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Xe.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Y.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Y.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Y.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Y.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Zn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Zn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Zn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Zn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Zr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Zr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/lda/Zr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda/Zr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ag.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ag.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ag.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ag.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Al.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Al.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Al.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Al.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ar.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ar.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ar.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ar.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/As.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/As.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/As.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/As.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Au.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Au.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Au.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Au.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/B.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/B.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/B.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/B.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ba.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ba.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ba.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ba.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Be.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Be.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Be.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Be.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Bi.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Bi.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Bi.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Bi.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Br.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Br.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Br.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Br.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/C.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/C.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/C.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/C.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ca.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ca.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ca.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ca.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cd.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Cd.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cd.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Cd.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cl.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Cl.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cl.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Cl.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Co.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Co.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Co.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Co.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Cr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Cr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cs.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Cs.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cs.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Cs.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cu.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Cu.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Cu.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Cu.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/F.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/F.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/F.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/F.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Fe.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Fe.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Fe.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Fe.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ga.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ga.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ga.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ga.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ge.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ge.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ge.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ge.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/H.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/H.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/H.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/H.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/He.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/He.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/He.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/He.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Hf.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Hf.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Hf.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Hf.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Hg.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Hg.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Hg.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Hg.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/I.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/I.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/I.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/I.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/In.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/In.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/In.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/In.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ir.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ir.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ir.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ir.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/K.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/K.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/K.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/K.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Kr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Kr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Kr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Kr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/La.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/La.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/La.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/La.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Li.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Li.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Li.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Li.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Lu.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Lu.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Lu.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Lu.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mg.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Mg.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mg.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Mg.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Mn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Mn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mo.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Mo.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Mo.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Mo.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/N.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/N.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/N.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/N.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Na.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Na.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Na.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Na.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Nb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Nb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Nb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Nb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ne.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ne.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ne.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ne.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ni.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ni.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ni.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ni.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/O.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/O.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/O.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/O.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Os.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Os.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Os.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Os.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/P.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/P.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/P.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/P.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Pb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Pb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pd.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Pd.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pd.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Pd.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Po.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Po.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Po.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Po.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pt.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Pt.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Pt.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Pt.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Rb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Rb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Re.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Re.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Re.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Re.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rh.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Rh.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rh.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Rh.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Rn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Rn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Rn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ru.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ru.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ru.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ru.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/S.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/S.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/S.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/S.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Sb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Sb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sc.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Sc.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sc.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Sc.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Se.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Se.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Se.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Se.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Si.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Si.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Si.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Si.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Sn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Sn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Sr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Sr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Sr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ta.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ta.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ta.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ta.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Tc.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Tc.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Tc.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Tc.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Te.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Te.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Te.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Te.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ti.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ti.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Ti.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Ti.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Tl.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Tl.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Tl.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Tl.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/V.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/V.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/V.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/V.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/W.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/W.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/W.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/W.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Xe.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Xe.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Xe.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Xe.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Y.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Y.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Y.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Y.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Zn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Zn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Zn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Zn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Zr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Zr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbe/Zr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe/Zr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ag.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ag.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ag.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ag.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Al.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Al.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Al.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Al.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ar.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ar.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ar.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ar.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/As.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/As.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/As.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/As.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Au.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Au.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Au.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Au.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/B.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/B.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/B.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/B.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ba.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ba.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ba.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ba.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Be.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Be.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Be.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Be.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Bi.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Bi.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Bi.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Bi.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Br.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Br.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Br.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Br.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/C.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/C.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/C.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/C.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ca.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ca.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ca.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ca.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cd.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Cd.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cd.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Cd.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cl.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Cl.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cl.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Cl.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Co.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Co.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Co.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Co.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Cr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Cr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cs.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Cs.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cs.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Cs.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cu.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Cu.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Cu.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Cu.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/F.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/F.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/F.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/F.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Fe.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Fe.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Fe.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Fe.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ga.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ga.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ga.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ga.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ge.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ge.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ge.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ge.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/H.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/H.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/H.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/H.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/He.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/He.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/He.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/He.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Hf.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Hf.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Hf.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Hf.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Hg.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Hg.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Hg.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Hg.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/I.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/I.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/I.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/I.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/In.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/In.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/In.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/In.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ir.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ir.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ir.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ir.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/K.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/K.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/K.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/K.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Kr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Kr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Kr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Kr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/La.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/La.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/La.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/La.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Li.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Li.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Li.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Li.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Lu.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Lu.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Lu.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Lu.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mg.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Mg.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mg.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Mg.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Mn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Mn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mo.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Mo.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Mo.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Mo.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/N.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/N.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/N.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/N.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Na.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Na.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Na.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Na.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Nb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Nb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Nb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Nb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ne.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ne.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ne.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ne.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ni.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ni.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ni.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ni.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/O.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/O.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/O.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/O.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Os.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Os.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Os.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Os.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/P.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/P.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/P.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/P.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Pb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Pb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pd.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Pd.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pd.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Pd.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Po.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Po.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Po.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Po.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pt.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Pt.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Pt.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Pt.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Rb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Rb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Re.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Re.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Re.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Re.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rh.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Rh.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rh.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Rh.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Rn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Rn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Rn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ru.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ru.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ru.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ru.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/S.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/S.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/S.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/S.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Sb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Sb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sc.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Sc.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sc.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Sc.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Se.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Se.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Se.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Se.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Si.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Si.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Si.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Si.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Sn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Sn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Sr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Sr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Sr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ta.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ta.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ta.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ta.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Tc.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Tc.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Tc.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Tc.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Te.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Te.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Te.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Te.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ti.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ti.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ti.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ti.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Tl.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Tl.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Tl.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Tl.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/V.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/V.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/V.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/V.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/W.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/W.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/W.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/W.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Xe.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Xe.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Xe.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Xe.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Y.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Y.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Y.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Y.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Zn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Zn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Zn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Zn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Zr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Zr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Zr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Zr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent b/src/koopmans/pseudopotentials/pseudo_dojo_stringent similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ag.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ag.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ag.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ag.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Al.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Al.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Al.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Al.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ar.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ar.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ar.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ar.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/As.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/As.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/As.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/As.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Au.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Au.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Au.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Au.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/B.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/B.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/B.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/B.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ba.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ba.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ba.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ba.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Be.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Be.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Be.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Be.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Bi.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Bi.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Bi.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Bi.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Br.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Br.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Br.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Br.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/C.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/C.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/C.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/C.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ca.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ca.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ca.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ca.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cd.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Cd.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cd.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Cd.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cl.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Cl.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cl.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Cl.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Co.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Co.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Co.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Co.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Cr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Cr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cs.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Cs.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cs.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Cs.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cu.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Cu.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Cu.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Cu.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/F.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/F.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/F.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/F.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Fe.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Fe.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Fe.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Fe.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ga.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ga.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ga.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ga.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ge.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ge.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ge.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ge.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/H.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/H.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/H.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/H.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/He.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/He.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/He.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/He.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Hf.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Hf.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Hf.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Hf.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Hg.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Hg.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Hg.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Hg.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/I.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/I.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/I.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/I.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/In.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/In.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/In.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/In.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ir.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ir.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ir.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ir.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/K.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/K.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/K.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/K.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Kr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Kr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Kr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Kr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Li.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Li.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Li.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Li.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mg.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Mg.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mg.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Mg.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Mn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Mn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mo.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Mo.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Mo.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Mo.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/N.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/N.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/N.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/N.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Na.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Na.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Na.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Na.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Nb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Nb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Nb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Nb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ne.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ne.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ne.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ne.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ni.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ni.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ni.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ni.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/O.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/O.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/O.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/O.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Os.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Os.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Os.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Os.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/P.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/P.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/P.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/P.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Pb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Pb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pd.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Pd.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pd.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Pd.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Po.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Po.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Po.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Po.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pt.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Pt.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Pt.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Pt.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Rb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Rb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Re.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Re.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Re.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Re.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rh.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Rh.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rh.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Rh.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Rn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Rn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Rn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ru.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ru.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ru.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ru.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/S.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/S.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/S.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/S.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Sb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Sb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sc.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Sc.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sc.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Sc.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Se.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Se.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Se.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Se.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Si.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Si.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Si.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Si.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Sn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Sn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Sr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Sr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Sr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ta.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ta.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ta.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ta.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Tc.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Tc.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Tc.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Tc.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Te.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Te.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Te.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Te.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ti.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ti.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Ti.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Ti.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Tl.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Tl.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Tl.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Tl.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/V.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/V.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/V.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/V.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/W.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/W.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/W.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/W.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Xe.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Xe.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Xe.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Xe.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Y.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Y.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Y.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Y.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Zn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Zn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Zn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Zn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Zr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Zr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/lda/Zr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/lda/Zr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ag.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ag.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ag.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ag.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Al.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Al.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Al.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Al.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ar.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ar.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ar.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ar.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/As.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/As.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/As.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/As.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Au.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Au.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Au.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Au.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/B.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/B.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/B.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/B.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ba.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ba.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ba.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ba.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Be.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Be.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Be.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Be.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Bi.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Bi.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Bi.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Bi.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Br.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Br.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Br.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Br.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/C.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/C.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/C.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/C.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ca.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ca.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ca.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ca.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cd.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Cd.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cd.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Cd.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cl.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Cl.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cl.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Cl.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Co.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Co.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Co.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Co.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Cr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Cr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cs.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Cs.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cs.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Cs.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cu.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Cu.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Cu.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Cu.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/F.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/F.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/F.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/F.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Fe.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Fe.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Fe.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Fe.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ga.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ga.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ga.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ga.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ge.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ge.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ge.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ge.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/H.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/H.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/H.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/H.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/He.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/He.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/He.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/He.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Hf.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Hf.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Hf.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Hf.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Hg.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Hg.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Hg.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Hg.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/I.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/I.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/I.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/I.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/In.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/In.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/In.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/In.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ir.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ir.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ir.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ir.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/K.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/K.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/K.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/K.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Kr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Kr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Kr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Kr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/La.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/La.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/La.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/La.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Li.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Li.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Li.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Li.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Lu.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Lu.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Lu.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Lu.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mg.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Mg.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mg.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Mg.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Mn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Mn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mo.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Mo.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Mo.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Mo.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/N.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/N.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/N.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/N.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Na.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Na.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Na.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Na.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Nb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Nb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Nb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Nb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ne.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ne.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ne.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ne.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ni.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ni.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ni.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ni.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/O.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/O.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/O.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/O.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Os.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Os.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Os.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Os.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/P.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/P.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/P.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/P.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Pb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Pb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pd.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Pd.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pd.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Pd.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Po.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Po.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Po.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Po.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pt.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Pt.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Pt.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Pt.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Rb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Rb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Re.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Re.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Re.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Re.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rh.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Rh.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rh.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Rh.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Rn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Rn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Rn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ru.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ru.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ru.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ru.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/S.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/S.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/S.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/S.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Sb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Sb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sc.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Sc.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sc.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Sc.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Se.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Se.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Se.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Se.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Si.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Si.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Si.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Si.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Sn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Sn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Sr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Sr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Sr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ta.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ta.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ta.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ta.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Tc.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Tc.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Tc.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Tc.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Te.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Te.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Te.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Te.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ti.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ti.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Ti.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Ti.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Tl.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Tl.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Tl.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Tl.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/V.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/V.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/V.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/V.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/W.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/W.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/W.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/W.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Xe.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Xe.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Xe.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Xe.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Y.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Y.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Y.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Y.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Zn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Zn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Zn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Zn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Zr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Zr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbe/Zr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbe/Zr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ag.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ag.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ag.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ag.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Al.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Al.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Al.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Al.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ar.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ar.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ar.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ar.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/As.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/As.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/As.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/As.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Au.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Au.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Au.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Au.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/B.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/B.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/B.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/B.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ba.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ba.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ba.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ba.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Be.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Be.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Be.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Be.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Bi.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Bi.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Bi.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Bi.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Br.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Br.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Br.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Br.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/C.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/C.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/C.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/C.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ca.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ca.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ca.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ca.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cd.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Cd.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cd.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Cd.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cl.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Cl.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cl.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Cl.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Co.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Co.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Co.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Co.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Cr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Cr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cs.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Cs.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cs.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Cs.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cu.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Cu.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Cu.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Cu.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/F.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/F.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/F.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/F.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Fe.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Fe.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Fe.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Fe.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ga.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ga.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ga.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ga.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ge.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ge.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ge.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ge.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/H.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/H.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/H.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/H.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/He.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/He.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/He.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/He.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Hf.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Hf.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Hf.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Hf.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Hg.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Hg.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Hg.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Hg.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/I.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/I.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/I.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/I.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/In.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/In.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/In.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/In.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ir.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ir.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ir.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ir.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/K.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/K.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/K.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/K.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Kr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Kr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Kr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Kr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/La.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/La.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/La.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/La.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Li.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Li.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Li.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Li.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Lu.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Lu.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Lu.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Lu.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mg.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Mg.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mg.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Mg.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Mn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Mn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mo.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Mo.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Mo.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Mo.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/N.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/N.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/N.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/N.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Na.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Na.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Na.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Na.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Nb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Nb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Nb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Nb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ne.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ne.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ne.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ne.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ni.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ni.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ni.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ni.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/O.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/O.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/O.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/O.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Os.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Os.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Os.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Os.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/P.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/P.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/P.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/P.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Pb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Pb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pd.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Pd.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pd.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Pd.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Po.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Po.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Po.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Po.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pt.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Pt.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Pt.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Pt.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Rb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Rb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Re.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Re.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Re.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Re.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rh.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Rh.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rh.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Rh.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Rn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Rn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Rn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ru.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ru.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ru.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ru.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/S.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/S.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/S.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/S.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sb.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Sb.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sb.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Sb.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sc.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Sc.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sc.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Sc.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Se.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Se.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Se.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Se.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Si.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Si.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Si.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Si.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Sn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Sn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Sr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Sr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Sr.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ta.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ta.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ta.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ta.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Tc.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Tc.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Tc.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Tc.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Te.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Te.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Te.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Te.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ti.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ti.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Ti.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Ti.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Tl.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Tl.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Tl.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Tl.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/V.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/V.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/V.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/V.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/W.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/W.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/W.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/W.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Xe.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Xe.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Xe.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Xe.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Y.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Y.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Y.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Y.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Zn.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Zn.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Zn.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Zn.upf diff --git a/src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Zr.upf b/src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Zr.upf similarity index 100% rename from src/koopmans/pseudos/pseudo_dojo_stringent_v0.4.1/pbesol/Zr.upf rename to src/koopmans/pseudopotentials/pseudo_dojo_stringent_v0.4.1/pbesol/Zr.upf diff --git a/src/koopmans/pseudos/sg15 b/src/koopmans/pseudopotentials/sg15 similarity index 100% rename from src/koopmans/pseudos/sg15 rename to src/koopmans/pseudopotentials/sg15 diff --git a/src/koopmans/pseudos/sg15_relativistic b/src/koopmans/pseudopotentials/sg15_relativistic similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic rename to src/koopmans/pseudopotentials/sg15_relativistic diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ag_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ag_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ag_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ag_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Al_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Al_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Al_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Al_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ar_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ar_ONCV_PBE_FR-1.1.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ar_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ar_ONCV_PBE_FR-1.1.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/As_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/As_ONCV_PBE_FR-1.1.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/As_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/As_ONCV_PBE_FR-1.1.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Au_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Au_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Au_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Au_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/B_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/B_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/B_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/B_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Br_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Br_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Br_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Br_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/C_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/C_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/C_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/C_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ca_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ca_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ca_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ca_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cd_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Cd_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cd_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Cd_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cl_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Cl_ONCV_PBE_FR-1.1.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cl_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Cl_ONCV_PBE_FR-1.1.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Co_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Co_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Co_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Co_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cr_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Cr_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cr_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Cr_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cs_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Cs_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cs_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Cs_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cu_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Cu_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Cu_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Cu_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/F_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/F_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/F_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/F_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Fe_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Fe_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Fe_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Fe_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ga_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ga_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ga_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ga_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ge_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ge_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ge_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ge_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/H_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/H_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/H_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/H_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/He_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/He_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/He_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/He_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Hf_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Hf_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Hf_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Hf_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Hg_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Hg_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Hg_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Hg_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/I_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/I_ONCV_PBE_FR-1.1.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/I_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/I_ONCV_PBE_FR-1.1.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/In_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/In_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/In_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/In_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ir_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ir_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ir_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ir_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/K_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/K_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/K_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/K_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Kr_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Kr_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Kr_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Kr_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/La_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/La_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/La_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/La_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Mg_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Mg_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Mg_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Mg_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Mn_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Mn_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Mn_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Mn_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Mo_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Mo_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Mo_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Mo_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/N_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/N_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/N_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/N_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Na_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Na_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Na_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Na_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Nb_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Nb_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Nb_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Nb_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ni_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ni_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ni_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ni_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/O_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/O_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/O_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/O_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Os_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Os_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Os_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Os_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/P_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/P_ONCV_PBE_FR-1.1.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/P_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/P_ONCV_PBE_FR-1.1.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Pb_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Pb_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Pb_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Pb_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Pd_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Pd_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Pd_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Pd_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Pt_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Pt_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Pt_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Pt_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Rb_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Rb_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Rb_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Rb_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Re_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Re_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Re_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Re_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Rh_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Rh_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Rh_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Rh_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ru_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ru_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ru_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ru_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/S_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/S_ONCV_PBE_FR-1.1.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/S_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/S_ONCV_PBE_FR-1.1.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sb_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Sb_ONCV_PBE_FR-1.1.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sb_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Sb_ONCV_PBE_FR-1.1.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sc_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Sc_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sc_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Sc_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Se_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Se_ONCV_PBE_FR-1.1.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Se_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Se_ONCV_PBE_FR-1.1.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Si_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Si_ONCV_PBE_FR-1.1.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Si_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Si_ONCV_PBE_FR-1.1.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sn_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Sn_ONCV_PBE_FR-1.1.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sn_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Sn_ONCV_PBE_FR-1.1.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sr_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Sr_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Sr_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Sr_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ta_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ta_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ta_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ta_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Tc_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Tc_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Tc_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Tc_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Te_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Te_ONCV_PBE_FR-1.1.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Te_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Te_ONCV_PBE_FR-1.1.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ti_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ti_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Ti_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Ti_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Tl_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Tl_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Tl_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Tl_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/V_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/V_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/V_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/V_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/W_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/W_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/W_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/W_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Xe_ONCV_PBE_FR-1.1.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Xe_ONCV_PBE_FR-1.1.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Xe_ONCV_PBE_FR-1.1.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Xe_ONCV_PBE_FR-1.1.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Y_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Y_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Y_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Y_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Zn_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Zn_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Zn_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Zn_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Zr_ONCV_PBE_FR-1.0.upf b/src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Zr_ONCV_PBE_FR-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_relativistic_v1.0/pbe/Zr_ONCV_PBE_FR-1.0.upf rename to src/koopmans/pseudopotentials/sg15_relativistic_v1.0/pbe/Zr_ONCV_PBE_FR-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Ag_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ag_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Ag_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ag_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Al_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Al_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Al_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Al_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Ar_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ar_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Ar_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ar_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/As_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/As_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/As_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/As_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Au_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Au_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Au_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Au_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/B_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/B_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/B_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/B_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Ba_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ba_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Ba_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ba_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Be_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Be_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Be_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Be_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Bi_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Bi_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Bi_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Bi_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Br_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Br_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Br_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Br_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/C_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/C_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/C_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/C_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Ca_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ca_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Ca_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ca_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Cd_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Cd_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Cd_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Cd_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Cl_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Cl_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Cl_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Cl_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Co_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Co_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Co_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Co_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Cr_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Cr_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Cr_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Cr_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Cs_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Cs_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Cs_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Cs_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Cu_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Cu_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Cu_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Cu_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/F_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/F_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/F_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/F_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Fe_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Fe_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Fe_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Fe_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Ga_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ga_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Ga_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ga_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Ge_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ge_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Ge_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ge_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/H_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/H_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/H_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/H_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/He_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/He_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/He_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/He_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Hf_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Hf_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Hf_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Hf_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Hg_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Hg_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Hg_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Hg_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/I_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/I_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/I_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/I_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/In_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/In_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/In_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/In_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Ir_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ir_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Ir_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ir_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/K_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/K_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/K_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/K_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Kr_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Kr_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Kr_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Kr_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/La_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/La_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/La_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/La_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Li_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Li_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Li_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Li_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Mg_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Mg_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Mg_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Mg_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Mn_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Mn_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Mn_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Mn_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Mo_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Mo_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Mo_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Mo_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/N_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/N_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/N_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/N_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Na_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Na_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Na_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Na_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Nb_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Nb_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Nb_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Nb_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Ne_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ne_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Ne_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ne_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Ni_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ni_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Ni_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ni_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/O_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/O_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/O_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/O_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Os_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Os_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Os_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Os_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/P_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/P_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/P_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/P_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Pb_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Pb_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Pb_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Pb_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Pd_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Pd_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Pd_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Pd_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Pt_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Pt_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Pt_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Pt_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Rb_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Rb_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Rb_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Rb_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Re_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Re_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Re_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Re_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Rh_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Rh_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Rh_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Rh_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Ru_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ru_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Ru_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ru_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/S_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/S_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/S_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/S_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Sb_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Sb_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Sb_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Sb_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Sc_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Sc_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Sc_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Sc_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Se_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Se_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Se_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Se_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Si_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Si_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Si_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Si_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Sn_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Sn_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Sn_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Sn_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Sr_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Sr_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Sr_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Sr_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Ta_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ta_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Ta_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ta_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Tc_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Tc_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Tc_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Tc_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Te_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Te_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Te_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Te_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Ti_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ti_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Ti_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Ti_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Tl_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Tl_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Tl_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Tl_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/V_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/V_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/V_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/V_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/W_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/W_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/W_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/W_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Xe_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Xe_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Xe_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Xe_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Y_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Y_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Y_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Y_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Zn_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Zn_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Zn_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Zn_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.0/pbe/Zr_ONCV_PBE-1.0.upf b/src/koopmans/pseudopotentials/sg15_v1.0/pbe/Zr_ONCV_PBE-1.0.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.0/pbe/Zr_ONCV_PBE-1.0.upf rename to src/koopmans/pseudopotentials/sg15_v1.0/pbe/Zr_ONCV_PBE-1.0.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Ag_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ag_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Ag_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ag_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Al_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Al_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Al_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Al_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Ar_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ar_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Ar_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ar_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/As_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/As_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/As_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/As_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Au_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Au_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Au_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Au_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/B_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/B_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/B_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/B_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Ba_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ba_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Ba_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ba_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Be_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Be_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Be_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Be_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Bi_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Bi_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Bi_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Bi_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Br_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Br_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Br_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Br_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/C_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/C_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/C_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/C_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Ca_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ca_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Ca_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ca_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Cd_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Cd_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Cd_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Cd_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Cl_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Cl_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Cl_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Cl_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Co_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Co_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Co_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Co_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Cr_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Cr_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Cr_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Cr_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Cs_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Cs_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Cs_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Cs_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Cu_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Cu_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Cu_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Cu_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/F_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/F_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/F_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/F_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Fe_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Fe_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Fe_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Fe_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Ga_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ga_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Ga_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ga_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Ge_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ge_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Ge_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ge_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/H_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/H_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/H_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/H_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/He_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/He_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/He_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/He_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Hf_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Hf_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Hf_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Hf_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Hg_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Hg_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Hg_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Hg_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/I_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/I_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/I_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/I_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/In_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/In_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/In_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/In_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Ir_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ir_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Ir_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ir_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/K_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/K_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/K_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/K_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Kr_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Kr_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Kr_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Kr_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/La_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/La_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/La_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/La_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Li_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Li_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Li_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Li_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Mg_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Mg_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Mg_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Mg_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Mn_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Mn_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Mn_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Mn_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Mo_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Mo_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Mo_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Mo_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/N_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/N_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/N_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/N_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Na_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Na_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Na_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Na_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Nb_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Nb_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Nb_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Nb_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Ne_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ne_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Ne_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ne_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Ni_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ni_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Ni_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ni_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/O_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/O_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/O_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/O_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Os_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Os_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Os_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Os_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/P_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/P_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/P_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/P_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Pb_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Pb_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Pb_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Pb_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Pd_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Pd_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Pd_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Pd_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Pt_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Pt_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Pt_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Pt_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Rb_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Rb_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Rb_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Rb_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Re_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Re_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Re_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Re_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Rh_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Rh_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Rh_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Rh_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Ru_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ru_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Ru_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ru_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/S_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/S_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/S_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/S_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Sb_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Sb_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Sb_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Sb_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Sc_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Sc_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Sc_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Sc_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Se_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Se_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Se_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Se_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Sn_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Sn_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Sn_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Sn_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Sr_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Sr_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Sr_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Sr_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Ta_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ta_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Ta_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ta_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Tc_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Tc_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Tc_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Tc_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Te_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Te_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Te_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Te_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Ti_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ti_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Ti_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Ti_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Tl_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Tl_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Tl_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Tl_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/V_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/V_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/V_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/V_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/W_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/W_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/W_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/W_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Xe_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Xe_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Xe_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Xe_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Y_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Y_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Y_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Y_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Zn_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Zn_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Zn_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Zn_ONCV_PBE-1.2.upf diff --git a/src/koopmans/pseudos/sg15_v1.2/pbe/Zr_ONCV_PBE-1.2.upf b/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Zr_ONCV_PBE-1.2.upf similarity index 100% rename from src/koopmans/pseudos/sg15_v1.2/pbe/Zr_ONCV_PBE-1.2.upf rename to src/koopmans/pseudopotentials/sg15_v1.2/pbe/Zr_ONCV_PBE-1.2.upf From 3fcc18dba1e56c885f314b7a8ef8654c6bd77cdf Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 21:59:56 +0200 Subject: [PATCH 37/49] Added references --- src/koopmans/references.bib | 318 ++++++++++++++++++++++++++++++++++++ 1 file changed, 318 insertions(+) create mode 100644 src/koopmans/references.bib diff --git a/src/koopmans/references.bib b/src/koopmans/references.bib new file mode 100644 index 000000000..a09f2fa41 --- /dev/null +++ b/src/koopmans/references.bib @@ -0,0 +1,318 @@ + +@article{Baroni2001, + title = {Phonons and Related Crystal Properties from Density-Functional Perturbation Theory}, + author = {Baroni, Stefano and {de Gironcoli}, Stefano and Dal Corso, Andrea and Giannozzi, Paolo}, + year = {2001}, + month = jul, + journal = {Reviews of Modern Physics}, + volume = {73}, + number = {2}, + pages = {515--562}, + publisher = {{American Physical Society}}, + issn = {0034-6861}, + doi = {10.1103/RevModPhys.73.515} +} + +@article{Borghi2014, + title = {Koopmans-Compliant Functionals and Their Performance against Reference Molecular Data}, + author = {Borghi, Giovanni and Ferretti, Andrea and Nguyen, Ngoc Linh and Dabo, Ismaila and Marzari, Nicola}, + year = {2014}, + month = aug, + journal = {Physical Review B}, + volume = {90}, + number = {7}, + pages = {075135}, + publisher = {{American Physical Society}}, + issn = {1098-0121}, + doi = {10.1103/PhysRevB.90.075135} +} + +@article{Borghi2015, + title = {Variational Minimization of Orbital-Density-Dependent Functionals}, + author = {Borghi, Giovanni and Park, Cheol Hwan and Nguyen, Ngoc Linh and Ferretti, Andrea and Marzari, Nicola}, + year = {2015}, + month = apr, + journal = {Physical Review B - Condensed Matter and Materials Physics}, + volume = {91}, + number = {15}, + pages = {155112}, + publisher = {{American Physical Society}}, + issn = {1550235X}, + doi = {10.1103/PhysRevB.91.155112} +} + +@article{Colonna2018, + title = {Screening in {{Orbital-Density-Dependent Functionals}}}, + author = {Colonna, Nicola and Nguyen, Ngoc Linh and Ferretti, Andrea and Marzari, Nicola}, + year = {2018}, + month = may, + journal = {Journal of Chemical Theory and Computation}, + volume = {14}, + number = {5}, + eprint = {1711.04485}, + eprinttype = {arxiv}, + pages = {2549--2557}, + publisher = {{American Chemical Society}}, + issn = {15499626}, + doi = {10.1021/acs.jctc.7b01116}, + archiveprefix = {arXiv} +} + +@article{Colonna2019, + title = {Koopmans-Compliant Functionals and Potentials and Their Application to the {{GW100}} Test Set}, + author = {Colonna, Nicola and Nguyen, Ngoc Linh and Ferretti, Andrea and Marzari, Nicola}, + year = {2019}, + month = mar, + journal = {Journal of Chemical Theory and Computation}, + volume = {15}, + number = {3}, + pages = {1905--1914}, + publisher = {{American Chemical Society}}, + issn = {1549-9618}, + doi = {10.1021/acs.jctc.8b00976} +} + +@article{Colonna2022, + title = {Koopmans {{Spectral Functionals}} in {{Periodic Boundary Conditions}}}, + author = {Colonna, Nicola and Gennaro, Riccardo De and Linscott, Edward and Marzari, Nicola}, + year = {2022}, + month = aug, + journal = {Journal of Chemical Theory and Computation}, + publisher = {{American Chemical Society}}, + doi = {10.1021/acs.jctc.2c00161}, + copyright = {\textcopyright{} 2022 American Chemical Society}, + langid = {english} +} + +@misc{Dabo2009, + title = {Non-{{Koopmans Corrections}} in {{Density-functional Theory}}: {{Self-interaction Revisited}}}, + author = {Dabo, I. and Cococcioni, M. and Marzari, N.}, + year = {2009}, + month = jan, + eprint = {0901.2637}, + eprinttype = {arxiv}, + archiveprefix = {arXiv} +} + +@article{Dabo2010, + title = {Koopmans' Condition for Density-Functional Theory}, + author = {Dabo, Ismaila and Ferretti, Andrea and Poilvert, Nicolas and Li, Yanli and Marzari, Nicola and Cococcioni, Matteo}, + year = {2010}, + month = sep, + journal = {Physical Review B}, + volume = {82}, + number = {11}, + pages = {115121}, + publisher = {{American Physical Society}}, + issn = {1098-0121}, + doi = {10.1103/PhysRevB.82.115121} +} + +@article{Dabo2013, + title = {Donor and Acceptor Levels of Organic Photovoltaic Compounds from First Principles}, + author = {Dabo, Ismaila and Ferretti, Andrea and Park, Cheol Hwan and Poilvert, Nicolas and Li, Yanli and Cococcioni, Matteo and Marzari, Nicola}, + year = {2013}, + month = jan, + journal = {Physical Chemistry Chemical Physics}, + volume = {15}, + number = {2}, + eprint = {1210.7973}, + eprinttype = {arxiv}, + pages = {685--695}, + issn = {14639076}, + doi = {10.1039/c2cp43491a}, + archiveprefix = {arXiv} +} + +@article{DeGennaro2022, + title = {Bloch's Theorem in Orbital-Density-Dependent Functionals: {{Band}} Structures from {{Koopmans}} Spectral Functionals}, + shorttitle = {Bloch's Theorem in Orbital-Density-Dependent Functionals}, + author = {De Gennaro, Riccardo and Colonna, Nicola and Linscott, Edward and Marzari, Nicola}, + year = {2022}, + month = jul, + journal = {Phys. Rev. B}, + volume = {106}, + number = {3}, + pages = {035106}, + publisher = {{American Physical Society}}, + doi = {10.1103/PhysRevB.106.035106}, + copyright = {All rights reserved} +} + +@article{Ferretti2014, + title = {Bridging Density-Functional and Many-Body Perturbation Theory: Orbital-Density Dependence in Electronic-Structure Functionals}, + author = {Ferretti, Andrea and Dabo, Ismaila and Cococcioni, Matteo and Marzari, Nicola}, + year = {2014}, + month = may, + journal = {Physical Review B}, + volume = {89}, + number = {19}, + pages = {195134}, + publisher = {{American Physical Society}}, + issn = {1098-0121}, + doi = {10.1103/PhysRevB.89.195134} +} + +@article{Hamann2013, + title = {Optimized Norm-Conserving {{Vanderbilt}} Pseudopotentials}, + author = {Hamann, D. R.}, + year = {2013}, + month = aug, + journal = {Physical Review B - Condensed Matter and Materials Physics}, + volume = {88}, + number = {8}, + pages = {085117}, + publisher = {{American Physical Society}}, + issn = {10980121}, + doi = {10.1103/PhysRevB.88.085117} +} + +@article{Lejaeghere2016, + title = {Reproducibility in Density Functional Theory Calculations of Solids}, + author = {Lejaeghere, Kurt and Bihlmayer, Gustav and Bj{\"o}rkman, Torbj{\"o}rn and Blaha, Peter and Bl{\"u}gel, Stefan and Blum, Volker and Caliste, Damien and Castelli, Ivano E. and Clark, Stewart J. and Dal Corso, Andrea and {de Gironcoli}, Stefano and Deutsch, Thierry and Dewhurst, John Kay and Di Marco, Igor and Draxl, Claudia and Du{\l}ak, Marcin and Eriksson, Olle and {Flores-Livas}, Jos{\'e} A. and Garrity, Kevin F. and Genovese, Luigi and Giannozzi, Paolo and Giantomassi, Matteo and Goedecker, Stefan and Gonze, Xavier and Gr{\aa}n{\"a}s, Oscar and Gross, E. K. U. and Gulans, Andris and Gygi, Fran{\c c}ois and Hamann, D. R. and Hasnip, Phil J. and Holzwarth, N. A. W. and Iu{\c s}an, Diana and Jochym, Dominik B. and Jollet, Fran{\c c}ois and Jones, Daniel and Kresse, Georg and Koepernik, Klaus and K{\"u}{\c c}{\"u}kbenli, Emine and Kvashnin, Yaroslav O. and Locht, Inka L. M. and Lubeck, Sven and Marsman, Martijn and Marzari, Nicola and Nitzsche, Ulrike and Nordstr{\"o}m, Lars and Ozaki, Taisuke and Paulatto, Lorenzo and Pickard, Chris J. and Poelmans, Ward and Probert, Matt I. J. and Refson, Keith and Richter, Manuel and Rignanese, Gian-Marco and Saha, Santanu and Scheffler, Matthias and Schlipf, Martin and Schwarz, Karlheinz and Sharma, Sangeeta and Tavazza, Francesca and Thunstr{\"o}m, Patrik and Tkatchenko, Alexandre and Torrent, Marc and Vanderbilt, David and {van Setten}, Michiel J. and Van Speybroeck, Veronique and Wills, John M. and Yates, Jonathan R. and Zhang, Guo-Xu and Cottenier, Stefaan}, + year = {2016}, + month = mar, + journal = {Science}, + volume = {351}, + number = {6280}, + pages = {aad3000}, + publisher = {{American Association for the Advancement of Science}}, + doi = {10.1126/science.aad3000} +} + +@article{Marzari2012, + title = {Maximally Localized {{Wannier}} Functions: {{Theory}} and Applications}, + author = {Marzari, Nicola and Mostofi, Arash A. and Yates, Jonathan R. and Souza, Ivo and Vanderbilt, David}, + year = {2012}, + month = oct, + journal = {Reviews of Modern Physics}, + volume = {84}, + number = {4}, + pages = {1419--1475}, + publisher = {{American Physical Society}}, + issn = {0034-6861}, + doi = {10.1103/RevModPhys.84.1419} +} + +@article{Nattino2019, + title = {Functional {{Extrapolations}} to {{Tame Unbound Anions}} in {{Density-Functional Theory Calculations}}}, + author = {Nattino, Francesco and Dupont, C{\'e}line and Marzari, Nicola and Andreussi, Oliviero}, + year = {2019}, + month = nov, + journal = {J. Chem. Theory Comput.}, + volume = {15}, + number = {11}, + eprint = {1906.00822}, + eprinttype = {arxiv}, + pages = {6313--6322}, + publisher = {{American Chemical Society}}, + issn = {15499626}, + doi = {10.1021/acs.jctc.9b00552}, + archiveprefix = {arXiv}, + pmid = {31580667} +} + +@article{Nguyen2016, + title = {First-{{Principles Photoemission Spectroscopy}} of {{DNA}} and {{RNA Nucleobases}} from {{Koopmans-Compliant Functionals}}}, + author = {Nguyen, Ngoc Linh and Borghi, Giovanni and Ferretti, Andrea and Marzari, Nicola}, + year = {2016}, + month = aug, + journal = {Journal of Chemical Theory and Computation}, + volume = {12}, + number = {8}, + pages = {3948--3958}, + publisher = {{American Chemical Society}}, + issn = {15499626}, + doi = {10.1021/acs.jctc.6b00145} +} + +@article{Nguyen2018, + title = {Koopmans-Compliant Spectral Functionals for Extended Systems}, + author = {Nguyen, Ngoc Linh and Colonna, Nicola and Ferretti, Andrea and Marzari, Nicola}, + year = {2018}, + month = may, + journal = {Physical Review X}, + volume = {8}, + number = {2}, + pages = {021051}, + publisher = {{American Physical Society}}, + issn = {2160-3308}, + doi = {10.1103/PhysRevX.8.021051} +} + +@article{Pederson1984, + title = {Local-density {{Hartree}}\textendash{{Fock}} Theory of Electronic States of Molecules with Self-interaction Correction}, + author = {Pederson, Mark R. and Heaton, Richard A. and Lin, Chun C.}, + year = {1984}, + month = mar, + journal = {The Journal of Chemical Physics}, + volume = {80}, + number = {5}, + pages = {1972--1975}, + publisher = {{American Institute of Physics}}, + issn = {0021-9606}, + doi = {10.1063/1.446959}, + keywords = {ELECTRONIC STRUCTURE,HARTREE−FOCK METHOD,MOLECULES,NITROGEN} +} + +@article{Prandini2018, + title = {Precision and Efficiency in Solid-State Pseudopotential Calculations}, + author = {Prandini, Gianluca and Marrazzo, Antimo and Castelli, Ivano E. and Mounet, Nicolas and Marzari, Nicola}, + year = {2018}, + month = dec, + journal = {npj Comput Mater}, + volume = {4}, + number = {1}, + pages = {1--13}, + publisher = {{Nature Publishing Group}}, + issn = {2057-3960}, + doi = {10.1038/s41524-018-0127-2}, + copyright = {2018 The Author(s)}, + langid = {english}, + keywords = {Computational methods,Electronic structure} +} + +@article{Scherpelz2016, + title = {Implementation and {{Validation}} of {{Fully Relativistic GW Calculations}}: {{Spin}}\textendash{{Orbit Coupling}} in {{Molecules}}, {{Nanocrystals}}, and {{Solids}}}, + shorttitle = {Implementation and {{Validation}} of {{Fully Relativistic GW Calculations}}}, + author = {Scherpelz, Peter and Govoni, Marco and Hamada, Ikutaro and Galli, Giulia}, + year = {2016}, + month = aug, + journal = {J. Chem. Theory Comput.}, + volume = {12}, + number = {8}, + pages = {3523--3544}, + publisher = {{American Chemical Society}}, + issn = {1549-9618}, + doi = {10.1021/acs.jctc.6b00114} +} + +@article{Schlipf2015, + title = {Optimization Algorithm for the Generation of {{ONCV}} Pseudopotentials}, + author = {Schlipf, Martin and Gygi, Fran{\c c}ois}, + year = {2015}, + month = nov, + journal = {Computer Physics Communications}, + volume = {196}, + pages = {36--44}, + issn = {0010-4655}, + doi = {10.1016/j.cpc.2015.05.011}, + keywords = {All-electron calculation,Condensed matter,Density functional theory,Plane wave,Pseudopotential} +} + +@article{vanSetten2018, + title = {The {{PseudoDojo}}: {{Training}} and Grading a 85 Element Optimized Norm-Conserving Pseudopotential Table}, + shorttitle = {The {{PseudoDojo}}}, + author = {{van Setten}, M. J. and Giantomassi, M. and Bousquet, E. and Verstraete, M. J. and Hamann, D. R. and Gonze, X. and Rignanese, G. -M.}, + year = {2018}, + month = may, + journal = {Computer Physics Communications}, + volume = {226}, + pages = {39--54}, + issn = {0010-4655}, + doi = {10.1016/j.cpc.2018.01.012}, + langid = {english}, + keywords = {Density functional theory,Electronic structure,First-principles calculation,Pseudopotential} +} + + From c4b8dd89563374cb208d072833986040b9cc0459 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 22:25:25 +0200 Subject: [PATCH 38/49] Fixing bugs from previous commit --- Makefile | 4 ++-- conftest.py | 3 ++- src/koopmans/pseudopotentials.py | 2 +- src/koopmans/references.py | 2 +- tests/calculators/test_projwfc.py | 7 ++++--- tests/data/kcp/ki_final.cpi | 2 +- tests/data/kcp/ki_final.cpo | 4 ++-- tests/data/kcw/kc.kso | 14 +++++++------- tests/data/ph/eps.pho | 4 ++-- tests/data/pw/scf.pwi | 2 +- tests/data/pw/scf.pwo | 2 +- tests/data/qei_to_json/example.cpi | 2 +- tests/data/qei_to_json/example.pwi | 2 +- tests/patches/_check.py | 2 +- tests/patches/_mock.py | 2 +- tests/patches/_utils.py | 2 +- tests/tutorials/test_tutorial_1.py | 5 +++-- tests/tutorials/test_tutorial_2.py | 5 +++-- tests/tutorials/test_tutorial_3.py | 4 ++-- tests/tutorials/test_tutorial_4.py | 2 +- 20 files changed, 38 insertions(+), 34 deletions(-) diff --git a/Makefile b/Makefile index 7adf17bd0..3fa0be7dc 100644 --- a/Makefile +++ b/Makefile @@ -80,5 +80,5 @@ tests: clean_tests: rm -rf tests/tmp -benchmark: - python3 -m pytest --generate_benchmark +benchmarks: + python3 -m pytest tests/ --generate_benchmark diff --git a/conftest.py b/conftest.py index 423b9774b..95fdcb338 100644 --- a/conftest.py +++ b/conftest.py @@ -1,3 +1,4 @@ +from pathlib import Path from typing import Any, Dict import pytest @@ -22,7 +23,7 @@ def pytest_addoption(parser): @pytest.fixture def datadir(): # Returns the directory where various reference QE files are stored - return Path(__path__[0]) / 'tests' / 'data' + return Path(__file__).parent / 'tests' / 'data' @pytest.fixture diff --git a/src/koopmans/pseudopotentials.py b/src/koopmans/pseudopotentials.py index 8c8725e78..45b1c2e9d 100644 --- a/src/koopmans/pseudopotentials.py +++ b/src/koopmans/pseudopotentials.py @@ -33,7 +33,7 @@ class Pseudopotential: cutoff_rho: Optional[float] = None -pseudos_directory = Path('pseudopotentials') +pseudos_directory = Path(__file__).parent / 'pseudopotentials' # A database containing all the available pseudopotentials pseudo_database: List[Pseudopotential] = [] diff --git a/src/koopmans/references.py b/src/koopmans/references.py index d1e354d15..703ab71f3 100644 --- a/src/koopmans/references.py +++ b/src/koopmans/references.py @@ -9,5 +9,5 @@ from pybtex.database.input import bibtex parser = bibtex.Parser() -bib_file = 'references.bib' +bib_file = Path(__file__).parent / 'references.bib' bib_data = parser.parse_file(bib_file) diff --git a/tests/calculators/test_projwfc.py b/tests/calculators/test_projwfc.py index fbfe868ab..e31cb44c0 100644 --- a/tests/calculators/test_projwfc.py +++ b/tests/calculators/test_projwfc.py @@ -1,9 +1,10 @@ import shutil +from pathlib import Path import pytest -from pathlib import Path -from koopmans import __path__ as koopmans_src, utils, workflows +from koopmans import __path__ as koopmans_src +from koopmans import utils, workflows from koopmans.io import read_kwf as read_encoded_json from koopmans.io import write_kwf as write_encoded_json from tests import patches @@ -17,7 +18,7 @@ def test_generate_dos(silicon, tmp_path, datadir, pytestconfig): name='si', **silicon) calc = wf.new_calculator('projwfc') - calc.pseudo_dir = Path(koopmans_src[0]) / 'pseudos' / 'pseudo_dojo_standard' / 'pbesol' + calc.pseudo_dir = Path(koopmans_src[0]) / 'pseudopotentials/pseudo_dojo_standard/pbesol' # Copy over pdos files for f in (datadir / 'projwfc').glob('*.pdos*'): diff --git a/tests/data/kcp/ki_final.cpi b/tests/data/kcp/ki_final.cpi index 5c0bf21f1..acd203280 100644 --- a/tests/data/kcp/ki_final.cpi +++ b/tests/data/kcp/ki_final.cpi @@ -6,7 +6,7 @@ outdir = '/home/elinscott/code/koopmans/tests/tmp/test_singlepoint_h2o_ki_dscf_e0/TMP-CP/' prefix = 'kc' disk_io = 'high' - pseudo_dir = '/home/elinscott/code/koopmans/pseudos/sg15_v1.2/pbe/' + pseudo_dir = '/home/elinscott/code/koopmans/src/koopmans/pseudopotentials/sg15_v1.2/pbe/' ndr = 60 ndw = 70 write_hr = .true. diff --git a/tests/data/kcp/ki_final.cpo b/tests/data/kcp/ki_final.cpo index 72f032d5d..16e751fb3 100644 --- a/tests/data/kcp/ki_final.cpo +++ b/tests/data/kcp/ki_final.cpo @@ -24,12 +24,12 @@ ---------------------------------- Reading pseudopotential for specie # 1 from file : - /home/elinscott/code/koopmans/pseudos/sg15_v1.2/pbe/O_ONCV_PBE-1.2.upf + /home/elinscott/code/koopmans/src/koopmans/pseudopotentials/sg15_v1.2/pbe/O_ONCV_PBE-1.2.upf file type is 20: UPF read_nonlocal Reading pseudopotential for specie # 2 from file : - /home/elinscott/code/koopmans/pseudos/sg15_v1.2/pbe/H_ONCV_PBE-1.2.upf + /home/elinscott/code/koopmans/src/koopmans/pseudopotentials/sg15_v1.2/pbe/H_ONCV_PBE-1.2.upf file type is 20: UPF read_nonlocal diff --git a/tests/data/kcw/kc.kso b/tests/data/kcw/kc.kso index b340ad134..6b34a4a08 100644 --- a/tests/data/kcw/kc.kso +++ b/tests/data/kcw/kc.kso @@ -315,7 +315,7 @@ weight = 1 0.12500000 PseudoPot. # 1 for Si read from file: - /home/elinscott/code/koopmans/pseudos/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf + /home/elinscott/code/koopmans/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf MD5 check sum: 7f029a58b69e3aa87b46a36c608bf45e Pseudo is Norm-conserving, Zval = 4.0 Generated using ONCVPSP code by D. R. Hamann @@ -680,7 +680,7 @@ weight = 2 0.12500000 PseudoPot. # 1 for Si read from file: - /home/elinscott/code/koopmans/pseudos/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf + /home/elinscott/code/koopmans/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf MD5 check sum: 7f029a58b69e3aa87b46a36c608bf45e Pseudo is Norm-conserving, Zval = 4.0 Generated using ONCVPSP code by D. R. Hamann @@ -1042,7 +1042,7 @@ weight = 3 0.12500000 PseudoPot. # 1 for Si read from file: - /home/elinscott/code/koopmans/pseudos/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf + /home/elinscott/code/koopmans/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf MD5 check sum: 7f029a58b69e3aa87b46a36c608bf45e Pseudo is Norm-conserving, Zval = 4.0 Generated using ONCVPSP code by D. R. Hamann @@ -1422,7 +1422,7 @@ weight = 4 0.12500000 PseudoPot. # 1 for Si read from file: - /home/elinscott/code/koopmans/pseudos/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf + /home/elinscott/code/koopmans/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf MD5 check sum: 7f029a58b69e3aa87b46a36c608bf45e Pseudo is Norm-conserving, Zval = 4.0 Generated using ONCVPSP code by D. R. Hamann @@ -1784,7 +1784,7 @@ weight = 5 0.12500000 PseudoPot. # 1 for Si read from file: - /home/elinscott/code/koopmans/pseudos/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf + /home/elinscott/code/koopmans/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf MD5 check sum: 7f029a58b69e3aa87b46a36c608bf45e Pseudo is Norm-conserving, Zval = 4.0 Generated using ONCVPSP code by D. R. Hamann @@ -2164,7 +2164,7 @@ weight = 6 0.12500000 PseudoPot. # 1 for Si read from file: - /home/elinscott/code/koopmans/pseudos/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf + /home/elinscott/code/koopmans/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf MD5 check sum: 7f029a58b69e3aa87b46a36c608bf45e Pseudo is Norm-conserving, Zval = 4.0 Generated using ONCVPSP code by D. R. Hamann @@ -2544,7 +2544,7 @@ weight = 7 0.12500000 PseudoPot. # 1 for Si read from file: - /home/elinscott/code/koopmans/pseudos/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf + /home/elinscott/code/koopmans/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf MD5 check sum: 7f029a58b69e3aa87b46a36c608bf45e Pseudo is Norm-conserving, Zval = 4.0 Generated using ONCVPSP code by D. R. Hamann diff --git a/tests/data/ph/eps.pho b/tests/data/ph/eps.pho index c5257bbe0..d9d351cc3 100644 --- a/tests/data/ph/eps.pho +++ b/tests/data/ph/eps.pho @@ -104,7 +104,7 @@ k( 6) = ( -0.5000000 -0.5000000 -0.7796610), wk = 0.2500000 PseudoPot. # 1 for Ti read from file: - /home/elinscott/code/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/Ti.upf + /home/elinscott/code/koopmans/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/Ti.upf MD5 check sum: c7cef475492d2ee3d0561e3a3e59fcd4 Pseudo is Norm-conserving + core correction, Zval = 12.0 Generated using ONCVPSP code by D. R. Hamann @@ -117,7 +117,7 @@ l(6) = 2 PseudoPot. # 2 for O read from file: - /home/elinscott/code/koopmans/pseudos/pseudo_dojo_standard_v0.4.1/pbesol/O.upf + /home/elinscott/code/koopmans/src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol/O.upf MD5 check sum: f226cbcd508cec715ff87a8f75a1dfba Pseudo is Norm-conserving + core correction, Zval = 6.0 Generated using ONCVPSP code by D. R. Hamann diff --git a/tests/data/pw/scf.pwi b/tests/data/pw/scf.pwi index c222b0d70..8bc3793b3 100644 --- a/tests/data/pw/scf.pwi +++ b/tests/data/pw/scf.pwi @@ -3,7 +3,7 @@ verbosity = 'high' outdir = '/home/elinscott/code/koopmans/tests/tmp/test_singlepoint_si_ki_dfpt_ex0/wannier/TMP/' prefix = 'kc' - pseudo_dir = '/home/elinscott/code/koopmans/pseudos/sg15_v1.2/pbe/' + pseudo_dir = '/home/elinscott/code/koopmans/src/koopmans/pseudopotentials/sg15_v1.2/pbe/' / &SYSTEM tot_charge = 0 diff --git a/tests/data/pw/scf.pwo b/tests/data/pw/scf.pwo index 51024fe5e..28b374a8e 100644 --- a/tests/data/pw/scf.pwo +++ b/tests/data/pw/scf.pwo @@ -72,7 +72,7 @@ Warning: card / ignored PseudoPot. # 1 for Si read from file: - /home/elinscott/code/koopmans/pseudos/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf + /home/elinscott/code/koopmans/src/koopmans/pseudopotentials/sg15_v1.2/pbe/Si_ONCV_PBE-1.2.upf MD5 check sum: 7f029a58b69e3aa87b46a36c608bf45e Pseudo is Norm-conserving, Zval = 4.0 Generated using ONCVPSP code by D. R. Hamann diff --git a/tests/data/qei_to_json/example.cpi b/tests/data/qei_to_json/example.cpi index 7cbe991d4..a9b745f42 100644 --- a/tests/data/qei_to_json/example.cpi +++ b/tests/data/qei_to_json/example.cpi @@ -6,7 +6,7 @@ outdir = 'TMP-CP/' prefix = 'kc' disk_io = 'high' - pseudo_dir = '../../../pseudos/sg15_v1.0/pbe/' + pseudo_dir = '../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe/' ndr = 99 ndw = 50 write_hr = .false. diff --git a/tests/data/qei_to_json/example.pwi b/tests/data/qei_to_json/example.pwi index b78adf0d8..0b6821081 100644 --- a/tests/data/qei_to_json/example.pwi +++ b/tests/data/qei_to_json/example.pwi @@ -2,7 +2,7 @@ calculation = 'scf' outdir = 'TMP/' prefix = 'kc' - pseudo_dir = '../../../pseudos/sg15_v1.2/pbe/' + pseudo_dir = '../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe/' / &SYSTEM ibrav = 2 diff --git a/tests/patches/_check.py b/tests/patches/_check.py index d3c5dc0e1..8976b4c5f 100644 --- a/tests/patches/_check.py +++ b/tests/patches/_check.py @@ -10,7 +10,7 @@ from ase.spectrum.band_structure import BandStructure from ase.spectrum.doscollection import GridDOSCollection -from koopmans import base_directory, utils +from koopmans import utils from koopmans.calculators import (Calc, EnvironCalculator, KoopmansCPCalculator, KoopmansHamCalculator, KoopmansScreenCalculator, PhCalculator, diff --git a/tests/patches/_mock.py b/tests/patches/_mock.py index 9d2bb462a..6d85e0bbc 100644 --- a/tests/patches/_mock.py +++ b/tests/patches/_mock.py @@ -62,7 +62,7 @@ def _calculate(self): if isinstance(ref_val, np.ndarray): ref_val = ref_val.tolist() - if val != ref_val: + if val != ref_val and key != 'pseudo_dir': raise ValueError(f'Error in {self.prefix}: {key} differs ({val} != {ref_val})') # Compare the atoms and the cell diff --git a/tests/patches/_utils.py b/tests/patches/_utils.py index 2f0134936..5ffa4e447 100644 --- a/tests/patches/_utils.py +++ b/tests/patches/_utils.py @@ -6,7 +6,7 @@ def benchmark_filename(calc: calculators.CalculatorExt) -> Path: - base_directory = Path(__path__).parents[2] + base_directory = Path(__file__).parents[2] benchmark_dir = base_directory / 'tests' / 'benchmarks' if base_directory / 'tests' / 'tmp' in calc.directory.parents: parent = base_directory / 'tests' / 'tmp' diff --git a/tests/tutorials/test_tutorial_1.py b/tests/tutorials/test_tutorial_1.py index d2bbda025..cfad7833e 100644 --- a/tests/tutorials/test_tutorial_1.py +++ b/tests/tutorials/test_tutorial_1.py @@ -1,9 +1,10 @@ +from pathlib import Path + import pytest -from pathlib import Path from koopmans.utils import chdir -tutorial_dir = Path(__path__[0]).parents[2] / 'tutorials' / 'tutorial_1' +tutorial_dir = Path(__file__).parents[2] / 'tutorials' / 'tutorial_1' @pytest.mark.tutorials diff --git a/tests/tutorials/test_tutorial_2.py b/tests/tutorials/test_tutorial_2.py index a9d04a992..f46c9a8bd 100644 --- a/tests/tutorials/test_tutorial_2.py +++ b/tests/tutorials/test_tutorial_2.py @@ -1,10 +1,11 @@ +from pathlib import Path + import pytest from koopmans.io import read from koopmans.utils import chdir -from pathlib import Path -tutorial_dir = Path(__path__[0]).parents[2] / 'tutorials' / 'tutorial_2' +tutorial_dir = Path(__file__).parents[2] / 'tutorials' / 'tutorial_2' @pytest.mark.tutorials diff --git a/tests/tutorials/test_tutorial_3.py b/tests/tutorials/test_tutorial_3.py index 79f86844f..426a352d8 100644 --- a/tests/tutorials/test_tutorial_3.py +++ b/tests/tutorials/test_tutorial_3.py @@ -1,12 +1,12 @@ import shutil +from pathlib import Path import pytest -from pathlib import Path from koopmans.io import read from koopmans.utils import chdir -tutorial_dir = Path(__path__[0]).parents[2] / 'tutorials' / 'tutorial_3' +tutorial_dir = Path(__file__).parents[2] / 'tutorials' / 'tutorial_3' @pytest.mark.tutorials diff --git a/tests/tutorials/test_tutorial_4.py b/tests/tutorials/test_tutorial_4.py index c94dc42a3..1c364a799 100644 --- a/tests/tutorials/test_tutorial_4.py +++ b/tests/tutorials/test_tutorial_4.py @@ -5,7 +5,7 @@ from koopmans.io import read from koopmans.utils import chdir -tutorial_dir = Path(__path__[0]).parents[2] / 'tutorials' / 'tutorial_4' +tutorial_dir = Path(__file__).parents[2] / 'tutorials' / 'tutorial_4' @pytest.mark.tutorials From 72b44829e4a5e9cdd8c2f30f7285f5465ae5614b Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 22:25:58 +0200 Subject: [PATCH 39/49] mypy compliance --- .../pseudopotentials/generate_wfc_psps.py | 20 ++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/src/koopmans/pseudopotentials/generate_wfc_psps.py b/src/koopmans/pseudopotentials/generate_wfc_psps.py index 337c56b57..9a29c74f3 100644 --- a/src/koopmans/pseudopotentials/generate_wfc_psps.py +++ b/src/koopmans/pseudopotentials/generate_wfc_psps.py @@ -3,9 +3,9 @@ Written by Edward Linscott, March 2022 ''' -from pathlib import Path import subprocess import xml.etree.ElementTree as ET +from pathlib import Path for fname in Path().rglob('*.upf'): try: @@ -15,11 +15,16 @@ # Do not touch files not generated by oncvpsp.x pp_info = pseudo.find('PP_INFO') - if 'ONCVPSP ' not in pp_info.text: + if pp_info is None: + raise ValueError(f'{fname} is missing a PP_INFO block') + if pp_info.text is None or 'ONCVPSP ' not in pp_info.text: continue # Do not touch files that have already got the appropriate fields - n_wfc = int(pseudo.find('PP_HEADER').get('number_of_wfc')) + pp_header = pseudo.find('PP_HEADER') + if pp_header is None: + raise ValueError(f'{fname} is missing a PP_HEADER block') + n_wfc = int(pp_header.get('number_of_wfc', 0)) if n_wfc > 0: continue @@ -32,11 +37,16 @@ print(f'Generating {new_fname}...', end='', flush=True) # Generate a oncvpsp.x input file + pp_inputfile = pp_info.find('PP_INPUTFILE') + if pp_inputfile is None: + raise ValueError(f'{fname} is missing a PP_INPUTFILE subblock') + if pp_inputfile.text is None: + raise ValueError(f'{fname} has an empty PP_INPUTFILE subblock') with open('tmp.in', 'w') as fd: - fd.write(pp_info.find('PP_INPUTFILE').text) + fd.write(pp_inputfile.text) # Work out the appropriate program - if pseudo.find('PP_HEADER').get('relativistic') == 'full': + if pp_header.get('relativistic') == 'full': prog = 'oncvpspr.x' else: prog = 'oncvpsp.x' From 9fb55db9767f007755d959d8167c8af2669f9a1f Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 22:40:51 +0200 Subject: [PATCH 40/49] Updated benchmarks to refer to new pseudo directory --- ...vergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin1.json | 6 +++--- ...vergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2.json | 6 +++--- ...ce_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2_dummy.json | 6 +++--- ...vergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin1.json | 6 +++--- ...vergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2.json | 6 +++--- ...ce_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2_dummy.json | 6 +++--- ...vergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin1.json | 6 +++--- ...vergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2.json | 6 +++--- ...ce_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2_dummy.json | 6 +++--- ...vergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin1.json | 6 +++--- ...vergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2.json | 6 +++--- ...ce_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2_dummy.json | 6 +++--- ...vergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin1.json | 6 +++--- ...vergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2.json | 6 +++--- ...ce_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2_dummy.json | 6 +++--- ...vergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin1.json | 6 +++--- ...vergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2.json | 6 +++--- ...ce_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2_dummy.json | 6 +++--- ...vergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin1.json | 6 +++--- ...vergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2.json | 6 +++--- ...ce_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2_dummy.json | 6 +++--- ...vergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin1.json | 6 +++--- ...vergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2.json | 6 +++--- ...ce_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2_dummy.json | 6 +++--- ...vergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin1.json | 6 +++--- ...vergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2.json | 6 +++--- ...ce_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2_dummy.json | 6 +++--- tests/benchmarks/test_dftbands_si0-dft_bands-bands.json | 2 +- tests/benchmarks/test_dftbands_si0-dft_bands-projwfc.json | 2 +- tests/benchmarks/test_dftbands_si0-dft_bands-scf.json | 2 +- tests/benchmarks/test_dftph_tio20-scf.json | 2 +- .../test_singlepoint_gaas_wan2odd0-final-ki_final.json | 6 +++--- .../test_singlepoint_gaas_wan2odd0-init-dft_dummy.json | 6 +++--- .../test_singlepoint_gaas_wan2odd0-init-dft_init.json | 6 +++--- .../test_singlepoint_gaas_wan2odd0-init-wannier-nscf.json | 6 +++--- .../test_singlepoint_gaas_wan2odd0-init-wannier-scf.json | 6 +++--- ...st_singlepoint_gaas_wan2odd0-postproc-wannier-bands.json | 6 +++--- ...est_singlepoint_gaas_wan2odd0-postproc-wannier-nscf.json | 6 +++--- ...test_singlepoint_gaas_wan2odd0-postproc-wannier-scf.json | 6 +++--- ...glepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-ki.json | 6 +++--- ...l_dscf0-ki-calc_alpha-iteration_1-orbital_4-dft_n-1.json | 6 +++--- ...l_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1.json | 6 +++--- ...0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json | 6 +++--- ..._dscf0-ki-calc_alpha-iteration_1-orbital_5-pz_print.json | 6 +++--- ...t_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1.json | 6 +++--- ...all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1_dummy.json | 6 +++--- ...t_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2.json | 6 +++--- ...all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2_dummy.json | 6 +++--- ...l_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1.json | 6 +++--- ...0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1_dummy.json | 6 +++--- ..._dscf0-ki-calc_alpha-iteration_2-orbital_5-pz_print.json | 6 +++--- .../test_singlepoint_h2o_all_dscf0-ki-final-ki_final.json | 6 +++--- ...t_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin1.json | 6 +++--- ...t_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2.json | 6 +++--- ...lepoint_h2o_all_dscf0-ki-init-dft_init_nspin2_dummy.json | 6 +++--- ...singlepoint_h2o_all_dscf0-ki-init-pz_innerloop_init.json | 6 +++--- ...oint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-kipz.json | 6 +++--- ...scf0-kipz-calc_alpha-iteration_1-orbital_4-kipz_n-1.json | 6 +++--- ...kipz-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json | 6 +++--- ...scf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_n+1.json | 6 +++--- ...f0-kipz-calc_alpha-iteration_1-orbital_5-kipz_print.json | 6 +++--- ...o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1.json | 6 +++--- ...dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1_dummy.json | 6 +++--- ...o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2.json | 6 +++--- ...dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2_dummy.json | 6 +++--- ...scf0-kipz-calc_alpha-iteration_2-orbital_4-kipz_n-1.json | 6 +++--- ...scf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_n+1.json | 6 +++--- ...f0-kipz-calc_alpha-iteration_2-orbital_5-kipz_print.json | 6 +++--- ...est_singlepoint_h2o_all_dscf0-kipz-final-kipz_final.json | 6 +++--- ...t_singlepoint_h2o_all_dscf0-pkipz-final-pkipz_final.json | 6 +++--- .../test_singlepoint_h2o_ki_dscf_e0-calc_alpha-ki.json | 6 +++--- ...lepoint_h2o_ki_dscf_e0-calc_alpha-orbital_4-dft_n-1.json | 6 +++--- ...lepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1.json | 6 +++--- ...t_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1_dummy.json | 6 +++--- ...epoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-pz_print.json | 6 +++--- .../test_singlepoint_h2o_ki_dscf_e0-final-ki_final.json | 6 +++--- ...est_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin1.json | 6 +++--- ...est_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2.json | 6 +++--- ...nglepoint_h2o_ki_dscf_e0-init-dft_init_nspin2_dummy.json | 6 +++--- ...t_singlepoint_h2o_ki_dscf_e0-init-pz_innerloop_init.json | 6 +++--- .../test_singlepoint_ozone_ki_dfpt0-init-dft.json | 2 +- ...test_singlepoint_si_ki_dfpt0-postproc-wannier-bands.json | 2 +- .../test_singlepoint_si_ki_dfpt0-postproc-wannier-nscf.json | 2 +- .../test_singlepoint_si_ki_dfpt0-postproc-wannier-scf.json | 2 +- .../test_singlepoint_si_ki_dfpt0-wannier-bands.json | 2 +- .../test_singlepoint_si_ki_dfpt0-wannier-nscf.json | 2 +- .../test_singlepoint_si_ki_dfpt0-wannier-scf.json | 2 +- ...t_singlepoint_si_ki_dfpt_ex0-postproc-wannier-bands.json | 2 +- ...st_singlepoint_si_ki_dfpt_ex0-postproc-wannier-nscf.json | 2 +- ...est_singlepoint_si_ki_dfpt_ex0-postproc-wannier-scf.json | 2 +- .../test_singlepoint_si_ki_dfpt_ex0-wannier-bands.json | 2 +- .../test_singlepoint_si_ki_dfpt_ex0-wannier-nscf.json | 2 +- .../test_singlepoint_si_ki_dfpt_ex0-wannier-scf.json | 2 +- .../test_singlepoint_si_ki_dscf_Fa0-calc_alpha-ki.json | 2 +- ...epoint_si_ki_dscf_Fa0-calc_alpha-orbital_32-dft_n-1.json | 2 +- ...epoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1.json | 2 +- ..._si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1_dummy.json | 2 +- ...point_si_ki_dscf_Fa0-calc_alpha-orbital_33-pz_print.json | 2 +- .../test_singlepoint_si_ki_dscf_Fa0-final-ki_final.json | 2 +- .../test_singlepoint_si_ki_dscf_Fa0-init-dft_dummy.json | 2 +- .../test_singlepoint_si_ki_dscf_Fa0-init-dft_init.json | 2 +- .../test_singlepoint_si_ki_dscf_Fa0-init-wannier-nscf.json | 2 +- .../test_singlepoint_si_ki_dscf_Fa0-init-wannier-scf.json | 2 +- ...st_singlepoint_si_ki_dscf_Fa0-postproc-pdos-projwfc.json | 2 +- ...t_singlepoint_si_ki_dscf_Fa0-postproc-wannier-bands.json | 2 +- ...st_singlepoint_si_ki_dscf_Fa0-postproc-wannier-nscf.json | 2 +- ...est_singlepoint_si_ki_dscf_Fa0-postproc-wannier-scf.json | 2 +- .../test_singlepoint_si_ki_dscf_Tr0-calc_alpha-ki.json | 2 +- ...si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_32-dft_n-1.json | 2 +- ...si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1.json | 2 +- ...dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1_dummy.json | 2 +- ...i_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-pz_print.json | 2 +- ...si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_32-dft_n-1.json | 2 +- ...si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1.json | 2 +- ...dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1_dummy.json | 2 +- ...i_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-pz_print.json | 2 +- .../test_singlepoint_si_ki_dscf_Tr0-final-ki_final.json | 2 +- .../test_singlepoint_si_ki_dscf_Tr0-init-dft_dummy.json | 2 +- .../test_singlepoint_si_ki_dscf_Tr0-init-dft_init.json | 2 +- .../test_singlepoint_si_ki_dscf_Tr0-init-wannier-nscf.json | 2 +- .../test_singlepoint_si_ki_dscf_Tr0-init-wannier-scf.json | 2 +- ...st_singlepoint_si_ki_dscf_Tr0-postproc-pdos-projwfc.json | 2 +- ...t_singlepoint_si_ki_dscf_Tr0-postproc-wannier-bands.json | 2 +- ...st_singlepoint_si_ki_dscf_Tr0-postproc-wannier-nscf.json | 2 +- ...est_singlepoint_si_ki_dscf_Tr0-postproc-wannier-scf.json | 2 +- tests/benchmarks/test_wannierize_tio20-pdos-projwfc.json | 2 +- tests/benchmarks/test_wannierize_tio20-wannier-bands.json | 2 +- tests/benchmarks/test_wannierize_tio20-wannier-nscf.json | 2 +- tests/benchmarks/test_wannierize_tio20-wannier-scf.json | 2 +- tests/benchmarks/tutorials-tutorial_1-calc_alpha-ki.json | 2 +- .../tutorials-tutorial_1-calc_alpha-orbital_1-dft_n-1.json | 2 +- .../tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1.json | 2 +- ...ials-tutorial_1-calc_alpha-orbital_10-dft_n+1_dummy.json | 2 +- ...tutorials-tutorial_1-calc_alpha-orbital_10-pz_print.json | 2 +- .../tutorials-tutorial_1-calc_alpha-orbital_2-dft_n-1.json | 2 +- .../tutorials-tutorial_1-calc_alpha-orbital_3-dft_n-1.json | 2 +- .../tutorials-tutorial_1-calc_alpha-orbital_4-dft_n-1.json | 2 +- .../tutorials-tutorial_1-calc_alpha-orbital_5-dft_n-1.json | 2 +- .../tutorials-tutorial_1-calc_alpha-orbital_6-dft_n-1.json | 2 +- .../tutorials-tutorial_1-calc_alpha-orbital_7-dft_n-1.json | 2 +- .../tutorials-tutorial_1-calc_alpha-orbital_8-dft_n-1.json | 2 +- .../tutorials-tutorial_1-calc_alpha-orbital_9-dft_n-1.json | 2 +- tests/benchmarks/tutorials-tutorial_1-final-ki_final.json | 2 +- .../tutorials-tutorial_1-init-dft_init_nspin1.json | 2 +- .../tutorials-tutorial_1-init-dft_init_nspin2.json | 2 +- .../tutorials-tutorial_1-init-dft_init_nspin2_dummy.json | 2 +- .../benchmarks/tutorials-tutorial_2-2x2x2-pdos-projwfc.json | 2 +- .../tutorials-tutorial_2-2x2x2-wannier-bands.json | 2 +- .../benchmarks/tutorials-tutorial_2-2x2x2-wannier-nscf.json | 2 +- .../benchmarks/tutorials-tutorial_2-2x2x2-wannier-scf.json | 2 +- .../benchmarks/tutorials-tutorial_2-4x4x4-pdos-projwfc.json | 2 +- .../tutorials-tutorial_2-4x4x4-wannier-bands.json | 2 +- .../benchmarks/tutorials-tutorial_2-4x4x4-wannier-nscf.json | 2 +- .../benchmarks/tutorials-tutorial_2-4x4x4-wannier-scf.json | 2 +- .../benchmarks/tutorials-tutorial_2-8x8x8-pdos-projwfc.json | 2 +- .../tutorials-tutorial_2-8x8x8-wannier-bands.json | 2 +- .../benchmarks/tutorials-tutorial_2-8x8x8-wannier-nscf.json | 2 +- .../benchmarks/tutorials-tutorial_2-8x8x8-wannier-scf.json | 2 +- tests/benchmarks/tutorials-tutorial_2-calc_alpha-ki.json | 2 +- .../tutorials-tutorial_2-calc_alpha-orbital_32-dft_n-1.json | 2 +- .../tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1.json | 2 +- ...ials-tutorial_2-calc_alpha-orbital_33-dft_n+1_dummy.json | 2 +- ...tutorials-tutorial_2-calc_alpha-orbital_33-pz_print.json | 2 +- tests/benchmarks/tutorials-tutorial_2-final-ki_final.json | 2 +- tests/benchmarks/tutorials-tutorial_2-init-dft_dummy.json | 2 +- tests/benchmarks/tutorials-tutorial_2-init-dft_init.json | 2 +- .../benchmarks/tutorials-tutorial_2-init-wannier-nscf.json | 2 +- tests/benchmarks/tutorials-tutorial_2-init-wannier-scf.json | 2 +- .../tutorials-tutorial_2-postproc-pdos-projwfc.json | 2 +- .../tutorials-tutorial_2-postproc-wannier-bands.json | 2 +- .../tutorials-tutorial_2-postproc-wannier-nscf.json | 2 +- .../tutorials-tutorial_2-postproc-wannier-scf.json | 2 +- .../benchmarks/tutorials-tutorial_3-dfpt-pdos-projwfc.json | 2 +- .../benchmarks/tutorials-tutorial_3-dfpt-wannier-bands.json | 2 +- .../benchmarks/tutorials-tutorial_3-dfpt-wannier-nscf.json | 2 +- tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-scf.json | 2 +- tests/benchmarks/tutorials-tutorial_3-dft_bands-bands.json | 2 +- .../benchmarks/tutorials-tutorial_3-dft_bands-projwfc.json | 2 +- tests/benchmarks/tutorials-tutorial_3-dft_bands-scf.json | 2 +- tests/benchmarks/tutorials-tutorial_3-pdos-projwfc.json | 2 +- tests/benchmarks/tutorials-tutorial_3-wannier-bands.json | 2 +- tests/benchmarks/tutorials-tutorial_3-wannier-nscf.json | 2 +- tests/benchmarks/tutorials-tutorial_3-wannier-scf.json | 2 +- ...tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d0-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d1-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d2-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d3-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d0-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d1-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d2-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d3-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d0-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d1-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d2-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d3-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d0-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d1-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d2-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d3-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d0-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d1-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d2-dft.json | 6 +++--- ...tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d3-dft.json | 6 +++--- 203 files changed, 395 insertions(+), 395 deletions(-) diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin1.json index 7f1b20368..496c6a5c4 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin1.json @@ -9,11 +9,11 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 98, "ndw": 98, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2.json index 4fc557b80..73a5c8514 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 99, "ndw": 51, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2_dummy.json index 84bc19b52..73cac1c9b 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d0-dft_nspin2_dummy.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 50, "ndw": 99, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin1.json index fc541c56c..76c581360 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin1.json @@ -9,11 +9,11 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 98, "ndw": 98, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2.json index 7112c84f9..7107ee4c6 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 99, "ndw": 51, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2_dummy.json index 7e16c299a..69ffcfe9e 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d1-dft_nspin2_dummy.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 50, "ndw": 99, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin1.json index 9c79f2fc1..c5ce101fe 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin1.json @@ -9,11 +9,11 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 98, "ndw": 98, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2.json index 50e091790..4e9f8c83c 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 99, "ndw": 51, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2_dummy.json index cff6cf11c..167c9e758 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_20d0-cell_size_1d2-dft_nspin2_dummy.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 80.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 50, "ndw": 99, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin1.json index 1ae7c3ecc..b6f13e9d9 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin1.json @@ -9,11 +9,11 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 98, "ndw": 98, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2.json index 7fbac8d13..e200cede3 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 99, "ndw": 51, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2_dummy.json index 7fae3985d..90aee200f 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d0-dft_nspin2_dummy.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 50, "ndw": 99, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin1.json index 3dc64c63f..dc631c1b8 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin1.json @@ -9,11 +9,11 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 98, "ndw": 98, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2.json index fa959580c..80c870290 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 99, "ndw": 51, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2_dummy.json index 10df58bb4..88bdca90c 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d1-dft_nspin2_dummy.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 50, "ndw": 99, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin1.json index e398c7fd0..e2bb1d6c9 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin1.json @@ -9,11 +9,11 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 98, "ndw": 98, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2.json index e36c10860..fc8bd9005 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 99, "ndw": 51, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2_dummy.json index 22a36ab68..bc07981c8 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_30d0-cell_size_1d2-dft_nspin2_dummy.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 120.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 50, "ndw": 99, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin1.json index bf87d982d..5518a48d1 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin1.json @@ -9,11 +9,11 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 98, "ndw": 98, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2.json index 103b784a3..4c169d22d 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 99, "ndw": 51, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2_dummy.json index ad8bf37b5..caccd14c6 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d0-dft_nspin2_dummy.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 50, "ndw": 99, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin1.json index f2317b74e..084da1062 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin1.json @@ -9,11 +9,11 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 98, "ndw": 98, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2.json index 0bfe37fdb..7138a1bf9 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 99, "ndw": 51, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2_dummy.json index d4469b600..a5bcfdd23 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d1-dft_nspin2_dummy.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 50, "ndw": 99, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin1.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin1.json index aafe3b39b..ae1bf2df2 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin1.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin1.json @@ -9,11 +9,11 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 98, "ndw": 98, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2.json index ccfaed96a..c4085d5af 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 99, "ndw": 51, diff --git a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2_dummy.json b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2_dummy.json index fc5f3ce44..f2ca23ae2 100644 --- a/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2_dummy.json +++ b/tests/benchmarks/test_convergence_h2o0-ecutwfc_40d0-cell_size_1d2-dft_nspin2_dummy.json @@ -11,11 +11,11 @@ "nbnd": 5, "ecutrho": 160.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndr": 50, "ndw": 99, diff --git a/tests/benchmarks/test_dftbands_si0-dft_bands-bands.json b/tests/benchmarks/test_dftbands_si0-dft_bands-bands.json index cad169370..187f02cc7 100644 --- a/tests/benchmarks/test_dftbands_si0-dft_bands-bands.json +++ b/tests/benchmarks/test_dftbands_si0-dft_bands-bands.json @@ -200,7 +200,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbesol" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_dftbands_si0-dft_bands-projwfc.json b/tests/benchmarks/test_dftbands_si0-dft_bands-projwfc.json index d677965bc..7332f77e9 100644 --- a/tests/benchmarks/test_dftbands_si0-dft_bands-projwfc.json +++ b/tests/benchmarks/test_dftbands_si0-dft_bands-projwfc.json @@ -22103,7 +22103,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbesol" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol" }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", diff --git a/tests/benchmarks/test_dftbands_si0-dft_bands-scf.json b/tests/benchmarks/test_dftbands_si0-dft_bands-scf.json index 7a8dca609..f970a07a7 100644 --- a/tests/benchmarks/test_dftbands_si0-dft_bands-scf.json +++ b/tests/benchmarks/test_dftbands_si0-dft_bands-scf.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbesol" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_dftph_tio20-scf.json b/tests/benchmarks/test_dftph_tio20-scf.json index 558361d73..08c64eb25 100644 --- a/tests/benchmarks/test_dftph_tio20-scf.json +++ b/tests/benchmarks/test_dftph_tio20-scf.json @@ -14,7 +14,7 @@ "Ti": "Ti.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/pbesol" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-final-ki_final.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-final-ki_final.json index a582971a8..41933f0f4 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-final-ki_final.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-final-ki_final.json @@ -14,11 +14,11 @@ "ecutwfc": 40.0, "nbnd": 104, "pseudopotentials": { - "As": "As_ONCV_PBE-1.0.upf", - "Ga": "Ga_ONCV_PBE-1.0.upf" + "Ga": "Ga_ONCV_PBE-1.0.upf", + "As": "As_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndw": 70, "ndr": 51, diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_dummy.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_dummy.json index 07beaf896..55f90e64c 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_dummy.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_dummy.json @@ -12,11 +12,11 @@ "neldw": 72, "ecutwfc": 40.0, "pseudopotentials": { - "As": "As_ONCV_PBE-1.0.upf", - "Ga": "Ga_ONCV_PBE-1.0.upf" + "Ga": "Ga_ONCV_PBE-1.0.upf", + "As": "As_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndw": 50, "ndr": 50, diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_init.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_init.json index b821fb7ac..23b9ff036 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_init.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-dft_init.json @@ -13,11 +13,11 @@ "ecutwfc": 40.0, "nbnd": 104, "pseudopotentials": { - "As": "As_ONCV_PBE-1.0.upf", - "Ga": "Ga_ONCV_PBE-1.0.upf" + "Ga": "Ga_ONCV_PBE-1.0.upf", + "As": "As_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndw": 51, "ndr": 50, diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-nscf.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-nscf.json index b699eb56c..4df089bcf 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-nscf.json @@ -17,11 +17,11 @@ 2 ], "pseudopotentials": { - "As": "As_ONCV_PBE-1.0.upf", - "Ga": "Ga_ONCV_PBE-1.0.upf" + "Ga": "Ga_ONCV_PBE-1.0.upf", + "As": "As_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-scf.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-scf.json index 4d1a0da86..907db25e3 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-init-wannier-scf.json @@ -13,11 +13,11 @@ 2 ], "pseudopotentials": { - "As": "As_ONCV_PBE-1.0.upf", - "Ga": "Ga_ONCV_PBE-1.0.upf" + "Ga": "Ga_ONCV_PBE-1.0.upf", + "As": "As_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-bands.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-bands.json index 79d51f19b..d9066affc 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-bands.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-bands.json @@ -342,11 +342,11 @@ "__ase_objtype__": "bandpath" }, "pseudopotentials": { - "As": "As_ONCV_PBE-1.0.upf", - "Ga": "Ga_ONCV_PBE-1.0.upf" + "Ga": "Ga_ONCV_PBE-1.0.upf", + "As": "As_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-nscf.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-nscf.json index 44443a392..75586215f 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-nscf.json @@ -17,11 +17,11 @@ 8 ], "pseudopotentials": { - "As": "As_ONCV_PBE-1.0.upf", - "Ga": "Ga_ONCV_PBE-1.0.upf" + "Ga": "Ga_ONCV_PBE-1.0.upf", + "As": "As_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-scf.json b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-scf.json index 4d1a0da86..907db25e3 100644 --- a/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_gaas_wan2odd0-postproc-wannier-scf.json @@ -13,11 +13,11 @@ 2 ], "pseudopotentials": { - "As": "As_ONCV_PBE-1.0.upf", - "Ga": "Ga_ONCV_PBE-1.0.upf" + "Ga": "Ga_ONCV_PBE-1.0.upf", + "As": "As_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-ki.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-ki.json index fa6063b9f..28a442fb2 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-ki.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-ki.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 60, "ndr": 51, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_4-dft_n-1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_4-dft_n-1.json index 90a9c6300..8d3cb09ed 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_4-dft_n-1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_4-dft_n-1.json @@ -12,11 +12,11 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1.json index f4f56831a..92d310aae 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1.json @@ -12,11 +12,11 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 68, "ndr": 65, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json index 4f1c32474..ec8b61170 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json @@ -12,11 +12,11 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 65, "ndr": 65, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-pz_print.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-pz_print.json index 8cb2ac76c..bed2fab9f 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-pz_print.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_1-orbital_5-pz_print.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 64, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1.json index b2b628fdd..f9f5194a8 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1.json @@ -11,11 +11,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 98, "ndr": 98, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1_dummy.json index 83fa600db..5ebd5bc53 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin1_dummy.json @@ -11,11 +11,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 98, "ndr": 98, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2.json index 16743e610..2c1e160cd 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 60, "ndr": 99, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2_dummy.json index ece776dd1..08c8b5bbc 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-ki_nspin2_dummy.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 99, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1.json index 821398165..3e4732b88 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1.json @@ -12,11 +12,11 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 68, "ndr": 65, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1_dummy.json index 2dfd0ec87..e3e0df92d 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-dft_n+1_dummy.json @@ -12,11 +12,11 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 65, "ndr": 65, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-pz_print.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-pz_print.json index 03a17d2f2..3133213f4 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-pz_print.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-calc_alpha-iteration_2-orbital_5-pz_print.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 64, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-final-ki_final.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-final-ki_final.json index 48ad3bd75..57d1faea8 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-final-ki_final.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-final-ki_final.json @@ -14,11 +14,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 70, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin1.json index 3eb2db0af..c43e01c0b 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin1.json @@ -11,11 +11,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 98, "ndr": 98, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2.json index a72bea173..05ed781ae 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 50, "ndr": 99, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2_dummy.json index 2138628ba..f84f3c76c 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-dft_init_nspin2_dummy.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 99, "ndr": 50, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-pz_innerloop_init.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-pz_innerloop_init.json index e41f33cf3..6041f478b 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-pz_innerloop_init.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-ki-init-pz_innerloop_init.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 51, "ndr": 50, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-kipz.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-kipz.json index 9391e9352..97de61468 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-kipz.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-kipz.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 60, "ndr": 51, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_4-kipz_n-1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_4-kipz_n-1.json index 5c2751da7..ce3c42fb4 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_4-kipz_n-1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_4-kipz_n-1.json @@ -12,11 +12,11 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json index f6e531165..fa0b56b9a 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-dft_n+1_dummy.json @@ -12,11 +12,11 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 65, "ndr": 65, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_n+1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_n+1.json index 48422a945..cb56e9e4f 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_n+1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_n+1.json @@ -12,11 +12,11 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 68, "ndr": 65, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_print.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_print.json index 1ab4957a7..7fbeb475e 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_print.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_1-orbital_5-kipz_print.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 64, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1.json index de30026e0..f6c281d58 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1.json @@ -11,11 +11,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 98, "ndr": 98, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1_dummy.json index f66354117..968545c92 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin1_dummy.json @@ -11,11 +11,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 98, "ndr": 98, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2.json index f4920b1fc..037b16be8 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 60, "ndr": 99, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2_dummy.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2_dummy.json index 95aafa281..e499bbc21 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-kipz_nspin2_dummy.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 99, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_4-kipz_n-1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_4-kipz_n-1.json index 1f3da6a69..9800ca549 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_4-kipz_n-1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_4-kipz_n-1.json @@ -12,11 +12,11 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_n+1.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_n+1.json index d9dca53a7..2f711db48 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_n+1.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_n+1.json @@ -12,11 +12,11 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 68, "ndr": 65, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_print.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_print.json index 9b26810b3..3bad7d070 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_print.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-calc_alpha-iteration_2-orbital_5-kipz_print.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 64, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-final-kipz_final.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-final-kipz_final.json index 3f9b0ae49..e8700ac27 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-final-kipz_final.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-kipz-final-kipz_final.json @@ -14,11 +14,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 70, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-pkipz-final-pkipz_final.json b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-pkipz-final-pkipz_final.json index f2b6197c8..f331f3617 100644 --- a/tests/benchmarks/test_singlepoint_h2o_all_dscf0-pkipz-final-pkipz_final.json +++ b/tests/benchmarks/test_singlepoint_h2o_all_dscf0-pkipz-final-pkipz_final.json @@ -14,11 +14,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 71, "ndr": 70, diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-ki.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-ki.json index 5169df12a..ccb4a4ef3 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-ki.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-ki.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 60, "ndr": 51, diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_4-dft_n-1.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_4-dft_n-1.json index 909bceb5b..ff5e4313f 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_4-dft_n-1.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_4-dft_n-1.json @@ -12,11 +12,11 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1.json index 1eba08563..8c8f1a9de 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1.json @@ -12,11 +12,11 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 68, "ndr": 65, diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1_dummy.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1_dummy.json index 0ab59e6f6..f24599de0 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-dft_n+1_dummy.json @@ -12,11 +12,11 @@ "neldw": 4, "ecutwfc": 20.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 65, "ndr": 65, diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-pz_print.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-pz_print.json index 4db6746de..4d74898d8 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-pz_print.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-calc_alpha-orbital_5-pz_print.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 64, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-final-ki_final.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-final-ki_final.json index 01749f3bf..334229c26 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-final-ki_final.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-final-ki_final.json @@ -14,11 +14,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 70, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin1.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin1.json index 7a817583f..3f6d4d858 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin1.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin1.json @@ -11,11 +11,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 98, "ndr": 98, diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2.json index 7bf043e24..968531ae2 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 50, "ndr": 99, diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2_dummy.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2_dummy.json index 8d3395693..30b3c003a 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2_dummy.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-dft_init_nspin2_dummy.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 99, "ndr": 50, diff --git a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-pz_innerloop_init.json b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-pz_innerloop_init.json index fdaf5bf1b..75ca62d5a 100644 --- a/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-pz_innerloop_init.json +++ b/tests/benchmarks/test_singlepoint_h2o_ki_dscf_e0-init-pz_innerloop_init.json @@ -13,11 +13,11 @@ "ecutwfc": 20.0, "nbnd": 5, "pseudopotentials": { - "H": "H_ONCV_PBE-1.2.upf", - "O": "O_ONCV_PBE-1.2.upf" + "O": "O_ONCV_PBE-1.2.upf", + "H": "H_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 51, "ndr": 50, diff --git a/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-init-dft.json b/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-init-dft.json index b6fd54c94..f1106498f 100644 --- a/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-init-dft.json +++ b/tests/benchmarks/test_singlepoint_ozone_ki_dfpt0-init-dft.json @@ -19,7 +19,7 @@ "O": "O_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-bands.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-bands.json index bc509e68e..1aa3dda72 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-bands.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-bands.json @@ -201,7 +201,7 @@ "Si": "Si_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-nscf.json index 7e84fed18..b72864d94 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-nscf.json @@ -20,7 +20,7 @@ "Si": "Si_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-scf.json index 842b43036..dfc776943 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-postproc-wannier-scf.json @@ -16,7 +16,7 @@ "Si": "Si_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-bands.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-bands.json index 135ecd372..981df2a3e 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-bands.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-bands.json @@ -202,7 +202,7 @@ "Si": "Si_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-nscf.json index a6f704ba6..ae85caccd 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-nscf.json @@ -21,7 +21,7 @@ "Si": "Si_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-scf.json index 16cb48ec6..9f5e1fdfc 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt0-wannier-scf.json @@ -17,7 +17,7 @@ "Si": "Si_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-bands.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-bands.json index bc509e68e..1aa3dda72 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-bands.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-bands.json @@ -201,7 +201,7 @@ "Si": "Si_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-nscf.json index 7e84fed18..b72864d94 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-nscf.json @@ -20,7 +20,7 @@ "Si": "Si_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-scf.json index 842b43036..dfc776943 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-postproc-wannier-scf.json @@ -16,7 +16,7 @@ "Si": "Si_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-bands.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-bands.json index 135ecd372..981df2a3e 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-bands.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-bands.json @@ -202,7 +202,7 @@ "Si": "Si_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-nscf.json index a6f704ba6..ae85caccd 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-nscf.json @@ -21,7 +21,7 @@ "Si": "Si_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-scf.json index 16cb48ec6..9f5e1fdfc 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dfpt_ex0-wannier-scf.json @@ -17,7 +17,7 @@ "Si": "Si_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-ki.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-ki.json index 04f8ac4de..a0fce917d 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-ki.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-ki.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 60, "ndr": 51, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_32-dft_n-1.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_32-dft_n-1.json index 20e4bd7da..b2ae42373 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_32-dft_n-1.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_32-dft_n-1.json @@ -15,7 +15,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1.json index 996f81cdc..931fad232 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1.json @@ -15,7 +15,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 68, "ndr": 65, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1_dummy.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1_dummy.json index 9aed2e264..c892857f1 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1_dummy.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-dft_n+1_dummy.json @@ -15,7 +15,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 65, "ndr": 65, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-pz_print.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-pz_print.json index 4b28ce1ff..122054752 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-pz_print.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-calc_alpha-orbital_33-pz_print.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 64, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-final-ki_final.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-final-ki_final.json index 2cd1bfd6a..bd088d59f 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-final-ki_final.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-final-ki_final.json @@ -17,7 +17,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 70, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_dummy.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_dummy.json index 418adc69b..654fcd3f6 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_dummy.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_dummy.json @@ -15,7 +15,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 50, "ndr": 50, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_init.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_init.json index 797b0c63b..ef459a215 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_init.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-dft_init.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 51, "ndr": 50, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-nscf.json index efc9c3e86..eb42fe605 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-nscf.json @@ -20,7 +20,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-scf.json index 72710d417..72c2ea026 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-init-wannier-scf.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-pdos-projwfc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-pdos-projwfc.json index 1f2687d41..642f0bbd1 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-pdos-projwfc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-pdos-projwfc.json @@ -21168,7 +21168,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-bands.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-bands.json index 0f9d9a7a6..4fc0102c6 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-bands.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-bands.json @@ -282,7 +282,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-nscf.json index ea4dfdb4b..6d8c0e7d2 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-nscf.json @@ -20,7 +20,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-scf.json index 72710d417..72c2ea026 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Fa0-postproc-wannier-scf.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-ki.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-ki.json index 4dd1f3637..3a1a3159b 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-ki.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-ki.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 60, "ndr": 51, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_32-dft_n-1.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_32-dft_n-1.json index 1f71f17af..45657e652 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_32-dft_n-1.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_32-dft_n-1.json @@ -15,7 +15,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1.json index c29cd11e0..0365c7338 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1.json @@ -15,7 +15,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 68, "ndr": 65, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1_dummy.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1_dummy.json index 1e3154d64..93e2b8d98 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1_dummy.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-dft_n+1_dummy.json @@ -15,7 +15,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 65, "ndr": 65, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-pz_print.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-pz_print.json index 714d1b11f..ea6dd5aca 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-pz_print.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_1-orbital_33-pz_print.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 64, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_32-dft_n-1.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_32-dft_n-1.json index a928bd5ae..14f241e74 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_32-dft_n-1.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_32-dft_n-1.json @@ -15,7 +15,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1.json index ae408fc2a..1ee5f2ddb 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1.json @@ -15,7 +15,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 68, "ndr": 65, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1_dummy.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1_dummy.json index ce33b67e5..c038b8b56 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1_dummy.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-dft_n+1_dummy.json @@ -15,7 +15,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 65, "ndr": 65, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-pz_print.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-pz_print.json index 72db0cef2..a2fb9aecb 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-pz_print.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-calc_alpha-spin_2-orbital_33-pz_print.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 64, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-final-ki_final.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-final-ki_final.json index 021885166..d3755718c 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-final-ki_final.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-final-ki_final.json @@ -17,7 +17,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 70, "ndr": 60, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_dummy.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_dummy.json index 418adc69b..654fcd3f6 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_dummy.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_dummy.json @@ -15,7 +15,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 50, "ndr": 50, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_init.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_init.json index bd132ba7a..f63187bf6 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_init.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-dft_init.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "ndw": 51, "ndr": 50, diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-nscf.json index e613b2863..db721d18a 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-nscf.json @@ -21,7 +21,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-scf.json index d392c64c8..2b6ddcc8b 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-init-wannier-scf.json @@ -17,7 +17,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-pdos-projwfc.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-pdos-projwfc.json index 578219feb..39593c8f7 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-pdos-projwfc.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-pdos-projwfc.json @@ -39896,7 +39896,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "spin_polarized": true, "__koopmans_name__": "BenchGenProjwfcCalculator", diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-bands.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-bands.json index 44cd311b8..345c069af 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-bands.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-bands.json @@ -283,7 +283,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-nscf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-nscf.json index 51b1be396..6beea9385 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-nscf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-nscf.json @@ -21,7 +21,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-scf.json b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-scf.json index d392c64c8..2b6ddcc8b 100644 --- a/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-scf.json +++ b/tests/benchmarks/test_singlepoint_si_ki_dscf_Tr0-postproc-wannier-scf.json @@ -17,7 +17,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_wannierize_tio20-pdos-projwfc.json b/tests/benchmarks/test_wannierize_tio20-pdos-projwfc.json index 722ac32bd..371d2b872 100644 --- a/tests/benchmarks/test_wannierize_tio20-pdos-projwfc.json +++ b/tests/benchmarks/test_wannierize_tio20-pdos-projwfc.json @@ -246873,7 +246873,7 @@ "Ti": "Ti.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-bands.json b/tests/benchmarks/test_wannierize_tio20-wannier-bands.json index c5922a230..b68ac87da 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-bands.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-bands.json @@ -175,7 +175,7 @@ "Ti": "Ti.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-nscf.json b/tests/benchmarks/test_wannierize_tio20-wannier-nscf.json index 4796e1eae..26fc312f7 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-nscf.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-nscf.json @@ -21,7 +21,7 @@ "Ti": "Ti.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/test_wannierize_tio20-wannier-scf.json b/tests/benchmarks/test_wannierize_tio20-wannier-scf.json index f3c231ffa..a2018e224 100644 --- a/tests/benchmarks/test_wannierize_tio20-wannier-scf.json +++ b/tests/benchmarks/test_wannierize_tio20-wannier-scf.json @@ -17,7 +17,7 @@ "Ti": "Ti.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/pbe" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-ki.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-ki.json index 592105bfd..92ef55292 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-ki.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-ki.json @@ -17,7 +17,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 60, "ndr": 51, diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_1-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_1-dft_n-1.json index 09ff92506..20f0b60a5 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_1-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_1-dft_n-1.json @@ -16,7 +16,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1.json index c582b78d1..09ed231a7 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1.json @@ -16,7 +16,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 68, "ndr": 65, diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1_dummy.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1_dummy.json index eea740c33..58905c7c0 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1_dummy.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-dft_n+1_dummy.json @@ -16,7 +16,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 65, "ndr": 65, diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-pz_print.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-pz_print.json index b3330feb8..b1927bd6e 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-pz_print.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_10-pz_print.json @@ -17,7 +17,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 64, "ndr": 60, diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_2-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_2-dft_n-1.json index 87beaf891..3acfc0f77 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_2-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_2-dft_n-1.json @@ -16,7 +16,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_3-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_3-dft_n-1.json index 66a594777..f75e39e4a 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_3-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_3-dft_n-1.json @@ -16,7 +16,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_4-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_4-dft_n-1.json index 82271c7b7..7d94d2740 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_4-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_4-dft_n-1.json @@ -16,7 +16,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_5-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_5-dft_n-1.json index acf8d6069..e7a27b5fa 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_5-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_5-dft_n-1.json @@ -16,7 +16,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_6-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_6-dft_n-1.json index 799af256c..cd9838289 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_6-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_6-dft_n-1.json @@ -16,7 +16,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_7-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_7-dft_n-1.json index ecd3888fe..5bfc4d605 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_7-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_7-dft_n-1.json @@ -16,7 +16,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_8-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_8-dft_n-1.json index 7f6f114ab..c1bd65368 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_8-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_8-dft_n-1.json @@ -16,7 +16,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_9-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_9-dft_n-1.json index 185a68a29..ccf573aed 100644 --- a/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_9-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_1-calc_alpha-orbital_9-dft_n-1.json @@ -16,7 +16,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/tutorials-tutorial_1-final-ki_final.json b/tests/benchmarks/tutorials-tutorial_1-final-ki_final.json index c0d770071..34d1f3168 100644 --- a/tests/benchmarks/tutorials-tutorial_1-final-ki_final.json +++ b/tests/benchmarks/tutorials-tutorial_1-final-ki_final.json @@ -18,7 +18,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 70, "ndr": 60, diff --git a/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin1.json b/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin1.json index 6635a5196..b464824c9 100644 --- a/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin1.json +++ b/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin1.json @@ -15,7 +15,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 98, "ndr": 98, diff --git a/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2.json b/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2.json index 5eec78ede..bca36827c 100644 --- a/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2.json +++ b/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2.json @@ -17,7 +17,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 50, "ndr": 99, diff --git a/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2_dummy.json b/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2_dummy.json index 63035a1e2..28a67778b 100644 --- a/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2_dummy.json +++ b/tests/benchmarks/tutorials-tutorial_1-init-dft_init_nspin2_dummy.json @@ -17,7 +17,7 @@ "O": "O_ONCV_PBE-1.2.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/sg15_v1.2/pbe" + "__path__": "../../../src/koopmans/pseudopotentials/sg15_v1.2/pbe" }, "ndw": 99, "ndr": 50, diff --git a/tests/benchmarks/tutorials-tutorial_2-2x2x2-pdos-projwfc.json b/tests/benchmarks/tutorials-tutorial_2-2x2x2-pdos-projwfc.json index 7bad63951..5896ffefa 100644 --- a/tests/benchmarks/tutorials-tutorial_2-2x2x2-pdos-projwfc.json +++ b/tests/benchmarks/tutorials-tutorial_2-2x2x2-pdos-projwfc.json @@ -34239,7 +34239,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", diff --git a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-bands.json b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-bands.json index 9a15f8d8e..e16994f0b 100644 --- a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-bands.json +++ b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-bands.json @@ -261,7 +261,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-nscf.json b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-nscf.json index 2c355f482..c2908a1b6 100644 --- a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-nscf.json +++ b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-nscf.json @@ -20,7 +20,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-scf.json b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-scf.json index f2bf79c29..1f80bdc34 100644 --- a/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-scf.json +++ b/tests/benchmarks/tutorials-tutorial_2-2x2x2-wannier-scf.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_2-4x4x4-pdos-projwfc.json b/tests/benchmarks/tutorials-tutorial_2-4x4x4-pdos-projwfc.json index c8d2902d0..61ecac1fa 100644 --- a/tests/benchmarks/tutorials-tutorial_2-4x4x4-pdos-projwfc.json +++ b/tests/benchmarks/tutorials-tutorial_2-4x4x4-pdos-projwfc.json @@ -34302,7 +34302,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", diff --git a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-bands.json b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-bands.json index 8bfed2ac6..d7d4832f7 100644 --- a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-bands.json +++ b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-bands.json @@ -261,7 +261,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-nscf.json b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-nscf.json index df1eb7438..ac29cf4c6 100644 --- a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-nscf.json +++ b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-nscf.json @@ -20,7 +20,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-scf.json b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-scf.json index 74cd49488..6bd755033 100644 --- a/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-scf.json +++ b/tests/benchmarks/tutorials-tutorial_2-4x4x4-wannier-scf.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_2-8x8x8-pdos-projwfc.json b/tests/benchmarks/tutorials-tutorial_2-8x8x8-pdos-projwfc.json index 7716d0989..b35b8e686 100644 --- a/tests/benchmarks/tutorials-tutorial_2-8x8x8-pdos-projwfc.json +++ b/tests/benchmarks/tutorials-tutorial_2-8x8x8-pdos-projwfc.json @@ -34311,7 +34311,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", diff --git a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-bands.json b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-bands.json index 018580977..59cb7fa08 100644 --- a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-bands.json +++ b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-bands.json @@ -261,7 +261,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-nscf.json b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-nscf.json index c5d8ff01a..5e2da84de 100644 --- a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-nscf.json +++ b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-nscf.json @@ -20,7 +20,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-scf.json b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-scf.json index d29bc63de..4e983ab22 100644 --- a/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-scf.json +++ b/tests/benchmarks/tutorials-tutorial_2-8x8x8-wannier-scf.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-ki.json b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-ki.json index 0a9f9d8a1..c61166d57 100644 --- a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-ki.json +++ b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-ki.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "ndw": 60, "ndr": 51, diff --git a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_32-dft_n-1.json b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_32-dft_n-1.json index 8f262259b..d92ce43a3 100644 --- a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_32-dft_n-1.json +++ b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_32-dft_n-1.json @@ -15,7 +15,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "ndw": 63, "ndr": 60, diff --git a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1.json b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1.json index cc7314bb9..7285d90e5 100644 --- a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1.json +++ b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1.json @@ -15,7 +15,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "ndw": 68, "ndr": 65, diff --git a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1_dummy.json b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1_dummy.json index e57a0ea4d..19ec23629 100644 --- a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1_dummy.json +++ b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-dft_n+1_dummy.json @@ -15,7 +15,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "ndw": 65, "ndr": 65, diff --git a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-pz_print.json b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-pz_print.json index b5c229319..757ecc7a6 100644 --- a/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-pz_print.json +++ b/tests/benchmarks/tutorials-tutorial_2-calc_alpha-orbital_33-pz_print.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "ndw": 64, "ndr": 60, diff --git a/tests/benchmarks/tutorials-tutorial_2-final-ki_final.json b/tests/benchmarks/tutorials-tutorial_2-final-ki_final.json index c92569cfc..c68bb0e06 100644 --- a/tests/benchmarks/tutorials-tutorial_2-final-ki_final.json +++ b/tests/benchmarks/tutorials-tutorial_2-final-ki_final.json @@ -17,7 +17,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "ndw": 70, "ndr": 60, diff --git a/tests/benchmarks/tutorials-tutorial_2-init-dft_dummy.json b/tests/benchmarks/tutorials-tutorial_2-init-dft_dummy.json index a98fba754..f7bfd4896 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-dft_dummy.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-dft_dummy.json @@ -15,7 +15,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "ndw": 50, "ndr": 50, diff --git a/tests/benchmarks/tutorials-tutorial_2-init-dft_init.json b/tests/benchmarks/tutorials-tutorial_2-init-dft_init.json index 12076a8e8..4ed17d045 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-dft_init.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-dft_init.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "ndw": 51, "ndr": 50, diff --git a/tests/benchmarks/tutorials-tutorial_2-init-wannier-nscf.json b/tests/benchmarks/tutorials-tutorial_2-init-wannier-nscf.json index 5340d1c0f..acfb954b1 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-wannier-nscf.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-wannier-nscf.json @@ -20,7 +20,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_2-init-wannier-scf.json b/tests/benchmarks/tutorials-tutorial_2-init-wannier-scf.json index 275969b6c..55fdf7838 100644 --- a/tests/benchmarks/tutorials-tutorial_2-init-wannier-scf.json +++ b/tests/benchmarks/tutorials-tutorial_2-init-wannier-scf.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-pdos-projwfc.json b/tests/benchmarks/tutorials-tutorial_2-postproc-pdos-projwfc.json index d6a8b140f..62fabd67b 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-pdos-projwfc.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-pdos-projwfc.json @@ -34239,7 +34239,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-bands.json b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-bands.json index 1dc8313eb..2e8b16009 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-bands.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-bands.json @@ -261,7 +261,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-nscf.json b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-nscf.json index e98158c0c..935e2e3f6 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-nscf.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-nscf.json @@ -20,7 +20,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-scf.json b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-scf.json index 275969b6c..55fdf7838 100644 --- a/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-scf.json +++ b/tests/benchmarks/tutorials-tutorial_2-postproc-wannier-scf.json @@ -16,7 +16,7 @@ "Si": "Si.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-pdos-projwfc.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-pdos-projwfc.json index 439cec311..bb2be9c79 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-pdos-projwfc.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-pdos-projwfc.json @@ -474870,7 +474870,7 @@ "Zn": "Zn.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-bands.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-bands.json index 365d221dc..a1605c8d5 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-bands.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-bands.json @@ -293,7 +293,7 @@ "Zn": "Zn.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-nscf.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-nscf.json index 616032050..5dc9540b9 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-nscf.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-nscf.json @@ -22,7 +22,7 @@ "Zn": "Zn.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-scf.json b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-scf.json index 3819156d8..aac1cd5e2 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-scf.json +++ b/tests/benchmarks/tutorials-tutorial_3-dfpt-wannier-scf.json @@ -18,7 +18,7 @@ "Zn": "Zn.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_3-dft_bands-bands.json b/tests/benchmarks/tutorials-tutorial_3-dft_bands-bands.json index 6db0e82dd..13a101da1 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dft_bands-bands.json +++ b/tests/benchmarks/tutorials-tutorial_3-dft_bands-bands.json @@ -291,7 +291,7 @@ "Zn": "Zn.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_3-dft_bands-projwfc.json b/tests/benchmarks/tutorials-tutorial_3-dft_bands-projwfc.json index adf6b6920..545cab898 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dft_bands-projwfc.json +++ b/tests/benchmarks/tutorials-tutorial_3-dft_bands-projwfc.json @@ -474869,7 +474869,7 @@ "Zn": "Zn.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", diff --git a/tests/benchmarks/tutorials-tutorial_3-dft_bands-scf.json b/tests/benchmarks/tutorials-tutorial_3-dft_bands-scf.json index 024882b58..825b60aa1 100644 --- a/tests/benchmarks/tutorials-tutorial_3-dft_bands-scf.json +++ b/tests/benchmarks/tutorials-tutorial_3-dft_bands-scf.json @@ -17,7 +17,7 @@ "Zn": "Zn.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_3-pdos-projwfc.json b/tests/benchmarks/tutorials-tutorial_3-pdos-projwfc.json index 00f111d24..fd39e82bb 100644 --- a/tests/benchmarks/tutorials-tutorial_3-pdos-projwfc.json +++ b/tests/benchmarks/tutorials-tutorial_3-pdos-projwfc.json @@ -474870,7 +474870,7 @@ "Zn": "Zn.upf" }, "pseudo_dir": { - "__path__": "../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "spin_polarized": false, "__koopmans_name__": "BenchGenProjwfcCalculator", diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-bands.json b/tests/benchmarks/tutorials-tutorial_3-wannier-bands.json index 466181fa7..8d983237a 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-bands.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-bands.json @@ -292,7 +292,7 @@ "Zn": "Zn.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-nscf.json b/tests/benchmarks/tutorials-tutorial_3-wannier-nscf.json index 798203ad9..70672c786 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-nscf.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-nscf.json @@ -21,7 +21,7 @@ "Zn": "Zn.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_3-wannier-scf.json b/tests/benchmarks/tutorials-tutorial_3-wannier-scf.json index add6a1752..e4a614aac 100644 --- a/tests/benchmarks/tutorials-tutorial_3-wannier-scf.json +++ b/tests/benchmarks/tutorials-tutorial_3-wannier-scf.json @@ -17,7 +17,7 @@ "Zn": "Zn.upf" }, "pseudo_dir": { - "__path__": "../../../pseudos/pseudo_dojo_standard_v0.4.1/lda" + "__path__": "../../../src/koopmans/pseudopotentials/pseudo_dojo_standard_v0.4.1/lda" }, "gamma_only": false, "koffset": [ diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d0-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d0-dft.json index f23477fc2..82ccb2ffe 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d0-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d0-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 20.0, "ecutrho": 80.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d1-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d1-dft.json index 2f8a62f40..c96ba6a1d 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d1-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d1-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 20.0, "ecutrho": 80.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d2-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d2-dft.json index 1a4203d90..a9d369b55 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d2-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d2-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 20.0, "ecutrho": 80.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d3-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d3-dft.json index 0c9870c1e..b7f99001f 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d3-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_20d0-cell_size_1d3-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 20.0, "ecutrho": 80.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d0-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d0-dft.json index 35fae9ad8..54267c08d 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d0-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d0-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 30.0, "ecutrho": 120.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d1-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d1-dft.json index 886cacdbc..7465533a2 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d1-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d1-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 30.0, "ecutrho": 120.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d2-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d2-dft.json index d2c7124df..b2ef11060 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d2-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d2-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 30.0, "ecutrho": 120.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d3-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d3-dft.json index 7bae89068..5ba9e3def 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d3-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_30d0-cell_size_1d3-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 30.0, "ecutrho": 120.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d0-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d0-dft.json index a5e68505a..48f392495 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d0-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d0-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 40.0, "ecutrho": 160.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d1-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d1-dft.json index 3905a072e..c1c7c991f 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d1-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d1-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 40.0, "ecutrho": 160.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d2-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d2-dft.json index 95cf10ec2..6e2324f25 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d2-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d2-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 40.0, "ecutrho": 160.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d3-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d3-dft.json index 949d3c5c1..c8c5d1c8e 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d3-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_40d0-cell_size_1d3-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 40.0, "ecutrho": 160.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d0-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d0-dft.json index 38f2c16c9..fdca78771 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d0-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d0-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 50.0, "ecutrho": 200.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d1-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d1-dft.json index a0aa0f997..5ed47f1c8 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d1-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d1-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 50.0, "ecutrho": 200.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d2-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d2-dft.json index c0dfecdce..b6ba307b1 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d2-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d2-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 50.0, "ecutrho": 200.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d3-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d3-dft.json index 7bbbc2973..45cebae86 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d3-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_50d0-cell_size_1d3-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 50.0, "ecutrho": 200.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d0-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d0-dft.json index 705226a9f..80e56d5d5 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d0-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d0-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 60.0, "ecutrho": 240.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d1-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d1-dft.json index 0be15233d..2f79e1280 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d1-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d1-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 60.0, "ecutrho": 240.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d2-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d2-dft.json index 8494431cb..1d57919d8 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d2-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d2-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 60.0, "ecutrho": 240.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, diff --git a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d3-dft.json b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d3-dft.json index 772789022..063274848 100644 --- a/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d3-dft.json +++ b/tests/benchmarks/tutorials-tutorial_4-ecutwfc_60d0-cell_size_1d3-dft.json @@ -10,11 +10,11 @@ "ecutwfc": 60.0, "ecutrho": 240.0, "pseudopotentials": { - "H": "H_ONCV_PBE-1.0.upf", - "O": "O_ONCV_PBE-1.0.upf" + "O": "O_ONCV_PBE-1.0.upf", + "H": "H_ONCV_PBE-1.0.upf" }, "pseudo_dir": { - "__path__": "../../../../pseudos/sg15_v1.0/pbe" + "__path__": "../../../../src/koopmans/pseudopotentials/sg15_v1.0/pbe" }, "ndr": 50, "ndw": 51, From e2a9c3b52e416c40306bcb3bf9b11c757c778ef6 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 23:11:01 +0200 Subject: [PATCH 41/49] Updated MANIFEST.in --- MANIFEST.in | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/MANIFEST.in b/MANIFEST.in index f64e0ebf8..e5e9d03e3 100644 --- a/MANIFEST.in +++ b/MANIFEST.in @@ -1,2 +1,2 @@ -include docs/refs.bib -graft pseudos/ +graft src/koopmans/pseudopotentials +include src/koopmans/references.bib From 52fd0d0f56cae9340b001209198081bfc80232e6 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Tue, 27 Sep 2022 23:14:04 +0200 Subject: [PATCH 42/49] Updated gitignore --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index b7319433a..28f598a3b 100644 --- a/.gitignore +++ b/.gitignore @@ -27,3 +27,5 @@ postproc/ wannier/ screening/ hamiltonian/ +build/ +dist/ From acba1c38fe40229d585d6f466f90f27cdcec58cd Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Wed, 28 Sep 2022 13:27:18 +0200 Subject: [PATCH 43/49] Replace pseudo soft links because pip does not package soft links --- src/koopmans/pseudopotentials/pseudo_dojo_standard | 1 - src/koopmans/pseudopotentials/pseudo_dojo_stringent | 1 - src/koopmans/pseudopotentials/sg15 | 1 - src/koopmans/pseudopotentials/sg15_relativistic | 1 - src/koopmans/settings/_workflow.py | 11 ++++++++--- tests/patches/_check.py | 8 +++++++- 6 files changed, 15 insertions(+), 8 deletions(-) delete mode 120000 src/koopmans/pseudopotentials/pseudo_dojo_standard delete mode 120000 src/koopmans/pseudopotentials/pseudo_dojo_stringent delete mode 120000 src/koopmans/pseudopotentials/sg15 delete mode 120000 src/koopmans/pseudopotentials/sg15_relativistic diff --git a/src/koopmans/pseudopotentials/pseudo_dojo_standard b/src/koopmans/pseudopotentials/pseudo_dojo_standard deleted file mode 120000 index 22f7d7f84..000000000 --- a/src/koopmans/pseudopotentials/pseudo_dojo_standard +++ /dev/null @@ -1 +0,0 @@ -pseudo_dojo_standard_v0.4.1 \ No newline at end of file diff --git a/src/koopmans/pseudopotentials/pseudo_dojo_stringent b/src/koopmans/pseudopotentials/pseudo_dojo_stringent deleted file mode 120000 index 709394283..000000000 --- a/src/koopmans/pseudopotentials/pseudo_dojo_stringent +++ /dev/null @@ -1 +0,0 @@ -pseudo_dojo_stringent_v0.4.1 \ No newline at end of file diff --git a/src/koopmans/pseudopotentials/sg15 b/src/koopmans/pseudopotentials/sg15 deleted file mode 120000 index 788494938..000000000 --- a/src/koopmans/pseudopotentials/sg15 +++ /dev/null @@ -1 +0,0 @@ -sg15_v1.2 \ No newline at end of file diff --git a/src/koopmans/pseudopotentials/sg15_relativistic b/src/koopmans/pseudopotentials/sg15_relativistic deleted file mode 120000 index 485318e67..000000000 --- a/src/koopmans/pseudopotentials/sg15_relativistic +++ /dev/null @@ -1 +0,0 @@ -sg15_relativistic_v1.0 \ No newline at end of file diff --git a/src/koopmans/settings/_workflow.py b/src/koopmans/settings/_workflow.py index 951617c4e..936bb27d8 100644 --- a/src/koopmans/settings/_workflow.py +++ b/src/koopmans/settings/_workflow.py @@ -148,8 +148,13 @@ def __setitem__(self, key: str, value: Any): # Make sure that pseudo libraries shortcuts (e.g. "sg15") are converted to the explicit version # (e.g. "sg15_v1.2") if key == 'pseudo_library': - full_path = pseudopotentials.pseudos_directory / value - if full_path.is_symlink(): - value = Path(os.path.realpath(full_path)).name + if value == 'sg15': + value = 'sg15_v1.2' + elif value == 'sg15_relativistic': + value = 'sg15_relativistic_v1.0' + elif value == 'pseudo_dojo_standard': + value = 'pseudo_dojo_standard_v0.4.1' + elif value == 'pseudo_dojo_stringent': + value = 'pseudo_dojo_stringent_v0.4.1' return super().__setitem__(key, value) diff --git a/tests/patches/_check.py b/tests/patches/_check.py index 8976b4c5f..ab3f1e2c9 100644 --- a/tests/patches/_check.py +++ b/tests/patches/_check.py @@ -10,7 +10,7 @@ from ase.spectrum.band_structure import BandStructure from ase.spectrum.doscollection import GridDOSCollection -from koopmans import utils +from koopmans import pseudopotentials, utils from koopmans.calculators import (Calc, EnvironCalculator, KoopmansCPCalculator, KoopmansHamCalculator, KoopmansScreenCalculator, PhCalculator, @@ -192,6 +192,12 @@ def _calculate(self): if isinstance(ref_val, np.ndarray): ref_val = ref_val.tolist() + if key == 'pseudo_dir': + # If using the central pseudo directory, only compare the relative paths + if pseudopotentials.pseudos_directory in val.parents: + val = Path('koopmans/pseudopotentials') / val.relative_to(pseudopotentials.pseudos_directory) + ref_val = Path(*ref_val.parts[-len(val.parts):]) + if val != ref_val: raise ValueError(f'Error in {self.prefix}: {key} differs ({val} != {ref_val})') From 2bfd0ac54ad675b8e23a12b5dd5765a6403eff42 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Wed, 28 Sep 2022 13:29:46 +0200 Subject: [PATCH 44/49] Corrected pseudo path of test_generate_dos --- tests/calculators/test_projwfc.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/calculators/test_projwfc.py b/tests/calculators/test_projwfc.py index e31cb44c0..94853421e 100644 --- a/tests/calculators/test_projwfc.py +++ b/tests/calculators/test_projwfc.py @@ -18,7 +18,7 @@ def test_generate_dos(silicon, tmp_path, datadir, pytestconfig): name='si', **silicon) calc = wf.new_calculator('projwfc') - calc.pseudo_dir = Path(koopmans_src[0]) / 'pseudopotentials/pseudo_dojo_standard/pbesol' + calc.pseudo_dir = Path(koopmans_src[0]) / 'pseudopotentials/pseudo_dojo_standard_v0.4.1/pbesol' # Copy over pdos files for f in (datadir / 'projwfc').glob('*.pdos*'): From fd6cf7e97c831972c720117b30b27b1547c11652 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Thu, 29 Sep 2022 12:56:31 +0200 Subject: [PATCH 45/49] Expand explanation of what make install does --- README.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.rst b/README.rst index 7a1ed5ab6..8efd10055 100644 --- a/README.rst +++ b/README.rst @@ -77,7 +77,7 @@ To add all of the Quantum ESPRESSO binaries to your path, run sudo make install -By default the binaries will be added to ``/usr/local/bin``. You can override this default by appending ``PREFIX=/path/to/bin/`` to the above command. +By default this will copy the Quantum ESPRESSO binaries to ``/usr/local/bin``. This requires sudo privileges. If you do not have sudo privileges, you can either (a) install the codes in a different location by running ``make install PREFIX=/path/to/bin/`` (in which case ``/path/to/bin/`` should be on your path) or (b) appending ``bin/`` from the current directory to your path. Installing the workflow manager """"""""""""""""""""""""""""""" From 94ef977da571191ec454a364f4e6aa6cde08a363 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Thu, 29 Sep 2022 13:01:55 +0200 Subject: [PATCH 46/49] Improving wording from previous commit --- README.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.rst b/README.rst index 8efd10055..d3187453b 100644 --- a/README.rst +++ b/README.rst @@ -77,7 +77,7 @@ To add all of the Quantum ESPRESSO binaries to your path, run sudo make install -By default this will copy the Quantum ESPRESSO binaries to ``/usr/local/bin``. This requires sudo privileges. If you do not have sudo privileges, you can either (a) install the codes in a different location by running ``make install PREFIX=/path/to/bin/`` (in which case ``/path/to/bin/`` should be on your path) or (b) appending ``bin/`` from the current directory to your path. +By default this will copy the Quantum ESPRESSO binaries to ``/usr/local/bin``. This requires sudo privileges. If you do not have sudo privileges, you can either (a) install the codes in a different location by running ``make install PREFIX=/path/to/bin/`` (substitute ``/path/to/bin/`` with any directory of your choosing that is on your path) or (b) appending ``bin/`` from the current directory to your path. Installing the workflow manager """"""""""""""""""""""""""""""" From e25d0a786e01b7b24545f4c39e8dae03c1adbb93 Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Thu, 29 Sep 2022 13:02:39 +0200 Subject: [PATCH 47/49] Further improving wording from previous commit --- README.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.rst b/README.rst index d3187453b..eab80743c 100644 --- a/README.rst +++ b/README.rst @@ -77,7 +77,7 @@ To add all of the Quantum ESPRESSO binaries to your path, run sudo make install -By default this will copy the Quantum ESPRESSO binaries to ``/usr/local/bin``. This requires sudo privileges. If you do not have sudo privileges, you can either (a) install the codes in a different location by running ``make install PREFIX=/path/to/bin/`` (substitute ``/path/to/bin/`` with any directory of your choosing that is on your path) or (b) appending ``bin/`` from the current directory to your path. +By default this will copy the Quantum ESPRESSO binaries to ``/usr/local/bin``. This requires sudo privileges. If you do not have sudo privileges, you can either (a) install the codes in a different location by running ``make install PREFIX=/path/to/bin/`` (substitute ``/path/to/bin/`` with any directory of your choosing that is on your path) or (b) append ``bin/`` from the current directory to your path. Installing the workflow manager """"""""""""""""""""""""""""""" From 2f43bce537035673c99a2a898946ca173170accb Mon Sep 17 00:00:00 2001 From: Edward Linscott Date: Thu, 29 Sep 2022 13:06:02 +0200 Subject: [PATCH 48/49] Minor bugfix replace __path__ with __file__ --- tests/patches/_check.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/patches/_check.py b/tests/patches/_check.py index ab3f1e2c9..cec837a45 100644 --- a/tests/patches/_check.py +++ b/tests/patches/_check.py @@ -122,7 +122,7 @@ class CheckCalc: @property def _calcname(self) -> Path: # type: ignore[attr-defined] - calcname: Path = (self.directory / self.prefix).relative_to(__path__ + '../../tests/tmp') + calcname: Path = (self.directory / self.prefix).relative_to(Path(__file__).parent + '../../tests/tmp') return calcname.relative_to(calcname.parts[0]) def _check_results(self, benchmark: Calc): From 011bd4a5f3588da03784d7f50d180fe661d7706e Mon Sep 17 00:00:00 2001 From: degennar Date: Thu, 29 Sep 2022 14:14:47 +0200 Subject: [PATCH 49/49] fixing absolute path in _chech.py --- tests/patches/_check.py | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/patches/_check.py b/tests/patches/_check.py index cec837a45..102599a7a 100644 --- a/tests/patches/_check.py +++ b/tests/patches/_check.py @@ -1,3 +1,4 @@ +from bdb import set_trace import itertools import json from abc import ABC, abstractmethod @@ -122,7 +123,7 @@ class CheckCalc: @property def _calcname(self) -> Path: # type: ignore[attr-defined] - calcname: Path = (self.directory / self.prefix).relative_to(Path(__file__).parent + '../../tests/tmp') + calcname: Path = (self.directory / self.prefix).relative_to((Path(__file__).parent / '../../tests/tmp').resolve()) return calcname.relative_to(calcname.parts[0]) def _check_results(self, benchmark: Calc):